/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.finset.prod
import data.set.finite

/-!
# N-ary images of finsets

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

This file defines `finset.image₂`, the binary image of finsets. This is the finset version of
`set.image2`. This is mostly useful to define pointwise operations.

## Notes

This file is very similar to `data.set.n_ary`, `order.filter.n_ary` and `data.option.n_ary`. Please
keep them in sync.

We do not define `finset.image₃` as its only purpose would be to prove properties of `finset.image₂`
and `set.image2` already fulfills this task.
-/

open function set

variables {α α' β β' γ γ' δ δ' ε ε' ζ ζ' ν : Type*}

namespace finset
variables [decidable_eq α'] [decidable_eq β'] [decidable_eq γ] [decidable_eq γ'] [decidable_eq δ]
  [decidable_eq δ'] [decidable_eq ε] [decidable_eq ε']
  {f f' : α → β → γ} {g g' : α → β → γ → δ} {s s' : finset α} {t t' : finset β} {u u' : finset γ}
  {a a' : α} {b b' : β} {c : γ}

/-- The image of a binary function `f : α → β → γ` as a function `finset α → finset β → finset γ`.
Mathematically this should be thought of as the image of the corresponding function `α × β → γ`. -/
def image₂ (f : α → β → γ) (s : finset α) (t : finset β) : finset γ :=
(s ×ˢ t).image $ uncurry f

@[simp] lemma mem_image₂ : c ∈ image₂ f s t ↔ ∃ a b, a ∈ s ∧ b ∈ t ∧ f a b = c :=
by simp [image₂, and_assoc]

@[simp, norm_cast] lemma coe_image₂ (f : α → β → γ) (s : finset α) (t : finset β) :
  (image₂ f s t : set γ) = set.image2 f s t :=
set.ext $ λ _, mem_image₂

lemma card_image₂_le (f : α → β → γ) (s : finset α) (t : finset β) :
  (image₂ f s t).card ≤ s.card * t.card :=
card_image_le.trans_eq $ card_product _ _

lemma card_image₂_iff :
  (image₂ f s t).card = s.card * t.card ↔ (s ×ˢ t : set (α × β)).inj_on (λ x, f x.1 x.2) :=
by { rw [←card_product, ←coe_product], exact card_image_iff }

lemma card_image₂ (hf : injective2 f) (s : finset α) (t : finset β) :
  (image₂ f s t).card = s.card * t.card :=
(card_image_of_injective _ hf.uncurry).trans $ card_product _ _

lemma mem_image₂_of_mem (ha : a ∈ s) (hb : b ∈ t) : f a b ∈ image₂ f s t :=
mem_image₂.2 ⟨a, b, ha, hb, rfl⟩

lemma mem_image₂_iff (hf : injective2 f) : f a b ∈ image₂ f s t ↔ a ∈ s ∧ b ∈ t :=
by rw [←mem_coe, coe_image₂, mem_image2_iff hf, mem_coe, mem_coe]

lemma image₂_subset (hs : s ⊆ s') (ht : t ⊆ t') : image₂ f s t ⊆ image₂ f s' t' :=
by { rw [←coe_subset, coe_image₂, coe_image₂], exact image2_subset hs ht }

lemma image₂_subset_left (ht : t ⊆ t') : image₂ f s t ⊆ image₂ f s t' := image₂_subset subset.rfl ht

lemma image₂_subset_right (hs : s ⊆ s') : image₂ f s t ⊆ image₂ f s' t :=
image₂_subset hs subset.rfl

lemma image_subset_image₂_left (hb : b ∈ t) : s.image (λ a, f a b) ⊆ image₂ f s t :=
image_subset_iff.2 $ λ a ha, mem_image₂_of_mem ha hb

lemma image_subset_image₂_right (ha : a ∈ s) : t.image (λ b, f a b) ⊆ image₂ f s t :=
image_subset_iff.2 $ λ b, mem_image₂_of_mem ha

lemma forall_image₂_iff {p : γ → Prop} : (∀ z ∈ image₂ f s t, p z) ↔ ∀ (x ∈ s) (y ∈ t), p (f x y) :=
by simp_rw [←mem_coe, coe_image₂, forall_image2_iff]

@[simp] lemma image₂_subset_iff : image₂ f s t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), f x y ∈ u :=
forall_image₂_iff

lemma image₂_subset_iff_left : image₂ f s t ⊆ u ↔ ∀ a ∈ s, t.image (λ b, f a b) ⊆ u :=
by simp_rw [image₂_subset_iff, image_subset_iff]

lemma image₂_subset_iff_right : image₂ f s t ⊆ u ↔ ∀ b ∈ t, s.image (λ a, f a b) ⊆ u :=
by simp_rw [image₂_subset_iff, image_subset_iff, @forall₂_swap α]

@[simp] lemma image₂_nonempty_iff : (image₂ f s t).nonempty ↔ s.nonempty ∧ t.nonempty :=
by { rw [←coe_nonempty, coe_image₂], exact image2_nonempty_iff }

lemma nonempty.image₂ (hs : s.nonempty) (ht : t.nonempty) : (image₂ f s t).nonempty :=
image₂_nonempty_iff.2 ⟨hs, ht⟩

lemma nonempty.of_image₂_left (h : (image₂ f s t).nonempty) : s.nonempty :=
(image₂_nonempty_iff.1 h).1

lemma nonempty.of_image₂_right (h : (image₂ f s t).nonempty) : t.nonempty :=
(image₂_nonempty_iff.1 h).2

@[simp] lemma image₂_empty_left : image₂ f ∅ t = ∅ := coe_injective $ by simp
@[simp] lemma image₂_empty_right : image₂ f s ∅ = ∅ := coe_injective $ by simp
@[simp] lemma image₂_eq_empty_iff : image₂ f s t = ∅ ↔ s = ∅ ∨ t = ∅ :=
by simp_rw [←not_nonempty_iff_eq_empty, image₂_nonempty_iff, not_and_distrib]

@[simp] lemma image₂_singleton_left : image₂ f {a} t = t.image (λ b, f a b) := ext $ λ x, by simp
@[simp] lemma image₂_singleton_right : image₂ f s {b} = s.image (λ a, f a b) := ext $ λ x, by simp
lemma image₂_singleton_left' : image₂ f {a} t = t.image (f a) := image₂_singleton_left

lemma image₂_singleton : image₂ f {a} {b} = {f a b} := by simp

lemma image₂_union_left [decidable_eq α] : image₂ f (s ∪ s') t = image₂ f s t ∪ image₂ f s' t :=
coe_injective $ by { push_cast, exact image2_union_left }

lemma image₂_union_right [decidable_eq β] : image₂ f s (t ∪ t') = image₂ f s t ∪ image₂ f s t' :=
coe_injective $ by { push_cast, exact image2_union_right }

@[simp] lemma image₂_insert_left [decidable_eq α] :
  image₂ f (insert a s) t = t.image (λ b, f a b) ∪ image₂ f s t :=
coe_injective $ by { push_cast, exact image2_insert_left }

@[simp] lemma image₂_insert_right [decidable_eq β] :
  image₂ f s (insert b t) = s.image (λ a, f a b) ∪ image₂ f s t :=
coe_injective $ by { push_cast, exact image2_insert_right }

lemma image₂_inter_left [decidable_eq α] (hf : injective2 f) :
  image₂ f (s ∩ s') t = image₂ f s t ∩ image₂ f s' t :=
coe_injective $ by { push_cast, exact image2_inter_left hf }

lemma image₂_inter_right [decidable_eq β] (hf : injective2 f) :
  image₂ f s (t ∩ t') = image₂ f s t ∩ image₂ f s t' :=
coe_injective $ by { push_cast, exact image2_inter_right hf }

lemma image₂_inter_subset_left [decidable_eq α] :
  image₂ f (s ∩ s') t ⊆ image₂ f s t ∩ image₂ f s' t :=
coe_subset.1 $ by { push_cast, exact image2_inter_subset_left }

lemma image₂_inter_subset_right [decidable_eq β] :
  image₂ f s (t ∩ t') ⊆ image₂ f s t ∩ image₂ f s t' :=
coe_subset.1 $ by { push_cast, exact image2_inter_subset_right }

lemma image₂_congr (h : ∀ (a ∈ s) (b ∈ t), f a b = f' a b) : image₂ f s t = image₂ f' s t :=
coe_injective $ by { push_cast, exact image2_congr h }

/-- A common special case of `image₂_congr` -/
lemma image₂_congr' (h : ∀ a b, f a b = f' a b) : image₂ f s t = image₂ f' s t :=
image₂_congr $ λ a _ b _, h a b

lemma subset_image₂ {s : set α} {t : set β} (hu : ↑u ⊆ image2 f s t) :
  ∃ (s' : finset α) (t' : finset β), ↑s' ⊆ s ∧ ↑t' ⊆ t ∧ u ⊆ image₂ f s' t' :=
begin
  apply finset.induction_on' u,
  { exact ⟨∅, ∅, set.empty_subset _, set.empty_subset _, empty_subset _⟩ },
  rintro a u ha _ _ ⟨s', t', hs, hs', h⟩,
  obtain ⟨x, y, hx, hy, ha⟩ := hu ha,
  haveI := classical.dec_eq α,
  haveI := classical.dec_eq β,
  refine ⟨insert x s', insert y t', _⟩,
  simp_rw [coe_insert, set.insert_subset],
  exact ⟨⟨hx, hs⟩, ⟨hy, hs'⟩, insert_subset.2 ⟨mem_image₂.2 ⟨x, y, mem_insert_self _ _,
    mem_insert_self _ _, ha⟩, h.trans $ image₂_subset (subset_insert _ _) $ subset_insert _ _⟩⟩,
end

variables (s t)

lemma card_image₂_singleton_left (hf : injective (f a)) : (image₂ f {a} t).card = t.card :=
by rw [image₂_singleton_left, card_image_of_injective _ hf]

lemma card_image₂_singleton_right (hf : injective (λ a, f a b)) : (image₂ f s {b}).card = s.card :=
by rw [image₂_singleton_right, card_image_of_injective _ hf]

lemma image₂_singleton_inter [decidable_eq β] (t₁ t₂ : finset β) (hf : injective (f a)) :
  image₂ f {a} (t₁ ∩ t₂) = image₂ f {a} t₁ ∩ image₂ f {a} t₂ :=
by simp_rw [image₂_singleton_left, image_inter _ _ hf]

lemma image₂_inter_singleton [decidable_eq α] (s₁ s₂ : finset α) (hf : injective (λ a, f a b)) :
  image₂ f (s₁ ∩ s₂) {b} = image₂ f s₁ {b} ∩ image₂ f s₂ {b} :=
by simp_rw [image₂_singleton_right, image_inter _ _ hf]

lemma card_le_card_image₂_left {s : finset α} (hs : s.nonempty) (hf : ∀ a, injective (f a)) :
  t.card ≤ (image₂ f s t).card :=
begin
  obtain ⟨a, ha⟩ := hs,
  rw ←card_image₂_singleton_left _ (hf a),
  exact card_le_of_subset (image₂_subset_right $ singleton_subset_iff.2 ha),
end

lemma card_le_card_image₂_right {t : finset β} (ht : t.nonempty)
  (hf : ∀ b, injective (λ a, f a b)) :
  s.card ≤ (image₂ f s t).card :=
begin
  obtain ⟨b, hb⟩ := ht,
  rw ←card_image₂_singleton_right _ (hf b),
  exact card_le_of_subset (image₂_subset_left $ singleton_subset_iff.2 hb),
end

variables {s t}

lemma bUnion_image_left : s.bUnion (λ a, t.image $ f a) = image₂ f s t :=
coe_injective $ by { push_cast, exact set.Union_image_left _ }

lemma bUnion_image_right : t.bUnion (λ b, s.image $ λ a, f a b) = image₂ f s t :=
coe_injective $ by { push_cast, exact set.Union_image_right _ }

/-!
### Algebraic replacement rules

A collection of lemmas to transfer associativity, commutativity, distributivity, ... of operations
to the associativity, commutativity, distributivity, ... of `finset.image₂` of those operations.

The proof pattern is `image₂_lemma operation_lemma`. For example, `image₂_comm mul_comm` proves that
`image₂ (*) f g = image₂ (*) g f` in a `comm_semigroup`.
-/

lemma image_image₂ (f : α → β → γ) (g : γ → δ) :
  (image₂ f s t).image g = image₂ (λ a b, g (f a b)) s t :=
coe_injective $ by { push_cast, exact image_image2 _ _ }

lemma image₂_image_left (f : γ → β → δ) (g : α → γ) :
  image₂ f (s.image g) t = image₂ (λ a b, f (g a) b) s t :=
coe_injective $ by { push_cast, exact image2_image_left _ _ }

lemma image₂_image_right (f : α → γ → δ) (g : β → γ) :
  image₂ f s (t.image g) = image₂ (λ a b, f a (g b)) s t :=
coe_injective $ by { push_cast, exact image2_image_right _ _ }

@[simp] lemma image₂_mk_eq_product [decidable_eq α] [decidable_eq β] (s : finset α) (t : finset β) :
  image₂ prod.mk s t = s ×ˢ t :=
by ext; simp [prod.ext_iff]

@[simp] lemma image₂_curry (f : α × β → γ) (s : finset α) (t : finset β) :
  image₂ (curry f) s t = (s ×ˢ t).image f :=
by { classical, rw [←image₂_mk_eq_product, image_image₂, curry] }

@[simp] lemma image_uncurry_product (f : α → β → γ) (s : finset α) (t : finset β) :
  (s ×ˢ t).image (uncurry f) = image₂ f s t := by rw [←image₂_curry, curry_uncurry]

lemma image₂_swap (f : α → β → γ) (s : finset α) (t : finset β) :
  image₂ f s t = image₂ (λ a b, f b a) t s :=
coe_injective $ by { push_cast, exact image2_swap _ _ _ }

@[simp] lemma image₂_left [decidable_eq α] (h : t.nonempty) : image₂ (λ x y, x) s t = s :=
coe_injective $ by { push_cast, exact image2_left h }

@[simp] lemma image₂_right [decidable_eq β] (h : s.nonempty) : image₂ (λ x y, y) s t = t :=
coe_injective $ by { push_cast, exact image2_right h }

lemma image₂_assoc {γ : Type*} {u : finset γ} {f : δ → γ → ε} {g : α → β → δ} {f' : α → ε' → ε}
  {g' : β → γ → ε'} (h_assoc : ∀ a b c, f (g a b) c = f' a (g' b c)) :
  image₂ f (image₂ g s t) u = image₂ f' s (image₂ g' t u) :=
coe_injective $ by { push_cast, exact image2_assoc h_assoc }

lemma image₂_left_comm {γ : Type*} {u : finset γ} {f : α → δ → ε} {g : β → γ → δ} {f' : α → γ → δ'}
  {g' : β → δ' → ε} (h_left_comm : ∀ a b c, f a (g b c) = g' b (f' a c)) :
  image₂ f s (image₂ g t u) = image₂ g' t (image₂ f' s u) :=
coe_injective $ by { push_cast, exact image2_left_comm h_left_comm }

lemma image₂_right_comm {γ : Type*} {u : finset γ} {f : δ → γ → ε} {g : α → β → δ} {f' : α → γ → δ'}
  {g' : δ' → β → ε} (h_right_comm : ∀ a b c, f (g a b) c = g' (f' a c) b) :
  image₂ f (image₂ g s t) u = image₂ g' (image₂ f' s u) t :=
coe_injective $ by { push_cast, exact image2_right_comm h_right_comm }

lemma image₂_image₂_image₂_comm {γ δ : Type*} {u : finset γ} {v : finset δ} [decidable_eq ζ]
  [decidable_eq ζ'] [decidable_eq ν] {f : ε → ζ → ν} {g : α → β → ε} {h : γ → δ → ζ}
  {f' : ε' → ζ' → ν} {g' : α → γ → ε'} {h' : β → δ → ζ'}
  (h_comm : ∀ a b c d, f (g a b) (h c d) = f' (g' a c) (h' b d)) :
  image₂ f (image₂ g s t) (image₂ h u v) = image₂ f' (image₂ g' s u) (image₂ h' t v) :=
coe_injective $ by { push_cast, exact image2_image2_image2_comm h_comm }

lemma image_image₂_distrib {g : γ → δ} {f' : α' → β' → δ} {g₁ : α → α'} {g₂ : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' (g₁ a) (g₂ b)) :
  (image₂ f s t).image g = image₂ f' (s.image g₁) (t.image g₂) :=
coe_injective $ by { push_cast, exact image_image2_distrib h_distrib }

/-- Symmetric statement to `finset.image₂_image_left_comm`. -/
lemma image_image₂_distrib_left {g : γ → δ} {f' : α' → β → δ} {g' : α → α'}
  (h_distrib : ∀ a b, g (f a b) = f' (g' a) b) :
  (image₂ f s t).image g = image₂ f' (s.image g') t :=
coe_injective $ by { push_cast, exact image_image2_distrib_left h_distrib }

/-- Symmetric statement to `finset.image_image₂_right_comm`. -/
lemma image_image₂_distrib_right {g : γ → δ} {f' : α → β' → δ} {g' : β → β'}
  (h_distrib : ∀ a b, g (f a b) = f' a (g' b)) :
  (image₂ f s t).image g = image₂ f' s (t.image g') :=
coe_injective $ by { push_cast, exact image_image2_distrib_right h_distrib }

/-- Symmetric statement to `finset.image_image₂_distrib_left`. -/
lemma image₂_image_left_comm {f : α' → β → γ} {g : α → α'} {f' : α → β → δ} {g' : δ → γ}
  (h_left_comm : ∀ a b, f (g a) b = g' (f' a b)) :
  image₂ f (s.image g) t = (image₂ f' s t).image g' :=
(image_image₂_distrib_left $ λ a b, (h_left_comm a b).symm).symm

/-- Symmetric statement to `finset.image_image₂_distrib_right`. -/
lemma image_image₂_right_comm {f : α → β' → γ} {g : β → β'} {f' : α → β → δ} {g' : δ → γ}
  (h_right_comm : ∀ a b, f a (g b) = g' (f' a b)) :
  image₂ f s (t.image g) = (image₂ f' s t).image g' :=
(image_image₂_distrib_right $ λ a b, (h_right_comm a b).symm).symm

/-- The other direction does not hold because of the `s`-`s` cross terms on the RHS. -/
lemma image₂_distrib_subset_left {γ : Type*} {u : finset γ} {f : α → δ → ε} {g : β → γ → δ}
  {f₁ : α → β → β'} {f₂ : α → γ → γ'} {g' : β' → γ' → ε}
  (h_distrib : ∀ a b c, f a (g b c) = g' (f₁ a b) (f₂ a c)) :
  image₂ f s (image₂ g t u) ⊆ image₂ g' (image₂ f₁ s t) (image₂ f₂ s u) :=
coe_subset.1 $ by { push_cast, exact set.image2_distrib_subset_left h_distrib }

/-- The other direction does not hold because of the `u`-`u` cross terms on the RHS. -/
lemma image₂_distrib_subset_right {γ : Type*} {u : finset γ} {f : δ → γ → ε} {g : α → β → δ}
  {f₁ : α → γ → α'} {f₂ : β → γ → β'} {g' : α' → β' → ε}
  (h_distrib : ∀ a b c, f (g a b) c = g' (f₁ a c) (f₂ b c)) :
  image₂ f (image₂ g s t) u ⊆ image₂ g' (image₂ f₁ s u) (image₂ f₂ t u) :=
coe_subset.1 $ by { push_cast, exact set.image2_distrib_subset_right h_distrib }

lemma image_image₂_antidistrib {g : γ → δ} {f' : β' → α' → δ} {g₁ : β → β'} {g₂ : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g₁ b) (g₂ a)) :
  (image₂ f s t).image g = image₂ f' (t.image g₁) (s.image g₂) :=
by { rw image₂_swap f, exact image_image₂_distrib (λ _ _, h_antidistrib _ _) }

/-- Symmetric statement to `finset.image₂_image_left_anticomm`. -/
lemma image_image₂_antidistrib_left {g : γ → δ} {f' : β' → α → δ} {g' : β → β'}
  (h_antidistrib : ∀ a b, g (f a b) = f' (g' b) a) :
  (image₂ f s t).image g = image₂ f' (t.image g') s :=
coe_injective $ by { push_cast, exact image_image2_antidistrib_left h_antidistrib }

/-- Symmetric statement to `finset.image_image₂_right_anticomm`. -/
lemma image_image₂_antidistrib_right {g : γ → δ} {f' : β → α' → δ} {g' : α → α'}
  (h_antidistrib : ∀ a b, g (f a b) = f' b (g' a)) :
  (image₂ f s t).image g = image₂ f' t (s.image g') :=
coe_injective $ by { push_cast, exact image_image2_antidistrib_right h_antidistrib }

/-- Symmetric statement to `finset.image_image₂_antidistrib_left`. -/
lemma image₂_image_left_anticomm {f : α' → β → γ} {g : α → α'} {f' : β → α → δ} {g' : δ → γ}
  (h_left_anticomm : ∀ a b, f (g a) b = g' (f' b a)) :
  image₂ f (s.image g) t = (image₂ f' t s).image g' :=
(image_image₂_antidistrib_left $ λ a b, (h_left_anticomm b a).symm).symm

/-- Symmetric statement to `finset.image_image₂_antidistrib_right`. -/
lemma image_image₂_right_anticomm {f : α → β' → γ} {g : β → β'} {f' : β → α → δ} {g' : δ → γ}
  (h_right_anticomm : ∀ a b, f a (g b) = g' (f' b a)) :
  image₂ f s (t.image g) = (image₂ f' t s).image g' :=
(image_image₂_antidistrib_right $ λ a b, (h_right_anticomm b a).symm).symm

/-- If `a` is a left identity for `f : α → β → β`, then `{a}` is a left identity for
`finset.image₂ f`. -/
lemma image₂_left_identity {f : α → γ → γ} {a : α} (h : ∀ b, f a b = b) (t : finset γ) :
  image₂ f {a} t = t :=
coe_injective $ by rw [coe_image₂, coe_singleton, set.image2_left_identity h]

/-- If `b` is a right identity for `f : α → β → α`, then `{b}` is a right identity for
`finset.image₂ f`. -/
lemma image₂_right_identity {f : γ → β → γ} {b : β} (h : ∀ a, f a b = a) (s : finset γ) :
  image₂ f s {b} = s :=
by rw [image₂_singleton_right, funext h, image_id']

variables [decidable_eq α] [decidable_eq β]

lemma image₂_inter_union_subset_union :
  image₂ f (s ∩ s') (t ∪ t') ⊆ image₂ f s t ∪ image₂ f s' t' :=
coe_subset.1 $ by { push_cast, exact set.image2_inter_union_subset_union }

lemma image₂_union_inter_subset_union :
  image₂ f (s ∪ s') (t ∩ t') ⊆ image₂ f s t ∪ image₂ f s' t' :=
coe_subset.1 $ by { push_cast, exact set.image2_union_inter_subset_union }

lemma image₂_inter_union_subset {f : α → α → β} {s t : finset α} (hf : ∀ a b, f a b = f b a) :
  image₂ f (s ∩ t) (s ∪ t) ⊆ image₂ f s t :=
coe_subset.1 $ by { push_cast, exact image2_inter_union_subset hf }

lemma image₂_union_inter_subset {f : α → α → β} {s t : finset α} (hf : ∀ a b, f a b = f b a) :
  image₂ f (s ∪ t) (s ∩ t) ⊆ image₂ f s t :=
coe_subset.1 $ by { push_cast, exact image2_union_inter_subset hf }

end finset

namespace set
variables [decidable_eq γ] {s : set α} {t : set β}

@[simp] lemma to_finset_image2 (f : α → β → γ) (s : set α) (t : set β) [fintype s] [fintype t]
  [fintype (image2 f s t)] :
  (image2 f s t).to_finset = finset.image₂ f s.to_finset t.to_finset :=
finset.coe_injective $ by simp

lemma finite.to_finset_image2 (f : α → β → γ) (hs : s.finite) (ht : t.finite)
  (hf := hs.image2 f ht) :
  hf.to_finset = finset.image₂ f hs.to_finset ht.to_finset :=
finset.coe_injective $ by simp

end set


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

! This file was ported from Lean 3 source module analysis.locally_convex.bounded
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.LocallyConvex.Basic
import Mathbin.Analysis.LocallyConvex.BalancedCoreHull
import Mathbin.Analysis.Seminorm
import Mathbin.Topology.Bornology.Basic
import Mathbin.Topology.Algebra.UniformGroup
import Mathbin.Topology.UniformSpace.Cauchy

/-!
# Von Neumann Boundedness

This file defines natural or von Neumann bounded sets and proves elementary properties.

## Main declarations

* `bornology.is_vonN_bounded`: A set `s` is von Neumann-bounded if every neighborhood of zero
absorbs `s`.
* `bornology.vonN_bornology`: The bornology made of the von Neumann-bounded sets.

## Main results

* `bornology.is_vonN_bounded.of_topological_space_le`: A coarser topology admits more
von Neumann-bounded sets.
* `bornology.is_vonN_bounded.image`: A continuous linear image of a bounded set is bounded.
* `bornology.is_vonN_bounded_iff_smul_tendsto_zero`: Given any sequence `ε` of scalars which tends
  to `𝓝[≠] 0`, we have that a set `S` is bounded if and only if for any sequence `x : ℕ → S`,
  `ε • x` tends to 0. This shows that bounded sets are completely determined by sequences, which is
  the key fact for proving that sequential continuity implies continuity for linear maps defined on
  a bornological space

## References

* [Bourbaki, *Topological Vector Spaces*][bourbaki1987]

-/

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

open Set Filter

open Topology Pointwise

namespace Bornology

section SeminormedRing

section Zero

variable (𝕜)

variable [SeminormedRing 𝕜] [SMul 𝕜 E] [Zero E]

variable [TopologicalSpace E]

/-- A set `s` is von Neumann bounded if every neighborhood of 0 absorbs `s`. -/
def IsVonNBounded (s : Set E) : Prop :=
  ∀ ⦃V⦄, V ∈ 𝓝 (0 : E) → Absorbs 𝕜 V s
#align bornology.is_vonN_bounded Bornology.IsVonNBounded

variable (E)

@[simp]
theorem isVonNBounded_empty : IsVonNBounded 𝕜 (∅ : Set E) := fun _ _ => absorbs_empty
#align bornology.is_vonN_bounded_empty Bornology.isVonNBounded_empty

variable {𝕜 E}

theorem isVonNBounded_iff (s : Set E) : IsVonNBounded 𝕜 s ↔ ∀ V ∈ 𝓝 (0 : E), Absorbs 𝕜 V s :=
  Iff.rfl
#align bornology.is_vonN_bounded_iff Bornology.isVonNBounded_iff

theorem Filter.HasBasis.isVonNBounded_basis_iff {q : ι → Prop} {s : ι → Set E} {A : Set E}
    (h : (𝓝 (0 : E)).HasBasis q s) : IsVonNBounded 𝕜 A ↔ ∀ (i) (hi : q i), Absorbs 𝕜 (s i) A :=
  by
  refine' ⟨fun hA i hi => hA (h.mem_of_mem hi), fun hA V hV => _⟩
  rcases h.mem_iff.mp hV with ⟨i, hi, hV⟩
  exact (hA i hi).mono_left hV
#align filter.has_basis.is_vonN_bounded_basis_iff Filter.HasBasis.isVonNBounded_basis_iff

/-- Subsets of bounded sets are bounded. -/
theorem IsVonNBounded.subset {s₁ s₂ : Set E} (h : s₁ ⊆ s₂) (hs₂ : IsVonNBounded 𝕜 s₂) :
    IsVonNBounded 𝕜 s₁ := fun V hV => (hs₂ hV).mono_right h
#align bornology.is_vonN_bounded.subset Bornology.IsVonNBounded.subset

/-- The union of two bounded sets is bounded. -/
theorem IsVonNBounded.union {s₁ s₂ : Set E} (hs₁ : IsVonNBounded 𝕜 s₁) (hs₂ : IsVonNBounded 𝕜 s₂) :
    IsVonNBounded 𝕜 (s₁ ∪ s₂) := fun V hV => (hs₁ hV).union (hs₂ hV)
#align bornology.is_vonN_bounded.union Bornology.IsVonNBounded.union

end Zero

end SeminormedRing

section MultipleTopologies

variable [SeminormedRing 𝕜] [AddCommGroup E] [Module 𝕜 E]

/-- If a topology `t'` is coarser than `t`, then any set `s` that is bounded with respect to
`t` is bounded with respect to `t'`. -/
theorem IsVonNBounded.of_topologicalSpace_le {t t' : TopologicalSpace E} (h : t ≤ t') {s : Set E}
    (hs : @IsVonNBounded 𝕜 E _ _ _ t s) : @IsVonNBounded 𝕜 E _ _ _ t' s := fun V hV =>
  hs <| (le_iff_nhds t t').mp h 0 hV
#align bornology.is_vonN_bounded.of_topological_space_le Bornology.IsVonNBounded.of_topologicalSpace_le

end MultipleTopologies

section Image

variable {𝕜₁ 𝕜₂ : Type _} [NormedDivisionRing 𝕜₁] [NormedDivisionRing 𝕜₂] [AddCommGroup E]
  [Module 𝕜₁ E] [AddCommGroup F] [Module 𝕜₂ F] [TopologicalSpace E] [TopologicalSpace F]

/-- A continuous linear image of a bounded set is bounded. -/
theorem IsVonNBounded.image {σ : 𝕜₁ →+* 𝕜₂} [RingHomSurjective σ] [RingHomIsometric σ] {s : Set E}
    (hs : IsVonNBounded 𝕜₁ s) (f : E →SL[σ] F) : IsVonNBounded 𝕜₂ (f '' s) :=
  by
  let σ' := RingEquiv.ofBijective σ ⟨σ.injective, σ.is_surjective⟩
  have σ_iso : Isometry σ := AddMonoidHomClass.isometry_of_norm σ fun x => RingHomIsometric.is_iso
  have σ'_symm_iso : Isometry σ'.symm := σ_iso.right_inv σ'.right_inv
  have f_tendsto_zero := f.continuous.tendsto 0
  rw [map_zero] at f_tendsto_zero
  intro V hV
  rcases hs (f_tendsto_zero hV) with ⟨r, hrpos, hr⟩
  refine' ⟨r, hrpos, fun a ha => _⟩
  rw [← σ'.apply_symm_apply a]
  have hanz : a ≠ 0 := norm_pos_iff.mp (hrpos.trans_le ha)
  have : σ'.symm a ≠ 0 := (map_ne_zero σ'.symm.to_ring_hom).mpr hanz
  change _ ⊆ σ _ • _
  rw [Set.image_subset_iff, preimage_smul_setₛₗ _ _ _ f this.is_unit]
  refine' hr (σ'.symm a) _
  rwa [σ'_symm_iso.norm_map_of_map_zero (map_zero _)]
#align bornology.is_vonN_bounded.image Bornology.IsVonNBounded.image

end Image

section sequence

variable {𝕝 : Type _} [NormedField 𝕜] [NontriviallyNormedField 𝕝] [AddCommGroup E] [Module 𝕜 E]
  [Module 𝕝 E] [TopologicalSpace E] [ContinuousSMul 𝕝 E]

theorem IsVonNBounded.smul_tendsto_zero {S : Set E} {ε : ι → 𝕜} {x : ι → E} {l : Filter ι}
    (hS : IsVonNBounded 𝕜 S) (hxS : ∀ᶠ n in l, x n ∈ S) (hε : Tendsto ε l (𝓝 0)) :
    Tendsto (ε • x) l (𝓝 0) := by
  rw [tendsto_def] at *
  intro V hV
  rcases hS hV with ⟨r, r_pos, hrS⟩
  filter_upwards [hxS, hε _ (Metric.ball_mem_nhds 0 <| inv_pos.mpr r_pos)]with n hnS hnr
  by_cases this : ε n = 0
  · simp [this, mem_of_mem_nhds hV]
  · rw [mem_preimage, mem_ball_zero_iff, lt_inv (norm_pos_iff.mpr this) r_pos, ← norm_inv] at hnr
    rw [mem_preimage, Pi.smul_apply', ← Set.mem_inv_smul_set_iff₀ this]
    exact hrS _ hnr.le hnS
#align bornology.is_vonN_bounded.smul_tendsto_zero Bornology.IsVonNBounded.smul_tendsto_zero

theorem isVonNBounded_of_smul_tendsto_zero {ε : ι → 𝕝} {l : Filter ι} [l.ne_bot]
    (hε : ∀ᶠ n in l, ε n ≠ 0) {S : Set E}
    (H : ∀ x : ι → E, (∀ n, x n ∈ S) → Tendsto (ε • x) l (𝓝 0)) : IsVonNBounded 𝕝 S :=
  by
  rw [(nhds_basis_balanced 𝕝 E).isVonNBounded_basis_iff]
  by_contra' H'
  rcases H' with ⟨V, ⟨hV, hVb⟩, hVS⟩
  have : ∀ᶠ n in l, ∃ x : S, ε n • (x : E) ∉ V :=
    by
    filter_upwards [hε]with n hn
    rw [Absorbs] at hVS
    push_neg  at hVS
    rcases hVS _ (norm_pos_iff.mpr <| inv_ne_zero hn) with ⟨a, haε, haS⟩
    rcases set.not_subset.mp haS with ⟨x, hxS, hx⟩
    refine' ⟨⟨x, hxS⟩, fun hnx => _⟩
    rw [← Set.mem_inv_smul_set_iff₀ hn] at hnx
    exact hx (hVb.smul_mono haε hnx)
  rcases this.choice with ⟨x, hx⟩
  refine' Filter.frequently_false l (Filter.Eventually.frequently _)
  filter_upwards [hx,
    (H (coe ∘ x) fun n => (x n).2).Eventually (eventually_mem_set.mpr hV)]using fun n => id
#align bornology.is_vonN_bounded_of_smul_tendsto_zero Bornology.isVonNBounded_of_smul_tendsto_zero

/-- Given any sequence `ε` of scalars which tends to `𝓝[≠] 0`, we have that a set `S` is bounded
  if and only if for any sequence `x : ℕ → S`, `ε • x` tends to 0. This actually works for any
  indexing type `ι`, but in the special case `ι = ℕ` we get the important fact that convergent
  sequences fully characterize bounded sets. -/
theorem isVonNBounded_iff_smul_tendsto_zero {ε : ι → 𝕝} {l : Filter ι} [l.ne_bot]
    (hε : Tendsto ε l (𝓝[≠] 0)) {S : Set E} :
    IsVonNBounded 𝕝 S ↔ ∀ x : ι → E, (∀ n, x n ∈ S) → Tendsto (ε • x) l (𝓝 0) :=
  ⟨fun hS x hxS => hS.smul_tendsto_zero (eventually_of_forall hxS) (le_trans hε nhdsWithin_le_nhds),
    isVonNBounded_of_smul_tendsto_zero (hε self_mem_nhdsWithin)⟩
#align bornology.is_vonN_bounded_iff_smul_tendsto_zero Bornology.isVonNBounded_iff_smul_tendsto_zero

end sequence

section NormedField

variable [NormedField 𝕜] [AddCommGroup E] [Module 𝕜 E]

variable [TopologicalSpace E] [ContinuousSMul 𝕜 E]

/-- Singletons are bounded. -/
theorem isVonNBounded_singleton (x : E) : IsVonNBounded 𝕜 ({x} : Set E) := fun V hV =>
  (absorbent_nhds_zero hV).Absorbs
#align bornology.is_vonN_bounded_singleton Bornology.isVonNBounded_singleton

/-- The union of all bounded set is the whole space. -/
theorem isVonNBounded_covers : ⋃₀ setOf (IsVonNBounded 𝕜) = (Set.univ : Set E) :=
  Set.eq_univ_iff_forall.mpr fun x =>
    Set.mem_unionₛ.mpr ⟨{x}, isVonNBounded_singleton _, Set.mem_singleton _⟩
#align bornology.is_vonN_bounded_covers Bornology.isVonNBounded_covers

variable (𝕜 E)

-- See note [reducible non-instances]
/-- The von Neumann bornology defined by the von Neumann bounded sets.

Note that this is not registered as an instance, in order to avoid diamonds with the
metric bornology.-/
@[reducible]
def vonNBornology : Bornology E :=
  Bornology.ofBounded (setOf (IsVonNBounded 𝕜)) (isVonNBounded_empty 𝕜 E)
    (fun _ hs _ ht => hs.Subset ht) (fun _ hs _ => hs.union) isVonNBounded_singleton
#align bornology.vonN_bornology Bornology.vonNBornology

variable {E}

@[simp]
theorem isBounded_iff_isVonNBounded {s : Set E} :
    @IsBounded _ (vonNBornology 𝕜 E) s ↔ IsVonNBounded 𝕜 s :=
  isBounded_ofBounded_iff _
#align bornology.is_bounded_iff_is_vonN_bounded Bornology.isBounded_iff_isVonNBounded

end NormedField

end Bornology

section UniformAddGroup

variable (𝕜) [NontriviallyNormedField 𝕜] [AddCommGroup E] [Module 𝕜 E]

variable [UniformSpace E] [UniformAddGroup E] [ContinuousSMul 𝕜 E]

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem TotallyBounded.isVonNBounded {s : Set E} (hs : TotallyBounded s) :
    Bornology.IsVonNBounded 𝕜 s :=
  by
  rw [totallyBounded_iff_subset_finite_unionᵢ_nhds_zero] at hs
  intro U hU
  have h : Filter.Tendsto (fun x : E × E => x.fst + x.snd) (𝓝 (0, 0)) (𝓝 ((0 : E) + (0 : E))) :=
    tendsto_add
  rw [add_zero] at h
  have h' := (nhds_basis_balanced 𝕜 E).Prod (nhds_basis_balanced 𝕜 E)
  simp_rw [← nhds_prod_eq, id.def] at h'
  rcases h.basis_left h' U hU with ⟨x, hx, h''⟩
  rcases hs x.snd hx.2.1 with ⟨t, ht, hs⟩
  refine' Absorbs.mono_right _ hs
  rw [ht.absorbs_Union]
  have hx_fstsnd : x.fst + x.snd ⊆ U := by
    intro z hz
    rcases set.mem_add.mp hz with ⟨z1, z2, hz1, hz2, hz⟩
    have hz' : (z1, z2) ∈ x.fst ×ˢ x.snd := ⟨hz1, hz2⟩
    simpa only [hz] using h'' hz'
  refine' fun y hy => Absorbs.mono_left _ hx_fstsnd
  rw [← Set.singleton_vadd, vadd_eq_add]
  exact (absorbent_nhds_zero hx.1.1).Absorbs.add hx.2.2.absorbs_self
#align totally_bounded.is_vonN_bounded TotallyBounded.isVonNBounded

end UniformAddGroup

section VonNBornologyEqMetric

variable (𝕜 E) [NontriviallyNormedField 𝕜] [SeminormedAddCommGroup E] [NormedSpace 𝕜 E]

namespace NormedSpace

theorem isVonNBounded_ball (r : ℝ) : Bornology.IsVonNBounded 𝕜 (Metric.ball (0 : E) r) :=
  by
  rw [metric.nhds_basis_ball.is_vonN_bounded_basis_iff, ← ball_normSeminorm 𝕜 E]
  exact fun ε hε => (normSeminorm 𝕜 E).ball_zero_absorbs_ball_zero hε
#align normed_space.is_vonN_bounded_ball NormedSpace.isVonNBounded_ball

theorem isVonNBounded_closedBall (r : ℝ) :
    Bornology.IsVonNBounded 𝕜 (Metric.closedBall (0 : E) r) :=
  (isVonNBounded_ball 𝕜 E (r + 1)).Subset (Metric.closedBall_subset_ball <| by linarith)
#align normed_space.is_vonN_bounded_closed_ball NormedSpace.isVonNBounded_closedBall

theorem isVonNBounded_iff (s : Set E) : Bornology.IsVonNBounded 𝕜 s ↔ Bornology.IsBounded s :=
  by
  rw [← Metric.bounded_iff_isBounded, Metric.bounded_iff_subset_ball (0 : E)]
  constructor
  · intro h
    rcases h (Metric.ball_mem_nhds 0 zero_lt_one) with ⟨ρ, hρ, hρball⟩
    rcases NormedField.exists_lt_norm 𝕜 ρ with ⟨a, ha⟩
    specialize hρball a ha.le
    rw [← ball_normSeminorm 𝕜 E, Seminorm.smul_ball_zero (norm_pos_iff.1 <| hρ.trans ha),
      ball_normSeminorm, mul_one] at hρball
    exact ⟨‖a‖, hρball.trans Metric.ball_subset_closedBall⟩
  · exact fun ⟨C, hC⟩ => (is_vonN_bounded_closed_ball 𝕜 E C).Subset hC
#align normed_space.is_vonN_bounded_iff NormedSpace.isVonNBounded_iff

theorem isVonNBounded_iff' (s : Set E) :
    Bornology.IsVonNBounded 𝕜 s ↔ ∃ r : ℝ, ∀ (x : E) (hx : x ∈ s), ‖x‖ ≤ r := by
  rw [NormedSpace.isVonNBounded_iff, ← Metric.bounded_iff_isBounded, bounded_iff_forall_norm_le]
#align normed_space.is_vonN_bounded_iff' NormedSpace.isVonNBounded_iff'

theorem image_isVonNBounded_iff (f : E' → E) (s : Set E') :
    Bornology.IsVonNBounded 𝕜 (f '' s) ↔ ∃ r : ℝ, ∀ (x : E') (hx : x ∈ s), ‖f x‖ ≤ r := by
  simp_rw [is_vonN_bounded_iff', Set.ball_image_iff]
#align normed_space.image_is_vonN_bounded_iff NormedSpace.image_isVonNBounded_iff

/-- In a normed space, the von Neumann bornology (`bornology.vonN_bornology`) is equal to the
metric bornology. -/
theorem vonNBornology_eq : Bornology.vonNBornology 𝕜 E = PseudoMetricSpace.toBornology :=
  by
  rw [Bornology.ext_iff_isBounded]
  intro s
  rw [Bornology.isBounded_iff_isVonNBounded]
  exact is_vonN_bounded_iff 𝕜 E s
#align normed_space.vonN_bornology_eq NormedSpace.vonNBornology_eq

variable (𝕜)

theorem isBounded_iff_subset_smul_ball {s : Set E} :
    Bornology.IsBounded s ↔ ∃ a : 𝕜, s ⊆ a • Metric.ball 0 1 :=
  by
  rw [← is_vonN_bounded_iff 𝕜]
  constructor
  · intro h
    rcases h (Metric.ball_mem_nhds 0 zero_lt_one) with ⟨ρ, hρ, hρball⟩
    rcases NormedField.exists_lt_norm 𝕜 ρ with ⟨a, ha⟩
    exact ⟨a, hρball a ha.le⟩
  · rintro ⟨a, ha⟩
    exact ((is_vonN_bounded_ball 𝕜 E 1).image (a • 1 : E →L[𝕜] E)).Subset ha
#align normed_space.is_bounded_iff_subset_smul_ball NormedSpace.isBounded_iff_subset_smul_ball

theorem isBounded_iff_subset_smul_closedBall {s : Set E} :
    Bornology.IsBounded s ↔ ∃ a : 𝕜, s ⊆ a • Metric.closedBall 0 1 :=
  by
  constructor
  · rw [is_bounded_iff_subset_smul_ball 𝕜]
    exact Exists.imp fun a ha => ha.trans <| Set.smul_set_mono <| Metric.ball_subset_closedBall
  · rw [← is_vonN_bounded_iff 𝕜]
    rintro ⟨a, ha⟩
    exact ((is_vonN_bounded_closed_ball 𝕜 E 1).image (a • 1 : E →L[𝕜] E)).Subset ha
#align normed_space.is_bounded_iff_subset_smul_closed_ball NormedSpace.isBounded_iff_subset_smul_closedBall

end NormedSpace

end VonNBornologyEqMetric


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem bipartite_graph_two_colorable {G : Type*} [graph G] : (∃ A B : set G, A ∪ B = G ∧ A ∩ B = ∅ ∧ (∀ a b : G, a ∈ A ∧ b ∈ B → edge G a b)) ↔ (∃ f : G → ℕ, ∀ a b : G, a ≠ b → f a ≠ f b ∧ (edge G a b → f a = 0 ∧ f b = 1)) :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  assume h1 : ∃ (f : G → ℕ), ∀ (a b : G), a ≠ b → f a ≠ f b ∧ (edge G a b → f a = 0 ∧ f b = 1),
  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
  have h2 : ∃ (A B : set G), A ∪ B = G ∧ A ∩ B = ∅ ∧ (∀ (a b : G), a ∈ A ∧ b ∈ B → edge G a b), from sorry,
  -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
  have h3 : ∀ (a b : G), a ∈ A ∧ b ∈ A → ¬ (edge G a b), from sorry,
  have h4 : ∀ (a b : G), a ∈ B ∧ b ∈ B → ¬ (edge G a b), from sorry,
  -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  have h5 : ∀ (a b : G), a ∈ A ∧ b ∈ B → edge G a b, from sorry,
  show (∃ (A B : set G), A ∪ B = G ∧ A ∩ B = ∅ ∧ (∀ (a b : G), a ∈ A ∧ b ∈ B → edge G a b)) ↔ (∃ (f : G → ℕ), ∀ (a b : G), a ≠ b → f a ≠ f b ∧ (edge G a b → f a = 0 ∧ f b = 1)), from sorry,
end

--OUTPUT 2
theorem bipartite_graph_two_colorable {G : Type*} [graph G] : ∀ G, is_bipartite G ↔ is_two_colorable G :=
begin
  assume (G : Type*) [graph G],
  show is_bipartite G ↔ is_two_colorable G, from sorry,
end

--OUTPUT 3
theorem bipartite_graph_two_colorable {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  assume h1 : two_colorable G,
  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
  have h2 : ∃ (A B : set G), ∀ (v : G), v ∈ A ∨ v ∈ B, from sorry,
  -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
  have h3 : ∀ (u v : G), u ∈ A ∧ v ∈ A → ¬ edge u v, from sorry,
  have h4 : ∀ (u v : G), u ∈ B ∧ v ∈ B → ¬ edge u v, from sorry,
  -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  have h5 : ∀ (u v : G), edge u v → (u ∈ A ∧ v ∈ B) ∨ (u ∈ B ∧ v ∈ A), from sorry,
  show bipartite G, from sorry,

  -- Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$.
  assume h6 : bipartite G,
  -- Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.
  have h7 : ∃ (A B : set G), ∀ (u v : G), edge u v → (u ∈ A ∧ v ∈ B) ∨ (u ∈ B ∧ v ∈ A), from sorry,
  show two_colorable G, from sorry,
end

--OUTPUT 4
theorem two_colorable_iff_bipartite (G : Type*) [graph G] : two_colorable G ↔ bipartite G :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  have h1 : ∀ G : Type*, [graph G] → two_colorable G → (∃ (A B : set G) (f : G → Prop), (∀ (a : G), f a ∨ ¬ f a) ∧ (∀ (a b : G), edge G a b → f a ≠ f b)),
  from by {
    assume (G : Type*) (hG : [graph G]) (h1 : two_colorable G),
    -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
    have h2 : ∃ (A B : set G) (f : G → Prop), (∀ (a : G), f a ∨ ¬ f a) ∧ (∀ (a b : G), edge G a b → f a ≠ f b), from sorry,
    -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
    have h3 : (∀ (a b : G), a ∈ A ∧ b ∈ A → ¬ edge G a b) ∧ (∀ (a b : G), a ∈ B ∧ b ∈ B → ¬ edge G a b), from sorry,
    -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
    have h4 : (∀ (a b : G), edge G a b → (a ∈ A ∧ b ∈ B) ∨ (a ∈ B ∧ b ∈ A)), from sorry,
    show ∃ (A B : set G) (f : G → Prop), (∀ (a : G), f a ∨ ¬ f a) ∧ (∀ (a b : G), edge G a b → f a ≠ f b), from sorry,
  },
  -- Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$.
  have h2 : ∀ G : Type*, [graph G] → bipartite G → (∃ (A B : set G) (f : G → Prop), (∀ (a : G), f a ∨ ¬ f a) ∧ (∀ (a b : G), edge G a b → f a ≠ f b)),
  from by {
    assume (G : Type*) (hG : [graph G]) (h2 : bipartite G),
    -- Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.
    have h3 : ∃ (A B : set G) (f : G → Prop), (∀ (a : G), f a ∨ ¬ f a) ∧ (∀ (a b : G), edge G a b → f a ≠ f b), from sorry,
    show ∃ (A B : set G) (f : G → Prop), (∀ (a : G), f a ∨ ¬ f a) ∧ (∀ (a b : G), edge G a b → f a ≠ f b), from sorry,
  },
  show two_colorable G ↔ bipartite G, from sorry,
end

--OUTPUT 5
theorem bipartite_graph_2_colorable {G : Type*} [graph G] : (∃ V1 V2 : set G, is_bipartite G V1 V2) ↔ (∃ (c : G → color), is_valid_coloring G c) :=
begin
  -- Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color.
  have h1 : (∃ (c : G → color), is_valid_coloring G c), from sorry,
  -- Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue.
  have h2 : ∃ A B : set G, ∀ a : G, (c a = red) ↔ (a ∈ A) ∧ (c a = blue) ↔ (a ∈ B), from sorry,
  -- Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$.
  have h3 : ∀ a b : G, a ∈ A ∧ b ∈ A → ¬ (a -- b), from sorry,
  have h4 : ∀ a b : G, a ∈ B ∧ b ∈ B → ¬ (a -- b), from sorry,
  -- This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.
  have h5 : ∀ a b : G, a -- b → (a ∈ A ∧ b ∈ B) ∨ (a ∈ B ∧ b ∈ A), from sorry,
  have h6 : ∃ V1 V2 : set G, is_bipartite G V1 V2, from sorry,

  -- Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$.
  have h7 : ∃ V1 V2 : set G, is_bipartite G V1 V2, from sorry,
  -- Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.
  have h8 : ∃ (c : G → color), is_valid_coloring G c, from sorry,
  show (∃ V1 V2 : set G, is_bipartite G V1 V2) ↔ (∃ (c : G → color), is_valid_coloring G c), from sorry,
end

--OUTPUT 6
theorem bipartite_graph_two_colorable (G : Type*) [graph G] :
  ∃ f : G → ℕ, ∀ v w, (v ≠ w) → (f v ≠ f w) := sorry

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

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

Setting $b = a$, this becomes:

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

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

These $x$ and $y$ are both $e$, by definition of identity element.

Thus $a x = a$ and $y a = a$.

Thus $a x = y a$.

Thus $a \circ x = y \circ a$.

Thus $\struct {G, \circ}$ is abelian.
{{qed}}
-/
theorem group_is_abelian {G : Type*} [group G] : ∀ a b : G, a * b = b * a :=
begin
  -- Group has Latin Square Property
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

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

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

  show ∀ a b : G, a * b = b * a, from by {
    assume (a b : G),
    have h7 : a * (1 : G) = a, from sorry,
    have h8 : (1 : G) * a = a, from sorry,
    have h9 : a * (1 : G) = (1 : G) * a, from sorry,
    show a * b = b * a, from sorry,
  }
end

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

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

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

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

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

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

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

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

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

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

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

Setting $b = a$, this becomes:

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

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

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

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

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

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

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


variable α : Type
variables a b : α
variables f g : α → ℕ
variable h₁ : a = b
variable h₂ : f = g

example : f a = f b := congr_arg f h₁
example : f a = g a := congr_fun h₂ a
example : f a = g b := congr h₂ h₁


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Joey van Langen, Casper Putz
-/
import tactic.apply_fun
import algebra.ring.equiv
import data.zmod.algebra
import linear_algebra.finite_dimensional
import ring_theory.integral_domain
import field_theory.separable
import field_theory.splitting_field

/-!
# Finite fields

This file contains basic results about finite fields.
Throughout most of this file, `K` denotes a finite field
and `q` is notation for the cardinality of `K`.

See `ring_theory.integral_domain` for the fact that the unit group of a finite field is a
cyclic group, as well as the fact that every finite integral domain is a field
(`fintype.field_of_domain`).

## Main results

1. `fintype.card_units`: The unit group of a finite field is has cardinality `q - 1`.
2. `sum_pow_units`: The sum of `x^i`, where `x` ranges over the units of `K`, is
   - `q-1` if `q-1 ∣ i`
   - `0`   otherwise
3. `finite_field.card`: The cardinality `q` is a power of the characteristic of `K`.
   See `card'` for a variant.

## Notation

Throughout most of this file, `K` denotes a finite field
and `q` is notation for the cardinality of `K`.

## Implementation notes

While `fintype Kˣ` can be inferred from `fintype K` in the presence of `decidable_eq K`,
in this file we take the `fintype Kˣ` argument directly to reduce the chance of typeclass
diamonds, as `fintype` carries data.

-/

variables {K : Type*} {R : Type*}
local notation `q` := fintype.card K

open_locale big_operators polynomial

namespace finite_field
open finset function

section polynomial

variables [comm_ring R] [is_domain R]

open polynomial

/-- The cardinality of a field is at most `n` times the cardinality of the image of a degree `n`
  polynomial -/
lemma card_image_polynomial_eval [decidable_eq R] [fintype R] {p : R[X]}
  (hp : 0 < p.degree) : fintype.card R ≤ nat_degree p * (univ.image (λ x, eval x p)).card :=
finset.card_le_mul_card_image _ _
  (λ a _, calc _ = (p - C a).roots.to_finset.card : congr_arg card
    (by simp [finset.ext_iff, mem_roots_sub_C hp])
    ... ≤ (p - C a).roots.card : multiset.to_finset_card_le _
    ... ≤ _ : card_roots_sub_C' hp)

/-- If `f` and `g` are quadratic polynomials, then the `f.eval a + g.eval b = 0` has a solution. -/
lemma exists_root_sum_quadratic [fintype R] {f g : R[X]} (hf2 : degree f = 2)
  (hg2 : degree g = 2) (hR : fintype.card R % 2 = 1) : ∃ a b, f.eval a + g.eval b = 0 :=
by letI := classical.dec_eq R; exact
suffices ¬ disjoint (univ.image (λ x : R, eval x f)) (univ.image (λ x : R, eval x (-g))),
begin
  simp only [disjoint_left, mem_image] at this,
  push_neg at this,
  rcases this with ⟨x, ⟨a, _, ha⟩, ⟨b, _, hb⟩⟩,
  exact ⟨a, b, by rw [ha, ← hb, eval_neg, neg_add_self]⟩
end,
assume hd : disjoint _ _,
lt_irrefl (2 * ((univ.image (λ x : R, eval x f)) ∪ (univ.image (λ x : R, eval x (-g)))).card) $
calc 2 * ((univ.image (λ x : R, eval x f)) ∪ (univ.image (λ x : R, eval x (-g)))).card
    ≤ 2 * fintype.card R : nat.mul_le_mul_left _ (finset.card_le_univ _)
... = fintype.card R + fintype.card R : two_mul _
... < nat_degree f * (univ.image (λ x : R, eval x f)).card +
      nat_degree (-g) * (univ.image (λ x : R, eval x (-g))).card :
    add_lt_add_of_lt_of_le
      (lt_of_le_of_ne
        (card_image_polynomial_eval (by rw hf2; exact dec_trivial))
        (mt (congr_arg (%2)) (by simp [nat_degree_eq_of_degree_eq_some hf2, hR])))
      (card_image_polynomial_eval (by rw [degree_neg, hg2]; exact dec_trivial))
... = 2 * (univ.image (λ x : R, eval x f) ∪ univ.image (λ x : R, eval x (-g))).card :
  by rw [card_disjoint_union hd]; simp [nat_degree_eq_of_degree_eq_some hf2,
    nat_degree_eq_of_degree_eq_some hg2, bit0, mul_add]

end polynomial

lemma prod_univ_units_id_eq_neg_one [comm_ring K] [is_domain K] [fintype Kˣ] :
  (∏ x : Kˣ, x) = (-1 : Kˣ) :=
begin
  classical,
  have : (∏ x in (@univ Kˣ _).erase (-1), x) = 1,
  from prod_involution (λ x _, x⁻¹) (by simp)
    (λ a, by simp [units.inv_eq_self_iff] {contextual := tt})
    (λ a, by simp [@inv_eq_iff_inv_eq _ _ a, eq_comm])
    (by simp),
  rw [← insert_erase (mem_univ (-1 : Kˣ)), prod_insert (not_mem_erase _ _),
      this, mul_one]
end

section
variables [group_with_zero K] [fintype K]

lemma pow_card_sub_one_eq_one (a : K) (ha : a ≠ 0) : a ^ (q - 1) = 1 :=
calc a ^ (fintype.card K - 1) = (units.mk0 a ha ^ (fintype.card K - 1) : Kˣ) :
    by rw [units.coe_pow, units.coe_mk0]
  ... = 1 : by { classical, rw [← fintype.card_units, pow_card_eq_one], refl }

lemma pow_card (a : K) : a ^ q = a :=
begin
  have hp : 0 < fintype.card K := lt_trans zero_lt_one fintype.one_lt_card,
  by_cases h : a = 0, { rw h, apply zero_pow hp },
  rw [← nat.succ_pred_eq_of_pos hp, pow_succ, nat.pred_eq_sub_one,
    pow_card_sub_one_eq_one a h, mul_one],
end

lemma pow_card_pow (n : ℕ) (a : K) : a ^ q ^ n = a :=
begin
  induction n with n ih,
  { simp, },
  { simp [pow_succ, pow_mul, ih, pow_card], },
end

end

variables (K) [field K] [fintype K]

theorem card (p : ℕ) [char_p K p] : ∃ (n : ℕ+), nat.prime p ∧ q = p^(n : ℕ) :=
begin
  haveI hp : fact p.prime := ⟨char_p.char_is_prime K p⟩,
  letI : module (zmod p) K := { .. (zmod.cast_hom dvd_rfl K : zmod p →+* _).to_module },
  obtain ⟨n, h⟩ := vector_space.card_fintype (zmod p) K,
  rw zmod.card at h,
  refine ⟨⟨n, _⟩, hp.1, h⟩,
  apply or.resolve_left (nat.eq_zero_or_pos n),
  rintro rfl,
  rw pow_zero at h,
  have : (0 : K) = 1, { apply fintype.card_le_one_iff.mp (le_of_eq h) },
  exact absurd this zero_ne_one,
end

-- this statement doesn't use `q` because we want `K` to be an explicit parameter
theorem card' : ∃ (p : ℕ) (n : ℕ+), nat.prime p ∧ fintype.card K = p^(n : ℕ) :=
let ⟨p, hc⟩ := char_p.exists K in ⟨p, @finite_field.card K _ _ p hc⟩

@[simp] lemma cast_card_eq_zero : (q : K) = 0 :=
begin
  rcases char_p.exists K with ⟨p, _char_p⟩, resetI,
  rcases card K p with ⟨n, hp, hn⟩,
  simp only [char_p.cast_eq_zero_iff K p, hn],
  conv { congr, rw [← pow_one p] },
  exact pow_dvd_pow _ n.2,
end

lemma forall_pow_eq_one_iff (i : ℕ) :
  (∀ x : Kˣ, x ^ i = 1) ↔ q - 1 ∣ i :=
begin
  classical,
  obtain ⟨x, hx⟩ := is_cyclic.exists_generator Kˣ,
  rw [←fintype.card_units, ←order_of_eq_card_of_forall_mem_zpowers hx, order_of_dvd_iff_pow_eq_one],
  split,
  { intro h, apply h },
  { intros h y,
    simp_rw ← mem_powers_iff_mem_zpowers at hx,
    rcases hx y with ⟨j, rfl⟩,
    rw [← pow_mul, mul_comm, pow_mul, h, one_pow], }
end

/-- The sum of `x ^ i` as `x` ranges over the units of a finite field of cardinality `q`
is equal to `0` unless `(q - 1) ∣ i`, in which case the sum is `q - 1`. -/
lemma sum_pow_units [fintype Kˣ] (i : ℕ) :
  ∑ x : Kˣ, (x ^ i : K) = if (q - 1) ∣ i then -1 else 0 :=
begin
  let φ : Kˣ →* K :=
  { to_fun   := λ x, x ^ i,
    map_one' := by rw [units.coe_one, one_pow],
    map_mul' := by { intros, rw [units.coe_mul, mul_pow] } },
  haveI : decidable (φ = 1), { classical, apply_instance },
  calc ∑ x : Kˣ, φ x = if φ = 1 then fintype.card Kˣ else 0 : sum_hom_units φ
                      ... = if (q - 1) ∣ i then -1 else 0 : _,
  suffices : (q - 1) ∣ i ↔ φ = 1,
  { simp only [this],
    split_ifs with h h, swap, refl,
    rw [fintype.card_units, nat.cast_sub, cast_card_eq_zero, nat.cast_one, zero_sub],
    show 1 ≤ q, from fintype.card_pos_iff.mpr ⟨0⟩ },
  rw [← forall_pow_eq_one_iff, monoid_hom.ext_iff],
  apply forall_congr, intro x,
  rw [units.ext_iff, units.coe_pow, units.coe_one, monoid_hom.one_apply],
  refl,
end

/-- The sum of `x ^ i` as `x` ranges over a finite field of cardinality `q`
is equal to `0` if `i < q - 1`. -/
lemma sum_pow_lt_card_sub_one (i : ℕ) (h : i < q - 1) :
  ∑ x : K, x ^ i = 0 :=
begin
  by_cases hi : i = 0,
  { simp only [hi, nsmul_one, sum_const, pow_zero, card_univ, cast_card_eq_zero], },
  classical,
  have hiq : ¬ (q - 1) ∣ i, { contrapose! h,  exact nat.le_of_dvd (nat.pos_of_ne_zero hi) h },
  let φ : Kˣ ↪ K := ⟨coe, units.ext⟩,
  have : univ.map φ = univ \ {0},
  { ext x,
    simp only [true_and, embedding.coe_fn_mk, mem_sdiff, units.exists_iff_ne_zero,
               mem_univ, mem_map, exists_prop_of_true, mem_singleton] },
  calc ∑ x : K, x ^ i = ∑ x in univ \ {(0 : K)}, x ^ i :
    by rw [← sum_sdiff ({0} : finset K).subset_univ, sum_singleton,
           zero_pow (nat.pos_of_ne_zero hi), add_zero]
    ... = ∑ x : Kˣ, x ^ i : by { rw [← this, univ.sum_map φ], refl }
    ... = 0 : by { rw [sum_pow_units K i, if_neg], exact hiq, }
end

section is_splitting_field
open polynomial

section

variables (K' : Type*) [field K'] {p n : ℕ}

lemma X_pow_card_sub_X_nat_degree_eq (hp : 1 < p) :
  (X ^ p - X : K'[X]).nat_degree = p :=
begin
  have h1 : (X : K'[X]).degree < (X ^ p : K'[X]).degree,
  { rw [degree_X_pow, degree_X],
    exact_mod_cast hp },
  rw [nat_degree_eq_of_degree_eq (degree_sub_eq_left_of_degree_lt h1), nat_degree_X_pow],
end

lemma X_pow_card_pow_sub_X_nat_degree_eq (hn : n ≠ 0) (hp : 1 < p) :
  (X ^ p ^ n - X : K'[X]).nat_degree = p ^ n :=
X_pow_card_sub_X_nat_degree_eq K' $ nat.one_lt_pow _ _ (nat.pos_of_ne_zero hn) hp

lemma X_pow_card_sub_X_ne_zero (hp : 1 < p) : (X ^ p - X : K'[X]) ≠ 0 :=
ne_zero_of_nat_degree_gt $
calc 1 < _ : hp
... = _ : (X_pow_card_sub_X_nat_degree_eq K' hp).symm

lemma X_pow_card_pow_sub_X_ne_zero (hn : n ≠ 0) (hp : 1 < p) :
  (X ^ p ^ n - X : K'[X]) ≠ 0 :=
X_pow_card_sub_X_ne_zero K' $ nat.one_lt_pow _ _ (nat.pos_of_ne_zero hn) hp

end

variables (p : ℕ) [fact p.prime] [char_p K p]
lemma roots_X_pow_card_sub_X : roots (X^q - X : K[X]) = finset.univ.val :=
begin
  classical,
  have aux : (X^q - X : K[X]) ≠ 0 := X_pow_card_sub_X_ne_zero K fintype.one_lt_card,
  have : (roots (X^q - X : K[X])).to_finset = finset.univ,
  { rw eq_univ_iff_forall,
    intro x,
    rw [multiset.mem_to_finset, mem_roots aux, is_root.def, eval_sub, eval_pow, eval_X, sub_eq_zero,
      pow_card] },
  rw [←this, multiset.to_finset_val, eq_comm, multiset.dedup_eq_self],
  apply nodup_roots,
  rw separable_def,
  convert is_coprime_one_right.neg_right using 1,
  { rw [derivative_sub, derivative_X, derivative_X_pow, ←C_eq_nat_cast,
    C_eq_zero.mpr (char_p.cast_card_eq_zero K), zero_mul, zero_sub], },
  end

instance : is_splitting_field (zmod p) K (X^q - X) :=
{ splits :=
  begin
    have h : (X^q - X : K[X]).nat_degree = q :=
      X_pow_card_sub_X_nat_degree_eq K fintype.one_lt_card,
    rw [←splits_id_iff_splits, splits_iff_card_roots, polynomial.map_sub, polynomial.map_pow,
      map_X, h, roots_X_pow_card_sub_X K, ←finset.card_def, finset.card_univ],
  end,
  adjoin_roots :=
  begin
    classical,
    transitivity algebra.adjoin (zmod p) ((roots (X^q - X : K[X])).to_finset : set K),
    { simp only [polynomial.map_pow, map_X, polynomial.map_sub], convert rfl },
    { rw [roots_X_pow_card_sub_X, val_to_finset, coe_univ, algebra.adjoin_univ], }
  end }

end is_splitting_field

variables {K}

theorem frobenius_pow {p : ℕ} [fact p.prime] [char_p K p] {n : ℕ} (hcard : q = p^n) :
  (frobenius K p) ^ n = 1 :=
begin
  ext, conv_rhs { rw [ring_hom.one_def, ring_hom.id_apply, ← pow_card x, hcard], }, clear hcard,
  induction n, {simp},
  rw [pow_succ, pow_succ', pow_mul, ring_hom.mul_def, ring_hom.comp_apply, frobenius_def, n_ih]
end

open polynomial

lemma expand_card (f : K[X]) :
  expand K q f = f ^ q :=
begin
  cases char_p.exists K with p hp,
  letI := hp,
  rcases finite_field.card K p with ⟨⟨n, npos⟩, ⟨hp, hn⟩⟩,
  haveI : fact p.prime := ⟨hp⟩,
  dsimp at hn,
  rw [hn, ← map_expand_pow_char, frobenius_pow hn, ring_hom.one_def, map_id]
end

end finite_field

namespace zmod

open finite_field polynomial

lemma sq_add_sq (p : ℕ) [hp : fact p.prime] (x : zmod p) :
  ∃ a b : zmod p, a^2 + b^2 = x :=
begin
  cases hp.1.eq_two_or_odd with hp2 hp_odd,
  { substI p, change fin 2 at x, fin_cases x, { use 0, simp }, { use [0, 1], simp } },
  let f : (zmod p)[X] := X^2,
  let g : (zmod p)[X] := X^2 - C x,
  obtain ⟨a, b, hab⟩ : ∃ a b, f.eval a + g.eval b = 0 :=
    @exists_root_sum_quadratic _ _ _ _ f g
      (degree_X_pow 2) (degree_X_pow_sub_C dec_trivial _) (by rw [zmod.card, hp_odd]),
  refine ⟨a, b, _⟩,
  rw ← sub_eq_zero,
  simpa only [eval_C, eval_X, eval_pow, eval_sub, ← add_sub_assoc] using hab,
end

end zmod

namespace char_p

lemma sq_add_sq (R : Type*) [comm_ring R] [is_domain R]
  (p : ℕ) [fact (0 < p)] [char_p R p] (x : ℤ) :
  ∃ a b : ℕ, (a^2 + b^2 : R) = x :=
begin
  haveI := char_is_prime_of_pos R p,
  obtain ⟨a, b, hab⟩ := zmod.sq_add_sq p x,
  refine ⟨a.val, b.val, _⟩,
  simpa using congr_arg (zmod.cast_hom dvd_rfl R) hab
end

end char_p

open_locale nat
open zmod

/-- The **Fermat-Euler totient theorem**. `nat.modeq.pow_totient` is an alternative statement
  of the same theorem. -/
@[simp] lemma zmod.pow_totient {n : ℕ} [fact (0 < n)] (x : (zmod n)ˣ) : x ^ φ n = 1 :=
by rw [← card_units_eq_totient, pow_card_eq_one]

/-- The **Fermat-Euler totient theorem**. `zmod.pow_totient` is an alternative statement
  of the same theorem. -/
lemma nat.modeq.pow_totient {x n : ℕ} (h : nat.coprime x n) : x ^ φ n ≡ 1 [MOD n] :=
begin
  cases n, {simp},
  rw ← zmod.eq_iff_modeq_nat,
  let x' : units (zmod (n+1)) := zmod.unit_of_coprime _ h,
  have := zmod.pow_totient x',
  apply_fun (coe : units (zmod (n+1)) → zmod (n+1)) at this,
  simpa only [-zmod.pow_totient, nat.succ_eq_add_one, nat.cast_pow, units.coe_one,
    nat.cast_one, coe_unit_of_coprime, units.coe_pow],
end

section

variables {V : Type*} [fintype K] [division_ring K] [add_comm_group V] [module K V]

-- should this go in a namespace?
-- finite_dimensional would be natural,
-- but we don't assume it...
lemma card_eq_pow_finrank [fintype V] :
  fintype.card V = q ^ (finite_dimensional.finrank K V) :=
begin
  let b := is_noetherian.finset_basis K V,
  rw [module.card_fintype b, ← finite_dimensional.finrank_eq_card_basis b],
end

end

open finite_field
namespace zmod

/-- A variation on Fermat's little theorem. See `zmod.pow_card_sub_one_eq_one` -/
@[simp] lemma pow_card {p : ℕ} [fact p.prime] (x : zmod p) : x ^ p = x :=
by { have h := finite_field.pow_card x, rwa zmod.card p at h }

@[simp] lemma pow_card_pow {n p : ℕ} [fact p.prime] (x : zmod p) : x ^ p ^ n = x :=
begin
  induction n with n ih,
  { simp, },
  { simp [pow_succ, pow_mul, ih, pow_card], },
end

@[simp] lemma frobenius_zmod (p : ℕ) [fact p.prime] :
  frobenius (zmod p) p = ring_hom.id _ :=
by { ext a, rw [frobenius_def, zmod.pow_card, ring_hom.id_apply] }

@[simp] lemma card_units (p : ℕ) [fact p.prime] : fintype.card ((zmod p)ˣ) = p - 1 :=
by rw [fintype.card_units, card]

/-- **Fermat's Little Theorem**: for every unit `a` of `zmod p`, we have `a ^ (p - 1) = 1`. -/
theorem units_pow_card_sub_one_eq_one (p : ℕ) [fact p.prime] (a : (zmod p)ˣ) :
  a ^ (p - 1) = 1 :=
by rw [← card_units p, pow_card_eq_one]

/-- **Fermat's Little Theorem**: for all nonzero `a : zmod p`, we have `a ^ (p - 1) = 1`. -/
theorem pow_card_sub_one_eq_one {p : ℕ} [fact p.prime] {a : zmod p} (ha : a ≠ 0) :
  a ^ (p - 1) = 1 :=
by { have h := pow_card_sub_one_eq_one a ha, rwa zmod.card p at h }

open polynomial

lemma expand_card {p : ℕ} [fact p.prime] (f : polynomial (zmod p)) :
  expand (zmod p) p f = f ^ p :=
by { have h := finite_field.expand_card f, rwa zmod.card p at h }

end zmod

/-- **Fermat's Little Theorem**: for all `a : ℤ` coprime to `p`, we have
`a ^ (p - 1) ≡ 1 [ZMOD p]`. -/
lemma int.modeq.pow_card_sub_one_eq_one {p : ℕ} (hp : nat.prime p) {n : ℤ} (hpn : is_coprime n p) :
  n ^ (p - 1) ≡ 1 [ZMOD p] :=
begin
  haveI : fact p.prime := ⟨hp⟩,
  have : ¬ (n : zmod p) = 0,
  { rw [char_p.int_cast_eq_zero_iff _ p, ← (nat.prime_iff_prime_int.mp hp).coprime_iff_not_dvd],
    { exact hpn.symm },
    exact zmod.char_p p },
  simpa [← zmod.int_coe_eq_int_coe_iff] using zmod.pow_card_sub_one_eq_one this
end


import data.real.basic data.analysis.filter

open lattice multiset

universes u v

-- `I` is a "set" (actually a type) that is finite and nonempty
variables {I : Type} [fintype I] [nonempty I] [decidable_eq I]
-- `S` is a "set family", a function which produces (sub)sets of ℝ
variables (S : I → set ℝ)

-- Since `I` is finite, we can sum over all values of it
def sumI (f : I → ℝ) : ℝ := finset.univ.sum f
-- A function `s : I → ℝ` is a _choice_ of `S` on `is` when, for each `i ∈ is`, `s i ∈ S i`
def choices_of_on (is : finset I) : set (I → ℝ) := λ s, ∀ i ∈ is, s i ∈ S i

-- A helper to simplify the definition of a choice when used on a finset insertion
@[simp]
lemma choices_insert (a : I → ℝ) (i : I) (is : finset I)
  : a ∈ choices_of_on S (insert i is)
  ↔ a i ∈ S i ∧ a ∈ choices_of_on S is :=
  begin
  unfold choices_of_on,
  constructor,
  intro h, constructor, apply h, simp,
  intros i' i'mem, apply h, exact finset.mem_insert_of_mem i'mem,
  intro h, intros i' i'mem,
  by_cases hi : i' = i, rw hi, exact h.1,
  apply h.2, exact finset.mem_of_mem_insert_of_ne i'mem hi,
  end

-- A helper to simplify the definition of a choice when used on the empty finset
@[simp]
lemma choices_empty (a : I → ℝ) : a ∈ choices_of_on S ∅ ↔ true :=
  begin
  unfold choices_of_on,
  simp [finset.exists_mem_empty_iff],
  end

-- The lemma that Sup (A + B) = Sup A + Sup B
lemma Sup_sum (A B : set ℝ)
  (bddA : bdd_above A) (bddB : bdd_above B)
  (neA : A ≠ ∅) (neB : B ≠ ∅) :
  Sup { x | ∃ (a ∈ A) (b ∈ B), x = a + b } =
    Sup A + Sup B :=
  begin
  apply cSup_intro,
  rw set.ne_empty_iff_exists_mem at *,
  rcases neA with ⟨a, a_mem⟩,
  rcases neB with ⟨b, b_mem⟩,
  simp,
  exact ⟨_, _, a_mem, _, b_mem, rfl⟩,
  rintro x,
  rintro ⟨a, a_mem, b, b_mem, xab⟩, rw xab,
  exact add_le_add (le_cSup bddA a_mem) (le_cSup bddB b_mem),
  rintro w w_lt, simp,
  let ε := (Sup A + Sup B) - w,
  have : ε > 0, exact sub_pos_of_lt w_lt,
  have : ε/2 > 0, exact div_pos_of_pos_of_pos this two_pos,
  have wa : Sup A - ε/2 < Sup A, rw sub_lt, simp, assumption,
  have wb : Sup B - ε/2 < Sup B, rw sub_lt, simp, assumption,
  have := exists_lt_of_lt_cSup neA wa,
  rcases this with ⟨a, a_mem, a_lt⟩,
  have := exists_lt_of_lt_cSup neB wb,
  rcases this with ⟨b, b_mem, b_lt⟩,
  apply exists.intro,
  constructor,
  apply exists.intro a, constructor, exact a_mem,
  apply exists.intro b, constructor, exact b_mem,
  refl,
  have : w = (Sup A + Sup B) - ε,
    show w = (Sup A + Sup B) - ((Sup A + Sup B) - w),
    simp,
  rw this,
  have : Sup A + Sup B - ε = (Sup A - ε/2) + (Sup B - ε/2),
    symmetry,
    calc (Sup A - ε/2) + (Sup B - ε/2)
        = (Sup A + Sup B) - (ε/2 + ε/2)
          : by rw [← add_sub_comm]
    ... = (Sup A + Sup B) - ε : by rw add_halves,
  rw this, apply add_lt_add; assumption,
  end

-- The axiom of choice, but on a finset (sorta kinda not really avoids the axiom part of it)
theorem finset_choice {α : Type u} [decidable_eq α] {β : α → Sort v} {r : Π x, β x → Prop} (h : ∀ x, ∃ y, r x y) :
  ∀ (xs : finset α), ∃ (f : Π x ∈ xs, β x), ∀ x ∈ xs, r x (f x H) :=
  begin
  intro xs,
  apply @finset.case_strong_induction_on α _
    (λ (xs : finset α), ∃ (f : Π x ∈ xs, β x), ∀ x ∈ xs, r x (f x H)),
  apply exists.intro
    (λ x H, false.elim (finset.not_mem_empty _ H)),
  intros x H, apply false.elim (finset.not_mem_empty _ H),
  intros x xs novel ih,
  rcases h x with ⟨w, wr⟩,
  rcases ih xs (by refl) with ⟨f, fr⟩,
  let f' : Π x' ∈ insert x xs, β x' := λ x' H,
    if xx : x = x'
      then (@eq.rec α x β w x' xx : β x')
      else f x' (finset.mem_of_mem_insert_of_ne H (xx ∘ eq.symm)),
  apply exists.intro f',
  intros x' H,
  by_cases xx : x = x', subst xx,
  refine eq.mp _ wr, congr, symmetry, exact dif_pos rfl,
  dsimp [f'], rw [dif_neg xx],
  apply fr,
  end

-- The axiom of choice on a finite type
theorem finite_choice {α : Type u} [decidable_eq α] [fintype α] {β : α → Sort v} {r : Π x, β x → Prop} (h : ∀ x, ∃ y, r x y) :
  ∃ (f : Π x, β x), ∀ x, r x (f x) :=
  begin
  have := finset_choice h finset.univ,
  rcases this with ⟨f, fr⟩,
  apply exists.intro (λ x, f x (finset.mem_univ x)),
  intro x, apply fr x (finset.mem_univ x),
  end

set_option pp.beta true

-- The main lemma: the sum of Sups (over each S i) is the Sup of the sums (over each choice s of S)
theorem sum_sups_eq_sup_sums (bddS : ∀ i, bdd_above (S i)) (neS : ∀ i, S i ≠ ∅) :
  sumI (λ i, Sup (S i)) = Sup (sumI '' choices_of_on S finset.univ) :=
  begin
  -- `I` is nonempty, so so should its universal finite set be
  have : (finset.univ : finset I) ≠ ∅,
  {
    intro e, exfalso,
    have := finset.eq_empty_iff_forall_not_mem.1 e,
    apply nonempty.elim _inst_2, intro i,
    exact this _ (finset.mem_univ i),
  },
  -- Revert `this` so it will be an assumption for each step of induction
  revert this,
  -- Strong induction on finsets: the more formal version of "induction on the size of a finset"
  apply @finset.case_strong_induction_on I _
    (λ is, is ≠ ∅ → is.sum (λ i, Sup (S i)) = Sup (is.sum '' choices_of_on S is)),
  -- The base case is trivial, since we stipulated that `is` is nonempty
  { intro h, cc },
  -- Introduce the member being added `i`, the rest of the finset `is`,
  -- the fact that `i` is not already in `is` (note that we name proofs in
  -- type theory!), and the induction hypothesis, which will notably apply to `is`
  intros i is inotmemis ih _,
  -- This is just some definitional unfolding and simplifying, to make it clearer
  -- what is happening with `insert i is` in the goal.
  unfold set.image at *,
  simp [finset.sum.equations._eqn_1, multiset.ndinsert_of_not_mem inotmemis] at *,
  -- If `is = ∅`, this is the actual base case (a singleton set)
  by_cases empt : is = ∅,
  {
    -- So we end up with Sup … = Sup …
    rw empt, simp,
    -- And just have to prove that the sets are equal
    congr, apply funext, intro x, apply propext,
    constructor,
    intro mem, apply exists.intro (λ _, x), exact ⟨mem, rfl⟩,
    rintro ⟨s, ⟨mem, si_x⟩⟩,
    rw si_x at mem, exact mem,
  },
  -- Apply the inductive hypothesis now
  rw ih; try { simp <|> assumption }, clear ih,
  -- We can add the Sups together, then prove that the set is what we already had
  rw [← Sup_sum], congr, simp, apply funext, intro x, apply propext,
  -- Prove each direction of the equality
  constructor,
  {
    rintro ⟨a, hsi, b, ⟨s, schoice, ssum⟩, hx⟩,
    -- We need a new function that satisfies the following properties
    let s' := (λ i', if i = i' then a else s i'),
    have s'i : s' i = a, exact if_pos rfl,
    have s'is : ∀ i' ∈ is, s' i' = s i',
      {
        intros i' i'mem,
        have : i ≠ i', intro ieqi', rw ieqi' at inotmemis, exact inotmemis i'mem,
        exact if_neg this,
      },
    apply exists.intro s',
    constructor,
    constructor,
    rw s'i, exact hsi,
    intros i' i'mem, rw s'is i' i'mem, exact schoice i' i'mem,
    rw [hx, ← ssum, s'i], congr' 2,
    exact multiset.map_congr s'is,
  }, {
    rintro ⟨s, ⟨schoice0, schoice⟩, ssum⟩,
    -- We already have the function, so just need to specify the numbers
    apply exists.intro (s i),
    constructor, assumption,
    apply exists.intro (sum (map s (is.val))),
    constructor,
    apply exists.intro s, finish, finish
  },

  -- We need to prove that S i and the set of choices are bounded
  exact bddS i,
  -- `bounds i` computes an upper bound on `S i` for each `i`
  -- so, of course, an upper bound on any sum
  have : ∃ (bounds : I → ℝ), ∀ i, ∀ si ∈ S i, si ≤ bounds i,
  {
    apply @finite_choice I _ _ (λ _, ℝ) (λ i bound, ∀ si ∈ S i, si ≤ bound) bddS,
  },
  rcases this with ⟨bounds, isbounds⟩,
  apply exists.intro (sum (map bounds (is.val))),
  simp,
  intros asum s schoice isasum, rw ← isasum,
  apply finset.sum_le_sum,
  intros i i_mem, apply isbounds i (s i) (schoice i i_mem),

  -- We need to prove that S i and the set of choices are nonempty
  exact neS i,
  rw set.ne_empty_iff_exists_mem,
  -- `s i` computes an element of `S i` for each `i`
  have : ∃ (s : I → ℝ), s ∈ choices_of_on S is,
  {
    apply exists_imp_exists _,
    apply @finite_choice I _ _ (λ _, ℝ) (λ i si, si ∈ S i),
    intro i,
    exact set.exists_mem_of_ne_empty (neS i),
    intros s si i i_mem, exact si i,
  },
  rcases this with ⟨si, issi⟩,
  constructor,
  constructor,
  constructor,
  exact issi, refl,
  end


/-
Copyright (c) 2021 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import ring_theory.jacobson
import field_theory.algebraic_closure
import field_theory.mv_polynomial
import algebraic_geometry.prime_spectrum

/-!
# Nullstellensatz
This file establishes a version of Hilbert's classical Nullstellensatz for `mv_polynomial`s.
The main statement of the theorem is `vanishing_ideal_zero_locus_eq_radical`.

The statement is in terms of new definitions `vanishing_ideal` and `zero_locus`.
Mathlib already has versions of these in terms of the prime spectrum of a ring,
  but those are not well-suited for expressing this result.
Suggestions for better ways to state this theorem or organize things are welcome.

The machinery around `vanishing_ideal` and `zero_locus` is also minimal, I only added lemmas
  directly needed in this proof, since I'm not sure if they are the right approach.
-/

open ideal

noncomputable theory

namespace mv_polynomial
open mv_polynomial

variables {k : Type*} [field k]
variables {σ : Type*}

/-- Set of points that are zeroes of all polynomials in an ideal -/
def zero_locus (I : ideal (mv_polynomial σ k)) : set (σ → k) :=
{x : σ → k | ∀ p ∈ I, eval x p = 0}

@[simp] lemma mem_zero_locus_iff {I : ideal (mv_polynomial σ k)} {x : σ → k} :
  x ∈ zero_locus I ↔ ∀ p ∈ I, eval x p = 0 := iff.rfl

lemma zero_locus_anti_mono {I J : ideal (mv_polynomial σ k)} (h : I ≤ J) :
  zero_locus J ≤ zero_locus I :=
λ x hx p hp, hx p $ h hp

lemma zero_locus_bot : zero_locus (⊥ : ideal (mv_polynomial σ k)) = ⊤ :=
eq_top_iff.2 (λ x hx p hp, trans (congr_arg (eval x) (mem_bot.1 hp)) (eval x).map_zero)

lemma zero_locus_top : zero_locus (⊤ : ideal (mv_polynomial σ k)) = ⊥ :=
eq_bot_iff.2 $ λ x hx, one_ne_zero ((eval x).map_one ▸ (hx 1 submodule.mem_top) : (1 : k) = 0)

/-- Ideal of polynomials with common zeroes at all elements of a set -/
def vanishing_ideal (V : set (σ → k)) : ideal (mv_polynomial σ k) :=
{ carrier := {p | ∀ x ∈ V, eval x p = 0},
  zero_mem' := λ x hx, ring_hom.map_zero _,
  add_mem' := λ p q hp hq x hx, by simp only [hq x hx, hp x hx, add_zero, ring_hom.map_add],
  smul_mem' := λ p q hq x hx,
    by simp only [hq x hx, algebra.id.smul_eq_mul, mul_zero, ring_hom.map_mul] }

@[simp] lemma mem_vanishing_ideal_iff {V : set (σ → k)} {p : mv_polynomial σ k} :
  p ∈ vanishing_ideal V ↔ ∀ x ∈ V, eval x p = 0 := iff.rfl

lemma vanishing_ideal_anti_mono {A B : set (σ → k)} (h : A ≤ B) :
  vanishing_ideal B ≤ vanishing_ideal A :=
λ p hp x hx, hp x $ h hx

lemma le_vanishing_ideal_zero_locus (I : ideal (mv_polynomial σ k)) :
  I ≤ vanishing_ideal (zero_locus I) :=
λ p hp x hx, hx p hp

lemma zero_locus_vanishing_ideal_le (V : set (σ → k)) :
  V ≤ zero_locus (vanishing_ideal V) :=
λ V hV p hp, hp V hV

theorem zero_locus_vanishing_ideal_galois_connection :
  @galois_connection (ideal (mv_polynomial σ k)) (order_dual (set (σ → k))) _ _
    zero_locus vanishing_ideal :=
λ I V, ⟨λ h, le_trans (le_vanishing_ideal_zero_locus I) (vanishing_ideal_anti_mono h),
  λ h, le_trans (zero_locus_anti_mono h) (zero_locus_vanishing_ideal_le V)⟩

lemma mem_vanishing_ideal_singleton_iff (x : σ → k) (p : mv_polynomial σ k) :
  p ∈ (vanishing_ideal {x} : ideal (mv_polynomial σ k)) ↔ (eval x p = 0) :=
⟨λ h, h x rfl, λ hpx y hy, hy.symm ▸ hpx⟩

instance vanishing_ideal_singleton_is_maximal {x : σ → k} :
  (vanishing_ideal {x} : ideal (mv_polynomial σ k)).is_maximal :=
begin
  have : (vanishing_ideal {x} : ideal (mv_polynomial σ k)).quotient ≃+* k := ring_equiv.of_bijective
    (ideal.quotient.lift _ (eval x) (λ p h, (mem_vanishing_ideal_singleton_iff x p).mp h))
    begin
      refine ⟨(ring_hom.injective_iff _).mpr (λ p hp, _), λ z,
        ⟨(ideal.quotient.mk (vanishing_ideal {x} : ideal (mv_polynomial σ k))) (C z), by simp⟩⟩,
      obtain ⟨q, rfl⟩ := quotient.mk_surjective p,
      rwa [ideal.quotient.lift_mk, ← mem_vanishing_ideal_singleton_iff,
        ← quotient.eq_zero_iff_mem] at hp,
    end,
  rw [← bot_quotient_is_maximal_iff, ring_equiv.bot_maximal_iff this],
  exact bot_is_maximal,
end

lemma radical_le_vanishing_ideal_zero_locus (I : ideal (mv_polynomial σ k)) :
  I.radical ≤ vanishing_ideal (zero_locus I) :=
begin
  intros p hp x hx,
  rw ← mem_vanishing_ideal_singleton_iff,
  rw radical_eq_Inf at hp,
  refine (mem_Inf.mp hp) ⟨le_trans (le_vanishing_ideal_zero_locus I)
    (vanishing_ideal_anti_mono (λ y hy, hy.symm ▸ hx)), is_maximal.is_prime' _⟩,
end

/-- The point in the prime spectrum assosiated to a given point -/
def point_to_point (x : σ → k) : prime_spectrum (mv_polynomial σ k) :=
⟨(vanishing_ideal {x} : ideal (mv_polynomial σ k)), by apply_instance⟩

@[simp] lemma vanishing_ideal_point_to_point (V : set (σ → k)) :
  prime_spectrum.vanishing_ideal (point_to_point '' V) = mv_polynomial.vanishing_ideal V :=
le_antisymm
  (λ p hp x hx, (((prime_spectrum.mem_vanishing_ideal _ _).1 hp)
    ⟨vanishing_ideal {x}, by apply_instance⟩ ⟨x, ⟨hx, rfl⟩⟩) x rfl)
  (λ p hp, (prime_spectrum.mem_vanishing_ideal _ _).2
    (λ I hI, let ⟨x, hx⟩ := hI in hx.2 ▸ λ x' hx', (set.mem_singleton_iff.1 hx').symm ▸ hp x hx.1))

lemma point_to_point_zero_locus_le (I : ideal (mv_polynomial σ k)) :
  point_to_point '' (mv_polynomial.zero_locus I) ≤ prime_spectrum.zero_locus ↑I :=
λ J hJ, let ⟨x, hx⟩ := hJ in (le_trans (le_vanishing_ideal_zero_locus I)
  (hx.2 ▸ vanishing_ideal_anti_mono (set.singleton_subset_iff.2 hx.1)) : I ≤ J.as_ideal)

variables [is_alg_closed k] [fintype σ]

lemma is_maximal_iff_eq_vanishing_ideal_singleton (I : ideal (mv_polynomial σ k)) :
  I.is_maximal ↔ ∃ (x : σ → k), I = vanishing_ideal {x} :=
begin
  refine ⟨λ hI, _, λ h, let ⟨x, hx⟩ := h in
    hx.symm ▸ (mv_polynomial.vanishing_ideal_singleton_is_maximal)⟩,
  letI : I.is_maximal := hI,
  letI : field I.quotient := quotient.field I,
  let ϕ : k →+* I.quotient := (ideal.quotient.mk I).comp C,
  have hϕ : function.bijective ϕ := ⟨quotient_mk_comp_C_injective _ _ I hI.ne_top,
    is_alg_closed.algebra_map_surjective_of_is_integral' ϕ
      (mv_polynomial.comp_C_integral_of_surjective_of_jacobson _ quotient.mk_surjective)⟩,
  obtain ⟨φ, hφ⟩ := function.surjective.has_right_inverse hϕ.2,
  let x : σ → k := λ s, φ ((ideal.quotient.mk I) (X s)),
  have hx : ∀ s : σ, ϕ (x s) = (ideal.quotient.mk I) (X s) := λ s, hφ ((ideal.quotient.mk I) (X s)),
  refine ⟨x, (is_maximal.eq_of_le (by apply_instance) hI.ne_top _).symm⟩,
  intros p hp,
  rw [← quotient.eq_zero_iff_mem, map_mv_polynomial_eq_eval₂ (ideal.quotient.mk I) p, eval₂_eq'],
  rw [mem_vanishing_ideal_singleton_iff, eval_eq'] at hp,
  convert (trans (congr_arg ϕ hp) ϕ.map_zero),
  simp only [ϕ.map_sum, ϕ.map_mul, ϕ.map_prod, ϕ.map_pow, hx],
end

/-- Main statement of the Nullstellensatz -/
@[simp] theorem vanishing_ideal_zero_locus_eq_radical (I : ideal (mv_polynomial σ k)) :
  vanishing_ideal (zero_locus I) = I.radical :=
begin
  rw I.radical_eq_jacobson,
  refine le_antisymm (le_Inf _) (λ p hp x hx, _),
  { rintros J ⟨hJI, hJ⟩,
    obtain ⟨x, hx⟩ := (is_maximal_iff_eq_vanishing_ideal_singleton J).1 hJ,
    refine hx.symm ▸ vanishing_ideal_anti_mono (λ y hy p hp, _),
    rw [← mem_vanishing_ideal_singleton_iff, set.mem_singleton_iff.1 hy, ← hx],
    refine hJI hp },
  { rw ← mem_vanishing_ideal_singleton_iff x p,
    refine (mem_Inf.mp hp) ⟨le_trans (le_vanishing_ideal_zero_locus I)
      (vanishing_ideal_anti_mono (λ y hy, hy.symm ▸ hx)),
        mv_polynomial.vanishing_ideal_singleton_is_maximal⟩ },
end

@[simp] lemma is_prime.vanishing_ideal_zero_locus (P : ideal (mv_polynomial σ k)) [h : P.is_prime] :
  vanishing_ideal (zero_locus P) = P :=
trans (vanishing_ideal_zero_locus_eq_radical P) h.radical

end mv_polynomial