/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis
-/

import analysis.normed.group.hom
import analysis.normed_space.basic
import analysis.normed_space.linear_isometry
import algebra.star.self_adjoint
import algebra.star.unitary

/-!
# Normed star rings and algebras

A normed star group is a normed group with a compatible `star` which is isometric.

A C⋆-ring is a normed star group that is also a ring and that verifies the stronger
condition `∥x⋆ * x∥ = ∥x∥^2` for all `x`.  If a C⋆-ring is also a star algebra, then it is a
C⋆-algebra.

To get a C⋆-algebra `E` over field `𝕜`, use
`[normed_field 𝕜] [star_ring 𝕜] [normed_ring E] [star_ring E] [cstar_ring E]
 [normed_algebra 𝕜 E] [star_module 𝕜 E]`.

## TODO

- Show that `∥x⋆ * x∥ = ∥x∥^2` is equivalent to `∥x⋆ * x∥ = ∥x⋆∥ * ∥x∥`, which is used as the
  definition of C*-algebras in some sources (e.g. Wikipedia).

-/

open_locale topological_space

local postfix `⋆`:std.prec.max_plus := star

/-- A normed star group is a normed group with a compatible `star` which is isometric. -/
class normed_star_group (E : Type*) [semi_normed_group E] [star_add_monoid E] : Prop :=
(norm_star : ∀ x : E, ∥x⋆∥ = ∥x∥)

export normed_star_group (norm_star)
attribute [simp] norm_star

variables {𝕜 E α : Type*}

section normed_star_group
variables [semi_normed_group E] [star_add_monoid E] [normed_star_group E]

@[simp] lemma nnnorm_star (x : E) : ∥star x∥₊ = ∥x∥₊ := subtype.ext $ norm_star _

/-- The `star` map in a normed star group is a normed group homomorphism. -/
def star_normed_group_hom : normed_group_hom E E :=
{ bound' := ⟨1, λ v, le_trans (norm_star _).le (one_mul _).symm.le⟩,
  .. star_add_equiv }

/-- The `star` map in a normed star group is an isometry -/
lemma star_isometry : isometry (star : E → E) :=
star_add_equiv.to_add_monoid_hom.isometry_of_norm norm_star

@[priority 100]
instance normed_star_group.to_has_continuous_star : has_continuous_star E :=
⟨star_isometry.continuous⟩

end normed_star_group

instance ring_hom_isometric.star_ring_end [normed_comm_ring E] [star_ring E]
  [normed_star_group E] : ring_hom_isometric (star_ring_end E) :=
⟨norm_star⟩

/-- A C*-ring is a normed star ring that satifies the stronger condition `∥x⋆ * x∥ = ∥x∥^2`
for every `x`. -/
class cstar_ring (E : Type*) [non_unital_normed_ring E] [star_ring E] : Prop :=
(norm_star_mul_self : ∀ {x : E}, ∥x⋆ * x∥ = ∥x∥ * ∥x∥)

instance : cstar_ring ℝ :=
{ norm_star_mul_self := λ x, by simp only [star, id.def, norm_mul] }

namespace cstar_ring
section non_unital

variables [non_unital_normed_ring E] [star_ring E] [cstar_ring E]

/-- In a C*-ring, star preserves the norm. -/
@[priority 100] -- see Note [lower instance priority]
instance to_normed_star_group : normed_star_group E :=
⟨begin
  intro x,
  by_cases htriv : x = 0,
  { simp only [htriv, star_zero] },
  { have hnt : 0 < ∥x∥ := norm_pos_iff.mpr htriv,
    have hnt_star : 0 < ∥x⋆∥ :=
      norm_pos_iff.mpr ((add_equiv.map_ne_zero_iff star_add_equiv).mpr htriv),
    have h₁ := calc
      ∥x∥ * ∥x∥ = ∥x⋆ * x∥        : norm_star_mul_self.symm
            ... ≤ ∥x⋆∥ * ∥x∥      : norm_mul_le _ _,
    have h₂ := calc
      ∥x⋆∥ * ∥x⋆∥ = ∥x * x⋆∥      : by rw [←norm_star_mul_self, star_star]
             ... ≤ ∥x∥ * ∥x⋆∥     : norm_mul_le _ _,
    exact le_antisymm (le_of_mul_le_mul_right h₂ hnt_star) (le_of_mul_le_mul_right h₁ hnt) },
end⟩

lemma norm_self_mul_star {x : E} : ∥x * x⋆∥ = ∥x∥ * ∥x∥ :=
by { nth_rewrite 0 [←star_star x], simp only [norm_star_mul_self, norm_star] }

lemma norm_star_mul_self' {x : E} : ∥x⋆ * x∥ = ∥x⋆∥ * ∥x∥ :=
by rw [norm_star_mul_self, norm_star]

lemma nnnorm_star_mul_self {x : E} : ∥x⋆ * x∥₊ = ∥x∥₊ * ∥x∥₊ :=
subtype.ext norm_star_mul_self

end non_unital

section unital
variables [normed_ring E] [star_ring E] [cstar_ring E]

@[simp] lemma norm_one [nontrivial E] : ∥(1 : E)∥ = 1 :=
begin
  have : 0 < ∥(1 : E)∥ := norm_pos_iff.mpr one_ne_zero,
  rw [←mul_left_inj' this.ne', ←norm_star_mul_self, mul_one, star_one, one_mul],
end

@[priority 100] -- see Note [lower instance priority]
instance [nontrivial E] : norm_one_class E := ⟨norm_one⟩

lemma norm_coe_unitary [nontrivial E] (U : unitary E) : ∥(U : E)∥ = 1 :=
begin
  rw [←sq_eq_sq (norm_nonneg _) zero_le_one, one_pow 2, sq, ←cstar_ring.norm_star_mul_self,
    unitary.coe_star_mul_self, cstar_ring.norm_one],
end

@[simp] lemma norm_of_mem_unitary [nontrivial E] {U : E} (hU : U ∈ unitary E) : ∥U∥ = 1 :=
norm_coe_unitary ⟨U, hU⟩

@[simp] lemma norm_coe_unitary_mul (U : unitary E) (A : E) : ∥(U : E) * A∥ = ∥A∥ :=
begin
  nontriviality E,
  refine le_antisymm _ _,
  { calc _  ≤ ∥(U : E)∥ * ∥A∥     : norm_mul_le _ _
        ... = ∥A∥                 : by rw [norm_coe_unitary, one_mul] },
  { calc _ = ∥(U : E)⋆ * U * A∥         : by rw [unitary.coe_star_mul_self U, one_mul]
       ... ≤ ∥(U : E)⋆∥ * ∥(U : E) * A∥ : by { rw [mul_assoc], exact norm_mul_le _ _ }
       ... = ∥(U : E) * A∥              : by rw [norm_star, norm_coe_unitary, one_mul] },
end

@[simp] lemma norm_unitary_smul (U : unitary E) (A : E) : ∥U • A∥ = ∥A∥ :=
norm_coe_unitary_mul U A

lemma norm_mem_unitary_mul {U : E} (A : E) (hU : U ∈ unitary E) : ∥U * A∥ = ∥A∥ :=
norm_coe_unitary_mul ⟨U, hU⟩ A

@[simp] lemma norm_mul_coe_unitary (A : E) (U : unitary E) : ∥A * U∥ = ∥A∥ :=
calc _ = ∥((U : E)⋆ * A⋆)⋆∥ : by simp only [star_star, star_mul]
  ...  = ∥(U : E)⋆ * A⋆∥    : by rw [norm_star]
  ...  = ∥A⋆∥               : norm_mem_unitary_mul (star A) (unitary.star_mem U.prop)
  ...  = ∥A∥                : norm_star _

lemma norm_mul_mem_unitary (A : E) {U : E} (hU : U ∈ unitary E) : ∥A * U∥ = ∥A∥ :=
norm_mul_coe_unitary A ⟨U, hU⟩

end unital
end cstar_ring

lemma nnnorm_pow_two_pow_of_self_adjoint [normed_ring E] [star_ring E] [cstar_ring E]
  {x : E} (hx : x ∈ self_adjoint E) (n : ℕ) : ∥x ^ 2 ^ n∥₊ = ∥x∥₊ ^ (2 ^ n) :=
begin
  induction n with k hk,
  { simp only [pow_zero, pow_one] },
  { rw [pow_succ, pow_mul', sq],
    nth_rewrite 0 ←(self_adjoint.mem_iff.mp hx),
    rw [←star_pow, cstar_ring.nnnorm_star_mul_self, ←sq, hk, pow_mul'] },
end

lemma self_adjoint.nnnorm_pow_two_pow [normed_ring E] [star_ring E] [cstar_ring E]
  (x : self_adjoint E) (n : ℕ) : ∥x ^ 2 ^ n∥₊ = ∥x∥₊ ^ (2 ^ n) :=
nnnorm_pow_two_pow_of_self_adjoint x.property _

section starₗᵢ

variables [comm_semiring 𝕜] [star_ring 𝕜] [normed_ring E] [star_ring E] [normed_star_group E]
variables [module 𝕜 E] [star_module 𝕜 E]

variables (𝕜)
/-- `star` bundled as a linear isometric equivalence -/
def starₗᵢ : E ≃ₗᵢ⋆[𝕜] E :=
{ map_smul' := star_smul,
  norm_map' := norm_star,
  .. star_add_equiv }

variables {𝕜}

@[simp] lemma coe_starₗᵢ : (starₗᵢ 𝕜 : E → E) = star := rfl

lemma starₗᵢ_apply {x : E} : starₗᵢ 𝕜 x = star x := rfl

end starₗᵢ


-- λ x, max b (log x)

import data.complex.basic
import data.real.basic

import tactics

open complex (abs)
open_locale real
open set (univ Ici)
noncomputable theory

variables {E : Type} [normed_add_comm_group E] [complete_space E] [normed_space ℂ E]

-- max b (log x)
def max_log (b x : ℝ) : ℝ := (max b.exp x).log

lemma max_exp_pos {b x : ℝ} : max b.exp x > 0 := lt_of_lt_of_le (real.exp_pos _) (by bound)
@[simp] lemma le_max_log (b x : ℝ) : b ≤ max_log b x := begin rw [max_log, real.le_log_iff_exp_le max_exp_pos], bound end
lemma max_log_eq_b {b x : ℝ} (h : b.exp ≥ x) : max_log b x = b := by simp [max_log, max_eq_left h]
lemma max_log_eq_log {b x : ℝ} (h : b.exp ≤ x) : max_log b x = x.log := by simp [max_log, max_eq_right h]
lemma max_log_le {b x y : ℝ} (yb : b ≤ y) (xy : x ≤ y.exp) : max_log b x ≤ y := begin
  rw [max_log, real.log_le_iff_le_exp max_exp_pos], apply max_le, apply real.exp_le_exp.mpr yb, exact xy,
end
lemma le_exp_max_log (b x : ℝ) : x ≤ (max_log b x).exp := begin rw [max_log, real.exp_log max_exp_pos], bound end

-- Extracting underlying bounds from max_log bounds
lemma le_of_max_log_le {b x y : ℝ} (m : max_log b x ≤ y) : x ≤ y.exp := begin
  rw [max_log, real.log_le_iff_le_exp max_exp_pos] at m, exact le_of_max_le_right m,
end

-- max_log is increasing
lemma monotone_max_log (b : ℝ) : monotone (λ x, max_log b x) := begin
  simp_rw max_log, intros x y xy, simp, rw real.log_le_log max_exp_pos max_exp_pos, apply max_le_max (le_refl _) xy,
end

lemma continuous_max_log (b : ℝ) : continuous (λ x, max_log b x) := begin
  simp_rw max_log, rw continuous_iff_continuous_at, intro x,
  apply continuous_at.comp, refine continuous_at.log _ (ne_of_gt max_exp_pos),
  apply continuous_at_id, apply continuous.continuous_at, continuity,
end

-- max b (log ∥f z∥) is continuous for continuous f
theorem continuous_on.max_log_norm {f : ℂ → E} {s : set ℂ}
    (fc : continuous_on f s) (b : ℝ) : continuous_on (λ z, max_log b ∥f z∥) s :=
  (continuous_max_log b).comp_continuous_on fc.norm

-- log is Lipschitz away from 0
lemma lipschitz_on_with.log (b : ℝ) : lipschitz_on_with (-b).exp.to_nnreal real.log (Ici b.exp) := begin
  rw lipschitz_on_with_iff_dist_le_mul,
  have half : ∀ x y : ℝ, y ≥ b.exp → x ≥ y → |x.log - y.log| ≤ (-b).exp * |x - y|, {
    intros x y yb xy,
    have yp : y > 0 := lt_of_lt_of_le (real.exp_pos _) yb,
    have xp : x > 0 := lt_of_lt_of_le yp xy,
    have yi : (-b).exp ≥ y⁻¹, { rw real.exp_neg, bound [real.exp_pos] },
    rw abs_of_nonneg (sub_nonneg.mpr xy),
    rw abs_of_nonneg (sub_nonneg.mpr ((real.log_le_log yp xp).mpr xy)),
    rw ←real.log_div (ne_of_gt xp) (ne_of_gt yp),
    rw real.log_le_iff_le_exp (div_pos xp yp),
    transitivity (y⁻¹ * (x - y)).exp, swap, bound [real.exp_le_exp.mpr],
    have e : y⁻¹ * (x - y) = x/y - 1 := by field_simp [ne_of_gt yp],
    rw e,
    have e1 := real.add_one_le_exp (x/y - 1),
    simp at e1, exact e1,
  },
  intros x xs y ys,
  simp at xs ys ⊢,
  rw max_eq_left (le_of_lt (real.exp_pos _)),
  simp_rw real.dist_eq,
  by_cases xy : x ≥ y, { exact half x y ys xy },
  simp at xy,
  rw [←neg_sub y x, abs_neg],
  rw [←neg_sub y.log x.log, abs_neg],
  exact half y x xs (le_of_lt xy),
end

-- max_log is Lipschitz
theorem lipschitz_with.max_log (b : ℝ) : lipschitz_with (-b).exp.to_nnreal (max_log b) := begin
  rw ←lipschitz_on_univ,
  have h := (lipschitz_on_with.log b).comp ((lipschitz_with.id.const_max (b.exp)).lipschitz_on_with univ) (by simp),
  have e : real.log ∘ max (real.exp b) = max_log b, { funext x, simp [max_log] },
  simp at h, simpa [e],
end


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import field_theory.minpoly

/-!
# Power basis

This file defines a structure `power_basis R S`, giving a basis of the
`R`-algebra `S` as a finite list of powers `1, x, ..., x^n`.
For example, if `x` is algebraic over a ring/field, adjoining `x`
gives a `power_basis` structure generated by `x`.

## Definitions

* `power_basis R A`: a structure containing an `x` and an `n` such that
`1, x, ..., x^n` is a basis for the `R`-algebra `A` (viewed as an `R`-module).

* `finrank (hf : f ≠ 0) : finite_dimensional.finrank K (adjoin_root f) = f.nat_degree`,
  the dimension of `adjoin_root f` equals the degree of `f`

* `power_basis.lift (pb : power_basis R S)`: if `y : S'` satisfies the same
  equations as `pb.gen`, this is the map `S →ₐ[R] S'` sending `pb.gen` to `y`

* `power_basis.equiv`: if two power bases satisfy the same equations, they are
  equivalent as algebras

## Implementation notes

Throughout this file, `R`, `S`, ... are `comm_ring`s, `A`, `B`, ... are
`comm_ring` with `is_domain`s and `K`, `L`, ... are `field`s.
`S` is an `R`-algebra, `B` is an `A`-algebra, `L` is a `K`-algebra.

## Tags

power basis, powerbasis

-/

open polynomial

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables [algebra R S] [algebra S T] [algebra R T] [is_scalar_tower R S T]
variables {A B : Type*} [comm_ring A]
  [comm_ring B] [is_domain B] [algebra A B]
variables {K L : Type*} [field K] [field L] [algebra K L]

/-- `pb : power_basis R S` states that `1, pb.gen, ..., pb.gen ^ (pb.dim - 1)`
is a basis for the `R`-algebra `S` (viewed as `R`-module).

This is a structure, not a class, since the same algebra can have many power bases.
For the common case where `S` is defined by adjoining an integral element to `R`,
the canonical power basis is given by `{algebra,intermediate_field}.adjoin.power_basis`.
-/
@[nolint has_inhabited_instance]
structure power_basis (R S : Type*) [comm_ring R] [ring S] [algebra R S] :=
(gen : S)
(dim : ℕ)
(basis : basis (fin dim) R S)
(basis_eq_pow : ∀ i, basis i = gen ^ (i : ℕ))

namespace power_basis

@[simp] lemma coe_basis (pb : power_basis R S) :
  ⇑pb.basis = λ (i : fin pb.dim), pb.gen ^ (i : ℕ) :=
funext pb.basis_eq_pow

/-- Cannot be an instance because `power_basis` cannot be a class. -/
lemma finite_dimensional [algebra K S] (pb : power_basis K S) : finite_dimensional K S :=
finite_dimensional.of_fintype_basis pb.basis

lemma finrank [algebra K S] (pb : power_basis K S) : finite_dimensional.finrank K S = pb.dim :=
by rw [finite_dimensional.finrank_eq_card_basis pb.basis, fintype.card_fin]

lemma mem_span_pow' {x y : S} {d : ℕ} :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : polynomial R, f.degree < d ∧ y = aeval x f :=
begin
  have : set.range (λ (i : fin d), x ^ (i : ℕ)) = (λ (i : ℕ), x ^ i) '' ↑(finset.range d),
  { ext n,
    simp_rw [set.mem_range, set.mem_image, finset.mem_coe, finset.mem_range],
    exact ⟨λ ⟨⟨i, hi⟩, hy⟩, ⟨i, hi, hy⟩, λ ⟨i, hi, hy⟩, ⟨⟨i, hi⟩, hy⟩⟩ },
  simp only [this, finsupp.mem_span_image_iff_total, degree_lt_iff_coeff_zero,
    exists_iff_exists_finsupp, coeff, aeval, eval₂_ring_hom', eval₂_eq_sum, polynomial.sum, support,
    finsupp.mem_supported', finsupp.total, finsupp.sum, algebra.smul_def, eval₂_zero, exists_prop,
    linear_map.id_coe, eval₂_one, id.def, not_lt, finsupp.coe_lsum, linear_map.coe_smul_right,
    finset.mem_range, alg_hom.coe_mk, finset.mem_coe],
  simp_rw [@eq_comm _ y],
  exact iff.rfl
end

lemma mem_span_pow {x y : S} {d : ℕ} (hd : d ≠ 0) :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : polynomial R, f.nat_degree < d ∧ y = aeval x f :=
begin
  rw mem_span_pow',
  split;
  { rintros ⟨f, h, hy⟩,
    refine ⟨f, _, hy⟩,
    by_cases hf : f = 0,
    { simp only [hf, nat_degree_zero, degree_zero] at h ⊢,
      exact lt_of_le_of_ne (nat.zero_le d) hd.symm <|> exact with_bot.bot_lt_coe d },
    simpa only [degree_eq_nat_degree hf, with_bot.coe_lt_coe] using h },
end

lemma dim_ne_zero [h : nontrivial S] (pb : power_basis R S) : pb.dim ≠ 0 :=
λ h, not_nonempty_iff.mpr (h.symm ▸ fin.is_empty : is_empty (fin pb.dim)) pb.basis.index_nonempty

lemma dim_pos [nontrivial S] (pb : power_basis R S) : 0 < pb.dim :=
nat.pos_of_ne_zero pb.dim_ne_zero

lemma exists_eq_aeval [nontrivial S] (pb : power_basis R S) (y : S) :
  ∃ f : polynomial R, f.nat_degree < pb.dim ∧ y = aeval pb.gen f :=
(mem_span_pow pb.dim_ne_zero).mp (by simpa using pb.basis.mem_span y)

lemma exists_eq_aeval' (pb : power_basis R S) (y : S) :
  ∃ f : polynomial R, y = aeval pb.gen f :=
begin
  nontriviality S,
  obtain ⟨f, _, hf⟩ := exists_eq_aeval pb y,
  exact ⟨f, hf⟩
end

lemma alg_hom_ext {S' : Type*} [semiring S'] [algebra R S']
  (pb : power_basis R S) ⦃f g : S →ₐ[R] S'⦄ (h : f pb.gen = g pb.gen) :
  f = g :=
begin
  ext x,
  obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x,
  rw [← polynomial.aeval_alg_hom_apply, ← polynomial.aeval_alg_hom_apply, h]
end

section minpoly

open_locale big_operators

variable [algebra A S]

/-- `pb.minpoly_gen` is a minimal polynomial for `pb.gen`.

If `A` is not a field, it might not necessarily be *the* minimal polynomial,
however `nat_degree_minpoly` shows its degree is indeed minimal.
-/
noncomputable def minpoly_gen (pb : power_basis A S) : polynomial A :=
X ^ pb.dim -
  ∑ (i : fin pb.dim), C (pb.basis.repr (pb.gen ^ pb.dim) i) * X ^ (i : ℕ)

@[simp]
lemma aeval_minpoly_gen (pb : power_basis A S) : aeval pb.gen (minpoly_gen pb) = 0 :=
begin
  simp_rw [minpoly_gen, alg_hom.map_sub, alg_hom.map_sum, alg_hom.map_mul, alg_hom.map_pow,
           aeval_C, ← algebra.smul_def, aeval_X],
  refine sub_eq_zero.mpr ((pb.basis.total_repr (pb.gen ^ pb.dim)).symm.trans _),
  rw [finsupp.total_apply, finsupp.sum_fintype];
    simp only [pb.coe_basis, zero_smul, eq_self_iff_true, implies_true_iff]
end

lemma dim_le_nat_degree_of_root (h : power_basis A S) {p : polynomial A}
  (ne_zero : p ≠ 0) (root : aeval h.gen p = 0) :
  h.dim ≤ p.nat_degree :=
begin
  refine le_of_not_lt (λ hlt, ne_zero _),
  let p_coeff : fin (h.dim) → A := λ i, p.coeff i,
  suffices : ∀ i, p_coeff i = 0,
  { ext i,
    by_cases hi : i < h.dim,
    { exact this ⟨i, hi⟩ },
    exact coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)) },
  intro i,
  refine linear_independent_iff'.mp h.basis.linear_independent _ _ _ i (finset.mem_univ _),
  rw aeval_eq_sum_range' hlt at root,
  rw finset.sum_fin_eq_sum_range,
  convert root,
  ext i,
  split_ifs with hi,
  { simp_rw [coe_basis, p_coeff, fin.coe_mk] },
  { rw [coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)),
        zero_smul] }
end

variables [is_domain A]

@[simp]
lemma degree_minpoly_gen (pb : power_basis A S) :
  degree (minpoly_gen pb) = pb.dim :=
begin
  unfold minpoly_gen,
  rw degree_sub_eq_left_of_degree_lt; rw degree_X_pow,
  apply degree_sum_fin_lt
end

@[simp]
lemma nat_degree_minpoly_gen (pb : power_basis A S) :
  nat_degree (minpoly_gen pb) = pb.dim :=
nat_degree_eq_of_degree_eq_some pb.degree_minpoly_gen

lemma minpoly_gen_monic (pb : power_basis A S) : monic (minpoly_gen pb) :=
begin
  apply monic_sub_of_left (monic_pow (monic_X) _),
  rw degree_X_pow,
  exact degree_sum_fin_lt _
end

lemma is_integral_gen (pb : power_basis A S) : is_integral A pb.gen :=
⟨minpoly_gen pb, minpoly_gen_monic pb, aeval_minpoly_gen pb⟩

@[simp]
lemma nat_degree_minpoly (pb : power_basis A S) :
  (minpoly A pb.gen).nat_degree = pb.dim :=
begin
  refine le_antisymm _
    (dim_le_nat_degree_of_root pb (minpoly.ne_zero pb.is_integral_gen) (minpoly.aeval _ _)),
  rw ← nat_degree_minpoly_gen,
  apply nat_degree_le_of_degree_le,
  rw ← degree_eq_nat_degree (minpoly_gen_monic pb).ne_zero,
  exact minpoly.min _ _ (minpoly_gen_monic pb) (aeval_minpoly_gen pb)
end

@[simp]
lemma minpoly_gen_eq [algebra K S] (pb : power_basis K S) :
  pb.minpoly_gen = minpoly K pb.gen :=
minpoly.unique K pb.gen pb.minpoly_gen_monic pb.aeval_minpoly_gen (λ p p_monic p_root,
  pb.degree_minpoly_gen.symm ▸ pb.dim_le_degree_of_root p_monic.ne_zero p_root)

end minpoly

section equiv

variables [algebra A S] {S' : Type*} [comm_ring S'] [algebra A S']

lemma nat_degree_lt_nat_degree {p q : polynomial R} (hp : p ≠ 0) (hpq : p.degree < q.degree) :
  p.nat_degree < q.nat_degree :=
begin
  by_cases hq : q = 0, { rw [hq, degree_zero] at hpq, have := not_lt_bot hpq, contradiction },
  rwa [degree_eq_nat_degree hp, degree_eq_nat_degree hq, with_bot.coe_lt_coe] at hpq
end

variables [is_domain A]

lemma constr_pow_aeval (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (f : polynomial A) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) (aeval pb.gen f) = aeval y f :=
begin
  rw [← aeval_mod_by_monic_eq_self_of_root (minpoly.monic pb.is_integral_gen) (minpoly.aeval _ _),
      ← @aeval_mod_by_monic_eq_self_of_root _ _ _ _ _ f _ (minpoly.monic pb.is_integral_gen) y hy],
  by_cases hf : f %ₘ minpoly A pb.gen = 0,
  { simp only [hf, alg_hom.map_zero, linear_map.map_zero] },
  have : (f %ₘ minpoly A pb.gen).nat_degree < pb.dim,
  { rw ← pb.nat_degree_minpoly,
    apply nat_degree_lt_nat_degree hf,
    exact degree_mod_by_monic_lt _ (minpoly.monic pb.is_integral_gen) },
  rw [aeval_eq_sum_range' this, aeval_eq_sum_range' this, linear_map.map_sum],
  refine finset.sum_congr rfl (λ i (hi : i ∈ finset.range pb.dim), _),
  rw finset.mem_range at hi,
  rw linear_map.map_smul,
  congr,
  rw [← fin.coe_mk hi, ← pb.basis_eq_pow ⟨i, hi⟩, basis.constr_basis]
end

lemma constr_pow_gen (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) pb.gen = y :=
by { convert pb.constr_pow_aeval hy X; rw aeval_X }

lemma constr_pow_algebra_map (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (x : A) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) (algebra_map A S x) = algebra_map A S' x :=
by { convert pb.constr_pow_aeval hy (C x); rw aeval_C }

lemma constr_pow_mul (pb : power_basis A S) {y : S'}
  (hy : aeval y (minpoly A pb.gen) = 0) (x x' : S) :
  pb.basis.constr A (λ i, y ^ (i : ℕ)) (x * x') =
    pb.basis.constr A (λ i, y ^ (i : ℕ)) x * pb.basis.constr A (λ i, y ^ (i : ℕ)) x' :=
begin
  obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x,
  obtain ⟨g, rfl⟩ := pb.exists_eq_aeval' x',
  simp only [← aeval_mul, pb.constr_pow_aeval hy]
end

/-- `pb.lift y hy` is the algebra map sending `pb.gen` to `y`,
where `hy` states the higher powers of `y` are the same as the higher powers of `pb.gen`.

See `power_basis.lift_equiv` for a bundled equiv sending `⟨y, hy⟩` to the algebra map.
-/
noncomputable def lift (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) :
  S →ₐ[A] S' :=
{ map_one' := by { convert pb.constr_pow_algebra_map hy 1 using 2; rw ring_hom.map_one },
  map_zero' := by { convert pb.constr_pow_algebra_map hy 0 using 2; rw ring_hom.map_zero },
  map_mul' := pb.constr_pow_mul hy,
  commutes' := pb.constr_pow_algebra_map hy,
  .. pb.basis.constr A (λ i, y ^ (i : ℕ)) }

@[simp] lemma lift_gen (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) :
  pb.lift y hy pb.gen = y :=
pb.constr_pow_gen hy

@[simp] lemma lift_aeval (pb : power_basis A S) (y : S')
  (hy : aeval y (minpoly A pb.gen) = 0) (f : polynomial A) :
  pb.lift y hy (aeval pb.gen f) = aeval y f :=
pb.constr_pow_aeval hy f

/-- `pb.lift_equiv` states that roots of the minimal polynomial of `pb.gen` correspond to
maps sending `pb.gen` to that root.

This is the bundled equiv version of `power_basis.lift`.
If the codomain of the `alg_hom`s is an integral domain, then the roots form a multiset,
see `lift_equiv'` for the corresponding statement.
-/
@[simps]
noncomputable def lift_equiv (pb : power_basis A S) :
  (S →ₐ[A] S') ≃ {y : S' // aeval y (minpoly A pb.gen) = 0} :=
{ to_fun := λ f, ⟨f pb.gen, by rw [aeval_alg_hom_apply, minpoly.aeval, f.map_zero]⟩,
  inv_fun := λ y, pb.lift y y.2,
  left_inv := λ f, pb.alg_hom_ext $ lift_gen _ _ _,
  right_inv := λ y, subtype.ext $ lift_gen _ _ y.prop }

/-- `pb.lift_equiv'` states that elements of the root set of the minimal
polynomial of `pb.gen` correspond to maps sending `pb.gen` to that root. -/
@[simps {fully_applied := ff}]
noncomputable def lift_equiv' (pb : power_basis A S) :
  (S →ₐ[A] B) ≃ {y : B // y ∈ ((minpoly A pb.gen).map (algebra_map A B)).roots} :=
pb.lift_equiv.trans ((equiv.refl _).subtype_equiv (λ x,
  begin
    rw [mem_roots, is_root.def, equiv.refl_apply, ← eval₂_eq_eval_map, ← aeval_def],
    exact map_monic_ne_zero (minpoly.monic pb.is_integral_gen)
  end))

/-- There are finitely many algebra homomorphisms `S →ₐ[A] B` if `S` is of the form `A[x]`
and `B` is an integral domain. -/
noncomputable def alg_hom.fintype (pb : power_basis A S) :
  fintype (S →ₐ[A] B) :=
by letI := classical.dec_eq B; exact
fintype.of_equiv _ pb.lift_equiv'.symm

local attribute [irreducible] power_basis.lift

/-- `pb.equiv_of_root pb' h₁ h₂` is an equivalence of algebras with the same power basis,
where "the same" means that `pb` is a root of `pb'`s minimal polynomial and vice versa.

See also `power_basis.equiv_of_minpoly` which takes the hypothesis that the
minimal polynomials are identical.
-/
noncomputable def equiv_of_root
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
  S ≃ₐ[A] S' :=
alg_equiv.of_alg_hom
  (pb.lift pb'.gen h₂)
  (pb'.lift pb.gen h₁)
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb'.exists_eq_aeval' x, simp })
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval' x, simp })

@[simp]
lemma equiv_of_root_aeval
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0)
  (f : polynomial A) :
  pb.equiv_of_root pb' h₁ h₂ (aeval pb.gen f) = aeval pb'.gen f :=
pb.lift_aeval _ h₂ _

@[simp]
lemma equiv_of_root_gen
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
  pb.equiv_of_root pb' h₁ h₂ pb.gen = pb'.gen :=
pb.lift_gen _ h₂

@[simp]
lemma equiv_of_root_symm
  (pb : power_basis A S) (pb' : power_basis A S')
  (h₁ : aeval pb.gen (minpoly A pb'.gen) = 0) (h₂ : aeval pb'.gen (minpoly A pb.gen) = 0) :
  (pb.equiv_of_root pb' h₁ h₂).symm = pb'.equiv_of_root pb h₂ h₁ :=
rfl

/-- `pb.equiv_of_minpoly pb' h` is an equivalence of algebras with the same power basis,
where "the same" means that they have identical minimal polynomials.

See also `power_basis.equiv_of_root` which takes the hypothesis that each generator is a root of the
other basis' minimal polynomial; `power_basis.equiv_root` is more general if `A` is not a field.
-/
noncomputable def equiv_of_minpoly
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  S ≃ₐ[A] S' :=
pb.equiv_of_root pb' (h ▸ minpoly.aeval _ _) (h.symm ▸ minpoly.aeval _ _)

@[simp]
lemma equiv_of_minpoly_aeval
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen)
  (f : polynomial A) :
  pb.equiv_of_minpoly pb' h (aeval pb.gen f) = aeval pb'.gen f :=
pb.equiv_of_root_aeval pb' _ _ _

@[simp]
lemma equiv_of_minpoly_gen
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  pb.equiv_of_minpoly pb' h pb.gen = pb'.gen :=
pb.equiv_of_root_gen pb' _ _

@[simp]
lemma equiv_of_minpoly_symm
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : minpoly A pb.gen = minpoly A pb'.gen) :
  (pb.equiv_of_minpoly pb' h).symm = pb'.equiv_of_minpoly pb h.symm :=
rfl

end equiv

end power_basis

open power_basis

/-- Useful lemma to show `x` generates a power basis:
the powers of `x` less than the degree of `x`'s minimal polynomial are linearly independent. -/
lemma is_integral.linear_independent_pow [algebra K S] {x : S} (hx : is_integral K x) :
  linear_independent K (λ (i : fin (minpoly K x).nat_degree), x ^ (i : ℕ)) :=
begin
  rw linear_independent_iff,
  intros p hp,
  set f : polynomial K := p.sum (λ i, monomial i) with hf0,
  have f_def : ∀ (i : fin _), f.coeff i = p i,
  { intro i,
    simp only [f, finsupp.sum, coeff_monomial, finset_sum_coeff],
    rw [finset.sum_eq_single, if_pos rfl],
    { intros b _ hb,
      rw if_neg (mt (λ h, _) hb),
      exact fin.coe_injective h },
    { intro hi,
      rw if_pos rfl,
      exact finsupp.not_mem_support_iff.mp hi } },
  have f_def' : ∀ i, f.coeff i = if hi : i < _ then p ⟨i, hi⟩ else 0,
  { intro i,
    split_ifs with hi,
    { exact f_def ⟨i, hi⟩ },
    simp only [f, finsupp.sum, coeff_monomial, finset_sum_coeff],
    apply finset.sum_eq_zero,
    rintro ⟨j, hj⟩ -,
    apply if_neg (mt _ hi),
    rintro rfl,
    exact hj },
  suffices : f = 0,
  { ext i, rw [← f_def, this, coeff_zero, finsupp.zero_apply] },
  contrapose hp with hf,
  intro h,
  have : (minpoly K x).degree ≤ f.degree,
  { apply minpoly.degree_le_of_ne_zero K x hf,
    convert h,
    simp_rw [finsupp.total_apply, aeval_def, hf0, finsupp.sum, eval₂_finset_sum],
    apply finset.sum_congr rfl,
    rintro i -,
    simp only [algebra.smul_def, eval₂_monomial] },
  have : ¬ (minpoly K x).degree ≤ f.degree,
  { apply not_le_of_lt,
    rw [degree_eq_nat_degree (minpoly.ne_zero hx), degree_lt_iff_coeff_zero],
    intros i hi,
    rw [f_def' i, dif_neg],
    exact hi.not_lt },
  contradiction
end

lemma is_integral.mem_span_pow [nontrivial R] {x y : S} (hx : is_integral R x)
  (hy : ∃ f : polynomial R, y = aeval x f) :
  y ∈ submodule.span R (set.range (λ (i : fin (minpoly R x).nat_degree),
    x ^ (i : ℕ))) :=
begin
  obtain ⟨f, rfl⟩ := hy,
  apply mem_span_pow'.mpr _,
  have := minpoly.monic hx,
  refine ⟨f.mod_by_monic (minpoly R x),
      lt_of_lt_of_le (degree_mod_by_monic_lt _ this) degree_le_nat_degree,
      _⟩,
  conv_lhs { rw ← mod_by_monic_add_div f this },
  simp only [add_zero, zero_mul, minpoly.aeval, aeval_add, alg_hom.map_mul]
end

namespace power_basis

section map

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

/-- `power_basis.map pb (e : S ≃ₐ[R] S')` is the power basis for `S'` generated by `e pb.gen`. -/
@[simps]
noncomputable def map (pb : power_basis R S) (e : S ≃ₐ[R] S') : power_basis R S' :=
{ dim := pb.dim,
  basis := pb.basis.map e.to_linear_equiv,
  gen := e pb.gen,
  basis_eq_pow :=
    λ i, by rw [basis.map_apply, pb.basis_eq_pow, e.to_linear_equiv_apply, e.map_pow] }

variables [algebra A S] [algebra A S']

@[simp]
lemma minpoly_gen_map (pb : power_basis A S) (e : S ≃ₐ[A] S') :
  (pb.map e).minpoly_gen = pb.minpoly_gen :=
by { dsimp only [minpoly_gen, map_dim], -- Turn `fin (pb.map e).dim` into `fin pb.dim`
     simp only [linear_equiv.trans_apply, map_basis, basis.map_repr,
        map_gen, alg_equiv.to_linear_equiv_apply, e.to_linear_equiv_symm, alg_equiv.map_pow,
        alg_equiv.symm_apply_apply, sub_right_inj] }

variables [is_domain A]

@[simp]
lemma equiv_of_root_map (pb : power_basis A S) (e : S ≃ₐ[A] S')
  (h₁ h₂) :
  pb.equiv_of_root (pb.map e) h₁ h₂ = e :=
by { ext x, obtain ⟨f, rfl⟩ := pb.exists_eq_aeval' x, simp [aeval_alg_equiv] }

@[simp]
lemma equiv_of_minpoly_map (pb : power_basis A S) (e : S ≃ₐ[A] S')
  (h : minpoly A pb.gen = minpoly A (pb.map e).gen) :
  pb.equiv_of_minpoly (pb.map e) h = e :=
pb.equiv_of_root_map _ _ _

end map

end power_basis


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

! This file was ported from Lean 3 source module number_theory.frobenius_number
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Nat.Modeq
import Mathbin.GroupTheory.Submonoid.Basic
import Mathbin.GroupTheory.Submonoid.Membership
import Mathbin.Tactic.Ring
import Mathbin.Tactic.Zify

/-!
# Frobenius Number in Two Variables

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

In this file we first define a predicate for Frobenius numbers, then solve the 2-variable variant
of this problem.

## Theorem Statement

Given a finite set of relatively prime integers all greater than 1, their Frobenius number is the
largest positive integer that cannot be expressed as a sum of nonnegative multiples of these
integers. Here we show the Frobenius number of two relatively prime integers `m` and `n` greater
than 1 is `m * n - m - n`. This result is also known as the Chicken McNugget Theorem.

## Implementation Notes

First we define Frobenius numbers in general using `is_greatest` and `add_submonoid.closure`. Then
we proceed to compute the Frobenius number of `m` and `n`.

For the upper bound, we begin with an auxiliary lemma showing `m * n` is not attainable, then show
`m * n - m - n` is not attainable. Then for the construction, we create a `k_1` which is `k mod n`
and `0 mod m`, then show it is at most `k`. Then `k_1` is a multiple of `m`, so `(k-k_1)`
is a multiple of n, and we're done.

## Tags

frobenius number, chicken mcnugget, chinese remainder theorem, add_submonoid.closure
-/

open Nat

#print FrobeniusNumber /-
/-- A natural number `n` is the **Frobenius number** of a set of natural numbers `s` if it is an
upper bound on the complement of the additive submonoid generated by `s`.
In other words, it is the largest number that can not be expressed as a sum of numbers in `s`. -/
def FrobeniusNumber (n : ℕ) (s : Set ℕ) : Prop :=
  IsGreatest { k | k ∉ AddSubmonoid.closure s } n
#align is_frobenius_number FrobeniusNumber
-/

variable {m n : ℕ}

#print frobeniusNumber_pair /-
/-- The **Chicken Mcnugget theorem** stating that the Frobenius number
  of positive numbers `m` and `n` is `m * n - m - n`. -/
theorem frobeniusNumber_pair (cop : coprime m n) (hm : 1 < m) (hn : 1 < n) :
    FrobeniusNumber (m * n - m - n) {m, n} :=
  by
  simp_rw [FrobeniusNumber, AddSubmonoid.mem_closure_pair]
  have hmn : m + n ≤ m * n := add_le_mul hm hn
  constructor
  · push_neg
    intro a b h
    apply cop.mul_add_mul_ne_mul (add_one_ne_zero a) (add_one_ne_zero b)
    simp only [Nat.sub_sub, smul_eq_mul] at h
    zify  at h⊢
    rw [← sub_eq_zero] at h⊢
    rw [← h]
    ring
  · intro k hk
    dsimp at hk
    contrapose! hk
    let x := chinese_remainder cop 0 k
    have hx : x.val < m * n := chinese_remainder_lt_mul cop 0 k (ne_bot_of_gt hm) (ne_bot_of_gt hn)
    suffices key : x.1 ≤ k
    · obtain ⟨a, ha⟩ := modeq_zero_iff_dvd.mp x.2.1
      obtain ⟨b, hb⟩ := (modeq_iff_dvd' key).mp x.2.2
      exact ⟨a, b, by rw [mul_comm, ← ha, mul_comm, ← hb, Nat.add_sub_of_le key]⟩
    refine' modeq.le_of_lt_add x.2.2 (lt_of_le_of_lt _ (add_lt_add_right hk n))
    rw [Nat.sub_add_cancel (le_tsub_of_add_le_left hmn)]
    exact
      modeq.le_of_lt_add
        (x.2.1.trans (modeq_zero_iff_dvd.mpr (Nat.dvd_sub' (dvd_mul_right m n) dvd_rfl)).symm)
        (lt_of_lt_of_le hx le_tsub_add)
#align is_frobenius_number_pair frobeniusNumber_pair
-/


/-
Copyright (c) 2022 Christopher Hoskin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Christopher Hoskin
-/
import order.basic
import algebra.group_power.basic
import algebra.ring.defs
import tactic.nth_rewrite

/-!
# Idempotents

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

This file defines idempotents for an arbitary multiplication and proves some basic results,
including:

* `is_idempotent_elem.mul_of_commute`: In a semigroup, the product of two commuting idempotents is
  an idempotent;
* `is_idempotent_elem.one_sub_iff`: In a (non-associative) ring, `p` is an idempotent if and only if
  `1-p` is an idempotent.
* `is_idempotent_elem.pow_succ_eq`: In a monoid `p ^ (n+1) = p` for `p` an idempotent and `n` a
  natural number.

## Tags

projection, idempotent
-/

variables {M N S M₀ M₁ R G G₀ : Type*}
variables [has_mul M] [monoid N] [semigroup S] [mul_zero_class M₀] [mul_one_class M₁]
  [non_assoc_ring R] [group G] [cancel_monoid_with_zero G₀]

/--
An element `p` is said to be idempotent if `p * p = p`
-/
def is_idempotent_elem (p : M) : Prop := p * p = p

namespace is_idempotent_elem

lemma of_is_idempotent [is_idempotent M (*)] (a : M) : is_idempotent_elem a :=
is_idempotent.idempotent a

lemma eq {p : M} (h : is_idempotent_elem p) : p * p = p := h

lemma mul_of_commute {p q : S} (h : commute p q) (h₁ : is_idempotent_elem p)
  (h₂ : is_idempotent_elem q) : is_idempotent_elem (p * q)  :=
by rw [is_idempotent_elem, mul_assoc, ← mul_assoc q, ← h.eq, mul_assoc p, h₂.eq, ← mul_assoc, h₁.eq]

lemma zero : is_idempotent_elem (0 : M₀) := mul_zero _

lemma one : is_idempotent_elem (1 : M₁) := mul_one _

lemma one_sub {p : R} (h : is_idempotent_elem p) : is_idempotent_elem (1 - p) :=
by rw [is_idempotent_elem, mul_sub, mul_one, sub_mul, one_mul, h.eq, sub_self, sub_zero]

@[simp] lemma one_sub_iff {p : R} : is_idempotent_elem (1 - p) ↔ is_idempotent_elem p :=
⟨ λ h, sub_sub_cancel 1 p ▸ h.one_sub, is_idempotent_elem.one_sub ⟩

lemma pow {p : N} (n : ℕ) (h : is_idempotent_elem p) : is_idempotent_elem (p ^ n) :=
nat.rec_on n ((pow_zero p).symm ▸ one) (λ n ih, show p ^ n.succ * p ^ n.succ = p ^ n.succ,
  by { nth_rewrite 2 ←h.eq, rw [←sq, ←sq, ←pow_mul, ←pow_mul'] })

lemma pow_succ_eq {p : N} (n : ℕ) (h : is_idempotent_elem p) : p ^ (n + 1) = p :=
nat.rec_on n ((nat.zero_add 1).symm ▸ pow_one p) (λ n ih, by rw [pow_succ, ih, h.eq])

@[simp] lemma iff_eq_one {p : G} : is_idempotent_elem p ↔ p = 1 :=
iff.intro (λ h, mul_left_cancel ((mul_one p).symm ▸ h.eq : p * p = p * 1)) (λ h, h.symm ▸ one)

@[simp] lemma iff_eq_zero_or_one {p : G₀}  : is_idempotent_elem p ↔ p = 0 ∨ p = 1 :=
begin
  refine iff.intro
    (λ h, or_iff_not_imp_left.mpr (λ hp, _))
    (λ h, h.elim (λ hp, hp.symm ▸ zero) (λ hp, hp.symm ▸ one)),
  exact mul_left_cancel₀ hp (h.trans (mul_one p).symm)
end

/-! ### Instances on `subtype is_idempotent_elem` -/
section instances

instance : has_zero { p : M₀ // is_idempotent_elem p } := { zero := ⟨ 0, zero ⟩ }

@[simp] lemma coe_zero : ↑(0 : {p : M₀ // is_idempotent_elem p}) = (0 : M₀) := rfl

instance : has_one { p : M₁ // is_idempotent_elem p } := { one := ⟨ 1, one ⟩ }

@[simp] lemma coe_one : ↑(1 : { p : M₁ // is_idempotent_elem p }) = (1 : M₁) := rfl

instance : has_compl { p : R // is_idempotent_elem p } := ⟨λ p, ⟨1 - p, p.prop.one_sub⟩⟩

@[simp] lemma coe_compl (p : { p : R // is_idempotent_elem p }) : ↑(pᶜ) = (1 : R) - ↑p := rfl

@[simp] lemma compl_compl (p : {p : R // is_idempotent_elem p}) : pᶜᶜ = p :=
subtype.ext $ sub_sub_cancel _ _

@[simp] lemma zero_compl : (0 : {p : R // is_idempotent_elem p})ᶜ = 1 := subtype.ext $ sub_zero _

@[simp] lemma one_compl : (1 : {p : R // is_idempotent_elem p})ᶜ = 0 := subtype.ext $ sub_self _

end instances

end is_idempotent_elem


/-
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

Theory of complete lattices.
-/
import order.bounded_lattice data.set.basic tactic.pi_instances

set_option old_structure_cmd true

namespace lattice
universes u v w w₂
variables {α : Type u} {β : Type v} {ι : Sort w} {ι₂ : Sort w₂}

/-- class for the `Sup` operator -/
class has_Sup (α : Type u) := (Sup : set α → α)
/-- class for the `Inf` operator -/
class has_Inf (α : Type u) := (Inf : set α → α)
/-- Supremum of a set -/
def Sup [has_Sup α] : set α → α := has_Sup.Sup
/-- Infimum of a set -/
def Inf [has_Inf α] : set α → α := has_Inf.Inf

/-- A complete lattice is a bounded lattice which
  has suprema and infima for every subset. -/
class complete_lattice (α : Type u) extends bounded_lattice α, has_Sup α, has_Inf α :=
(le_Sup : ∀s, ∀a∈s, a ≤ Sup s)
(Sup_le : ∀s a, (∀b∈s, b ≤ a) → Sup s ≤ a)
(Inf_le : ∀s, ∀a∈s, Inf s ≤ a)
(le_Inf : ∀s a, (∀b∈s, a ≤ b) → a ≤ Inf s)

/-- A complete linear order is a linear order whose lattice structure is complete. -/
class complete_linear_order (α : Type u) extends complete_lattice α, linear_order α

/-- Indexed supremum -/
def supr [complete_lattice α] (s : ι → α) : α := Sup {a : α | ∃i : ι, a = s i}
/-- Indexed infimum -/
def infi [complete_lattice α] (s : ι → α) : α := Inf {a : α | ∃i : ι, a = s i}

notation `⨆` binders `, ` r:(scoped f, supr f) := r
notation `⨅` binders `, ` r:(scoped f, infi f) := r

section
open set
variables [complete_lattice α] {s t : set α} {a b : α}

@[ematch] theorem le_Sup : a ∈ s → a ≤ Sup s := complete_lattice.le_Sup s a

theorem Sup_le : (∀b∈s, b ≤ a) → Sup s ≤ a := complete_lattice.Sup_le s a

@[ematch] theorem Inf_le : a ∈ s → Inf s ≤ a := complete_lattice.Inf_le s a

theorem le_Inf : (∀b∈s, a ≤ b) → a ≤ Inf s := complete_lattice.le_Inf s a

theorem le_Sup_of_le (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
le_trans h (le_Sup hb)

theorem Inf_le_of_le (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
le_trans (Inf_le hb) h

theorem Sup_le_Sup (h : s ⊆ t) : Sup s ≤ Sup t :=
Sup_le (assume a, assume ha : a ∈ s, le_Sup $ h ha)

theorem Inf_le_Inf (h : s ⊆ t) : Inf t ≤ Inf s :=
le_Inf (assume a, assume ha : a ∈ s, Inf_le $ h ha)

@[simp] theorem Sup_le_iff : Sup s ≤ a ↔ (∀b ∈ s, b ≤ a) :=
⟨assume : Sup s ≤ a, assume b, assume : b ∈ s,
  le_trans (le_Sup ‹b ∈ s›) ‹Sup s ≤ a›,
  Sup_le⟩

@[simp] theorem le_Inf_iff : a ≤ Inf s ↔ (∀b ∈ s, a ≤ b) :=
⟨assume : a ≤ Inf s, assume b, assume : b ∈ s,
  le_trans ‹a ≤ Inf s› (Inf_le ‹b ∈ s›),
  le_Inf⟩

-- how to state this? instead a parameter `a`, use `∃a, a ∈ s` or `s ≠ ∅`?
theorem Inf_le_Sup (h : a ∈ s) : Inf s ≤ Sup s :=
by have := le_Sup h; finish
--Inf_le_of_le h (le_Sup h)

-- TODO: it is weird that we have to add union_def
theorem Sup_union {s t : set α} : Sup (s ∪ t) = Sup s ⊔ Sup t :=
le_antisymm
  (by finish)
  (sup_le (Sup_le_Sup $ subset_union_left _ _) (Sup_le_Sup $ subset_union_right _ _))

/- old proof:
le_antisymm
  (Sup_le $ assume a h, or.rec_on h (le_sup_left_of_le ∘ le_Sup) (le_sup_right_of_le ∘ le_Sup))
  (sup_le (Sup_le_Sup $ subset_union_left _ _) (Sup_le_Sup $ subset_union_right _ _))
-/

theorem Sup_inter_le {s t : set α} : Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
by finish
/-
  Sup_le (assume a ⟨a_s, a_t⟩, le_inf (le_Sup a_s) (le_Sup a_t))
-/

theorem Inf_union {s t : set α} : Inf (s ∪ t) = Inf s ⊓ Inf t :=
le_antisymm
  (le_inf (Inf_le_Inf $ subset_union_left _ _) (Inf_le_Inf $ subset_union_right _ _))
  (by finish)

/- old proof:
le_antisymm
  (le_inf (Inf_le_Inf $ subset_union_left _ _) (Inf_le_Inf $ subset_union_right _ _))
  (le_Inf $ assume a h, or.rec_on h (inf_le_left_of_le ∘ Inf_le) (inf_le_right_of_le ∘ Inf_le))
-/

theorem le_Inf_inter {s t : set α} : Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
by finish
/-
le_Inf (assume a ⟨a_s, a_t⟩, sup_le (Inf_le a_s) (Inf_le a_t))
-/

@[simp] theorem Sup_empty : Sup ∅ = (⊥ : α) :=
le_antisymm (by finish) (by finish)
-- le_antisymm (Sup_le (assume _, false.elim)) bot_le

@[simp] theorem Inf_empty : Inf ∅ = (⊤ : α) :=
le_antisymm (by finish) (by finish)
--le_antisymm le_top (le_Inf (assume _, false.elim))

@[simp] theorem Sup_univ : Sup univ = (⊤ : α) :=
le_antisymm (by finish) (le_Sup ⟨⟩) -- finish fails because ⊤ ≤ a simplifies to a = ⊤
--le_antisymm le_top (le_Sup ⟨⟩)

@[simp] theorem Inf_univ : Inf univ = (⊥ : α) :=
le_antisymm (Inf_le ⟨⟩) bot_le

-- TODO(Jeremy): get this automatically
@[simp] theorem Sup_insert {a : α} {s : set α} : Sup (insert a s) = a ⊔ Sup s :=
have Sup {b | b = a} = a,
  from le_antisymm (Sup_le $ assume b b_eq, b_eq ▸ le_refl _) (le_Sup rfl),
calc Sup (insert a s) = Sup {b | b = a} ⊔ Sup s : Sup_union
                  ... = a ⊔ Sup s : by rw [this]

@[simp] theorem Inf_insert {a : α} {s : set α} : Inf (insert a s) = a ⊓ Inf s :=
have Inf {b | b = a} = a,
  from le_antisymm (Inf_le rfl) (le_Inf $ assume b b_eq, b_eq ▸ le_refl _),
calc Inf (insert a s) = Inf {b | b = a} ⊓ Inf s : Inf_union
                  ... = a ⊓ Inf s : by rw [this]

@[simp] theorem Sup_singleton {a : α} : Sup {a} = a :=
by finish [singleton_def]
--eq.trans Sup_insert $ by simp

@[simp] theorem Inf_singleton {a : α} : Inf {a} = a :=
by finish [singleton_def]
--eq.trans Inf_insert $ by simp

@[simp] theorem Inf_eq_top : Inf s = ⊤ ↔ (∀a∈s, a = ⊤) :=
iff.intro
  (assume h a ha, top_unique $ h ▸ Inf_le ha)
  (assume h, top_unique $ le_Inf $ assume a ha, top_le_iff.2 $ h a ha)

@[simp] theorem Sup_eq_bot : Sup s = ⊥ ↔ (∀a∈s, a = ⊥) :=
iff.intro
  (assume h a ha, bot_unique $ h ▸ le_Sup ha)
  (assume h, bot_unique $ Sup_le $ assume a ha, le_bot_iff.2 $ h a ha)

end

section complete_linear_order
variables [complete_linear_order α] {s t : set α} {a b : α}

lemma Inf_lt_iff : Inf s < b ↔ (∃a∈s, a < b) :=
iff.intro
  (assume : Inf s < b, classical.by_contradiction $ assume : ¬ (∃a∈s, a < b),
    have b ≤ Inf s,
      from le_Inf $ assume a ha, le_of_not_gt $ assume h, this ⟨a, ha, h⟩,
    lt_irrefl b (lt_of_le_of_lt ‹b ≤ Inf s› ‹Inf s < b›))
  (assume ⟨a, ha, h⟩, lt_of_le_of_lt (Inf_le ha) h)

lemma lt_Sup_iff : b < Sup s ↔ (∃a∈s, b < a) :=
iff.intro
  (assume : b < Sup s, classical.by_contradiction $ assume : ¬ (∃a∈s, b < a),
    have Sup s ≤ b,
      from Sup_le $ assume a ha, le_of_not_gt $ assume h, this ⟨a, ha, h⟩,
    lt_irrefl b (lt_of_lt_of_le ‹b < Sup s› ‹Sup s ≤ b›))
  (assume ⟨a, ha, h⟩, lt_of_lt_of_le h $ le_Sup ha)

lemma Sup_eq_top : Sup s = ⊤ ↔ (∀b<⊤, ∃a∈s, b < a) :=
iff.intro
  (assume (h : Sup s = ⊤) b hb, by rwa [←h, lt_Sup_iff] at hb)
  (assume h, top_unique $ le_of_not_gt $ assume h',
    let ⟨a, ha, h⟩ := h _ h' in
    lt_irrefl a $ lt_of_le_of_lt (le_Sup ha) h)

lemma lt_supr_iff {ι : Sort*} {f : ι → α} : a < supr f ↔ (∃i, a < f i) :=
iff.trans lt_Sup_iff $ iff.intro
  (assume ⟨a', ⟨i, rfl⟩, ha⟩, ⟨i, ha⟩)
  (assume ⟨i, hi⟩, ⟨f i, ⟨i, rfl⟩, hi⟩)

lemma infi_lt_iff {ι : Sort*} {f : ι → α} : infi f < a ↔ (∃i, f i < a) :=
iff.trans Inf_lt_iff $ iff.intro
  (assume ⟨a', ⟨i, rfl⟩, ha⟩, ⟨i, ha⟩)
  (assume ⟨i, hi⟩, ⟨f i, ⟨i, rfl⟩, hi⟩)

end complete_linear_order

/- supr & infi -/

section
open set
variables [complete_lattice α] {s t : ι → α} {a b : α}

-- TODO: this declaration gives error when starting smt state
--@[ematch]
theorem le_supr (s : ι → α) (i : ι) : s i ≤ supr s :=
le_Sup ⟨i, rfl⟩

@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i ≤ supr s :) :=
le_Sup ⟨i, rfl⟩

/- TODO: this version would be more powerful, but, alas, the pattern matcher
   doesn't accept it.
@[ematch] theorem le_supr' (s : ι → α) (i : ι) : (: s i :) ≤ (: supr s :) :=
le_Sup ⟨i, rfl⟩
-/

theorem le_supr_of_le (i : ι) (h : a ≤ s i) : a ≤ supr s :=
le_trans h (le_supr _ i)

theorem supr_le (h : ∀i, s i ≤ a) : supr s ≤ a :=
Sup_le $ assume b ⟨i, eq⟩, eq.symm ▸ h i

theorem supr_le_supr (h : ∀i, s i ≤ t i) : supr s ≤ supr t :=
supr_le $ assume i, le_supr_of_le i (h i)

theorem supr_le_supr2 {t : ι₂ → α} (h : ∀i, ∃j, s i ≤ t j) : supr s ≤ supr t :=
supr_le $ assume j, exists.elim (h j) le_supr_of_le

theorem supr_le_supr_const (h : ι → ι₂) : (⨆ i:ι, a) ≤ (⨆ j:ι₂, a) :=
supr_le $ le_supr _ ∘ h

@[simp] theorem supr_le_iff : supr s ≤ a ↔ (∀i, s i ≤ a) :=
⟨assume : supr s ≤ a, assume i, le_trans (le_supr _ _) this, supr_le⟩

-- TODO: finish doesn't do well here.
@[congr] theorem supr_congr_Prop {p q : Prop} {f₁ : p → α} {f₂ : q → α}
  (pq : p ↔ q) (f : ∀x, f₁ (pq.mpr x) = f₂ x) : supr f₁ = supr f₂ :=
le_antisymm
  (supr_le_supr2 $ assume j, ⟨pq.mp j, le_of_eq $ f _⟩)
  (supr_le_supr2 $ assume j, ⟨pq.mpr j, le_of_eq $ (f j).symm⟩)

theorem infi_le (s : ι → α) (i : ι) : infi s ≤ s i :=
Inf_le ⟨i, rfl⟩

@[ematch] theorem infi_le' (s : ι → α) (i : ι) : (: infi s ≤ s i :) :=
Inf_le ⟨i, rfl⟩

/- I wanted to see if this would help for infi_comm; it doesn't.
@[ematch] theorem infi_le₂' (s : ι → ι₂ → α) (i : ι) (j : ι₂): (: ⨅ i j, s i j :) ≤ (: s i j :) :=
begin
  transitivity,
  apply (infi_le (λ i, ⨅ j, s i j) i),
  apply infi_le
end
-/

theorem infi_le_of_le (i : ι) (h : s i ≤ a) : infi s ≤ a :=
le_trans (infi_le _ i) h

theorem le_infi (h : ∀i, a ≤ s i) : a ≤ infi s :=
le_Inf $ assume b ⟨i, eq⟩, eq.symm ▸ h i

theorem infi_le_infi (h : ∀i, s i ≤ t i) : infi s ≤ infi t :=
le_infi $ assume i, infi_le_of_le i (h i)

theorem infi_le_infi2 {t : ι₂ → α} (h : ∀j, ∃i, s i ≤ t j) : infi s ≤ infi t :=
le_infi $ assume j, exists.elim (h j) infi_le_of_le

theorem infi_le_infi_const (h : ι₂ → ι) : (⨅ i:ι, a) ≤ (⨅ j:ι₂, a) :=
le_infi $ infi_le _ ∘ h

@[simp] theorem le_infi_iff : a ≤ infi s ↔ (∀i, a ≤ s i) :=
⟨assume : a ≤ infi s, assume i, le_trans this (infi_le _ _), le_infi⟩

@[congr] theorem infi_congr_Prop {p q : Prop} {f₁ : p → α} {f₂ : q → α}
  (pq : p ↔ q) (f : ∀x, f₁ (pq.mpr x) = f₂ x) : infi f₁ = infi f₂ :=
le_antisymm
  (infi_le_infi2 $ assume j, ⟨pq.mpr j, le_of_eq $ f j⟩)
  (infi_le_infi2 $ assume j, ⟨pq.mp j, le_of_eq $ (f _).symm⟩)

@[simp] theorem infi_const {a : α} : ∀[nonempty ι], (⨅ b:ι, a) = a
| ⟨i⟩ := le_antisymm (Inf_le ⟨i, rfl⟩) (by finish)

@[simp] theorem supr_const {a : α} : ∀[nonempty ι], (⨆ b:ι, a) = a
| ⟨i⟩ := le_antisymm (by finish) (le_Sup ⟨i, rfl⟩)

@[simp] lemma infi_top : (⨅i:ι, ⊤ : α) = ⊤ :=
top_unique $ le_infi $ assume i, le_refl _

@[simp] lemma supr_bot : (⨆i:ι, ⊥ : α) = ⊥ :=
bot_unique $ supr_le $ assume i, le_refl _

@[simp] lemma infi_eq_top : infi s = ⊤ ↔ (∀i, s i = ⊤) :=
iff.intro
  (assume eq i, top_unique $ eq ▸ infi_le _ _)
  (assume h, top_unique $ le_infi $ assume i, top_le_iff.2 $ h i)

@[simp] lemma infi_eq_bot : supr s = ⊥ ↔ (∀i, s i = ⊥) :=
iff.intro
  (assume eq i, bot_unique $ eq ▸ le_supr _ _)
  (assume h, bot_unique $ supr_le $ assume i, le_bot_iff.2 $ h i)

@[simp] lemma infi_pos {p : Prop} {f : p → α} (hp : p) : (⨅ h : p, f h) = f hp :=
le_antisymm (infi_le _ _) (le_infi $ assume h, le_refl _)

@[simp] lemma infi_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨅ h : p, f h) = ⊤ :=
le_antisymm le_top $ le_infi $ assume h, (hp h).elim

@[simp] lemma supr_pos {p : Prop} {f : p → α} (hp : p) : (⨆ h : p, f h) = f hp :=
le_antisymm (supr_le $ assume h, le_refl _) (le_supr _ _)

@[simp] lemma supr_neg {p : Prop} {f : p → α} (hp : ¬ p) : (⨆ h : p, f h) = ⊥ :=
le_antisymm (supr_le $ assume h, (hp h).elim) bot_le

-- TODO: should this be @[simp]?
theorem infi_comm {f : ι → ι₂ → α} : (⨅i, ⨅j, f i j) = (⨅j, ⨅i, f i j) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le_of_le j $ infi_le _ i)
  (le_infi $ assume j, le_infi $ assume i, infi_le_of_le i $ infi_le _ j)

/- TODO: this is strange. In the proof below, we get exactly the desired
   among the equalities, but close does not get it.
begin
  apply @le_antisymm,
    simp, intros,
    begin [smt]
      ematch, ematch, ematch, trace_state, have := le_refl (f i_1 i),
      trace_state, close
    end
end
-/

-- TODO: should this be @[simp]?
theorem supr_comm {f : ι → ι₂ → α} : (⨆i, ⨆j, f i j) = (⨆j, ⨆i, f i j) :=
le_antisymm
  (supr_le $ assume i, supr_le $ assume j, le_supr_of_le j $ le_supr _ i)
  (supr_le $ assume j, supr_le $ assume i, le_supr_of_le i $ le_supr _ j)

@[simp] theorem infi_infi_eq_left {b : β} {f : Πx:β, x = b → α} : (⨅x, ⨅h:x = b, f x h) = f b rfl :=
le_antisymm
  (infi_le_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_refl _ end)

@[simp] theorem infi_infi_eq_right {b : β} {f : Πx:β, b = x → α} : (⨅x, ⨅h:b = x, f x h) = f b rfl :=
le_antisymm
  (infi_le_of_le b $ infi_le _ rfl)
  (le_infi $ assume b', le_infi $ assume eq, match b', eq with ._, rfl := le_refl _ end)

@[simp] theorem supr_supr_eq_left {b : β} {f : Πx:β, x = b → α} : (⨆x, ⨆h : x = b, f x h) = f b rfl :=
le_antisymm
  (supr_le $ assume b', supr_le $ assume eq, match b', eq with ._, rfl := le_refl _ end)
  (le_supr_of_le b $ le_supr _ rfl)

@[simp] theorem supr_supr_eq_right {b : β} {f : Πx:β, b = x → α} : (⨆x, ⨆h : b = x, f x h) = f b rfl :=
le_antisymm
  (supr_le $ assume b', supr_le $ assume eq, match b', eq with ._, rfl := le_refl _ end)
  (le_supr_of_le b $ le_supr _ rfl)

attribute [ematch] le_refl

theorem infi_inf_eq {f g : ι → α} : (⨅ x, f x ⊓ g x) = (⨅ x, f x) ⊓ (⨅ x, g x) :=
le_antisymm
  (le_inf
    (le_infi $ assume i, infi_le_of_le i inf_le_left)
    (le_infi $ assume i, infi_le_of_le i inf_le_right))
  (le_infi $ assume i, le_inf
    (inf_le_left_of_le $ infi_le _ _)
    (inf_le_right_of_le $ infi_le _ _))

/- TODO: here is another example where more flexible pattern matching
   might help.

begin
  apply @le_antisymm,
  safe, pose h := f a ⊓ g a, begin [smt] ematch, ematch  end
end
-/

lemma infi_inf {f : ι → α} {a : α} (i : ι) : (⨅x, f x) ⊓ a = (⨅ x, f x ⊓ a) :=
le_antisymm
  (le_infi $ assume i, le_inf (inf_le_left_of_le $ infi_le _ _) inf_le_right)
  (le_inf (infi_le_infi $ assume i, inf_le_left) (infi_le_of_le i inf_le_right))

lemma inf_infi {f : ι → α} {a : α} (i : ι) : a ⊓ (⨅x, f x) = (⨅ x, a ⊓ f x) :=
by rw [inf_comm, infi_inf i]; simp [inf_comm]

lemma binfi_inf {ι : Sort*} {p : ι → Prop}
  {f : Πi, p i → α} {a : α} {i : ι} (hi : p i) :
  (⨅i (h : p i), f i h) ⊓ a = (⨅ i (h : p i), f i h ⊓ a) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume hi,
    le_inf (inf_le_left_of_le $ infi_le_of_le i $ infi_le _ _) inf_le_right)
  (le_inf (infi_le_infi $ assume i, infi_le_infi $ assume hi, inf_le_left)
     (infi_le_of_le i $ infi_le_of_le hi $ inf_le_right))

theorem supr_sup_eq {f g : β → α} : (⨆ x, f x ⊔ g x) = (⨆ x, f x) ⊔ (⨆ x, g x) :=
le_antisymm
  (supr_le $ assume i, sup_le
    (le_sup_left_of_le $ le_supr _ _)
    (le_sup_right_of_le $ le_supr _ _))
  (sup_le
    (supr_le $ assume i, le_supr_of_le i le_sup_left)
    (supr_le $ assume i, le_supr_of_le i le_sup_right))

/- supr and infi under Prop -/

@[simp] theorem infi_false {s : false → α} : infi s = ⊤ :=
le_antisymm le_top (le_infi $ assume i, false.elim i)

@[simp] theorem supr_false {s : false → α} : supr s = ⊥ :=
le_antisymm (supr_le $ assume i, false.elim i) bot_le

@[simp] theorem infi_true {s : true → α} : infi s = s trivial :=
le_antisymm (infi_le _ _) (le_infi $ assume ⟨⟩, le_refl _)

@[simp] theorem supr_true {s : true → α} : supr s = s trivial :=
le_antisymm (supr_le $ assume ⟨⟩, le_refl _) (le_supr _ _)

@[simp] theorem infi_exists {p : ι → Prop} {f : Exists p → α} : (⨅ x, f x) = (⨅ i, ⨅ h:p i, f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

@[simp] theorem supr_exists {p : ι → Prop} {f : Exists p → α} : (⨆ x, f x) = (⨆ i, ⨆ h:p i, f ⟨i, h⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λh:p i, f ⟨i, h⟩) _)
  (supr_le $ assume i, supr_le $ assume : p i, le_supr _ _)

theorem infi_and {p q : Prop} {s : p ∧ q → α} : infi s = (⨅ h₁ h₂, s ⟨h₁, h₂⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_and {p q : Prop} {s : p ∧ q → α} : supr s = (⨆ h₁ h₂, s ⟨h₁, h₂⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λj, s ⟨i, j⟩) _)
  (supr_le $ assume i, supr_le $ assume j, le_supr _ _)

theorem infi_or {p q : Prop} {s : p ∨ q → α} :
  infi s = (⨅ h : p, s (or.inl h)) ⊓ (⨅ h : q, s (or.inr h)) :=
le_antisymm
  (le_inf
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩)
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩))
  (le_infi $ assume i, match i with
  | or.inl i := inf_le_left_of_le $ infi_le _ _
  | or.inr j := inf_le_right_of_le $ infi_le _ _
  end)

theorem supr_or {p q : Prop} {s : p ∨ q → α} :
  (⨆ x, s x) = (⨆ i, s (or.inl i)) ⊔ (⨆ j, s (or.inr j)) :=
le_antisymm
  (supr_le $ assume s, match s with
  | or.inl i := le_sup_left_of_le $ le_supr _ i
  | or.inr j := le_sup_right_of_le $ le_supr _ j
  end)
  (sup_le
    (supr_le_supr2 $ assume i, ⟨or.inl i, le_refl _⟩)
    (supr_le_supr2 $ assume j, ⟨or.inr j, le_refl _⟩))

theorem Inf_eq_infi {s : set α} : Inf s = (⨅a ∈ s, a) :=
le_antisymm
  (le_infi $ assume b, le_infi $ assume h, Inf_le h)
  (le_Inf $ assume b h, infi_le_of_le b $ infi_le _ h)

theorem Sup_eq_supr {s : set α} : Sup s = (⨆a ∈ s, a) :=
le_antisymm
  (Sup_le $ assume b h, le_supr_of_le b $ le_supr _ h)
  (supr_le $ assume b, supr_le $ assume h, le_Sup h)

lemma Sup_range {f : ι → α} : Sup (range f) = supr f :=
le_antisymm
  (Sup_le $ forall_range_iff.mpr $ assume i, le_supr _ _)
  (supr_le $ assume i, le_Sup (mem_range_self _))

lemma Inf_range {f : ι → α} : Inf (range f) = infi f :=
le_antisymm
  (le_infi $ assume i, Inf_le (mem_range_self _))
  (le_Inf $ forall_range_iff.mpr $ assume i, infi_le _ _)

lemma supr_range {g : β → α} {f : ι → β} : (⨆b∈range f, g b) = (⨆i, g (f i)) :=
le_antisymm
  (supr_le $ assume b, supr_le $ assume ⟨i, (h : f i = b)⟩, h ▸ le_supr _ i)
  (supr_le $ assume i, le_supr_of_le (f i) $ le_supr (λp, g (f i)) (mem_range_self _))

lemma infi_range {g : β → α} {f : ι → β} : (⨅b∈range f, g b) = (⨅i, g (f i)) :=
le_antisymm
  (le_infi $ assume i, infi_le_of_le (f i) $ infi_le (λp, g (f i)) (mem_range_self _))
  (le_infi $ assume b, le_infi $ assume ⟨i, (h : f i = b)⟩, h ▸ infi_le _ i)

theorem Inf_image {s : set β} {f : β → α} : Inf (f '' s) = (⨅ a ∈ s, f a) :=
calc Inf (set.image f s) = (⨅a, ⨅h : ∃b, b ∈ s ∧ f b = a, a) : Inf_eq_infi
                     ... = (⨅a, ⨅b, ⨅h : f b = a ∧ b ∈ s, a) : by simp [and_comm]
                     ... = (⨅a, ⨅b, ⨅h : a = f b, ⨅h : b ∈ s, a) : by simp [infi_and, eq_comm]
                     ... = (⨅b, ⨅a, ⨅h : a = f b, ⨅h : b ∈ s, a) : by rw [infi_comm]
                     ... = (⨅a∈s, f a) : congr_arg infi $ by funext x; rw [infi_infi_eq_left]

theorem Sup_image {s : set β} {f : β → α} : Sup (f '' s) = (⨆ a ∈ s, f a) :=
calc Sup (set.image f s) = (⨆a, ⨆h : ∃b, b ∈ s ∧ f b = a, a) : Sup_eq_supr
                     ... = (⨆a, ⨆b, ⨆h : f b = a ∧ b ∈ s, a) : by simp [and_comm]
                     ... = (⨆a, ⨆b, ⨆h : a = f b, ⨆h : b ∈ s, a) : by simp [supr_and, eq_comm]
                     ... = (⨆b, ⨆a, ⨆h : a = f b, ⨆h : b ∈ s, a) : by rw [supr_comm]
                     ... = (⨆a∈s, f a) : congr_arg supr $ by funext x; rw [supr_supr_eq_left]

/- supr and infi under set constructions -/

/- should work using the simplifier! -/
@[simp] theorem infi_emptyset {f : β → α} : (⨅ x ∈ (∅ : set β), f x) = ⊤ :=
le_antisymm le_top (le_infi $ assume x, le_infi false.elim)

@[simp] theorem supr_emptyset {f : β → α} : (⨆ x ∈ (∅ : set β), f x) = ⊥ :=
le_antisymm (supr_le $ assume x, supr_le false.elim) bot_le

@[simp] theorem infi_univ {f : β → α} : (⨅ x ∈ (univ : set β), f x) = (⨅ x, f x) :=
show (⨅ (x : β) (H : true), f x) = ⨅ (x : β), f x,
  from congr_arg infi $ funext $ assume x, infi_const

@[simp] theorem supr_univ {f : β → α} : (⨆ x ∈ (univ : set β), f x) = (⨆ x, f x) :=
show (⨆ (x : β) (H : true), f x) = ⨆ (x : β), f x,
  from congr_arg supr $ funext $ assume x, supr_const

@[simp] theorem infi_union {f : β → α} {s t : set β} : (⨅ x ∈ s ∪ t, f x) = (⨅x∈s, f x) ⊓ (⨅x∈t, f x) :=
calc (⨅ x ∈ s ∪ t, f x) = (⨅ x, (⨅h : x∈s, f x) ⊓ (⨅h : x∈t, f x)) : congr_arg infi $ funext $ assume x, infi_or
                    ... = (⨅x∈s, f x) ⊓ (⨅x∈t, f x) : infi_inf_eq

@[simp] theorem supr_union {f : β → α} {s t : set β} : (⨆ x ∈ s ∪ t, f x) = (⨆x∈s, f x) ⊔ (⨆x∈t, f x) :=
calc (⨆ x ∈ s ∪ t, f x) = (⨆ x, (⨆h : x∈s, f x) ⊔ (⨆h : x∈t, f x)) : congr_arg supr $ funext $ assume x, supr_or
                    ... = (⨆x∈s, f x) ⊔ (⨆x∈t, f x) : supr_sup_eq

@[simp] theorem insert_of_has_insert (x : α) (a : set α) : has_insert.insert x a = insert x a := rfl

@[simp] theorem infi_insert {f : β → α} {s : set β} {b : β} : (⨅ x ∈ insert b s, f x) = f b ⊓ (⨅x∈s, f x) :=
eq.trans infi_union $ congr_arg (λx:α, x ⊓ (⨅x∈s, f x)) infi_infi_eq_left

@[simp] theorem supr_insert {f : β → α} {s : set β} {b : β} : (⨆ x ∈ insert b s, f x) = f b ⊔ (⨆x∈s, f x) :=
eq.trans supr_union $ congr_arg (λx:α, x ⊔ (⨆x∈s, f x)) supr_supr_eq_left

@[simp] theorem infi_singleton {f : β → α} {b : β} : (⨅ x ∈ (singleton b : set β), f x) = f b :=
show (⨅ x ∈ insert b (∅ : set β), f x) = f b,
  by simp

@[simp] theorem supr_singleton {f : β → α} {b : β} : (⨆ x ∈ (singleton b : set β), f x) = f b :=
show (⨆ x ∈ insert b (∅ : set β), f x) = f b,
  by simp

/- supr and infi under Type -/

@[simp] theorem infi_empty {s : empty → α} : infi s = ⊤ :=
le_antisymm le_top (le_infi $ assume i, empty.rec_on _ i)

@[simp] theorem supr_empty {s : empty → α} : supr s = ⊥ :=
le_antisymm (supr_le $ assume i, empty.rec_on _ i) bot_le

@[simp] theorem infi_unit {f : unit → α} : (⨅ x, f x) = f () :=
le_antisymm (infi_le _ _) (le_infi $ assume ⟨⟩, le_refl _)

@[simp] theorem supr_unit {f : unit → α} : (⨆ x, f x) = f () :=
le_antisymm (supr_le $ assume ⟨⟩, le_refl _) (le_supr _ _)

lemma supr_bool_eq {f : bool → α} : (⨆b:bool, f b) = f tt ⊔ f ff :=
le_antisymm
  (supr_le $ assume b, match b with tt := le_sup_left | ff := le_sup_right end)
  (sup_le (le_supr _ _) (le_supr _ _))

lemma infi_bool_eq {f : bool → α} : (⨅b:bool, f b) = f tt ⊓ f ff :=
le_antisymm
  (le_inf (infi_le _ _) (infi_le _ _))
  (le_infi $ assume b, match b with tt := inf_le_left | ff := inf_le_right end)

theorem infi_subtype {p : ι → Prop} {f : subtype p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_subtype {p : ι → Prop} {f : subtype p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λh:p i, f ⟨i, h⟩) _)
  (supr_le $ assume i, supr_le $ assume : p i, le_supr _ _)

theorem infi_sigma {p : β → Type w} {f : sigma p → α} : (⨅ x, f x) = (⨅ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume : p i, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_sigma {p : β → Type w} {f : sigma p → α} : (⨆ x, f x) = (⨆ i (h:p i), f ⟨i, h⟩) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λh:p i, f ⟨i, h⟩) _)
  (supr_le $ assume i, supr_le $ assume : p i, le_supr _ _)

theorem infi_prod {γ : Type w} {f : β × γ → α} : (⨅ x, f x) = (⨅ i j, f (i, j)) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume j, infi_le _ _)
  (le_infi $ assume ⟨i, h⟩, infi_le_of_le i $ infi_le _ _)

theorem supr_prod {γ : Type w} {f : β × γ → α} : (⨆ x, f x) = (⨆ i j, f (i, j)) :=
le_antisymm
  (supr_le $ assume ⟨i, h⟩, le_supr_of_le i $ le_supr (λj, f ⟨i, j⟩) _)
  (supr_le $ assume i, supr_le $ assume j, le_supr _ _)

theorem infi_sum {γ : Type w} {f : β ⊕ γ → α} :
  (⨅ x, f x) = (⨅ i, f (sum.inl i)) ⊓ (⨅ j, f (sum.inr j)) :=
le_antisymm
  (le_inf
    (infi_le_infi2 $ assume i, ⟨_, le_refl _⟩)
    (infi_le_infi2 $ assume j, ⟨_, le_refl _⟩))
  (le_infi $ assume s, match s with
  | sum.inl i := inf_le_left_of_le $ infi_le _ _
  | sum.inr j := inf_le_right_of_le $ infi_le _ _
  end)

theorem supr_sum {γ : Type w} {f : β ⊕ γ → α} :
  (⨆ x, f x) = (⨆ i, f (sum.inl i)) ⊔ (⨆ j, f (sum.inr j)) :=
le_antisymm
  (supr_le $ assume s, match s with
  | sum.inl i := le_sup_left_of_le $ le_supr _ i
  | sum.inr j := le_sup_right_of_le $ le_supr _ j
  end)
  (sup_le
    (supr_le_supr2 $ assume i, ⟨sum.inl i, le_refl _⟩)
    (supr_le_supr2 $ assume j, ⟨sum.inr j, le_refl _⟩))

end

/- Instances -/

instance complete_lattice_Prop : complete_lattice Prop :=
{ Sup    := λs, ∃a∈s, a,
  le_Sup := assume s a h p, ⟨a, h, p⟩,
  Sup_le := assume s a h ⟨b, h', p⟩, h b h' p,
  Inf    := λs, ∀a:Prop, a∈s → a,
  Inf_le := assume s a h p, p a h,
  le_Inf := assume s a h p b hb, h b hb p,
  ..lattice.bounded_lattice_Prop }

lemma Inf_Prop_eq {s : set Prop} : Inf s = (∀p ∈ s, p) := rfl

lemma Sup_Prop_eq {s : set Prop} : Sup s = (∃p ∈ s, p) := rfl

lemma infi_Prop_eq {ι : Sort*} {p : ι → Prop} : (⨅i, p i) = (∀i, p i) :=
le_antisymm (assume h i, h _ ⟨i, rfl⟩ ) (assume h p ⟨i, eq⟩, eq.symm ▸ h i)

lemma supr_Prop_eq {ι : Sort*} {p : ι → Prop} : (⨆i, p i) = (∃i, p i) :=
le_antisymm (assume ⟨q, ⟨i, (eq : q = p i)⟩, hq⟩, ⟨i, eq ▸ hq⟩) (assume ⟨i, hi⟩, ⟨p i, ⟨i, rfl⟩, hi⟩)

instance pi.complete_lattice {α : Type u} {β : α → Type v} [∀ i, complete_lattice (β i)] :
  complete_lattice (Π i, β i) :=
by { pi_instance;
     { intros, intro,
       apply_field, intros,
       simp at H, rcases H with ⟨ x, H₀, H₁ ⟩,
       subst b, apply a_1 _ H₀ i, } }

lemma Inf_apply
  {α : Type u} {β : α → Type v} [∀ i, complete_lattice (β i)] {s : set (Πa, β a)} {a : α} :
  (Inf s) a = (⨅f∈s, (f : Πa, β a) a) :=
by rw [← Inf_image]; refl

lemma infi_apply {α : Type u} {β : α → Type v} {ι : Sort*} [∀ i, complete_lattice (β i)]
  {f : ι → Πa, β a} {a : α} : (⨅i, f i) a = (⨅i, f i a) :=
by rw [← Inf_range, Inf_apply, infi_range]

lemma Sup_apply
  {α : Type u} {β : α → Type v} [∀ i, complete_lattice (β i)] {s : set (Πa, β a)} {a : α} :
  (Sup s) a = (⨆f∈s, (f : Πa, β a) a) :=
by rw [← Sup_image]; refl

lemma supr_apply {α : Type u} {β : α → Type v} {ι : Sort*} [∀ i, complete_lattice (β i)]
  {f : ι → Πa, β a} {a : α} : (⨆i, f i) a = (⨆i, f i a) :=
by rw [← Sup_range, Sup_apply, supr_range]

section complete_lattice
variables [preorder α] [complete_lattice β]

theorem monotone_Sup_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Sup s) :=
assume x y h, Sup_le $ assume x' ⟨f, f_in, fx_eq⟩, le_Sup_of_le ⟨f, f_in, rfl⟩ $ fx_eq ▸ m_s _ f_in h

theorem monotone_Inf_of_monotone {s : set (α → β)} (m_s : ∀f∈s, monotone f) : monotone (Inf s) :=
assume x y h, le_Inf $ assume x' ⟨f, f_in, fx_eq⟩, Inf_le_of_le ⟨f, f_in, rfl⟩ $ fx_eq ▸ m_s _ f_in h

end complete_lattice

section ord_continuous
open lattice
variables [complete_lattice α] [complete_lattice β]

/-- A function `f` between complete lattices is order-continuous
  if it preserves all suprema. -/
def ord_continuous (f : α → β) := ∀s : set α, f (Sup s) = (⨆i∈s, f i)

lemma ord_continuous_sup {f : α → β} {a₁ a₂ : α} (hf : ord_continuous f) : f (a₁ ⊔ a₂) = f a₁ ⊔ f a₂ :=
have h : f (Sup {a₁, a₂}) = (⨆i∈({a₁, a₂} : set α), f i), from hf _,
have h₁ : {a₁, a₂} = (insert a₂ {a₁} : set α), from rfl,
begin
  rw [h₁, Sup_insert, Sup_singleton, sup_comm] at h,
  rw [h, supr_insert, supr_singleton, sup_comm]
end

lemma ord_continuous_mono {f : α → β} (hf : ord_continuous f) : monotone f :=
assume a₁ a₂ h,
calc f a₁ ≤ f a₁ ⊔ f a₂ : le_sup_left
  ... = f (a₁ ⊔ a₂) : (ord_continuous_sup hf).symm
  ... = _ : by rw [sup_of_le_right h]

end ord_continuous
end lattice

namespace order_dual
open lattice
variable (α : Type*)

instance [has_Inf α] : has_Sup (order_dual α) := ⟨(Inf : set α → α)⟩
instance [has_Sup α] : has_Inf (order_dual α) := ⟨(Sup : set α → α)⟩

instance [complete_lattice α] : complete_lattice (order_dual α) :=
{ le_Sup := @complete_lattice.Inf_le α _,
  Sup_le := @complete_lattice.le_Inf α _,
  Inf_le := @complete_lattice.le_Sup α _,
  le_Inf := @complete_lattice.Sup_le α _,
  .. order_dual.lattice.bounded_lattice α, ..order_dual.lattice.has_Sup α, ..order_dual.lattice.has_Inf α }

end order_dual


/-
Copyright (c) 2019 Patrick MAssot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import topology.uniform_space.absolute_value
import topology.instances.real
import topology.instances.rat
import topology.uniform_space.completion

/-!
# Comparison of Cauchy reals and Bourbaki reals

In `data.real.basic` real numbers are defined using the so called Cauchy construction (although
it is due to Georg Cantor). More precisely, this construction applies to commutative rings equipped
with an absolute value with values in a linear ordered field.

On the other hand, in the `uniform_space` folder, we construct completions of general uniform
spaces, which allows to construct the Bourbaki real numbers. In this file we build uniformly
continuous bijections from Cauchy reals to Bourbaki reals and back. This is a cross sanity check of
both constructions. Of course those two constructions are variations on the completion idea, simply
with different level of generality. Comparing with Dedekind cuts or quasi-morphisms would be of a
completely different nature.

Note that `metric_space/cau_seq_filter` also relates the notions of Cauchy sequences in metric
spaces and Cauchy filters in general uniform spaces, and `metric_space/completion` makes sure
the completion (as a uniform space) of a metric space is a metric space.

Historical note: mathlib used to define real numbers in an intermediate way, using completion
of uniform spaces but extending multiplication in an ad-hoc way.

TODO:
* Upgrade this isomorphism to a topological ring isomorphism.
* Do the same comparison for p-adic numbers

## Implementation notes

The heavy work is done in `topology/uniform_space/abstract_completion` which provides an abstract
caracterization of completions of uniform spaces, and isomorphisms between them. The only work left
here is to prove the uniform space structure coming from the absolute value on ℚ (with values in ℚ,
not referring to ℝ) coincides with the one coming from the metric space structure (which of course
does use ℝ).

## References

* [N. Bourbaki, *Topologie générale*][bourbaki1966]

## Tags

real numbers, completion, uniform spaces
-/

open set function filter cau_seq uniform_space

/-- The metric space uniform structure on ℚ (which presupposes the existence
of real numbers) agrees with the one coming directly from (abs : ℚ → ℚ). -/
lemma rat.uniform_space_eq :
  is_absolute_value.uniform_space (abs : ℚ → ℚ) = metric_space.to_uniform_space' :=
begin
  ext s,
  erw [metric.mem_uniformity_dist, is_absolute_value.mem_uniformity],
  split ; rintro ⟨ε, ε_pos, h⟩,
  { use [ε, by exact_mod_cast ε_pos],
    intros a b hab,
    apply h,
    rw [rat.dist_eq, abs_sub_comm] at hab,
    exact_mod_cast hab },
  { obtain ⟨ε', h', h''⟩ : ∃ ε' : ℚ, 0 < ε' ∧ (ε' : ℝ) < ε, from exists_pos_rat_lt ε_pos,
    use [ε', h'],
    intros a b hab,
    apply h,
    rw [rat.dist_eq, abs_sub_comm],
    refine lt_trans _ h'',
    exact_mod_cast hab }
end

/-- Cauchy reals packaged as a completion of ℚ using the absolute value route. -/
noncomputable
def rational_cau_seq_pkg : @abstract_completion ℚ $ is_absolute_value.uniform_space (abs : ℚ → ℚ) :=
{ space := ℝ,
  coe := (coe : ℚ → ℝ),
  uniform_struct := by apply_instance,
  complete :=  by apply_instance,
  separation :=  by apply_instance,
  uniform_inducing := by { rw rat.uniform_space_eq,
                           exact rat.uniform_embedding_coe_real.to_uniform_inducing },
  dense := rat.dense_embedding_coe_real.dense }

namespace compare_reals
/-- Type wrapper around ℚ to make sure the absolute value uniform space instance is picked up
instead of the metric space one. We proved in rat.uniform_space_eq that they are equal,
but they are not definitionaly equal, so it would confuse the type class system (and probably
also human readers). -/
@[derive comm_ring, derive inhabited] def Q := ℚ

instance : uniform_space Q := is_absolute_value.uniform_space (abs : ℚ → ℚ)

/-- Real numbers constructed as in Bourbaki. -/
@[derive inhabited]
def Bourbakiℝ : Type := completion Q

instance bourbaki.uniform_space: uniform_space Bourbakiℝ := completion.uniform_space Q

/-- Bourbaki reals packaged as a completion of Q using the general theory. -/
def Bourbaki_pkg : abstract_completion Q := completion.cpkg

/-- The equivalence between Bourbaki and Cauchy reals-/
noncomputable def compare_equiv : Bourbakiℝ ≃ ℝ :=
Bourbaki_pkg.compare_equiv rational_cau_seq_pkg

lemma compare_uc : uniform_continuous (compare_equiv) :=
Bourbaki_pkg.uniform_continuous_compare_equiv _

lemma compare_uc_symm : uniform_continuous (compare_equiv).symm :=
Bourbaki_pkg.uniform_continuous_compare_equiv_symm _
end compare_reals


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

import measure_theory.measure.regular
import measure_theory.function.simple_func_dense
import topology.urysohns_lemma

/-!
# Approximation in Lᵖ by continuous functions

This file proves that bounded continuous functions are dense in `Lp E p μ`, for `1 ≤ p < ∞`, if the
domain `α` of the functions is a normal topological space and the measure `μ` is weakly regular.

The result is presented in several versions:
* `measure_theory.Lp.bounded_continuous_function_dense`: The subgroup
  `measure_theory.Lp.bounded_continuous_function` of `Lp E p μ`, the additive subgroup of
  `Lp E p μ` consisting of equivalence classes containing a continuous representative, is dense in
  `Lp E p μ`.
* `bounded_continuous_function.to_Lp_dense_range`: For finite-measure `μ`, the continuous linear
  map `bounded_continuous_function.to_Lp p μ 𝕜` from `α →ᵇ E` to `Lp E p μ` has dense range.
* `continuous_map.to_Lp_dense_range`: For compact `α` and finite-measure `μ`, the continuous linear
  map `continuous_map.to_Lp p μ 𝕜` from `C(α, E)` to `Lp E p μ` has dense range.

Note that for `p = ∞` this result is not true:  the characteristic function of the set `[0, ∞)` in
`ℝ` cannot be continuously approximated in `L∞`.

The proof is in three steps.  First, since simple functions are dense in `Lp`, it suffices to prove
the result for a scalar multiple of a characteristic function of a measurable set `s`. Secondly,
since the measure `μ` is weakly regular, the set `s` can be approximated above by an open set and
below by a closed set.  Finally, since the domain `α` is normal, we use Urysohn's lemma to find a
continuous function interpolating between these two sets.

## Related results

Are you looking for a result on "directional" approximation (above or below with respect to an
order) of functions whose codomain is `ℝ≥0∞` or `ℝ`, by semicontinuous functions?  See the
Vitali-Carathéodory theorem, in the file `measure_theory.vitali_caratheodory`.

-/

open_locale ennreal nnreal topological_space bounded_continuous_function
open measure_theory topological_space continuous_map

variables {α : Type*} [measurable_space α] [topological_space α] [normal_space α] [borel_space α]
variables (E : Type*) [measurable_space E] [normed_group E] [borel_space E]
  [second_countable_topology E]
variables {p : ℝ≥0∞} [_i : fact (1 ≤ p)] (hp : p ≠ ∞) (μ : measure α)

include _i hp

namespace measure_theory.Lp

variables [normed_space ℝ E]

/-- A function in `Lp` can be approximated in `Lp` by continuous functions. -/
lemma bounded_continuous_function_dense [μ.weakly_regular] :
  (bounded_continuous_function E p μ).topological_closure = ⊤ :=
begin
  have hp₀ : 0 < p := lt_of_lt_of_le ennreal.zero_lt_one _i.elim,
  have hp₀' : 0 ≤ 1 / p.to_real := div_nonneg zero_le_one ennreal.to_real_nonneg,
  have hp₀'' : 0 < p.to_real,
  { simpa [← ennreal.to_real_lt_to_real ennreal.zero_ne_top hp] using hp₀ },
  -- It suffices to prove that scalar multiples of the indicator function of a finite-measure
  -- measurable set can be approximated by continuous functions
  suffices :  ∀ (c : E) {s : set α} (hs : measurable_set s) (hμs : μ s < ⊤),
    (Lp.simple_func.indicator_const p hs hμs.ne c : Lp E p μ)
      ∈ (bounded_continuous_function E p μ).topological_closure,
  { rw add_subgroup.eq_top_iff',
    refine Lp.induction hp _ _ _ _,
    { exact this },
    { exact λ f g hf hg hfg', add_subgroup.add_mem _ },
    { exact add_subgroup.is_closed_topological_closure _ } },
  -- Let `s` be a finite-measure measurable set, let's approximate `c` times its indicator function
  intros c s hs hsμ,
  refine mem_closure_iff_frequently.mpr _,
  rw metric.nhds_basis_closed_ball.frequently_iff,
  intros ε hε,
  -- A little bit of pre-emptive work, to find `η : ℝ≥0` which will be a margin small enough for
  -- our purposes
  obtain ⟨η, hη_pos, hη_le⟩ : ∃ η, 0 < η ∧ (↑(∥bit0 (∥c∥)∥₊ * (2 * η) ^ (1 / p.to_real)) : ℝ) ≤ ε,
  { have : filter.tendsto (λ x : ℝ≥0, ∥bit0 (∥c∥)∥₊ * (2 * x) ^ (1 / p.to_real)) (𝓝 0) (𝓝 0),
    { have : filter.tendsto (λ x : ℝ≥0, 2 * x) (𝓝 0) (𝓝 (2 * 0)) := filter.tendsto_id.const_mul 2,
      convert ((nnreal.continuous_at_rpow_const (or.inr hp₀')).tendsto.comp this).const_mul _,
      simp [hp₀''.ne'] },
    let ε' : ℝ≥0 := ⟨ε, hε.le⟩,
    have hε' : 0 < ε' := by exact_mod_cast hε,
    obtain ⟨δ, hδ, hδε'⟩ :=
      nnreal.nhds_zero_basis.eventually_iff.mp (eventually_le_of_tendsto_lt hε' this),
    obtain ⟨η, hη, hηδ⟩ := exists_between hδ,
    refine ⟨η, hη, _⟩,
    exact_mod_cast hδε' hηδ },
  have hη_pos' : (0 : ℝ≥0∞) < η := ennreal.coe_pos.2 hη_pos,
  -- Use the regularity of the measure to `η`-approximate `s` by an open superset and a closed
  -- subset
  obtain ⟨u, su, u_open, μu⟩ : ∃ u ⊇ s, is_open u ∧ μ u < μ s + ↑η,
  { refine s.exists_is_open_lt_of_lt _ _,
    simpa using ennreal.add_lt_add_left hsμ.ne hη_pos' },
  obtain ⟨F, Fs, F_closed, μF⟩ : ∃ F ⊆ s, is_closed F ∧ μ s < μ F + ↑η :=
    hs.exists_is_closed_lt_add hsμ.ne hη_pos'.ne',
  have : disjoint uᶜ F,
  { rw [set.disjoint_iff_inter_eq_empty, set.inter_comm, ← set.subset_compl_iff_disjoint],
    simpa using Fs.trans su },
  have h_μ_sdiff : μ (u \ F) ≤ 2 * η,
  { have hFμ : μ F < ⊤ := (measure_mono Fs).trans_lt hsμ,
    refine ennreal.le_of_add_le_add_left hFμ.ne _,
    have : μ u < μ F + ↑η + ↑η,
      from μu.trans (ennreal.add_lt_add_right ennreal.coe_ne_top μF),
    convert this.le using 1,
    { rw [add_comm, ← measure_union, set.diff_union_of_subset (Fs.trans su)],
      { exact disjoint_sdiff_self_left },
      { exact (u_open.sdiff F_closed).measurable_set },
      { exact F_closed.measurable_set } },
    have : (2:ℝ≥0∞) * η = η + η := by simpa using add_mul (1:ℝ≥0∞) 1 η,
    rw this,
    abel },
  -- Apply Urysohn's lemma to get a continuous approximation to the characteristic function of
  -- the set `s`
  obtain ⟨g, hgu, hgF, hg_range⟩ :=
    exists_continuous_zero_one_of_closed u_open.is_closed_compl F_closed this,
  -- Multiply this by `c` to get a continuous approximation to the function `f`; the key point is
  -- that this is pointwise bounded by the indicator of the set `u \ F`
  have g_norm : ∀ x, ∥g x∥ = g x := λ x, by rw [real.norm_eq_abs, abs_of_nonneg (hg_range x).1],
  have gc_bd : ∀ x, ∥g x • c - s.indicator (λ x, c) x∥ ≤ ∥(u \ F).indicator (λ x, bit0 ∥c∥) x∥,
  { intros x,
    by_cases hu : x ∈ u,
    { rw ← set.diff_union_of_subset (Fs.trans su) at hu,
      cases hu with hFu hF,
      { refine (norm_sub_le _ _).trans _,
        refine (add_le_add_left (norm_indicator_le_norm_self (λ x, c) x) _).trans _,
        have h₀ : g x * ∥c∥ + ∥c∥ ≤ 2 * ∥c∥,
        { nlinarith [(hg_range x).1, (hg_range x).2, norm_nonneg c] },
        have h₁ : (2:ℝ) * ∥c∥ = bit0 (∥c∥) := by simpa using add_mul (1:ℝ) 1 (∥c∥),
        simp [hFu, norm_smul, h₀, ← h₁, g_norm x] },
      { simp [hgF hF, Fs hF] } },
    { have : x ∉ s := λ h, hu (su h),
      simp [hgu hu, this] } },
  -- The rest is basically just `ennreal`-arithmetic
  have gc_snorm : snorm ((λ x, g x • c) - s.indicator (λ x, c)) p μ
    ≤ (↑(∥bit0 (∥c∥)∥₊ * (2 * η) ^ (1 / p.to_real)) : ℝ≥0∞),
  { refine (snorm_mono_ae (filter.eventually_of_forall gc_bd)).trans _,
    rw snorm_indicator_const (u_open.sdiff F_closed).measurable_set hp₀.ne' hp,
    push_cast [← ennreal.coe_rpow_of_nonneg _ hp₀'],
    exact ennreal.mul_left_mono (ennreal.rpow_left_monotone_of_nonneg hp₀' h_μ_sdiff) },
  have gc_cont : continuous (λ x, g x • c) := g.continuous.smul continuous_const,
  have gc_mem_ℒp : mem_ℒp (λ x, g x • c) p μ,
  { have : mem_ℒp ((λ x, g x • c) - s.indicator (λ x, c)) p μ :=
    ⟨(gc_cont.ae_measurable μ).sub (measurable_const.indicator hs).ae_measurable,
      gc_snorm.trans_lt ennreal.coe_lt_top⟩,
    simpa using this.add (mem_ℒp_indicator_const p hs c (or.inr hsμ.ne)) },
  refine ⟨gc_mem_ℒp.to_Lp _, _, _⟩,
  { rw mem_closed_ball_iff_norm,
    refine le_trans _ hη_le,
    rw [simple_func.coe_indicator_const, indicator_const_Lp, ← mem_ℒp.to_Lp_sub, Lp.norm_to_Lp],
    exact ennreal.to_real_le_coe_of_le_coe gc_snorm },
  { rw [set_like.mem_coe, mem_bounded_continuous_function_iff],
    refine ⟨bounded_continuous_function.of_normed_group _ gc_cont (∥c∥) _, rfl⟩,
    intros x,
    have h₀ : g x * ∥c∥ ≤ ∥c∥,
    { nlinarith [(hg_range x).1, (hg_range x).2, norm_nonneg c] },
    simp [norm_smul, g_norm x, h₀] },
end

end measure_theory.Lp

variables (𝕜 : Type*) [measurable_space 𝕜] [normed_field 𝕜] [opens_measurable_space 𝕜]
  [normed_algebra ℝ 𝕜] [normed_space 𝕜 E]

namespace bounded_continuous_function

lemma to_Lp_dense_range [μ.weakly_regular] [is_finite_measure μ] :
  dense_range ⇑(to_Lp p μ 𝕜 : (α →ᵇ E) →L[𝕜] Lp E p μ) :=
begin
  haveI : normed_space ℝ E := restrict_scalars.normed_space ℝ 𝕜 E,
  rw dense_range_iff_closure_range,
  suffices : (to_Lp p μ 𝕜 : _ →L[𝕜] Lp E p μ).range.to_add_subgroup.topological_closure = ⊤,
  { exact congr_arg coe this },
  simp [range_to_Lp p μ, measure_theory.Lp.bounded_continuous_function_dense E hp],
end

end bounded_continuous_function

namespace continuous_map

lemma to_Lp_dense_range [compact_space α] [μ.weakly_regular] [is_finite_measure μ] :
  dense_range ⇑(to_Lp p μ 𝕜 : C(α, E) →L[𝕜] Lp E p μ) :=
begin
  haveI : normed_space ℝ E := restrict_scalars.normed_space ℝ 𝕜 E,
  rw dense_range_iff_closure_range,
  suffices : (to_Lp p μ 𝕜 : _ →L[𝕜] Lp E p μ).range.to_add_subgroup.topological_closure = ⊤,
  { exact congr_arg coe this },
  simp [range_to_Lp p μ, measure_theory.Lp.bounded_continuous_function_dense E hp]
end

end continuous_map


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.instances.real_vector_space
import analysis.normed_space.affine_isometry

/-!
# Mazur-Ulam Theorem

Mazur-Ulam theorem states that an isometric bijection between two normed affine spaces over `ℝ` is
affine. We formalize it in three definitions:

* `isometry_equiv.to_real_linear_isometry_equiv_of_map_zero` : given `E ≃ᵢ F` sending `0` to `0`,
  returns `E ≃ₗᵢ[ℝ] F` with the same `to_fun` and `inv_fun`;
* `isometry_equiv.to_real_linear_isometry_equiv` : given `f : E ≃ᵢ F`, returns a linear isometry
  equivalence `g : E ≃ₗᵢ[ℝ] F` with `g x = f x - f 0`.
* `isometry_equiv.to_real_affine_isometry_equiv` : given `f : PE ≃ᵢ PF`, returns an affine isometry
  equivalence `g : PE ≃ᵃⁱ[ℝ] PF` whose underlying `isometry_equiv` is `f`

The formalization is based on [Jussi Väisälä, *A Proof of the Mazur-Ulam Theorem*][Vaisala_2003].

## Tags

isometry, affine map, linear map
-/

variables {E PE F PF : Type*} [normed_add_comm_group E] [normed_space ℝ E] [metric_space PE]
  [normed_add_torsor E PE] [normed_add_comm_group F] [normed_space ℝ F] [metric_space PF]
  [normed_add_torsor F PF]

open set affine_map affine_isometry_equiv

noncomputable theory

namespace isometry_equiv

include E

/-- If an isometric self-homeomorphism of a normed vector space over `ℝ` fixes `x` and `y`,
then it fixes the midpoint of `[x, y]`. This is a lemma for a more general Mazur-Ulam theorem,
see below. -/
lemma midpoint_fixed {x y : PE} :
  ∀ e : PE ≃ᵢ PE, e x = x → e y = y → e (midpoint ℝ x y) = midpoint ℝ x y :=
begin
  set z := midpoint ℝ x y,
  -- Consider the set of `e : E ≃ᵢ E` such that `e x = x` and `e y = y`
  set s := { e : PE ≃ᵢ PE | e x = x ∧ e y = y },
  haveI : nonempty s := ⟨⟨isometry_equiv.refl PE, rfl, rfl⟩⟩,
  -- On the one hand, `e` cannot send the midpoint `z` of `[x, y]` too far
  have h_bdd : bdd_above (range $ λ e : s, dist (e z) z),
  { refine ⟨dist x z + dist x z, forall_range_iff.2 $ subtype.forall.2 _⟩,
    rintro e ⟨hx, hy⟩,
    calc dist (e z) z ≤ dist (e z) x + dist x z     : dist_triangle (e z) x z
                  ... = dist (e x) (e z) + dist x z : by rw [hx, dist_comm]
                  ... = dist x z + dist x z         : by erw [e.dist_eq x z] },
  -- On the other hand, consider the map `f : (E ≃ᵢ E) → (E ≃ᵢ E)`
  -- sending each `e` to `R ∘ e⁻¹ ∘ R ∘ e`, where `R` is the point reflection in the
  -- midpoint `z` of `[x, y]`.
  set R : PE ≃ᵢ PE := (point_reflection ℝ z).to_isometry_equiv,
  set f : (PE ≃ᵢ PE) → (PE ≃ᵢ PE) := λ e, ((e.trans R).trans e.symm).trans R,
  -- Note that `f` doubles the value of ``dist (e z) z`
  have hf_dist : ∀ e, dist (f e z) z = 2 * dist (e z) z,
  { intro e,
    dsimp [f],
    rw [dist_point_reflection_fixed, ← e.dist_eq, e.apply_symm_apply,
      dist_point_reflection_self_real, dist_comm] },
  -- Also note that `f` maps `s` to itself
  have hf_maps_to : maps_to f s s,
  { rintros e ⟨hx, hy⟩,
    split; simp [hx, hy, e.symm_apply_eq.2 hx.symm, e.symm_apply_eq.2 hy.symm], },
  -- Therefore, `dist (e z) z = 0` for all `e ∈ s`.
  set c := ⨆ e : s, dist ((e : PE ≃ᵢ PE) z) z,
  have : c ≤ c / 2,
  { apply csupr_le,
    rintros ⟨e, he⟩,
    simp only [subtype.coe_mk, le_div_iff' (zero_lt_two' ℝ), ← hf_dist],
    exact le_csupr h_bdd ⟨f e, hf_maps_to he⟩ },
  replace : c ≤ 0, { linarith },
  refine λ e hx hy, dist_le_zero.1 (le_trans _ this),
  exact le_csupr h_bdd ⟨e, hx, hy⟩
end

include F

/-- A bijective isometry sends midpoints to midpoints. -/
lemma map_midpoint (f : PE ≃ᵢ PF) (x y : PE) : f (midpoint ℝ x y) = midpoint ℝ (f x) (f y) :=
begin
  set e : PE ≃ᵢ PE :=
    ((f.trans $ (point_reflection ℝ $ midpoint ℝ (f x) (f y)).to_isometry_equiv).trans f.symm).trans
    (point_reflection ℝ $ midpoint ℝ x y).to_isometry_equiv,
  have hx : e x = x, by simp,
  have hy : e y = y, by simp,
  have hm := e.midpoint_fixed hx hy,
  simp only [e, trans_apply] at hm,
  rwa [← eq_symm_apply, to_isometry_equiv_symm, point_reflection_symm, coe_to_isometry_equiv,
    coe_to_isometry_equiv, point_reflection_self, symm_apply_eq, point_reflection_fixed_iff] at hm
end

/-!
Since `f : PE ≃ᵢ PF` sends midpoints to midpoints, it is an affine map.
We define a conversion to a `continuous_linear_equiv` first, then a conversion to an `affine_map`.
-/

/-- **Mazur-Ulam Theorem**: if `f` is an isometric bijection between two normed vector spaces
over `ℝ` and `f 0 = 0`, then `f` is a linear isometry equivalence. -/
def to_real_linear_isometry_equiv_of_map_zero (f : E ≃ᵢ F) (h0 : f 0 = 0) :
  E ≃ₗᵢ[ℝ] F :=
{ norm_map' := λ x, show ‖f x‖ = ‖x‖, by simp only [← dist_zero_right, ← h0, f.dist_eq],
  .. ((add_monoid_hom.of_map_midpoint ℝ ℝ f h0 f.map_midpoint).to_real_linear_map f.continuous),
  .. f }

@[simp] lemma coe_to_real_linear_equiv_of_map_zero (f : E ≃ᵢ F) (h0 : f 0 = 0) :
  ⇑(f.to_real_linear_isometry_equiv_of_map_zero h0) = f := rfl

@[simp] lemma coe_to_real_linear_equiv_of_map_zero_symm (f : E ≃ᵢ F) (h0 : f 0 = 0) :
  ⇑(f.to_real_linear_isometry_equiv_of_map_zero h0).symm = f.symm := rfl

/-- **Mazur-Ulam Theorem**: if `f` is an isometric bijection between two normed vector spaces
over `ℝ`, then `x ↦ f x - f 0` is a linear isometry equivalence. -/
def to_real_linear_isometry_equiv (f : E ≃ᵢ F) : E ≃ₗᵢ[ℝ] F :=
(f.trans (isometry_equiv.add_right (f 0)).symm).to_real_linear_isometry_equiv_of_map_zero
  (by simpa only [sub_eq_add_neg] using sub_self (f 0))

@[simp] lemma to_real_linear_equiv_apply (f : E ≃ᵢ F) (x : E) :
  (f.to_real_linear_isometry_equiv : E → F) x = f x - f 0 :=
(sub_eq_add_neg (f x) (f 0)).symm

@[simp] lemma to_real_linear_isometry_equiv_symm_apply (f : E ≃ᵢ F) (y : F) :
  (f.to_real_linear_isometry_equiv.symm : F → E) y = f.symm (y + f 0) := rfl

/-- **Mazur-Ulam Theorem**: if `f` is an isometric bijection between two normed add-torsors over
normed vector spaces over `ℝ`, then `f` is an affine isometry equivalence. -/
def to_real_affine_isometry_equiv (f : PE ≃ᵢ PF) : PE ≃ᵃⁱ[ℝ] PF :=
affine_isometry_equiv.mk' f
  (((vadd_const (classical.arbitrary PE)).trans $ f.trans
    (vadd_const (f $ classical.arbitrary PE)).symm).to_real_linear_isometry_equiv)
  (classical.arbitrary PE) (λ p, by simp)

@[simp] lemma coe_fn_to_real_affine_isometry_equiv (f : PE ≃ᵢ PF) :
  ⇑f.to_real_affine_isometry_equiv = f :=
rfl

@[simp] lemma coe_to_real_affine_isometry_equiv (f : PE ≃ᵢ PF) :
  f.to_real_affine_isometry_equiv.to_isometry_equiv = f :=
by { ext, refl }

end isometry_equiv


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.preserves.limits
import Mathlib.PostPort

universes v v₂ u

namespace Mathlib

namespace category_theory.limits

@[simp] theorem limit.lift_π_app {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (H : J ⥤ K ⥤ C) [has_limit H] (c : cone H) (j : J) (k : K) : nat_trans.app (limit.lift H c) k ≫ nat_trans.app (limit.π H j) k = nat_trans.app (nat_trans.app (cone.π c) j) k :=
  congr_app (limit.lift_π c j) k

@[simp] theorem colimit.ι_desc_app_assoc {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (H : J ⥤ K ⥤ C) [has_colimit H] (c : cocone H) (j : J) (k : K) {X' : C} (f' : functor.obj (cocone.X c) k ⟶ X') : nat_trans.app (colimit.ι H j) k ≫ nat_trans.app (colimit.desc H c) k ≫ f' =
  nat_trans.app (nat_trans.app (cocone.ι c) j) k ≫ f' := sorry

/--
The evaluation functors jointly reflect limits: that is, to show a cone is a limit of `F`
it suffices to show that each evaluation cone is a limit. In other words, to prove a cone is
limiting you can show it's pointwise limiting.
-/
def evaluation_jointly_reflects_limits {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] {F : J ⥤ K ⥤ C} (c : cone F) (t : (k : K) → is_limit (functor.map_cone (functor.obj (evaluation K C) k) c)) : is_limit c :=
  is_limit.mk
    fun (s : cone F) =>
      nat_trans.mk
        fun (k : K) =>
          is_limit.lift (t k)
            (cone.mk (functor.obj (cone.X s) k) (whisker_right (cone.π s) (functor.obj (evaluation K C) k)))

/--
Given a functor `F` and a collection of limit cones for each diagram `X ↦ F X k`, we can stitch
them together to give a cone for the diagram `F`.
`combined_is_limit` shows that the new cone is limiting, and `eval_combined` shows it is
(essentially) made up of the original cones.
-/
@[simp] theorem combine_cones_X_obj {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (F : J ⥤ K ⥤ C) (c : (k : K) → limit_cone (functor.obj (functor.flip F) k)) (k : K) : functor.obj (cone.X (combine_cones F c)) k = cone.X (limit_cone.cone (c k)) :=
  Eq.refl (functor.obj (cone.X (combine_cones F c)) k)

/-- The stitched together cones each project down to the original given cones (up to iso). -/
def evaluate_combined_cones {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (F : J ⥤ K ⥤ C) (c : (k : K) → limit_cone (functor.obj (functor.flip F) k)) (k : K) : functor.map_cone (functor.obj (evaluation K C) k) (combine_cones F c) ≅ limit_cone.cone (c k) :=
  cones.ext (iso.refl (cone.X (functor.map_cone (functor.obj (evaluation K C) k) (combine_cones F c)))) sorry

/-- Stitching together limiting cones gives a limiting cone. -/
def combined_is_limit {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (F : J ⥤ K ⥤ C) (c : (k : K) → limit_cone (functor.obj (functor.flip F) k)) : is_limit (combine_cones F c) :=
  evaluation_jointly_reflects_limits (combine_cones F c)
    fun (k : K) => is_limit.of_iso_limit (limit_cone.is_limit (c k)) (iso.symm (evaluate_combined_cones F c k))

/--
The evaluation functors jointly reflect colimits: that is, to show a cocone is a colimit of `F`
it suffices to show that each evaluation cocone is a colimit. In other words, to prove a cocone is
colimiting you can show it's pointwise colimiting.
-/
def evaluation_jointly_reflects_colimits {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] {F : J ⥤ K ⥤ C} (c : cocone F) (t : (k : K) → is_colimit (functor.map_cocone (functor.obj (evaluation K C) k) c)) : is_colimit c :=
  is_colimit.mk
    fun (s : cocone F) =>
      nat_trans.mk
        fun (k : K) =>
          is_colimit.desc (t k)
            (cocone.mk (functor.obj (cocone.X s) k) (whisker_right (cocone.ι s) (functor.obj (evaluation K C) k)))

/--
Given a functor `F` and a collection of colimit cocones for each diagram `X ↦ F X k`, we can stitch
them together to give a cocone for the diagram `F`.
`combined_is_colimit` shows that the new cocone is colimiting, and `eval_combined` shows it is
(essentially) made up of the original cocones.
-/
def combine_cocones {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (F : J ⥤ K ⥤ C) (c : (k : K) → colimit_cocone (functor.obj (functor.flip F) k)) : cocone F :=
  cocone.mk
    (functor.mk (fun (k : K) => cocone.X (colimit_cocone.cocone (c k)))
      fun (k₁ k₂ : K) (f : k₁ ⟶ k₂) =>
        is_colimit.desc (colimit_cocone.is_colimit (c k₁))
          (cocone.mk (cocone.X (colimit_cocone.cocone (c k₂)))
            (functor.map (functor.flip F) f ≫ cocone.ι (colimit_cocone.cocone (c k₂)))))
    (nat_trans.mk fun (j : J) => nat_trans.mk fun (k : K) => nat_trans.app (cocone.ι (colimit_cocone.cocone (c k))) j)

/-- The stitched together cocones each project down to the original given cocones (up to iso). -/
def evaluate_combined_cocones {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (F : J ⥤ K ⥤ C) (c : (k : K) → colimit_cocone (functor.obj (functor.flip F) k)) (k : K) : functor.map_cocone (functor.obj (evaluation K C) k) (combine_cocones F c) ≅ colimit_cocone.cocone (c k) :=
  cocones.ext (iso.refl (cocone.X (functor.map_cocone (functor.obj (evaluation K C) k) (combine_cocones F c)))) sorry

/-- Stitching together colimiting cocones gives a colimiting cocone. -/
def combined_is_colimit {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] (F : J ⥤ K ⥤ C) (c : (k : K) → colimit_cocone (functor.obj (functor.flip F) k)) : is_colimit (combine_cocones F c) :=
  evaluation_jointly_reflects_colimits (combine_cocones F c)
    fun (k : K) =>
      is_colimit.of_iso_colimit (colimit_cocone.is_colimit (c k)) (iso.symm (evaluate_combined_cocones F c k))

protected instance functor_category_has_limits_of_shape {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_limits_of_shape J C] : has_limits_of_shape J (K ⥤ C) :=
  has_limits_of_shape.mk
    fun (F : J ⥤ K ⥤ C) =>
      has_limit.mk
        (limit_cone.mk (combine_cones F fun (k : K) => get_limit_cone (functor.obj (functor.flip F) k))
          (combined_is_limit F fun (k : K) => get_limit_cone (functor.obj (functor.flip F) k)))

protected instance functor_category_has_colimits_of_shape {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_colimits_of_shape J C] : has_colimits_of_shape J (K ⥤ C) :=
  has_colimits_of_shape.mk
    fun (F : J ⥤ K ⥤ C) =>
      has_colimit.mk
        (colimit_cocone.mk (combine_cocones F fun (k : K) => get_colimit_cocone (functor.obj (functor.flip F) k))
          (combined_is_colimit F fun (k : K) => get_colimit_cocone (functor.obj (functor.flip F) k)))

protected instance functor_category_has_limits {C : Type u} [category C] {K : Type v} [category K] [has_limits C] : has_limits (K ⥤ C) :=
  has_limits.mk fun (J : Type v) (𝒥 : small_category J) => limits.functor_category_has_limits_of_shape

protected instance functor_category_has_colimits {C : Type u} [category C] {K : Type v} [category K] [has_colimits C] : has_colimits (K ⥤ C) :=
  has_colimits.mk fun (J : Type v) (𝒥 : small_category J) => limits.functor_category_has_colimits_of_shape

protected instance evaluation_preserves_limits_of_shape {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_limits_of_shape J C] (k : K) : preserves_limits_of_shape J (functor.obj (evaluation K C) k) :=
  preserves_limits_of_shape.mk
    fun (F : J ⥤ K ⥤ C) =>
      preserves_limit_of_preserves_limit_cone
        (combined_is_limit F fun (k : K) => get_limit_cone (F ⋙ functor.obj (evaluation K C) k))
        (is_limit.of_iso_limit (limit.is_limit (F ⋙ functor.obj (evaluation K C) k))
          (iso.symm (evaluate_combined_cones F (fun (k : K) => get_limit_cone (F ⋙ functor.obj (evaluation K C) k)) k)))

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a limit,
then the evaluation of that limit at `k` is the limit of the evaluations of `F.obj j` at `k`.
-/
def limit_obj_iso_limit_comp_evaluation {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) : functor.obj (limit F) k ≅ limit (F ⋙ functor.obj (evaluation K C) k) :=
  preserves_limit_iso (functor.obj (evaluation K C) k) F

@[simp] theorem limit_obj_iso_limit_comp_evaluation_hom_π {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) (j : J) (k : K) : iso.hom (limit_obj_iso_limit_comp_evaluation F k) ≫ limit.π (F ⋙ functor.obj (evaluation K C) k) j =
  nat_trans.app (limit.π F j) k := sorry

@[simp] theorem limit_obj_iso_limit_comp_evaluation_inv_π_app_assoc {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_limits_of_shape J C] (F : J ⥤ K ⥤ C) (j : J) (k : K) {X' : C} (f' : functor.obj (functor.obj F j) k ⟶ X') : iso.inv (limit_obj_iso_limit_comp_evaluation F k) ≫ nat_trans.app (limit.π F j) k ≫ f' =
  limit.π (F ⋙ functor.obj (evaluation K C) k) j ≫ f' := sorry

theorem limit_obj_ext {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] {H : J ⥤ K ⥤ C} [has_limits_of_shape J C] {k : K} {W : C} {f : W ⟶ functor.obj (limit H) k} {g : W ⟶ functor.obj (limit H) k} (w : ∀ (j : J), f ≫ nat_trans.app (limit.π H j) k = g ≫ nat_trans.app (limit.π H j) k) : f = g := sorry

protected instance evaluation_preserves_colimits_of_shape {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_colimits_of_shape J C] (k : K) : preserves_colimits_of_shape J (functor.obj (evaluation K C) k) :=
  preserves_colimits_of_shape.mk
    fun (F : J ⥤ K ⥤ C) =>
      preserves_colimit_of_preserves_colimit_cocone
        (combined_is_colimit F fun (k : K) => get_colimit_cocone (F ⋙ functor.obj (evaluation K C) k))
        (is_colimit.of_iso_colimit (colimit.is_colimit (F ⋙ functor.obj (evaluation K C) k))
          (iso.symm
            (evaluate_combined_cocones F (fun (k : K) => get_colimit_cocone (F ⋙ functor.obj (evaluation K C) k)) k)))

/--
If `F : J ⥤ K ⥤ C` is a functor into a functor category which has a colimit,
then the evaluation of that colimit at `k` is the colimit of the evaluations of `F.obj j` at `k`.
-/
def colimit_obj_iso_colimit_comp_evaluation {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) (k : K) : functor.obj (colimit F) k ≅ colimit (F ⋙ functor.obj (evaluation K C) k) :=
  preserves_colimit_iso (functor.obj (evaluation K C) k) F

@[simp] theorem colimit_obj_iso_colimit_comp_evaluation_ι_inv {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) (j : J) (k : K) : colimit.ι (F ⋙ functor.obj (evaluation K C) k) j ≫ iso.inv (colimit_obj_iso_colimit_comp_evaluation F k) =
  nat_trans.app (colimit.ι F j) k := sorry

@[simp] theorem colimit_obj_iso_colimit_comp_evaluation_ι_app_hom {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] [has_colimits_of_shape J C] (F : J ⥤ K ⥤ C) (j : J) (k : K) : nat_trans.app (colimit.ι F j) k ≫ iso.hom (colimit_obj_iso_colimit_comp_evaluation F k) =
  colimit.ι (F ⋙ functor.obj (evaluation K C) k) j := sorry

theorem colimit_obj_ext {C : Type u} [category C] {J : Type v} {K : Type v} [small_category J] [category K] {H : J ⥤ K ⥤ C} [has_colimits_of_shape J C] {k : K} {W : C} {f : functor.obj (colimit H) k ⟶ W} {g : functor.obj (colimit H) k ⟶ W} (w : ∀ (j : J), nat_trans.app (colimit.ι H j) k ≫ f = nat_trans.app (colimit.ι H j) k ≫ g) : f = g := sorry

protected instance evaluation_preserves_limits {C : Type u} [category C] {K : Type v} [category K] [has_limits C] (k : K) : preserves_limits (functor.obj (evaluation K C) k) :=
  preserves_limits.mk fun (J : Type v) (𝒥 : small_category J) => limits.evaluation_preserves_limits_of_shape k

protected instance evaluation_preserves_colimits {C : Type u} [category C] {K : Type v} [category K] [has_colimits C] (k : K) : preserves_colimits (functor.obj (evaluation K C) k) :=
  preserves_colimits.mk fun (J : Type v) (𝒥 : small_category J) => limits.evaluation_preserves_colimits_of_shape k