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

import algebra.char_p.algebra
import group_theory.finiteness

import algebraic_geometry.EllipticCurve.torsion

-- Note: temporary
import algebraic_geometry.EllipticCurve.kummer

/-!
# The Mordell-Weil theorem for an elliptic curve over a number field
-/

noncomputable theory
open_locale classical

universe u

variables {F : Type u} [field F]
variables {E : EllipticCurve F}
variables {K : Type u} [field K] [algebra F K]

----------------------------------------------------------------------------------------------------

namespace EllipticCurve

open point

----------------------------------------------------------------------------------------------------
/-! ## Reduction lemma -/

section reduction

variables (n : ℕ)

/-- `nE(F)` is a subgroup of `ιₚ⁻¹(nE(K))`. -/
lemma range_le_comap_range : (E⟮F⟯⬝n) ≤ add_subgroup.comap ιₚ E⟮K⟯⬝n :=
by { rintro P ⟨Q, hQ⟩, rw [← hQ], exact ⟨ιₚ Q, (map_nsmul ιₚ Q n).symm⟩ }

/-- The kernel `Φ` of the cokernel map `E(F)/nE(F) → E(K)/nE(K)` induced by `ιₚ : E(F) ↪ E(K)`. -/
def Φ (E : EllipticCurve F) (K : Type u) [field K] [algebra F K] : add_subgroup E⟮F⟯/n :=
(quotient_add_group.map _ _ _ $ @range_le_comap_range _ _ _ K _ _ n).ker

/-- If `[P] ∈ Φ`, then `ιₚ(P) ∈ nE(K)`. -/
lemma Φ_mem_range (P : Φ n E K) : ιₚ (quot.out P.val) ∈ E⟮K⟯⬝n :=
begin
  cases P with P hP,
  change (quotient_add_group.lift _ ((quotient_add_group.mk' _).comp _) _) P = 0 at hP,
  rw [← quot.out_eq P, quotient_add_group.lift_quot_mk, add_monoid_hom.coe_comp,
      quotient_add_group.coe_mk', quotient_add_group.eq_zero_iff] at hP,
  exact hP
end

variables [finite_dimensional F K] [is_galois F K]

/-- The map `κ : Φ → H¹(Gal(K/F), E(K)[n])` induced by the inflation-restriction exact sequence. -/
def κ : Φ n E K → (K ≃ₐ[F] K) → E⟮K⟯[n] :=
λ P σ, ⟨σ • (Φ_mem_range n P).some - (Φ_mem_range n P).some,
begin
  change n • (σ • _ - _ : E⟮K⟯) = 0,
  rw [smul_sub, mul_by.map_smul],
  change σ • mul_by n _ - mul_by n _ = 0,
  rw [(Φ_mem_range n P).some_spec, sub_eq_zero],
  revert σ,
  change ιₚ (quot.out P.val) ∈ E⟮K⟯^F,
  rw [point_gal.fixed.eq],
  exact ⟨quot.out P.val, rfl⟩
end⟩

/-- `κ` is injective. -/
lemma κ.injective : function.injective $ @κ _ _ E K _ _ n _ _ :=
begin
  intros P₁_ P₂_ hP_,
  let P₁ := quot.out P₁_.val,
  let P₂ := quot.out P₂_.val,
  have hP₁ : ∃ Q₁ : E⟮K⟯, n • Q₁ = ιₚ P₁ := Φ_mem_range n P₁_,
  have hP₂ : ∃ Q₂ : E⟮K⟯, n • Q₂ = ιₚ P₂ := Φ_mem_range n P₂_,
  have hP : hP₁.some - hP₂.some ∈ (ιₚ : E⟮F⟯ →+ E⟮K⟯).range :=
  begin
    rw [← point_gal.fixed.eq],
    intro σ,
    rw [smul_sub, sub_eq_sub_iff_sub_eq_sub],
    injection (congr_fun hP_) σ
  end,
  cases hP with Q hQ,
  apply_fun ((•) n) at hQ,
  rw [smul_sub, hP₁.some_spec, hP₂.some_spec] at hQ,
  rw [← P₁_.eta P₁_.property, ← P₂_.eta P₂_.property, subtype.mk_eq_mk, ← quotient.out_equiv_out],
  change ∃ S : E⟮F⟯, n • S = -P₁ + P₂,
  existsi [-Q],
  apply_fun (ιₚ : E⟮F⟯ →+ E⟮K⟯) using point_hom.injective,
  rw [← neg_inj, ← map_neg, smul_neg, neg_neg, map_nsmul, ← map_neg, neg_add', neg_neg, map_sub],
  exact hQ
end

/-- If `E(K)/2E(K)` is finite, then `E(F)/2E(F)` is finite. -/
def coker_2_of_fg_extension.fintype [invertible (2 : F)] : fintype (E⟮K⟯/2) → fintype E⟮F⟯/2 :=
add_group.fintype_of_ker_codom $ fintype.of_injective (κ 2) (κ.injective 2)

end reduction

----------------------------------------------------------------------------------------------------
/-! ## Complete 2-descent -/

section complete_2_descent

-- Note: requires minimality of Weierstrass equation
/-- The primes of a number field dividing `n` or at which `E` has bad reduction. -/
lemma bad_primes [number_field K] (n : ℕ) : finset $ primes K :=
@set.to_finset _ {p : primes K | (p.valuation ((F↑K)E.disc_unit) ≠ 1) ∨ (p.valuation ((ℤ↑K)n) < 1)}
begin
  sorry
end

variables [number_field F] [number_field K] [algebra F⟮E[2]⟯ K] [is_scalar_tower F F⟮E[2]⟯ K]

notation K⟮E; n⟯² := K⟮@bad_primes _ _ E _ _ _ infer_instance n, n⟯²

/-- `2` is invertible in a number field. -/
instance number_field.invertible_two : invertible (2 : F) := invertible_of_nonzero two_ne_zero'

variables (ha₁ : E.a₁ = 0) (ha₃ : E.a₃ = 0)
variables {a b c : K} (h3 : (cubic.map (F↑K) $ ψ₂_x E F).roots = {a, b, c})

include ha₁ ha₃ h3

local notation n`⬝`K := (zpow_group_hom n : Kˣ →* Kˣ).range

/-- The complete 2-descent function `δ : E(K) → Kˣ/(Kˣ)² × Kˣ/(Kˣ)²`. -/
def δ.to_fun : E⟮K⟯ → (Kˣ ⧸ (2⬝K)) × (Kˣ ⧸ (2⬝K))
| 0            := 1
| (some x y w) :=
if ha : x = a then
  (units.mk0 ((a - c) * (a - b)⁻¹) $ mul_ne_zero (sub_ne_zero.mpr (ψ₂_x.roots_ne h3).2.1) $
    inv_ne_zero $ sub_ne_zero.mpr (ψ₂_x.roots_ne h3).1,
  units.mk0 (a - b) $ sub_ne_zero.mpr (ψ₂_x.roots_ne h3).1)
else if hb : x = b then
  (units.mk0 (b - a) $ sub_ne_zero.mpr (ψ₂_x.roots_ne h3).1.symm,
  units.mk0 ((b - c) * (b - a)⁻¹) $ mul_ne_zero (sub_ne_zero.mpr (ψ₂_x.roots_ne h3).2.2) $
    inv_ne_zero $ sub_ne_zero.mpr (ψ₂_x.roots_ne h3).1.symm)
else
  (units.mk0 (x - a) $ sub_ne_zero.mpr ha, units.mk0 (x - b) $ sub_ne_zero.mpr hb)

omit ha₁ ha₃ h3

-- Input: explicit computation
/-- The complete 2-descent homomorphism `δ : E(K) → Kˣ/(Kˣ)² × Kˣ/(Kˣ)²`. -/
def δ : E⟮K⟯ →+ additive ((Kˣ ⧸ (2⬝K)) × (Kˣ ⧸ (2⬝K))) :=
{ to_fun    := δ.to_fun ha₁ ha₃ h3,
  map_zero' := rfl,
  map_add'  := sorry }

@[simp] lemma δ.map_zero : δ ha₁ ha₃ h3 (0 : E⟮K⟯) = 0 := (δ ha₁ ha₃ h3).map_zero'

@[simp] lemma δ.map_add (P Q : E⟮K⟯) : δ ha₁ ha₃ h3 (P + Q) = δ ha₁ ha₃ h3 P + δ ha₁ ha₃ h3 Q :=
(δ ha₁ ha₃ h3).map_add' P Q

-- Input: constructive proof for `ker δ = 2E(K)`
lemma δ.ker : (δ ha₁ ha₃ h3).ker = E⟮K⟯⬝2 :=
begin
  ext P,
  split,
  { intro hP,
    cases P with x y w,
    { exact ⟨0, rfl⟩ },
    { change δ.to_fun ha₁ ha₃ h3 _ = 1 at hP,
      simp only [δ.to_fun] at hP,
      split_ifs at hP,
      { sorry },
      { sorry },
      { sorry } } },
  { rintro ⟨Q, hQ⟩,
    rw [← hQ],
    change δ ha₁ ha₃ h3 (2 • Q) = 0,
    rw [map_nsmul],
    change ((δ ha₁ ha₃ h3 Q).1 ^ 2, (δ ha₁ ha₃ h3 Q).2 ^ 2) = 1,
    apply prod.ext,
    all_goals { rw [← quotient_group.out_eq' (δ ha₁ ha₃ h3 Q).1,
                    ← quotient_group.out_eq' (δ ha₁ ha₃ h3 Q).2],
                exact (quotient_group.eq_one_iff _).mpr ⟨quot.out _, rfl⟩ } }
end

-- Input: local analysis for `im δ ≤ K(E; 2) × K(E; 2)`
lemma δ.range_le : (δ ha₁ ha₃ h3).range ≤ K⟮E; 2⟯² :=
begin
  sorry
end

/-- The lift `δ' : E(K)/2E(K) → K(E; 2) × K(E; 2)` of `δ`. -/
def δ.lift : (E⟮K⟯/2) →+ K⟮E; 2⟯² :=
(add_subgroup.inclusion $ δ.range_le ha₁ ha₃ h3).comp $
  (quotient_add_group.range_ker_lift $ δ ha₁ ha₃ h3).comp $
  (quotient_add_group.equiv_quotient_of_eq $ δ.ker ha₁ ha₃ h3).symm.to_add_monoid_hom

lemma δ.lift.injective : function.injective $ @δ.lift _ _ _ K _ _ _ _ _ _ ha₁ ha₃ _ _ _ h3 :=
begin
  apply function.injective.comp,
  { intros x y hxy,
    rw [← set_like.coe_eq_coe, add_subgroup.coe_inclusion, add_subgroup.coe_inclusion,
        set_like.coe_eq_coe] at hxy,
    exact hxy },
  simp only,
  apply function.injective.comp,
  { exact quotient_add_group.range_ker_lift_injective (δ ha₁ ha₃ h3) },
  simp only,
  { intros x y hxy,
    rw [add_equiv.coe_to_add_monoid_hom, add_equiv.apply_eq_iff_eq] at hxy,
    exact hxy }
end

end complete_2_descent

----------------------------------------------------------------------------------------------------
/-! ## The weak Mordell-Weil theorem -/

section weak_mordell_weil

variables [number_field F]

/-- A splitting field of a number field has characteristic zero. -/
instance : char_zero F⟮E[2]⟯ := char_zero_of_injective_algebra_map (F↑F⟮E[2]⟯).injective

/-- A splitting field of a number field is a number field. -/
instance : number_field F⟮E[2]⟯ :=
@number_field.mk _ _ _ $ @finite_dimensional.trans _ F _ _ _ _ _ _
  (@algebra.to_module _ _ _ _ $ @algebra_rat F⟮E[2]⟯ _ _) (by convert is_scalar_tower.rat) _ _

/-- A splitting field of a number field is Galois. -/
instance : is_galois F F⟮E[2]⟯ := ⟨⟩

/-- The weak Mordell-Weil theorem for `n = 2` assuming `E[2] ⊂ E(F)`: `E(F)/2E(F)` is finite. -/
instance coker_2_of_rat_E₂.fintype (ha₁ : E.a₁ = 0) (ha₃ : E.a₃ = 0) : fintype E⟮F⟮E[2]⟯⟯/2 :=
fintype.of_injective _ $ δ.lift.injective ha₁ ha₃
  ((cubic.splits_iff_roots_eq_three $ ψ₂_x.a_ne_zero E F).mp $ ψ₂_x.splits F⟮E[2]⟯)
    .some_spec.some_spec.some_spec

/-- The weak Mordell-Weil theorem for `n = 2`: `E(F)/2E(F)` is finite. -/
instance : fintype E⟮F⟯/2 :=
begin
  apply @coker_2_of_fg_extension.fintype _ _ E F⟮E[2]⟯,
  apply @fintype.of_equiv _ _ (@coker_2_of_rat_E₂.fintype _ _ E.covₘ _ (covₘ.a₁ E) (covₘ.a₃ E)),
  apply (quotient_add_group.quotient_equiv_of_equiv _ 2).to_equiv,
  rw [← ψ₂_x.eq_covₘ],
  apply covₘ.equiv_add
end

end weak_mordell_weil

----------------------------------------------------------------------------------------------------
/-! ## The Mordell-Weil theorem -/

section mordell_weil

variables [number_field F]

/-- The Mordell-Weil theorem: `E(F)` is finitely generated. -/
instance : add_group.fg E⟮F⟯ := sorry

end mordell_weil

----------------------------------------------------------------------------------------------------

end EllipticCurve


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit : sorry := sorry

/--`theorem`
Density of rational orbit
The fractional parts of the integer multiples of a rational number form a dense subset of the unit interval
`proof`
This is a corollary of the Density of irrational orbit.

Let $\alpha$ be a rational number. Then there exists $i, j \in \mathbb{Z}$ such that $\alpha=\frac{i}{j}$. Then
$$
\left\{\frac{i}{j} k\right\}=k\frac{i}{j}-\lfloor k\frac{i}{j} \rfloor=\frac{i}{j}-\frac{\lfloor k\frac{i}{j} \rfloor}{k}
$$
is an integer multiple of the irrational number $\alpha-\frac{\lfloor k\frac{i}{j} \rfloor}{k}$.

Hence, the set $S$ from the Density of irrational orbit contains all integer multiples of $\alpha-\frac{\lfloor k\frac{i}{j} \rfloor}{k}$, which implies that it contains all integer multiples of $\alpha$, and that it is dense in $[0,1]$.

QED
-/
theorem density_of_rational_orbit : sorry := sorry
end

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (ha : irrational α) :
∀ ε > 0, ∃ N : ℕ, ∀ n : ℕ, n ≥ N → ∃ m : ℤ, |((m : ℝ) * α) % 1 - ε| < ε :=
begin
  assume (ε : ℝ) (hε : ε > 0),

  -- Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$
  have h1 : ∀ (i j : ℤ), i ≠ j → ((i : ℝ) * α) % 1 ≠ ((j : ℝ) * α) % 1, from sorry,

  -- If this were not true, then
  have h2 : ((i : ℝ) * α) % 1 = ((j : ℝ) * α) % 1 → i = j, from sorry,

  -- Then
  have h3 : ((i : ℝ) * α) % 1 = ((j : ℝ) * α) % 1 → irrational α, from sorry,

  -- Hence,
  -- $S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}$ is an infinite subset of $\left[0,1\right]$.
  have h4 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h5 : ∀ (i j : ℤ), i ≠ j → ((i : ℝ) * α) % 1 ≠ ((j : ℝ) * α) % 1, from sorry,
  have h6 : ∀ (i : ℤ), ∃ (j : ℤ), ((j : ℝ) * α) % 1 ≠ ((i : ℝ) * α) % 1, from sorry,
  have h7 : ∀ (i : ℤ), ∃ (j : ℤ), ((j : ℝ) * α) % 1 ≠ ((i : ℝ) * α) % 1, from sorry,
  have h8 : ∀ (i : ℤ), ∃ (j : ℤ), ((j : ℝ) * α) % 1 ≠ ((i : ℝ) * α) % 1, from sorry,
  have h9 : ∃ (i : ℤ), ∃ (j : ℤ), ((j : ℝ) * α) % 1 ≠ ((i : ℝ) * α) % 1, from sorry,
  have h10 : set.Icc 0 1 ≠ ∅, from sorry,
  -- have h4 : ∃ (i : ℤ), ∃ (j : ℤ), ((j : ℝ) * α) % 1 ≠ ((i : ℝ) * α) % 1, from sorry,
  have h11 : ∞, from sorry,
  have h12 : ((j : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h13 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h14 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h15 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h16 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h17 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h18 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h19 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h20 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h21 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h22 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h23 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h24 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h25 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h26 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h27 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h28 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h29 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h30 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h31 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h32 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h33 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h34 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h35 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h36 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h37 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h38 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h39 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h40 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h41 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h42 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h43 : ∀ (i : ℤ), ((i : ℝ) * α) % 1 ∈ set.Icc 0 1, from sorry,
  have h44 : ∀ (i : ℤ), ((i : ℝ) * α) %
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_irrational_orbit (α : ℝ) :
  (∀ (i j : ℤ), i ≠ j → ¬(α * i - ⌊α * i⌋ = α * j - ⌊α * j⌋))
  → ∀ x : ℝ, x ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋)
  → ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ∧ abs (y - x) < ε
:=
begin
  --Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$.
  assume (h1 : ∀ (i j : ℤ), i ≠ j → ¬(α * i - ⌊α * i⌋ = α * j - ⌊α * j⌋)),
  assume (x : ℝ) (h2 : x ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋)),
  assume (ε : ℝ) (h3 : ε > 0),

  --$S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}$ is an infinite subset of $\left[0,1\right]$.
  have h4 : ∀ (i : ℤ), α * i - ⌊α * i⌋ ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋), from sorry,
  have h5 : set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ≠ ∅, from sorry,
  have h6 : set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ⊆ set.Icc 0 1, from sorry,

  --By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$.
  have h7 : ∀ (B : set ℝ), B ≠ ∅ → B ⊆ set.Icc 0 1 → ∃ (l : ℝ), l ∈ set.Icc 0 1 ∧ (∀ (ε : ℝ), ε > 0 → ∃ (x : ℝ), x ∈ B ∧ abs (l - x) < ε), from sorry,
  have h8 : ∃ (l : ℝ), l ∈ set.Icc 0 1 ∧ (∀ (ε : ℝ), ε > 0 → ∃ (x : ℝ), x ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ∧ abs (l - x) < ε), from sorry,

  --One can thus find pairs of elements of $S$ that are arbitrarily close.
  have h9 : ∀ (ε : ℝ), ε > 0 → ∃ (x y : ℝ), x ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ∧ y ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ∧ abs (x - y) < ε, from sorry,

  --Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.
  have h10 : ∀ (ε : ℝ), ε > 0 → ∃ (x : ℝ), x ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ∧ abs x < ε, from sorry,

  --To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$.
  show ∃ (y : ℝ), y ∈ set.range (λ (i : ℤ), α * i - ⌊α * i⌋) ∧ abs (y - x) < ε, from sorry,
end

--OUTPUT 4
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit_dense {α : Type*} [discrete_linear_ordered_field α] (α : α) (h ⊢ : ¬ is_rat α) :
  ∀ (ε : α) (ε_pos : 0 < ε) (y : α) (y_in : 0 ≤ y ∧ y < 1), ∃ x : α, x ∈ {n • α | n : ℤ} ∧ |y - x| < ε :=
begin
  assume ε (ε_pos : 0 < ε) y (y_in : 0 ≤ y ∧ y < 1),
  -- Let $\alpha$ be an irrational number.
  -- Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$.
  -- If this were not true, then
  have h1 : ∀ (i j : ℤ) (h_ne : i ≠ j), (i • α) - (i•α).to_int ≠ (j • α) - (j•α).to_int,
  from sorry,

  -- Then
  -- $$
  -- i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
  -- $$
  -- which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$.
  have h2 : ∀ (i j : ℤ) (h_ne : i ≠ j), (i • α) - (i•α).to_int = (j • α) - (j•α).to_int →
    (α = (i • α).to_int - (j • α).to_int) / (i - j) ∨ (α = (j • α).to_int - (i • α).to_int) / (j - i),
  from sorry,

  -- Hence,
  -- $$
  -- S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
  -- $$
  -- is an infinite subset of $\left[0,1\right]$.
  have h3 : {n • α | n : ℤ} ⊆ {x : α | 0 ≤ x ∧ x < 1}, from sorry,
  have h4 : ∃ x : α, x ∈ {n • α | n : ℤ}, from sorry,
  have h5 : {n • α | n : ℤ} ≠ ∅, from sorry,
  have h6 : {n • α | n : ℤ} ⊆ {x : α | 0 ≤ x ∧ x < 1}, from sorry,
  have h7 : ∀ (x : α), x ∈ {n • α | n : ℤ} → 0 ≤ x ∧ x < 1, from sorry,
  have h8 : ∃ (x : α), x ∈ {n • α | n : ℤ} ∧ 0 ≤ x ∧ x < 1, from sorry,
  have h9 : ∀ (x : α), x ∈ {n • α | n : ℤ} → x ≤ 1, from sorry,
  have h10 : ∃ (x : α), x ∈ {n • α | n : ℤ} ∧ x ≤ 1, from sorry,
  have h11 : {n • α | n : ℤ} ⊆ {x : α | x ≤ 1}, from sorry,
  have h12 : {n • α | n : ℤ} ⊆ ↑({n • α | n : ℤ} : set α), from sorry,
  have h13 : ↑({n • α | n : ℤ} : set α) ⊆ {x : α | 0 ≤ x ∧ x < 1}, from sorry,
  have h14 : ↑({n • α | n : ℤ} : set α) ≠ ∅, from sorry,
  have h15 : ↑({n • α | n : ℤ} : set α) ⊆ {x : α | 0 ≤ x ∧ x < 1}, from sorry,
  have h16 : ∀ (x : α), x ∈ ↑({n • α | n : ℤ} : set α) → 0 ≤ x ∧ x < 1, from sorry,
  have h17 : ∃ (x : α), x ∈ ↑({n • α | n : ℤ} : set α) ∧ 0 ≤ x ∧ x < 1, from sorry,
  have h18 : ∀ (x : α), x ∈ ↑({n • α | n : ℤ} : set α) → x ≤ 1, from sorry,
  have h19 : ∃ (x : α), x ∈ ↑({n • α | n : ℤ} : set α) ∧ x ≤ 1, from sorry,
  have h20 : ↑({n • α | n : ℤ} : set α) ⊆ {x : α | x ≤ 1}, from sorry,

  -- By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$.
  have h21 : ∃ (x : α), x ∈ ↑({n • α | n : ℤ} : set α) ∧ ∀ (ε : α) (ε_pos : 0 < ε), ∃ (N : ℤ), ∀ (n : ℤ), n > N → |x - (n•α)| < ε, from sorry,
  cases h21 with x h22,

  -- One can thus find pairs of elements of $S$ that are arbitrarily close.
  have h23 : ∀ (ε : α) (ε_pos : 0 < ε), ∃ (i j : ℤ) (h_ne : i ≠ j), |x - (i•α)| < ε ∧ |x - (j•α)| < ε, from sorry,
  cases h23 ε ε_pos with i h24,
  cases h24 with j h25,
  cases h25 with h_ne h26,
  cases h26 with h27 h28,

  -- Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.
  have h29 : ∀ (i j : ℤ) (h_ne : i ≠ j), |(i•α) - (j•α)| ∈ {n • α | n : ℤ}, from sorry,
  have h30 : ∀ (ε : α) (ε_pos : 0 < ε), ∃ (N : ℤ), ∀ (n : ℤ), n > N → |(0:α) - (n•α)| < ε, from sorry,

  -- To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$.
  have h31 : ∀ (y : α) (h_in : 0 ≤ y ∧ y < 1) (ε : α) (ε_pos : 0 < ε), ∃ (x : α), x ∈ {n • α | n : ℤ} ∧ |y - x| < ε, from sorry,

  -- Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.
  have h32 : ∀ (y : α) (h_in : 0 ≤ y ∧ y < 1) (ε : α) (ε_pos : 0 < ε), ∃ (x : α), x ∈ {n • α | n : ℤ} ∧ |y - x| < ε, from sorry,
  show ∃ (x : α), x ∈ {n • α | n : ℤ} ∧ |y - x| < ε, from sorry,
end

--OUTPUT 5
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (h1 : ¬ ∃ x : ℝ, α = x/x) :
∀ y ∈ Icc 0 1, ∃ x : ℝ, ∃ i : ℤ, y = x ∧ x = i * α :=
begin
  assume y h2,
  have h3 : ∀ i j : ℤ, i ≠ j → i * α ≠ j * α, from sorry,
  have h4 : ∀ i : ℤ, i * α ≠ 0, from sorry,
  have h5 : ∃ x : ℝ, ∃ i : ℤ, ∀ i : ℤ, x ≠ i * α, from sorry,
  have h6 : ∀ i : ℤ, ∃ x : ℝ, x ≠ i * α, from sorry,
  have h7 : ∃ N : ℕ, ∀ i : ℤ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h8 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h9 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h10 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h11 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h12 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h13 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h14 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h15 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h16 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h17 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h18 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h19 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h20 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h21 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h22 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h23 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h24 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h25 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h26 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h27 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h28 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h29 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h30 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h31 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h32 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h33 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h34 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h35 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h36 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h37 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h38 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h39 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h40 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h41 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h42 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h43 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h44 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h45 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h46 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N → ∃ x : ℝ, x ≠ i * α, from sorry,
  have h47 : ∃ N : ℕ, ∀ i : ℕ, i ≥ N →
end --Needs more than 2000 tokens!

--OUTPUT 6
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (hα : ¬ is_rat α) :
  ∃ (S : set ℝ), ∀ (x : ℝ), x ∈ S → 0 ≤ x ∧ x < 1 ∧ ∀ y : ℝ, 0 ≤ y ∧ y < 1 → ∃ (x : ℝ), x ∈ S ∧ |y - x| < 1 :=
begin
  -- Let $\alpha$ be an irrational number.
  assume α,
  assume hα : ¬ is_rat α,

  -- Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$.
  have h2 : ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α},
  from sorry,

  -- If this were not true, then
  -- $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$.
  have h3 : ∀ (i j : ℤ), i ≠ j → (α = (floor i α - floor j α) / (i - j) → (α ∈ ℚ)),
  from sorry,

  -- Hence,
  -- $S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}$
  -- is an infinite subset of $\left[0,1\right]$.
  have h4 : ∃ (S : set ℝ), ∀ (x : ℝ), x ∈ S → 0 ≤ x ∧ x < 1 ∧ ∀ (y : ℝ), y ∈ S → 0 ≤ y ∧ y < 1 ∧ ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α},
  from sorry,

  -- By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$.
  have h5 : ∃ (S : set ℝ), ∀ (x : ℝ), x ∈ S → 0 ≤ x ∧ x < 1 ∧ ∀ (y : ℝ), y ∈ S → 0 ≤ y ∧ y < 1 ∧ ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α} ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε,
  from sorry,

  -- One can thus find pairs of elements of $S$ that are arbitrarily close.
  have h6 : ∃ (S : set ℝ), ∀ (x : ℝ), x ∈ S → 0 ≤ x ∧ x < 1 ∧ ∀ (y : ℝ), y ∈ S → 0 ≤ y ∧ y < 1 ∧ ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α} ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε ∧ ∀ (x y : ℝ), x ∈ S ∧ y ∈ S → ∃ (ε : ℝ), ε > 0 ∧ |x - y| < ε,
  from sorry,

  -- Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.
  have h7 : ∃ (S : set ℝ), ∀ (x : ℝ), x ∈ S → 0 ≤ x ∧ x < 1 ∧ ∀ (y : ℝ), y ∈ S → 0 ≤ y ∧ y < 1 ∧ ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α} ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε ∧ ∀ (x y : ℝ), x ∈ S ∧ y ∈ S → ∃ (ε : ℝ), ε > 0 ∧ |x - y| < ε ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε,
  from sorry,

  -- To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$.
  have h8 : ∃ (S : set ℝ), ∀ (x : ℝ), x ∈ S → 0 ≤ x ∧ x < 1 ∧ ∀ (y : ℝ), y ∈ S → 0 ≤ y ∧ y < 1 ∧ ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α} ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε ∧ ∀ (x y : ℝ), x ∈ S ∧ y ∈ S → ∃ (ε : ℝ), ε > 0 ∧ |x - y| < ε ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε ∧ ∀ (y : ℝ), 0 ≤ y ∧ y < 1 → ∃ (x : ℝ), x ∈ S ∧ ∃ (ε : ℝ), ε > 0 ∧ |y - x| < ε,
  from sorry,

  -- Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.
  have h9 : ∃ (S : set ℝ), ∀ (x : ℝ), x ∈ S → 0 ≤ x ∧ x < 1 ∧ ∀ (y : ℝ), y ∈ S → 0 ≤ y ∧ y < 1 ∧ ∀ (i j : ℤ), i ≠ j → {i * α} ≠ {j * α} ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε ∧ ∀ (x y : ℝ), x ∈ S ∧ y ∈ S → ∃ (ε : ℝ), ε > 0 ∧ |x - y| < ε ∧ ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (y : ℝ), y ∈ S ∧ |x - y| < ε ∧ ∀ (y : ℝ), 0 ≤ y ∧ y < 1 → ∃ (x : ℝ), x ∈ S ∧ ∃ (ε : ℝ), ε > 0 ∧ |y - x| < ε ∧ ∀ (y : ℝ), 0 ≤ y ∧ y < 1 → ∃ (x : ℝ), x ∈ S ∧ ∀ (ε : ℝ), ε > 0 → ∃ (n : ℕ), |y - ({n * x} % 1) | < ε,
  from sorry,

  -- QED
  show ∃ (S : set
end --Needs more than 2000 tokens!

--OUTPUT 7
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit : ∀ (α : ℝ) (hα : ¬ is_rat α), ∀ y ∈ set.Icc 0 1, ∃ x ∈ set.Icc 0 1, ∃ N : ℤ,
∀ (ε : ℝ) (hε : ε > 0), |y - (N : ℝ) * x| < ε :=
begin
  assume α hα y h1,
  have h2 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h3 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h4 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h5 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h6 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h7 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h8 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h9 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h10 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,

  have h11 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h12 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h13 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h14 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h15 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h16 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h17 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h18 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h19 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h20 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h21 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h22 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h23 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h24 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h25 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h26 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h27 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h28 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h29 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h30 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h31 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h32 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h33 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h34 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h35 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h36 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h37 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h38 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h39 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h40 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h41 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h42 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h43 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h44 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h45 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h46 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h47 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h48 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h49 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h50 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h51 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h52 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h53 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h54 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
  have h55 : ∀ i j : ℤ, i ≠ j → {i * α} ≠ {j * α}, from sorry,
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_irrational_orbit {α : Type*} [decidable_linear_order α] (α : ℚ) : ∀ ε > 0, ∃ n : ℤ, |n*α - (n*α).floor| < ε :=
begin
  assume ε,
  assume h1 : ε > 0,
  have h2 : ∃ n : ℤ, |n*α - (n*α).floor| < ε, from sorry,
  show ∃ n : ℤ, |n*α - (n*α).floor| < ε, from sorry,
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from sorry,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from sorry,
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by sorry
  -- applying the above property further gives:
  ... = x*x + x*y + y*x + y*y : by sorry
  -- rearranging the terms using commutativity and adding gives:
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  -- Setting $b = a$, this becomes:
  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  --From Negative of Absolute Value: $\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$
  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from sorry,

  --Let $\epsilon > 0$.
  assume (h7 : ε > 0),

  --As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that $\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$
  cases h2 ε h7 with N1 h8,

  --As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that $\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$
  cases h3 ε h7 with N2 h9,

  --Let $N = \max \set {N_1, N_2}$.
  let N := max N1 N2,
  use N,

  --Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.
  have h10 : ∀ n > N, n > N1 ∧ n > N2 := sorry,

  --$\forall n > N: l - \epsilon < y_n < l + \epsilon$
  --$\forall n > N: l - \epsilon < z_n < l + \epsilon$
  --$\forall n \in \N: y_n \le x_n \le z_n$
  --So $\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$
  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from sorry,

  --$\forall n > N: l - \epsilon < x_n < l + \epsilon$
  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from sorry,

  --So $\forall n > N: \size {x_n - l} < \epsilon$
  --Hence the result
  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from sorry,
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem
FEW SHOT PROMPTS TO CODEX(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 category_theory.limits.shapes.terminal
import category_theory.limits.preserves.basic

/-!
# Preserving terminal object

Constructions to relate the notions of preserving terminal objects and reflecting terminal objects
to concrete objects.

In particular, we show that `terminal_comparison G` is an isomorphism iff `G` preserves terminal
objects.
-/

universes v v₁ v₂ u u₁ u₂

noncomputable theory

open category_theory category_theory.category category_theory.limits

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables (G : C ⥤ D)

namespace category_theory.limits

variables (X : C)

section terminal

/--
The map of an empty cone is a limit iff the mapped object is terminal.
-/
def is_limit_map_cone_empty_cone_equiv :
  is_limit (G.map_cone (as_empty_cone.{v₁} X)) ≃ is_terminal (G.obj X) :=
is_limit_empty_cone_equiv D _ _ (eq_to_iso rfl)

/-- The property of preserving terminal objects expressed in terms of `is_terminal`. -/
def is_terminal.is_terminal_obj [preserves_limit (functor.empty.{0} C) G]
  (l : is_terminal X) : is_terminal (G.obj X) :=
is_limit_map_cone_empty_cone_equiv G X (preserves_limit.preserves l)

/-- The property of reflecting terminal objects expressed in terms of `is_terminal`. -/
def is_terminal.is_terminal_of_obj [reflects_limit (functor.empty.{0} C) G]
  (l : is_terminal (G.obj X)) : is_terminal X :=
reflects_limit.reflects ((is_limit_map_cone_empty_cone_equiv G X).symm l)

variables [has_terminal C]
/--
If `G` preserves the terminal object and `C` has a terminal object, then the image of the terminal
object is terminal.
-/
def is_limit_of_has_terminal_of_preserves_limit [preserves_limit (functor.empty.{0} C) G] :
  is_terminal (G.obj (⊤_ C)) :=
terminal_is_terminal.is_terminal_obj G (⊤_ C)

/--
If `C` has a terminal object and `G` preserves terminal objects, then `D` has a terminal object
also.
Note this property is somewhat unique to (co)limits of the empty diagram: for general `J`, if `C`
has limits of shape `J` and `G` preserves them, then `D` does not necessarily have limits of shape
`J`.
-/
lemma has_terminal_of_has_terminal_of_preserves_limit [preserves_limit (functor.empty.{0} C) G] :
  has_terminal D :=
⟨λ F,
begin
  haveI := has_limit.mk ⟨_, is_limit_of_has_terminal_of_preserves_limit G⟩,
  apply has_limit_of_iso F.unique_from_empty.symm,
end⟩

variable [has_terminal D]
/--
If the terminal comparison map for `G` is an isomorphism, then `G` preserves terminal objects.
-/
def preserves_terminal.of_iso_comparison
  [i : is_iso (terminal_comparison G)] : preserves_limit (functor.empty C) G :=
begin
  apply preserves_limit_of_preserves_limit_cone terminal_is_terminal,
  apply (is_limit_map_cone_empty_cone_equiv _ _).symm _,
  apply is_limit.of_point_iso (limit.is_limit (functor.empty.{0} D)),
  apply i,
end

/-- If there is any isomorphism `G.obj ⊤ ⟶ ⊤`, then `G` preserves terminal objects. -/
def preserves_terminal_of_is_iso
  (f : G.obj (⊤_ C) ⟶ ⊤_ D) [i : is_iso f] : preserves_limit (functor.empty C) G :=
begin
  rw subsingleton.elim f (terminal_comparison G) at i,
  exactI preserves_terminal.of_iso_comparison G,
end

/-- If there is any isomorphism `G.obj ⊤ ≅ ⊤`, then `G` preserves terminal objects. -/
def preserves_terminal_of_iso
  (f : G.obj (⊤_ C) ≅ ⊤_ D) : preserves_limit (functor.empty C) G :=
preserves_terminal_of_is_iso G f.hom

variables [preserves_limit (functor.empty.{0} C) G]

/--
If `G` preserves terminal objects, then the terminal comparison map for `G` is an isomorphism.
-/
def preserves_terminal.iso : G.obj (⊤_ C) ≅ ⊤_ D :=
(is_limit_of_has_terminal_of_preserves_limit G).cone_point_unique_up_to_iso (limit.is_limit _)

@[simp]
lemma preserves_terminal.iso_hom : (preserves_terminal.iso G).hom = terminal_comparison G :=
rfl

instance : is_iso (terminal_comparison G) :=
begin
  rw ← preserves_terminal.iso_hom,
  apply_instance,
end

end terminal

section initial

/--
The map of an empty cocone is a colimit iff the mapped object is initial.
-/
def is_colimit_map_cocone_empty_cocone_equiv :
  is_colimit (G.map_cocone (as_empty_cocone.{v₁} X)) ≃ is_initial (G.obj X) :=
is_colimit_empty_cocone_equiv D _ _ (eq_to_iso rfl)

/-- The property of preserving initial objects expressed in terms of `is_initial`. -/
def is_initial.is_initial_obj [preserves_colimit (functor.empty.{0} C) G]
  (l : is_initial X) : is_initial (G.obj X) :=
is_colimit_map_cocone_empty_cocone_equiv G X (preserves_colimit.preserves l)

/-- The property of reflecting initial objects expressed in terms of `is_initial`. -/
def is_initial.is_initial_of_obj [reflects_colimit (functor.empty.{0} C) G]
  (l : is_initial (G.obj X)) : is_initial X :=
reflects_colimit.reflects ((is_colimit_map_cocone_empty_cocone_equiv G X).symm l)

variables [has_initial C]
/--
If `G` preserves the initial object and `C` has a initial object, then the image of the initial
object is initial.
-/
def is_colimit_of_has_initial_of_preserves_colimit [preserves_colimit (functor.empty.{0} C) G] :
  is_initial (G.obj (⊥_ C)) :=
initial_is_initial.is_initial_obj G (⊥_ C)

/--
If `C` has a initial object and `G` preserves initial objects, then `D` has a initial object
also.
Note this property is somewhat unique to colimits of the empty diagram: for general `J`, if `C`
has colimits of shape `J` and `G` preserves them, then `D` does not necessarily have colimits of
shape `J`.
-/
lemma has_initial_of_has_initial_of_preserves_colimit [preserves_colimit (functor.empty.{0} C) G] :
  has_initial D :=
⟨λ F,
begin
  haveI := has_colimit.mk ⟨_, is_colimit_of_has_initial_of_preserves_colimit G⟩,
  apply has_colimit_of_iso F.unique_from_empty,
end⟩

variable [has_initial D]
/--
If the initial comparison map for `G` is an isomorphism, then `G` preserves initial objects.
-/
def preserves_initial.of_iso_comparison
  [i : is_iso (initial_comparison G)] : preserves_colimit (functor.empty C) G :=
begin
  apply preserves_colimit_of_preserves_colimit_cocone initial_is_initial,
  apply (is_colimit_map_cocone_empty_cocone_equiv _ _).symm _,
  apply is_colimit.of_point_iso (colimit.is_colimit (functor.empty.{0} D)),
  apply i,
end

/-- If there is any isomorphism `⊥ ⟶ G.obj ⊥`, then `G` preserves initial objects. -/
def preserves_initial_of_is_iso
  (f : ⊥_ D ⟶ G.obj (⊥_ C)) [i : is_iso f] : preserves_colimit (functor.empty C) G :=
begin
  rw subsingleton.elim f (initial_comparison G) at i,
  exactI preserves_initial.of_iso_comparison G,
end

/-- If there is any isomorphism `⊥ ≅ G.obj ⊥ `, then `G` preserves initial objects. -/
def preserves_initial_of_iso
  (f : ⊥_ D ≅ G.obj (⊥_ C)) : preserves_colimit (functor.empty C) G :=
preserves_initial_of_is_iso G f.hom

variables [preserves_colimit (functor.empty.{0} C) G]

/-- If `G` preserves initial objects, then the initial comparison map for `G` is an isomorphism. -/
def preserves_initial.iso : G.obj (⊥_ C) ≅ ⊥_ D :=
(is_colimit_of_has_initial_of_preserves_colimit G).cocone_point_unique_up_to_iso
  (colimit.is_colimit _)

@[simp]
lemma preserves_initial.iso_hom : (preserves_initial.iso G).inv = initial_comparison G :=
rfl

instance : is_iso (initial_comparison G) :=
begin
  rw ← preserves_initial.iso_hom,
  apply_instance,
end

end initial

end category_theory.limits


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import data.set.finite
import order.well_founded
import order.order_iso_nat
import algebra.pointwise

/-!
# Well-founded sets

A well-founded subset of an ordered type is one on which the relation `<` is well-founded.

## Main Definitions
 * `set.well_founded_on s r` indicates that the relation `r` is
  well-founded when restricted to the set `s`.
 * `set.is_wf s` indicates that `<` is well-founded when restricted to `s`.
 * `set.partially_well_ordered_on s r` indicates that the relation `r` is
  partially well-ordered (also known as well quasi-ordered) when restricted to the set `s`.
 * `set.is_pwo s` indicates that any infinite sequence of elements in `s`
  contains an infinite monotone subsequence. Note that

### Definitions for Hahn Series
 * `set.add_antidiagonal s t a` and `set.mul_antidiagonal s t a` are the sets of pairs of elements
  from `s` and `t` that add/multiply to `a`.
 * `finset.add_antidiagonal` and `finset.mul_antidiagonal` are finite versions of
  `set.add_antidiagonal` and `set.mul_antidiagonal` defined when `s` and `t` are well-founded.

## Main Results
 * Higman's Lemma, `set.partially_well_ordered_on.partially_well_ordered_on_sublist_forall₂`,
  shows that if `r` is partially well-ordered on `s`, then `list.sublist_forall₂` is partially
  well-ordered on the set of lists of elements of `s`. The result was originally published by
  Higman, but this proof more closely follows Nash-Williams.
 * `set.well_founded_on_iff` relates `well_founded_on` to the well-foundedness of a relation on the
 original type, to avoid dealing with subtypes.
 * `set.is_wf.mono` shows that a subset of a well-founded subset is well-founded.
 * `set.is_wf.union` shows that the union of two well-founded subsets is well-founded.
 * `finset.is_wf` shows that all `finset`s are well-founded.

## References
 * [Higman, *Ordering by Divisibility in Abstract Algebras*][Higman52]
 * [Nash-Williams, *On Well-Quasi-Ordering Finite Trees*][Nash-Williams63]
-/

open_locale pointwise

variables {α : Type*}

namespace set

/-- `s.well_founded_on r` indicates that the relation `r` is well-founded when restricted to `s`. -/
def well_founded_on (s : set α) (r : α → α → Prop) : Prop :=
well_founded (λ (a : s) (b : s), r a b)

lemma well_founded_on_iff {s : set α} {r : α → α → Prop} :
  s.well_founded_on r ↔ well_founded (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
begin
  have f : rel_embedding (λ (a : s) (b : s), r a b) (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
    ⟨⟨coe, subtype.coe_injective⟩, λ a b, by simp⟩,
  refine ⟨λ h, _, f.well_founded⟩,
  rw well_founded.well_founded_iff_has_min,
  intros t ht,
  by_cases hst : (s ∩ t).nonempty,
  { rw ← subtype.preimage_coe_nonempty at hst,
    rcases well_founded.well_founded_iff_has_min.1 h (coe ⁻¹' t) hst with ⟨⟨m, ms⟩, mt, hm⟩,
    exact ⟨m, mt, λ x xt ⟨xm, xs, ms⟩, hm ⟨x, xs⟩ xt xm⟩ },
  { rcases ht with ⟨m, mt⟩,
    exact ⟨m, mt, λ x xt ⟨xm, xs, ms⟩, hst ⟨m, ⟨ms, mt⟩⟩⟩ }
end

lemma well_founded_on.induction {s : set α} {r : α → α → Prop} (hs : s.well_founded_on r) {x : α}
  (hx : x ∈ s) {P : α → Prop} (hP : ∀ (y ∈ s), (∀ (z ∈ s), r z y → P z) → P y) :
  P x :=
begin
  let Q : s → Prop := λ y, P y,
  change Q ⟨x, hx⟩,
  refine well_founded.induction hs ⟨x, hx⟩ _,
  rintros ⟨y, ys⟩ ih,
  exact hP _ ys (λ z zs zy, ih ⟨z, zs⟩ zy),
end

instance is_strict_order.subset {s : set α} {r : α → α → Prop} [is_strict_order α r] :
  is_strict_order α (λ (a b : α), r a b ∧ a ∈ s ∧ b ∈ s) :=
{ to_is_irrefl := ⟨λ a con, irrefl_of r a con.1 ⟩,
  to_is_trans := ⟨λ a b c ab bc, ⟨trans_of r ab.1 bc.1, ab.2.1, bc.2.2⟩ ⟩ }

theorem well_founded_on_iff_no_descending_seq {s : set α} {r : α → α → Prop} [is_strict_order α r] :
  s.well_founded_on r ↔ ∀ (f : ((>) : ℕ → ℕ → Prop) ↪r r), ¬ (range f) ⊆ s :=
begin
  rw [well_founded_on_iff, rel_embedding.well_founded_iff_no_descending_seq],
  refine ⟨λ h f con, begin
      refine h.elim' ⟨⟨f, f.injective⟩, λ a b, _⟩,
       simp only [con (mem_range_self a), con (mem_range_self b), and_true, gt_iff_lt,
        function.embedding.coe_fn_mk, f.map_rel_iff]
    end, λ h, ⟨λ con, _⟩⟩,
  rcases con with ⟨f, hf⟩,
  have hfs' : ∀ n : ℕ, f n ∈ s := λ n, (hf.2 n.lt_succ_self).2.2,
  refine h ⟨f, λ a b, _⟩ (λ n hn, _),
  { rw ← hf,
    exact ⟨λ h, ⟨h, hfs' _, hfs' _⟩, λ h, h.1⟩ },
  { rcases set.mem_range.1 hn with ⟨m, hm⟩,
    rw ← hm,
    apply hfs' }
end

section has_lt
variables [has_lt α]

/-- `s.is_wf` indicates that `<` is well-founded when restricted to `s`. -/
def is_wf (s : set α) : Prop := well_founded_on s (<)

lemma is_wf_univ_iff : is_wf (univ : set α) ↔ well_founded ((<) : α → α → Prop) :=
by simp [is_wf, well_founded_on_iff]

variables {s t : set α}

theorem is_wf.mono (h : is_wf t) (st : s ⊆ t) : is_wf s :=
begin
  rw [is_wf, well_founded_on_iff] at *,
  refine subrelation.wf (λ x y xy, _) h,
  exact ⟨xy.1, st xy.2.1, st xy.2.2⟩,
end
end has_lt

section partial_order
variables [partial_order α] {s t : set α} {a : α}

theorem is_wf_iff_no_descending_seq :
  is_wf s ↔ ∀ (f : (order_dual ℕ) ↪o α), ¬ (range f) ⊆ s :=
begin
  haveI : is_strict_order α (λ (a b : α), a < b ∧ a ∈ s ∧ b ∈ s) :=
  { to_is_irrefl := ⟨λ x con, lt_irrefl x con.1⟩,
    to_is_trans := ⟨λ a b c ab bc, ⟨lt_trans ab.1 bc.1, ab.2.1, bc.2.2⟩⟩, },
  rw [is_wf, well_founded_on_iff_no_descending_seq],
  exact ⟨λ h f, h f.lt_embedding, λ h f, h (order_embedding.of_strict_mono
    f (λ _ _, f.map_rel_iff.2))⟩,
end

theorem is_wf.union (hs : is_wf s) (ht : is_wf t) : is_wf (s ∪ t) :=
begin
  classical,
  rw [is_wf_iff_no_descending_seq] at *,
  rintros f fst,
  have h : infinite (f ⁻¹' s) ∨ infinite (f ⁻¹' t),
  { have h : infinite (univ : set ℕ) := infinite_univ,
    have hpre : f ⁻¹' (s ∪ t) = set.univ,
    { rw [← image_univ, image_subset_iff, univ_subset_iff] at fst,
      exact fst },
    rw preimage_union at hpre,
    rw ← hpre at h,
    rw [infinite, infinite],
    rw infinite at h,
    contrapose! h,
    exact finite.union h.1 h.2, },
  rw [← infinite_coe_iff, ← infinite_coe_iff] at h,
  cases h with inf inf; haveI := inf,
  { apply hs ((nat.order_embedding_of_set (f ⁻¹' s)).dual.trans f),
    change range (function.comp f (nat.order_embedding_of_set (f ⁻¹' s))) ⊆ s,
    rw [range_comp, image_subset_iff],
      simp },
  { apply ht ((nat.order_embedding_of_set (f ⁻¹' t)).dual.trans f),
    change range (function.comp f (nat.order_embedding_of_set (f ⁻¹' t))) ⊆ t,
    rw [range_comp, image_subset_iff],
      simp }
end
end partial_order

end set

namespace set

/-- A subset is partially well-ordered by a relation `r` when any infinite sequence contains
  two elements where the first is related to the second by `r`. -/
def partially_well_ordered_on (s) (r : α → α → Prop) : Prop :=
  ∀ (f : ℕ → α), range f ⊆ s → ∃ (m n : ℕ), m < n ∧ r (f m) (f n)

/-- A subset of a preorder is partially well-ordered when any infinite sequence contains
  a monotone subsequence of length 2 (or equivalently, an infinite monotone subsequence). -/
def is_pwo [preorder α] (s) : Prop :=
partially_well_ordered_on s ((≤) : α → α → Prop)

theorem partially_well_ordered_on.mono {s t : set α} {r : α → α → Prop}
  (ht : t.partially_well_ordered_on r) (hsub : s ⊆ t) :
  s.partially_well_ordered_on r :=
λ f hf, ht f (set.subset.trans hf hsub)

theorem partially_well_ordered_on.image_of_monotone_on {s : set α}
  {r : α → α → Prop} {β : Type*} {r' : β → β → Prop}
  (hs : s.partially_well_ordered_on r) {f : α → β}
  (hf : ∀ a1 a2 : α, a1 ∈ s → a2 ∈ s → r a1 a2 → r' (f a1) (f a2)) :
  (f '' s).partially_well_ordered_on r' :=
λ g hg, begin
  have h := λ (n : ℕ), ((mem_image _ _ _).1 (hg (mem_range_self n))),
  obtain ⟨m, n, hlt, hmn⟩ := hs (λ n, classical.some (h n)) _,
  { refine ⟨m, n, hlt, _⟩,
    rw [← (classical.some_spec (h m)).2,
      ← (classical.some_spec (h n)).2],
    exact hf _ _ (classical.some_spec (h m)).1 (classical.some_spec (h n)).1 hmn },
  { rintros _ ⟨n, rfl⟩,
    exact (classical.some_spec (h n)).1 }
end

section partial_order
variables {s : set α} {t : set α} {r : α → α → Prop}

theorem partially_well_ordered_on.exists_monotone_subseq [is_refl α r] [is_trans α r]
  (h : s.partially_well_ordered_on r) (f : ℕ → α) (hf : range f ⊆ s) :
  ∃ (g : ℕ ↪o ℕ), ∀ m n : ℕ, m ≤ n → r (f (g m)) (f (g n)) :=
begin
  obtain ⟨g, h1 | h2⟩ := exists_increasing_or_nonincreasing_subseq r f,
  { refine ⟨g, λ m n hle, _⟩,
    obtain hlt | heq := lt_or_eq_of_le hle,
    { exact h1 m n hlt, },
    { rw [heq],
      apply refl_of r } },
  { exfalso,
    obtain ⟨m, n, hlt, hle⟩ := h (f ∘ g) (subset.trans (range_comp_subset_range _ _) hf),
    exact h2 m n hlt hle }
end

theorem partially_well_ordered_on_iff_exists_monotone_subseq [is_refl α r] [is_trans α r] :
  s.partially_well_ordered_on r ↔
    ∀ f : ℕ → α, range f ⊆ s → ∃ (g : ℕ ↪o ℕ), ∀ m n : ℕ, m ≤ n → r (f (g m)) (f (g n)) :=
begin
  classical,
  split; intros h f hf,
  { exact h.exists_monotone_subseq f hf },
  { obtain ⟨g, gmon⟩ := h f hf,
    refine ⟨g 0, g 1, g.lt_iff_lt.2 zero_lt_one, gmon _ _ zero_le_one⟩, }
end

lemma partially_well_ordered_on.well_founded_on [is_partial_order α r]
  (h : s.partially_well_ordered_on r) :
  s.well_founded_on (λ a b, r a b ∧ a ≠ b) :=
begin
  haveI : is_strict_order α (λ a b, r a b ∧ a ≠ b) :=
  { to_is_irrefl := ⟨λ a con, con.2 rfl⟩,
    to_is_trans := ⟨λ a b c ab bc, ⟨trans ab.1 bc.1,
      λ ac, ab.2 (antisymm ab.1 (ac.symm ▸ bc.1))⟩⟩ },
  rw well_founded_on_iff_no_descending_seq,
  intros f con,
  obtain ⟨m, n, hlt, hle⟩ := h f con,
  exact (f.map_rel_iff.2 hlt).2 (antisymm hle (f.map_rel_iff.2 hlt).1).symm,
end

variables [partial_order α]

lemma is_pwo.is_wf (h : s.is_pwo) :
  s.is_wf :=
begin
  rw [is_wf],
  convert h.well_founded_on,
  ext x y,
  rw lt_iff_le_and_ne,
end

theorem is_pwo.exists_monotone_subseq
  (h : s.is_pwo) (f : ℕ → α) (hf : range f ⊆ s) :
  ∃ (g : ℕ ↪o ℕ), monotone (f ∘ g) :=
h.exists_monotone_subseq f hf

theorem is_pwo_iff_exists_monotone_subseq :
  s.is_pwo ↔
    ∀ f : ℕ → α, range f ⊆ s → ∃ (g : ℕ ↪o ℕ), monotone (f ∘ g) :=
partially_well_ordered_on_iff_exists_monotone_subseq

lemma is_pwo.prod (hs : s.is_pwo)
  (ht : t.is_pwo) :
  (s.prod t).is_pwo :=
begin
  classical,
  rw is_pwo_iff_exists_monotone_subseq at *,
  intros f hf,
  obtain ⟨g1, h1⟩ := hs (prod.fst ∘ f) _,
  swap,
  { rw [range_comp, image_subset_iff],
    refine subset.trans hf _,
    rintros ⟨x1, x2⟩ hx,
    simp only [mem_preimage, hx.1] },
  obtain ⟨g2, h2⟩ := ht (prod.snd ∘ f ∘ g1) _,
  refine ⟨g2.trans g1, λ m n mn, _⟩,
  swap,
  { rw [range_comp, image_subset_iff],
    refine subset.trans (range_comp_subset_range _ _) (subset.trans hf _),
    rintros ⟨x1, x2⟩ hx,
    simp only [mem_preimage, hx.2] },
  simp only [rel_embedding.coe_trans, function.comp_app],
  exact ⟨h1 (g2.le_iff_le.2 mn), h2 mn⟩,
end

theorem is_pwo.image_of_monotone {β : Type*} [partial_order β]
  (hs : s.is_pwo) {f : α → β} (hf : monotone f) :
  is_pwo (f '' s) :=
hs.image_of_monotone_on (λ _ _ _ _ ab, hf ab)

theorem is_pwo.union (hs : is_pwo s) (ht : is_pwo t) : is_pwo (s ∪ t) :=
begin
  classical,
  rw [is_pwo_iff_exists_monotone_subseq] at *,
  rintros f fst,
  have h : infinite (f ⁻¹' s) ∨ infinite (f ⁻¹' t),
  { have h : infinite (univ : set ℕ) := infinite_univ,
    have hpre : f ⁻¹' (s ∪ t) = set.univ,
    { rw [← image_univ, image_subset_iff, univ_subset_iff] at fst,
      exact fst },
    rw preimage_union at hpre,
    rw ← hpre at h,
    rw [infinite, infinite],
    rw infinite at h,
    contrapose! h,
    exact finite.union h.1 h.2, },
  rw [← infinite_coe_iff, ← infinite_coe_iff] at h,
  cases h with inf inf; haveI := inf,
  { obtain ⟨g, hg⟩ := hs (f ∘ (nat.order_embedding_of_set (f ⁻¹' s))) _,
    { rw [function.comp.assoc, ← rel_embedding.coe_trans] at hg,
      exact ⟨_, hg⟩ },
    rw [range_comp, image_subset_iff],
    simp },
  { obtain ⟨g, hg⟩ := ht (f ∘ (nat.order_embedding_of_set (f ⁻¹' t))) _,
    { rw [function.comp.assoc, ← rel_embedding.coe_trans] at hg,
      exact ⟨_, hg⟩ },
    rw [range_comp, image_subset_iff],
    simp }
end

end partial_order

theorem is_wf.is_pwo [linear_order α] {s : set α}
  (hs : s.is_wf) : s.is_pwo :=
λ f hf, begin
  rw [is_wf, well_founded_on_iff] at hs,
  have hrange : (range f).nonempty := ⟨f 0, mem_range_self 0⟩,
  let a := hs.min (range f) hrange,
  obtain ⟨m, hm⟩ := hs.min_mem (range f) hrange,
  refine ⟨m, m.succ, m.lt_succ_self, le_of_not_lt (λ con, _)⟩,
  rw hm at con,
  apply hs.not_lt_min (range f) hrange (mem_range_self m.succ)
    ⟨con, hf (mem_range_self m.succ), hf _⟩,
  rw ← hm,
  apply mem_range_self,
end

theorem is_wf_iff_is_pwo [linear_order α] {s : set α} :
  s.is_wf ↔ s.is_pwo :=
⟨is_wf.is_pwo, is_pwo.is_wf⟩

end set

namespace finset

@[simp]
theorem partially_well_ordered_on {r : α → α → Prop} [is_refl α r] (f : finset α) :
  set.partially_well_ordered_on (↑f : set α) r :=
begin
  intros g hg,
  by_cases hinj : function.injective g,
  { exact (set.infinite_of_injective_forall_mem hinj (set.range_subset_iff.1 hg)
      f.finite_to_set).elim },
  { rw [function.injective] at hinj,
    push_neg at hinj,
    obtain ⟨m, n, gmgn, hne⟩ := hinj,
    cases lt_or_gt_of_ne hne with hlt hlt;
    { refine ⟨_, _, hlt, _⟩,
      rw gmgn,
      exact refl_of r _, } }
end

@[simp]
theorem is_pwo [partial_order α] (f : finset α) :
  set.is_pwo (↑f : set α) :=
f.partially_well_ordered_on

@[simp]
theorem well_founded_on {r : α → α → Prop} [is_strict_order α r] (f : finset α) :
  set.well_founded_on (↑f : set α) r :=
begin
  rw [set.well_founded_on_iff_no_descending_seq],
  intros g con,
  apply set.infinite_of_injective_forall_mem g.injective (set.range_subset_iff.1 con),
  exact f.finite_to_set,
end

@[simp]
theorem is_wf [partial_order α] (f : finset α) : set.is_wf (↑f : set α) :=
f.is_pwo.is_wf

end finset

namespace set
variables [partial_order α] {s : set α} {a : α}

theorem finite.is_pwo (h : s.finite) : s.is_pwo :=
begin
  rw ← h.coe_to_finset,
  exact h.to_finset.is_pwo,
end

@[simp]
theorem fintype.is_pwo [fintype α] : s.is_pwo := (finite.of_fintype s).is_pwo

@[simp]
theorem is_pwo_empty : is_pwo (∅ : set α) :=
finite_empty.is_pwo

@[simp]
theorem is_pwo_singleton (a) : is_pwo ({a} : set α) :=
(finite_singleton a).is_pwo

theorem is_pwo.insert (a) (hs : is_pwo s) : is_pwo (insert a s) :=
by { rw ← union_singleton, exact hs.union (is_pwo_singleton a) }

/-- `is_wf.min` returns a minimal element of a nonempty well-founded set. -/
noncomputable def is_wf.min (hs : is_wf s) (hn : s.nonempty) : α :=
hs.min univ (nonempty_iff_univ_nonempty.1 hn.to_subtype)

lemma is_wf.min_mem (hs : is_wf s) (hn : s.nonempty) : hs.min hn ∈ s :=
(well_founded.min hs univ (nonempty_iff_univ_nonempty.1 hn.to_subtype)).2

lemma is_wf.not_lt_min (hs : is_wf s) (hn : s.nonempty) (ha : a ∈ s) : ¬ a < hs.min hn :=
hs.not_lt_min univ (nonempty_iff_univ_nonempty.1 hn.to_subtype) (mem_univ (⟨a, ha⟩ : s))

@[simp]
lemma is_wf_min_singleton (a) {hs : is_wf ({a} : set α)} {hn : ({a} : set α).nonempty} :
  hs.min hn = a :=
eq_of_mem_singleton (is_wf.min_mem hs hn)

end set

@[simp]
theorem finset.is_wf_sup {ι : Type*} [partial_order α] (f : finset ι) (g : ι → set α)
  (hf : ∀ i : ι, i ∈ f → (g i).is_wf) : (f.sup g).is_wf :=
begin
  classical,
  revert hf,
  apply f.induction_on,
  { intro h,
    simp [set.is_pwo_empty.is_wf], },
  { intros s f sf hf hsf,
    rw finset.sup_insert,
    exact (hsf s (finset.mem_insert_self _ _)).union  (hf (λ s' s'f, hsf _
      (finset.mem_insert_of_mem s'f))) }
end

@[simp]
theorem finset.is_pwo_sup {ι : Type*} [partial_order α] (f : finset ι) (g : ι → set α)
  (hf : ∀ i : ι, i ∈ f → (g i).is_pwo) : (f.sup g).is_pwo :=
begin
  classical,
  revert hf,
  apply f.induction_on,
  { intro h,
    simp [set.is_pwo_empty.is_wf], },
  { intros s f sf hf hsf,
    rw finset.sup_insert,
    exact (hsf s (finset.mem_insert_self _ _)).union  (hf (λ s' s'f, hsf _
      (finset.mem_insert_of_mem s'f))) }
end

namespace set
variables [linear_order α] {s t : set α} {a : α}

lemma is_wf.min_le
  (hs : s.is_wf) (hn : s.nonempty) (ha : a ∈ s) : hs.min hn ≤ a :=
le_of_not_lt (hs.not_lt_min hn ha)

lemma is_wf.le_min_iff
  (hs : s.is_wf) (hn : s.nonempty) :
  a ≤ hs.min hn ↔ ∀ b, b ∈ s → a ≤ b :=
⟨λ ha b hb, le_trans ha (hs.min_le hn hb), λ h, h _ (hs.min_mem _)⟩

lemma is_wf.min_le_min_of_subset
  {hs : s.is_wf} {hsn : s.nonempty} {ht : t.is_wf} {htn : t.nonempty} (hst : s ⊆ t) :
  ht.min htn ≤ hs.min hsn :=
(is_wf.le_min_iff _ _).2 (λ b hb, ht.min_le htn (hst hb))

lemma is_wf.min_union (hs : s.is_wf) (hsn : s.nonempty) (ht : t.is_wf) (htn : t.nonempty) :
  (hs.union ht).min (union_nonempty.2 (or.intro_left _ hsn)) = min (hs.min hsn) (ht.min htn) :=
begin
  refine le_antisymm (le_min (is_wf.min_le_min_of_subset (subset_union_left _ _))
      (is_wf.min_le_min_of_subset (subset_union_right _ _))) _,
  rw min_le_iff,
  exact ((mem_union _ _ _).1 ((hs.union ht).min_mem
    (union_nonempty.2 (or.intro_left _ hsn)))).imp (hs.min_le _) (ht.min_le _),
end

end set

namespace set

variables {s : set α} {t : set α}

@[to_additive]
theorem is_pwo.mul [ordered_cancel_comm_monoid α] (hs : s.is_pwo) (ht : t.is_pwo) :
  is_pwo (s * t) :=
begin
  rw ← image_mul_prod,
  exact (is_pwo.prod hs ht).image_of_monotone (λ _ _ h, mul_le_mul' h.1 h.2),
end

variable [linear_ordered_cancel_comm_monoid α]

@[to_additive]
theorem is_wf.mul (hs : s.is_wf) (ht : t.is_wf) : is_wf (s * t) :=
(hs.is_pwo.mul ht.is_pwo).is_wf

@[to_additive]
theorem is_wf.min_mul (hs : s.is_wf) (ht : t.is_wf) (hsn : s.nonempty) (htn : t.nonempty) :
  (hs.mul ht).min (hsn.mul htn) = hs.min hsn * ht.min htn :=
begin
  refine le_antisymm (is_wf.min_le _ _ (mem_mul.2 ⟨_, _, hs.min_mem _, ht.min_mem _, rfl⟩)) _,
  rw is_wf.le_min_iff,
  rintros _ ⟨x, y, hx, hy, rfl⟩,
  exact mul_le_mul' (hs.min_le _ hx) (ht.min_le _ hy),
end

end set

namespace set
namespace partially_well_ordered_on

/-- In the context of partial well-orderings, a bad sequence is a nonincreasing sequence
  whose range is contained in a particular set `s`. One exists if and only if `s` is not
  partially well-ordered. -/
def is_bad_seq (r : α → α → Prop) (s : set α) (f : ℕ → α) : Prop :=
set.range f ⊆ s ∧ ∀ (m n : ℕ), m < n → ¬ r (f m) (f n)

lemma iff_forall_not_is_bad_seq (r : α → α → Prop) (s : set α) :
  s.partially_well_ordered_on r ↔
    ∀ f, ¬ is_bad_seq r s f :=
begin
  rw [set.partially_well_ordered_on],
  apply forall_congr (λ f, _),
  simp [is_bad_seq]
end

/-- This indicates that every bad sequence `g` that agrees with `f` on the first `n`
  terms has `rk (f n) ≤ rk (g n)`. -/
def is_min_bad_seq (r : α → α → Prop) (rk : α → ℕ) (s : set α) (n : ℕ) (f : ℕ → α) : Prop :=
  ∀ g : ℕ → α, (∀ (m : ℕ), m < n → f m = g m) → rk (g n) < rk (f n) → ¬ is_bad_seq r s g

/-- Given a bad sequence `f`, this constructs a bad sequence that agrees with `f` on the first `n`
  terms and is minimal at `n`.
-/
noncomputable def min_bad_seq_of_bad_seq (r : α → α → Prop) (rk : α → ℕ) (s : set α)
  (n : ℕ) (f : ℕ → α) (hf : is_bad_seq r s f) :
  { g : ℕ → α // (∀ (m : ℕ), m < n → f m = g m) ∧ is_bad_seq r s g ∧ is_min_bad_seq r rk s n g } :=
begin
  classical,
  have h : ∃ (k : ℕ) (g : ℕ → α), (∀ m, m < n → f m = g m) ∧ is_bad_seq r s g
        ∧ rk (g n) = k :=
  ⟨_, f, λ _ _, rfl, hf, rfl⟩,
  obtain ⟨h1, h2, h3⟩ := classical.some_spec (nat.find_spec h),
  refine ⟨classical.some (nat.find_spec h), h1, by convert h2, λ g hg1 hg2 con, _⟩,
  refine nat.find_min h _ ⟨g, λ m mn, (h1 m mn).trans (hg1 m mn), by convert con, rfl⟩,
  rwa ← h3,
end

lemma exists_min_bad_of_exists_bad (r : α → α → Prop) (rk : α → ℕ) (s : set α) :
  (∃ f, is_bad_seq r s f) → ∃ f, is_bad_seq r s f ∧ ∀ n, is_min_bad_seq r rk s n f :=
begin
  rintro ⟨f0, (hf0 : is_bad_seq r s f0)⟩,
  let fs : Π (n : ℕ), { f :  ℕ → α // is_bad_seq r s f ∧ is_min_bad_seq r rk s n f },
  { refine nat.rec _ _,
    { exact ⟨(min_bad_seq_of_bad_seq r rk s 0 f0 hf0).1,
        (min_bad_seq_of_bad_seq r rk s 0 f0 hf0).2.2⟩, },
    { exact λ n fn, ⟨(min_bad_seq_of_bad_seq r rk s (n + 1) fn.1 fn.2.1).1,
        (min_bad_seq_of_bad_seq r rk s (n + 1) fn.1 fn.2.1).2.2⟩ } },
  have h : ∀ m n, m ≤ n → (fs m).1 m = (fs n).1 m,
  { intros m n mn,
    obtain ⟨k, rfl⟩ := exists_add_of_le mn,
    clear mn,
    induction k with k ih,
    { refl },
    rw [ih, ((min_bad_seq_of_bad_seq r rk s (m + k).succ (fs (m + k)).1 (fs (m + k)).2.1).2.1 m
        (nat.lt_succ_iff.2 (nat.add_le_add_left k.zero_le m)))],
    refl },
  refine ⟨λ n, (fs n).1 n, ⟨set.range_subset_iff.2 (λ n, ((fs n).2).1.1 (mem_range_self n)),
    λ m n mn, _⟩, λ n g hg1 hg2, _⟩,
  { dsimp,
    rw [← subtype.val_eq_coe, h m n (le_of_lt mn)],
    convert (fs n).2.1.2 m n mn },
  { convert (fs n).2.2 g (λ m mn, eq.trans _ (hg1 m mn)) (lt_of_lt_of_le hg2 (le_refl _)),
    rw ← h m n (le_of_lt mn) },
end

lemma iff_not_exists_is_min_bad_seq {r : α → α → Prop} (rk : α → ℕ) {s : set α} :
  s.partially_well_ordered_on r ↔ ¬ ∃ f, is_bad_seq r s f ∧ ∀ n, is_min_bad_seq r rk s n f :=
begin
  rw [iff_forall_not_is_bad_seq, ← not_exists, not_congr],
  split,
  { apply exists_min_bad_of_exists_bad },
  rintro ⟨f, hf1, hf2⟩,
  exact ⟨f, hf1⟩,
end

/-- Higman's Lemma, which states that for any reflexive, transitive relation `r` which is
  partially well-ordered on a set `s`, the relation `list.sublist_forall₂ r` is partially
  well-ordered on the set of lists of elements of `s`. That relation is defined so that
  `list.sublist_forall₂ r l₁ l₂` whenever `l₁` related pointwise by `r` to a sublist of `l₂`.  -/
lemma partially_well_ordered_on_sublist_forall₂ (r : α → α → Prop) [is_refl α r] [is_trans α r]
  {s : set α} (h : s.partially_well_ordered_on r) :
  { l : list α | ∀ x, x ∈ l → x ∈ s }.partially_well_ordered_on (list.sublist_forall₂ r) :=
begin
  rcases s.eq_empty_or_nonempty with rfl | ⟨as, has⟩,
  { apply partially_well_ordered_on.mono (finset.partially_well_ordered_on {list.nil}),
    { intros l hl,
      rw [finset.mem_coe, finset.mem_singleton, list.eq_nil_iff_forall_not_mem],
      exact hl, },
    apply_instance },
  haveI : inhabited α := ⟨as⟩,
  rw [iff_not_exists_is_min_bad_seq (list.length)],
  rintro ⟨f, hf1, hf2⟩,
  have hnil : ∀ n, f n ≠ list.nil :=
    λ n con, (hf1).2 n n.succ n.lt_succ_self (con.symm ▸ list.sublist_forall₂.nil),
  obtain ⟨g, hg⟩ := h.exists_monotone_subseq (list.head ∘ f) _,
  swap, { simp only [set.range_subset_iff, function.comp_apply],
    exact λ n, hf1.1 (set.mem_range_self n) _ (list.head_mem_self (hnil n)) },
  have hf' := hf2 (g 0) (λ n, if n < g 0 then f n else list.tail (f (g (n - g 0))))
    (λ m hm, (if_pos hm).symm) _,
  swap, { simp only [if_neg (lt_irrefl (g 0)), tsub_self],
    rw [list.length_tail, ← nat.pred_eq_sub_one],
    exact nat.pred_lt (λ con, hnil _ (list.length_eq_zero.1 con)) },
  rw [is_bad_seq] at hf',
  push_neg at hf',
  obtain ⟨m, n, mn, hmn⟩ := hf' _,
  swap, { rw set.range_subset_iff,
    rintro n x hx,
    split_ifs at hx with hn hn,
    { exact hf1.1 (set.mem_range_self _) _ hx },
    { refine hf1.1 (set.mem_range_self _) _ (list.tail_subset _ hx), } },
  by_cases hn : n < g 0,
  { apply hf1.2 m n mn,
    rwa [if_pos hn, if_pos (mn.trans hn)] at hmn },
  { obtain ⟨n', rfl⟩ := le_iff_exists_add.1 (not_lt.1 hn),
    rw [if_neg hn, add_comm (g 0) n', add_tsub_cancel_right] at hmn,
    split_ifs at hmn with hm hm,
    { apply hf1.2 m (g n') (lt_of_lt_of_le hm (g.monotone n'.zero_le)),
      exact trans hmn (list.tail_sublist_forall₂_self _) },
    { rw [← (tsub_lt_iff_left (le_of_not_lt hm))] at mn,
      apply hf1.2 _ _ (g.lt_iff_lt.2 mn),
      rw [← list.cons_head_tail (hnil (g (m - g 0))), ← list.cons_head_tail (hnil (g n'))],
      exact list.sublist_forall₂.cons (hg _ _ (le_of_lt mn)) hmn, } }
end

end partially_well_ordered_on

namespace is_pwo

@[to_additive]
lemma submonoid_closure [ordered_cancel_comm_monoid α] {s : set α} (hpos : ∀ x : α, x ∈ s → 1 ≤ x)
  (h : s.is_pwo) : is_pwo ((submonoid.closure s) : set α) :=
begin
  have hl : ((submonoid.closure s) : set α) ⊆ list.prod '' { l : list α | ∀ x, x ∈ l → x ∈ s },
  { intros x hx,
    rw set_like.mem_coe at hx,
    refine submonoid.closure_induction hx (λ x hx, ⟨_, λ y hy, _, list.prod_singleton⟩)
      ⟨_, λ y hy, (list.not_mem_nil _ hy).elim, list.prod_nil⟩ _,
    { rwa list.mem_singleton.1 hy },
    rintros _ _ ⟨l, hl, rfl⟩ ⟨l', hl', rfl⟩,
    refine ⟨_, λ y hy, _, list.prod_append⟩,
    cases list.mem_append.1 hy with hy hy,
    { exact hl _ hy },
    { exact hl' _ hy } },
  apply ((h.partially_well_ordered_on_sublist_forall₂ (≤)).image_of_monotone_on _).mono hl,
  intros l1 l2 hl1 hl2 h12,
  obtain ⟨l, hll1, hll2⟩ := list.sublist_forall₂_iff.1 h12,
  refine le_trans (list.rel_prod (le_refl 1) (λ a b ab c d cd, mul_le_mul' ab cd) hll1) _,
  obtain ⟨l', hl'⟩ := hll2.exists_perm_append,
  rw [hl'.prod_eq, list.prod_append, ← mul_one l.prod, mul_assoc, one_mul],
  apply mul_le_mul_left',
  have hl's := λ x hx, hl2 x (list.subset.trans (l.subset_append_right _) hl'.symm.subset hx),
  clear hl',
  induction l' with x1 x2 x3 x4 x5,
  { refl },
  rw [list.prod_cons, ← one_mul (1 : α)],
  exact mul_le_mul' (hpos x1 (hl's x1 (list.mem_cons_self x1 x2)))
    (x3 (λ x hx, hl's x (list.mem_cons_of_mem _ hx)))
end

end is_pwo

/-- `set.mul_antidiagonal s t a` is the set of all pairs of an element in `s` and an element in `t`
  that multiply to `a`. -/
@[to_additive "`set.add_antidiagonal s t a` is the set of all pairs of an element in `s`
  and an element in `t` that add to `a`."]
def mul_antidiagonal [monoid α] (s t : set α) (a : α) : set (α × α) :=
{ x | x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t }

namespace mul_antidiagonal

@[simp, to_additive]
lemma mem_mul_antidiagonal [monoid α] {s t : set α} {a : α} {x : α × α} :
  x ∈ mul_antidiagonal s t a ↔ x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t := iff.refl _

section cancel_comm_monoid
variables [cancel_comm_monoid α] {s t : set α} {a : α}

@[to_additive]
lemma fst_eq_fst_iff_snd_eq_snd {x y : (mul_antidiagonal s t a)} :
  (x : α × α).fst = (y : α × α).fst ↔ (x : α × α).snd = (y : α × α).snd :=
⟨λ h, begin
  have hx := x.2.1,
  rw [subtype.val_eq_coe, h] at hx,
  apply mul_left_cancel (hx.trans y.2.1.symm),
end, λ h, begin
  have hx := x.2.1,
  rw [subtype.val_eq_coe, h] at hx,
  apply mul_right_cancel (hx.trans y.2.1.symm),
end⟩

@[to_additive]
lemma eq_of_fst_eq_fst {x y : (mul_antidiagonal s t a)}
  (h : (x : α × α).fst = (y : α × α).fst) : x = y :=
subtype.ext (prod.ext h (mul_antidiagonal.fst_eq_fst_iff_snd_eq_snd.1 h))

@[to_additive]
lemma eq_of_snd_eq_snd {x y : (mul_antidiagonal s t a)}
  (h : (x : α × α).snd = (y : α × α).snd) : x = y :=
subtype.ext (prod.ext (mul_antidiagonal.fst_eq_fst_iff_snd_eq_snd.2 h) h)

end cancel_comm_monoid

section ordered_cancel_comm_monoid
variables [ordered_cancel_comm_monoid α] (s t : set α) (a : α)

@[to_additive]
lemma eq_of_fst_le_fst_of_snd_le_snd {x y : (mul_antidiagonal s t a)}
  (h1 : (x : α × α).fst ≤ (y : α × α).fst) (h2 : (x : α × α).snd ≤ (y : α × α).snd ) :
  x = y :=
begin
  apply eq_of_fst_eq_fst,
  cases eq_or_lt_of_le h1 with heq hlt,
  { exact heq },
  exfalso,
  exact ne_of_lt (mul_lt_mul_of_lt_of_le hlt h2)
    ((mem_mul_antidiagonal.1 x.2).1.trans (mem_mul_antidiagonal.1 y.2).1.symm)
end

variables {s} {t}

@[to_additive]
theorem finite_of_is_pwo (hs : s.is_pwo) (ht : t.is_pwo) (a) :
  (mul_antidiagonal s t a).finite :=
begin
  by_contra h,
  rw [← set.infinite] at h,
  have h1 : (mul_antidiagonal s t a).partially_well_ordered_on (prod.fst ⁻¹'o (≤)),
  { intros f hf,
    refine hs (prod.fst ∘ f) _,
    rw range_comp,
    rintros _ ⟨⟨x, y⟩, hxy, rfl⟩,
    exact (mem_mul_antidiagonal.1 (hf hxy)).2.1 },
  have h2 : (mul_antidiagonal s t a).partially_well_ordered_on (prod.snd ⁻¹'o (≤)),
  { intros f hf,
    refine ht (prod.snd ∘ f) _,
    rw range_comp,
    rintros _ ⟨⟨x, y⟩, hxy, rfl⟩,
    exact (mem_mul_antidiagonal.1 (hf hxy)).2.2 },
  obtain ⟨g, hg⟩ := h1.exists_monotone_subseq (λ x, h.nat_embedding _ x) _,
  swap, { rintro _ ⟨k, rfl⟩,
    exact ((infinite.nat_embedding (s.mul_antidiagonal t a) h) _).2 },
  obtain ⟨m, n, mn, h2'⟩ := h2 (λ x, (h.nat_embedding _) (g x)) _,
  swap, { rintro _ ⟨k, rfl⟩,
    exact ((infinite.nat_embedding (s.mul_antidiagonal t a) h) _).2, },
  apply ne_of_lt mn (g.injective ((h.nat_embedding _).injective _)),
  exact eq_of_fst_le_fst_of_snd_le_snd _ _ _ (hg _ _ (le_of_lt mn)) h2',
end

end ordered_cancel_comm_monoid

@[to_additive]
theorem finite_of_is_wf [linear_ordered_cancel_comm_monoid α] {s t : set α}
  (hs : s.is_wf) (ht : t.is_wf) (a) :
  (mul_antidiagonal s t a).finite :=
finite_of_is_pwo hs.is_pwo ht.is_pwo a

end mul_antidiagonal
end set

namespace finset

variables [ordered_cancel_comm_monoid α]
variables {s t : set α} (hs : s.is_pwo) (ht : t.is_pwo) (a : α)

/-- `finset.mul_antidiagonal_of_is_wf hs ht a` is the set of all pairs of an element in
  `s` and an element in `t` that multiply to `a`, but its construction requires proofs
  `hs` and `ht` that `s` and `t` are well-ordered. -/
@[to_additive "`finset.add_antidiagonal_of_is_wf hs ht a` is the set of all pairs of an element in
  `s` and an element in `t` that add to `a`, but its construction requires proofs
  `hs` and `ht` that `s` and `t` are well-ordered."]
noncomputable def mul_antidiagonal : finset (α × α) :=
(set.mul_antidiagonal.finite_of_is_pwo hs ht a).to_finset

variables {hs} {ht} {u : set α} {hu : u.is_pwo} {a} {x : α × α}

@[simp, to_additive]
lemma mem_mul_antidiagonal :
  x ∈ mul_antidiagonal hs ht a ↔ x.1 * x.2 = a ∧ x.1 ∈ s ∧ x.2 ∈ t :=
by simp [mul_antidiagonal]

@[to_additive]
lemma mul_antidiagonal_mono_left (hus : u ⊆ s) :
  (finset.mul_antidiagonal hu ht a) ⊆ (finset.mul_antidiagonal hs ht a) :=
λ x hx, begin
  rw mem_mul_antidiagonal at *,
  exact ⟨hx.1, hus hx.2.1, hx.2.2⟩,
end

@[to_additive]
lemma mul_antidiagonal_mono_right (hut : u ⊆ t) :
  (finset.mul_antidiagonal hs hu a) ⊆ (finset.mul_antidiagonal hs ht a) :=
λ x hx, begin
  rw mem_mul_antidiagonal at *,
  exact ⟨hx.1, hx.2.1, hut hx.2.2⟩,
end

@[to_additive]
lemma support_mul_antidiagonal_subset_mul :
  { a : α | (mul_antidiagonal hs ht a).nonempty } ⊆ s * t :=
(λ x ⟨⟨a1, a2⟩, ha⟩, begin
  obtain ⟨hmul, h1, h2⟩ := mem_mul_antidiagonal.1 ha,
  exact ⟨a1, a2, h1, h2, hmul⟩,
end)

@[to_additive]
theorem is_pwo_support_mul_antidiagonal :
  { a : α | (mul_antidiagonal hs ht a).nonempty }.is_pwo :=
(hs.mul ht).mono support_mul_antidiagonal_subset_mul

@[to_additive]
theorem mul_antidiagonal_min_mul_min {α} [linear_ordered_cancel_comm_monoid α] {s t : set α}
  (hs : s.is_wf) (ht : t.is_wf)
  (hns : s.nonempty) (hnt : t.nonempty) :
  mul_antidiagonal hs.is_pwo ht.is_pwo ((hs.min hns) * (ht.min hnt)) =
    {(hs.min hns, ht.min hnt)} :=
begin
  ext ⟨a1, a2⟩,
  rw [mem_mul_antidiagonal, finset.mem_singleton, prod.ext_iff],
  split,
  { rintro ⟨hast, has, hat⟩,
    cases eq_or_lt_of_le (hs.min_le hns has) with heq hlt,
    { refine ⟨heq.symm, _⟩,
      rw heq at hast,
      exact mul_left_cancel hast },
    { contrapose hast,
      exact ne_of_gt (mul_lt_mul_of_lt_of_le hlt (ht.min_le hnt hat)) } },
  { rintro ⟨ha1, ha2⟩,
    rw [ha1, ha2],
    exact ⟨rfl, hs.min_mem _, ht.min_mem _⟩ }
end

end finset

lemma well_founded.is_wf [has_lt α] (h : well_founded ((<) : α → α → Prop)) (s : set α) :
  s.is_wf :=
(set.is_wf_univ_iff.2 h).mono (set.subset_univ s)


/-
Copyright (c) 2021 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
-/
import algebra.big_operators.order
import algebra.big_operators.ring
import data.rat.cast

/-!
# The Oxford Invariants Puzzle Challenges - Summer 2021, Week 3, Problem 1

## Original statement

Let `n ≥ 3`, `a₁, ..., aₙ` be strictly positive integers such that `aᵢ ∣ aᵢ₋₁ + aᵢ₊₁` for
`i = 2, ..., n - 1`. Show that $\sum_{i=1}^{n-1}\dfrac{a_0a_n}{a_ia_{i+1}} ∈ \mathbb N$.

## Comments

Mathlib is based on type theory, so saying that a rational is a natural doesn't make sense. Instead,
we ask that there exists `b : ℕ` whose cast to `α` is the sum we want.

In mathlib, `ℕ` starts at `0`. To make the indexing cleaner, we use `a₀, ..., aₙ₋₁` instead of
`a₁, ..., aₙ`. Similarly, it's nicer to not use substraction of naturals, so we replace
`aᵢ ∣ aᵢ₋₁ + aᵢ₊₁` by `aᵢ₊₁ ∣ aᵢ + aᵢ₊₂`.

We don't actually have to work in `ℚ` or `ℝ`. We can be even more general by stating the result for
any linearly ordered field.

Instead of having `n` naturals, we use a function `a : ℕ → ℕ`.

In the proof itself, we replace `n : ℕ, 1 ≤ n` by `n + 1`.

The statement is actually true for `n = 0, 1` (`n = 1, 2` before the reindexing) as the sum is
simply `0` and `1` respectively. So the version we prove is slightly more general.

Overall, the indexing is a bit of a mess to understand. But, trust Lean, it works.

## Formalised statement

Let `n : ℕ`, `a : ℕ → ℕ`, `∀ i ≤ n, 0 < a i`, `∀ i, i + 2 ≤ n → aᵢ₊₁ ∣ aᵢ + aᵢ₊₂` (read `→` as
"implies"). Then there exists `b : ℕ` such that `b` as an element of any linearly ordered field
equals $\sum_{i=0}^{n-1} (a_0 a_n) / (a_i a_{i+1})$.

## Proof outline

The case `n = 0` is trivial.

For `n + 1`, we prove the result by induction but by adding `aₙ₊₁ ∣ aₙ * b - a₀` to the induction
hypothesis, where `b` is the previous sum, $\sum_{i=0}^{n-1} (a_0 a_n) / (a_i a_{i+1})$, as a
natural.
* Base case:
  * $\sum_{i=0}^0 (a_0 a_{0+1}) / (a_0 a_{0+1})$ is a natural:
    $\sum_{i=0}^0 (a_0 a_{0+1}) / (a_0 a_{0+1}) = (a_0 a_1) / (a_0 a_1) = 1$.
  * Divisibility condition:
    `a₀ * 1 - a₀ = 0` is clearly divisible by `a₁`.
* Induction step:
  * $\sum_{i=0}^n (a_0 a_{n+1}) / (a_i a_{i+1})$ is a natural:
    $$\sum_{i=0}^{n+1} (a_0 a_{n+2}) / (a_i a_{i+1})
      = \sum_{i=0}^n\ (a_0 a_{n+2}) / (a_i a_{i+1}) + (a_0 a_{n+2}) / (a_{n+1} a_{n+2})
      = a_{n+2} / a_{n+1} × \sum_{i=0}^n (a_0 a_{n+1}) / (a_i a_{i+1}) + a_0 / a_{n+1}
      = a_{n+2} / a_{n+1} × b + a_0 / a_{n+1}
      = (a_n + a_{n+2}) / a_{n+1} × b - (a_n b - a_0)(a_{n+1})$$
    which is a natural because `(aₙ + aₙ₊₂)/aₙ₊₁`, `b` and `(aₙ * b - a₀)/aₙ₊₁` are (plus an
    annoying inequality, or the fact that the original sum is positive because its terms are).
  * Divisibility condition:
    `aₙ₊₁ * ((aₙ + aₙ₊₂)/aₙ₊₁ * b - (aₙ * b - a₀)/aₙ₊₁) - a₀ = aₙ₊₁aₙ₊₂b` is divisible by `aₙ₊₂`.
-/

open_locale big_operators

variables {α : Type*} [linear_ordered_field α]

theorem week3_p1 (n : ℕ) (a : ℕ → ℕ) (a_pos : ∀ i ≤ n, 0 < a i)
  (ha : ∀ i, i + 2 ≤ n → a (i + 1) ∣ a i + a (i + 2)) :
  ∃ b : ℕ, (b : α) = ∑ i in finset.range n, (a 0 * a n)/(a i * a (i + 1)) :=
begin
  -- Treat separately `n = 0` and `n ≥ 1`
  cases n,
  /- Case `n = 0`
  The sum is trivially equal to `0` -/
  { exact ⟨0, by rw [nat.cast_zero, finset.sum_range_zero]⟩ }, -- `⟨Claim it, Prove it⟩`
  /- Case `n ≥ 1`. We replace `n` by `n + 1` everywhere to make this inequality explicit
  Set up the stronger induction hypothesis -/
  suffices h : ∃ b : ℕ, (b : α) = ∑ i in finset.range (n + 1), (a 0 * a (n + 1))/(a i * a (i + 1))
           ∧ a (n + 1) ∣ a n * b - a 0,
  { obtain ⟨b, hb, -⟩ := h,
    exact ⟨b, hb⟩ },
  simp_rw ←@nat.cast_pos α at a_pos,
  /- Declare the induction
  `ih` will be the induction hypothesis -/
  induction n with n ih,
  /- Base case
  Claim that the sum equals `1`-/
  { refine ⟨1, _, _⟩,
    -- Check that this indeed equals the sum
    { rw [nat.cast_one, finset.sum_range_one, div_self],
      exact (mul_pos (a_pos 0 (nat.zero_le _)) (a_pos 1 (nat.zero_lt_succ _))).ne' },
    -- Check the divisibility condition
    { rw [mul_one, tsub_self],
      exact dvd_zero _ } },
  /- Induction step
  `b` is the value of the previous sum as a natural, `hb` is the proof that it is indeed the value,
  and `han` is the divisibility condition -/
  obtain ⟨b, hb, han⟩ := ih (λ i hi, ha i $ nat.le_succ_of_le hi)
    (λ i hi, a_pos i $ nat.le_succ_of_le hi),
  specialize ha n le_rfl,
  have ha₀ : a 0 ≤ a n * b, -- Needing this is an artifact of `ℕ`-substraction.
  { rw [←@nat.cast_le α, nat.cast_mul, hb, ←div_le_iff' (a_pos _ $ n.le_succ.trans $ nat.le_succ _),
      ←mul_div_mul_right _ _ (a_pos _ $ nat.le_succ _).ne'],
    suffices h : ∀ i, i ∈ finset.range (n + 1) → 0 ≤ (a 0 : α) * a (n + 1) / (a i * a (i + 1)),
    { exact finset.single_le_sum h (finset.self_mem_range_succ n) },
    refine (λ i _, div_nonneg _ _); refine mul_nonneg _ _; exact nat.cast_nonneg _ },
  -- Claim that the sum equals `(aₙ + aₙ₊₂)/aₙ₊₁ * b - (aₙ * b - a₀)/aₙ₊₁`
  refine ⟨(a n + a (n + 2))/ a (n + 1) * b - (a n * b - a 0) / a (n + 1), _, _⟩,
  -- Check that this indeed equals the sum
  { calc
      (((a n + a (n + 2)) / a (n + 1) * b - (a n * b - a 0) / a (n + 1) : ℕ) : α)
        = (a n + a (n + 2)) / a (n + 1) * b - (a n * b - a 0) / a (n + 1) : begin
          norm_cast,
          rw nat.cast_sub (nat.div_le_of_le_mul _),
          rw [←mul_assoc, nat.mul_div_cancel' ha, add_mul],
          exact tsub_le_self.trans (nat.le_add_right _ _),
        end
    ... = a (n + 2) / a (n + 1) * b + (a 0 * a (n + 2)) / (a (n + 1) * a (n + 2))
        : by rw [add_div, add_mul, sub_div, mul_div_right_comm, add_sub_sub_cancel,
            mul_div_mul_right _ _ (a_pos _ le_rfl).ne']
    ... = ∑ (i : ℕ) in finset.range (n + 2), a 0 * a (n + 2) / (a i * a (i + 1))
        : begin
          rw [finset.sum_range_succ, hb, finset.mul_sum],
          congr, ext i,
          rw [←mul_div_assoc, ←mul_div_right_comm, mul_div_assoc, mul_div_cancel _
            (a_pos _ $ nat.le_succ _).ne', mul_comm],
        end },
  -- Check the divisibility condition
  { rw [mul_tsub, ← mul_assoc, nat.mul_div_cancel' ha, add_mul,
      nat.mul_div_cancel' han, add_tsub_tsub_cancel ha₀, add_tsub_cancel_right],
    exact dvd_mul_right _ _ }
end


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.fintype.card
import data.finset.sum
import logic.embedding.set

/-!
## Instances

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

We provide the `fintype` instance for the sum of two fintypes.
-/

universes u v

variables {α β : Type*}

open finset

instance (α : Type u) (β : Type v) [fintype α] [fintype β] : fintype (α ⊕ β) :=
{ elems := univ.disj_sum univ,
  complete := by rintro (_ | _); simp }

@[simp] lemma finset.univ_disj_sum_univ {α β : Type*} [fintype α] [fintype β] :
  univ.disj_sum univ = (univ : finset (α ⊕ β)) :=
rfl

@[simp] theorem fintype.card_sum [fintype α] [fintype β] :
  fintype.card (α ⊕ β) = fintype.card α + fintype.card β :=
card_disj_sum _ _

/-- If the subtype of all-but-one elements is a `fintype` then the type itself is a `fintype`. -/
def fintype_of_fintype_ne (a : α) (h : fintype {b // b ≠ a}) : fintype α :=
fintype.of_bijective (sum.elim (coe : {b // b = a} → α) (coe : {b // b ≠ a} → α)) $
  by { classical, exact (equiv.sum_compl (= a)).bijective }

lemma image_subtype_ne_univ_eq_image_erase [fintype α] [decidable_eq β] (k : β) (b : α → β) :
  image (λ i : {a // b a ≠ k}, b ↑i) univ = (image b univ).erase k :=
begin
  apply subset_antisymm,
  { rw image_subset_iff,
    intros i _,
    apply mem_erase_of_ne_of_mem i.2 (mem_image_of_mem _ (mem_univ _)) },
  { intros i hi,
    rw mem_image,
    rcases mem_image.1 (erase_subset _ _ hi) with ⟨a, _, ha⟩,
    subst ha,
    exact ⟨⟨a, ne_of_mem_erase hi⟩, mem_univ _, rfl⟩ }
end

lemma image_subtype_univ_ssubset_image_univ [fintype α] [decidable_eq β] (k : β) (b : α → β)
  (hk : k ∈ image b univ) (p : β → Prop) [decidable_pred p] (hp : ¬ p k) :
  image (λ i : {a // p (b a)}, b ↑i) univ ⊂ image b univ :=
begin
  split,
  { intros x hx,
    rcases mem_image.1 hx with ⟨y, _, hy⟩,
    exact hy ▸ mem_image_of_mem b (mem_univ y) },
  { intros h,
    rw mem_image at hk,
    rcases hk with ⟨k', _, hk'⟩, subst hk',
    have := h (mem_image_of_mem b (mem_univ k')),
    rw mem_image at this,
    rcases this with ⟨j, hj, hj'⟩,
    exact hp (hj' ▸ j.2) }
end

/-- Any injection from a finset `s` in a fintype `α` to a finset `t` of the same cardinality as `α`
can be extended to a bijection between `α` and `t`. -/
lemma finset.exists_equiv_extend_of_card_eq [fintype α] [decidable_eq β] {t : finset β}
  (hαt : fintype.card α = t.card) {s : finset α} {f : α → β} (hfst : s.image f ⊆ t)
  (hfs : set.inj_on f s) :
  ∃ g : α ≃ t, ∀ i ∈ s, (g i : β) = f i :=
begin
  classical,
  induction s using finset.induction with a s has H generalizing f,
  { obtain ⟨e⟩ : nonempty (α ≃ ↥t) := by rwa [← fintype.card_eq, fintype.card_coe],
    use e,
    simp },
  have hfst' : finset.image f s ⊆ t := (finset.image_mono _ (s.subset_insert a)).trans hfst,
  have hfs' : set.inj_on f s := hfs.mono (s.subset_insert a),
  obtain ⟨g', hg'⟩ := H hfst' hfs',
  have hfat : f a ∈ t := hfst (mem_image_of_mem _ (s.mem_insert_self a)),
  use g'.trans (equiv.swap (⟨f a, hfat⟩ : t) (g' a)),
  simp_rw mem_insert,
  rintro i (rfl | hi),
  { simp },
  rw [equiv.trans_apply, equiv.swap_apply_of_ne_of_ne, hg' _ hi],
  { exact ne_of_apply_ne subtype.val (ne_of_eq_of_ne (hg' _ hi) $
    hfs.ne (subset_insert _ _ hi) (mem_insert_self _ _) $ ne_of_mem_of_not_mem hi has) },
  { exact g'.injective.ne (ne_of_mem_of_not_mem hi has) },
end

/-- Any injection from a set `s` in a fintype `α` to a finset `t` of the same cardinality as `α`
can be extended to a bijection between `α` and `t`. -/
lemma set.maps_to.exists_equiv_extend_of_card_eq [fintype α] {t : finset β}
  (hαt : fintype.card α = t.card) {s : set α} {f : α → β} (hfst : s.maps_to f t)
  (hfs : set.inj_on f s) :
  ∃ g : α ≃ t, ∀ i ∈ s, (g i : β) = f i :=
begin
  classical,
  let s' : finset α := s.to_finset,
  have hfst' : s'.image f ⊆ t := by simpa [← finset.coe_subset] using hfst,
  have hfs' : set.inj_on f s' := by simpa using hfs,
  obtain ⟨g, hg⟩ := finset.exists_equiv_extend_of_card_eq hαt hfst' hfs',
  refine ⟨g, λ i hi, _⟩,
  apply hg,
  simpa using hi,
end

lemma fintype.card_subtype_or (p q : α → Prop)
  [fintype {x // p x}] [fintype {x // q x}] [fintype {x // p x ∨ q x}] :
  fintype.card {x // p x ∨ q x} ≤ fintype.card {x // p x} + fintype.card {x // q x} :=
begin
  classical,
  convert fintype.card_le_of_embedding (subtype_or_left_embedding p q),
  rw fintype.card_sum
end

lemma fintype.card_subtype_or_disjoint (p q : α → Prop) (h : disjoint p q)
  [fintype {x // p x}] [fintype {x // q x}] [fintype {x // p x ∨ q x}] :
  fintype.card {x // p x ∨ q x} = fintype.card {x // p x} + fintype.card {x // q x} :=
begin
  classical,
  convert fintype.card_congr (subtype_or_equiv p q h),
  simp
end

section
open_locale classical

@[simp] lemma infinite_sum : infinite (α ⊕ β) ↔ infinite α ∨ infinite β :=
begin
  refine ⟨λ H, _, λ H, H.elim (@sum.infinite_of_left α β) (@sum.infinite_of_right α β)⟩,
  contrapose! H, haveI := fintype_of_not_infinite H.1, haveI := fintype_of_not_infinite H.2,
  exact infinite.false
end

end


import Mathlib
import RSACryptosystems

theorem mod_pow_eq :  mod_pow a b n = (a ^ b) % n :=
  by
  rw[mod_pow]
  have h' : n > 1 := by
    sorry
  by_cases h : b = 0
  · simp[h, h', Nat.mod_eq_of_lt]
  · simp[h, h']
    sorry

#check Commute.add_pow
#check Nat.Prime.dvd_choose_self

theorem freshman's_dream (a b : ℕ) (hp : Nat.Prime p) : ((a + b) ^ p) % p = (a ^ p + b ^ p)%p := by
  rw[← Nat.ModEq]
  rw[add_pow]
  rw[Nat.ModEq.comm]
  have h1 : {0, p} ⊆  Finset.range (p + 1) := by
    rw[Finset.subset_iff]
    simp
  rw[←Finset.sum_sdiff h1 ]
  have h2 : 0 ≠ p := by
    sorry
  rw[Finset.sum_pair h2]
  simp
  rw[Nat.modEq_iff_dvd']
  rw[Nat.sub_add_eq,← Nat.add_assoc]
  simp[← Nat.add_le_add_left]
  sorry

theorem fermat_little_theorem (p : ℕ) (hp : Nat.Prime p) (a : ℕ) : a ^ (p - 1) % p = 1 := by
  sorry

theorem ende : (decryption e n (encryption e n m)) = m :=
  by
  sorry


import ..mcrl2_mrg.mcrl2_mrg

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

/- The relation used to prove congruence of encapsulation-/
inductive R_encap {x₁ y₁ : mcrl2 α} {A : set α} (R : mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R {x y} (h : R x y) : R_encap x y
| basel : R_encap (encap A x₁) (encap A y₁)
| baser : R_encap (encap A y₁) (encap A x₁)
| step {x y} (h : R x y) : R_encap (encap A x) (encap A y)

theorem R_encap.symm {x₁ y₁ A R} (R_symm : symmetric R) :
symmetric (@R_encap α _ x₁ y₁ A R) :=
begin
  intros x y h,
  cases h,
  { apply R_encap.R,
    exact R_symm h_h},
  { exact R_encap.baser},
  { exact R_encap.basel},
  { exact R_encap.step (R_symm h_h)}
end

theorem bisim.encap {x₁ x₂ : mcrl2 α} {A} (h : x₁ ≈ x₂) :
(encap A x₁) ≈ (encap A x₂) :=
begin
  rcases h with ⟨R, Rx, R_bisim⟩,
  apply exists.intro (R_encap R),
  apply and.intro R_encap.basel,
  apply and.intro,
  { intros x y x' a h₁ h₂,
    cases h₁,
    { have h : ∃y', transition y a y' ∧ option.rel R x' y',
      by exact bisim_lift R_bisim h₁_h h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro w,
      apply and.intro haw,
      apply option.rel.mono,
      { intros a b, exact R_encap.R},
      { assumption}},
    { cases h₂,
      have h : ∃y', transition x₂ a y' ∧ option.rel R h₂_y y',
      by exact bisim_lift R_bisim Rx h₂_h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro (encap A <$> w),
      apply and.intro,
      { apply transition.encap_pass; assumption},
      { cases hRw,
        { apply option.rel.some,
          apply R_encap.step,
          assumption},
        { exact option.rel.none}}},
    { cases h₂,
      have h : ∃y', transition x₁ a y' ∧ option.rel R h₂_y y',
      by exact bisim_lift R_bisim (R_bisim.right Rx) h₂_h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro (encap A <$> w),
      apply and.intro,
      { apply transition.encap_pass; assumption},
      { cases hRw,
        { apply option.rel.some,
          apply R_encap.step,
          assumption},
        { exact option.rel.none}}},
    { cases h₂,
      have h : ∃y', transition h₁_y a y' ∧ option.rel R h₂_y y',
      by exact bisim_lift R_bisim h₁_h h₂_h₂,
      rcases h with ⟨w, haw, hRw⟩,
      apply exists.intro (encap A <$> w),
      apply and.intro,
      { apply transition.encap_pass; assumption},
      { cases hRw,
        { apply option.rel.some,
          apply R_encap.step,
          assumption},
        { exact option.rel.none}}}},
  { exact R_encap.symm R_bisim.right}
end


import o_minimal.o_minimal
import data.set.disjointed
import data.setoid.partition

namespace o_minimal

variables {R : Type*} [DUNLO R]
variables (S : struc R) [definable_constants S] [is_definable_le S R]

namespace struc

def cell : Π {n}, set (finvec n R) → Prop
| 0     s := s = set.univ
| (n+1) s := ∃ (s₀ : set (finvec n R)) (h : cell s₀),
                  s = {x | x.init ∈ s₀}
              ∨
              (∃ (f : finvec n R → R) (hf : def_fun S f),
                  s = {x | x.init ∈ s₀ ∧ x (fin.last n) = f x.init}
                ∨ s = {x | x.init ∈ s₀ ∧ x (fin.last n) ∈ set.Ioi (f x.init)}
                ∨ s = {x | x.init ∈ s₀ ∧ x (fin.last n) ∈ set.Iio (f x.init)})
              ∨
              (∃ (f g : finvec n R → R) (hf : def_fun S f) (hg : def_fun S g),
                (∀ x₀ ∈ s₀, f x₀ < g x₀) ∧
                  s = {x | x.init ∈ s₀ ∧ x (fin.last n) ∈ set.Ioo (f x.init) (g x.init)})

lemma init_definable (n : ℕ) :
  def_fun S (finvec.init : finvec (n+1) R → finvec n R) :=
begin
  sorry
end

lemma cell.definable : ∀ {n} (s : set (finvec n R)) (hs : S.cell s), def_set S s
| 0     s hs := by { cases hs, apply def_set_univ }
| (n+1) s hs :=
begin
  obtain ⟨s₀, hs₀, H|H|H⟩ := hs,
  { cases H,
    show def_set S (finvec.init ⁻¹' s₀), sorry },
  sorry,
  sorry,
end

def decomposition : Π {n} (C : set (set (finvec n R))), Prop
| 0     C := C = {set.univ}
| (n+1) C := C.finite ∧ setoid.is_partition C
            ∧ ∀ s ∈ C, S.cell s
            ∧ decomposition ((set.image finvec.init) '' C)

end struc

end o_minimal