import tactic
import .hilbert

noncomputable theory
open_locale classical

local infix ` ≃ `:55 := C        -- \ equiv == equivalence/congruence
local infix `⬝`:56   := Segment.mk  -- \ cdot == center-dot

-------------------------------
-- |#Instructions For Hilbert# |
-------------------------------

-- Alex: I copied the instructions from the propositions.lean document
-- and deleted the ones that didn't pertain to the Hilbert group

/-
0. Read these instructions carefully.
1. I have tried my best to translate statements of the propositions into Lean.
2. In place of proofs, I have placed sorry's.
3. Do NOT add your proofs to this file. Create a new file called
   euclid_props.lean (and hilbert_props.lean) on CoCalc. Copy the statements there
   and add your proofs to it.
4. You might have to make minor changes to the statement to make it compatible with
   your syntax.  Don't make too many changes though.
5. If you do make a change to the statement, then don't forget to add a note
   in your hilbert_props.lean file.
6. I am also mentioning missing definitions in this file. You need to define these
   in your hilbert.lean / euclid.lean source file so that the propositions given
   here make sense.
7. If you spot some obvious mistakes in the statement of the propositions given
   below then let me know.  You can also ask me for clarifications.
8. This is still an incomplete list and I will keep adding more propositions in
   this file.

-- VK
-/

-- If two distinct lines intersect, then they do so in exactly one point.
lemma single_intersection (l₁ l₂ : Line) :
     l₁ ≠ l₂
  → intersect_line l₁ l₂
  → ∃! x : Point, lies_on_line x l₁ ∧ lies_on_line x l₂ :=
begin
  intros h₁ h₂,
  rw intersect_line at h₂,
  choose x h₂ using h₂,
  use x,
  tidy,
  symmetry,
  by_contradiction,
  have line_exists := line_exists x y a_2,
    sorry,
  have h₃ : l₁ = ⟨x, y, a_2⟩,
    { apply line_unique, assumption, assumption},
  have h₄ : l₂ = ⟨x, y, a_2⟩,
    { apply line_unique, assumption, assumption},
  cc,
end

-- Through any point there exists at least two lines.
lemma two_lines (p : Point) : ∃ l₁ l₂ : Line,
  l₁ ≠ l₂ ∧ lies_on_line p l₁ ∧ lies_on_line p l₂ :=
begin
  choose a b c h using no_line_on_three_points,
  by_cases ha : p ≠ a,
  by_cases hb : p ≠ b,
  by_cases hc : p ≠ c,
  set la : Line := ⟨p, a, ha⟩,
  set lb : Line := ⟨p, b, hb⟩,
  set lc : Line := ⟨p, c, hc⟩,
  by_cases hab : la ≠ lb,
  use la,
  use lb,
  have le := line_exists p a ha,
  split,
    assumption,
    split,
      exact le.1,
  have le := line_exists p b hb,
  exact le.1,
  simp at hab,
  by_cases hbc : lb ≠ lc,
  repeat {sorry},
end

-- # Euclid's Proposition 1
---------------------------
-- To construct an equilateral triangle on a given
-- finite straight line.
theorem construct_equilateral (s : Segment) :
  ∃ t : Triangle, t.p₁ = s.p₁ ∧ t.p₂ = s.p₂ ∧ equilateral t :=
begin
    let a : Point := s.p₁,
    let b : Point := s.p₂,
    -- let c : Point := s.p₁ ⬝ c ≃ s.p₂ ⬝ c,
    -- ,
    sorry,
end

-- # Euclid's Proposition 2
---------------------------
-- To place a straight line equal to a given straight
-- line with one end at a given point.
theorem segment_move (s : Segment) (h : s.p₁ ≠ s.p₂):
  ∃ s' : Segment, s ≃ s' ∧ s'.p₁ = s.p₁ :=
begin
    sorry,
    --let l : Line := line_of_points s.p₁ s.p₂ h,
    --let y : Line := lies_on_line s.p₁ y,
    --fapply segment_copy' s.p₁ s.p₂ l s.p₁ y,
end

-- Proposition 3.  To cut off from the greater of two given unequal
-- straight lines a straight line equal to the less.
-- Assume s₂ < s₁
--theorem prop3 (s₁ s₂ : Segment) (h : s₁.p1 ≠ s₁.p2):
--  ∃ x : Point, lies_on_segment x s₁ h ∧ s₁.p1⬝x ≃ s₂ := sorry

-- Proposition 4.  If two triangles have two sides equal to two sides
-- respectively, and have the angles contained by the equal straight
-- lines equal, then they also have the base equal to the base, the
-- triangle equals the triangle, and the remaining angles equal the
-- remaining angles respectively, namely those opposite the equal
-- sides.

--theorem prop4 (t₁ t₂ : Triangle) :
--  t₁.a⬝t₁.b ≃ t₂.a⬝t₂.b
--  → t₁.a⬝t₁.c ≃ t₂.a⬝t₂.c
--  → (Angle.mk t₁.a {Ray . base:=t₁.a, extension:=t₁.b} {Ray . base:=t₁.a, extension:=t₁.b} rfl rfl) ≃ Angle.mk t₁.a {Ray . base:=t₁.a, extension:=t₁.b} {Ray . base:=t₁.a, extension:=t₁.b} rfl rfl
--  → congruent_triangles t₁ t₂
--  := sorry

-- Proposition 5.  In isosceles triangles the angles at the base equal
-- one another, and, if the equal straight lines are produced further,
-- then the angles under the base equal one another.
----------------------------------------------------------------------
-- Part 1 of Prop 5
theorem isosceles_triangle_base_angle (abc : Triangle) :
  let sides := sides_of_triangle abc in
  let angles := angles_of_triangle abc in
  sides.nth 0 ≃ sides.nth 1  -- a⬝b ≃ b⬝c
  → angles.nth 0 ≃ angles.nth 2 :=
begin
  set a := abc.p₁,
  set b := abc.p₂,
  set c := abc.p₃,
  intros sides angles h,
  have x : b⬝a ≃ a⬝b,
    { apply segment_swap},
  have ba_bc : b⬝a ≃ b⬝c,
    { apply C_segment_trans,
      apply C_segment_symm,
      exact x,
      exact h},
  have bc_ba : b⬝c ≃ b⬝a,
    { apply C_segment_symm,
      exact ba_bc},
  have abc_cba : (⟨a, b, c⟩ : Angle) ≃ ⟨c, b, a⟩,
    by symmetry,
  have cong_tri := congruent_triangle_SAS b a c b c a ba_bc bc_ba abc_cba,
  have angles_cong := angles_of_congruent_triangle ⟨b, a, c⟩ ⟨b, c, a⟩ cong_tri,
  exact angles_cong.2.1,
end

-- Proposition 6.
--     If in a triangle two angles equal one another, then the sides opposite the equal angles also equal one another.

-- TODO: Maybe this should be a Theorem?
-- Corresponding angles in congruent triangles must be congruent
-- May be needed
-- ∧ t₁.α₁ ≃ t₂.α₁
-- ∧ t₁.α₂ ≃ t₂.α₂
-- ∧ t₁.α₃ ≃ t₂.α₃

-- # Proposition 6
------------------
-- If in a triangle two angles equal one another, then the sides
-- opposite the equal angles also equal one another.
-- https://artofproblemsolving.com/wiki/index.php/Base_Angle_Theorem
theorem sides_opposite_equal_angles_are_equal (abc : Triangle):
  let sides := (sides_of_triangle abc) in
  let angles := (angles_of_triangle abc) in
  angles.nth 0 ≃ angles.nth 2 → sides.nth 0 ≃ sides.nth 1 :=
  -- bac ≃ bca → ab ≃ bc
begin
  set a := abc.p₁,
  set b := abc.p₂,
  set c := abc.p₃,
  intros sides angles h,
  -- BAC === BCA or ACB
  -- sides: ba = ac
  -- angle:
  by_contradiction, -- assume ¬ (ab ≃ bc)
  sorry,
end

#exit

-- Proposition 7.
-- --     Given two straight lines constructed from the ends of a straight line and meeting in a point, there cannot be constructed from the ends of the same straight line, and on the same side of it, two other straight lines meeting in another point and equal to the former two respectively, namely each equal to that from the same end.

-- Proposition 8.
--     If two triangles have the two sides equal to two sides respectively, and also have the base equal to the base, then they also have the angles equal which are contained by the equal straight lines.

-- Proposition 9.
--     To bisect a given rectilinear angle.

theorem prop_9 (a : Angle): ∃ (p : Point), Angle.mk a.ext₁ a.base p ≃ Angle.mk p a.base a.ext₂

-- Proposition 10.
--     To bisect a given finite straight line.

theorem prop_10 (s : Segment) : ∃ (p : Point), B s.p₁ p s.p₂ ∧ p₁⬝p ≃ p⬝p₂

-- Proposition 11.
--     To draw a straight line at right angles to a given straight line from a given point on it.

-- Proposition 12.
--     To draw a straight line perpendicular to a given infinite straight line from a given point not on it.

-- Proposition 13.
--     If a straight line stands on a straight line, then it makes either two right angles or angles whose sum equals two right angles.

-- Proposition 14.
--     If with any straight line, and at a point on it, two straight lines not lying on the same side make the sum of the adjacent angles equal to two right angles, then the two straight lines are in a straight line with one another.

-- Proposition 15.
--     If two straight lines cut one another, then they make the vertical angles equal to one another.

--     Corollary. If two straight lines cut one another, then they will make the angles at the point of section equal to four right angles.
--
/-
Proposition 16.
    In any triangle, if one of the sides is produced, then the exterior angle is greater than either of the interior and opposite angles.

Proposition 17.
    In any triangle the sum of any two angles is less than two right angles.

Proposition 18.
    In any triangle the angle opposite the greater side is greater.

Proposition 19.
    In any triangle the side opposite the greater angle is greater.

Proposition 20.
    In any triangle the sum of any two sides is greater than the remaining one.

Proposition 21.
    If from the ends of one of the sides of a triangle two straight lines are constructed meeting within the triangle, then the sum of the straight lines so constructed is less than the sum of the remaining two sides of the triangle, but the constructed straight lines contain a greater angle than the angle contained by the remaining two sides.

Proposition 22.
    To construct a triangle out of three straight lines which equal three given straight lines: thus it is necessary that the sum of any two of the straight lines should be greater than the remaining one.

Proposition 23.
    To construct a rectilinear angle equal to a given rectilinear angle on a given straight line and at a point on it.

Proposition 24.
    If two triangles have two sides equal to two sides respectively, but have one of the angles contained by the equal straight lines greater than the other, then they also have the base greater than the base.

Proposition 25.
    If two triangles have two sides equal to two sides respectively, but have the base greater than the base, then they also have the one of the angles contained by the equal straight lines greater than the other.

Proposition 26.
    If two triangles have two angles equal to two angles respectively, and one side equal to one side, namely, either the side adjoining the equal angles, or that opposite one of the equal angles, then the remaining sides equal the remaining sides and the remaining angle equals the remaining angle. -/

theorem prop26_part1 (t₁ t₂ : Triangle): t₁.α₁ ≃ t₂.α₁ → t₁.α₂ ≃ t₂.α₂ → t₁.s₁₂ ≃ t₂.s₁₂ → congruent t₁ t₂ :=
begin
    let G : Point :=
    sorry
end

/-
Proposition 27.
    If a straight line falling on two straight lines makes the alternate angles equal to one another, then the straight lines are parallel to one another.

Proposition 28.
    If a straight line falling on two straight lines makes the exterior angle equal to the interior and opposite angle on the same side, or the sum of the interior angles on the same side equal to two right angles, then the straight lines are parallel to one another.

Proposition 29.
    A straight line falling on parallel straight lines makes the alternate angles equal to one another, the exterior angle equal to the interior and opposite angle, and the sum of the interior angles on the same side equal to two right angles.

Proposition 30.
    Straight lines parallel to the same straight line are also parallel to one another. -/

theorem prop30 (l₁ l₂ l₃ : Line): parallel_lines l₁ l₂ → parallel_lines l₁ l₃ → parallel_lines l₂ l₃

/-Proposition 31.
    To draw a straight line through a given point parallel to a given straight line. -/

theorem prop31 (l : Line) (p: Point) (h: ¬lies_on_line p l): ∃ (l' : Line), lies_on_line p l' ∧ parallel_lines l l' :=
begin
    /-split,
    split,
    let l' := Line,
    use l',
    choose l' using parallel_postulate,-/

    sorry,
end

/-Proposition 32.
    In any triangle, if one of the sides is produced, then the exterior angle equals the sum of the two interior and opposite angles, and the sum of the three interior angles of the triangle equals two right angles.

Proposition 33.
    Straight lines which join the ends of equal and parallel straight lines in the same directions are themselves equal and parallel.

Proposition 34.
    In parallelogrammic areas the opposite sides and angles equal one another, and the diameter bisects the areas.

Proposition 35.
    Parallelograms which are on the same base and in the same parallels equal one another.

Proposition 36.
    Parallelograms which are on equal bases and in the same parallels equal one another.

Proposition 37.
    Triangles which are on the same base and in the same parallels equal one another.

Proposition 38.
    Triangles which are on equal bases and in the same parallels equal one another.

Proposition 39.
    Equal triangles which are on the same base and on the same side are also in the same parallels.

Proposition 40.
    Equal triangles which are on equal bases and on the same side are also in the same parallels.

Proposition 41.
    If a parallelogram has the same base with a triangle and is in the same parallels, then the parallelogram is double the triangle.

Proposition 42.
    To construct a parallelogram equal to a given triangle in a given rectilinear angle.

Proposition 43.
    In any parallelogram the complements of the parallelograms about the diameter equal one another.

Proposition 44.
    To a given straight line in a given rectilinear angle, to apply a parallelogram equal to a given triangle.

Proposition 45.
    To construct a parallelogram equal to a given rectilinear figure in a given rectilinear angle.

Proposition 46.
    To describe a square on a given straight line.

Proposition 47.
    In right-angled triangles the square on the side opposite the right angle equals the sum of the squares on the sides containing the right angle.

Proposition 48.
    If in a triangle the square on one of the sides equals the sum of the squares on the remaining two sides of the triangle, then the angle contained by the remaining two sides of the triangle is right.
-/


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston, Bryan Gin-ge Chen

! This file was ported from Lean 3 source module data.setoid.basic
! leanprover-community/mathlib commit c3291da49cfa65f0d43b094750541c0731edc932
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Relation
import Mathbin.Order.GaloisConnection

/-!
# Equivalence relations

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

This file defines the complete lattice of equivalence relations on a type, results about the
inductively defined equivalence closure of a binary relation, and the analogues of some isomorphism
theorems for quotients of arbitrary types.

## Implementation notes

The function `rel` and lemmas ending in ' make it easier to talk about different
equivalence relations on the same type.

The complete lattice instance for equivalence relations could have been defined by lifting
the Galois insertion of equivalence relations on α into binary relations on α, and then using
`complete_lattice.copy` to define a complete lattice instance with more appropriate
definitional equalities (a similar example is `filter.complete_lattice` in
`order/filter/basic.lean`). This does not save space, however, and is less clear.

Partitions are not defined as a separate structure here; users are encouraged to
reason about them using the existing `setoid` and its infrastructure.

## Tags

setoid, equivalence, iseqv, relation, equivalence relation
-/

variable {α : Type _} {β : Type _}

#print Setoid.Rel /-
/-- A version of `setoid.r` that takes the equivalence relation as an explicit argument. -/
def Setoid.Rel (r : Setoid α) : α → α → Prop :=
  @Setoid.r _ r
#align setoid.rel Setoid.Rel
-/

#print Setoid.decidableRel /-
instance Setoid.decidableRel (r : Setoid α) [h : DecidableRel r.R] : DecidableRel r.Rel :=
  h
#align setoid.decidable_rel Setoid.decidableRel
-/

#print Quotient.eq_rel /-
/-- A version of `quotient.eq'` compatible with `setoid.rel`, to make rewriting possible. -/
theorem Quotient.eq_rel {r : Setoid α} {x y} :
    (Quotient.mk'' x : Quotient r) = Quotient.mk'' y ↔ r.Rel x y :=
  Quotient.eq'
#align quotient.eq_rel Quotient.eq_rel
-/

namespace Setoid

#print Setoid.ext' /-
@[ext]
theorem ext' {r s : Setoid α} (H : ∀ a b, r.Rel a b ↔ s.Rel a b) : r = s :=
  ext H
#align setoid.ext' Setoid.ext'
-/

#print Setoid.ext_iff /-
theorem ext_iff {r s : Setoid α} : r = s ↔ ∀ a b, r.Rel a b ↔ s.Rel a b :=
  ⟨fun h a b => h ▸ Iff.rfl, ext'⟩
#align setoid.ext_iff Setoid.ext_iff
-/

#print Setoid.eq_iff_rel_eq /-
/-- Two equivalence relations are equal iff their underlying binary operations are equal. -/
theorem eq_iff_rel_eq {r₁ r₂ : Setoid α} : r₁ = r₂ ↔ r₁.Rel = r₂.Rel :=
  ⟨fun h => h ▸ rfl, fun h => Setoid.ext' fun x y => h ▸ Iff.rfl⟩
#align setoid.eq_iff_rel_eq Setoid.eq_iff_rel_eq
-/

/-- Defining `≤` for equivalence relations. -/
instance : LE (Setoid α) :=
  ⟨fun r s => ∀ ⦃x y⦄, r.Rel x y → s.Rel x y⟩

#print Setoid.le_def /-
theorem le_def {r s : Setoid α} : r ≤ s ↔ ∀ {x y}, r.Rel x y → s.Rel x y :=
  Iff.rfl
#align setoid.le_def Setoid.le_def
-/

#print Setoid.refl' /-
@[refl]
theorem refl' (r : Setoid α) (x) : r.Rel x x :=
  r.2.1 x
#align setoid.refl' Setoid.refl'
-/

#print Setoid.symm' /-
@[symm]
theorem symm' (r : Setoid α) : ∀ {x y}, r.Rel x y → r.Rel y x := fun _ _ h => r.2.2.1 h
#align setoid.symm' Setoid.symm'
-/

#print Setoid.trans' /-
@[trans]
theorem trans' (r : Setoid α) : ∀ {x y z}, r.Rel x y → r.Rel y z → r.Rel x z := fun _ _ _ hx =>
  r.2.2.2 hx
#align setoid.trans' Setoid.trans'
-/

#print Setoid.comm' /-
theorem comm' (s : Setoid α) {x y} : s.Rel x y ↔ s.Rel y x :=
  ⟨s.symm', s.symm'⟩
#align setoid.comm' Setoid.comm'
-/

#print Setoid.ker /-
/-- The kernel of a function is an equivalence relation. -/
def ker (f : α → β) : Setoid α :=
  ⟨(· = ·) on f, eq_equivalence.comap f⟩
#align setoid.ker Setoid.ker
-/

#print Setoid.ker_mk_eq /-
/-- The kernel of the quotient map induced by an equivalence relation r equals r. -/
@[simp]
theorem ker_mk_eq (r : Setoid α) : ker (@Quotient.mk' _ r) = r :=
  ext' fun x y => Quotient.eq'
#align setoid.ker_mk_eq Setoid.ker_mk_eq
-/

#print Setoid.ker_apply_mk_out /-
theorem ker_apply_mk_out {f : α → β} (a : α) :
    (f
        haveI := Setoid.ker f
        ⟦a⟧.out) =
      f a :=
  @Quotient.mk_out _ (Setoid.ker f) a
#align setoid.ker_apply_mk_out Setoid.ker_apply_mk_out
-/

#print Setoid.ker_apply_mk_out' /-
theorem ker_apply_mk_out' {f : α → β} (a : α) :
    f (Quotient.mk'' a : Quotient <| Setoid.ker f).out' = f a :=
  @Quotient.mk_out' _ (Setoid.ker f) a
#align setoid.ker_apply_mk_out' Setoid.ker_apply_mk_out'
-/

/- warning: setoid.ker_def -> Setoid.ker_def is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {f : α -> β} {x : α} {y : α}, Iff (Setoid.Rel.{u1} α (Setoid.ker.{u1, u2} α β f) x y) (Eq.{succ u2} β (f x) (f y))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {f : α -> β} {x : α} {y : α}, Iff (Setoid.Rel.{u2} α (Setoid.ker.{u2, u1} α β f) x y) (Eq.{succ u1} β (f x) (f y))
Case conversion may be inaccurate. Consider using '#align setoid.ker_def Setoid.ker_defₓ'. -/
theorem ker_def {f : α → β} {x y : α} : (ker f).Rel x y ↔ f x = f y :=
  Iff.rfl
#align setoid.ker_def Setoid.ker_def

#print Setoid.prod /-
/-- Given types `α`, `β`, the product of two equivalence relations `r` on `α` and `s` on `β`:
    `(x₁, x₂), (y₁, y₂) ∈ α × β` are related by `r.prod s` iff `x₁` is related to `y₁`
    by `r` and `x₂` is related to `y₂` by `s`. -/
protected def prod (r : Setoid α) (s : Setoid β) : Setoid (α × β)
    where
  R x y := r.Rel x.1 y.1 ∧ s.Rel x.2 y.2
  iseqv :=
    ⟨fun x => ⟨r.refl' x.1, s.refl' x.2⟩, fun _ _ h => ⟨r.symm' h.1, s.symm' h.2⟩,
      fun _ _ _ h1 h2 => ⟨r.trans' h1.1 h2.1, s.trans' h1.2 h2.2⟩⟩
#align setoid.prod Setoid.prod
-/

/-- The infimum of two equivalence relations. -/
instance : Inf (Setoid α) :=
  ⟨fun r s =>
    ⟨fun x y => r.Rel x y ∧ s.Rel x y,
      ⟨fun x => ⟨r.refl' x, s.refl' x⟩, fun _ _ h => ⟨r.symm' h.1, s.symm' h.2⟩, fun _ _ _ h1 h2 =>
        ⟨r.trans' h1.1 h2.1, s.trans' h1.2 h2.2⟩⟩⟩⟩

/- warning: setoid.inf_def -> Setoid.inf_def is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {r : Setoid.{succ u1} α} {s : Setoid.{succ u1} α}, Eq.{succ u1} (α -> α -> Prop) (Setoid.Rel.{u1} α (Inf.inf.{u1} (Setoid.{succ u1} α) (Setoid.hasInf.{u1} α) r s)) (Inf.inf.{u1} (α -> α -> Prop) (Pi.hasInf.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasInf.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => SemilatticeInf.toHasInf.{0} Prop (Lattice.toSemilatticeInf.{0} Prop (CompleteLattice.toLattice.{0} Prop Prop.completeLattice))))) (Setoid.Rel.{u1} α r) (Setoid.Rel.{u1} α s))
but is expected to have type
  forall {α : Type.{u1}} {r : Setoid.{succ u1} α} {s : Setoid.{succ u1} α}, Eq.{succ u1} (α -> α -> Prop) (Setoid.Rel.{u1} α (Inf.inf.{u1} (Setoid.{succ u1} α) (Setoid.instInfSetoid.{u1} α) r s)) (Inf.inf.{u1} (α -> α -> Prop) (Pi.instInfForAll.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.instInfForAll.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => Lattice.toInf.{0} Prop (CompleteLattice.toLattice.{0} Prop Prop.completeLattice)))) (Setoid.Rel.{u1} α r) (Setoid.Rel.{u1} α s))
Case conversion may be inaccurate. Consider using '#align setoid.inf_def Setoid.inf_defₓ'. -/
/-- The infimum of 2 equivalence relations r and s is the same relation as the infimum
    of the underlying binary operations. -/
theorem inf_def {r s : Setoid α} : (r ⊓ s).Rel = r.Rel ⊓ s.Rel :=
  rfl
#align setoid.inf_def Setoid.inf_def

/- warning: setoid.inf_iff_and -> Setoid.inf_iff_and is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {r : Setoid.{succ u1} α} {s : Setoid.{succ u1} α} {x : α} {y : α}, Iff (Setoid.Rel.{u1} α (Inf.inf.{u1} (Setoid.{succ u1} α) (Setoid.hasInf.{u1} α) r s) x y) (And (Setoid.Rel.{u1} α r x y) (Setoid.Rel.{u1} α s x y))
but is expected to have type
  forall {α : Type.{u1}} {r : Setoid.{succ u1} α} {s : Setoid.{succ u1} α} {x : α} {y : α}, Iff (Setoid.Rel.{u1} α (Inf.inf.{u1} (Setoid.{succ u1} α) (Setoid.instInfSetoid.{u1} α) r s) x y) (And (Setoid.Rel.{u1} α r x y) (Setoid.Rel.{u1} α s x y))
Case conversion may be inaccurate. Consider using '#align setoid.inf_iff_and Setoid.inf_iff_andₓ'. -/
theorem inf_iff_and {r s : Setoid α} {x y} : (r ⊓ s).Rel x y ↔ r.Rel x y ∧ s.Rel x y :=
  Iff.rfl
#align setoid.inf_iff_and Setoid.inf_iff_and

/-- The infimum of a set of equivalence relations. -/
instance : InfSet (Setoid α) :=
  ⟨fun S =>
    ⟨fun x y => ∀ r ∈ S, Rel r x y,
      ⟨fun x r hr => r.refl' x, fun _ _ h r hr => r.symm' <| h r hr, fun _ _ _ h1 h2 r hr =>
        r.trans' (h1 r hr) <| h2 r hr⟩⟩⟩

#print Setoid.infₛ_def /-
/-- The underlying binary operation of the infimum of a set of equivalence relations
    is the infimum of the set's image under the map to the underlying binary operation. -/
theorem infₛ_def {s : Set (Setoid α)} : (infₛ s).Rel = infₛ (Rel '' s) :=
  by
  ext
  simp only [infₛ_image, infᵢ_apply, infᵢ_Prop_eq]
  rfl
#align setoid.Inf_def Setoid.infₛ_def
-/

instance : PartialOrder (Setoid α) where
  le := (· ≤ ·)
  lt r s := r ≤ s ∧ ¬s ≤ r
  le_refl _ _ _ := id
  le_trans _ _ _ hr hs _ _ h := hs <| hr h
  lt_iff_le_not_le _ _ := Iff.rfl
  le_antisymm r s h1 h2 := Setoid.ext' fun x y => ⟨fun h => h1 h, fun h => h2 h⟩

#print Setoid.completeLattice /-
/-- The complete lattice of equivalence relations on a type, with bottom element `=`
    and top element the trivial equivalence relation. -/
instance completeLattice : CompleteLattice (Setoid α) :=
  {
    completeLatticeOfInf (Setoid α) fun s =>
      ⟨fun r hr x y h => h _ hr, fun r hr x y h r' hr' =>
        hr hr' h⟩ with
    inf := Inf.inf
    inf_le_left := fun _ _ _ _ h => h.1
    inf_le_right := fun _ _ _ _ h => h.2
    le_inf := fun _ _ _ h1 h2 _ _ h => ⟨h1 h, h2 h⟩
    top := ⟨fun _ _ => True, ⟨fun _ => trivial, fun _ _ h => h, fun _ _ _ h1 h2 => h1⟩⟩
    le_top := fun _ _ _ _ => trivial
    bot := ⟨(· = ·), ⟨fun _ => rfl, fun _ _ h => h.symm, fun _ _ _ h1 h2 => h1.trans h2⟩⟩
    bot_le := fun r x y h => h ▸ r.2.1 x }
#align setoid.complete_lattice Setoid.completeLattice
-/

/- warning: setoid.top_def -> Setoid.top_def is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}}, Eq.{succ u1} (α -> α -> Prop) (Setoid.Rel.{u1} α (Top.top.{u1} (Setoid.{succ u1} α) (CompleteLattice.toHasTop.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) (Top.top.{u1} (α -> α -> Prop) (Pi.hasTop.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasTop.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => CompleteLattice.toHasTop.{0} Prop Prop.completeLattice))))
but is expected to have type
  forall {α : Type.{u1}}, Eq.{succ u1} (α -> α -> Prop) (Setoid.Rel.{u1} α (Top.top.{u1} (Setoid.{succ u1} α) (CompleteLattice.toTop.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) (Top.top.{u1} (α -> α -> Prop) (Pi.instTopForAll.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.instTopForAll.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => CompleteLattice.toTop.{0} Prop Prop.completeLattice))))
Case conversion may be inaccurate. Consider using '#align setoid.top_def Setoid.top_defₓ'. -/
@[simp]
theorem top_def : (⊤ : Setoid α).Rel = ⊤ :=
  rfl
#align setoid.top_def Setoid.top_def

/- warning: setoid.bot_def -> Setoid.bot_def is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}}, Eq.{succ u1} (α -> α -> Prop) (Setoid.Rel.{u1} α (Bot.bot.{u1} (Setoid.{succ u1} α) (CompleteLattice.toHasBot.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) (Eq.{succ u1} α)
but is expected to have type
  forall {α : Type.{u1}}, Eq.{succ u1} (α -> α -> Prop) (Setoid.Rel.{u1} α (Bot.bot.{u1} (Setoid.{succ u1} α) (CompleteLattice.toBot.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) (fun (x._@.Mathlib.Data.Setoid.Basic._hyg.1211 : α) (x._@.Mathlib.Data.Setoid.Basic._hyg.1213 : α) => Eq.{succ u1} α x._@.Mathlib.Data.Setoid.Basic._hyg.1211 x._@.Mathlib.Data.Setoid.Basic._hyg.1213)
Case conversion may be inaccurate. Consider using '#align setoid.bot_def Setoid.bot_defₓ'. -/
@[simp]
theorem bot_def : (⊥ : Setoid α).Rel = (· = ·) :=
  rfl
#align setoid.bot_def Setoid.bot_def

/- warning: setoid.eq_top_iff -> Setoid.eq_top_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {s : Setoid.{succ u1} α}, Iff (Eq.{succ u1} (Setoid.{succ u1} α) s (Top.top.{u1} (Setoid.{succ u1} α) (CompleteLattice.toHasTop.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) (forall (x : α) (y : α), Setoid.Rel.{u1} α s x y)
but is expected to have type
  forall {α : Type.{u1}} {s : Setoid.{succ u1} α}, Iff (Eq.{succ u1} (Setoid.{succ u1} α) s (Top.top.{u1} (Setoid.{succ u1} α) (CompleteLattice.toTop.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) (forall (x : α) (y : α), Setoid.Rel.{u1} α s x y)
Case conversion may be inaccurate. Consider using '#align setoid.eq_top_iff Setoid.eq_top_iffₓ'. -/
theorem eq_top_iff {s : Setoid α} : s = (⊤ : Setoid α) ↔ ∀ x y : α, s.Rel x y := by
  simp [eq_top_iff, Setoid.le_def, Setoid.top_def, Pi.top_apply]
#align setoid.eq_top_iff Setoid.eq_top_iff

#print Setoid.eqvGen_eq /-
/-- The inductively defined equivalence closure of a binary relation r is the infimum
    of the set of all equivalence relations containing r. -/
theorem eqvGen_eq (r : α → α → Prop) :
    EqvGen.Setoid r = infₛ { s : Setoid α | ∀ ⦃x y⦄, r x y → s.Rel x y } :=
  le_antisymm
    (fun _ _ H =>
      EqvGen.ndrec (fun _ _ h _ hs => hs h) (refl' _) (fun _ _ _ => symm' _)
        (fun _ _ _ _ _ => trans' _) H)
    (infₛ_le fun _ _ h => EqvGen.rel _ _ h)
#align setoid.eqv_gen_eq Setoid.eqvGen_eq
-/

/- warning: setoid.sup_eq_eqv_gen -> Setoid.sup_eq_eqvGen is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (r : Setoid.{succ u1} α) (s : Setoid.{succ u1} α), Eq.{succ u1} (Setoid.{succ u1} α) (Sup.sup.{u1} (Setoid.{succ u1} α) (SemilatticeSup.toHasSup.{u1} (Setoid.{succ u1} α) (Lattice.toSemilatticeSup.{u1} (Setoid.{succ u1} α) (CompleteLattice.toLattice.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) r s) (EqvGen.Setoid.{u1} α (fun (x : α) (y : α) => Or (Setoid.Rel.{u1} α r x y) (Setoid.Rel.{u1} α s x y)))
but is expected to have type
  forall {α : Type.{u1}} (r : Setoid.{succ u1} α) (s : Setoid.{succ u1} α), Eq.{succ u1} (Setoid.{succ u1} α) (Sup.sup.{u1} (Setoid.{succ u1} α) (SemilatticeSup.toSup.{u1} (Setoid.{succ u1} α) (Lattice.toSemilatticeSup.{u1} (Setoid.{succ u1} α) (CompleteLattice.toLattice.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) r s) (EqvGen.Setoid.{u1} α (fun (x : α) (y : α) => Or (Setoid.Rel.{u1} α r x y) (Setoid.Rel.{u1} α s x y)))
Case conversion may be inaccurate. Consider using '#align setoid.sup_eq_eqv_gen Setoid.sup_eq_eqvGenₓ'. -/
/-- The supremum of two equivalence relations r and s is the equivalence closure of the binary
    relation `x is related to y by r or s`. -/
theorem sup_eq_eqvGen (r s : Setoid α) : r ⊔ s = EqvGen.Setoid fun x y => r.Rel x y ∨ s.Rel x y :=
  by
  rw [eqv_gen_eq]
  apply congr_arg Inf
  simp only [le_def, or_imp, ← forall_and]
#align setoid.sup_eq_eqv_gen Setoid.sup_eq_eqvGen

/- warning: setoid.sup_def -> Setoid.sup_def is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {r : Setoid.{succ u1} α} {s : Setoid.{succ u1} α}, Eq.{succ u1} (Setoid.{succ u1} α) (Sup.sup.{u1} (Setoid.{succ u1} α) (SemilatticeSup.toHasSup.{u1} (Setoid.{succ u1} α) (Lattice.toSemilatticeSup.{u1} (Setoid.{succ u1} α) (CompleteLattice.toLattice.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) r s) (EqvGen.Setoid.{u1} α (Sup.sup.{u1} (α -> α -> Prop) (Pi.hasSup.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasSup.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => SemilatticeSup.toHasSup.{0} Prop (Lattice.toSemilatticeSup.{0} Prop (CompleteLattice.toLattice.{0} Prop Prop.completeLattice))))) (Setoid.Rel.{u1} α r) (Setoid.Rel.{u1} α s)))
but is expected to have type
  forall {α : Type.{u1}} {r : Setoid.{succ u1} α} {s : Setoid.{succ u1} α}, Eq.{succ u1} (Setoid.{succ u1} α) (Sup.sup.{u1} (Setoid.{succ u1} α) (SemilatticeSup.toSup.{u1} (Setoid.{succ u1} α) (Lattice.toSemilatticeSup.{u1} (Setoid.{succ u1} α) (CompleteLattice.toLattice.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)))) r s) (EqvGen.Setoid.{u1} α (Sup.sup.{u1} (α -> α -> Prop) (Pi.instSupForAll.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.instSupForAll.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => SemilatticeSup.toSup.{0} Prop (Lattice.toSemilatticeSup.{0} Prop (CompleteLattice.toLattice.{0} Prop Prop.completeLattice))))) (Setoid.Rel.{u1} α r) (Setoid.Rel.{u1} α s)))
Case conversion may be inaccurate. Consider using '#align setoid.sup_def Setoid.sup_defₓ'. -/
/-- The supremum of 2 equivalence relations r and s is the equivalence closure of the
    supremum of the underlying binary operations. -/
theorem sup_def {r s : Setoid α} : r ⊔ s = EqvGen.Setoid (r.Rel ⊔ s.Rel) := by
  rw [sup_eq_eqv_gen] <;> rfl
#align setoid.sup_def Setoid.sup_def

/- warning: setoid.Sup_eq_eqv_gen -> Setoid.supₛ_eq_eqvGen is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (S : Set.{u1} (Setoid.{succ u1} α)), Eq.{succ u1} (Setoid.{succ u1} α) (SupSet.supₛ.{u1} (Setoid.{succ u1} α) (CompleteSemilatticeSup.toHasSup.{u1} (Setoid.{succ u1} α) (CompleteLattice.toCompleteSemilatticeSup.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α))) S) (EqvGen.Setoid.{u1} α (fun (x : α) (y : α) => Exists.{succ u1} (Setoid.{succ u1} α) (fun (r : Setoid.{succ u1} α) => And (Membership.Mem.{u1, u1} (Setoid.{succ u1} α) (Set.{u1} (Setoid.{succ u1} α)) (Set.hasMem.{u1} (Setoid.{succ u1} α)) r S) (Setoid.Rel.{u1} α r x y))))
but is expected to have type
  forall {α : Type.{u1}} (S : Set.{u1} (Setoid.{succ u1} α)), Eq.{succ u1} (Setoid.{succ u1} α) (SupSet.supₛ.{u1} (Setoid.{succ u1} α) (CompleteLattice.toSupSet.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)) S) (EqvGen.Setoid.{u1} α (fun (x : α) (y : α) => Exists.{succ u1} (Setoid.{succ u1} α) (fun (r : Setoid.{succ u1} α) => And (Membership.mem.{u1, u1} (Setoid.{succ u1} α) (Set.{u1} (Setoid.{succ u1} α)) (Set.instMembershipSet.{u1} (Setoid.{succ u1} α)) r S) (Setoid.Rel.{u1} α r x y))))
Case conversion may be inaccurate. Consider using '#align setoid.Sup_eq_eqv_gen Setoid.supₛ_eq_eqvGenₓ'. -/
/-- The supremum of a set S of equivalence relations is the equivalence closure of the binary
    relation `there exists r ∈ S relating x and y`. -/
theorem supₛ_eq_eqvGen (S : Set (Setoid α)) :
    supₛ S = EqvGen.Setoid fun x y => ∃ r : Setoid α, r ∈ S ∧ r.Rel x y :=
  by
  rw [eqv_gen_eq]
  apply congr_arg Inf
  simp only [upperBounds, le_def, and_imp, exists_imp]
  ext
  exact ⟨fun H x y r hr => H hr, fun H r hr x y => H r hr⟩
#align setoid.Sup_eq_eqv_gen Setoid.supₛ_eq_eqvGen

/- warning: setoid.Sup_def -> Setoid.supₛ_def is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {s : Set.{u1} (Setoid.{succ u1} α)}, Eq.{succ u1} (Setoid.{succ u1} α) (SupSet.supₛ.{u1} (Setoid.{succ u1} α) (CompleteSemilatticeSup.toHasSup.{u1} (Setoid.{succ u1} α) (CompleteLattice.toCompleteSemilatticeSup.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α))) s) (EqvGen.Setoid.{u1} α (SupSet.supₛ.{u1} (α -> α -> Prop) (Pi.supSet.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.supSet.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => CompleteSemilatticeSup.toHasSup.{0} Prop (CompleteLattice.toCompleteSemilatticeSup.{0} Prop Prop.completeLattice)))) (Set.image.{u1, u1} (Setoid.{succ u1} α) (α -> α -> Prop) (Setoid.Rel.{u1} α) s)))
but is expected to have type
  forall {α : Type.{u1}} {s : Set.{u1} (Setoid.{succ u1} α)}, Eq.{succ u1} (Setoid.{succ u1} α) (SupSet.supₛ.{u1} (Setoid.{succ u1} α) (CompleteLattice.toSupSet.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α)) s) (EqvGen.Setoid.{u1} α (SupSet.supₛ.{u1} (α -> α -> Prop) (Pi.supSet.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.supSet.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => CompleteLattice.toSupSet.{0} Prop Prop.completeLattice))) (Set.image.{u1, u1} (Setoid.{succ u1} α) (α -> α -> Prop) (Setoid.Rel.{u1} α) s)))
Case conversion may be inaccurate. Consider using '#align setoid.Sup_def Setoid.supₛ_defₓ'. -/
/-- The supremum of a set of equivalence relations is the equivalence closure of the
    supremum of the set's image under the map to the underlying binary operation. -/
theorem supₛ_def {s : Set (Setoid α)} : supₛ s = EqvGen.Setoid (supₛ (Rel '' s)) :=
  by
  rw [Sup_eq_eqv_gen, supₛ_image]
  congr with (x y)
  simp only [supᵢ_apply, supᵢ_Prop_eq, exists_prop]
#align setoid.Sup_def Setoid.supₛ_def

#print Setoid.eqvGen_of_setoid /-
/-- The equivalence closure of an equivalence relation r is r. -/
@[simp]
theorem eqvGen_of_setoid (r : Setoid α) : EqvGen.Setoid r.R = r :=
  le_antisymm (by rw [eqv_gen_eq] <;> exact infₛ_le fun _ _ => id) EqvGen.rel
#align setoid.eqv_gen_of_setoid Setoid.eqvGen_of_setoid
-/

#print Setoid.eqvGen_idem /-
/-- Equivalence closure is idempotent. -/
@[simp]
theorem eqvGen_idem (r : α → α → Prop) : EqvGen.Setoid (EqvGen.Setoid r).Rel = EqvGen.Setoid r :=
  eqvGen_of_setoid _
#align setoid.eqv_gen_idem Setoid.eqvGen_idem
-/

#print Setoid.eqvGen_le /-
/-- The equivalence closure of a binary relation r is contained in any equivalence
    relation containing r. -/
theorem eqvGen_le {r : α → α → Prop} {s : Setoid α} (h : ∀ x y, r x y → s.Rel x y) :
    EqvGen.Setoid r ≤ s := by rw [eqv_gen_eq] <;> exact infₛ_le h
#align setoid.eqv_gen_le Setoid.eqvGen_le
-/

#print Setoid.eqvGen_mono /-
/-- Equivalence closure of binary relations is monotone. -/
theorem eqvGen_mono {r s : α → α → Prop} (h : ∀ x y, r x y → s x y) :
    EqvGen.Setoid r ≤ EqvGen.Setoid s :=
  eqvGen_le fun _ _ hr => EqvGen.rel _ _ <| h _ _ hr
#align setoid.eqv_gen_mono Setoid.eqvGen_mono
-/

/- warning: setoid.gi -> Setoid.gi is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}}, GaloisInsertion.{u1, u1} (α -> α -> Prop) (Setoid.{succ u1} α) (Pi.preorder.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.preorder.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => PartialOrder.toPreorder.{0} Prop Prop.partialOrder))) (PartialOrder.toPreorder.{u1} (Setoid.{succ u1} α) (Setoid.partialOrder.{u1} α)) (EqvGen.Setoid.{u1} α) (Setoid.Rel.{u1} α)
but is expected to have type
  forall {α : Type.{u1}}, GaloisInsertion.{u1, u1} (α -> α -> Prop) (Setoid.{succ u1} α) (Pi.preorder.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.preorder.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => PartialOrder.toPreorder.{0} Prop Prop.partialOrder))) (PartialOrder.toPreorder.{u1} (Setoid.{succ u1} α) (Setoid.instPartialOrderSetoid.{u1} α)) (EqvGen.Setoid.{u1} α) (Setoid.Rel.{u1} α)
Case conversion may be inaccurate. Consider using '#align setoid.gi Setoid.giₓ'. -/
/-- There is a Galois insertion of equivalence relations on α into binary relations
    on α, with equivalence closure the lower adjoint. -/
def gi : @GaloisInsertion (α → α → Prop) (Setoid α) _ _ EqvGen.Setoid Rel
    where
  choice r h := EqvGen.Setoid r
  gc r s := ⟨fun H _ _ h => H <| EqvGen.rel _ _ h, fun H => eqvGen_of_setoid s ▸ eqvGen_mono H⟩
  le_l_u x := (eqvGen_of_setoid x).symm ▸ le_refl x
  choice_eq _ _ := rfl
#align setoid.gi Setoid.gi

open Function

/- warning: setoid.injective_iff_ker_bot -> Setoid.injective_iff_ker_bot is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β), Iff (Function.Injective.{succ u1, succ u2} α β f) (Eq.{succ u1} (Setoid.{succ u1} α) (Setoid.ker.{u1, u2} α β f) (Bot.bot.{u1} (Setoid.{succ u1} α) (CompleteLattice.toHasBot.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (f : α -> β), Iff (Function.Injective.{succ u2, succ u1} α β f) (Eq.{succ u2} (Setoid.{succ u2} α) (Setoid.ker.{u2, u1} α β f) (Bot.bot.{u2} (Setoid.{succ u2} α) (CompleteLattice.toBot.{u2} (Setoid.{succ u2} α) (Setoid.completeLattice.{u2} α))))
Case conversion may be inaccurate. Consider using '#align setoid.injective_iff_ker_bot Setoid.injective_iff_ker_botₓ'. -/
/-- A function from α to β is injective iff its kernel is the bottom element of the complete lattice
    of equivalence relations on α. -/
theorem injective_iff_ker_bot (f : α → β) : Injective f ↔ ker f = ⊥ :=
  (@eq_bot_iff (Setoid α) _ _ (ker f)).symm
#align setoid.injective_iff_ker_bot Setoid.injective_iff_ker_bot

/- warning: setoid.ker_iff_mem_preimage -> Setoid.ker_iff_mem_preimage is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {f : α -> β} {x : α} {y : α}, Iff (Setoid.Rel.{u1} α (Setoid.ker.{u1, u2} α β f) x y) (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) x (Set.preimage.{u1, u2} α β f (Singleton.singleton.{u2, u2} β (Set.{u2} β) (Set.hasSingleton.{u2} β) (f y))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {f : α -> β} {x : α} {y : α}, Iff (Setoid.Rel.{u2} α (Setoid.ker.{u2, u1} α β f) x y) (Membership.mem.{u2, u2} α (Set.{u2} α) (Set.instMembershipSet.{u2} α) x (Set.preimage.{u2, u1} α β f (Singleton.singleton.{u1, u1} β (Set.{u1} β) (Set.instSingletonSet.{u1} β) (f y))))
Case conversion may be inaccurate. Consider using '#align setoid.ker_iff_mem_preimage Setoid.ker_iff_mem_preimageₓ'. -/
/-- The elements related to x ∈ α by the kernel of f are those in the preimage of f(x) under f. -/
theorem ker_iff_mem_preimage {f : α → β} {x y} : (ker f).Rel x y ↔ x ∈ f ⁻¹' {f y} :=
  Iff.rfl
#align setoid.ker_iff_mem_preimage Setoid.ker_iff_mem_preimage

#print Setoid.liftEquiv /-
/-- Equivalence between functions `α → β` such that `r x y → f x = f y` and functions
`quotient r → β`. -/
def liftEquiv (r : Setoid α) : { f : α → β // r ≤ ker f } ≃ (Quotient r → β)
    where
  toFun f := Quotient.lift (f : α → β) f.2
  invFun f := ⟨f ∘ Quotient.mk', fun x y h => by simp [ker_def, Quotient.sound h]⟩
  left_inv := fun ⟨f, hf⟩ => Subtype.eq <| funext fun x => rfl
  right_inv f := funext fun x => Quotient.inductionOn' x fun x => rfl
#align setoid.lift_equiv Setoid.liftEquiv
-/

/- warning: setoid.lift_unique -> Setoid.lift_unique is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {r : Setoid.{succ u1} α} {f : α -> β} (H : LE.le.{u1} (Setoid.{succ u1} α) (Setoid.hasLe.{u1} α) r (Setoid.ker.{u1, u2} α β f)) (g : (Quotient.{succ u1} α r) -> β), (Eq.{max (succ u1) (succ u2)} (α -> β) f (Function.comp.{succ u1, succ u1, succ u2} α (Quotient.{succ u1} α r) β g (Quotient.mk'.{succ u1} α r))) -> (Eq.{max (succ u1) (succ u2)} ((Quotient.{succ u1} α r) -> β) (Quotient.lift.{succ u1, succ u2} α β r f H) g)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {r : Setoid.{succ u2} α} {f : α -> β} (H : LE.le.{u2} (Setoid.{succ u2} α) (Setoid.instLESetoid.{u2} α) r (Setoid.ker.{u2, u1} α β f)) (g : (Quotient.{succ u2} α r) -> β), (Eq.{max (succ u2) (succ u1)} (α -> β) f (Function.comp.{succ u2, succ u2, succ u1} α (Quotient.{succ u2} α r) β g (Quotient.mk''.{succ u2} α r))) -> (Eq.{max (succ u2) (succ u1)} ((Quotient.{succ u2} α r) -> β) (Quotient.lift.{succ u2, succ u1} α β r f H) g)
Case conversion may be inaccurate. Consider using '#align setoid.lift_unique Setoid.lift_uniqueₓ'. -/
/-- The uniqueness part of the universal property for quotients of an arbitrary type. -/
theorem lift_unique {r : Setoid α} {f : α → β} (H : r ≤ ker f) (g : Quotient r → β)
    (Hg : f = g ∘ Quotient.mk') : Quotient.lift f H = g :=
  by
  ext ⟨x⟩
  erw [Quotient.lift_mk f H, Hg]
  rfl
#align setoid.lift_unique Setoid.lift_unique

/- warning: setoid.ker_lift_injective -> Setoid.ker_lift_injective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β), Function.Injective.{succ u1, succ u2} (Quotient.{succ u1} α (Setoid.ker.{u1, u2} α β f)) β (Quotient.lift.{succ u1, succ u2} α β (Setoid.ker.{u1, u2} α β f) f (fun (_x : α) (_x_1 : α) (h : HasEquivₓ.Equiv.{succ u1} α (setoidHasEquiv.{succ u1} α (Setoid.ker.{u1, u2} α β f)) _x _x_1) => h))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (f : α -> β), Function.Injective.{succ u2, succ u1} (Quotient.{succ u2} α (Setoid.ker.{u2, u1} α β f)) β (Quotient.lift.{succ u2, succ u1} α β (Setoid.ker.{u2, u1} α β f) f (fun (_x : α) (_x_1 : α) (h : HasEquiv.Equiv.{succ u2, 0} α (instHasEquiv.{succ u2} α (Setoid.ker.{u2, u1} α β f)) _x _x_1) => h))
Case conversion may be inaccurate. Consider using '#align setoid.ker_lift_injective Setoid.ker_lift_injectiveₓ'. -/
/-- Given a map f from α to β, the natural map from the quotient of α by the kernel of f is
    injective. -/
theorem ker_lift_injective (f : α → β) : Injective (@Quotient.lift _ _ (ker f) f fun _ _ h => h) :=
  fun x y => Quotient.inductionOn₂' x y fun a b h => Quotient.sound' h
#align setoid.ker_lift_injective Setoid.ker_lift_injective

/- warning: setoid.ker_eq_lift_of_injective -> Setoid.ker_eq_lift_of_injective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {r : Setoid.{succ u1} α} (f : α -> β) (H : forall (x : α) (y : α), (Setoid.Rel.{u1} α r x y) -> (Eq.{succ u2} β (f x) (f y))), (Function.Injective.{succ u1, succ u2} (Quotient.{succ u1} α r) β (Quotient.lift.{succ u1, succ u2} α β r f H)) -> (Eq.{succ u1} (Setoid.{succ u1} α) (Setoid.ker.{u1, u2} α β f) r)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {r : Setoid.{succ u2} α} (f : α -> β) (H : forall (x : α) (y : α), (Setoid.Rel.{u2} α r x y) -> (Eq.{succ u1} β (f x) (f y))), (Function.Injective.{succ u2, succ u1} (Quotient.{succ u2} α r) β (Quotient.lift.{succ u2, succ u1} α β r f H)) -> (Eq.{succ u2} (Setoid.{succ u2} α) (Setoid.ker.{u2, u1} α β f) r)
Case conversion may be inaccurate. Consider using '#align setoid.ker_eq_lift_of_injective Setoid.ker_eq_lift_of_injectiveₓ'. -/
/-- Given a map f from α to β, the kernel of f is the unique equivalence relation on α whose
    induced map from the quotient of α to β is injective. -/
theorem ker_eq_lift_of_injective {r : Setoid α} (f : α → β) (H : ∀ x y, r.Rel x y → f x = f y)
    (h : Injective (Quotient.lift f H)) : ker f = r :=
  le_antisymm
    (fun x y hk =>
      Quotient.exact <| h <| show Quotient.lift f H ⟦x⟧ = Quotient.lift f H ⟦y⟧ from hk)
    H
#align setoid.ker_eq_lift_of_injective Setoid.ker_eq_lift_of_injective

variable (r : Setoid α) (f : α → β)

#print Setoid.quotientKerEquivRange /-
/-- The first isomorphism theorem for sets: the quotient of α by the kernel of a function f
    bijects with f's image. -/
noncomputable def quotientKerEquivRange : Quotient (ker f) ≃ Set.range f :=
  Equiv.ofBijective
    (@Quotient.lift _ (Set.range f) (ker f) (fun x => ⟨f x, Set.mem_range_self x⟩) fun _ _ h =>
      Subtype.ext_val h)
    ⟨fun x y h => ker_lift_injective f <| by rcases x with ⟨⟩ <;> rcases y with ⟨⟩ <;> injections,
      fun ⟨w, z, hz⟩ =>
      ⟨@Quotient.mk' _ (ker f) z, by rw [Quotient.lift_mk] <;> exact Subtype.ext_iff_val.2 hz⟩⟩
#align setoid.quotient_ker_equiv_range Setoid.quotientKerEquivRange
-/

#print Setoid.quotientKerEquivOfRightInverse /-
/-- If `f` has a computable right-inverse, then the quotient by its kernel is equivalent to its
domain. -/
@[simps]
def quotientKerEquivOfRightInverse (g : β → α) (hf : Function.RightInverse g f) :
    Quotient (ker f) ≃ β
    where
  toFun a := Quotient.liftOn' a f fun _ _ => id
  invFun b := Quotient.mk'' (g b)
  left_inv a := Quotient.inductionOn' a fun a => Quotient.sound' <| hf (f a)
  right_inv := hf
#align setoid.quotient_ker_equiv_of_right_inverse Setoid.quotientKerEquivOfRightInverse
-/

#print Setoid.quotientKerEquivOfSurjective /-
/-- The quotient of α by the kernel of a surjective function f bijects with f's codomain.

If a specific right-inverse of `f` is known, `setoid.quotient_ker_equiv_of_right_inverse` can be
definitionally more useful. -/
noncomputable def quotientKerEquivOfSurjective (hf : Surjective f) : Quotient (ker f) ≃ β :=
  quotientKerEquivOfRightInverse _ (Function.surjInv hf) (rightInverse_surjInv hf)
#align setoid.quotient_ker_equiv_of_surjective Setoid.quotientKerEquivOfSurjective
-/

variable {r f}

#print Setoid.map /-
/-- Given a function `f : α → β` and equivalence relation `r` on `α`, the equivalence
    closure of the relation on `f`'s image defined by '`x ≈ y` iff the elements of `f⁻¹(x)` are
    related to the elements of `f⁻¹(y)` by `r`.' -/
def map (r : Setoid α) (f : α → β) : Setoid β :=
  EqvGen.Setoid fun x y => ∃ a b, f a = x ∧ f b = y ∧ r.Rel a b
#align setoid.map Setoid.map
-/

#print Setoid.mapOfSurjective /-
/-- Given a surjective function f whose kernel is contained in an equivalence relation r, the
    equivalence relation on f's codomain defined by x ≈ y ↔ the elements of f⁻¹(x) are related to
    the elements of f⁻¹(y) by r. -/
def mapOfSurjective (r) (f : α → β) (h : ker f ≤ r) (hf : Surjective f) : Setoid β :=
  ⟨fun x y => ∃ a b, f a = x ∧ f b = y ∧ r.Rel a b,
    ⟨fun x =>
      let ⟨y, hy⟩ := hf x
      ⟨y, y, hy, hy, r.refl' y⟩,
      fun _ _ ⟨x, y, hx, hy, h⟩ => ⟨y, x, hy, hx, r.symm' h⟩,
      fun _ _ _ ⟨x, y, hx, hy, h₁⟩ ⟨y', z, hy', hz, h₂⟩ =>
      ⟨x, z, hx, hz, r.trans' h₁ <| r.trans' (h <| by rwa [← hy'] at hy) h₂⟩⟩⟩
#align setoid.map_of_surjective Setoid.mapOfSurjective
-/

/- warning: setoid.map_of_surjective_eq_map -> Setoid.mapOfSurjective_eq_map is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} {r : Setoid.{succ u1} α} {f : α -> β} (h : LE.le.{u1} (Setoid.{succ u1} α) (Setoid.hasLe.{u1} α) (Setoid.ker.{u1, u2} α β f) r) (hf : Function.Surjective.{succ u1, succ u2} α β f), Eq.{succ u2} (Setoid.{succ u2} β) (Setoid.map.{u1, u2} α β r f) (Setoid.mapOfSurjective.{u1, u2} α β r f h hf)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} {r : Setoid.{succ u2} α} {f : α -> β} (h : LE.le.{u2} (Setoid.{succ u2} α) (Setoid.instLESetoid.{u2} α) (Setoid.ker.{u2, u1} α β f) r) (hf : Function.Surjective.{succ u2, succ u1} α β f), Eq.{succ u1} (Setoid.{succ u1} β) (Setoid.map.{u2, u1} α β r f) (Setoid.mapOfSurjective.{u2, u1} α β r f h hf)
Case conversion may be inaccurate. Consider using '#align setoid.map_of_surjective_eq_map Setoid.mapOfSurjective_eq_mapₓ'. -/
/-- A special case of the equivalence closure of an equivalence relation r equalling r. -/
theorem mapOfSurjective_eq_map (h : ker f ≤ r) (hf : Surjective f) :
    map r f = mapOfSurjective r f h hf := by
  rw [← eqv_gen_of_setoid (map_of_surjective r f h hf)] <;> rfl
#align setoid.map_of_surjective_eq_map Setoid.mapOfSurjective_eq_map

#print Setoid.comap /-
/-- Given a function `f : α → β`, an equivalence relation `r` on `β` induces an equivalence
relation on `α` defined by '`x ≈ y` iff `f(x)` is related to `f(y)` by `r`'.

See note [reducible non-instances]. -/
@[reducible]
def comap (f : α → β) (r : Setoid β) : Setoid α :=
  ⟨r.Rel on f, r.iseqv.comap _⟩
#align setoid.comap Setoid.comap
-/

#print Setoid.comap_rel /-
theorem comap_rel (f : α → β) (r : Setoid β) (x y : α) : (comap f r).Rel x y ↔ r.Rel (f x) (f y) :=
  Iff.rfl
#align setoid.comap_rel Setoid.comap_rel
-/

#print Setoid.comap_eq /-
/-- Given a map `f : N → M` and an equivalence relation `r` on `β`, the equivalence relation
    induced on `α` by `f` equals the kernel of `r`'s quotient map composed with `f`. -/
theorem comap_eq {f : α → β} {r : Setoid β} : comap f r = ker (@Quotient.mk' _ r ∘ f) :=
  ext fun x y => show _ ↔ ⟦_⟧ = ⟦_⟧ by rw [Quotient.eq'] <;> rfl
#align setoid.comap_eq Setoid.comap_eq
-/

#print Setoid.comapQuotientEquiv /-
/-- The second isomorphism theorem for sets. -/
noncomputable def comapQuotientEquiv (f : α → β) (r : Setoid β) :
    Quotient (comap f r) ≃ Set.range (@Quotient.mk' _ r ∘ f) :=
  (Quotient.congrRight <| ext_iff.1 comap_eq).trans <| quotientKerEquivRange <| Quotient.mk' ∘ f
#align setoid.comap_quotient_equiv Setoid.comapQuotientEquiv
-/

variable (r f)

#print Setoid.quotientQuotientEquivQuotient /-
/-- The third isomorphism theorem for sets. -/
def quotientQuotientEquivQuotient (s : Setoid α) (h : r ≤ s) :
    Quotient (ker (Quot.mapRight h)) ≃ Quotient s
    where
  toFun x :=
    Quotient.liftOn' x
      (fun w => Quotient.liftOn' w (@Quotient.mk' _ s) fun x y H => Quotient.sound <| h H)
      fun x y => Quotient.inductionOn₂' x y fun w z H => show @Quot.mk _ _ _ = @Quot.mk _ _ _ from H
  invFun x :=
    Quotient.liftOn' x (fun w => @Quotient.mk' _ (ker <| Quot.mapRight h) <| @Quotient.mk' _ r w)
      fun x y H => Quotient.sound' <| show @Quot.mk _ _ _ = @Quot.mk _ _ _ from Quotient.sound H
  left_inv x :=
    Quotient.inductionOn' x fun y => Quotient.inductionOn' y fun w => by show ⟦_⟧ = _ <;> rfl
  right_inv x := Quotient.inductionOn' x fun y => by show ⟦_⟧ = _ <;> rfl
#align setoid.quotient_quotient_equiv_quotient Setoid.quotientQuotientEquivQuotient
-/

variable {r f}

open Quotient

#print Setoid.correspondence /-
/-- Given an equivalence relation `r` on `α`, the order-preserving bijection between the set of
equivalence relations containing `r` and the equivalence relations on the quotient of `α` by `r`. -/
def correspondence (r : Setoid α) : { s // r ≤ s } ≃o Setoid (Quotient r)
    where
  toFun s := mapOfSurjective s.1 Quotient.mk' ((ker_mk_eq r).symm ▸ s.2) exists_rep
  invFun s := ⟨comap Quotient.mk'' s, fun x y h => by rw [comap_rel, eq_rel.2 h]⟩
  left_inv s :=
    Subtype.ext_iff_val.2 <|
      ext' fun _ _ =>
        ⟨fun h =>
          let ⟨a, b, hx, hy, H⟩ := h
          s.1.trans' (s.1.symm' <| s.2 <| eq_rel.1 hx) <| s.1.trans' H <| s.2 <| eq_rel.1 hy,
          fun h => ⟨_, _, rfl, rfl, h⟩⟩
  right_inv s :=
    let Hm : ker Quotient.mk'' ≤ comap Quotient.mk'' s := fun x y h => by
      rw [comap_rel, (@eq_rel _ r x y).2 (ker_mk_eq r ▸ h)]
    ext' fun x y =>
      ⟨fun h =>
        let ⟨a, b, hx, hy, H⟩ := h
        hx ▸ hy ▸ H,
        Quotient.induction_on₂ x y fun w z h => ⟨w, z, rfl, rfl, h⟩⟩
  map_rel_iff' s t :=
    ⟨fun h x y hs =>
      let ⟨a, b, hx, hy, ht⟩ := h ⟨x, y, rfl, rfl, hs⟩
      t.1.trans' (t.1.symm' <| t.2 <| eq_rel.1 hx) <| t.1.trans' ht <| t.2 <| eq_rel.1 hy,
      fun h x y hs =>
      let ⟨a, b, hx, hy, Hs⟩ := hs
      ⟨a, b, hx, hy, h Hs⟩⟩
#align setoid.correspondence Setoid.correspondence
-/

end Setoid

/- warning: quotient.subsingleton_iff -> Quotient.subsingleton_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {s : Setoid.{succ u1} α}, Iff (Subsingleton.{succ u1} (Quotient.{succ u1} α s)) (Eq.{succ u1} (Setoid.{succ u1} α) s (Top.top.{u1} (Setoid.{succ u1} α) (CompleteLattice.toHasTop.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α))))
but is expected to have type
  forall {α : Type.{u1}} {s : Setoid.{succ u1} α}, Iff (Subsingleton.{succ u1} (Quotient.{succ u1} α s)) (Eq.{succ u1} (Setoid.{succ u1} α) s (Top.top.{u1} (Setoid.{succ u1} α) (CompleteLattice.toTop.{u1} (Setoid.{succ u1} α) (Setoid.completeLattice.{u1} α))))
Case conversion may be inaccurate. Consider using '#align quotient.subsingleton_iff Quotient.subsingleton_iffₓ'. -/
@[simp]
theorem Quotient.subsingleton_iff {s : Setoid α} : Subsingleton (Quotient s) ↔ s = ⊤ :=
  by
  simp only [subsingleton_iff, eq_top_iff, Setoid.le_def, Setoid.top_def, Pi.top_apply,
    forall_const]
  refine' (surjective_quotient_mk _).forall.trans (forall_congr' fun a => _)
  refine' (surjective_quotient_mk _).forall.trans (forall_congr' fun b => _)
  exact Quotient.eq''
#align quotient.subsingleton_iff Quotient.subsingleton_iff

/- warning: quot.subsingleton_iff -> Quot.subsingleton_iff is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (r : α -> α -> Prop), Iff (Subsingleton.{succ u1} (Quot.{succ u1} α r)) (Eq.{succ u1} (α -> α -> Prop) (EqvGen.{u1} α r) (Top.top.{u1} (α -> α -> Prop) (Pi.hasTop.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.hasTop.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => CompleteLattice.toHasTop.{0} Prop Prop.completeLattice)))))
but is expected to have type
  forall {α : Type.{u1}} (r : α -> α -> Prop), Iff (Subsingleton.{succ u1} (Quot.{succ u1} α r)) (Eq.{succ u1} (α -> α -> Prop) (EqvGen.{u1} α r) (Top.top.{u1} (α -> α -> Prop) (Pi.instTopForAll.{u1, u1} α (fun (ᾰ : α) => α -> Prop) (fun (i : α) => Pi.instTopForAll.{u1, 0} α (fun (ᾰ : α) => Prop) (fun (i : α) => CompleteLattice.toTop.{0} Prop Prop.completeLattice)))))
Case conversion may be inaccurate. Consider using '#align quot.subsingleton_iff Quot.subsingleton_iffₓ'. -/
theorem Quot.subsingleton_iff (r : α → α → Prop) : Subsingleton (Quot r) ↔ EqvGen r = ⊤ :=
  by
  simp only [subsingleton_iff, _root_.eq_top_iff, Pi.le_def, Pi.top_apply, forall_const]
  refine' (surjective_quot_mk _).forall.trans (forall_congr' fun a => _)
  refine' (surjective_quot_mk _).forall.trans (forall_congr' fun b => _)
  rw [Quot.eq]
  simp only [forall_const, le_Prop_eq]
#align quot.subsingleton_iff Quot.subsingleton_iff


/-
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 analysis.convex.exposed
import analysis.normed_space.hahn_banach.separation

/-!
# The Krein-Milman theorem

This file proves the Krein-Milman lemma and the Krein-Milman theorem.

## The lemma

The lemma states that a nonempty compact set `s` has an extreme point. The proof goes:
1. Using Zorn's lemma, find a minimal nonempty closed `t` that is an extreme subset of `s`. We will
  show that `t` is a singleton, thus corresponding to an extreme point.
2. By contradiction, `t` contains two distinct points `x` and `y`.
3. With the (geometric) Hahn-Banach theorem, find an hyperplane that separates `x` and `y`.
4. Look at the extreme (actually exposed) subset of `t` obtained by going the furthest away from
  the separating hyperplane in the direction of `x`. It is nonempty, closed and an extreme subset
  of `s`.
5. It is a strict subset of `t` (`y` isn't in it), so `t` isn't minimal. Absurd.

## The theorem

The theorem states that a compact convex set `s` is the closure of the convex hull of its extreme
points. It is an almost immediate strengthening of the lemma. The proof goes:
1. By contradiction, `s \ closure (convex_hull ℝ (extreme_points ℝ s))` is nonempty, say with `x`.
2. With the (geometric) Hahn-Banach theorem, find an hyperplane that separates `x` from
  `closure (convex_hull ℝ (extreme_points ℝ s))`.
3. Look at the extreme (actually exposed) subset of
  `s \ closure (convex_hull ℝ (extreme_points ℝ s))` obtained by going the furthest away from the
  separating hyperplane. It is nonempty by assumption of nonemptiness and compactness, so by the
  lemma it has an extreme point.
4. This point is also an extreme point of `s`. Absurd.

## Related theorems

When the space is finite dimensional, the `closure` can be dropped to strengthen the result of the
Krein-Milman theorem. This leads to the Minkowski-Carathéodory theorem (currently not in mathlib).
Birkhoff's theorem is the Minkowski-Carathéodory theorem applied to the set of bistochastic
matrices, permutation matrices being the extreme points.

## References

See chapter 8 of [Barry Simon, *Convexity*][simon2011]

-/

open set
open_locale classical

variables {E : Type*} [add_comm_group E] [module ℝ E] [topological_space E] [t2_space E]
  [topological_add_group E] [has_continuous_smul ℝ E] [locally_convex_space ℝ E] {s : set E}

/-- **Krein-Milman lemma**: In a LCTVS, any nonempty compact set has an extreme point. -/
lemma is_compact.has_extreme_point (hscomp : is_compact s) (hsnemp : s.nonempty) :
  (s.extreme_points ℝ).nonempty :=
begin
  let S : set (set E) := {t | t.nonempty ∧ is_closed t ∧ is_extreme ℝ s t},
  rsuffices ⟨t, ⟨⟨x, hxt⟩, htclos, hst⟩, hBmin⟩ : ∃ t ∈ S, ∀ u ∈ S, u ⊆ t → u = t,
  { refine ⟨x, mem_extreme_points_iff_extreme_singleton.2 _⟩,
    rwa ←eq_singleton_iff_unique_mem.2 ⟨hxt, λ y hyB, _⟩,
    by_contra hyx,
    obtain ⟨l, hl⟩ := geometric_hahn_banach_point_point hyx,
    obtain ⟨z, hzt, hz⟩ := (is_compact_of_is_closed_subset hscomp htclos hst.1).exists_forall_ge
      ⟨x, hxt⟩ l.continuous.continuous_on,
    have h : is_exposed ℝ t {z ∈ t | ∀ w ∈ t, l w ≤ l z} := λ h, ⟨l, rfl⟩,
    rw ←hBmin {z ∈ t | ∀ w ∈ t, l w ≤ l z} ⟨⟨z, hzt, hz⟩, h.is_closed htclos, hst.trans
      h.is_extreme⟩ (t.sep_subset _) at hyB,
    exact hl.not_le (hyB.2 x hxt) },
  refine zorn_superset _ (λ F hFS hF, _),
  obtain rfl | hFnemp := F.eq_empty_or_nonempty,
  { exact ⟨s, ⟨hsnemp, hscomp.is_closed, is_extreme.rfl⟩, λ _, false.elim⟩ },
  refine ⟨⋂₀ F, ⟨_, is_closed_sInter $ λ t ht, (hFS ht).2.1, is_extreme_sInter hFnemp $
    λ t ht, (hFS ht).2.2⟩, λ t ht, sInter_subset_of_mem ht⟩,
  haveI : nonempty ↥F := hFnemp.to_subtype,
  rw sInter_eq_Inter,
  refine is_compact.nonempty_Inter_of_directed_nonempty_compact_closed _ (λ t u, _)
    (λ t, (hFS t.mem).1)
    (λ t, is_compact_of_is_closed_subset hscomp (hFS t.mem).2.1 (hFS t.mem).2.2.1)
    (λ t, (hFS t.mem).2.1),
  obtain htu | hut := hF.total t.mem u.mem,
  exacts [⟨t, subset.rfl, htu⟩, ⟨u, hut, subset.rfl⟩],
end

/-- **Krein-Milman theorem**: In a LCTVS, any compact convex set is the closure of the convex hull
    of its extreme points. -/
lemma closure_convex_hull_extreme_points (hscomp : is_compact s) (hAconv : convex ℝ s) :
  closure (convex_hull ℝ $ s.extreme_points ℝ) = s :=
begin
  apply (closure_minimal (convex_hull_min extreme_points_subset hAconv) hscomp.is_closed).antisymm,
  by_contra hs,
  obtain ⟨x, hxA, hxt⟩ := not_subset.1 hs,
  obtain ⟨l, r, hlr, hrx⟩ := geometric_hahn_banach_closed_point (convex_convex_hull _ _).closure
    is_closed_closure hxt,
  have h : is_exposed ℝ s {y ∈ s | ∀ z ∈ s, l z ≤ l y} := λ _, ⟨l, rfl⟩,
  obtain ⟨z, hzA, hz⟩ := hscomp.exists_forall_ge ⟨x, hxA⟩ l.continuous.continuous_on,
  obtain ⟨y, hy⟩ := (h.is_compact hscomp).has_extreme_point ⟨z, hzA, hz⟩,
  linarith [hlr _ (subset_closure $ subset_convex_hull _ _ $
    h.is_extreme.extreme_points_subset_extreme_points hy), hy.1.2 x hxA],
end


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Michael Stoll

! This file was ported from Lean 3 source module number_theory.legendre_symbol.quadratic_reciprocity
! leanprover-community/mathlib commit 2196ab363eb097c008d4497125e0dde23fb36db2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.NumberTheory.LegendreSymbol.QuadraticChar

/-!
# Legendre symbol and quadratic reciprocity.

This file contains results about quadratic residues modulo a prime number.

We define the Legendre symbol $\Bigl(\frac{a}{p}\Bigr)$ as `legendre_sym p a`.
Note the order of arguments! The advantage of this form is that then `legendre_sym p`
is a multiplicative map.

The Legendre symbol is used to define the Jacobi symbol, `jacobi_sym a b`, for integers `a`
and (odd) natural numbers `b`, which extends the Legendre symbol.

## Main results

We prove the law of quadratic reciprocity, see `legendre_sym.quadratic_reciprocity` and
`legendre_sym.quadratic_reciprocity'`, as well as the
interpretations in terms of existence of square roots depending on the congruence mod 4,
`zmod.exists_sq_eq_prime_iff_of_mod_four_eq_one`, and
`zmod.exists_sq_eq_prime_iff_of_mod_four_eq_three`.

We also prove the supplementary laws that give conditions for when `-1` or `2`
(or `-2`) is a square modulo a prime `p`:
`legendre_sym.at_neg_one` and `zmod.exists_sq_eq_neg_one_iff` for `-1`,
`legendre_sym.at_two` and `zmod.exists_sq_eq_two_iff` for `2`,
`legendre_sym.at_neg_two` and `zmod.exists_sq_eq_neg_two_iff` for `-2`.

## Implementation notes

The proofs use results for quadratic characters on arbitrary finite fields
from `number_theory.legendre_symbol.quadratic_char`, which in turn are based on
properties of quadratic Gauss sums as provided by `number_theory.legendre_symbol.gauss_sum`.

## Tags

quadratic residue, quadratic nonresidue, Legendre symbol, quadratic reciprocity
-/

open Nat

section Euler

namespace ZMod

variable (p : ℕ) [Fact p.Prime]

/-- Euler's Criterion: A unit `x` of `zmod p` is a square if and only if `x ^ (p / 2) = 1`. -/
theorem euler_criterion_units (x : (ZMod p)ˣ) : (∃ y : (ZMod p)ˣ, y ^ 2 = x) ↔ x ^ (p / 2) = 1 :=
  by
  by_cases hc : p = 2
  · subst hc
    simp only [eq_iff_true_of_subsingleton, exists_const]
  · have h₀ := FiniteField.unit_isSquare_iff (by rwa [ring_char_zmod_n]) x
    have hs : (∃ y : (ZMod p)ˣ, y ^ 2 = x) ↔ IsSquare x :=
      by
      rw [isSquare_iff_exists_sq x]
      simp_rw [eq_comm]
    rw [hs]
    rwa [card p] at h₀
#align zmod.euler_criterion_units ZMod.euler_criterion_units

/-- Euler's Criterion: a nonzero `a : zmod p` is a square if and only if `x ^ (p / 2) = 1`. -/
theorem euler_criterion {a : ZMod p} (ha : a ≠ 0) : IsSquare (a : ZMod p) ↔ a ^ (p / 2) = 1 :=
  by
  apply (iff_congr _ (by simp [Units.ext_iff])).mp (euler_criterion_units p (Units.mk0 a ha))
  simp only [Units.ext_iff, sq, Units.val_mk0, Units.val_mul]
  constructor;
  · rintro ⟨y, hy⟩
    exact ⟨y, hy.symm⟩
  · rintro ⟨y, rfl⟩
    have hy : y ≠ 0 := by
      rintro rfl
      simpa [zero_pow] using ha
    refine' ⟨Units.mk0 y hy, _⟩
    simp
#align zmod.euler_criterion ZMod.euler_criterion

/-- If `a : zmod p` is nonzero, then `a^(p/2)` is either `1` or `-1`. -/
theorem pow_div_two_eq_neg_one_or_one {a : ZMod p} (ha : a ≠ 0) :
    a ^ (p / 2) = 1 ∨ a ^ (p / 2) = -1 :=
  by
  cases' prime.eq_two_or_odd (Fact.out p.prime) with hp2 hp_odd
  · subst p
    revert a ha
    decide
  rw [← mul_self_eq_one_iff, ← pow_add, ← two_mul, two_mul_odd_div_two hp_odd]
  exact pow_card_sub_one_eq_one ha
#align zmod.pow_div_two_eq_neg_one_or_one ZMod.pow_div_two_eq_neg_one_or_one

end ZMod

end Euler

section Legendre

/-!
### Definition of the Legendre symbol and basic properties
-/

open ZMod

variable (p : ℕ) [Fact p.Prime]

/-- The Legendre symbol of `a : ℤ` and a prime `p`, `legendre_sym p a`,
is an integer defined as

* `0` if `a` is `0` modulo `p`;
* `1` if `a` is a nonzero square modulo `p`
* `-1` otherwise.

Note the order of the arguments! The advantage of the order chosen here is
that `legendre_sym p` is a multiplicative function `ℤ → ℤ`.
-/
def legendreSym (a : ℤ) : ℤ :=
  quadraticChar (ZMod p) a
#align legendre_sym legendreSym

namespace legendreSym

/-- We have the congruence `legendre_sym p a ≡ a ^ (p / 2) mod p`. -/
theorem eq_pow (a : ℤ) : (legendreSym p a : ZMod p) = a ^ (p / 2) :=
  by
  cases' eq_or_ne (ringChar (ZMod p)) 2 with hc hc
  · by_cases ha : (a : ZMod p) = 0
    · rw [legendreSym, ha, quadraticChar_zero,
        zero_pow (Nat.div_pos (Fact.out p.prime).two_le (succ_pos 1))]
      norm_cast
    · have := (ring_char_zmod_n p).symm.trans hc
      -- p = 2
      subst p
      rw [legendreSym, quadraticChar_eq_one_of_char_two hc ha]
      revert ha
      generalize (a : ZMod 2) = b
      revert b
      decide
  · convert quadraticChar_eq_pow_of_char_ne_two' hc (a : ZMod p)
    exact (card p).symm
#align legendre_sym.eq_pow legendreSym.eq_pow

/-- If `p ∤ a`, then `legendre_sym p a` is `1` or `-1`. -/
theorem eq_one_or_neg_one {a : ℤ} (ha : (a : ZMod p) ≠ 0) :
    legendreSym p a = 1 ∨ legendreSym p a = -1 :=
  quadraticChar_dichotomy ha
#align legendre_sym.eq_one_or_neg_one legendreSym.eq_one_or_neg_one

theorem eq_neg_one_iff_not_one {a : ℤ} (ha : (a : ZMod p) ≠ 0) :
    legendreSym p a = -1 ↔ ¬legendreSym p a = 1 :=
  quadraticChar_eq_neg_one_iff_not_one ha
#align legendre_sym.eq_neg_one_iff_not_one legendreSym.eq_neg_one_iff_not_one

/-- The Legendre symbol of `p` and `a` is zero iff `p ∣ a`. -/
theorem eq_zero_iff (a : ℤ) : legendreSym p a = 0 ↔ (a : ZMod p) = 0 :=
  quadraticChar_eq_zero_iff
#align legendre_sym.eq_zero_iff legendreSym.eq_zero_iff

@[simp]
theorem at_zero : legendreSym p 0 = 0 := by rw [legendreSym, Int.cast_zero, MulChar.map_zero]
#align legendre_sym.at_zero legendreSym.at_zero

@[simp]
theorem at_one : legendreSym p 1 = 1 := by rw [legendreSym, Int.cast_one, MulChar.map_one]
#align legendre_sym.at_one legendreSym.at_one

/-- The Legendre symbol is multiplicative in `a` for `p` fixed. -/
protected theorem mul (a b : ℤ) : legendreSym p (a * b) = legendreSym p a * legendreSym p b := by
  simp only [legendreSym, Int.cast_mul, map_mul]
#align legendre_sym.mul legendreSym.mul

/-- The Legendre symbol is a homomorphism of monoids with zero. -/
@[simps]
def hom : ℤ →*₀ ℤ where
  toFun := legendreSym p
  map_zero' := at_zero p
  map_one' := at_one p
  map_mul' := legendreSym.mul p
#align legendre_sym.hom legendreSym.hom

/-- The square of the symbol is 1 if `p ∤ a`. -/
theorem sq_one {a : ℤ} (ha : (a : ZMod p) ≠ 0) : legendreSym p a ^ 2 = 1 :=
  quadraticChar_sq_one ha
#align legendre_sym.sq_one legendreSym.sq_one

/-- The Legendre symbol of `a^2` at `p` is 1 if `p ∤ a`. -/
theorem sq_one' {a : ℤ} (ha : (a : ZMod p) ≠ 0) : legendreSym p (a ^ 2) = 1 := by
  exact_mod_cast quadraticChar_sq_one' ha
#align legendre_sym.sq_one' legendreSym.sq_one'

/-- The Legendre symbol depends only on `a` mod `p`. -/
protected theorem mod (a : ℤ) : legendreSym p a = legendreSym p (a % p) := by
  simp only [legendreSym, int_cast_mod]
#align legendre_sym.mod legendreSym.mod

/-- When `p ∤ a`, then `legendre_sym p a = 1` iff `a` is a square mod `p`. -/
theorem eq_one_iff {a : ℤ} (ha0 : (a : ZMod p) ≠ 0) : legendreSym p a = 1 ↔ IsSquare (a : ZMod p) :=
  quadraticChar_one_iff_isSquare ha0
#align legendre_sym.eq_one_iff legendreSym.eq_one_iff

theorem eq_one_iff' {a : ℕ} (ha0 : (a : ZMod p) ≠ 0) :
    legendreSym p a = 1 ↔ IsSquare (a : ZMod p) :=
  by
  rw [eq_one_iff]
  norm_cast
  exact_mod_cast ha0
#align legendre_sym.eq_one_iff' legendreSym.eq_one_iff'

/-- `legendre_sym p a = -1` iff `a` is a nonsquare mod `p`. -/
theorem eq_neg_one_iff {a : ℤ} : legendreSym p a = -1 ↔ ¬IsSquare (a : ZMod p) :=
  quadraticChar_neg_one_iff_not_isSquare
#align legendre_sym.eq_neg_one_iff legendreSym.eq_neg_one_iff

theorem eq_neg_one_iff' {a : ℕ} : legendreSym p a = -1 ↔ ¬IsSquare (a : ZMod p) :=
  by
  rw [eq_neg_one_iff]
  norm_cast
#align legendre_sym.eq_neg_one_iff' legendreSym.eq_neg_one_iff'

/-- The number of square roots of `a` modulo `p` is determined by the Legendre symbol. -/
theorem card_sqrts (hp : p ≠ 2) (a : ℤ) :
    ↑{ x : ZMod p | x ^ 2 = a }.toFinset.card = legendreSym p a + 1 :=
  quadraticChar_card_sqrts ((ringChar_zmod_n p).substr hp) a
#align legendre_sym.card_sqrts legendreSym.card_sqrts

end legendreSym

end Legendre

section Values

/-!
### The value of the Legendre symbol at `-1`

See `jacobi_sym.at_neg_one` for the corresponding statement for the Jacobi symbol.
-/

variable {p : ℕ} [Fact p.Prime]

open ZMod

/-- `legendre_sym p (-1)` is given by `χ₄ p`. -/
theorem legendreSym.at_neg_one (hp : p ≠ 2) : legendreSym p (-1) = χ₄ p := by
  simp only [legendreSym, card p, quadraticChar_neg_one ((ring_char_zmod_n p).substr hp),
    Int.cast_neg, Int.cast_one]
#align legendre_sym.at_neg_one legendreSym.at_neg_one

namespace ZMod

/-- `-1` is a square in `zmod p` iff `p` is not congruent to `3` mod `4`. -/
theorem exists_sq_eq_neg_one_iff : IsSquare (-1 : ZMod p) ↔ p % 4 ≠ 3 := by
  rw [FiniteField.isSquare_neg_one_iff, card p]
#align zmod.exists_sq_eq_neg_one_iff ZMod.exists_sq_eq_neg_one_iff

theorem mod_four_ne_three_of_sq_eq_neg_one {y : ZMod p} (hy : y ^ 2 = -1) : p % 4 ≠ 3 :=
  exists_sq_eq_neg_one_iff.1 ⟨y, hy ▸ pow_two y⟩
#align zmod.mod_four_ne_three_of_sq_eq_neg_one ZMod.mod_four_ne_three_of_sq_eq_neg_one

/-- If two nonzero squares are negatives of each other in `zmod p`, then `p % 4 ≠ 3`. -/
theorem mod_four_ne_three_of_sq_eq_neg_sq' {x y : ZMod p} (hy : y ≠ 0) (hxy : x ^ 2 = -y ^ 2) :
    p % 4 ≠ 3 :=
  @mod_four_ne_three_of_sq_eq_neg_one p _ (x / y)
    (by
      apply_fun fun z => z / y ^ 2  at hxy
      rwa [neg_div, ← div_pow, ← div_pow, div_self hy, one_pow] at hxy)
#align zmod.mod_four_ne_three_of_sq_eq_neg_sq' ZMod.mod_four_ne_three_of_sq_eq_neg_sq'

theorem mod_four_ne_three_of_sq_eq_neg_sq {x y : ZMod p} (hx : x ≠ 0) (hxy : x ^ 2 = -y ^ 2) :
    p % 4 ≠ 3 :=
  mod_four_ne_three_of_sq_eq_neg_sq' hx (neg_eq_iff_eq_neg.mpr hxy).symm
#align zmod.mod_four_ne_three_of_sq_eq_neg_sq ZMod.mod_four_ne_three_of_sq_eq_neg_sq

end ZMod

/-!
### The value of the Legendre symbol at `2` and `-2`

See `jacobi_sym.at_two` and `jacobi_sym.at_neg_two` for the corresponding statements
for the Jacobi symbol.
-/

namespace legendreSym

variable (hp : p ≠ 2)

include hp

/-- `legendre_sym p 2` is given by `χ₈ p`. -/
theorem at_two : legendreSym p 2 = χ₈ p := by
  simp only [legendreSym, card p, quadraticChar_two ((ring_char_zmod_n p).substr hp), Int.cast_bit0,
    Int.cast_one]
#align legendre_sym.at_two legendreSym.at_two

/-- `legendre_sym p (-2)` is given by `χ₈' p`. -/
theorem at_neg_two : legendreSym p (-2) = χ₈' p := by
  simp only [legendreSym, card p, quadraticChar_neg_two ((ring_char_zmod_n p).substr hp),
    Int.cast_bit0, Int.cast_one, Int.cast_neg]
#align legendre_sym.at_neg_two legendreSym.at_neg_two

end legendreSym

namespace ZMod

variable (hp : p ≠ 2)

include hp

/-- `2` is a square modulo an odd prime `p` iff `p` is congruent to `1` or `7` mod `8`. -/
theorem exists_sq_eq_two_iff : IsSquare (2 : ZMod p) ↔ p % 8 = 1 ∨ p % 8 = 7 :=
  by
  rw [FiniteField.isSquare_two_iff, card p]
  have h₁ := prime.mod_two_eq_one_iff_ne_two.mpr hp
  rw [← mod_mod_of_dvd p (by norm_num : 2 ∣ 8)] at h₁
  have h₂ := mod_lt p (by norm_num : 0 < 8)
  revert h₂ h₁
  generalize hm : p % 8 = m; clear! p
  decide!
#align zmod.exists_sq_eq_two_iff ZMod.exists_sq_eq_two_iff

/-- `-2` is a square modulo an odd prime `p` iff `p` is congruent to `1` or `3` mod `8`. -/
theorem exists_sq_eq_neg_two_iff : IsSquare (-2 : ZMod p) ↔ p % 8 = 1 ∨ p % 8 = 3 :=
  by
  rw [FiniteField.isSquare_neg_two_iff, card p]
  have h₁ := prime.mod_two_eq_one_iff_ne_two.mpr hp
  rw [← mod_mod_of_dvd p (by norm_num : 2 ∣ 8)] at h₁
  have h₂ := mod_lt p (by norm_num : 0 < 8)
  revert h₂ h₁
  generalize hm : p % 8 = m; clear! p
  decide!
#align zmod.exists_sq_eq_neg_two_iff ZMod.exists_sq_eq_neg_two_iff

end ZMod

end Values

section Reciprocity

/-!
### The Law of Quadratic Reciprocity

See `jacobi_sym.quadratic_reciprocity` and variants for a version of Quadratic Reciprocity
for the Jacobi symbol.
-/

variable {p q : ℕ} [Fact p.Prime] [Fact q.Prime]

namespace legendreSym

open ZMod

/-- The Law of Quadratic Reciprocity: if `p` and `q` are distinct odd primes, then
`(q / p) * (p / q) = (-1)^((p-1)(q-1)/4)`. -/
theorem quadratic_reciprocity (hp : p ≠ 2) (hq : q ≠ 2) (hpq : p ≠ q) :
    legendreSym q p * legendreSym p q = (-1) ^ (p / 2 * (q / 2)) :=
  by
  have hp₁ := (prime.eq_two_or_odd <| Fact.out p.prime).resolve_left hp
  have hq₁ := (prime.eq_two_or_odd <| Fact.out q.prime).resolve_left hq
  have hq₂ := (ring_char_zmod_n q).substr hq
  have h :=
    quadraticChar_odd_prime ((ring_char_zmod_n p).substr hp) hq ((ring_char_zmod_n p).substr hpq)
  rw [card p] at h
  have nc : ∀ n r : ℕ, ((n : ℤ) : ZMod r) = n := fun n r => by norm_cast
  have nc' : (((-1) ^ (p / 2) : ℤ) : ZMod q) = (-1) ^ (p / 2) := by norm_cast
  rw [legendreSym, legendreSym, nc, nc, h, map_mul, mul_rotate', mul_comm (p / 2), ← pow_two,
    quadraticChar_sq_one (prime_ne_zero q p hpq.symm), mul_one, pow_mul, χ₄_eq_neg_one_pow hp₁, nc',
    map_pow, quadraticChar_neg_one hq₂, card q, χ₄_eq_neg_one_pow hq₁]
#align legendre_sym.quadratic_reciprocity legendreSym.quadratic_reciprocity

/-- The Law of Quadratic Reciprocity: if `p` and `q` are odd primes, then
`(q / p) = (-1)^((p-1)(q-1)/4) * (p / q)`. -/
theorem quadratic_reciprocity' (hp : p ≠ 2) (hq : q ≠ 2) :
    legendreSym q p = (-1) ^ (p / 2 * (q / 2)) * legendreSym p q :=
  by
  cases' eq_or_ne p q with h h
  · subst p
    rw [(eq_zero_iff q q).mpr (by exact_mod_cast nat_cast_self q), MulZeroClass.mul_zero]
  · have qr := congr_arg (· * legendreSym p q) (quadratic_reciprocity hp hq h)
    have : ((q : ℤ) : ZMod p) ≠ 0 := by exact_mod_cast prime_ne_zero p q h
    simpa only [mul_assoc, ← pow_two, sq_one p this, mul_one] using qr
#align legendre_sym.quadratic_reciprocity' legendreSym.quadratic_reciprocity'

/-- The Law of Quadratic Reciprocity: if `p` and `q` are odd primes and `p % 4 = 1`,
then `(q / p) = (p / q)`. -/
theorem quadratic_reciprocity_one_mod_four (hp : p % 4 = 1) (hq : q ≠ 2) :
    legendreSym q p = legendreSym p q := by
  rw [quadratic_reciprocity' (prime.mod_two_eq_one_iff_ne_two.mp (odd_of_mod_four_eq_one hp)) hq,
    pow_mul, neg_one_pow_div_two_of_one_mod_four hp, one_pow, one_mul]
#align legendre_sym.quadratic_reciprocity_one_mod_four legendreSym.quadratic_reciprocity_one_mod_four

/-- The Law of Quadratic Reciprocity: if `p` and `q` are primes that are both congruent
to `3` mod `4`, then `(q / p) = -(p / q)`. -/
theorem quadratic_reciprocity_three_mod_four (hp : p % 4 = 3) (hq : q % 4 = 3) :
    legendreSym q p = -legendreSym p q :=
  by
  let nop := @neg_one_pow_div_two_of_three_mod_four
  rw [quadratic_reciprocity', pow_mul, nop hp, nop hq, neg_one_mul] <;>
    rwa [← prime.mod_two_eq_one_iff_ne_two, odd_of_mod_four_eq_three]
#align legendre_sym.quadratic_reciprocity_three_mod_four legendreSym.quadratic_reciprocity_three_mod_four

end legendreSym

namespace ZMod

open legendreSym

/-- If `p` and `q` are odd primes and `p % 4 = 1`, then `q` is a square mod `p` iff
`p` is a square mod `q`. -/
theorem exists_sq_eq_prime_iff_of_mod_four_eq_one (hp1 : p % 4 = 1) (hq1 : q ≠ 2) :
    IsSquare (q : ZMod p) ↔ IsSquare (p : ZMod q) :=
  by
  cases' eq_or_ne p q with h h
  · subst p
  ·
    rw [← eq_one_iff' p (prime_ne_zero p q h), ← eq_one_iff' q (prime_ne_zero q p h.symm),
      quadratic_reciprocity_one_mod_four hp1 hq1]
#align zmod.exists_sq_eq_prime_iff_of_mod_four_eq_one ZMod.exists_sq_eq_prime_iff_of_mod_four_eq_one

/-- If `p` and `q` are distinct primes that are both congruent to `3` mod `4`, then `q` is
a square mod `p` iff `p` is a nonsquare mod `q`. -/
theorem exists_sq_eq_prime_iff_of_mod_four_eq_three (hp3 : p % 4 = 3) (hq3 : q % 4 = 3)
    (hpq : p ≠ q) : IsSquare (q : ZMod p) ↔ ¬IsSquare (p : ZMod q) := by
  rw [← eq_one_iff' p (prime_ne_zero p q hpq), ← eq_neg_one_iff' q,
    quadratic_reciprocity_three_mod_four hp3 hq3, neg_inj]
#align zmod.exists_sq_eq_prime_iff_of_mod_four_eq_three ZMod.exists_sq_eq_prime_iff_of_mod_four_eq_three

end ZMod

end Reciprocity


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Johannes Hölzl, Scott Morrison, Jens Wagemaker
-/
import data.polynomial.basic

/-!
# Univariate monomials

Preparatory lemmas for degree_basic.
-/

noncomputable theory

namespace polynomial
open_locale polynomial

universes u
variables {R : Type u} {a b : R} {m n : ℕ}
variables [semiring R] {p q r : R[X]}

lemma monomial_one_eq_iff [nontrivial R] {i j : ℕ} :
  (monomial i 1 : R[X]) = monomial j 1 ↔ i = j :=
begin
  simp_rw [←of_finsupp_single],
  exact add_monoid_algebra.of_injective.eq_iff
end

instance [nontrivial R] : infinite R[X] :=
infinite.of_injective (λ i, monomial i 1) $
λ m n h, by simpa [monomial_one_eq_iff] using h

lemma card_support_le_one_iff_monomial {f : R[X]} :
  finset.card f.support ≤ 1 ↔ ∃ n a, f = monomial n a :=
begin
  split,
  { assume H,
    rw finset.card_le_one_iff_subset_singleton at H,
    rcases H with ⟨n, hn⟩,
    refine ⟨n, f.coeff n, _⟩,
    ext i,
    by_cases hi : i = n,
    { simp [hi, coeff_monomial] },
    { have : f.coeff i = 0,
      { rw ← not_mem_support_iff,
        exact λ hi', hi (finset.mem_singleton.1 (hn hi')) },
      simp [this, ne.symm hi, coeff_monomial] } },
  { rintros ⟨n, a, rfl⟩,
    rw ← finset.card_singleton n,
    apply finset.card_le_of_subset,
    exact support_monomial' _ _ }
end

lemma ring_hom_ext {S} [semiring S] {f g : R[X] →+* S}
  (h₁ : ∀ a, f (C a) = g (C a)) (h₂ : f X = g X) : f = g :=
begin
  set f' := f.comp (to_finsupp_iso R).symm.to_ring_hom with hf',
  set g' := g.comp (to_finsupp_iso R).symm.to_ring_hom with hg',
  have A : f' = g',
  { ext,
    { simp [h₁, ring_equiv.to_ring_hom_eq_coe] },
    { simpa [ring_equiv.to_ring_hom_eq_coe] using h₂, } },
  have B : f = f'.comp (to_finsupp_iso R),
    by { rw [hf', ring_hom.comp_assoc], ext x, simp only [ring_equiv.to_ring_hom_eq_coe,
      ring_equiv.symm_apply_apply, function.comp_app, ring_hom.coe_comp,
      ring_equiv.coe_to_ring_hom] },
  have C : g = g'.comp (to_finsupp_iso R),
    by { rw [hg', ring_hom.comp_assoc], ext x, simp only [ring_equiv.to_ring_hom_eq_coe,
      ring_equiv.symm_apply_apply, function.comp_app, ring_hom.coe_comp,
      ring_equiv.coe_to_ring_hom] },
  rw [B, C, A]
end

@[ext] lemma ring_hom_ext' {S} [semiring S] {f g : R[X] →+* S}
  (h₁ : f.comp C = g.comp C) (h₂ : f X = g X) : f = g :=
ring_hom_ext (ring_hom.congr_fun h₁) h₂

end polynomial


import data.set.function

namespace function
variables {α β γ δ : Type*} (f : (α → β) → γ)

def has_frame (S : set α) : Prop :=
∃ (g : (S → β) → γ), f = g ∘ (set.restrict S)

variables {f} {S : set α}

theorem has_frame_iff [nonempty β] : has_frame f S ↔ ∀ ⦃c₁ c₂ : α → β⦄, (∀ x ∈ S, c₁ x = c₂ x) → f c₁ = f c₂ :=
begin
  split,
  { rintro ⟨g, rfl⟩, intros c₁ c₂ h, dsimp only [function.comp_app],
    congr' 1, ext, simp only [set.restrict_apply], apply h, exact subtype.mem x, },
  classical,
  intro h,
  use (λ c : S → β, f (λ v, if h : v ∈ S then c ⟨v, h⟩ else nonempty.some infer_instance)),
  ext c, simp only [function.comp_app], apply h, intros x hx, simp [hx],
end

theorem has_frame.mono {S'} (h : has_frame f S) (hS' : S ⊆ S') : has_frame f S' :=
by { rcases h with ⟨g, rfl⟩, use (λ c : S' → β, g (λ v, c ⟨v.1, hS' v.2⟩)), ext x, simp, congr, }

theorem has_frame.const (α β : Type*) (C : γ) : has_frame (const (α → β) C) ∅ :=
⟨λ _, C, by { ext, simp, }⟩

theorem has_frame.postcomp (h : has_frame f S) (g : γ → δ) :
  has_frame (g ∘ f) S :=
by { rcases h with ⟨g', rfl⟩, use (g ∘ g'), }

end function

section examples

def test_fun (f : ℕ → ℤ) : ℤ := (f 0) + (f 1) * (f 2)

theorem test_fun_frame : function.has_frame test_fun {0, 1, 2} :=
begin
  rw function.has_frame_iff,
  intros c₁ c₂ h,
  simp [test_fun, h],
end

def test_fun₂ (f : ℕ → ℤ) : ℤ := if test_fun f = 5 then f 3 else -(f 3)

theorem test_fun₂_frame : function.has_frame test_fun₂ {0, 1, 2, 3} :=
begin
  rw function.has_frame_iff,
  intros c₁ c₂ h,
  simp [test_fun₂],
end

end examples


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro

Topology of the complex numbers.
-/
import data.complex.basic analysis.metric_space

noncomputable theory
open filter

namespace complex

-- TODO(Mario): these proofs are all copied from analysis/real. Generalize
-- to normed fields
instance : metric_space ℂ :=
{ dist               := λx y, (x - y).abs,
  dist_self          := by simp [abs_zero],
  eq_of_dist_eq_zero := by simp [add_neg_eq_zero],
  dist_comm          := assume x y, complex.abs_sub _ _,
  dist_triangle      := assume x y z, complex.abs_sub_le _ _ _ }

theorem dist_eq (x y : ℂ) : dist x y = (x - y).abs := rfl

theorem uniform_continuous_add : uniform_continuous (λp : ℂ × ℂ, p.1 + p.2) :=
uniform_continuous_of_metric.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_add_continuous_lemma abs ε0 in
⟨δ, δ0, λ a b h, let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ h₁ h₂⟩

theorem uniform_continuous_neg : uniform_continuous (@has_neg.neg ℂ _) :=
uniform_continuous_of_metric.2 $ λ ε ε0, ⟨_, ε0, λ a b h,
  by rw dist_comm at h; simpa [dist_eq] using h⟩

instance : uniform_add_group ℂ :=
uniform_add_group.mk' uniform_continuous_add uniform_continuous_neg

instance : topological_add_group ℂ := by apply_instance

lemma uniform_continuous_inv (s : set ℂ) {r : ℝ} (r0 : 0 < r) (H : ∀ x ∈ s, r ≤ abs x) :
  uniform_continuous (λp:s, p.1⁻¹) :=
uniform_continuous_of_metric.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_inv_continuous_lemma abs ε0 r0 in
⟨δ, δ0, λ a b h, Hδ (H _ a.2) (H _ b.2) h⟩

lemma uniform_continuous_abs : uniform_continuous (abs : ℂ → ℝ) :=
uniform_continuous_of_metric.2 $ λ ε ε0,
  ⟨ε, ε0, λ a b, lt_of_le_of_lt (abs_abs_sub_le_abs_sub _ _)⟩

lemma continuous_abs : continuous (abs : ℂ → ℝ) :=
uniform_continuous_abs.continuous

lemma tendsto_inv {r : ℂ} (r0 : r ≠ 0) : tendsto (λq, q⁻¹) (nhds r) (nhds r⁻¹) :=
by rw ← abs_pos at r0; exact
tendsto_of_uniform_continuous_subtype
  (uniform_continuous_inv {x | abs r / 2 < abs x} (half_pos r0) (λ x h, le_of_lt h))
  (mem_nhds_sets (continuous_abs _ $ is_open_lt' (abs r / 2)) (half_lt_self r0))

lemma continuous_inv' : continuous (λa:{r:ℂ // r ≠ 0}, a.val⁻¹) :=
continuous_iff_tendsto.mpr $ assume ⟨r, hr⟩,
  (continuous_iff_tendsto.mp continuous_subtype_val _).comp (tendsto_inv hr)

lemma continuous_inv {α} [topological_space α] {f : α → ℂ} (h : ∀a, f a ≠ 0) (hf : continuous f) :
  continuous (λa, (f a)⁻¹) :=
show continuous ((has_inv.inv ∘ @subtype.val ℂ (λr, r ≠ 0)) ∘ λa, ⟨f a, h a⟩),
  from (continuous_subtype_mk _ hf).comp continuous_inv'

lemma uniform_continuous_mul_const {x : ℂ} : uniform_continuous ((*) x) :=
uniform_continuous_of_metric.2 $ λ ε ε0, begin
  cases no_top (abs x) with y xy,
  have y0 := lt_of_le_of_lt (abs_nonneg _) xy,
  refine ⟨_, div_pos ε0 y0, λ a b h, _⟩,
  rw [dist_eq, ← mul_sub, abs_mul, ← mul_div_cancel' ε (ne_of_gt y0)],
  exact mul_lt_mul' (le_of_lt xy) h (abs_nonneg _) y0
end

lemma uniform_continuous_mul (s : set (ℂ × ℂ))
  {r₁ r₂ : ℝ} (r₁0 : 0 < r₁) (r₂0 : 0 < r₂)
  (H : ∀ x ∈ s, abs (x : ℂ × ℂ).1 < r₁ ∧ abs x.2 < r₂) :
  uniform_continuous (λp:s, p.1.1 * p.1.2) :=
uniform_continuous_of_metric.2 $ λ ε ε0,
let ⟨δ, δ0, Hδ⟩ := rat_mul_continuous_lemma abs ε0 r₁0 r₂0 in
⟨δ, δ0, λ a b h,
  let ⟨h₁, h₂⟩ := max_lt_iff.1 h in Hδ (H _ a.2).1 (H _ b.2).2 h₁ h₂⟩

lemma continuous_mul : continuous (λp : ℂ × ℂ, p.1 * p.2) :=
continuous_iff_tendsto.2 $ λ ⟨a₁, a₂⟩,
tendsto_of_uniform_continuous_subtype
  (uniform_continuous_mul
    ({x | abs x < abs a₁ + 1}.prod {x | abs x < abs a₂ + 1})
    (lt_of_le_of_lt (abs_nonneg _) (lt_add_one _))
    (lt_of_le_of_lt (abs_nonneg _) (lt_add_one _))
    (λ x, id))
  (mem_nhds_sets
    (is_open_prod
      (continuous_abs _ $ is_open_gt' _)
      (continuous_abs _ $ is_open_gt' _))
    ⟨lt_add_one (abs a₁), lt_add_one (abs a₂)⟩)

instance : topological_ring ℂ :=
{ continuous_mul := continuous_mul, ..complex.topological_add_group }

instance : topological_semiring ℂ := by apply_instance

end complex


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

! This file was ported from Lean 3 source module ring_theory.nullstellensatz
! leanprover-community/mathlib commit 9556784a5b84697562e9c6acb40500d4a82e675a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.Jacobson
import Mathbin.FieldTheory.IsAlgClosed.Basic
import Mathbin.FieldTheory.MvPolynomial
import Mathbin.AlgebraicGeometry.PrimeSpectrum.Basic

/-!
# 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 section

namespace MvPolynomial

open MvPolynomial

variable {k : Type _} [Field k]

variable {σ : Type _}

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

@[simp]
theorem mem_zeroLocus_iff {I : Ideal (MvPolynomial σ k)} {x : σ → k} :
    x ∈ zeroLocus I ↔ ∀ p ∈ I, eval x p = 0 :=
  Iff.rfl
#align mv_polynomial.mem_zero_locus_iff MvPolynomial.mem_zeroLocus_iff

theorem zeroLocus_anti_mono {I J : Ideal (MvPolynomial σ k)} (h : I ≤ J) :
    zeroLocus J ≤ zeroLocus I := fun x hx p hp => hx p <| h hp
#align mv_polynomial.zero_locus_anti_mono MvPolynomial.zeroLocus_anti_mono

theorem zeroLocus_bot : zeroLocus (⊥ : Ideal (MvPolynomial σ k)) = ⊤ :=
  eq_top_iff.2 fun x hx p hp => trans (congr_arg (eval x) (mem_bot.1 hp)) (eval x).map_zero
#align mv_polynomial.zero_locus_bot MvPolynomial.zeroLocus_bot

theorem zeroLocus_top : zeroLocus (⊤ : Ideal (MvPolynomial σ k)) = ⊥ :=
  eq_bot_iff.2 fun x hx => one_ne_zero ((eval x).map_one ▸ hx 1 Submodule.mem_top : (1 : k) = 0)
#align mv_polynomial.zero_locus_top MvPolynomial.zeroLocus_top

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

@[simp]
theorem mem_vanishingIdeal_iff {V : Set (σ → k)} {p : MvPolynomial σ k} :
    p ∈ vanishingIdeal V ↔ ∀ x ∈ V, eval x p = 0 :=
  Iff.rfl
#align mv_polynomial.mem_vanishing_ideal_iff MvPolynomial.mem_vanishingIdeal_iff

theorem vanishingIdeal_anti_mono {A B : Set (σ → k)} (h : A ≤ B) :
    vanishingIdeal B ≤ vanishingIdeal A := fun p hp x hx => hp x <| h hx
#align mv_polynomial.vanishing_ideal_anti_mono MvPolynomial.vanishingIdeal_anti_mono

theorem vanishingIdeal_empty : vanishingIdeal (∅ : Set (σ → k)) = ⊤ :=
  le_antisymm le_top fun p hp x hx => absurd hx (Set.not_mem_empty x)
#align mv_polynomial.vanishing_ideal_empty MvPolynomial.vanishingIdeal_empty

theorem le_vanishingIdeal_zeroLocus (I : Ideal (MvPolynomial σ k)) :
    I ≤ vanishingIdeal (zeroLocus I) := fun p hp x hx => hx p hp
#align mv_polynomial.le_vanishing_ideal_zero_locus MvPolynomial.le_vanishingIdeal_zeroLocus

theorem zeroLocus_vanishingIdeal_le (V : Set (σ → k)) : V ≤ zeroLocus (vanishingIdeal V) :=
  fun V hV p hp => hp V hV
#align mv_polynomial.zero_locus_vanishing_ideal_le MvPolynomial.zeroLocus_vanishingIdeal_le

theorem zeroLocus_vanishingIdeal_galoisConnection :
    @GaloisConnection (Ideal (MvPolynomial σ k)) (Set (σ → k))ᵒᵈ _ _ zeroLocus vanishingIdeal :=
  fun I V =>
  ⟨fun h => le_trans (le_vanishingIdeal_zeroLocus I) (vanishingIdeal_anti_mono h), fun h =>
    le_trans (zeroLocus_anti_mono h) (zeroLocus_vanishingIdeal_le V)⟩
#align mv_polynomial.zero_locus_vanishing_ideal_galois_connection MvPolynomial.zeroLocus_vanishingIdeal_galoisConnection

theorem mem_vanishingIdeal_singleton_iff (x : σ → k) (p : MvPolynomial σ k) :
    p ∈ (vanishingIdeal {x} : Ideal (MvPolynomial σ k)) ↔ eval x p = 0 :=
  ⟨fun h => h x rfl, fun hpx y hy => hy.symm ▸ hpx⟩
#align mv_polynomial.mem_vanishing_ideal_singleton_iff MvPolynomial.mem_vanishingIdeal_singleton_iff

instance vanishingIdeal_singleton_isMaximal {x : σ → k} :
    (vanishingIdeal {x} : Ideal (MvPolynomial σ k)).IsMaximal :=
  by
  have : MvPolynomial σ k ⧸ vanishing_ideal {x} ≃+* k :=
    RingEquiv.ofBijective
      (Ideal.Quotient.lift _ (eval x) fun p h => (mem_vanishing_ideal_singleton_iff x p).mp h)
      (by
        refine'
          ⟨(injective_iff_map_eq_zero _).mpr fun p hp => _, fun z =>
            ⟨(Ideal.Quotient.mk (vanishing_ideal {x} : Ideal (MvPolynomial σ 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)
  rw [← bot_quotient_is_maximal_iff, ring_equiv.bot_maximal_iff this]
  exact bot_is_maximal
#align mv_polynomial.vanishing_ideal_singleton_is_maximal MvPolynomial.vanishingIdeal_singleton_isMaximal

theorem radical_le_vanishingIdeal_zeroLocus (I : Ideal (MvPolynomial σ k)) :
    I.radical ≤ vanishingIdeal (zeroLocus I) :=
  by
  intro 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 fun y hy => hy.symm ▸ hx),
        is_maximal.is_prime' _⟩
#align mv_polynomial.radical_le_vanishing_ideal_zero_locus MvPolynomial.radical_le_vanishingIdeal_zeroLocus

/-- The point in the prime spectrum assosiated to a given point -/
def pointToPoint (x : σ → k) : PrimeSpectrum (MvPolynomial σ k) :=
  ⟨(vanishingIdeal {x} : Ideal (MvPolynomial σ k)), by infer_instance⟩
#align mv_polynomial.point_to_point MvPolynomial.pointToPoint

@[simp]
theorem vanishingIdeal_pointToPoint (V : Set (σ → k)) :
    PrimeSpectrum.vanishingIdeal (pointToPoint '' V) = MvPolynomial.vanishingIdeal V :=
  le_antisymm
    (fun p hp x hx =>
      (((PrimeSpectrum.mem_vanishingIdeal _ _).1 hp) ⟨vanishingIdeal {x}, by infer_instance⟩
          ⟨x, ⟨hx, rfl⟩⟩)
        x rfl)
    fun p hp =>
    (PrimeSpectrum.mem_vanishingIdeal _ _).2 fun I hI =>
      let ⟨x, hx⟩ := hI
      hx.2 ▸ fun x' hx' => (Set.mem_singleton_iff.1 hx').symm ▸ hp x hx.1
#align mv_polynomial.vanishing_ideal_point_to_point MvPolynomial.vanishingIdeal_pointToPoint

theorem pointToPoint_zeroLocus_le (I : Ideal (MvPolynomial σ k)) :
    pointToPoint '' MvPolynomial.zeroLocus I ≤ PrimeSpectrum.zeroLocus ↑I := fun J hJ =>
  let ⟨x, hx⟩ := hJ
  (le_trans (le_vanishingIdeal_zeroLocus I)
      (hx.2 ▸ vanishingIdeal_anti_mono (Set.singleton_subset_iff.2 hx.1)) :
    I ≤ J.asIdeal)
#align mv_polynomial.point_to_point_zero_locus_le MvPolynomial.pointToPoint_zeroLocus_le

variable [IsAlgClosed k] [Finite σ]

theorem isMaximal_iff_eq_vanishingIdeal_singleton (I : Ideal (MvPolynomial σ k)) :
    I.IsMaximal ↔ ∃ x : σ → k, I = vanishingIdeal {x} :=
  by
  cases nonempty_fintype σ
  refine'
    ⟨fun hI => _, fun h =>
      let ⟨x, hx⟩ := h
      hx.symm ▸ MvPolynomial.vanishingIdeal_singleton_isMaximal⟩
  letI : I.is_maximal := hI
  letI : Field (MvPolynomial σ k ⧸ I) := quotient.field I
  let ϕ : k →+* MvPolynomial σ k ⧸ I := (Ideal.Quotient.mk I).comp C
  have hϕ : Function.Bijective ϕ :=
    ⟨quotient_mk_comp_C_injective _ _ I hI.ne_top,
      IsAlgClosed.algebra_map_surjective_of_is_integral' ϕ
        (mv_polynomial.comp_C_integral_of_surjective_of_jacobson _ quotient.mk_surjective)⟩
  obtain ⟨φ, hφ⟩ := Function.Surjective.hasRightInverse hϕ.2
  let x : σ → k := fun s => φ ((Ideal.Quotient.mk I) (X s))
  have hx : ∀ s : σ, ϕ (x s) = (Ideal.Quotient.mk I) (X s) := fun s =>
    hφ ((Ideal.Quotient.mk I) (X s))
  refine' ⟨x, (is_maximal.eq_of_le (by infer_instance) hI.ne_top _).symm⟩
  intro 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
  simpa only [ϕ.map_sum, ϕ.map_mul, ϕ.map_prod, ϕ.map_pow, ϕ.map_zero, hx] using congr_arg ϕ hp
#align mv_polynomial.is_maximal_iff_eq_vanishing_ideal_singleton MvPolynomial.isMaximal_iff_eq_vanishingIdeal_singleton

/-- Main statement of the Nullstellensatz -/
@[simp]
theorem vanishingIdeal_zeroLocus_eq_radical (I : Ideal (MvPolynomial σ k)) :
    vanishingIdeal (zeroLocus I) = I.radical :=
  by
  rw [I.radical_eq_jacobson]
  refine' le_antisymm (le_infₛ _) fun p hp x hx => _
  · rintro J ⟨hJI, hJ⟩
    obtain ⟨x, hx⟩ := (is_maximal_iff_eq_vanishing_ideal_singleton J).1 hJ
    refine' hx.symm ▸ vanishing_ideal_anti_mono fun 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 fun y hy => hy.symm ▸ hx),
          MvPolynomial.vanishingIdeal_singleton_isMaximal⟩
#align mv_polynomial.vanishing_ideal_zero_locus_eq_radical MvPolynomial.vanishingIdeal_zeroLocus_eq_radical

@[simp]
theorem IsPrime.vanishingIdeal_zeroLocus (P : Ideal (MvPolynomial σ k)) [h : P.IsPrime] :
    vanishingIdeal (zeroLocus P) = P :=
  trans (vanishingIdeal_zeroLocus_eq_radical P) h.radical
#align mv_polynomial.is_prime.vanishing_ideal_zero_locus MvPolynomial.IsPrime.vanishingIdeal_zeroLocus

end MvPolynomial