/-
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

! This file was ported from Lean 3 source module combinatorics.additive.salem_spencer
! leanprover-community/mathlib commit acf5258c81d0bc7cb254ed026c1352e685df306c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Hom.Freiman
import Mathbin.Analysis.Asymptotics.Asymptotics
import Mathbin.Analysis.Convex.StrictConvexSpace

/-!
# Salem-Spencer sets and Roth numbers

This file defines Salem-Spencer sets and the Roth number of a set.

A Salem-Spencer set is a set without arithmetic progressions of length `3`. Equivalently, the
average of any two distinct elements is not in the set.

The Roth number of a finset is the size of its biggest Salem-Spencer subset. This is a more general
definition than the one often found in mathematical litterature, where the `n`-th Roth number is
the size of the biggest Salem-Spencer subset of `{0, ..., n - 1}`.

## Main declarations

* `mul_salem_spencer`: Predicate for a set to be multiplicative Salem-Spencer.
* `add_salem_spencer`: Predicate for a set to be additive Salem-Spencer.
* `mul_roth_number`: The multiplicative Roth number of a finset.
* `add_roth_number`: The additive Roth number of a finset.
* `roth_number_nat`: The Roth number of a natural. This corresponds to
  `add_roth_number (finset.range n)`.

## TODO

* Can `add_salem_spencer_iff_eq_right` be made more general?
* Generalize `mul_salem_spencer.image` to Freiman homs

## Tags

Salem-Spencer, Roth, arithmetic progression, average, three-free
-/

open Finset Function Metric Nat

open Pointwise

variable {F α β 𝕜 E : Type _}

section SalemSpencer

open Set

section Monoid

variable [Monoid α] [Monoid β] (s t : Set α)

/-- A multiplicative Salem-Spencer, aka non averaging, set `s` in a monoid is a set such that the
multiplicative average of any two distinct elements is not in the set. -/
@[to_additive
      "A Salem-Spencer, aka non averaging, set `s` in an additive monoid\nis a set such that the average of any two distinct elements is not in the set."]
def MulSalemSpencer : Prop :=
  ∀ ⦃a b c⦄, a ∈ s → b ∈ s → c ∈ s → a * b = c * c → a = b
#align mul_salem_spencer MulSalemSpencer
#align add_salem_spencer AddSalemSpencer

/-- Whether a given finset is Salem-Spencer is decidable. -/
@[to_additive "Whether a given finset is Salem-Spencer is decidable."]
instance {α : Type _} [DecidableEq α] [Monoid α] {s : Finset α} :
    Decidable (MulSalemSpencer (s : Set α)) :=
  decidable_of_iff (∀ a ∈ s, ∀ b ∈ s, ∀ c ∈ s, a * b = c * c → a = b)
    ⟨fun h a b c ha hb hc => h a ha b hb c hc, fun h a ha b hb c hc => h ha hb hc⟩

variable {s t}

@[to_additive]
theorem MulSalemSpencer.mono (h : t ⊆ s) (hs : MulSalemSpencer s) : MulSalemSpencer t :=
  fun a b c ha hb hc => hs (h ha) (h hb) (h hc)
#align mul_salem_spencer.mono MulSalemSpencer.mono
#align add_salem_spencer.mono AddSalemSpencer.mono

@[simp, to_additive]
theorem mulSalemSpencer_empty : MulSalemSpencer (∅ : Set α) := fun a _ _ ha => ha.elim
#align mul_salem_spencer_empty mulSalemSpencer_empty
#align add_salem_spencer_empty add_salem_spencer_empty

@[to_additive]
theorem Set.Subsingleton.mulSalemSpencer (hs : s.Subsingleton) : MulSalemSpencer s :=
  fun a b _ ha hb _ _ => hs ha hb
#align set.subsingleton.mul_salem_spencer Set.Subsingleton.mulSalemSpencer
#align set.subsingleton.add_salem_spencer Set.Subsingleton.add_salem_spencer

@[simp, to_additive]
theorem mulSalemSpencer_singleton (a : α) : MulSalemSpencer ({a} : Set α) :=
  subsingleton_singleton.MulSalemSpencer
#align mul_salem_spencer_singleton mulSalemSpencer_singleton
#align add_salem_spencer_singleton add_salem_spencer_singleton

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[to_additive AddSalemSpencer.prod]
theorem MulSalemSpencer.prod {t : Set β} (hs : MulSalemSpencer s) (ht : MulSalemSpencer t) :
    MulSalemSpencer (s ×ˢ t) := fun a b c ha hb hc h =>
  Prod.ext (hs ha.1 hb.1 hc.1 (Prod.ext_iff.1 h).1) (ht ha.2 hb.2 hc.2 (Prod.ext_iff.1 h).2)
#align mul_salem_spencer.prod MulSalemSpencer.prod
#align add_salem_spencer.prod AddSalemSpencer.prod

@[to_additive]
theorem mulSalemSpencer_pi {ι : Type _} {α : ι → Type _} [∀ i, Monoid (α i)] {s : ∀ i, Set (α i)}
    (hs : ∀ i, MulSalemSpencer (s i)) : MulSalemSpencer ((univ : Set ι).pi s) :=
  fun a b c ha hb hc h =>
  funext fun i => hs i (ha i trivial) (hb i trivial) (hc i trivial) <| congr_fun h i
#align mul_salem_spencer_pi mulSalemSpencer_pi
#align add_salem_spencer_pi add_salem_spencer_pi

end Monoid

section CommMonoid

variable [CommMonoid α] [CommMonoid β] {s : Set α} {a : α}

@[to_additive]
theorem MulSalemSpencer.of_image [FunLike F α fun _ => β] [FreimanHomClass F s β 2] (f : F)
    (hf : s.InjOn f) (h : MulSalemSpencer (f '' s)) : MulSalemSpencer s :=
  fun a b c ha hb hc habc =>
  hf ha hb <|
    h (mem_image_of_mem _ ha) (mem_image_of_mem _ hb) (mem_image_of_mem _ hc) <|
      map_mul_map_eq_map_mul_map f ha hb hc hc habc
#align mul_salem_spencer.of_image MulSalemSpencer.of_image
#align add_salem_spencer.of_image AddSalemSpencer.of_image

-- TODO: Generalize to Freiman homs
@[to_additive]
theorem MulSalemSpencer.image [MulHomClass F α β] (f : F) (hf : (s * s).InjOn f)
    (h : MulSalemSpencer s) : MulSalemSpencer (f '' s) :=
  by
  rintro _ _ _ ⟨a, ha, rfl⟩ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ habc
  rw [h ha hb hc (hf (mul_mem_mul ha hb) (mul_mem_mul hc hc) <| by rwa [map_mul, map_mul])]
#align mul_salem_spencer.image MulSalemSpencer.image
#align add_salem_spencer.image AddSalemSpencer.image

end CommMonoid

section CancelCommMonoid

variable [CancelCommMonoid α] {s : Set α} {a : α}

@[to_additive]
theorem mulSalemSpencer_insert :
    MulSalemSpencer (insert a s) ↔
      MulSalemSpencer s ∧
        (∀ ⦃b c⦄, b ∈ s → c ∈ s → a * b = c * c → a = b) ∧
          ∀ ⦃b c⦄, b ∈ s → c ∈ s → b * c = a * a → b = c :=
  by
  refine'
    ⟨fun hs =>
      ⟨hs.mono (subset_insert _ _), fun b c hb hc => hs (Or.inl rfl) (Or.inr hb) (Or.inr hc),
        fun b c hb hc => hs (Or.inr hb) (Or.inr hc) (Or.inl rfl)⟩,
      _⟩
  rintro ⟨hs, ha, ha'⟩ b c d hb hc hd h
  rw [mem_insert_iff] at hb hc hd
  obtain rfl | hb := hb <;> obtain rfl | hc := hc
  · rfl
  all_goals obtain rfl | hd := hd
  · exact (mul_left_cancel h).symm
  · exact ha hc hd h
  · exact mul_right_cancel h
  · exact (ha hb hd <| (mul_comm _ _).trans h).symm
  · exact ha' hb hc h
  · exact hs hb hc hd h
#align mul_salem_spencer_insert mulSalemSpencer_insert
#align add_salem_spencer_insert add_salem_spencer_insert

@[simp, to_additive]
theorem mulSalemSpencer_pair (a b : α) : MulSalemSpencer ({a, b} : Set α) :=
  by
  rw [mulSalemSpencer_insert]
  refine' ⟨mulSalemSpencer_singleton _, _, _⟩
  · rintro c d (rfl : c = b) (rfl : d = c)
    exact mul_right_cancel
  · rintro c d (rfl : c = b) (rfl : d = c) _
    rfl
#align mul_salem_spencer_pair mulSalemSpencer_pair
#align add_salem_spencer_pair add_salem_spencer_pair

@[to_additive]
theorem MulSalemSpencer.mul_left (hs : MulSalemSpencer s) : MulSalemSpencer ((· * ·) a '' s) :=
  by
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h
  rw [mul_mul_mul_comm, mul_mul_mul_comm a d] at h
  rw [hs hb hc hd (mul_left_cancel h)]
#align mul_salem_spencer.mul_left MulSalemSpencer.mul_left
#align add_salem_spencer.add_left AddSalemSpencer.add_left

@[to_additive]
theorem MulSalemSpencer.mul_right (hs : MulSalemSpencer s) : MulSalemSpencer ((· * a) '' s) :=
  by
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h
  rw [mul_mul_mul_comm, mul_mul_mul_comm d] at h
  rw [hs hb hc hd (mul_right_cancel h)]
#align mul_salem_spencer.mul_right MulSalemSpencer.mul_right
#align add_salem_spencer.add_right AddSalemSpencer.add_right

@[to_additive]
theorem mulSalemSpencer_mul_left_iff : MulSalemSpencer ((· * ·) a '' s) ↔ MulSalemSpencer s :=
  ⟨fun hs b c d hb hc hd h =>
    mul_left_cancel
      (hs (mem_image_of_mem _ hb) (mem_image_of_mem _ hc) (mem_image_of_mem _ hd) <| by
        rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
    MulSalemSpencer.mul_left⟩
#align mul_salem_spencer_mul_left_iff mulSalemSpencer_mul_left_iff
#align add_salem_spencer_add_left_iff add_salem_spencer_add_left_iff

@[to_additive]
theorem mulSalemSpencer_mul_right_iff : MulSalemSpencer ((· * a) '' s) ↔ MulSalemSpencer s :=
  ⟨fun hs b c d hb hc hd h =>
    mul_right_cancel
      (hs (Set.mem_image_of_mem _ hb) (Set.mem_image_of_mem _ hc) (Set.mem_image_of_mem _ hd) <| by
        rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
    MulSalemSpencer.mul_right⟩
#align mul_salem_spencer_mul_right_iff mulSalemSpencer_mul_right_iff
#align add_salem_spencer_add_right_iff add_salem_spencer_add_right_iff

end CancelCommMonoid

section OrderedCancelCommMonoid

variable [OrderedCancelCommMonoid α] {s : Set α} {a : α}

@[to_additive]
theorem mulSalemSpencer_insert_of_lt (hs : ∀ i ∈ s, i < a) :
    MulSalemSpencer (insert a s) ↔
      MulSalemSpencer s ∧ ∀ ⦃b c⦄, b ∈ s → c ∈ s → a * b = c * c → a = b :=
  by
  refine' mul_salem_spencer_insert.trans _
  rw [← and_assoc']
  exact and_iff_left fun b c hb hc h => ((mul_lt_mul_of_lt_of_lt (hs _ hb) (hs _ hc)).Ne h).elim
#align mul_salem_spencer_insert_of_lt mulSalemSpencer_insert_of_lt
#align add_salem_spencer_insert_of_lt add_salem_spencer_insert_of_lt

end OrderedCancelCommMonoid

section CancelCommMonoidWithZero

variable [CancelCommMonoidWithZero α] [NoZeroDivisors α] {s : Set α} {a : α}

theorem MulSalemSpencer.mul_left₀ (hs : MulSalemSpencer s) (ha : a ≠ 0) :
    MulSalemSpencer ((· * ·) a '' s) :=
  by
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h
  rw [mul_mul_mul_comm, mul_mul_mul_comm a d] at h
  rw [hs hb hc hd (mul_left_cancel₀ (mul_ne_zero ha ha) h)]
#align mul_salem_spencer.mul_left₀ MulSalemSpencer.mul_left₀

theorem MulSalemSpencer.mul_right₀ (hs : MulSalemSpencer s) (ha : a ≠ 0) :
    MulSalemSpencer ((· * a) '' s) :=
  by
  rintro _ _ _ ⟨b, hb, rfl⟩ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩ h
  rw [mul_mul_mul_comm, mul_mul_mul_comm d] at h
  rw [hs hb hc hd (mul_right_cancel₀ (mul_ne_zero ha ha) h)]
#align mul_salem_spencer.mul_right₀ MulSalemSpencer.mul_right₀

theorem mulSalemSpencer_mul_left_iff₀ (ha : a ≠ 0) :
    MulSalemSpencer ((· * ·) a '' s) ↔ MulSalemSpencer s :=
  ⟨fun hs b c d hb hc hd h =>
    mul_left_cancel₀ ha
      (hs (Set.mem_image_of_mem _ hb) (Set.mem_image_of_mem _ hc) (Set.mem_image_of_mem _ hd) <| by
        rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
    fun hs => hs.mulLeft₀ ha⟩
#align mul_salem_spencer_mul_left_iff₀ mulSalemSpencer_mul_left_iff₀

theorem mulSalemSpencer_mul_right_iff₀ (ha : a ≠ 0) :
    MulSalemSpencer ((· * a) '' s) ↔ MulSalemSpencer s :=
  ⟨fun hs b c d hb hc hd h =>
    mul_right_cancel₀ ha
      (hs (Set.mem_image_of_mem _ hb) (Set.mem_image_of_mem _ hc) (Set.mem_image_of_mem _ hd) <| by
        rw [mul_mul_mul_comm, h, mul_mul_mul_comm]),
    fun hs => hs.mulRight₀ ha⟩
#align mul_salem_spencer_mul_right_iff₀ mulSalemSpencer_mul_right_iff₀

end CancelCommMonoidWithZero

section Nat

theorem addSalemSpencer_iff_eq_right {s : Set ℕ} :
    AddSalemSpencer s ↔ ∀ ⦃a b c⦄, a ∈ s → b ∈ s → c ∈ s → a + b = c + c → a = c :=
  by
  refine' forall₄_congr fun a b c _ => forall₃_congr fun _ _ habc => ⟨_, _⟩
  · rintro rfl
    simp_rw [← two_mul] at habc
    exact mul_left_cancel₀ two_ne_zero habc
  · rintro rfl
    exact (add_left_cancel habc).symm
#align add_salem_spencer_iff_eq_right addSalemSpencer_iff_eq_right

end Nat

/-- The frontier of a closed strictly convex set only contains trivial arithmetic progressions.
The idea is that an arithmetic progression is contained on a line and the frontier of a strictly
convex set does not contain lines. -/
theorem addSalemSpencer_frontier [LinearOrderedField 𝕜] [TopologicalSpace E] [AddCommMonoid E]
    [Module 𝕜 E] {s : Set E} (hs₀ : IsClosed s) (hs₁ : StrictConvex 𝕜 s) :
    AddSalemSpencer (frontier s) := by
  intro a b c ha hb hc habc
  obtain rfl : (1 / 2 : 𝕜) • a + (1 / 2 : 𝕜) • b = c := by
    rwa [← smul_add, one_div, inv_smul_eq_iff₀ (show (2 : 𝕜) ≠ 0 by norm_num), two_smul]
  exact
    hs₁.eq (hs₀.frontier_subset ha) (hs₀.frontier_subset hb) one_half_pos one_half_pos
      (add_halves _) hc.2
#align add_salem_spencer_frontier addSalemSpencer_frontier

theorem addSalemSpencer_sphere [NormedAddCommGroup E] [NormedSpace ℝ E] [StrictConvexSpace ℝ E]
    (x : E) (r : ℝ) : AddSalemSpencer (sphere x r) :=
  by
  obtain rfl | hr := eq_or_ne r 0
  · rw [sphere_zero]
    exact add_salem_spencer_singleton _
  · convert addSalemSpencer_frontier is_closed_ball (strictConvex_closedBall ℝ x r)
    exact (frontier_closedBall _ hr).symm
#align add_salem_spencer_sphere addSalemSpencer_sphere

end SalemSpencer

open Finset

section RothNumber

variable [DecidableEq α]

section Monoid

variable [Monoid α] [DecidableEq β] [Monoid β] (s t : Finset α)

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (t «expr ⊆ » s) -/
/-- The multiplicative Roth number of a finset is the cardinality of its biggest multiplicative
Salem-Spencer subset. -/
@[to_additive
      "The additive Roth number of a finset is the cardinality of its biggest additive\nSalem-Spencer subset. The usual Roth number corresponds to `add_roth_number (finset.range n)`, see\n`roth_number_nat`. "]
def mulRothNumber : Finset α →o ℕ :=
  ⟨fun s =>
    Nat.findGreatest (fun m => ∃ (t : _)(_ : t ⊆ s), t.card = m ∧ MulSalemSpencer (t : Set α))
      s.card,
    by
    rintro t u htu
    refine' Nat.findGreatest_mono (fun m => _) (card_le_of_subset htu)
    rintro ⟨v, hvt, hv⟩
    exact ⟨v, hvt.trans htu, hv⟩⟩
#align mul_roth_number mulRothNumber
#align add_roth_number addRothNumber

@[to_additive]
theorem mulRothNumber_le : mulRothNumber s ≤ s.card := by convert Nat.findGreatest_le s.card
#align mul_roth_number_le mulRothNumber_le
#align add_roth_number_le add_roth_number_le

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (t «expr ⊆ » s) -/
/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (t «expr ⊆ » s) -/
@[to_additive]
theorem mulRothNumber_spec :
    ∃ (t : _)(_ : t ⊆ s), t.card = mulRothNumber s ∧ MulSalemSpencer (t : Set α) :=
  @Nat.findGreatest_spec _ _
    (fun m => ∃ (t : _)(_ : t ⊆ s), t.card = m ∧ MulSalemSpencer (t : Set α)) _ (Nat.zero_le _)
    ⟨∅, empty_subset _, card_empty, mulSalemSpencer_empty⟩
#align mul_roth_number_spec mulRothNumber_spec
#align add_roth_number_spec add_roth_number_spec

variable {s t} {n : ℕ}

@[to_additive]
theorem MulSalemSpencer.le_mulRothNumber (hs : MulSalemSpencer (s : Set α)) (h : s ⊆ t) :
    s.card ≤ mulRothNumber t :=
  le_findGreatest (card_le_of_subset h) ⟨s, h, rfl, hs⟩
#align mul_salem_spencer.le_mul_roth_number MulSalemSpencer.le_mulRothNumber
#align add_salem_spencer.le_add_roth_number AddSalemSpencer.le_add_roth_number

@[to_additive]
theorem MulSalemSpencer.roth_number_eq (hs : MulSalemSpencer (s : Set α)) :
    mulRothNumber s = s.card :=
  (mulRothNumber_le _).antisymm <| hs.le_mulRothNumber <| Subset.refl _
#align mul_salem_spencer.roth_number_eq MulSalemSpencer.roth_number_eq
#align add_salem_spencer.roth_number_eq AddSalemSpencer.roth_number_eq

@[simp, to_additive]
theorem mulRothNumber_empty : mulRothNumber (∅ : Finset α) = 0 :=
  Nat.eq_zero_of_le_zero <| (mulRothNumber_le _).trans card_empty.le
#align mul_roth_number_empty mulRothNumber_empty
#align add_roth_number_empty add_roth_number_empty

@[simp, to_additive]
theorem mulRothNumber_singleton (a : α) : mulRothNumber ({a} : Finset α) = 1 :=
  by
  convert MulSalemSpencer.roth_number_eq _
  rw [coe_singleton]
  exact mulSalemSpencer_singleton a
#align mul_roth_number_singleton mulRothNumber_singleton
#align add_roth_number_singleton add_roth_number_singleton

@[to_additive]
theorem mulRothNumber_union_le (s t : Finset α) :
    mulRothNumber (s ∪ t) ≤ mulRothNumber s + mulRothNumber t :=
  let ⟨u, hus, hcard, hu⟩ := mulRothNumber_spec (s ∪ t)
  calc
    mulRothNumber (s ∪ t) = u.card := hcard.symm
    _ = (u ∩ s ∪ u ∩ t).card := by rw [← inter_distrib_left, (inter_eq_left_iff_subset _ _).2 hus]
    _ ≤ (u ∩ s).card + (u ∩ t).card := (card_union_le _ _)
    _ ≤ mulRothNumber s + mulRothNumber t :=
      add_le_add ((hu.mono <| inter_subset_left _ _).le_mulRothNumber <| inter_subset_right _ _)
        ((hu.mono <| inter_subset_left _ _).le_mulRothNumber <| inter_subset_right _ _)

#align mul_roth_number_union_le mulRothNumber_union_le
#align add_roth_number_union_le add_roth_number_union_le

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[to_additive]
theorem le_mulRothNumber_product (s : Finset α) (t : Finset β) :
    mulRothNumber s * mulRothNumber t ≤ mulRothNumber (s ×ˢ t) :=
  by
  obtain ⟨u, hus, hucard, hu⟩ := mulRothNumber_spec s
  obtain ⟨v, hvt, hvcard, hv⟩ := mulRothNumber_spec t
  rw [← hucard, ← hvcard, ← card_product]
  refine' MulSalemSpencer.le_mulRothNumber _ (product_subset_product hus hvt)
  rw [coe_product]
  exact hu.prod hv
#align le_mul_roth_number_product le_mulRothNumber_product
#align le_add_roth_number_product le_add_roth_number_product

@[to_additive]
theorem mulRothNumber_lt_of_forall_not_mulSalemSpencer
    (h : ∀ t ∈ powersetLen n s, ¬MulSalemSpencer ((t : Finset α) : Set α)) : mulRothNumber s < n :=
  by
  obtain ⟨t, hts, hcard, ht⟩ := mulRothNumber_spec s
  rw [← hcard, ← not_le]
  intro hn
  obtain ⟨u, hut, rfl⟩ := exists_smaller_set t n hn
  exact h _ (mem_powerset_len.2 ⟨hut.trans hts, rfl⟩) (ht.mono hut)
#align mul_roth_number_lt_of_forall_not_mul_salem_spencer mulRothNumber_lt_of_forall_not_mulSalemSpencer
#align add_roth_number_lt_of_forall_not_add_salem_spencer add_roth_number_lt_of_forall_not_add_salem_spencer

end Monoid

section CancelCommMonoid

variable [CancelCommMonoid α] (s : Finset α) (a : α)

@[simp, to_additive]
theorem mulRothNumber_map_mul_left :
    mulRothNumber (s.map <| mulLeftEmbedding a) = mulRothNumber s :=
  by
  refine' le_antisymm _ _
  · obtain ⟨u, hus, hcard, hu⟩ := mulRothNumber_spec (s.map <| mulLeftEmbedding a)
    rw [subset_map_iff] at hus
    obtain ⟨u, hus, rfl⟩ := hus
    rw [coe_map] at hu
    rw [← hcard, card_map]
    exact (mulSalemSpencer_mul_left_iff.1 hu).le_mulRothNumber hus
  · obtain ⟨u, hus, hcard, hu⟩ := mulRothNumber_spec s
    have h : MulSalemSpencer (u.map <| mulLeftEmbedding a : Set α) :=
      by
      rw [coe_map]
      exact hu.mul_left
    convert h.le_mul_roth_number (map_subset_map.2 hus)
    rw [card_map, hcard]
#align mul_roth_number_map_mul_left mulRothNumber_map_mul_left
#align add_roth_number_map_add_left add_roth_number_map_add_left

@[simp, to_additive]
theorem mulRothNumber_map_mul_right :
    mulRothNumber (s.map <| mulRightEmbedding a) = mulRothNumber s := by
  rw [← mul_left_embedding_eq_mul_right_embedding, mulRothNumber_map_mul_left s a]
#align mul_roth_number_map_mul_right mulRothNumber_map_mul_right
#align add_roth_number_map_add_right add_roth_number_map_add_right

end CancelCommMonoid

end RothNumber

section rothNumberNat

variable {s : Finset ℕ} {k n : ℕ}

/-- The Roth number of a natural `N` is the largest integer `m` for which there is a subset of
`range N` of size `m` with no arithmetic progression of length 3.
Trivially, `roth_number_nat N ≤ N`, but Roth's theorem (proved in 1953) shows that
`roth_number_nat N = o(N)` and the construction by Behrend gives a lower bound of the form
`N * exp(-C sqrt(log(N))) ≤ roth_number_nat N`.
A significant refinement of Roth's theorem by Bloom and Sisask announced in 2020 gives
`roth_number_nat N = O(N / (log N)^(1+c))` for an absolute constant `c`. -/
def rothNumberNat : ℕ →o ℕ :=
  ⟨fun n => addRothNumber (range n), addRothNumber.mono.comp range_mono⟩
#align roth_number_nat rothNumberNat

theorem rothNumberNat_def (n : ℕ) : rothNumberNat n = addRothNumber (range n) :=
  rfl
#align roth_number_nat_def rothNumberNat_def

theorem rothNumberNat_le (N : ℕ) : rothNumberNat N ≤ N :=
  (add_roth_number_le _).trans (card_range _).le
#align roth_number_nat_le rothNumberNat_le

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (t «expr ⊆ » range[finset.range] n) -/
theorem rothNumberNat_spec (n : ℕ) :
    ∃ (t : _)(_ : t ⊆ range n), t.card = rothNumberNat n ∧ AddSalemSpencer (t : Set ℕ) :=
  add_roth_number_spec _
#align roth_number_nat_spec rothNumberNat_spec

/-- A verbose specialization of `add_salem_spencer.le_add_roth_number`, sometimes convenient in
practice. -/
theorem AddSalemSpencer.le_rothNumberNat (s : Finset ℕ) (hs : AddSalemSpencer (s : Set ℕ))
    (hsn : ∀ x ∈ s, x < n) (hsk : s.card = k) : k ≤ rothNumberNat n :=
  hsk.ge.trans <| hs.le_add_roth_number fun x hx => mem_range.2 <| hsn x hx
#align add_salem_spencer.le_roth_number_nat AddSalemSpencer.le_rothNumberNat

/-- The Roth number is a subadditive function. Note that by Fekete's lemma this shows that
the limit `roth_number_nat N / N` exists, but Roth's theorem gives the stronger result that this
limit is actually `0`. -/
theorem rothNumberNat_add_le (M N : ℕ) :
    rothNumberNat (M + N) ≤ rothNumberNat M + rothNumberNat N :=
  by
  simp_rw [rothNumberNat_def]
  rw [range_add_eq_union, ← add_roth_number_map_add_left (range N) M]
  exact add_roth_number_union_le _ _
#align roth_number_nat_add_le rothNumberNat_add_le

@[simp]
theorem rothNumberNat_zero : rothNumberNat 0 = 0 :=
  rfl
#align roth_number_nat_zero rothNumberNat_zero

theorem addRothNumber_Ico (a b : ℕ) : addRothNumber (Ico a b) = rothNumberNat (b - a) :=
  by
  obtain h | h := le_total b a
  · rw [tsub_eq_zero_of_le h, Ico_eq_empty_of_le h, rothNumberNat_zero, add_roth_number_empty]
  convert add_roth_number_map_add_left _ a
  rw [range_eq_Ico, map_eq_image]
  convert(image_add_left_Ico 0 (b - a) _).symm
  exact (add_tsub_cancel_of_le h).symm
#align add_roth_number_Ico addRothNumber_Ico

open Asymptotics Filter

theorem rothNumberNat_isOWith_id :
    IsOWith 1 atTop (fun N => (rothNumberNat N : ℝ)) fun N => (N : ℝ) :=
  isOWith_of_le _ <| by simpa only [Real.norm_coe_nat, Nat.cast_le] using rothNumberNat_le
#align roth_number_nat_is_O_with_id rothNumberNat_isOWith_id

/-- The Roth number has the trivial bound `roth_number_nat N = O(N)`. -/
theorem rothNumberNat_isO_id : (fun N => (rothNumberNat N : ℝ)) =O[atTop] fun N => (N : ℝ) :=
  rothNumberNat_isOWith_id.IsO
#align roth_number_nat_is_O_id rothNumberNat_isO_id

end rothNumberNat


import natural_deduction
import semantics

variables {vars : Type} {Γ : set (Form vars)} {A B C : Form vars}

/-- A complete set of formulas contains, for every formula A, either A
or its negation.

Note: this is a different use of the word from the "completeness theorem",
which pertains to the derivation and semantic system, not to sets.
-/
def complete (Γ : set (Form vars)) : Prop :=
  ∀ (A : Form vars), A ∈ Γ ∨ (~ A) ∈ Γ

/-- Let Γ be a set of formulas (we will also require Γ be consistent but this
is asserted in the corresponding theorem lindenbaum_fn_consistent and
lindenbaum_lemma).

Using the denumeration A₀, A₁, ... of all formulas, define the following sequence
of sets inductively:

 Γ₀ = Γ

 Γₙ₊₁ = if consistent (insert Aₙ Γₙ) then insert Aₙ Γₙ else insert (~ Aₙ) Γₙ
-/
def lindenbaum_fn (Γ : set (Form vars)) [denumerable vars]
  [∀ (Γ : set (Form vars)), decidable (consistent Γ)] : ℕ → set (Form vars)
| 0 := Γ
| (n + 1) :=
let Aₙ := denumerable.of_nat (Form vars) n in
if consistent (insert Aₙ (lindenbaum_fn n))
then insert Aₙ (lindenbaum_fn n)
else insert (~ Aₙ) (lindenbaum_fn n)

/-- Each of the Γₙ defined above are consistent if the source set Γ is consistent -/
lemma lindenbaum_fn_consistent {Γ : set (Form vars)} {hcon : consistent Γ}
  [denumerable vars] [∀ (Γ : set (Form vars)), decidable (consistent Γ)]
  : ∀ n, consistent (lindenbaum_fn Γ n) :=
begin
  intro n,
  induction n,
  -- Γ₀ = Γ is consistent by assumption
  case nat.zero { exact hcon },
  case nat.succ : k ih {
    simp [lindenbaum_fn, apply_ite consistent],
    set A  := denumerable.of_nat (Form vars) k,
    set Γₖ := lindenbaum_fn Γ k,
    by_cases hc : consistent (insert A Γₖ),
    -- if inserting A is consistent, then the goal immediately follows.
    { rw if_pos hc, exact hc },
    -- if inserting A is inconsistent, then we prove by contradiction since if
    -- inserting A or ~ A are both inconsistent, then we can show it is
    -- already inconsistent before insertion, thus contradicting the ih.
    { rw if_neg hc, by_contra hnc, simp [consistent] at hc hnc,
      exact ih (Deriv.Not_E (Deriv.Not_I hnc) (Deriv.Not_I hc)),
    }
  }
end

/-- If i ≤ n, then Γᵢ ⊆ Γₙ, i.e. latter Γs contain all the previous ones. -/
lemma lindenbaum_fn_chain {Γ : set (Form vars)} {n i : ℕ} (hi : i ≤ n)
  [denumerable vars] [∀ (Γ : set (Form vars)), decidable (consistent Γ)]
  : lindenbaum_fn Γ i ⊆ lindenbaum_fn Γ n :=
begin
  cases lt_or_eq_of_le hi with hlt heq,
  -- if i = n then its trivial
  swap, { rw heq },
  -- otherwise induction
  clear hi,
  induction n,
  -- if n = 0 then there's no i < 0 so vacuously true
  case nat.zero { simp at hlt, exfalso, exact hlt },
  -- for the inductive case
  case nat.succ : k ih {
    simp [lindenbaum_fn],
    set A := denumerable.of_nat (Form vars) k,
    split_ifs with hc,
    { cases lt_or_eq_of_le (nat.le_of_lt_succ hlt) with hlt heq,
      -- if (hlt : i < k) then by the ih Γᵢ ⊆ Γₖ and Γₖ ⊆ Γₖ₊₁
      {exact trans (ih hlt) (set.subset_insert A _) },
      -- otherwise (heq : i = k) so Γᵢ = Γₖ and Γₖ ⊆ Γₖ₊₁
      { rw heq, exact set.subset_insert A _ }
    },
    { -- exact same proof as above since we don't care about what formula is being inserted
      cases lt_or_eq_of_le (nat.le_of_lt_succ hlt) with hlt heq,
      -- if (hlt : i < k) then by the ih Γᵢ ⊆ Γₖ and Γₖ ⊆ Γₖ₊₁
      { exact trans (ih hlt) (set.subset_insert (~ A) _) },
      -- otherwise (heq : i = k) so Γᵢ = Γₖ and Γₖ ⊆ Γₖ₊₁
      { rw heq, exact set.subset_insert (~ A) _ }
    }
  }
end

/-- We show that we can take union of all the Γᵢ defined above to form a
completion of Γ that preserves Γ's consistency. -/
lemma lindenbaum_lemma (Γ : set (Form vars)) (hcon : consistent Γ)
  [denumerable vars] [∀ (Γ : set (Form vars)), decidable (consistent Γ)]
  : ∃ CΓ, Γ ⊆ CΓ ∧ complete CΓ ∧ consistent CΓ :=
begin
  let CΓ := ⋃ (i : ℕ), (lindenbaum_fn Γ i),
  refine ⟨CΓ, _, _, _⟩,
  -- Γ ⊆ CΓ
  { exact set.subset_Union (lindenbaum_fn Γ) 0 },
  -- complete CΓ
  { rw complete,
    intro A,
    simp,
    -- if A appears as the nth formula, then it is inserted in Γₙ₊₁
    have hA : A ∈ lindenbaum_fn Γ (encodable.encode A + 1) ∨
       (~ A) ∈ lindenbaum_fn Γ (encodable.encode A + 1), {
      simp [lindenbaum_fn],
      split_ifs with hc,
      { left, exact set.mem_insert A _ },
      { right, exact set.mem_insert (~A) _ },
    },
    cases hA,
    { left,
      use encodable.encode A + 1,
      exact hA },
    { right,
      use encodable.encode A + 1,
      exact hA }
  },
  -- consistent CΓ
  { -- First we show that every finite subset of CΓ is a subset of Γₙ for some n
    have hfinsub : ∀ (Δ : set (Form vars)), Δ.finite → Δ ⊆ CΓ → ∃n, Δ ⊆ lindenbaum_fn Γ n, {
      intros Δ hΔfin hsub,
      by_cases hne : Δ.nonempty,
      { -- Suppose Δ is nonempty.
        -- Because Δ is finite, it is a subset of the union of a finite amount of
        -- the Γᵢs in CΓ. We want to take the max of the indices i, as the Γₙ with the greatest
        -- index contains all the other Γᵢs - and so contains Δ.
        have := set.finite_subset_Union hΔfin hsub,
        -- finΓ is the set of indices n - it is finite and defines a subset of CΓ that contains Δ
        rcases this with ⟨finΓ, ⟨hfinΓ⟩, hsubfinΓ⟩,
        haveI := hfinΓ, -- to allow the fintype typeclass to be resolved implicitly
        -- Since Δ is non-empty, finΓ is nonempty, so the maximum over finΓ is defined.
        have hfinΓne : finΓ.to_finset.nonempty, {
          cases hne with A hA,
          specialize hsubfinΓ hA,
          simp at hsubfinΓ,
          rcases hsubfinΓ with ⟨i, hi, _⟩,
          use i,
          rwa set.mem_to_finset,
        },
        use finΓ.to_finset.max' hfinΓne,
        set max_i := finΓ.to_finset.max' hfinΓne,
        -- Now we reason about each δ ∈ Δ from the fact that it belongs to some Γᵢ
        -- where i belongs in finΓ.
        intros δ hδ,
        specialize hsubfinΓ hδ, simp at hsubfinΓ,
        rcases hsubfinΓ with ⟨i, hi, hmemΓi⟩,
        -- using lindenbaum_fn_chain we can show each δ belongs to Γ_max_i
        apply lindenbaum_fn_chain,
        exact finset.le_max' (finΓ.to_finset) i
                             (set.mem_to_finset.mpr hi),
        exact hmemΓi
      },
      -- otherwise if Δ is empty, its trivially a subset of any set
      -- so we can pick any Γₙ - let's pick Γ₀ for simplicity.
      { use 0, simp [set.not_nonempty_iff_eq_empty] at hne, rw hne, simp},
    },
    -- every finite subset of CΓ is consistent, since it is a subset of some Γₙ
    -- and those are all consistent.
    have hfincon : ∀ (Δ : set (Form vars)), Δ ⊆ CΓ → Δ.finite → consistent Δ, {
      intros Δ hsub hΔfin,
      rcases hfinsub Δ hΔfin hsub with ⟨n, hsubΓn⟩,
      apply mt (Deriv.Weakening hsubΓn),
      apply lindenbaum_fn_consistent n, exact hcon -- why can't it resolve hcon implicitly???
    },
    --
    exact deriv_compactness' hfincon,
  }
end

/-- From the Lindenbaum completion, we can build a semantic model
(variable assignment) of propositional logic. -/
def lindenbaum_model (CΓ : set (Form vars)) [∀p, decidable (⦃p⦄ ∈ CΓ)]
  : vars → bool :=
λ p, if ⦃p⦄ ∈ CΓ then true else false

lemma contradiction_of_deriv_of_nmem
  (hcomp : complete Γ) (hcon : consistent Γ)
  : (Γ ⊩ A) →  A ∉ Γ → false :=
begin
  intros hdA hAnin,
  have : (~ A) ∈ Γ := (or_iff_right hAnin).mp (hcomp A),
  have hdnA : (Γ ⊩ ~ A) := Deriv.Ax this,
  have hincon : inconsistent Γ := Deriv.Not_E hdnA hdA,
  exact hcon hincon
end

lemma deriv_iff_mem
  (hcomp : complete Γ) (hcon : consistent Γ) : (Γ ⊩ A) ↔ A ∈ Γ :=
begin
  split,
  { intro hdA,
    by_contra hAnin,
    exact contradiction_of_deriv_of_nmem hcomp hcon hdA hAnin
  },
  { exact Deriv.Ax }
end

/-- We can now show that this new model reflects membership in the completion. -/
lemma truth_lemma
  (CΓ : set (Form vars)) [∀p, decidable (⦃p⦄ ∈ CΓ)]
  (hcomp : complete CΓ) (hcon : consistent CΓ)
  : ↥(lindenbaum_model CΓ ⊨ A) ↔ A ∈ CΓ :=
begin
  induction A,
  case Form.Bottom {
    simp [eval],
    rw ←deriv_iff_mem hcomp hcon,
    exact hcon
  },
  case Form.Var {
    simp [eval, lindenbaum_model],
    split_ifs,
    {simp, exact h},
    {simp, exact h}
  },
  case Form.Not : A ih {
    simp [eval, ih],
    split,
    { intro h, exact (or_iff_right h).mp (hcomp A) },
    {
      intro hnA,
      by_contra hA,
      have hincon : inconsistent CΓ := Deriv.Not_E (Deriv.Ax hnA) (Deriv.Ax hA),
      exact hcon hincon
    },
  },
  case Form.And : A B ihA ihB {
    simp [eval, ihA, ihB],
    split,
    { rintro ⟨hA, hB⟩,
      have hdAB : (CΓ ⊩ (A ⋀ B)) := Deriv.And_I (Deriv.Ax hA) (Deriv.Ax hB),
      by_contra hABnin,
      exact contradiction_of_deriv_of_nmem hcomp hcon hdAB hABnin
    },
    { intro hAB,
      have hdA : (CΓ ⊩ A) := Deriv.And_E_1 (Deriv.Ax hAB),
      have hdB : (CΓ ⊩ B) := Deriv.And_E_2 (Deriv.Ax hAB),
      split,
      {by_contra hAnin, exact contradiction_of_deriv_of_nmem hcomp hcon hdA hAnin},
      {by_contra hBnin, exact contradiction_of_deriv_of_nmem hcomp hcon hdB hBnin}
    },
  },
  case Form.Or : A B ihA ihB {
    simp[eval, ihA, ihB],
    split,
    { intro h,
      rw ←deriv_iff_mem hcomp hcon,
      cases h with hA hB,
      { exact Deriv.Or_I_1 (Deriv.Ax hA) },
      { exact Deriv.Or_I_2 (Deriv.Ax hB) }
    },
    { intro hAB,
      by_contra h,
      rw [not_or_distrib] at h,
      cases h with hAnin hBnin,
      have hnAin : (~ A) ∈ CΓ := (or_iff_right hAnin).mp (hcomp A),
      have hnBin : (~ B) ∈ CΓ := (or_iff_right hBnin).mp (hcomp B),
      /- Build the derivation:
                    (Ax)------------ (Ax)----------   (Ax)----------- (Ax)----------
                        CΓ, A ⊩ ~ A      CΓ, A ⊩ A       CΓ, B ⊩ ~ B     CΓ, B ⊩ B
    (Ax)----------- (~E)---------------------------   (~E)--------------------------
        CΓ ⊩ A ⋁ B             CΓ, A ⊩ ⊥                        CΓ, B ⊩ ⊥
        ---------------------------------------------------------------------------
                                      CΓ ⊩ ⊥
      -/
      have hincon : (inconsistent CΓ), {
        apply Deriv.Or_E,
        { exact Deriv.Ax hAB },
        { apply Deriv.Not_E,
          exact Deriv.Ax (or.intro_right _ hnAin),
          exact Deriv.Ax (or.intro_left _ rfl)},
        { apply Deriv.Not_E,
          exact Deriv.Ax (or.intro_right _ hnBin),
          exact Deriv.Ax (or.intro_left _ rfl)
        }
      },
      exact hcon hincon
    }
  },
end

theorem completeness' {Γ : set (Form vars)} [denumerable vars]
  : consistent Γ → satisfiable Γ :=
begin
  -- specifically, we need membership in CΓ to be decidable
  -- and consistency of sets of formulas to be decicable
  -- hence we use classical reasoning
  classical,
  intro hcon,
  -- construct the lindenbaum completion CΓ of Γ
  rcases lindenbaum_lemma Γ hcon with ⟨CΓ, hsuper, hcomp, hcon⟩,
  simp [satisfiable],
  -- build a model out of CΓ
  use lindenbaum_model CΓ,
  -- for every sentence γ ∈ Γ,
  intros γ hγ,
  -- it is entailed by the model iff γ ∈ CΓ (by the truth lemma)
  rw truth_lemma CΓ hcomp hcon,
  -- but that's easy to show since Γ ⊆ CΓ
  apply hsuper,
  exact hγ
end

theorem completeness [denumerable vars] {Γ : set (Form vars)} {A : Form vars}
  : (Γ ⊨ A) → (Γ ⊩ A) :=
begin
  intro hA,
  -- We rely on the fact that if Γ ⊨ A, then insert (~ A) Γ ⊨ ⊥
  have : ¬ satisfiable (insert (~ A) Γ), {
    rw [satisfiable_iff, entail], simp,
    intros v hnA hΓ,
    -- since hA : Γ ⊨ A, and hΓ : v ⊨ Γ, then also v ⊨ A
    specialize hA v hΓ,
    -- but this contradicts with the fact that hnA : v ⊨ ~ A
    -- which allows us to prove falsehood
    simp [eval] at hnA,
    simp [hnA] at hA,
    -- but falsehood is equivalent to entailing ⊥,
    -- which is exactly what we need
    simp [eval],
    exact hA
  },
  -- By the completeness' theorem, we can conclude that (~ A) :: Γ is
  -- inconsistent, so (~ A) :: Γ ⊩ ⊥.
  have : ¬ consistent (insert (~ A) Γ) := mt completeness' this,
  simp [consistent] at this,
  -- Applying the Contra derivation step, we find exactly what we need.
  exact Deriv.Contra this
end

#lint


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

/-!
# The standard basis

This file defines the standard basis `std_basis R φ i b j`, which is `b` where `i = j` and `0`
elsewhere.

To give a concrete example, `std_basis R (λ (i : fin 3), R) i 1` gives the `i`th unit basis vector
in `R³`, and `pi.is_basis_fun` proves this is a basis over `fin 3 → R`.

## Main definitions

 - `linear_map.std_basis R ϕ i b`: the `i`'th standard `R`-basis vector on `Π i, ϕ i`,
   scaled by `b`.

## Main results

 - `pi.is_basis_std_basis`: `std_basis` turns a component-wise basis into a basis on the product
   type.
 - `pi.is_basis_fun`: `std_basis R (λ _, R) i 1` is a basis for `n → R`.

-/

open function submodule
open_locale big_operators
open_locale big_operators

namespace linear_map

variables (R : Type*) {ι : Type*} [semiring R] (φ : ι → Type*)
  [Π i, add_comm_monoid (φ i)] [Π i, module R (φ i)] [decidable_eq ι]

/-- The standard basis of the product of `φ`. -/
def std_basis : Π (i : ι), φ i →ₗ[R] (Πi, φ i) := single

lemma std_basis_apply (i : ι) (b : φ i) : std_basis R φ i b = update 0 i b :=
rfl

lemma coe_std_basis (i : ι) : ⇑(std_basis R φ i) = pi.single i :=
funext $ std_basis_apply R φ i

@[simp] lemma std_basis_same (i : ι) (b : φ i) : std_basis R φ i b i = b :=
by rw [std_basis_apply, update_same]

lemma std_basis_ne (i j : ι) (h : j ≠ i) (b : φ i) : std_basis R φ i b j = 0 :=
by rw [std_basis_apply, update_noteq h]; refl

lemma std_basis_eq_pi_diag (i : ι) : std_basis R φ i = pi (diag i) :=
begin
  ext x j,
  convert (update_apply 0 x i j _).symm,
  refl,
end

lemma ker_std_basis (i : ι) : ker (std_basis R φ i) = ⊥ :=
ker_eq_bot_of_injective $ assume f g hfg,
  have std_basis R φ i f i = std_basis R φ i g i := hfg ▸ rfl,
  by simpa only [std_basis_same]

lemma proj_comp_std_basis (i j : ι) : (proj i).comp (std_basis R φ j) = diag j i :=
by rw [std_basis_eq_pi_diag, proj_pi]

lemma proj_std_basis_same (i : ι) : (proj i).comp (std_basis R φ i) = id :=
by ext b; simp

lemma proj_std_basis_ne (i j : ι) (h : i ≠ j) : (proj i).comp (std_basis R φ j) = 0 :=
by ext b; simp [std_basis_ne R φ _ _ h]

lemma supr_range_std_basis_le_infi_ker_proj (I J : set ι) (h : disjoint I J) :
  (⨆i∈I, range (std_basis R φ i)) ≤ (⨅i∈J, ker (proj i)) :=
begin
  refine (supr_le $ assume i, supr_le $ assume hi, range_le_iff_comap.2 _),
  simp only [(ker_comp _ _).symm, eq_top_iff, set_like.le_def, mem_ker, comap_infi, mem_infi],
  assume b hb j hj,
  have : i ≠ j := assume eq, h ⟨hi, eq.symm ▸ hj⟩,
  rw [mem_comap, mem_ker, ← comp_apply, proj_std_basis_ne R φ j i this.symm, zero_apply]
end

lemma infi_ker_proj_le_supr_range_std_basis {I : finset ι} {J : set ι} (hu : set.univ ⊆ ↑I ∪ J) :
  (⨅ i∈J, ker (proj i)) ≤ (⨆i∈I, range (std_basis R φ i)) :=
set_like.le_def.2
begin
  assume b hb,
  simp only [mem_infi, mem_ker, proj_apply] at hb,
  rw ← show ∑ i in I, std_basis R φ i (b i) = b,
  { ext i,
    rw [finset.sum_apply, ← std_basis_same R φ i (b i)],
    refine finset.sum_eq_single i (assume j hjI ne, std_basis_ne _ _ _ _ ne.symm _) _,
    assume hiI,
    rw [std_basis_same],
    exact hb _ ((hu trivial).resolve_left hiI) },
  exact sum_mem _ (assume i hiI, mem_supr_of_mem i $ mem_supr_of_mem hiI $
    (std_basis R φ i).mem_range_self (b i))
end

lemma supr_range_std_basis_eq_infi_ker_proj {I J : set ι}
  (hd : disjoint I J) (hu : set.univ ⊆ I ∪ J) (hI : set.finite I) :
  (⨆i∈I, range (std_basis R φ i)) = (⨅i∈J, ker (proj i)) :=
begin
  refine le_antisymm (supr_range_std_basis_le_infi_ker_proj _ _ _ _ hd) _,
  have : set.univ ⊆ ↑hI.to_finset ∪ J, { rwa [hI.coe_to_finset] },
  refine le_trans (infi_ker_proj_le_supr_range_std_basis R φ this) (supr_le_supr $ assume i, _),
  rw [set.finite.mem_to_finset],
  exact le_refl _
end

lemma supr_range_std_basis [fintype ι] : (⨆i:ι, range (std_basis R φ i)) = ⊤ :=
have (set.univ : set ι) ⊆ ↑(finset.univ : finset ι) ∪ ∅ := by rw [finset.coe_univ, set.union_empty],
begin
  apply top_unique,
  convert (infi_ker_proj_le_supr_range_std_basis R φ this),
  exact infi_emptyset.symm,
  exact (funext $ λi, (@supr_pos _ _ _ (λh, range (std_basis R φ i)) $ finset.mem_univ i).symm)
end

lemma disjoint_std_basis_std_basis (I J : set ι) (h : disjoint I J) :
  disjoint (⨆i∈I, range (std_basis R φ i)) (⨆i∈J, range (std_basis R φ i)) :=
begin
  refine disjoint.mono
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right)
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right) _,
  simp only [disjoint, set_like.le_def, mem_infi, mem_inf, mem_ker, mem_bot, proj_apply,
    funext_iff],
  rintros b ⟨hI, hJ⟩ i,
  classical,
  by_cases hiI : i ∈ I,
  { by_cases hiJ : i ∈ J,
    { exact (h ⟨hiI, hiJ⟩).elim },
    { exact hJ i hiJ } },
  { exact hI i hiI }
end

lemma std_basis_eq_single {a : R} :
  (λ (i : ι), (std_basis R (λ _ : ι, R) i) a) = λ (i : ι), (finsupp.single i a) :=
begin
  ext i j,
  rw [std_basis_apply, finsupp.single_apply],
  split_ifs,
  { rw [h, function.update_same] },
  { rw [function.update_noteq (ne.symm h)], refl },
end

end linear_map

namespace pi
open linear_map
open set

variables {R : Type*}

section module
variables {η : Type*} {ιs : η → Type*} {Ms : η → Type*}

lemma linear_independent_std_basis [ring R] [∀i, add_comm_group (Ms i)] [∀i, module R (Ms i)]
  [decidable_eq η] (v : Πj, ιs j → (Ms j)) (hs : ∀i, linear_independent R (v i)) :
  linear_independent R (λ (ji : Σ j, ιs j), std_basis R Ms ji.1 (v ji.1 ji.2)) :=
begin
  have hs' : ∀j : η, linear_independent R (λ i : ιs j, std_basis R Ms j (v j i)),
  { intro j,
    exact (hs j).map' _ (ker_std_basis _ _ _) },
  apply linear_independent_Union_finite hs',
  { assume j J _ hiJ,
    simp [(set.Union.equations._eqn_1 _).symm, submodule.span_image, submodule.span_Union],
    have h₀ : ∀ j, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ range (std_basis R Ms j),
    { intro j,
      rw [span_le, linear_map.range_coe],
      apply range_comp_subset_range },
    have h₁ : span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ ⨆ i ∈ {j}, range (std_basis R Ms i),
    { rw @supr_singleton _ _ _ (λ i, linear_map.range (std_basis R (λ (j : η), Ms j) i)),
      apply h₀ },
    have h₂ : (⨆ j ∈ J, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))) ≤
               ⨆ j ∈ J, range (std_basis R (λ (j : η), Ms j) j) :=
      supr_le_supr (λ i, supr_le_supr (λ H, h₀ i)),
    have h₃ : disjoint (λ (i : η), i ∈ {j}) J,
    { convert set.disjoint_singleton_left.2 hiJ using 0 },
    exact (disjoint_std_basis_std_basis _ _ _ _ h₃).mono h₁ h₂ }
end

variables [semiring R] [∀i, add_comm_monoid (Ms i)] [∀i, module R (Ms i)]

variable [fintype η]

section

open linear_equiv

/-- `pi.basis (s : ∀ j, basis (ιs j) R (Ms j))` is the `Σ j, ιs j`-indexed basis on `Π j, Ms j`
given by `s j` on each component. -/
protected noncomputable def basis (s : ∀ j, basis (ιs j) R (Ms j)) :
  basis (Σ j, ιs j) R (Π j, Ms j) :=
-- The `add_comm_monoid (Π j, Ms j)` instance was hard to find.
-- Defining this in tactic mode seems to shake up instance search enough that it works by itself.
by { refine basis.of_repr (_ ≪≫ₗ (finsupp.sigma_finsupp_lequiv_pi_finsupp R).symm),
     exact linear_equiv.Pi_congr_right (λ j, (s j).repr) }

@[simp] lemma basis_repr_std_basis [decidable_eq η] (s : ∀ j, basis (ιs j) R (Ms j)) (j i) :
  (pi.basis s).repr (std_basis R _ j (s j i)) = finsupp.single ⟨j, i⟩ 1 :=
begin
  ext ⟨j', i'⟩,
  by_cases hj : j = j',
  { subst hj,
    simp only [pi.basis, linear_equiv.trans_apply, basis.repr_self, std_basis_same,
        linear_equiv.Pi_congr_right_apply, finsupp.sigma_finsupp_lequiv_pi_finsupp_symm_apply],
    symmetry,
    exact basis.finsupp.single_apply_left
      (λ i i' (h : (⟨j, i⟩ : Σ j, ιs j) = ⟨j, i'⟩), eq_of_heq (sigma.mk.inj h).2) _ _ _ },
  simp only [pi.basis, linear_equiv.trans_apply, finsupp.sigma_finsupp_lequiv_pi_finsupp_symm_apply,
      linear_equiv.Pi_congr_right_apply],
  dsimp,
  rw [std_basis_ne _ _ _ _ (ne.symm hj), linear_equiv.map_zero, finsupp.zero_apply,
      finsupp.single_eq_of_ne],
  rintros ⟨⟩,
  contradiction
end

@[simp] lemma basis_apply [decidable_eq η] (s : ∀ j, basis (ιs j) R (Ms j)) (ji) :
  pi.basis s ji = std_basis R _ ji.1 (s ji.1 ji.2) :=
basis.apply_eq_iff.mpr (by simp)

@[simp] lemma basis_repr (s : ∀ j, basis (ιs j) R (Ms j)) (x) (ji) :
  (pi.basis s).repr x ji = (s ji.1).repr (x ji.1) ji.2 :=
rfl

end

section
variables (R η)

/-- The basis on `η → R` where the `i`th basis vector is `function.update 0 i 1`. -/
noncomputable def basis_fun : basis η R (Π (j : η), R) :=
basis.of_equiv_fun (linear_equiv.refl _ _)

@[simp] lemma basis_fun_apply [decidable_eq η] (i) :
  basis_fun R η i = std_basis R (λ (i : η), R) i 1 :=
by { simp only [basis_fun, basis.coe_of_equiv_fun, linear_equiv.refl_symm,
                linear_equiv.refl_apply, std_basis_apply],
     congr /- Get rid of a `decidable_eq` mismatch. -/ }

@[simp] lemma basis_fun_repr (x : η → R) (i : η) :
  (pi.basis_fun R η).repr x i = x i :=
by simp [basis_fun]

end

end module

end pi

namespace matrix

variables (R : Type*) (n : Type*) (m : Type*) [fintype m] [fintype n] [semiring R]

/-- The standard basis of `matrix n m R`. -/
noncomputable def std_basis : basis (n × m) R (matrix n m R) :=
basis.reindex (pi.basis (λ (i : n), pi.basis_fun R m)) (equiv.sigma_equiv_prod _ _)

variables {n m}

lemma std_basis_eq_std_basis_matrix (i : n) (j : m) [decidable_eq n] [decidable_eq m] :
  std_basis R n m (i, j) = std_basis_matrix i j (1 : R) :=
begin
  ext a b,
  by_cases hi : i = a; by_cases hj : j = b,
  { simp [std_basis, hi, hj] },
  { simp [std_basis, hi, hj, ne.symm hj, linear_map.std_basis_ne] },
  { simp [std_basis, hi, hj, ne.symm hi, linear_map.std_basis_ne] },
  { simp [std_basis, hi, hj, ne.symm hj, ne.symm hi, linear_map.std_basis_ne] }
end

end matrix


import tactic.ring data.real.basic

example (x y : ℕ) : x + y = y + x := by ring
example (x y : ℕ) : x + y + y = 2 * y + x := by ring
example {α} [comm_ring α] (x y : α) : x + y + y - x = 2 * y := by ring
example (x y : ℚ) : x / 2 + x / 2 = x := by ring
example (x y : ℚ) : (x + y) ^ 3 = x ^ 3 + y ^ 3 + 3 * (x * y ^ 2 + x ^ 2 * y) := by ring
example (x y : ℝ) : (x + y) ^ 3 = x ^ 3 + y ^ 3 + 3 * (x * y ^ 2 + x ^ 2 * y) := by ring
example {α} [comm_semiring α] (x : α) : (x + 1) ^ 6 = (1 + x) ^ 6 := by try_for 15000 {ring}


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.instances.real_vector_space
import analysis.normed_space.add_torsor
import linear_algebra.affine_space.midpoint
import analysis.normed_space.linear_isometry

/-!
# Mazur-Ulam Theorem

Mazur-Ulam theorem states that an isometric bijection between two normed affine spaces over `ℝ` is
affine. We formalize it in three definitions:

* `isometric.to_real_linear_isometry_equiv_of_map_zero` : given `E ≃ᵢ F` sending `0` to `0`,
  returns `E ≃ₗᵢ[ℝ] F` with the same `to_fun` and `inv_fun`;
* `isometric.to_real_linear_isometry_equiv` : given `f : E ≃ᵢ F`,
  returns `g : E ≃ₗᵢ[ℝ] F` with `g x = f x - f 0`.
* `isometric.to_affine_equiv` : given `PE ≃ᵢ PF`, returns `g : PE ≃ᵃ[ℝ] PF` with the same
  `to_equiv`.

The formalization is based on [Jussi Väisälä, *A Proof of the Mazur-Ulam Theorem*][Vaisala_2003].

## Tags

isometry, affine map, linear map
-/

variables
  {E PE : Type*} [normed_group E] [normed_space ℝ E] [metric_space PE] [normed_add_torsor E PE]
  {F PF : Type*} [normed_group F] [normed_space ℝ F] [metric_space PF] [normed_add_torsor F PF]

open set affine_map

noncomputable theory

namespace isometric

include E

/-- If an isometric self-homeomorphism of a normed vector space over `ℝ` fixes `x` and `y`,
then it fixes the midpoint of `[x, y]`. This is a lemma for a more general Mazur-Ulam theorem,
see below. -/
lemma midpoint_fixed {x y : PE} :
  ∀ e : PE ≃ᵢ PE, e x = x → e y = y → e (midpoint ℝ x y) = midpoint ℝ x y :=
begin
  set z := midpoint ℝ x y,
  -- Consider the set of `e : E ≃ᵢ E` such that `e x = x` and `e y = y`
  set s := { e : PE ≃ᵢ PE | e x = x ∧ e y = y },
  haveI : nonempty s := ⟨⟨isometric.refl PE, rfl, rfl⟩⟩,
  -- On the one hand, `e` cannot send the midpoint `z` of `[x, y]` too far
  have h_bdd : bdd_above (range $ λ e : s, dist (e z) z),
  { refine ⟨dist x z + dist x z, forall_range_iff.2 $ subtype.forall.2 _⟩,
    rintro e ⟨hx, hy⟩,
    calc dist (e z) z ≤ dist (e z) x + dist x z     : dist_triangle (e z) x z
                  ... = dist (e x) (e z) + dist x z : by rw [hx, dist_comm]
                  ... = dist x z + dist x z         : by erw [e.dist_eq x z] },
  -- On the other hand, consider the map `f : (E ≃ᵢ E) → (E ≃ᵢ E)`
  -- sending each `e` to `R ∘ e⁻¹ ∘ R ∘ e`, where `R` is the point reflection in the
  -- midpoint `z` of `[x, y]`.
  set R : PE ≃ᵢ PE := point_reflection z,
  set f : (PE ≃ᵢ PE) → (PE ≃ᵢ PE) := λ e, ((e.trans R).trans e.symm).trans R,
  -- Note that `f` doubles the value of ``dist (e z) z`
  have hf_dist : ∀ e, dist (f e z) z = 2 * dist (e z) z,
  { intro e,
    dsimp [f],
    rw [dist_point_reflection_fixed, ← e.dist_eq, e.apply_symm_apply,
      dist_point_reflection_self_real, dist_comm] },
  -- Also note that `f` maps `s` to itself
  have hf_maps_to : maps_to f s s,
  { rintros e ⟨hx, hy⟩,
    split; simp [hx, hy, e.symm_apply_eq.2 hx.symm, e.symm_apply_eq.2 hy.symm], },
  -- Therefore, `dist (e z) z = 0` for all `e ∈ s`.
  set c := ⨆ e : s, dist (e z) z,
  have : c ≤ c / 2,
  { apply csupr_le,
    rintros ⟨e, he⟩,
    simp only [coe_fn_coe_base, subtype.coe_mk, le_div_iff' (@zero_lt_two ℝ _ _), ← hf_dist],
    exact le_csupr h_bdd ⟨f e, hf_maps_to he⟩ },
  replace : c ≤ 0, { linarith },
  refine λ e hx hy, dist_le_zero.1 (le_trans _ this),
  exact le_csupr h_bdd ⟨e, hx, hy⟩
end

include F

/-- A bijective isometry sends midpoints to midpoints. -/
lemma map_midpoint (f : PE ≃ᵢ PF) (x y : PE) : f (midpoint ℝ x y) = midpoint ℝ (f x) (f y) :=
begin
  set e : PE ≃ᵢ PE := ((f.trans $ point_reflection $ midpoint ℝ (f x) (f y)).trans f.symm).trans
    (point_reflection $ midpoint ℝ x y),
  have hx : e x = x, by simp,
  have hy : e y = y, by simp,
  have hm := e.midpoint_fixed hx hy,
  simp only [e, trans_apply] at hm,
  rwa [← eq_symm_apply, point_reflection_symm, point_reflection_self, symm_apply_eq,
    point_reflection_fixed_iff ℝ] at hm,
  apply_instance
end

/-!
Since `f : PE ≃ᵢ PF` sends midpoints to midpoints, it is an affine map.
We define a conversion to a `continuous_linear_equiv` first, then a conversion to an `affine_map`.
-/

/-- Mazur-Ulam Theorem: if `f` is an isometric bijection between two normed vector spaces
over `ℝ` and `f 0 = 0`, then `f` is a linear equivalence. -/
def to_real_linear_isometry_equiv_of_map_zero (f : E ≃ᵢ F) (h0 : f 0 = 0) :
  E ≃ₗᵢ[ℝ] F :=
{ norm_map' := λ x, show ∥f x∥ = ∥x∥, by simp only [← dist_zero_right, ← h0, f.dist_eq],
  .. ((add_monoid_hom.of_map_midpoint ℝ ℝ f h0 f.map_midpoint).to_real_linear_map f.continuous),
  .. f }

@[simp] lemma coe_to_real_linear_equiv_of_map_zero (f : E ≃ᵢ F) (h0 : f 0 = 0) :
  ⇑(f.to_real_linear_isometry_equiv_of_map_zero h0) = f := rfl

@[simp] lemma coe_to_real_linear_equiv_of_map_zero_symm (f : E ≃ᵢ F) (h0 : f 0 = 0) :
  ⇑(f.to_real_linear_isometry_equiv_of_map_zero h0).symm = f.symm := rfl

/-- Mazur-Ulam Theorem: if `f` is an isometric bijection between two normed vector spaces
over `ℝ`, then `x ↦ f x - f 0` is a linear equivalence. -/
def to_real_linear_isometry_equiv (f : E ≃ᵢ F) : E ≃ₗᵢ[ℝ] F :=
(f.trans (isometric.add_right (f 0)).symm).to_real_linear_isometry_equiv_of_map_zero
  (by simpa only [sub_eq_add_neg] using sub_self (f 0))

@[simp] lemma to_real_linear_equiv_apply (f : E ≃ᵢ F) (x : E) :
  (f.to_real_linear_isometry_equiv : E → F) x = f x - f 0 :=
(sub_eq_add_neg (f x) (f 0)).symm

@[simp] lemma to_real_linear_isometry_equiv_symm_apply (f : E ≃ᵢ F) (y : F) :
  (f.to_real_linear_isometry_equiv.symm : F → E) y = f.symm (y + f 0) := rfl

/-- Convert an isometric equivalence between two affine spaces to an `affine_map`. -/
def to_affine_equiv (f : PE ≃ᵢ PF) : PE ≃ᵃ[ℝ] PF :=
affine_equiv.mk' f.to_equiv
  (((vadd_const (classical.arbitrary PE)).trans $ f.trans
    (vadd_const (f $ classical.arbitrary PE)).symm).to_real_linear_isometry_equiv.to_linear_equiv)
  (classical.arbitrary PE) (λ p, by simp)

@[simp] lemma coe_to_affine_equiv (f : PE ≃ᵢ PF) : ⇑f.to_affine_equiv = f := rfl

end isometric