/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.algebra.subalgebra
import Mathlib.PostPort

universes u v₁ w v u₁ u_1 u_2 u_3

namespace Mathlib

/-!
# Towers of algebras

In this file we prove basic facts about towers of algebra.

An algebra tower A/S/R is expressed by having instances of `algebra A S`,
`algebra R S`, `algebra R A` and `is_scalar_tower R S A`, the later asserting the
compatibility condition `(r • s) • a = r • (s • a)`.

An important definition is `to_alg_hom R S A`, the canonical `R`-algebra homomorphism `S →ₐ[R] A`.

-/

namespace algebra

/-- The `R`-algebra morphism `A → End (M)` corresponding to the representation of the algebra `A`
on the `R`-module `M`. -/
def lsmul (R : Type u) {A : Type w} (M : Type v₁) [comm_semiring R] [semiring A] [algebra R A] [add_comm_monoid M] [semimodule R M] [semimodule A M] [is_scalar_tower R A M] : alg_hom R A (module.End R M) :=
  alg_hom.mk
    (linear_map.to_fun
      ((fun (this : linear_map R A (linear_map R M M)) => this)
        (linear_map.mk₂ R has_scalar.smul sorry sorry sorry sorry)))
    sorry sorry sorry sorry sorry

@[simp] theorem lsmul_coe (R : Type u) {A : Type w} (M : Type v₁) [comm_semiring R] [semiring A] [algebra R A] [add_comm_monoid M] [semimodule R M] [semimodule A M] [is_scalar_tower R A M] (a : A) : ⇑(coe_fn (lsmul R M) a) = has_scalar.smul a :=
  rfl

end algebra

namespace is_scalar_tower

theorem algebra_map_smul {R : Type u} (A : Type w) {M : Type v₁} [comm_semiring R] [semiring A] [algebra R A] [add_comm_monoid M] [semimodule R M] [semimodule A M] [is_scalar_tower R A M] (r : R) (x : M) : coe_fn (algebra_map R A) r • x = r • x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (coe_fn (algebra_map R A) r • x = r • x)) (algebra.algebra_map_eq_smul_one r)))
    (eq.mpr (id (Eq._oldrec (Eq.refl ((r • 1) • x = r • x)) (smul_assoc r 1 x)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (r • 1 • x = r • x)) (one_smul A x))) (Eq.refl (r • x))))

theorem of_algebra_map_eq {R : Type u} {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] (h : ∀ (x : R), coe_fn (algebra_map R A) x = coe_fn (algebra_map S A) (coe_fn (algebra_map R S) x)) : is_scalar_tower R S A := sorry

/-- See note [partially-applied ext lemmas]. -/
theorem of_algebra_map_eq' {R : Type u} {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] (h : algebra_map R A = ring_hom.comp (algebra_map S A) (algebra_map R S)) : is_scalar_tower R S A :=
  of_algebra_map_eq (iff.mp ring_hom.ext_iff h)

protected instance subalgebra (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] (S₀ : subalgebra R S) : is_scalar_tower (↥S₀) S A :=
  of_algebra_map_eq fun (x : ↥S₀) => rfl

theorem algebra_map_eq (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] : algebra_map R A = ring_hom.comp (algebra_map S A) (algebra_map R S) := sorry

theorem algebra_map_apply (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (x : R) : coe_fn (algebra_map R A) x = coe_fn (algebra_map S A) (coe_fn (algebra_map R S) x) := sorry

protected instance subalgebra' (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (S₀ : subalgebra R S) : is_scalar_tower R (↥S₀) A :=
  of_algebra_map_eq fun (_x : R) => algebra_map_apply R S A _x

theorem algebra.ext {S : Type u} {A : Type v} [comm_semiring S] [semiring A] (h1 : algebra S A) (h2 : algebra S A) (h : ∀ {r : S} {x : A}, r • x = r • x) : h1 = h2 := sorry

theorem algebra_comap_eq (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] : algebra.comap.algebra R S A = _inst_8 := sorry

/-- In a tower, the canonical map from the middle element to the top element is an
algebra homomorphism over the bottom element. -/
def to_alg_hom (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] : alg_hom R S A :=
  alg_hom.mk (ring_hom.to_fun (algebra_map S A)) sorry sorry sorry sorry sorry

theorem to_alg_hom_apply (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (y : S) : coe_fn (to_alg_hom R S A) y = coe_fn (algebra_map S A) y :=
  rfl

@[simp] theorem coe_to_alg_hom (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] : ↑(to_alg_hom R S A) = algebra_map S A :=
  ring_hom.ext fun (_x : S) => rfl

@[simp] theorem coe_to_alg_hom' (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] : ⇑(to_alg_hom R S A) = ⇑(algebra_map S A) :=
  rfl

/-- R ⟶ S induces S-Alg ⥤ R-Alg -/
def restrict_base (R : Type u) {S : Type v} {A : Type w} {B : Type u₁} [comm_semiring R] [comm_semiring S] [semiring A] [semiring B] [algebra R S] [algebra S A] [algebra S B] [algebra R A] [algebra R B] [is_scalar_tower R S A] [is_scalar_tower R S B] (f : alg_hom S A B) : alg_hom R A B :=
  alg_hom.mk (ring_hom.to_fun ↑f) sorry sorry sorry sorry sorry

theorem restrict_base_apply (R : Type u) {S : Type v} {A : Type w} {B : Type u₁} [comm_semiring R] [comm_semiring S] [semiring A] [semiring B] [algebra R S] [algebra S A] [algebra S B] [algebra R A] [algebra R B] [is_scalar_tower R S A] [is_scalar_tower R S B] (f : alg_hom S A B) (x : A) : coe_fn (restrict_base R f) x = coe_fn f x :=
  rfl

@[simp] theorem coe_restrict_base (R : Type u) {S : Type v} {A : Type w} {B : Type u₁} [comm_semiring R] [comm_semiring S] [semiring A] [semiring B] [algebra R S] [algebra S A] [algebra S B] [algebra R A] [algebra R B] [is_scalar_tower R S A] [is_scalar_tower R S B] (f : alg_hom S A B) : ↑(restrict_base R f) = ↑f :=
  rfl

@[simp] theorem coe_restrict_base' (R : Type u) {S : Type v} {A : Type w} {B : Type u₁} [comm_semiring R] [comm_semiring S] [semiring A] [semiring B] [algebra R S] [algebra S A] [algebra S B] [algebra R A] [algebra R B] [is_scalar_tower R S A] [is_scalar_tower R S B] (f : alg_hom S A B) : ⇑(restrict_base R f) = ⇑f :=
  rfl

protected instance right {S : Type v} {A : Type w} [comm_semiring S] [semiring A] [algebra S A] : is_scalar_tower S A A :=
  mk
    fun (x : S) (y z : A) =>
      eq.mpr (id (Eq._oldrec (Eq.refl ((x • y) • z = x • y • z)) smul_eq_mul))
        (eq.mpr (id (Eq._oldrec (Eq.refl (x • y * z = x • y • z)) smul_eq_mul))
          (eq.mpr (id (Eq._oldrec (Eq.refl (x • y * z = x • (y * z))) (algebra.smul_mul_assoc x y z)))
            (Eq.refl (x • (y * z)))))

protected instance comap {R : Type u_1} {S : Type u_2} {A : Type u_3} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] : is_scalar_tower R S (algebra.comap R S A) :=
  of_algebra_map_eq fun (x : R) => rfl

-- conflicts with is_scalar_tower.subalgebra

protected instance subsemiring {S : Type v} {A : Type w} [comm_semiring S] [semiring A] [algebra S A] (U : subsemiring S) : is_scalar_tower (↥U) S A :=
  of_algebra_map_eq fun (x : ↥U) => rfl

-- conflicts with is_scalar_tower.subalgebra

protected instance subring {S : Type u_1} {A : Type u_2} [comm_ring S] [ring A] [algebra S A] (U : set S) [is_subring U] : is_scalar_tower (↥U) S A :=
  of_algebra_map_eq fun (x : ↥U) => rfl

protected instance of_ring_hom {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_semiring R] [comm_semiring A] [comm_semiring B] [algebra R A] [algebra R B] (f : alg_hom R A B) : is_scalar_tower R A B :=
  let _inst : algebra A B := ring_hom.to_algebra ↑f;
  of_algebra_map_eq fun (x : R) => Eq.symm (alg_hom.commutes f x)

protected instance rat (R : Type u) (S : Type v) [field R] [division_ring S] [algebra R S] [char_zero R] [char_zero S] : is_scalar_tower ℚ R S :=
  of_algebra_map_eq fun (x : ℚ) => Eq.symm (ring_hom.map_rat_cast (algebra_map R S) x)

end is_scalar_tower

namespace subalgebra

/-- If A/S/R is a tower of algebras then the `res`triction of a S-subalgebra of A is
an R-subalgebra of A. -/
def res (R : Type u) {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (U : subalgebra S A) : subalgebra R A :=
  mk (carrier U) (one_mem' U) (mul_mem' U) (zero_mem' U) (add_mem' U) sorry

@[simp] theorem res_top (R : Type u) {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] : res R ⊤ = ⊤ :=
  iff.mpr algebra.eq_top_iff fun (_x : A) => (fun (this : _x ∈ ⊤) => this) algebra.mem_top

@[simp] theorem mem_res (R : Type u) {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] {U : subalgebra S A} {x : A} : x ∈ res R U ↔ x ∈ U :=
  iff.rfl

theorem res_inj (R : Type u) {S : Type v} {A : Type w} [comm_semiring R] [comm_semiring S] [semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] {U : subalgebra S A} {V : subalgebra S A} (H : res R U = res R V) : U = V := sorry

/-- Produces a map from `subalgebra.under`. -/
def of_under {R : Type u_1} {A : Type u_2} {B : Type u_3} [comm_semiring R] [comm_semiring A] [semiring B] [algebra R A] [algebra R B] (S : subalgebra R A) (U : subalgebra (↥S) A) [algebra (↥S) B] [is_scalar_tower R (↥S) B] (f : alg_hom (↥S) (↥U) B) : alg_hom R (↥(under S U)) B :=
  alg_hom.mk (alg_hom.to_fun f) sorry sorry sorry sorry sorry

end subalgebra

namespace is_scalar_tower

theorem range_under_adjoin (R : Type u) (S : Type v) (A : Type w) [comm_semiring R] [comm_semiring S] [comm_semiring A] [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A] (t : set A) : subalgebra.under (alg_hom.range (to_alg_hom R S A)) (algebra.adjoin (↥(alg_hom.range (to_alg_hom R S A))) t) =
  subalgebra.res R (algebra.adjoin S t) := sorry

end is_scalar_tower

namespace submodule

theorem smul_mem_span_smul_of_mem {R : Type u} {S : Type v} {A : Type w} [comm_semiring R] [semiring S] [add_comm_monoid A] [algebra R S] [semimodule S A] [semimodule R A] [is_scalar_tower R S A] {s : set S} {t : set A} {k : S} (hks : k ∈ span R s) {x : A} (hx : x ∈ t) : k • x ∈ span R (s • t) := sorry

theorem smul_mem_span_smul {R : Type u} {S : Type v} {A : Type w} [comm_semiring R] [semiring S] [add_comm_monoid A] [algebra R S] [semimodule S A] [semimodule R A] [is_scalar_tower R S A] {s : set S} (hs : span R s = ⊤) {t : set A} {k : S} {x : A} (hx : x ∈ span R t) : k • x ∈ span R (s • t) := sorry

theorem smul_mem_span_smul' {R : Type u} {S : Type v} {A : Type w} [comm_semiring R] [semiring S] [add_comm_monoid A] [algebra R S] [semimodule S A] [semimodule R A] [is_scalar_tower R S A] {s : set S} (hs : span R s = ⊤) {t : set A} {k : S} {x : A} (hx : x ∈ span R (s • t)) : k • x ∈ span R (s • t) := sorry

theorem span_smul {R : Type u} {S : Type v} {A : Type w} [comm_semiring R] [semiring S] [add_comm_monoid A] [algebra R S] [semimodule S A] [semimodule R A] [is_scalar_tower R S A] {s : set S} (hs : span R s = ⊤) (t : set A) : span R (s • t) = restrict_scalars R (span S t) := sorry


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Patrick Massot

Continuous functions.

Parts of the formalization is based on the books:
  N. Bourbaki: General Topology
  I. M. James: Topologies and Uniformities
A major difference is that this formalization is heavily based on the filter library.
-/
import analysis.topology.topological_space
noncomputable theory

open set filter lattice
local attribute [instance] classical.prop_decidable

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

section
variables [topological_space α] [topological_space β] [topological_space γ]

/-- A function between topological spaces is continuous if the preimage
  of every open set is open. -/
def continuous (f : α → β) := ∀s, is_open s → is_open (f ⁻¹' s)

lemma continuous_id : continuous (id : α → α) :=
assume s h, h

lemma continuous.comp {f : α → β} {g : β → γ} (hf : continuous f) (hg : continuous g):
  continuous (g ∘ f) :=
assume s h, hf _ (hg s h)

lemma continuous.tendsto {f : α → β} (hf : continuous f) (x) :
  tendsto f (nhds x) (nhds (f x)) | s :=
show s ∈ (nhds (f x)).sets → s ∈ (map f (nhds x)).sets,
by simp [nhds_sets]; exact
assume t t_subset t_open fx_in_t,
  ⟨f ⁻¹' t, preimage_mono t_subset, hf t t_open, fx_in_t⟩

lemma continuous_iff_tendsto {f : α → β} :
  continuous f ↔ (∀x, tendsto f (nhds x) (nhds (f x))) :=
⟨continuous.tendsto,
  assume hf : ∀x, tendsto f (nhds x) (nhds (f x)),
  assume s, assume hs : is_open s,
  have ∀a, f a ∈ s → s ∈ (nhds (f a)).sets,
    by simp [nhds_sets]; exact assume a ha, ⟨s, subset.refl s, hs, ha⟩,
  show is_open (f ⁻¹' s),
    by simp [is_open_iff_nhds]; exact assume a ha, hf a (this a ha)⟩

lemma continuous_const {b : β} : continuous (λa:α, b) :=
continuous_iff_tendsto.mpr $ assume a, tendsto_const_nhds

lemma continuous_iff_is_closed {f : α → β} :
  continuous f ↔ (∀s, is_closed s → is_closed (f ⁻¹' s)) :=
⟨assume hf s hs, hf (-s) hs,
  assume hf s, by rw [←is_closed_compl_iff, ←is_closed_compl_iff]; exact hf _⟩

lemma continuous_if {p : α → Prop} {f g : α → β} {h : ∀a, decidable (p a)}
  (hp : ∀a∈frontier {a | p a}, f a = g a) (hf : continuous f) (hg : continuous g) :
  continuous (λa, @ite (p a) (h a) β (f a) (g a)) :=
continuous_iff_is_closed.mpr $
assume s hs,
have (λa, ite (p a) (f a) (g a)) ⁻¹' s =
    (closure {a | p a} ∩  f ⁻¹' s) ∪ (closure {a | ¬ p a} ∩ g ⁻¹' s),
  from set.ext $ assume a,
  classical.by_cases
    (assume : a ∈ frontier {a | p a},
      have hac : a ∈ closure {a | p a}, from this.left,
      have hai : a ∈ closure {a | ¬ p a},
        from have a ∈ - interior {a | p a}, from this.right, by rwa [←closure_compl] at this,
      by by_cases p a; simp [h, hp a this, hac, hai, iff_def] {contextual := tt})
    (assume hf : a ∈ - frontier {a | p a},
      classical.by_cases
        (assume : p a,
          have hc : a ∈ closure {a | p a}, from subset_closure this,
          have hnc : a ∉ closure {a | ¬ p a},
            by show a ∉ closure (- {a | p a}); rw [closure_compl]; simpa [frontier, hc] using hf,
          by simp [this, hc, hnc])
        (assume : ¬ p a,
          have hc : a ∈ closure {a | ¬ p a}, from subset_closure this,
          have hnc : a ∉ closure {a | p a},
            begin
              have hc : a ∈ closure (- {a | p a}), from hc,
              simp [closure_compl] at hc,
              simpa [frontier, hc] using hf
            end,
          by simp [this, hc, hnc])),
by rw [this]; exact is_closed_union
  (is_closed_inter is_closed_closure $ continuous_iff_is_closed.mp hf s hs)
  (is_closed_inter is_closed_closure $ continuous_iff_is_closed.mp hg s hs)

lemma image_closure_subset_closure_image {f : α → β} {s : set α} (h : continuous f) :
  f '' closure s ⊆ closure (f '' s) :=
have ∀ (a : α), nhds a ⊓ principal s ≠ ⊥ → nhds (f a) ⊓ principal (f '' s) ≠ ⊥,
  from assume a ha,
  have h₁ : ¬ map f (nhds a ⊓ principal s) = ⊥,
    by rwa[map_eq_bot_iff],
  have h₂ : map f (nhds a ⊓ principal s) ≤ nhds (f a) ⊓ principal (f '' s),
    from le_inf
      (le_trans (map_mono inf_le_left) $ by rw [continuous_iff_tendsto] at h; exact h a)
      (le_trans (map_mono inf_le_right) $ by simp; exact subset.refl _),
  neq_bot_of_le_neq_bot h₁ h₂,
by simp [image_subset_iff, closure_eq_nhds]; assumption

lemma compact_image {s : set α} {f : α → β} (hs : compact s) (hf : continuous f) : compact (f '' s) :=
compact_of_finite_subcover $ assume c hco hcs,
  have hdo : ∀t∈c, is_open (f ⁻¹' t), from assume t' ht, hf _ $ hco _ ht,
  have hds : s ⊆ ⋃i∈c, f ⁻¹' i,
    by simpa [subset_def, -mem_image] using hcs,
  let ⟨d', hcd', hfd', hd'⟩ := compact_elim_finite_subcover_image hs hdo hds in
  ⟨d', hcd', hfd', by simpa [subset_def, -mem_image, image_subset_iff] using hd'⟩

end

section constructions
local notation `cont` := @continuous _ _
local notation `tspace` := topological_space
open topological_space

variables {f : α → β} {ι : Sort*}

lemma continuous_iff_le_coinduced {t₁ : tspace α} {t₂ : tspace β} :
  cont t₁ t₂ f ↔ t₂ ≤ coinduced f t₁ := iff.rfl

lemma continuous_iff_induced_le {t₁ : tspace α} {t₂ : tspace β} :
  cont t₁ t₂ f ↔ induced f t₂ ≤ t₁ :=
iff.trans continuous_iff_le_coinduced (gc_induced_coinduced f _ _).symm

theorem continuous_generated_from {t : tspace α} {b : set (set β)}
  (h : ∀s∈b, is_open (f ⁻¹' s)) : cont t (generate_from b) f :=
continuous_iff_le_coinduced.2 $ generate_from_le h

lemma continuous_induced_dom {t : tspace β} : cont (induced f t) t f :=
assume s h, ⟨_, h, rfl⟩

lemma continuous_induced_rng {g : γ → α} {t₂ : tspace β} {t₁ : tspace γ}
  (h : cont t₁ t₂ (f ∘ g)) : cont t₁ (induced f t₂) g :=
assume s ⟨t, ht, s_eq⟩, s_eq.symm ▸ h t ht

lemma continuous_coinduced_rng {t : tspace α} : cont t (coinduced f t) f :=
assume s h, h

lemma continuous_coinduced_dom {g : β → γ} {t₁ : tspace α} {t₂ : tspace γ}
  (h : cont t₁ t₂ (g ∘ f)) : cont (coinduced f t₁) t₂ g :=
assume s hs, h s hs

lemma continuous_le_dom {t₁ t₂ : tspace α} {t₃ : tspace β}
  (h₁ : t₁ ≤ t₂) (h₂ : cont t₁ t₃ f) : cont t₂ t₃ f :=
assume s h, h₁ _ (h₂ s h)

lemma continuous_le_rng {t₁ : tspace α} {t₂ t₃ : tspace β}
  (h₁ : t₃ ≤ t₂) (h₂ : cont t₁ t₂ f) : cont t₁ t₃ f :=
assume s h, h₂ s (h₁ s h)

lemma continuous_inf_dom {t₁ t₂ : tspace α} {t₃ : tspace β}
  (h₁ : cont t₁ t₃ f) (h₂ : cont t₂ t₃ f) : cont (t₁ ⊓ t₂) t₃ f :=
assume s h, ⟨h₁ s h, h₂ s h⟩

lemma continuous_inf_rng_left {t₁ : tspace α} {t₃ t₂ : tspace β} :
  cont t₁ t₂ f → cont t₁ (t₂ ⊓ t₃) f :=
continuous_le_rng inf_le_left

lemma continuous_inf_rng_right {t₁ : tspace α} {t₃ t₂ : tspace β} :
  cont t₁ t₃ f → cont t₁ (t₂ ⊓ t₃) f :=
continuous_le_rng inf_le_right

lemma continuous_Inf_dom {t₁ : set (tspace α)} {t₂ : tspace β}
  (h : ∀t∈t₁, cont t t₂ f) : cont (Inf t₁) t₂ f :=
continuous_iff_induced_le.2 $ le_Inf $ assume t ht, continuous_iff_induced_le.1 $ h t ht

lemma continuous_Inf_rng {t₁ : tspace α} {t₂ : set (tspace β)} {t : tspace β}
  (h₁ : t ∈ t₂) (hf : cont t₁ t f) : cont t₁ (Inf t₂) f :=
continuous_iff_le_coinduced.2 $ Inf_le_of_le h₁ $ continuous_iff_le_coinduced.1 hf

lemma continuous_infi_dom {t₁ : ι → tspace α} {t₂ : tspace β}
  (h : ∀i, cont (t₁ i) t₂ f) : cont (infi t₁) t₂ f :=
continuous_Inf_dom $ assume t ⟨i, (t_eq : t = t₁ i)⟩, t_eq.symm ▸ h i

lemma continuous_infi_rng {t₁ : tspace α} {t₂ : ι → tspace β} {i : ι}
  (h : cont t₁ (t₂ i) f) : cont t₁ (infi t₂) f :=
continuous_Inf_rng ⟨i, rfl⟩ h

lemma continuous_sup_rng {t₁ : tspace α} {t₂ t₃ : tspace β}
  (h₁ : cont t₁ t₂ f) (h₂ : cont t₁ t₃ f) : cont t₁ (t₂ ⊔ t₃) f :=
continuous_iff_le_coinduced.2 $ sup_le
  (continuous_iff_le_coinduced.1 h₁)
  (continuous_iff_le_coinduced.1 h₂)

lemma continuous_sup_dom_left {t₁ t₂ : tspace α} {t₃ : tspace β} :
  cont t₁ t₃ f → cont (t₁ ⊔ t₂) t₃ f :=
continuous_le_dom le_sup_left

lemma continuous_sup_dom_right {t₁ t₂ : tspace α} {t₃ : tspace β} :
  cont t₂ t₃ f → cont (t₁ ⊔ t₂) t₃ f :=
continuous_le_dom le_sup_right

lemma continuous_Sup_dom {t₁ : set (tspace α)} {t₂ : tspace β} {t : tspace α} (h₁ : t ∈ t₁) :
  cont t t₂ f → cont (Sup t₁) t₂ f :=
continuous_le_dom $ le_Sup h₁

lemma continuous_Sup_rng {t₁ : tspace α} {t₂ : set (tspace β)}
  (h : ∀t∈t₂, cont t₁ t f) : cont t₁ (Sup t₂) f :=
continuous_iff_le_coinduced.2 $ Sup_le $ assume b hb, continuous_iff_le_coinduced.1 $ h b hb

lemma continuous_supr_dom {t₁ : ι → tspace α} {t₂ : tspace β} {i : ι} :
  cont (t₁ i) t₂ f → cont (supr t₁) t₂ f :=
continuous_le_dom $ le_supr _ _

lemma continuous_supr_rng {t₁ : tspace α} {t₂ : ι → tspace β}
  (h : ∀i, cont t₁ (t₂ i) f) : cont t₁ (supr t₂) f :=
continuous_iff_le_coinduced.2 $ supr_le $ assume i, continuous_iff_le_coinduced.1 $ h i

lemma continuous_top {t : tspace β} : cont ⊤ t f :=
continuous_iff_induced_le.2 $ le_top

lemma continuous_bot {t : tspace α} : cont t ⊥ f :=
continuous_iff_le_coinduced.2 $ bot_le

end constructions

section induced
open topological_space
variables [t : topological_space β] {f : α → β}

theorem is_open_induced {s : set β} (h : is_open s) : (induced f t).is_open (f ⁻¹' s) :=
⟨s, h, rfl⟩

lemma nhds_induced_eq_comap {a : α} : @nhds α (induced f t) a = comap f (nhds (f a)) :=
le_antisymm
  (assume s ⟨s', hs', (h_s : f ⁻¹' s' ⊆ s)⟩,
    let ⟨t', hsub, ht', hin⟩ := mem_nhds_sets_iff.1 hs' in
    (@nhds α (induced f t) a).sets_of_superset
      begin
        simp [mem_nhds_sets_iff],
        exact ⟨preimage f t', preimage_mono hsub, is_open_induced ht', hin⟩
      end
      h_s)
  (le_infi $ assume s, le_infi $ assume ⟨as, s', is_open_s', s_eq⟩,
    begin
      simp [comap, mem_nhds_sets_iff, s_eq],
      exact ⟨s', ⟨s', subset.refl _, is_open_s', by rwa [s_eq] at as⟩, subset.refl _⟩
    end)

lemma map_nhds_induced_eq {a : α} (h : image f univ ∈ (nhds (f a)).sets) :
  map f (@nhds α (induced f t) a) = nhds (f a) :=
le_antisymm
  (@continuous.tendsto α β (induced f t) _ _ continuous_induced_dom a)
  (assume s, assume hs : f ⁻¹' s ∈ (@nhds α (induced f t) a).sets,
    let ⟨t', t_subset, is_open_t, a_in_t⟩ := mem_nhds_sets_iff.mp h in
    let ⟨s', s'_subset, ⟨s'', is_open_s'', s'_eq⟩, a_in_s'⟩ := (@mem_nhds_sets_iff _ (induced f t) _ _).mp hs in
    by subst s'_eq; exact (mem_nhds_sets_iff.mpr $
      ⟨t' ∩ s'',
        assume x ⟨h₁, h₂⟩, match x, h₂, t_subset h₁ with
        | x, h₂, ⟨y, _, y_eq⟩ := begin subst y_eq, exact s'_subset h₂ end
        end,
        is_open_inter is_open_t is_open_s'',
        ⟨a_in_t, a_in_s'⟩⟩))

lemma closure_induced [t : topological_space β] {f : α → β} {a : α} {s : set α}
  (hf : ∀x y, f x = f y → x = y) :
  a ∈ @closure α (topological_space.induced f t) s ↔ f a ∈ closure (f '' s) :=
have comap f (nhds (f a) ⊓ principal (f '' s)) ≠ ⊥ ↔ nhds (f a) ⊓ principal (f '' s) ≠ ⊥,
  from ⟨assume h₁ h₂, h₁ $ h₂.symm ▸ comap_bot,
    assume h,
    forall_sets_neq_empty_iff_neq_bot.mp $
      assume s₁ ⟨s₂, hs₂, (hs : f ⁻¹' s₂ ⊆ s₁)⟩,
      have f '' s ∈ (nhds (f a) ⊓ principal (f '' s)).sets,
        from mem_inf_sets_of_right $ by simp [subset.refl],
      have s₂ ∩ f '' s ∈ (nhds (f a) ⊓ principal (f '' s)).sets,
        from inter_mem_sets hs₂ this,
      let ⟨b, hb₁, ⟨a, ha, ha₂⟩⟩ := inhabited_of_mem_sets h this in
      ne_empty_of_mem $ hs $ by rwa [←ha₂] at hb₁⟩,
calc a ∈ @closure α (topological_space.induced f t) s
    ↔ (@nhds α (topological_space.induced f t) a) ⊓ principal s ≠ ⊥ : by rw [closure_eq_nhds]; refl
  ... ↔ comap f (nhds (f a)) ⊓ principal (f ⁻¹' (f '' s)) ≠ ⊥ : by rw [nhds_induced_eq_comap, preimage_image_eq _ hf]
  ... ↔ comap f (nhds (f a) ⊓ principal (f '' s)) ≠ ⊥ : by rw [comap_inf, ←comap_principal]
  ... ↔ _ : by rwa [closure_eq_nhds]

end induced

section embedding

/-- A function between topological spaces is an embedding if it is injective,
  and for all `s : set α`, `s` is open iff it is the preimage of an open set. -/
def embedding [tα : topological_space α] [tβ : topological_space β] (f : α → β) : Prop :=
function.injective f ∧ tα = tβ.induced f

variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

lemma embedding_id : embedding (@id α) :=
⟨assume a₁ a₂ h, h, induced_id.symm⟩

lemma embedding_compose {f : α → β} {g : β → γ} (hf : embedding f) (hg : embedding g) :
  embedding (g ∘ f) :=
⟨assume a₁ a₂ h, hf.left $ hg.left h, by rw [hf.right, hg.right, induced_compose]⟩

lemma embedding_prod_mk {f : α → β} {g : γ → δ} (hf : embedding f) (hg : embedding g) :
  embedding (λx:α×γ, (f x.1, g x.2)) :=
⟨assume ⟨x₁, x₂⟩ ⟨y₁, y₂⟩, by simp; exact assume h₁ h₂, ⟨hf.left h₁, hg.left h₂⟩,
  by rw [prod.topological_space, prod.topological_space, hf.right, hg.right,
         induced_compose, induced_compose, induced_sup, induced_compose, induced_compose]⟩

lemma embedding_of_embedding_compose {f : α → β} {g : β → γ} (hf : continuous f) (hg : continuous g)
  (hgf : embedding (g ∘ f)) : embedding f :=
⟨assume a₁ a₂ h, hgf.left $ by simp [h, (∘)],
  le_antisymm
    (by rw [hgf.right, ← continuous_iff_induced_le];
        apply continuous_induced_dom.comp hg)
    (by rwa ← continuous_iff_induced_le)⟩

lemma embedding_open {f : α → β} {s : set α}
  (hf : embedding f) (h : is_open (range f)) (hs : is_open s) : is_open (f '' s) :=
let ⟨t, ht, h_eq⟩ := by rw [hf.right] at hs; exact hs in
have is_open (t ∩ range f), from is_open_inter ht h,
h_eq.symm ▸ by rwa [image_preimage_eq_inter_range]

lemma embedding_is_closed {f : α → β} {s : set α}
  (hf : embedding f) (h : is_closed (range f)) (hs : is_closed s) : is_closed (f '' s) :=
let ⟨t, ht, h_eq⟩ := by rw [hf.right, is_closed_induced_iff] at hs; exact hs in
have is_closed (t ∩ range f), from is_closed_inter ht h,
h_eq.symm ▸ by rwa [image_preimage_eq_inter_range]

lemma embedding.map_nhds_eq [topological_space α] [topological_space β] {f : α → β} (hf : embedding f) (a : α)
  (h : f '' univ ∈ (nhds (f a)).sets) : (nhds a).map f = nhds (f a) :=
by rw [hf.2]; exact map_nhds_induced_eq h

lemma embedding.tendsto_nhds_iff {ι : Type*}
  {f : ι → β} {g : β → γ} {a : filter ι} {b : β} (hg : embedding g) :
  tendsto f a (nhds b) ↔ tendsto (g ∘ f) a (nhds (g b)) :=
by rw [tendsto, tendsto, hg.right, nhds_induced_eq_comap, ← map_le_iff_le_comap, filter.map_map]

lemma embedding.continuous_iff {f : α → β} {g : β → γ} (hg : embedding g) :
  continuous f ↔ continuous (g ∘ f) :=
by simp [continuous_iff_tendsto, embedding.tendsto_nhds_iff hg]

lemma embedding.continuous {f : α → β} (hf : embedding f) : continuous f :=
hf.continuous_iff.mp continuous_id

lemma compact_iff_compact_image_of_embedding {s : set α} {f : α → β} (hf : embedding f) :
  compact s ↔ compact (f '' s) :=
iff.intro (assume h, compact_image h hf.continuous) $ assume h, begin
  rw compact_iff_ultrafilter_le_nhds at ⊢ h,
  intros u hu us',
  let u' : filter β := map f u,
  have : u' ≤ principal (f '' s), begin
    rw [map_le_iff_le_comap, comap_principal], convert us',
    exact preimage_image_eq _ hf.1
  end,
  rcases h u' (ultrafilter_map hu) this with ⟨_, ⟨a, ha, ⟨⟩⟩, _⟩,
  refine ⟨a, ha, _⟩,
  rwa [hf.2, nhds_induced_eq_comap, ←map_le_iff_le_comap]
end

end embedding

section quotient_map

/-- A function between topological spaces is a quotient map if it is surjective,
  and for all `s : set β`, `s` is open iff its preimage is an open set. -/
def quotient_map [tα : topological_space α] [tβ : topological_space β] (f : α → β) : Prop :=
function.surjective f ∧ tβ = tα.coinduced f

variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

lemma quotient_map_id : quotient_map (@id α) :=
⟨assume a, ⟨a, rfl⟩, coinduced_id.symm⟩

lemma quotient_map_compose {f : α → β} {g : β → γ} (hf : quotient_map f) (hg : quotient_map g) :
  quotient_map (g ∘ f) :=
⟨function.surjective_comp hg.left hf.left, by rw [hg.right, hf.right, coinduced_compose]⟩

lemma quotient_map_of_quotient_map_compose {f : α → β} {g : β → γ}
  (hf : continuous f) (hg : continuous g)
  (hgf : quotient_map (g ∘ f)) : quotient_map g :=
⟨assume b, let ⟨a, h⟩ := hgf.left b in ⟨f a, h⟩,
  le_antisymm
    (by rwa ← continuous_iff_le_coinduced)
    (by rw [hgf.right, ← continuous_iff_le_coinduced];
        apply hf.comp continuous_coinduced_rng)⟩

lemma quotient_map.continuous_iff {f : α → β} {g : β → γ} (hf : quotient_map f) :
  continuous g ↔ continuous (g ∘ f) :=
by rw [continuous_iff_le_coinduced, continuous_iff_le_coinduced, hf.right, coinduced_compose]

lemma quotient_map.continuous {f : α → β} (hf : quotient_map f) : continuous f :=
hf.continuous_iff.mp continuous_id

end quotient_map

section sierpinski
variables [topological_space α]

@[simp] lemma is_open_singleton_true : is_open ({true} : set Prop) :=
topological_space.generate_open.basic _ (by simp)

lemma continuous_Prop {p : α → Prop} : continuous p ↔ is_open {x | p x} :=
⟨assume h : continuous p,
  have is_open (p ⁻¹' {true}),
    from h _ is_open_singleton_true,
  by simp [preimage, eq_true] at this; assumption,
  assume h : is_open {x | p x},
  continuous_generated_from $ assume s (hs : s ∈ {{true}}),
    by simp at hs; simp [hs, preimage, eq_true, h]⟩

end sierpinski

section prod
open topological_space
variables [topological_space α] [topological_space β] [topological_space γ]

lemma continuous_fst : continuous (@prod.fst α β) :=
continuous_sup_dom_left continuous_induced_dom

lemma continuous_snd : continuous (@prod.snd α β) :=
continuous_sup_dom_right continuous_induced_dom

lemma continuous.prod_mk {f : γ → α} {g : γ → β}
  (hf : continuous f) (hg : continuous g) : continuous (λx, prod.mk (f x) (g x)) :=
continuous_sup_rng (continuous_induced_rng hf) (continuous_induced_rng hg)

lemma continuous_swap : continuous (prod.swap : α × β → β × α) :=
continuous.prod_mk continuous_snd continuous_fst

lemma is_open_prod {s : set α} {t : set β} (hs : is_open s) (ht : is_open t) :
  is_open (set.prod s t) :=
is_open_inter (continuous_fst s hs) (continuous_snd t ht)

lemma nhds_prod_eq {a : α} {b : β} : nhds (a, b) = filter.prod (nhds a) (nhds b) :=
by rw [filter.prod, prod.topological_space, nhds_sup, nhds_induced_eq_comap, nhds_induced_eq_comap]

lemma prod_mem_nhds_sets {s : set α} {t : set β} {a : α} {b : β}
  (ha : s ∈ (nhds a).sets) (hb : t ∈ (nhds b).sets) : set.prod s t ∈ (nhds (a, b)).sets :=
by rw [nhds_prod_eq]; exact prod_mem_prod ha hb

lemma nhds_swap (a : α) (b : β) : nhds (a, b) = (nhds (b, a)).map prod.swap :=
by rw [nhds_prod_eq, filter.prod_comm, nhds_prod_eq]; refl

lemma tendsto_prod_mk_nhds {γ} {a : α} {b : β} {f : filter γ} {ma : γ → α} {mb : γ → β}
  (ha : tendsto ma f (nhds a)) (hb : tendsto mb f (nhds b)) :
  tendsto (λc, (ma c, mb c)) f (nhds (a, b)) :=
by rw [nhds_prod_eq]; exact filter.tendsto.prod_mk ha hb

lemma prod_generate_from_generate_from_eq {s : set (set α)} {t : set (set β)}
  (hs : ⋃₀ s = univ) (ht : ⋃₀ t = univ) :
  @prod.topological_space α β (generate_from s) (generate_from t) =
  generate_from {g | ∃u∈s, ∃v∈t, g = set.prod u v} :=
let G := generate_from {g | ∃u∈s, ∃v∈t, g = set.prod u v} in
le_antisymm
  (sup_le
    (induced_le_iff_le_coinduced.mpr $ generate_from_le $ assume u hu,
      have (⋃v∈t, set.prod u v) = prod.fst ⁻¹' u,
        from calc (⋃v∈t, set.prod u v) = set.prod u univ :
            set.ext $ assume ⟨a, b⟩, by rw ← ht; simp [and.left_comm] {contextual:=tt}
          ... = prod.fst ⁻¹' u : by simp [set.prod, preimage],
      show G.is_open (prod.fst ⁻¹' u),
        from this ▸ @is_open_Union _ _ G _ $ assume v, @is_open_Union _ _ G _ $ assume hv,
          generate_open.basic _ ⟨_, hu, _, hv, rfl⟩)
    (induced_le_iff_le_coinduced.mpr $ generate_from_le $ assume v hv,
      have (⋃u∈s, set.prod u v) = prod.snd ⁻¹' v,
        from calc (⋃u∈s, set.prod u v) = set.prod univ v:
            set.ext $ assume ⟨a, b⟩, by rw [←hs]; by_cases b ∈ v; simp [h] {contextual:=tt}
          ... = prod.snd ⁻¹' v : by simp [set.prod, preimage],
      show G.is_open (prod.snd ⁻¹' v),
        from this ▸ @is_open_Union _ _ G _ $ assume u, @is_open_Union _ _ G _ $ assume hu,
          generate_open.basic _ ⟨_, hu, _, hv, rfl⟩))
  (generate_from_le $ assume g ⟨u, hu, v, hv, g_eq⟩, g_eq.symm ▸
    @is_open_prod _ _ (generate_from s) (generate_from t) _ _
      (generate_open.basic _ hu) (generate_open.basic _ hv))

lemma prod_eq_generate_from [tα : topological_space α] [tβ : topological_space β] :
  prod.topological_space =
  generate_from {g | ∃(s:set α) (t:set β), is_open s ∧ is_open t ∧ g = set.prod s t} :=
le_antisymm
  (sup_le
    (assume s ⟨t, ht, s_eq⟩,
      have set.prod t univ = s, by simp [s_eq, preimage, set.prod],
      this ▸ (generate_open.basic _ ⟨t, univ, ht, is_open_univ, rfl⟩))
    (assume s ⟨t, ht, s_eq⟩,
      have set.prod univ t = s, by simp [s_eq, preimage, set.prod],
      this ▸ (generate_open.basic _ ⟨univ, t, is_open_univ, ht, rfl⟩)))
  (generate_from_le $ assume g ⟨s, t, hs, ht, g_eq⟩, g_eq.symm ▸ is_open_prod hs ht)

lemma is_open_prod_iff {s : set (α×β)} : is_open s ↔
  (∀a b, (a, b) ∈ s → ∃u v, is_open u ∧ is_open v ∧ a ∈ u ∧ b ∈ v ∧ set.prod u v ⊆ s) :=
begin
  rw [is_open_iff_nhds],
  simp [nhds_prod_eq, mem_prod_iff],
  simp [mem_nhds_sets_iff],
  exact forall_congr (assume a, ball_congr $ assume b h,
    ⟨assume ⟨u', ⟨u, us, uo, au⟩, v', ⟨v, vs, vo, bv⟩, h⟩,
      ⟨u, uo, v, vo, au, bv, subset.trans (set.prod_mono us vs) h⟩,
      assume ⟨u, uo, v, vo, au, bv, h⟩,
      ⟨u, ⟨u, subset.refl u, uo, au⟩, v, ⟨v, subset.refl v, vo, bv⟩, h⟩⟩)
end

lemma closure_prod_eq {s : set α} {t : set β} :
  closure (set.prod s t) = set.prod (closure s) (closure t) :=
set.ext $ assume ⟨a, b⟩,
have filter.prod (nhds a) (nhds b) ⊓ principal (set.prod s t) =
  filter.prod (nhds a ⊓ principal s) (nhds b ⊓ principal t),
  by rw [←prod_inf_prod, prod_principal_principal],
by simp [closure_eq_nhds, nhds_prod_eq, this]; exact prod_neq_bot

lemma is_closed_prod [topological_space α] [topological_space β] {s₁ : set α} {s₂ : set β}
  (h₁ : is_closed s₁) (h₂ : is_closed s₂) : is_closed (set.prod s₁ s₂) :=
closure_eq_iff_is_closed.mp $ by simp [h₁, h₂, closure_prod_eq, closure_eq_of_is_closed]

section tube_lemma

def nhds_contain_boxes (s : set α) (t : set β) : Prop :=
∀ (n : set (α × β)) (hn : is_open n) (hp : set.prod s t ⊆ n),
∃ (u : set α) (v : set β), is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ set.prod u v ⊆ n

lemma nhds_contain_boxes.symm {s : set α} {t : set β} :
  nhds_contain_boxes s t → nhds_contain_boxes t s :=
assume H n hn hp,
  let ⟨u, v, uo, vo, su, tv, p⟩ :=
    H (prod.swap ⁻¹' n)
      (continuous_swap n hn)
      (by rwa [←image_subset_iff, prod.swap, image_swap_prod]) in
  ⟨v, u, vo, uo, tv, su,
    by rwa [←image_subset_iff, prod.swap, image_swap_prod] at p⟩

lemma nhds_contain_boxes.comm {s : set α} {t : set β} :
  nhds_contain_boxes s t ↔ nhds_contain_boxes t s :=
iff.intro nhds_contain_boxes.symm nhds_contain_boxes.symm

lemma nhds_contain_boxes_of_singleton {x : α} {y : β} :
  nhds_contain_boxes ({x} : set α) ({y} : set β) :=
assume n hn hp,
  let ⟨u, v, uo, vo, xu, yv, hp'⟩ :=
    is_open_prod_iff.mp hn x y (hp $ by simp) in
  ⟨u, v, uo, vo, by simpa, by simpa, hp'⟩

lemma nhds_contain_boxes_of_compact {s : set α} (hs : compact s) (t : set β)
  (H : ∀ x ∈ s, nhds_contain_boxes ({x} : set α) t) : nhds_contain_boxes s t :=
assume n hn hp,
have ∀x : subtype s, ∃uv : set α × set β,
     is_open uv.1 ∧ is_open uv.2 ∧ {↑x} ⊆ uv.1 ∧ t ⊆ uv.2 ∧ set.prod uv.1 uv.2 ⊆ n,
  from assume ⟨x, hx⟩,
    have set.prod {x} t ⊆ n, from
      subset.trans (prod_mono (by simpa) (subset.refl _)) hp,
    let ⟨ux,vx,H1⟩ := H x hx n hn this in ⟨⟨ux,vx⟩,H1⟩,
let ⟨uvs, h⟩ := classical.axiom_of_choice this in
have us_cover : s ⊆ ⋃i, (uvs i).1, from
  assume x hx, set.subset_Union _ ⟨x,hx⟩ (by simpa using (h ⟨x,hx⟩).2.2.1),
let ⟨s0, _, s0_fin, s0_cover⟩ :=
  compact_elim_finite_subcover_image hs (λi _, (h i).1) $
    by rw bUnion_univ; exact us_cover in
let u := ⋃(i ∈ s0), (uvs i).1 in
let v := ⋂(i ∈ s0), (uvs i).2 in
have is_open u, from is_open_bUnion (λi _, (h i).1),
have is_open v, from is_open_bInter s0_fin (λi _, (h i).2.1),
have t ⊆ v, from subset_bInter (λi _, (h i).2.2.2.1),
have set.prod u v ⊆ n, from assume ⟨x',y'⟩ ⟨hx',hy'⟩,
  have ∃i ∈ s0, x' ∈ (uvs i).1, by simpa using hx',
  let ⟨i,is0,hi⟩ := this in
  (h i).2.2.2.2 ⟨hi, (bInter_subset_of_mem is0 : v ⊆ (uvs i).2) hy'⟩,
⟨u, v, ‹is_open u›, ‹is_open v›, s0_cover, ‹t ⊆ v›, ‹set.prod u v ⊆ n›⟩

lemma generalized_tube_lemma {s : set α} (hs : compact s) {t : set β} (ht : compact t)
  {n : set (α × β)} (hn : is_open n) (hp : set.prod s t ⊆ n) :
  ∃ (u : set α) (v : set β), is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ set.prod u v ⊆ n :=
have _, from
  nhds_contain_boxes_of_compact hs t $ assume x _, nhds_contain_boxes.symm $
    nhds_contain_boxes_of_compact ht {x} $ assume y _, nhds_contain_boxes_of_singleton,
this n hn hp

end tube_lemma

lemma is_closed_diagonal [topological_space α] [t2_space α] : is_closed {p:α×α | p.1 = p.2} :=
is_closed_iff_nhds.mpr $ assume ⟨a₁, a₂⟩ h, eq_of_nhds_neq_bot $ assume : nhds a₁ ⊓ nhds a₂ = ⊥, h $
  let ⟨t₁, ht₁, t₂, ht₂, (h' : t₁ ∩ t₂ ⊆ ∅)⟩ :=
    by rw [←empty_in_sets_eq_bot, mem_inf_sets] at this; exact this in
  begin
    rw [nhds_prod_eq, ←empty_in_sets_eq_bot],
    apply filter.sets_of_superset,
    apply inter_mem_inf_sets (prod_mem_prod ht₁ ht₂) (mem_principal_sets.mpr (subset.refl _)),
    exact assume ⟨x₁, x₂⟩ ⟨⟨hx₁, hx₂⟩, (heq : x₁ = x₂)⟩,
      show false, from @h' x₁ ⟨hx₁, heq.symm ▸ hx₂⟩
  end

lemma is_closed_eq [topological_space α] [t2_space α] [topological_space β] {f g : β → α}
  (hf : continuous f) (hg : continuous g) : is_closed {x:β | f x = g x} :=
continuous_iff_is_closed.mp (hf.prod_mk hg) _ is_closed_diagonal

lemma diagonal_eq_range_diagonal_map : {p:α×α | p.1 = p.2} = range (λx, (x,x)) :=
ext $ assume p, iff.intro
  (assume h, ⟨p.1, prod.ext_iff.2 ⟨rfl, h⟩⟩)
  (assume ⟨x, hx⟩, show p.1 = p.2, by rw ←hx)

lemma prod_subset_compl_diagonal_iff_disjoint {s t : set α} :
  set.prod s t ⊆ - {p:α×α | p.1 = p.2} ↔ s ∩ t = ∅ :=
by rw [eq_empty_iff_forall_not_mem, subset_compl_comm,
       diagonal_eq_range_diagonal_map, range_subset_iff]; simp

lemma compact_compact_separated [t2_space α] {s t : set α}
  (hs : compact s) (ht : compact t) (hst : s ∩ t = ∅) :
  ∃u v : set α, is_open u ∧ is_open v ∧ s ⊆ u ∧ t ⊆ v ∧ u ∩ v = ∅ :=
by simp only [prod_subset_compl_diagonal_iff_disjoint.symm] at ⊢ hst;
   exact generalized_tube_lemma hs ht is_closed_diagonal hst

lemma closed_of_compact [t2_space α] (s : set α) (hs : compact s) : is_closed s :=
is_open_compl_iff.mpr $ is_open_iff_forall_mem_open.mpr $ assume x hx,
  let ⟨u, v, uo, vo, su, xv, uv⟩ :=
    compact_compact_separated hs (compact_singleton : compact {x})
      (by rwa [inter_comm, ←subset_compl_iff_disjoint, singleton_subset_iff]) in
  have v ⊆ -s, from
    subset_compl_comm.mp (subset.trans su (subset_compl_iff_disjoint.mpr uv)),
⟨v, this, vo, by simpa using xv⟩

/- TODO: more fine grained instances for first_countable_topology, separable_space, t2_space, ... -/
instance [second_countable_topology α] [second_countable_topology β] :
  second_countable_topology (α × β) :=
⟨let ⟨a, ha₁, ha₂, ha₃, ha₄, ha₅⟩ := is_open_generated_countable_inter α in
  let ⟨b, hb₁, hb₂, hb₃, hb₄, hb₅⟩ := is_open_generated_countable_inter β in
  ⟨{g | ∃u∈a, ∃v∈b, g = set.prod u v},
    have {g | ∃u∈a, ∃v∈b, g = set.prod u v} = (⋃u∈a, ⋃v∈b, {set.prod u v}),
      by apply set.ext; simp,
    by rw [this]; exact (countable_bUnion ha₁ $ assume u hu, countable_bUnion hb₁ $ by simp),
    by rw [ha₅, hb₅, prod_generate_from_generate_from_eq ha₄ hb₄]⟩⟩

end prod

section sum
variables [topological_space α] [topological_space β] [topological_space γ]

lemma continuous_inl : continuous (@sum.inl α β) :=
continuous_inf_rng_left continuous_coinduced_rng

lemma continuous_inr : continuous (@sum.inr α β) :=
continuous_inf_rng_right continuous_coinduced_rng

lemma continuous_sum_rec {f : α → γ} {g : β → γ}
  (hf : continuous f) (hg : continuous g) : @continuous (α ⊕ β) γ _ _ (@sum.rec α β (λ_, γ) f g) :=
continuous_inf_dom hf hg

end sum

section subtype
variables [topological_space α] [topological_space β] [topological_space γ] {p : α → Prop}

lemma embedding_graph {f : α → β} (hf : continuous f) : embedding (λx, (x, f x)) :=
embedding_of_embedding_compose (continuous_id.prod_mk hf) continuous_fst embedding_id

lemma embedding_subtype_val : embedding (@subtype.val α p) :=
⟨assume a₁ a₂, subtype.eq, rfl⟩

lemma continuous_subtype_val : continuous (@subtype.val α p) :=
continuous_induced_dom

lemma continuous_subtype_mk {f : β → α}
  (hp : ∀x, p (f x)) (h : continuous f) : continuous (λx, (⟨f x, hp x⟩ : subtype p)) :=
continuous_induced_rng h

lemma embedding_inl : embedding (@sum.inl α β) :=
⟨λ _ _, sum.inl.inj_iff.mp,
  begin
    unfold sum.topological_space,
    apply le_antisymm,
    { intros u hu, existsi (sum.inl '' u),
      change
        (is_open (sum.inl ⁻¹' (@sum.inl α β '' u)) ∧
         is_open (sum.inr ⁻¹' (@sum.inl α β '' u))) ∧
        u = sum.inl ⁻¹' (sum.inl '' u),
      have : sum.inl ⁻¹' (@sum.inl α β '' u) = u :=
        preimage_image_eq u (λ _ _, sum.inl.inj_iff.mp), rw this,
      have : sum.inr ⁻¹' (@sum.inl α β '' u) = ∅ :=
        eq_empty_iff_forall_not_mem.mpr (assume a ⟨b, _, h⟩, sum.inl_ne_inr h), rw this,
      exact ⟨⟨hu, is_open_empty⟩, rfl⟩ },
    { rw induced_le_iff_le_coinduced, exact lattice.inf_le_left }
  end⟩

lemma embedding_inr : embedding (@sum.inr α β) :=
⟨λ _ _, sum.inr.inj_iff.mp,
  begin
    unfold sum.topological_space,
    apply le_antisymm,
    { intros u hu, existsi (sum.inr '' u),
      change
        (is_open (sum.inl ⁻¹' (@sum.inr α β '' u)) ∧
         is_open (sum.inr ⁻¹' (@sum.inr α β '' u))) ∧
        u = sum.inr ⁻¹' (sum.inr '' u),
      have : sum.inl ⁻¹' (@sum.inr α β '' u) = ∅ :=
        eq_empty_iff_forall_not_mem.mpr (assume b ⟨a, _, h⟩, sum.inr_ne_inl h), rw this,
      have : sum.inr ⁻¹' (@sum.inr α β '' u) = u :=
        preimage_image_eq u (λ _ _, sum.inr.inj_iff.mp), rw this,
      exact ⟨⟨is_open_empty, hu⟩, rfl⟩ },
    { rw induced_le_iff_le_coinduced, exact lattice.inf_le_right }
  end⟩

lemma map_nhds_subtype_val_eq {a : α} (ha : p a) (h : {a | p a} ∈ (nhds a).sets) :
  map (@subtype.val α p) (nhds ⟨a, ha⟩) = nhds a :=
map_nhds_induced_eq (by simp [subtype_val_image, h])

lemma nhds_subtype_eq_comap {a : α} {h : p a} :
  nhds (⟨a, h⟩ : subtype p) = comap subtype.val (nhds a) :=
nhds_induced_eq_comap

lemma continuous_subtype_nhds_cover {ι : Sort*} {f : α → β} {c : ι → α → Prop}
  (c_cover : ∀x:α, ∃i, {x | c i x} ∈ (nhds x).sets)
  (f_cont  : ∀i, continuous (λ(x : subtype (c i)), f x.val)) :
  continuous f :=
continuous_iff_tendsto.mpr $ assume x,
  let ⟨i, (c_sets : {x | c i x} ∈ (nhds x).sets)⟩ := c_cover x in
  let x' : subtype (c i) := ⟨x, mem_of_nhds c_sets⟩ in
  calc map f (nhds x) = map f (map subtype.val (nhds x')) :
      congr_arg (map f) (map_nhds_subtype_val_eq _ $ c_sets).symm
    ... = map (λx:subtype (c i), f x.val) (nhds x') : rfl
    ... ≤ nhds (f x) : continuous_iff_tendsto.mp (f_cont i) x'

lemma continuous_subtype_is_closed_cover {ι : Sort*} {f : α → β} (c : ι → α → Prop)
  (h_lf : locally_finite (λi, {x | c i x}))
  (h_is_closed : ∀i, is_closed {x | c i x})
  (h_cover : ∀x, ∃i, c i x)
  (f_cont  : ∀i, continuous (λ(x : subtype (c i)), f x.val)) :
  continuous f :=
continuous_iff_is_closed.mpr $
  assume s hs,
  have ∀i, is_closed (@subtype.val α {x | c i x} '' (f ∘ subtype.val ⁻¹' s)),
    from assume i,
    embedding_is_closed embedding_subtype_val
      (by simp [subtype_val_range]; exact h_is_closed i)
      (continuous_iff_is_closed.mp (f_cont i) _ hs),
  have is_closed (⋃i, @subtype.val α {x | c i x} '' (f ∘ subtype.val ⁻¹' s)),
    from is_closed_Union_of_locally_finite
      (locally_finite_subset h_lf $ assume i x ⟨⟨x', hx'⟩, _, heq⟩, heq ▸ hx')
      this,
  have f ⁻¹' s = (⋃i, @subtype.val α {x | c i x} '' (f ∘ subtype.val ⁻¹' s)),
  begin
    apply set.ext,
    have : ∀ (x : α), f x ∈ s ↔ ∃ (i : ι), c i x ∧ f x ∈ s :=
      λ x, ⟨λ hx, let ⟨i, hi⟩ := h_cover x in ⟨i, hi, hx⟩,
            λ ⟨i, hi, hx⟩, hx⟩,
    simp [and.comm, and.left_comm], simpa [(∘)],
  end,
  by rwa [this]

lemma closure_subtype {x : {a // p a}} {s : set {a // p a}}:
  x ∈ closure s ↔ x.val ∈ closure (subtype.val '' s) :=
closure_induced $ assume x y, subtype.eq

lemma compact_iff_compact_in_subtype {s : set {a // p a}} :
  compact s ↔ compact (subtype.val '' s) :=
compact_iff_compact_image_of_embedding embedding_subtype_val

lemma compact_iff_compact_univ {s : set α} : compact s ↔ compact (univ : set (subtype s)) :=
by rw [compact_iff_compact_in_subtype, image_univ, subtype_val_range]; refl

end subtype

section quotient
variables [topological_space α] [topological_space β] [topological_space γ]
variables {r : α → α → Prop} {s : setoid α}

lemma quotient_map_quot_mk : quotient_map (@quot.mk α r) :=
⟨quot.exists_rep, rfl⟩

lemma continuous_quot_mk : continuous (@quot.mk α r) :=
continuous_coinduced_rng

lemma continuous_quot_lift {f : α → β} (hr : ∀ a b, r a b → f a = f b)
  (h : continuous f) : continuous (quot.lift f hr : quot r → β) :=
continuous_coinduced_dom h

lemma quotient_map_quotient_mk : quotient_map (@quotient.mk α s) :=
quotient_map_quot_mk

lemma continuous_quotient_mk : continuous (@quotient.mk α s) :=
continuous_coinduced_rng

lemma continuous_quotient_lift {f : α → β} (hs : ∀ a b, a ≈ b → f a = f b)
  (h : continuous f) : continuous (quotient.lift f hs : quotient s → β) :=
continuous_coinduced_dom h

end quotient

section pi
variables {ι : Type*} {π : ι → Type*}
open topological_space

lemma continuous_pi [topological_space α] [∀i, topological_space (π i)] {f : α → Πi:ι, π i}
  (h : ∀i, continuous (λa, f a i)) : continuous f :=
continuous_supr_rng $ assume i, continuous_induced_rng $ h i

lemma continuous_apply [∀i, topological_space (π i)] (i : ι) :
  continuous (λp:Πi, π i, p i) :=
continuous_supr_dom continuous_induced_dom

lemma nhds_pi [t : ∀i, topological_space (π i)] {a : Πi, π i} :
  nhds a = (⨅i, comap (λx, x i) (nhds (a i))) :=
calc nhds a = (⨅i, @nhds _ (@topological_space.induced _ _ (λx:Πi, π i, x i) (t i)) a) : nhds_supr
  ... = (⨅i, comap (λx, x i) (nhds (a i))) : by simp [nhds_induced_eq_comap]

/-- Tychonoff's theorem -/
lemma compact_pi_infinite [∀i, topological_space (π i)] {s : Πi:ι, set (π i)} :
  (∀i, compact (s i)) → compact {x : Πi:ι, π i | ∀i, x i ∈ s i} :=
begin
  simp [compact_iff_ultrafilter_le_nhds, nhds_pi],
  exact assume h f hf hfs,
    let p : Πi:ι, filter (π i) := λi, map (λx:Πi:ι, π i, x i) f in
    have ∀i:ι, ∃a, a∈s i ∧ p i ≤ nhds a,
      from assume i, h i (p i) (ultrafilter_map hf) $
      show (λx:Πi:ι, π i, x i) ⁻¹' s i ∈ f.sets,
        from mem_sets_of_superset hfs $ assume x (hx : ∀i, x i ∈ s i), hx i,
    let ⟨a, ha⟩ := classical.axiom_of_choice this in
    ⟨a, assume i, (ha i).left, assume i, map_le_iff_le_comap.mp $ (ha i).right⟩
end

lemma is_open_set_pi [∀a, topological_space (π a)] {i : set ι} {s : Πa, set (π a)}
  (hi : finite i) (hs : ∀a∈i, is_open (s a)) : is_open (pi i s) :=
by rw [pi_def]; exact (is_open_bInter hi $ assume a ha, continuous_apply a _ $ hs a ha)

lemma pi_eq_generate_from [∀a, topological_space (π a)] :
  Pi.topological_space =
  generate_from {g | ∃(s:Πa, set (π a)) (i : finset ι), (∀a∈i, is_open (s a)) ∧ g = pi ↑i s} :=
le_antisymm
  (supr_le $ assume a s ⟨t, ht, s_eq⟩, generate_open.basic _ $
    ⟨function.update (λa, univ) a t, {a}, by simpa using ht, by ext f; simp [s_eq, pi]⟩)
  (generate_from_le $ assume g ⟨s, i, hi, eq⟩, eq.symm ▸ is_open_set_pi (finset.finite_to_set _) hi)

lemma pi_generate_from_eq {g : Πa, set (set (π a))} :
  @Pi.topological_space ι π (λa, generate_from (g a)) =
  generate_from {t | ∃(s:Πa, set (π a)) (i : finset ι), (∀a∈i, s a ∈ g a) ∧ t = pi ↑i s} :=
let G := {t | ∃(s:Πa, set (π a)) (i : finset ι), (∀a∈i, s a ∈ g a) ∧ t = pi ↑i s} in
begin
  rw [pi_eq_generate_from],
  refine le_antisymm (generate_from_le _) (generate_from_mono _),
  { rintros s ⟨t, i, hi, rfl⟩,
    rw [pi_def],
    apply is_open_bInter (finset.finite_to_set _),
    assume a ha, show ((generate_from G).coinduced (λf:Πa, π a, f a)).is_open (t a),
    refine generate_from_le _ _ (hi a ha),
    exact assume s hs, generate_open.basic _ ⟨function.update (λa, univ) a s, {a}, by simp [hs]⟩ },
  exact assume s ⟨t, i, ht, eq⟩, ⟨t, i, assume a ha, generate_open.basic _ (ht a ha), eq⟩
end

lemma pi_generate_from_eq_fintype {g : Πa, set (set (π a))} [fintype ι] (hg : ∀a, ⋃₀ g a = univ) :
  @Pi.topological_space ι π (λa, generate_from (g a)) =
  generate_from {t | ∃(s:Πa, set (π a)), (∀a, s a ∈ g a) ∧ t = pi univ s} :=
let G := {t | ∃(s:Πa, set (π a)), (∀a, s a ∈ g a) ∧ t = pi univ s} in
begin
  rw [pi_generate_from_eq],
  refine le_antisymm (generate_from_le _) (generate_from_mono _),
  { rintros s ⟨t, i, ht, rfl⟩,
    apply is_open_iff_forall_mem_open.2 _,
    assume f hf,
    have : ∀a, ∃s, s ∈ g a ∧ f a ∈ s,
    { assume a, have : f a ∈ ⋃₀ g a, { rw [hg], apply mem_univ }, simpa },
    rcases classical.axiom_of_choice this with ⟨c, hc⟩,
    refine ⟨pi univ (λa, if a ∈ i then t a else (c : Πa, set (π a)) a), _, _, _⟩,
    { simp [pi_if] },
    { refine generate_open.basic _ ⟨_, assume a, _, rfl⟩,
      by_cases a ∈ i; simp [*, pi] at * },
    { have : f ∈ pi {a | a ∉ i} c, { simp [*, pi] at * },
      simpa [pi_if, hf] } },
  exact assume s ⟨t, ht, eq⟩, ⟨t, finset.univ, by simp [ht, eq]⟩
end

instance second_countable_topology_fintype
  [fintype ι] [t : ∀a, topological_space (π a)] [sc : ∀a, second_countable_topology (π a)] :
  second_countable_topology (∀a, π a) :=
have ∀i, ∃b : set (set (π i)), countable b ∧ ∅ ∉ b ∧ is_topological_basis b, from
  assume a, @is_open_generated_countable_inter (π a) _ (sc a),
let ⟨g, hg⟩ := classical.axiom_of_choice this in
have t = (λa, generate_from (g a)), from funext $ assume a, (hg a).2.2.2.2,
begin
  constructor,
  refine ⟨pi univ '' pi univ g, countable_image _ _, _⟩,
  { suffices : countable {f : Πa, set (π a) | ∀a, f a ∈ g a}, { simpa [pi] },
    exact countable_pi (assume i, (hg i).1), },
  rw [this, pi_generate_from_eq_fintype],
  { congr' 1, ext f, simp [pi, eq_comm] },
  exact assume a, (hg a).2.2.2.1
end

end pi

-- TODO: use embeddings from above!
structure dense_embedding [topological_space α] [topological_space β] (e : α → β) : Prop :=
(dense   : ∀x, x ∈ closure (range e))
(inj     : function.injective e)
(induced : ∀a, comap e (nhds (e a)) = nhds a)

theorem dense_embedding.mk'
  [topological_space α] [topological_space β] (e : α → β)
  (c     : continuous e)
  (dense : ∀x, x ∈ closure (range e))
  (inj   : function.injective e)
  (H     : ∀ (a:α) s ∈ (nhds a).sets,
    ∃t ∈ (nhds (e a)).sets, ∀ b, e b ∈ t → b ∈ s) :
  dense_embedding e :=
⟨dense, inj, λ a, le_antisymm
  (by simpa [le_def] using H a)
  (tendsto_iff_comap.1 $ c.tendsto _)⟩

namespace dense_embedding
variables [topological_space α] [topological_space β]
variables {e : α → β} (de : dense_embedding e)

protected lemma embedding (de : dense_embedding e) : embedding e :=
⟨de.inj, eq_of_nhds_eq_nhds begin intro a, rw [← de.induced a, nhds_induced_eq_comap] end⟩

protected lemma tendsto (de : dense_embedding e) {a : α} : tendsto e (nhds a) (nhds (e a)) :=
by rw [←de.induced a]; exact tendsto_comap

protected lemma continuous (de : dense_embedding e) {a : α} : continuous e :=
continuous_iff_tendsto.2 $ λ a, de.tendsto

lemma inj_iff (de : dense_embedding e) {x y} : e x = e y ↔ x = y := de.inj.eq_iff

lemma closure_range : closure (range e) = univ :=
let h := de.dense in
set.ext $ assume x, ⟨assume _, trivial, assume _, @h x⟩

lemma self_sub_closure_image_preimage_of_open {s : set β} (de : dense_embedding e) :
  is_open s → s ⊆ closure (e '' (e ⁻¹' s)) :=
begin
  intros s_op b b_in_s,
  rw [image_preimage_eq_inter_range, mem_closure_iff],
  intros U U_op b_in,
  rw ←inter_assoc,
  have ne_e : U ∩ s ≠ ∅ := ne_empty_of_mem ⟨b_in, b_in_s⟩,
  exact (dense_iff_inter_open.1 de.closure_range) _ (is_open_inter U_op s_op) ne_e
end

lemma closure_image_nhds_of_nhds {s : set α} {a : α} (de : dense_embedding e) :
  s ∈ (nhds a).sets → closure (e '' s) ∈ (nhds (e a)).sets :=
begin
  rw [← de.induced a, mem_comap_sets],
  intro h,
  rcases h with ⟨t, t_nhd, sub⟩,
  rw mem_nhds_sets_iff at t_nhd,
  rcases t_nhd with ⟨U, U_sub, ⟨U_op, e_a_in_U⟩⟩,
  have := calc e ⁻¹' U ⊆ e⁻¹' t : preimage_mono U_sub
                   ... ⊆ s      : sub,
  have := calc U ⊆ closure (e '' (e ⁻¹' U)) : self_sub_closure_image_preimage_of_open de U_op
             ... ⊆ closure (e '' s)         : closure_mono (image_subset e this),
  have U_nhd : U ∈ (nhds (e a)).sets := mem_nhds_sets U_op e_a_in_U,
  exact (nhds (e a)).sets_of_superset U_nhd this
end

variables [topological_space δ] {f : γ → α} {g : γ → δ} {h : δ → β}
/--
 γ -f→ α
g↓     ↓e
 δ -h→ β
-/
lemma tendsto_comap_nhds_nhds  {d : δ} {a : α} (de : dense_embedding e) (H : tendsto h (nhds d) (nhds (e a)))
  (comm : h ∘ g = e ∘ f) : tendsto f (comap g (nhds d)) (nhds a) :=
begin
  have lim1 : map g (comap g (nhds d)) ≤ nhds d := map_comap_le,
  replace lim1 : map h (map g (comap g (nhds d))) ≤ map h (nhds d) := map_mono lim1,
  rw [filter.map_map, comm, ← filter.map_map, map_le_iff_le_comap] at lim1,
  have lim2 :  comap e (map h (nhds d)) ≤  comap e  (nhds (e a)) := comap_mono H,
  rw de.induced at lim2,
  exact le_trans lim1 lim2,
end

protected lemma nhds_inf_neq_bot (de : dense_embedding e) {b : β} : nhds b ⊓ principal (range e) ≠ ⊥ :=
begin
  have h := de.dense,
  simp [closure_eq_nhds] at h,
  exact h _
end

lemma comap_nhds_neq_bot (de : dense_embedding e) {b : β} : comap e (nhds b) ≠ ⊥ :=
forall_sets_neq_empty_iff_neq_bot.mp $
assume s ⟨t, ht, (hs : e ⁻¹' t ⊆ s)⟩,
have t ∩ range e ∈ (nhds b ⊓ principal (range e)).sets,
  from inter_mem_inf_sets ht (subset.refl _),
let ⟨_, ⟨hx₁, y, rfl⟩⟩ := inhabited_of_mem_sets de.nhds_inf_neq_bot this in
subset_ne_empty hs $ ne_empty_of_mem hx₁

variables [topological_space γ]
/-- If `e : α → β` is a dense embedding, then any function `α → γ` extends to a function `β → γ`. -/
def extend (de : dense_embedding e) (f : α → γ) (b : β) : γ :=
have nonempty γ, from
let ⟨_, ⟨_, a, _⟩⟩ := exists_mem_of_ne_empty
  (mem_closure_iff.1 (de.dense b) _ is_open_univ trivial) in ⟨f a⟩,
@lim _ (classical.inhabited_of_nonempty this) _ (map f (comap e (nhds b)))

lemma extend_eq [t2_space γ] {b : β} {c : γ} {f : α → γ}
  (hf : map f (comap e (nhds b)) ≤ nhds c) : de.extend f b = c :=
@lim_eq _ (id _) _ _ _ _ (by simp; exact comap_nhds_neq_bot de) hf

lemma extend_e_eq [t2_space γ] {a : α} {f : α → γ} (de : dense_embedding e)
  (hf : map f (nhds a) ≤ nhds (f a)) : de.extend f (e a) = f a :=
de.extend_eq begin rw de.induced; exact hf end

lemma tendsto_extend [regular_space γ] {b : β} {f : α → γ} (de : dense_embedding e)
  (hf : {b | ∃c, tendsto f (comap e $ nhds b) (nhds c)} ∈ (nhds b).sets) :
  tendsto (de.extend f) (nhds b) (nhds (de.extend f b)) :=
let φ := {b | tendsto f (comap e $ nhds b) (nhds $ de.extend f b)} in
have hφ : φ ∈ (nhds b).sets,
  from (nhds b).sets_of_superset hf $ assume b ⟨c, hc⟩,
    show tendsto f (comap e (nhds b)) (nhds (de.extend f b)), from (de.extend_eq hc).symm ▸ hc,
assume s hs,
let ⟨s'', hs''₁, hs''₂, hs''₃⟩ := nhds_is_closed hs in
let ⟨s', hs'₁, (hs'₂ : e ⁻¹' s' ⊆ f ⁻¹' s'')⟩ := mem_of_nhds hφ hs''₁ in
let ⟨t, (ht₁ : t ⊆ φ ∩ s'), ht₂, ht₃⟩ := mem_nhds_sets_iff.mp $ inter_mem_sets hφ hs'₁ in
have h₁ : closure (f '' (e ⁻¹' s')) ⊆ s'',
  by rw [closure_subset_iff_subset_of_is_closed hs''₃, image_subset_iff]; exact hs'₂,
have h₂ : t ⊆ de.extend f ⁻¹' closure (f '' (e ⁻¹' t)), from
  assume b' hb',
  have nhds b' ≤ principal t, by simp; exact mem_nhds_sets ht₂ hb',
  have map f (comap e (nhds b')) ≤ nhds (de.extend f b') ⊓ principal (f '' (e ⁻¹' t)),
    from calc _ ≤ map f (comap e (nhds b' ⊓ principal t)) : map_mono $ comap_mono $ le_inf (le_refl _) this
      ... ≤ map f (comap e (nhds b')) ⊓ map f (comap e (principal t)) :
        le_inf (map_mono $ comap_mono $ inf_le_left) (map_mono $ comap_mono $ inf_le_right)
      ... ≤ map f (comap e (nhds b')) ⊓ principal (f '' (e ⁻¹' t)) : by simp [le_refl]
      ... ≤ _ : inf_le_inf ((ht₁ hb').left) (le_refl _),
  show de.extend f b' ∈ closure (f '' (e ⁻¹' t)),
  begin
    rw [closure_eq_nhds],
    apply neq_bot_of_le_neq_bot _ this,
    simp,
    exact de.comap_nhds_neq_bot
  end,
(nhds b).sets_of_superset
  (show t ∈ (nhds b).sets, from mem_nhds_sets ht₂ ht₃)
  (calc t ⊆ de.extend f ⁻¹' closure (f '' (e ⁻¹' t)) : h₂
    ... ⊆ de.extend f ⁻¹' closure (f '' (e ⁻¹' s')) :
      preimage_mono $ closure_mono $ image_subset f $ preimage_mono $ subset.trans ht₁ $ inter_subset_right _ _
    ... ⊆ de.extend f ⁻¹' s'' : preimage_mono h₁
    ... ⊆ de.extend f ⁻¹' s : preimage_mono hs''₂)

lemma continuous_extend [regular_space γ] {f : α → γ} (de : dense_embedding e)
  (hf : ∀b, ∃c, tendsto f (comap e (nhds b)) (nhds c)) : continuous (de.extend f) :=
continuous_iff_tendsto.mpr $ assume b, de.tendsto_extend $ univ_mem_sets' hf

end dense_embedding

namespace dense_embedding
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

/-- The product of two dense embeddings is a dense embedding -/
protected def prod {e₁ : α → β} {e₂ : γ → δ} (de₁ : dense_embedding e₁) (de₂ : dense_embedding e₂) :
  dense_embedding (λ(p : α × γ), (e₁ p.1, e₂ p.2)) :=
{ dense_embedding .
  dense   :=
    have closure (range (λ(p : α × γ), (e₁ p.1, e₂ p.2))) =
        set.prod (closure (range e₁)) (closure (range e₂)),
      by rw [←closure_prod_eq, prod_range_range_eq],
    assume ⟨b, d⟩, begin rw [this], simp, constructor, apply de₁.dense, apply de₂.dense end,
  inj     := assume ⟨x₁, x₂⟩ ⟨y₁, y₂⟩,
    by simp; exact assume h₁ h₂, ⟨de₁.inj h₁, de₂.inj h₂⟩,
  induced := assume ⟨a, b⟩,
    by rw [nhds_prod_eq, nhds_prod_eq, ←prod_comap_comap_eq, de₁.induced, de₂.induced] }

def subtype_emb (p : α → Prop) {e : α → β} (de : dense_embedding e) (x : {x // p x}) :
  {x // x ∈ closure (e '' {x | p x})} :=
⟨e x.1, subset_closure $ mem_image_of_mem e x.2⟩

protected def subtype (p : α → Prop) {e : α → β} (de : dense_embedding e) :
  dense_embedding (de.subtype_emb p) :=
{ dense_embedding .
  dense   := assume ⟨x, hx⟩, closure_subtype.mpr $
    have (λ (x : {x // p x}), e (x.val)) = e ∘ subtype.val, from rfl,
    begin
      rw ← image_univ,
      simp [(image_comp _ _ _).symm, (∘), subtype_emb, -image_univ],
      rw [this, image_comp, subtype_val_image],
      simp,
      assumption
    end,
  inj     := assume ⟨x, hx⟩ ⟨y, hy⟩ h, subtype.eq $ de.inj $ @@congr_arg subtype.val h,
  induced := assume ⟨x, hx⟩,
    by simp [subtype_emb, nhds_subtype_eq_comap, comap_comap_comp, (∘), (de.induced x).symm] }

end dense_embedding

lemma is_closed_property [topological_space α] [topological_space β] {e : α → β} {p : β → Prop}
  (he : closure (range e) = univ) (hp : is_closed {x | p x}) (h : ∀a, p (e a)) :
  ∀b, p b :=
have univ ⊆ {b | p b},
  from calc univ = closure (range e) : he.symm
    ... ⊆ closure {b | p b} : closure_mono $ range_subset_iff.mpr h
    ... = _ : closure_eq_of_is_closed hp,
assume b, this trivial

lemma is_closed_property2 [topological_space α] [topological_space β] {e : α → β} {p : β → β → Prop}
  (he : dense_embedding e) (hp : is_closed {q:β×β | p q.1 q.2}) (h : ∀a₁ a₂, p (e a₁) (e a₂)) :
  ∀b₁ b₂, p b₁ b₂ :=
have ∀q:β×β, p q.1 q.2,
  from is_closed_property (he.prod he).closure_range hp $ assume a, h _ _,
assume b₁ b₂, this ⟨b₁, b₂⟩

lemma is_closed_property3 [topological_space α] [topological_space β] {e : α → β} {p : β → β → β → Prop}
  (he : dense_embedding e) (hp : is_closed {q:β×β×β | p q.1 q.2.1 q.2.2}) (h : ∀a₁ a₂ a₃, p (e a₁) (e a₂) (e a₃)) :
  ∀b₁ b₂ b₃, p b₁ b₂ b₃ :=
have ∀q:β×β×β, p q.1 q.2.1 q.2.2,
  from is_closed_property (he.prod $ he.prod he).closure_range hp $ assume ⟨a₁, a₂, a₃⟩, h _ _ _,
assume b₁ b₂ b₃, this ⟨b₁, b₂, b₃⟩

lemma mem_closure_of_continuous [topological_space α] [topological_space β]
  {f : α → β} {a : α} {s : set α} {t : set β}
  (hf : continuous f) (ha : a ∈ closure s) (h : ∀a∈s, f a ∈ closure t) :
  f a ∈ closure t :=
calc f a ∈ f '' closure s : mem_image_of_mem _ ha
  ... ⊆ closure (f '' s) : image_closure_subset_closure_image hf
  ... ⊆ closure (closure t) : closure_mono $ image_subset_iff.mpr $ h
  ... ⊆ closure t : begin rw [closure_eq_of_is_closed], exact subset.refl _, exact is_closed_closure end

lemma mem_closure_of_continuous2 [topological_space α] [topological_space β] [topological_space γ]
  {f : α → β → γ} {a : α} {b : β} {s : set α} {t : set β} {u : set γ}
  (hf : continuous (λp:α×β, f p.1 p.2)) (ha : a ∈ closure s) (hb : b ∈ closure t)
  (h : ∀a∈s, ∀b∈t, f a b ∈ closure u) :
  f a b ∈ closure u :=
have (a,b) ∈ closure (set.prod s t),
  by simp [closure_prod_eq, ha, hb],
show f (a, b).1 (a, b).2 ∈ closure u,
  from @mem_closure_of_continuous (α×β) _ _ _ (λp:α×β, f p.1 p.2) (a,b) _ u hf this $
    assume ⟨p₁, p₂⟩ ⟨h₁, h₂⟩, h p₁ h₁ p₂ h₂


macro "foo!" x:term : term => `(let xs := $x; xs.succ + xs)

def f1 (x : Nat) : Nat :=
foo! x+1

theorem ex1 (x : Nat) : f1 x = Nat.succ (x+1) + (x + 1) :=
rfl

def f2 (xs : Nat) : Nat :=
foo! xs

theorem ex2 (x : Nat) : f2 x = Nat.succ x + x :=
rfl


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

! This file was ported from Lean 3 source module category_theory.preadditive.yoneda.injective
! leanprover-community/mathlib commit f8d8465c3c392a93b9ed226956e26dee00975946
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Preadditive.Yoneda.Basic
import Mathbin.CategoryTheory.Preadditive.Injective
import Mathbin.Algebra.Category.Group.EpiMono
import Mathbin.Algebra.Category.Module.EpiMono

/-!
An object is injective iff the preadditive yoneda functor on it preserves epimorphisms.
-/

universe v u

open Opposite

namespace CategoryTheory

variable {C : Type u} [Category.{v} C]

section Preadditive

variable [Preadditive C]

namespace Injective

theorem injective_iff_preservesEpimorphisms_preadditiveYoneda_obj (J : C) :
    Injective J ↔ (preadditiveYoneda.obj J).PreservesEpimorphisms :=
  by
  rw [injective_iff_preserves_epimorphisms_yoneda_obj]
  refine' ⟨fun h : (preadditive_yoneda.obj J ⋙ forget _).PreservesEpimorphisms => _, _⟩
  ·
    exact
      functor.preserves_epimorphisms_of_preserves_of_reflects (preadditive_yoneda.obj J) (forget _)
  · intro
    exact (inferInstance : (preadditive_yoneda.obj J ⋙ forget _).PreservesEpimorphisms)
#align category_theory.injective.injective_iff_preserves_epimorphisms_preadditive_yoneda_obj CategoryTheory.Injective.injective_iff_preservesEpimorphisms_preadditiveYoneda_obj

theorem injective_iff_preservesEpimorphisms_preadditive_yoneda_obj' (J : C) :
    Injective J ↔ (preadditiveYonedaObj J).PreservesEpimorphisms :=
  by
  rw [injective_iff_preserves_epimorphisms_yoneda_obj]
  refine' ⟨fun h : (preadditive_yoneda_obj J ⋙ forget _).PreservesEpimorphisms => _, _⟩
  ·
    exact
      functor.preserves_epimorphisms_of_preserves_of_reflects (preadditive_yoneda_obj J) (forget _)
  · intro
    exact (inferInstance : (preadditive_yoneda_obj J ⋙ forget _).PreservesEpimorphisms)
#align category_theory.injective.injective_iff_preserves_epimorphisms_preadditive_yoneda_obj' CategoryTheory.Injective.injective_iff_preservesEpimorphisms_preadditive_yoneda_obj'

end Injective

end Preadditive

end CategoryTheory


import order.conditionally_complete_lattice
import algebra.order.with_zero
import topology.instances.nnreal

noncomputable theory

namespace nnreal

/- variables (α β : Type*) {ι : Sort*}
variables [nonempty ι] [cg : linear_ordered_comm_group_with_zero α]
--[decidable_eq α] -/

/- variables {α : Type*} [linear_ordered_comm_group_with_zero α] [conditionally_complete_lattice α]
[covariant_class α α (*) (≤)]

#exit -/
variables {ι : Sort*} [nonempty ι]

lemma le_mul_cinfi {a : nnreal} {g : nnreal} {h : ι → nnreal}
  (H : ∀ j, a ≤ g * h j) : a ≤ g * infi h :=
begin
  by_cases hg : g = 0,
  { simp_rw [hg, zero_mul] at H ⊢,
    exact H (nonempty.some _inst_1), },
  { rw [mul_comm, ← mul_inv_le_iff₀ hg],
    apply le_cinfi,
    simp_rw [mul_inv_le_iff₀ hg, mul_comm],
    exact H, }
end

lemma mul_csupr_le {a : nnreal} {g : nnreal} {h : ι → nnreal}
  (H : ∀ j, g * h j ≤ a) : g * supr h ≤ a :=
begin
  by_cases hg : g = 0,
  { simp_rw [hg, zero_mul] at H ⊢,
    exact H (nonempty.some _inst_1), },
  { rw mul_comm,
    rw ← le_div_iff₀ hg,
    apply csupr_le,
    simp_rw [le_div_iff₀ hg, mul_comm],
    exact H, }
end

lemma le_cinfi_mul {a : nnreal} {g : ι → nnreal} {h : nnreal}
  (H : ∀ i, a ≤ g i * h) : a ≤ infi g * h :=
begin
  by_cases hh : h = 0,
  { simp_rw [hh, mul_zero] at H ⊢,
    exact H (nonempty.some _inst_1) },
  { simp_rw ← mul_inv_le_iff₀ hh at H ⊢,
    exact le_cinfi H, }
end

lemma csupr_mul_le {a : nnreal} {g : ι → nnreal} {h : nnreal}
  (H : ∀ i, g i * h ≤ a) : supr g * h ≤ a :=
begin
  by_cases hh : h = 0,
  { simp_rw [hh, mul_zero] at H ⊢,
    exact H (nonempty.some _inst_1) },
  { simp_rw ← le_div_iff₀ hh at H ⊢,
    exact csupr_le H, }
end

lemma le_cinfi_mul_cinfi {a : nnreal} {g h : ι → nnreal} (H : ∀ i j, a ≤ g i * h j) :
  a ≤ infi g * infi h :=
le_cinfi_mul  $ λ i, le_mul_cinfi $ H i

@[to_additive]
lemma csupr_mul_csupr_le {a : nnreal} {g h : ι → nnreal} (H : ∀ i j, g i * h j ≤ a) :
  supr g * supr h ≤ a :=
csupr_mul_le $ λ i, mul_csupr_le $ H _

variables {f : ι → nnreal}

lemma mul_csupr (hf : bdd_above (set.range f)) (a : nnreal) :
  a * (⨆ i, f i) = ⨆ i, a * f i :=
begin
  by_cases ha : a = 0,
  { rw [ha, zero_mul], simp_rw zero_mul, rw csupr_const, },
  { apply le_antisymm,
    { rw [mul_comm, ← le_div_iff₀ ha],
      apply csupr_le,
      intro i,
      rw [le_div_iff₀ ha, mul_comm],
      have h_bdd : bdd_above (set.range (λ z, a * f z)),
      { obtain ⟨b, hb⟩ := hf,
        use (a * b),
        rw mem_upper_bounds at hb ⊢,
        rintros r ⟨z, hz⟩,
        simpa [← hz, mul_le_mul_left (lt_of_le_of_ne (zero_le a) (ne.symm ha))]
        using hb (f z) (set.mem_range_self z), },
      exact le_csupr h_bdd _, },
    { apply csupr_le,
      intro z,
      simpa [mul_le_mul_left (lt_of_le_of_ne (zero_le a) (ne.symm ha))] using le_csupr hf _, }},
end

lemma csupr_mul (hf : bdd_above (set.range f)) (a : nnreal) :
  (⨆ i, f i) * a = ⨆ i, f i * a :=
by { rw [mul_comm, mul_csupr hf], simp_rw [mul_comm] }

lemma csupr_div (hf : bdd_above (set.range f)) (a : nnreal) :
  (⨆ i, f i) / a = ⨆ i, f i / a :=
by simp only [div_eq_mul_inv, csupr_mul hf]

end nnreal


import tactic

inductive foo : Type
| atom : ℕ → foo
| neg : foo → foo

open foo

lemma not_self_double_dual (A) : neg (neg A) ≠ A := sorry

inductive dual (A : foo) : foo → foo → Prop
| negpos : dual (neg A) A
| posneg : dual A (neg A)

theorem bar (A B) : dual A B (neg B) → A = B :=
begin
  intro d,
  have h := not_self_double_dual A,
  generalize_hyp e : B = B' at d,
end

  -- intro e,
  -- apply_fun foo.sizeof at e,
  -- refine ne_of_gt _ e,
  -- refine lt_trans _ _, exact (neg A).sizeof,
  -- rw [foo.sizeof, nat.add_comm], exact nat.lt_succ_self _ ,
  -- rw [foo.sizeof, foo.sizeof], apply add_lt_add_left,
  -- have : sizeof (neg A) = (neg A).sizeof, refl, rw this,
  -- rw [foo.sizeof, nat.add_comm], exact nat.lt_succ_self _ ,


import number_theory.bernoulli

--OUTPUT 1
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- apply strong induction on $n$, so for all $m < d$,  $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$
  induction n with d hd,
  from by ring,
  from by {
    -- and we want to show that $B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$
    have h1 : (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x^(d - 1),
      from by {
        have h2 : (d + 1) * (1 + x)^d = (d + 1) * x^d + ((d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^k), from by {
          rw pow_add, ring, },
        have h3 : ∀ k : fin d, (d + 1) * dchoose (d + 1) k * x^k = d * dchoose (d + 1) k * x^k + dchoose (d + 1) k * x^k, from
          assume (k : fin d), (d + 1) * dchoose (d + 1) k * x^k = (d * dchoose (d + 1) k + dchoose (d + 1) k) * x^k,
        have h4 : ∀ k : fin d, dchoose (d + 1) k * x^k = dchoose (d + 1) k * x^{k + 1} / x, from assume (k : fin d),
          dchoose (d + 1) k * x^k = dchoose (d + 1) k * x^{k + 1} / x,
        have h5 : (d + 1) * x^d = (d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^k, from by {
          congr, rw [← polynomial.bernoulli_eq_sum], ext, ring, },
        have h6 : (d + 1) * (1 + x)^d - (d + 1) * x^d = (d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^(k + 1) / x, from by {
          rw [h2,h5,add_comm], ring, },
        have h7 : (d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^(k + 1) = (d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^k * x, from by {
          congr, ext, ring, },
        have h8 : (d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^(k + 1) / x = (d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^k + (d + 1) * ∑ (k : fin d), dchoose (d + 1) k * x^k, from by {
          rw [h7,mul_div_cancel,one_mul], },
        have h9 : ∀ k : fin d, dchoose (d + 1) k * x^k = (polynomial.bernoulli k).eval x, from assume (k : fin d),
          dchoose (d + 1) k * x^k = (polynomial.bernoulli k).eval x,
        have h10 : ∀ k : fin d, dchoose (d + 1) k * x^k = (polynomial.bernoulli k).eval x, from assume (k : fin d),
          dchoose (d + 1) k * x^k = (polynomial.bernoulli k).eval x,
        have h11 : ∀ k : fin d, (d + 1) * dchoose (d + 1) k * x^k = (d + 1) * (polynomial.bernoulli k).eval x, from assume (k : fin d),
          (d + 1) * dchoose (d + 1) k * x^k = (d + 1) * (polynomial.bernoulli k).eval x,
        have h12 : ∀ k : fin d, dchoose (d + 1) k * x^k = dchoose (d + 1) k * x^{k + 1} / x, from assume (k : fin d),
          dchoose (d + 1) k * x^k = dchoose (d + 1) k * x^{k + 1} / x,
        have h13 : ∀ k : fin d, (d + 1) * dchoose (d + 1) k * x^(k + 1) = (d + 1) * (polynomial.bernoulli k).eval x * x, from assume (k : fin d),
          (d + 1) * dchoose (d + 1) k * x^(k + 1) = (d + 1) * (polynomial.bernoulli k).eval x * x,
        have h14 : ∀ k : fin d, (d + 1) * dchoose (d + 1) k * x^k + (d + 1) * dchoose (d + 1) k * x^k = (d + 1) * (polynomial.bernoulli k).eval x + (d + 1) * (polynomial.bernoulli k).eval x, from assume (k : fin d),
          (d + 1) * dchoose (d + 1) k * x^k + (d + 1) * dchoose (d + 1) k * x^k = (d + 1) * (polynomial.bernoulli k).eval x + (d + 1) * (polynomial.bernoulli k).eval x,
        have h15 : ∀ k : fin d, dchoose (d + 1) k * x^k + dchoose (d + 1) k * x^k = (polynomial.bernoulli k).eval x + (polynomial.bernoulli k).eval x, from assume (k : fin d),
          dchoose (d + 1) k * x^k + dchoose (d + 1) k * x^k = (polynomial.bernoulli k).eval x + (polynomial.bernoulli k).eval x,
        have h16 : ∀ k : fin d, d * (polynomial.bernoulli k).eval x + dchoose (d + 1) k * x^k = d * (polynomial.bernoulli k).eval x + (polynomial.bernoulli k).eval x, from assume (k : fin d),
          d * (polynomial.bernoulli k).eval x + dchoose (d + 1) k * x^k = d * (polynomial.bernoulli k).eval x + (polynomial.bernoulli k).eval x,
        have h17 : ∀ k : fin d, (d + 1) * (polynomial.bernoulli k).eval x + (d + 1) * (polynomial.bernoulli k).eval x = d * (polynomial.bernoulli k).eval x + (polynomial.bernoulli k).eval x, from assume (k : fin d),
          (d + 1) * (polynomial.bernoulli k).eval x + (d + 1) * (polynomial.bernoulli k).eval x = d * (polynomial.bernoulli k).eval x + (polynomial.bernoulli k).eval x,
        have h18 : (d + 1) * (1 + x)^d - (d + 1) * x^d = (d + 1) * ∑ (k : fin d), (polynomial.bernoulli k).eval x, from by {
          rw [h2,h3,h4,h5,h6,h7,h8,h9,h10,h11,h12,h13,h14,h15,h16,h17], ring, },
        have h19 : (d + 1) * (1 + x)^d - (d + 1) * x^
end --Needs more than 2000 tokens!

--OUTPUT 2
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with d hd,
  {
    rw polynomial.bernoulli_zero,
    rw polynomial.eval_one,
    rw nat.sub_zero,
    ring,
  },
  {
    rw polynomial.bernoulli_succ,
    rw polynomial.eval_add,
    rw polynomial.eval_mul,
    rw polynomial.eval_X,
    rw polynomial.eval_C,
    rw polynomial.eval_one,
    rw polynomial.eval_X,
    rw polynomial.eval_C,
    rw polynomial.eval_add,
    rw nat.sub_succ,
    rw polynomial.eval_mul,
    rw polynomial.eval_X,
    rw polynomial.eval_C,
    rw polynomial.eval_one,
    rw polynomial.eval_X,
    rw polynomial.eval_C,
    rw polynomial.eval_add,
    rw polynomial.eval_mul,
    rw polynomial.eval_X,
    rw polynomial.eval_C,
    rw nat.cast_add,
    rw nat.cast_one,
    rw nat.add_comm,
    rw nat.add_one,
    rw nat.add_one,
    rw nat.add_one,
    rw nat.add_one,
    rw hd,
    ring,
  }
end

--OUTPUT 3
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
    -- we apply strong induction on $n$
  induction n with d hd,
    -- the base case with $n=0$ is trivial
  {
    show (polynomial.bernoulli 0).eval (1 + x) = (polynomial.bernoulli 0).eval x, from
    obviously,
  },
  -- in the inductive case, we have that $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ for all $m < d$
  {
    assume : ∀ m < d, (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x ^ (m - 1),
    -- we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
    have goal : (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x ^ (d - 1), from
    begin
      --  multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number),
      have sum_eq : (d + 1) * ((1 + x) ^ d - x ^ d) = polynomial.sum (λ l, (d + 1) * ((d + 1) ^ l : ℚ) / (fact l) * x ^ (l - 1)), from
      begin
        { refine congr_arg (λ p : polynomial ℚ, (d + 1) * p) _, have h : ∀ n, ((d + 1) ^ n) / (fact n) = nth_bernoulli n * (d + 1), from
        begin
          assume n, rw [nat.otimes_pow, nat.div_pow_of_pow_le, nat.fact_eq_zero, zero_le, nat.div_eq_of_eq_mul, ←nat.div_eq_div_iff, ←nat.div_eq_div_iff],
          exact nat.pow_le_pow_of_le_right (d + 1) (succ n) (nat.le_add_right _ _),
        end, rw [h, nth_bernoulli_polynomial_eq], rw [polynomial.sum_C_mul], refl, },
        { assume l, rw [nat.div_eq_div_iff, nat.div_eq_div_iff], have h : (d + 1) ^ l * (fact d) * (d + 1) = (d + 1) ^ (l + 1), from
        calc (d + 1) ^ l * (fact d) * (d + 1) = (d + 1) ^ l * (fact d) * (1 + d + 1) : by rw add_comm
        ... = (d + 1) ^ l * (fact d) * (1 + (d + 1)) : by rw add_assoc
        ... = (d + 1) ^ l * (fact d) * (fact d + 1) : by rw [←fact_succ d, ←nat.fact_eq_zero d, add_zero]
        ... = (d + 1) ^ l * (fact (d + 1)) : by rw fact_succ
        ... = (d + 1) ^ (l + 1) : by rw [←nat.fact_eq_zero (d + 1), nat.pow_succ (d + 1) l], rw h, },
        { assume l hl, rw [fact_pos hl, nat.pow_succ (d + 1) l, nat.pow_succ (d + 1) (l - 1), nat.div_mul_cancel (nat.pos_of_ne_zero (ne_of_gt (nat.pos_of_ne_zero hl)))], rw ←nat.fact_eq_zero (d + 1), },
      end,
      -- The conclusion then follows easily
      cases nat.eq_or_lt_of_le (nat.succ_le_of_lt (by linarith)) with hdl hdl,
        -- If $d = l$ then we are done
      {
        rw hdl, rw [polynomial.sum_C_mul], rw [polynomial.sum_C_mul], rw ←sum_eq, refl,
      },
      {
        -- Otherwise, we use the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number)
        have h7 : (d + 1) * ((1 + x) ^ d - x ^ d) = d * (d + 1) * x ^ (d - 1) + (d + 1) * ((1 + x) ^ (d - 1) - x ^ (d - 1)), from
        begin
          calc (d + 1) * ((1 + x) ^ d - x ^ d) = d * (d + 1) * x ^ (d - 1) + (d + 1) * ((1 + x) ^ d - x ^ d - x ^ (d - 1)) : by rw sub_sub
          ... = d * (d + 1) * x ^ (d - 1) + (d + 1) * ((1 + x) ^ d - x ^ d - (1 + x) * x ^ (d - 1)) : by rw nat.sub_sub
          ... = d * (d + 1) * x ^ (d - 1) + (d + 1) * ((1 + x) * ((1 + x) ^ (d - 1) - x ^ (d - 1))) : by rw sub_sub
          ... = d * (d + 1) * x ^ (d - 1) + (d + 1) * ((1 + x) * ((1 + x) ^ (d - 1) - (1 + x) * x ^ (d - 2))) : by rw nat.sub_sub
          ... = d * (d + 1) * x ^ (d - 1) + (d + 1) * ((1 + x) * (1 + x) ^ (d - 1) - (1 + x)^2 * x ^ (d - 2)) : by rw sub_sub
          ... = d * (d + 1) * x ^ (d - 1) + (d + 1) * (1 + x) * ((1 + x) ^ (d - 1) - x ^ (d - 1)) : by rw nat.sub_sub,
        end,
        -- and conclude by induction
        rw ←sum_eq at h7, rw polynomial.sum_add at h7, rw add_comm at h7, rw polynomial.sum_add at h7, rw ←nat.mul_sub_left_distrib at h7, rw pow_zero at h7, rw mul_one at h7, rw ←nat.mul_sub_left_distrib at h7, rw ←nat.mul_sub_left_distrib at h7, rw [polynomial.sum_C_mul], rw [polynomial.sum_C_mul], rw ←hd, rw pow_zero, rw mul_one, rw pow_zero, rw mul_one, rw ←hd, rw hdl, rw add_comm, rw add_comm, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←sum_eq, rw ←
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- ind./cases
  cases n,
  { -- base case
    have e1 : (polynomial.bernoulli (nat.succ 0)).eval (1 + x) = (polynomial.bernoulli (nat.succ 0)).eval x + (nat.succ 0) * x^(nat.succ 0 - 1), from by
    {
      -- rw
      rw nat.one_mul,
      rw nat.one_pow,
      rw polynomial.bernoulli,
      rw polynomial.eval_sum,
      -- calc
      calc (polynomial.X * (polynomial.bernoulli (nat.succ 0)).deriv).eval (1 + x) = polynomial.X.eval (1 + x) * (polynomial.bernoulli (nat.succ 0)).deriv.eval (1 + x) : by apply polynomial.eval_mul
      ... = (1 + x) * (polynomial.bernoulli (nat.succ 0)).deriv.eval (1 + x) : by {rw polynomial.X, rw polynomial.eval_C, ring}
      ... = (1 + x) * (polynomial.bernoulli (nat.succ (nat.succ 0))).deriv.eval x : by {rw polynomial.bernoulli, rw polynomial.deriv_sum, rw ← polynomial.deriv_C, rw polynomial.deriv_X, rw polynomial.deriv_const, rw polynomial.eval_pow, ac_refl, rw polynomial.deriv_const, rw polynomial.eval_C, rw nat.succ_ne_zero, rw polynomial.eval_const, ac_refl}
      ... = (1 + x) * 1 : by {rw polynomial.bernoulli, rw polynomial.deriv_sum, rw ← polynomial.deriv_C, rw polynomial.deriv_X, rw polynomial.deriv_const, rw polynomial.eval_pow, ac_refl, rw polynomial.deriv_const, rw polynomial.eval_C, rw nat.succ_ne_zero, rw polynomial.eval_C, ac_refl}
      ... = 1 + x : by ring
      ... = polynomial.X.eval x * (polynomial.bernoulli (nat.succ 0)).deriv.eval x : by {rw polynomial.X, rw polynomial.eval_C, ring,}
      ... = (polynomial.X * (polynomial.bernoulli (nat.succ 0)).deriv).eval x : by apply polynomial.eval_mul
      ... = (polynomial.bernoulli (nat.succ 0)).eval x : by rw polynomial.bernoulli,
      rw nat.one_mul,
      rw nat.one_pow,
    },
    rw e1,
    exact rfl,
  },
  { -- inductive case
    assume d : ℕ,
    assume ih : polynomial.bernoulli d = polynomial.bernoulli d.succ.succ,
    have e1 : (polynomial.bernoulli (nat.succ d)).eval (1 + x) = (polynomial.bernoulli (nat.succ d)).eval x + (nat.succ d) * x^(nat.succ d - 1), from by
    {
      -- rw
      rw polynomial.bernoulli,
      rw polynomial.eval_sum,
      -- calc
      calc (polynomial.X * (polynomial.bernoulli (nat.succ d)).deriv).eval (1 + x) = polynomial.X.eval (1 + x) * (polynomial.bernoulli (nat.succ d)).deriv.eval (1 + x) : by apply polynomial.eval_mul
      ... = (1 + x) * (polynomial.bernoulli (nat.succ d)).deriv.eval (1 + x) : by {rw polynomial.X, rw polynomial.eval_C, ring}
      ... = (1 + x) * (polynomial.bernoulli (nat.succ (nat.succ d))).deriv.eval x : by {rw polynomial.bernoulli, rw polynomial.deriv_sum, rw ← polynomial.deriv_C, rw polynomial.deriv_X, rw polynomial.deriv_const, rw polynomial.eval_pow, ac_refl, rw polynomial.deriv_const, rw polynomial.eval_C, rw nat.succ_ne_zero, rw polynomial.eval_const, ac_refl}
      ... = (1 + x) * (nat.succ d) * x^(d - 1) : by {rw polynomial.bernoulli, rw polynomial.deriv_sum, rw ← polynomial.deriv_C, rw polynomial.deriv_X, rw polynomial.deriv_const, rw polynomial.eval_pow, ac_refl, rw polynomial.deriv_const, rw polynomial.eval_C, rw nat.succ_ne_zero, rw polynomial.eval_C, ac_refl, rw polynomial.eval_mul, rw polynomial.eval_const, rw polynomial.eval_pow, ac_refl}
      ... = (1 + x) * (nat.succ d) * x^(d - 1) : by {rw nat.pow_succ_eq_mul_pow, rw nat.succ_pred_eq_of_pos, rw nat.zero_ne_one, ac_refl}
      ... = (nat.succ d) * (1 + x) * x^(d - 1) : by ring
      ... = (1 + x) * (nat.succ d) * x^(d - 1) : by ring
      ... = (1 + x) * (polynomial.bernoulli d).deriv.eval x : by {rw polynomial.bernoulli, rw polynomial.deriv_sum, rw ← polynomial.deriv_C, rw polynomial.deriv_X, rw polynomial.deriv_const, rw polynomial.eval_pow, ac_refl, rw polynomial.deriv_const, rw polynomial.eval_C, rw nat.succ_ne_zero, rw polynomial.eval_const, ac_refl}
      ... = (1 + x) * (polynomial.bernoulli (nat.succ d)).deriv.eval x : by rw ih
      ... = polynomial.X.eval x * (polynomial.bernoulli (nat.succ d)).deriv.eval x : by {rw polynomial.X, rw polynomial.eval_C, ring}
      ... = (polynomial.X * (polynomial.bernoulli (nat.succ d)).deriv).eval x : by apply polynomial.eval_mul
      ... = (polynomial.bernoulli (nat.succ d)).eval x : by rw polynomial.bernoulli
      ... = (polynomial.bernoulli d).eval x + (nat.succ d) * x^(nat.succ d - 1) : by rw ih
    },
    rw e1,
    exact rfl,
  }
end

--OUTPUT 5
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- We apply strong induction on $n$
  induction n with d hd,
  case nat.zero {
    -- Let $B_0 (x) = 1$
    use (1 : ℚ),
    -- Then $B_0 (1 + x) = 1$, as required.
    conv {to_lhs, rw ← hd }, ring
  },
  case nat.succ {
    -- Given $B_n (x)$ is correct, we want to deduce that $B_{n+1} (x)$ is correct.
    have h1 : polynomial.bernoulli n.succ = polynomial.bernoulli n + n.succ * X^n, from
        by obviously,

    have h2 : (n + 1) * (1 + x)^n = (n + 1) * x^n + (n + 1) * (n * x^(n - 1)), from by {
      have h2 : (1 + x)^n = x^n + n * x^(n - 1), from hd.symm,
      rw h2, ring,
    },

    rw h2,
    show (polynomial.bernoulli (n+1)).eval (1+x) =
        (polynomial.bernoulli (n+1)).eval x + (n+1) * x^n, rw [h1, eval_add, h1, eval_add, h1], ring }
end

--OUTPUT 6
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  have h1 : (polynomial.bernoulli n).eval (1 + x) = n * x^(n - 1),
  {
    have h2 : (polynomial.bernoulli n).eval (1 + x) = (((polynomial.bernoulli n).eval 1) * (1 + x)^n - (polynomial.bernoulli n).eval x * (1 + x)^n), by ring,
    rw [h2, polynomial.bernoulli_eval_one], rw pow_one (1 + x), rw pow_one x, rw mul_one, rw mul_one, rw mul_one, ring,
  },

  have h3 : (polynomial.bernoulli n).eval x + n * x^(n - 1) = ((polynomial.bernoulli n).eval x + (polynomial.bernoulli n).eval x) + n * x^(n - 1), by ring,
  rw [h3, h1], ring,
end

--OUTPUT 7
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n with m hi,
  { -- Base case
    -- $n = 0$
    exact by {simp},
  },
  {
    -- Induction step
    have H2 : ∀ x : ℚ, (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1), from
      assume x : ℚ, hi,
    have H3 : ∀ x : ℚ, (polynomial.bernoulli (m + 1)).eval (1 + x) = (polynomial.bernoulli (m + 1)).eval x + m * x^m * ((x + 1) - x), from
      assume x : ℚ, polynomial.eval_mul_leading_coeff (polynomial.bernoulli (m + 1)) (1 + x),

    -- The conclusion follows easily
    exact by {rw [H2,H3], ring, done},
  }
end

--OUTPUT 8
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- We apply strong induction on $n$
  apply nat.strong_induction_on n,
  assume (d : ℕ) (H : ∀ m : ℕ, m < d →
    (polynomial.bernoulli m).eval (1 + x) = (polynomial.bernoulli m).eval x + m * x^(m - 1)),

  -- We want to show that $B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$
  have h1 : (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x^(d - 1),

  -- Multiplying both sides by $(d+1)$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$
  calc (polynomial.bernoulli d).eval (1 + x) = (polynomial.bernoulli d).eval x + d * x^(d - 1) : H d (nat.succ_lt_succ (nat.zero_lt_succ d))
  ... = (d + 1) * (1 + x)^d - (d + 1) * x^d :
    -- (where $B_k$ is the $k$-th Bernoulli number)
    begin
      assume (d : ℕ),
      have h0 : ∀ l : ℕ, (polynomial.bernoulli l).eval 0 = l / (l + 1), from assume l,
        begin
          -- Let us first prove that $B_l (x) = B_{l - 1} (x) + 1$
          have h1 : (polynomial.bernoulli l).eval x = (polynomial.bernoulli (l - 1)).eval x + 1, from by {
            induction l with l hl,
            have h2 : polynomial.bernoulli 0 = polynomial.C 1, from by {
              apply polynomial.C_1,
            },
            rw [h2,polynomial.C_add],
            rw [hl],
            apply polynomial.one_mul,
          },

          -- Now, using the fact that $B_l (0) = 0$ for all $l \in \mathbb{N}$, we conclude that $B_{l - 1} (0) = -\frac{1}{l}$
          rw [h1,ring.sub_zero],
        end,

      -- We now need to apply the formula $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$
      have h2 : ∀ l : ℕ, (∑ k in finset.range (l + 1), (l + 1)!/((k+1)! * (l - k)!) * l / (l + 1)) = l + 1, from assume l,
        begin
          induction l with l hl,
          simp,
          show (∑ (k : fin n), n! / k! / ((n - k + 1)!) * (n - 1) / (n + 1)) = n + 1, from by simp,

          show (∑ (k : fin (l+2)), (l+2)! / k! / (l+2 - k)! * l / (l+2)) = l + 1 + 1, from by {
            rw [finset.sum_range_succ],
            rw [hl],
            have h3 : (l + 1) * (l + 2) / (l + 2) = l + 1, from begin
              rw [mul_comm (l + 1) (l + 2),mul_one_div_cancel l.succ_pos],
              exact dec_trivial,
            end,
            ring,
          }
        end,

      -- Now, let us apply the formula
      induction d with d hd,
      rw [zero_add,finset.sum_range_zero],
      simp,

      rw [ring.add_assoc,ring.one_add,finset.sum_range_succ],
      rw [ring.add_assoc,ring.one_add,finset.sum_range_succ],
      have h3 : (d + 1) * (1 + x)^d - (d + 1) * x^d =
        (∑ k in finset.range (d + 1), (d + 1)!/((k+1)! * (d - k + 1)!) * (d + 1)) * x^d - (d + 1) * x^d, from by {
        rw [polynomial.pow_coe_add_one,polynomial.pow_coe_add_one],
        rw [polynomial.coe_C],
        rw [polynomial.coe_C],
        have h3 : ∑ k in finset.range (1 + 1), d! / ((1 + k)! * (1 - k + 1)!) = d + 1, from
          by {rw [one_add,finset.sum_range_succ], rw [finset.sum_range_zero], simp, },
        rw [h3],
        rw [nat.fact_succ_eq_succ_mul,nat.fact_succ_eq_succ_mul],
        rw [field.div_mul_cancel ((nat.succ d).pos)],
        rw [field.div_mul_cancel ((nat.succ d).pos)],
        rw [nat.cast_one,nat.cast_one,field.mul_one],
        rw [← fpow_add_one,fpow_succ],
        have h4 : (d! / ((1 + 1)! * (1 - 1 + 1)!)) = d, from by {
          have h5 : (d! / ((1 + 1)! * (1 - 1 + 1)!)) = (d! / (1! * (1 - 1 + 1)!)), from by simp,
          have h6 : (d! / (1! * (2)!) = d), from by {
            rw [nat.fact_succ_eq_succ_mul,nat.fact_eq_one,nat.cast_one,field.one_mul],
            rw [field.mul_inv_cancel ((nat.succ d).pos),field.inv_eq_one_div],
            rw [nat.fact_eq_one,nat.cast_one,field.one_div],
            ring,
          },
          exact eq.trans h5 h6,
        },
        rw [h4],
      },
      have h4 : (∑ k in finset.range (d + 1), (d + 1)!/((k+1)! * (d - k + 1)!) * (d + 1)) * x^d - (d + 1) * x^d =
        (d + 1) * x^d * (∑ k in finset.range (d + 1), (d + 1)!/((k+1)! * (d - k + 1)!) - 1), from by {
          rw [mul_sub,mul_sub,mul_assoc,mul_comm x^d (d + 1)],
          ring,
        },
      have h5 : (d + 1) * x^d * (∑ k in finset.range (d + 1), (d + 1)!/((k+1)! * (d - k + 1)!) - 1) = (d + 1) * x^d * (d + 1 - 1), from by {
        have h6 : ∑ k in finset.range (d + 1), (d + 1)!/((k+1)! * (d - k + 1)!) - 1 = d, from
          by {rw [h2,nat.sub_eq_zero_iff_eq,one_add],},
        rw [h6],
      },
      have h6 : (d + 1) * x^d
end --Needs more than 2000 tokens!

--OUTPUT 9
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  induction n using nat.strong_induction_on,
  rw polynomial.bernoulli_zero, rw polynomial.eval_zero, rw polynomial.eval_zero, rw one_add_one, ring,
  rw polynomial.bernoulli_succ, rw polynomial.eval_add, rw polynomial.eval_C, rw add_one,
  rw polynomial.eval_mul, rw polynomial.eval_X, rw polynomial.eval_pow, rw polynomial.eval_X,
  rw polynomial.eval_mul, rw polynomial.eval_X, rw polynomial.eval_pow, rw pow_succ, rw mul_one,
  have h : polynomial.bernoulli (n + 1) = (n + 1 : ℚ) * X^n + polynomial.bernoulli n, from
    polynomial.bernoulli_eq_add_mul_X n,
  rw polynomial.eval_add, rw polynomial.eval_mul, rw polynomial.eval_C, rw polynomial.eval_X,
  rw polynomial.eval_pow, rw pow_succ, rw pow_zero, ring, rw ←h, rw ←n_ih, ring,
end

--OUTPUT 10
theorem bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
begin
  -- We apply strong induction on $n$
  have h1 : ∀ (d : ℕ), ∀ (m : ℕ), m < d → (bernoulli m).eval (1 + x) = (bernoulli m).eval x + m * x^(m - 1),
  begin
    intro d,
    induction d with d hd, -- d = 0
    {
      assume m hm,
      rw [zero_lt_iff_ne_zero] at hm,
      cases m,
      {
        rw [one_eq_succ_zero],
        simp,
      },
      {
        rw [succ_eq_add_one],
        rw [add_one_ne_zero] at hm,
        rw [add_lt_iff_pos_right] at hm,
        rw [pos_iff_ne_zero] at hm,
        rw [succ_eq_add_one],
        rw [hm],
        ring,
      }
    }, -- d = succ d, use strong induction
    {
      assume (m : ℕ) (hm : m < succ d),
      cases hm with hm_lt hm_eq,
      rw [succ_lt_succ_iff] at hm_lt,
      rw [hm_eq],
      rw [succ_eq_add_one],
      have h1 : (bernoulli d).eval (1+x) = (bernoulli d).eval x + d * x^(d - 1), from hd _ hm_lt,
      ring,
      rw [succ_eq_add_one],
      have h2 : (bernoulli m).eval (1+x) = (bernoulli m).eval x + m * x^(m - 1), from hd _ hm_lt,
      exact h2,
    }
  end,
  -- Hence, $(d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1}$
  have h2 : (n + 1) * (1 + x)^n - (n + 1) * x^n = (polynomial.eval (bernoulli n) x) + sum (range n) (λ l : ℕ, (n + 1) * (l+1) * x^l / ↑(n+1)),
  begin
    have h1_1 : ∀ (l : ℕ), l < n + 1 → (n+1) * (l+1) * x^l  = ((n+1) * x^l) * (l+1), from
      assume (l : ℕ) (h : l < n + 1), by ring,
    rw [←polynomial.eval_add (polynomial.bernoulli n) ((n+1) * x^n),
        polynomial.eval_add, polynomial.eval_smul, polynomial.eval_C, polynomial.eval_zero,
        polynomial.sum_range_succ_zero n (λ l : ℕ, (n + 1) * (l + 1) * x^l / ↑(n + 1)),
        ←polynomial.eval_add (polynomial.sum_range_succ_zero n (λ l : ℕ, (n + 1) * (l + 1) * x^l / ↑(n + 1)))
        (((n+1) * x^n) * (1+x)),
        polynomial.eval_add, polynomial.eval_add (polynomial.sum_range_succ_zero n (λ l : ℕ, (n + 1) * (l + 1) * x^l / ↑(n + 1))),
        polynomial.eval_smul, polynomial.eval_C],
    simp,
    rw [polynomial.sum_mul_distrib],
    have h1_2 : (1+x) * (n+1) - (n+1) * x^n = (n+1) * x^(n - 1), by ring,
    rw [h1_2],
    have h1_3 : ∀ (l : ℕ), l < n + 1 → (1+x)^l = (x^l * (l+1)) + (bernoulli l).eval (1+x), from
      assume (l : ℕ) (h : l < n + 1),
      begin
        induction l with l hl,
        {
          rw [zero_lt_iff_ne_zero] at h,
          rw [one_eq_succ_zero],
          rw [one_eq_succ_zero] at h,
          have h1 : ¬ l < 0, from
            (not_lt_of_ge (nat.zero_le l))
              (by {rw [lt_iff_le_and_ne],
                    split,
                    rwa nat.zero_le,
                    rw [one_ne_zero],
                    intro h2,
                    rw [succ_inj] at h2,
                    rw [h2],
                    exact h})
          rw [zero_lt_iff_ne_zero] at h1,
          rw [h1],
          simp,
        }, -- l = succ l, use strong induction
        {
          rw [succ_lt_succ_iff] at h,
          rw [succ_eq_add_one, ←add_zero (polynomial.bernoulli l)],
          rw [polynomial.mul_add],
          rw [polynomial.mul_C_mul_X, polynomial.mul_X_mul_X],
          rw [←polynomial.eval_add (polynomial.bernoulli l) x^l],
          rw [polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_C],
          have h1 : l < n + 1, from h.left,
          have h2 : (bernoulli l).eval (1+x) = (bernoulli l).eval x + l * x^(l - 1), from h1_3 l h1,
          rw [h2, ←hl h.left],
          ring,
        },
      end,
    simp,
    have h1_4 := (h1_3 n (le_refl n)),
    rw [←polynomial.eval_add (polynomial.bernoulli n) x^n] at h1_4,
    rw [←polynomial.eval_smul (bernoulli n) (n+1) x^n],
    rw [←polynomial.eval_add (polynomial.bernoulli n) n * x^n] at h1_4,
    rw [polynomial.eval_add, polynomial.eval_add, polynomial.eval_add, polynomial.eval_C],
    ring,
    {
      assume i hi,
      have h1_5 : (1 + x)^i = (x^i * (i + 1)) + (bernoulli i).eval (1 + x), from h1_3 _ hi,
      rw [h1_5],
      rw [polynomial.eval_add, polynomial.eval_smul, polynomial.eval_C],
      ring,
    }
  end,
  -- The conclusion then follows easily
  rw [←add_assoc, ←h2],
  ring,
end

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

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

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

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

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

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

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  -- $A$ and $B$ are sets. $A$ and $B$ belong to power set of $S$
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  -- Then $A ⊆ S$ and $B ⊆ S$, by power set definition
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by {split,apply set.subset_of_mem_powerset,exact hA,apply set.subset_of_mem_powerset,exact hB},
  -- Then $(A ∩ B) ⊆ A$, by intersection of set is a subset
  have h2 : (A ∩ B) ⊆ A, from by apply set.inter_subset_left,
  -- Then $(A ∩ B) ⊆ S$, by subset relation is transitive
  have h3 : (A ∩ B) ⊆ S, from by {apply set.subset.trans h2 h1.left},
  -- Hence $(A ∩ B) ∈  𝒫 S$, by power set definition
  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
  -- expand the power
  calc (x + y)^2 = (x+y)*(x+y) : by rw sq
  -- distributive property of multiplication over addition gives:
  ... = x*(x+y) + y*(x+y) : by rw add_mul
  -- applying the above property further gives:
  ... = 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}
  -- rearranging the terms using commutativity and adding gives:
  ... = 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
  -- Group has Latin Square Property
  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, },

  -- Setting $b = a$, this becomes:
  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,

  -- These $x$ and $y$ are both $(1 : G)$, by definition of identity element
  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`
Bernoulli polynomial evaluation
Given a natural number $n$ and a rational $x$, let $B_n (x)$ denote the $n$-th Bernoulli polynomial evaluated at $x$. Then, $$B_n (1 + x) = B_n (x) + n x^{n - 1}$$
`proof`
We apply strong induction on $n$. So, for all $m < d$, we have $B_{m} (1 + x) = B_{m} (x) + m x^{m - 1}$ and we want to show that $$B_{d} (1 + x) = B_{d} (x) + d x^{d - 1}$$
Multiplying both sides by $d + 1$, and using the fact that, for all $l \in \mathbb{N}$, $\sum_{k = 0}^{l} {l + 1 \choose k} B_k = (l + 1) X^l$ (where $B_k$ is the $k$-th Bernoulli number), we get that
$$ (d + 1) (1 + x)^d - (d + 1) x^d = \sum_{l = 0}^{d} {d + 1 \choose l} l x^{l - 1} $$
The conclusion then follows easily.

QED

-/
theorem  bernoulli_eval_one_add (n : ℕ) (x : ℚ) :
  (polynomial.bernoulli n).eval (1 + x) = (polynomial.bernoulli n).eval x + n * x^(n - 1) :=
FEW SHOT PROMPTS TO CODEX(END)-/