/-
Copyright (c) 2021 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/
import algebra.big_operators.order
import combinatorics.hall.basic
import data.fintype.big_operators
import set_theory.cardinal.finite

/-!
# Configurations of Points and lines
This file introduces abstract configurations of points and lines, and proves some basic properties.

## Main definitions
* `configuration.nondegenerate`: Excludes certain degenerate configurations,
  and imposes uniqueness of intersection points.
* `configuration.has_points`: A nondegenerate configuration in which
  every pair of lines has an intersection point.
* `configuration.has_lines`:  A nondegenerate configuration in which
  every pair of points has a line through them.
* `configuration.line_count`: The number of lines through a given point.
* `configuration.point_count`: The number of lines through a given line.

## Main statements
* `configuration.has_lines.card_le`: `has_lines` implies `|P| ≤ |L|`.
* `configuration.has_points.card_le`: `has_points` implies `|L| ≤ |P|`.
* `configuration.has_lines.has_points`: `has_lines` and `|P| = |L|` implies `has_points`.
* `configuration.has_points.has_lines`: `has_points` and `|P| = |L|` implies `has_lines`.
Together, these four statements say that any two of the following properties imply the third:
(a) `has_lines`, (b) `has_points`, (c) `|P| = |L|`.

-/

open_locale big_operators

set_option old_structure_cmd true

namespace configuration

variables (P L : Type*) [has_mem P L]

/-- A type synonym. -/
def dual := P

instance [this : inhabited P] : inhabited (dual P) := this

instance [finite P] : finite (dual P) := ‹finite P›
instance [this : fintype P] : fintype (dual P) := this

instance : has_mem (dual L) (dual P) :=
⟨function.swap (has_mem.mem : P → L → Prop)⟩

/-- A configuration is nondegenerate if:
  1) there does not exist a line that passes through all of the points,
  2) there does not exist a point that is on all of the lines,
  3) there is at most one line through any two points,
  4) any two lines have at most one intersection point.
  Conditions 3 and 4 are equivalent. -/
class nondegenerate : Prop :=
(exists_point : ∀ l : L, ∃ p, p ∉ l)
(exists_line : ∀ p, ∃ l : L, p ∉ l)
(eq_or_eq : ∀ {p₁ p₂ : P} {l₁ l₂ : L}, p₁ ∈ l₁ → p₂ ∈ l₁ → p₁ ∈ l₂ → p₂ ∈ l₂ → p₁ = p₂ ∨ l₁ = l₂)

/-- A nondegenerate configuration in which every pair of lines has an intersection point. -/
class has_points extends nondegenerate P L :=
(mk_point : Π {l₁ l₂ : L} (h : l₁ ≠ l₂), P)
(mk_point_ax : ∀ {l₁ l₂ : L} (h : l₁ ≠ l₂), mk_point h ∈ l₁ ∧ mk_point h ∈ l₂)

/-- A nondegenerate configuration in which every pair of points has a line through them. -/
class has_lines extends nondegenerate P L :=
(mk_line : Π {p₁ p₂ : P} (h : p₁ ≠ p₂), L)
(mk_line_ax : ∀ {p₁ p₂ : P} (h : p₁ ≠ p₂), p₁ ∈ mk_line h ∧ p₂ ∈ mk_line h)

open nondegenerate has_points (mk_point mk_point_ax) has_lines (mk_line mk_line_ax)

instance [nondegenerate P L] : nondegenerate (dual L) (dual P) :=
{ exists_point := @exists_line P L _ _,
  exists_line := @exists_point P L _ _,
  eq_or_eq := λ l₁ l₂ p₁ p₂ h₁ h₂ h₃ h₄, (@eq_or_eq P L _ _ p₁ p₂ l₁ l₂ h₁ h₃ h₂ h₄).symm }

instance [has_points P L] : has_lines (dual L) (dual P) :=
{ mk_line := @mk_point P L _ _,
  mk_line_ax := λ _ _, mk_point_ax,
  .. dual.nondegenerate _ _ }

instance [has_lines P L] : has_points (dual L) (dual P) :=
{ mk_point := @mk_line P L _ _,
  mk_point_ax := λ _ _, mk_line_ax,
  .. dual.nondegenerate _ _ }

lemma has_points.exists_unique_point [has_points P L] (l₁ l₂ : L) (hl : l₁ ≠ l₂) :
  ∃! p, p ∈ l₁ ∧ p ∈ l₂ :=
⟨mk_point hl, mk_point_ax hl,
  λ p hp, (eq_or_eq hp.1 (mk_point_ax hl).1 hp.2 (mk_point_ax hl).2).resolve_right hl⟩

lemma has_lines.exists_unique_line [has_lines P L] (p₁ p₂ : P) (hp : p₁ ≠ p₂) :
  ∃! l : L, p₁ ∈ l ∧ p₂ ∈ l :=
has_points.exists_unique_point (dual L) (dual P) p₁ p₂ hp

variables {P L}

/-- If a nondegenerate configuration has at least as many points as lines, then there exists
  an injective function `f` from lines to points, such that `f l` does not lie on `l`. -/
lemma nondegenerate.exists_injective_of_card_le [nondegenerate P L]
  [fintype P] [fintype L] (h : fintype.card L ≤ fintype.card P) :
  ∃ f : L → P, function.injective f ∧ ∀ l, (f l) ∉ l :=
begin
  classical,
  let t : L → finset P := λ l, (set.to_finset {p | p ∉ l}),
  suffices : ∀ s : finset L, s.card ≤ (s.bUnion t).card, -- Hall's marriage theorem
  { obtain ⟨f, hf1, hf2⟩ := (finset.all_card_le_bUnion_card_iff_exists_injective t).mp this,
    exact ⟨f, hf1, λ l, set.mem_to_finset.mp (hf2 l)⟩ },
  intro s,
  by_cases hs₀ : s.card = 0, -- If `s = ∅`, then `s.card = 0 ≤ (s.bUnion t).card`
  { simp_rw [hs₀, zero_le] },
  by_cases hs₁ : s.card = 1, -- If `s = {l}`, then pick a point `p ∉ l`
  { obtain ⟨l, rfl⟩ := finset.card_eq_one.mp hs₁,
    obtain ⟨p, hl⟩ := exists_point l,
    rw [finset.card_singleton, finset.singleton_bUnion, nat.one_le_iff_ne_zero],
    exact finset.card_ne_zero_of_mem (set.mem_to_finset.mpr hl) },
  suffices : (s.bUnion t)ᶜ.card ≤ sᶜ.card, -- Rephrase in terms of complements (uses `h`)
  { rw [finset.card_compl, finset.card_compl, tsub_le_iff_left] at this,
    replace := h.trans this,
    rwa [←add_tsub_assoc_of_le s.card_le_univ, le_tsub_iff_left
      (le_add_left s.card_le_univ), add_le_add_iff_right] at this },
  have hs₂ : (s.bUnion t)ᶜ.card ≤ 1, -- At most one line through two points of `s`
  { refine finset.card_le_one_iff.mpr (λ p₁ p₂ hp₁ hp₂, _),
    simp_rw [finset.mem_compl, finset.mem_bUnion, exists_prop, not_exists, not_and,
      set.mem_to_finset, set.mem_set_of_eq, not_not] at hp₁ hp₂,
    obtain ⟨l₁, l₂, hl₁, hl₂, hl₃⟩ :=
    finset.one_lt_card_iff.mp (nat.one_lt_iff_ne_zero_and_ne_one.mpr ⟨hs₀, hs₁⟩),
    exact (eq_or_eq (hp₁ l₁ hl₁) (hp₂ l₁ hl₁) (hp₁ l₂ hl₂) (hp₂ l₂ hl₂)).resolve_right hl₃ },
  by_cases hs₃ : sᶜ.card = 0,
  { rw [hs₃, le_zero_iff],
    rw [finset.card_compl, tsub_eq_zero_iff_le, has_le.le.le_iff_eq (finset.card_le_univ _),
        eq_comm, finset.card_eq_iff_eq_univ] at hs₃ ⊢,
    rw hs₃,
    rw finset.eq_univ_iff_forall at hs₃ ⊢,
    exact λ p, exists.elim (exists_line p) -- If `s = univ`, then show `s.bUnion t = univ`
      (λ l hl, finset.mem_bUnion.mpr ⟨l, finset.mem_univ l, set.mem_to_finset.mpr hl⟩) },
  { exact hs₂.trans (nat.one_le_iff_ne_zero.mpr hs₃) }, -- If `s < univ`, then consequence of `hs₂`
end

variables {P} (L)

/-- Number of points on a given line. -/
noncomputable def line_count (p : P) : ℕ := nat.card {l : L // p ∈ l}

variables (P) {L}

/-- Number of lines through a given point. -/
noncomputable def point_count (l : L) : ℕ := nat.card {p : P // p ∈ l}

variables (P L)

lemma sum_line_count_eq_sum_point_count [fintype P] [fintype L] :
  ∑ p : P, line_count L p = ∑ l : L, point_count P l :=
begin
  classical,
  simp only [line_count, point_count, nat.card_eq_fintype_card, ←fintype.card_sigma],
  apply fintype.card_congr,
  calc (Σ p, {l : L // p ∈ l}) ≃ {x : P × L // x.1 ∈ x.2} :
    (equiv.subtype_prod_equiv_sigma_subtype (∈)).symm
  ... ≃ {x : L × P // x.2 ∈ x.1} : (equiv.prod_comm P L).subtype_equiv (λ x, iff.rfl)
  ... ≃ (Σ l, {p // p ∈ l}) : equiv.subtype_prod_equiv_sigma_subtype (λ (l : L) (p : P), p ∈ l),
end

variables {P L}

lemma has_lines.point_count_le_line_count [has_lines P L] {p : P} {l : L} (h : p ∉ l)
  [finite {l : L // p ∈ l}] : point_count P l ≤ line_count L p :=
begin
  by_cases hf : infinite {p : P // p ∈ l},
  { exactI (le_of_eq nat.card_eq_zero_of_infinite).trans (zero_le (line_count L p)) },
  haveI := fintype_of_not_infinite hf,
  casesI nonempty_fintype {l : L // p ∈ l},
  rw [line_count, point_count, nat.card_eq_fintype_card, nat.card_eq_fintype_card],
  have : ∀ p' : {p // p ∈ l}, p ≠ p' := λ p' hp', h ((congr_arg (∈ l) hp').mpr p'.2),
  exact fintype.card_le_of_injective (λ p', ⟨mk_line (this p'), (mk_line_ax (this p')).1⟩)
    (λ p₁ p₂ hp, subtype.ext ((eq_or_eq p₁.2 p₂.2 (mk_line_ax (this p₁)).2
      ((congr_arg _ (subtype.ext_iff.mp hp)).mpr (mk_line_ax (this p₂)).2)).resolve_right
        (λ h', (congr_arg _ h').mp h (mk_line_ax (this p₁)).1))),
end

lemma has_points.line_count_le_point_count [has_points P L] {p : P} {l : L} (h : p ∉ l)
  [hf : finite {p : P // p ∈ l}] : line_count L p ≤ point_count P l :=
@has_lines.point_count_le_line_count (dual L) (dual P) _ _ l p h hf

variables (P L)

/-- If a nondegenerate configuration has a unique line through any two points, then `|P| ≤ |L|`. -/
lemma has_lines.card_le [has_lines P L] [fintype P] [fintype L] :
  fintype.card P ≤ fintype.card L :=
begin
  classical,
  by_contradiction hc₂,
  obtain ⟨f, hf₁, hf₂⟩ := nondegenerate.exists_injective_of_card_le (le_of_not_le hc₂),
  have := calc ∑ p, line_count L p = ∑ l, point_count P l : sum_line_count_eq_sum_point_count P L
  ... ≤ ∑ l, line_count L (f l) :
    finset.sum_le_sum (λ l hl, has_lines.point_count_le_line_count (hf₂ l))
  ... = ∑ p in finset.univ.image f, line_count L p :
    finset.sum_bij (λ l hl, f l) (λ l hl, finset.mem_image_of_mem f hl) (λ l hl, rfl)
      (λ l₁ l₂ hl₁ hl₂ hl₃, hf₁ hl₃) (λ p, by simp_rw [finset.mem_image, eq_comm, imp_self])
  ... < ∑ p, line_count L p : _,
  { exact lt_irrefl _ this },
  { obtain ⟨p, hp⟩ := not_forall.mp (mt (fintype.card_le_of_surjective f) hc₂),
    refine finset.sum_lt_sum_of_subset ((finset.univ.image f).subset_univ) (finset.mem_univ p)
      _ _ (λ p hp₁ hp₂, zero_le (line_count L p)),
    { simpa only [finset.mem_image, exists_prop, finset.mem_univ, true_and] },
    { rw [line_count, nat.card_eq_fintype_card, fintype.card_pos_iff],
      obtain ⟨l, hl⟩ := @exists_line P L _ _ p,
      exact let this := not_exists.mp hp l in ⟨⟨mk_line this, (mk_line_ax this).2⟩⟩ } },
end

/-- If a nondegenerate configuration has a unique point on any two lines, then `|L| ≤ |P|`. -/
lemma has_points.card_le [has_points P L] [fintype P] [fintype L] :
  fintype.card L ≤ fintype.card P :=
@has_lines.card_le (dual L) (dual P) _ _ _ _

variables {P L}

lemma has_lines.exists_bijective_of_card_eq [has_lines P L]
  [fintype P] [fintype L] (h : fintype.card P = fintype.card L) :
  ∃ f : L → P, function.bijective f ∧ ∀ l, point_count P l = line_count L (f l) :=
begin
  classical,
  obtain ⟨f, hf1, hf2⟩ := nondegenerate.exists_injective_of_card_le (ge_of_eq h),
  have hf3 := (fintype.bijective_iff_injective_and_card f).mpr ⟨hf1, h.symm⟩,
  refine ⟨f, hf3, λ l, (finset.sum_eq_sum_iff_of_le
    (by exact λ l hl, has_lines.point_count_le_line_count (hf2 l))).mp
      ((sum_line_count_eq_sum_point_count P L).symm.trans ((finset.sum_bij (λ l hl, f l)
        (λ l hl, finset.mem_univ (f l)) (λ l hl, refl (line_count L (f l)))
          (λ l₁ l₂ hl₁ hl₂ hl, hf1 hl) (λ p hp, _)).symm)) l (finset.mem_univ l)⟩,
  obtain ⟨l, rfl⟩ := hf3.2 p,
  exact ⟨l, finset.mem_univ l, rfl⟩,
end

lemma has_lines.line_count_eq_point_count [has_lines P L] [fintype P] [fintype L]
  (hPL : fintype.card P = fintype.card L) {p : P} {l : L} (hpl : p ∉ l) :
  line_count L p = point_count P l :=
begin
  classical,
  obtain ⟨f, hf1, hf2⟩ := has_lines.exists_bijective_of_card_eq hPL,
  let s : finset (P × L) := set.to_finset {i | i.1 ∈ i.2},
  have step1 : ∑ i : P × L, line_count L i.1 = ∑ i : P × L, point_count P i.2,
  { rw [←finset.univ_product_univ, finset.sum_product_right, finset.sum_product],
    simp_rw [finset.sum_const, finset.card_univ, hPL, sum_line_count_eq_sum_point_count] },
  have step2 : ∑ i in s, line_count L i.1 = ∑ i in s, point_count P i.2,
  { rw [s.sum_finset_product finset.univ (λ p, set.to_finset {l | p ∈ l})],
    rw [s.sum_finset_product_right finset.univ (λ l, set.to_finset {p | p ∈ l})],
    refine (finset.sum_bij (λ l hl, f l) (λ l hl, finset.mem_univ (f l)) (λ l hl, _)
      (λ _ _ _ _ h, hf1.1 h) (λ p hp, _)).symm,
    { simp_rw [finset.sum_const, set.to_finset_card, ←nat.card_eq_fintype_card],
      change (point_count P l) • (point_count P l) = (line_count L (f l)) • (line_count L (f l)),
      rw hf2 },
    { obtain ⟨l, hl⟩ := hf1.2 p,
      exact ⟨l, finset.mem_univ l, hl.symm⟩ },
    all_goals { simp_rw [finset.mem_univ, true_and, set.mem_to_finset], exact λ p, iff.rfl } },
  have step3 : ∑ i in sᶜ, line_count L i.1 = ∑ i in sᶜ, point_count P i.2,
  { rwa [←s.sum_add_sum_compl, ←s.sum_add_sum_compl, step2, add_left_cancel_iff] at step1 },
  rw ← set.to_finset_compl at step3,
  exact ((finset.sum_eq_sum_iff_of_le (by exact λ i hi, has_lines.point_count_le_line_count
    (set.mem_to_finset.mp hi))).mp step3.symm (p, l) (set.mem_to_finset.mpr hpl)).symm,
end

lemma has_points.line_count_eq_point_count [has_points P L] [fintype P] [fintype L]
  (hPL : fintype.card P = fintype.card L) {p : P} {l : L} (hpl : p ∉ l) :
  line_count L p = point_count P l :=
(@has_lines.line_count_eq_point_count (dual L) (dual P) _ _  _ _ hPL.symm l p hpl).symm

/-- If a nondegenerate configuration has a unique line through any two points, and if `|P| = |L|`,
  then there is a unique point on any two lines. -/
noncomputable def has_lines.has_points [has_lines P L] [fintype P] [fintype L]
  (h : fintype.card P = fintype.card L) : has_points P L :=
let this : ∀ l₁ l₂ : L, l₁ ≠ l₂ → ∃ p : P, p ∈ l₁ ∧ p ∈ l₂ := λ l₁ l₂ hl, begin
  classical,
  obtain ⟨f, hf1, hf2⟩ := has_lines.exists_bijective_of_card_eq h,
  haveI : nontrivial L := ⟨⟨l₁, l₂, hl⟩⟩,
  haveI := fintype.one_lt_card_iff_nontrivial.mp ((congr_arg _ h).mpr fintype.one_lt_card),
  have h₁ : ∀ p : P, 0 < line_count L p := λ p, exists.elim (exists_ne p) (λ q hq, (congr_arg _
    nat.card_eq_fintype_card).mpr (fintype.card_pos_iff.mpr ⟨⟨mk_line hq, (mk_line_ax hq).2⟩⟩)),
  have h₂ : ∀ l : L, 0 < point_count P l := λ l, (congr_arg _ (hf2 l)).mpr (h₁ (f l)),
  obtain ⟨p, hl₁⟩ := fintype.card_pos_iff.mp ((congr_arg _ nat.card_eq_fintype_card).mp (h₂ l₁)),
  by_cases hl₂ : p ∈ l₂, exact ⟨p, hl₁, hl₂⟩,
  have key' : fintype.card {q : P // q ∈ l₂} = fintype.card {l : L // p ∈ l},
  { exact ((has_lines.line_count_eq_point_count h hl₂).trans nat.card_eq_fintype_card).symm.trans
    nat.card_eq_fintype_card, },
  have : ∀ q : {q // q ∈ l₂}, p ≠ q := λ q hq, hl₂ ((congr_arg (∈ l₂) hq).mpr q.2),
  let f : {q : P // q ∈ l₂} → {l : L // p ∈ l} := λ q, ⟨mk_line (this q), (mk_line_ax (this q)).1⟩,
  have hf : function.injective f := λ q₁ q₂ hq, subtype.ext ((eq_or_eq q₁.2 q₂.2
    (mk_line_ax (this q₁)).2 ((congr_arg _ (subtype.ext_iff.mp hq)).mpr (mk_line_ax
      (this q₂)).2)).resolve_right (λ h, (congr_arg _ h).mp hl₂ (mk_line_ax (this q₁)).1)),
  have key' := ((fintype.bijective_iff_injective_and_card f).mpr ⟨hf, key'⟩).2,
  obtain ⟨q, hq⟩ := key' ⟨l₁, hl₁⟩,
  exact ⟨q, (congr_arg _ (subtype.ext_iff.mp hq)).mp (mk_line_ax (this q)).2, q.2⟩,
end in
{ mk_point := λ l₁ l₂ hl, classical.some (this l₁ l₂ hl),
  mk_point_ax := λ l₁ l₂ hl, classical.some_spec (this l₁ l₂ hl),
  .. ‹has_lines P L› }

/-- If a nondegenerate configuration has a unique point on any two lines, and if `|P| = |L|`,
  then there is a unique line through any two points. -/
noncomputable def has_points.has_lines [has_points P L] [fintype P] [fintype L]
  (h : fintype.card P = fintype.card L) : has_lines P L :=
let this := @has_lines.has_points (dual L) (dual P) _ _ _ _ h.symm in
{ mk_line := λ _ _, this.mk_point,
  mk_line_ax := λ _ _, this.mk_point_ax,
  .. ‹has_points P L› }

variables (P L)

/-- A projective plane is a nondegenerate configuration in which every pair of lines has
  an intersection point, every pair of points has a line through them,
  and which has three points in general position. -/
class projective_plane extends has_points P L, has_lines P L :=
(exists_config : ∃ (p₁ p₂ p₃ : P) (l₁ l₂ l₃ : L), p₁ ∉ l₂ ∧ p₁ ∉ l₃ ∧
  p₂ ∉ l₁ ∧ p₂ ∈ l₂ ∧ p₂ ∈ l₃ ∧ p₃ ∉ l₁ ∧ p₃ ∈ l₂ ∧ p₃ ∉ l₃)

namespace projective_plane

variables [projective_plane P L]

instance : projective_plane (dual L) (dual P) :=
{ exists_config :=
    let ⟨p₁, p₂, p₃, l₁, l₂, l₃, h₁₂, h₁₃, h₂₁, h₂₂, h₂₃, h₃₁, h₃₂, h₃₃⟩ :=
      @exists_config P L _ _ in
    ⟨l₁, l₂, l₃, p₁, p₂, p₃, h₂₁, h₃₁, h₁₂, h₂₂, h₃₂, h₁₃, h₂₃, h₃₃⟩,
  .. dual.has_points _ _,
  .. dual.has_lines _ _ }

/-- The order of a projective plane is one less than the number of lines through an arbitrary point.
Equivalently, it is one less than the number of points on an arbitrary line. -/
noncomputable def order : ℕ :=
line_count L (classical.some (@exists_config P L _ _)) - 1

lemma card_points_eq_card_lines [fintype P] [fintype L] : fintype.card P = fintype.card L :=
le_antisymm (has_lines.card_le P L) (has_points.card_le P L)

variables {P} (L)

lemma line_count_eq_line_count [finite P] [finite L] (p q : P) :
  line_count L p = line_count L q :=
begin
  casesI nonempty_fintype P,
  casesI nonempty_fintype L,
  obtain ⟨p₁, p₂, p₃, l₁, l₂, l₃, h₁₂, h₁₃, h₂₁, h₂₂, h₂₃, h₃₁, h₃₂, h₃₃⟩ := exists_config,
  have h := card_points_eq_card_lines P L,
  let n := line_count L p₂,
  have hp₂ : line_count L p₂ = n := rfl,
  have hl₁ : point_count P l₁ = n := (has_lines.line_count_eq_point_count h h₂₁).symm.trans hp₂,
  have hp₃ : line_count L p₃ = n := (has_lines.line_count_eq_point_count h h₃₁).trans hl₁,
  have hl₃ : point_count P l₃ = n := (has_lines.line_count_eq_point_count h h₃₃).symm.trans hp₃,
  have hp₁ : line_count L p₁ = n := (has_lines.line_count_eq_point_count h h₁₃).trans hl₃,
  have hl₂ : point_count P l₂ = n := (has_lines.line_count_eq_point_count h h₁₂).symm.trans hp₁,
  suffices : ∀ p : P, line_count L p = n, { exact (this p).trans (this q).symm },
  refine λ p, or_not.elim (λ h₂, _) (λ h₂, (has_lines.line_count_eq_point_count h h₂).trans hl₂),
  refine or_not.elim (λ h₃, _) (λ h₃, (has_lines.line_count_eq_point_count h h₃).trans hl₃),
  rwa (eq_or_eq h₂ h₂₂ h₃ h₂₃).resolve_right (λ h, h₃₃ ((congr_arg (has_mem.mem p₃) h).mp h₃₂)),
end

variables (P) {L}

lemma point_count_eq_point_count [finite P] [finite L] (l m : L) :
  point_count P l = point_count P m :=
line_count_eq_line_count (dual P) l m

variables {P L}

lemma line_count_eq_point_count [finite P] [finite L] (p : P) (l : L) :
  line_count L p = point_count P l :=
exists.elim (exists_point l) $ λ q hq, (line_count_eq_line_count L p q).trans $
  by { casesI nonempty_fintype P, casesI nonempty_fintype L,
    exact has_lines.line_count_eq_point_count (card_points_eq_card_lines P L) hq }

variables (P L)

lemma dual.order [finite P] [finite L] : order (dual L) (dual P) = order P L :=
congr_arg (λ n, n - 1) (line_count_eq_point_count _ _)

variables {P} (L)

lemma line_count_eq [finite P] [finite L] (p : P) : line_count L p = order P L + 1 :=
begin
  classical,
  obtain ⟨q, -, -, l, -, -, -, -, h, -⟩ := classical.some_spec (@exists_config P L _ _),
  casesI nonempty_fintype {l : L // q ∈ l},
  rw [order, line_count_eq_line_count L p q, line_count_eq_line_count L (classical.some _) q,
      line_count, nat.card_eq_fintype_card, nat.sub_add_cancel],
  exact fintype.card_pos_iff.mpr ⟨⟨l, h⟩⟩,
end

variables (P) {L}

lemma point_count_eq [finite P] [finite L] (l : L) : point_count P l = order P L + 1 :=
(line_count_eq (dual P) l).trans (congr_arg (λ n, n + 1) (dual.order P L))

variables (P L)

lemma one_lt_order [finite P] [finite L] : 1 < order P L :=
begin
  obtain ⟨p₁, p₂, p₃, l₁, l₂, l₃, -, -, h₂₁, h₂₂, h₂₃, h₃₁, h₃₂, h₃₃⟩ := @exists_config P L _ _,
  classical,
  casesI nonempty_fintype {p : P // p ∈ l₂},
  rw [←add_lt_add_iff_right, ←point_count_eq _ l₂, point_count, nat.card_eq_fintype_card],
  simp_rw [fintype.two_lt_card_iff, ne, subtype.ext_iff],
  have h := mk_point_ax (λ h, h₂₁ ((congr_arg _ h).mpr h₂₂)),
  exact ⟨⟨mk_point _, h.2⟩, ⟨p₂, h₂₂⟩, ⟨p₃, h₃₂⟩,
    ne_of_mem_of_not_mem h.1 h₂₁, ne_of_mem_of_not_mem h.1 h₃₁, ne_of_mem_of_not_mem h₂₃ h₃₃⟩,
end

variables {P} (L)

lemma two_lt_line_count [finite P] [finite L] (p : P) : 2 < line_count L p :=
by simpa only [line_count_eq L p, nat.succ_lt_succ_iff] using one_lt_order P L

variables (P) {L}

lemma two_lt_point_count [finite P] [finite L] (l : L) : 2 < point_count P l :=
by simpa only [point_count_eq P l, nat.succ_lt_succ_iff] using one_lt_order P L

variables (P) (L)

lemma card_points [fintype P] [finite L] : fintype.card P = order P L ^ 2 + order P L + 1 :=
begin
  casesI nonempty_fintype L,
  obtain ⟨p, -⟩ := @exists_config P L _ _,
  let ϕ : {q // q ≠ p} ≃ Σ (l : {l : L // p ∈ l}), {q // q ∈ l.1 ∧ q ≠ p} :=
  { to_fun := λ q, ⟨⟨mk_line q.2, (mk_line_ax q.2).2⟩, q, (mk_line_ax q.2).1, q.2⟩,
    inv_fun := λ lq, ⟨lq.2, lq.2.2.2⟩,
    left_inv := λ q, subtype.ext rfl,
    right_inv := λ lq, sigma.subtype_ext (subtype.ext ((eq_or_eq (mk_line_ax lq.2.2.2).1
      (mk_line_ax lq.2.2.2).2 lq.2.2.1 lq.1.2).resolve_left lq.2.2.2)) rfl },
  classical,
  have h1 : fintype.card {q // q ≠ p} + 1 = fintype.card P,
  { apply (eq_tsub_iff_add_eq_of_le (nat.succ_le_of_lt (fintype.card_pos_iff.mpr ⟨p⟩))).mp,
    convert (fintype.card_subtype_compl _).trans (congr_arg _ (fintype.card_subtype_eq p)) },
  have h2 : ∀ l : {l : L // p ∈ l}, fintype.card {q // q ∈ l.1 ∧ q ≠ p} = order P L,
  { intro l,
    rw [←fintype.card_congr (equiv.subtype_subtype_equiv_subtype_inter (∈ l.val) (≠ p)),
      fintype.card_subtype_compl (λ (x : subtype (∈ l.val)), x.val = p), ←nat.card_eq_fintype_card],
    refine tsub_eq_of_eq_add ((point_count_eq P l.1).trans _),
    rw ← fintype.card_subtype_eq (⟨p, l.2⟩ : {q : P // q ∈ l.1}),
    simp_rw subtype.ext_iff_val },
  simp_rw [←h1, fintype.card_congr ϕ, fintype.card_sigma, h2, finset.sum_const, finset.card_univ],
  rw [←nat.card_eq_fintype_card, ←line_count, line_count_eq, smul_eq_mul, nat.succ_mul, sq],
end

lemma card_lines [finite P] [fintype L] :
  fintype.card L = order P L ^ 2 + order P L + 1 :=
(card_points (dual L) (dual P)).trans (congr_arg (λ n, n ^ 2 + n + 1) (dual.order P L))

end projective_plane

end configuration


/-
  This type bundles together a value of a certain type
  together with a proof that it satisfies a certain property.

  It can be used to write algorithms that return values
  that must satisfy certain defining properties.
-/
@[class] structure Prover {α : Type _} (p : α → Prop) :=
  value : α
  proof : p value

-- easier notation
notation "#[" v ":" T "]" " ~ " p => Prover (λ (v : T) => p)

-- examples
#check #[x : Nat] ~ (x + 5 > 0)

example : #[x : Nat] ~ (x + 5 = 10) :=
  {
    value := 5,
    proof := rfl
  }

-- connection with existential quantifier
theorem valueWitness {α : Type _} {p : α → Prop} : (#[v : α] ~ p v) → (∃ v : α, p v) :=
  λ valPrf => ⟨valPrf.value, valPrf.proof⟩


/-
Copyright (c) 2023 Tian Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tian Chen
-/

import matrix.doubly_stochastic.basic
import analysis.convex.combination
import combinatorics.hall.finite

open_locale big_operators

open finset matrix

noncomputable theory

namespace matrix.doubly_stochastic

variables {m n α : Type*} [fintype m] [fintype n]
  [decidable_eq m] [decidable_eq n]
  [linear_ordered_field α] {M : matrix m n α}

/-- Inequality used in the application of Hall. -/
lemma hall (hM : M.doubly_stochastic) (s : finset m) :
  s.card ≤ (s.bUnion (λ i, (M.finsupp.curry i).support)).card :=
let t := s.bUnion (λ i, (M.finsupp.curry i).support) in
nat.cast_le.mp $
  calc (s.card : α)
      = ∑ i in s, 1 :
          by rw [sum_const, nsmul_one]
  ... ≤ ∑ i in s, ∑ j in t, M i j : -- actually an equality but that's not needed
          sum_le_sum $ λ i hi, by {
            rw [← hM.row i, ← sum_filter_ne_zero],
            apply sum_le_sum_of_subset_of_nonneg,
            { intros j hj,
              rw mem_bUnion,
              use [i, hi],
              rw [finsupp.mem_support_iff, curry_finsupp_apply],
              exact (mem_filter.1 hj).2 },
            { intros,
              apply hM.nonneg } }
  ... ≤ ∑ i, ∑ j in t, M i j :
          sum_le_sum_of_subset_of_nonneg (subset_univ _) $
            λ _ _ _, sum_nonneg' $ λ _, hM.nonneg _ _
  ... = t.card :
          by rw sum_comm; simp_rw [hM.col]; rw [sum_const, nsmul_one]

/-- **Birkhoff's theorem** -/
theorem mem_convex_hull (hM : M.doubly_stochastic) :
  M ∈ convex_hull α ((pequiv.to_matrix ∘ equiv.to_pequiv) '' set.univ : set (matrix m n α)) :=
begin
  let e := fintype.equiv_of_card_eq hM.card_eq_card,
  cases (univ : finset m).eq_empty_or_nonempty with hm hm,
  { haveI := univ_eq_empty_iff.mp hm,
    apply subset_convex_hull,
    exact ⟨e, set.mem_univ _, subsingleton.elim _ _⟩ },
  induction hN : M.support.card using nat.strong_induction_on
    with N h_ind generalizing M,
  obtain ⟨c, hc_inj, hc⟩ := (all_card_le_bUnion_card_iff_exists_injective' _).1 hM.hall,
  let σ : m ≃ n := equiv.of_bijective c ⟨hc_inj, hc_inj.surjective_of_fintype e⟩,
  have hσ : ∀ i, M i (σ i) ≠ 0 :=
    λ i, (M.mem_support_curry_finsupp _ _).mp (hc i),
  let x := (univ.image $ λ i, M i (c i)).min' (hm.image _),
  obtain ⟨a, _, ha : M a (σ a) = x⟩ := mem_image.mp (min'_mem _ _),
  have hx_min : ∀ i, x ≤ M i (σ i) :=
    λ i, min'_le _ _ (mem_image.mpr ⟨i, mem_univ _, rfl⟩),
  set M' := M - x • σ.to_pequiv.to_matrix with hM',
  have h1x_nonneg : 0 ≤ 1 - x := ha ▸ sub_nonneg_of_le (hM.le_one _ _),
  by_cases h1x : 1 - x = 0,
  { rw sub_eq_zero at h1x,
    apply subset_convex_hull,
    use [σ, set.mem_univ _],
    show σ.to_pequiv.to_matrix = M,
    ext i j,
    rw [pequiv.to_matrix, equiv.to_pequiv_apply],
    simp_rw [option.mem_some_iff],
    have hi' : M i (σ i) = 1 := le_antisymm (hM.le_one i _) (h1x.symm ▸ hx_min i),
    split_ifs with hij hij,
    { rw [← hij, hi'] },
    { exact (hM.row_eq_zero_of_ne hi' _ hij).symm } },
  have hM_wz : univ.center_mass ![x, 1 - x] ![σ.to_pequiv.to_matrix, (1 - x)⁻¹ • M'] = M,
  { rw [center_mass_eq_of_sum_1],
    all_goals {
      rw fin.sum_univ_two,
      iterate { rw [cons_val_zero, cons_val_one, head_cons] },
      try { rw smul_inv_smul₀ h1x },
      rw add_sub_cancel'_right } },
  rw ← hM_wz,
  apply (convex_convex_hull α _).center_mass_mem,
  { intros i _,
    fin_cases i,
    { rw ← ha,
      apply hM.nonneg },
    { exact h1x_nonneg } },
  { rw fin.sum_univ_two,
    calc 0 < 1 : zero_lt_one
    ... = _ : (add_sub_cancel'_right x _).symm },
  { intros i _,
    fin_cases i,
    { apply subset_convex_hull,
      exact ⟨σ, set.mem_univ _, rfl⟩ },
    show (1 - x)⁻¹ • M' ∈ _,
    refine h_ind _ _ _ rfl,
    { rw [← hN, support_smul_eq (inv_ne_zero h1x)],
      swap, apply_instance,
      apply card_lt_card,
      rw ssubset_iff,
      use [a, σ a],
      rw [insert_subset, subset_iff, not_mem_support_iff, mem_support_iff],
      refine ⟨_, hσ _, _⟩,
      { apply sub_eq_zero_of_eq,
        show _ = x • _,
        rw [pequiv.to_matrix, equiv.to_pequiv_apply],
        simp_rw [option.mem_some_iff],
        rw [if_pos rfl, smul_eq_mul, mul_one, ha] },
      { rintro ⟨i, j⟩ hij,
        rw mem_support_iff at hij ⊢,
        by_cases hj : j = σ i,
        { rw hj,
          apply hσ },
        { change M i j - x • _ ≠ 0 at hij,
          rw [pequiv.to_matrix, equiv.to_pequiv_apply] at hij,
          simp_rw [option.mem_some_iff] at hij,
          rw [if_neg (ne.symm hj), smul_zero, sub_zero] at hij,
          exact hij } } },
    { rw doubly_stochastic_iff,
      split,
      { intros i j,
        apply mul_nonneg (inv_nonneg_of_nonneg h1x_nonneg),
        apply sub_nonneg_of_le,
        show x • _ ≤ _,
        rw [pequiv.to_matrix, equiv.to_pequiv_apply],
        simp_rw [option.mem_some_iff],
        rw [smul_eq_mul, mul_boole],
        split_ifs with hj hj,
        { rw ← hj,
          apply hx_min },
        { apply hM.nonneg } },
      have hσ' := σ.doubly_stochastic α,
      simp_rw [pi.smul_apply, ← smul_sum, hM', pi.sub_apply, pi.smul_apply, sum_sub_distrib,
        ← smul_sum, hσ'.row, hσ'.col, hM.row, hM.col, smul_eq_mul, mul_one, inv_mul_cancel h1x],
      exact ⟨λ _, rfl, λ _, rfl⟩ } }
end

/-- **Birkhoff's theorem**, finset version. -/
theorem mem_convex_hull_finset (hM : M.doubly_stochastic) :
  M ∈ convex_hull α ((univ.image (pequiv.to_matrix ∘ equiv.to_pequiv) :
    finset (matrix m n α)) : set (matrix m n α)) :=
begin
  rw [finset.coe_image, finset.coe_univ],
  exact hM.mem_convex_hull
end

/-- **Birkhoff's theorem**, using a weight function. -/
theorem mem_convex_hull' (hM : M.doubly_stochastic) :
  ∃ c : (m ≃ n) → α,
    (∀ σ, 0 ≤ c σ) ∧
    ∑ σ, c σ = 1 ∧
    M = ∑ σ, c σ • σ.to_pequiv.to_matrix :=
begin
  have := hM.mem_convex_hull_finset,
  rw finset.mem_convex_hull at this,
  rcases this with ⟨c, hc0, hc1, hM'⟩,
  use (c ∘ pequiv.to_matrix ∘ equiv.to_pequiv),
  split,
  { intro σ,
    apply hc0,
    apply mem_image_of_mem,
    exact mem_univ _ },
  split,
  show ∑ (σ : m ≃ n), (c (pequiv.to_matrix (equiv.to_pequiv σ))) = 1,
  rw [← hc1, sum_image],
  swap,
  rw [← hM', center_mass_eq_of_sum_1 _ _ hc1, sum_image],
  refl,
  all_goals {
    intros σ₁ _ σ₂ _ h,
    have := pequiv.to_matrix_injective h,
    rw pequiv.ext_iff at this,
    ext i,
    specialize this i,
    rwa [equiv.to_pequiv_apply, equiv.to_pequiv_apply, option.some_inj] at this }
end

end matrix.doubly_stochastic


/-
Copyright (c) 2019 Neil Strickland.  All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Neil Strickland

This file sets up a version of the Euclidean algorithm that works
only with natural numbers.  Given a, b > 0, it computes the unique
system (w, x, y, z, d) such that the following identities hold:

 w * z = x * y + 1
 a = (w + x) d
 b = (y + z) d

These equations force w, z, d > 0.  They also imply that
the integers a' = w + x = a / d and b' = y + z = b / d are coprime,
and that d is the gcd of a and b.

This story is closely related to the structure of SL₂(ℕ) (as a
free monoid on two generators) and the theory of continued fractions.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ring
import Mathlib.tactic.abel
import Mathlib.data.pnat.prime
import Mathlib.PostPort

universes l

namespace Mathlib

namespace pnat

/-- A term of xgcd_type is a system of six naturals.  They should
 be thought of as representing the matrix
 [[w, x], [y, z]] = [[wp + 1, x], [y, zp + 1]]
 together with the vector [a, b] = [ap + 1, bp + 1].
-/
structure xgcd_type where
  wp : ℕ
  x : ℕ
  y : ℕ
  zp : ℕ
  ap : ℕ
  bp : ℕ

namespace xgcd_type

protected instance has_sizeof : SizeOf xgcd_type := { sizeOf := fun (u : xgcd_type) => bp u }

/-- The has_repr instance converts terms to strings in a way that
 reflects the matrix/vector interpretation as above. -/
protected instance has_repr : has_repr xgcd_type := sorry

def mk' (w : ℕ+) (x : ℕ) (y : ℕ) (z : ℕ+) (a : ℕ+) (b : ℕ+) : xgcd_type :=
  mk (Nat.pred (subtype.val w)) x y (Nat.pred (subtype.val z)) (Nat.pred (subtype.val a))
    (Nat.pred (subtype.val b))

def w (u : xgcd_type) : ℕ+ := nat.succ_pnat (wp u)

def z (u : xgcd_type) : ℕ+ := nat.succ_pnat (zp u)

def a (u : xgcd_type) : ℕ+ := nat.succ_pnat (ap u)

def b (u : xgcd_type) : ℕ+ := nat.succ_pnat (bp u)

def r (u : xgcd_type) : ℕ := (ap u + 1) % (bp u + 1)

def q (u : xgcd_type) : ℕ := (ap u + 1) / (bp u + 1)

def qp (u : xgcd_type) : ℕ := q u - 1

/-- The map v gives the product of the matrix
 [[w, x], [y, z]] = [[wp + 1, x], [y, zp + 1]]
 and the vector [a, b] = [ap + 1, bp + 1].  The map
 vp gives [sp, tp] such that v = [sp + 1, tp + 1].
-/
def vp (u : xgcd_type) : ℕ × ℕ :=
  (wp u + x u + ap u + wp u * ap u + x u * bp u, y u + zp u + bp u + y u * ap u + zp u * bp u)

def v (u : xgcd_type) : ℕ × ℕ := (↑(w u) * ↑(a u) + x u * ↑(b u), y u * ↑(a u) + ↑(z u) * ↑(b u))

def succ₂ (t : ℕ × ℕ) : ℕ × ℕ := (Nat.succ (prod.fst t), Nat.succ (prod.snd t))

theorem v_eq_succ_vp (u : xgcd_type) : v u = succ₂ (vp u) := sorry

/-- is_special holds if the matrix has determinant one. -/
def is_special (u : xgcd_type) := wp u + zp u + wp u * zp u = x u * y u

def is_special' (u : xgcd_type) := w u * z u = nat.succ_pnat (x u * y u)

theorem is_special_iff (u : xgcd_type) : is_special u ↔ is_special' u := sorry

/-- is_reduced holds if the two entries in the vector are the
 same.  The reduction algorithm will produce a system with this
 property, whose product vector is the same as for the original
 system. -/
def is_reduced (u : xgcd_type) := ap u = bp u

def is_reduced' (u : xgcd_type) := a u = b u

theorem is_reduced_iff (u : xgcd_type) : is_reduced u ↔ is_reduced' u :=
  { mp := congr_arg nat.succ_pnat, mpr := nat.succ_pnat_inj }

def flip (u : xgcd_type) : xgcd_type := mk (zp u) (y u) (x u) (wp u) (bp u) (ap u)

@[simp] theorem flip_w (u : xgcd_type) : w (flip u) = z u := rfl

@[simp] theorem flip_x (u : xgcd_type) : x (flip u) = y u := rfl

@[simp] theorem flip_y (u : xgcd_type) : y (flip u) = x u := rfl

@[simp] theorem flip_z (u : xgcd_type) : z (flip u) = w u := rfl

@[simp] theorem flip_a (u : xgcd_type) : a (flip u) = b u := rfl

@[simp] theorem flip_b (u : xgcd_type) : b (flip u) = a u := rfl

theorem flip_is_reduced (u : xgcd_type) : is_reduced (flip u) ↔ is_reduced u :=
  id { mp := fun (h : bp u = ap u) => Eq.symm h, mpr := fun (h : ap u = bp u) => Eq.symm h }

theorem flip_is_special (u : xgcd_type) : is_special (flip u) ↔ is_special u := sorry

theorem flip_v (u : xgcd_type) : v (flip u) = prod.swap (v u) := sorry

/-- Properties of division with remainder for a / b.  -/
theorem rq_eq (u : xgcd_type) : r u + (bp u + 1) * q u = ap u + 1 :=
  nat.mod_add_div (ap u + 1) (bp u + 1)

theorem qp_eq (u : xgcd_type) (hr : r u = 0) : q u = qp u + 1 := sorry

/-- The following function provides the starting point for
 our algorithm.  We will apply an iterative reduction process
 to it, which will produce a system satisfying is_reduced.
 The gcd can be read off from this final system.
-/
def start (a : ℕ+) (b : ℕ+) : xgcd_type := mk 0 0 0 0 (↑a - 1) (↑b - 1)

theorem start_is_special (a : ℕ+) (b : ℕ+) : is_special (start a b) := id (Eq.refl (0 + 0 + 0 * 0))

theorem start_v (a : ℕ+) (b : ℕ+) : v (start a b) = (↑a, ↑b) := sorry

def finish (u : xgcd_type) : xgcd_type :=
  mk (wp u) ((wp u + 1) * qp u + x u) (y u) (y u * qp u + zp u) (bp u) (bp u)

theorem finish_is_reduced (u : xgcd_type) : is_reduced (finish u) := id (Eq.refl (ap (finish u)))

theorem finish_is_special (u : xgcd_type) (hs : is_special u) : is_special (finish u) := sorry

theorem finish_v (u : xgcd_type) (hr : r u = 0) : v (finish u) = v u := sorry

/-- This is the main reduction step, which is used when u.r ≠ 0, or
 equivalently b does not divide a. -/
def step (u : xgcd_type) : xgcd_type :=
  mk (y u * q u + zp u) (y u) ((wp u + 1) * q u + x u) (wp u) (bp u) (r u - 1)

/-- We will apply the above step recursively.  The following result
 is used to ensure that the process terminates. -/
theorem step_wf (u : xgcd_type) (hr : r u ≠ 0) : sizeof (step u) < sizeof u := sorry

theorem step_is_special (u : xgcd_type) (hs : is_special u) : is_special (step u) := sorry

/-- The reduction step does not change the product vector. -/
theorem step_v (u : xgcd_type) (hr : r u ≠ 0) : v (step u) = prod.swap (v u) := sorry

/-- We can now define the full reduction function, which applies
 step as long as possible, and then applies finish. Note that the
 "have" statement puts a fact in the local context, and the
 equation compiler uses this fact to help construct the full
 definition in terms of well-founded recursion.  The same fact
 needs to be introduced in all the inductive proofs of properties
 given below. -/
def reduce : xgcd_type → xgcd_type := sorry

theorem reduce_a {u : xgcd_type} (h : r u = 0) : reduce u = finish u := sorry

theorem reduce_b {u : xgcd_type} (h : r u ≠ 0) : reduce u = flip (reduce (step u)) := sorry

theorem reduce_reduced (u : xgcd_type) : is_reduced (reduce u) := sorry

theorem reduce_reduced' (u : xgcd_type) : is_reduced' (reduce u) :=
  iff.mp (is_reduced_iff (reduce u)) (reduce_reduced u)

theorem reduce_special (u : xgcd_type) : is_special u → is_special (reduce u) := sorry

theorem reduce_special' (u : xgcd_type) (hs : is_special u) : is_special' (reduce u) :=
  iff.mp (is_special_iff (reduce u)) (reduce_special u hs)

theorem reduce_v (u : xgcd_type) : v (reduce u) = v u := sorry

end xgcd_type

def xgcd (a : ℕ+) (b : ℕ+) : xgcd_type := xgcd_type.reduce (xgcd_type.start a b)

def gcd_d (a : ℕ+) (b : ℕ+) : ℕ+ := xgcd_type.a (xgcd a b)

def gcd_w (a : ℕ+) (b : ℕ+) : ℕ+ := xgcd_type.w (xgcd a b)

def gcd_x (a : ℕ+) (b : ℕ+) : ℕ := xgcd_type.x (xgcd a b)

def gcd_y (a : ℕ+) (b : ℕ+) : ℕ := xgcd_type.y (xgcd a b)

def gcd_z (a : ℕ+) (b : ℕ+) : ℕ+ := xgcd_type.z (xgcd a b)

def gcd_a' (a : ℕ+) (b : ℕ+) : ℕ+ :=
  nat.succ_pnat (xgcd_type.wp (xgcd a b) + xgcd_type.x (xgcd a b))

def gcd_b' (a : ℕ+) (b : ℕ+) : ℕ+ :=
  nat.succ_pnat (xgcd_type.y (xgcd a b) + xgcd_type.zp (xgcd a b))

theorem gcd_a'_coe (a : ℕ+) (b : ℕ+) : ↑(gcd_a' a b) = ↑(gcd_w a b) + gcd_x a b := sorry

theorem gcd_b'_coe (a : ℕ+) (b : ℕ+) : ↑(gcd_b' a b) = gcd_y a b + ↑(gcd_z a b) := sorry

theorem gcd_props (a : ℕ+) (b : ℕ+) :
    let d : ℕ+ := gcd_d a b;
      let w : ℕ+ := gcd_w a b;
      let x : ℕ := gcd_x a b;
      let y : ℕ := gcd_y a b;
      let z : ℕ+ := gcd_z a b;
      let a' : ℕ+ := gcd_a' a b;
      let b' : ℕ+ := gcd_b' a b;
      w * z = nat.succ_pnat (x * y) ∧
        a = a' * d ∧
          b = b' * d ∧
            z * a' = nat.succ_pnat (x * ↑b') ∧
              w * b' = nat.succ_pnat (y * ↑a') ∧ ↑z * ↑a = x * ↑b + ↑d ∧ ↑w * ↑b = y * ↑a + ↑d :=
  sorry

theorem gcd_eq (a : ℕ+) (b : ℕ+) : gcd_d a b = gcd a b := sorry

theorem gcd_det_eq (a : ℕ+) (b : ℕ+) :
    gcd_w a b * gcd_z a b = nat.succ_pnat (gcd_x a b * gcd_y a b) :=
  and.left (gcd_props a b)

theorem gcd_a_eq (a : ℕ+) (b : ℕ+) : a = gcd_a' a b * gcd a b :=
  gcd_eq a b ▸ and.left (and.right (gcd_props a b))

theorem gcd_b_eq (a : ℕ+) (b : ℕ+) : b = gcd_b' a b * gcd a b :=
  gcd_eq a b ▸ and.left (and.right (and.right (gcd_props a b)))

theorem gcd_rel_left' (a : ℕ+) (b : ℕ+) :
    gcd_z a b * gcd_a' a b = nat.succ_pnat (gcd_x a b * ↑(gcd_b' a b)) :=
  and.left (and.right (and.right (and.right (gcd_props a b))))

theorem gcd_rel_right' (a : ℕ+) (b : ℕ+) :
    gcd_w a b * gcd_b' a b = nat.succ_pnat (gcd_y a b * ↑(gcd_a' a b)) :=
  and.left (and.right (and.right (and.right (and.right (gcd_props a b)))))

theorem gcd_rel_left (a : ℕ+) (b : ℕ+) : ↑(gcd_z a b) * ↑a = gcd_x a b * ↑b + ↑(gcd a b) :=
  gcd_eq a b ▸ and.left (and.right (and.right (and.right (and.right (and.right (gcd_props a b))))))

theorem gcd_rel_right (a : ℕ+) (b : ℕ+) : ↑(gcd_w a b) * ↑b = gcd_y a b * ↑a + ↑(gcd a b) :=
  gcd_eq a b ▸ and.right (and.right (and.right (and.right (and.right (and.right (gcd_props a b))))))

end Mathlib


theorem impNot {p q : Prop} : p → ¬ q ↔ ¬ (p ∧ q) :=
  ⟨ λ hpq h => hpq h.1 h.2, λ h hp hq => h <| And.intro hp hq ⟩

theorem Exists.impNot {p q : α → Prop} : (∃ x, p x → ¬ q x) ↔ ∃ x, ¬ (p x ∧ q x) := by
  apply Iff.intro
  intro h
  cases h with | intro x hx =>
  { exact ⟨ x, λ hs => hx hs.1 hs.2 ⟩ }
  intro h
  cases h with | intro x hx =>
  { exact ⟨ x, λ hpx hqx => hx <| And.intro hpx hqx ⟩ }

namespace Classical

theorem contrapositive {p q : Prop} : (¬ q → ¬ p) → p → q :=
  λ hqp hp => match em q with
    | Or.inl h => h
    | Or.inr h => False.elim <| hqp h hp

theorem notNot {p : Prop} : ¬ ¬ p ↔ p := by
  apply Iff.intro
  { intro hp; cases em p with
    | inl   => assumption
    | inr h => exact False.elim <| hp h }
  { exact λ hp hnp => False.elim <| hnp hp }

theorem notForall {p : α → Prop} : (¬ ∀ x, p x) → ∃ x, ¬ p x := by
  { apply contrapositive; intro hx; rw [notNot]; intro x;
    cases em (p x); { assumption }
      { apply False.elim <| hx <| Exists.intro x _; assumption } }

theorem notAnd {p q : Prop} : p ∧ ¬ q ↔ ¬ (p → q) := by
  apply Iff.intro
  { exact λ h himp => h.2 <| himp h.1 }
  { intro h; apply And.intro;
    { revert h; apply contrapositive; rw [notNot];
      exact λ hnp hp => False.elim <| hnp hp }
    { exact λ hq => h <| λ _ => hq } }

theorem Exists.notAnd {p q : α → Prop} :
  (∃ x, p x ∧ ¬ q x) ↔ ∃ x, ¬ (p x → q x) := by
  apply Iff.intro
  { intro h;
    let ⟨ x, ⟨ hp, hnq ⟩ ⟩ := h;
    exact Exists.intro x λ h => hnq <| h hp }
  { intro h;
    let ⟨ x, hx ⟩ := h;
    apply Exists.intro x;
    apply And.intro;
    { revert hx; apply contrapositive;
      exact λ hpx hpq => hpq λ hp => False.elim <| hpx hp }
    { intro foo;
      apply hx;
      intro bar;
      assumption; } }

end Classical


open classical
variables (α : Type) (p q : α -> Prop)
variable a : α
variable r : Prop
example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r :=
iff.intro
    (assume hA : (∃ x, p x ∧ r),
        exists.elim hA $
            assume y (h1 : p y ∧ r),
            have hr : r, from and.right h1,
            have h5 : p y, from and.left h1,
            have h6 : ∃ x, p x, from exists.intro y h5,
            show (∃ x, p x) ∧ r, from and.intro h6 hr)
    (assume hB : (∃ x, p x) ∧ r,
        have h1 : (∃ x, p x),from and.left hB,
        have h4 : r, from and.right hB,
        exists.elim h1 $
        assume y (h2 : p y),
        have h5 : p y ∧ r, from and.intro h2 h4,
        show ∃ x, p x ∧ r, from exists.intro y h5)


/-
Copyright (c) 2020 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Patrick Massot
-/
import data.set.intervals.basic
import data.equiv.mul_add
import algebra.pointwise

/-!
# (Pre)images of intervals

In this file we prove a bunch of trivial lemmas like “if we add `a` to all points of `[b, c]`,
then we get `[a + b, a + c]`”. For the functions `x ↦ x ± a`, `x ↦ a ± x`, and `x ↦ -x` we prove
lemmas about preimages and images of all intervals. We also prove a few lemmas about images under
`x ↦ a * x`, `x ↦ x * a` and `x ↦ x⁻¹`.
-/

universe u
open_locale pointwise

namespace set

section has_exists_add_of_le
/-!
The lemmas in this section state that addition maps intervals bijectively. The typeclass
`has_exists_add_of_le` is defined specifically to make them work when combined with
`ordered_cancel_add_comm_monoid`; the lemmas below therefore apply to all
`ordered_add_comm_group`, but also to `ℕ` and `ℝ≥0`, which are not groups.

TODO : move as much as possible in this file to the setting of this weaker typeclass.
-/

variables {α : Type u} [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α] (a b d : α)

lemma Icc_add_bij : bij_on (+d) (Icc a b) (Icc (a + d) (b + d)) :=
begin
  refine ⟨λ _ h, ⟨add_le_add_right h.1 _, add_le_add_right h.2 _⟩,
          λ _ _ _ _ h, add_right_cancel h,
          λ _ h, _⟩,
  obtain ⟨c, rfl⟩ := exists_add_of_le h.1,
  rw [mem_Icc, add_right_comm, add_le_add_iff_right, add_le_add_iff_right] at h,
  exact ⟨a + c, h, by rw add_right_comm⟩,
end

lemma Ioo_add_bij : bij_on (+d) (Ioo a b) (Ioo (a + d) (b + d)) :=
begin
  refine ⟨λ _ h, ⟨add_lt_add_right h.1 _, add_lt_add_right h.2 _⟩,
          λ _ _ _ _ h, add_right_cancel h,
          λ _ h, _⟩,
  obtain ⟨c, rfl⟩ := exists_add_of_le h.1.le,
  rw [mem_Ioo, add_right_comm, add_lt_add_iff_right, add_lt_add_iff_right] at h,
  exact ⟨a + c, h, by rw add_right_comm⟩,
end

lemma Ioc_add_bij : bij_on (+d) (Ioc a b) (Ioc (a + d) (b + d)) :=
begin
  refine ⟨λ _ h, ⟨add_lt_add_right h.1 _, add_le_add_right h.2 _⟩,
          λ _ _ _ _ h, add_right_cancel h,
          λ _ h, _⟩,
  obtain ⟨c, rfl⟩ := exists_add_of_le h.1.le,
  rw [mem_Ioc, add_right_comm, add_lt_add_iff_right, add_le_add_iff_right] at h,
  exact ⟨a + c, h, by rw add_right_comm⟩,
end

lemma Ico_add_bij : bij_on (+d) (Ico a b) (Ico (a + d) (b + d)) :=
begin
  refine ⟨λ _ h, ⟨add_le_add_right h.1 _, add_lt_add_right h.2 _⟩,
          λ _ _ _ _ h, add_right_cancel h,
          λ _ h, _⟩,
  obtain ⟨c, rfl⟩ := exists_add_of_le h.1,
  rw [mem_Ico, add_right_comm, add_le_add_iff_right, add_lt_add_iff_right] at h,
  exact ⟨a + c, h, by rw add_right_comm⟩,
end

lemma Ici_add_bij : bij_on (+d) (Ici a) (Ici (a + d)) :=
begin
  refine ⟨λ x h, add_le_add_right (mem_Ici.mp h) _, λ _ _ _ _ h, add_right_cancel h, λ _ h, _⟩,
  obtain ⟨c, rfl⟩ := exists_add_of_le (mem_Ici.mp h),
  rw [mem_Ici, add_right_comm, add_le_add_iff_right] at h,
  exact ⟨a + c, h, by rw add_right_comm⟩,
end

lemma Ioi_add_bij : bij_on (+d) (Ioi a) (Ioi (a + d)) :=
begin
  refine ⟨λ x h, add_lt_add_right (mem_Ioi.mp h) _, λ _ _ _ _ h, add_right_cancel h, λ _ h, _⟩,
  obtain ⟨c, rfl⟩ := exists_add_of_le (mem_Ioi.mp h).le,
  rw [mem_Ioi, add_right_comm, add_lt_add_iff_right] at h,
  exact ⟨a + c, h, by rw add_right_comm⟩,
end

end has_exists_add_of_le

section ordered_add_comm_group

variables {G : Type u} [ordered_add_comm_group G] (a b c : G)

/-!
### Preimages under `x ↦ a + x`
-/

@[simp] lemma preimage_const_add_Ici : (λ x, a + x) ⁻¹' (Ici b) = Ici (b - a) :=
ext $ λ x, sub_le_iff_le_add'.symm

@[simp] lemma preimage_const_add_Ioi : (λ x, a + x) ⁻¹' (Ioi b) = Ioi (b - a) :=
ext $ λ x, sub_lt_iff_lt_add'.symm

@[simp] lemma preimage_const_add_Iic : (λ x, a + x) ⁻¹' (Iic b) = Iic (b - a) :=
ext $ λ x, le_sub_iff_add_le'.symm

@[simp] lemma preimage_const_add_Iio : (λ x, a + x) ⁻¹' (Iio b) = Iio (b - a) :=
ext $ λ x, lt_sub_iff_add_lt'.symm

@[simp] lemma preimage_const_add_Icc : (λ x, a + x) ⁻¹' (Icc b c) = Icc (b - a) (c - a) :=
by simp [← Ici_inter_Iic]

@[simp] lemma preimage_const_add_Ico : (λ x, a + x) ⁻¹' (Ico b c) = Ico (b - a) (c - a) :=
by simp [← Ici_inter_Iio]

@[simp] lemma preimage_const_add_Ioc : (λ x, a + x) ⁻¹' (Ioc b c) = Ioc (b - a) (c - a) :=
by simp [← Ioi_inter_Iic]

@[simp] lemma preimage_const_add_Ioo : (λ x, a + x) ⁻¹' (Ioo b c) = Ioo (b - a) (c - a) :=
by simp [← Ioi_inter_Iio]

/-!
### Preimages under `x ↦ x + a`
-/

@[simp] lemma preimage_add_const_Ici : (λ x, x + a) ⁻¹' (Ici b) = Ici (b - a) :=
ext $ λ x, sub_le_iff_le_add.symm

@[simp] lemma preimage_add_const_Ioi : (λ x, x + a) ⁻¹' (Ioi b) = Ioi (b - a) :=
ext $ λ x, sub_lt_iff_lt_add.symm

@[simp] lemma preimage_add_const_Iic : (λ x, x + a) ⁻¹' (Iic b) = Iic (b - a) :=
ext $ λ x, le_sub_iff_add_le.symm

@[simp] lemma preimage_add_const_Iio : (λ x, x + a) ⁻¹' (Iio b) = Iio (b - a) :=
ext $ λ x, lt_sub_iff_add_lt.symm

@[simp] lemma preimage_add_const_Icc : (λ x, x + a) ⁻¹' (Icc b c) = Icc (b - a) (c - a) :=
by simp [← Ici_inter_Iic]

@[simp] lemma preimage_add_const_Ico : (λ x, x + a) ⁻¹' (Ico b c) = Ico (b - a) (c - a) :=
by simp [← Ici_inter_Iio]

@[simp] lemma preimage_add_const_Ioc : (λ x, x + a) ⁻¹' (Ioc b c) = Ioc (b - a) (c - a) :=
by simp [← Ioi_inter_Iic]

@[simp] lemma preimage_add_const_Ioo : (λ x, x + a) ⁻¹' (Ioo b c) = Ioo (b - a) (c - a) :=
by simp [← Ioi_inter_Iio]

/-!
### Preimages under `x ↦ -x`
-/

@[simp] lemma preimage_neg_Ici : - Ici a = Iic (-a) := ext $ λ x, le_neg
@[simp] lemma preimage_neg_Iic : - Iic a = Ici (-a) := ext $ λ x, neg_le
@[simp] lemma preimage_neg_Ioi : - Ioi a = Iio (-a) := ext $ λ x, lt_neg
@[simp] lemma preimage_neg_Iio : - Iio a = Ioi (-a) := ext $ λ x, neg_lt

@[simp] lemma preimage_neg_Icc : - Icc a b = Icc (-b) (-a) :=
by simp [← Ici_inter_Iic, inter_comm]

@[simp] lemma preimage_neg_Ico : - Ico a b = Ioc (-b) (-a) :=
by simp [← Ici_inter_Iio, ← Ioi_inter_Iic, inter_comm]

@[simp] lemma preimage_neg_Ioc : - Ioc a b = Ico (-b) (-a) :=
by simp [← Ioi_inter_Iic, ← Ici_inter_Iio, inter_comm]

@[simp] lemma preimage_neg_Ioo : - Ioo a b = Ioo (-b) (-a) :=
by simp [← Ioi_inter_Iio, inter_comm]

/-!
### Preimages under `x ↦ x - a`
-/

@[simp] lemma preimage_sub_const_Ici : (λ x, x - a) ⁻¹' (Ici b) = Ici (b + a) :=
by simp [sub_eq_add_neg]

@[simp] lemma preimage_sub_const_Ioi : (λ x, x - a) ⁻¹' (Ioi b) = Ioi (b + a) :=
by simp [sub_eq_add_neg]

@[simp] lemma preimage_sub_const_Iic : (λ x, x - a) ⁻¹' (Iic b) = Iic (b + a) :=
by simp [sub_eq_add_neg]

@[simp] lemma preimage_sub_const_Iio : (λ x, x - a) ⁻¹' (Iio b) = Iio (b + a) :=
by simp [sub_eq_add_neg]

@[simp] lemma preimage_sub_const_Icc : (λ x, x - a) ⁻¹' (Icc b c) = Icc (b + a) (c + a) :=
by simp [sub_eq_add_neg]

@[simp] lemma preimage_sub_const_Ico : (λ x, x - a) ⁻¹' (Ico b c) = Ico (b + a) (c + a) :=
by simp [sub_eq_add_neg]

@[simp] lemma preimage_sub_const_Ioc : (λ x, x - a) ⁻¹' (Ioc b c) = Ioc (b + a) (c + a) :=
by simp [sub_eq_add_neg]

@[simp] lemma preimage_sub_const_Ioo : (λ x, x - a) ⁻¹' (Ioo b c) = Ioo (b + a) (c + a) :=
by simp [sub_eq_add_neg]

/-!
### Preimages under `x ↦ a - x`
-/

@[simp] lemma preimage_const_sub_Ici : (λ x, a - x) ⁻¹' (Ici b) = Iic (a - b) :=
ext $ λ x, le_sub

@[simp] lemma preimage_const_sub_Iic : (λ x, a - x) ⁻¹' (Iic b) = Ici (a - b) :=
ext $ λ x, sub_le

@[simp] lemma preimage_const_sub_Ioi : (λ x, a - x) ⁻¹' (Ioi b) = Iio (a - b) :=
ext $ λ x, lt_sub

@[simp] lemma preimage_const_sub_Iio : (λ x, a - x) ⁻¹' (Iio b) = Ioi (a - b) :=
ext $ λ x, sub_lt

@[simp] lemma preimage_const_sub_Icc : (λ x, a - x) ⁻¹' (Icc b c) = Icc (a - c) (a - b) :=
by simp [← Ici_inter_Iic, inter_comm]

@[simp] lemma preimage_const_sub_Ico : (λ x, a - x) ⁻¹' (Ico b c) = Ioc (a - c) (a - b) :=
by simp [← Ioi_inter_Iic, ← Ici_inter_Iio, inter_comm]

@[simp] lemma preimage_const_sub_Ioc : (λ x, a - x) ⁻¹' (Ioc b c) = Ico (a - c) (a - b) :=
by simp [← Ioi_inter_Iic, ← Ici_inter_Iio, inter_comm]

@[simp] lemma preimage_const_sub_Ioo : (λ x, a - x) ⁻¹' (Ioo b c) = Ioo (a - c) (a - b) :=
by simp [← Ioi_inter_Iio, inter_comm]

/-!
### Images under `x ↦ a + x`
-/

@[simp] lemma image_const_add_Ici : (λ x, a + x) '' Ici b = Ici (a + b) :=
by simp [add_comm]

@[simp] lemma image_const_add_Iic : (λ x, a + x) '' Iic b = Iic (a + b) :=
by simp [add_comm]

@[simp] lemma image_const_add_Iio : (λ x, a + x) '' Iio b = Iio (a + b) :=
by simp [add_comm]

@[simp] lemma image_const_add_Ioi : (λ x, a + x) '' Ioi b = Ioi (a + b) :=
by simp [add_comm]

@[simp] lemma image_const_add_Icc : (λ x, a + x) '' Icc b c = Icc (a + b) (a + c) :=
by simp [add_comm]

@[simp] lemma image_const_add_Ico : (λ x, a + x) '' Ico b c = Ico (a + b) (a + c) :=
by simp [add_comm]

@[simp] lemma image_const_add_Ioc : (λ x, a + x) '' Ioc b c = Ioc (a + b) (a + c) :=
by simp [add_comm]

@[simp] lemma image_const_add_Ioo : (λ x, a + x) '' Ioo b c = Ioo (a + b) (a + c) :=
by simp [add_comm]

/-!
### Images under `x ↦ x + a`
-/

@[simp] lemma image_add_const_Ici : (λ x, x + a) '' Ici b = Ici (b + a) := by simp
@[simp] lemma image_add_const_Iic : (λ x, x + a) '' Iic b = Iic (b + a) := by simp
@[simp] lemma image_add_const_Iio : (λ x, x + a) '' Iio b = Iio (b + a) := by simp
@[simp] lemma image_add_const_Ioi : (λ x, x + a) '' Ioi b = Ioi (b + a) := by simp

@[simp] lemma image_add_const_Icc : (λ x, x + a) '' Icc b c = Icc (b + a) (c + a) :=
by simp

@[simp] lemma image_add_const_Ico : (λ x, x + a) '' Ico b c = Ico (b + a) (c + a) :=
by simp

@[simp] lemma image_add_const_Ioc : (λ x, x + a) '' Ioc b c = Ioc (b + a) (c + a) :=
by simp

@[simp] lemma image_add_const_Ioo : (λ x, x + a) '' Ioo b c = Ioo (b + a) (c + a) :=
by simp

/-!
### Images under `x ↦ -x`
-/

lemma image_neg_Ici : has_neg.neg '' (Ici a) = Iic (-a) := by simp
lemma image_neg_Iic : has_neg.neg '' (Iic a) = Ici (-a) := by simp
lemma image_neg_Ioi : has_neg.neg '' (Ioi a) = Iio (-a) := by simp
lemma image_neg_Iio : has_neg.neg '' (Iio a) = Ioi (-a) := by simp
lemma image_neg_Icc : has_neg.neg '' (Icc a b) = Icc (-b) (-a) := by simp
lemma image_neg_Ico : has_neg.neg '' (Ico a b) = Ioc (-b) (-a) := by simp
lemma image_neg_Ioc : has_neg.neg '' (Ioc a b) = Ico (-b) (-a) := by simp
lemma image_neg_Ioo : has_neg.neg '' (Ioo a b) = Ioo (-b) (-a) := by simp

/-!
### Images under `x ↦ a - x`
-/

@[simp] lemma image_const_sub_Ici : (λ x, a - x) '' Ici b = Iic (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

@[simp] lemma image_const_sub_Iic : (λ x, a - x) '' Iic b = Ici (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

@[simp] lemma image_const_sub_Ioi : (λ x, a - x) '' Ioi b = Iio (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

@[simp] lemma image_const_sub_Iio : (λ x, a - x) '' Iio b = Ioi (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

@[simp] lemma image_const_sub_Icc : (λ x, a - x) '' Icc b c = Icc (a - c) (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

@[simp] lemma image_const_sub_Ico : (λ x, a - x) '' Ico b c = Ioc (a - c) (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

@[simp] lemma image_const_sub_Ioc : (λ x, a - x) '' Ioc b c = Ico (a - c) (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

@[simp] lemma image_const_sub_Ioo : (λ x, a - x) '' Ioo b c = Ioo (a - c) (a - b) :=
by simp [sub_eq_add_neg, image_comp (λ x, a + x) (λ x, -x)]

/-!
### Images under `x ↦ x - a`
-/

@[simp] lemma image_sub_const_Ici : (λ x, x - a) '' Ici b = Ici (b - a) := by simp [sub_eq_neg_add]
@[simp] lemma image_sub_const_Iic : (λ x, x - a) '' Iic b = Iic (b - a) := by simp [sub_eq_neg_add]
@[simp] lemma image_sub_const_Ioi : (λ x, x - a) '' Ioi b = Ioi (b - a) := by simp [sub_eq_neg_add]
@[simp] lemma image_sub_const_Iio : (λ x, x - a) '' Iio b = Iio (b - a) := by simp [sub_eq_neg_add]

@[simp] lemma image_sub_const_Icc : (λ x, x - a) '' Icc b c = Icc (b - a) (c - a) :=
by simp [sub_eq_neg_add]

@[simp] lemma image_sub_const_Ico : (λ x, x - a) '' Ico b c = Ico (b - a) (c - a) :=
by simp [sub_eq_neg_add]

@[simp] lemma image_sub_const_Ioc : (λ x, x - a) '' Ioc b c = Ioc (b - a) (c - a) :=
by simp [sub_eq_neg_add]

@[simp] lemma image_sub_const_Ioo : (λ x, x - a) '' Ioo b c = Ioo (b - a) (c - a) :=
by simp [sub_eq_neg_add]

/-!
### Bijections
-/

lemma Iic_add_bij : bij_on (+a) (Iic b) (Iic (b + a)) :=
begin
  refine ⟨λ x h, add_le_add_right (mem_Iic.mp h) _, λ _ _ _ _ h, add_right_cancel h, λ _ h, _⟩,
  simpa [add_comm a] using h,
end

lemma Iio_add_bij : bij_on (+a) (Iio b) (Iio (b + a)) :=
begin
  refine ⟨λ x h, add_lt_add_right (mem_Iio.mp h) _, λ _ _ _ _ h, add_right_cancel h, λ _ h, _⟩,
  simpa [add_comm a] using h,
end

end ordered_add_comm_group

/-!
### Multiplication and inverse in a field
-/

section linear_ordered_field

variables {k : Type u} [linear_ordered_field k]

@[simp] lemma preimage_mul_const_Iio (a : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Iio a) = Iio (a / c) :=
ext $ λ x, (lt_div_iff h).symm

@[simp] lemma preimage_mul_const_Ioi (a : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Ioi a) = Ioi (a / c) :=
ext $ λ x, (div_lt_iff h).symm

@[simp] lemma preimage_mul_const_Iic (a : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Iic a) = Iic (a / c) :=
ext $ λ x, (le_div_iff h).symm

@[simp] lemma preimage_mul_const_Ici (a : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Ici a) = Ici (a / c) :=
ext $ λ x, (div_le_iff h).symm

@[simp] lemma preimage_mul_const_Ioo (a b : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Ioo a b) = Ioo (a / c) (b / c) :=
by simp [← Ioi_inter_Iio, h]

@[simp] lemma preimage_mul_const_Ioc (a b : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Ioc a b) = Ioc (a / c) (b / c) :=
by simp [← Ioi_inter_Iic, h]

@[simp] lemma preimage_mul_const_Ico (a b : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Ico a b) = Ico (a / c) (b / c) :=
by simp [← Ici_inter_Iio, h]

@[simp] lemma preimage_mul_const_Icc (a b : k) {c : k} (h : 0 < c) :
  (λ x, x * c) ⁻¹' (Icc a b) = Icc (a / c) (b / c) :=
by simp [← Ici_inter_Iic, h]

@[simp] lemma preimage_mul_const_Iio_of_neg (a : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Iio a) = Ioi (a / c) :=
ext $ λ x, (div_lt_iff_of_neg h).symm

@[simp] lemma preimage_mul_const_Ioi_of_neg (a : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Ioi a) = Iio (a / c) :=
ext $ λ x, (lt_div_iff_of_neg h).symm

@[simp] lemma preimage_mul_const_Iic_of_neg (a : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Iic a) = Ici (a / c) :=
ext $ λ x, (div_le_iff_of_neg h).symm

@[simp] lemma preimage_mul_const_Ici_of_neg (a : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Ici a) = Iic (a / c) :=
ext $ λ x, (le_div_iff_of_neg h).symm

@[simp] lemma preimage_mul_const_Ioo_of_neg (a b : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Ioo a b) = Ioo (b / c) (a / c) :=
by simp [← Ioi_inter_Iio, h, inter_comm]

@[simp] lemma preimage_mul_const_Ioc_of_neg (a b : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Ioc a b) = Ico (b / c) (a / c) :=
by simp [← Ioi_inter_Iic, ← Ici_inter_Iio, h, inter_comm]

@[simp] lemma preimage_mul_const_Ico_of_neg (a b : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Ico a b) = Ioc (b / c) (a / c) :=
by simp [← Ici_inter_Iio, ← Ioi_inter_Iic, h, inter_comm]

@[simp] lemma preimage_mul_const_Icc_of_neg (a b : k) {c : k} (h : c < 0) :
  (λ x, x * c) ⁻¹' (Icc a b) = Icc (b / c) (a / c) :=
by simp [← Ici_inter_Iic, h, inter_comm]

@[simp] lemma preimage_const_mul_Iio (a : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Iio a) = Iio (a / c) :=
ext $ λ x, (lt_div_iff' h).symm

@[simp] lemma preimage_const_mul_Ioi (a : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Ioi a) = Ioi (a / c) :=
ext $ λ x, (div_lt_iff' h).symm

@[simp] lemma preimage_const_mul_Iic (a : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Iic a) = Iic (a / c) :=
ext $ λ x, (le_div_iff' h).symm

@[simp] lemma preimage_const_mul_Ici (a : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Ici a) = Ici (a / c) :=
ext $ λ x, (div_le_iff' h).symm

@[simp] lemma preimage_const_mul_Ioo (a b : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Ioo a b) = Ioo (a / c) (b / c) :=
by simp [← Ioi_inter_Iio, h]

@[simp] lemma preimage_const_mul_Ioc (a b : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Ioc a b) = Ioc (a / c) (b / c) :=
by simp [← Ioi_inter_Iic, h]

@[simp] lemma preimage_const_mul_Ico (a b : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Ico a b) = Ico (a / c) (b / c) :=
by simp [← Ici_inter_Iio, h]

@[simp] lemma preimage_const_mul_Icc (a b : k) {c : k} (h : 0 < c) :
  ((*) c) ⁻¹' (Icc a b) = Icc (a / c) (b / c) :=
by simp [← Ici_inter_Iic, h]

@[simp] lemma preimage_const_mul_Iio_of_neg (a : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Iio a) = Ioi (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Iio_of_neg a h

@[simp] lemma preimage_const_mul_Ioi_of_neg (a : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Ioi a) = Iio (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Ioi_of_neg a h

@[simp] lemma preimage_const_mul_Iic_of_neg (a : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Iic a) = Ici (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Iic_of_neg a h

@[simp] lemma preimage_const_mul_Ici_of_neg (a : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Ici a) = Iic (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Ici_of_neg a h

@[simp] lemma preimage_const_mul_Ioo_of_neg (a b : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Ioo a b) = Ioo (b / c) (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Ioo_of_neg a b h

@[simp] lemma preimage_const_mul_Ioc_of_neg (a b : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Ioc a b) = Ico (b / c) (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Ioc_of_neg a b h

@[simp] lemma preimage_const_mul_Ico_of_neg (a b : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Ico a b) = Ioc (b / c) (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Ico_of_neg a b h

@[simp] lemma preimage_const_mul_Icc_of_neg (a b : k) {c : k} (h : c < 0) :
  ((*) c) ⁻¹' (Icc a b) = Icc (b / c) (a / c) :=
by simpa only [mul_comm] using preimage_mul_const_Icc_of_neg a b h

lemma image_mul_right_Icc' (a b : k) {c : k} (h : 0 < c) :
  (λ x, x * c) '' Icc a b = Icc (a * c) (b * c) :=
((units.mk0 c h.ne').mul_right.image_eq_preimage _).trans (by simp [h, division_def])

lemma image_mul_right_Icc {a b c : k} (hab : a ≤ b) (hc : 0 ≤ c) :
  (λ x, x * c) '' Icc a b = Icc (a * c) (b * c) :=
begin
  cases eq_or_lt_of_le hc,
  { subst c,
    simp [(nonempty_Icc.2 hab).image_const] },
  exact image_mul_right_Icc' a b ‹0 < c›
end

lemma image_mul_left_Icc' {a : k} (h : 0 < a) (b c : k) :
  ((*) a) '' Icc b c = Icc (a * b) (a * c) :=
by { convert image_mul_right_Icc' b c h using 1; simp only [mul_comm _ a] }

lemma image_mul_left_Icc {a b c : k} (ha : 0 ≤ a) (hbc : b ≤ c) :
  ((*) a) '' Icc b c = Icc (a * b) (a * c) :=
by { convert image_mul_right_Icc hbc ha using 1; simp only [mul_comm _ a] }

lemma image_mul_right_Ioo (a b : k) {c : k} (h : 0 < c) :
  (λ x, x * c) '' Ioo a b = Ioo (a * c) (b * c) :=
((units.mk0 c h.ne').mul_right.image_eq_preimage _).trans (by simp [h, division_def])

lemma image_mul_left_Ioo {a : k} (h : 0 < a) (b c : k) :
  ((*) a) '' Ioo b c = Ioo (a * b) (a * c) :=
by { convert image_mul_right_Ioo b c h using 1; simp only [mul_comm _ a] }

/-- The image under `inv` of `Ioo 0 a` is `Ioi a⁻¹`. -/
lemma image_inv_Ioo_0_left {a : k} (ha : 0 < a) : has_inv.inv '' Ioo 0 a = Ioi a⁻¹ :=
begin
  ext x,
  exact ⟨λ ⟨y, ⟨hy0, hya⟩, hyx⟩, hyx ▸ (inv_lt_inv ha hy0).2 hya, λ h, ⟨x⁻¹, ⟨inv_pos.2 (lt_trans
    (inv_pos.2 ha) h), (inv_lt ha (lt_trans (inv_pos.2 ha) h)).1 h⟩, inv_inv₀ x⟩⟩,
end

/-!
### Images under `x ↦ a * x + b`
-/

@[simp] lemma image_affine_Icc' {a : k} (h : 0 < a) (b c d : k) :
  (λ x, a * x + b) '' Icc c d = Icc (a * c + b) (a * d + b) :=
begin
  suffices : (λ x, x + b) '' ((λ x, a * x) '' Icc c d) = Icc (a * c + b) (a * d + b),
  { rwa set.image_image at this, },
  rw [image_mul_left_Icc' h, image_add_const_Icc],
end

end linear_ordered_field
end set


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

! This file was ported from Lean 3 source module data.finsupp.fin
! leanprover-community/mathlib commit f7fc89d5d5ff1db2d1242c7bb0e9062ce47ef47c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Finsupp.Defs

/-!
# `cons` and `tail` for maps `Fin n →₀ M`

We interpret maps `Fin n →₀ M` as `n`-tuples of elements of `M`,
We define the following operations:
* `Finsupp.tail` : the tail of a map `Fin (n + 1) →₀ M`, i.e., its last `n` entries;
* `Finsupp.cons` : adding an element at the beginning of an `n`-tuple, to get an `n + 1`-tuple;

In this context, we prove some usual properties of `tail` and `cons`, analogous to those of
`Data.Fin.Tuple.Basic`.
-/

noncomputable section

namespace Finsupp

variable {n : ℕ} (i : Fin n) {M : Type _} [Zero M] (y : M) (t : Fin (n + 1) →₀ M) (s : Fin n →₀ M)

/-- `tail` for maps `Fin (n + 1) →₀ M`. See `Fin.tail` for more details. -/
def tail (s : Fin (n + 1) →₀ M) : Fin n →₀ M :=
  Finsupp.equivFunOnFinite.symm (Fin.tail s)
#align finsupp.tail Finsupp.tail

/-- `cons` for maps `Fin n →₀ M`. See `Fin.cons` for more details. -/
def cons (y : M) (s : Fin n →₀ M) : Fin (n + 1) →₀ M :=
  Finsupp.equivFunOnFinite.symm (Fin.cons y s : Fin (n + 1) → M)
#align finsupp.cons Finsupp.cons

theorem tail_apply : tail t i = t i.succ :=
  rfl
#align finsupp.tail_apply Finsupp.tail_apply

@[simp]
theorem cons_zero : cons y s 0 = y :=
  rfl
#align finsupp.cons_zero Finsupp.cons_zero

@[simp]
theorem cons_succ : cons y s i.succ = s i :=
  -- porting notes: was Fin.cons_succ _ _ _
  rfl
#align finsupp.cons_succ Finsupp.cons_succ

@[simp]
theorem tail_cons : tail (cons y s) = s :=
  ext fun k => by simp only [tail_apply, cons_succ]
#align finsupp.tail_cons Finsupp.tail_cons

@[simp]
theorem cons_tail : cons (t 0) (tail t) = t := by
  ext a
  by_cases c_a : a = 0
  · rw [c_a, cons_zero]
  · rw [← Fin.succ_pred a c_a, cons_succ, ← tail_apply]
#align finsupp.cons_tail Finsupp.cons_tail

@[simp]
theorem cons_zero_zero : cons 0 (0 : Fin n →₀ M) = 0 := by
  ext a
  by_cases c : a = 0
  · simp [c]
  · rw [← Fin.succ_pred a c, cons_succ]
    simp
#align finsupp.cons_zero_zero Finsupp.cons_zero_zero

variable {s} {y}

theorem cons_ne_zero_of_left (h : y ≠ 0) : cons y s ≠ 0 := by
  contrapose! h with c
  rw [← cons_zero y s, c, Finsupp.coe_zero, Pi.zero_apply]
#align finsupp.cons_ne_zero_of_left Finsupp.cons_ne_zero_of_left

theorem cons_ne_zero_of_right (h : s ≠ 0) : cons y s ≠ 0 := by
  contrapose! h with c
  ext a
  simp [← cons_succ a y s, c]
#align finsupp.cons_ne_zero_of_right Finsupp.cons_ne_zero_of_right

theorem cons_ne_zero_iff : cons y s ≠ 0 ↔ y ≠ 0 ∨ s ≠ 0 := by
  refine' ⟨fun h => _, fun h => h.casesOn cons_ne_zero_of_left cons_ne_zero_of_right⟩
  refine' imp_iff_not_or.1 fun h' c => h _
  rw [h', c, Finsupp.cons_zero_zero]
#align finsupp.cons_ne_zero_iff Finsupp.cons_ne_zero_iff

end Finsupp


import .love02_backward_proofs_exercise_sheet

/-! # LoVe Homework 2: Backward Proofs

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

namespace backward_proofs

/-! ## Question 1 (4 points): Connectives and Quantifiers

1.1 (3 points). Complete the following proofs using basic tactics such as
`intro`, `apply`, and `exact`.

Hint: Some strategies for carrying out such proofs are described at the end of
Section 2.3 in the Hitchhiker's Guide. -/

lemma B (a b c : Prop) :
  (a → b) → (c → a) → c → b :=
begin
  intros hg hf hc,
  apply hg,
  apply hf,
  exact hc
end

lemma S (a b c : Prop) :
  (a → b → c) → (a → b) → a → c :=
begin
  intros hg hf ha,
  apply hg,
  exact ha,
  apply hf,
  exact ha
end

lemma more_nonsense (a b c : Prop) :
  (c → (a → b) → a) → c → b → a :=
begin
  intros hf hc hb,
  apply hf,
  { exact hc },
  { intro ha,
    exact hb }
end

lemma even_more_nonsense (a b c : Prop) :
  (a → a → b) → (b → c) → a → b → c :=
begin
  intros hf hg ha hb,
  apply hg,
  exact hb
end

/-! 1.2 (1 point). Prove the following lemma using basic tactics. -/

lemma weak_peirce (a b : Prop) :
  ((((a → b) → a) → a) → b) → b :=
begin
  intro hf,
  apply hf,
  intro hg,
  apply hg,
  intro ha,
  apply hf,
  intro hh,
  exact ha
end

/-! ## Question 2 (5 points): Logical Connectives

2.1 (1 point). Prove the following property about implication using basic
tactics.

Hints:

* Keep in mind that `¬ a` is the same as `a → false`. You can start by invoking
  `rw not_def` if this helps you.

* You will need to apply the elimination rules for `∨` and `false` at some
  point. -/

lemma about_implication (a b : Prop) :
  ¬ a ∨ b → a → b :=
begin
  rw not_def,
  intros hor ha,
  apply or.elim hor,
  { intro hna,
    apply false.elim,
    apply hna,
    exact ha },
  { intro hb,
    exact hb }
end

/-! 2.2 (2 points). Prove the missing link in our chain of classical axiom
implications.

Hints:

* You can use `rw double_negation` to unfold the definition of
  `double_negation`, and similarly for the other definitions.

* You will need to apply the double negation hypothesis for `a ∨ ¬ a`. You will
  also need the left and right introduction rules for `∨` at some point. -/

#check excluded_middle
#check peirce
#check double_negation

lemma em_of_dn :
  double_negation → excluded_middle :=
begin
  rw double_negation,
  rw excluded_middle,
  intros hdoubleneg a,
  apply hdoubleneg,
  intro hnaona,
  apply hnaona,
  apply or.intro_right,
  intro hna,
  apply hnaona,
  apply or.intro_left,
  assumption
end

/-! 2.3 (2 points). We have proved three of the six possible implications
between `excluded_middle`, `peirce`, and `double_negation`. State and prove the
three missing implications, exploiting the three theorems we already have. -/

#check peirce_of_em
#check dn_of_peirce
#check em_of_dn

lemma peirce_of_dn :
  double_negation → peirce :=
begin
  intro h,
  apply peirce_of_em,
  apply em_of_dn,
  exact h
end

lemma em_of_peirce :
  peirce → excluded_middle :=
begin
  intro h,
  apply em_of_dn,
  apply dn_of_peirce,
  exact h
end

lemma dn_of_em :
  excluded_middle → double_negation :=
begin
  intro h,
  apply dn_of_peirce,
  apply peirce_of_em,
  exact h
end

end backward_proofs

end LoVe


/-
Copyright (c) 2019 Minchao Wu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Minchao Wu, Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Minimum and maximum of lists

## Main definitions

The main definitions are `argmax`, `argmin`, `minimum` and `maximum` for lists.

`argmax f l` returns `some a`, where `a` of `l` that maximises `f a`. If there are `a b` such that
  `f a = f b`, it returns whichever of `a` or `b` comes first in the list.
  `argmax f []` = none`

`minimum l` returns an `with_top α`, the smallest element of `l` for nonempty lists, and `⊤` for
`[]`
-/

namespace list

/-- Auxiliary definition to define `argmax` -/
def argmax₂ {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (a : Option α) (b : α) : Option α :=
  option.cases_on a (some b) fun (c : α) => ite (f b ≤ f c) (some c) (some b)

/-- `argmax f l` returns `some a`, where `a` of `l` that maximises `f a`. If there are `a b` such
that `f a = f b`, it returns whichever of `a` or `b` comes first in the list.
`argmax f []` = none` -/
def argmax {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (l : List α) : Option α :=
  foldl (argmax₂ f) none l

/-- `argmin f l` returns `some a`, where `a` of `l` that minimises `f a`. If there are `a b` such
that `f a = f b`, it returns whichever of `a` or `b` comes first in the list.
`argmin f []` = none` -/
def argmin {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (l : List α) : Option α :=
  argmax f l

@[simp] theorem argmax_two_self {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (a : α) : argmax₂ f (some a) a = ↑a :=
  if_pos (le_refl (f a))

@[simp] theorem argmax_nil {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) : argmax f [] = none :=
  rfl

@[simp] theorem argmin_nil {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) : argmin f [] = none :=
  rfl

@[simp] theorem argmax_singleton {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {a : α} : argmax f [a] = some a :=
  rfl

@[simp] theorem argmin_singleton {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {a : α} : argmin f [a] = ↑a :=
  rfl

@[simp] theorem foldl_argmax₂_eq_none {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {l : List α} {o : Option α} : foldl (argmax₂ f) o l = none ↔ l = [] ∧ o = none := sorry

theorem argmax_mem {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {l : List α} {m : α} : m ∈ argmax f l → m ∈ l := sorry

theorem argmin_mem {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {l : List α} {m : α} : m ∈ argmin f l → m ∈ l :=
  argmax_mem

@[simp] theorem argmax_eq_none {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {l : List α} : argmax f l = none ↔ l = [] := sorry

@[simp] theorem argmin_eq_none {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {l : List α} : argmin f l = none ↔ l = [] :=
  argmax_eq_none

theorem le_argmax_of_mem {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {a : α} {m : α} {l : List α} : a ∈ l → m ∈ argmax f l → f a ≤ f m :=
  le_of_foldl_argmax₂

theorem argmin_le_of_mem {α : Type u_1} {β : Type u_2} [linear_order β] {f : α → β} {a : α} {m : α} {l : List α} : a ∈ l → m ∈ argmin f l → f m ≤ f a :=
  le_argmax_of_mem

theorem argmax_concat {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (a : α) (l : List α) : argmax f (l ++ [a]) = option.cases_on (argmax f l) (some a) fun (c : α) => ite (f a ≤ f c) (some c) (some a) := sorry

theorem argmin_concat {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (a : α) (l : List α) : argmin f (l ++ [a]) = option.cases_on (argmin f l) (some a) fun (c : α) => ite (f c ≤ f a) (some c) (some a) :=
  argmax_concat f a l

theorem argmax_cons {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (a : α) (l : List α) : argmax f (a :: l) = option.cases_on (argmax f l) (some a) fun (c : α) => ite (f c ≤ f a) (some a) (some c) := sorry

theorem argmin_cons {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) (a : α) (l : List α) : argmin f (a :: l) = option.cases_on (argmin f l) (some a) fun (c : α) => ite (f a ≤ f c) (some a) (some c) :=
  argmax_cons f a l

theorem index_of_argmax {α : Type u_1} {β : Type u_2} [linear_order β] [DecidableEq α] {f : α → β} {l : List α} {m : α} : m ∈ argmax f l → ∀ {a : α}, a ∈ l → f m ≤ f a → index_of m l ≤ index_of a l := sorry

theorem index_of_argmin {α : Type u_1} {β : Type u_2} [linear_order β] [DecidableEq α] {f : α → β} {l : List α} {m : α} : m ∈ argmin f l → ∀ {a : α}, a ∈ l → f a ≤ f m → index_of m l ≤ index_of a l :=
  index_of_argmax

theorem mem_argmax_iff {α : Type u_1} {β : Type u_2} [linear_order β] [DecidableEq α] {f : α → β} {m : α} {l : List α} : m ∈ argmax f l ↔ m ∈ l ∧ (∀ (a : α), a ∈ l → f a ≤ f m) ∧ ∀ (a : α), a ∈ l → f m ≤ f a → index_of m l ≤ index_of a l := sorry

theorem argmax_eq_some_iff {α : Type u_1} {β : Type u_2} [linear_order β] [DecidableEq α] {f : α → β} {m : α} {l : List α} : argmax f l = some m ↔
  m ∈ l ∧ (∀ (a : α), a ∈ l → f a ≤ f m) ∧ ∀ (a : α), a ∈ l → f m ≤ f a → index_of m l ≤ index_of a l :=
  mem_argmax_iff

theorem mem_argmin_iff {α : Type u_1} {β : Type u_2} [linear_order β] [DecidableEq α] {f : α → β} {m : α} {l : List α} : m ∈ argmin f l ↔ m ∈ l ∧ (∀ (a : α), a ∈ l → f m ≤ f a) ∧ ∀ (a : α), a ∈ l → f a ≤ f m → index_of m l ≤ index_of a l :=
  mem_argmax_iff

theorem argmin_eq_some_iff {α : Type u_1} {β : Type u_2} [linear_order β] [DecidableEq α] {f : α → β} {m : α} {l : List α} : argmin f l = some m ↔
  m ∈ l ∧ (∀ (a : α), a ∈ l → f m ≤ f a) ∧ ∀ (a : α), a ∈ l → f a ≤ f m → index_of m l ≤ index_of a l :=
  mem_argmin_iff

/-- `maximum l` returns an `with_bot α`, the largest element of `l` for nonempty lists, and `⊥` for
`[]`  -/
def maximum {α : Type u_1} [linear_order α] (l : List α) : with_bot α :=
  argmax id l

/-- `minimum l` returns an `with_top α`, the smallest element of `l` for nonempty lists, and `⊤` for
`[]`  -/
def minimum {α : Type u_1} [linear_order α] (l : List α) : with_top α :=
  argmin id l

@[simp] theorem maximum_nil {α : Type u_1} [linear_order α] : maximum [] = ⊥ :=
  rfl

@[simp] theorem minimum_nil {α : Type u_1} [linear_order α] : minimum [] = ⊤ :=
  rfl

@[simp] theorem maximum_singleton {α : Type u_1} [linear_order α] (a : α) : maximum [a] = ↑a :=
  rfl

@[simp] theorem minimum_singleton {α : Type u_1} [linear_order α] (a : α) : minimum [a] = ↑a :=
  rfl

theorem maximum_mem {α : Type u_1} [linear_order α] {l : List α} {m : α} : maximum l = ↑m → m ∈ l :=
  argmax_mem

theorem minimum_mem {α : Type u_1} [linear_order α] {l : List α} {m : α} : minimum l = ↑m → m ∈ l :=
  argmin_mem

@[simp] theorem maximum_eq_none {α : Type u_1} [linear_order α] {l : List α} : maximum l = none ↔ l = [] :=
  argmax_eq_none

@[simp] theorem minimum_eq_none {α : Type u_1} [linear_order α] {l : List α} : minimum l = none ↔ l = [] :=
  argmin_eq_none

theorem le_maximum_of_mem {α : Type u_1} [linear_order α] {a : α} {m : α} {l : List α} : a ∈ l → maximum l = ↑m → a ≤ m :=
  le_argmax_of_mem

theorem minimum_le_of_mem {α : Type u_1} [linear_order α] {a : α} {m : α} {l : List α} : a ∈ l → minimum l = ↑m → m ≤ a :=
  argmin_le_of_mem

theorem le_maximum_of_mem' {α : Type u_1} [linear_order α] {a : α} {l : List α} (ha : a ∈ l) : ↑a ≤ maximum l := sorry

theorem le_minimum_of_mem' {α : Type u_1} [linear_order α] {a : α} {l : List α} (ha : a ∈ l) : minimum l ≤ ↑a :=
  le_maximum_of_mem' ha

theorem maximum_concat {α : Type u_1} [linear_order α] (a : α) (l : List α) : maximum (l ++ [a]) = max (maximum l) ↑a := sorry

theorem minimum_concat {α : Type u_1} [linear_order α] (a : α) (l : List α) : minimum (l ++ [a]) = min (minimum l) ↑a :=
  maximum_concat a l

theorem maximum_cons {α : Type u_1} [linear_order α] (a : α) (l : List α) : maximum (a :: l) = max (↑a) (maximum l) := sorry

theorem minimum_cons {α : Type u_1} [linear_order α] (a : α) (l : List α) : minimum (a :: l) = min (↑a) (minimum l) :=
  maximum_cons a l

theorem maximum_eq_coe_iff {α : Type u_1} [linear_order α] {m : α} {l : List α} : maximum l = ↑m ↔ m ∈ l ∧ ∀ (a : α), a ∈ l → a ≤ m := sorry

theorem minimum_eq_coe_iff {α : Type u_1} [linear_order α] {m : α} {l : List α} : minimum l = ↑m ↔ m ∈ l ∧ ∀ (a : α), a ∈ l → m ≤ a :=
  maximum_eq_coe_iff


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

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_101
  (x : ℝ)
  (h₀ : x^2 - 5 * x - 4 ≤ 10) :
  x ≥ -2 ∧ x ≤ 7 :=
begin
  split; nlinarith,
end


lemma add_assoc' {α : Type} [add_semigroup α] :
  ∀ (a b c : α), a + (b + c) = a + b + c :=
begin
  intros a b c, rewrite add_assoc
end

lemma mul_assoc' {α : Type} [comm_semigroup α] :
  ∀ (a b c : α), a * (b * c) = a * b * c :=
begin
  intros a b c, rewrite mul_assoc
end

#check add_right_comm
lemma mul_comm_assoc {α : Type} [comm_semigroup α] :
  ∀ a b c : α, (a * b) * c = (a * c) * b :=
begin
  intros a b c, rewrite mul_assoc,
  rewrite mul_comm b c,
  rewrite mul_assoc
end

lemma mul_add_mul_add {α : Type} [ring α] (t c x d : α) :
  (t + c * x) + (d * x)  = t + ((c + d) * x) :=
begin
  rewrite add_assoc,
  rewrite add_mul
end


/-
Copyright (c) 2022 Moritz Doll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll
-/
import analysis.locally_convex.basic
import topology.bornology.basic
import topology.algebra.uniform_group
import analysis.locally_convex.balanced_core_hull

/-!
# Von Neumann Boundedness

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

## Main declarations

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

## Main results

* `bornology.is_vonN_bounded_of_topological_space_le`: A coarser topology admits more
von Neumann-bounded sets.

## References

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

-/

variables {𝕜 E ι : Type*}

open_locale topological_space pointwise

namespace bornology

section semi_normed_ring

section has_zero

variables (𝕜)
variables [semi_normed_ring 𝕜] [has_scalar 𝕜 E] [has_zero E]
variables [topological_space E]

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

variables (E)

@[simp] lemma is_vonN_bounded_empty : is_vonN_bounded 𝕜 (∅ : set E) :=
λ _ _, absorbs_empty

variables {𝕜 E}

lemma is_vonN_bounded_iff (s : set E) : is_vonN_bounded 𝕜 s ↔ ∀ V ∈ 𝓝 (0 : E), absorbs 𝕜 V s :=
iff.rfl

lemma _root_.filter.has_basis.is_vonN_bounded_basis_iff {q : ι → Prop} {s : ι → set E} {A : set E}
  (h : (𝓝 (0 : E)).has_basis q s) :
  is_vonN_bounded 𝕜 A ↔ ∀ i (hi : q i), absorbs 𝕜 (s i) A :=
begin
  refine ⟨λ hA i hi, hA (h.mem_of_mem hi), λ hA V hV, _⟩,
  rcases h.mem_iff.mp hV with ⟨i, hi, hV⟩,
  exact (hA i hi).mono_left hV,
end

/-- Subsets of bounded sets are bounded. -/
lemma is_vonN_bounded.subset {s₁ s₂ : set E} (h : s₁ ⊆ s₂) (hs₂ : is_vonN_bounded 𝕜 s₂) :
  is_vonN_bounded 𝕜 s₁ :=
λ V hV, (hs₂ hV).mono_right h

/-- The union of two bounded sets is bounded. -/

end has_zero

end semi_normed_ring

section multiple_topologies

variables [semi_normed_ring 𝕜] [add_comm_group E] [module 𝕜 E]

/-- If a topology `t'` is coarser than `t`, then any set `s` that is bounded with respect to
`t` is bounded with respect to `t'`. -/
lemma is_vonN_bounded.of_topological_space_le {t t' : topological_space E} (h : t ≤ t') {s : set E}
  (hs : @is_vonN_bounded 𝕜 E _ _ _ t s) : @is_vonN_bounded 𝕜 E _ _ _ t' s :=
λ V hV, hs $ (le_iff_nhds t t').mp h 0 hV

end multiple_topologies

section normed_field

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E]
variables [topological_space E] [has_continuous_smul 𝕜 E]

/-- Singletons are bounded. -/
lemma is_vonN_bounded_singleton (x : E) : is_vonN_bounded 𝕜 ({x} : set E) :=
λ V hV, (absorbent_nhds_zero hV).absorbs

/-- The union of all bounded set is the whole space. -/
lemma is_vonN_bounded_covers : ⋃₀ (set_of (is_vonN_bounded 𝕜)) = (set.univ : set E) :=
set.eq_univ_iff_forall.mpr (λ x, set.mem_sUnion.mpr
  ⟨{x}, is_vonN_bounded_singleton _, set.mem_singleton _⟩)

variables (𝕜 E)

/-- The von Neumann bornology defined by the von Neumann bounded sets.

Note that this is not registered as an instance, in order to avoid diamonds with the
metric bornology.-/
@[reducible] -- See note [reducible non-instances]
def vonN_bornology : bornology E :=
bornology.of_bounded (set_of (is_vonN_bounded 𝕜)) (is_vonN_bounded_empty 𝕜 E)
  (λ _ hs _ ht, hs.subset ht) (λ _ hs _, hs.union) is_vonN_bounded_singleton

variables {E}

@[simp] lemma is_bounded_iff_is_vonN_bounded {s : set E} :
  @is_bounded _ (vonN_bornology 𝕜 E) s ↔ is_vonN_bounded 𝕜 s :=
is_bounded_of_bounded_iff _

end normed_field

end bornology

section uniform_add_group

variables [nondiscrete_normed_field 𝕜] [add_comm_group E] [module 𝕜 E]
variables [uniform_space E] [uniform_add_group E] [has_continuous_smul 𝕜 E]
variables [regular_space E]

lemma totally_bounded.is_vonN_bounded {s : set E} (hs : totally_bounded s) :
  bornology.is_vonN_bounded 𝕜 s :=
begin
  rw totally_bounded_iff_subset_finite_Union_nhds_zero at hs,
  intros U hU,
  have h : filter.tendsto (λ (x : E × E), x.fst + x.snd) (𝓝 (0,0)) (𝓝 ((0 : E) + (0 : E))) :=
    tendsto_add,
  rw add_zero at h,
  have h' := (nhds_basis_closed_balanced 𝕜 E).prod (nhds_basis_closed_balanced 𝕜 E),
  simp_rw [←nhds_prod_eq, id.def] at h',
  rcases h.basis_left h' U hU with ⟨x, hx, h''⟩,
  rcases hs x.snd hx.2.1 with ⟨t, ht, hs⟩,
  refine absorbs.mono_right _ hs,
  rw ht.absorbs_Union,
  have hx_fstsnd : x.fst + x.snd ⊆ U,
  { intros z hz,
    rcases set.mem_add.mp hz with ⟨z1, z2, hz1, hz2, hz⟩,
    have hz' : (z1, z2) ∈ x.fst ×ˢ x.snd := ⟨hz1, hz2⟩,
    simpa only [hz] using h'' hz' },
  refine λ y hy, absorbs.mono_left _ hx_fstsnd,
  rw [←set.singleton_vadd, vadd_eq_add],
  exact (absorbent_nhds_zero hx.1.1).absorbs.add hx.2.2.2.absorbs_self,
end

end uniform_add_group


import .love09_hoare_logic_demo

/-! # LoVe Homework 9: Hoare Logic

Homework must be done individually. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Question 1 (6 points): Hoare Logic for LOOP

We introduce the LOOP language: -/

namespace loop

inductive stmt : Type
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| it     : (state → Prop) → stmt → stmt
| loop   : stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

/-! The language is similar to WHILE. There are three differences:

* There is no `skip` statement.

* The `it` statement is an `if`–`then` construct with no `else` case.

* The `loop` construct corresponds to a randomized `while` loop. It executes
  the body an unspecified (possibly infinite) number of times.

The big-step semantics for LOOP is defined below. -/

inductive big_step : stmt × state → state → Prop
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hs : big_step (S, s) t)
    (ht : big_step (T, t) u) :
  big_step (S ;; T, s) u
| it_true {b : state → Prop} {S s t} (hcond : b s) (hbody : big_step (S, s) t) :
  big_step (stmt.it b S, s) t
| it_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (stmt.it b S, s) s
| loop_continue {S s t u} (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.loop S, t) u) :
  big_step (stmt.loop S, s) u
| loop_exit {S s} :
  big_step (stmt.loop S, s) s

infix ` ⟹ ` : 110 := big_step

/-! The definition of Hoare triples for partial correctness is unsurprising: -/

def partial_hoare (P : state → Prop) (S : stmt) (Q : state → Prop) : Prop :=
∀s t, P s → (S, s) ⟹ t → Q t

local notation `{* ` P : 1 ` *} ` S : 1 ` {* ` Q : 1 ` *}` :=
partial_hoare P S Q

namespace partial_hoare

/-! 1.1 (1 point). Prove the consequence rule. -/

lemma consequence {P P' Q Q' : state → Prop} {S} (h : {* P *} S {* Q *})
    (hp : ∀s, P' s → P s) (hq : ∀s, Q s → Q' s) :
  {* P' *} S {* Q' *} :=
begin
  intros s t hs hst,
  apply hq,
  apply h,
  { apply hp,
    assumption },
  { assumption }
end

/-! 1.2 (1 point). Prove the rule for `assign`. -/

lemma assign_intro {P : state → Prop} {x} {a : state → ℕ} :
  {* λs, P (s{x ↦ a s}) *} stmt.assign x a {* P *} :=
begin
  intros s t P hst,
  cases' hst,
  assumption
end

/-! 1.3 (1 point). Prove the rule for `seq`. -/

lemma seq_intro {P Q R S T} (hS : {* P *} S {* Q *}) (hT : {* Q *} T {* R *}) :
  {* P *} stmt.seq S T {* R *} :=
begin
  intros s t hP hst,
  cases' hst,
  apply hT _ _ _ hst_1,
  apply hS _ _ _ hst,
  assumption
end

/-! 1.4 (1 point). Prove the rule for `it`. -/

lemma it_intro {b P Q : state → Prop} {S}
    (htrue : {* λs, P s ∧ b s *} S {* Q *}) (hfalse : ∀s, P s ∧ ¬ b s → Q s) :
  {* P *} stmt.it b S {* Q *} :=
begin
  intros s t hs hst,
  cases' hst,
  { apply htrue,
    exact and.intro hs hcond,
    assumption },
  { apply hfalse,
    exact and.intro hs hcond }
end

/-! 1.5 (2 points). Prove the rule for `loop`. Notice the similarity with the
rule for `while` in the WHILE language. -/

lemma loop_intro {S} (P : state → Prop) (h : {* P *} S {* P *}) :
  {* P *} stmt.loop S {* P *} :=
begin
  intros s t hs hst,
  induction' hst,
  case loop_continue {
    apply ih_hst_1 P h,
    exact h _ _ hs hst },
  case loop_exit {
    exact hs }
end

end partial_hoare

end loop

/-! ## Question 2 (3 points): Program Verification

The following WHILE program is intended to compute 2 to the power of `n`,
leaving the result in `y`. -/

def POWER_OF_TWO : stmt :=
stmt.assign "y" (λs, 1) ;;
stmt.while (λs, s "n" ≠ 0)
  (stmt.assign "y" (λs, s "y" * 2) ;;
   stmt.assign "n" (λs, s "n" - 1))

/-! 2.1 (1 point). Define a recursive function that computes 2 to the power of
`n`. -/

def two_to_the_nth : ℕ → ℕ
| 0       := 1
| (n + 1) := 2 * two_to_the_nth n

/-! Remember to test your function. Otherwise, you will have big difficulties
answering question 2.2 below. -/

#eval two_to_the_nth 0   -- expected: 1
#eval two_to_the_nth 1   -- expected: 2
#eval two_to_the_nth 2   -- expected: 4
#eval two_to_the_nth 3   -- expected: 8
#eval two_to_the_nth 8   -- expected: 256

/-! 2.2 (2 points). Prove the correctness of `POWER_OF_TWO` using `vcg`. -/

lemma POWER_OF_TWO_correct (n₀ : ℕ) :
  {* λs, s "n" = n₀ *} POWER_OF_TWO {* λs, s "y" = two_to_the_nth n₀ *} :=
show {* λs, s "n" = n₀ *}
     stmt.assign "y" (λs, 1) ;;
     stmt.while_inv (λs, s "y" * two_to_the_nth (s "n") = two_to_the_nth n₀)
       (λs, s "n" ≠ 0)
       (stmt.assign "y" (λs, s "y" * 2) ;;
        stmt.assign "n" (λs, s "n" - 1))
     {* λs, s "y" = two_to_the_nth n₀ *}, from
  begin
    vcg; simp [two_to_the_nth] { contextual := tt },
    intro s,
    cases' s "n",
    { simp },
    { simp [two_to_the_nth, mul_assoc] { contextual := tt } }
  end

end LoVe


-- CN_de_diferencia_no_negativa.lean
-- Si R es un anillo ordenado y a b ∈ R, entonces 0 ≤ b - a → a ≤ b
-- José A. Alonso Jiménez <https://jaalonso.github.io>
-- Sevilla, 27-octubre-2022
-- ---------------------------------------------------------------------

-- ---------------------------------------------------------------------
-- Demostrar que si R es un anillo ordenado y a b ∈ R, entonces
--    0 ≤ b - a → a ≤ b
-- ---------------------------------------------------------------------

import algebra.order.ring
variables {R : Type*} [ordered_ring R]
variables a b : R

-- 1ª demostración
-- ===============

example : 0 ≤ b - a → a ≤ b :=
begin
  intro h,
  calc
    a   = 0 + a       : (zero_add a).symm
    ... ≤ (b - a) + a : add_le_add_right h a
    ... = b           : sub_add_cancel b a
end

-- 2ª demostración
-- ===============

example : 0 ≤ b - a → a ≤ b :=
-- by library_search
sub_nonneg.mp

-- 3ª demostración
-- ===============

example : 0 ≤ b - a → a ≤ b :=
-- by hint
by simp


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

/-!
# Balanced Core and Balanced Hull

## Main definitions

* `balanced_core`: The largest balanced subset of a set `s`.
* `balanced_hull`: The smallest balanced superset of a set `s`.

## Main statements

* `balanced_core_eq_Inter`: Characterization of the balanced core as an intersection over subsets.
* `nhds_basis_closed_balanced`: The closed balanced sets form a basis of the neighborhood filter.

## Implementation details

The balanced core and hull are implemented differently: for the core we take the obvious definition
of the union over all balanced sets that are contained in `s`, whereas for the hull, we take the
union over `r • s`, for `r` the scalars with `‖r‖ ≤ 1`. We show that `balanced_hull` has the
defining properties of a hull in `balanced.hull_minimal` and `subset_balanced_hull`.
For the core we need slightly stronger assumptions to obtain a characterization as an intersection,
this is `balanced_core_eq_Inter`.

## References

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

## Tags

balanced
-/

open set
open_locale pointwise topology filter

variables {𝕜 E ι : Type*}

section balanced_hull

section semi_normed_ring
variables [semi_normed_ring 𝕜]

section has_smul
variables (𝕜) [has_smul 𝕜 E] {s t : set E} {x : E}

/-- The largest balanced subset of `s`.-/
def balanced_core (s : set E) := ⋃₀ {t : set E | balanced 𝕜 t ∧ t ⊆ s}

/-- Helper definition to prove `balanced_core_eq_Inter`-/
def balanced_core_aux (s : set E) := ⋂ (r : 𝕜) (hr : 1 ≤ ‖r‖), r • s

/-- The smallest balanced superset of `s`.-/
def balanced_hull (s : set E) := ⋃ (r : 𝕜) (hr : ‖r‖ ≤ 1), r • s

variables {𝕜}

lemma balanced_core_subset (s : set E) : balanced_core 𝕜 s ⊆ s := sUnion_subset $ λ t ht, ht.2

lemma balanced_core_empty : balanced_core 𝕜 (∅ : set E) = ∅ :=
eq_empty_of_subset_empty (balanced_core_subset _)

lemma mem_balanced_core_iff : x ∈ balanced_core 𝕜 s ↔ ∃ t, balanced 𝕜 t ∧ t ⊆ s ∧ x ∈ t :=
by simp_rw [balanced_core, mem_sUnion, mem_set_of_eq, exists_prop, and_assoc]

lemma smul_balanced_core_subset (s : set E) {a : 𝕜} (ha : ‖a‖ ≤ 1) :
  a • balanced_core 𝕜 s ⊆ balanced_core 𝕜 s :=
begin
  rintro x ⟨y, hy, rfl⟩,
  rw mem_balanced_core_iff at hy,
  rcases hy with ⟨t, ht1, ht2, hy⟩,
  exact ⟨t, ⟨ht1, ht2⟩, ht1 a ha (smul_mem_smul_set hy)⟩,
end

lemma balanced_core_balanced (s : set E) : balanced 𝕜 (balanced_core 𝕜 s) :=
λ _, smul_balanced_core_subset s

/-- The balanced core of `t` is maximal in the sense that it contains any balanced subset
`s` of `t`.-/
lemma balanced.subset_core_of_subset (hs : balanced 𝕜 s) (h : s ⊆ t) : s ⊆ balanced_core 𝕜 t :=
subset_sUnion_of_mem ⟨hs, h⟩

lemma mem_balanced_core_aux_iff : x ∈ balanced_core_aux 𝕜 s ↔ ∀ r : 𝕜, 1 ≤ ‖r‖ → x ∈ r • s :=
mem_Inter₂

lemma mem_balanced_hull_iff : x ∈ balanced_hull 𝕜 s ↔ ∃ (r : 𝕜) (hr : ‖r‖ ≤ 1), x ∈ r • s :=
mem_Union₂

/-- The balanced hull of `s` is minimal in the sense that it is contained in any balanced superset
`t` of `s`. -/
lemma balanced.hull_subset_of_subset (ht : balanced 𝕜 t) (h : s ⊆ t) : balanced_hull 𝕜 s ⊆ t :=
λ x hx, by { obtain ⟨r, hr, y, hy, rfl⟩ := mem_balanced_hull_iff.1 hx, exact ht.smul_mem hr (h hy) }

end has_smul

section module
variables [add_comm_group E] [module 𝕜 E] {s : set E}

lemma balanced_core_zero_mem (hs : (0 : E) ∈ s) : (0 : E) ∈ balanced_core 𝕜 s :=
mem_balanced_core_iff.2 ⟨0, balanced_zero, zero_subset.2 hs, zero_mem_zero⟩

lemma balanced_core_nonempty_iff : (balanced_core 𝕜 s).nonempty ↔ (0 : E) ∈ s :=
⟨λ h, zero_subset.1 $ (zero_smul_set h).superset.trans $ (balanced_core_balanced s (0 : 𝕜) $
  norm_zero.trans_le zero_le_one).trans $ balanced_core_subset _,
    λ h, ⟨0, balanced_core_zero_mem h⟩⟩

variables (𝕜)

lemma subset_balanced_hull [norm_one_class 𝕜] {s : set E} : s ⊆ balanced_hull 𝕜 s :=
λ _ hx, mem_balanced_hull_iff.2 ⟨1, norm_one.le, _, hx, one_smul _ _⟩

variables {𝕜}

lemma balanced_hull.balanced (s : set E) : balanced 𝕜 (balanced_hull 𝕜 s) :=
begin
  intros a ha,
  simp_rw [balanced_hull, smul_set_Union₂, subset_def, mem_Union₂],
  rintro x ⟨r, hr, hx⟩,
  rw ←smul_assoc at hx,
  exact ⟨a • r, (semi_normed_ring.norm_mul _ _).trans (mul_le_one ha (norm_nonneg r) hr), hx⟩,
end

end module
end semi_normed_ring

section normed_field

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E] {s t : set E}

@[simp] lemma balanced_core_aux_empty : balanced_core_aux 𝕜 (∅ : set E) = ∅ :=
begin
  simp_rw [balanced_core_aux, Inter₂_eq_empty_iff, smul_set_empty],
  exact λ _, ⟨1, norm_one.ge, not_mem_empty _⟩,
end

lemma balanced_core_aux_subset (s : set E) : balanced_core_aux 𝕜 s ⊆ s :=
λ x hx, by simpa only [one_smul] using mem_balanced_core_aux_iff.1 hx 1 norm_one.ge

lemma balanced_core_aux_balanced (h0 : (0 : E) ∈ balanced_core_aux 𝕜 s):
  balanced 𝕜 (balanced_core_aux 𝕜 s) :=
begin
  rintro a ha x ⟨y, hy, rfl⟩,
  obtain rfl | h := eq_or_ne a 0,
  { rwa zero_smul },
  rw mem_balanced_core_aux_iff at ⊢ hy,
  intros r hr,
  have h'' : 1 ≤ ‖a⁻¹ • r‖,
  { rw [norm_smul, norm_inv],
    exact one_le_mul_of_one_le_of_one_le (one_le_inv (norm_pos_iff.mpr h) ha) hr },
  have h' := hy (a⁻¹ • r) h'',
  rwa [smul_assoc, mem_inv_smul_set_iff₀ h] at h',
end

lemma balanced_core_aux_maximal (h : t ⊆ s) (ht : balanced 𝕜 t) : t ⊆ balanced_core_aux 𝕜 s :=
begin
  refine λ x hx, mem_balanced_core_aux_iff.2 (λ r hr, _),
  rw mem_smul_set_iff_inv_smul_mem₀ (norm_pos_iff.mp $ zero_lt_one.trans_le hr),
  refine h (ht.smul_mem _ hx),
  rw norm_inv,
  exact inv_le_one hr,
end

lemma balanced_core_subset_balanced_core_aux : balanced_core 𝕜 s ⊆ balanced_core_aux 𝕜 s :=
balanced_core_aux_maximal (balanced_core_subset s) (balanced_core_balanced s)

lemma balanced_core_eq_Inter (hs : (0 : E) ∈ s) :
  balanced_core 𝕜 s = ⋂ (r : 𝕜) (hr : 1 ≤ ‖r‖), r • s :=
begin
  refine balanced_core_subset_balanced_core_aux.antisymm  _,
  refine (balanced_core_aux_balanced _).subset_core_of_subset (balanced_core_aux_subset s),
  exact balanced_core_subset_balanced_core_aux (balanced_core_zero_mem hs),
end

lemma subset_balanced_core (ht : (0 : E) ∈ t) (hst : ∀ (a : 𝕜) (ha : ‖a‖ ≤ 1), a • s ⊆ t) :
  s ⊆ balanced_core 𝕜 t :=
begin
  rw balanced_core_eq_Inter ht,
  refine subset_Inter₂ (λ a ha, _),
  rw ←smul_inv_smul₀ (norm_pos_iff.mp $ zero_lt_one.trans_le ha) s,
  refine smul_set_mono (hst _ _),
  rw [norm_inv],
  exact inv_le_one ha,
end

end normed_field

end balanced_hull

/-! ### Topological properties -/

section topology

variables [nontrivially_normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [topological_space E]
  [has_continuous_smul 𝕜 E] {U : set E}

protected lemma is_closed.balanced_core (hU : is_closed U) : is_closed (balanced_core 𝕜 U) :=
begin
  by_cases h : (0 : E) ∈ U,
  { rw balanced_core_eq_Inter h,
    refine is_closed_Inter (λ a, _),
    refine is_closed_Inter (λ ha, _),
    have ha' := lt_of_lt_of_le zero_lt_one ha,
    rw norm_pos_iff at ha',
    refine is_closed_map_smul_of_ne_zero ha' U hU },
  convert is_closed_empty,
  contrapose! h,
  exact balanced_core_nonempty_iff.mp (set.nonempty_iff_ne_empty.2 h),
end

lemma balanced_core_mem_nhds_zero (hU : U ∈ 𝓝 (0 : E)) : balanced_core 𝕜 U ∈ 𝓝 (0 : E) :=
begin
  -- Getting neighborhoods of the origin for `0 : 𝕜` and `0 : E`
  obtain ⟨r, V, hr, hV, hrVU⟩ : ∃ (r : ℝ) (V : set E), 0 < r ∧ V ∈ 𝓝 (0 : E) ∧
    ∀ (c : 𝕜) (y : E), ‖c‖ < r → y ∈ V → c • y ∈ U,
  { have h : filter.tendsto (λ (x : 𝕜 × E), x.fst • x.snd) (𝓝 (0,0)) (𝓝 0),
      from continuous_smul.tendsto' (0, 0) _ (smul_zero _),
    simpa only [← prod.exists', ← prod.forall', ← and_imp, ← and.assoc, exists_prop]
      using h.basis_left (normed_add_comm_group.nhds_zero_basis_norm_lt.prod_nhds
        ((𝓝 _).basis_sets)) U hU },
  rcases normed_field.exists_norm_lt 𝕜 hr with ⟨y, hy₀, hyr⟩,
  rw [norm_pos_iff] at hy₀,
  have : y • V ∈ 𝓝 (0 : E) := (set_smul_mem_nhds_zero_iff hy₀).mpr hV,
  -- It remains to show that `y • V ⊆ balanced_core 𝕜 U`
  refine filter.mem_of_superset this (subset_balanced_core (mem_of_mem_nhds hU) $ λ a ha, _),
  rw [smul_smul],
  rintro _ ⟨z, hz, rfl⟩,
  refine hrVU _ _ _ hz,
  rw [norm_mul, ← one_mul r],
  exact mul_lt_mul' ha hyr (norm_nonneg y) one_pos
end

variables (𝕜 E)

lemma nhds_basis_balanced : (𝓝 (0 : E)).has_basis
  (λ (s : set E), s ∈ 𝓝 (0 : E) ∧ balanced 𝕜 s) id :=
filter.has_basis_self.mpr
  (λ s hs, ⟨balanced_core 𝕜 s, balanced_core_mem_nhds_zero hs,
            balanced_core_balanced s, balanced_core_subset s⟩)

lemma nhds_basis_closed_balanced [regular_space E] : (𝓝 (0 : E)).has_basis
  (λ (s : set E), s ∈ 𝓝 (0 : E) ∧ is_closed s ∧ balanced 𝕜 s) id :=
begin
  refine (closed_nhds_basis 0).to_has_basis (λ s hs, _) (λ s hs, ⟨s, ⟨hs.1, hs.2.1⟩, rfl.subset⟩),
  refine ⟨balanced_core 𝕜 s, ⟨balanced_core_mem_nhds_zero hs.1, _⟩, balanced_core_subset s⟩,
  exact ⟨hs.2.balanced_core, balanced_core_balanced s⟩
end

end topology