/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Justus Springer

! This file was ported from Lean 3 source module category_theory.limits.lattice
! leanprover-community/mathlib commit c3019c79074b0619edb4b27553a91b2e82242395
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.CompleteLattice
import Mathlib.Data.Fintype.Lattice
import Mathlib.CategoryTheory.Limits.Shapes.Pullbacks
import Mathlib.CategoryTheory.Category.Preorder
import Mathlib.CategoryTheory.Limits.Shapes.Products
import Mathlib.CategoryTheory.Limits.Shapes.FiniteLimits

/-!
# Limits in lattice categories are given by infimums and supremums.
-/

universe w u

open CategoryTheory

open CategoryTheory.Limits

namespace CategoryTheory.Limits.CompleteLattice

section Semilattice

variable {α : Type u}

variable {J : Type w} [SmallCategory J] [FinCategory J]

/-- The limit cone over any functor from a finite diagram into a `SemilatticeInf` with `OrderTop`.
-/
def finiteLimitCone [SemilatticeInf α] [OrderTop α] (F : J ⥤ α) : LimitCone F where
  cone :=
    { pt := Finset.univ.inf F.obj
      π := { app := fun j => homOfLE (Finset.inf_le (Fintype.complete _)) } }
  isLimit := { lift := fun s => homOfLE (Finset.le_inf fun j _ => (s.π.app j).down.down) }
#align category_theory.limits.complete_lattice.finite_limit_cone CategoryTheory.Limits.CompleteLattice.finiteLimitCone

/--
The colimit cocone over any functor from a finite diagram into a `SemilatticeSup` with `OrderBot`.
-/
def finiteColimitCocone [SemilatticeSup α] [OrderBot α] (F : J ⥤ α) : ColimitCocone F where
  cocone :=
    { pt := Finset.univ.sup F.obj
      ι := { app := fun i => homOfLE (Finset.le_sup (Fintype.complete _)) } }
  isColimit := { desc := fun s => homOfLE (Finset.sup_le fun j _ => (s.ι.app j).down.down) }
#align category_theory.limits.complete_lattice.finite_colimit_cocone CategoryTheory.Limits.CompleteLattice.finiteColimitCocone

-- see Note [lower instance priority]
instance (priority := 100) hasFiniteLimits_of_semilatticeInf_orderTop [SemilatticeInf α]
    [OrderTop α] : HasFiniteLimits α := ⟨by
  intro J 𝒥₁ 𝒥₂
  exact { has_limit := fun F => HasLimit.mk (finiteLimitCone F) }⟩
#align category_theory.limits.complete_lattice.has_finite_limits_of_semilattice_inf_order_top CategoryTheory.Limits.CompleteLattice.hasFiniteLimits_of_semilatticeInf_orderTop

-- see Note [lower instance priority]
instance (priority := 100) hasFiniteColimits_of_semilatticeSup_orderBot [SemilatticeSup α]
    [OrderBot α] : HasFiniteColimits α := ⟨by
  intro J 𝒥₁ 𝒥₂
  exact { has_colimit := fun F => HasColimit.mk (finiteColimitCocone F) }⟩
#align category_theory.limits.complete_lattice.has_finite_colimits_of_semilattice_sup_order_bot CategoryTheory.Limits.CompleteLattice.hasFiniteColimits_of_semilatticeSup_orderBot

/-- The limit of a functor from a finite diagram into a `SemilatticeInf` with `OrderTop` is the
infimum of the objects in the image.
-/
theorem finite_limit_eq_finset_univ_inf [SemilatticeInf α] [OrderTop α] (F : J ⥤ α) :
    limit F = Finset.univ.inf F.obj :=
  (IsLimit.conePointUniqueUpToIso (limit.isLimit F) (finiteLimitCone F).isLimit).to_eq
#align category_theory.limits.complete_lattice.finite_limit_eq_finset_univ_inf CategoryTheory.Limits.CompleteLattice.finite_limit_eq_finset_univ_inf

/-- The colimit of a functor from a finite diagram into a `SemilatticeSup` with `OrderBot`
is the supremum of the objects in the image.
-/
theorem finite_colimit_eq_finset_univ_sup [SemilatticeSup α] [OrderBot α] (F : J ⥤ α) :
    colimit F = Finset.univ.sup F.obj :=
  (IsColimit.coconePointUniqueUpToIso (colimit.isColimit F) (finiteColimitCocone F).isColimit).to_eq
#align category_theory.limits.complete_lattice.finite_colimit_eq_finset_univ_sup CategoryTheory.Limits.CompleteLattice.finite_colimit_eq_finset_univ_sup

/--
A finite product in the category of a `SemilatticeInf` with `OrderTop` is the same as the infimum.
-/
theorem finite_product_eq_finset_inf [SemilatticeInf α] [OrderTop α] {ι : Type u} [Fintype ι]
    (f : ι → α) : (∏ f) = Fintype.elems.inf f := by
  trans
  exact
    (IsLimit.conePointUniqueUpToIso (limit.isLimit _)
        (finiteLimitCone (Discrete.functor f)).isLimit).to_eq
  change Finset.univ.inf (f ∘ discreteEquiv.toEmbedding) = Fintype.elems.inf f
  simp only [← Finset.inf_map, Finset.univ_map_equiv_to_embedding]
  rfl
#align category_theory.limits.complete_lattice.finite_product_eq_finset_inf CategoryTheory.Limits.CompleteLattice.finite_product_eq_finset_inf

/-- A finite coproduct in the category of a `SemilatticeSup` with `OrderBot` is the same as the
supremum.
-/
theorem finite_coproduct_eq_finset_sup [SemilatticeSup α] [OrderBot α] {ι : Type u} [Fintype ι]
    (f : ι → α) : (∐ f) = Fintype.elems.sup f := by
  trans
  exact
    (IsColimit.coconePointUniqueUpToIso (colimit.isColimit _)
        (finiteColimitCocone (Discrete.functor f)).isColimit).to_eq
  change Finset.univ.sup (f ∘ discreteEquiv.toEmbedding) = Fintype.elems.sup f
  simp only [← Finset.sup_map, Finset.univ_map_equiv_to_embedding]
  rfl
#align category_theory.limits.complete_lattice.finite_coproduct_eq_finset_sup CategoryTheory.Limits.CompleteLattice.finite_coproduct_eq_finset_sup

-- see Note [lower instance priority]
instance (priority := 100) [SemilatticeInf α] [OrderTop α] : HasBinaryProducts α := by
  have : ∀ x y : α, HasLimit (pair x y) :=
    by
    letI := hasFiniteLimits_of_hasFiniteLimits_of_size.{u} α
    infer_instance
  apply hasBinaryProducts_of_hasLimit_pair

/-- The binary product in the category of a `SemilatticeInf` with `OrderTop` is the same as the
infimum.
-/
@[simp]
theorem prod_eq_inf [SemilatticeInf α] [OrderTop α] (x y : α) : Limits.prod x y = x ⊓ y :=
  calc
    Limits.prod x y = limit (pair x y) := rfl
    _ = Finset.univ.inf (pair x y).obj := by rw [finite_limit_eq_finset_univ_inf (pair.{u} x y)]
    _ = x ⊓ (y ⊓ ⊤) := rfl
    -- Note: finset.inf is realized as a fold, hence the definitional equality
    _ = x ⊓ y := by rw [inf_top_eq]
#align category_theory.limits.complete_lattice.prod_eq_inf CategoryTheory.Limits.CompleteLattice.prod_eq_inf

-- see Note [lower instance priority]
instance (priority := 100) [SemilatticeSup α] [OrderBot α] : HasBinaryCoproducts α := by
  have : ∀ x y : α, HasColimit (pair x y) :=
    by
    letI := hasFiniteColimits_of_hasFiniteColimits_of_size.{u} α
    infer_instance
  apply hasBinaryCoproducts_of_hasColimit_pair

/-- The binary coproduct in the category of a `semilattice_sup` with `order_bot` is the same as the
supremum.
-/
@[simp]
theorem coprod_eq_sup [SemilatticeSup α] [OrderBot α] (x y : α) : Limits.coprod x y = x ⊔ y :=
  calc
    Limits.coprod x y = colimit (pair x y) := rfl
    _ = Finset.univ.sup (pair x y).obj := by rw [finite_colimit_eq_finset_univ_sup (pair x y)]
    _ = x ⊔ (y ⊔ ⊥) := rfl
    -- Note: finset.sup is realized as a fold, hence the definitional equality
    _ = x ⊔ y := by rw [sup_bot_eq]
#align category_theory.limits.complete_lattice.coprod_eq_sup CategoryTheory.Limits.CompleteLattice.coprod_eq_sup

/-- The pullback in the category of a `semilattice_inf` with `order_top` is the same as the infimum
over the objects.
-/
@[simp]
theorem pullback_eq_inf [SemilatticeInf α] [OrderTop α] {x y z : α} (f : x ⟶ z) (g : y ⟶ z) :
    pullback f g = x ⊓ y :=
  calc
    pullback f g = limit (cospan f g) := rfl
    _ = Finset.univ.inf (cospan f g).obj := by rw [finite_limit_eq_finset_univ_inf]
    _ = z ⊓ (x ⊓ (y ⊓ ⊤)) := rfl
    _ = z ⊓ (x ⊓ y) := by rw [inf_top_eq]
    _ = x ⊓ y := inf_eq_right.mpr (inf_le_of_left_le f.le)

#align category_theory.limits.complete_lattice.pullback_eq_inf CategoryTheory.Limits.CompleteLattice.pullback_eq_inf

/-- The pushout in the category of a `semilattice_sup` with `order_bot` is the same as the supremum
over the objects.
-/
@[simp]
theorem pushout_eq_sup [SemilatticeSup α] [OrderBot α] (x y z : α) (f : z ⟶ x) (g : z ⟶ y) :
    pushout f g = x ⊔ y :=
  calc
    pushout f g = colimit (span f g) := rfl
    _ = Finset.univ.sup (span f g).obj := by rw [finite_colimit_eq_finset_univ_sup]
    _ = z ⊔ (x ⊔ (y ⊔ ⊥)) := rfl
    _ = z ⊔ (x ⊔ y) := by rw [sup_bot_eq]
    _ = x ⊔ y := sup_eq_right.mpr (le_sup_of_le_left f.le)

#align category_theory.limits.complete_lattice.pushout_eq_sup CategoryTheory.Limits.CompleteLattice.pushout_eq_sup

end Semilattice

variable {α : Type u} [CompleteLattice α]

variable {J : Type u} [SmallCategory J]

/-- The limit cone over any functor into a complete lattice.
-/
def limitCone (F : J ⥤ α) : LimitCone F where
  cone :=
    { pt := infᵢ F.obj
      π := { app := fun j => homOfLE (CompleteLattice.infₛ_le _ _ (Set.mem_range_self _)) } }
  isLimit :=
    { lift := fun s =>
        homOfLE (CompleteLattice.le_infₛ _ _ (by rintro _ ⟨j, rfl⟩; exact (s.π.app j).le)) }
#align category_theory.limits.complete_lattice.limit_cone CategoryTheory.Limits.CompleteLattice.limitCone

/-- The colimit cocone over any functor into a complete lattice.
-/
def colimitCocone (F : J ⥤ α) : ColimitCocone F where
  cocone :=
    { pt := supᵢ F.obj
      ι := { app := fun j => homOfLE (CompleteLattice.le_supₛ _ _ (Set.mem_range_self _)) } }
  isColimit :=
    { desc := fun s =>
        homOfLE (CompleteLattice.supₛ_le _ _ (by rintro _ ⟨j, rfl⟩; exact (s.ι.app j).le)) }
#align category_theory.limits.complete_lattice.colimit_cocone CategoryTheory.Limits.CompleteLattice.colimitCocone

-- It would be nice to only use the `Inf` half of the complete lattice, but
-- this seems not to have been described separately.
-- see Note [lower instance priority]
instance (priority := 100) hasLimits_of_completeLattice : HasLimits α where
  has_limits_of_shape _ := { has_limit := fun F => HasLimit.mk (limitCone F) }
#align category_theory.limits.complete_lattice.has_limits_of_complete_lattice CategoryTheory.Limits.CompleteLattice.hasLimits_of_completeLattice

-- see Note [lower instance priority]
instance (priority := 100) hasColimits_of_completeLattice : HasColimits α where
  has_colimits_of_shape _ := { has_colimit := fun F => HasColimit.mk (colimitCocone F) }
#align category_theory.limits.complete_lattice.has_colimits_of_complete_lattice CategoryTheory.Limits.CompleteLattice.hasColimits_of_completeLattice

/-- The limit of a functor into a complete lattice is the infimum of the objects in the image.
-/
theorem limit_eq_infᵢ (F : J ⥤ α) : limit F = infᵢ F.obj :=
  (IsLimit.conePointUniqueUpToIso (limit.isLimit F) (limitCone F).isLimit).to_eq
#align category_theory.limits.complete_lattice.limit_eq_infi CategoryTheory.Limits.CompleteLattice.limit_eq_infᵢ

/-- The colimit of a functor into a complete lattice is the supremum of the objects in the image.
-/
theorem colimit_eq_supᵢ (F : J ⥤ α) : colimit F = supᵢ F.obj :=
  (IsColimit.coconePointUniqueUpToIso (colimit.isColimit F) (colimitCocone F).isColimit).to_eq
#align category_theory.limits.complete_lattice.colimit_eq_supr CategoryTheory.Limits.CompleteLattice.colimit_eq_supᵢ

end CategoryTheory.Limits.CompleteLattice


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

! This file was ported from Lean 3 source module combinatorics.additive.behrend
! leanprover-community/mathlib commit ceb887ddf3344dab425292e497fa2af91498437c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.InnerProductSpace.PiL2
import Mathbin.Combinatorics.Additive.SalemSpencer
import Mathbin.Combinatorics.Pigeonhole
import Mathbin.Data.Complex.ExponentialBounds

/-!
# Behrend's bound on Roth numbers

This file proves Behrend's lower bound on Roth numbers. This says that we can find a subset of
`{1, ..., n}` of size `n / exp (O (sqrt (log n)))` which does not contain arithmetic progressions of
length `3`.

The idea is that the sphere (in the `n` dimensional Euclidean space) doesn't contain arithmetic
progressions (literally) because the corresponding ball is strictly convex. Thus we can take
integer points on that sphere and map them onto `ℕ` in a way that preserves arithmetic progressions
(`behrend.map`).

## Main declarations

* `behrend.sphere`: The intersection of the Euclidean sphere with the positive integer quadrant.
  This is the set that we will map on `ℕ`.
* `behrend.map`: Given a natural number `d`, `behrend.map d : ℕⁿ → ℕ` reads off the coordinates as
  digits in base `d`.
* `behrend.card_sphere_le_roth_number_nat`: Implicit lower bound on Roth numbers in terms of
  `behrend.sphere`.
* `behrend.roth_lower_bound`: Behrend's explicit lower bound on Roth numbers.

## References

* [Bryan Gillespie, *Behrend’s Construction*]
  (http://www.epsilonsmall.com/resources/behrends-construction/behrend.pdf)
* Behrend, F. A., "On sets of integers which contain no three terms in arithmetical progression"
* [Wikipedia, *Salem-Spencer set*](https://en.wikipedia.org/wiki/Salem–Spencer_set)

## Tags

Salem-Spencer, Behrend construction, arithmetic progression, sphere, strictly convex
-/

open Finset

open Nat hiding log

open Real

open BigOperators Pointwise

namespace Behrend

variable {α β : Type _} {n d k N : ℕ} {x : Fin n → ℕ}

/-!
### Turning the sphere into a Salem-Spencer set

We define `behrend.sphere`, the intersection of the $$L^2$$ sphere with the positive quadrant of
integer points. Because the $$L^2$$ closed ball is strictly convex, the $$L^2$$ sphere and
`behrend.sphere` are Salem-Spencer (`add_salem_spencer_sphere`). Then we can turn this set in
`fin n → ℕ` into a set in `ℕ` using `behrend.map`, which preserves `add_salem_spencer` because it is
an additive monoid homomorphism.
-/

/-- The box `{0, ..., d - 1}^n` as a finset. -/
def box (n d : ℕ) : Finset (Fin n → ℕ) :=
  Fintype.piFinset fun _ => range d
#align behrend.box Behrend.box

theorem mem_box : x ∈ box n d ↔ ∀ i, x i < d := by simp only [box, Fintype.mem_piFinset, mem_range]
#align behrend.mem_box Behrend.mem_box

@[simp]
theorem card_box : (box n d).card = d ^ n := by simp [box]
#align behrend.card_box Behrend.card_box

@[simp]
theorem box_zero : box (n + 1) 0 = ∅ := by simp [box]
#align behrend.box_zero Behrend.box_zero

/-- The intersection of the sphere of radius `sqrt k` with the integer points in the positive
quadrant. -/
def sphere (n d k : ℕ) : Finset (Fin n → ℕ) :=
  (box n d).filterₓ fun x => (∑ i, x i ^ 2) = k
#align behrend.sphere Behrend.sphere

theorem sphere_zero_subset : sphere n d 0 ⊆ 0 := fun x => by
  simp (config := { contextual := true }) [sphere, Function.funext_iff]
#align behrend.sphere_zero_subset Behrend.sphere_zero_subset

@[simp]
theorem sphere_zero_right (n k : ℕ) : sphere (n + 1) 0 k = ∅ := by simp [sphere]
#align behrend.sphere_zero_right Behrend.sphere_zero_right

theorem sphere_subset_box : sphere n d k ⊆ box n d :=
  filter_subset _ _
#align behrend.sphere_subset_box Behrend.sphere_subset_box

theorem norm_of_mem_sphere {x : Fin n → ℕ} (hx : x ∈ sphere n d k) :
    ‖(PiLp.equiv 2 _).symm (coe ∘ x : Fin n → ℝ)‖ = sqrt k :=
  by
  rw [EuclideanSpace.norm_eq]
  dsimp
  simp_rw [abs_cast, ← cast_pow, ← cast_sum, (mem_filter.1 hx).2]
#align behrend.norm_of_mem_sphere Behrend.norm_of_mem_sphere

theorem sphere_subset_preimage_metric_sphere :
    (sphere n d k : Set (Fin n → ℕ)) ⊆
      (fun x : Fin n → ℕ => (PiLp.equiv 2 _).symm (coe ∘ x : Fin n → ℝ)) ⁻¹'
        Metric.sphere (0 : PiLp 2 fun _ : Fin n => ℝ) (sqrt k) :=
  fun x hx => by rw [Set.mem_preimage, mem_sphere_zero_iff_norm, norm_of_mem_sphere hx]
#align behrend.sphere_subset_preimage_metric_sphere Behrend.sphere_subset_preimage_metric_sphere

/-- The map that appears in Behrend's bound on Roth numbers. -/
@[simps]
def map (d : ℕ) : (Fin n → ℕ) →+ ℕ
    where
  toFun a := ∑ i, a i * d ^ (i : ℕ)
  map_zero' := by simp_rw [Pi.zero_apply, MulZeroClass.zero_mul, sum_const_zero]
  map_add' a b := by simp_rw [Pi.add_apply, add_mul, sum_add_distrib]
#align behrend.map Behrend.map

@[simp]
theorem map_zero (d : ℕ) (a : Fin 0 → ℕ) : map d a = 0 := by simp [map]
#align behrend.map_zero Behrend.map_zero

theorem map_succ (a : Fin (n + 1) → ℕ) :
    map d a = a 0 + (∑ x : Fin n, a x.succ * d ^ (x : ℕ)) * d := by
  simp [map, Fin.sum_univ_succ, pow_succ', ← mul_assoc, ← sum_mul]
#align behrend.map_succ Behrend.map_succ

theorem map_succ' (a : Fin (n + 1) → ℕ) : map d a = a 0 + map d (a ∘ Fin.succ) * d :=
  map_succ _
#align behrend.map_succ' Behrend.map_succ'

theorem map_monotone (d : ℕ) : Monotone (map d : (Fin n → ℕ) → ℕ) := fun x y h =>
  by
  dsimp
  exact sum_le_sum fun i _ => Nat.mul_le_mul_right _ <| h i
#align behrend.map_monotone Behrend.map_monotone

theorem map_mod (a : Fin n.succ → ℕ) : map d a % d = a 0 % d := by
  rw [map_succ, Nat.add_mul_mod_self_right]
#align behrend.map_mod Behrend.map_mod

theorem map_eq_iff {x₁ x₂ : Fin n.succ → ℕ} (hx₁ : ∀ i, x₁ i < d) (hx₂ : ∀ i, x₂ i < d) :
    map d x₁ = map d x₂ ↔ x₁ 0 = x₂ 0 ∧ map d (x₁ ∘ Fin.succ) = map d (x₂ ∘ Fin.succ) :=
  by
  refine' ⟨fun h => _, fun h => by rw [map_succ', map_succ', h.1, h.2]⟩
  have : x₁ 0 = x₂ 0 := by
    rw [← mod_eq_of_lt (hx₁ _), ← map_mod, ← mod_eq_of_lt (hx₂ _), ← map_mod, h]
  rw [map_succ, map_succ, this, add_right_inj, mul_eq_mul_right_iff] at h
  exact ⟨this, h.resolve_right (pos_of_gt (hx₁ 0)).ne'⟩
#align behrend.map_eq_iff Behrend.map_eq_iff

theorem map_injOn : { x : Fin n → ℕ | ∀ i, x i < d }.InjOn (map d) :=
  by
  intro x₁ hx₁ x₂ hx₂ h
  induction' n with n ih
  · simp
  ext i
  have x := (map_eq_iff hx₁ hx₂).1 h
  refine' Fin.cases x.1 (congr_fun <| ih (fun _ => _) (fun _ => _) x.2) i
  · exact hx₁ _
  · exact hx₂ _
#align behrend.map_inj_on Behrend.map_injOn

theorem map_le_of_mem_box (hx : x ∈ box n d) :
    map (2 * d - 1) x ≤ ∑ i : Fin n, (d - 1) * (2 * d - 1) ^ (i : ℕ) :=
  map_monotone (2 * d - 1) fun _ => Nat.le_pred_of_lt <| mem_box.1 hx _
#align behrend.map_le_of_mem_box Behrend.map_le_of_mem_box

theorem addSalemSpencer_sphere : AddSalemSpencer (sphere n d k : Set (Fin n → ℕ)) :=
  by
  set f : (Fin n → ℕ) →+ EuclideanSpace ℝ (Fin n) :=
    { toFun := fun f => (coe : ℕ → ℝ) ∘ f
      map_zero' := funext fun _ => cast_zero
      map_add' := fun _ _ => funext fun _ => cast_add _ _ }
  refine' AddSalemSpencer.of_image (f.to_add_freiman_hom (sphere n d k) 2) _ _
  · exact cast_injective.comp_left.inj_on _
  refine' (addSalemSpencer_sphere 0 <| sqrt k).mono (Set.image_subset_iff.2 fun x => _)
  rw [Set.mem_preimage, mem_sphere_zero_iff_norm]
  exact norm_of_mem_sphere
#align behrend.add_salem_spencer_sphere Behrend.addSalemSpencer_sphere

theorem addSalemSpencer_image_sphere :
    AddSalemSpencer ((sphere n d k).image (map (2 * d - 1)) : Set ℕ) :=
  by
  rw [coe_image]
  refine'
    @AddSalemSpencer.image _ (Fin n → ℕ) ℕ _ _ (sphere n d k) _ (map (2 * d - 1))
      (map_inj_on.mono _) addSalemSpencer_sphere
  rw [Set.add_subset_iff]
  rintro a ha b hb i
  have hai := mem_box.1 (sphere_subset_box ha) i
  have hbi := mem_box.1 (sphere_subset_box hb) i
  rw [lt_tsub_iff_right, ← succ_le_iff, two_mul]
  exact (add_add_add_comm _ _ 1 1).trans_le (add_le_add hai hbi)
#align behrend.add_salem_spencer_image_sphere Behrend.addSalemSpencer_image_sphere

theorem sum_sq_le_of_mem_box (hx : x ∈ box n d) : (∑ i : Fin n, x i ^ 2) ≤ n * (d - 1) ^ 2 :=
  by
  rw [mem_box] at hx
  have : ∀ i, x i ^ 2 ≤ (d - 1) ^ 2 := fun i =>
    Nat.pow_le_pow_of_le_left (Nat.le_pred_of_lt (hx i)) _
  exact (sum_le_card_nsmul univ _ _ fun i _ => this i).trans (by rw [card_fin, smul_eq_mul])
#align behrend.sum_sq_le_of_mem_box Behrend.sum_sq_le_of_mem_box

theorem sum_eq : (∑ i : Fin n, d * (2 * d + 1) ^ (i : ℕ)) = ((2 * d + 1) ^ n - 1) / 2 :=
  by
  refine' (Nat.div_eq_of_eq_mul_left zero_lt_two _).symm
  rw [← sum_range fun i => d * (2 * d + 1) ^ (i : ℕ), ← mul_sum, mul_right_comm, mul_comm d, ←
    geom_sum_mul_add, add_tsub_cancel_right, mul_comm]
#align behrend.sum_eq Behrend.sum_eq

theorem sum_lt : (∑ i : Fin n, d * (2 * d + 1) ^ (i : ℕ)) < (2 * d + 1) ^ n :=
  sum_eq.trans_lt <| (Nat.div_le_self _ 2).trans_lt <| pred_lt (pow_pos (succ_pos _) _).ne'
#align behrend.sum_lt Behrend.sum_lt

theorem card_sphere_le_rothNumberNat (n d k : ℕ) :
    (sphere n d k).card ≤ rothNumberNat ((2 * d - 1) ^ n) :=
  by
  cases n
  · refine' (card_le_univ _).trans_eq _
    rw [pow_zero]
    exact Fintype.card_unique
  cases d
  · simp
  refine' add_salem_spencer_image_sphere.le_roth_number_nat _ _ (card_image_of_inj_on _)
  · simp only [subset_iff, mem_image, and_imp, forall_exists_index, mem_range,
      forall_apply_eq_imp_iff₂, sphere, mem_filter]
    rintro _ x hx _ rfl
    exact (map_le_of_mem_box hx).trans_lt sum_lt
  refine' map_inj_on.mono fun x => _
  simp only [mem_coe, sphere, mem_filter, mem_box, and_imp, two_mul]
  exact fun h _ i => (h i).trans_le le_self_add
#align behrend.card_sphere_le_roth_number_nat Behrend.card_sphere_le_rothNumberNat

/-!
### Optimization

Now that we know how to turn the integer points of any sphere into a Salem-Spencer set, we find a
sphere containing many integer points by the pigeonhole principle. This gives us an implicit bound
that we then optimize by tweaking the parameters. The (almost) optimal parameters are
`behrend.n_value` and `behrend.d_value`.
-/

theorem exists_large_sphere_aux (n d : ℕ) :
    ∃ k ∈ range (n * (d - 1) ^ 2 + 1),
      (↑(d ^ n) / (↑(n * (d - 1) ^ 2) + 1) : ℝ) ≤ (sphere n d k).card :=
  by
  refine' exists_le_card_fiber_of_nsmul_le_card_of_maps_to (fun x hx => _) nonempty_range_succ _
  · rw [mem_range, lt_succ_iff]
    exact sum_sq_le_of_mem_box hx
  · rw [card_range, _root_.nsmul_eq_mul, mul_div_assoc', cast_add_one, mul_div_cancel_left,
      card_box]
    exact (cast_add_one_pos _).ne'
#align behrend.exists_large_sphere_aux Behrend.exists_large_sphere_aux

theorem exists_large_sphere (n d : ℕ) : ∃ k, (d ^ n / ↑(n * d ^ 2) : ℝ) ≤ (sphere n d k).card :=
  by
  obtain ⟨k, -, hk⟩ := exists_large_sphere_aux n d
  refine' ⟨k, _⟩
  obtain rfl | hn := n.eq_zero_or_pos
  · simp
  obtain rfl | hd := d.eq_zero_or_pos
  · simp
  rw [← cast_pow]
  refine' (div_le_div_of_le_left _ _ _).trans hk
  · exact cast_nonneg _
  · exact cast_add_one_pos _
  simp only [← le_sub_iff_add_le', cast_mul, ← mul_sub, cast_pow, cast_sub hd, sub_sq, one_pow,
    cast_one, mul_one, sub_add, sub_sub_self]
  apply one_le_mul_of_one_le_of_one_le
  · rwa [one_le_cast]
  rw [le_sub_iff_add_le]
  norm_num
  exact one_le_cast.2 hd
#align behrend.exists_large_sphere Behrend.exists_large_sphere

theorem bound_aux' (n d : ℕ) : (d ^ n / ↑(n * d ^ 2) : ℝ) ≤ rothNumberNat ((2 * d - 1) ^ n) :=
  let ⟨k, h⟩ := exists_large_sphere n d
  h.trans <| cast_le.2 <| card_sphere_le_rothNumberNat _ _ _
#align behrend.bound_aux' Behrend.bound_aux'

theorem bound_aux (hd : d ≠ 0) (hn : 2 ≤ n) :
    (d ^ (n - 2) / n : ℝ) ≤ rothNumberNat ((2 * d - 1) ^ n) :=
  by
  convert bound_aux' n d using 1
  rw [cast_mul, cast_pow, mul_comm, ← div_div, pow_sub₀ _ _ hn, ← div_eq_mul_inv]
  rwa [cast_ne_zero]
#align behrend.bound_aux Behrend.bound_aux

open Filter Topology

open Real

section NumericalBounds

theorem log_two_mul_two_le_sqrt_log_eight : log 2 * 2 ≤ sqrt (log 8) :=
  by
  rw [show (8 : ℝ) = 2 ^ ((3 : ℕ) : ℝ) by norm_num1, log_rpow zero_lt_two (3 : ℕ)]
  apply le_sqrt_of_sq_le
  rw [mul_pow, sq (log 2), mul_assoc, mul_comm]
  refine' mul_le_mul_of_nonneg_right _ (log_nonneg one_le_two)
  rw [← le_div_iff]
  apply log_two_lt_d9.le.trans
  all_goals norm_num1
#align behrend.log_two_mul_two_le_sqrt_log_eight Behrend.log_two_mul_two_le_sqrt_log_eight

theorem two_div_one_sub_two_div_e_le_eight : 2 / (1 - 2 / exp 1) ≤ 8 :=
  by
  rw [div_le_iff, mul_sub, mul_one, mul_div_assoc', le_sub_comm, div_le_iff (exp_pos _)]
  · linarith [exp_one_gt_d9]
  rw [sub_pos, div_lt_one] <;> exact exp_one_gt_d9.trans' (by norm_num)
#align behrend.two_div_one_sub_two_div_e_le_eight Behrend.two_div_one_sub_two_div_e_le_eight

theorem le_sqrt_log (hN : 4096 ≤ N) : log (2 / (1 - 2 / exp 1)) * (69 / 50) ≤ sqrt (log ↑N) :=
  by
  have : ((12 : ℕ) : ℝ) * log 2 ≤ log N :=
    by
    rw [← log_rpow zero_lt_two, log_le_log, rpow_nat_cast]
    · norm_num1
      exact_mod_cast hN
    · exact rpow_pos_of_pos zero_lt_two _
    rw [cast_pos]
    exact hN.trans_lt' (by norm_num1)
  refine'
    (mul_le_mul_of_nonneg_right
            ((log_le_log _ <| by norm_num1).2 two_div_one_sub_two_div_e_le_eight) <|
          by norm_num1).trans
      _
  · refine' div_pos zero_lt_two _
    rw [sub_pos, div_lt_one (exp_pos _)]
    exact exp_one_gt_d9.trans_le' (by norm_num1)
  have l8 : log 8 = (3 : ℕ) * log 2 :=
    by
    rw [← log_rpow zero_lt_two, rpow_nat_cast]
    norm_num
  rw [l8, cast_bit1, cast_one]
  apply le_sqrt_of_sq_le (le_trans _ this)
  simp only [cast_bit0, cast_bit1, cast_one]
  rw [mul_right_comm, mul_pow, sq (log 2), ← mul_assoc]
  apply mul_le_mul_of_nonneg_right _ (log_nonneg one_le_two)
  rw [← le_div_iff']
  · exact log_two_lt_d9.le.trans (by norm_num1)
  exact sq_pos_of_ne_zero _ (by norm_num1)
#align behrend.le_sqrt_log Behrend.le_sqrt_log

theorem exp_neg_two_mul_le {x : ℝ} (hx : 0 < x) : exp (-2 * x) < exp (2 - ⌈x⌉₊) / ⌈x⌉₊ :=
  by
  have h₁ := ceil_lt_add_one hx.le
  have h₂ : 1 - x ≤ 2 - ⌈x⌉₊ := by
    rw [le_sub_iff_add_le]
    apply (add_le_add_left h₁.le _).trans_eq
    rw [← add_assoc, sub_add_cancel]
    rfl
  have h₃ : exp (-(x + 1)) ≤ 1 / (x + 1) :=
    by
    rw [exp_neg, inv_eq_one_div]
    refine' one_div_le_one_div_of_le (add_pos hx zero_lt_one) _
    apply le_trans _ (add_one_le_exp_of_nonneg <| add_nonneg hx.le zero_le_one)
    exact le_add_of_nonneg_right zero_le_one
  refine' lt_of_le_of_lt _ (div_lt_div_of_lt_left (exp_pos _) (cast_pos.2 <| ceil_pos.2 hx) h₁)
  refine' le_trans _ (div_le_div_of_le_of_nonneg (exp_le_exp.2 h₂) <| add_nonneg hx.le zero_le_one)
  rw [le_div_iff (add_pos hx zero_lt_one), ← le_div_iff' (exp_pos _), ← exp_sub, neg_mul,
    sub_neg_eq_add, two_mul, sub_add_add_cancel, add_comm _ x]
  refine' le_trans _ (add_one_le_exp_of_nonneg <| add_nonneg hx.le zero_le_one)
  exact le_add_of_nonneg_right zero_le_one
#align behrend.exp_neg_two_mul_le Behrend.exp_neg_two_mul_le

theorem div_lt_floor {x : ℝ} (hx : 2 / (1 - 2 / exp 1) ≤ x) : x / exp 1 < (⌊x / 2⌋₊ : ℝ) :=
  by
  apply lt_of_le_of_lt _ (sub_one_lt_floor _)
  have : 0 < 1 - 2 / exp 1 := by
    rw [sub_pos, div_lt_one (exp_pos _)]
    exact lt_of_le_of_lt (by norm_num) exp_one_gt_d9
  rwa [le_sub_comm, div_eq_mul_one_div x, div_eq_mul_one_div x, ← mul_sub, div_sub', ←
    div_eq_mul_one_div, mul_div_assoc', one_le_div, ← div_le_iff this]
  · exact zero_lt_two
  · exact two_ne_zero
#align behrend.div_lt_floor Behrend.div_lt_floor

theorem ceil_lt_mul {x : ℝ} (hx : 50 / 19 ≤ x) : (⌈x⌉₊ : ℝ) < 1.38 * x :=
  by
  refine' (ceil_lt_add_one <| hx.trans' <| by norm_num).trans_le _
  rwa [← le_sub_iff_add_le', ← sub_one_mul, show (69 / 50 - 1 : ℝ) = (50 / 19)⁻¹ by norm_num1, ←
    div_eq_inv_mul, one_le_div]
  norm_num1
#align behrend.ceil_lt_mul Behrend.ceil_lt_mul

end NumericalBounds

/-- The (almost) optimal value of `n` in `behrend.bound_aux`. -/
noncomputable def nValue (N : ℕ) : ℕ :=
  ⌈sqrt (log N)⌉₊
#align behrend.n_value Behrend.nValue

/-- The (almost) optimal value of `d` in `behrend.bound_aux`. -/
noncomputable def dValue (N : ℕ) : ℕ :=
  ⌊(N : ℝ) ^ (1 / nValue N : ℝ) / 2⌋₊
#align behrend.d_value Behrend.dValue

theorem nValue_pos (hN : 2 ≤ N) : 0 < nValue N :=
  ceil_pos.2 <| Real.sqrt_pos.2 <| log_pos <| one_lt_cast.2 <| hN
#align behrend.n_value_pos Behrend.nValue_pos

theorem two_le_nValue (hN : 3 ≤ N) : 2 ≤ nValue N :=
  by
  refine' succ_le_of_lt (lt_ceil.2 <| lt_sqrt_of_sq_lt _)
  rw [cast_one, one_pow, lt_log_iff_exp_lt]
  refine' lt_of_lt_of_le _ (cast_le.2 hN)
  · exact exp_one_lt_d9.trans_le (by norm_num)
  rw [cast_pos]
  exact (zero_lt_succ _).trans_le hN
#align behrend.two_le_n_value Behrend.two_le_nValue

theorem three_le_nValue (hN : 64 ≤ N) : 3 ≤ nValue N :=
  by
  rw [n_value, ← lt_iff_add_one_le, lt_ceil, cast_two]
  apply lt_sqrt_of_sq_lt
  have : (2 : ℝ) ^ ((6 : ℕ) : ℝ) ≤ N := by
    rw [rpow_nat_cast]
    exact (cast_le.2 hN).trans' (by norm_num1)
  apply lt_of_lt_of_le _ ((log_le_log (rpow_pos_of_pos zero_lt_two _) _).2 this)
  rw [log_rpow zero_lt_two, cast_bit0, cast_bit1, cast_one, ← div_lt_iff']
  · exact log_two_gt_d9.trans_le' (by norm_num1)
  · norm_num1
  rw [cast_pos]
  exact hN.trans_lt' (by norm_num1)
#align behrend.three_le_n_value Behrend.three_le_nValue

theorem dValue_pos (hN₃ : 8 ≤ N) : 0 < dValue N :=
  by
  have hN₀ : 0 < (N : ℝ) := cast_pos.2 (succ_pos'.trans_le hN₃)
  rw [d_value, floor_pos, ← log_le_log zero_lt_one, log_one, log_div _ two_ne_zero, log_rpow hN₀,
    div_mul_eq_mul_div, one_mul, sub_nonneg, le_div_iff]
  · have : (n_value N : ℝ) ≤ 2 * sqrt (log N) :=
      by
      apply (ceil_lt_add_one <| sqrt_nonneg _).le.trans
      rw [two_mul, add_le_add_iff_left]
      apply le_sqrt_of_sq_le
      rw [one_pow, le_log_iff_exp_le hN₀]
      exact (exp_one_lt_d9.le.trans <| by norm_num).trans (cast_le.2 hN₃)
    apply (mul_le_mul_of_nonneg_left this <| log_nonneg one_le_two).trans _
    rw [← mul_assoc, ← le_div_iff (Real.sqrt_pos.2 <| log_pos <| one_lt_cast.2 _), div_sqrt]
    · apply log_two_mul_two_le_sqrt_log_eight.trans
      apply Real.sqrt_le_sqrt
      rw [log_le_log _ hN₀]
      · exact_mod_cast hN₃
      · norm_num
    exact hN₃.trans_lt' (by norm_num)
  · exact cast_pos.2 (n_value_pos <| hN₃.trans' <| by norm_num)
  · exact (rpow_pos_of_pos hN₀ _).ne'
  · exact div_pos (rpow_pos_of_pos hN₀ _) zero_lt_two
#align behrend.d_value_pos Behrend.dValue_pos

theorem le_N (hN : 2 ≤ N) : (2 * dValue N - 1) ^ nValue N ≤ N :=
  by
  have : (2 * d_value N - 1) ^ n_value N ≤ (2 * d_value N) ^ n_value N :=
    Nat.pow_le_pow_of_le_left (Nat.sub_le _ _) _
  apply this.trans
  suffices ((2 * d_value N) ^ n_value N : ℝ) ≤ N by exact_mod_cast this
  rw [← rpow_nat_cast]
  suffices i : (2 * d_value N : ℝ) ≤ (N : ℝ) ^ (1 / n_value N : ℝ)
  · apply (rpow_le_rpow (mul_nonneg zero_le_two (cast_nonneg _)) i (cast_nonneg _)).trans
    rw [← rpow_mul (cast_nonneg _), one_div_mul_cancel, rpow_one]
    rw [cast_ne_zero]
    apply (n_value_pos hN).ne'
  rw [← le_div_iff']
  · exact floor_le (div_nonneg (rpow_nonneg_of_nonneg (cast_nonneg _) _) zero_le_two)
  apply zero_lt_two
#align behrend.le_N Behrend.le_N

theorem bound (hN : 4096 ≤ N) : (N : ℝ) ^ (1 / nValue N : ℝ) / exp 1 < dValue N :=
  by
  apply div_lt_floor _
  rw [← log_le_log, log_rpow, mul_comm, ← div_eq_mul_one_div]
  · apply le_trans _ (div_le_div_of_le_left _ _ (ceil_lt_mul _).le)
    rw [mul_comm, ← div_div, div_sqrt, le_div_iff]
    · exact le_sqrt_log hN
    · norm_num1
    · apply log_nonneg
      rw [one_le_cast]
      exact hN.trans' (by norm_num1)
    · rw [cast_pos, lt_ceil, cast_zero, Real.sqrt_pos]
      refine' log_pos _
      rw [one_lt_cast]
      exact hN.trans_lt' (by norm_num1)
    apply le_sqrt_of_sq_le
    have : ((12 : ℕ) : ℝ) * log 2 ≤ log N :=
      by
      rw [← log_rpow zero_lt_two, log_le_log, rpow_nat_cast]
      · norm_num1
        exact_mod_cast hN
      · exact rpow_pos_of_pos zero_lt_two _
      rw [cast_pos]
      exact hN.trans_lt' (by norm_num1)
    refine' le_trans _ this
    simp only [cast_bit0, cast_bit1, cast_one]
    rw [← div_le_iff']
    · exact log_two_gt_d9.le.trans' (by norm_num1)
    · norm_num1
  · rw [cast_pos]
    exact hN.trans_lt' (by norm_num1)
  · refine' div_pos zero_lt_two _
    rw [sub_pos, div_lt_one (exp_pos _)]
    exact lt_of_le_of_lt (by norm_num1) exp_one_gt_d9
  apply rpow_pos_of_pos
  rw [cast_pos]
  exact hN.trans_lt' (by norm_num1)
#align behrend.bound Behrend.bound

theorem roth_lower_bound_explicit (hN : 4096 ≤ N) :
    (N : ℝ) * exp (-4 * sqrt (log N)) < rothNumberNat N :=
  by
  let n := n_value N
  have hn : 0 < (n : ℝ) := cast_pos.2 (n_value_pos <| hN.trans' <| by norm_num1)
  have hd : 0 < d_value N := d_value_pos (hN.trans' <| by norm_num1)
  have hN₀ : 0 < (N : ℝ) := cast_pos.2 (hN.trans' <| by norm_num1)
  have hn₂ : 2 ≤ n := two_le_n_value (hN.trans' <| by norm_num1)
  have : (2 * d_value N - 1) ^ n ≤ N := le_N (hN.trans' <| by norm_num1)
  refine' ((bound_aux hd.ne' hn₂).trans <| cast_le.2 <| roth_number_nat.mono this).trans_lt' _
  refine' (div_lt_div_of_lt hn <| pow_lt_pow_of_lt_left (bound hN) _ _).trans_le' _
  · exact div_nonneg (rpow_nonneg_of_nonneg (cast_nonneg _) _) (exp_pos _).le
  · exact tsub_pos_of_lt (three_le_n_value <| hN.trans' <| by norm_num1)
  rw [← rpow_nat_cast, div_rpow (rpow_nonneg_of_nonneg hN₀.le _) (exp_pos _).le, ← rpow_mul hN₀.le,
    mul_comm (_ / _), mul_one_div, cast_sub hn₂, cast_two, same_sub_div hn.ne', exp_one_rpow,
    div_div, rpow_sub hN₀, rpow_one, div_div, div_eq_mul_inv]
  refine' mul_le_mul_of_nonneg_left _ (cast_nonneg _)
  rw [mul_inv, mul_inv, ← exp_neg, ← rpow_neg (cast_nonneg _), neg_sub, ← div_eq_mul_inv]
  have : exp (-4 * sqrt (log N)) = exp (-2 * sqrt (log N)) * exp (-2 * sqrt (log N)) :=
    by
    rw [← exp_add, ← add_mul]
    norm_num
  rw [this]
  refine'
    mul_le_mul _ (exp_neg_two_mul_le <| Real.sqrt_pos.2 <| log_pos _).le (exp_pos _).le <|
      rpow_nonneg_of_nonneg (cast_nonneg _) _
  · rw [← le_log_iff_exp_le (rpow_pos_of_pos hN₀ _), log_rpow hN₀, ← le_div_iff, mul_div_assoc,
      div_sqrt, neg_mul, neg_le_neg_iff, div_mul_eq_mul_div, div_le_iff hn]
    · exact mul_le_mul_of_nonneg_left (le_ceil _) zero_le_two
    refine' Real.sqrt_pos.2 (log_pos _)
    rw [one_lt_cast]
    exact hN.trans_lt' (by norm_num1)
  · rw [one_lt_cast]
    exact hN.trans_lt' (by norm_num1)
#align behrend.roth_lower_bound_explicit Behrend.roth_lower_bound_explicit

theorem exp_four_lt : exp 4 < 64 :=
  by
  rw [show (64 : ℝ) = 2 ^ ((6 : ℕ) : ℝ) by norm_num1, ←
    lt_log_iff_exp_lt (rpow_pos_of_pos zero_lt_two _), log_rpow zero_lt_two, ← div_lt_iff']
  exact log_two_gt_d9.trans_le' (by norm_num1)
  norm_num
#align behrend.exp_four_lt Behrend.exp_four_lt

theorem four_zero_nine_six_lt_exp_sixteen : 4096 < exp 16 :=
  by
  rw [← log_lt_iff_lt_exp (show (0 : ℝ) < 4096 by norm_num), show (4096 : ℝ) = 2 ^ 12 by norm_num, ←
    rpow_nat_cast, log_rpow zero_lt_two, cast_bit0, cast_bit0, cast_bit1, cast_one]
  linarith [log_two_lt_d9]
#align behrend.four_zero_nine_six_lt_exp_sixteen Behrend.four_zero_nine_six_lt_exp_sixteen

theorem lower_bound_le_one' (hN : 2 ≤ N) (hN' : N ≤ 4096) : (N : ℝ) * exp (-4 * sqrt (log N)) ≤ 1 :=
  by
  rw [← log_le_log (mul_pos (cast_pos.2 (zero_lt_two.trans_le hN)) (exp_pos _)) zero_lt_one,
    log_one, log_mul (cast_pos.2 (zero_lt_two.trans_le hN)).ne' (exp_pos _).ne', log_exp, neg_mul, ←
    sub_eq_add_neg, sub_nonpos, ←
    div_le_iff (Real.sqrt_pos.2 <| log_pos <| one_lt_cast.2 <| one_lt_two.trans_le hN), div_sqrt,
    sqrt_le_left (zero_le_bit0.2 zero_le_two),
    log_le_iff_le_exp (cast_pos.2 (zero_lt_two.trans_le hN))]
  norm_num1
  apply le_trans _ four_zero_nine_six_lt_exp_sixteen.le
  exact_mod_cast hN'
#align behrend.lower_bound_le_one' Behrend.lower_bound_le_one'

theorem lower_bound_le_one (hN : 1 ≤ N) (hN' : N ≤ 4096) : (N : ℝ) * exp (-4 * sqrt (log N)) ≤ 1 :=
  by
  obtain rfl | hN := hN.eq_or_lt
  · norm_num
  · exact lower_bound_le_one' hN hN'
#align behrend.lower_bound_le_one Behrend.lower_bound_le_one

theorem roth_lower_bound : (N : ℝ) * exp (-4 * sqrt (log N)) ≤ rothNumberNat N :=
  by
  obtain rfl | hN := Nat.eq_zero_or_pos N
  · norm_num
  obtain h₁ | h₁ := le_or_lt 4096 N
  · exact (roth_lower_bound_explicit h₁).le
  · apply (lower_bound_le_one hN h₁.le).trans
    simpa using roth_number_nat.monotone hN
#align behrend.roth_lower_bound Behrend.roth_lower_bound

end Behrend


import definitions subgroups basic tactic
open function tactic

universe u

namespace Algebra

variables (G H : Type u) [group G] [group H]

structure hom :=
(f : G → H)
(prsv : ∀ a b : G, f(a + b) = f a + f b)

def iso : Type* := {φ : hom G H // bijective φ.f}

def image (φ : hom G H) : set H:=
set.range φ.f

lemma hom_id_to_id (φ : hom G H) : φ.1 (0 : G) = (0 : H) :=
begin
  cases φ with f H, simp,
  replace H := H 0 0,
  rw group.ident_r at H,
  nth_rewrite 0   ← add_zero (f 0) at H,
  symmetry,
  apply group.cancel_left (f 0) 0 (f 0), exact H,
end

lemma hom_img_has_ident (φ : hom G H) : (0 : H) ∈ (image G H φ) :=
begin
  rw image, simp, use 0, exact hom_id_to_id G H φ,
end

lemma hom_image_subgroup (φ : hom G H) : subgroup H :=
{ carrier := (image G H φ),
  has_ident := hom_img_has_ident G H φ,
  closure :=
  begin
    intros a b H1 H2,
    cases H1 with g₁ H1,
    cases H2 with g₂ H2,
    rw image, simp, use (g₁ + g₂),
    rw [φ.2, H1, H2]
  end ,
  has_inv :=
  begin
    intros a H1, simp at *,
    cases H1 with w H1,
    use (-w),

  end }

end Algebra


import tactic.pure_maths -- hide

/-
# Propositional logic
## Level 3: And swap

-/

namespace exlean -- hide

variables {p q : Prop} -- hide

/-
## Task

Intuitively, you'd expect that if you have $h : p \land q$, then you can derive $q \land p$.
In this level, you'll do just that!

Recall you can:
* use `cases`, or `.left` and `.right` for and elimination and
* use `split` or `and.intro` for and introduction.
-/

/- Theorem :
Let $p$ and $q$ be propositions. Assuming $h : p \land q$, we have $h : q \land p$.
-/
theorem and.swap (h : p ∧ q) : q ∧ p :=
begin
  split,
  { show q, from h.right, },
  { show p, from h.left, },

end

end exlean -- hide


/-
Copyright (c) 2019 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.zsqrtd.gaussian_int
/-!
# Sums of two squares

Proof of Fermat's theorem on the sum of two squares. Every prime congruent to 1 mod 4 is the sum
of two squares
-/

open gaussian_int principal_ideal_ring

namespace nat
namespace prime

/-- Fermat's theorem on the sum of two squares. Every prime congruent to 1 mod 4 is the sum
of two squares -/
lemma sq_add_sq (p : ℕ) [hp : _root_.fact p.prime] (hp1 : p % 4 = 1) :
  ∃ a b : ℕ, a ^ 2 + b ^ 2 = p :=
begin
  apply sq_add_sq_of_nat_prime_of_not_irreducible p,
  rw [principal_ideal_ring.irreducible_iff_prime, prime_iff_mod_four_eq_three_of_nat_prime p, hp1],
  norm_num
end

end prime
end nat


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_398
  (a b c : ℝ)
  (h₀ : 0 < a ∧ 0 < b ∧ 0 < c)
  (h₁ : 9 * b = 20 * c)
  (h₂ : 7 * a = 4 * b) :
  63 * a = 80 * c :=
begin
  linarith,
end


/-
Copyright (c) 2022 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández

! This file was ported from Lean 3 source module ring_theory.dedekind_domain.adic_valuation
! leanprover-community/mathlib commit a8e7ac804fc39df0340c64906075787e0c90fa60
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.DedekindDomain.Ideal
import Mathbin.RingTheory.Valuation.ExtendToLocalization
import Mathbin.RingTheory.Valuation.ValuationSubring
import Mathbin.RingTheory.Polynomial.Cyclotomic.Basic
import Mathbin.Topology.Algebra.ValuedField

/-!
# Adic valuations on Dedekind domains
Given a Dedekind domain `R` of Krull dimension 1 and a maximal ideal `v` of `R`, we define the
`v`-adic valuation on `R` and its extension to the field of fractions `K` of `R`.
We prove several properties of this valuation, including the existence of uniformizers.

We define the completion of `K` with respect to the `v`-adic valuation, denoted
`v.adic_completion`,and its ring of integers, denoted `v.adic_completion_integers`.

## Main definitions
 - `is_dedekind_domain.height_one_spectrum.int_valuation v` is the `v`-adic valuation on `R`.
 - `is_dedekind_domain.height_one_spectrum.valuation v` is the `v`-adic valuation on `K`.
 - `is_dedekind_domain.height_one_spectrum.adic_completion v` is the completion of `K` with respect
    to its `v`-adic valuation.
 - `is_dedekind_domain.height_one_spectrum.adic_completion_integers v` is the ring of integers of
    `v.adic_completion`.

## Main results
- `is_dedekind_domain.height_one_spectrum.int_valuation_le_one` : The `v`-adic valuation on `R` is
  bounded above by 1.
- `is_dedekind_domain.height_one_spectrum.int_valuation_lt_one_iff_dvd` : The `v`-adic valuation of
  `r ∈ R` is less than 1 if and only if `v` divides the ideal `(r)`.
- `is_dedekind_domain.height_one_spectrum.int_valuation_le_pow_iff_dvd` : The `v`-adic valuation of
  `r ∈ R` is less than or equal to `multiplicative.of_add (-n)` if and only if `vⁿ` divides the
  ideal `(r)`.
- `is_dedekind_domain.height_one_spectrum.int_valuation_exists_uniformizer` : There exists `π ∈ R`
  with `v`-adic valuation `multiplicative.of_add (-1)`.
- `is_dedekind_domain.height_one_spectrum.valuation_of_mk'` : The `v`-adic valuation of `r/s ∈ K`
  is the valuation of `r` divided by the valuation of `s`.
- `is_dedekind_domain.height_one_spectrum.valuation_of_algebra_map` : The `v`-adic valuation on `K`
  extends the `v`-adic valuation on `R`.
- `is_dedekind_domain.height_one_spectrum.valuation_exists_uniformizer` : There exists `π ∈ K` with
  `v`-adic valuation `multiplicative.of_add (-1)`.

## Implementation notes
We are only interested in Dedekind domains with Krull dimension 1.

## References
* [G. J. Janusz, *Algebraic Number Fields*][janusz1996]
* [J.W.S. Cassels, A. Frölich, *Algebraic Number Theory*][cassels1967algebraic]
* [J. Neukirch, *Algebraic Number Theory*][Neukirch1992]

## Tags
dedekind domain, dedekind ring, adic valuation
-/

noncomputable section

open Classical DiscreteValuation

open Multiplicative IsDedekindDomain

variable {R : Type _} [CommRing R] [IsDomain R] [IsDedekindDomain R] {K : Type _} [Field K]
  [Algebra R K] [IsFractionRing R K] (v : HeightOneSpectrum R)

namespace IsDedekindDomain.HeightOneSpectrum

/-! ### Adic valuations on the Dedekind domain R -/

/-- The additive `v`-adic valuation of `r ∈ R` is the exponent of `v` in the factorization of the
ideal `(r)`, if `r` is nonzero, or infinity, if `r = 0`. `int_valuation_def` is the corresponding
multiplicative valuation. -/
def intValuationDef (r : R) : ℤₘ₀ :=
  if r = 0 then 0
  else
    Multiplicative.ofAdd
      (-(Associates.mk v.asIdeal).count (Associates.mk (Ideal.span {r} : Ideal R)).factors : ℤ)
#align is_dedekind_domain.height_one_spectrum.int_valuation_def IsDedekindDomain.HeightOneSpectrum.intValuationDef

theorem intValuationDef_if_pos {r : R} (hr : r = 0) : v.intValuationDef r = 0 :=
  if_pos hr
#align is_dedekind_domain.height_one_spectrum.int_valuation_def_if_pos IsDedekindDomain.HeightOneSpectrum.intValuationDef_if_pos

theorem intValuationDef_if_neg {r : R} (hr : r ≠ 0) :
    v.intValuationDef r =
      Multiplicative.ofAdd
        (-(Associates.mk v.asIdeal).count (Associates.mk (Ideal.span {r} : Ideal R)).factors : ℤ) :=
  if_neg hr
#align is_dedekind_domain.height_one_spectrum.int_valuation_def_if_neg IsDedekindDomain.HeightOneSpectrum.intValuationDef_if_neg

/-- Nonzero elements have nonzero adic valuation. -/
theorem int_valuation_ne_zero (x : R) (hx : x ≠ 0) : v.intValuationDef x ≠ 0 :=
  by
  rw [int_valuation_def, if_neg hx]
  exact WithZero.coe_ne_zero
#align is_dedekind_domain.height_one_spectrum.int_valuation_ne_zero IsDedekindDomain.HeightOneSpectrum.int_valuation_ne_zero

/-- Nonzero divisors have nonzero valuation. -/
theorem int_valuation_ne_zero' (x : nonZeroDivisors R) : v.intValuationDef x ≠ 0 :=
  v.int_valuation_ne_zero x (nonZeroDivisors.coe_ne_zero x)
#align is_dedekind_domain.height_one_spectrum.int_valuation_ne_zero' IsDedekindDomain.HeightOneSpectrum.int_valuation_ne_zero'

/-- Nonzero divisors have valuation greater than zero. -/
theorem int_valuation_zero_le (x : nonZeroDivisors R) : 0 < v.intValuationDef x :=
  by
  rw [v.int_valuation_def_if_neg (nonZeroDivisors.coe_ne_zero x)]
  exact WithZero.zero_lt_coe _
#align is_dedekind_domain.height_one_spectrum.int_valuation_zero_le IsDedekindDomain.HeightOneSpectrum.int_valuation_zero_le

/-- The `v`-adic valuation on `R` is bounded above by 1. -/
theorem int_valuation_le_one (x : R) : v.intValuationDef x ≤ 1 :=
  by
  rw [int_valuation_def]
  by_cases hx : x = 0
  · rw [if_pos hx]
    exact WithZero.zero_le 1
  · rw [if_neg hx, ← WithZero.coe_one, ← ofAdd_zero, WithZero.coe_le_coe, of_add_le,
      Right.neg_nonpos_iff]
    exact Int.coe_nat_nonneg _
#align is_dedekind_domain.height_one_spectrum.int_valuation_le_one IsDedekindDomain.HeightOneSpectrum.int_valuation_le_one

/-- The `v`-adic valuation of `r ∈ R` is less than 1 if and only if `v` divides the ideal `(r)`. -/
theorem int_valuation_lt_one_iff_dvd (r : R) :
    v.intValuationDef r < 1 ↔ v.asIdeal ∣ Ideal.span {r} :=
  by
  rw [int_valuation_def]
  split_ifs with hr
  · simpa [hr] using WithZero.zero_lt_coe _
  · rw [← WithZero.coe_one, ← ofAdd_zero, WithZero.coe_lt_coe, of_add_lt, neg_lt_zero, ←
      Int.ofNat_zero, Int.ofNat_lt, zero_lt_iff]
    have h : (Ideal.span {r} : Ideal R) ≠ 0 :=
      by
      rw [Ne.def, Ideal.zero_eq_bot, Ideal.span_singleton_eq_bot]
      exact hr
    apply Associates.count_ne_zero_iff_dvd h (by apply v.irreducible)
#align is_dedekind_domain.height_one_spectrum.int_valuation_lt_one_iff_dvd IsDedekindDomain.HeightOneSpectrum.int_valuation_lt_one_iff_dvd

/-- The `v`-adic valuation of `r ∈ R` is less than `multiplicative.of_add (-n)` if and only if
`vⁿ` divides the ideal `(r)`. -/
theorem int_valuation_le_pow_iff_dvd (r : R) (n : ℕ) :
    v.intValuationDef r ≤ Multiplicative.ofAdd (-(n : ℤ)) ↔ v.asIdeal ^ n ∣ Ideal.span {r} :=
  by
  rw [int_valuation_def]
  split_ifs with hr
  · simp_rw [hr, Ideal.dvd_span_singleton, zero_le', Submodule.zero_mem]
  ·
    rw [WithZero.coe_le_coe, of_add_le, neg_le_neg_iff, Int.ofNat_le, Ideal.dvd_span_singleton, ←
      Associates.le_singleton_iff,
      Associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hr)
        (by apply v.associates_irreducible)]
#align is_dedekind_domain.height_one_spectrum.int_valuation_le_pow_iff_dvd IsDedekindDomain.HeightOneSpectrum.int_valuation_le_pow_iff_dvd

/-- The `v`-adic valuation of `0 : R` equals 0. -/
theorem IntValuation.map_zero' : v.intValuationDef 0 = 0 :=
  v.intValuationDef_if_pos (Eq.refl 0)
#align is_dedekind_domain.height_one_spectrum.int_valuation.map_zero' IsDedekindDomain.HeightOneSpectrum.IntValuation.map_zero'

/-- The `v`-adic valuation of `1 : R` equals 1. -/
theorem IntValuation.map_one' : v.intValuationDef 1 = 1 := by
  rw [v.int_valuation_def_if_neg (zero_ne_one.symm : (1 : R) ≠ 0), Ideal.span_singleton_one, ←
    Ideal.one_eq_top, Associates.mk_one, Associates.factors_one,
    Associates.count_zero (by apply v.associates_irreducible), Int.ofNat_zero, neg_zero, ofAdd_zero,
    WithZero.coe_one]
#align is_dedekind_domain.height_one_spectrum.int_valuation.map_one' IsDedekindDomain.HeightOneSpectrum.IntValuation.map_one'

/-- The `v`-adic valuation of a product equals the product of the valuations. -/
theorem IntValuation.map_mul' (x y : R) :
    v.intValuationDef (x * y) = v.intValuationDef x * v.intValuationDef y :=
  by
  simp only [int_valuation_def]
  by_cases hx : x = 0
  · rw [hx, MulZeroClass.zero_mul, if_pos (Eq.refl _), MulZeroClass.zero_mul]
  · by_cases hy : y = 0
    · rw [hy, MulZeroClass.mul_zero, if_pos (Eq.refl _), MulZeroClass.mul_zero]
    · rw [if_neg hx, if_neg hy, if_neg (mul_ne_zero hx hy), ← WithZero.coe_mul, WithZero.coe_inj, ←
        ofAdd_add, ← Ideal.span_singleton_mul_span_singleton, ← Associates.mk_mul_mk, ← neg_add,
        Associates.count_mul (by apply associates.mk_ne_zero'.mpr hx)
          (by apply associates.mk_ne_zero'.mpr hy) (by apply v.associates_irreducible)]
      rfl
#align is_dedekind_domain.height_one_spectrum.int_valuation.map_mul' IsDedekindDomain.HeightOneSpectrum.IntValuation.map_mul'

theorem IntValuation.le_max_iff_min_le {a b c : ℕ} :
    Multiplicative.ofAdd (-c : ℤ) ≤
        max (Multiplicative.ofAdd (-a : ℤ)) (Multiplicative.ofAdd (-b : ℤ)) ↔
      min a b ≤ c :=
  by
  rw [le_max_iff, of_add_le, of_add_le, neg_le_neg_iff, neg_le_neg_iff, Int.ofNat_le, Int.ofNat_le,
    ← min_le_iff]
#align is_dedekind_domain.height_one_spectrum.int_valuation.le_max_iff_min_le IsDedekindDomain.HeightOneSpectrum.IntValuation.le_max_iff_min_le

/-- The `v`-adic valuation of a sum is bounded above by the maximum of the valuations. -/
theorem IntValuation.map_add_le_max' (x y : R) :
    v.intValuationDef (x + y) ≤ max (v.intValuationDef x) (v.intValuationDef y) :=
  by
  by_cases hx : x = 0
  · rw [hx, zero_add]
    conv_rhs => rw [int_valuation_def, if_pos (Eq.refl _)]
    rw [max_eq_right (WithZero.zero_le (v.int_valuation_def y))]
    exact le_refl _
  · by_cases hy : y = 0
    · rw [hy, add_zero]
      conv_rhs => rw [max_comm, int_valuation_def, if_pos (Eq.refl _)]
      rw [max_eq_right (WithZero.zero_le (v.int_valuation_def x))]
      exact le_refl _
    · by_cases hxy : x + y = 0
      · rw [int_valuation_def, if_pos hxy]
        exact zero_le'
      · rw [v.int_valuation_def_if_neg hxy, v.int_valuation_def_if_neg hx,
          v.int_valuation_def_if_neg hy, [anonymous], int_valuation.le_max_iff_min_le]
        set nmin :=
          min ((Associates.mk v.as_ideal).count (Associates.mk (Ideal.span {x})).factors)
            ((Associates.mk v.as_ideal).count (Associates.mk (Ideal.span {y})).factors)
        have h_dvd_x : x ∈ v.as_ideal ^ nmin :=
          by
          rw [← Associates.le_singleton_iff x nmin _,
            Associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hx) _]
          exact min_le_left _ _
          apply v.associates_irreducible
        have h_dvd_y : y ∈ v.as_ideal ^ nmin :=
          by
          rw [← Associates.le_singleton_iff y nmin _,
            Associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hy) _]
          exact min_le_right _ _
          apply v.associates_irreducible
        have h_dvd_xy : Associates.mk v.as_ideal ^ nmin ≤ Associates.mk (Ideal.span {x + y}) :=
          by
          rw [Associates.le_singleton_iff]
          exact Ideal.add_mem (v.as_ideal ^ nmin) h_dvd_x h_dvd_y
        rw [Associates.prime_pow_dvd_iff_le (associates.mk_ne_zero'.mpr hxy) _] at h_dvd_xy
        exact h_dvd_xy
        apply v.associates_irreducible
#align is_dedekind_domain.height_one_spectrum.int_valuation.map_add_le_max' IsDedekindDomain.HeightOneSpectrum.IntValuation.map_add_le_max'

/-- The `v`-adic valuation on `R`. -/
def intValuation : Valuation R ℤₘ₀
    where
  toFun := v.intValuationDef
  map_zero' := IntValuation.map_zero' v
  map_one' := IntValuation.map_one' v
  map_mul' := IntValuation.map_mul' v
  map_add_le_max' := IntValuation.map_add_le_max' v
#align is_dedekind_domain.height_one_spectrum.int_valuation IsDedekindDomain.HeightOneSpectrum.intValuation

/-- There exists `π ∈ R` with `v`-adic valuation `multiplicative.of_add (-1)`. -/
theorem int_valuation_exists_uniformizer :
    ∃ π : R, v.intValuationDef π = Multiplicative.ofAdd (-1 : ℤ) :=
  by
  have hv : _root_.irreducible (Associates.mk v.as_ideal) := v.associates_irreducible
  have hlt : v.as_ideal ^ 2 < v.as_ideal :=
    by
    rw [← Ideal.dvdNotUnit_iff_lt]
    exact
      ⟨v.ne_bot, v.as_ideal, (not_congr Ideal.isUnit_iff).mpr (Ideal.IsPrime.ne_top v.is_prime),
        sq v.as_ideal⟩
  obtain ⟨π, mem, nmem⟩ := SetLike.exists_of_lt hlt
  have hπ : Associates.mk (Ideal.span {π}) ≠ 0 :=
    by
    rw [Associates.mk_ne_zero']
    intro h
    rw [h] at nmem
    exact nmem (Submodule.zero_mem (v.as_ideal ^ 2))
  use π
  rw [int_valuation_def, if_neg (associates.mk_ne_zero'.mp hπ), WithZero.coe_inj]
  apply congr_arg
  rw [neg_inj, ← Int.ofNat_one, Int.coe_nat_inj']
  rw [← Ideal.dvd_span_singleton, ← Associates.mk_le_mk_iff_dvd_iff] at mem nmem
  rw [← pow_one (Associates.mk v.as_ideal), Associates.prime_pow_dvd_iff_le hπ hv] at mem
  rw [Associates.mk_pow, Associates.prime_pow_dvd_iff_le hπ hv, not_le] at nmem
  exact Nat.eq_of_le_of_lt_succ mem nmem
#align is_dedekind_domain.height_one_spectrum.int_valuation_exists_uniformizer IsDedekindDomain.HeightOneSpectrum.int_valuation_exists_uniformizer

/-! ### Adic valuations on the field of fractions `K` -/

/-- The `v`-adic valuation of `x ∈ K` is the valuation of `r` divided by the valuation of `s`,
where `r` and `s` are chosen so that `x = r/s`. -/
def valuation (v : HeightOneSpectrum R) : Valuation K ℤₘ₀ :=
  v.intValuation.extendToLocalization
    (fun r hr => Set.mem_compl <| v.int_valuation_ne_zero' ⟨r, hr⟩) K
#align is_dedekind_domain.height_one_spectrum.valuation IsDedekindDomain.HeightOneSpectrum.valuation

theorem valuation_def (x : K) :
    v.Valuation x =
      v.intValuation.extendToLocalization
        (fun r hr => Set.mem_compl (v.int_valuation_ne_zero' ⟨r, hr⟩)) K x :=
  rfl
#align is_dedekind_domain.height_one_spectrum.valuation_def IsDedekindDomain.HeightOneSpectrum.valuation_def

/-- The `v`-adic valuation of `r/s ∈ K` is the valuation of `r` divided by the valuation of `s`. -/
theorem valuation_of_mk' {r : R} {s : nonZeroDivisors R} :
    v.Valuation (IsLocalization.mk' K r s) = v.intValuation r / v.intValuation s :=
  by
  erw [valuation_def, (IsLocalization.toLocalizationMap (nonZeroDivisors R) K).lift_mk',
    div_eq_mul_inv, mul_eq_mul_left_iff]
  left
  rw [Units.val_inv_eq_inv_val, inv_inj]
  rfl
#align is_dedekind_domain.height_one_spectrum.valuation_of_mk' IsDedekindDomain.HeightOneSpectrum.valuation_of_mk'

/-- The `v`-adic valuation on `K` extends the `v`-adic valuation on `R`. -/
theorem valuation_of_algebraMap (r : R) : v.Valuation (algebraMap R K r) = v.intValuation r := by
  rw [valuation_def, Valuation.extendToLocalization_apply_map_apply]
#align is_dedekind_domain.height_one_spectrum.valuation_of_algebra_map IsDedekindDomain.HeightOneSpectrum.valuation_of_algebraMap

/-- The `v`-adic valuation on `R` is bounded above by 1. -/
theorem valuation_le_one (r : R) : v.Valuation (algebraMap R K r) ≤ 1 :=
  by
  rw [valuation_of_algebra_map]
  exact v.int_valuation_le_one r
#align is_dedekind_domain.height_one_spectrum.valuation_le_one IsDedekindDomain.HeightOneSpectrum.valuation_le_one

/-- The `v`-adic valuation of `r ∈ R` is less than 1 if and only if `v` divides the ideal `(r)`. -/
theorem valuation_lt_one_iff_dvd (r : R) :
    v.Valuation (algebraMap R K r) < 1 ↔ v.asIdeal ∣ Ideal.span {r} :=
  by
  rw [valuation_of_algebra_map]
  exact v.int_valuation_lt_one_iff_dvd r
#align is_dedekind_domain.height_one_spectrum.valuation_lt_one_iff_dvd IsDedekindDomain.HeightOneSpectrum.valuation_lt_one_iff_dvd

variable (K)

/-- There exists `π ∈ K` with `v`-adic valuation `multiplicative.of_add (-1)`. -/
theorem valuation_exists_uniformizer : ∃ π : K, v.Valuation π = Multiplicative.ofAdd (-1 : ℤ) :=
  by
  obtain ⟨r, hr⟩ := v.int_valuation_exists_uniformizer
  use algebraMap R K r
  rw [valuation_def, Valuation.extendToLocalization_apply_map_apply]
  exact hr
#align is_dedekind_domain.height_one_spectrum.valuation_exists_uniformizer IsDedekindDomain.HeightOneSpectrum.valuation_exists_uniformizer

/-- Uniformizers are nonzero. -/
theorem valuation_uniformizer_ne_zero : Classical.choose (v.valuation_exists_uniformizer K) ≠ 0 :=
  haveI hu := Classical.choose_spec (v.valuation_exists_uniformizer K)
  (Valuation.ne_zero_iff _).mp (ne_of_eq_of_ne hu WithZero.coe_ne_zero)
#align is_dedekind_domain.height_one_spectrum.valuation_uniformizer_ne_zero IsDedekindDomain.HeightOneSpectrum.valuation_uniformizer_ne_zero

/-! ### Completions with respect to adic valuations

Given a Dedekind domain `R` with field of fractions `K` and a maximal ideal `v` of `R`, we define
the completion of `K` with respect to its `v`-adic valuation, denoted `v.adic_completion`, and its
ring of integers, denoted `v.adic_completion_integers`. -/

variable {K}

/-- `K` as a valued field with the `v`-adic valuation. -/
def adicValued : Valued K ℤₘ₀ :=
  Valued.mk' v.Valuation
#align is_dedekind_domain.height_one_spectrum.adic_valued IsDedekindDomain.HeightOneSpectrum.adicValued

theorem adicValued_apply {x : K} : (v.adicValued.V : _) x = v.Valuation x :=
  rfl
#align is_dedekind_domain.height_one_spectrum.adic_valued_apply IsDedekindDomain.HeightOneSpectrum.adicValued_apply

variable (K)

/-- The completion of `K` with respect to its `v`-adic valuation. -/
def AdicCompletion :=
  @UniformSpace.Completion K v.adicValued.toUniformSpace
#align is_dedekind_domain.height_one_spectrum.adic_completion IsDedekindDomain.HeightOneSpectrum.AdicCompletion

instance : Field (v.adicCompletion K) :=
  @UniformSpace.Completion.field K _ v.adicValued.toUniformSpace _ _ v.adicValued.to_uniformAddGroup

instance : Inhabited (v.adicCompletion K) :=
  ⟨0⟩

instance valuedAdicCompletion : Valued (v.adicCompletion K) ℤₘ₀ :=
  @Valued.valuedCompletion _ _ _ _ v.adicValued
#align is_dedekind_domain.height_one_spectrum.valued_adic_completion IsDedekindDomain.HeightOneSpectrum.valuedAdicCompletion

theorem valuedAdicCompletion_def {x : v.adicCompletion K} :
    Valued.v x = @Valued.extension K _ _ _ (adicValued v) x :=
  rfl
#align is_dedekind_domain.height_one_spectrum.valued_adic_completion_def IsDedekindDomain.HeightOneSpectrum.valuedAdicCompletion_def

instance adicCompletion_completeSpace : CompleteSpace (v.adicCompletion K) :=
  @UniformSpace.Completion.completeSpace K v.adicValued.toUniformSpace
#align is_dedekind_domain.height_one_spectrum.adic_completion_complete_space IsDedekindDomain.HeightOneSpectrum.adicCompletion_completeSpace

instance AdicCompletion.hasLiftT : HasLiftT K (v.adicCompletion K) :=
  (inferInstance : HasLiftT K (@UniformSpace.Completion K v.adicValued.toUniformSpace))
#align is_dedekind_domain.height_one_spectrum.adic_completion.has_lift_t IsDedekindDomain.HeightOneSpectrum.AdicCompletion.hasLiftT

/-- The ring of integers of `adic_completion`. -/
def adicCompletionIntegers : ValuationSubring (v.adicCompletion K) :=
  Valued.v.ValuationSubring
#align is_dedekind_domain.height_one_spectrum.adic_completion_integers IsDedekindDomain.HeightOneSpectrum.adicCompletionIntegers

instance : Inhabited (adicCompletionIntegers K v) :=
  ⟨0⟩

variable (R K)

theorem mem_adicCompletionIntegers {x : v.adicCompletion K} :
    x ∈ v.adicCompletionIntegers K ↔ (Valued.v x : ℤₘ₀) ≤ 1 :=
  Iff.rfl
#align is_dedekind_domain.height_one_spectrum.mem_adic_completion_integers IsDedekindDomain.HeightOneSpectrum.mem_adicCompletionIntegers

section AlgebraInstances

instance (priority := 100) adicValued.has_uniform_continuous_const_smul' :
    @UniformContinuousConstSMul R K v.adicValued.toUniformSpace _ :=
  @uniformContinuousConstSMul_of_continuousConstSMul R K _ _ _ v.adicValued.toUniformSpace _ _
#align is_dedekind_domain.height_one_spectrum.adic_valued.has_uniform_continuous_const_smul' IsDedekindDomain.HeightOneSpectrum.adicValued.has_uniform_continuous_const_smul'

instance adicValued.uniformContinuousConstSMul :
    @UniformContinuousConstSMul K K v.adicValued.toUniformSpace _ :=
  @Ring.uniformContinuousConstSMul K _ v.adicValued.toUniformSpace _ _
#align is_dedekind_domain.height_one_spectrum.adic_valued.has_uniform_continuous_const_smul IsDedekindDomain.HeightOneSpectrum.adicValued.uniformContinuousConstSMul

instance AdicCompletion.algebra' : Algebra R (v.adicCompletion K) :=
  @UniformSpace.Completion.algebra K _ v.adicValued.toUniformSpace _ _ R _ _
    (adicValued.has_uniform_continuous_const_smul' R K v)
#align is_dedekind_domain.height_one_spectrum.adic_completion.algebra' IsDedekindDomain.HeightOneSpectrum.AdicCompletion.algebra'

@[simp]
theorem coe_smul_adicCompletion (r : R) (x : K) :
    (↑(r • x) : v.adicCompletion K) = r • (↑x : v.adicCompletion K) :=
  @UniformSpace.Completion.coe_smul R K v.adicValued.toUniformSpace _ _ r x
#align is_dedekind_domain.height_one_spectrum.coe_smul_adic_completion IsDedekindDomain.HeightOneSpectrum.coe_smul_adicCompletion

instance : Algebra K (v.adicCompletion K) :=
  @UniformSpace.Completion.algebra' K _ v.adicValued.toUniformSpace _ _

theorem algebraMap_adic_completion' :
    ⇑(algebraMap R <| v.adicCompletion K) = coe ∘ algebraMap R K :=
  rfl
#align is_dedekind_domain.height_one_spectrum.algebra_map_adic_completion' IsDedekindDomain.HeightOneSpectrum.algebraMap_adic_completion'

theorem algebraMap_adicCompletion : ⇑(algebraMap K <| v.adicCompletion K) = coe :=
  rfl
#align is_dedekind_domain.height_one_spectrum.algebra_map_adic_completion IsDedekindDomain.HeightOneSpectrum.algebraMap_adicCompletion

instance : IsScalarTower R K (v.adicCompletion K) :=
  @UniformSpace.Completion.isScalarTower R K K v.adicValued.toUniformSpace _ _ _
    (adicValued.has_uniform_continuous_const_smul' R K v) _ _

instance : Algebra R (v.adicCompletionIntegers K)
    where
  smul r x :=
    ⟨r • (x : v.adicCompletion K),
      by
      have h : (algebraMap R (adicCompletion K v)) r = (coe <| algebraMap R K r) := rfl
      rw [Algebra.smul_def]
      refine' ValuationSubring.mul_mem _ _ _ _ x.2
      rw [mem_adic_completion_integers, h, Valued.valuedCompletion_apply]
      exact v.valuation_le_one _⟩
  toFun r :=
    ⟨coe <| algebraMap R K r, by
      simpa only [mem_adic_completion_integers, Valued.valuedCompletion_apply] using
        v.valuation_le_one _⟩
  map_one' := by simp only [map_one] <;> rfl
  map_mul' x y := by
    ext
    simp_rw [RingHom.map_mul, Subring.coe_mul, Subtype.coe_mk, UniformSpace.Completion.coe_mul]
  map_zero' := by simp only [map_zero] <;> rfl
  map_add' x y := by
    ext
    simp_rw [RingHom.map_add, Subring.coe_add, Subtype.coe_mk, UniformSpace.Completion.coe_add]
  commutes' r x := by rw [mul_comm]
  smul_def' r x := by
    ext
    simp only [Subring.coe_mul, [anonymous], Algebra.smul_def]
    rfl

@[simp]
theorem coe_smul_adicCompletionIntegers (r : R) (x : v.adicCompletionIntegers K) :
    (↑(r • x) : v.adicCompletion K) = r • (x : v.adicCompletion K) :=
  rfl
#align is_dedekind_domain.height_one_spectrum.coe_smul_adic_completion_integers IsDedekindDomain.HeightOneSpectrum.coe_smul_adicCompletionIntegers

instance : NoZeroSMulDivisors R (v.adicCompletionIntegers K)
    where eq_zero_or_eq_zero_of_smul_eq_zero c x hcx :=
    by
    rw [Algebra.smul_def, mul_eq_zero] at hcx
    refine' hcx.imp_left fun hc => _
    letI : UniformSpace K := v.adic_valued.to_uniform_space
    rw [← map_zero (algebraMap R (v.adic_completion_integers K))] at hc
    exact
      IsFractionRing.injective R K (UniformSpace.Completion.coe_injective K (subtype.ext_iff.mp hc))

instance AdicCompletion.is_scalar_tower' :
    IsScalarTower R (v.adicCompletionIntegers K) (v.adicCompletion K)
    where smul_assoc x y z := by
    simp only [Algebra.smul_def]
    apply mul_assoc
#align is_dedekind_domain.height_one_spectrum.adic_completion.is_scalar_tower' IsDedekindDomain.HeightOneSpectrum.AdicCompletion.is_scalar_tower'

end AlgebraInstances

end IsDedekindDomain.HeightOneSpectrum


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import analysis.box_integral.partition.additive
import measure_theory.measure.lebesgue

/-!
# Box-additive functions defined by measures

In this file we prove a few simple facts about rectangular boxes, partitions, and measures:

- given a box `I : box ι`, its coercion to `set (ι → ℝ)` and `I.Icc` are measurable sets;
- if `μ` is a locally finite measure, then `(I : set (ι → ℝ))` and `I.Icc` have finite measure;
- if `μ` is a locally finite measure, then `λ J, (μ J).to_real` is a box additive function.

For the last statement, we both prove it as a proposition and define a bundled
`box_integral.box_additive` function.

### Tags

rectangular box, measure
-/

open set
noncomputable theory
open_locale ennreal big_operators classical box_integral

variables {ι : Type*}

namespace box_integral

open measure_theory

namespace box

lemma measure_Icc_lt_top (I : box ι) (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  μ I.Icc < ∞ :=
show μ (Icc I.lower I.upper) < ∞, from I.is_compact_Icc.measure_lt_top

lemma measure_coe_lt_top (I : box ι) (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  μ I < ∞ :=
(measure_mono $ coe_subset_Icc).trans_lt (I.measure_Icc_lt_top μ)

variables [fintype ι] (I : box ι)

lemma measurable_set_coe : measurable_set (I : set (ι → ℝ)) :=
begin
  rw [coe_eq_pi],
  haveI := fintype.to_encodable ι,
  exact measurable_set.univ_pi (λ i, measurable_set_Ioc)
end

lemma measurable_set_Icc : measurable_set I.Icc := measurable_set_Icc

lemma measurable_set_Ioo : measurable_set I.Ioo :=
(measurable_set_pi (finite.of_fintype _).countable).2 $ or.inl $ λ i hi, measurable_set_Ioo

lemma coe_ae_eq_Icc : (I : set (ι → ℝ)) =ᵐ[volume] I.Icc :=
by { rw coe_eq_pi, exact measure.univ_pi_Ioc_ae_eq_Icc }

lemma Ioo_ae_eq_Icc : I.Ioo =ᵐ[volume] I.Icc :=
measure.univ_pi_Ioo_ae_eq_Icc

end box

lemma prepartition.measure_Union_to_real [fintype ι] {I : box ι} (π : prepartition I)
  (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  (μ π.Union).to_real = ∑ J in π.boxes, (μ J).to_real :=
begin
  erw [← ennreal.to_real_sum, π.Union_def, measure_bUnion_finset π.pairwise_disjoint],
  exacts [λ J hJ, J.measurable_set_coe, λ J hJ, (J.measure_coe_lt_top μ).ne]
end

end box_integral

open box_integral box_integral.box

variables [fintype ι]

namespace measure_theory

namespace measure

/-- If `μ` is a locally finite measure on `ℝⁿ`, then `λ J, (μ J).to_real` is a box-additive
function. -/
@[simps] def to_box_additive (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  ι →ᵇᵃ[⊤] ℝ :=
{ to_fun := λ J, (μ J).to_real,
  sum_partition_boxes' := λ J hJ π hπ, by rw [← π.measure_Union_to_real, hπ.Union_eq] }

end measure

end measure_theory

namespace box_integral

open measure_theory

namespace box

@[simp] lemma volume_apply (I : box ι) :
  (volume : measure (ι → ℝ)).to_box_additive I = ∏ i, (I.upper i - I.lower i) :=
by rw [measure.to_box_additive_apply, coe_eq_pi, real.volume_pi_Ioc_to_real I.lower_le_upper]

lemma volume_face_mul {n} (i : fin (n + 1)) (I : box (fin (n + 1))) :
  (∏ j, ((I.face i).upper j - (I.face i).lower j)) * (I.upper i - I.lower i) =
    ∏ j, (I.upper j - I.lower j) :=
by simp only [face_lower, face_upper, (∘), fin.prod_univ_succ_above _ i, mul_comm]

end box

namespace box_additive_map

/-- Box-additive map sending each box `I` to the continuous linear endomorphism
`x ↦ (volume I).to_real • x`. -/
protected def volume {E : Type*} [normed_group E] [normed_space ℝ E] :
  ι →ᵇᵃ (E →L[ℝ] E) :=
(volume : measure (ι → ℝ)).to_box_additive.to_smul

lemma volume_apply {E : Type*} [normed_group E] [normed_space ℝ E] (I : box ι) (x : E) :
  box_additive_map.volume I x = (∏ j, (I.upper j - I.lower j)) • x :=
congr_arg2 (•) I.volume_apply rfl

end box_additive_map

end box_integral


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

! This file was ported from Lean 3 source module algebra.monoid_algebra.no_zero_divisors
! leanprover-community/mathlib commit 3e067975886cf5801e597925328c335609511b1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.MonoidAlgebra.Support

/-!
# Variations on non-zero divisors in `AddMonoidAlgebra`s

This file studies the interaction between typeclass assumptions on two Types `R` and `A` and
whether `AddMonoidAlgebra R A` has non-zero zero-divisors.  For some background on related
questions, see [Kaplansky's Conjectures](https://en.wikipedia.org/wiki/Kaplansky%27s_conjectures),
especially the *zero divisor conjecture*.

_Conjecture._
Let `K` be a field, and `G` a torsion-free group. The group ring `K[G]` does not contain
nontrivial zero divisors, that is, it is a domain.

We formalize in this file the well-known result that if `R` is a field and `A` is a left-ordered
group, then `R[A]` contains no non-zero zero-divisors.  Some of these assumptions can be trivially
weakened: below we mention what assumptions are sufficient for the proofs in this file.

##  Main results

* `NoZeroDivisors.of_left_ordered` shows that if `R` is a semiring with no non-zero
  zero-divisors, `A` is a linearly ordered, add right cancel semigroup with strictly monotone
  left addition, then `AddMonoidAlgebra R A` has no non-zero zero-divisors.
* `NoZeroDivisors.of_right_ordered` shows that if `R` is a semiring with no non-zero
  zero-divisors, `A` is a linearly ordered, add left cancel semigroup with strictly monotone
  right addition, then `AddMonoidAlgebra R A` has no non-zero zero-divisors.

The conditions on `A` imposed in `NoZeroDivisors.of_left_ordered` are sometimes referred to as
`left-ordered`.
The conditions on `A` imposed in `NoZeroDivisors.of_right_ordered` are sometimes referred to as
`right-ordered`.

These conditions are sufficient, but not necessary.  As mentioned above, *Kaplansky's Conjecture*
asserts that `A` being torsion-free may be enough.
-/

namespace AddMonoidAlgebra

open Finsupp

variable {R A : Type _} [Semiring R]

/-- The coefficient of a monomial in a product `f * g` that can be reached in at most one way
as a product of monomials in the supports of `f` and `g` is a product. -/
theorem mul_apply_add_eq_mul_of_forall_ne [Add A] {f g : AddMonoidAlgebra R A} {a0 b0 : A}
    (h : ∀ {a b : A}, a ∈ f.support → b ∈ g.support → a ≠ a0 ∨ b ≠ b0 → a + b ≠ a0 + b0) :
    (f * g) (a0 + b0) = f a0 * g b0 := by
  classical
    rw [mul_apply]
    refine' (Finset.sum_eq_single a0 _ _).trans _
    · exact fun b H hb => Finset.sum_eq_zero fun x H1 => if_neg (h H H1 (Or.inl hb))
    · exact fun af0 => by simp [not_mem_support_iff.mp af0]
    · refine' (Finset.sum_eq_single b0 (fun b bg b0 => _) _).trans (if_pos rfl)
      · by_cases af : a0 ∈ f.support
        · exact if_neg (h af bg (Or.inr b0))
        · simp only [not_mem_support_iff.mp af, MulZeroClass.zero_mul, ite_self]
      · exact fun bf0 => by simp [not_mem_support_iff.mp bf0]
#align add_monoid_algebra.mul_apply_add_eq_mul_of_forall_ne AddMonoidAlgebra.mul_apply_add_eq_mul_of_forall_ne

section LeftOrRightOrderability

theorem Left.exists_add_of_mem_support_single_mul [AddLeftCancelSemigroup A]
    {g : AddMonoidAlgebra R A} (a x : A)
    (hx : x ∈ (single a 1 * g : AddMonoidAlgebra R A).support) : ∃ b ∈ g.support, a + b = x := by
  rwa [support_single_mul _ _ (fun y => by rw [one_mul] : ∀ y : R, 1 * y = 0 ↔ _),
    Finset.mem_map] at hx
#align add_monoid_algebra.left.exists_add_of_mem_support_single_mul AddMonoidAlgebra.Left.exists_add_of_mem_support_single_mul

theorem Right.exists_add_of_mem_support_single_mul [AddRightCancelSemigroup A]
    {f : AddMonoidAlgebra R A} (b x : A)
    (hx : x ∈ (f * single b 1 : AddMonoidAlgebra R A).support) : ∃ a ∈ f.support, a + b = x := by
  rwa [support_mul_single _ _ (fun y => by rw [mul_one] : ∀ y : R, y * 1 = 0 ↔ _),
    Finset.mem_map] at hx
#align add_monoid_algebra.right.exists_add_of_mem_support_single_mul AddMonoidAlgebra.Right.exists_add_of_mem_support_single_mul

/-- If `R` is a semiring with no non-trivial zero-divisors and `A` is a left-ordered add right
cancel semigroup, then `AddMonoidAlgebra R A` also contains no non-zero zero-divisors. -/
theorem NoZeroDivisors.of_left_ordered [NoZeroDivisors R] [AddRightCancelSemigroup A]
    [LinearOrder A] [CovariantClass A A (· + ·) (· < ·)] : NoZeroDivisors (AddMonoidAlgebra R A) :=
  ⟨@fun f g fg => by
    contrapose! fg
    let gmin : A := g.support.min' (support_nonempty_iff.mpr fg.2)
    refine' support_nonempty_iff.mp _
    obtain ⟨a, ha, H⟩ :=
      Right.exists_add_of_mem_support_single_mul gmin
        ((f * single gmin 1 : AddMonoidAlgebra R A).support.min'
          (by rw [support_mul_single] <;> simp [support_nonempty_iff.mpr fg.1]))
        (Finset.min'_mem _ _)
    refine' ⟨a + gmin, mem_support_iff.mpr _⟩
    rw [mul_apply_add_eq_mul_of_forall_ne _]
    · refine' mul_ne_zero _ _
      exacts[mem_support_iff.mp ha, mem_support_iff.mp (Finset.min'_mem _ _)]
    · rw [H]
      rintro b c bf cg (hb | hc) <;> refine' ne_of_gt _
      · refine' lt_of_lt_of_le (_ : _ < b + gmin) _
        · apply Finset.min'_lt_of_mem_erase_min'
          rw [← H]
          apply Finset.mem_erase_of_ne_of_mem
          · simpa only [Ne.def, add_left_inj]
          · rw [support_mul_single _ _ (fun y => by rw [mul_one] : ∀ y : R, y * 1 = 0 ↔ _)]
            simpa only [Finset.mem_map, addRightEmbedding_apply, add_left_inj, exists_prop,
              exists_eq_right]
        · haveI : CovariantClass A A (· + ·) (· ≤ ·) := Add.to_covariantClass_left A
          exact add_le_add_left (Finset.min'_le _ _ cg) _
      · refine' lt_of_le_of_lt (_ : _ ≤ b + gmin) _
        · apply Finset.min'_le
          rw [support_mul_single _ _ (fun y => by rw [mul_one] : ∀ y : R, y * 1 = 0 ↔ _)]
          simp only [bf, Finset.mem_map, addRightEmbedding_apply, add_left_inj, exists_prop,
            exists_eq_right]
        · refine' add_lt_add_left _ _
          exact Finset.min'_lt_of_mem_erase_min' _ _ (Finset.mem_erase.mpr ⟨hc, cg⟩)⟩
#align add_monoid_algebra.no_zero_divisors.of_left_ordered AddMonoidAlgebra.NoZeroDivisors.of_left_ordered

/-- If `R` is a semiring with no non-trivial zero-divisors and `A` is a right-ordered add left
cancel semigroup, then `AddMonoidAlgebra R A` also contains no non-zero zero-divisors. -/
theorem NoZeroDivisors.of_right_ordered [NoZeroDivisors R] [AddLeftCancelSemigroup A]
    [LinearOrder A] [CovariantClass A A (Function.swap (· + ·)) (· < ·)] :
    NoZeroDivisors (AddMonoidAlgebra R A) :=
  ⟨@fun f g fg => by
    contrapose! fg
    let fmin : A := f.support.min' (support_nonempty_iff.mpr fg.1)
    refine' support_nonempty_iff.mp _
    obtain ⟨a, ha, H⟩ :=
      Left.exists_add_of_mem_support_single_mul fmin
        ((single fmin 1 * g : AddMonoidAlgebra R A).support.min'
          (by rw [support_single_mul] <;> simp [support_nonempty_iff.mpr fg.2]))
        (Finset.min'_mem _ _)
    refine' ⟨fmin + a, mem_support_iff.mpr _⟩
    rw [mul_apply_add_eq_mul_of_forall_ne _]
    · refine' mul_ne_zero _ _
      exacts[mem_support_iff.mp (Finset.min'_mem _ _), mem_support_iff.mp ha]
    · rw [H]
      rintro b c bf cg (hb | hc) <;> refine' ne_of_gt _
      · refine' lt_of_le_of_lt (_ : _ ≤ fmin + c) _
        · apply Finset.min'_le
          rw [support_single_mul _ _ (fun y => by rw [one_mul] : ∀ y : R, 1 * y = 0 ↔ _)]
          simp only [cg, Finset.mem_map, addLeftEmbedding_apply, add_right_inj, exists_prop,
            exists_eq_right]
        · refine' add_lt_add_right _ _
          exact Finset.min'_lt_of_mem_erase_min' _ _ (Finset.mem_erase.mpr ⟨hb, bf⟩)
      · refine' lt_of_lt_of_le (_ : _ < fmin + c) _
        · apply Finset.min'_lt_of_mem_erase_min'
          rw [← H]
          apply Finset.mem_erase_of_ne_of_mem
          · simpa only [Ne.def, add_right_inj]
          · rw [support_single_mul _ _ (fun y => by rw [one_mul] : ∀ y : R, 1 * y = 0 ↔ _)]
            simpa only [Finset.mem_map, addLeftEmbedding_apply, add_right_inj, exists_prop,
              exists_eq_right]
        · haveI : CovariantClass A A (Function.swap (· + ·)) (· ≤ ·) :=
            Add.to_covariantClass_right A
          exact add_le_add_right (Finset.min'_le _ _ bf) _⟩
#align add_monoid_algebra.no_zero_divisors.of_right_ordered AddMonoidAlgebra.NoZeroDivisors.of_right_ordered

end LeftOrRightOrderability

end AddMonoidAlgebra