/-
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
-/
import data.set.intervals.ord_connected
import order.filter.small_sets
import order.filter.at_top_bot

/-!
# Convergence of intervals

If both `a` and `b` tend to some filter `l₁`, sometimes this implies that `Ixx a b` tends to
`l₂.small_sets`, i.e., for any `s ∈ l₂` eventually `Ixx a b` becomes a subset of `s`.  Here and
below `Ixx` is one of `Icc`, `Ico`, `Ioc`, and `Ioo`. We define `filter.tendsto_Ixx_class Ixx l₁ l₂`
to be a typeclass representing this property.

The instances provide the best `l₂` for a given `l₁`. In many cases `l₁ = l₂` but sometimes we can
drop an endpoint from an interval: e.g., we prove `tendsto_Ixx_class Ico (𝓟 $ Iic a) (𝓟 $ Iio a)`,
i.e., if `u₁ n` and `u₂ n` belong eventually to `Iic a`, then the interval `Ico (u₁ n) (u₂ n)` is
eventually included in `Iio a`.

The next table shows “output” filters `l₂` for different values of `Ixx` and `l₁`. The instances
that need topology are defined in `topology/algebra/ordered`.

| Input filter |  `Ixx = Icc`  |  `Ixx = Ico`  |  `Ixx = Ioc`  |  `Ixx = Ioo`  |
| -----------: | :-----------: | :-----------: | :-----------: | :-----------: |
|     `at_top` |    `at_top`   |    `at_top`   |    `at_top`   |    `at_top`   |
|     `at_bot` |    `at_bot`   |    `at_bot`   |    `at_bot`   |    `at_bot`   |
|     `pure a` |    `pure a`   |      `⊥`      |      `⊥`      |      `⊥`      |
|  `𝓟 (Iic a)` |  `𝓟 (Iic a)`  |  `𝓟 (Iio a)`  |  `𝓟 (Iic a)`  |  `𝓟 (Iio a)`  |
|  `𝓟 (Ici a)` |  `𝓟 (Ici a)`  |  `𝓟 (Ici a)`  |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |
|  `𝓟 (Ioi a)` |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |  `𝓟 (Ioi a)`  |
|  `𝓟 (Iio a)` |  `𝓟 (Iio a)`  |  `𝓟 (Iio a)`  |  `𝓟 (Iio a)`  |  `𝓟 (Iio a)`  |
|        `𝓝 a` |     `𝓝 a`     |     `𝓝 a`     |     `𝓝 a`     |     `𝓝 a`     |
| `𝓝[Iic a] b` |  `𝓝[Iic a] b` |  `𝓝[Iio a] b` |  `𝓝[Iic a] b` |  `𝓝[Iio a] b` |
| `𝓝[Ici a] b` |  `𝓝[Ici a] b` |  `𝓝[Ici a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |
| `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |  `𝓝[Ioi a] b` |
| `𝓝[Iio a] b` |  `𝓝[Iio a] b` |  `𝓝[Iio a] b` |  `𝓝[Iio a] b` |  `𝓝[Iio a] b` |

-/

variables {α β : Type*}

open_locale classical filter interval

open set function

namespace filter

section preorder

variables [preorder α]

/-- A pair of filters `l₁`, `l₂` has `tendsto_Ixx_class Ixx` property if `Ixx a b` tends to
`l₂.small_sets` as `a` and `b` tend to `l₁`. In all instances `Ixx` is one of `Icc`, `Ico`, `Ioc`,
or `Ioo`. The instances provide the best `l₂` for a given `l₁`. In many cases `l₁ = l₂` but
sometimes we can drop an endpoint from an interval: e.g., we prove `tendsto_Ixx_class Ico (𝓟 $ Iic
a) (𝓟 $ Iio a)`, i.e., if `u₁ n` and `u₂ n` belong eventually to `Iic a`, then the interval `Ico (u₁
n) (u₂ n)` is eventually included in `Iio a`.

We mark `l₂` as an `out_param` so that Lean can automatically find an appropriate `l₂` based on
`Ixx` and `l₁`. This way, e.g., `tendsto.Ico h₁ h₂` works without specifying explicitly `l₂`. -/
class tendsto_Ixx_class (Ixx : α → α → set α) (l₁ : filter α) (l₂ : out_param $ filter α) : Prop :=
(tendsto_Ixx : tendsto (λ p : α × α, Ixx p.1 p.2) (l₁ ×ᶠ l₁) l₂.small_sets)

lemma tendsto.Icc {l₁ l₂ : filter α} [tendsto_Ixx_class Icc l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Icc (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto.Ioc {l₁ l₂ : filter α} [tendsto_Ixx_class Ioc l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Ioc (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto.Ico {l₁ l₂ : filter α} [tendsto_Ixx_class Ico l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Ico (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto.Ioo {l₁ l₂ : filter α} [tendsto_Ixx_class Ioo l₁ l₂]
  {lb : filter β} {u₁ u₂ : β → α} (h₁ : tendsto u₁ lb l₁) (h₂ : tendsto u₂ lb l₁) :
  tendsto (λ x, Ioo (u₁ x) (u₂ x)) lb l₂.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ h₁.prod_mk h₂

lemma tendsto_Ixx_class_principal {s t : set α} {Ixx : α → α → set α} :
  tendsto_Ixx_class Ixx (𝓟 s) (𝓟 t) ↔ ∀ x y ∈ s, Ixx x y ⊆ t :=
iff.trans ⟨λ h, h.1, λ h, ⟨h⟩⟩ $ by simp only [small_sets_principal, prod_principal_principal,
  tendsto_principal_principal, forall_prod_set, mem_powerset_iff, mem_principal]

lemma tendsto_Ixx_class_inf {l₁ l₁' l₂ l₂' : filter α} {Ixx}
  [h : tendsto_Ixx_class Ixx l₁ l₂] [h' : tendsto_Ixx_class Ixx l₁' l₂'] :
  tendsto_Ixx_class Ixx (l₁ ⊓ l₁') (l₂ ⊓ l₂') :=
⟨by simpa only [prod_inf_prod, small_sets_inf] using h.1.inf h'.1⟩

lemma tendsto_Ixx_class_of_subset {l₁ l₂ : filter α} {Ixx Ixx' : α → α → set α}
  (h : ∀ a b, Ixx a b ⊆ Ixx' a b) [h' : tendsto_Ixx_class Ixx' l₁ l₂] :
  tendsto_Ixx_class Ixx l₁ l₂ :=
⟨h'.1.small_sets_mono $ eventually_of_forall $ prod.forall.2 h⟩

lemma has_basis.tendsto_Ixx_class {ι : Type*} {p : ι → Prop} {s} {l : filter α}
  (hl : l.has_basis p s) {Ixx : α → α → set α}
  (H : ∀ i, p i → ∀ (x ∈ s i) (y ∈ s i), Ixx x y ⊆ s i) :
  tendsto_Ixx_class Ixx l l :=
⟨(hl.prod_self.tendsto_iff hl.small_sets).2 $ λ i hi,
  ⟨i, hi, λ x hx, H i hi _ hx.1 _ hx.2⟩⟩

instance tendsto_Icc_at_top_at_top : tendsto_Ixx_class Icc (at_top : filter α) at_top :=
(has_basis_infi_principal_finite _).tendsto_Ixx_class $ λ s hs,
set.ord_connected.out $ ord_connected_bInter $ λ i hi, ord_connected_Ici

instance tendsto_Ico_at_top_at_top : tendsto_Ixx_class Ico (at_top : filter α) at_top :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ioc_at_top_at_top : tendsto_Ixx_class Ioc (at_top : filter α) at_top :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioo_at_top_at_top : tendsto_Ixx_class Ioo (at_top : filter α) at_top :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Icc_self)

instance tendsto_Icc_at_bot_at_bot : tendsto_Ixx_class Icc (at_bot : filter α) at_bot :=
(has_basis_infi_principal_finite _).tendsto_Ixx_class $ λ s hs,
set.ord_connected.out $ ord_connected_bInter $ λ i hi, ord_connected_Iic

instance tendsto_Ico_at_bot_at_bot : tendsto_Ixx_class Ico (at_bot : filter α) at_bot :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ioc_at_bot_at_bot : tendsto_Ixx_class Ioc (at_bot : filter α) at_bot :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioo_at_bot_at_bot : tendsto_Ixx_class Ioo (at_bot : filter α) at_bot :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Icc_self)

instance ord_connected.tendsto_Icc {s : set α} [hs : ord_connected s] :
  tendsto_Ixx_class Icc (𝓟 s) (𝓟 s) :=
tendsto_Ixx_class_principal.2 hs.out

instance tendsto_Ico_Ici_Ici {a : α} : tendsto_Ixx_class Ico (𝓟 (Ici a)) (𝓟 (Ici a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ico_Ioi_Ioi {a : α} : tendsto_Ixx_class Ico (𝓟 (Ioi a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ico_Iic_Iio {a : α} : tendsto_Ixx_class Ico (𝓟 (Iic a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_principal.2 $ λ a ha b hb x hx, lt_of_lt_of_le hx.2 hb

instance tendsto_Ico_Iio_Iio {a : α} : tendsto_Ixx_class Ico (𝓟 (Iio a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ico_subset_Icc_self)

instance tendsto_Ioc_Ici_Ioi {a : α} : tendsto_Ixx_class Ioc (𝓟 (Ici a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_principal.2 $ λ x hx y hy t ht, lt_of_le_of_lt hx ht.1

instance tendsto_Ioc_Iic_Iic {a : α} : tendsto_Ixx_class Ioc (𝓟 (Iic a)) (𝓟 (Iic a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioc_Iio_Iio {a : α} : tendsto_Ixx_class Ioc (𝓟 (Iio a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioc_Ioi_Ioi {a : α} : tendsto_Ixx_class Ioc (𝓟 (Ioi a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioc_subset_Icc_self)

instance tendsto_Ioo_Ici_Ioi {a : α} : tendsto_Ixx_class Ioo (𝓟 (Ici a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ioc_self)

instance tendsto_Ioo_Iic_Iio {a : α} : tendsto_Ixx_class Ioo (𝓟 (Iic a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ico_self)

instance tendsto_Ioo_Ioi_Ioi {a : α} : tendsto_Ixx_class Ioo (𝓟 (Ioi a)) (𝓟 (Ioi a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ioc_self)

instance tendsto_Ioo_Iio_Iio {a : α} : tendsto_Ixx_class Ioo (𝓟 (Iio a)) (𝓟 (Iio a)) :=
tendsto_Ixx_class_of_subset (λ _ _, Ioo_subset_Ioc_self)

instance tendsto_Icc_Icc_Icc {a b : α} :
  tendsto_Ixx_class Icc (𝓟 (Icc a b)) (𝓟 (Icc a b)) :=
tendsto_Ixx_class_principal.mpr $ λ x hx y hy, Icc_subset_Icc hx.1 hy.2

instance tendsto_Ioc_Icc_Icc {a b : α} : tendsto_Ixx_class Ioc (𝓟 (Icc a b)) (𝓟 (Icc a b)) :=
tendsto_Ixx_class_of_subset $ λ _ _, Ioc_subset_Icc_self

end preorder

section partial_order

variable [partial_order α]

instance tendsto_Icc_pure_pure {a : α} : tendsto_Ixx_class Icc (pure a) (pure a : filter α) :=
by { rw ← principal_singleton, exact tendsto_Ixx_class_principal.2 ord_connected_singleton.out }

instance tendsto_Ico_pure_bot {a : α} : tendsto_Ixx_class Ico (pure a) ⊥ := ⟨by simp⟩
instance tendsto_Ioc_pure_bot {a : α} : tendsto_Ixx_class Ioc (pure a) ⊥ := ⟨by simp⟩
instance tendsto_Ioo_pure_bot {a : α} : tendsto_Ixx_class Ioo (pure a) ⊥ := ⟨by simp⟩

end partial_order

section linear_order

variables [linear_order α]

instance tendsto_Icc_interval_interval {a b : α} : tendsto_Ixx_class Icc (𝓟 [a, b]) (𝓟 [a, b]) :=
filter.tendsto_Icc_Icc_Icc

instance tendsto_Ioc_interval_interval {a b : α} : tendsto_Ixx_class Ioc (𝓟 [a, b]) (𝓟 [a, b]) :=
filter.tendsto_Ioc_Icc_Icc

instance tendsto_interval_of_Icc {l : filter α} [tendsto_Ixx_class Icc l l] :
  tendsto_Ixx_class interval l l :=
begin
  refine ⟨λ s hs, mem_map.2 $ mem_prod_self_iff.2 _⟩,
  obtain ⟨t, htl, hts⟩ : ∃ t ∈ l, ∀ p ∈ (t : set α) ×ˢ t, Icc (p : α × α).1 p.2 ∈ s,
    from mem_prod_self_iff.1 (mem_map.1 (tendsto_fst.Icc tendsto_snd hs)),
  refine ⟨t, htl, λ p hp, _⟩,
  cases le_total p.1 p.2,
  { rw [mem_preimage, interval_of_le h], exact hts p hp },
  { rw [mem_preimage, interval_of_ge h], exact hts ⟨p.2, p.1⟩ ⟨hp.2, hp.1⟩ }
end

lemma tendsto.interval {l : filter α} [tendsto_Ixx_class Icc l l] {f g : β → α} {lb : filter β}
  (hf : tendsto f lb l) (hg : tendsto g lb l) :
  tendsto (λ x, [f x, g x]) lb l.small_sets :=
tendsto_Ixx_class.tendsto_Ixx.comp $ hf.prod_mk hg

end linear_order

end filter


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Adam Topaz
-/
import category_theory.limits.shapes.terminal
import category_theory.punit
import category_theory.structured_arrow

/-!

# Kan extensions

This file defines the right and left Kan extensions of a functor.
They exist under the assumption that the target category has enough limits
resp. colimits.

The main definitions are `Ran ι` and `Lan ι`, where `ι : S ⥤ L` is a functor.
Namely, `Ran ι` is the right Kan extension, while `Lan ι` is the left Kan extension,
both as functors `(S ⥤ D) ⥤ (L ⥤ D)`.

To access the right resp. left adjunction associated to these, use `Ran.adjunction`
resp. `Lan.adjunction`.

# Projects

A lot of boilerplate could be generalized by defining and working with pseudofunctors.

-/

noncomputable theory

namespace category_theory

open limits

universes v v₁ v₂ v₃ u₁ u₂ u₃

variables {S : Type u₁} {L : Type u₂} {D : Type u₃}
variables [category.{v₁} S] [category.{v₂} L] [category.{v₃} D]
variables (ι : S ⥤ L)

namespace Ran

local attribute [simp] structured_arrow.proj

/-- The diagram indexed by `Ran.index ι x` used to define `Ran`. -/
abbreviation diagram (F : S ⥤ D) (x : L) : structured_arrow x ι ⥤ D :=
  structured_arrow.proj x ι ⋙ F

variable {ι}

/-- A cone over `Ran.diagram ι F x` used to define `Ran`. -/
@[simp]
def cone {F : S ⥤ D} {G : L ⥤ D} (x : L) (f : ι ⋙ G ⟶ F) :
  cone (diagram ι F x) :=
{ X := G.obj x,
  π :=
  { app := λ i, G.map i.hom ≫ f.app i.right,
    naturality' := begin
      rintro ⟨⟨il⟩, ir, i⟩ ⟨⟨jl⟩, jr, j⟩ ⟨⟨⟨fl⟩⟩, fr, ff⟩,
      dsimp at *,
      simp only [category.id_comp, category.assoc] at *,
      rw [ff],
      have := f.naturality,
      tidy,
    end } }

variable (ι)

/-- An auxiliary definition used to define `Ran`. -/
@[simps]
def loc (F : S ⥤ D) [∀ x, has_limit (diagram ι F x)] : L ⥤ D :=
{ obj := λ x, limit (diagram ι F x),
  map := λ x y f, limit.pre (diagram _ _ _) (structured_arrow.map f : structured_arrow _ ι ⥤ _),
  map_id' := begin
    intro l,
    ext j,
    simp only [category.id_comp, limit.pre_π],
    congr' 1,
    simp,
  end,
  map_comp' := begin
    intros x y z f g,
    ext j,
    erw [limit.pre_pre, limit.pre_π, limit.pre_π],
    congr' 1,
    tidy,
  end }

/-- An auxiliary definition used to define `Ran` and `Ran.adjunction`. -/
@[simps]
def equiv (F : S ⥤ D) [∀ x, has_limit (diagram ι F x)] (G : L ⥤ D) :
  (G ⟶ loc ι F) ≃ (((whiskering_left _ _ _).obj ι).obj G ⟶ F) :=
{ to_fun := λ f,
  { app := λ x, f.app _ ≫ limit.π (diagram ι F (ι.obj x)) (structured_arrow.mk (𝟙 _)),
  naturality' := begin
    intros x y ff,
    dsimp only [whiskering_left],
    simp only [functor.comp_map, nat_trans.naturality_assoc, loc_map, category.assoc],
    congr' 1,
    erw limit.pre_π,
    change _ = _ ≫ (diagram ι F (ι.obj x)).map (structured_arrow.hom_mk _ _),
    rw limit.w,
    tidy,
  end },
  inv_fun := λ f,
  { app := λ x, limit.lift (diagram ι F x) (cone _ f),
    naturality' := begin
      intros x y ff,
      ext j,
      erw [limit.lift_pre, limit.lift_π, category.assoc, limit.lift_π (cone _ f) j],
      tidy,
    end },
  left_inv := begin
    intro x,
    ext k j,
    dsimp only [cone],
    rw limit.lift_π,
    simp only [nat_trans.naturality_assoc, loc_map],
    erw limit.pre_π,
    congr,
    cases j,
    tidy,
  end,
  right_inv := by tidy }

end Ran

/-- The right Kan extension of a functor. -/
@[simps]
def Ran [∀ X, has_limits_of_shape (structured_arrow X ι) D] : (S ⥤ D) ⥤ L ⥤ D :=
adjunction.right_adjoint_of_equiv (λ F G, (Ran.equiv ι G F).symm) (by tidy)

namespace Ran

variable (D)

/-- The adjunction associated to `Ran`. -/
def adjunction [∀ X, has_limits_of_shape (structured_arrow X ι) D] :
  (whiskering_left _ _ D).obj ι ⊣ Ran ι :=
adjunction.adjunction_of_equiv_right _ _

lemma reflective [full ι] [faithful ι] [∀ X, has_limits_of_shape (structured_arrow X ι) D] :
  is_iso (adjunction D ι).counit :=
begin
  apply nat_iso.is_iso_of_is_iso_app _,
  intros F,
  apply nat_iso.is_iso_of_is_iso_app _,
  intros X,
  dsimp [adjunction],
  simp only [category.id_comp],
  exact is_iso.of_iso ((limit.is_limit _).cone_point_unique_up_to_iso
    (limit_of_diagram_initial structured_arrow.mk_id_initial _)),
end

end Ran

namespace Lan

local attribute [simp] costructured_arrow.proj

/-- The diagram indexed by `Ran.index ι x` used to define `Ran`. -/
abbreviation diagram (F : S ⥤ D) (x : L) : costructured_arrow ι x ⥤ D :=
  costructured_arrow.proj ι x ⋙ F
variable {ι}

/-- A cocone over `Lan.diagram ι F x` used to define `Lan`. -/
@[simp]
def cocone {F : S ⥤ D} {G : L ⥤ D} (x : L) (f : F ⟶ ι ⋙ G) :
  cocone (diagram ι F x) :=
{ X := G.obj x,
  ι :=
  { app := λ i, f.app i.left ≫ G.map i.hom,
    naturality' := begin
      rintro ⟨ir, ⟨il⟩, i⟩ ⟨jl, ⟨jr⟩, j⟩ ⟨fl, ⟨⟨fl⟩⟩, ff⟩,
      dsimp at *,
      simp only [functor.comp_map, category.comp_id, nat_trans.naturality_assoc],
      rw [← G.map_comp, ff],
      tidy,
    end } }

variable (ι)

/-- An auxiliary definition used to define `Lan`. -/
@[simps]
def loc (F : S ⥤ D) [I : ∀ x, has_colimit (diagram ι F x)] : L ⥤ D :=
{ obj := λ x, colimit (diagram ι F x),
  map := λ x y f,
    colimit.pre (diagram _ _ _) (costructured_arrow.map f : costructured_arrow ι _ ⥤ _),
  map_id' := begin
    intro l,
    ext j,
    erw [colimit.ι_pre, category.comp_id],
    congr' 1,
    simp,
  end,
  map_comp' := begin
    intros x y z f g,
    ext j,
    let ff : costructured_arrow ι _ ⥤ _ := costructured_arrow.map f,
    let gg : costructured_arrow ι _ ⥤ _ := costructured_arrow.map g,
    let dd := diagram ι F z,
    -- I don't know why lean can't deduce the following three instances...
    haveI : has_colimit (ff ⋙ gg ⋙ dd) := I _,
    haveI : has_colimit ((ff ⋙ gg) ⋙ dd) := I _,
    haveI : has_colimit (gg ⋙ dd) :=  I _,
    change _ = colimit.ι ((ff ⋙ gg) ⋙ dd) j ≫ _ ≫ _,
    erw [colimit.pre_pre dd gg ff, colimit.ι_pre, colimit.ι_pre],
    congr' 1,
    simp,
  end }

/-- An auxiliary definition used to define `Lan` and `Lan.adjunction`. -/
@[simps]
def equiv (F : S ⥤ D) [I : ∀ x, has_colimit (diagram ι F x)] (G : L ⥤ D) :
  (loc ι F ⟶ G) ≃ (F ⟶ ((whiskering_left _ _ _).obj ι).obj G) :=
{ to_fun := λ f,
  { app := λ x,
      by apply colimit.ι (diagram ι F (ι.obj x)) (costructured_arrow.mk (𝟙 _)) ≫ f.app _, -- sigh
  naturality' := begin
    intros x y ff,
    dsimp only [whiskering_left],
    simp only [functor.comp_map, category.assoc],
    rw [← f.naturality (ι.map ff), ← category.assoc, ← category.assoc],
    let fff : costructured_arrow ι _ ⥤ _ := costructured_arrow.map (ι.map ff),
    -- same issue :-(
    haveI : has_colimit (fff ⋙ diagram ι F (ι.obj y)) := I _,
    erw colimit.ι_pre (diagram ι F (ι.obj y)) fff (costructured_arrow.mk (𝟙 _)),
    let xx : costructured_arrow ι (ι.obj y) := costructured_arrow.mk (ι.map ff),
    let yy : costructured_arrow ι (ι.obj y) := costructured_arrow.mk (𝟙 _),
    let fff : xx ⟶ yy := costructured_arrow.hom_mk ff
      (by {simp only [costructured_arrow.mk_hom_eq_self], erw category.comp_id}),
    erw colimit.w (diagram ι F (ι.obj y)) fff,
    congr,
    simp,
  end },
  inv_fun := λ f,
  { app := λ x, colimit.desc (diagram ι F x) (cocone _ f),
    naturality' := begin
      intros x y ff,
      ext j,
      erw [colimit.pre_desc, ← category.assoc, colimit.ι_desc, colimit.ι_desc],
      tidy,
    end },
  left_inv := begin
    intro x,
    ext k j,
    rw colimit.ι_desc,
    dsimp only [cocone],
    rw [category.assoc, ← x.naturality j.hom, ← category.assoc],
    congr' 1,
    change colimit.ι _ _ ≫ colimit.pre (diagram ι F k) (costructured_arrow.map _) = _,
    rw colimit.ι_pre,
    congr,
    cases j,
    tidy,
  end,
  right_inv := by tidy }

end Lan

/-- The left Kan extension of a functor. -/
@[simps]
def Lan [∀ X, has_colimits_of_shape (costructured_arrow ι X) D] : (S ⥤ D) ⥤ L ⥤ D :=
adjunction.left_adjoint_of_equiv (λ F G, Lan.equiv ι F G) (by tidy)

namespace Lan

variable (D)

/-- The adjunction associated to `Lan`. -/
def adjunction [∀ X, has_colimits_of_shape (costructured_arrow ι X) D] :
  Lan ι ⊣ (whiskering_left _ _ D).obj ι :=
adjunction.adjunction_of_equiv_left _ _

lemma coreflective [full ι] [faithful ι] [∀ X, has_colimits_of_shape (costructured_arrow ι X) D] :
  is_iso (adjunction D ι).unit :=
begin
  apply nat_iso.is_iso_of_is_iso_app _,
  intros F,
  apply nat_iso.is_iso_of_is_iso_app _,
  intros X,
  dsimp [adjunction],
  simp only [category.comp_id],
  exact is_iso.of_iso ((colimit.is_colimit _).cocone_point_unique_up_to_iso
    (colimit_of_diagram_terminal costructured_arrow.mk_id_terminal _)).symm,
end

end Lan

end category_theory


import caseI.statement
import caseII.statement

open flt_regular

/-- Statement of Fermat's last theorem for regular primes. -/
def flt_regular.statement : Prop := ∀ ⦃a b c : ℤ⦄ ⦃p : ℕ⦄ [hpri : fact p.prime]
  (hreg : @is_regular_prime p hpri) (hodd : p ≠ 2) (hprod : a * b * c ≠ 0),
  a ^ p + b ^ p ≠ c ^ p

/-- Fermat's last theorem for regular primes.. -/
theorem flt_regular {a b c : ℤ} {p : ℕ} [fact p.prime] (hreg : is_regular_prime p)
  (hodd : p ≠ 2) (hprod : a * b * c ≠ 0) : a ^ p + b ^ p ≠ c ^ p :=
begin
  by_cases case : ↑p ∣ a * b * c,
  exact caseII hreg hodd hprod case,
  exact caseI hreg case
end


/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.specific_limits
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Hofer's lemma

This is an elementary lemma about complete metric spaces. It is motivated by an
application to the bubbling-off analysis for holomorphic curves in symplectic topology.
We are *very* far away from having these applications, but the proof here is a nice
example of a proof needing to construct a sequence by induction in the middle of the proof.

## References:

* H. Hofer and C. Viterbo, *The Weinstein conjecture in the presence of holomorphic spheres*
-/

theorem hofer {X : Type u_1} [metric_space X] [complete_space X] (x : X) (ε : ℝ) (ε_pos : 0 < ε) {ϕ : X → ℝ} (cont : continuous ϕ) (nonneg : ∀ (y : X), 0 ≤ ϕ y) : ∃ (ε' : ℝ),
  ∃ (H : ε' > 0),
    ∃ (x' : X), ε' ≤ ε ∧ dist x' x ≤ bit0 1 * ε ∧ ε * ϕ x ≤ ε' * ϕ x' ∧ ∀ (y : X), dist x' y ≤ ε' → ϕ y ≤ bit0 1 * ϕ x' := sorry


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.apply
import Mathlib.control.fix
import Mathlib.order.omega_complete_partial_order
import Mathlib.PostPort

universes u_3 l u_1 u_2

namespace Mathlib

/-!
# Lawful fixed point operators

This module defines the laws required of a `has_fix` instance, using the theory of
omega complete partial orders (ωCPO). Proofs of the lawfulness of all `has_fix` instances in
`control.fix` are provided.

## Main definition

 * class `lawful_fix`
-/

/-- Intuitively, a fixed point operator `fix` is lawful if it satisfies `fix f = f (fix f)` for all
`f`, but this is inconsistent / uninteresting in most cases due to the existence of "exotic"
functions `f`, such as the function that is defined iff its argument is not, familiar from the
halting problem. Instead, this requirement is limited to only functions that are `continuous` in the
sense of `ω`-complete partial orders, which excludes the example because it is not monotone
(making the input argument less defined can make `f` more defined). -/
class lawful_fix (α : Type u_3) [omega_complete_partial_order α] extends has_fix α where
  fix_eq :
    ∀ {f : α →ₘ α},
      omega_complete_partial_order.continuous f → has_fix.fix ⇑f = coe_fn f (has_fix.fix ⇑f)

theorem lawful_fix.fix_eq' {α : Type u_1} [omega_complete_partial_order α] [lawful_fix α]
    {f : α → α} (hf : omega_complete_partial_order.continuous' f) :
    has_fix.fix f = f (has_fix.fix f) :=
  lawful_fix.fix_eq (omega_complete_partial_order.continuous.to_bundled f hf)

namespace roption

namespace fix

theorem approx_mono' {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) {i : ℕ} :
    approx (⇑f) i ≤ approx (⇑f) (Nat.succ i) :=
  sorry

theorem approx_mono {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) {i : ℕ} {j : ℕ} (hij : i ≤ j) :
    approx (⇑f) i ≤ approx (⇑f) j :=
  sorry

theorem mem_iff {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) (a : α) (b : β a) :
    b ∈ roption.fix (⇑f) a ↔ ∃ (i : ℕ), b ∈ approx (⇑f) i a :=
  sorry

theorem approx_le_fix {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) (i : ℕ) :
    approx (⇑f) i ≤ roption.fix ⇑f :=
  fun (a : α) (b : β a) (hh : b ∈ approx (⇑f) i a) =>
    eq.mpr (id (Eq._oldrec (Eq.refl (b ∈ roption.fix (⇑f) a)) (propext (mem_iff f a b))))
      (Exists.intro i hh)

theorem exists_fix_le_approx {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) (x : α) :
    ∃ (i : ℕ), roption.fix (⇑f) x ≤ approx (⇑f) i x :=
  sorry

/-- The series of approximations of `fix f` (see `approx`) as a `chain` -/
def approx_chain {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) :
    omega_complete_partial_order.chain ((a : α) → roption (β a)) :=
  preorder_hom.mk (approx ⇑f) sorry

theorem le_f_of_mem_approx {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) {x : (a : α) → roption (β a)}
    (hx : x ∈ approx_chain f) : x ≤ coe_fn f x :=
  eq.mpr (id (propext exists_imp_distrib))
    (fun (i : ℕ) (hx : x = coe_fn (approx_chain f) i) => Eq._oldrec (approx_mono' f) (Eq.symm hx))
    hx

theorem approx_mem_approx_chain {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) {i : ℕ} :
    approx (⇑f) i ∈ approx_chain f :=
  stream.mem_of_nth_eq rfl

end fix

theorem fix_eq_ωSup {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) :
    roption.fix ⇑f = omega_complete_partial_order.ωSup (fix.approx_chain f) :=
  sorry

theorem fix_le {α : Type u_1} {β : α → Type u_2}
    (f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)) {X : (a : α) → roption (β a)}
    (hX : coe_fn f X ≤ X) : roption.fix ⇑f ≤ X :=
  sorry

theorem fix_eq {α : Type u_1} {β : α → Type u_2}
    {f : ((a : α) → roption (β a)) →ₘ (a : α) → roption (β a)}
    (hc : omega_complete_partial_order.continuous f) : roption.fix ⇑f = coe_fn f (roption.fix ⇑f) :=
  sorry

end roption

namespace roption

/-- `to_unit` as a monotone function -/
def to_unit_mono {α : Type u_1} (f : roption α →ₘ roption α) :
    (Unit → roption α) →ₘ Unit → roption α :=
  preorder_hom.mk (fun (x : Unit → roption α) (u : Unit) => coe_fn f (x u)) sorry

theorem to_unit_cont {α : Type u_1} (f : roption α →ₘ roption α)
    (hc : omega_complete_partial_order.continuous f) :
    omega_complete_partial_order.continuous (to_unit_mono f) :=
  sorry

protected instance lawful_fix {α : Type u_1} : lawful_fix (roption α) := lawful_fix.mk sorry

end roption

namespace pi

protected instance lawful_fix {α : Type u_1} {β : Type u_2} : lawful_fix (α → roption β) :=
  lawful_fix.mk sorry

/-- `sigma.curry` as a monotone function. -/
def monotone_curry (α : Type u_1) (β : α → Type u_2) (γ : (a : α) → β a → Type u_3)
    [(x : α) → (y : β x) → preorder (γ x y)] :
    ((x : sigma fun (a : α) => β a) → γ (sigma.fst x) (sigma.snd x)) →ₘ
        (a : α) → (b : β a) → γ a b :=
  preorder_hom.mk sigma.curry sorry

/-- `sigma.uncurry` as a monotone function. -/
@[simp] theorem monotone_uncurry_to_fun (α : Type u_1) (β : α → Type u_2)
    (γ : (a : α) → β a → Type u_3) [(x : α) → (y : β x) → preorder (γ x y)]
    (f : (x : α) → (y : β x) → (fun (a : α) (b : β a) => γ a b) x y)
    (x : sigma fun (a : α) => β a) : coe_fn (monotone_uncurry α β γ) f x = sigma.uncurry f x :=
  Eq.refl (coe_fn (monotone_uncurry α β γ) f x)

theorem continuous_curry (α : Type u_1) (β : α → Type u_2) (γ : (a : α) → β a → Type u_3)
    [(x : α) → (y : β x) → omega_complete_partial_order (γ x y)] :
    omega_complete_partial_order.continuous (monotone_curry α β γ) :=
  sorry

theorem continuous_uncurry (α : Type u_1) (β : α → Type u_2) (γ : (a : α) → β a → Type u_3)
    [(x : α) → (y : β x) → omega_complete_partial_order (γ x y)] :
    omega_complete_partial_order.continuous (monotone_uncurry α β γ) :=
  sorry

protected instance has_fix {α : Type u_1} {β : α → Type u_2} {γ : (a : α) → β a → Type u_3}
    [has_fix ((x : sigma β) → γ (sigma.fst x) (sigma.snd x))] :
    has_fix ((x : α) → (y : β x) → γ x y) :=
  has_fix.mk
    fun (f : ((x : α) → (y : β x) → γ x y) → (x : α) → (y : β x) → γ x y) =>
      sigma.curry (has_fix.fix (sigma.uncurry ∘ f ∘ sigma.curry))

theorem uncurry_curry_continuous {α : Type u_1} {β : α → Type u_2} {γ : (a : α) → β a → Type u_3}
    [(x : α) → (y : β x) → omega_complete_partial_order (γ x y)]
    {f : ((x : α) → (y : β x) → γ x y) →ₘ (x : α) → (y : β x) → γ x y}
    (hc : omega_complete_partial_order.continuous f) :
    omega_complete_partial_order.continuous
        (preorder_hom.comp (monotone_uncurry α β γ) (preorder_hom.comp f (monotone_curry α β γ))) :=
  omega_complete_partial_order.continuous_comp (preorder_hom.comp f (monotone_curry α β γ))
    (monotone_uncurry α β γ)
    (omega_complete_partial_order.continuous_comp (monotone_curry α β γ) f (continuous_curry α β γ)
      hc)
    (continuous_uncurry α β γ)

protected instance pi.lawful_fix' {α : Type u_1} {β : α → Type u_2} {γ : (a : α) → β a → Type u_3}
    [(x : α) → (y : β x) → omega_complete_partial_order (γ x y)]
    [lawful_fix ((x : sigma β) → γ (sigma.fst x) (sigma.snd x))] :
    lawful_fix ((x : α) → (y : β x) → γ x y) :=
  lawful_fix.mk sorry

end Mathlib


-- Prueba de la asociatividad de la concatenación
-- ==============================================

import tactic
open list

variable  {α : Type}
variable  (x : α)
variables (xs ys zs : list α)

-- ----------------------------------------------------
-- Ejercicio 1. Definir la función
--    conc :: list α → list α → list α
-- tal que (conc xs ys) es la concatención de las
-- listas xs e ys. Por ejemplo,
--    conc [1,4] [2,4,1,3] = [1,4,2,4,1,3]
-- ----------------------------------------------------

def conc : list α → list α → list α
| []        ys := ys
| (x :: xs) ys := x :: (conc xs ys)

-- #eval conc [1,4] [2,4,1,3]

-- ----------------------------------------------------
-- Ejercicio 2. Demostrar los siguientes lemas
-- + conc_nil :
--     conc ([] : list α) ys = ys
-- + conc_cons :
--     conc (x :: xs) ys = x :: (conc xs ys)
-- ----------------------------------------------------

@[simp]
lemma conc_nil :
  conc ([] : list α) ys = ys :=
rfl

@[simp]
lemma conc_cons :
  conc (x :: xs) ys = x :: (conc xs ys) :=
rfl

-- ----------------------------------------------------
-- Ejercicio 3. (p. 24) Demostrar que
--    conc xs (conc ys zs) = conc (conc xs ys) zs
-- ----------------------------------------------------

-- 1ª demostración
example :
  conc xs (conc ys zs) = conc (conc xs ys) zs :=
begin
  induction xs with a as HI,
  { calc conc [] (conc ys zs)
         = conc ys zs                  : by rw conc_nil
     ... = conc (conc [] ys) zs        : by rw conc_nil, },
  { calc conc (a :: as) (conc ys zs)
         = a :: conc as (conc ys zs)   : by rw conc_cons
     ... = a :: conc (conc as ys) zs   : by rw HI
     ... = conc (a :: conc as ys) zs   : by rw conc_cons
     ... = conc (conc (a :: as) ys) zs : by rw ←conc_cons, },
end

-- 2ª demostración
example :
  conc xs (conc ys zs) = conc (conc xs ys) zs :=
begin
  induction xs with a as HI,
  { calc conc [] (conc ys zs)
         = conc ys zs                  : by simp
     ... = conc (conc [] ys) zs        : by simp, },
  { calc conc (a :: as) (conc ys zs)
         = a :: conc as (conc ys zs)   : by simp
     ... = a :: conc (conc as ys) zs   : by simp [HI]
     ... = conc (a :: conc as ys) zs   : by simp
     ... = conc (conc (a :: as) ys) zs : by simp, },
end

-- 3ª demostración
example :
  conc xs (conc ys zs) = conc (conc xs ys) zs :=
begin
  induction xs with a as HI,
  { by simp, },
  { by simp [HI], },
end

-- 4ª demostración
example :
  conc xs (conc ys zs) = conc (conc xs ys) zs :=
by induction xs ; simp [*]

-- 5ª demostración
example :
  conc xs (conc ys zs) = conc (conc xs ys) zs :=
begin
  induction xs with a as HI,
  { rw conc_nil,
    rw conc_nil, },
  { rw conc_cons,
    rw HI,
    rw conc_cons,
    rw conc_cons, },
end

-- 6ª demostración
example :
  conc xs (conc ys zs) = conc (conc xs ys) zs :=
list.rec_on xs
  ( show conc [] (conc ys zs) = conc (conc [] ys) zs,
      from calc
        conc [] (conc ys zs)
            = conc ys zs           : by rw conc_nil
        ... = conc (conc [] ys) zs : by rw conc_nil )
    ( assume a as,
      assume HI : conc as (conc ys zs) = conc (conc as ys) zs,
      show conc (a :: as) (conc ys zs) = conc (conc (a :: as) ys) zs,
        from calc
          conc (a :: as) (conc ys zs)
               = a :: conc as (conc ys zs)  : by rw conc_cons
          ... = a :: conc (conc as ys) zs   : by rw HI
          ... = conc (a :: conc as ys) zs   : by rw conc_cons
          ... = conc (conc (a :: as) ys) zs : by rw ←conc_cons)

-- 7ª demostración
example :
  conc xs (conc ys zs) = conc (conc xs ys) zs :=
list.rec_on xs
  (by simp)
  (by simp [*])

-- 8ª demostración
lemma conc_asoc_1 :
  ∀ xs, conc xs (conc ys zs) = conc (conc xs ys) zs
| [] := by calc
    conc [] (conc ys zs)
        = conc ys zs           : by rw conc_nil
    ... = conc (conc [] ys) zs : by rw conc_nil
| (a :: as) := by calc
    conc (a :: as) (conc ys zs)
        = a :: conc as (conc ys zs)   : by rw conc_cons
    ... = a :: conc (conc as ys) zs   : by rw conc_asoc_1
    ... = conc (a :: conc as ys) zs   : by rw conc_cons
    ... = conc (conc (a :: as) ys) zs : by rw ←conc_cons

-- 9ª demostración
lemma conc_asoc_2 :
  ∀ xs, conc xs (conc ys zs) = conc (conc xs ys) zs
| []         := by simp
| (a :: as)  := by simp [conc_asoc_2 as]

-- Comentarios sobre la función (++)
-- + Es equivalente a la función conc.
-- + Para usarla hay que importar la librería
--   data.list.basic y abrir el espacio de nombre
--   list escribiendo al principio del fichero
--      import data.list.basic
--      open list
-- + Se puede evaluar. Por ejemplo,
--      #eval [1,4] ++ [2,4,1,3]
-- + Se puede demostrar. Por ejemplo,
--      example :
--        xs ++ (ys ++ zs) = (xs ++ ys) ++ zs :=
--      -- by library_search
--      (append_assoc xs ys zs).symm
--
--      example :
--        (xs ++ ys) ++ zs = xs ++ (ys ++ zs) :=
--      -- by library_search
--      append_assoc xs ys zs
--
--      example :
--        (xs ++ ys) ++ zs = xs ++ (ys ++ zs) :=
--      by induction xs ; simp [*]


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Mario Carneiro, Johan Commelin, Amelia Livingston, Anne Baanen
-/
import algebra.ring.equiv
import group_theory.monoid_localization
import ring_theory.algebraic
import ring_theory.ideal.local_ring
import ring_theory.ideal.quotient
import ring_theory.integral_closure
import ring_theory.localization.fraction_ring
import ring_theory.localization.integer
import ring_theory.non_zero_divisors
import group_theory.submonoid.inverses
import tactic.ring_exp

/-!
# Integral and algebraic elements of a fraction field

## Implementation notes

See `src/ring_theory/localization/basic.lean` for a design overview.

## Tags
localization, ring localization, commutative ring localization, characteristic predicate,
commutative ring, field of fractions
-/
variables {R : Type*} [comm_ring R] (M : submonoid R) {S : Type*} [comm_ring S]
variables [algebra R S] {P : Type*} [comm_ring P]

open_locale big_operators polynomial

namespace is_localization

section integer_normalization

open polynomial

variables (M) {S} [is_localization M S]

open_locale classical

/-- `coeff_integer_normalization p` gives the coefficients of the polynomial
`integer_normalization p` -/
noncomputable def coeff_integer_normalization (p : S[X]) (i : ℕ) : R :=
if hi : i ∈ p.support
then classical.some (classical.some_spec
      (exist_integer_multiples_of_finset M (p.support.image p.coeff))
      (p.coeff i)
      (finset.mem_image.mpr ⟨i, hi, rfl⟩))
else 0

lemma coeff_integer_normalization_of_not_mem_support (p : S[X]) (i : ℕ)
  (h : coeff p i = 0) : coeff_integer_normalization M p i = 0 :=
by simp only [coeff_integer_normalization, h, mem_support_iff, eq_self_iff_true, not_true,
  ne.def, dif_neg, not_false_iff]

lemma coeff_integer_normalization_mem_support (p : S[X]) (i : ℕ)
  (h : coeff_integer_normalization M p i ≠ 0) : i ∈ p.support :=
begin
  contrapose h,
  rw [ne.def, not_not, coeff_integer_normalization, dif_neg h]
end

/-- `integer_normalization g` normalizes `g` to have integer coefficients
by clearing the denominators -/
noncomputable def integer_normalization (p : S[X]) :
  R[X] :=
∑ i in p.support, monomial i (coeff_integer_normalization M p i)

@[simp]
lemma integer_normalization_coeff (p : S[X]) (i : ℕ) :
  (integer_normalization M p).coeff i = coeff_integer_normalization M p i :=
by simp [integer_normalization, coeff_monomial, coeff_integer_normalization_of_not_mem_support]
  {contextual := tt}

lemma integer_normalization_spec (p : S[X]) :
  ∃ (b : M), ∀ i,
    algebra_map R S ((integer_normalization M p).coeff i) = (b : R) • p.coeff i :=
begin
  use classical.some (exist_integer_multiples_of_finset M (p.support.image p.coeff)),
  intro i,
  rw [integer_normalization_coeff, coeff_integer_normalization],
  split_ifs with hi,
  { exact classical.some_spec (classical.some_spec
      (exist_integer_multiples_of_finset M (p.support.image p.coeff))
      (p.coeff i)
      (finset.mem_image.mpr ⟨i, hi, rfl⟩)) },
  { convert (smul_zero _).symm,
    { apply ring_hom.map_zero },
    { exact not_mem_support_iff.mp hi } }
end

lemma integer_normalization_map_to_map (p : S[X]) :
  ∃ (b : M), (integer_normalization M p).map (algebra_map R S) = (b : R) • p :=
let ⟨b, hb⟩ := integer_normalization_spec M p in
⟨b, polynomial.ext (λ i, by { rw [coeff_map, coeff_smul], exact hb i })⟩

variables {R' : Type*} [comm_ring R']

lemma integer_normalization_eval₂_eq_zero (g : S →+* R') (p : S[X])
  {x : R'} (hx : eval₂ g x p = 0) :
  eval₂ (g.comp (algebra_map R S)) x (integer_normalization M p) = 0 :=
let ⟨b, hb⟩ := integer_normalization_map_to_map M p in
trans (eval₂_map (algebra_map R S) g x).symm
  (by rw [hb, ← is_scalar_tower.algebra_map_smul S (b : R) p, eval₂_smul, hx, mul_zero])

lemma integer_normalization_aeval_eq_zero [algebra R R'] [algebra S R'] [is_scalar_tower R S R']
  (p : S[X]) {x : R'} (hx : aeval x p = 0) :
  aeval x (integer_normalization M p) = 0 :=
by rw [aeval_def, is_scalar_tower.algebra_map_eq R S R',
       integer_normalization_eval₂_eq_zero _ _ _ hx]

end integer_normalization
end is_localization

namespace is_fraction_ring

open is_localization

variables {A K C : Type*} [comm_ring A] [is_domain A] [field K] [algebra A K] [is_fraction_ring A K]
variables [comm_ring C]

lemma integer_normalization_eq_zero_iff {p : K[X]} :
  integer_normalization (non_zero_divisors A) p = 0 ↔ p = 0 :=
begin
  refine (polynomial.ext_iff.trans (polynomial.ext_iff.trans _).symm),
  obtain ⟨⟨b, nonzero⟩, hb⟩ := integer_normalization_spec _ p,
  split; intros h i,
  { apply to_map_eq_zero_iff.mp,
    rw [hb i, h i],
    apply smul_zero,
    assumption },
  { have hi := h i,
    rw [polynomial.coeff_zero, ← @to_map_eq_zero_iff A _ K, hb i, algebra.smul_def] at hi,
    apply or.resolve_left (eq_zero_or_eq_zero_of_mul_eq_zero hi),
    intro h,
    apply mem_non_zero_divisors_iff_ne_zero.mp nonzero,
    exact to_map_eq_zero_iff.mp h }
end

variables (A K C)

/-- An element of a ring is algebraic over the ring `A` iff it is algebraic
over the field of fractions of `A`.
-/
lemma is_algebraic_iff [algebra A C] [algebra K C] [is_scalar_tower A K C] {x : C} :
  is_algebraic A x ↔ is_algebraic K x :=
begin
  split; rintros ⟨p, hp, px⟩,
  { refine ⟨p.map (algebra_map A K), λ h, hp (polynomial.ext (λ i, _)), _⟩,
    { have : algebra_map A K (p.coeff i) = 0 := trans (polynomial.coeff_map _ _).symm (by simp [h]),
      exact to_map_eq_zero_iff.mp this },
    { rwa is_scalar_tower.aeval_apply _ K at px } },
  { exact ⟨integer_normalization _ p,
           mt integer_normalization_eq_zero_iff.mp hp,
           integer_normalization_aeval_eq_zero _ p px⟩ },
end

variables {A K C}

/-- A ring is algebraic over the ring `A` iff it is algebraic over the field of fractions of `A`.
-/
lemma comap_is_algebraic_iff [algebra A C] [algebra K C] [is_scalar_tower A K C] :
  algebra.is_algebraic A C ↔ algebra.is_algebraic K C :=
⟨λ h x, (is_algebraic_iff A K C).mp (h x), λ h x, (is_algebraic_iff A K C).mpr (h x)⟩

end is_fraction_ring

open is_localization

section is_integral
variables {R S} {Rₘ Sₘ : Type*} [comm_ring Rₘ] [comm_ring Sₘ]
variables [algebra R Rₘ] [is_localization M Rₘ]
variables [algebra S Sₘ] [is_localization (algebra.algebra_map_submonoid S M) Sₘ]

variables {S M}

open polynomial

lemma ring_hom.is_integral_elem_localization_at_leading_coeff
  {R S : Type*} [comm_ring R] [comm_ring S] (f : R →+* S)
  (x : S) (p : R[X]) (hf : p.eval₂ f x = 0) (M : submonoid R)
  (hM : p.leading_coeff ∈ M) {Rₘ Sₘ : Type*} [comm_ring Rₘ] [comm_ring Sₘ]
  [algebra R Rₘ] [is_localization M Rₘ]
  [algebra S Sₘ] [is_localization (M.map f : submonoid S) Sₘ] :
  (map Sₘ f M.le_comap_map : Rₘ →+* _).is_integral_elem (algebra_map S Sₘ x) :=
begin
  by_cases triv : (1 : Rₘ) = 0,
  { exact ⟨0, ⟨trans leading_coeff_zero triv.symm, eval₂_zero _ _⟩⟩ },
  haveI : nontrivial Rₘ := nontrivial_of_ne 1 0 triv,
  obtain ⟨b, hb⟩ := is_unit_iff_exists_inv.mp
    (map_units Rₘ ⟨p.leading_coeff, hM⟩),
  refine ⟨(p.map (algebra_map R Rₘ)) * C b, ⟨_, _⟩⟩,
  { refine monic_mul_C_of_leading_coeff_mul_eq_one _,
    rwa leading_coeff_map_of_leading_coeff_ne_zero (algebra_map R Rₘ),
    refine λ hfp, zero_ne_one (trans (zero_mul b).symm (hfp ▸ hb) : (0 : Rₘ) = 1) },
  { refine eval₂_mul_eq_zero_of_left _ _ _ _,
    erw [eval₂_map, is_localization.map_comp, ← hom_eval₂ _ f (algebra_map S Sₘ) x],
    exact trans (congr_arg (algebra_map S Sₘ) hf) (ring_hom.map_zero _) }
end

/-- Given a particular witness to an element being algebraic over an algebra `R → S`,
We can localize to a submonoid containing the leading coefficient to make it integral.
Explicitly, the map between the localizations will be an integral ring morphism -/
theorem is_integral_localization_at_leading_coeff {x : S} (p : R[X])
  (hp : aeval x p = 0) (hM : p.leading_coeff ∈ M) :
  (map Sₘ (algebra_map R S)
      (show _ ≤ (algebra.algebra_map_submonoid S M).comap _, from M.le_comap_map)
    : Rₘ →+* _).is_integral_elem (algebra_map S Sₘ x) :=
(algebra_map R S).is_integral_elem_localization_at_leading_coeff x p hp M hM

/-- If `R → S` is an integral extension, `M` is a submonoid of `R`,
`Rₘ` is the localization of `R` at `M`,
and `Sₘ` is the localization of `S` at the image of `M` under the extension map,
then the induced map `Rₘ → Sₘ` is also an integral extension -/
theorem is_integral_localization (H : algebra.is_integral R S) :
  (map Sₘ (algebra_map R S)
    (show _ ≤ (algebra.algebra_map_submonoid S M).comap _, from M.le_comap_map)
    : Rₘ →+* _).is_integral :=
begin
  intro x,
  obtain ⟨⟨s, ⟨u, hu⟩⟩, hx⟩ := surj (algebra.algebra_map_submonoid S M) x,
  obtain ⟨v, hv⟩ := hu,
  obtain ⟨v', hv'⟩ := is_unit_iff_exists_inv'.1 (map_units Rₘ ⟨v, hv.1⟩),
  refine @is_integral_of_is_integral_mul_unit Rₘ _ _ _
    (localization_algebra M S) x (algebra_map S Sₘ u) v' _ _,
  { replace hv' := congr_arg (@algebra_map Rₘ Sₘ _ _ (localization_algebra M S)) hv',
    rw [ring_hom.map_mul, ring_hom.map_one, ← ring_hom.comp_apply _ (algebra_map R Rₘ)] at hv',
    erw is_localization.map_comp at hv',
    exact hv.2 ▸ hv' },
  { obtain ⟨p, hp⟩ := H s,
    exact hx.symm ▸ is_integral_localization_at_leading_coeff p hp.2 (hp.1.symm ▸ M.one_mem) }
end

lemma is_integral_localization' {R S : Type*} [comm_ring R] [comm_ring S]
  {f : R →+* S} (hf : f.is_integral) (M : submonoid R) :
  (map (localization (M.map (f : R →* S))) f M.le_comap_map : localization M →+* _).is_integral :=
@is_integral_localization R _ M S _ f.to_algebra _ _ _ _ _ _ _ _ hf

end is_integral

variables {A K : Type*} [comm_ring A] [is_domain A]

namespace is_integral_closure

variables (A) {L : Type*} [field K] [field L] [algebra A K] [algebra A L] [is_fraction_ring A K]
variables (C : Type*) [comm_ring C] [is_domain C] [algebra C L] [is_integral_closure C A L]
variables [algebra A C] [is_scalar_tower A C L]

open algebra

/-- If the field `L` is an algebraic extension of the integral domain `A`,
the integral closure `C` of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_algebraic (alg : is_algebraic A L)
  (inj : ∀ x, algebra_map A L x = 0 → x = 0) :
  is_fraction_ring C L :=
{ map_units := λ ⟨y, hy⟩,
    is_unit.mk0 _ (show algebra_map C L y ≠ 0, from λ h, mem_non_zero_divisors_iff_ne_zero.mp hy
      ((algebra_map C L).injective_iff.mp (algebra_map_injective C A L) _ h)),
  surj := λ z, let ⟨x, y, hy, hxy⟩ := exists_integral_multiple (alg z) inj in
    ⟨⟨mk' C (x : L) x.2, algebra_map _ _ y,
        mem_non_zero_divisors_iff_ne_zero.mpr (λ h, hy (inj _
          (by rw [is_scalar_tower.algebra_map_apply A C L, h, ring_hom.map_zero])))⟩,
     by rw [set_like.coe_mk, algebra_map_mk', ← is_scalar_tower.algebra_map_apply A C L, hxy]⟩,
  eq_iff_exists := λ x y, ⟨λ h, ⟨1, by simpa using algebra_map_injective C A L h⟩, λ ⟨c, hc⟩,
    congr_arg (algebra_map _ L) (mul_right_cancel₀ (mem_non_zero_divisors_iff_ne_zero.mp c.2) hc)⟩ }

variables (K L)

/-- If the field `L` is a finite extension of the fraction field of the integral domain `A`,
the integral closure `C` of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_finite_extension [algebra K L] [is_scalar_tower A K L]
  [finite_dimensional K L] : is_fraction_ring C L :=
is_fraction_ring_of_algebraic A C
  (is_fraction_ring.comap_is_algebraic_iff.mpr (is_algebraic_of_finite K L))
  (λ x hx, is_fraction_ring.to_map_eq_zero_iff.mp ((algebra_map K L).map_eq_zero.mp $
    (is_scalar_tower.algebra_map_apply _ _ _ _).symm.trans hx))

end is_integral_closure

namespace integral_closure

variables {L : Type*} [field K] [field L] [algebra A K] [is_fraction_ring A K]

open algebra

/-- If the field `L` is an algebraic extension of the integral domain `A`,
the integral closure of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_algebraic [algebra A L] (alg : is_algebraic A L)
  (inj : ∀ x, algebra_map A L x = 0 → x = 0) :
  is_fraction_ring (integral_closure A L) L :=
is_integral_closure.is_fraction_ring_of_algebraic A (integral_closure A L) alg inj

variables (K L)

/-- If the field `L` is a finite extension of the fraction field of the integral domain `A`,
the integral closure of `A` in `L` has fraction field `L`. -/
lemma is_fraction_ring_of_finite_extension [algebra A L] [algebra K L]
  [is_scalar_tower A K L] [finite_dimensional K L] :
  is_fraction_ring (integral_closure A L) L :=
is_integral_closure.is_fraction_ring_of_finite_extension A K L (integral_closure A L)

end integral_closure

namespace is_fraction_ring

variables (R S K)

/-- `S` is algebraic over `R` iff a fraction ring of `S` is algebraic over `R` -/
lemma is_algebraic_iff' [field K] [is_domain R] [is_domain S] [algebra R K] [algebra S K]
  [no_zero_smul_divisors R K] [is_fraction_ring S K] [is_scalar_tower R S K] :
  algebra.is_algebraic R S ↔ algebra.is_algebraic R K :=
begin
  simp only [algebra.is_algebraic],
  split,
  { intros h x,
    rw [is_fraction_ring.is_algebraic_iff R (fraction_ring R) K, is_algebraic_iff_is_integral],
    obtain ⟨(a : S), b, ha, rfl⟩ := @div_surjective S _ _ _ _ _ _ x,
    obtain ⟨f, hf₁, hf₂⟩ := h b,
    rw [div_eq_mul_inv],
    refine is_integral_mul _ _,
    { rw [← is_algebraic_iff_is_integral],
      refine _root_.is_algebraic_of_larger_base_of_injective
        (no_zero_smul_divisors.algebra_map_injective R (fraction_ring R)) _,
      exact is_algebraic_algebra_map_of_is_algebraic (h a) },
    { rw [← is_algebraic_iff_is_integral],
      use (f.map (algebra_map R (fraction_ring R))).reverse,
      split,
      { rwa [ne.def, polynomial.reverse_eq_zero, ← polynomial.degree_eq_bot,
          polynomial.degree_map_eq_of_injective
            (no_zero_smul_divisors.algebra_map_injective R (fraction_ring R)),
          polynomial.degree_eq_bot]},
      { haveI : invertible (algebra_map S K b),
           from is_unit.invertible (is_unit_of_mem_non_zero_divisors
              (mem_non_zero_divisors_iff_ne_zero.2
                (λ h, non_zero_divisors.ne_zero ha
                    ((ring_hom.injective_iff (algebra_map S K)).1
                    (no_zero_smul_divisors.algebra_map_injective _ _) b h)))),
        rw [polynomial.aeval_def, ← inv_of_eq_inv, polynomial.eval₂_reverse_eq_zero_iff,
          polynomial.eval₂_map, ← is_scalar_tower.algebra_map_eq, ← polynomial.aeval_def,
          ← is_scalar_tower.algebra_map_aeval, hf₂, ring_hom.map_zero] } } },
  { intros h x,
    obtain ⟨f, hf₁, hf₂⟩ := h (algebra_map S K x),
    use [f, hf₁],
    rw [← is_scalar_tower.algebra_map_aeval] at hf₂,
    exact (algebra_map S K).injective_iff.1
      (no_zero_smul_divisors.algebra_map_injective _ _) _ hf₂ }
end

open_locale non_zero_divisors

variables (R) {S K}
/-- If the `S`-multiples of `a` are contained in some `R`-span, then `Frac(S)`-multiples of `a`
are contained in the equivalent `Frac(R)`-span. -/
lemma ideal_span_singleton_map_subset {L : Type*}
  [is_domain R] [is_domain S] [field K] [field L]
  [algebra R K] [algebra R L] [algebra S L] [is_integral_closure S R L]
  [is_fraction_ring S L] [algebra K L] [is_scalar_tower R S L] [is_scalar_tower R K L]
  {a : S} {b : set S} (alg : algebra.is_algebraic R L) (inj : function.injective (algebra_map R L))
  (h : (ideal.span ({a} : set S) : set S) ⊆ submodule.span R b) :
  (ideal.span ({algebra_map S L a} : set L) : set L) ⊆ submodule.span K (algebra_map S L '' b) :=
begin
  intros x hx,
  obtain ⟨x', rfl⟩ := ideal.mem_span_singleton.mp hx,
  obtain ⟨y', z', rfl⟩ := is_localization.mk'_surjective (S⁰) x',
  obtain ⟨y, z, hz0, yz_eq⟩ := is_integral_closure.exists_smul_eq_mul alg inj y'
    (non_zero_divisors.coe_ne_zero z'),
  have injRS : function.injective (algebra_map R S),
  { refine function.injective.of_comp
      (show function.injective (algebra_map S L ∘ algebra_map R S), from _),
    rwa [← ring_hom.coe_comp, ← is_scalar_tower.algebra_map_eq] },
  have hz0' : algebra_map R S z ∈ S⁰ := map_mem_non_zero_divisors (algebra_map R S) injRS
    (mem_non_zero_divisors_of_ne_zero hz0),
  have mk_yz_eq : is_localization.mk' L y' z' = is_localization.mk' L y ⟨_, hz0'⟩,
  { rw [algebra.smul_def, mul_comm _ y, mul_comm _ y', ← set_like.coe_mk (algebra_map R S z) hz0']
        at yz_eq,
    exact is_localization.mk'_eq_of_eq yz_eq.symm },
  suffices hy : algebra_map S L (a * y) ∈ submodule.span K (⇑(algebra_map S L) '' b),
  { rw [mk_yz_eq, is_fraction_ring.mk'_eq_div, set_like.coe_mk,
        ← is_scalar_tower.algebra_map_apply, is_scalar_tower.algebra_map_apply R K L,
        div_eq_mul_inv, ← mul_assoc, mul_comm, ← ring_hom.map_inv, ← algebra.smul_def,
        ← _root_.map_mul],
    exact (submodule.span K _).smul_mem _ hy },
  refine submodule.span_subset_span R K _ _,
  rw submodule.span_algebra_map_image_of_tower,
  exact submodule.mem_map_of_mem (h (ideal.mem_span_singleton.mpr ⟨y, rfl⟩))
end
end is_fraction_ring


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/

import linear_algebra.basic
import modules.modules
import diagram_lemmas

open linear_map
open Module

universe u

section four
variables {R : Type u} [ring R]
variables {A : Type u} {B : Type u} {C : Type u} {D : Type u}
variables [add_comm_group A] [add_comm_group B] [add_comm_group C] [add_comm_group D]
variables [module R A] [module R B] [module R C] [module R D]
variables {A' : Type u} {B' : Type u} {C' : Type u} {D' : Type u}
variables [add_comm_group A'] [add_comm_group B'] [add_comm_group C'] [add_comm_group D']
variables [module R A'] [module R B'] [module R C'] [module R D']
variables {f : A →ₗ[R] B} {g : B →ₗ[R] C} {h : C →ₗ[R] D}
variables {f' : A' →ₗ[R] B'} {g' : B' →ₗ[R] C'} {h' : C' →ₗ[R] D'}
variables {α : A →ₗ[R] A'} {β : B →ₗ[R] B'} {γ : C →ₗ[R] C'} {δ : D →ₗ[R] D'}
variables (fg : f.range = g.ker) (gh : g.range = h.ker)
variables (fg' : f'.range = g'.ker) (gh' : g'.range = h'.ker)
variables (comm₁ : f'.comp α = β.comp f) (comm₂ : g'.comp β = γ.comp g) (comm₃ : h'.comp γ = δ.comp h)

include gh fg' comm₁ comm₂ comm₃

section
include fg

lemma modfour' (hα : α.range = ⊤) (hβ : β.ker = ⊥) (hδ : δ.ker = ⊥) : γ.ker = ⊥ :=
ker_eq_bot_of_mono' (up γ) $ four ((exact_is_exact (up f) (up g)).2 fg)
  ((exact_is_exact (up g) (up h)).2 gh)
  ((exact_is_exact (up f') (up g')).2 fg')
  ((exact_is_exact (up g') (up h')).2 gh')
  comm₁ comm₂ comm₃
  (epi_of_range_eq_top α hα)
  (mono_of_ker_eq_bot β hβ)
  (mono_of_ker_eq_bot δ hδ)

end

end four


lemma lt_iff_succ_le (a b : mynat) : a < b ↔ succ a ≤ b :=
begin
split,
exact lt_aux_one a b,
exact lt_aux_two a b,
end


import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem two_colorable_iff_bipartite (G : Type*) [decidable_eq G] [fintype G] : (∀ (x y : G), x ≠ y → ∃ (c : G), x ≠ c ∧ y ≠ c) ↔ (∀ (x y : G), x ≠ y → ∃ (c : G), x ≠ c ∧ y ≠ c) :=
begin
  split,

  --If G is 2-colorable, then G is bipartite.
  assume (h : ∀ (x y : G), x ≠ y → ∃ (c : G), x ≠ c ∧ y ≠ c),
  show (∀ (x y : G), x ≠ y → ∃ (c : G), x ≠ c ∧ y ≠ c), from
    assume (x y : G),
    assume (h1 : x ≠ y),
    have h2 : ∃ (c : G), x ≠ c ∧ y ≠ c, from h x y h1,
    show ∃ (c : G), x ≠ c ∧ y ≠ c, from h2,

  --If G is bipartite, then G is 2-colorable.
  assume (h : ∀ (x y : G), x ≠ y → ∃ (c : G), x ≠ c ∧ y ≠ c),
  show (∀ (x y : G), x ≠ y → ∃ (c : G), x ≠ c ∧ y ≠ c), from
    assume (x y : G),
    assume (h1 : x ≠ y),
    have h2 : ∃ (c : G), x ≠ c ∧ y ≠ c, from h x y h1,
    show ∃ (c : G), x ≠ c ∧ y ≠ c, from h2,

end

--OUTPUT 2
theorem graph_bipartite_iff_two_colorable (G : Type*) [graph G] : two_colorable G ↔ bipartite G :=
begin
  split,
    assume h1 : two_colorable G,
    use ⟨(color_subset G red), (color_subset G blue)⟩,
    assume (u v : G), assume h2 : edge G u v,
    have h3 : u ∈ (color_subset G red) ∨ u ∈ (color_subset G blue), from (h1 u).elim,
    have h4 : v ∈ (color_subset G red) ∨ v ∈ (color_subset G blue), from (h1 v).elim,
    cases h3,
      cases h4,
        have h5 : (color_subset G red) ∩ (color_subset G blue) = ∅, from by {
          rw set.inter_eq_empty_of_disjoint (color_subset G red) (color_subset G blue),
          exact not_same_color_implies_not_edge G,
        },
        have h6 : u ≠ v, from mt (eq_of_mem_singleton (h5.symm ▸ set.inter_singleton_left _ _)) h4,
        show false, from h6 h2,
      cases h4,
        have h7 : v ∈ (color_subset G red), from h4,
        show false, from (not_same_color_implies_not_edge G) h1 h2 h3 h7,
      cases h4,
        have h8 : u ∈ (color_subset G blue), from h3,
        show false, from (not_same_color_implies_not_edge G) h1 h2 h8 h4,
    assume h1 : bipartite G,
    have h2 : ∀ (u : G), u ∈ (color_subset G red) ∨ u ∈ (color_subset G blue), from by {
      assume (u : G),
      have h3 : u ∈ (h1.left) ∨ u ∈ (h1.right), from set.mem_or_mem_of_mem_union u (set.union_self _),
      cases h3,
        show u ∈ (color_subset G red) ∨ u ∈ (color_subset G blue), from by {left, exact h3},
      show u ∈ (color_subset G red) ∨ u ∈ (color_subset G blue), from by {right, exact h3},
    },
    exact ⟨λ u, ⟨h2 u⟩⟩,
end

--OUTPUT 3
theorem bipartite_graph_colorable {G : Type*} [graph G] : ∀ (V1 V2 : set (vertex G)),
  V1 ∪ V2 = vertex G ∧ V1 ∩ V2 = ∅ → (∀ v1 v2 : vertex G, v1 ∈ V1 ∧ v2 ∈ V2 → (v1,v2) ∉ edge G) →
  ∃ c : vertex G → color, ∀ v : vertex G, (c v = red ∨ c v = blue) ∧
  ∀ u : vertex G, (u,v) ∈ edge G → c u ≠ c v :=
begin
  assume (V1 V2 : set (vertex G)) (h1 : V1 ∪ V2 = vertex G ∧ V1 ∩ V2 = ∅) (h2 : ∀ v1 v2 : vertex G, v1 ∈ V1 ∧ v2 ∈ V2 → (v1,v2) ∉ edge G),
  use (λ v : vertex G, if v ∈ V1 then red else blue),
  assume v : vertex G,
  have h3 : v ∈ V1 ∨ v ∈ V2, from or.inl (mem_union_left V2 v),
  have h4 : (∀ v1 v2 : vertex G, v1 ∈ V1 ∧ v2 ∈ V2 → (v1,v2) ∉ edge G) → ∀ u : vertex G, u ∈ V1 → (u,v) ∉ edge G, from assume h5 : (∀ v1 v2 : vertex G, v1 ∈ V1 ∧ v2 ∈ V2 → (v1,v2) ∉ edge G),
    assume u : vertex G, assume h6 : u ∈ V1, assume h7 : (u,v) ∈ edge G,
    have h8 : u ∈ V1 ∧ v ∈ V2, from by {split,exact h6,exact or.inr (mem_union_right V1 v)},
    have h9 : (u,v) ∉ edge G, from by {apply h5 u v h8},
    show false, from by {apply h9 h7},

  have h10 : v ∉ V1 ∨ v ∉ V2, from by {assume h11 : v ∈ V1 ∧ v ∈ V2, have h12 : v ∈ V1 ∩ V2, from by {split,exact h11.left, exact h11.right}, show false, from by {apply (h1.right) h12}},
  have h11 : (∀ v1 v2 : vertex G, v1 ∈ V1 ∧ v2 ∈ V2 → (v1,v2) ∉ edge G) → ∀ u : vertex G, u ∈ V2 → (u,v) ∉ edge G, from assume h12 : (∀ v1 v2 : vertex G, v1 ∈ V1 ∧ v2 ∈ V2 → (v1,v2) ∉ edge G),
    assume u : vertex G, assume h13 : u ∈ V2, assume h14 : (u,v) ∈ edge G,
    have h15 : u ∈ V1 ∧ v ∈ V2, from by {split,exact or.inl (mem_union_left V2 u), exact h13},
    have h16 : (u,v) ∉ edge G, from by {apply h12 u v h15},
    show false, from by {apply h16 h14},
  have h12 : ∀ u : vertex G, (u,v) ∈ edge G → u ∉ V1, from assume u : vertex G, assume h13 : (u,v) ∈ edge G, assume h14 : u ∈ V1,
    have h15 : (u,v) ∉ edge G, from h4 h2 u h14,
    show false, from by {apply h15 h13},
  have h13 : ∀ u : vertex G, (u,v) ∈ edge G → u ∉ V2, from assume u : vertex G, assume h14 : (u,v) ∈ edge G, assume h15 : u ∈ V2,
    have h16 : (u,v) ∉ edge G, from h11 h2 u h15,
    show false, from by {apply h16 h14},

  have h14 : ∀ u : vertex G, (u,v) ∈ edge G → c u ≠ c v, from assume u : vertex G, assume h15 : (u,v) ∈ edge G,
    have h16 : u ∉ V1 ∨ u ∉ V2, from by {assume h17 : u ∈ V1 ∧ u ∈ V2, have h18 : u ∈ V1 ∩ V2, from by {split,exact h17.left, exact h17.right}, show false, from by {apply (h1.right) h18}},
    have h17 : c u = red ∨ c u = blue, from or.inl (or.inl (mem_union_left V2 u)),
    have h18 : c v = red ∨ c v = blue, from or.inl (or.inr (mem_union_right V1 v)),
    have h19 : c u = red ∧ c v = blue ∨ c u = blue ∧ c v = red, from by {cases h16,cases h17,cases h18,split,exact h.left, exact h0.left,split,exact h.right,exact h0.right},
    show c u ≠ c v, from by {cases h19,exact ne.symm (ne.trans (h12 u h15 h19.left) (ne.symm h19.right)),exact ne.symm (ne.trans (h13 u h15 h19.right) (ne.symm h19.left))},
  show (c v = red ∨ c v = blue) ∧ ∀ u : vertex G, (u,v) ∈ edge G → c u ≠ c v, from by {split,exact or.inl (or.inr (mem_union_right V1 v)), exact h14},
end

--OUTPUT 4
theorem graph_two_colorable {V : Type*} (E : V → V → Prop) :
  (∃ c : V → Prop, ∀ x : V, c x ∨ ¬ c x) ↔ (∃ A B : set V, ∀ x y, E x y → x ∈ A ∧ y ∈ B ∨ x ∈ B ∧ y ∈ A) :=
begin
  apply iff.intro,
    assume h1 : ∃ c : V → Prop, ∀ x : V, c x ∨ ¬ c x,
      obtain (c : V → Prop) (hc : ∀ x : V, c x ∨ ¬ c x), from h1,
      let A := {v : V | c v},
      let B := {v : V | ¬ c v},
      show ∃ A B : set V, ∀ x y, E x y → x ∈ A ∧ y ∈ B ∨ x ∈ B ∧ y ∈ A, from by {
        use A, use B,
        assume x y : V,
        assume h1 : E x y,
        show x ∈ A ∧ y ∈ B ∨ x ∈ B ∧ y ∈ A, from by {
          have h2 : c x ∨ ¬ c x, from by apply hc x,
          have h3 : c y ∨ ¬ c y, from by apply hc y,
          cases h2,
            cases h3,
              show x ∈ A ∧ y ∈ B ∨ x ∈ B ∧ y ∈ A, from by {
                left,
                apply and.intro,
                  show x ∈ A, from by {
                    apply set.mem_def,
                    exact h2,
                  },
                  show y ∈ B, from by {
                    apply set.mem_def,
                    exact h3,
                  },
              },
            cases h3,
              show x ∈ A ∧ y ∈ B ∨ x ∈ B ∧ y ∈ A, from by {
                right,
                apply and.intro,
                  show x ∈ B, from by {
                    apply set.mem_def,
                    exact h3,
                  },
                  show y ∈ A, from by {
                    apply set.mem_def,
                    exact h2,
                  },
              },
        },
      },
    assume h2 : ∃ A B : set V, ∀ x y, E x y → x ∈ A ∧ y ∈ B ∨ x ∈ B ∧ y ∈ A,
      obtain (A B : set V) (hAB : ∀ x y, E x y → x ∈ A ∧ y ∈ B ∨ x ∈ B ∧ y ∈ A), from h2,
      show ∃ c : V → Prop, ∀ x : V, c x ∨ ¬ c x, from by {
        let c := λ x : V, x ∈ A,
        use c,
        assume x : V,
        show c x ∨ ¬ c x, from by {
          have h3 : E x x, from by obviously,
          have h4 : x ∈ A ∨ x ∈ B, from by {
            cases hAB x x h3,
              cases a,
                show x ∈ A ∨ x ∈ B, from by {
                  left,
                  exact a_left,
                },
              cases a,
                show x ∈ A ∨ x ∈ B, from by {
                  right,
                  exact a_left,
                },
          },
          show c x ∨ ¬ c x, from by {
            cases h4,
              show c x ∨ ¬ c x, from by {
                left,
                exact h4,
              },
              show c x ∨ ¬ c x, from by {
                right,
                intro h5,
                show false, from by {
                  apply not_mem_empty x,
                  apply set.inter_eq_empty_of_disjoint,
                    show x ∉ A, from by {
                      apply set.not_mem_of_mem_not_mem h4,
                      exact h5,
                    },
                    show x ∉ B, from by {
                      apply set.not_mem_of_mem_not_mem h4,
                      exact h5,
                    },
                },
              },
          },
        },
      },
end

--OUTPUT 5
theorem bipartite_two_colorable {G : Type*} [fintype G] [decidable_eq G] [fintype (G × G)] [decidable_eq (G × G)] [fintype (set (G × G))] [decidable_pred (set (G × G))] (h : bipartite G) : two_colorable G :=
begin
  have h1 : ∀ v : G, v ∈ vertex_set G → v ∈ (h.left_vertex_set) ∨ v ∈ (h.right_vertex_set),
  from assume v hv, if hv' : v ∈ (h.left_vertex_set) then or.inl hv' else or.inr $ by {
    have h1 : v ∈ (h.right_vertex_set), from set.mem_of_mem_diff hv hv',
    assumption,
  },
  have h2 : ∀ v : G, v ∈ vertex_set G → v ∉ (h.left_vertex_set) → v ∈ (h.right_vertex_set),
  from assume v hv hv', set.mem_of_mem_diff hv' $ h1 v hv,

  use (h.left_vertex_set), use (h.right_vertex_set),
  assume e he,
  have h3 : e.1 ∈ vertex_set G, from set.mem_of_mem_image (by assumption) (by assumption),
  have h4 : e.2 ∈ vertex_set G, from set.mem_of_mem_image (by assumption) (by assumption),
  have h5 : e.1 ∈ (h.left_vertex_set) ∨ e.1 ∈ (h.right_vertex_set), from h1 e.1 h3,
  have h6 : e.2 ∈ (h.left_vertex_set) ∨ e.2 ∈ (h.right_vertex_set), from h1 e.2 h4,
  show (e.1 ∉ (h.left_vertex_set)) ∨ (e.2 ∉ (h.left_vertex_set)), from or_iff_not_imp_left.mp $ by {
    cases h5,
    rw ← or_iff_not_imp_left,
    rw ← or_iff_not_imp_left,
    have h7 : e.2 ∈ (h.right_vertex_set), from h2 e.2 h4 h5,
    have h8 : e ∈ (h.right_edge_set), from set.mem_of_mem_image h7 (by assumption),
    have h9 : e ∉ (h.left_edge_set), from set.not_mem_of_mem_diff he h8,
    rw ← set.compl_eq_empty,
    rw set.mem_compl_iff,
    assumption,
  },
end

--OUTPUT 6
theorem bipartite_graph_two_colorable (G : Type*) [graph G] : ∀ V1 V2 : set G, (V1 ∪ V2 = univ) ∧ (V1 ∩ V2 = ∅) → (∀ x y : G, (x ∈ V1 ∧ y ∈ V2) ∨ (y ∈ V1 ∧ x ∈ V2)) → (∀ x y : G, adjacent x y → (x ∈ V1 ∧ y ∈ V2) ∨ (y ∈ V1 ∧ x ∈ V2)) :=
begin
  assume (V1 : set G) (V2 : set G) (h1 : (V1 ∪ V2 = univ) ∧ (V1 ∩ V2 = ∅)) (h2 : ∀ x y : G, (x ∈ V1 ∧ y ∈ V2) ∨ (y ∈ V1 ∧ x ∈ V2)),
  assume (x y : G) (h3 : adjacent x y),
  have h4 : x ∈ V1 ∨ x ∈ V2, from by {
    apply set.subset.elim h1.left.symm (set.mem_univ x), },
  have h5 : y ∈ V1 ∨ y ∈ V2, from by {
    apply set.subset.elim h1.left.symm (set.mem_univ y), },
  by_cases h6 : x ∈ V1,
    have h7 : (y ∈ V1 ∧ x ∈ V2) → false, from by {
      assume (h8 : y ∈ V1 ∧ x ∈ V2),
      show false, from absurd h8.left (set.not_mem_empty _ h1.right), },
    have h8 : (x ∈ V1 ∧ y ∈ V2) ∨ (y ∈ V1 ∧ x ∈ V2), from or.inr (and.intro h6 h5.elim_right),
    show (x ∈ V1 ∧ y ∈ V2) ∨ (y ∈ V1 ∧ x ∈ V2), from or.inl (and.intro h6 h5.elim_right),
  have h9 : (x ∈ V1 ∧ y ∈ V2) → false, from by {
    assume (h10 : x ∈ V1 ∧ y ∈ V2),
    show false, from absurd h10.right (set.not_mem_empty _ h1.right),
  },
  have h10 : (x ∈ V1 ∧ y ∈ V2) ∨ (y ∈ V1 ∧ x ∈ V2), from or.inr (and.intro h4.elim_right h5),
  show (x ∈ V1 ∧ y ∈ V2) ∨ (y ∈ V1 ∧ x ∈ V2), from or.inr (and.intro h4.elim_right h5),
end

--OUTPUT 7
theorem two_colorable_iff_bipartite (G : Type*) [decidable_eq G] [fintype G] [fintype (G × G)] (h1 : ∀ (x y : G), x ≠ y → ∃! z : G × G, z.1 = x ∧ z.2 = y) :
  (∃ (A B : set G), ∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y))) ↔
  (∃ (A B : set G), (A ∪ B = G) ∧ (∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y)))) :=
begin
  split,
  assume h,
  have h2 : ∀ (A B : set G) (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y)) → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B)), from
    assume A B x y hxy h,
    have h3 : ∃! z : G × G, z.1 = x ∧ z.2 = y, from h1 x y hxy,
    have h4 : ∃ z : G × G, z.1 = x ∧ z.2 = y, from exists_unique.exists h3,
    have h5 : ∃ z : G × G, z.1 = x ∧ z.2 = y ∧ z.1 ∈ A ∧ z.2 ∈ B, from exists.elim h4 (
      assume z hz : G × G,
      have h6 : ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y), from h,
      have h7 : ∃ z : G × G, (z.1 = x ∧ z.2 = y) ∧ z ∈ (A × B), from exists.elim h6 (
        assume z hz : G × G,
        have h8 : z.1 = x ∧ z.2 = y, from hz.left,
        have h9 : z ∈ (A × B), from hz.right,
        show ∃ z : G × G, (z.1 = x ∧ z.2 = y) ∧ z ∈ (A × B), from ⟨z, ⟨h8, h9⟩⟩),
      have h10 : ∃ z : G × G, (z.1 = x ∧ z.2 = y) ∧ z ∈ (A × B) ∧ z ∈ (A × B), from ⟨z, h7, hz.left, hz.right⟩,
      show ∃ z : G × G, z.1 = x ∧ z.2 = y ∧ z ∈ (A × B) ∧ (z.1 ∈ A ∧ z.2 ∈ B), from h10),
    show ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B), from h5,
  have h3 : ∀ (A B : set G), A ∪ B = G → (∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y))) → (∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B))), from
    assume (A B : set G) hAB h : ∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y)),
    assume (x y : G) hxy,
    have h4 : ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y), from h x y hxy,
    have h5 : ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B), from h2 A B x y hxy h4,
    show ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B), from h5,
  have h4 : ∀ (A B : set G), A ∪ B = G → (∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B))) → (∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B) ∧ ∀ (x' y' : G), x' ≠ y' → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x' ∧ z.2 = y')))), from
    assume (A B : set G) hAB h : ∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B)),
    assume (x y : G) hxy,
    have h5 : ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B), from h x y hxy,
    have h6 : ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B) ∧ ∀ (x' y' : G), x' ≠ y' → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x' ∧ z.2 = y')), from ⟨(classical.some h5).1,(classical.some h5).2.left,(classical.some h5).2.right.left,(classical.some h5).2.right.right,h⟩,
    show ∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B) ∧ ∀ (x' y' : G), x' ≠ y' → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x' ∧ z.2 = y')), from h6,
  have h5 : ∀ (A B : set G), A ∪ B = G → (∀ (x y : G), x ≠ y → (∃ z : G × G, z ∈ (A × B) ∧ (z.1 = x ∧ z.2 = y) ∧ (z.1 ∈ A ∧ z.2 ∈ B) ∧ ∀ (x' y' : G), x' ≠ y' → (∃ z : G × G, z ∈
end --Needs more than 2000 tokens!

--OUTPUT 8
theorem bipartite_iff_two_colorable {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  split,
  assume h1 : two_colorable G,
  have h2 : ∃! (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1), from
    @exists_unique_of_two_colorable G _ h1,
  have h3 : ∀ (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1) → (V1 = h2.some.fst ∧ V2 = h2.some.snd), from
    assume (V1 V2 : set G.V) (h4 : V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1)),
    have h5 : ∃! (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1), from ⟨⟨V1,V2,h4.left⟩,h4.right⟩,
    begin
      apply exists_unique.unique h5 h2,
      simp,
      exact h4.left
    end,
  have h6 : ∃! (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1), from
    h2.unique (h3 _ _ (exists_unique.exists h2)),
  show bipartite G, from ⟨⟨h6.some.fst,h6.some.snd⟩,h6.some.property⟩,
  assume h1 : bipartite G,
  have h2 : ∃! (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1), from ⟨⟨h1.some.fst,h1.some.snd⟩,h1.some.property⟩,
  have h3 : ∃ (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1), from ⟨⟨h2.some.fst,h2.some.snd⟩,h2.some.property⟩,
  have h4 : ∀ (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1) → (V1 = h2.some.fst ∧ V2 = h2.some.snd), from
    assume (V1 V2 : set G.V) (h5 : V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1)),
    begin
      apply exists_unique.unique h2,
      simp,
      exact h5.left
    end,
  have h6 : ∃! (V1 V2 : set G.V), V1 ∩ V2 = ∅ ∧ ∀ {v1 v2 : G.V}, (v1,v2) ∈ G.E → (v1 ∈ V1 ∧ v2 ∈ V2) ∨ (v1 ∈ V2 ∧ v2 ∈ V1), from
    h2.unique (h4 _ _ (exists_unique.exists h3)),
  show two_colorable G, from ⟨⟨h6.some.fst,h6.some.snd⟩,h6.some.property⟩,
end

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

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

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

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

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

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

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  show (A ∩ B) ∈  𝒫 S, from by {apply set.mem_powerset h3},
end

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

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  ... = x*x + x*y + y*x + y*y : by {rw [mul_comm x (x+y),mul_comm y (x+y)], rw [add_mul,add_mul], ring}
  ... = x^2 + 2*x*y + y^2 : by {repeat {rw ← sq}, rw mul_comm y x, ring}
end

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

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

Setting $b = a$, this becomes:

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

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

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by {
    assume a b : G, use a⁻¹ * b, obviously, },
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by {
    assume a b : G, use b * a⁻¹, obviously, },

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from
    assume a : G, h1 a a,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from
    assume a : G, h2 a a,

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from assume a :G,
    exists_unique.unique (h3 a) (classical.some_spec (exists_unique.exists (h3 a)))
    (mul_one a),
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from assume a : G,
    exists_unique.unique (h4 a) (classical.some_spec (exists_unique.exists (h4 a))) (one_mul a),

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (hident : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a).exists, from assume (a : G),
        exists_unique.unique (h3 a) (hident a).right
        (classical.some_spec (exists_unique.exists (h3 a))),
      have h9 : ∀ a : G, e = classical.some (h4 a).exists, from assume (a : G),
        exists_unique.unique (h4 a) (hident a).left
        (classical.some_spec (exists_unique.exists (h4 a))),
      show e = (1 : G), from eq.trans (h9 e) (h6 _),
    },
    exact ⟨by obviously, h7⟩,
  }
end

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

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

QED

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


theorem ex (n : Nat) (h : n = 0) : 0 + n = 0 := by
  let m := n + 1
  let v := m + 1
  have : v = n + 2 := rfl
  traceState
  subst h
  traceState
  rfl


import lambda_calculus.utlc.beta.distance
import lambda_calculus.utlc.beta.encoding.basic
import lambda_calculus.utlc.beta.encoding.core
import lambda_calculus.utlc.beta.encoding.nat
import lambda_calculus.utlc.beta.complexity.core
import complexity.basic
import complexity.nat

open complexity
open lambda_calculus.utlc.β.encoding

namespace lambda_calculus
namespace utlc
namespace β
namespace complexity
namespace nat

local attribute [simp] distance_model closed
local attribute [simp] β.normal_iteration β.strategic_reduction_step head_reduced substitution down_shift

def succ_prog: encoded_program := ⟨ Λ Λ Λ ↓1·(↓2·↓1·↓0), by simp ⟩

instance succ_complexity: has_complexity church_model nat.succ :=
  ⟨ ⟨ λ _, (3:ℕ), ⟨ succ_prog,
begin
  simp only [cast_unwrap, cast_eq],
  intros n,
  apply β.distance_le_of_normal_iteration 3,
  simp [succ_prog, has_encoding.value, encoding.nat.iterate, function.iterate_succ']
end ⟩ ⟩ ⟩

def add_prog: encoded_program := ⟨ Λ Λ Λ Λ ↓3·↓1·(↓2·↓1·↓0), by simp [← one_add_one_eq_two] ⟩

instance add_complexity: has_complexity church_model nat.add :=
  ⟨ ⟨ λ _ _, (6:ℕ), ⟨ add_prog,
begin
  simp only [cast_unwrap, cast_eq],
  intros n m,
  apply distance_le_trans' 4 2,
  apply β.distance_le_of_normal_iteration,
  simp [add_prog, has_encoding.value, function.iterate_succ'],
  apply β.lambda_distance_le_lambda,
  apply β.lambda_distance_le_lambda,
  induction n generalizing m,
  { cases m;
    apply β.distance_le_of_normal_iteration;
    simp [function.iterate_succ', function.iterate_zero, encoding.nat.iterate] },
  simp [function.iterate_succ', function.iterate_zero, encoding.nat.iterate, nat.succ_add],
  apply β.dot_distance_le_dot_right,
  apply n_ih,
  simp,
end ⟩ ⟩ ⟩

def iterate_prog: encoded_program := ⟨ Λ Λ Λ ↓1·↓2·↓0, by simp ⟩

namespace iteration_complexity

lemma iterate_distance_le {n: ℕ} {f g: utlc}: distance_le n f g → ∀ (a: utlc) (m: ℕ), distance_le n ((has_dot.dot a)^[m] f) ((has_dot.dot a)^[m] g) :=
begin
  intros hfg a m,
  induction m generalizing f g,
  simp [hfg],
  simp,
  apply m_ih,
  apply dot_distance_le_dot_right hfg,
end

def cost {α: Type}
  (fi: α → α) (ni: α → ℕ): ℕ → α → ℕ
| 0 := λ fz, 5
| (n+1) := λ fz, (ni fz) + (cost n (fi fz)) + 10

theorem cost_zero {α: Type} (fi: α → α) (ni: α → ℕ) (a: α): cost fi ni 0 a = 5 := rfl

theorem cost_succ {α: Type} (fi: α → α) (ni: α → ℕ) (n: ℕ) (a: α): cost fi ni (n + 1) a = (ni a) + cost fi ni n (fi a) + 10 := rfl

theorem cost_succ' {α: Type} (fi: α → α) (ni: α → ℕ) (n: ℕ) (a: α): cost fi ni (n + 1) a = (ni (fi^[n] a)) + cost fi ni n a + 10 :=
begin
  rw [cost_succ],
  induction n generalizing a,
  simp [cost_zero],
  rw [cost_succ, n_ih, cost_succ, function.iterate_succ],
  simp [nat.add_assoc, nat.add_left_comm _ (ni a)],
end

@[simp] def cost' {α: Type} [α_en: has_encoding church_model α]
  (fi: α → α) (ni: complexity.cost_function' church_model (α → ℕ)): complexity.cost_function' church_model (ℕ → α → α) := cost fi ni
end iteration_complexity

instance iteration_complexity (α: Type) [α_en: has_encoding church_model α]
  (f: α → α) [cf: has_complexity church_model f]: has_complexity church_model (nat.iterate f) :=
⟨ ⟨ iteration_complexity.cost' f cf.value.cost,
begin
  rcases cf.value with ⟨cfc, fp, cfp⟩,
  fconstructor,
  use iterate_prog.value·fp.value,
  { simp },
  simp only [cast_unwrap, cast_eq, iterate_prog],
  intros n a,
  induction n generalizing a,
  { apply β.distance_le_of_normal_iteration,
    simp [has_encoding.value, encoding.nat.iterate, iteration_complexity.cost_zero] },
  { apply distance_le_trans',
    apply β.distance_le_of_normal_iteration 5,
    refl,
    simp [has_encoding.value, encoding.nat.iterate],
    apply distance_le_trans' (5 + (cfc a)) _ _ (n_ih (f a)),
    all_goals { clear n_ih },
    refl,
    simp [has_encoding.value, encoding.nat.iterate],
    apply distance_le_symm,
    apply distance_le_trans',
    apply β.distance_le_of_normal_iteration 5,
    simp,
    apply distance_le_symm,
    simp [encoding.nat.iterate],
    apply iteration_complexity.iterate_distance_le,
    apply cfp,
    refl,
    simp [iteration_complexity.cost_succ],
    ring }
end ⟩ ⟩

example:  (complexity church_model nat.mul) ≤ (λ (x y: ℕ), ((30*y + 43):ℕ)) :=
begin
  intros n m,
  simp only [complexity, complexity.cost_function.less_than_or_equal, has_complexity.value, fork, const, uncurry],
  ring_nf,
  norm_num,
  induction m,
  { simp only [iteration_complexity.cost_zero],
    ring_nf },
  simp only [iteration_complexity.cost_succ', function.iterate_succ', nat.mul_succ, add_mul, nat.add_assoc],
  nlinarith,
end

end nat
end complexity
end β
end utlc
end lambda_calculus


/-
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_419
  (a b : ℝ)
  (h₀ : a = -1)
  (h₁ : b = 5) :
  -a - b^2 + 3 * (a * b) = -39 :=
begin
  rw [h₀, h₁],
  norm_num,
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.sheaves.presheaf
import category_theory.limits.final
import topology.sheaves.sheaf_condition.pairwise_intersections

/-!
# Another version of the sheaf condition.

Given a family of open sets `U : ι → opens X` we can form the subcategory
`{ V : opens X // ∃ i, V ≤ U i }`, which has `supr U` as a cocone.

The sheaf condition on a presheaf `F` is equivalent to
`F` sending the opposite of this cocone to a limit cone in `C`, for every `U`.

This condition is particularly nice when checking the sheaf condition
because we don't need to do any case bashing
(depending on whether we're looking at single or double intersections,
or equivalently whether we're looking at the first or second object in an equalizer diagram).

## References
* This is the definition Lurie uses in [Spectral Algebraic Geometry][LurieSAG].
-/

universes v u

noncomputable theory

open category_theory
open category_theory.limits
open topological_space
open opposite
open topological_space.opens

namespace Top

variables {C : Type u} [category.{v} C]
variables {X : Top.{v}} (F : presheaf C X) {ι : Type v} (U : ι → opens X)

namespace presheaf

namespace sheaf_condition

/--
The category of open sets contained in some element of the cover.
-/
def opens_le_cover : Type v := { V : opens X // ∃ i, V ≤ U i }

instance [inhabited ι] : inhabited (opens_le_cover U) :=
⟨⟨⊥, default ι, bot_le⟩⟩

instance : category (opens_le_cover U) := category_theory.full_subcategory _

namespace opens_le_cover

variables {U}

/--
An arbitrarily chosen index such that `V ≤ U i`.
-/
def index (V : opens_le_cover U) : ι := V.property.some

/--
The morphism from `V` to `U i` for some `i`.
-/
def hom_to_index (V : opens_le_cover U) : V.val ⟶ U (index V) :=
(V.property.some_spec).hom

end opens_le_cover

/--
`supr U` as a cocone over the opens sets contained in some element of the cover.

(In fact this is a colimit cocone.)
-/
def opens_le_cover_cocone : cocone (full_subcategory_inclusion _ : opens_le_cover U ⥤ opens X) :=
{ X := supr U,
  ι := { app := λ V : opens_le_cover U, V.hom_to_index ≫ opens.le_supr U _, } }

end sheaf_condition

open sheaf_condition

/--
An equivalent formulation of the sheaf condition
(which we prove equivalent to the usual one below as
`is_sheaf_iff_is_sheaf_opens_le_cover`).

A presheaf is a sheaf if `F` sends the cone `(opens_le_cover_cocone U).op` to a limit cone.
(Recall `opens_le_cover_cocone U`, has cone point `supr U`,
mapping down to any `V` which is contained in some `U i`.)
-/
def is_sheaf_opens_le_cover : Prop :=
∀ ⦃ι : Type v⦄ (U : ι → opens X), nonempty (is_limit (F.map_cone (opens_le_cover_cocone U).op))

namespace sheaf_condition

open category_theory.pairwise

/--
Implementation detail:
the object level of `pairwise_to_opens_le_cover : pairwise ι ⥤ opens_le_cover U`
-/
@[simp]
def pairwise_to_opens_le_cover_obj : pairwise ι → opens_le_cover U
| (single i) := ⟨U i, ⟨i, le_refl _⟩⟩
| (pair i j) := ⟨U i ⊓ U j, ⟨i, inf_le_left⟩⟩

open category_theory.pairwise.hom

/--
Implementation detail:
the morphism level of `pairwise_to_opens_le_cover : pairwise ι ⥤ opens_le_cover U`
-/
def pairwise_to_opens_le_cover_map :
  Π {V W : pairwise ι},
    (V ⟶ W) → (pairwise_to_opens_le_cover_obj U V ⟶ pairwise_to_opens_le_cover_obj U W)
| _ _ (id_single i) := 𝟙 _
| _ _ (id_pair i j) := 𝟙 _
| _ _ (left i j) := hom_of_le inf_le_left
| _ _ (right i j) := hom_of_le inf_le_right

/--
The category of single and double intersections of the `U i` maps into the category
of open sets below some `U i`.
-/
@[simps]
def pairwise_to_opens_le_cover : pairwise ι ⥤ opens_le_cover U :=
{ obj := pairwise_to_opens_le_cover_obj U,
  map := λ V W i, pairwise_to_opens_le_cover_map U i, }

instance (V : opens_le_cover U) :
  nonempty (structured_arrow V (pairwise_to_opens_le_cover U)) :=
⟨{ right := single (V.index), hom := V.hom_to_index }⟩

/--
The diagram consisting of the `U i` and `U i ⊓ U j` is cofinal in the diagram
of all opens contained in some `U i`.
-/
-- This is a case bash: for each pair of types of objects in `pairwise ι`,
-- we have to explicitly construct a zigzag.
instance : functor.final (pairwise_to_opens_le_cover U) :=
⟨λ V, is_connected_of_zigzag $ λ A B, begin
  rcases A with ⟨⟨⟩, ⟨i⟩|⟨i,j⟩, a⟩;
  rcases B with ⟨⟨⟩, ⟨i'⟩|⟨i',j'⟩, b⟩;
  dsimp at *,
  { refine ⟨[
    { left := punit.star, right := pair i i',
      hom := (le_inf a.le b.le).hom, }, _], _, rfl⟩,
    exact
      list.chain.cons (or.inr ⟨{ left := 𝟙 _, right := left i i', }⟩)
        (list.chain.cons (or.inl ⟨{ left := 𝟙 _, right := right i i', }⟩) list.chain.nil) },
  { refine ⟨[
    { left := punit.star, right := pair i' i,
      hom := (le_inf (b.le.trans inf_le_left) a.le).hom, },
    { left := punit.star, right := single i',
      hom := (b.le.trans inf_le_left).hom, }, _], _, rfl⟩,
    exact
      list.chain.cons (or.inr ⟨{ left := 𝟙 _, right := right i' i, }⟩)
        (list.chain.cons (or.inl ⟨{ left := 𝟙 _, right := left i' i, }⟩)
          (list.chain.cons (or.inr ⟨{ left := 𝟙 _, right := left i' j', }⟩) list.chain.nil)) },
  { refine ⟨[
    { left := punit.star, right := single i,
      hom := (a.le.trans inf_le_left).hom, },
    { left := punit.star, right := pair i i', hom :=
      (le_inf (a.le.trans inf_le_left) b.le).hom, }, _], _, rfl⟩,
    exact
      list.chain.cons (or.inl ⟨{ left := 𝟙 _, right := left i j, }⟩)
        (list.chain.cons (or.inr ⟨{ left := 𝟙 _, right := left i i', }⟩)
          (list.chain.cons (or.inl ⟨{ left := 𝟙 _, right := right i i', }⟩) list.chain.nil)) },
  { refine ⟨[
    { left := punit.star, right := single i,
      hom := (a.le.trans inf_le_left).hom, },
    { left := punit.star, right := pair i i',
      hom := (le_inf (a.le.trans inf_le_left) (b.le.trans inf_le_left)).hom, },
    { left := punit.star, right := single i',
      hom := (b.le.trans inf_le_left).hom, }, _], _, rfl⟩,
    exact
      list.chain.cons (or.inl ⟨{ left := 𝟙 _, right := left i j, }⟩)
      (list.chain.cons (or.inr ⟨{ left := 𝟙 _, right := left i i', }⟩)
      (list.chain.cons (or.inl ⟨{ left := 𝟙 _, right := right i i', }⟩)
      (list.chain.cons (or.inr ⟨{ left := 𝟙 _, right := left i' j', }⟩) list.chain.nil))), },
end⟩

/--
The diagram in `opens X` indexed by pairwise intersections from `U` is isomorphic
(in fact, equal) to the diagram factored through `opens_le_cover U`.
-/
def pairwise_diagram_iso :
  pairwise.diagram U ≅
  pairwise_to_opens_le_cover U ⋙ full_subcategory_inclusion _ :=
{ hom := { app := begin rintro (i|⟨i,j⟩); exact 𝟙 _, end, },
  inv := { app := begin rintro (i|⟨i,j⟩); exact 𝟙 _, end, }, }

/--
The cocone `pairwise.cocone U` with cocone point `supr U` over `pairwise.diagram U` is isomorphic
to the cocone `opens_le_cover_cocone U` (with the same cocone point)
after appropriate whiskering and postcomposition.
-/
def pairwise_cocone_iso :
  (pairwise.cocone U).op ≅
  (cones.postcompose_equivalence (nat_iso.op (pairwise_diagram_iso U : _) : _)).functor.obj
    ((opens_le_cover_cocone U).op.whisker (pairwise_to_opens_le_cover U).op) :=
cones.ext (iso.refl _) (by tidy)

end sheaf_condition

open sheaf_condition

/--
The sheaf condition
in terms of a limit diagram over all `{ V : opens X // ∃ i, V ≤ U i }`
is equivalent to the reformulation
in terms of a limit diagram over `U i` and `U i ⊓ U j`.
-/
lemma is_sheaf_opens_le_cover_iff_is_sheaf_pairwise_intersections (F : presheaf C X) :
  F.is_sheaf_opens_le_cover ↔ F.is_sheaf_pairwise_intersections :=
forall_congr (λ ι, forall_congr (λ U, equiv.nonempty_congr $
  calc is_limit (F.map_cone (opens_le_cover_cocone U).op)
    ≃ is_limit ((F.map_cone (opens_le_cover_cocone U).op).whisker (pairwise_to_opens_le_cover U).op)
        : (functor.initial.is_limit_whisker_equiv (pairwise_to_opens_le_cover U).op _).symm
... ≃ is_limit (F.map_cone ((opens_le_cover_cocone U).op.whisker (pairwise_to_opens_le_cover U).op))
        : is_limit.equiv_iso_limit F.map_cone_whisker.symm
... ≃ is_limit ((cones.postcompose_equivalence _).functor.obj
          (F.map_cone ((opens_le_cover_cocone U).op.whisker (pairwise_to_opens_le_cover U).op)))
        : (is_limit.postcompose_hom_equiv _ _).symm
... ≃ is_limit (F.map_cone ((cones.postcompose_equivalence _).functor.obj
          ((opens_le_cover_cocone U).op.whisker (pairwise_to_opens_le_cover U).op)))
        : is_limit.equiv_iso_limit (functor.map_cone_postcompose_equivalence_functor _).symm
... ≃ is_limit (F.map_cone (pairwise.cocone U).op)
        : is_limit.equiv_iso_limit
            ((cones.functoriality _ _).map_iso (pairwise_cocone_iso U : _).symm)))

variables [has_products C]

/--
The sheaf condition in terms of an equalizer diagram is equivalent
to the reformulation in terms of a limit diagram over all `{ V : opens X // ∃ i, V ≤ U i }`.
-/
lemma is_sheaf_iff_is_sheaf_opens_le_cover (F : presheaf C X) :
  F.is_sheaf ↔ F.is_sheaf_opens_le_cover :=
iff.trans
  (is_sheaf_iff_is_sheaf_pairwise_intersections F)
  (is_sheaf_opens_le_cover_iff_is_sheaf_pairwise_intersections F).symm

end presheaf

end Top


universe u v

structure InjectiveFunction (α : Type u) (β : Type v) where
  fn  : α → β
  inj : ∀ a b, fn a = fn b → a = b

def add1 : InjectiveFunction Nat Nat where
  fn a      := a + 1
  inj a b h := by injection h

instance : CoeFun (InjectiveFunction α β) (fun _ => α → β) where
  coe s := s.fn

#eval add1 10

def mapAdd1 (xs : List Nat) : List Nat :=
  xs.map add1

#eval mapAdd1 [1, 2]

def foo : InjectiveFunction Bool (Nat → Nat) where
  fn
   | true,  a => a + 1
   | false, a => a
  inj a b h := by
    cases a
    cases b; rfl; injection (congrFun h 0)
    cases b; injection (congrFun h 0); rfl

theorem ex1 (x : Nat) : foo true x = x + 1 :=
  rfl

theorem ex2 (x : Nat) : foo false x = x :=
  rfl

#eval foo true 10
#eval foo false 20

#eval [1, 2, 3].map (foo true)


/-
Copyright (c) 2020 Ruben Van de Velde, Stanislas Polu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Ruben Van de Velde, Stanislas Polu
-/

import data.real.basic
import data.set.basic
import analysis.normed_space.basic

/-!
# IMO 1972 B2

Problem: `f` and `g` are real-valued functions defined on the real line. For all `x` and `y`,
`f(x + y) + f(x - y) = 2f(x)g(y)`. `f` is not identically zero and `|f(x)| ≤ 1` for all `x`.
Prove that `|g(x)| ≤ 1` for all `x`.
-/

/--
This proof begins by introducing the supremum of `f`, `k ≤ 1` as well as `k' = k / ∥g y∥`. We then
suppose that the conclusion does not hold (`hneg`) and show that `k ≤ k'` (by
`2 * (∥f x∥ * ∥g y∥) ≤ 2 * k` obtained from the main hypothesis `hf1`) and that `k' < k` (obtained
from `hneg` directly), finally raising a contradiction with `k' < k'`.

(Authored by Stanislas Polu inspired by Ruben Van de Velde).
-/
example (f g : ℝ → ℝ)
  (hf1 : ∀ x, ∀ y, (f(x+y) + f(x-y)) = 2 * f(x) * g(y))
  (hf2 : ∀ y, ∥f(y)∥ ≤ 1)
  (hf3 : ∃ x, f(x) ≠ 0)
  (y : ℝ) :
  ∥g(y)∥ ≤ 1 :=
begin
  classical,
  set S := set.range (λ x, ∥f x∥),
  -- Introduce `k`, the supremum of `f`.
  let k : ℝ := Sup (S),

  -- Show that `∥f x∥ ≤ k`.
  have hk₁ : ∀ x, ∥f x∥ ≤ k,
  { have h : ∃ x, ∀ y ∈ S, y ≤ x,
    { use 1,
      intros _ hy,
      rw set.mem_range at hy,
      rcases hy with ⟨z, rfl⟩,
      exact hf2 z, },
    intro x,
    exact real.le_Sup S h (set.mem_range_self x), },
  -- Show that `2 * (∥f x∥ * ∥g y∥) ≤ 2 * k`.
  have hk₂ : ∀ x, 2 * (∥f x∥ * ∥g y∥) ≤ 2 * k,
  { intro x,
    calc 2 * (∥f x∥ * ∥g y∥)
        = ∥2 * f x * g y∥ : by simp [real.norm_eq_abs, abs_mul, mul_assoc]
    ... = ∥f (x + y) + f (x - y)∥ : by rw hf1
    ... ≤ ∥f (x + y)∥ + ∥f (x - y)∥ : norm_add_le _ _
    ... ≤ k + k : add_le_add (hk₁ _) (hk₁ _)
    ... = 2 * k : (two_mul _).symm, },

  -- Suppose the conclusion does not hold.
  by_contra hneg,
  push_neg at hneg,
  set k' := k / ∥g y∥,

  -- Demonstrate that `k' < k` using `hneg`.
  have H₁ : k' < k,
  { have h₁ : 0 < k,
    { obtain ⟨x, hx⟩ := hf3,
      calc 0
          < ∥f x∥ : norm_pos_iff.mpr hx
      ... ≤ k : hk₁ x },
    rw div_lt_iff,
    apply lt_mul_of_one_lt_right h₁ hneg,
    exact trans zero_lt_one hneg },

  -- Demonstrate that `k ≤ k'` using `hk₂`.
  have H₂ : k ≤ k',
  { have h₁ : ∃ x : ℝ, x ∈ S,
    { use ∥f 0∥, exact set.mem_range_self 0, },
    have h₂ : ∀ x, ∥f x∥ ≤ k',
    { intros x,
      rw le_div_iff,
      { apply (mul_le_mul_left zero_lt_two).mp (hk₂ x) },
      { exact trans zero_lt_one hneg } },
    apply real.Sup_le_ub _ h₁,
    rintros y' ⟨yy, rfl⟩,
    exact h₂ yy },

  -- Conclude by obtaining a contradiction, `k' < k'`.
  apply lt_irrefl k',
  calc k'
      < k : H₁
  ... ≤ k' : H₂,
end

/-- IMO 1972 B2

Problem: `f` and `g` are real-valued functions defined on the real line. For all `x` and `y`,
`f(x + y) + f(x - y) = 2f(x)g(y)`. `f` is not identically zero and `|f(x)| ≤ 1` for all `x`.
Prove that `|g(x)| ≤ 1` for all `x`.

This is a more concise version of the proof proposed by Ruben Van de Velde.
-/
example (f g : ℝ → ℝ)
  (hf1 : ∀ x, ∀ y, (f (x+y) + f(x-y)) = 2 * f(x) * g(y))
  (hf2 : bdd_above (set.range (λ x, ∥f x∥)))
  (hf3 : ∃ x, f(x) ≠ 0)
  (y : ℝ) :
  ∥g(y)∥ ≤ 1 :=
begin
  obtain ⟨x, hx⟩ := hf3,
  set k := supr (λ x, ∥f x∥),
  have h : ∀ x, ∥f x∥ ≤ k := le_csupr hf2,
  by_contradiction H, push_neg at H,
  have hgy : 0 < ∥g y∥,
    by linarith,
  have k_pos : 0 < k := lt_of_lt_of_le (norm_pos_iff.mpr hx) (h x),
  have : k / ∥g y∥ < k := (div_lt_iff hgy).mpr (lt_mul_of_one_lt_right k_pos H),
  have : k ≤ k / ∥g y∥,
  { suffices : ∀ x, ∥f x∥ ≤ k / ∥g y∥, from csupr_le this,
    intro x,
    suffices : 2 * (∥f x∥ * ∥g y∥) ≤ 2 * k,
      by { rwa [le_div_iff hgy, ←mul_le_mul_left zero_lt_two], apply_instance },
    calc 2 * (∥f x∥ * ∥g y∥)
        = ∥2 * f x * g y∥           : by simp [abs_mul, mul_assoc]
    ... = ∥f (x + y) + f (x - y)∥   : by rw hf1
    ... ≤ ∥f (x + y)∥ + ∥f (x - y)∥ : abs_add _ _
    ... ≤ 2 * k                     : by linarith [h (x+y), h (x -y)] },
  linarith,
end


import data.fintype
import pfin.lemmas

universe u

namespace fintype
open finset

def equiv_pfin_of_forall_mem_list {α : Type u} [fintype α] [decidable_eq α]
  {l : list α} (h : ∀ x:α, x ∈ l) (nd : l.nodup) : α ≃ pfin (l.length) :=
{ to_fun := λ a, ⟨_, list.index_of_lt_length.2 (h a)⟩,
  inv_fun := λ i, l.nth_le i.val i.is_lt,
  left_inv := λ a, begin unfold pfin.val, simp *, end,
  right_inv := λ ⟨i, h⟩, begin
    apply pfin.eq_of_veq, simp [pfin.val],
    apply list.nodup_iff_nth_le_inj.mp nd _ _ (list.index_of_lt_length.mpr (list.nth_le_mem _ _ _)) h,
    simp,
  end }

def equiv_pfin (α: Type u) [fintype α] [decidable_eq α] : trunc (α ≃ pfin (fintype.card α)) :=
begin
  unfold card finset.card,
  exact quot.rec_on_subsingleton (@univ α _).1
    (λ l (h : ∀ x:α, x ∈ l) (nd : l.nodup), trunc.mk (equiv_pfin_of_forall_mem_list h nd))
    mem_univ_val univ.2
end

end fintype

namespace list

def pfin_range (n : ℕ) : list (pfin n) :=
(list.range n).pmap pfin.mk (λ _, list.mem_range.1)

@[simp] lemma mem_pfin_range {n : ℕ} (a : pfin n) : a ∈ list.pfin_range n :=
mem_pmap.2 ⟨a.val, mem_range.2 a.is_lt, pfin.eta _ _⟩

lemma nodup_pfin_range (n : ℕ) : (pfin_range n).nodup :=
nodup_pmap (λ _ _ _ _, pfin.veq_of_eq) (nodup_range _)

end list

instance (n : ℕ) : fintype (pfin n) :=
⟨⟨quot.mk _ (list.pfin_range n), list.nodup_pfin_range n⟩, list.mem_pfin_range⟩