<|start_filename|>src/category_theory/noetherian.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.subobject.lattice
import category_theory.essentially_small
import category_theory.simple

/-!
# Artinian and noetherian categories

An artinian category is a category in which objects do not
have infinite decreasing sequences of subobjects.

A noetherian category is a category in which objects do not
have infinite increasing sequences of subobjects.

We show that any nonzero artinian object has a simple subobject.

## Future work
The Jordan-Hölder theorem, following https://stacks.math.columbia.edu/tag/0FCK.
-/

namespace category_theory
open category_theory.limits

variables {C : Type*} [category C]

/--
A noetherian object is an object
which does not have infinite increasing sequences of subobjects.

See https://stacks.math.columbia.edu/tag/0FCG
-/
class noetherian_object (X : C) : Prop :=
(subobject_gt_well_founded : well_founded ((>) : subobject X → subobject X → Prop))

/--
An artinian object is an object
which does not have infinite decreasing sequences of subobjects.

See https://stacks.math.columbia.edu/tag/0FCF
-/
class artinian_object (X : C) : Prop :=
(subobject_lt_well_founded [] : well_founded ((<) : subobject X → subobject X → Prop))

variables (C)

/-- A category is noetherian if it is essentially small and all objects are noetherian. -/
class noetherian extends essentially_small C :=
(noetherian_object : ∀ (X : C), noetherian_object X)

attribute [priority 100, instance] noetherian.noetherian_object

/-- A category is artinian if it is essentially small and all objects are artinian. -/
class artinian extends essentially_small C :=
(artinian_object : ∀ (X : C), artinian_object X)

attribute [priority 100, instance] artinian.artinian_object

variables {C}

open subobject
variables [has_zero_morphisms C] [has_zero_object C]

lemma exists_simple_subobject {X : C} [artinian_object X] (h : ¬ is_zero X) :
  ∃ (Y : subobject X), simple (Y : C) :=
begin
  haveI : nontrivial (subobject X) := nontrivial_of_not_is_zero h,
  haveI := is_atomic_of_order_bot_well_founded_lt (artinian_object.subobject_lt_well_founded X),
  have := is_atomic.eq_bot_or_exists_atom_le (⊤ : subobject X),
  obtain ⟨Y, s⟩ := (is_atomic.eq_bot_or_exists_atom_le (⊤ : subobject X)).resolve_left top_ne_bot,
  exact ⟨Y, (subobject_simple_iff_is_atom _).mpr s.1⟩,
end

/-- Choose an arbitrary simple subobject of a non-zero artinian object. -/
noncomputable def simple_subobject {X : C} [artinian_object X] (h : ¬ is_zero X) : C :=
(exists_simple_subobject h).some

/-- The monomorphism from the arbitrary simple subobject of a non-zero artinian object. -/
@[derive mono]
noncomputable def simple_subobject_arrow {X : C} [artinian_object X] (h : ¬ is_zero X) :
  simple_subobject h ⟶ X :=
(exists_simple_subobject h).some.arrow

instance {X : C} [artinian_object X] (h : ¬ is_zero X) : simple (simple_subobject h) :=
(exists_simple_subobject h).some_spec

end category_theory


<|start_filename|>src/analysis/normed_space/pi_Lp.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.mean_inequalities

/-!
# `L^p` distance on finite products of metric spaces
Given finitely many metric spaces, one can put the max distance on their product, but there is also
a whole family of natural distances, indexed by a real parameter `p ∈ [1, ∞)`, that also induce
the product topology. We define them in this file. The distance on `Π i, α i` is given by
$$
d(x, y) = \left(\sum d(x_i, y_i)^p\right)^{1/p}.
$$

We give instances of this construction for emetric spaces, metric spaces, normed groups and normed
spaces.

To avoid conflicting instances, all these are defined on a copy of the original Pi type, named
`pi_Lp p α`. The assumpion `[fact (1 ≤ p)]` is required for the metric and normed space instances.

We ensure that the topology and uniform structure on `pi_Lp p α` are (defeq to) the product
topology and product uniformity, to be able to use freely continuity statements for the coordinate
functions, for instance.

## Implementation notes

We only deal with the `L^p` distance on a product of finitely many metric spaces, which may be
distinct. A closely related construction is `lp`, the `L^p` norm on a product of (possibly
infinitely many) normed spaces, where the norm is
$$
\left(\sum ∥f (x)∥^p \right)^{1/p}.
$$
However, the topology induced by this construction is not the product topology, and some functions
have infinite `L^p` norm. These subtleties are not present in the case of finitely many metric
spaces, hence it is worth devoting a file to this specific case which is particularly well behaved.

Another related construction is `measure_theory.Lp`, the `L^p` norm on the space of functions from
a measure space to a normed space, where the norm is
$$
\left(\int ∥f (x)∥^p dμ\right)^{1/p}.
$$
This has all the same subtleties as `lp`, and the further subtlety that this only
defines a seminorm (as almost everywhere zero functions have zero `L^p` norm).
The construction `pi_Lp` corresponds to the special case of `measure_theory.Lp` in which the basis
is a finite space equipped with the counting measure.

To prove that the topology (and the uniform structure) on a finite product with the `L^p` distance
are the same as those coming from the `L^∞` distance, we could argue that the `L^p` and `L^∞` norms
are equivalent on `ℝ^n` for abstract (norm equivalence) reasons. Instead, we give a more explicit
(easy) proof which provides a comparison between these two norms with explicit constants.

We also set up the theory for `pseudo_emetric_space` and `pseudo_metric_space`.
-/

open real set filter is_R_or_C bornology
open_locale big_operators uniformity topological_space nnreal ennreal

noncomputable theory

variables {ι : Type*}

/-- A copy of a Pi type, on which we will put the `L^p` distance. Since the Pi type itself is
already endowed with the `L^∞` distance, we need the type synonym to avoid confusing typeclass
resolution. Also, we let it depend on `p`, to get a whole family of type on which we can put
different distances. -/
@[nolint unused_arguments]
def pi_Lp {ι : Type*} (p : ℝ) (α : ι → Type*) : Type* := Π (i : ι), α i

instance {ι : Type*} (p : ℝ) (α : ι → Type*) [Π i, inhabited (α i)] : inhabited (pi_Lp p α) :=
⟨λ i, default⟩

instance fact_one_le_one_real : fact ((1:ℝ) ≤ 1) := ⟨rfl.le⟩
instance fact_one_le_two_real : fact ((1:ℝ) ≤ 2) := ⟨one_le_two⟩

namespace pi_Lp

variables (p : ℝ) [fact_one_le_p : fact (1 ≤ p)] (𝕜 : Type*) (α : ι → Type*) (β : ι → Type*)

/-- Canonical bijection between `pi_Lp p α` and the original Pi type. We introduce it to be able
to compare the `L^p` and `L^∞` distances through it. -/
protected def equiv : pi_Lp p α ≃ Π (i : ι), α i :=
equiv.refl _

lemma equiv_apply (x : pi_Lp p α) (i : ι) : pi_Lp.equiv p α x i = x i := rfl
lemma equiv_symm_apply (x : Π i, α i) (i : ι) : (pi_Lp.equiv p α).symm x i = x i := rfl

@[simp] lemma equiv_apply' (x : pi_Lp p α) : pi_Lp.equiv p α x = x := rfl
@[simp] lemma equiv_symm_apply' (x : Π i, α i) : (pi_Lp.equiv p α).symm x = x := rfl

section
/-!
### The uniformity on finite `L^p` products is the product uniformity

In this section, we put the `L^p` edistance on `pi_Lp p α`, and we check that the uniformity
coming from this edistance coincides with the product uniformity, by showing that the canonical
map to the Pi type (with the `L^∞` distance) is a uniform embedding, as it is both Lipschitz and
antiLipschitz.

We only register this emetric space structure as a temporary instance, as the true instance (to be
registered later) will have as uniformity exactly the product uniformity, instead of the one coming
from the edistance (which is equal to it, but not defeq). See Note [forgetful inheritance]
explaining why having definitionally the right uniformity is often important.
-/

variables [Π i, pseudo_metric_space (α i)] [Π i, pseudo_emetric_space (β i)] [fintype ι]

include fact_one_le_p

private lemma pos : 0 < p := zero_lt_one.trans_le fact_one_le_p.out

/-- Endowing the space `pi_Lp p β` with the `L^p` pseudoedistance. This definition is not
satisfactory, as it does not register the fact that the topology and the uniform structure coincide
with the product one. Therefore, we do not register it as an instance. Using this as a temporary
pseudoemetric space instance, we will show that the uniform structure is equal (but not defeq) to
the product one, and then register an instance in which we replace the uniform structure by the
product one using this pseudoemetric space and `pseudo_emetric_space.replace_uniformity`. -/
def pseudo_emetric_aux : pseudo_emetric_space (pi_Lp p β) :=
{ edist          := λ f g, (∑ i, edist (f i) (g i) ^ p) ^ (1/p),
  edist_self     := λ f, by simp [edist, ennreal.zero_rpow_of_pos (pos p),
    ennreal.zero_rpow_of_pos (inv_pos.2 $ pos p)],
  edist_comm     := λ f g, by simp [edist, edist_comm],
  edist_triangle := λ f g h, calc
    (∑ i, edist (f i) (h i) ^ p) ^ (1 / p) ≤
    (∑ i, (edist (f i) (g i) + edist (g i) (h i)) ^ p) ^ (1 / p) :
    begin
      apply ennreal.rpow_le_rpow _ (one_div_nonneg.2 (pos p).le),
      refine finset.sum_le_sum (λ i hi, _),
      exact ennreal.rpow_le_rpow (edist_triangle _ _ _) (pos p).le
    end
    ... ≤
    (∑ i, edist (f i) (g i) ^ p) ^ (1 / p) + (∑ i, edist (g i) (h i) ^ p) ^ (1 / p) :
      ennreal.Lp_add_le _ _ _ fact_one_le_p.out }

local attribute [instance] pi_Lp.pseudo_emetric_aux

/-- Endowing the space `pi_Lp p β` with the `L^p` pseudodistance. This definition is not
satisfactory, as it does not register the fact that the topology, the uniform structure, and the
bornology coincide with the product ones. Therefore, we do not register it as an instance. Using
this as a temporary pseudoemetric space instance, we will show that the uniform structure is equal
(but not defeq) to the product one, and then register an instance in which we replace the uniform
structure and the bornology by the product ones using this pseudometric space,
`pseudo_metric_space.replace_uniformity`, and `pseudo_metric_space.replace_bornology`.

See note [reducible non-instances] -/
@[reducible] def pseudo_metric_aux : pseudo_metric_space (pi_Lp p α) :=
pseudo_emetric_space.to_pseudo_metric_space_of_dist
  (λ f g, (∑ i, dist (f i) (g i) ^ p) ^ (1/p))
  (λ f g, ennreal.rpow_ne_top_of_nonneg (one_div_nonneg.2 (pos p).le) $ ne_of_lt $
    (ennreal.sum_lt_top $ λ i hi, ennreal.rpow_ne_top_of_nonneg (pos p).le (edist_ne_top _ _)))
  (λ f g,
    have A : ∀ i, edist (f i) (g i) ^ p ≠ ⊤,
      from λ i, ennreal.rpow_ne_top_of_nonneg (pos p).le (edist_ne_top _ _),
    have B : edist f g = (∑ i, edist (f i) (g i) ^ p) ^ (1/p), from rfl,
    by simp only [B, dist_edist, ennreal.to_real_rpow, ← ennreal.to_real_sum (λ i _, A i)])

local attribute [instance] pi_Lp.pseudo_metric_aux

lemma lipschitz_with_equiv_aux : lipschitz_with 1 (pi_Lp.equiv p β) :=
begin
  have cancel : p * (1/p) = 1 := mul_div_cancel' 1 (pos p).ne',
  assume x y,
  simp only [edist, forall_prop_of_true, one_mul, finset.mem_univ, finset.sup_le_iff,
             ennreal.coe_one],
  assume i,
  calc
  edist (x i) (y i) = (edist (x i) (y i) ^ p) ^ (1/p) :
    by simp [← ennreal.rpow_mul, cancel, -one_div]
  ... ≤ (∑ i, edist (x i) (y i) ^ p) ^ (1 / p) :
  begin
    apply ennreal.rpow_le_rpow _ (one_div_nonneg.2 $ (pos p).le),
    exact finset.single_le_sum (λ i hi, (bot_le : (0 : ℝ≥0∞) ≤ _)) (finset.mem_univ i)
  end
end

lemma antilipschitz_with_equiv_aux :
  antilipschitz_with ((fintype.card ι : ℝ≥0) ^ (1/p)) (pi_Lp.equiv p β) :=
begin
  have pos : 0 < p := lt_of_lt_of_le zero_lt_one fact_one_le_p.out,
  have nonneg : 0 ≤ 1 / p := one_div_nonneg.2 (le_of_lt pos),
  have cancel : p * (1/p) = 1 := mul_div_cancel' 1 (ne_of_gt pos),
  assume x y,
  simp [edist, -one_div],
  calc (∑ i, edist (x i) (y i) ^ p) ^ (1 / p) ≤
  (∑ i, edist (pi_Lp.equiv p β x) (pi_Lp.equiv p β y) ^ p) ^ (1 / p) :
  begin
    apply ennreal.rpow_le_rpow _ nonneg,
    apply finset.sum_le_sum (λ i hi, _),
    apply ennreal.rpow_le_rpow _ (le_of_lt pos),
    exact finset.le_sup (finset.mem_univ i)
  end
  ... = (((fintype.card ι : ℝ≥0)) ^ (1/p) : ℝ≥0) *
    edist (pi_Lp.equiv p β x) (pi_Lp.equiv p β y) :
  begin
    simp only [nsmul_eq_mul, finset.card_univ, ennreal.rpow_one, finset.sum_const,
      ennreal.mul_rpow_of_nonneg _ _ nonneg, ←ennreal.rpow_mul, cancel],
    have : (fintype.card ι : ℝ≥0∞) = (fintype.card ι : ℝ≥0) :=
      (ennreal.coe_nat (fintype.card ι)).symm,
    rw [this, ennreal.coe_rpow_of_nonneg _ nonneg]
  end
end

lemma aux_uniformity_eq :
  𝓤 (pi_Lp p β) = @uniformity _ (Pi.uniform_space _) :=
begin
  have A : uniform_inducing (pi_Lp.equiv p β) :=
    (antilipschitz_with_equiv_aux p β).uniform_inducing
    (lipschitz_with_equiv_aux p β).uniform_continuous,
  have : (λ (x : pi_Lp p β × pi_Lp p β),
    ((pi_Lp.equiv p β) x.fst, (pi_Lp.equiv p β) x.snd)) = id,
    by ext i; refl,
  rw [← A.comap_uniformity, this, comap_id]
end

lemma aux_cobounded_eq :
  cobounded (pi_Lp p α) = @cobounded _ pi.bornology :=
calc cobounded (pi_Lp p α) = comap (pi_Lp.equiv p α) (cobounded _) :
  le_antisymm (antilipschitz_with_equiv_aux p α).tendsto_cobounded.le_comap
    (lipschitz_with_equiv_aux p α).comap_cobounded_le
... = _ : comap_id

end

/-! ### Instances on finite `L^p` products -/

instance uniform_space [Π i, uniform_space (β i)] : uniform_space (pi_Lp p β) :=
Pi.uniform_space _

variable [fintype ι]

instance bornology [Π i, bornology (β i)] : bornology (pi_Lp p β) := pi.bornology

include fact_one_le_p

/-- pseudoemetric space instance on the product of finitely many pseudoemetric spaces, using the
`L^p` pseudoedistance, and having as uniformity the product uniformity. -/
instance [Π i, pseudo_emetric_space (β i)] : pseudo_emetric_space (pi_Lp p β) :=
(pseudo_emetric_aux p β).replace_uniformity (aux_uniformity_eq p β).symm

/-- emetric space instance on the product of finitely many emetric spaces, using the `L^p`
edistance, and having as uniformity the product uniformity. -/
instance [Π i, emetric_space (α i)] : emetric_space (pi_Lp p α) :=
@emetric.of_t0_pseudo_emetric_space (pi_Lp p α) _ pi.t0_space

variables {p β}
lemma edist_eq [Π i, pseudo_emetric_space (β i)] (x y : pi_Lp p β) :
  edist x y = (∑ i, edist (x i) (y i) ^ p) ^ (1/p) := rfl
variables (p β)

/-- pseudometric space instance on the product of finitely many psuedometric spaces, using the
`L^p` distance, and having as uniformity the product uniformity. -/
instance [Π i, pseudo_metric_space (β i)] : pseudo_metric_space (pi_Lp p β) :=
((pseudo_metric_aux p β).replace_uniformity (aux_uniformity_eq p β).symm).replace_bornology $
  λ s, filter.ext_iff.1 (aux_cobounded_eq p β).symm sᶜ

/-- metric space instance on the product of finitely many metric spaces, using the `L^p` distance,
and having as uniformity the product uniformity. -/
instance [Π i, metric_space (α i)] : metric_space (pi_Lp p α) := metric.of_t0_pseudo_metric_space _

omit fact_one_le_p
lemma dist_eq {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [Π i, pseudo_metric_space (β i)] (x y : pi_Lp p β) :
  dist x y = (∑ i : ι, dist (x i) (y i) ^ p) ^ (1/p) := rfl

lemma nndist_eq {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [Π i, pseudo_metric_space (β i)] (x y : pi_Lp p β) :
  nndist x y = (∑ i : ι, nndist (x i) (y i) ^ p) ^ (1/p) :=
subtype.ext $ by { push_cast, exact dist_eq _ _ }

include fact_one_le_p

lemma lipschitz_with_equiv [Π i, pseudo_emetric_space (β i)] :
  lipschitz_with 1 (pi_Lp.equiv p β) :=
lipschitz_with_equiv_aux p β

lemma antilipschitz_with_equiv [Π i, pseudo_emetric_space (β i)] :
  antilipschitz_with ((fintype.card ι : ℝ≥0) ^ (1/p)) (pi_Lp.equiv p β) :=
antilipschitz_with_equiv_aux p β

/-- seminormed group instance on the product of finitely many normed groups, using the `L^p`
norm. -/
instance semi_normed_group [Π i, semi_normed_group (β i)] : semi_normed_group (pi_Lp p β) :=
{ norm := λf, (∑ i, ∥f i∥ ^ p) ^ (1/p),
  dist_eq := λ x y, by simp [pi_Lp.dist_eq, dist_eq_norm, sub_eq_add_neg],
  .. pi.add_comm_group }

/-- normed group instance on the product of finitely many normed groups, using the `L^p` norm. -/
instance normed_group [Π i, normed_group (α i)] : normed_group (pi_Lp p α) :=
{ ..pi_Lp.semi_normed_group p α }

omit fact_one_le_p
lemma norm_eq {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [Π i, semi_normed_group (β i)] (f : pi_Lp p β) :
  ∥f∥ = (∑ i, ∥f i∥ ^ p) ^ (1/p) := rfl

lemma nnnorm_eq {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [Π i, semi_normed_group (β i)] (f : pi_Lp p β) :
  ∥f∥₊ = (∑ i, ∥f i∥₊ ^ p) ^ (1/p) :=
by { ext, simp [nnreal.coe_sum, norm_eq] }

lemma norm_eq_of_nat {p : ℝ} [fact (1 ≤ p)] {β : ι → Type*}
  [Π i, semi_normed_group (β i)] (n : ℕ) (h : p = n) (f : pi_Lp p β) :
  ∥f∥ = (∑ i, ∥f i∥ ^ n) ^ (1/(n : ℝ)) :=
by simp [norm_eq, h, real.sqrt_eq_rpow, ←real.rpow_nat_cast]

lemma norm_eq_of_L2 {β : ι → Type*} [Π i, semi_normed_group (β i)] (x : pi_Lp 2 β) :
  ∥x∥ = sqrt (∑ (i : ι), ∥x i∥ ^ 2) :=
by { rw [norm_eq_of_nat 2]; simp [sqrt_eq_rpow] }

lemma nnnorm_eq_of_L2 {β : ι → Type*} [Π i, semi_normed_group (β i)] (x : pi_Lp 2 β) :
  ∥x∥₊ = nnreal.sqrt (∑ (i : ι), ∥x i∥₊ ^ 2) :=
subtype.ext $ by { push_cast, exact norm_eq_of_L2 x }

lemma dist_eq_of_L2 {β : ι → Type*} [Π i, semi_normed_group (β i)] (x y : pi_Lp 2 β) :
  dist x y = (∑ i, dist (x i) (y i) ^ 2).sqrt :=
by simp_rw [dist_eq_norm, norm_eq_of_L2, pi.sub_apply]

lemma nndist_eq_of_L2 {β : ι → Type*} [Π i, semi_normed_group (β i)] (x y : pi_Lp 2 β) :
  nndist x y = (∑ i, nndist (x i) (y i) ^ 2).sqrt :=
subtype.ext $ by { push_cast, exact dist_eq_of_L2 _ _ }

lemma edist_eq_of_L2 {β : ι → Type*} [Π i, semi_normed_group (β i)] (x y : pi_Lp 2 β) :
  edist x y = (∑ i, edist (x i) (y i) ^ 2) ^ (1 / 2 : ℝ) :=
by simp_rw [pi_Lp.edist_eq, ennreal.rpow_two]

include fact_one_le_p

variables [normed_field 𝕜]

/-- The product of finitely many normed spaces is a normed space, with the `L^p` norm. -/
instance normed_space [Π i, semi_normed_group (β i)] [Π i, normed_space 𝕜 (β i)] :
  normed_space 𝕜 (pi_Lp p β) :=
{ norm_smul_le :=
  begin
    assume c f,
    have : p * (1 / p) = 1 := mul_div_cancel' 1 (lt_of_lt_of_le zero_lt_one fact_one_le_p.out).ne',
    simp only [pi_Lp.norm_eq, norm_smul, mul_rpow, norm_nonneg, ←finset.mul_sum, pi.smul_apply],
    rw [mul_rpow (rpow_nonneg_of_nonneg (norm_nonneg _) _), ← rpow_mul (norm_nonneg _),
        this, rpow_one],
    exact finset.sum_nonneg (λ i hi, rpow_nonneg_of_nonneg (norm_nonneg _) _)
  end,
  .. pi.module ι β 𝕜 }

/- Register simplification lemmas for the applications of `pi_Lp` elements, as the usual lemmas
for Pi types will not trigger. -/
variables {𝕜 p α} [Π i, semi_normed_group (β i)] [Π i, normed_space 𝕜 (β i)] (c : 𝕜)
variables (x y : pi_Lp p β) (x' y' : Π i, β i) (i : ι)

@[simp] lemma zero_apply : (0 : pi_Lp p β) i = 0 := rfl
@[simp] lemma add_apply : (x + y) i = x i + y i := rfl
@[simp] lemma sub_apply : (x - y) i = x i - y i := rfl
@[simp] lemma smul_apply : (c • x) i = c • x i := rfl
@[simp] lemma neg_apply : (-x) i = - (x i) := rfl

@[simp] lemma equiv_zero : pi_Lp.equiv p β 0 = 0 := rfl
@[simp] lemma equiv_symm_zero : (pi_Lp.equiv p β).symm 0 = 0 := rfl

@[simp] lemma equiv_add :
  pi_Lp.equiv p β (x + y) = pi_Lp.equiv p β x + pi_Lp.equiv p β y := rfl
@[simp] lemma equiv_symm_add :
  (pi_Lp.equiv p β).symm (x' + y') = (pi_Lp.equiv p β).symm x' + (pi_Lp.equiv p β).symm y' := rfl

@[simp] lemma equiv_sub : pi_Lp.equiv p β (x - y) = pi_Lp.equiv p β x - pi_Lp.equiv p β y := rfl
@[simp] lemma equiv_symm_sub :
  (pi_Lp.equiv p β).symm (x' - y') = (pi_Lp.equiv p β).symm x' - (pi_Lp.equiv p β).symm y' := rfl

@[simp] lemma equiv_neg : pi_Lp.equiv p β (-x) = -pi_Lp.equiv p β x := rfl
@[simp] lemma equiv_symm_neg : (pi_Lp.equiv p β).symm (-x') = -(pi_Lp.equiv p β).symm x' := rfl

@[simp] lemma equiv_smul : pi_Lp.equiv p β (c • x) = c • pi_Lp.equiv p β x := rfl
@[simp] lemma equiv_symm_smul :
  (pi_Lp.equiv p β).symm (c • x') = c • (pi_Lp.equiv p β).symm x' := rfl

lemma nnnorm_equiv_symm_const {β} [semi_normed_group β] (b : β) :
  ∥(pi_Lp.equiv p (λ _ : ι, β)).symm (function.const _ b)∥₊ = fintype.card ι ^ (1 / p) * ∥b∥₊ :=
begin
  have : p ≠ 0 := (zero_lt_one.trans_le (fact.out $ 1 ≤ p)).ne',
  simp_rw [pi_Lp.nnnorm_eq, equiv_symm_apply, function.const_apply, finset.sum_const,
    finset.card_univ, nsmul_eq_mul, nnreal.mul_rpow, ←nnreal.rpow_mul, mul_one_div_cancel this,
    nnreal.rpow_one],
end

lemma norm_equiv_symm_const {β} [semi_normed_group β] (b : β) :
  ∥(pi_Lp.equiv p (λ _ : ι, β)).symm (function.const _ b)∥ = fintype.card ι ^ (1 / p) * ∥b∥ :=
(congr_arg coe $ nnnorm_equiv_symm_const b).trans $ by simp

lemma nnnorm_equiv_symm_one {β} [semi_normed_group β] [has_one β] :
  ∥(pi_Lp.equiv p (λ _ : ι, β)).symm 1∥₊ = fintype.card ι ^ (1 / p) * ∥(1 : β)∥₊ :=
(nnnorm_equiv_symm_const (1 : β)).trans rfl

lemma norm_equiv_symm_one {β} [semi_normed_group β] [has_one β] :
  ∥(pi_Lp.equiv p (λ _ : ι, β)).symm 1∥ = fintype.card ι ^ (1 / p) * ∥(1 : β)∥ :=
(norm_equiv_symm_const (1 : β)).trans rfl

variables (𝕜)

/-- `pi_Lp.equiv` as a linear map. -/
@[simps {fully_applied := ff}]
protected def linear_equiv : pi_Lp p β ≃ₗ[𝕜] Π i, β i :=
{ to_fun := pi_Lp.equiv _ _,
  inv_fun := (pi_Lp.equiv _ _).symm,
  ..linear_equiv.refl _ _}

end pi_Lp


<|start_filename|>src/data/finset/card.lean<|end_filename|>
/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import data.finset.basic
import tactic.by_contra

/-!
# Cardinality of a finite set

This defines the cardinality of a `finset` and provides induction principles for finsets.

## Main declarations

* `finset.card`: `s.card : ℕ` returns the cardinality of `s : finset α`.

### Induction principles

* `finset.strong_induction`: Strong induction
* `finset.strong_induction_on`
* `finset.strong_downward_induction`
* `finset.strong_downward_induction_on`
* `finset.case_strong_induction_on`

## TODO

Should we add a noncomputable version?
-/

open function multiset nat

variables {α β : Type*}

namespace finset
variables {s t : finset α} {a b : α}

/-- `s.card` is the number of elements of `s`, aka its cardinality. -/
def card (s : finset α) : ℕ := s.1.card

lemma card_def (s : finset α) : s.card = s.1.card := rfl

@[simp] lemma card_mk {m nodup} : (⟨m, nodup⟩ : finset α).card = m.card := rfl

@[simp] lemma card_empty : card (∅ : finset α) = 0 := rfl

lemma card_le_of_subset : s ⊆ t → s.card ≤ t.card := multiset.card_le_of_le ∘ val_le_iff.mpr

@[mono] lemma card_mono : monotone (@card α) := by apply card_le_of_subset

@[simp] lemma card_eq_zero : s.card = 0 ↔ s = ∅ := card_eq_zero.trans val_eq_zero

lemma card_pos : 0 < s.card ↔ s.nonempty :=
pos_iff_ne_zero.trans $ (not_congr card_eq_zero).trans nonempty_iff_ne_empty.symm

alias finset.card_pos ↔ _ finset.nonempty.card_pos

lemma card_ne_zero_of_mem (h : a ∈ s) : s.card ≠ 0 := (not_congr card_eq_zero).2 $ ne_empty_of_mem h

@[simp] lemma card_singleton (a : α) : card ({a} : finset α) = 1 := card_singleton _

lemma card_singleton_inter [decidable_eq α] : ({a} ∩ s).card ≤ 1 :=
begin
  cases (finset.decidable_mem a s),
  { simp [finset.singleton_inter_of_not_mem h] },
  { simp [finset.singleton_inter_of_mem h] }
end

@[simp] lemma card_cons (h : a ∉ s) : (s.cons a h).card = s.card + 1 := card_cons _ _

section insert_erase
variables [decidable_eq α]

@[simp] lemma card_insert_of_not_mem (h : a ∉ s) : (insert a s).card = s.card + 1 :=
by rw [←cons_eq_insert _ _ h, card_cons]

lemma card_insert_of_mem (h : a ∈ s) : card (insert a s) = s.card := by rw insert_eq_of_mem h

lemma card_insert_le (a : α) (s : finset α) : card (insert a s) ≤ s.card + 1 :=
by by_cases a ∈ s; [{rw insert_eq_of_mem h, exact nat.le_succ _ }, rw card_insert_of_not_mem h]

/-- If `a ∈ s` is known, see also `finset.card_insert_of_mem` and `finset.card_insert_of_not_mem`.
-/
lemma card_insert_eq_ite : card (insert a s) = if a ∈ s then s.card else s.card + 1 :=
begin
  by_cases h : a ∈ s,
  { rw [card_insert_of_mem h, if_pos h] },
  { rw [card_insert_of_not_mem h, if_neg h] }
end

@[simp] lemma card_doubleton (h : a ≠ b) : ({a, b} : finset α).card = 2 :=
by rw [card_insert_of_not_mem (not_mem_singleton.2 h), card_singleton]

@[simp] lemma card_erase_of_mem : a ∈ s → (s.erase a).card = s.card - 1 := card_erase_of_mem
@[simp] lemma card_erase_add_one : a ∈ s → (s.erase a).card + 1 = s.card := card_erase_add_one

lemma card_erase_lt_of_mem : a ∈ s → (s.erase a).card < s.card := card_erase_lt_of_mem

lemma card_erase_le : (s.erase a).card ≤ s.card := card_erase_le

lemma pred_card_le_card_erase : s.card - 1 ≤ (s.erase a).card :=
begin
  by_cases h : a ∈ s,
  { exact (card_erase_of_mem h).ge },
  { rw erase_eq_of_not_mem h,
    exact nat.sub_le _ _ }
end

/-- If `a ∈ s` is known, see also `finset.card_erase_of_mem` and `finset.erase_eq_of_not_mem`. -/
lemma card_erase_eq_ite : (s.erase a).card = if a ∈ s then s.card - 1 else s.card :=
card_erase_eq_ite

end insert_erase

@[simp] lemma card_range (n : ℕ) : (range n).card = n := card_range n

@[simp] lemma card_attach : s.attach.card = s.card := multiset.card_attach

end finset

section to_list_multiset
variables [decidable_eq α] (m : multiset α) (l : list α)

lemma multiset.card_to_finset : m.to_finset.card = m.dedup.card := rfl

lemma multiset.to_finset_card_le : m.to_finset.card ≤ m.card := card_le_of_le $ dedup_le _

lemma multiset.to_finset_card_of_nodup {m : multiset α} (h : m.nodup) : m.to_finset.card = m.card :=
congr_arg card $ multiset.dedup_eq_self.mpr h

lemma list.card_to_finset : l.to_finset.card = l.dedup.length := rfl

lemma list.to_finset_card_le : l.to_finset.card ≤ l.length := multiset.to_finset_card_le ⟦l⟧

lemma list.to_finset_card_of_nodup {l : list α} (h : l.nodup) : l.to_finset.card = l.length :=
multiset.to_finset_card_of_nodup h

end to_list_multiset

namespace finset
variables {s t : finset α} {f : α → β} {n : ℕ}

@[simp] lemma length_to_list (s : finset α) : s.to_list.length = s.card :=
by { rw [to_list, ←multiset.coe_card, multiset.coe_to_list], refl }

lemma card_image_le [decidable_eq β] : (s.image f).card ≤ s.card :=
by simpa only [card_map] using (s.1.map f).to_finset_card_le

lemma card_image_of_inj_on [decidable_eq β] (H : set.inj_on f s) : (s.image f).card = s.card :=
by simp only [card, image_val_of_inj_on H, card_map]

lemma inj_on_of_card_image_eq [decidable_eq β] (H : (s.image f).card = s.card) : set.inj_on f s :=
begin
  change (s.1.map f).dedup.card = s.1.card at H,
  have : (s.1.map f).dedup = s.1.map f,
  { refine multiset.eq_of_le_of_card_le (multiset.dedup_le _) _,
    rw H,
    simp only [multiset.card_map] },
  rw multiset.dedup_eq_self at this,
  exact inj_on_of_nodup_map this,
end

lemma card_image_iff [decidable_eq β] : (s.image f).card = s.card ↔ set.inj_on f s :=
⟨inj_on_of_card_image_eq, card_image_of_inj_on⟩

lemma card_image_of_injective [decidable_eq β] (s : finset α) (H : injective f) :
  (s.image f).card = s.card :=
card_image_of_inj_on $ λ x _ y _ h, H h

lemma fiber_card_ne_zero_iff_mem_image (s : finset α) (f : α → β) [decidable_eq β] (y : β) :
  (s.filter (λ x, f x = y)).card ≠ 0 ↔ y ∈ s.image f :=
by { rw [←pos_iff_ne_zero, card_pos, fiber_nonempty_iff_mem_image] }

@[simp] lemma card_map (f : α ↪ β) : (s.map f).card = s.card := multiset.card_map _ _

@[simp] lemma card_subtype (p : α → Prop) [decidable_pred p] (s : finset α) :
  (s.subtype p).card = (s.filter p).card :=
by simp [finset.subtype]

lemma card_filter_le (s : finset α) (p : α → Prop) [decidable_pred p] :
  (s.filter p).card ≤ s.card :=
card_le_of_subset $ filter_subset _ _

lemma eq_of_subset_of_card_le {s t : finset α} (h : s ⊆ t) (h₂ : t.card ≤ s.card) : s = t :=
eq_of_veq $ multiset.eq_of_le_of_card_le (val_le_iff.mpr h) h₂

lemma map_eq_of_subset {f : α ↪ α} (hs : s.map f ⊆ s) : s.map f = s :=
eq_of_subset_of_card_le hs (card_map _).ge

lemma filter_card_eq {p : α → Prop} [decidable_pred p] (h : (s.filter p).card = s.card) (x : α)
  (hx : x ∈ s) :
  p x :=
begin
  rw [←eq_of_subset_of_card_le (s.filter_subset p) h.ge, mem_filter] at hx,
  exact hx.2,
end

lemma card_lt_card (h : s ⊂ t) : s.card < t.card := card_lt_of_lt $ val_lt_iff.2 h

lemma card_eq_of_bijective (f : ∀ i, i < n → α) (hf : ∀ a ∈ s, ∃ i, ∃ h : i < n, f i h = a)
  (hf' : ∀ i (h : i < n), f i h ∈ s) (f_inj : ∀ i j (hi : i < n)
  (hj : j < n), f i hi = f j hj → i = j) :
  s.card = n :=
begin
  classical,
  have : ∀ (a : α), a ∈ s ↔ ∃ i (hi : i ∈ range n), f i (mem_range.1 hi) = a,
    from λ a, ⟨λ ha, let ⟨i, hi, eq⟩ := hf a ha in ⟨i, mem_range.2 hi, eq⟩,
      λ ⟨i, hi, eq⟩, eq ▸ hf' i (mem_range.1 hi)⟩,
  have : s = ((range n).attach.image $ λi, f i.1 (mem_range.1 i.2)),
    by simpa only [ext_iff, mem_image, exists_prop, subtype.exists, mem_attach, true_and],
  calc s.card = card ((range n).attach.image $ λ i, f i.1 (mem_range.1 i.2)) :
      by rw this
    ... = card ((range n).attach) :
      card_image_of_injective _ $ λ ⟨i, hi⟩ ⟨j, hj⟩ eq,
        subtype.eq $ f_inj i j (mem_range.1 hi) (mem_range.1 hj) eq
    ... = card (range n) : card_attach
    ... = n : card_range n
end

lemma card_congr {t : finset β} (f : Π a ∈ s, β) (h₁ : ∀ a ha, f a ha ∈ t)
  (h₂ : ∀ a b ha hb, f a ha = f b hb → a = b) (h₃ : ∀ b ∈ t, ∃ a ha, f a ha = b) :
  s.card = t.card :=
by classical;
calc s.card = s.attach.card : card_attach.symm
... = (s.attach.image (λ (a : {a // a ∈ s}), f a.1 a.2)).card
    : eq.symm (card_image_of_injective _ $ λ a b h, subtype.eq $ h₂ _ _ _ _ h)
... = t.card : congr_arg card (finset.ext $ λ b,
    ⟨λ h, let ⟨a, ha₁, ha₂⟩ := mem_image.1 h in ha₂ ▸ h₁ _ _,
      λ h, let ⟨a, ha₁, ha₂⟩ := h₃ b h in mem_image.2 ⟨⟨a, ha₁⟩, by simp [ha₂]⟩⟩)

lemma card_le_card_of_inj_on {t : finset β} (f : α → β) (hf : ∀ a ∈ s, f a ∈ t)
  (f_inj : ∀ a₁ ∈ s, ∀ a₂ ∈ s, f a₁ = f a₂ → a₁ = a₂) :
  s.card ≤ t.card :=
by classical;
  calc s.card = (s.image f).card : (card_image_of_inj_on f_inj).symm
    ... ≤ t.card : card_le_of_subset $ image_subset_iff.2 hf

/-- If there are more pigeons than pigeonholes, then there are two pigeons in the same pigeonhole.
-/
lemma exists_ne_map_eq_of_card_lt_of_maps_to {t : finset β} (hc : t.card < s.card)
  {f : α → β} (hf : ∀ a ∈ s, f a ∈ t) :
  ∃ (x ∈ s) (y ∈ s), x ≠ y ∧ f x = f y :=
begin
  classical,
  by_contra' hz,
  refine hc.not_le (card_le_card_of_inj_on f hf _),
  intros x hx y hy, contrapose, exact hz x hx y hy,
end

lemma le_card_of_inj_on_range (f : ℕ → α) (hf : ∀ i < n, f i ∈ s)
  (f_inj : ∀ (i < n) (j < n), f i = f j → i = j) :
  n ≤ s.card :=
calc n = card (range n) : (card_range n).symm
  ... ≤ s.card : card_le_card_of_inj_on f (by simpa only [mem_range]) (by simpa only [mem_range])

lemma surj_on_of_inj_on_of_card_le {t : finset β} (f : Π a ∈ s, β) (hf : ∀ a ha, f a ha ∈ t)
  (hinj : ∀ a₁ a₂ ha₁ ha₂, f a₁ ha₁ = f a₂ ha₂ → a₁ = a₂) (hst : t.card ≤ s.card) :
  ∀ b ∈ t, ∃ a ha, b = f a ha :=
begin
  classical,
  intros b hb,
  have h : (s.attach.image $ λ (a : {a // a ∈ s}), f a a.prop).card = s.card,
  { exact @card_attach _ s ▸ card_image_of_injective _
      (λ ⟨a₁, ha₁⟩ ⟨a₂, ha₂⟩ h, subtype.eq $ hinj _ _ _ _ h) },
  have h' : image (λ a : {a // a ∈ s}, f a a.prop) s.attach = t,
  { exact eq_of_subset_of_card_le (λ b h, let ⟨a, ha₁, ha₂⟩ := mem_image.1 h in
      ha₂ ▸ hf _ _) (by simp [hst, h]) },
  rw ←h' at hb,
  obtain ⟨a, ha₁, ha₂⟩ := mem_image.1 hb,
  exact ⟨a, a.2, ha₂.symm⟩,
end

lemma inj_on_of_surj_on_of_card_le {t : finset β} (f : Π a ∈ s, β) (hf : ∀ a ha, f a ha ∈ t)
  (hsurj : ∀ b ∈ t, ∃ a ha, b = f a ha) (hst : s.card ≤ t.card) ⦃a₁ a₂⦄ (ha₁ : a₁ ∈ s)
  (ha₂ : a₂ ∈ s) (ha₁a₂: f a₁ ha₁ = f a₂ ha₂) :
  a₁ = a₂ :=
by haveI : inhabited {x // x ∈ s} := ⟨⟨a₁, ha₁⟩⟩; exact
let f' : {x // x ∈ s} → {x // x ∈ t} := λ x, ⟨f x.1 x.2, hf x.1 x.2⟩ in
let g : {x // x ∈ t} → {x // x ∈ s} :=
  @surj_inv _ _ f'
    (λ x, let ⟨y, hy₁, hy₂⟩ := hsurj x.1 x.2 in ⟨⟨y, hy₁⟩, subtype.eq hy₂.symm⟩) in
have hg : injective g, from injective_surj_inv _,
have hsg : surjective g, from λ x,
  let ⟨y, hy⟩ := surj_on_of_inj_on_of_card_le (λ (x : {x // x ∈ t}) (hx : x ∈ t.attach), g x)
    (λ x _, show (g x) ∈ s.attach, from mem_attach _ _)
    (λ x y _ _ hxy, hg hxy) (by simpa) x (mem_attach _ _) in
  ⟨y, hy.snd.symm⟩,
have hif : injective f',
  from (left_inverse_of_surjective_of_right_inverse hsg
      (right_inverse_surj_inv _)).injective,
subtype.ext_iff_val.1 (@hif ⟨a₁, ha₁⟩ ⟨a₂, ha₂⟩ (subtype.eq ha₁a₂))

@[simp] lemma card_disj_union (s t : finset α) (h) : (s.disj_union t h).card = s.card + t.card :=
multiset.card_add _ _

/-! ### Lattice structure -/

section lattice
variables [decidable_eq α]

lemma card_union_add_card_inter (s t : finset α) : (s ∪ t).card + (s ∩ t).card = s.card + t.card :=
finset.induction_on t (by simp) $ λ a r har, by by_cases a ∈ s; simp *; cc

lemma card_union_le (s t : finset α) : (s ∪ t).card ≤ s.card + t.card :=
card_union_add_card_inter s t ▸ nat.le_add_right _ _

lemma card_union_eq (h : disjoint s t) : (s ∪ t).card = s.card + t.card :=
by rw [←disj_union_eq_union s t $ λ x, disjoint_left.mp h, card_disj_union _ _ _]

@[simp] lemma card_disjoint_union (h : disjoint s t) : card (s ∪ t) = s.card + t.card :=
card_union_eq h

lemma card_sdiff (h : s ⊆ t) : card (t \ s) = t.card - s.card :=
suffices card (t \ s) = card ((t \ s) ∪ s) - s.card, by rwa sdiff_union_of_subset h at this,
by rw [card_disjoint_union sdiff_disjoint, add_tsub_cancel_right]

lemma card_sdiff_add_card_eq_card {s t : finset α} (h : s ⊆ t) : card (t \ s) + card s = card t :=
((nat.sub_eq_iff_eq_add (card_le_of_subset h)).mp (card_sdiff h).symm).symm

lemma le_card_sdiff (s t : finset α) : t.card - s.card ≤ card (t \ s) :=
calc card t - card s
      ≤ card t - card (s ∩ t) : tsub_le_tsub_left (card_le_of_subset (inter_subset_left s t)) _
  ... = card (t \ (s ∩ t)) : (card_sdiff (inter_subset_right s t)).symm
  ... ≤ card (t \ s) : by rw sdiff_inter_self_right t s

lemma card_sdiff_add_card : (s \ t).card + t.card = (s ∪ t).card :=
by rw [←card_disjoint_union sdiff_disjoint, sdiff_union_self_eq_union]

end lattice

lemma filter_card_add_filter_neg_card_eq_card (p : α → Prop) [decidable_pred p] :
  (s.filter p).card + (s.filter (not ∘ p)).card = s.card :=
by { classical, simp [←card_union_eq, filter_union_filter_neg_eq, disjoint_filter] }

/-- Given a set `A` and a set `B` inside it, we can shrink `A` to any appropriate size, and keep `B`
inside it. -/
lemma exists_intermediate_set {A B : finset α} (i : ℕ) (h₁ : i + card B ≤ card A) (h₂ : B ⊆ A) :
  ∃ (C : finset α), B ⊆ C ∧ C ⊆ A ∧ card C = i + card B :=
begin
  classical,
  rcases nat.le.dest h₁ with ⟨k, _⟩,
  clear h₁,
  induction k with k ih generalizing A,
  { exact ⟨A, h₂, subset.refl _, h.symm⟩ },
  have : (A \ B).nonempty,
  { rw [←card_pos, card_sdiff h₂, ←h, nat.add_right_comm,
        add_tsub_cancel_right, nat.add_succ],
    apply nat.succ_pos },
  rcases this with ⟨a, ha⟩,
  have z : i + card B + k = card (erase A a),
  { rw [card_erase_of_mem (mem_sdiff.1 ha).1, ←h],
    refl },
  rcases ih _ z with ⟨B', hB', B'subA', cards⟩,
  { exact ⟨B', hB', trans B'subA' (erase_subset _ _), cards⟩ },
  { rintro t th,
    apply mem_erase_of_ne_of_mem _ (h₂ th),
    rintro rfl,
    exact not_mem_sdiff_of_mem_right th ha }
end

/-- We can shrink `A` to any smaller size. -/
lemma exists_smaller_set (A : finset α) (i : ℕ) (h₁ : i ≤ card A) :
  ∃ (B : finset α), B ⊆ A ∧ card B = i :=
let ⟨B, _, x₁, x₂⟩ := exists_intermediate_set i (by simpa) (empty_subset A) in ⟨B, x₁, x₂⟩

lemma exists_subset_or_subset_of_two_mul_lt_card [decidable_eq α] {X Y : finset α} {n : ℕ}
  (hXY : 2 * n < (X ∪ Y).card) :
  ∃ C : finset α, n < C.card ∧ (C ⊆ X ∨ C ⊆ Y) :=
begin
  have h₁ : (X ∩ (Y \ X)).card = 0 := finset.card_eq_zero.mpr (finset.inter_sdiff_self X Y),
  have h₂ : (X ∪ Y).card = X.card + (Y \ X).card,
  { rw [←card_union_add_card_inter X (Y \ X), finset.union_sdiff_self_eq_union, h₁, add_zero] },
  rw [h₂, two_mul] at hXY,
  rcases lt_or_lt_of_add_lt_add hXY with h|h,
  { exact ⟨X, h, or.inl (finset.subset.refl X)⟩ },
  { exact ⟨Y \ X, h, or.inr (finset.sdiff_subset Y X)⟩ }
end

/-! ### Explicit description of a finset from its card -/

lemma card_eq_one : s.card = 1 ↔ ∃ a, s = {a} :=
by cases s; simp only [multiset.card_eq_one, finset.card, ←val_inj, singleton_val]

lemma exists_eq_insert_iff [decidable_eq α] {s t : finset α} :
  (∃ a ∉ s, insert a s = t) ↔ s ⊆ t ∧ s.card + 1 = t.card :=
begin
  split,
  { rintro ⟨a, ha, rfl⟩,
    exact ⟨subset_insert _ _, (card_insert_of_not_mem ha).symm⟩ },
  { rintro ⟨hst, h⟩,
    obtain ⟨a, ha⟩ : ∃ a, t \ s = {a},
    { exact card_eq_one.1 (by rw [card_sdiff hst, ←h, add_tsub_cancel_left]) },
    refine ⟨a, λ hs, (_ : a ∉ {a}) $ mem_singleton_self _,
      by rw [insert_eq, ←ha, sdiff_union_of_subset hst]⟩,
    rw ←ha,
    exact not_mem_sdiff_of_mem_right hs }
end

lemma card_le_one : s.card ≤ 1 ↔ ∀ (a ∈ s) (b ∈ s), a = b :=
begin
  obtain rfl | ⟨x, hx⟩ := s.eq_empty_or_nonempty,
  { simp },
  refine (nat.succ_le_of_lt (card_pos.2 ⟨x, hx⟩)).le_iff_eq.trans (card_eq_one.trans ⟨_, _⟩),
  { rintro ⟨y, rfl⟩,
    simp },
  { exact λ h, ⟨x, eq_singleton_iff_unique_mem.2 ⟨hx, λ y hy, h _ hy _ hx⟩⟩ }
end

lemma card_le_one_iff : s.card ≤ 1 ↔ ∀ {a b}, a ∈ s → b ∈ s → a = b := by { rw card_le_one, tauto }

lemma card_le_one_iff_subset_singleton [nonempty α] : s.card ≤ 1 ↔ ∃ (x : α), s ⊆ {x} :=
begin
  refine ⟨λ H, _, _⟩,
  { obtain rfl | ⟨x, hx⟩ := s.eq_empty_or_nonempty,
    { exact ⟨classical.arbitrary α, empty_subset _⟩ },
    { exact ⟨x, λ y hy, by rw [card_le_one.1 H y hy x hx, mem_singleton]⟩ } },
  { rintro ⟨x, hx⟩,
    rw ←card_singleton x,
    exact card_le_of_subset hx }
end

/-- A `finset` of a subsingleton type has cardinality at most one. -/
lemma card_le_one_of_subsingleton [subsingleton α] (s : finset α) : s.card ≤ 1 :=
finset.card_le_one_iff.2 $ λ _ _ _ _, subsingleton.elim _ _

lemma one_lt_card : 1 < s.card ↔ ∃ (a ∈ s) (b ∈ s), a ≠ b :=
by { rw ←not_iff_not, push_neg, exact card_le_one }

lemma one_lt_card_iff : 1 < s.card ↔ ∃ a b, a ∈ s ∧ b ∈ s ∧ a ≠ b :=
by { rw one_lt_card, simp only [exists_prop, exists_and_distrib_left] }

lemma two_lt_card_iff : 2 < s.card ↔ ∃ a b c, a ∈ s ∧ b ∈ s ∧ c ∈ s ∧ a ≠ b ∧ a ≠ c ∧ b ≠ c :=
begin
  classical,
  refine ⟨λ h, _, _⟩,
  { obtain ⟨c, hc⟩ := card_pos.mp (zero_lt_two.trans h),
    have : 1 < (s.erase c).card := by rwa [←add_lt_add_iff_right 1, card_erase_add_one hc],
    obtain ⟨a, b, ha, hb, hab⟩ := one_lt_card_iff.mp this,
    exact ⟨a, b, c, mem_of_mem_erase ha, mem_of_mem_erase hb, hc,
      hab, ne_of_mem_erase ha, ne_of_mem_erase hb⟩ },
  { rintros ⟨a, b, c, ha, hb, hc, hab, hac, hbc⟩,
    rw [←card_erase_add_one hc, ←card_erase_add_one (mem_erase_of_ne_of_mem hbc hb),
        ←card_erase_add_one (mem_erase_of_ne_of_mem hab (mem_erase_of_ne_of_mem hac ha))],
    apply nat.le_add_left },
end

lemma two_lt_card : 2 < s.card ↔ ∃ (a ∈ s) (b ∈ s) (c ∈ s), a ≠ b ∧ a ≠ c ∧ b ≠ c :=
by simp_rw [two_lt_card_iff, exists_prop, exists_and_distrib_left]

lemma exists_ne_of_one_lt_card (hs : 1 < s.card) (a : α) : ∃ b, b ∈ s ∧ b ≠ a :=
begin
  obtain ⟨x, hx, y, hy, hxy⟩ := finset.one_lt_card.mp hs,
  by_cases ha : y = a,
  { exact ⟨x, hx, ne_of_ne_of_eq hxy ha⟩ },
  { exact ⟨y, hy, ha⟩ }
end

lemma card_eq_succ [decidable_eq α] : s.card = n + 1 ↔ ∃ a t, a ∉ t ∧ insert a t = s ∧ t.card = n :=
⟨λ h,
  let ⟨a, has⟩ := card_pos.mp (h.symm ▸ nat.zero_lt_succ _ : 0 < s.card) in
    ⟨a, s.erase a, s.not_mem_erase a, insert_erase has,
      by simp only [h, card_erase_of_mem has, add_tsub_cancel_right]⟩,
  λ ⟨a, t, hat, s_eq, n_eq⟩, s_eq ▸ n_eq ▸ card_insert_of_not_mem hat⟩

lemma card_eq_two [decidable_eq α] : s.card = 2 ↔ ∃ x y, x ≠ y ∧ s = {x, y} :=
begin
  split,
  { rw card_eq_succ,
    simp_rw [card_eq_one],
    rintro ⟨a, _, hab, rfl, b, rfl⟩,
    exact ⟨a, b, not_mem_singleton.1 hab, rfl⟩ },
  { rintro ⟨x, y, h, rfl⟩,
    exact card_doubleton h }
end

lemma card_eq_three [decidable_eq α] :
  s.card = 3 ↔ ∃ x y z, x ≠ y ∧ x ≠ z ∧ y ≠ z ∧ s = {x, y, z} :=
begin
  split,
  { rw card_eq_succ,
    simp_rw [card_eq_two],
    rintro ⟨a, _, abc, rfl, b, c, bc, rfl⟩,
    rw [mem_insert, mem_singleton, not_or_distrib] at abc,
    exact ⟨a, b, c, abc.1, abc.2, bc, rfl⟩ },
  { rintro ⟨x, y, z, xy, xz, yz, rfl⟩,
    simp only [xy, xz, yz, mem_insert, card_insert_of_not_mem, not_false_iff, mem_singleton,
      or_self, card_singleton] }
end

/-! ### Inductions -/

/-- Suppose that, given objects defined on all strict subsets of any finset `s`, one knows how to
define an object on `s`. Then one can inductively define an object on all finsets, starting from
the empty set and iterating. This can be used either to define data, or to prove properties. -/
def strong_induction {p : finset α → Sort*} (H : ∀ s, (∀ t ⊂ s, p t) → p s) :
  ∀ (s : finset α), p s
| s := H s (λ t h, have t.card < s.card, from card_lt_card h, strong_induction t)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf card⟩]}

lemma strong_induction_eq {p : finset α → Sort*} (H : ∀ s, (∀ t ⊂ s, p t) → p s) (s : finset α) :
  strong_induction H s = H s (λ t h, strong_induction H t) :=
by rw strong_induction

/-- Analogue of `strong_induction` with order of arguments swapped. -/
@[elab_as_eliminator] def strong_induction_on {p : finset α → Sort*} (s : finset α) :
  (∀ s, (∀ t ⊂ s, p t) → p s) → p s :=
λ H, strong_induction H s

lemma strong_induction_on_eq {p : finset α → Sort*} (s : finset α) (H : ∀ s, (∀ t ⊂ s, p t) → p s) :
  s.strong_induction_on H = H s (λ t h, t.strong_induction_on H) :=
by { dunfold strong_induction_on, rw strong_induction }

@[elab_as_eliminator] lemma case_strong_induction_on [decidable_eq α] {p : finset α → Prop}
  (s : finset α) (h₀ : p ∅) (h₁ : ∀ a s, a ∉ s → (∀ t ⊆ s, p t) → p (insert a s)) :
  p s :=
finset.strong_induction_on s $ λ s,
finset.induction_on s (λ _, h₀) $ λ a s n _ ih, h₁ a s n $
λ t ss, ih _ (lt_of_le_of_lt ss (ssubset_insert n) : t < _)

/-- Suppose that, given that `p t` can be defined on all supersets of `s` of cardinality less than
`n`, one knows how to define `p s`. Then one can inductively define `p s` for all finsets `s` of
cardinality less than `n`, starting from finsets of card `n` and iterating. This
can be used either to define data, or to prove properties. -/
def strong_downward_induction {p : finset α → Sort*} {n : ℕ} (H : ∀ t₁, (∀ {t₂ : finset α},
  t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  ∀ (s : finset α), s.card ≤ n → p s
| s := H s (λ t ht h, have n - t.card < n - s.card,
     from (tsub_lt_tsub_iff_left_of_le ht).2 (finset.card_lt_card h),
  strong_downward_induction t ht)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf (λ (t : finset α), n - t.card)⟩]}

lemma strong_downward_induction_eq {p : finset α → Sort*}
  (H : ∀ t₁, (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁)
  (s : finset α) :
  strong_downward_induction H s = H s (λ t ht hst, strong_downward_induction H t ht) :=
by rw strong_downward_induction

/-- Analogue of `strong_downward_induction` with order of arguments swapped. -/
@[elab_as_eliminator] def strong_downward_induction_on {p : finset α → Sort*} (s : finset α)
  (H : ∀ t₁, (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  s.card ≤ n → p s :=
strong_downward_induction H s

lemma strong_downward_induction_on_eq {p : finset α → Sort*} (s : finset α) (H : ∀ t₁,
  (∀ {t₂ : finset α}, t₂.card ≤ n → t₁ ⊂ t₂ → p t₂) → t₁.card ≤ n → p t₁) :
  s.strong_downward_induction_on H = H s (λ t ht h, t.strong_downward_induction_on H ht) :=
by { dunfold strong_downward_induction_on, rw strong_downward_induction }

lemma lt_wf {α} : well_founded (@has_lt.lt (finset α) _) :=
have H : subrelation (@has_lt.lt (finset α) _)
    (inv_image ( < ) card),
  from λ x y hxy, card_lt_card hxy,
subrelation.wf H $ inv_image.wf _ $ nat.lt_wf

end finset


<|start_filename|>src/algebraic_topology/fundamental_groupoid/product.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import category_theory.groupoid
import algebraic_topology.fundamental_groupoid.basic
import topology.category.Top.limits
import topology.homotopy.product
import category_theory.limits.preserves.shapes.products

/-!
# Fundamental groupoid preserves products
In this file, we give the following definitions/theorems:

  - `fundamental_groupoid_functor.pi_iso` An isomorphism between Π i, (π Xᵢ) and π (Πi, Xᵢ), whose
    inverse is precisely the product of the maps π (Π i, Xᵢ) → π (Xᵢ), each induced by
    the projection in `Top` Π i, Xᵢ → Xᵢ.

  - `fundamental_groupoid_functor.prod_iso` An isomorphism between πX × πY and π (X × Y), whose
    inverse is precisely the product of the maps π (X × Y) → πX and π (X × Y) → Y, each induced by
    the projections X × Y → X and X × Y → Y

  - `fundamental_groupoid_functor.preserves_product` A proof that the fundamental groupoid functor
    preserves all products.
-/

noncomputable theory

namespace fundamental_groupoid_functor

open_locale fundamental_groupoid

universes u

section pi

variables {I : Type u} (X : I → Top.{u})

/--
The projection map Π i, X i → X i induces a map π(Π i, X i) ⟶ π(X i).
-/
def proj (i : I) : πₓ (Top.of (Π i, X i)) ⥤ πₓ (X i) := πₘ ⟨_, continuous_apply i⟩

/-- The projection map is precisely path.homotopic.proj interpreted as a functor -/
@[simp] lemma proj_map (i : I) (x₀ x₁ : πₓ (Top.of (Π i, X i))) (p : x₀ ⟶ x₁) :
  (proj X i).map p = (@path.homotopic.proj _ _ _ _ _ i p) := rfl

/--
The map taking the pi product of a family of fundamental groupoids to the fundamental
groupoid of the pi product. This is actually an isomorphism (see `pi_iso`)
-/
@[simps]
def pi_to_pi_Top : (Π i, πₓ (X i)) ⥤ πₓ (Top.of (Π i, X i)) :=
{ obj := λ g, g,
  map := λ v₁ v₂ p, path.homotopic.pi p,
  map_id' :=
  begin
    intro x,
    change path.homotopic.pi (λ i, 𝟙 (x i)) = _,
    simp only [fundamental_groupoid.id_eq_path_refl, path.homotopic.pi_lift],
    refl,
  end,
  map_comp' := λ x y z f g, (path.homotopic.comp_pi_eq_pi_comp f g).symm, }

/--
Shows `pi_to_pi_Top` is an isomorphism, whose inverse is precisely the pi product
of the induced projections. This shows that `fundamental_groupoid_functor` preserves products.
-/
@[simps]
def pi_iso : category_theory.Groupoid.of (Π i : I, πₓ (X i)) ≅ πₓ (Top.of (Π i, X i)) :=
{ hom := pi_to_pi_Top X,
  inv := category_theory.functor.pi' (proj X),
  hom_inv_id' :=
  begin
    change pi_to_pi_Top X ⋙ (category_theory.functor.pi' (proj X)) = 𝟭 _,
    apply category_theory.functor.ext; intros,
    { ext, simp, }, { refl, },
  end,
  inv_hom_id' :=
  begin
    change (category_theory.functor.pi' (proj X)) ⋙ pi_to_pi_Top X = 𝟭 _,
    apply category_theory.functor.ext; intros,
    { suffices : path.homotopic.pi ((category_theory.functor.pi' (proj X)).map f) = f, { simpa, },
      change (category_theory.functor.pi' (proj X)).map f
        with λ i, (category_theory.functor.pi' (proj X)).map f i,
      simp, }, { refl, }
  end }

section preserves
open category_theory

/-- Equivalence between the categories of cones over the objects `π Xᵢ` written in two ways -/
def cone_discrete_comp : limits.cone (discrete.functor X ⋙ π) ≌
  limits.cone (discrete.functor (λ i, πₓ (X i))) :=
limits.cones.postcompose_equivalence (discrete.comp_nat_iso_discrete X π)

lemma cone_discrete_comp_obj_map_cone :
  (cone_discrete_comp X).functor.obj ((π).map_cone (Top.pi_fan.{u} X))
  = limits.fan.mk (πₓ (Top.of (Π i, X i))) (proj X) := rfl

/-- This is `pi_iso.inv` as a cone morphism (in fact, isomorphism) -/
def pi_Top_to_pi_cone : (limits.fan.mk (πₓ (Top.of (Π i, X i))) (proj X)) ⟶
  Groupoid.pi_limit_fan (λ i : I, (πₓ (X i))) := { hom := category_theory.functor.pi' (proj X) }

instance : is_iso (pi_Top_to_pi_cone X) :=
begin
  haveI : is_iso (pi_Top_to_pi_cone X).hom := (infer_instance : is_iso (pi_iso X).inv),
  exact limits.cones.cone_iso_of_hom_iso (pi_Top_to_pi_cone X),
end

/-- The fundamental groupoid functor preserves products -/
def preserves_product : limits.preserves_limit (discrete.functor X) π :=
begin
  apply limits.preserves_limit_of_preserves_limit_cone (Top.pi_fan_is_limit.{u} X),
  apply (limits.is_limit.of_cone_equiv (cone_discrete_comp X)).to_fun,
  simp only [cone_discrete_comp_obj_map_cone],
  apply limits.is_limit.of_iso_limit _ (as_iso (pi_Top_to_pi_cone X)).symm,
  exact Groupoid.pi_limit_fan_is_limit _,
end

end preserves

end pi

section prod

variables (A B : Top.{u})

/-- The induced map of the left projection map X × Y → X -/
def proj_left : πₓ (Top.of (A × B)) ⥤ πₓ A := πₘ ⟨_, continuous_fst⟩

/-- The induced map of the right projection map X × Y → Y -/
def proj_right : πₓ (Top.of (A × B)) ⥤ πₓ B := πₘ ⟨_, continuous_snd⟩

@[simp] lemma proj_left_map (x₀ x₁ : πₓ (Top.of (A × B))) (p : x₀ ⟶ x₁) :
  (proj_left A B).map p = path.homotopic.proj_left p := rfl

@[simp] lemma proj_right_map (x₀ x₁ : πₓ (Top.of (A × B))) (p : x₀ ⟶ x₁) :
  (proj_right A B).map p = path.homotopic.proj_right p := rfl


/--
The map taking the product of two fundamental groupoids to the fundamental groupoid of the product
of the two topological spaces. This is in fact an isomorphism (see `prod_iso`).
-/
@[simps obj]
def prod_to_prod_Top : (πₓ A) × (πₓ B) ⥤ πₓ (Top.of (A × B)) :=
{ obj := λ g, g,
  map := λ x y p, match x, y, p with
    | (x₀, x₁), (y₀, y₁), (p₀, p₁) := path.homotopic.prod p₀ p₁
  end,
  map_id' :=
  begin
    rintro ⟨x₀, x₁⟩,
    simp only [category_theory.prod_id, fundamental_groupoid.id_eq_path_refl],
    unfold_aux, rw path.homotopic.prod_lift, refl,
  end,
  map_comp' := λ x y z f g, match x, y, z, f, g with
    | (x₀, x₁), (y₀, y₁), (z₀, z₁), (f₀, f₁), (g₀, g₁) :=
    (path.homotopic.comp_prod_eq_prod_comp f₀ f₁ g₀ g₁).symm
  end }

lemma prod_to_prod_Top_map {x₀ x₁ : πₓ A} {y₀ y₁ : πₓ B}
  (p₀ : x₀ ⟶ x₁) (p₁ : y₀ ⟶ y₁) :
  @category_theory.functor.map _ _ _ _
  (prod_to_prod_Top A B) (x₀, y₀) (x₁, y₁) (p₀, p₁) = path.homotopic.prod p₀ p₁ := rfl

/--
Shows `prod_to_prod_Top` is an isomorphism, whose inverse is precisely the product
of the induced left and right projections.
-/
@[simps]
def prod_iso : category_theory.Groupoid.of ((πₓ A) × (πₓ B)) ≅ (πₓ (Top.of (A × B))) :=
{ hom := prod_to_prod_Top A B,
  inv := (proj_left A B).prod' (proj_right A B),
  hom_inv_id' :=
  begin
    change prod_to_prod_Top A B ⋙ ((proj_left A B).prod' (proj_right A B)) = 𝟭 _,
    apply category_theory.functor.hext, { intros, ext; simp; refl, },
    rintros ⟨x₀, x₁⟩ ⟨y₀, y₁⟩ ⟨f₀, f₁⟩,
    have := and.intro (path.homotopic.proj_left_prod f₀ f₁) (path.homotopic.proj_right_prod f₀ f₁),
    simpa,
  end,
  inv_hom_id' :=
  begin
    change ((proj_left A B).prod' (proj_right A B)) ⋙ prod_to_prod_Top A B = 𝟭 _,
    apply category_theory.functor.hext, { intros, ext; simp; refl, },
    rintros ⟨x₀, x₁⟩ ⟨y₀, y₁⟩ f,
    have := path.homotopic.prod_proj_left_proj_right f,
    simpa,
  end }

end prod

end fundamental_groupoid_functor


<|start_filename|>src/data/fin/tuple/monotone.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.fin.vec_notation

/-!
# Monotone finite sequences

In this file we prove `simp` lemmas that allow to simplify propositions like `monotone ![a, b, c]`.
-/

open set fin matrix function
variables {α : Type*}

lemma lift_fun_vec_cons {n : ℕ} (r : α → α → Prop) [is_trans α r] {f : fin (n + 1) → α} {a : α} :
  ((<) ⇒ r) (vec_cons a f) (vec_cons a f) ↔ r a (f 0) ∧ ((<) ⇒ r) f f :=
by simp only [lift_fun_iff_succ r, forall_fin_succ, cons_val_succ, cons_val_zero, ← succ_cast_succ,
  cast_succ_zero]

variables [preorder α] {n : ℕ} {f : fin (n + 1) → α} {a : α}

@[simp] lemma strict_mono_vec_cons : strict_mono (vec_cons a f) ↔ a < f 0 ∧ strict_mono f :=
lift_fun_vec_cons (<)

@[simp] lemma monotone_vec_cons : monotone (vec_cons a f) ↔ a ≤ f 0 ∧ monotone f :=
by simpa only [monotone_iff_forall_lt] using @lift_fun_vec_cons α n (≤) _ f a

@[simp] lemma strict_anti_vec_cons : strict_anti (vec_cons a f) ↔ f 0 < a ∧ strict_anti f :=
lift_fun_vec_cons (>)

@[simp] lemma antitone_vec_cons : antitone (vec_cons a f) ↔ f 0 ≤ a ∧ antitone f :=
@monotone_vec_cons αᵒᵈ _ _ _ _

lemma strict_mono.vec_cons (hf : strict_mono f) (ha : a < f 0) :
  strict_mono (vec_cons a f) :=
strict_mono_vec_cons.2 ⟨ha, hf⟩

lemma strict_anti.vec_cons (hf : strict_anti f) (ha : f 0 < a) :
  strict_anti (vec_cons a f) :=
strict_anti_vec_cons.2 ⟨ha, hf⟩

lemma monotone.vec_cons (hf : monotone f) (ha : a ≤ f 0) :
  monotone (vec_cons a f) :=
monotone_vec_cons.2 ⟨ha, hf⟩

lemma antitone.vec_cons (hf : antitone f) (ha : f 0 ≤ a) :
  antitone (vec_cons a f) :=
antitone_vec_cons.2 ⟨ha, hf⟩

example : monotone ![1, 2, 2, 3] := by simp [subsingleton.monotone]


<|start_filename|>src/linear_algebra/tensor_power.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import linear_algebra.pi_tensor_product
import logic.equiv.fin
import algebra.direct_sum.algebra

/-!
# Tensor power of a semimodule over a commutative semirings

We define the `n`th tensor power of `M` as the n-ary tensor product indexed by `fin n` of `M`,
`⨂[R] (i : fin n), M`. This is a special case of `pi_tensor_product`.

This file introduces the notation `⨂[R]^n M` for `tensor_power R n M`, which in turn is an
abbreviation for `⨂[R] i : fin n, M`.

## Main definitions:

* `tensor_power.ghas_one`
* `tensor_power.ghas_mul`

## TODO

Show `direct_sum.galgebra R (λ i, ⨂[R]^i M)` and `algebra R (⨁ n : ℕ, ⨂[R]^n M)`.


## Implementation notes

In this file we use `ₜ1` and `ₜ*` as local notation for the graded multiplicative structure on
tensor powers. Elsewhere, using `1` and `*` on `graded_monoid` should be preferred.
-/

open_locale tensor_product

/-- Homogenous tensor powers $M^{\otimes n}$. `⨂[R]^n M` is a shorthand for
`⨂[R] (i : fin n), M`. -/
@[reducible] protected def tensor_power (R : Type*) (n : ℕ) (M : Type*)
  [comm_semiring R] [add_comm_monoid M] [module R M] : Type* :=
⨂[R] i : fin n, M

variables {R : Type*} {M : Type*} [comm_semiring R] [add_comm_monoid M] [module R M]

localized "notation `⨂[`:100 R `]^`:80 n:max := tensor_power R n"
  in tensor_product

namespace tensor_power
open_locale tensor_product direct_sum
open pi_tensor_product

/-- As a graded monoid, `⨂[R]^i M` has a `1 : ⨂[R]^0 M`. -/
instance ghas_one : graded_monoid.ghas_one (λ i, ⨂[R]^i M) :=
{ one := tprod R fin.elim0 }

local notation `ₜ1` := @graded_monoid.ghas_one.one ℕ (λ i, ⨂[R]^i M) _ _

lemma ghas_one_def : ₜ1 = tprod R fin.elim0 := rfl

/-- A variant of `pi_tensor_prod.tmul_equiv` with the result indexed by `fin (n + m)`. -/
def mul_equiv {n m : ℕ} : (⨂[R]^n M) ⊗[R] (⨂[R]^m M) ≃ₗ[R] ⨂[R]^(n + m) M :=
(tmul_equiv R M).trans (reindex R M fin_sum_fin_equiv)

/-- As a graded monoid, `⨂[R]^i M` has a `(*) : ⨂[R]^i M → ⨂[R]^j M → ⨂[R]^(i + j) M`. -/
instance ghas_mul : graded_monoid.ghas_mul (λ i, ⨂[R]^i M) :=
{ mul := λ i j a b, mul_equiv (a ⊗ₜ b) }

local infix `ₜ*`:70 := @graded_monoid.ghas_mul.mul ℕ (λ i, ⨂[R]^i M) _ _ _ _

lemma ghas_mul_def {i j} (a : ⨂[R]^i M) (b : ⨂[R]^j M) : a ₜ* b = mul_equiv (a ⊗ₜ b) := rfl

end tensor_power


<|start_filename|>src/algebra/order/lattice_group.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.group_power.basic -- Needed for squares
import algebra.order.group
import tactic.nth_rewrite

/-!
# Lattice ordered groups

Lattice ordered groups were introduced by [Birkhoff][birkhoff1942].
They form the algebraic underpinnings of vector lattices, Banach lattices, AL-space, AM-space etc.

This file develops the basic theory, concentrating on the commutative case.

## Main statements

- `pos_div_neg`: Every element `a` of a lattice ordered commutative group has a decomposition
  `a⁺-a⁻` into the difference of the positive and negative component.
- `pos_inf_neg_eq_one`: The positive and negative components are coprime.
- `abs_triangle`: The absolute value operation satisfies the triangle inequality.

It is shown that the inf and sup operations are related to the absolute value operation by a
number of equations and inequalities.

## Notations

- `a⁺ = a ⊔ 0`: The *positive component* of an element `a` of a lattice ordered commutative group
- `a⁻ = (-a) ⊔ 0`: The *negative component* of an element `a` of a lattice ordered commutative group
- `|a| = a⊔(-a)`: The *absolute value* of an element `a` of a lattice ordered commutative group

## Implementation notes

A lattice ordered commutative group is a type `α` satisfying:

* `[lattice α]`
* `[comm_group α]`
* `[covariant_class α α (*) (≤)]`

The remainder of the file establishes basic properties of lattice ordered commutative groups. A
number of these results also hold in the non-commutative case ([Birkhoff][birkhoff1942],
[Fuchs][fuchs1963]) but we have not developed that here, since we are primarily interested in vector
lattices.

## References

* [Birkhoff, Lattice-ordered Groups][birkhoff1942]
* [Bourbaki, Algebra II][bourbaki1981]
* [Fuchs, Partially Ordered Algebraic Systems][fuchs1963]
* [Zaanen, Lectures on "Riesz Spaces"][zaanen1966]
* [Banasiak, Banach Lattices in Applications][banasiak]

## Tags

lattice, ordered, group
-/

universe u

-- A linearly ordered additive commutative group is a lattice ordered commutative group
@[priority 100, to_additive] -- see Note [lower instance priority]
instance linear_ordered_comm_group.to_covariant_class (α : Type u)
  [linear_ordered_comm_group α] : covariant_class α α (*) (≤) :=
{ elim := λ a b c bc, linear_ordered_comm_group.mul_le_mul_left _ _ bc a }

variables {α : Type u} [lattice α] [comm_group α]

-- Special case of Bourbaki A.VI.9 (1)
-- c + (a ⊔ b) = (c + a) ⊔ (c + b)
@[to_additive]
lemma mul_sup [covariant_class α α (*) (≤)] (a b c : α) : c * (a ⊔ b) = (c * a) ⊔ (c * b) :=
begin
  refine le_antisymm _ (by simp),
  rw [← mul_le_mul_iff_left (c⁻¹), ← mul_assoc, inv_mul_self, one_mul],
  exact sup_le (by simp) (by simp),
end

@[to_additive]
lemma mul_inf [covariant_class α α (*) (≤)] (a b c : α) : c * (a ⊓ b) = (c * a) ⊓ (c * b) :=
begin
  refine le_antisymm (by simp) _,
  rw [← mul_le_mul_iff_left (c⁻¹), ← mul_assoc, inv_mul_self, one_mul],
  exact le_inf (by simp) (by simp),
end

-- Special case of Bourbaki A.VI.9 (2)
-- -(a ⊔ b)=(-a) ⊓ (-b)
@[to_additive]
lemma inv_sup_eq_inv_inf_inv [covariant_class α α (*) (≤)] (a b : α) : (a ⊔ b)⁻¹ = a⁻¹ ⊓ b⁻¹ :=
begin
  apply le_antisymm,
  { refine le_inf _ _,
    { rw inv_le_inv_iff, exact le_sup_left, },
    { rw inv_le_inv_iff, exact le_sup_right, } },
  { rw [← inv_le_inv_iff, inv_inv],
    refine sup_le _ _,
    { rw ← inv_le_inv_iff, simp, },
    { rw ← inv_le_inv_iff, simp, } }
end

-- -(a ⊓ b) = -a ⊔ -b
@[to_additive]
lemma inv_inf_eq_sup_inv [covariant_class α α (*) (≤)] (a b : α) : (a ⊓ b)⁻¹ = a⁻¹ ⊔ b⁻¹ :=
by rw [← inv_inv (a⁻¹ ⊔ b⁻¹), inv_sup_eq_inv_inf_inv a⁻¹ b⁻¹, inv_inv, inv_inv]

-- Bourbaki A.VI.10 Prop 7
-- a ⊓ b + (a ⊔ b) = a + b
@[to_additive]
lemma inf_mul_sup [covariant_class α α (*) (≤)] (a b : α) : (a ⊓ b) * (a ⊔ b) = a * b :=
calc (a ⊓ b) * (a ⊔ b) = (a ⊓ b) * ((a * b) * (b⁻¹ ⊔ a⁻¹)) :
  by { rw mul_sup b⁻¹ a⁻¹ (a * b), simp, }
... = (a ⊓ b) * ((a * b) * (a ⊓ b)⁻¹) : by rw [inv_inf_eq_sup_inv, sup_comm]
... = a * b                       : by rw [mul_comm, inv_mul_cancel_right]

namespace lattice_ordered_comm_group

/--
Let `α` be a lattice ordered commutative group with identity `1`. For an element `a` of type `α`,
the element `a ⊔ 1` is said to be the *positive component* of `a`, denoted `a⁺`.
-/
@[to_additive /-"
Let `α` be a lattice ordered commutative group with identity `0`. For an element `a` of type `α`,
the element `a ⊔ 0` is said to be the *positive component* of `a`, denoted `a⁺`.
"-/,
priority 100] -- see Note [lower instance priority]
instance has_one_lattice_has_pos_part : has_pos_part (α) := ⟨λ a, a ⊔ 1⟩

@[to_additive pos_part_def]
lemma m_pos_part_def (a : α) : a⁺ = a ⊔ 1 := rfl

/--
Let `α` be a lattice ordered commutative group with identity `1`. For an element `a` of type `α`,
the element `(-a) ⊔ 1` is said to be the *negative component* of `a`, denoted `a⁻`.
-/
@[to_additive /-"
Let `α` be a lattice ordered commutative group with identity `0`. For an element `a` of type `α`,
the element `(-a) ⊔ 0` is said to be the *negative component* of `a`, denoted `a⁻`.
"-/,
priority 100] -- see Note [lower instance priority]
instance has_one_lattice_has_neg_part : has_neg_part (α) := ⟨λ a, a⁻¹ ⊔ 1⟩

@[to_additive neg_part_def]
lemma m_neg_part_def (a : α) : a⁻ = a⁻¹ ⊔ 1 := rfl

@[simp, to_additive]
lemma pos_one : (1 : α)⁺ = 1 := sup_idem

@[simp, to_additive]
lemma neg_one : (1 : α)⁻ = 1 := by rw [m_neg_part_def, inv_one, sup_idem]

-- a⁻ = -(a ⊓ 0)
@[to_additive]
lemma neg_eq_inv_inf_one [covariant_class α α (*) (≤)] (a : α) : a⁻ = (a ⊓ 1)⁻¹ :=
by rw [m_neg_part_def, ← inv_inj, inv_sup_eq_inv_inf_inv, inv_inv, inv_inv, inv_one]

@[to_additive le_abs]
lemma le_mabs (a : α) : a ≤ |a| := le_sup_left

@[to_additive]
-- -a ≤ |a|
lemma inv_le_abs (a : α) : a⁻¹ ≤ |a| := le_sup_right

-- 0 ≤ a⁺
@[to_additive pos_nonneg]
lemma one_le_pos (a : α) : 1 ≤ a⁺ := le_sup_right

-- 0 ≤ a⁻
@[to_additive neg_nonneg]
lemma one_le_neg (a : α) : 1 ≤ a⁻ := le_sup_right

@[to_additive] -- pos_nonpos_iff
lemma pos_le_one_iff {a : α} : a⁺ ≤ 1 ↔ a ≤ 1 :=
by { rw [m_pos_part_def, sup_le_iff], simp, }

@[to_additive] -- neg_nonpos_iff
lemma neg_le_one_iff {a : α} : a⁻ ≤ 1 ↔ a⁻¹ ≤ 1 :=
by { rw [m_neg_part_def, sup_le_iff], simp, }

@[to_additive]
lemma pos_eq_one_iff {a : α} : a⁺ = 1 ↔ a ≤ 1 :=
by { rw le_antisymm_iff, simp only [one_le_pos, and_true], exact pos_le_one_iff, }

@[to_additive]
lemma neg_eq_one_iff' {a : α} : a⁻ = 1 ↔ a⁻¹ ≤ 1 :=
by { rw le_antisymm_iff, simp only [one_le_neg, and_true], rw neg_le_one_iff, }

@[to_additive]
lemma neg_eq_one_iff [covariant_class α α has_mul.mul has_le.le] {a : α} : a⁻ = 1 ↔ 1 ≤ a :=
by { rw le_antisymm_iff, simp only [one_le_neg, and_true], rw [neg_le_one_iff, inv_le_one'], }

@[to_additive le_pos]
lemma m_le_pos (a : α) : a ≤ a⁺ := le_sup_left

-- -a ≤ a⁻
@[to_additive]
lemma inv_le_neg (a : α) : a⁻¹ ≤ a⁻ := le_sup_left

-- Bourbaki A.VI.12
--  a⁻ = (-a)⁺
@[to_additive]
lemma neg_eq_pos_inv (a : α) : a⁻ = (a⁻¹)⁺ := rfl

-- a⁺ = (-a)⁻
@[to_additive]
lemma pos_eq_neg_inv (a : α) : a⁺ = (a⁻¹)⁻ := by simp [neg_eq_pos_inv]

-- We use this in Bourbaki A.VI.12  Prop 9 a)
-- c + (a ⊓ b) = (c + a) ⊓ (c + b)
@[to_additive]
lemma mul_inf_eq_mul_inf_mul [covariant_class α α (*) (≤)]
  (a b c : α) : c * (a ⊓ b) = (c * a) ⊓ (c * b) :=
begin
  refine le_antisymm (by simp) _,
  rw [← mul_le_mul_iff_left c⁻¹, ← mul_assoc, inv_mul_self, one_mul, le_inf_iff],
  simp,
end

-- Bourbaki A.VI.12  Prop 9 a)
-- a = a⁺ - a⁻
@[simp, to_additive]
lemma pos_div_neg [covariant_class α α (*) (≤)] (a : α) : a⁺ / a⁻ = a :=
begin
  symmetry,
  rw div_eq_mul_inv,
  apply eq_mul_inv_of_mul_eq,
  rw [m_neg_part_def, mul_sup, mul_one, mul_right_inv, sup_comm, m_pos_part_def],
end

-- Bourbaki A.VI.12  Prop 9 a)
-- a⁺ ⊓ a⁻ = 0 (`a⁺` and `a⁻` are co-prime, and, since they are positive, disjoint)
@[to_additive]
lemma pos_inf_neg_eq_one [covariant_class α α (*) (≤)] (a : α) : a⁺ ⊓ a⁻ = 1 :=
by rw [←mul_right_inj (a⁻)⁻¹, mul_inf_eq_mul_inf_mul, mul_one, mul_left_inv, mul_comm,
  ← div_eq_mul_inv, pos_div_neg, neg_eq_inv_inf_one, inv_inv]

-- Bourbaki A.VI.12 (with a and b swapped)
-- a⊔b = b + (a - b)⁺
@[to_additive]
lemma sup_eq_mul_pos_div [covariant_class α α (*) (≤)] (a b : α) : a ⊔ b = b * (a / b)⁺ :=
calc a ⊔ b = (b * (a / b)) ⊔ (b * 1) : by rw [mul_one b, div_eq_mul_inv, mul_comm a,
  mul_inv_cancel_left]
... = b * ((a / b) ⊔ 1) : by rw ← mul_sup (a / b) 1 b

-- Bourbaki A.VI.12 (with a and b swapped)
-- a⊓b = a - (a - b)⁺
@[to_additive]
lemma inf_eq_div_pos_div [covariant_class α α (*) (≤)] (a b : α) : a ⊓ b = a / (a / b)⁺ :=
calc a ⊓ b = (a * 1) ⊓ (a * (b / a)) : by { rw [mul_one a, div_eq_mul_inv, mul_comm b,
  mul_inv_cancel_left], }
... = a * (1 ⊓ (b / a))     : by rw ← mul_inf_eq_mul_inf_mul 1 (b / a) a
... = a * ((b / a) ⊓ 1)     : by rw inf_comm
... = a * ((a / b)⁻¹ ⊓ 1)   : by { rw div_eq_mul_inv, nth_rewrite 0 ← inv_inv b,
  rw [← mul_inv, mul_comm b⁻¹, ← div_eq_mul_inv], }
... = a * ((a / b)⁻¹ ⊓ 1⁻¹) : by rw inv_one
... = a / ((a / b) ⊔ 1)     : by rw [← inv_sup_eq_inv_inf_inv, ← div_eq_mul_inv]

-- Bourbaki A.VI.12 Prop 9 c)
@[to_additive le_iff_pos_le_neg_ge]
lemma m_le_iff_pos_le_neg_ge [covariant_class α α (*) (≤)] (a b : α) : a ≤ b ↔ a⁺ ≤ b⁺ ∧ b⁻ ≤ a⁻ :=
begin
  split; intro h,
  { split,
    { exact sup_le (h.trans (m_le_pos b)) (one_le_pos b), },
    { rw ← inv_le_inv_iff at h,
      exact sup_le (h.trans (inv_le_neg a)) (one_le_neg a), } },
  { rw [← pos_div_neg a, ← pos_div_neg b],
    exact div_le_div'' h.1 h.2, }
end

@[to_additive neg_abs]
lemma m_neg_abs [covariant_class α α (*) (≤)] (a : α) : |a|⁻ = 1 :=
begin
  refine le_antisymm _ _,
  { rw ← pos_inf_neg_eq_one a,
    apply le_inf,
    { rw pos_eq_neg_inv,
      exact ((m_le_iff_pos_le_neg_ge _ _).mp (inv_le_abs a)).right, },
    { exact and.right (iff.elim_left (m_le_iff_pos_le_neg_ge _ _) (le_mabs a)), } },
  { exact one_le_neg _, }
end

@[to_additive pos_abs]
lemma m_pos_abs [covariant_class α α (*) (≤)] (a : α) : |a|⁺ = |a| :=
begin
  nth_rewrite 1 ← pos_div_neg (|a|),
  rw div_eq_mul_inv,
  symmetry,
  rw [mul_right_eq_self, inv_eq_one],
  exact m_neg_abs a,
end

@[to_additive abs_nonneg]
lemma one_le_abs [covariant_class α α (*) (≤)] (a : α) : 1 ≤ |a| :=
by { rw ← m_pos_abs, exact one_le_pos _, }

-- The proof from Bourbaki A.VI.12 Prop 9 d)
-- |a| = a⁺ - a⁻
@[to_additive]
lemma pos_mul_neg [covariant_class α α (*) (≤)] (a : α) : |a| = a⁺ * a⁻ :=
begin
  refine le_antisymm _ _,
  { refine sup_le _ _,
    { nth_rewrite 0 ← mul_one a,
      exact mul_le_mul' (m_le_pos a) (one_le_neg a) },
    { nth_rewrite 0 ← one_mul (a⁻¹),
      exact mul_le_mul' (one_le_pos a) (inv_le_neg a) } },
  { rw [← inf_mul_sup, pos_inf_neg_eq_one, one_mul, ← m_pos_abs a],
    apply sup_le,
    { exact ((m_le_iff_pos_le_neg_ge _ _).mp (le_mabs a)).left, },
    { rw neg_eq_pos_inv,
      exact ((m_le_iff_pos_le_neg_ge _ _).mp (inv_le_abs a)).left, }, }
end

-- a ⊔ b - (a ⊓ b) = |b - a|
@[to_additive]
lemma sup_div_inf_eq_abs_div [covariant_class α α (*) (≤)] (a b : α) :
  (a ⊔ b) / (a ⊓ b) = |b / a| :=
begin
  rw [sup_eq_mul_pos_div, inf_comm, inf_eq_div_pos_div, div_eq_mul_inv],
  nth_rewrite 1 div_eq_mul_inv,
  rw [mul_inv_rev, inv_inv, mul_comm, ← mul_assoc, inv_mul_cancel_right, pos_eq_neg_inv (a / b)],
  nth_rewrite 1 div_eq_mul_inv,
  rw [mul_inv_rev, ← div_eq_mul_inv, inv_inv, ← pos_mul_neg],
end

-- 2•(a ⊔ b) = a + b + |b - a|
@[to_additive two_sup_eq_add_add_abs_sub]
lemma sup_sq_eq_mul_mul_abs_div [covariant_class α α (*) (≤)] (a b : α) :
  (a ⊔ b)^2 = a * b * |b / a| :=
by rw [← inf_mul_sup a b, ← sup_div_inf_eq_abs_div, div_eq_mul_inv, ← mul_assoc, mul_comm,
    mul_assoc, ← pow_two, inv_mul_cancel_left]

-- 2•(a ⊓ b) = a + b - |b - a|
@[to_additive two_inf_eq_add_sub_abs_sub]
lemma inf_sq_eq_mul_div_abs_div [covariant_class α α (*) (≤)] (a b : α) :
  (a ⊓ b)^2 = a * b / |b / a| :=
by rw [← inf_mul_sup a b, ← sup_div_inf_eq_abs_div, div_eq_mul_inv, div_eq_mul_inv,
    mul_inv_rev, inv_inv, mul_assoc, mul_inv_cancel_comm_assoc, ← pow_two]

/--
Every lattice ordered commutative group is a distributive lattice
-/
@[to_additive
  "Every lattice ordered commutative additive group is a distributive lattice"
]
def lattice_ordered_comm_group_to_distrib_lattice (α : Type u)
  [s: lattice α] [comm_group α] [covariant_class α α (*) (≤)] : distrib_lattice α :=
{ le_sup_inf :=
  begin
    intros,
    rw [← mul_le_mul_iff_left (x ⊓ (y ⊓ z)), inf_mul_sup x (y ⊓ z),
      ← inv_mul_le_iff_le_mul, le_inf_iff],
    split,
    { rw [inv_mul_le_iff_le_mul, ← inf_mul_sup x y],
      apply mul_le_mul',
      { apply inf_le_inf_left, apply inf_le_left, },
      { apply inf_le_left, } },
    { rw [inv_mul_le_iff_le_mul, ← inf_mul_sup x z],
      apply mul_le_mul',
      { apply inf_le_inf_left, apply inf_le_right, },
      { apply inf_le_right, }, }
  end,
  ..s }

-- See, e.g. Zaanen, Lectures on Riesz Spaces
-- 3rd lecture
-- |a ⊔ c - (b ⊔ c)| + |a ⊓ c-b ⊓ c| = |a - b|
@[to_additive]
theorem abs_div_sup_mul_abs_div_inf [covariant_class α α (*) (≤)] (a b c : α) :
  |(a ⊔ c) / (b ⊔ c)| * |(a ⊓ c) / (b ⊓ c)| = |a / b| :=
begin
  letI : distrib_lattice α := lattice_ordered_comm_group_to_distrib_lattice α,
  calc |(a ⊔ c) / (b ⊔ c)| * |(a ⊓ c) / (b ⊓ c)| =
    ((b ⊔ c ⊔ (a ⊔ c)) / ((b ⊔ c) ⊓ (a ⊔ c))) * |(a ⊓ c) / (b ⊓ c)| : by rw sup_div_inf_eq_abs_div
  ... = (b ⊔ c ⊔ (a ⊔ c)) / ((b ⊔ c) ⊓ (a ⊔ c)) * (((b ⊓ c) ⊔ (a ⊓ c)) / ((b ⊓ c) ⊓ (a ⊓ c))) :
    by rw sup_div_inf_eq_abs_div (b ⊓ c) (a ⊓ c)
  ... = (b ⊔ a ⊔ c) / ((b ⊓ a) ⊔ c) * (((b ⊔ a) ⊓ c) / (b ⊓ a ⊓ c)) : by
  { rw [← sup_inf_right, ← inf_sup_right, sup_assoc],
    nth_rewrite 1 sup_comm,
    rw [sup_right_idem, sup_assoc, inf_assoc],
    nth_rewrite 3 inf_comm,
    rw [inf_right_idem, inf_assoc], }
  ... = (b ⊔ a ⊔ c) * ((b ⊔ a) ⊓ c) /(((b ⊓ a) ⊔ c) * (b ⊓ a ⊓ c)) : by rw div_mul_div_comm
  ... = (b ⊔ a) * c / ((b ⊓ a) * c) :
    by rw [mul_comm, inf_mul_sup, mul_comm (b ⊓ a ⊔ c), inf_mul_sup]
  ... = (b ⊔ a) / (b ⊓ a) : by rw [div_eq_mul_inv, mul_inv_rev, mul_assoc, mul_inv_cancel_left,
      ← div_eq_mul_inv]
  ... = |a / b|           : by rw sup_div_inf_eq_abs_div
end

/-- If `a` is positive, then it is equal to its positive component `a⁺`. -/ -- pos_of_nonneg
@[to_additive "If `a` is positive, then it is equal to its positive component `a⁺`."]
lemma pos_of_one_le (a : α) (h : 1 ≤ a) : a⁺ = a :=
by { rw m_pos_part_def, exact sup_of_le_left h, }

-- 0 ≤ a implies a⁺ = a
@[to_additive] -- pos_of_nonpos
lemma pos_of_le_one (a : α) (h : a ≤ 1) : a⁺ = 1 :=
pos_eq_one_iff.mpr h

@[to_additive neg_of_inv_nonneg]
lemma neg_of_one_le_inv (a : α) (h : 1 ≤ a⁻¹) : a⁻ = a⁻¹ :=
by { rw neg_eq_pos_inv, exact pos_of_one_le _ h, }

@[to_additive] -- neg_of_neg_nonpos
lemma neg_of_inv_le_one (a : α) (h : a⁻¹ ≤ 1) : a⁻ = 1 :=
neg_eq_one_iff'.mpr h

@[to_additive] -- neg_of_nonpos
lemma neg_of_le_one [covariant_class α α (*) (≤)] (a : α) (h : a ≤ 1) : a⁻ = a⁻¹ :=
by { refine neg_of_one_le_inv _ _, rw one_le_inv', exact h, }

@[to_additive] -- neg_of_nonneg'
lemma neg_of_one_le [covariant_class α α (*) (≤)] (a : α) (h : 1 ≤ a) : a⁻ = 1 :=
neg_eq_one_iff.mpr h

-- 0 ≤ a implies |a| = a
@[to_additive abs_of_nonneg]
lemma mabs_of_one_le [covariant_class α α (*) (≤)] (a : α) (h : 1 ≤ a) : |a| = a :=
begin
  unfold has_abs.abs,
  rw [sup_eq_mul_pos_div, div_eq_mul_inv, inv_inv, ← pow_two, inv_mul_eq_iff_eq_mul,
    ← pow_two, pos_of_one_le],
  rw pow_two,
  apply one_le_mul h h,
end

/-- The unary operation of taking the absolute value is idempotent. -/
@[simp, to_additive abs_abs "The unary operation of taking the absolute value is idempotent."]
lemma mabs_mabs [covariant_class α α (*) (≤)] (a : α) : | |a| | = |a| :=
mabs_of_one_le _ (one_le_abs _)

@[to_additive abs_sup_sub_sup_le_abs]
lemma mabs_sup_div_sup_le_mabs [covariant_class α α (*) (≤)] (a b c : α) :
  |(a ⊔ c) / (b ⊔ c)| ≤ |a / b| :=
begin
  apply le_of_mul_le_of_one_le_left,
  { rw abs_div_sup_mul_abs_div_inf, },
  { exact one_le_abs _, },
end

@[to_additive abs_inf_sub_inf_le_abs]
lemma mabs_inf_div_inf_le_mabs [covariant_class α α (*) (≤)] (a b c : α) :
  |(a ⊓ c) / (b ⊓ c)| ≤ |a / b| :=
begin
  apply le_of_mul_le_of_one_le_right,
  { rw abs_div_sup_mul_abs_div_inf, },
  { exact one_le_abs _, },
end

-- Commutative case, Zaanen, 3rd lecture
-- For the non-commutative case, see Birkhoff Theorem 19 (27)
-- |(a ⊔ c) - (b ⊔ c)| ⊔ |(a ⊓ c) - (b ⊓ c)| ≤ |a - b|
@[to_additive Birkhoff_inequalities]
theorem m_Birkhoff_inequalities [covariant_class α α (*) (≤)] (a b c : α) :
|(a ⊔ c) / (b ⊔ c)| ⊔ |(a ⊓ c) / (b ⊓ c)| ≤ |a / b| :=
sup_le (mabs_sup_div_sup_le_mabs a b c) (mabs_inf_div_inf_le_mabs a b c)

-- Banasiak Proposition 2.12, Zaanen 2nd lecture
/--
The absolute value satisfies the triangle inequality.
-/
@[to_additive abs_add_le]
lemma mabs_mul_le [covariant_class α α (*) (≤)] (a b : α) : |a * b| ≤ |a| * |b| :=
begin
  apply sup_le,
  { exact mul_le_mul' (le_mabs a) (le_mabs b), },
  { rw mul_inv,
    exact mul_le_mul' (inv_le_abs _) (inv_le_abs _), }
end

-- |a - b| = |b - a|
@[to_additive]
lemma abs_inv_comm (a b : α) : |a/b| = |b/a| :=
begin
  unfold has_abs.abs,
  rw [inv_div a b, ← inv_inv (a / b), inv_div, sup_comm],
end

-- | |a| - |b| | ≤ |a - b|
@[to_additive]
lemma abs_abs_div_abs_le [covariant_class α α (*) (≤)] (a b : α) : | |a| / |b| | ≤ |a / b| :=
begin
  unfold has_abs.abs,
  rw sup_le_iff,
  split,
  { apply div_le_iff_le_mul.2,
    convert mabs_mul_le (a/b) b,
    { rw div_mul_cancel', },
    { rw div_mul_cancel', },
    { exact covariant_swap_mul_le_of_covariant_mul_le α, } },
  { rw [div_eq_mul_inv, mul_inv_rev, inv_inv, mul_inv_le_iff_le_mul, ← abs_eq_sup_inv (a / b),
      abs_inv_comm],
    convert  mabs_mul_le (b/a) a,
    { rw div_mul_cancel', },
    {rw div_mul_cancel', } },
end

end lattice_ordered_comm_group


<|start_filename|>src/representation_theory/fdRep.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import representation_theory.Rep
import algebra.category.FinVect

/-!
# `fdRep k G` is the category of finite dimensional `k`-linear representations of `G`.

If `V : fdRep k G`, there is a coercion that allows you to treat `V` as a type,
and this type comes equipped with `module k V` and `finite_dimensional k V` instances.
Also `V.ρ` gives the homomorphism `G →* (V →ₗ[k] V)`.

Conversely, given a homomorphism `ρ : G →* (V →ₗ[k] V)`,
you can construct the bundled representation as `Rep.of ρ`.

We verify that `fdRep k G` is a rigid monoidal category.

## TODO
* `fdRep k G` has all finite (co)limits.
* `fdRep k G` is abelian.
* `fdRep k G ≌ FinVect (monoid_algebra k G)` (this will require generalising `FinVect` first).
* Upgrade the right rigid structure to a rigid structure.
-/

universes u

open category_theory
open category_theory.limits

/-- The category of finite dimensional `k`-linear representations of a monoid `G`. -/
@[derive [large_category, concrete_category/-, has_limits, has_colimits-/]]
abbreviation fdRep (k G : Type u) [field k] [monoid G] :=
Action (FinVect.{u} k) (Mon.of G)

namespace fdRep

variables {k G : Type u} [field k] [monoid G]

instance : has_coe_to_sort (fdRep k G) (Type u) := concrete_category.has_coe_to_sort _

instance (V : fdRep k G) : add_comm_group V :=
by { change add_comm_group ((forget₂ (fdRep k G) (FinVect k)).obj V), apply_instance, }

instance (V : fdRep k G) : module k V :=
by { change module k ((forget₂ (fdRep k G) (FinVect k)).obj V), apply_instance, }

instance (V : fdRep k G) : finite_dimensional k V :=
by { change finite_dimensional k ((forget₂ (fdRep k G) (FinVect k)).obj V), apply_instance, }

-- This works well with the new design for representations:
example (V : fdRep k G) : G →* (V →ₗ[k] V) := V.ρ

/-- Lift an unbundled representation to `Rep`. -/
@[simps ρ]
def of {V : Type u} [add_comm_group V] [module k V] [finite_dimensional k V]
  (ρ : G →* (V →ₗ[k] V)) : Rep k G :=
⟨FinVect.of k V, ρ⟩

instance : has_forget₂ (fdRep k G) (Rep k G) :=
{ forget₂ := (forget₂ (FinVect k) (Module k)).map_Action (Mon.of G), }

-- Verify that the monoidal structure is available.
example : monoidal_category (fdRep k G) := by apply_instance

end fdRep

namespace fdRep
variables {k G : Type u} [field k] [group G]

-- Verify that the rigid structure is available when the monoid is a group.
noncomputable instance : right_rigid_category (fdRep k G) :=
by { change right_rigid_category (Action (FinVect k) (Group.of G)), apply_instance, }

end fdRep


<|start_filename|>src/algebra/algebra/restrict_scalars.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.algebra.tower

/-!

# The `restrict_scalars` type alias

See the documentation attached to the `restrict_scalars` definition for advice on how and when to
use this type alias. As described there, it is often a better choice to use the `is_scalar_tower`
typeclass instead.

## Main definitions

* `restrict_scalars R S M`: the `S`-module `M` viewed as an `R` module when `S` is an `R`-algebra.
  Note that by default we do *not* have a `module S (restrict_scalars R S M)` instance
  for the original action.
  This is available as a def `restrict_scalars.module_orig` if really needed.
* `restrict_scalars.add_equiv : restrict_scalars R S M ≃+ M`: the additive equivalence
  between the restricted and original space (in fact, they are definitionally equal,
  but sometimes it is helpful to avoid using this fact, to keep instances from leaking).
* `restrict_scalars.ring_equiv : restrict_scalars R S A ≃+* A`: the ring equivalence
   between the restricted and original space when the module is an algebra.

## See also

There are many similarly-named definitions elsewhere which do not refer to this type alias. These
refer to restricting the scalar type in a bundled type, such as from `A →ₗ[R] B` to `A →ₗ[S] B`:

* `linear_map.restrict_scalars`
* `linear_equiv.restrict_scalars`
* `alg_hom.restrict_scalars`
* `alg_equiv.restrict_scalars`
* `submodule.restrict_scalars`
* `subalgebra.restrict_scalars`
-/

variables (R S M A : Type*)

/-- If we put an `R`-algebra structure on a semiring `S`, we get a natural equivalence from the
category of `S`-modules to the category of representations of the algebra `S` (over `R`). The type
synonym `restrict_scalars` is essentially this equivalence.

Warning: use this type synonym judiciously! Consider an example where we want to construct an
`R`-linear map from `M` to `S`, given:
```lean
variables (R S M : Type*)
variables [comm_semiring R] [semiring S] [algebra R S] [add_comm_monoid M] [module S M]
```
With the assumptions above we can't directly state our map as we have no `module R M` structure, but
`restrict_scalars` permits it to be written as:
```lean
-- an `R`-module structure on `M` is provided by `restrict_scalars` which is compatible
example : restrict_scalars R S M →ₗ[R] S := sorry
```
However, it is usually better just to add this extra structure as an argument:
```lean
-- an `R`-module structure on `M` and proof of its compatibility is provided by the user
example [module R M] [is_scalar_tower R S M] : M →ₗ[R] S := sorry
```
The advantage of the second approach is that it defers the duty of providing the missing typeclasses
`[module R M] [is_scalar_tower R S M]`. If some concrete `M` naturally carries these (as is often
the case) then we have avoided `restrict_scalars` entirely. If not, we can pass
`restrict_scalars R S M` later on instead of `M`.

Note that this means we almost always want to state definitions and lemmas in the language of
`is_scalar_tower` rather than `restrict_scalars`.

An example of when one might want to use `restrict_scalars` would be if one has a vector space
over a field of characteristic zero and wishes to make use of the `ℚ`-algebra structure. -/
@[nolint unused_arguments]
def restrict_scalars (R S M : Type*) : Type* := M

instance [I : inhabited M] : inhabited (restrict_scalars R S M) := I

instance [I : add_comm_monoid M] : add_comm_monoid (restrict_scalars R S M) := I

instance [I : add_comm_group M] : add_comm_group (restrict_scalars R S M) := I

section module

section
variables [semiring S] [add_comm_monoid M]

/-- We temporarily install an action of the original ring on `restrict_sclars R S M`. -/
def restrict_scalars.module_orig [I : module S M] :
  module S (restrict_scalars R S M) := I

variables [comm_semiring R] [algebra R S]
section
local attribute [instance] restrict_scalars.module_orig

/--
When `M` is a module over a ring `S`, and `S` is an algebra over `R`, then `M` inherits a
module structure over `R`.

The preferred way of setting this up is `[module R M] [module S M] [is_scalar_tower R S M]`.
-/
instance [module S M] : module R (restrict_scalars R S M) :=
module.comp_hom M (algebra_map R S)

/--
This instance is only relevant when `restrict_scalars.module_orig` is available as an instance.
-/
instance [module S M] : is_scalar_tower R S (restrict_scalars R S M) :=
⟨λ r S M, by { rw [algebra.smul_def, mul_smul], refl }⟩

end

/--
When `M` is a right-module over a ring `S`, and `S` is an algebra over `R`, then `M` inherits a
right-module structure over `R`.
The preferred way of setting this up is
`[module Rᵐᵒᵖ M] [module Sᵐᵒᵖ M] [is_scalar_tower Rᵐᵒᵖ Sᵐᵒᵖ M]`.
-/
instance restrict_scalars.op_module [module Sᵐᵒᵖ M] : module Rᵐᵒᵖ (restrict_scalars R S M) :=
begin
  letI : module Sᵐᵒᵖ (restrict_scalars R S M) := ‹module Sᵐᵒᵖ M›,
  exact module.comp_hom M (algebra_map R S).op
end

instance restrict_scalars.is_central_scalar [module S M] [module Sᵐᵒᵖ M] [is_central_scalar S M] :
  is_central_scalar R (restrict_scalars R S M) :=
{ op_smul_eq_smul := λ r x, (op_smul_eq_smul (algebra_map R S r) (_ : M) : _)}

/--
The `R`-algebra homomorphism from the original coefficient algebra `S` to endomorphisms
of `restrict_scalars R S M`.
-/
def restrict_scalars.lsmul [module S M] : S →ₐ[R] module.End R (restrict_scalars R S M) :=
begin
  -- We use `restrict_scalars.module_orig` in the implementation,
  -- but not in the type.
  letI : module S (restrict_scalars R S M) := restrict_scalars.module_orig R S M,
  exact algebra.lsmul R (restrict_scalars R S M),
end

end

variables [add_comm_monoid M]

/-- `restrict_scalars.add_equiv` is the additive equivalence with the original module. -/
@[simps] def restrict_scalars.add_equiv : restrict_scalars R S M ≃+ M :=
add_equiv.refl M

variables [comm_semiring R] [semiring S] [algebra R S] [module S M]

lemma restrict_scalars_smul_def (c : R) (x : restrict_scalars R S M) :
  c • x = ((algebra_map R S c) • x : M) := rfl

@[simp] lemma restrict_scalars.add_equiv_map_smul (t : R) (x : restrict_scalars R S M) :
  restrict_scalars.add_equiv R S M (t • x)
  = (algebra_map R S t) • restrict_scalars.add_equiv R S M x :=
rfl

end module

section algebra

instance [I : semiring A] : semiring (restrict_scalars R S A) := I
instance [I : ring A] : ring (restrict_scalars R S A) := I
instance [I : comm_semiring A] : comm_semiring (restrict_scalars R S A) := I
instance [I : comm_ring A] : comm_ring (restrict_scalars R S A) := I

variables [semiring A]

/-- Tautological ring isomorphism `restrict_scalars R S A ≃+* A`. -/
def restrict_scalars.ring_equiv : restrict_scalars R S A ≃+* A := ring_equiv.refl _

variables [comm_semiring S] [algebra S A] [comm_semiring R] [algebra R S]

@[simp] lemma restrict_scalars.ring_equiv_map_smul (r : R) (x : restrict_scalars R S A) :
  restrict_scalars.ring_equiv R S A (r • x)
  = (algebra_map R S r) • restrict_scalars.ring_equiv R S A x :=
rfl

/-- `R ⟶ S` induces `S-Alg ⥤ R-Alg` -/
instance : algebra R (restrict_scalars R S A) :=
{ smul := (•),
  commutes' := λ r x, algebra.commutes _ _,
  smul_def' := λ _ _, algebra.smul_def _ _,
  .. (algebra_map S A).comp (algebra_map R S) }

@[simp] lemma restrict_scalars.ring_equiv_algebra_map (r : R) :
  restrict_scalars.ring_equiv R S A (algebra_map R (restrict_scalars R S A) r) =
    algebra_map S A (algebra_map R S r) :=
rfl

end algebra


<|start_filename|>src/algebra/order/module.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.module.pi
import algebra.module.prod
import algebra.order.pi
import algebra.order.smul
import data.set.pointwise

/-!
# Ordered module

In this file we provide lemmas about `ordered_smul` that hold once a module structure is present.

## References

* https://en.wikipedia.org/wiki/Ordered_module

## Tags

ordered module, ordered scalar, ordered smul, ordered action, ordered vector space
-/

open_locale pointwise

variables {k M N : Type*}

namespace order_dual

instance [semiring k] [ordered_add_comm_monoid M] [module k M] : module k Mᵒᵈ :=
{ add_smul := λ r s x, order_dual.rec (add_smul _ _) x,
  zero_smul := λ m, order_dual.rec (zero_smul _) m }

end order_dual

section semiring
variables [ordered_semiring k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {a b : M} {c : k}

/- can be generalized from `module k M` to `distrib_mul_action_with_zero k M` once it exists.
where `distrib_mul_action_with_zero k M`is the conjunction of `distrib_mul_action k M` and
`smul_with_zero k M`.-/
lemma smul_neg_iff_of_pos (hc : 0 < c) :
  c • a < 0 ↔ a < 0 :=
begin
  rw [←neg_neg a, smul_neg, neg_neg_iff_pos, neg_neg_iff_pos],
  exact smul_pos_iff_of_pos hc,
end

end semiring

section ring
variables [ordered_ring k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {a b : M} {c : k}

lemma smul_lt_smul_of_neg (h : a < b) (hc : c < 0) :
  c • b < c • a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_lt_neg_iff],
  exact smul_lt_smul_of_pos h (neg_pos_of_neg hc),
end

lemma smul_le_smul_of_nonpos (h : a ≤ b) (hc : c ≤ 0) :
  c • b ≤ c • a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_le_neg_iff],
  exact smul_le_smul_of_nonneg h (neg_nonneg_of_nonpos hc),
end

lemma eq_of_smul_eq_smul_of_neg_of_le (hab : c • a = c • b) (hc : c < 0) (h : a ≤ b) :
  a = b :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_inj] at hab,
  exact eq_of_smul_eq_smul_of_pos_of_le hab (neg_pos_of_neg hc) h,
end

lemma lt_of_smul_lt_smul_of_nonpos (h : c • a < c • b) (hc : c ≤ 0) :
  b < a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_lt_neg_iff] at h,
  exact lt_of_smul_lt_smul_of_nonneg h (neg_nonneg_of_nonpos hc),
end

lemma smul_lt_smul_iff_of_neg (hc : c < 0) :
  c • a < c • b ↔ b < a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_lt_neg_iff],
  exact smul_lt_smul_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_neg_iff_of_neg (hc : c < 0) :
  c • a < 0 ↔ 0 < a :=
begin
  rw [←neg_neg c, neg_smul, neg_neg_iff_pos],
  exact smul_pos_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_pos_iff_of_neg (hc : c < 0) :
  0 < c • a ↔ a < 0 :=
begin
  rw [←neg_neg c, neg_smul, neg_pos],
  exact smul_neg_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_nonpos_of_nonpos_of_nonneg (hc : c ≤ 0) (ha : 0 ≤ a) : c • a ≤ 0 :=
calc
  c • a ≤ c • 0 : smul_le_smul_of_nonpos ha hc
  ... = 0 : smul_zero' M c

lemma smul_nonneg_of_nonpos_of_nonpos (hc : c ≤ 0) (ha : a ≤ 0) : 0 ≤ c • a :=
@smul_nonpos_of_nonpos_of_nonneg k Mᵒᵈ _ _ _ _ _ _ hc ha

alias smul_pos_iff_of_neg ↔ _ smul_pos_of_neg_of_neg
alias smul_neg_iff_of_pos ↔ _ smul_neg_of_pos_of_neg
alias smul_neg_iff_of_neg ↔ _ smul_neg_of_neg_of_pos

lemma antitone_smul_left (hc : c ≤ 0) : antitone (has_scalar.smul c : M → M) :=
λ a b h, smul_le_smul_of_nonpos h hc

lemma strict_anti_smul_left (hc : c < 0) : strict_anti (has_scalar.smul c : M → M) :=
λ a b h, smul_lt_smul_of_neg h hc

/-- Binary **rearrangement inequality**. -/
lemma smul_add_smul_le_smul_add_smul [contravariant_class M M (+) (≤)] {a b : k} {c d : M}
  (hab : a ≤ b) (hcd : c ≤ d) :
  a • d + b • c ≤ a • c + b • d :=
begin
  obtain ⟨b, rfl⟩ := exists_add_of_le hab,
  obtain ⟨d, rfl⟩ := exists_add_of_le hcd,
  rw [smul_add, add_right_comm, smul_add, ←add_assoc, add_smul _ _ d],
  rw le_add_iff_nonneg_right at hab hcd,
  exact add_le_add_left (le_add_of_nonneg_right $ smul_nonneg hab hcd) _,
end

/-- Binary **rearrangement inequality**. -/
lemma smul_add_smul_le_smul_add_smul' [contravariant_class M M (+) (≤)] {a b : k} {c d : M}
  (hba : b ≤ a) (hdc : d ≤ c) : a • d + b • c ≤ a • c + b • d :=
by { rw [add_comm (a • d), add_comm (a • c)], exact smul_add_smul_le_smul_add_smul hba hdc }

/-- Binary strict **rearrangement inequality**. -/
lemma smul_add_smul_lt_smul_add_smul [covariant_class M M (+) (<)] [contravariant_class M M (+) (<)]
  {a b : k} {c d : M} (hab : a < b) (hcd : c < d) : a • d + b • c < a • c + b • d :=
begin
  obtain ⟨b, rfl⟩ := exists_add_of_le hab.le,
  obtain ⟨d, rfl⟩ := exists_add_of_le hcd.le,
  rw [smul_add, add_right_comm, smul_add, ←add_assoc, add_smul _ _ d],
  rw lt_add_iff_pos_right at hab hcd,
  exact add_lt_add_left (lt_add_of_pos_right _ $ smul_pos hab hcd) _,
end

/-- Binary strict **rearrangement inequality**. -/
lemma smul_add_smul_lt_smul_add_smul' [covariant_class M M (+) (<)]
  [contravariant_class M M (+) (<)] {a b : k} {c d : M} (hba : b < a) (hdc : d < c) :
  a • d + b • c < a • c + b • d :=
by { rw [add_comm (a • d), add_comm (a • c)], exact smul_add_smul_lt_smul_add_smul hba hdc }

end ring

section field
variables [linear_ordered_field k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {a b : M} {c : k}

lemma smul_le_smul_iff_of_neg (hc : c < 0) : c • a ≤ c • b ↔ b ≤ a :=
begin
  rw [←neg_neg c, neg_smul, neg_smul (-c), neg_le_neg_iff],
  exact smul_le_smul_iff_of_pos (neg_pos_of_neg hc),
end

lemma smul_lt_iff_of_neg (hc : c < 0) : c • a < b ↔ c⁻¹ • b < a :=
begin
  rw [←neg_neg c, ←neg_neg a, neg_smul_neg, inv_neg, neg_smul _ b, neg_lt_neg_iff],
  exact smul_lt_iff_of_pos (neg_pos_of_neg hc),
end

lemma lt_smul_iff_of_neg (hc : c < 0) : a < c • b ↔ b < c⁻¹ • a :=
begin
  rw [←neg_neg c, ←neg_neg b, neg_smul_neg, inv_neg, neg_smul _ a, neg_lt_neg_iff],
  exact lt_smul_iff_of_pos (neg_pos_of_neg hc),
end

variables (M)

/-- Left scalar multiplication as an order isomorphism. -/
@[simps] def order_iso.smul_left_dual {c : k} (hc : c < 0) : M ≃o Mᵒᵈ :=
{ to_fun := λ b, order_dual.to_dual (c • b),
  inv_fun := λ b, c⁻¹ • (order_dual.of_dual b),
  left_inv := inv_smul_smul₀ hc.ne,
  right_inv := smul_inv_smul₀ hc.ne,
  map_rel_iff' := λ b₁ b₂, smul_le_smul_iff_of_neg hc }

variables {M} [ordered_add_comm_group N] [module k N] [ordered_smul k N]

-- TODO: solve `prod.has_lt` and `prod.has_le` misalignment issue
instance prod.ordered_smul : ordered_smul k (M × N) :=
ordered_smul.mk' $ λ (v u : M × N) (c : k) h hc,
  ⟨smul_le_smul_of_nonneg h.1.1 hc.le, smul_le_smul_of_nonneg h.1.2 hc.le⟩

instance pi.ordered_smul {ι : Type*} {M : ι → Type*} [Π i, ordered_add_comm_group (M i)]
  [Π i, mul_action_with_zero k (M i)] [∀ i, ordered_smul k (M i)] :
  ordered_smul k (Π i : ι, M i) :=
begin
  refine (ordered_smul.mk' $ λ v u c h hc i, _),
  change c • v i ≤ c • u i,
  exact smul_le_smul_of_nonneg (h.le i) hc.le,
end

-- Sometimes Lean fails to apply the dependent version to non-dependent functions,
-- so we define another instance
instance pi.ordered_smul' {ι : Type*} {M : Type*} [ordered_add_comm_group M]
  [mul_action_with_zero k M] [ordered_smul k M] :
  ordered_smul k (ι → M) :=
pi.ordered_smul

end field

/-! ### Upper/lower bounds -/

section ordered_semiring
variables [ordered_semiring k] [ordered_add_comm_monoid M] [smul_with_zero k M] [ordered_smul k M]
  {s : set M} {c : k}

lemma smul_lower_bounds_subset_lower_bounds_smul (hc : 0 ≤ c) :
  c • lower_bounds s ⊆ lower_bounds (c • s) :=
(monotone_smul_left hc).image_lower_bounds_subset_lower_bounds_image

lemma smul_upper_bounds_subset_upper_bounds_smul (hc : 0 ≤ c) :
  c • upper_bounds s ⊆ upper_bounds (c • s) :=
(monotone_smul_left hc).image_upper_bounds_subset_upper_bounds_image

lemma bdd_below.smul_of_nonneg (hs : bdd_below s) (hc : 0 ≤ c) : bdd_below (c • s) :=
(monotone_smul_left hc).map_bdd_below hs

lemma bdd_above.smul_of_nonneg (hs : bdd_above s) (hc : 0 ≤ c) : bdd_above (c • s) :=
(monotone_smul_left hc).map_bdd_above hs

end ordered_semiring

section ordered_ring
variables [ordered_ring k] [ordered_add_comm_group M] [module k M] [ordered_smul k M]
  {s : set M} {c : k}

lemma smul_lower_bounds_subset_upper_bounds_smul (hc : c ≤ 0) :
  c • lower_bounds s ⊆ upper_bounds (c • s) :=
(antitone_smul_left hc).image_lower_bounds_subset_upper_bounds_image

lemma smul_upper_bounds_subset_lower_bounds_smul (hc : c ≤ 0) :
  c • upper_bounds s ⊆ lower_bounds (c • s) :=
(antitone_smul_left hc).image_upper_bounds_subset_lower_bounds_image

lemma bdd_below.smul_of_nonpos (hc : c ≤ 0) (hs : bdd_below s) : bdd_above (c • s) :=
(antitone_smul_left hc).map_bdd_below hs

lemma bdd_above.smul_of_nonpos (hc : c ≤ 0) (hs : bdd_above s) : bdd_below (c • s) :=
(antitone_smul_left hc).map_bdd_above hs

end ordered_ring

section linear_ordered_field
variables [linear_ordered_field k] [ordered_add_comm_group M]

section mul_action_with_zero
variables [mul_action_with_zero k M] [ordered_smul k M] {s t : set M} {c : k}

@[simp] lemma lower_bounds_smul_of_pos (hc : 0 < c) : lower_bounds (c • s) = c • lower_bounds s :=
(order_iso.smul_left _ hc).lower_bounds_image

@[simp] lemma upper_bounds_smul_of_pos (hc : 0 < c) : upper_bounds (c • s) = c • upper_bounds s :=
(order_iso.smul_left _ hc).upper_bounds_image

@[simp] lemma bdd_below_smul_iff_of_pos (hc : 0 < c) : bdd_below (c • s) ↔ bdd_below s :=
(order_iso.smul_left _ hc).bdd_below_image

@[simp] lemma bdd_above_smul_iff_of_pos (hc : 0 < c) : bdd_above (c • s) ↔ bdd_above s :=
(order_iso.smul_left _ hc).bdd_above_image

end mul_action_with_zero

section module
variables [module k M] [ordered_smul k M] {s t : set M} {c : k}

@[simp] lemma lower_bounds_smul_of_neg (hc : c < 0) : lower_bounds (c • s) = c • upper_bounds s :=
(order_iso.smul_left_dual M hc).upper_bounds_image

@[simp] lemma upper_bounds_smul_of_neg (hc : c < 0) : upper_bounds (c • s) = c • lower_bounds s :=
(order_iso.smul_left_dual M hc).lower_bounds_image

@[simp] lemma bdd_below_smul_iff_of_neg (hc : c < 0) : bdd_below (c • s) ↔ bdd_above s :=
(order_iso.smul_left_dual M hc).bdd_above_image

@[simp] lemma bdd_above_smul_iff_of_neg (hc : c < 0) : bdd_above (c • s) ↔ bdd_below s :=
(order_iso.smul_left_dual M hc).bdd_below_image

end module
end linear_ordered_field


<|start_filename|>src/set_theory/cardinal/continuum.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import set_theory.cardinal.ordinal

/-!
# Cardinality of continuum

In this file we define `cardinal.continuum` (notation: `𝔠`, localized in `cardinal`) to be `2 ^ ℵ₀`.
We also prove some `simp` lemmas about cardinal arithmetic involving `𝔠`.

## Notation

- `𝔠` : notation for `cardinal.continuum` in locale `cardinal`.
-/

namespace cardinal

universes u v

open_locale cardinal

/-- Cardinality of continuum. -/
def continuum : cardinal.{u} := 2 ^ aleph_0.{u}

localized "notation `𝔠` := cardinal.continuum" in cardinal

@[simp] lemma two_power_aleph_0 : 2 ^ aleph_0.{u} = continuum.{u} := rfl

@[simp] lemma lift_continuum : lift.{v} 𝔠 = 𝔠 :=
by rw [←two_power_aleph_0, lift_two_power, lift_aleph_0, two_power_aleph_0]

/-!
### Inequalities
-/

lemma aleph_0_lt_continuum : ℵ₀ < 𝔠 := cantor ℵ₀

lemma aleph_0_le_continuum : ℵ₀ ≤ 𝔠 := aleph_0_lt_continuum.le

lemma nat_lt_continuum (n : ℕ) : ↑n < 𝔠 := (nat_lt_aleph_0 n).trans aleph_0_lt_continuum

lemma mk_set_nat : #(set ℕ) = 𝔠 := by simp

lemma continuum_pos : 0 < 𝔠 := nat_lt_continuum 0

lemma continuum_ne_zero : 𝔠 ≠ 0 := continuum_pos.ne'

lemma aleph_one_le_continuum : aleph 1 ≤ 𝔠 :=
by { rw ←succ_aleph_0, exact order.succ_le_of_lt aleph_0_lt_continuum }

/-!
### Addition
-/

@[simp] lemma aleph_0_add_continuum : ℵ₀ + 𝔠 = 𝔠 :=
add_eq_right aleph_0_le_continuum aleph_0_le_continuum

@[simp] lemma continuum_add_aleph_0 : 𝔠 + ℵ₀ = 𝔠 :=
(add_comm _ _).trans aleph_0_add_continuum

@[simp] lemma continuum_add_self : 𝔠 + 𝔠 = 𝔠 :=
add_eq_right aleph_0_le_continuum le_rfl

@[simp] lemma nat_add_continuum (n : ℕ) : ↑n + 𝔠 = 𝔠 :=
add_eq_right aleph_0_le_continuum (nat_lt_continuum n).le

@[simp] lemma continuum_add_nat (n : ℕ) : 𝔠 + n = 𝔠 :=
(add_comm _ _).trans (nat_add_continuum n)

/-!
### Multiplication
-/

@[simp] lemma continuum_mul_self : 𝔠 * 𝔠 = 𝔠 :=
mul_eq_left aleph_0_le_continuum le_rfl continuum_ne_zero

@[simp] lemma continuum_mul_aleph_0 : 𝔠 * ℵ₀ = 𝔠 :=
mul_eq_left aleph_0_le_continuum aleph_0_le_continuum aleph_0_ne_zero

@[simp] lemma aleph_0_mul_continuum : ℵ₀ * 𝔠 = 𝔠 :=
(mul_comm _ _).trans continuum_mul_aleph_0

@[simp] lemma nat_mul_continuum {n : ℕ} (hn : n ≠ 0) : ↑n * 𝔠 = 𝔠 :=
mul_eq_right aleph_0_le_continuum (nat_lt_continuum n).le (nat.cast_ne_zero.2 hn)

@[simp] lemma continuum_mul_nat {n : ℕ} (hn : n ≠ 0) : 𝔠 * n = 𝔠 :=
(mul_comm _ _).trans (nat_mul_continuum hn)

/-!
### Power
-/

@[simp] lemma aleph_0_power_aleph_0 : aleph_0.{u} ^ aleph_0.{u} = 𝔠 :=
power_self_eq le_rfl

@[simp] lemma nat_power_aleph_0 {n : ℕ} (hn : 2 ≤ n) : (n ^ aleph_0.{u} : cardinal.{u}) = 𝔠 :=
nat_power_eq le_rfl hn

@[simp] lemma continuum_power_aleph_0 : continuum.{u} ^ aleph_0.{u} = 𝔠 :=
by rw [←two_power_aleph_0, ←power_mul, mul_eq_left le_rfl le_rfl aleph_0_ne_zero]

end cardinal


<|start_filename|>src/data/list/infix.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.list.basic

/-!
# Prefixes, subfixes, infixes

This file proves properties about
* `list.prefix`: `l₁` is a prefix of `l₂` if `l₂` starts with `l₁`.
* `list.subfix`: `l₁` is a subfix of `l₂` if `l₂` ends with `l₁`.
* `list.infix`: `l₁` is an infix of `l₂` if `l₁` is a prefix of some subfix of `l₂`.
* `list.inits`: The list of prefixes of a list.
* `list.tails`: The list of prefixes of a list.
* `insert` on lists

All those (except `insert`) are defined in `data.list.defs`.

## Notation

`l₁ <+: l₂`: `l₁` is a prefix of `l₂`.
`l₁ <:+ l₂`: `l₁` is a subfix of `l₂`.
`l₁ <:+: l₂`: `l₁` is an infix of `l₂`.
-/

open nat

variables {α β : Type*}

namespace list
variables {l l₁ l₂ l₃ : list α} {a b : α} {m n : ℕ}

/-! ### prefix, suffix, infix -/

section fix

@[simp] lemma prefix_append (l₁ l₂ : list α) : l₁ <+: l₁ ++ l₂ := ⟨l₂, rfl⟩
@[simp] lemma suffix_append (l₁ l₂ : list α) : l₂ <:+ l₁ ++ l₂ := ⟨l₁, rfl⟩

lemma infix_append (l₁ l₂ l₃ : list α) : l₂ <:+: l₁ ++ l₂ ++ l₃ := ⟨l₁, l₃, rfl⟩

@[simp] lemma infix_append' (l₁ l₂ l₃ : list α) : l₂ <:+: l₁ ++ (l₂ ++ l₃) :=
by rw ← list.append_assoc; apply infix_append

lemma is_prefix.is_infix : l₁ <+: l₂ → l₁ <:+: l₂ := λ ⟨t, h⟩, ⟨[], t, h⟩
lemma is_suffix.is_infix : l₁ <:+ l₂ → l₁ <:+: l₂ := λ ⟨t, h⟩, ⟨t, [], by rw [h, append_nil]⟩

lemma nil_prefix (l : list α) : [] <+: l := ⟨l, rfl⟩
lemma nil_suffix (l : list α) : [] <:+ l := ⟨l, append_nil _⟩
lemma nil_infix (l : list α) : [] <:+: l := (nil_prefix _).is_infix

@[refl] lemma prefix_refl (l : list α) : l <+: l := ⟨[], append_nil _⟩
@[refl] lemma suffix_refl (l : list α) : l <:+ l := ⟨[], rfl⟩
@[refl] lemma infix_refl (l : list α) : l <:+: l := (prefix_refl l).is_infix

lemma prefix_rfl : l <+: l := prefix_refl _
lemma suffix_rfl : l <:+ l := suffix_refl _
lemma infix_rfl : l <:+: l := infix_refl _

@[simp] lemma suffix_cons (a : α) : ∀ l, l <:+ a :: l := suffix_append [a]

lemma prefix_concat (a : α) (l) : l <+: concat l a := by simp

lemma infix_cons : l₁ <:+: l₂ → l₁ <:+: a :: l₂ := λ ⟨L₁, L₂, h⟩, ⟨a :: L₁, L₂, h ▸ rfl⟩
lemma infix_concat : l₁ <:+: l₂ → l₁ <:+: concat l₂ a :=
λ ⟨L₁, L₂, h⟩, ⟨L₁, concat L₂ a, by simp_rw [←h, concat_eq_append, append_assoc]⟩

@[trans] lemma is_prefix.trans : ∀ {l₁ l₂ l₃ : list α}, l₁ <+: l₂ → l₂ <+: l₃ → l₁ <+: l₃
| l ._ ._ ⟨r₁, rfl⟩ ⟨r₂, rfl⟩ := ⟨r₁ ++ r₂, (append_assoc _ _ _).symm⟩

@[trans] lemma is_suffix.trans : ∀ {l₁ l₂ l₃ : list α}, l₁ <:+ l₂ → l₂ <:+ l₃ → l₁ <:+ l₃
| l ._ ._ ⟨l₁, rfl⟩ ⟨l₂, rfl⟩ := ⟨l₂ ++ l₁, append_assoc _ _ _⟩

@[trans] lemma is_infix.trans : ∀ {l₁ l₂ l₃ : list α}, l₁ <:+: l₂ → l₂ <:+: l₃ → l₁ <:+: l₃
| l ._ ._ ⟨l₁, r₁, rfl⟩ ⟨l₂, r₂, rfl⟩ := ⟨l₂ ++ l₁, r₁ ++ r₂, by simp only [append_assoc]⟩

protected lemma is_infix.sublist : l₁ <:+: l₂ → l₁ <+ l₂ :=
λ ⟨s, t, h⟩, by { rw [← h], exact (sublist_append_right _ _).trans (sublist_append_left _ _) }

protected lemma is_infix.subset (hl : l₁ <:+: l₂) : l₁ ⊆ l₂ :=
hl.sublist.subset

protected lemma is_prefix.sublist (h : l₁ <+: l₂) : l₁ <+ l₂ :=
h.is_infix.sublist

protected lemma is_prefix.subset (hl : l₁ <+: l₂) : l₁ ⊆ l₂ :=
hl.sublist.subset

protected lemma is_suffix.sublist (h : l₁ <:+ l₂) : l₁ <+ l₂ :=
h.is_infix.sublist

protected lemma is_suffix.subset (hl : l₁ <:+ l₂) : l₁ ⊆ l₂ :=
hl.sublist.subset

@[simp] lemma reverse_suffix : reverse l₁ <:+ reverse l₂ ↔ l₁ <+: l₂ :=
⟨λ ⟨r, e⟩, ⟨reverse r,
  by rw [← reverse_reverse l₁, ← reverse_append, e, reverse_reverse]⟩,
 λ ⟨r, e⟩, ⟨reverse r, by rw [← reverse_append, e]⟩⟩

@[simp] lemma reverse_prefix : reverse l₁ <+: reverse l₂ ↔ l₁ <:+ l₂ :=
by rw ← reverse_suffix; simp only [reverse_reverse]

@[simp] lemma reverse_infix : reverse l₁ <:+: reverse l₂ ↔ l₁ <:+: l₂ :=
⟨λ ⟨s, t, e⟩, ⟨reverse t, reverse s,
  by rw [← reverse_reverse l₁, append_assoc,
    ← reverse_append, ← reverse_append, e, reverse_reverse]⟩,
 λ ⟨s, t, e⟩, ⟨reverse t, reverse s,
  by rw [append_assoc, ← reverse_append, ← reverse_append, e]⟩⟩

alias reverse_prefix ↔ _ list.is_suffix.reverse
alias reverse_suffix ↔ _ list.is_prefix.reverse
alias reverse_infix ↔ _ list.is_infix.reverse

lemma is_infix.length_le (h : l₁ <:+: l₂) : l₁.length ≤ l₂.length := length_le_of_sublist h.sublist
lemma is_prefix.length_le (h : l₁ <+: l₂) : l₁.length ≤ l₂.length := length_le_of_sublist h.sublist
lemma is_suffix.length_le (h : l₁ <:+ l₂) : l₁.length ≤ l₂.length := length_le_of_sublist h.sublist

lemma eq_nil_of_infix_nil (h : l <:+: []) : l = [] := eq_nil_of_sublist_nil h.sublist

@[simp] lemma infix_nil_iff : l <:+: [] ↔ l = [] :=
⟨λ h, eq_nil_of_sublist_nil h.sublist, λ h, h ▸ infix_rfl⟩

alias infix_nil_iff ↔ list.eq_nil_of_infix_nil _

@[simp] lemma prefix_nil_iff : l <+: [] ↔ l = [] :=
⟨λ h, eq_nil_of_infix_nil h.is_infix, λ h, h ▸ prefix_rfl⟩

@[simp] lemma suffix_nil_iff : l <:+ [] ↔ l = [] :=
⟨λ h, eq_nil_of_infix_nil h.is_infix, λ h, h ▸ suffix_rfl⟩

alias prefix_nil_iff ↔ list.eq_nil_of_prefix_nil _
alias suffix_nil_iff ↔ list.eq_nil_of_suffix_nil _

lemma infix_iff_prefix_suffix (l₁ l₂ : list α) : l₁ <:+: l₂ ↔ ∃ t, l₁ <+: t ∧ t <:+ l₂ :=
⟨λ ⟨s, t, e⟩, ⟨l₁ ++ t, ⟨_, rfl⟩, by rw [← e, append_assoc]; exact ⟨_, rfl⟩⟩,
  λ ⟨._, ⟨t, rfl⟩, s, e⟩, ⟨s, t, by rw append_assoc; exact e⟩⟩

lemma eq_of_infix_of_length_eq (h : l₁ <:+: l₂) : l₁.length = l₂.length → l₁ = l₂ :=
eq_of_sublist_of_length_eq h.sublist

lemma eq_of_prefix_of_length_eq (h : l₁ <+: l₂) : l₁.length = l₂.length → l₁ = l₂ :=
eq_of_sublist_of_length_eq h.sublist

lemma eq_of_suffix_of_length_eq (h : l₁ <:+ l₂) : l₁.length = l₂.length → l₁ = l₂ :=
eq_of_sublist_of_length_eq h.sublist

lemma prefix_of_prefix_length_le : ∀ {l₁ l₂ l₃ : list α},
  l₁ <+: l₃ → l₂ <+: l₃ → length l₁ ≤ length l₂ → l₁ <+: l₂
| []      l₂ l₃ h₁ h₂ _ := nil_prefix _
| (a :: l₁) (b :: l₂) _ ⟨r₁, rfl⟩ ⟨r₂, e⟩ ll := begin
  injection e with _ e', subst b,
  rcases prefix_of_prefix_length_le ⟨_, rfl⟩ ⟨_, e'⟩
    (le_of_succ_le_succ ll) with ⟨r₃, rfl⟩,
  exact ⟨r₃, rfl⟩
end

lemma prefix_or_prefix_of_prefix (h₁ : l₁ <+: l₃) (h₂ : l₂ <+: l₃) : l₁ <+: l₂ ∨ l₂ <+: l₁ :=
(le_total (length l₁) (length l₂)).imp
  (prefix_of_prefix_length_le h₁ h₂)
  (prefix_of_prefix_length_le h₂ h₁)

lemma suffix_of_suffix_length_le (h₁ : l₁ <:+ l₃) (h₂ : l₂ <:+ l₃) (ll : length l₁ ≤ length l₂) :
  l₁ <:+ l₂ :=
reverse_prefix.1 $ prefix_of_prefix_length_le
  (reverse_prefix.2 h₁) (reverse_prefix.2 h₂) (by simp [ll])

lemma suffix_or_suffix_of_suffix (h₁ : l₁ <:+ l₃) (h₂ : l₂ <:+ l₃) : l₁ <:+ l₂ ∨ l₂ <:+ l₁ :=
(prefix_or_prefix_of_prefix (reverse_prefix.2 h₁) (reverse_prefix.2 h₂)).imp
  reverse_prefix.1 reverse_prefix.1

lemma suffix_cons_iff : l₁ <:+ a :: l₂ ↔ l₁ = a :: l₂ ∨ l₁ <:+ l₂ :=
begin
  split,
  { rintro ⟨⟨hd, tl⟩, hl₃⟩,
    { exact or.inl hl₃ },
    { simp only [cons_append] at hl₃,
      exact or.inr ⟨_, hl₃.2⟩ } },
  { rintro (rfl | hl₁),
    { exact (a :: l₂).suffix_refl },
    { exact hl₁.trans (l₂.suffix_cons _) } }
end

lemma infix_cons_iff : l₁ <:+: a :: l₂ ↔ l₁ <+: a :: l₂ ∨ l₁ <:+: l₂ :=
begin
  split,
  { rintro ⟨⟨hd, tl⟩, t, hl₃⟩,
    { exact or.inl ⟨t, hl₃⟩ },
    { simp only [cons_append] at hl₃,
      exact or.inr ⟨_, t, hl₃.2⟩ } },
  { rintro (h | hl₁),
    { exact h.is_infix },
    { exact infix_cons hl₁ } }
end

lemma infix_of_mem_join : ∀ {L : list (list α)}, l ∈ L → l <:+: join L
| (_  :: L) (or.inl rfl) := infix_append [] _ _
| (l' :: L) (or.inr h)   := is_infix.trans (infix_of_mem_join h) $ (suffix_append _ _).is_infix

lemma prefix_append_right_inj (l) : l ++ l₁ <+: l ++ l₂ ↔ l₁ <+: l₂ :=
exists_congr $ λ r, by rw [append_assoc, append_right_inj]

lemma prefix_cons_inj (a) : a :: l₁ <+: a :: l₂ ↔ l₁ <+: l₂ := prefix_append_right_inj [a]

lemma take_prefix (n) (l : list α) : take n l <+: l := ⟨_, take_append_drop _ _⟩
lemma drop_suffix (n) (l : list α) : drop n l <:+ l := ⟨_, take_append_drop _ _⟩
lemma take_sublist (n) (l : list α) : take n l <+ l := (take_prefix n l).sublist
lemma drop_sublist (n) (l : list α) : drop n l <+ l := (drop_suffix n l).sublist
lemma take_subset (n) (l : list α) : take n l ⊆ l := (take_sublist n l).subset
lemma drop_subset (n) (l : list α) : drop n l ⊆ l := (drop_sublist n l).subset
lemma mem_of_mem_take (h : a ∈ l.take n) : a ∈ l := take_subset n l h
lemma mem_of_mem_drop (h : a ∈ l.drop n) : a ∈ l := drop_subset n l h

lemma init_prefix : ∀ (l : list α), l.init <+: l
| [] := ⟨nil, by rw [init, list.append_nil]⟩
| (a :: l) := ⟨_, init_append_last (cons_ne_nil a l)⟩

lemma tail_suffix (l : list α) : tail l <:+ l := by rw ← drop_one; apply drop_suffix

lemma init_sublist (l : list α) : l.init <+ l := (init_prefix l).sublist
lemma tail_sublist (l : list α) : l.tail <+ l := (tail_suffix l).sublist
lemma init_subset (l : list α) : l.init ⊆ l := (init_sublist l).subset
lemma tail_subset (l : list α) : tail l ⊆ l := (tail_sublist l).subset
lemma mem_of_mem_init (h : a ∈ l.init) : a ∈ l := init_subset l h
lemma mem_of_mem_tail (h : a ∈ l.tail) : a ∈ l := tail_subset l h

lemma prefix_iff_eq_append : l₁ <+: l₂ ↔ l₁ ++ drop (length l₁) l₂ = l₂ :=
⟨by rintros ⟨r, rfl⟩; rw drop_left, λ e, ⟨_, e⟩⟩

lemma suffix_iff_eq_append : l₁ <:+ l₂ ↔ take (length l₂ - length l₁) l₂ ++ l₁ = l₂ :=
⟨by rintros ⟨r, rfl⟩; simp only [length_append, add_tsub_cancel_right, take_left], λ e, ⟨_, e⟩⟩

lemma prefix_iff_eq_take : l₁ <+: l₂ ↔ l₁ = take (length l₁) l₂ :=
⟨λ h, append_right_cancel $
  (prefix_iff_eq_append.1 h).trans (take_append_drop _ _).symm,
 λ e, e.symm ▸ take_prefix _ _⟩

lemma suffix_iff_eq_drop : l₁ <:+ l₂ ↔ l₁ = drop (length l₂ - length l₁) l₂ :=
⟨λ h, append_left_cancel $
  (suffix_iff_eq_append.1 h).trans (take_append_drop _ _).symm,
 λ e, e.symm ▸ drop_suffix _ _⟩

instance decidable_prefix [decidable_eq α] : ∀ (l₁ l₂ : list α), decidable (l₁ <+: l₂)
| []        l₂        := is_true ⟨l₂, rfl⟩
| (a :: l₁) []        := is_false $ λ ⟨t, te⟩, list.no_confusion te
| (a :: l₁) (b :: l₂) :=
  if h : a = b then
    decidable_of_decidable_of_iff (decidable_prefix l₁ l₂) (by rw [← h, prefix_cons_inj])
  else
    is_false $ λ ⟨t, te⟩, h $ by injection te

-- Alternatively, use mem_tails
instance decidable_suffix [decidable_eq α] : ∀ (l₁ l₂ : list α), decidable (l₁ <:+ l₂)
| []        l₂        := is_true ⟨l₂, append_nil _⟩
| (a :: l₁) []        := is_false $ mt (length_le_of_sublist ∘ is_suffix.sublist) dec_trivial
| l₁        (b :: l₂) := decidable_of_decidable_of_iff (@or.decidable _ _
    _ (l₁.decidable_suffix l₂)) suffix_cons_iff.symm

instance decidable_infix [decidable_eq α] : ∀ (l₁ l₂ : list α), decidable (l₁ <:+: l₂)
| []        l₂        := is_true ⟨[], l₂, rfl⟩
| (a :: l₁) []        := is_false $ λ ⟨s, t, te⟩, by simp at te; exact te
| l₁        (b :: l₂) := decidable_of_decidable_of_iff (@or.decidable _ _
    (l₁.decidable_prefix (b :: l₂)) (l₁.decidable_infix l₂)) infix_cons_iff.symm

lemma prefix_take_le_iff {L : list (list (option α))} (hm : m < L.length) :
  L.take m <+: L.take n ↔ m ≤ n :=
begin
  simp only [prefix_iff_eq_take, length_take],
  induction m with m IH generalizing L n,
  { simp only [min_eq_left, eq_self_iff_true, nat.zero_le, take] },
  cases L with l ls,
  { exact (not_lt_bot hm).elim },
  cases n,
  { refine iff_of_false _ (zero_lt_succ _).not_le,
    rw [take_zero, take_nil],
    simp only [take],
      exact not_false },
  { simp only [length] at hm,
    specialize @IH ls n (nat.lt_of_succ_lt_succ hm),
    simp only [le_of_lt (nat.lt_of_succ_lt_succ hm), min_eq_left] at IH,
    simp only [le_of_lt hm, IH, true_and, min_eq_left, eq_self_iff_true, length, take],
    exact ⟨nat.succ_le_succ, nat.le_of_succ_le_succ⟩ }
end

lemma cons_prefix_iff : a :: l₁ <+: b :: l₂ ↔ a = b ∧ l₁ <+: l₂ :=
begin
  split,
  { rintro ⟨L, hL⟩,
    simp only [cons_append] at hL,
    exact ⟨hL.left, ⟨L, hL.right⟩⟩ },
  { rintro ⟨rfl, h⟩,
    rwa [prefix_cons_inj] }
end

lemma is_prefix.map (h : l₁ <+: l₂) (f : α → β) : l₁.map f <+: l₂.map f :=
begin
  induction l₁ with hd tl hl generalizing l₂,
  { simp only [nil_prefix, map_nil] },
  { cases l₂ with hd₂ tl₂,
    { simpa only using eq_nil_of_prefix_nil h },
    { rw cons_prefix_iff at h,
      simp only [h, prefix_cons_inj, hl, map] } }
end

lemma is_prefix.filter_map (h : l₁ <+: l₂) (f : α → option β) :
  l₁.filter_map f <+: l₂.filter_map f :=
begin
  induction l₁ with hd₁ tl₁ hl generalizing l₂,
  { simp only [nil_prefix, filter_map_nil] },
  { cases l₂ with hd₂ tl₂,
    { simpa only using eq_nil_of_prefix_nil h },
    { rw cons_prefix_iff at h,
      rw [←@singleton_append _ hd₁ _, ←@singleton_append _ hd₂ _, filter_map_append,
         filter_map_append, h.left, prefix_append_right_inj],
      exact hl h.right } }
end

lemma is_prefix.reduce_option {l₁ l₂ : list (option α)} (h : l₁ <+: l₂) :
  l₁.reduce_option <+: l₂.reduce_option :=
h.filter_map id

lemma is_prefix.filter (p : α → Prop) [decidable_pred p] ⦃l₁ l₂ : list α⦄ (h : l₁ <+: l₂) :
  l₁.filter p <+: l₂.filter p :=
begin
  obtain ⟨xs, rfl⟩ := h,
  rw filter_append,
  exact prefix_append _ _
end

lemma is_suffix.filter (p : α → Prop) [decidable_pred p] ⦃l₁ l₂ : list α⦄ (h : l₁ <:+ l₂) :
  l₁.filter p <:+ l₂.filter p :=
begin
  obtain ⟨xs, rfl⟩ := h,
  rw filter_append,
  exact suffix_append _ _
end

lemma is_infix.filter (p : α → Prop) [decidable_pred p] ⦃l₁ l₂ : list α⦄ (h : l₁ <:+: l₂) :
  l₁.filter p <:+: l₂.filter p :=
begin
  obtain ⟨xs, ys, rfl⟩ := h,
  rw [filter_append, filter_append],
  exact infix_append _ _ _
end

instance : is_partial_order (list α) (<+:) :=
{ refl := prefix_refl,
  trans := λ _ _ _, is_prefix.trans,
  antisymm := λ _ _ h₁ h₂, eq_of_prefix_of_length_eq h₁ $ h₁.length_le.antisymm h₂.length_le }

instance : is_partial_order (list α) (<:+) :=
{ refl := suffix_refl,
  trans := λ _ _ _, is_suffix.trans,
  antisymm := λ _ _ h₁ h₂, eq_of_suffix_of_length_eq h₁ $ h₁.length_le.antisymm h₂.length_le }

instance : is_partial_order (list α) (<:+:) :=
{ refl := infix_refl,
  trans := λ _ _ _, is_infix.trans,
  antisymm := λ _ _ h₁ h₂, eq_of_infix_of_length_eq h₁ $ h₁.length_le.antisymm h₂.length_le }

end fix

section inits_tails

@[simp] lemma mem_inits : ∀ (s t : list α), s ∈ inits t ↔ s <+: t
| s []     := suffices s = nil ↔ s <+: nil, by simpa only [inits, mem_singleton],
  ⟨λ h, h.symm ▸ prefix_refl [], eq_nil_of_prefix_nil⟩
| s (a :: t) :=
  suffices (s = nil ∨ ∃ l ∈ inits t, a :: l = s) ↔ s <+: a :: t, by simpa,
  ⟨λ o, match s, o with
  | ._, or.inl rfl := ⟨_, rfl⟩
  | s, or.inr ⟨r, hr, hs⟩ := let ⟨s, ht⟩ := (mem_inits _ _).1 hr in
    by rw [← hs, ← ht]; exact ⟨s, rfl⟩
  end, λ mi, match s, mi with
  | [], ⟨._, rfl⟩ := or.inl rfl
  | (b :: s), ⟨r, hr⟩ := list.no_confusion hr $ λ ba (st : s++r = t), or.inr $
    by rw ba; exact ⟨_, (mem_inits _ _).2 ⟨_, st⟩, rfl⟩
  end⟩

@[simp] lemma mem_tails : ∀ (s t : list α), s ∈ tails t ↔ s <:+ t
| s []     := by simp only [tails, mem_singleton];
  exact ⟨λ h, by rw h; exact suffix_refl [], eq_nil_of_suffix_nil⟩
| s (a :: t) := by simp only [tails, mem_cons_iff, mem_tails s t];
  exact show s = a :: t ∨ s <:+ t ↔ s <:+ a :: t, from
  ⟨λ o, match s, t, o with
  | ._, t, or.inl rfl := suffix_rfl
  | s, ._, or.inr ⟨l, rfl⟩ := ⟨a :: l, rfl⟩
  end, λ e, match s, t, e with
  | ._, t, ⟨[], rfl⟩ := or.inl rfl
  | s, t, ⟨b :: l, he⟩ := list.no_confusion he (λ ab lt, or.inr ⟨l, lt⟩)
  end⟩

lemma inits_cons (a : α) (l : list α) : inits (a :: l) = [] :: l.inits.map (λ t, a :: t) := by simp
lemma tails_cons (a : α) (l : list α) : tails (a :: l) = (a :: l) :: l.tails := by simp

@[simp]
lemma inits_append : ∀ (s t : list α), inits (s ++ t) = s.inits ++ t.inits.tail.map (λ l, s ++ l)
| [] [] := by simp
| [] (a :: t) := by simp
| (a :: s) t := by simp [inits_append s t]

@[simp]
lemma tails_append : ∀ (s t : list α), tails (s ++ t) = s.tails.map (λ l, l ++ t) ++ t.tails.tail
| [] [] := by simp
| [] (a :: t) := by simp
| (a :: s) t := by simp [tails_append s t]

-- the lemma names `inits_eq_tails` and `tails_eq_inits` are like `sublists_eq_sublists'`
lemma inits_eq_tails : ∀ (l : list α), l.inits = (reverse $ map reverse $ tails $ reverse l)
| [] := by simp
| (a :: l) := by simp [inits_eq_tails l, map_eq_map_iff]

lemma tails_eq_inits : ∀ (l : list α), l.tails = (reverse $ map reverse $ inits $ reverse l)
| [] := by simp
| (a :: l) := by simp [tails_eq_inits l, append_left_inj]

lemma inits_reverse (l : list α) : inits (reverse l) = reverse (map reverse l.tails) :=
by { rw tails_eq_inits l, simp [reverse_involutive.comp_self] }

lemma tails_reverse (l : list α) : tails (reverse l) = reverse (map reverse l.inits) :=
by { rw inits_eq_tails l, simp [reverse_involutive.comp_self] }

lemma map_reverse_inits (l : list α) : map reverse l.inits = (reverse $ tails $ reverse l) :=
by { rw inits_eq_tails l, simp [reverse_involutive.comp_self] }

lemma map_reverse_tails (l : list α) : map reverse l.tails = (reverse $ inits $ reverse l) :=
by { rw tails_eq_inits l, simp [reverse_involutive.comp_self] }

@[simp] lemma length_tails (l : list α) : length (tails l) = length l + 1 :=
begin
  induction l with x l IH,
  { simp },
  { simpa using IH }
end

@[simp] lemma length_inits (l : list α) : length (inits l) = length l + 1 :=
by simp [inits_eq_tails]

@[simp] lemma nth_le_tails (l : list α) (n : ℕ) (hn : n < length (tails l)) :
  nth_le (tails l) n hn = l.drop n :=
begin
  induction l with x l IH generalizing n,
  { simp },
  { cases n,
    { simp },
    { simpa using IH n _ } }
end

@[simp] lemma nth_le_inits (l : list α) (n : ℕ) (hn : n < length (inits l)) :
  nth_le (inits l) n hn = l.take n :=
begin
  induction l with x l IH generalizing n,
  { simp },
  { cases n,
    { simp },
    { simpa using IH n _ } }
end

end inits_tails

/-! ### insert -/

section insert
variable [decidable_eq α]

@[simp] lemma insert_nil (a : α) : insert a nil = [a] := rfl

lemma insert.def (a : α) (l : list α) : insert a l = if a ∈ l then l else a :: l := rfl

@[simp, priority 980]
lemma insert_of_mem (h : a ∈ l) : insert a l = l := by simp only [insert.def, if_pos h]

@[simp, priority 970]
lemma insert_of_not_mem (h : a ∉ l) : insert a l = a :: l :=
by simp only [insert.def, if_neg h]; split; refl

@[simp] lemma mem_insert_iff : a ∈ insert b l ↔ a = b ∨ a ∈ l :=
begin
  by_cases h' : b ∈ l,
  { simp only [insert_of_mem h'],
    apply (or_iff_right_of_imp _).symm,
    exact λ e, e.symm ▸ h' },
  { simp only [insert_of_not_mem h', mem_cons_iff] }
end

@[simp] lemma suffix_insert (a : α) (l : list α) : l <:+ insert a l :=
by by_cases a ∈ l; [simp only [insert_of_mem h], simp only [insert_of_not_mem h, suffix_cons]]

lemma infix_insert (a : α) (l : list α) : l <:+: insert a l := (suffix_insert a l).is_infix
lemma sublist_insert (a : α) (l : list α) : l <+  l.insert a := (suffix_insert a l).sublist
lemma subset_insert (a : α) (l : list α) : l ⊆ l.insert a := (sublist_insert a l).subset

@[simp] lemma mem_insert_self (a : α) (l : list α) : a ∈  l.insert a :=
mem_insert_iff.2 $ or.inl rfl

lemma mem_insert_of_mem (h : a ∈ l) : a ∈ insert b l := mem_insert_iff.2 (or.inr h)

lemma eq_or_mem_of_mem_insert (h : a ∈ insert b l) : a = b ∨ a ∈ l := mem_insert_iff.1 h

@[simp] lemma length_insert_of_mem (h : a ∈ l) : (insert a l).length = l.length :=
congr_arg _ $ insert_of_mem h

@[simp] lemma length_insert_of_not_mem (h : a ∉ l) : (insert a l).length = l.length + 1 :=
congr_arg _ $ insert_of_not_mem h

end insert

lemma mem_of_mem_suffix (hx : a ∈ l₁) (hl : l₁ <:+ l₂) : a ∈ l₂ :=
hl.subset hx

end list


<|start_filename|>test/pointwise_nsmul.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.finset.pointwise
import order.filter.pointwise

/-!
# Ensuring priority of the `ℕ` and `ℤ` actions over pointwise ones

See Note [pointwise nat action].
-/

open_locale pointwise

variables {α β : Type*} [add_group α] [decidable_eq α] [group β] [decidable_eq β]

-- It is ok for the proofs to stop being `rfl`, but these statements should remain true
example (s : set α) (n : ℕ) : n • s = nsmul_rec n s := rfl
example (s : set α) (n : ℤ) : n • s = zsmul_rec n s := rfl
example (s : set β) (n : ℕ) : s ^ n = npow_rec n s := rfl
example (s : set β) (n : ℤ) : s ^ n = zpow_rec n s := rfl
example (s : finset α) (n : ℕ) : n • s = nsmul_rec n s := rfl
example (s : finset α) (n : ℤ) : n • s = zsmul_rec n s := rfl
example (s : finset β) (n : ℕ) : s ^ n = npow_rec n s := rfl
example (s : finset β) (n : ℤ) : s ^ n = zpow_rec n s := rfl
example (s : filter α) (n : ℕ) : n • s = nsmul_rec n s := rfl
example (s : filter α) (n : ℤ) : n • s = zsmul_rec n s := rfl
example (s : filter β) (n : ℕ) : s ^ n = npow_rec n s := rfl
example (s : filter β) (n : ℤ) : s ^ n = zpow_rec n s := rfl

example : 2 • ({2, 3} : finset ℕ) = {4, 5, 6} := rfl
example : ({2, 3}^2 : finset ℕ) = {4, 6, 9} := rfl


<|start_filename|>src/algebraic_geometry/Scheme.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebraic_geometry.Spec

/-!
# The category of schemes

A scheme is a locally ringed space such that every point is contained in some open set
where there is an isomorphism of presheaves between the restriction to that open set,
and the structure sheaf of `Spec R`, for some commutative ring `R`.

A morphism of schemes is just a morphism of the underlying locally ringed spaces.

-/

noncomputable theory

open topological_space
open category_theory
open Top
open opposite

namespace algebraic_geometry

/--
We define `Scheme` as a `X : LocallyRingedSpace`,
along with a proof that every point has an open neighbourhood `U`
so that that the restriction of `X` to `U` is isomorphic,
as a locally ringed space, to `Spec.to_LocallyRingedSpace.obj (op R)`
for some `R : CommRing`.
-/
structure Scheme extends to_LocallyRingedSpace : LocallyRingedSpace :=
(local_affine : ∀ x : to_LocallyRingedSpace, ∃ (U : open_nhds x) (R : CommRing),
  nonempty (to_LocallyRingedSpace.restrict U.open_embedding ≅
    Spec.to_LocallyRingedSpace.obj (op R)))

namespace Scheme

/--
Schemes are a full subcategory of locally ringed spaces.
-/
instance : category Scheme :=
induced_category.category Scheme.to_LocallyRingedSpace

/-- The structure sheaf of a Scheme. -/
protected abbreviation sheaf (X : Scheme) := X.to_SheafedSpace.sheaf

/-- The forgetful functor from `Scheme` to `LocallyRingedSpace`. -/
@[simps, derive[full, faithful]]
def forget_to_LocallyRingedSpace : Scheme ⥤ LocallyRingedSpace :=
  induced_functor _

@[simp] lemma forget_to_LocallyRingedSpace_preimage {X Y : Scheme} (f : X ⟶ Y) :
  Scheme.forget_to_LocallyRingedSpace.preimage f = f := rfl

/-- The forgetful functor from `Scheme` to `Top`. -/
@[simps]
def forget_to_Top : Scheme ⥤ Top :=
  Scheme.forget_to_LocallyRingedSpace ⋙ LocallyRingedSpace.forget_to_Top

instance {X Y : Scheme} : has_lift_t (X ⟶ Y)
  (X.to_SheafedSpace ⟶ Y.to_SheafedSpace) := (@@coe_to_lift $ @@coe_base coe_subtype)

lemma id_val_base (X : Scheme) : (subtype.val (𝟙 X)).base = 𝟙 _ := rfl

@[simp] lemma id_coe_base (X : Scheme) :
  (↑(𝟙 X) : X.to_SheafedSpace ⟶ X.to_SheafedSpace).base = 𝟙 _ := rfl

@[simp] lemma id_app {X : Scheme} (U : (opens X.carrier)ᵒᵖ) :
  (subtype.val (𝟙 X)).c.app U = X.presheaf.map
    (eq_to_hom (by { induction U using opposite.rec, cases U, refl })) :=
PresheafedSpace.id_c_app X.to_PresheafedSpace U

@[reassoc]
lemma comp_val {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).val = f.val ≫ g.val := rfl

@[reassoc, simp]
lemma comp_coe_base {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (↑(f ≫ g) : X.to_SheafedSpace ⟶ Z.to_SheafedSpace).base = f.val.base ≫ g.val.base := rfl

@[reassoc, elementwise]
lemma comp_val_base {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).val.base = f.val.base ≫ g.val.base := rfl

@[reassoc, simp]
lemma comp_val_c_app {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) (U) :
  (f ≫ g).val.c.app U = g.val.c.app U ≫ f.val.c.app _ := rfl

lemma congr_app {X Y : Scheme} {f g : X ⟶ Y} (e : f = g) (U) :
  f.val.c.app U = g.val.c.app U ≫ X.presheaf.map (eq_to_hom (by subst e)) :=
by { subst e, dsimp, simp }

lemma app_eq {X Y : Scheme} (f : X ⟶ Y) {U V : opens Y.carrier} (e : U = V) :
  f.val.c.app (op U) = Y.presheaf.map (eq_to_hom e.symm).op ≫
    f.val.c.app (op V) ≫ X.presheaf.map (eq_to_hom (congr_arg (opens.map f.val.base).obj e)).op :=
begin
  rw [← is_iso.inv_comp_eq, ← functor.map_inv, f.val.c.naturality, presheaf.pushforward_obj_map],
  congr
end
instance is_LocallyRingedSpace_iso {X Y : Scheme} (f : X ⟶ Y) [is_iso f] :
  @is_iso LocallyRingedSpace _ _ _ f :=
forget_to_LocallyRingedSpace.map_is_iso f

@[simp]
lemma inv_val_c_app {X Y : Scheme} (f : X ⟶ Y) [is_iso f] (U : opens X.carrier) :
  (inv f).val.c.app (op U) = X.presheaf.map (eq_to_hom $ by { rw is_iso.hom_inv_id, ext1, refl } :
    (opens.map (f ≫ inv f).1.base).obj U ⟶ U).op ≫
      inv (f.val.c.app (op $ (opens.map _).obj U)) :=
begin
  rw [is_iso.eq_comp_inv],
  erw ← Scheme.comp_val_c_app,
  rw [Scheme.congr_app (is_iso.hom_inv_id f),
    Scheme.id_app, ← functor.map_comp, eq_to_hom_trans, eq_to_hom_op],
  refl
end

/--
The spectrum of a commutative ring, as a scheme.
-/
def Spec_obj (R : CommRing) : Scheme :=
{ local_affine := λ x,
  ⟨⟨⊤, trivial⟩, R, ⟨(Spec.to_LocallyRingedSpace.obj (op R)).restrict_top_iso⟩⟩,
  to_LocallyRingedSpace := Spec.LocallyRingedSpace_obj R }

@[simp] lemma Spec_obj_to_LocallyRingedSpace (R : CommRing) :
  (Spec_obj R).to_LocallyRingedSpace = Spec.LocallyRingedSpace_obj R := rfl

/--
The induced map of a ring homomorphism on the ring spectra, as a morphism of schemes.
-/
def Spec_map {R S : CommRing} (f : R ⟶ S) :
  Spec_obj S ⟶ Spec_obj R :=
(Spec.LocallyRingedSpace_map f : Spec.LocallyRingedSpace_obj S ⟶ Spec.LocallyRingedSpace_obj R)

@[simp] lemma Spec_map_id (R : CommRing) :
  Spec_map (𝟙 R) = 𝟙 (Spec_obj R) :=
Spec.LocallyRingedSpace_map_id R

lemma Spec_map_comp {R S T : CommRing} (f : R ⟶ S) (g : S ⟶ T) :
  Spec_map (f ≫ g) = Spec_map g ≫ Spec_map f :=
Spec.LocallyRingedSpace_map_comp f g

/--
The spectrum, as a contravariant functor from commutative rings to schemes.
-/
@[simps] def Spec : CommRingᵒᵖ ⥤ Scheme :=
{ obj := λ R, Spec_obj (unop R),
  map := λ R S f, Spec_map f.unop,
  map_id' := λ R, by rw [unop_id, Spec_map_id],
  map_comp' := λ R S T f g, by rw [unop_comp, Spec_map_comp] }

/--
The empty scheme, as `Spec 0`.
-/
def empty : Scheme :=
Spec_obj (CommRing.of punit)

instance : has_emptyc Scheme := ⟨empty⟩

instance : inhabited Scheme := ⟨∅⟩

/--
The global sections, notated Gamma.
-/
def Γ : Schemeᵒᵖ ⥤ CommRing :=
(induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ

lemma Γ_def : Γ = (induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ := rfl

@[simp] lemma Γ_obj (X : Schemeᵒᵖ) : Γ.obj X = (unop X).presheaf.obj (op ⊤) := rfl

lemma Γ_obj_op (X : Scheme) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

@[simp] lemma Γ_map {X Y : Schemeᵒᵖ} (f : X ⟶ Y) :
  Γ.map f = f.unop.1.c.app (op ⊤) := rfl

lemma Γ_map_op {X Y : Scheme} (f : X ⟶ Y) :
  Γ.map f.op = f.1.c.app (op ⊤) := rfl

section basic_open

variables (X : Scheme) {V U : opens X.carrier} (f g : X.presheaf.obj (op U))

/-- The subset of the underlying space where the given section does not vanish. -/
def basic_open : opens X.carrier := X.to_LocallyRingedSpace.to_RingedSpace.basic_open f

@[simp]
lemma mem_basic_open (x : U) : ↑x ∈ X.basic_open f ↔ is_unit (X.presheaf.germ x f) :=
RingedSpace.mem_basic_open _ _ _

@[simp]
lemma mem_basic_open_top (f : X.presheaf.obj (op ⊤)) (x : X.carrier) :
  x ∈ X.basic_open f ↔ is_unit (X.presheaf.germ (⟨x, trivial⟩ : (⊤ : opens _)) f) :=
RingedSpace.mem_basic_open _ f ⟨x, trivial⟩

@[simp]
lemma basic_open_res (i : op U ⟶ op V) :
  X.basic_open (X.presheaf.map i f) = V ∩ X.basic_open f :=
RingedSpace.basic_open_res _ i f

-- This should fire before `basic_open_res`.
@[simp, priority 1100]
lemma basic_open_res_eq (i : op U ⟶ op V) [is_iso i] :
  X.basic_open (X.presheaf.map i f) = X.basic_open f :=
RingedSpace.basic_open_res_eq _ i f

lemma basic_open_subset : X.basic_open f ⊆ U :=
RingedSpace.basic_open_subset _ _

lemma preimage_basic_open {X Y : Scheme} (f : X ⟶ Y) {U : opens Y.carrier}
  (r : Y.presheaf.obj $ op U) :
  (opens.map f.1.base).obj (Y.basic_open r) =
    @Scheme.basic_open X ((opens.map f.1.base).obj U) (f.1.c.app _ r) :=
LocallyRingedSpace.preimage_basic_open f r

@[simp]
lemma preimage_basic_open' {X Y : Scheme} (f : X ⟶ Y) {U : opens Y.carrier}
  (r : Y.presheaf.obj $ op U) :
  (opens.map (↑f : X.to_SheafedSpace ⟶ Y.to_SheafedSpace).base).obj (Y.basic_open r) =
    @Scheme.basic_open X ((opens.map f.1.base).obj U) (f.1.c.app _ r) :=
LocallyRingedSpace.preimage_basic_open f r

@[simp]
lemma basic_open_zero (U : opens X.carrier) : X.basic_open (0 : X.presheaf.obj $ op U) = ∅ :=
LocallyRingedSpace.basic_open_zero _ U

@[simp]
lemma basic_open_mul : X.basic_open (f * g) = X.basic_open f ⊓ X.basic_open g :=
RingedSpace.basic_open_mul _ _ _

@[simp]
lemma basic_open_of_is_unit {f : X.presheaf.obj (op U)} (hf : is_unit f) : X.basic_open f = U :=
RingedSpace.basic_open_of_is_unit _ hf

end basic_open

end Scheme

lemma basic_open_eq_of_affine {R : CommRing} (f : R) :
  (Scheme.Spec.obj $ op R).basic_open ((Spec_Γ_identity.app R).inv f) =
    prime_spectrum.basic_open f :=
begin
  ext,
  erw Scheme.mem_basic_open_top,
  suffices : is_unit (structure_sheaf.to_stalk R x f) ↔ f ∉ prime_spectrum.as_ideal x,
  { exact this },
  erw [← is_unit_map_iff (structure_sheaf.stalk_to_fiber_ring_hom R x),
    structure_sheaf.stalk_to_fiber_ring_hom_to_stalk],
  exact (is_localization.at_prime.is_unit_to_map_iff
    (localization.at_prime (prime_spectrum.as_ideal x)) (prime_spectrum.as_ideal x) f : _)
end

@[simp]
lemma basic_open_eq_of_affine' {R : CommRing}
  (f : (Spec.to_SheafedSpace.obj (op R)).presheaf.obj (op ⊤)) :
  (Scheme.Spec.obj $ op R).basic_open f =
    prime_spectrum.basic_open ((Spec_Γ_identity.app R).hom f) :=
begin
  convert basic_open_eq_of_affine ((Spec_Γ_identity.app R).hom f),
  exact (iso.hom_inv_id_apply _ _).symm
end

end algebraic_geometry


<|start_filename|>src/ring_theory/coprime/lemmas.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import algebra.big_operators.ring
import data.fintype.basic
import data.int.gcd
import ring_theory.coprime.basic

/-!
# Additional lemmas about elements of a ring satisfying `is_coprime`

These lemmas are in a separate file to the definition of `is_coprime` as they require more imports.

Notably, this includes lemmas about `finset.prod` as this requires importing big_operators, and
lemmas about `has_pow` since these are easiest to prove via `finset.prod`.

-/

universes u v

variables {R : Type u} {I : Type v} [comm_semiring R] {x y z : R} {s : I → R} {t : finset I}

open_locale big_operators
section
open_locale classical

theorem nat.is_coprime_iff_coprime {m n : ℕ} : is_coprime (m : ℤ) n ↔ nat.coprime m n :=
⟨λ ⟨a, b, H⟩, nat.eq_one_of_dvd_one $ int.coe_nat_dvd.1 $ by { rw [int.coe_nat_one, ← H],
  exact dvd_add (dvd_mul_of_dvd_right (int.coe_nat_dvd.2 $ nat.gcd_dvd_left m n) _)
    (dvd_mul_of_dvd_right (int.coe_nat_dvd.2 $ nat.gcd_dvd_right m n) _) },
λ H, ⟨nat.gcd_a m n, nat.gcd_b m n, by rw [mul_comm _ (m : ℤ), mul_comm _ (n : ℤ),
    ← nat.gcd_eq_gcd_ab, show _ = _, from H, int.coe_nat_one]⟩⟩

theorem is_coprime.prod_left : (∀ i ∈ t, is_coprime (s i) x) → is_coprime (∏ i in t, s i) x :=
finset.induction_on t (λ _, is_coprime_one_left) $ λ b t hbt ih H,
by { rw finset.prod_insert hbt, rw finset.forall_mem_insert at H, exact H.1.mul_left (ih H.2) }

theorem is_coprime.prod_right : (∀ i ∈ t, is_coprime x (s i)) → is_coprime x (∏ i in t, s i) :=
by simpa only [is_coprime_comm] using is_coprime.prod_left

theorem is_coprime.prod_left_iff : is_coprime (∏ i in t, s i) x ↔ ∀ i ∈ t, is_coprime (s i) x :=
finset.induction_on t (iff_of_true is_coprime_one_left $ λ _, false.elim) $ λ b t hbt ih,
by rw [finset.prod_insert hbt, is_coprime.mul_left_iff, ih, finset.forall_mem_insert]

theorem is_coprime.prod_right_iff : is_coprime x (∏ i in t, s i) ↔ ∀ i ∈ t, is_coprime x (s i) :=
by simpa only [is_coprime_comm] using is_coprime.prod_left_iff

theorem is_coprime.of_prod_left (H1 : is_coprime (∏ i in t, s i) x) (i : I) (hit : i ∈ t) :
  is_coprime (s i) x :=
is_coprime.prod_left_iff.1 H1 i hit

theorem is_coprime.of_prod_right (H1 : is_coprime x (∏ i in t, s i)) (i : I) (hit : i ∈ t) :
  is_coprime x (s i) :=
is_coprime.prod_right_iff.1 H1 i hit

theorem finset.prod_dvd_of_coprime :
  ∀ (Hs : (t : set I).pairwise (is_coprime on s)) (Hs1 : ∀ i ∈ t, s i ∣ z),
  ∏ x in t, s x ∣ z :=
finset.induction_on t (λ _ _, one_dvd z)
begin
  intros a r har ih Hs Hs1,
  rw finset.prod_insert har,
  have aux1 : a ∈ (↑(insert a r) : set I) := finset.mem_insert_self a r,
  refine (is_coprime.prod_right $ λ i hir, Hs aux1 (finset.mem_insert_of_mem hir)
    $ by { rintro rfl, exact har hir }).mul_dvd
    (Hs1 a aux1) (ih (Hs.mono _) $ λ i hi, Hs1 i $ finset.mem_insert_of_mem hi),
  simp only [finset.coe_insert, set.subset_insert],
end

theorem fintype.prod_dvd_of_coprime [fintype I] (Hs : pairwise (is_coprime on s))
  (Hs1 : ∀ i, s i ∣ z) : ∏ x, s x ∣ z :=
finset.prod_dvd_of_coprime (Hs.set_pairwise _) (λ i _, Hs1 i)

end

open finset

lemma exists_sum_eq_one_iff_pairwise_coprime [decidable_eq I] (h : t.nonempty) :
  (∃ μ : I → R, ∑ i in t, μ i * ∏ j in t \ {i}, s j = 1) ↔ pairwise (is_coprime on λ i : t, s i) :=
begin
  refine h.cons_induction _ _; clear' t h,
  { simp only [pairwise, sum_singleton, finset.sdiff_self, prod_empty, mul_one,
      exists_apply_eq_apply, ne.def, true_iff],
    rintro a ⟨i, hi⟩ ⟨j, hj⟩ h,
    rw finset.mem_singleton at hi hj,
    simpa [hi, hj] using h },
  intros a t hat h ih,
  rw pairwise_cons',
  have mem : ∀ x ∈ t, a ∈ insert a t \ {x} := λ x hx, by
    { rw [mem_sdiff, mem_singleton], exact ⟨mem_insert_self _ _, λ ha, hat (ha.symm.cases_on hx)⟩ },
  split,
  { rintro ⟨μ, hμ⟩,
    rw [sum_cons, cons_eq_insert, sdiff_singleton_eq_erase, erase_insert hat] at hμ,
    refine ⟨ih.mp ⟨pi.single h.some (μ a * s h.some) + μ * λ _, s a, _⟩, λ b hb, _⟩,
    { rw [prod_eq_mul_prod_diff_singleton h.some_spec, ← mul_assoc,
        ← @if_pos _ _ h.some_spec R (_ * _) 0, ← sum_pi_single', ← sum_add_distrib] at hμ,
      rw [← hμ, sum_congr rfl], intros x hx, convert @add_mul R _ _ _ _ _ _ using 2,
      { by_cases hx : x = h.some,
        { rw [hx, pi.single_eq_same, pi.single_eq_same] },
        { rw [pi.single_eq_of_ne hx, pi.single_eq_of_ne hx, zero_mul] } },
      { convert (mul_assoc _ _ _).symm,
        convert prod_eq_mul_prod_diff_singleton (mem x hx) _ using 3,
        convert sdiff_sdiff_comm, rw [sdiff_singleton_eq_erase, erase_insert hat] } },
    { have : is_coprime (s b) (s a) :=
        ⟨μ a * ∏ i in t \ {b}, s i, ∑ i in t, μ i * ∏ j in t \ {i}, s j, _⟩,
      { exact ⟨this.symm, this⟩ },
      rw [mul_assoc, ← prod_eq_prod_diff_singleton_mul hb, sum_mul, ← hμ, sum_congr rfl],
      intros x hx, convert mul_assoc _ _ _,
      convert prod_eq_prod_diff_singleton_mul (mem x hx) _ using 3,
      convert sdiff_sdiff_comm, rw [sdiff_singleton_eq_erase, erase_insert hat] } },
  { rintro ⟨hs, Hb⟩, obtain ⟨μ, hμ⟩ := ih.mpr hs,
    obtain ⟨u, v, huv⟩ := is_coprime.prod_left (λ b hb, (Hb b hb).right),
    use λ i, if i = a then u else v * μ i,
    have hμ' : ∑ i in t, v * ((μ i * ∏ j in t \ {i}, s j) * s a) = v * s a := by
      rw [← mul_sum, ← sum_mul, hμ, one_mul],
    rw [sum_cons, cons_eq_insert, sdiff_singleton_eq_erase, erase_insert hat, if_pos rfl,
      ← huv, ← hμ', sum_congr rfl], intros x hx,
    rw [mul_assoc, if_neg (λ ha : x = a, hat (ha.cases_on hx))],
    convert mul_assoc _ _ _, convert (prod_eq_prod_diff_singleton_mul (mem x hx) _).symm using 3,
    convert sdiff_sdiff_comm, rw [sdiff_singleton_eq_erase, erase_insert hat] }
end

lemma exists_sum_eq_one_iff_pairwise_coprime' [fintype I] [nonempty I] [decidable_eq I] :
  (∃ μ : I → R, ∑ (i : I), μ i * ∏ j in {i}ᶜ, s j = 1) ↔ pairwise (is_coprime on s) :=
begin
  convert exists_sum_eq_one_iff_pairwise_coprime finset.univ_nonempty using 1,
  simp only [function.on_fun, pairwise_subtype_iff_pairwise_finset', coe_univ, set.pairwise_univ],
  assumption
end

lemma pairwise_coprime_iff_coprime_prod [decidable_eq I] :
  pairwise (is_coprime on λ i : t, s i) ↔ ∀ i ∈ t, is_coprime (s i) (∏ j in t \ {i}, (s j)) :=
begin
  refine ⟨λ hp i hi, is_coprime.prod_right_iff.mpr (λ j hj, _), λ hp, _⟩,
  { rw [finset.mem_sdiff, finset.mem_singleton] at hj,
    obtain ⟨hj, ji⟩ := hj,
    exact hp ⟨i, hi⟩ ⟨j, hj⟩ (λ h, ji (congr_arg coe h).symm) },
  { rintro ⟨i, hi⟩ ⟨j, hj⟩ h,
    apply is_coprime.prod_right_iff.mp (hp i hi),
    exact finset.mem_sdiff.mpr ⟨hj, λ f, h $ subtype.ext (finset.mem_singleton.mp f).symm⟩ }
end

variables {m n : ℕ}

theorem is_coprime.pow_left (H : is_coprime x y) : is_coprime (x ^ m) y :=
by { rw [← finset.card_range m, ← finset.prod_const], exact is_coprime.prod_left (λ _ _, H) }

theorem is_coprime.pow_right (H : is_coprime x y) : is_coprime x (y ^ n) :=
by { rw [← finset.card_range n, ← finset.prod_const], exact is_coprime.prod_right (λ _ _, H) }

theorem is_coprime.pow (H : is_coprime x y) : is_coprime (x ^ m) (y ^ n) :=
H.pow_left.pow_right

theorem is_coprime.pow_left_iff (hm : 0 < m) : is_coprime (x ^ m) y ↔ is_coprime x y :=
begin
  refine ⟨λ h, _, is_coprime.pow_left⟩,
  rw [← finset.card_range m, ← finset.prod_const] at h,
  exact h.of_prod_left 0 (finset.mem_range.mpr hm),
end

theorem is_coprime.pow_right_iff (hm : 0 < m) : is_coprime x (y ^ m) ↔ is_coprime x y :=
is_coprime_comm.trans $ (is_coprime.pow_left_iff hm).trans $ is_coprime_comm

theorem is_coprime.pow_iff (hm : 0 < m) (hn : 0 < n) :
  is_coprime (x ^ m) (y ^ n) ↔ is_coprime x y :=
(is_coprime.pow_left_iff hm).trans $ is_coprime.pow_right_iff hn


<|start_filename|>src/analysis/asymptotics/specific_asymptotics.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.normed_space.ordered
import analysis.asymptotics.asymptotics

/-!
# A collection of specific asymptotic results

This file contains specific lemmas about asymptotics which don't have their place in the general
theory developped in `analysis.asymptotics.asymptotics`.
-/

open filter asymptotics
open_locale topological_space

section normed_field

/-- If `f : 𝕜 → E` is bounded in a punctured neighborhood of `a`, then `f(x) = o((x - a)⁻¹)` as
`x → a`, `x ≠ a`. -/
lemma filter.is_bounded_under.is_o_sub_self_inv {𝕜 E : Type*} [normed_field 𝕜] [has_norm E]
  {a : 𝕜} {f : 𝕜 → E} (h : is_bounded_under (≤) (𝓝[≠] a) (norm ∘ f)) :
  f =o[𝓝[≠] a] (λ x, (x - a)⁻¹) :=
begin
  refine (h.is_O_const (@one_ne_zero ℝ _ _)).trans_is_o (is_o_const_left.2 $ or.inr _),
  simp only [(∘), norm_inv],
  exact (tendsto_norm_sub_self_punctured_nhds a).inv_tendsto_zero
end

end normed_field

section linear_ordered_field

variables {𝕜 : Type*} [linear_ordered_field 𝕜]

lemma pow_div_pow_eventually_eq_at_top {p q : ℕ} :
  (λ x : 𝕜, x^p / x^q) =ᶠ[at_top] (λ x, x^((p : ℤ) -q)) :=
begin
  apply ((eventually_gt_at_top (0 : 𝕜)).mono (λ x hx, _)),
  simp [zpow_sub₀ hx.ne'],
end

lemma pow_div_pow_eventually_eq_at_bot {p q : ℕ} :
  (λ x : 𝕜, x^p / x^q) =ᶠ[at_bot] (λ x, x^((p : ℤ) -q)) :=
begin
  apply ((eventually_lt_at_bot (0 : 𝕜)).mono (λ x hx, _)),
  simp [zpow_sub₀ hx.ne],
end

lemma tendsto_zpow_at_top_at_top {n : ℤ}
  (hn : 0 < n) : tendsto (λ x : 𝕜, x^n) at_top at_top :=
begin
  lift n to ℕ using hn.le,
  simp only [zpow_coe_nat],
  exact tendsto_pow_at_top (nat.succ_le_iff.mpr $ int.coe_nat_pos.mp hn)
end

lemma tendsto_pow_div_pow_at_top_at_top {p q : ℕ}
  (hpq : q < p) : tendsto (λ x : 𝕜, x^p / x^q) at_top at_top :=
begin
  rw tendsto_congr' pow_div_pow_eventually_eq_at_top,
  apply tendsto_zpow_at_top_at_top,
  linarith
end

lemma tendsto_pow_div_pow_at_top_zero [topological_space 𝕜] [order_topology 𝕜] {p q : ℕ}
  (hpq : p < q) : tendsto (λ x : 𝕜, x^p / x^q) at_top (𝓝 0) :=
begin
  rw tendsto_congr' pow_div_pow_eventually_eq_at_top,
  apply tendsto_zpow_at_top_zero,
  linarith
end

end linear_ordered_field

section normed_linear_ordered_field

variables {𝕜 : Type*} [normed_linear_ordered_field 𝕜]

lemma asymptotics.is_o_pow_pow_at_top_of_lt
  [order_topology 𝕜] {p q : ℕ} (hpq : p < q) :
  (λ x : 𝕜, x^p) =o[at_top] (λ x, x^q) :=
begin
  refine (is_o_iff_tendsto' _).mpr (tendsto_pow_div_pow_at_top_zero hpq),
  exact (eventually_gt_at_top 0).mono (λ x hx hxq, (pow_ne_zero q hx.ne' hxq).elim),
end

lemma asymptotics.is_O.trans_tendsto_norm_at_top {α : Type*} {u v : α → 𝕜} {l : filter α}
  (huv : u =O[l] v) (hu : tendsto (λ x, ∥u x∥) l at_top) : tendsto (λ x, ∥v x∥) l at_top :=
begin
  rcases huv.exists_pos with ⟨c, hc, hcuv⟩,
  rw is_O_with at hcuv,
  convert tendsto.at_top_div_const hc (tendsto_at_top_mono' l hcuv hu),
  ext x,
  rw mul_div_cancel_left _ hc.ne.symm,
end

end normed_linear_ordered_field

section real

open_locale big_operators
open finset

lemma asymptotics.is_o.sum_range {α : Type*} [normed_group α]
  {f : ℕ → α} {g : ℕ → ℝ} (h : f =o[at_top] g)
  (hg : 0 ≤ g) (h'g : tendsto (λ n, ∑ i in range n, g i) at_top at_top) :
  (λ n, ∑ i in range n, f i) =o[at_top] (λ n, ∑ i in range n, g i) :=
begin
  have A : ∀ i, ∥g i∥ = g i := λ i, real.norm_of_nonneg (hg i),
  have B : ∀ n, ∥∑ i in range n, g i∥ = ∑ i in range n, g i,
    from λ n, by rwa [real.norm_eq_abs, abs_sum_of_nonneg'],
  apply is_o_iff.2 (λ ε εpos, _),
  obtain ⟨N, hN⟩ : ∃ (N : ℕ), ∀ (b : ℕ), N ≤ b → ∥f b∥ ≤ ε / 2 * g b,
    by simpa only [A, eventually_at_top] using is_o_iff.mp h (half_pos εpos),
  have : (λ (n : ℕ), ∑ i in range N, f i) =o[at_top] (λ (n : ℕ), ∑ i in range n, g i),
  { apply is_o_const_left.2,
    exact or.inr (h'g.congr (λ n, (B n).symm)) },
  filter_upwards [is_o_iff.1 this (half_pos εpos), Ici_mem_at_top N] with n hn Nn,
  calc ∥∑ i in range n, f i∥
  = ∥∑ i in range N, f i + ∑ i in Ico N n, f i∥ :
    by rw sum_range_add_sum_Ico _ Nn
  ... ≤ ∥∑ i in range N, f i∥ + ∥∑ i in Ico N n, f i∥ :
    norm_add_le _ _
  ... ≤ ∥∑ i in range N, f i∥ + ∑ i in Ico N n, (ε / 2) * g i :
    add_le_add le_rfl (norm_sum_le_of_le _ (λ i hi, hN _ (mem_Ico.1 hi).1))
  ... ≤ ∥∑ i in range N, f i∥ + ∑ i in range n, (ε / 2) * g i :
    begin
      refine add_le_add le_rfl _,
      apply sum_le_sum_of_subset_of_nonneg,
      { rw range_eq_Ico,
        exact Ico_subset_Ico (zero_le _) le_rfl },
      { assume i hi hident,
        exact mul_nonneg (half_pos εpos).le (hg i) }
    end
  ... ≤ (ε / 2) * ∥∑ i in range n, g i∥ + (ε / 2) * (∑ i in range n, g i) :
    begin
      rw ← mul_sum,
      exact add_le_add hn (mul_le_mul_of_nonneg_left le_rfl (half_pos εpos).le),
    end
  ... = ε * ∥(∑ i in range n, g i)∥ : by { simp [B], ring }
end

lemma asymptotics.is_o_sum_range_of_tendsto_zero {α : Type*} [normed_group α]
  {f : ℕ → α} (h : tendsto f at_top (𝓝 0)) :
  (λ n, ∑ i in range n, f i) =o[at_top] (λ n, (n : ℝ)) :=
begin
  have := ((is_o_one_iff ℝ).2 h).sum_range (λ i, zero_le_one),
  simp only [sum_const, card_range, nat.smul_one_eq_coe] at this,
  exact this tendsto_coe_nat_at_top_at_top
end

/-- The Cesaro average of a converging sequence converges to the same limit. -/
lemma filter.tendsto.cesaro_smul {E : Type*} [normed_group E] [normed_space ℝ E]
  {u : ℕ → E} {l : E} (h : tendsto u at_top (𝓝 l)) :
  tendsto (λ (n : ℕ), (n ⁻¹ : ℝ) • (∑ i in range n, u i)) at_top (𝓝 l) :=
begin
  rw [← tendsto_sub_nhds_zero_iff, ← is_o_one_iff ℝ],
  have := asymptotics.is_o_sum_range_of_tendsto_zero (tendsto_sub_nhds_zero_iff.2 h),
  apply ((is_O_refl (λ (n : ℕ), (n : ℝ) ⁻¹) at_top).smul_is_o this).congr' _ _,
  { filter_upwards [Ici_mem_at_top 1] with n npos,
    have nposℝ : (0 : ℝ) < n := nat.cast_pos.2 npos,
    simp only [smul_sub, sum_sub_distrib, sum_const, card_range, sub_right_inj],
    rw [nsmul_eq_smul_cast ℝ, smul_smul, inv_mul_cancel nposℝ.ne', one_smul] },
  { filter_upwards [Ici_mem_at_top 1] with n npos,
    have nposℝ : (0 : ℝ) < n := nat.cast_pos.2 npos,
    rw [algebra.id.smul_eq_mul, inv_mul_cancel nposℝ.ne'] }
end

/-- The Cesaro average of a converging sequence converges to the same limit. -/
lemma filter.tendsto.cesaro {u : ℕ → ℝ} {l : ℝ} (h : tendsto u at_top (𝓝 l)) :
  tendsto (λ (n : ℕ), (n ⁻¹ : ℝ) * (∑ i in range n, u i)) at_top (𝓝 l) :=
h.cesaro_smul

end real


<|start_filename|>src/linear_algebra/projection.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import linear_algebra.quotient
import linear_algebra.prod

/-!
# Projection to a subspace

In this file we define
* `linear_proj_of_is_compl (p q : submodule R E) (h : is_compl p q)`: the projection of a module `E`
  to a submodule `p` along its complement `q`; it is the unique linear map `f : E → p` such that
  `f x = x` for `x ∈ p` and `f x = 0` for `x ∈ q`.
* `is_compl_equiv_proj p`: equivalence between submodules `q` such that `is_compl p q` and
  projections `f : E → p`, `∀ x ∈ p, f x = x`.

We also provide some lemmas justifying correctness of our definitions.

## Tags

projection, complement subspace
-/

section ring

variables {R : Type*} [ring R] {E : Type*} [add_comm_group E] [module R E]
  {F : Type*} [add_comm_group F] [module R F]
  {G : Type*} [add_comm_group G] [module R G] (p q : submodule R E)
variables {S : Type*} [semiring S] {M : Type*} [add_comm_monoid M] [module S M] (m : submodule S M)


noncomputable theory

namespace linear_map

variable {p}

open submodule

lemma ker_id_sub_eq_of_proj {f : E →ₗ[R] p} (hf : ∀ x : p, f x = x) :
  ker (id - p.subtype.comp f) = p :=
begin
  ext x,
  simp only [comp_apply, mem_ker, subtype_apply, sub_apply, id_apply, sub_eq_zero],
  exact ⟨λ h, h.symm ▸ submodule.coe_mem _, λ hx, by erw [hf ⟨x, hx⟩, subtype.coe_mk]⟩
end

lemma range_eq_of_proj {f : E →ₗ[R] p} (hf : ∀ x : p, f x = x) :
  range f = ⊤ :=
range_eq_top.2 $ λ x, ⟨x, hf x⟩

lemma is_compl_of_proj {f : E →ₗ[R] p} (hf : ∀ x : p, f x = x) :
  is_compl p f.ker :=
begin
  split,
  { rintros x ⟨hpx, hfx⟩,
    erw [set_like.mem_coe, mem_ker, hf ⟨x, hpx⟩, mk_eq_zero] at hfx,
    simp only [hfx, set_like.mem_coe, zero_mem] },
  { intros x hx,
    rw [mem_sup'],
    refine ⟨f x, ⟨x - f x, _⟩, add_sub_cancel'_right _ _⟩,
    rw [mem_ker, linear_map.map_sub, hf, sub_self] }
end

end linear_map

namespace submodule

open linear_map

/-- If `q` is a complement of `p`, then `M/p ≃ q`. -/
def quotient_equiv_of_is_compl (h : is_compl p q) : (E ⧸ p) ≃ₗ[R] q :=
linear_equiv.symm $ linear_equiv.of_bijective (p.mkq.comp q.subtype)
  (by simp only [← ker_eq_bot, ker_comp, ker_mkq, disjoint_iff_comap_eq_bot.1 h.symm.disjoint])
  (by simp only [← range_eq_top, range_comp, range_subtype, map_mkq_eq_top, h.sup_eq_top])

@[simp] lemma quotient_equiv_of_is_compl_symm_apply (h : is_compl p q) (x : q) :
  (quotient_equiv_of_is_compl p q h).symm x = quotient.mk x := rfl

@[simp] lemma quotient_equiv_of_is_compl_apply_mk_coe (h : is_compl p q) (x : q) :
  quotient_equiv_of_is_compl p q h (quotient.mk x) = x :=
(quotient_equiv_of_is_compl p q h).apply_symm_apply x

@[simp] lemma mk_quotient_equiv_of_is_compl_apply (h : is_compl p q) (x : E ⧸ p) :
  (quotient.mk (quotient_equiv_of_is_compl p q h x) : E ⧸ p) = x :=
(quotient_equiv_of_is_compl p q h).symm_apply_apply x

/-- If `q` is a complement of `p`, then `p × q` is isomorphic to `E`. It is the unique
linear map `f : E → p` such that `f x = x` for `x ∈ p` and `f x = 0` for `x ∈ q`. -/
def prod_equiv_of_is_compl (h : is_compl p q) : (p × q) ≃ₗ[R] E :=
begin
  apply linear_equiv.of_bijective (p.subtype.coprod q.subtype),
  { simp only [←ker_eq_bot, ker_eq_bot', prod.forall, subtype_apply, prod.mk_eq_zero, coprod_apply],
    -- TODO: if I add `submodule.forall`, it unfolds the outer `∀` but not the inner one.
    rintros ⟨x, hx⟩ ⟨y, hy⟩,
    simp only [coe_mk, mk_eq_zero, ← eq_neg_iff_add_eq_zero],
    rintro rfl,
    rw [neg_mem_iff] at hx,
    simp [disjoint_def.1 h.disjoint y hx hy] },
  { rw [← range_eq_top, ← sup_eq_range, h.sup_eq_top] }
end

@[simp] lemma coe_prod_equiv_of_is_compl (h : is_compl p q) :
  (prod_equiv_of_is_compl p q h : (p × q) →ₗ[R] E) = p.subtype.coprod q.subtype := rfl

@[simp] lemma coe_prod_equiv_of_is_compl' (h : is_compl p q) (x : p × q) :
  prod_equiv_of_is_compl p q h x = x.1 + x.2 := rfl

@[simp] lemma prod_equiv_of_is_compl_symm_apply_left (h : is_compl p q) (x : p) :
  (prod_equiv_of_is_compl p q h).symm x = (x, 0) :=
(prod_equiv_of_is_compl p q h).symm_apply_eq.2 $ by simp

@[simp] lemma prod_equiv_of_is_compl_symm_apply_right (h : is_compl p q) (x : q) :
  (prod_equiv_of_is_compl p q h).symm x = (0, x) :=
(prod_equiv_of_is_compl p q h).symm_apply_eq.2 $ by simp

@[simp] lemma prod_equiv_of_is_compl_symm_apply_fst_eq_zero (h : is_compl p q) {x : E} :
  ((prod_equiv_of_is_compl p q h).symm x).1 = 0 ↔ x ∈ q :=
begin
  conv_rhs { rw [← (prod_equiv_of_is_compl p q h).apply_symm_apply x] },
  rw [coe_prod_equiv_of_is_compl', submodule.add_mem_iff_left _ (submodule.coe_mem _),
    mem_right_iff_eq_zero_of_disjoint h.disjoint]
end

@[simp] lemma prod_equiv_of_is_compl_symm_apply_snd_eq_zero (h : is_compl p q) {x : E} :
  ((prod_equiv_of_is_compl p q h).symm x).2 = 0 ↔ x ∈ p :=
begin
  conv_rhs { rw [← (prod_equiv_of_is_compl p q h).apply_symm_apply x] },
  rw [coe_prod_equiv_of_is_compl', submodule.add_mem_iff_right _ (submodule.coe_mem _),
    mem_left_iff_eq_zero_of_disjoint h.disjoint]
end

@[simp]
lemma prod_comm_trans_prod_equiv_of_is_compl (h : is_compl p q) :
  linear_equiv.prod_comm R q p ≪≫ₗ prod_equiv_of_is_compl p q h =
    prod_equiv_of_is_compl q p h.symm :=
linear_equiv.ext $ λ _, add_comm _ _

/-- Projection to a submodule along its complement. -/
def linear_proj_of_is_compl (h : is_compl p q) :
  E →ₗ[R] p :=
(linear_map.fst R p q) ∘ₗ ↑(prod_equiv_of_is_compl p q h).symm

variables {p q}

@[simp] lemma linear_proj_of_is_compl_apply_left (h : is_compl p q) (x : p) :
  linear_proj_of_is_compl p q h x = x :=
by simp [linear_proj_of_is_compl]

@[simp] lemma linear_proj_of_is_compl_range (h : is_compl p q) :
  (linear_proj_of_is_compl p q h).range = ⊤ :=
range_eq_of_proj (linear_proj_of_is_compl_apply_left h)

@[simp] lemma linear_proj_of_is_compl_apply_eq_zero_iff (h : is_compl p q) {x : E} :
  linear_proj_of_is_compl p q h x = 0 ↔ x ∈ q:=
by simp [linear_proj_of_is_compl]

lemma linear_proj_of_is_compl_apply_right' (h : is_compl p q) (x : E) (hx : x ∈ q) :
  linear_proj_of_is_compl p q h x = 0 :=
(linear_proj_of_is_compl_apply_eq_zero_iff h).2 hx

@[simp] lemma linear_proj_of_is_compl_apply_right (h : is_compl p q) (x : q) :
  linear_proj_of_is_compl p q h x = 0 :=
linear_proj_of_is_compl_apply_right' h x x.2

@[simp] lemma linear_proj_of_is_compl_ker (h : is_compl p q) :
  (linear_proj_of_is_compl p q h).ker = q :=
ext $ λ x, mem_ker.trans (linear_proj_of_is_compl_apply_eq_zero_iff h)

lemma linear_proj_of_is_compl_comp_subtype (h : is_compl p q) :
  (linear_proj_of_is_compl p q h).comp p.subtype = id :=
linear_map.ext $ linear_proj_of_is_compl_apply_left h

lemma linear_proj_of_is_compl_idempotent (h : is_compl p q) (x : E) :
  linear_proj_of_is_compl p q h (linear_proj_of_is_compl p q h x) =
    linear_proj_of_is_compl p q h x :=
linear_proj_of_is_compl_apply_left h _

lemma exists_unique_add_of_is_compl_prod (hc : is_compl p q) (x : E) :
  ∃! (u : p × q), (u.fst : E) + u.snd = x :=
(prod_equiv_of_is_compl _ _ hc).to_equiv.bijective.exists_unique _

lemma exists_unique_add_of_is_compl (hc : is_compl p q) (x : E) :
  ∃ (u : p) (v : q), ((u : E) + v = x ∧ ∀ (r : p) (s : q),
    (r : E) + s = x → r = u ∧ s = v) :=
let ⟨u, hu₁, hu₂⟩ := exists_unique_add_of_is_compl_prod hc x in
  ⟨u.1, u.2, hu₁, λ r s hrs, prod.eq_iff_fst_eq_snd_eq.1 (hu₂ ⟨r, s⟩ hrs)⟩

lemma linear_proj_add_linear_proj_of_is_compl_eq_self (hpq : is_compl p q) (x : E) :
  (p.linear_proj_of_is_compl q hpq x + q.linear_proj_of_is_compl p hpq.symm x : E) = x :=
begin
  dunfold linear_proj_of_is_compl,
  rw ←prod_comm_trans_prod_equiv_of_is_compl _ _ hpq,
  exact (prod_equiv_of_is_compl _ _ hpq).apply_symm_apply x,
end

end submodule

namespace linear_map

open submodule

/-- Given linear maps `φ` and `ψ` from complement submodules, `of_is_compl` is
the induced linear map over the entire module. -/
def of_is_compl {p q : submodule R E} (h : is_compl p q)
  (φ : p →ₗ[R] F) (ψ : q →ₗ[R] F) : E →ₗ[R] F :=
(linear_map.coprod φ ψ) ∘ₗ ↑(submodule.prod_equiv_of_is_compl _ _ h).symm

variables {p q}

@[simp] lemma of_is_compl_left_apply
  (h : is_compl p q) {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} (u : p) :
  of_is_compl h φ ψ (u : E) = φ u := by simp [of_is_compl]

@[simp] lemma of_is_compl_right_apply
  (h : is_compl p q) {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} (v : q) :
  of_is_compl h φ ψ (v : E) = ψ v := by simp [of_is_compl]

lemma of_is_compl_eq (h : is_compl p q)
  {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} {χ : E →ₗ[R] F}
  (hφ : ∀ u, φ u = χ u) (hψ : ∀ u, ψ u = χ u) :
  of_is_compl h φ ψ = χ :=
begin
  ext x,
  obtain ⟨_, _, rfl, _⟩ := exists_unique_add_of_is_compl h x,
  simp [of_is_compl, hφ, hψ]
end

lemma of_is_compl_eq' (h : is_compl p q)
  {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} {χ : E →ₗ[R] F}
  (hφ : φ = χ.comp p.subtype) (hψ : ψ = χ.comp q.subtype) :
  of_is_compl h φ ψ = χ :=
of_is_compl_eq h (λ _, hφ.symm ▸ rfl) (λ _, hψ.symm ▸ rfl)

@[simp] lemma of_is_compl_zero (h : is_compl p q) :
  (of_is_compl h 0 0 : E →ₗ[R] F) = 0 :=
of_is_compl_eq _ (λ _, rfl) (λ _, rfl)

@[simp] lemma of_is_compl_add (h : is_compl p q)
  {φ₁ φ₂ : p →ₗ[R] F} {ψ₁ ψ₂ : q →ₗ[R] F} :
  of_is_compl h (φ₁ + φ₂) (ψ₁ + ψ₂) = of_is_compl h φ₁ ψ₁ + of_is_compl h φ₂ ψ₂ :=
of_is_compl_eq _ (by simp) (by simp)

@[simp] lemma of_is_compl_smul
  {R : Type*} [comm_ring R] {E : Type*} [add_comm_group E] [module R E]
  {F : Type*} [add_comm_group F] [module R F] {p q : submodule R E}
  (h : is_compl p q) {φ : p →ₗ[R] F} {ψ : q →ₗ[R] F} (c : R) :
  of_is_compl h (c • φ) (c • ψ) = c • of_is_compl h φ ψ :=
of_is_compl_eq _ (by simp) (by simp)

section

variables {R₁ : Type*} [comm_ring R₁] [module R₁ E] [module R₁ F]

/-- The linear map from `(p →ₗ[R₁] F) × (q →ₗ[R₁] F)` to `E →ₗ[R₁] F`. -/
def of_is_compl_prod {p q : submodule R₁ E} (h : is_compl p q) :
  ((p →ₗ[R₁] F) × (q →ₗ[R₁] F)) →ₗ[R₁] (E →ₗ[R₁] F) :=
{ to_fun := λ φ, of_is_compl h φ.1 φ.2,
  map_add' := by { intros φ ψ, rw [prod.snd_add, prod.fst_add, of_is_compl_add] },
  map_smul' := by { intros c φ, simp [prod.smul_snd, prod.smul_fst, of_is_compl_smul] } }

@[simp] lemma of_is_compl_prod_apply {p q : submodule R₁ E} (h : is_compl p q)
  (φ : (p →ₗ[R₁] F) × (q →ₗ[R₁] F)) : of_is_compl_prod h φ = of_is_compl h φ.1 φ.2 := rfl

/-- The natural linear equivalence between `(p →ₗ[R₁] F) × (q →ₗ[R₁] F)` and `E →ₗ[R₁] F`. -/
def of_is_compl_prod_equiv {p q : submodule R₁ E} (h : is_compl p q) :
  ((p →ₗ[R₁] F) × (q →ₗ[R₁] F)) ≃ₗ[R₁] (E →ₗ[R₁] F) :=
{ inv_fun := λ φ, ⟨φ.dom_restrict p, φ.dom_restrict q⟩,
  left_inv :=
    begin
      intros φ, ext,
      { exact of_is_compl_left_apply h x },
      { exact of_is_compl_right_apply h x }
    end,
  right_inv :=
    begin
      intro φ, ext,
      obtain ⟨a, b, hab, _⟩ := exists_unique_add_of_is_compl h x,
      rw [← hab], simp,
    end, .. of_is_compl_prod h }

end

@[simp] lemma linear_proj_of_is_compl_of_proj (f : E →ₗ[R] p) (hf : ∀ x : p, f x = x) :
  p.linear_proj_of_is_compl f.ker (is_compl_of_proj hf) = f :=
begin
  ext x,
  have : x ∈ p ⊔ f.ker,
  { simp only [(is_compl_of_proj hf).sup_eq_top, mem_top] },
  rcases mem_sup'.1 this with ⟨x, y, rfl⟩,
  simp [hf]
end

/-- If `f : E →ₗ[R] F` and `g : E →ₗ[R] G` are two surjective linear maps and
their kernels are complement of each other, then `x ↦ (f x, g x)` defines
a linear equivalence `E ≃ₗ[R] F × G`. -/
def equiv_prod_of_surjective_of_is_compl (f : E →ₗ[R] F) (g : E →ₗ[R] G) (hf : f.range = ⊤)
  (hg : g.range = ⊤) (hfg : is_compl f.ker g.ker) :
  E ≃ₗ[R] F × G :=
linear_equiv.of_bijective (f.prod g) (by simp [← ker_eq_bot, hfg.inf_eq_bot])
  (by simp [← range_eq_top, range_prod_eq hfg.sup_eq_top, *])

@[simp] lemma coe_equiv_prod_of_surjective_of_is_compl {f : E →ₗ[R] F} {g : E →ₗ[R] G}
  (hf : f.range = ⊤) (hg : g.range = ⊤) (hfg : is_compl f.ker g.ker) :
  (equiv_prod_of_surjective_of_is_compl f g hf hg hfg : E →ₗ[R] F × G) = f.prod g :=
rfl

@[simp] lemma equiv_prod_of_surjective_of_is_compl_apply {f : E →ₗ[R] F} {g : E →ₗ[R] G}
  (hf : f.range = ⊤) (hg : g.range = ⊤) (hfg : is_compl f.ker g.ker) (x : E):
  equiv_prod_of_surjective_of_is_compl f g hf hg hfg x = (f x, g x) :=
rfl

end linear_map

namespace submodule

open linear_map

/-- Equivalence between submodules `q` such that `is_compl p q` and linear maps `f : E →ₗ[R] p`
such that `∀ x : p, f x = x`. -/
def is_compl_equiv_proj :
  {q // is_compl p q} ≃ {f : E →ₗ[R] p // ∀ x : p, f x = x} :=
{ to_fun := λ q, ⟨linear_proj_of_is_compl p q q.2, linear_proj_of_is_compl_apply_left q.2⟩,
  inv_fun := λ f, ⟨(f : E →ₗ[R] p).ker, is_compl_of_proj f.2⟩,
  left_inv := λ ⟨q, hq⟩, by simp only [linear_proj_of_is_compl_ker, subtype.coe_mk],
  right_inv := λ ⟨f, hf⟩, subtype.eq $ f.linear_proj_of_is_compl_of_proj hf }

@[simp] lemma coe_is_compl_equiv_proj_apply (q : {q // is_compl p q}) :
  (p.is_compl_equiv_proj q : E →ₗ[R] p) = linear_proj_of_is_compl p q q.2 := rfl

@[simp] lemma coe_is_compl_equiv_proj_symm_apply (f : {f : E →ₗ[R] p // ∀ x : p, f x = x}) :
  (p.is_compl_equiv_proj.symm f : submodule R E) = (f : E →ₗ[R] p).ker := rfl

end submodule

namespace linear_map

open submodule

/--
A linear endomorphism of a module `E` is a projection onto a submodule `p` if it sends every element
of `E` to `p` and fixes every element of `p`.
The definition allow more generally any `fun_like` type and not just linear maps, so that it can be
used for example with `continuous_linear_map` or `matrix`.
-/
structure is_proj {F : Type*} [fun_like F M (λ _, M)] (f : F) : Prop :=
(map_mem : ∀ x, f x ∈ m)
(map_id : ∀ x ∈ m, f x = x)

lemma is_proj_iff_idempotent (f : M →ₗ[S] M) : (∃ p : submodule S M, is_proj p f) ↔ f ∘ₗ f = f :=
begin
  split,
  { intro h, obtain ⟨p, hp⟩ := h, ext, rw comp_apply, exact hp.map_id (f x) (hp.map_mem x), },
  { intro h, use f.range, split,
    { intro x, exact mem_range_self f x, },
    { intros x hx, obtain ⟨y, hy⟩ := mem_range.1 hx, rw [←hy, ←comp_apply, h], }, },
end

namespace is_proj

variables {p m}

/--
Restriction of the codomain of a projection of onto a subspace `p` to `p` instead of the whole
space.
-/
def cod_restrict {f : M →ₗ[S] M} (h : is_proj m f) : M →ₗ[S] m :=
f.cod_restrict m h.map_mem

@[simp]
lemma cod_restrict_apply {f : M →ₗ[S] M} (h : is_proj m f) (x : M) :
  ↑(h.cod_restrict x) = f x := f.cod_restrict_apply m x

@[simp]
lemma cod_restrict_apply_cod {f : M →ₗ[S] M} (h : is_proj m f) (x : m) :
  h.cod_restrict x = x :=
by {ext, rw [cod_restrict_apply], exact h.map_id x x.2}

lemma cod_restrict_ker {f : M →ₗ[S] M} (h : is_proj m f) :
  h.cod_restrict.ker = f.ker := f.ker_cod_restrict m _

lemma is_compl {f : E →ₗ[R] E} (h : is_proj p f) : is_compl p f.ker :=
by { rw ←cod_restrict_ker, exact is_compl_of_proj h.cod_restrict_apply_cod, }

lemma eq_conj_prod_map' {f : E →ₗ[R] E} (h : is_proj p f) :
  f = (p.prod_equiv_of_is_compl f.ker h.is_compl).to_linear_map ∘ₗ prod_map id 0 ∘ₗ
    (p.prod_equiv_of_is_compl f.ker h.is_compl).symm.to_linear_map :=
begin
  refine (linear_map.cancel_right
    (p.prod_equiv_of_is_compl f.ker h.is_compl).surjective).1 _,
  ext,
  { simp only [coe_comp, linear_equiv.coe_to_linear_map, coe_inl, function.comp_app,
  linear_equiv.of_top_apply, linear_equiv.of_injective_apply, coprod_apply, submodule.coe_subtype,
  coe_zero, add_zero, prod_equiv_of_is_compl_symm_apply_left, prod_map_apply, id_coe, id.def,
  zero_apply, coe_prod_equiv_of_is_compl', h.map_id x x.2], },
  {simp only [coe_comp, linear_equiv.coe_to_linear_map, coe_inr, function.comp_app,
  linear_equiv.of_top_apply, linear_equiv.of_injective_apply, coprod_apply, submodule.coe_subtype,
  coe_zero, zero_add, map_coe_ker, prod_equiv_of_is_compl_symm_apply_right, prod_map_apply, id_coe,
  id.def, zero_apply, coe_prod_equiv_of_is_compl'], }
end

end is_proj

end linear_map

end ring

section comm_ring

namespace linear_map

variables {R : Type*} [comm_ring R] {E : Type*} [add_comm_group E] [module R E]  {p : submodule R E}

lemma is_proj.eq_conj_prod_map {f : E →ₗ[R] E} (h : is_proj p f) :
  f = (p.prod_equiv_of_is_compl f.ker h.is_compl).conj (prod_map id 0) :=
by {rw linear_equiv.conj_apply, exact h.eq_conj_prod_map'}

end linear_map

end comm_ring


<|start_filename|>src/algebraic_topology/simplicial_object.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import algebraic_topology.simplex_category
import category_theory.arrow
import category_theory.limits.functor_category
import category_theory.opposites

/-!
# Simplicial objects in a category.

A simplicial object in a category `C` is a `C`-valued presheaf on `simplex_category`.
(Similarly a cosimplicial object is functor `simplex_category ⥤ C`.)

Use the notation `X _[n]` in the `simplicial` locale to obtain the `n`-th term of a
(co)simplicial object `X`, where `n` is a natural number.

-/

open opposite
open category_theory
open category_theory.limits

universes v u v' u'

namespace category_theory

variables (C : Type u) [category.{v} C]

/-- The category of simplicial objects valued in a category `C`.
This is the category of contravariant functors from `simplex_category` to `C`. -/
@[derive category, nolint has_inhabited_instance]
def simplicial_object := simplex_categoryᵒᵖ ⥤ C

namespace simplicial_object

localized
  "notation X `_[`:1000 n `]` :=
    (X : category_theory.simplicial_object _).obj (opposite.op (simplex_category.mk n))"
  in simplicial

instance {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (simplicial_object C) := by {dsimp [simplicial_object], apply_instance}

instance [has_limits C] : has_limits (simplicial_object C) := ⟨infer_instance⟩

instance {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (simplicial_object C) := by {dsimp [simplicial_object], apply_instance}

instance [has_colimits C] : has_colimits (simplicial_object C) := ⟨infer_instance⟩

variables {C} (X : simplicial_object C)

/-- Face maps for a simplicial object. -/
def δ {n} (i : fin (n+2)) : X _[n+1] ⟶ X _[n] :=
X.map (simplex_category.δ i).op

/-- Degeneracy maps for a simplicial object. -/
def σ {n} (i : fin (n+1)) : X _[n] ⟶ X _[n+1] :=
X.map (simplex_category.σ i).op


/-- Isomorphisms from identities in ℕ. -/
def eq_to_iso {n m : ℕ} (h : n = m) : X _[n] ≅ X _[m] :=
X.map_iso (eq_to_iso (by rw h))

@[simp] lemma eq_to_iso_refl {n : ℕ} (h : n = n) : X.eq_to_iso h = iso.refl _ :=
by { ext, simp [eq_to_iso], }


/-- The generic case of the first simplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  X.δ j.succ ≫ X.δ i = X.δ i.cast_succ ≫ X.δ j :=
by { dsimp [δ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_δ H] }

/-- The special case of the first simplicial identity -/
lemma δ_comp_δ_self {n} {i : fin (n+2)} : X.δ i.cast_succ ≫ X.δ i = X.δ i.succ ≫ X.δ i :=
by { dsimp [δ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_δ_self] }

/-- The second simplicial identity -/
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  X.σ j.succ ≫ X.δ i.cast_succ = X.δ i ≫ X.σ j :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_of_le H] }

/-- The first part of the third simplicial identity -/
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  X.σ i ≫ X.δ i.cast_succ = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_self, op_id, X.map_id],
end

/-- The second part of the third simplicial identity -/
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  X.σ i ≫ X.δ i.succ = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_succ, op_id, X.map_id],
end

/-- The fourth simplicial identity -/
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  X.σ j.cast_succ ≫ X.δ i.succ = X.δ i ≫ X.σ j :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_of_gt H] }

/-- The fifth simplicial identity -/
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  X.σ j ≫ X.σ i.cast_succ = X.σ i ≫ X.σ j.succ :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.σ_comp_σ H] }

variable (C)

/-- Functor composition induces a functor on simplicial objects. -/
@[simps]
def whiskering (D : Type*) [category D] :
  (C ⥤ D) ⥤ simplicial_object C ⥤ simplicial_object D :=
whiskering_right _ _ _

/-- Truncated simplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def truncated (n : ℕ) := (simplex_category.truncated n)ᵒᵖ ⥤ C

variable {C}

namespace truncated

instance {n} {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (simplicial_object.truncated C n) := by {dsimp [truncated], apply_instance}

instance {n} [has_limits C] : has_limits (simplicial_object.truncated C n) := ⟨infer_instance⟩

instance {n} {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (simplicial_object.truncated C n) :=
by {dsimp [truncated], apply_instance}

instance {n} [has_colimits C] : has_colimits (simplicial_object.truncated C n) := ⟨infer_instance⟩

variable (C)

/-- Functor composition induces a functor on truncated simplicial objects. -/
@[simps]
def whiskering {n} (D : Type*) [category D] :
  (C ⥤ D) ⥤ truncated C n ⥤ truncated D n :=
whiskering_right _ _ _

variable {C}

end truncated

section skeleton

/-- The skeleton functor from simplicial objects to truncated simplicial objects. -/
def sk (n : ℕ) : simplicial_object C ⥤ simplicial_object.truncated C n :=
(whiskering_left _ _ _).obj simplex_category.truncated.inclusion.op

end skeleton

variable (C)

/-- The constant simplicial object is the constant functor. -/
abbreviation const : C ⥤ simplicial_object C := category_theory.functor.const _

/-- The category of augmented simplicial objects, defined as a comma category. -/
@[derive category, nolint has_inhabited_instance]
def augmented := comma (𝟭 (simplicial_object C)) (const C)

variable {C}

namespace augmented

/-- Drop the augmentation. -/
@[simps]
def drop : augmented C ⥤ simplicial_object C := comma.fst _ _

/-- The point of the augmentation. -/
@[simps]
def point : augmented C ⥤ C := comma.snd _ _

/-- The functor from augmented objects to arrows. -/
@[simps]
def to_arrow : augmented C ⥤ arrow C :=
{ obj := λ X,
  { left := (drop.obj X) _[0],
    right := (point.obj X),
    hom := X.hom.app _ },
  map := λ X Y η,
  { left := (drop.map η).app _,
    right := (point.map η),
    w' := begin
      dsimp,
      rw ← nat_trans.comp_app,
      erw η.w,
      refl,
    end } }

variable (C)

/-- Functor composition induces a functor on augmented simplicial objects. -/
@[simp]
def whiskering_obj (D : Type*) [category D] (F : C ⥤ D) :
  augmented C ⥤ augmented D :=
{ obj := λ X,
  { left := ((whiskering _ _).obj F).obj (drop.obj X),
    right := F.obj (point.obj X),
    hom := whisker_right X.hom F ≫ (functor.const_comp _ _ _).hom },
  map := λ X Y η,
  { left := whisker_right η.left _,
    right := F.map η.right,
    w' := begin
      ext,
      dsimp,
      rw [category.comp_id, category.comp_id, ← F.map_comp, ← F.map_comp, ← nat_trans.comp_app],
      erw η.w,
      refl,
    end } }

/-- Functor composition induces a functor on augmented simplicial objects. -/
@[simps]
def whiskering (D : Type u') [category.{v'} D] :
  (C ⥤ D) ⥤ augmented C ⥤ augmented D :=
{ obj := whiskering_obj _ _,
  map := λ X Y η,
  { app := λ A,
    { left := whisker_left _ η,
      right := η.app _,
      w' := begin
        ext n,
        dsimp,
        rw [category.comp_id, category.comp_id, η.naturality],
      end }, }, }

variable {C}

end augmented

open_locale simplicial

/-- Aaugment a simplicial object with an object. -/
@[simps]
def augment (X : simplicial_object C) (X₀ : C) (f : X _[0] ⟶ X₀)
  (w : ∀ (i : simplex_category) (g₁ g₂ : [0] ⟶ i),
    X.map g₁.op ≫ f = X.map g₂.op ≫ f) : simplicial_object.augmented C :=
{ left := X,
  right := X₀,
  hom :=
  { app := λ i, X.map (simplex_category.const i.unop 0).op ≫ f,
    naturality' := begin
      intros i j g,
      dsimp,
      rw ← g.op_unop,
      simpa only [← X.map_comp, ← category.assoc, category.comp_id, ← op_comp] using w _ _ _,
    end } }

@[simp]
lemma augment_hom_zero (X : simplicial_object C) (X₀ : C) (f : X _[0] ⟶ X₀) (w) :
  (X.augment X₀ f w).hom.app (op [0]) = f :=
by { dsimp, rw [simplex_category.hom_zero_zero ([0].const 0), op_id, X.map_id, category.id_comp] }

end simplicial_object

/-- Cosimplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def cosimplicial_object := simplex_category ⥤ C

namespace cosimplicial_object

localized
  "notation X `_[`:1000 n `]` :=
    (X : category_theory.cosimplicial_object _).obj (simplex_category.mk n)"
  in simplicial

instance {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (cosimplicial_object C) := by {dsimp [cosimplicial_object], apply_instance}

instance [has_limits C] : has_limits (cosimplicial_object C) := ⟨infer_instance⟩

instance {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (cosimplicial_object C) :=
by {dsimp [cosimplicial_object], apply_instance}

instance [has_colimits C] : has_colimits (cosimplicial_object C) := ⟨infer_instance⟩

variables {C} (X : cosimplicial_object C)

/-- Coface maps for a cosimplicial object. -/
def δ {n} (i : fin (n+2)) : X _[n] ⟶ X _[n+1] :=
X.map (simplex_category.δ i)

/-- Codegeneracy maps for a cosimplicial object. -/
def σ {n} (i : fin (n+1)) : X _[n+1] ⟶ X _[n] :=
X.map (simplex_category.σ i)

/-- Isomorphisms from identities in ℕ. -/
def eq_to_iso {n m : ℕ} (h : n = m) : X _[n] ≅ X _[m] :=
X.map_iso (eq_to_iso (by rw h))

@[simp] lemma eq_to_iso_refl {n : ℕ} (h : n = n) : X.eq_to_iso h = iso.refl _ :=
by { ext, simp [eq_to_iso], }


/-- The generic case of the first cosimplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  X.δ i ≫ X.δ j.succ = X.δ j ≫ X.δ i.cast_succ :=
by { dsimp [δ], simp only [←X.map_comp, simplex_category.δ_comp_δ H], }

/-- The special case of the first cosimplicial identity -/
lemma δ_comp_δ_self {n} {i : fin (n+2)} : X.δ i ≫ X.δ i.cast_succ = X.δ i ≫ X.δ i.succ :=
by { dsimp [δ], simp only [←X.map_comp, simplex_category.δ_comp_δ_self] }

/-- The second cosimplicial identity -/
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  X.δ i.cast_succ ≫ X.σ j.succ = X.σ j ≫ X.δ i :=
by { dsimp [δ, σ], simp only [←X.map_comp, simplex_category.δ_comp_σ_of_le H] }

/-- The first part of the third cosimplicial identity -/
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  X.δ i.cast_succ ≫ X.σ i = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, simplex_category.δ_comp_σ_self, X.map_id],
end

/-- The second part of the third cosimplicial identity -/
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  X.δ i.succ ≫ X.σ i = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, simplex_category.δ_comp_σ_succ, X.map_id],
end

/-- The fourth cosimplicial identity -/
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  X.δ i.succ ≫ X.σ j.cast_succ = X.σ j ≫ X.δ i :=
by { dsimp [δ, σ], simp only [←X.map_comp, simplex_category.δ_comp_σ_of_gt H] }

/-- The fifth cosimplicial identity -/
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  X.σ i.cast_succ ≫ X.σ j = X.σ j.succ ≫ X.σ i :=
by { dsimp [δ, σ], simp only [←X.map_comp, simplex_category.σ_comp_σ H] }

variable (C)

/-- Functor composition induces a functor on cosimplicial objects. -/
@[simps]
def whiskering (D : Type*) [category D] :
  (C ⥤ D) ⥤ cosimplicial_object C ⥤ cosimplicial_object D :=
whiskering_right _ _ _

/-- Truncated cosimplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def truncated (n : ℕ) := simplex_category.truncated n ⥤ C

variable {C}

namespace truncated

instance {n} {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (cosimplicial_object.truncated C n) :=
by {dsimp [truncated], apply_instance}

instance {n} [has_limits C] : has_limits (cosimplicial_object.truncated C n) := ⟨infer_instance⟩

instance {n} {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (cosimplicial_object.truncated C n) :=
by {dsimp [truncated], apply_instance}

instance {n} [has_colimits C] : has_colimits (cosimplicial_object.truncated C n) := ⟨infer_instance⟩

variable (C)

/-- Functor composition induces a functor on truncated cosimplicial objects. -/
@[simps]
def whiskering {n} (D : Type*) [category D] :
  (C ⥤ D) ⥤ truncated C n ⥤ truncated D n :=
whiskering_right _ _ _

variable {C}

end truncated

section skeleton

/-- The skeleton functor from cosimplicial objects to truncated cosimplicial objects. -/
def sk (n : ℕ) : cosimplicial_object C ⥤ cosimplicial_object.truncated C n :=
(whiskering_left _ _ _).obj simplex_category.truncated.inclusion

end skeleton

variable (C)

/-- The constant cosimplicial object. -/
abbreviation const : C ⥤ cosimplicial_object C := category_theory.functor.const _

/-- Augmented cosimplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def augmented := comma (const C) (𝟭 (cosimplicial_object C))

variable {C}

namespace augmented

/-- Drop the augmentation. -/
@[simps]
def drop : augmented C ⥤ cosimplicial_object C := comma.snd _ _

/-- The point of the augmentation. -/
@[simps]
def point : augmented C ⥤ C := comma.fst _ _

/-- The functor from augmented objects to arrows. -/
@[simps]
def to_arrow : augmented C ⥤ arrow C :=
{ obj := λ X,
  { left := (point.obj X),
    right := (drop.obj X) _[0],
    hom := X.hom.app _ },
  map := λ X Y η,
  { left := (point.map η),
    right := (drop.map η).app _,
    w' := begin
      dsimp,
      rw ← nat_trans.comp_app,
      erw ← η.w,
      refl,
    end } }

variable (C)

/-- Functor composition induces a functor on augmented cosimplicial objects. -/
@[simp]
def whiskering_obj (D : Type*) [category D] (F : C ⥤ D) :
  augmented C ⥤ augmented D :=
{ obj := λ X,
  { left := F.obj (point.obj X),
    right := ((whiskering _ _).obj F).obj (drop.obj X),
    hom := (functor.const_comp _ _ _).inv ≫ whisker_right X.hom F },
  map := λ X Y η,
  { left := F.map η.left,
    right := whisker_right η.right _,
    w' := begin
      ext,
      dsimp,
      rw [category.id_comp, category.id_comp, ← F.map_comp, ← F.map_comp, ← nat_trans.comp_app],
      erw ← η.w,
      refl,
    end } }

/-- Functor composition induces a functor on augmented cosimplicial objects. -/
@[simps]
def whiskering (D : Type u') [category.{v'} D] :
  (C ⥤ D) ⥤ augmented C ⥤ augmented D :=
{ obj := whiskering_obj _ _,
  map := λ X Y η,
  { app := λ A,
    { left := η.app _,
      right := whisker_left _ η,
      w' := begin
        ext n,
        dsimp,
        rw [category.id_comp, category.id_comp, η.naturality],
      end }, }, }

variable {C}

end augmented

open_locale simplicial

/-- Augment a cosimplicial object with an object. -/
@[simps]
def augment (X : cosimplicial_object C) (X₀ : C) (f : X₀ ⟶ X.obj [0])
  (w : ∀ (i : simplex_category) (g₁ g₂ : [0] ⟶ i),
    f ≫ X.map g₁ = f ≫ X.map g₂) : cosimplicial_object.augmented C :=
{ left := X₀,
  right := X,
  hom :=
  { app := λ i, f ≫ X.map (simplex_category.const i 0),
  naturality' := begin
    intros i j g,
    dsimp,
    simpa [← X.map_comp] using w _ _ _,
  end } }

@[simp]
lemma augment_hom_zero (X : cosimplicial_object C) (X₀ : C) (f : X₀ ⟶ X.obj [0]) (w) :
  (X.augment X₀ f w).hom.app [0] = f :=
by { dsimp, rw [simplex_category.hom_zero_zero ([0].const 0), X.map_id, category.comp_id] }

end cosimplicial_object

/-- The anti-equivalence between simplicial objects and cosimplicial objects. -/
@[simps]
def simplicial_cosimplicial_equiv : (simplicial_object C)ᵒᵖ ≌ (cosimplicial_object Cᵒᵖ) :=
functor.left_op_right_op_equiv _ _

variable {C}

/-- Construct an augmented cosimplicial object in the opposite
category from an augmented simplicial object. -/
@[simps]
def simplicial_object.augmented.right_op (X : simplicial_object.augmented C) :
  cosimplicial_object.augmented Cᵒᵖ :=
{ left := opposite.op X.right,
  right := X.left.right_op,
  hom := X.hom.right_op }

/-- Construct an augmented simplicial object from an augmented cosimplicial
object in the opposite category. -/
@[simps]
def cosimplicial_object.augmented.left_op (X : cosimplicial_object.augmented Cᵒᵖ) :
  simplicial_object.augmented C :=
{ left := X.right.left_op,
  right := X.left.unop,
  hom := X.hom.left_op }

/-- Converting an augmented simplicial object to an augmented cosimplicial
object and back is isomorphic to the given object. -/
@[simps]
def simplicial_object.augmented.right_op_left_op_iso (X : simplicial_object.augmented C) :
  X.right_op.left_op ≅ X :=
comma.iso_mk X.left.right_op_left_op_iso (eq_to_iso $ by simp) (by tidy)

/-- Converting an augmented cosimplicial object to an augmented simplicial
object and back is isomorphic to the given object. -/
@[simps]
def cosimplicial_object.augmented.left_op_right_op_iso (X : cosimplicial_object.augmented Cᵒᵖ) :
  X.left_op.right_op ≅ X :=
comma.iso_mk (eq_to_iso $ by simp) X.right.left_op_right_op_iso (by tidy)

variable (C)

/-- A functorial version of `simplicial_object.augmented.right_op`. -/
@[simps]
def simplicial_to_cosimplicial_augmented :
  (simplicial_object.augmented C)ᵒᵖ ⥤ cosimplicial_object.augmented Cᵒᵖ :=
{ obj := λ X, X.unop.right_op,
  map := λ X Y f,
  { left := f.unop.right.op,
    right := f.unop.left.right_op,
    w' := begin
      ext x,
      dsimp,
      simp_rw ← op_comp,
      congr' 1,
      exact (congr_app f.unop.w (op x)).symm,
    end } }

/-- A functorial version of `cosimplicial_object.augmented.left_op`. -/
@[simps]
def cosimplicial_to_simplicial_augmented :
  cosimplicial_object.augmented Cᵒᵖ ⥤ (simplicial_object.augmented C)ᵒᵖ :=
{ obj := λ X, opposite.op X.left_op,
  map := λ X Y f, quiver.hom.op $
  { left := f.right.left_op,
    right := f.left.unop,
    w' := begin
      ext x,
      dsimp,
      simp_rw ← unop_comp,
      congr' 1,
      exact (congr_app f.w x.unop).symm,
    end} }

/-- The contravariant categorical equivalence between augmented simplicial
objects and augmented cosimplicial objects in the opposite category. -/
@[simps]
def simplicial_cosimplicial_augmented_equiv :
  (simplicial_object.augmented C)ᵒᵖ ≌ cosimplicial_object.augmented Cᵒᵖ :=
{ functor := simplicial_to_cosimplicial_augmented _,
  inverse := cosimplicial_to_simplicial_augmented _,
  unit_iso := nat_iso.of_components
    (λ X, X.unop.right_op_left_op_iso.op) begin
      intros X Y f,
      dsimp,
      rw (show f = f.unop.op, by simp),
      simp_rw ← op_comp,
      congr' 1,
      tidy,
    end,
  counit_iso := nat_iso.of_components
    (λ X, X.left_op_right_op_iso) (by tidy) }

end category_theory


<|start_filename|>src/analysis/normed/group/hom_completion.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import analysis.normed.group.hom
import analysis.normed.group.completion
/-!
# Completion of normed group homs

Given two (semi) normed groups `G` and `H` and a normed group hom `f : normed_group_hom G H`,
we build and study a normed group hom
`f.completion  : normed_group_hom (completion G) (completion H)` such that the diagram

```
                   f
     G       ----------->     H

     |                        |
     |                        |
     |                        |
     V                        V

completion G -----------> completion H
            f.completion
```

commutes. The map itself comes from the general theory of completion of uniform spaces, but here
we want a normed group hom, study its operator norm and kernel.

The vertical maps in the above diagrams are also normed group homs constructed in this file.

## Main definitions and results:

* `normed_group_hom.completion`: see the discussion above.
* `normed_group.to_compl : normed_group_hom G (completion G)`: the canonical map from `G` to its
  completion, as a normed group hom
* `normed_group_hom.completion_to_compl`: the above diagram indeed commutes.
* `normed_group_hom.norm_completion`: `∥f.completion∥ = ∥f∥`
* `normed_group_hom.ker_le_ker_completion`: the kernel of `f.completion` contains the image of the
  kernel of `f`.
* `normed_group_hom.ker_completion`: the kernel of `f.completion` is the closure of the image of the
  kernel of `f` under an assumption that `f` is quantitatively surjective onto its image.
* `normed_group_hom.extension` : if `H` is complete, the extension of `f : normed_group_hom G H`
  to a `normed_group_hom (completion G) H`.
-/

noncomputable theory

open set normed_group_hom uniform_space

section completion

variables {G : Type*} [semi_normed_group G]
variables {H : Type*} [semi_normed_group H]
variables {K : Type*} [semi_normed_group K]

/-- The normed group hom induced between completions. -/
def normed_group_hom.completion (f : normed_group_hom G H) :
  normed_group_hom (completion G) (completion H) :=
{ bound' := begin
    use ∥f∥,
    intro y,
    apply completion.induction_on y,
    { exact is_closed_le
            (continuous_norm.comp $ f.to_add_monoid_hom.continuous_completion f.continuous)
            (continuous_const.mul continuous_norm) },
    { intro x,
      change ∥f.to_add_monoid_hom.completion _ ↑x∥ ≤ ∥f∥ * ∥↑x∥,
      rw f.to_add_monoid_hom.completion_coe f.continuous,
      simp only [completion.norm_coe],
      exact f.le_op_norm x }
  end,
  ..f.to_add_monoid_hom.completion f.continuous }

lemma normed_group_hom.completion_def (f : normed_group_hom G H) (x : completion G) :
  f.completion x = completion.map f x := rfl

@[simp]
lemma normed_group_hom.completion_coe_to_fun (f : normed_group_hom G H) :
  (f.completion : completion G → completion H) = completion.map f :=
by { ext x, exact normed_group_hom.completion_def f x }

@[simp]
lemma normed_group_hom.completion_coe (f : normed_group_hom G H) (g : G) : f.completion g = f g :=
completion.map_coe f.uniform_continuous _

/-- Completion of normed group homs as a normed group hom. -/
@[simps] def normed_group_hom_completion_hom :
  normed_group_hom G H →+ normed_group_hom (completion G) (completion H) :=
{ to_fun := normed_group_hom.completion,
  map_zero' := begin
    apply to_add_monoid_hom_injective,
    exact add_monoid_hom.completion_zero
  end,
  map_add' := λ f g, begin
    apply to_add_monoid_hom_injective,
    exact f.to_add_monoid_hom.completion_add g.to_add_monoid_hom f.continuous g.continuous,
  end }

@[simp]
lemma normed_group_hom.completion_id :
  (normed_group_hom.id G).completion = normed_group_hom.id (completion G) :=
begin
  ext x,
  rw [normed_group_hom.completion_def, normed_group_hom.coe_id, completion.map_id],
  refl
end

lemma normed_group_hom.completion_comp (f : normed_group_hom G H) (g : normed_group_hom H K) :
  g.completion.comp f.completion = (g.comp f).completion :=
begin
  ext x,
  rw [normed_group_hom.coe_comp, normed_group_hom.completion_def,
    normed_group_hom.completion_coe_to_fun, normed_group_hom.completion_coe_to_fun,
    completion.map_comp (normed_group_hom.uniform_continuous _)
    (normed_group_hom.uniform_continuous _)],
  refl
end

lemma normed_group_hom.completion_neg (f : normed_group_hom G H) :
  (-f).completion = -f.completion :=
map_neg (normed_group_hom_completion_hom : normed_group_hom G H →+ _) f

lemma normed_group_hom.completion_add (f g : normed_group_hom G H) :
  (f + g).completion = f.completion + g.completion :=
normed_group_hom_completion_hom.map_add f g

lemma normed_group_hom.completion_sub (f g : normed_group_hom G H) :
  (f - g).completion = f.completion - g.completion :=
map_sub (normed_group_hom_completion_hom : normed_group_hom G H →+ _) f g

@[simp]
lemma normed_group_hom.zero_completion : (0 : normed_group_hom G H).completion = 0 :=
normed_group_hom_completion_hom.map_zero

/-- The map from a normed group to its completion, as a normed group hom. -/
def normed_group.to_compl : normed_group_hom G (completion G) :=
{ to_fun := coe,
  map_add' := completion.to_compl.map_add,
  bound' := ⟨1, by simp [le_refl]⟩ }

open normed_group

lemma normed_group.norm_to_compl (x : G) : ∥to_compl x∥ = ∥x∥ :=
completion.norm_coe x

lemma normed_group.dense_range_to_compl : dense_range (to_compl : G → completion G) :=
completion.dense_inducing_coe.dense

@[simp]
lemma normed_group_hom.completion_to_compl (f : normed_group_hom G H) :
  f.completion.comp to_compl = to_compl.comp f :=
begin
  ext x,
  change f.completion x = _,
  simpa
end

@[simp] lemma normed_group_hom.norm_completion (f : normed_group_hom G H) : ∥f.completion∥ = ∥f∥ :=
begin
  apply f.completion.op_norm_eq_of_bounds (norm_nonneg _),
  { intro x,
    apply completion.induction_on x,
    { apply is_closed_le,
      continuity },
    { intro g,
      simp [f.le_op_norm  g] } },
  { intros N N_nonneg hN,
    apply f.op_norm_le_bound N_nonneg,
    intro x,
    simpa using hN x },
end

lemma normed_group_hom.ker_le_ker_completion (f : normed_group_hom G H) :
  (to_compl.comp $ incl f.ker).range ≤ f.completion.ker  :=
begin
  intros a h,
  replace h : ∃ y : f.ker, to_compl (y : G) = a, by simpa using h,
  rcases h with ⟨⟨g, g_in : g ∈ f.ker⟩, rfl⟩,
  rw f.mem_ker at g_in,
  change f.completion (g : completion G) = 0,
  simp [normed_group_hom.mem_ker, f.completion_coe g, g_in, completion.coe_zero],
end

lemma normed_group_hom.ker_completion {f : normed_group_hom G H} {C : ℝ}
  (h : f.surjective_on_with f.range C) :
  (f.completion.ker : set $ completion G) = closure (to_compl.comp $ incl f.ker).range :=
begin
  rcases h.exists_pos with ⟨C', C'_pos, hC'⟩,
  apply le_antisymm,
  { intros hatg hatg_in,
    rw semi_normed_group.mem_closure_iff,
    intros ε ε_pos,
    have hCf : 0 ≤ C'*∥f∥ := (zero_le_mul_left C'_pos).mpr (norm_nonneg f),
    have ineq : 0 < 1 + C'*∥f∥, by linarith,
    set δ := ε/(1 + C'*∥f∥),
    have δ_pos : δ > 0, from div_pos ε_pos ineq,
    obtain ⟨_, ⟨g : G, rfl⟩, hg : ∥hatg - g∥ < δ⟩ :=
      semi_normed_group.mem_closure_iff.mp (completion.dense_inducing_coe.dense hatg) δ δ_pos,
    obtain ⟨g' : G, hgg' : f g' = f g, hfg : ∥g'∥ ≤ C' * ∥f g∥⟩ :=
      hC' (f g) (mem_range_self g),
    have mem_ker : g - g' ∈ f.ker,
      by rw [f.mem_ker, f.map_sub, sub_eq_zero.mpr hgg'.symm],
    have : ∥f g∥ ≤ ∥f∥*∥hatg - g∥,
    calc
      ∥f g∥ = ∥f.completion g∥ : by rw [f.completion_coe, completion.norm_coe]
        ... = ∥f.completion g - 0∥ : by rw [sub_zero _]
        ... = ∥f.completion g - (f.completion hatg)∥ : by rw [(f.completion.mem_ker _).mp hatg_in]
        ... = ∥f.completion (g - hatg)∥ : by rw [f.completion.map_sub]
        ... ≤ ∥f.completion∥ * ∥(g :completion G) - hatg∥ : f.completion.le_op_norm _
        ... = ∥f∥ * ∥hatg - g∥ : by rw [norm_sub_rev, f.norm_completion],
    have : ∥(g' : completion G)∥ ≤ C'*∥f∥*∥hatg - g∥,
    calc
    ∥(g' : completion G)∥ = ∥g'∥ : completion.norm_coe _
                      ... ≤ C' * ∥f g∥ : hfg
                      ... ≤ C' * ∥f∥ * ∥hatg - g∥ : by { rw mul_assoc,
                                                        exact (mul_le_mul_left C'_pos).mpr this },
    refine ⟨g - g', _, _⟩,
    { norm_cast,
      rw normed_group_hom.comp_range,
      apply add_subgroup.mem_map_of_mem,
      simp only [incl_range, mem_ker] },
    { calc ∥hatg - (g - g')∥ = ∥hatg - g + g'∥ : by abel
      ... ≤ ∥hatg - g∥ + ∥(g' : completion G)∥ : norm_add_le _ _
      ... < δ + C'*∥f∥*∥hatg - g∥ : by linarith
      ... ≤ δ + C'*∥f∥*δ : add_le_add_left (mul_le_mul_of_nonneg_left hg.le hCf) δ
      ... = (1 + C'*∥f∥)*δ : by ring
      ... = ε : mul_div_cancel' _ ineq.ne.symm } },
  { rw ← f.completion.is_closed_ker.closure_eq,
    exact closure_mono f.ker_le_ker_completion }
end

end completion

section extension

variables {G : Type*} [semi_normed_group G]
variables {H : Type*} [semi_normed_group H] [separated_space H] [complete_space H]

/-- If `H` is complete, the extension of `f : normed_group_hom G H` to a
`normed_group_hom (completion G) H`. -/
def normed_group_hom.extension (f : normed_group_hom G H) : normed_group_hom (completion G) H :=
{ bound' := begin
    refine ⟨∥f∥, λ v, completion.induction_on v (is_closed_le _ _) (λ a, _)⟩,
    { exact continuous.comp continuous_norm completion.continuous_extension },
    { exact continuous.mul continuous_const continuous_norm },
    { rw [completion.norm_coe, add_monoid_hom.to_fun_eq_coe, add_monoid_hom.extension_coe],
      exact le_op_norm f a }
  end,
  ..f.to_add_monoid_hom.extension f.continuous }

lemma normed_group_hom.extension_def (f : normed_group_hom G H) (v : G) :
  f.extension v = completion.extension f v := rfl

@[simp] lemma normed_group_hom.extension_coe (f : normed_group_hom G H) (v : G) :
  f.extension v = f v := add_monoid_hom.extension_coe _ f.continuous _

lemma normed_group_hom.extension_coe_to_fun (f : normed_group_hom G H) :
  (f.extension : (completion G) → H) = completion.extension f := rfl

lemma normed_group_hom.extension_unique (f : normed_group_hom G H)
  {g : normed_group_hom (completion G) H} (hg : ∀ v, f v = g v) : f.extension = g :=
begin
  ext v,
  rw [normed_group_hom.extension_coe_to_fun, completion.extension_unique f.uniform_continuous
    g.uniform_continuous (λ a, hg a)]
end

end extension


<|start_filename|>src/algebra/group/basic.lean<|end_filename|>
/-
Copyright (c) 2014 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>
-/

import algebra.group.defs
import data.bracket
import logic.function.basic

/-!
# Basic lemmas about semigroups, monoids, and groups

This file lists various basic lemmas about semigroups, monoids, and groups. Most proofs are
one-liners from the corresponding axioms. For the definitions of semigroups, monoids and groups, see
`algebra/group/defs.lean`.
-/

open function

universe u
variables {α G : Type*}

section associative
variables (f : α → α → α) [is_associative α f] (x y : α)

/--
Composing two associative operations of `f : α → α → α` on the left
is equal to an associative operation on the left.
-/
lemma comp_assoc_left : (f x) ∘ (f y) = (f (f x y)) :=
by { ext z, rw [function.comp_apply, @is_associative.assoc _ f] }

/--
Composing two associative operations of `f : α → α → α` on the right
is equal to an associative operation on the right.
-/
lemma comp_assoc_right : (λ z, f z x) ∘ (λ z, f z y) = (λ z, f z (f y x)) :=
by { ext z, rw [function.comp_apply, @is_associative.assoc _ f] }

end associative

section semigroup

/--
Composing two multiplications on the left by `y` then `x`
is equal to a multiplication on the left by `x * y`.
-/
@[simp, to_additive
"Composing two additions on the left by `y` then `x`
is equal to a addition on the left by `x + y`."]
lemma comp_mul_left [semigroup α] (x y : α) :
  ((*) x) ∘ ((*) y) = ((*) (x * y)) :=
comp_assoc_left _ _ _

/--
Composing two multiplications on the right by `y` and `x`
is equal to a multiplication on the right by `y * x`.
-/
@[simp, to_additive
"Composing two additions on the right by `y` and `x`
is equal to a addition on the right by `y + x`."]
lemma comp_mul_right [semigroup α] (x y : α) :
  (* x) ∘ (* y) = (* (y * x)) :=
comp_assoc_right _ _ _

end semigroup

section mul_one_class
variables {M : Type u} [mul_one_class M]

@[to_additive]
lemma ite_mul_one {P : Prop} [decidable P] {a b : M} :
  ite P (a * b) 1 = ite P a 1 * ite P b 1 :=
by { by_cases h : P; simp [h], }

@[to_additive]
lemma ite_one_mul {P : Prop} [decidable P] {a b : M} :
  ite P 1 (a * b) = ite P 1 a * ite P 1 b :=
by { by_cases h : P; simp [h], }

@[to_additive]
lemma eq_one_iff_eq_one_of_mul_eq_one {a b : M} (h : a * b = 1) : a = 1 ↔ b = 1 :=
by split; { rintro rfl, simpa using h }

@[to_additive]
lemma one_mul_eq_id : ((*) (1 : M)) = id := funext one_mul

@[to_additive]
lemma mul_one_eq_id : (* (1 : M)) = id := funext mul_one

end mul_one_class

section comm_semigroup
variables [comm_semigroup G]

@[no_rsimp, to_additive]
lemma mul_left_comm : ∀ a b c : G, a * (b * c) = b * (a * c) :=
left_comm has_mul.mul mul_comm mul_assoc

@[to_additive]
lemma mul_right_comm : ∀ a b c : G, a * b * c = a * c * b :=
right_comm has_mul.mul mul_comm mul_assoc

@[to_additive]
theorem mul_mul_mul_comm (a b c d : G) : (a * b) * (c * d) = (a * c) * (b * d) :=
by simp only [mul_left_comm, mul_assoc]

@[to_additive]
lemma mul_rotate (a b c : G) : a * b * c = b * c * a :=
by simp only [mul_left_comm, mul_comm]

@[to_additive]
lemma mul_rotate' (a b c : G) : a * (b * c) = b * (c * a) :=
by simp only [mul_left_comm, mul_comm]

end comm_semigroup

local attribute [simp] mul_assoc sub_eq_add_neg

section add_monoid
variables {M : Type u} [add_monoid M] {a b c : M}

@[simp] lemma bit0_zero : bit0 (0 : M) = 0 := add_zero _
@[simp] lemma bit1_zero [has_one M] : bit1 (0 : M) = 1 :=
by rw [bit1, bit0_zero, zero_add]

end add_monoid

section comm_monoid
variables {M : Type u} [comm_monoid M] {x y z : M}

@[to_additive] lemma inv_unique (hy : x * y = 1) (hz : x * z = 1) : y = z :=
left_inv_eq_right_inv (trans (mul_comm _ _) hy) hz

end comm_monoid

section left_cancel_monoid

variables {M : Type u} [left_cancel_monoid M] {a b : M}

@[simp, to_additive] lemma mul_right_eq_self : a * b = a ↔ b = 1 :=
calc a * b = a ↔ a * b = a * 1 : by rw mul_one
           ... ↔ b = 1         : mul_left_cancel_iff

@[simp, to_additive] lemma self_eq_mul_right : a = a * b ↔ b = 1 :=
eq_comm.trans mul_right_eq_self

end left_cancel_monoid

section right_cancel_monoid

variables {M : Type u} [right_cancel_monoid M] {a b : M}

@[simp, to_additive] lemma mul_left_eq_self : a * b = b ↔ a = 1 :=
calc a * b = b ↔ a * b = 1 * b : by rw one_mul
           ... ↔ a = 1         : mul_right_cancel_iff

@[simp, to_additive] lemma self_eq_mul_left : b = a * b ↔ a = 1 :=
eq_comm.trans mul_left_eq_self

end right_cancel_monoid

section has_involutive_inv
variables [has_involutive_inv G] {a b : G}

@[simp, to_additive]
lemma inv_involutive : function.involutive (has_inv.inv : G → G) := inv_inv

@[simp, to_additive]
lemma inv_surjective : function.surjective (has_inv.inv : G → G) :=
inv_involutive.surjective

@[to_additive]
lemma inv_injective : function.injective (has_inv.inv : G → G) :=
inv_involutive.injective

@[simp, to_additive] theorem inv_inj {a b : G} : a⁻¹ = b⁻¹ ↔ a = b := inv_injective.eq_iff

@[to_additive]
lemma eq_inv_of_eq_inv (h : a = b⁻¹) : b = a⁻¹ :=
by simp [h]

@[to_additive]
theorem eq_inv_iff_eq_inv : a = b⁻¹ ↔ b = a⁻¹ :=
⟨eq_inv_of_eq_inv, eq_inv_of_eq_inv⟩

@[to_additive]
theorem inv_eq_iff_inv_eq  : a⁻¹ = b ↔ b⁻¹ = a :=
eq_comm.trans $ eq_inv_iff_eq_inv.trans eq_comm

variables (G)

@[simp, to_additive] lemma inv_comp_inv : has_inv.inv ∘ has_inv.inv = @id G :=
inv_involutive.comp_self

@[to_additive] lemma left_inverse_inv : left_inverse (λ a : G, a⁻¹) (λ a, a⁻¹) := inv_inv
@[to_additive] lemma right_inverse_inv : left_inverse (λ a : G, a⁻¹) (λ a, a⁻¹) := inv_inv

end has_involutive_inv

section div_inv_monoid
variables [div_inv_monoid G] {a b c : G}

@[to_additive, field_simps] -- The attributes are out of order on purpose
lemma inv_eq_one_div (x : G) :
  x⁻¹ = 1 / x :=
by rw [div_eq_mul_inv, one_mul]

@[to_additive]
lemma mul_one_div (x y : G) :
  x * (1 / y) = x / y :=
by rw [div_eq_mul_inv, one_mul, div_eq_mul_inv]

@[to_additive]
lemma mul_div_assoc (a b c : G) : a * b / c = a * (b / c) :=
by rw [div_eq_mul_inv, div_eq_mul_inv, mul_assoc _ _ _]

@[to_additive, field_simps] -- The attributes are out of order on purpose
lemma mul_div_assoc' (a b c : G) : a * (b / c) = (a * b) / c :=
(mul_div_assoc _ _ _).symm

@[simp, to_additive] lemma one_div (a : G) : 1 / a = a⁻¹ :=
(inv_eq_one_div a).symm

@[to_additive] lemma mul_div (a b c : G) : a * (b / c) = a * b / c :=
by simp only [mul_assoc, div_eq_mul_inv]

@[to_additive] lemma div_eq_mul_one_div (a b : G) : a / b = a * (1 / b) :=
by rw [div_eq_mul_inv, one_div]

end div_inv_monoid

section division_monoid
variables [division_monoid α] {a b c : α}

local attribute [simp] mul_assoc div_eq_mul_inv

@[to_additive] lemma inv_eq_of_mul_eq_one_left (h : a * b = 1) : b⁻¹ = a :=
by rw [←inv_eq_of_mul_eq_one_right h, inv_inv]

@[to_additive] lemma eq_inv_of_mul_eq_one_left (h : a * b = 1) : a = b⁻¹ :=
(inv_eq_of_mul_eq_one_left h).symm

@[to_additive] lemma eq_inv_of_mul_eq_one_right (h : a * b = 1) : b = a⁻¹ :=
(inv_eq_of_mul_eq_one_right h).symm

@[to_additive] lemma eq_one_div_of_mul_eq_one_left (h : b * a = 1) : b = 1 / a :=
by rw [eq_inv_of_mul_eq_one_left h,  one_div]

@[to_additive] lemma eq_one_div_of_mul_eq_one_right (h : a * b = 1) : b = 1 / a :=
by rw [eq_inv_of_mul_eq_one_right h, one_div]

@[to_additive] lemma eq_of_div_eq_one (h : a / b = 1) : a = b :=
inv_injective $ inv_eq_of_mul_eq_one_right $ by rwa ←div_eq_mul_inv

@[to_additive] lemma div_ne_one_of_ne : a ≠ b → a / b ≠ 1 := mt eq_of_div_eq_one

variables (a b c)

@[to_additive] lemma one_div_mul_one_div_rev : (1 / a) * (1 / b) =  1 / (b * a) := by simp
@[to_additive] lemma inv_div_left : a⁻¹ / b = (b * a)⁻¹ := by simp
@[simp, to_additive] lemma inv_div : (a / b)⁻¹ = b / a := by simp
@[simp, to_additive] lemma one_div_div : 1 / (a / b) = b / a := by simp
@[simp, to_additive] lemma inv_one : (1 : α)⁻¹ = 1 :=
by simpa only [one_div, inv_inv] using (inv_div (1 : α) 1).symm
@[simp, to_additive] lemma div_one : a / 1 = a := by simp
@[to_additive] lemma one_div_one : (1 : α) / 1 = 1 := div_one _
@[to_additive] lemma one_div_one_div : 1 / (1 / a) = a := by simp

variables {a b c}

@[simp, to_additive] lemma inv_eq_one : a⁻¹ = 1 ↔ a = 1 := inv_injective.eq_iff' inv_one
@[simp, to_additive] lemma one_eq_inv : 1 = a⁻¹ ↔ a = 1 := eq_comm.trans inv_eq_one
@[to_additive] lemma inv_ne_one : a⁻¹ ≠ 1 ↔ a ≠ 1 := inv_eq_one.not

@[to_additive] lemma eq_of_one_div_eq_one_div (h : 1 / a = 1 / b) : a = b :=
by rw [←one_div_one_div a, h, one_div_one_div]

variables (a b c)

 -- The attributes are out of order on purpose
@[to_additive, field_simps] lemma div_div_eq_mul_div : a / (b / c) = a * c / b := by simp
@[simp, to_additive] lemma div_inv_eq_mul : a / b⁻¹ = a * b := by simp
@[to_additive] lemma div_mul_eq_div_div_swap : a / (b * c) = a / c / b :=
by simp only [mul_assoc, mul_inv_rev, div_eq_mul_inv]

end division_monoid

lemma bit0_neg [subtraction_monoid α] (a : α) : bit0 (-a) = -bit0 a := (neg_add_rev _ _).symm

section division_comm_monoid
variables [division_comm_monoid α] (a b c d : α)

local attribute [simp] mul_assoc mul_comm mul_left_comm div_eq_mul_inv

@[to_additive neg_add] lemma mul_inv : (a * b)⁻¹ = a⁻¹ * b⁻¹ := by simp
@[to_additive] lemma inv_div' : (a / b)⁻¹ = a⁻¹ / b⁻¹ := by simp
@[to_additive] lemma div_eq_inv_mul : a / b = b⁻¹ * a := by simp
@[to_additive] lemma inv_mul_eq_div : a⁻¹ * b = b / a := by simp
@[to_additive] lemma inv_mul' : (a * b)⁻¹ = a⁻¹ / b := by simp
@[simp, to_additive] lemma inv_div_inv : (a⁻¹ / b⁻¹) = b / a := by simp
@[to_additive] lemma inv_inv_div_inv : (a⁻¹ / b⁻¹)⁻¹ = a / b := by simp
@[to_additive] lemma one_div_mul_one_div : (1 / a) * (1 / b) =  1 / (a * b) := by simp

@[to_additive] lemma div_right_comm : a / b / c = a / c / b := by simp
@[to_additive, field_simps] lemma div_div : a / b / c = a / (b * c) := by simp
@[to_additive] lemma div_mul : a / b * c = a / (b / c) := by simp
@[to_additive] lemma mul_div_left_comm : a * (b / c) = b * (a / c) := by simp
@[to_additive] lemma mul_div_right_comm : a * b / c = a / c * b := by simp
@[to_additive] lemma div_mul_eq_div_div : a / (b * c) = a / b / c := by simp
@[to_additive, field_simps] lemma div_mul_eq_mul_div : a / b * c = a * c / b := by simp
@[to_additive] lemma mul_comm_div : a / b * c = a * (c / b) := by simp
@[to_additive] lemma div_mul_comm : a / b * c = c / b * a := by simp
@[to_additive] lemma div_mul_eq_div_mul_one_div : a / (b * c) = (a / b) * (1 / c) := by simp

@[to_additive] lemma div_div_div_eq : a / b / (c / d) = a * d / (b * c) := by simp
@[to_additive] lemma div_div_div_comm : a / b / (c / d) = a / c / (b / d) := by simp
@[to_additive] lemma div_mul_div_comm : a / b * (c / d) = a * c / (b * d) := by simp
@[to_additive] lemma mul_div_mul_comm : a * b / (c * d) = a / c * (b / d) := by simp

end division_comm_monoid

section group
variables [group G] {a b c d : G}

@[simp, to_additive] theorem div_eq_inv_self : a / b = b⁻¹ ↔ a = 1 :=
by rw [div_eq_mul_inv, mul_left_eq_self]

@[to_additive]
theorem mul_left_surjective (a : G) : function.surjective ((*) a) :=
λ x, ⟨a⁻¹ * x, mul_inv_cancel_left a x⟩

@[to_additive]
theorem mul_right_surjective (a : G) : function.surjective (λ x, x * a) :=
λ x, ⟨x * a⁻¹, inv_mul_cancel_right x a⟩

@[to_additive]
lemma eq_mul_inv_of_mul_eq (h : a * c = b) : a = b * c⁻¹ :=
by simp [h.symm]

@[to_additive]
lemma eq_inv_mul_of_mul_eq (h : b * a = c) : a = b⁻¹ * c :=
by simp [h.symm]

@[to_additive]
lemma inv_mul_eq_of_eq_mul (h : b = a * c) : a⁻¹ * b = c :=
by simp [h]

@[to_additive]
lemma mul_inv_eq_of_eq_mul (h : a = c * b) : a * b⁻¹ = c :=
by simp [h]

@[to_additive]
lemma eq_mul_of_mul_inv_eq (h : a * c⁻¹ = b) : a = b * c :=
by simp [h.symm]

@[to_additive]
lemma eq_mul_of_inv_mul_eq (h : b⁻¹ * a = c) : a = b * c :=
by simp [h.symm, mul_inv_cancel_left]

@[to_additive]
lemma mul_eq_of_eq_inv_mul (h : b = a⁻¹ * c) : a * b = c :=
by rw [h, mul_inv_cancel_left]

@[to_additive]
lemma mul_eq_of_eq_mul_inv (h : a = c * b⁻¹) : a * b = c :=
by simp [h]

@[to_additive]
theorem mul_eq_one_iff_eq_inv : a * b = 1 ↔ a = b⁻¹ :=
⟨eq_inv_of_mul_eq_one_left, λ h, by rw [h, mul_left_inv]⟩

@[to_additive]
theorem mul_eq_one_iff_inv_eq : a * b = 1 ↔ a⁻¹ = b :=
by rw [mul_eq_one_iff_eq_inv, eq_inv_iff_eq_inv, eq_comm]

@[to_additive]
theorem eq_inv_iff_mul_eq_one : a = b⁻¹ ↔ a * b = 1 :=
mul_eq_one_iff_eq_inv.symm

@[to_additive]
theorem inv_eq_iff_mul_eq_one : a⁻¹ = b ↔ a * b = 1 :=
mul_eq_one_iff_inv_eq.symm

@[to_additive]
theorem eq_mul_inv_iff_mul_eq : a = b * c⁻¹ ↔ a * c = b :=
⟨λ h, by rw [h, inv_mul_cancel_right], λ h, by rw [← h, mul_inv_cancel_right]⟩

@[to_additive]
theorem eq_inv_mul_iff_mul_eq : a = b⁻¹ * c ↔ b * a = c :=
⟨λ h, by rw [h, mul_inv_cancel_left], λ h, by rw [← h, inv_mul_cancel_left]⟩

@[to_additive]
theorem inv_mul_eq_iff_eq_mul : a⁻¹ * b = c ↔ b = a * c :=
⟨λ h, by rw [← h, mul_inv_cancel_left], λ h, by rw [h, inv_mul_cancel_left]⟩

@[to_additive]
theorem mul_inv_eq_iff_eq_mul : a * b⁻¹ = c ↔ a = c * b :=
⟨λ h, by rw [← h, inv_mul_cancel_right], λ h, by rw [h, mul_inv_cancel_right]⟩

@[to_additive]
theorem mul_inv_eq_one : a * b⁻¹ = 1 ↔ a = b :=
by rw [mul_eq_one_iff_eq_inv, inv_inv]

@[to_additive]
theorem inv_mul_eq_one : a⁻¹ * b = 1 ↔ a = b :=
by rw [mul_eq_one_iff_eq_inv, inv_inj]

@[to_additive]
lemma div_left_injective : function.injective (λ a, a / b) :=
by simpa only [div_eq_mul_inv] using λ a a' h, mul_left_injective (b⁻¹) h

@[to_additive]
lemma div_right_injective : function.injective (λ a, b / a) :=
by simpa only [div_eq_mul_inv] using λ a a' h, inv_injective (mul_right_injective b h)

@[simp, to_additive sub_add_cancel]
lemma div_mul_cancel' (a b : G) : a / b * b = a :=
by rw [div_eq_mul_inv, inv_mul_cancel_right a b]

@[simp, to_additive sub_self]
lemma div_self' (a : G) : a / a = 1 :=
by rw [div_eq_mul_inv, mul_right_inv a]

@[simp, to_additive add_sub_cancel]
lemma mul_div_cancel'' (a b : G) : a * b / b = a :=
by rw [div_eq_mul_inv, mul_inv_cancel_right a b]

@[simp, to_additive]
lemma mul_div_mul_right_eq_div (a b c : G) : (a * c) / (b * c) = a / b :=
by rw [div_mul_eq_div_div_swap]; simp only [mul_left_inj, eq_self_iff_true, mul_div_cancel'']

@[to_additive eq_sub_of_add_eq]
lemma eq_div_of_mul_eq' (h : a * c = b) : a = b / c :=
by simp [← h]

@[to_additive sub_eq_of_eq_add]
lemma div_eq_of_eq_mul'' (h : a = c * b) : a / b = c :=
by simp [h]

@[to_additive]
lemma eq_mul_of_div_eq (h : a / c = b) : a = b * c :=
by simp [← h]

@[to_additive]
lemma mul_eq_of_eq_div (h : a = c / b) : a * b = c :=
by simp [h]

@[simp, to_additive]
lemma div_right_inj : a / b = a / c ↔ b = c :=
div_right_injective.eq_iff

@[simp, to_additive]
lemma div_left_inj : b / a = c / a ↔ b = c :=
by { rw [div_eq_mul_inv, div_eq_mul_inv], exact mul_left_inj _ }

@[simp, to_additive sub_add_sub_cancel]
lemma div_mul_div_cancel' (a b c : G) : (a / b) * (b / c) = a / c :=
by rw [← mul_div_assoc, div_mul_cancel']

@[simp, to_additive sub_sub_sub_cancel_right]
lemma div_div_div_cancel_right' (a b c : G) : (a / c) / (b / c) = a / b :=
by rw [← inv_div c b, div_inv_eq_mul, div_mul_div_cancel']

@[to_additive]
theorem div_eq_one : a / b = 1 ↔ a = b :=
⟨eq_of_div_eq_one, λ h, by rw [h, div_self']⟩

alias div_eq_one ↔ _ div_eq_one_of_eq
alias sub_eq_zero ↔ _ sub_eq_zero_of_eq

@[to_additive]
theorem div_ne_one : a / b ≠ 1 ↔ a ≠ b :=
not_congr div_eq_one

@[simp, to_additive]
theorem div_eq_self : a / b = a ↔ b = 1 :=
by rw [div_eq_mul_inv, mul_right_eq_self, inv_eq_one]

@[to_additive eq_sub_iff_add_eq]
theorem eq_div_iff_mul_eq' : a = b / c ↔ a * c = b :=
by rw [div_eq_mul_inv, eq_mul_inv_iff_mul_eq]

@[to_additive]
theorem div_eq_iff_eq_mul : a / b = c ↔ a = c * b :=
by rw [div_eq_mul_inv, mul_inv_eq_iff_eq_mul]

@[to_additive]
theorem eq_iff_eq_of_div_eq_div (H : a / b = c / d) : a = b ↔ c = d :=
by rw [← div_eq_one, H, div_eq_one]

@[to_additive]
theorem left_inverse_div_mul_left (c : G) : function.left_inverse (λ x, x / c) (λ x, x * c) :=
assume x, mul_div_cancel'' x c

@[to_additive]
theorem left_inverse_mul_left_div (c : G) : function.left_inverse (λ x, x * c) (λ x, x / c) :=
assume x, div_mul_cancel' x c

@[to_additive]
theorem left_inverse_mul_right_inv_mul (c : G) :
  function.left_inverse (λ x, c * x) (λ x, c⁻¹ * x) :=
assume x, mul_inv_cancel_left c x

@[to_additive]
theorem left_inverse_inv_mul_mul_right (c : G) :
  function.left_inverse (λ x, c⁻¹ * x) (λ x, c * x) :=
assume x, inv_mul_cancel_left c x

@[to_additive]
lemma exists_npow_eq_one_of_zpow_eq_one {n : ℤ} (hn : n ≠ 0) {x : G} (h : x ^ n = 1) :
  ∃ n : ℕ, 0 < n ∧ x ^ n = 1 :=
begin
  cases n with n n,
  { rw zpow_of_nat at h,
    refine ⟨n, nat.pos_of_ne_zero (λ n0, hn _), h⟩, rw n0, refl },
  { rw [zpow_neg_succ_of_nat, inv_eq_one] at h,
    refine ⟨n + 1, n.succ_pos, h⟩ }
end

end group

section comm_group
variables [comm_group G] {a b c d : G}

local attribute [simp] mul_assoc mul_comm mul_left_comm div_eq_mul_inv

@[to_additive]
lemma div_eq_of_eq_mul' {a b c : G} (h : a = b * c) : a / b = c :=
by rw [h, div_eq_mul_inv, mul_comm, inv_mul_cancel_left]

@[simp, to_additive]
lemma mul_div_mul_left_eq_div (a b c : G) : (c * a) / (c * b) = a / b :=
by simp

@[to_additive eq_sub_of_add_eq']
lemma eq_div_of_mul_eq'' (h : c * a = b) : a = b / c :=
by simp [h.symm]

@[to_additive]
lemma eq_mul_of_div_eq' (h : a / b = c) : a = b * c :=
by simp [h.symm]

@[to_additive]
lemma mul_eq_of_eq_div' (h : b = c / a) : a * b = c :=
begin simp [h], rw [mul_comm c, mul_inv_cancel_left] end

@[to_additive sub_sub_self]
lemma div_div_self' (a b : G) : a / (a / b) = b :=
by simpa using mul_inv_cancel_left a b

@[to_additive]
lemma div_eq_div_mul_div (a b c : G) : a / b = c / b * (a / c) := by simp [mul_left_comm c]

@[simp, to_additive]
lemma div_div_cancel (a b : G) : a / (a / b) = b := div_div_self' a b

@[simp, to_additive]
lemma div_div_cancel_left (a b : G) : a / b / a = b⁻¹ := by simp

@[to_additive eq_sub_iff_add_eq']
lemma eq_div_iff_mul_eq'' : a = b / c ↔ c * a = b :=
by rw [eq_div_iff_mul_eq', mul_comm]

@[to_additive]
lemma div_eq_iff_eq_mul' : a / b = c ↔ a = b * c :=
by rw [div_eq_iff_eq_mul, mul_comm]

@[simp, to_additive add_sub_cancel']
lemma mul_div_cancel''' (a b : G) : a * b / a = b := by rw [div_eq_inv_mul, inv_mul_cancel_left]

@[simp, to_additive]
lemma mul_div_cancel'_right (a b : G) : a * (b / a) = b :=
by rw [← mul_div_assoc, mul_div_cancel''']

@[simp, to_additive sub_add_cancel']
lemma div_mul_cancel'' (a b : G) : a / (a * b) = b⁻¹ :=
by rw [← inv_div, mul_div_cancel''']

-- This lemma is in the `simp` set under the name `mul_inv_cancel_comm_assoc`,
-- along with the additive version `add_neg_cancel_comm_assoc`,
-- defined  in `algebra/group/commute`
@[to_additive]
lemma mul_mul_inv_cancel'_right (a b : G) : a * (b * a⁻¹) = b :=
by rw [← div_eq_mul_inv, mul_div_cancel'_right a b]

@[simp, to_additive]
lemma mul_mul_div_cancel (a b c : G) : (a * c) * (b / c) = a * b :=
by rw [mul_assoc, mul_div_cancel'_right]

@[simp, to_additive]
lemma div_mul_mul_cancel (a b c : G) : (a / c) * (b * c) = a * b :=
by rw [mul_left_comm, div_mul_cancel', mul_comm]

@[simp, to_additive sub_add_sub_cancel']
lemma div_mul_div_cancel'' (a b c : G) : (a / b) * (c / a) = c / b :=
by rw mul_comm; apply div_mul_div_cancel'

@[simp, to_additive]
lemma mul_div_div_cancel (a b c : G) : (a * b) / (a / c) = b * c :=
by rw [← div_mul, mul_div_cancel''']

@[simp, to_additive]
lemma div_div_div_cancel_left (a b c : G) : (c / a) / (c / b) = b / a :=
by rw [← inv_div b c, div_inv_eq_mul, mul_comm, div_mul_div_cancel']

@[to_additive] lemma div_eq_div_iff_mul_eq_mul : a / b = c / d ↔ a * d = c * b :=
begin
  rw [div_eq_iff_eq_mul, div_mul_eq_mul_div, eq_comm, div_eq_iff_eq_mul'],
  simp only [mul_comm, eq_comm]
end

@[to_additive] lemma div_eq_div_iff_div_eq_div : a / b = c / d ↔ a / c = b / d :=
by rw [div_eq_iff_eq_mul, div_mul_eq_mul_div, div_eq_iff_eq_mul', mul_div_assoc]

end comm_group

section commutator

/-- The commutator of two elements `g₁` and `g₂`. -/
instance commutator_element {G : Type*} [group G] : has_bracket G G :=
⟨λ g₁ g₂, g₁ * g₂ * g₁⁻¹ * g₂⁻¹⟩

lemma commutator_element_def  {G : Type*} [group G] (g₁ g₂ : G) :
  ⁅g₁, g₂⁆ = g₁ * g₂ * g₁⁻¹ * g₂⁻¹ := rfl

end commutator


<|start_filename|>src/linear_algebra/matrix/invariant_basis_number.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import linear_algebra.matrix.to_lin
import linear_algebra.invariant_basis_number

/-!
# Invertible matrices over a ring with invariant basis number are square.
-/

variables {n m : Type*} [fintype n] [decidable_eq n] [fintype m] [decidable_eq m]
variables {R : Type*} [semiring R] [invariant_basis_number R]

open_locale matrix

lemma matrix.square_of_invertible
  (M : matrix n m R) (N : matrix m n R) (h : M ⬝ N = 1) (h' : N ⬝ M = 1) :
  fintype.card n = fintype.card m :=
card_eq_of_lequiv R (matrix.to_linear_equiv_right'_of_inv h' h)


<|start_filename|>src/topology/instances/matrix.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import linear_algebra.determinant
import topology.algebra.infinite_sum
import topology.algebra.ring
import topology.algebra.star

/-!
# Topological properties of matrices

This file is a place to collect topological results about matrices.

## Main definitions:

* `matrix.topological_ring`: square matrices form a topological ring

## Main results

* Continuity:
  * `continuous.matrix_det`: the determinant is continuous over a topological ring.
  * `continuous.matrix_adjugate`: the adjugate is continuous over a topological ring.
* Infinite sums
  * `matrix.transpose_tsum`: transpose commutes with infinite sums
  * `matrix.diagonal_tsum`: diagonal commutes with infinite sums
  * `matrix.block_diagonal_tsum`: block diagonal commutes with infinite sums
  * `matrix.block_diagonal'_tsum`: non-uniform block diagonal commutes with infinite sums
-/

open matrix
open_locale matrix

variables {X α l m n p S R : Type*} {m' n' : l → Type*}

instance [topological_space R] : topological_space (matrix m n R) := Pi.topological_space

instance [topological_space R] [t2_space R] : t2_space (matrix m n R) := Pi.t2_space

/-! ### Lemmas about continuity of operations -/
section continuity
variables [topological_space X] [topological_space R]

instance [has_scalar α R] [has_continuous_const_smul α R] :
  has_continuous_const_smul α (matrix m n R) :=
pi.has_continuous_const_smul

instance [topological_space α] [has_scalar α R] [has_continuous_smul α R] :
  has_continuous_smul α (matrix m n R) :=
pi.has_continuous_smul

instance [has_add R] [has_continuous_add R] : has_continuous_add (matrix m n R) :=
pi.has_continuous_add

instance [has_neg R] [has_continuous_neg R] : has_continuous_neg (matrix m n R) :=
pi.has_continuous_neg

instance [add_group R] [topological_add_group R] : topological_add_group (matrix m n R) :=
pi.topological_add_group

/-- To show a function into matrices is continuous it suffices to show the coefficients of the
resulting matrix are continuous -/
@[continuity]
lemma continuous_matrix [topological_space α] {f : α → matrix m n R}
  (h : ∀ i j, continuous (λ a, f a i j)) : continuous f :=
continuous_pi $ λ _, continuous_pi $ λ j, h _ _

lemma continuous.matrix_elem {A : X → matrix m n R} (hA : continuous A) (i : m) (j : n) :
  continuous (λ x, A x i j) :=
(continuous_apply_apply i j).comp hA

@[continuity]
lemma continuous.matrix_map [topological_space S] {A : X → matrix m n S} {f : S → R}
   (hA : continuous A) (hf : continuous f) :
  continuous (λ x, (A x).map f) :=
continuous_matrix $ λ i j, hf.comp $ hA.matrix_elem _ _

@[continuity]
lemma continuous.matrix_transpose {A : X → matrix m n R} (hA : continuous A) :
  continuous (λ x, (A x)ᵀ) :=
continuous_matrix $ λ i j, hA.matrix_elem j i

lemma continuous.matrix_conj_transpose [has_star R] [has_continuous_star R] {A : X → matrix m n R}
  (hA : continuous A) : continuous (λ x, (A x)ᴴ) :=
hA.matrix_transpose.matrix_map continuous_star

instance [has_star R] [has_continuous_star R] : has_continuous_star (matrix m m R) :=
⟨continuous_id.matrix_conj_transpose⟩

@[continuity]
lemma continuous.matrix_col {A : X → n → R} (hA : continuous A) : continuous (λ x, col (A x)) :=
continuous_matrix $ λ i j, (continuous_apply _).comp hA

@[continuity]
lemma continuous.matrix_row {A : X → n → R} (hA : continuous A) : continuous (λ x, row (A x)) :=
continuous_matrix $ λ i j, (continuous_apply _).comp hA

@[continuity]
lemma continuous.matrix_diagonal [has_zero R] [decidable_eq n] {A : X → n → R} (hA : continuous A) :
  continuous (λ x, diagonal (A x)) :=
continuous_matrix $ λ i j, ((continuous_apply i).comp hA).if_const _ continuous_zero

@[continuity]
lemma continuous.matrix_dot_product [fintype n] [has_mul R] [add_comm_monoid R]
  [has_continuous_add R] [has_continuous_mul R]
  {A : X → n → R} {B : X → n → R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, dot_product (A x) (B x)) :=
continuous_finset_sum _ $ λ i _, ((continuous_apply i).comp hA).mul ((continuous_apply i).comp hB)

/-- For square matrices the usual `continuous_mul` can be used. -/
@[continuity]
lemma continuous.matrix_mul [fintype n] [has_mul R] [add_comm_monoid R] [has_continuous_add R]
  [has_continuous_mul R]
  {A : X → matrix m n R} {B : X → matrix n p R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, (A x).mul (B x)) :=
continuous_matrix $ λ i j, continuous_finset_sum _ $ λ k _,
  (hA.matrix_elem _ _).mul (hB.matrix_elem _ _)

instance [fintype n] [has_mul R] [add_comm_monoid R] [has_continuous_add R]
  [has_continuous_mul R] : has_continuous_mul (matrix n n R) :=
⟨continuous_fst.matrix_mul continuous_snd⟩

instance [fintype n] [non_unital_non_assoc_semiring R] [topological_semiring R] :
  topological_semiring (matrix n n R) :=
{}

instance [fintype n] [non_unital_non_assoc_ring R] [topological_ring R] :
  topological_ring (matrix n n R) :=
{}

@[continuity]
lemma continuous.matrix_vec_mul_vec [has_mul R] [has_continuous_mul R]
  {A : X → m → R} {B : X → n → R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, vec_mul_vec (A x) (B x)) :=
continuous_matrix $ λ i j, ((continuous_apply _).comp hA).mul ((continuous_apply _).comp hB)

@[continuity]
lemma continuous.matrix_mul_vec [non_unital_non_assoc_semiring R] [has_continuous_add R]
  [has_continuous_mul R] [fintype n]
  {A : X → matrix m n R} {B : X → n → R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, (A x).mul_vec (B x)) :=
continuous_pi $ λ i, ((continuous_apply i).comp hA).matrix_dot_product hB

@[continuity]
lemma continuous.matrix_vec_mul [non_unital_non_assoc_semiring R] [has_continuous_add R]
  [has_continuous_mul R] [fintype m]
  {A : X → m → R} {B : X → matrix m n R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, vec_mul (A x) (B x)) :=
continuous_pi $ λ i, hA.matrix_dot_product $ continuous_pi $ λ j, hB.matrix_elem _ _

@[continuity]
lemma continuous.matrix_minor {A : X → matrix l n R} (hA : continuous A) (e₁ : m → l) (e₂ : p → n) :
  continuous (λ x, (A x).minor e₁ e₂) :=
continuous_matrix $ λ i j, hA.matrix_elem _ _

@[continuity]
lemma continuous.matrix_reindex {A : X → matrix l n R}
  (hA : continuous A) (e₁ : l ≃ m) (e₂ : n ≃ p) :
  continuous (λ x, reindex e₁ e₂ (A x)) :=
hA.matrix_minor _ _

@[continuity]
lemma continuous.matrix_diag {A : X → matrix n n R} (hA : continuous A) :
  continuous (λ x, matrix.diag (A x)) :=
continuous_pi $ λ _, hA.matrix_elem _ _

-- note this doesn't elaborate well from the above
lemma continuous_matrix_diag : continuous (matrix.diag : matrix n n R → n → R) :=
show continuous (λ x : matrix n n R, matrix.diag x), from continuous_id.matrix_diag

@[continuity]
lemma continuous.matrix_trace [fintype n] [add_comm_monoid R] [has_continuous_add R]
  {A : X → matrix n n R} (hA : continuous A) :
  continuous (λ x, trace (A x)) :=
continuous_finset_sum _ $ λ i hi, hA.matrix_elem _ _

@[continuity]
lemma continuous.matrix_det [fintype n] [decidable_eq n] [comm_ring R] [topological_ring R]
  {A : X → matrix n n R} (hA : continuous A) :
  continuous (λ x, (A x).det) :=
begin
  simp_rw matrix.det_apply,
  refine continuous_finset_sum _ (λ l _, continuous.const_smul _ _),
  refine continuous_finset_prod _ (λ l _, hA.matrix_elem _ _),
end

@[continuity]
lemma continuous.matrix_update_column [decidable_eq n] (i : n)
  {A : X → matrix m n R} {B : X → m → R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, (A x).update_column i (B x)) :=
continuous_matrix $ λ j k, (continuous_apply k).comp $
  ((continuous_apply _).comp hA).update i ((continuous_apply _).comp hB)

@[continuity]
lemma continuous.matrix_update_row [decidable_eq m] (i : m)
  {A : X → matrix m n R} {B : X → n → R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, (A x).update_row i (B x)) :=
hA.update i hB

@[continuity]
lemma continuous.matrix_cramer [fintype n] [decidable_eq n] [comm_ring R] [topological_ring R]
  {A : X → matrix n n R} {B : X → n → R} (hA : continuous A) (hB : continuous B) :
  continuous (λ x, (A x).cramer (B x)) :=
continuous_pi $ λ i, (hA.matrix_update_column _ hB).matrix_det

@[continuity]
lemma continuous.matrix_adjugate [fintype n] [decidable_eq n] [comm_ring R] [topological_ring R]
  {A : X → matrix n n R} (hA : continuous A) :
  continuous (λ x, (A x).adjugate) :=
continuous_matrix $ λ j k, (hA.matrix_transpose.matrix_update_column k continuous_const).matrix_det

/-- When `ring.inverse` is continuous at the determinant (such as in a `normed_ring`, or a
`topological_field`), so is `matrix.has_inv`. -/
lemma continuous_at_matrix_inv [fintype n] [decidable_eq n] [comm_ring R] [topological_ring R]
  (A : matrix n n R) (h : continuous_at ring.inverse A.det) :
  continuous_at has_inv.inv A :=
(h.comp continuous_id.matrix_det.continuous_at).smul continuous_id.matrix_adjugate.continuous_at

-- lemmas about functions in `data/matrix/block.lean`
section block_matrices

@[continuity]
lemma continuous.matrix_from_blocks
  {A : X → matrix n l R} {B : X → matrix n m R} {C : X → matrix p l R} {D : X → matrix p m R}
  (hA : continuous A) (hB : continuous B) (hC : continuous C) (hD : continuous D) :
  continuous (λ x, matrix.from_blocks (A x) (B x) (C x) (D x)) :=
continuous_matrix $ λ i j,
  by cases i; cases j; refine continuous.matrix_elem _ i j; assumption

@[continuity]
lemma continuous.matrix_block_diagonal [has_zero R] [decidable_eq p] {A : X → p → matrix m n R}
  (hA : continuous A) :
  continuous (λ x, block_diagonal (A x)) :=
continuous_matrix $ λ ⟨i₁, i₂⟩ ⟨j₁, j₂⟩,
  (((continuous_apply i₂).comp hA).matrix_elem i₁ j₁).if_const _ continuous_zero

@[continuity]
lemma continuous.matrix_block_diag {A : X → matrix (m × p) (n × p) R} (hA : continuous A) :
  continuous (λ x, block_diag (A x)) :=
continuous_pi $ λ i, continuous_matrix $ λ j k, hA.matrix_elem _ _

@[continuity]
lemma continuous.matrix_block_diagonal' [has_zero R] [decidable_eq l]
  {A : X → Π i, matrix (m' i) (n' i) R} (hA : continuous A) :
  continuous (λ x, block_diagonal' (A x)) :=
continuous_matrix $ λ ⟨i₁, i₂⟩ ⟨j₁, j₂⟩, begin
  dsimp only [block_diagonal'],
  split_ifs,
  { subst h,
    exact ((continuous_apply i₁).comp hA).matrix_elem i₂ j₂ },
  { exact continuous_const },
end

@[continuity]
lemma continuous.matrix_block_diag' {A : X → matrix (Σ i, m' i) (Σ i, n' i) R} (hA : continuous A) :
  continuous (λ x, block_diag' (A x)) :=
continuous_pi $ λ i, continuous_matrix $ λ j k, hA.matrix_elem _ _

end block_matrices

end continuity

/-! ### Lemmas about infinite sums -/
section tsum
variables [semiring α] [add_comm_monoid R] [topological_space R] [module α R]

lemma has_sum.matrix_transpose {f : X → matrix m n R} {a : matrix m n R} (hf : has_sum f a) :
  has_sum (λ x, (f x)ᵀ) aᵀ :=
(hf.map (@matrix.transpose_add_equiv m n R _) continuous_id.matrix_transpose : _)

lemma summable.matrix_transpose {f : X → matrix m n R} (hf : summable f) :
  summable (λ x, (f x)ᵀ) :=
hf.has_sum.matrix_transpose.summable

@[simp] lemma summable_matrix_transpose {f : X → matrix m n R} :
  summable (λ x, (f x)ᵀ) ↔ summable f :=
(summable.map_iff_of_equiv (@matrix.transpose_add_equiv m n R _)
    (@continuous_id (matrix m n R) _).matrix_transpose (continuous_id.matrix_transpose) : _)

lemma matrix.transpose_tsum [t2_space R] {f : X → matrix m n R} : (∑' x, f x)ᵀ = ∑' x, (f x)ᵀ :=
begin
  by_cases hf : summable f,
  { exact hf.has_sum.matrix_transpose.tsum_eq.symm },
  { have hft := summable_matrix_transpose.not.mpr hf,
    rw [tsum_eq_zero_of_not_summable hf, tsum_eq_zero_of_not_summable hft, transpose_zero] },
end

lemma has_sum.matrix_conj_transpose [star_add_monoid R] [has_continuous_star R]
  {f : X → matrix m n R} {a : matrix m n R} (hf : has_sum f a) :
  has_sum (λ x, (f x)ᴴ) aᴴ :=
(hf.map (@matrix.conj_transpose_add_equiv m n R _ _) continuous_id.matrix_conj_transpose : _)

lemma summable.matrix_conj_transpose [star_add_monoid R] [has_continuous_star R]
  {f : X → matrix m n R} (hf : summable f) :
  summable (λ x, (f x)ᴴ) :=
hf.has_sum.matrix_conj_transpose.summable

@[simp] lemma summable_matrix_conj_transpose [star_add_monoid R] [has_continuous_star R]
  {f : X → matrix m n R} :
  summable (λ x, (f x)ᴴ) ↔ summable f :=
(summable.map_iff_of_equiv (@matrix.conj_transpose_add_equiv m n R _ _)
  (@continuous_id (matrix m n R) _).matrix_conj_transpose (continuous_id.matrix_conj_transpose) : _)

lemma matrix.conj_transpose_tsum [star_add_monoid R] [has_continuous_star R] [t2_space R]
  {f : X → matrix m n R} : (∑' x, f x)ᴴ = ∑' x, (f x)ᴴ :=
begin
  by_cases hf : summable f,
  { exact hf.has_sum.matrix_conj_transpose.tsum_eq.symm },
  { have hft := summable_matrix_conj_transpose.not.mpr hf,
    rw [tsum_eq_zero_of_not_summable hf, tsum_eq_zero_of_not_summable hft, conj_transpose_zero] },
end

lemma has_sum.matrix_diagonal [decidable_eq n] {f : X → n → R} {a : n → R} (hf : has_sum f a) :
  has_sum (λ x, diagonal (f x)) (diagonal a) :=
(hf.map (diagonal_add_monoid_hom n R) $ continuous.matrix_diagonal $ by exact continuous_id : _)

lemma summable.matrix_diagonal [decidable_eq n] {f : X → n → R} (hf : summable f) :
  summable (λ x, diagonal (f x)) :=
hf.has_sum.matrix_diagonal.summable

@[simp] lemma summable_matrix_diagonal [decidable_eq n] {f : X → n → R} :
  summable (λ x, diagonal (f x)) ↔ summable f :=
(summable.map_iff_of_left_inverse
  (@matrix.diagonal_add_monoid_hom n R _ _) (matrix.diag_add_monoid_hom n R)
  (by exact continuous.matrix_diagonal continuous_id)
  continuous_matrix_diag
  (λ A, diag_diagonal A) : _)

lemma matrix.diagonal_tsum [decidable_eq n] [t2_space R] {f : X → n → R} :
  diagonal (∑' x, f x) = ∑' x, diagonal (f x) :=
begin
  by_cases hf : summable f,
  { exact hf.has_sum.matrix_diagonal.tsum_eq.symm },
  { have hft := summable_matrix_diagonal.not.mpr hf,
    rw [tsum_eq_zero_of_not_summable hf, tsum_eq_zero_of_not_summable hft],
    exact diagonal_zero },
end

lemma has_sum.matrix_diag {f : X → matrix n n R} {a : matrix n n R} (hf : has_sum f a) :
  has_sum (λ x, diag (f x)) (diag a) :=
(hf.map (diag_add_monoid_hom n R) continuous_matrix_diag : _)

lemma summable.matrix_diag {f : X → matrix n n R} (hf : summable f) : summable (λ x, diag (f x)) :=
hf.has_sum.matrix_diag.summable

section block_matrices

lemma has_sum.matrix_block_diagonal [decidable_eq p]
  {f : X → p → matrix m n R} {a : p → matrix m n R} (hf : has_sum f a) :
  has_sum (λ x, block_diagonal (f x)) (block_diagonal a) :=
(hf.map (block_diagonal_add_monoid_hom m n p R) $
  continuous.matrix_block_diagonal $ by exact continuous_id : _)

lemma summable.matrix_block_diagonal [decidable_eq p] {f : X → p → matrix m n R} (hf : summable f) :
  summable (λ x, block_diagonal (f x)) :=
hf.has_sum.matrix_block_diagonal.summable

lemma summable_matrix_block_diagonal [decidable_eq p] {f : X → p → matrix m n R} :
  summable (λ x, block_diagonal (f x)) ↔ summable f :=
(summable.map_iff_of_left_inverse
  (matrix.block_diagonal_add_monoid_hom m n p R) (matrix.block_diag_add_monoid_hom m n p R)
  (by exact continuous.matrix_block_diagonal continuous_id)
  (by exact continuous.matrix_block_diag continuous_id)
  (λ A, block_diag_block_diagonal A) : _)

lemma matrix.block_diagonal_tsum [decidable_eq p] [t2_space R] {f : X → p → matrix m n R} :
  block_diagonal (∑' x, f x) = ∑' x, block_diagonal (f x) :=
begin
  by_cases hf : summable f,
  { exact hf.has_sum.matrix_block_diagonal.tsum_eq.symm },
  { have hft := summable_matrix_block_diagonal.not.mpr hf,
    rw [tsum_eq_zero_of_not_summable hf, tsum_eq_zero_of_not_summable hft],
    exact block_diagonal_zero },
end

lemma has_sum.matrix_block_diag {f : X → matrix (m × p) (n × p) R}
  {a : matrix (m × p) (n × p) R} (hf : has_sum f a) :
  has_sum (λ x, block_diag (f x)) (block_diag a) :=
(hf.map (block_diag_add_monoid_hom m n p R) $ continuous.matrix_block_diag continuous_id : _)

lemma summable.matrix_block_diag {f : X → matrix (m × p) (n × p) R} (hf : summable f) :
  summable (λ x, block_diag (f x)) :=
hf.has_sum.matrix_block_diag.summable

lemma has_sum.matrix_block_diagonal' [decidable_eq l]
  {f : X → Π i, matrix (m' i) (n' i) R} {a : Π i, matrix (m' i) (n' i) R} (hf : has_sum f a) :
  has_sum (λ x, block_diagonal' (f x)) (block_diagonal' a) :=
(hf.map (block_diagonal'_add_monoid_hom m' n' R) $
  continuous.matrix_block_diagonal' $ by exact continuous_id : _)

lemma summable.matrix_block_diagonal' [decidable_eq l]
  {f : X → Π i, matrix (m' i) (n' i) R} (hf : summable f) :
  summable (λ x, block_diagonal' (f x)) :=
hf.has_sum.matrix_block_diagonal'.summable

lemma summable_matrix_block_diagonal' [decidable_eq l] {f : X → Π i, matrix (m' i) (n' i) R} :
  summable (λ x, block_diagonal' (f x)) ↔ summable f :=
(summable.map_iff_of_left_inverse
  (matrix.block_diagonal'_add_monoid_hom m' n' R) (matrix.block_diag'_add_monoid_hom m' n' R)
  (by exact continuous.matrix_block_diagonal' continuous_id)
  (by exact continuous.matrix_block_diag' continuous_id)
  (λ A, block_diag'_block_diagonal' A) : _)

lemma matrix.block_diagonal'_tsum [decidable_eq l] [t2_space R]
  {f : X → Π i, matrix (m' i) (n' i) R} :
  block_diagonal' (∑' x, f x) = ∑' x, block_diagonal' (f x) :=
begin
  by_cases hf : summable f,
  { exact hf.has_sum.matrix_block_diagonal'.tsum_eq.symm },
  { have hft := summable_matrix_block_diagonal'.not.mpr hf,
    rw [tsum_eq_zero_of_not_summable hf, tsum_eq_zero_of_not_summable hft],
    exact block_diagonal'_zero },
end

lemma has_sum.matrix_block_diag' {f : X → matrix (Σ i, m' i) (Σ i, n' i) R}
  {a : matrix (Σ i, m' i) (Σ i, n' i) R} (hf : has_sum f a) :
  has_sum (λ x, block_diag' (f x)) (block_diag' a) :=
(hf.map (block_diag'_add_monoid_hom m' n' R) $ continuous.matrix_block_diag' continuous_id : _)

lemma summable.matrix_block_diag' {f : X → matrix (Σ i, m' i) (Σ i, n' i) R} (hf : summable f) :
  summable (λ x, block_diag' (f x)) :=
hf.has_sum.matrix_block_diag'.summable

end block_matrices

end tsum


<|start_filename|>src/analysis/specific_limits/basic.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>
-/
import algebra.geom_sum
import order.filter.archimedean
import order.iterate
import topology.instances.ennreal

/-!
# A collection of specific limit computations

This file, by design, is independent of `normed_space` in the import hierarchy.  It contains
important specific limit computations in metric spaces, in ordered rings/fields, and in specific
instances of these such as `ℝ`, `ℝ≥0` and `ℝ≥0∞`.
-/

noncomputable theory
open classical set function filter finset metric

open_locale classical topological_space nat big_operators uniformity nnreal ennreal

variables {α : Type*} {β : Type*} {ι : Type*}

lemma tendsto_inverse_at_top_nhds_0_nat : tendsto (λ n : ℕ, (n : ℝ)⁻¹) at_top (𝓝 0) :=
tendsto_inv_at_top_zero.comp tendsto_coe_nat_at_top_at_top

lemma tendsto_const_div_at_top_nhds_0_nat (C : ℝ) : tendsto (λ n : ℕ, C / n) at_top (𝓝 0) :=
by simpa only [mul_zero] using tendsto_const_nhds.mul tendsto_inverse_at_top_nhds_0_nat

lemma nnreal.tendsto_inverse_at_top_nhds_0_nat : tendsto (λ n : ℕ, (n : ℝ≥0)⁻¹) at_top (𝓝 0) :=
by { rw ← nnreal.tendsto_coe, convert tendsto_inverse_at_top_nhds_0_nat, simp }

lemma nnreal.tendsto_const_div_at_top_nhds_0_nat (C : ℝ≥0) :
  tendsto (λ n : ℕ, C / n) at_top (𝓝 0) :=
by simpa using tendsto_const_nhds.mul nnreal.tendsto_inverse_at_top_nhds_0_nat

lemma tendsto_one_div_add_at_top_nhds_0_nat :
  tendsto (λ n : ℕ, 1 / ((n : ℝ) + 1)) at_top (𝓝 0) :=
suffices tendsto (λ n : ℕ, 1 / (↑(n + 1) : ℝ)) at_top (𝓝 0), by simpa,
(tendsto_add_at_top_iff_nat 1).2 (tendsto_const_div_at_top_nhds_0_nat 1)

/-! ### Powers -/

lemma tendsto_add_one_pow_at_top_at_top_of_pos [linear_ordered_semiring α] [archimedean α] {r : α}
  (h : 0 < r) :
  tendsto (λ n:ℕ, (r + 1)^n) at_top at_top :=
tendsto_at_top_at_top_of_monotone' (λ n m, pow_le_pow (le_add_of_nonneg_left (le_of_lt h))) $
  not_bdd_above_iff.2 $ λ x, set.exists_range_iff.2 $ add_one_pow_unbounded_of_pos _ h

lemma tendsto_pow_at_top_at_top_of_one_lt [linear_ordered_ring α] [archimedean α]
  {r : α} (h : 1 < r) :
  tendsto (λn:ℕ, r ^ n) at_top at_top :=
sub_add_cancel r 1 ▸ tendsto_add_one_pow_at_top_at_top_of_pos (sub_pos.2 h)

lemma nat.tendsto_pow_at_top_at_top_of_one_lt {m : ℕ} (h : 1 < m) :
  tendsto (λn:ℕ, m ^ n) at_top at_top :=
tsub_add_cancel_of_le (le_of_lt h) ▸
  tendsto_add_one_pow_at_top_at_top_of_pos (tsub_pos_of_lt h)

lemma tendsto_pow_at_top_nhds_0_of_lt_1 {𝕜 : Type*} [linear_ordered_field 𝕜] [archimedean 𝕜]
  [topological_space 𝕜] [order_topology 𝕜] {r : 𝕜} (h₁ : 0 ≤ r) (h₂ : r < 1) :
  tendsto (λn:ℕ, r^n) at_top (𝓝 0) :=
h₁.eq_or_lt.elim
  (assume : 0 = r,
    (tendsto_add_at_top_iff_nat 1).mp $ by simp [pow_succ, ← this, tendsto_const_nhds])
  (assume : 0 < r,
    have tendsto (λn, (r⁻¹ ^ n)⁻¹) at_top (𝓝 0),
      from tendsto_inv_at_top_zero.comp
        (tendsto_pow_at_top_at_top_of_one_lt $ one_lt_inv this h₂),
    this.congr (λ n, by simp))

lemma tendsto_pow_at_top_nhds_within_0_of_lt_1 {𝕜 : Type*} [linear_ordered_field 𝕜] [archimedean 𝕜]
  [topological_space 𝕜] [order_topology 𝕜] {r : 𝕜} (h₁ : 0 < r) (h₂ : r < 1) :
  tendsto (λn:ℕ, r^n) at_top (𝓝[>] 0) :=
tendsto_inf.2 ⟨tendsto_pow_at_top_nhds_0_of_lt_1 h₁.le h₂,
  tendsto_principal.2 $ eventually_of_forall $ λ n, pow_pos h₁ _⟩

lemma uniformity_basis_dist_pow_of_lt_1 {α : Type*} [pseudo_metric_space α]
  {r : ℝ} (h₀ : 0 < r) (h₁ : r < 1) :
  (𝓤 α).has_basis (λ k : ℕ, true) (λ k, {p : α × α | dist p.1 p.2 < r ^ k}) :=
metric.mk_uniformity_basis (λ i _, pow_pos h₀ _) $ λ ε ε0,
  (exists_pow_lt_of_lt_one ε0 h₁).imp $ λ k hk, ⟨trivial, hk.le⟩

lemma geom_lt {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) {n : ℕ} (hn : 0 < n)
  (h : ∀ k < n, c * u k < u (k + 1)) :
  c ^ n * u 0 < u n :=
begin
  refine (monotone_mul_left_of_nonneg hc).seq_pos_lt_seq_of_le_of_lt hn _ _ h,
  { simp },
  { simp [pow_succ, mul_assoc, le_refl] }
end

lemma geom_le {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) (n : ℕ) (h : ∀ k < n, c * u k ≤ u (k + 1)) :
  c ^ n * u 0 ≤ u n :=
by refine (monotone_mul_left_of_nonneg hc).seq_le_seq n _ _ h; simp [pow_succ, mul_assoc, le_refl]

lemma lt_geom {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) {n : ℕ} (hn : 0 < n)
  (h : ∀ k < n, u (k + 1) < c * u k) :
  u n < c ^ n * u 0 :=
begin
  refine (monotone_mul_left_of_nonneg hc).seq_pos_lt_seq_of_lt_of_le hn _ h _,
  { simp },
  { simp [pow_succ, mul_assoc, le_refl] }
end

lemma le_geom {u : ℕ → ℝ} {c : ℝ} (hc : 0 ≤ c) (n : ℕ) (h : ∀ k < n, u (k + 1) ≤ c * u k) :
  u n ≤ (c ^ n) * u 0 :=
by refine (monotone_mul_left_of_nonneg hc).seq_le_seq n _ h _; simp [pow_succ, mul_assoc, le_refl]

/-- If a sequence `v` of real numbers satisfies `k * v n ≤ v (n+1)` with `1 < k`,
then it goes to +∞. -/
lemma tendsto_at_top_of_geom_le {v : ℕ → ℝ} {c : ℝ} (h₀ : 0 < v 0) (hc : 1 < c)
  (hu : ∀ n, c * v n ≤ v (n + 1)) : tendsto v at_top at_top :=
tendsto_at_top_mono (λ n, geom_le (zero_le_one.trans hc.le) n (λ k hk, hu k)) $
  (tendsto_pow_at_top_at_top_of_one_lt hc).at_top_mul_const h₀

lemma nnreal.tendsto_pow_at_top_nhds_0_of_lt_1 {r : ℝ≥0} (hr : r < 1) :
  tendsto (λ n:ℕ, r^n) at_top (𝓝 0) :=
nnreal.tendsto_coe.1 $ by simp only [nnreal.coe_pow, nnreal.coe_zero,
  tendsto_pow_at_top_nhds_0_of_lt_1 r.coe_nonneg hr]

lemma ennreal.tendsto_pow_at_top_nhds_0_of_lt_1 {r : ℝ≥0∞} (hr : r < 1) :
  tendsto (λ n:ℕ, r^n) at_top (𝓝 0) :=
begin
  rcases ennreal.lt_iff_exists_coe.1 hr with ⟨r, rfl, hr'⟩,
  rw [← ennreal.coe_zero],
  norm_cast at *,
  apply nnreal.tendsto_pow_at_top_nhds_0_of_lt_1 hr
end

/-! ### Geometric series-/
section geometric

lemma has_sum_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) :
  has_sum (λn:ℕ, r ^ n) (1 - r)⁻¹ :=
have r ≠ 1, from ne_of_lt h₂,
have tendsto (λn, (r ^ n - 1) * (r - 1)⁻¹) at_top (𝓝 ((0 - 1) * (r - 1)⁻¹)),
  from ((tendsto_pow_at_top_nhds_0_of_lt_1 h₁ h₂).sub tendsto_const_nhds).mul tendsto_const_nhds,
(has_sum_iff_tendsto_nat_of_nonneg (pow_nonneg h₁) _).mpr $
  by simp [neg_inv, geom_sum_eq, div_eq_mul_inv, *] at *

lemma summable_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : summable (λn:ℕ, r ^ n) :=
⟨_, has_sum_geometric_of_lt_1 h₁ h₂⟩

lemma tsum_geometric_of_lt_1 {r : ℝ} (h₁ : 0 ≤ r) (h₂ : r < 1) : ∑'n:ℕ, r ^ n = (1 - r)⁻¹ :=
(has_sum_geometric_of_lt_1 h₁ h₂).tsum_eq

lemma has_sum_geometric_two : has_sum (λn:ℕ, ((1:ℝ)/2) ^ n) 2 :=
by convert has_sum_geometric_of_lt_1 _ _; norm_num

lemma summable_geometric_two : summable (λn:ℕ, ((1:ℝ)/2) ^ n) :=
⟨_, has_sum_geometric_two⟩

lemma summable_geometric_two_encode {ι : Type*} [encodable ι] :
  summable (λ (i : ι), (1/2 : ℝ)^(encodable.encode i)) :=
summable_geometric_two.comp_injective encodable.encode_injective

lemma tsum_geometric_two : ∑'n:ℕ, ((1:ℝ)/2) ^ n = 2 :=
has_sum_geometric_two.tsum_eq

lemma sum_geometric_two_le (n : ℕ) : ∑ (i : ℕ) in range n, (1 / (2 : ℝ)) ^ i ≤ 2 :=
begin
  have : ∀ i, 0 ≤ (1 / (2 : ℝ)) ^ i,
  { intro i, apply pow_nonneg, norm_num },
  convert sum_le_tsum (range n) (λ i _, this i) summable_geometric_two,
  exact tsum_geometric_two.symm
end

lemma tsum_geometric_inv_two : ∑' n : ℕ, (2 : ℝ)⁻¹ ^ n = 2 :=
(inv_eq_one_div (2 : ℝ)).symm ▸ tsum_geometric_two

/-- The sum of `2⁻¹ ^ i` for `n ≤ i` equals `2 * 2⁻¹ ^ n`. -/
lemma tsum_geometric_inv_two_ge (n : ℕ) :
  ∑' i, ite (n ≤ i) ((2 : ℝ)⁻¹ ^ i) 0 = 2 * 2⁻¹ ^ n :=
begin
  have A : summable (λ (i : ℕ), ite (n ≤ i) ((2⁻¹ : ℝ) ^ i) 0),
  { apply summable_of_nonneg_of_le _ _ summable_geometric_two;
    { intro i, by_cases hi : n ≤ i; simp [hi] } },
  have B : (finset.range n).sum (λ (i : ℕ), ite (n ≤ i) ((2⁻¹ : ℝ)^i) 0) = 0 :=
    finset.sum_eq_zero (λ i hi, ite_eq_right_iff.2 $ λ h,
      (lt_irrefl _ ((finset.mem_range.1 hi).trans_le h)).elim),
  simp only [← sum_add_tsum_nat_add n A, B, if_true, zero_add, zero_le',
    le_add_iff_nonneg_left, pow_add, tsum_mul_right, tsum_geometric_inv_two],
end

lemma has_sum_geometric_two' (a : ℝ) : has_sum (λn:ℕ, (a / 2) / 2 ^ n) a :=
begin
  convert has_sum.mul_left (a / 2) (has_sum_geometric_of_lt_1
    (le_of_lt one_half_pos) one_half_lt_one),
  { funext n, simp, refl, },
  { norm_num }
end

lemma summable_geometric_two' (a : ℝ) : summable (λ n:ℕ, (a / 2) / 2 ^ n) :=
⟨a, has_sum_geometric_two' a⟩

lemma tsum_geometric_two' (a : ℝ) : ∑' n:ℕ, (a / 2) / 2^n = a :=
(has_sum_geometric_two' a).tsum_eq

/-- **Sum of a Geometric Series** -/
lemma nnreal.has_sum_geometric {r : ℝ≥0} (hr : r < 1) :
  has_sum (λ n : ℕ, r ^ n) (1 - r)⁻¹ :=
begin
  apply nnreal.has_sum_coe.1,
  push_cast,
  rw [nnreal.coe_sub (le_of_lt hr)],
  exact has_sum_geometric_of_lt_1 r.coe_nonneg hr
end

lemma nnreal.summable_geometric {r : ℝ≥0} (hr : r < 1) : summable (λn:ℕ, r ^ n) :=
⟨_, nnreal.has_sum_geometric hr⟩

lemma tsum_geometric_nnreal {r : ℝ≥0} (hr : r < 1) : ∑'n:ℕ, r ^ n = (1 - r)⁻¹ :=
(nnreal.has_sum_geometric hr).tsum_eq

/-- The series `pow r` converges to `(1-r)⁻¹`. For `r < 1` the RHS is a finite number,
and for `1 ≤ r` the RHS equals `∞`. -/
@[simp] lemma ennreal.tsum_geometric (r : ℝ≥0∞) : ∑'n:ℕ, r ^ n = (1 - r)⁻¹ :=
begin
  cases lt_or_le r 1 with hr hr,
  { rcases ennreal.lt_iff_exists_coe.1 hr with ⟨r, rfl, hr'⟩,
    norm_cast at *,
    convert ennreal.tsum_coe_eq (nnreal.has_sum_geometric hr),
    rw [ennreal.coe_inv $ ne_of_gt $ tsub_pos_iff_lt.2 hr] },
  { rw [tsub_eq_zero_iff_le.mpr hr, ennreal.inv_zero, ennreal.tsum_eq_supr_nat, supr_eq_top],
    refine λ a ha, (ennreal.exists_nat_gt (lt_top_iff_ne_top.1 ha)).imp
      (λ n hn, lt_of_lt_of_le hn _),
    calc (n:ℝ≥0∞) = ∑ i in range n, 1     : by rw [sum_const, nsmul_one, card_range]
              ... ≤ ∑ i in range n, r ^ i : sum_le_sum (λ k _, one_le_pow_of_one_le' hr k) }
end

end geometric

/-!
### Sequences with geometrically decaying distance in metric spaces

In this paragraph, we discuss sequences in metric spaces or emetric spaces for which the distance
between two consecutive terms decays geometrically. We show that such sequences are Cauchy
sequences, and bound their distances to the limit. We also discuss series with geometrically
decaying terms.
-/
section edist_le_geometric

variables [pseudo_emetric_space α] (r C : ℝ≥0∞) (hr : r < 1) (hC : C ≠ ⊤) {f : ℕ → α}
  (hu : ∀n, edist (f n) (f (n+1)) ≤ C * r^n)

include hr hC hu

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, `C ≠ ∞`, `r < 1`,
then `f` is a Cauchy sequence.-/
lemma cauchy_seq_of_edist_le_geometric : cauchy_seq f :=
begin
  refine cauchy_seq_of_edist_le_of_tsum_ne_top _ hu _,
  rw [ennreal.tsum_mul_left, ennreal.tsum_geometric],
  refine ennreal.mul_ne_top hC (ennreal.inv_ne_top.2 _),
  exact (tsub_pos_iff_lt.2 hr).ne'
end

omit hr hC

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, then the distance from
`f n` to the limit of `f` is bounded above by `C * r^n / (1 - r)`. -/
lemma edist_le_of_edist_le_geometric_of_tendsto {a : α} (ha : tendsto f at_top (𝓝 a)) (n : ℕ) :
  edist (f n) a ≤ (C * r^n) / (1 - r) :=
begin
  convert edist_le_tsum_of_edist_le_of_tendsto _ hu ha _,
  simp only [pow_add, ennreal.tsum_mul_left, ennreal.tsum_geometric, div_eq_mul_inv, mul_assoc]
end

/-- If `edist (f n) (f (n+1))` is bounded by `C * r^n`, then the distance from
`f 0` to the limit of `f` is bounded above by `C / (1 - r)`. -/
lemma edist_le_of_edist_le_geometric_of_tendsto₀ {a : α} (ha : tendsto f at_top (𝓝 a)) :
  edist (f 0) a ≤ C / (1 - r) :=
by simpa only [pow_zero, mul_one] using edist_le_of_edist_le_geometric_of_tendsto r C hu ha 0

end edist_le_geometric

section edist_le_geometric_two

variables [pseudo_emetric_space α] (C : ℝ≥0∞) (hC : C ≠ ⊤) {f : ℕ → α}
  (hu : ∀n, edist (f n) (f (n+1)) ≤ C / 2^n) {a : α} (ha : tendsto f at_top (𝓝 a))

include hC hu

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then `f` is a Cauchy sequence.-/
lemma cauchy_seq_of_edist_le_geometric_two : cauchy_seq f :=
begin
  simp only [div_eq_mul_inv, ennreal.inv_pow] at hu,
  refine cauchy_seq_of_edist_le_geometric 2⁻¹ C _ hC hu,
  simp [ennreal.one_lt_two]
end

omit hC
include ha

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then the distance from
`f n` to the limit of `f` is bounded above by `2 * C * 2^-n`. -/
lemma edist_le_of_edist_le_geometric_two_of_tendsto (n : ℕ) :
  edist (f n) a ≤ 2 * C / 2^n :=
begin
  simp only [div_eq_mul_inv, ennreal.inv_pow] at *,
  rw [mul_assoc, mul_comm],
  convert edist_le_of_edist_le_geometric_of_tendsto 2⁻¹ C hu ha n,
  rw [ennreal.one_sub_inv_two, inv_inv]
end

/-- If `edist (f n) (f (n+1))` is bounded by `C * 2^-n`, then the distance from
`f 0` to the limit of `f` is bounded above by `2 * C`. -/
lemma edist_le_of_edist_le_geometric_two_of_tendsto₀: edist (f 0) a ≤ 2 * C :=
by simpa only [pow_zero, div_eq_mul_inv, ennreal.inv_one, mul_one]
  using edist_le_of_edist_le_geometric_two_of_tendsto C hu ha 0

end edist_le_geometric_two

section le_geometric

variables [pseudo_metric_space α] {r C : ℝ} (hr : r < 1) {f : ℕ → α}
  (hu : ∀n, dist (f n) (f (n+1)) ≤ C * r^n)

include hr hu

lemma aux_has_sum_of_le_geometric : has_sum (λ n : ℕ, C * r^n) (C / (1 - r)) :=
begin
  rcases sign_cases_of_C_mul_pow_nonneg (λ n, dist_nonneg.trans (hu n)) with rfl | ⟨C₀, r₀⟩,
  { simp [has_sum_zero] },
  { refine has_sum.mul_left C _,
    simpa using has_sum_geometric_of_lt_1 r₀ hr }
end

variables (r C)

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then `f` is a Cauchy sequence.
Note that this lemma does not assume `0 ≤ C` or `0 ≤ r`. -/
lemma cauchy_seq_of_le_geometric : cauchy_seq f :=
cauchy_seq_of_dist_le_of_summable _ hu ⟨_, aux_has_sum_of_le_geometric hr hu⟩

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then the distance from
`f n` to the limit of `f` is bounded above by `C * r^n / (1 - r)`. -/
lemma dist_le_of_le_geometric_of_tendsto₀ {a : α} (ha : tendsto f at_top (𝓝 a)) :
  dist (f 0) a ≤ C / (1 - r) :=
(aux_has_sum_of_le_geometric hr hu).tsum_eq ▸
  dist_le_tsum_of_dist_le_of_tendsto₀ _ hu ⟨_, aux_has_sum_of_le_geometric hr hu⟩ ha

/-- If `dist (f n) (f (n+1))` is bounded by `C * r^n`, `r < 1`, then the distance from
`f 0` to the limit of `f` is bounded above by `C / (1 - r)`. -/
lemma dist_le_of_le_geometric_of_tendsto {a : α} (ha : tendsto f at_top (𝓝 a)) (n : ℕ) :
  dist (f n) a ≤ (C * r^n) / (1 - r) :=
begin
  have := aux_has_sum_of_le_geometric hr hu,
  convert dist_le_tsum_of_dist_le_of_tendsto _ hu ⟨_, this⟩ ha n,
  simp only [pow_add, mul_left_comm C, mul_div_right_comm],
  rw [mul_comm],
  exact (this.mul_left _).tsum_eq.symm
end

omit hr hu

variable (hu₂ : ∀ n, dist (f n) (f (n+1)) ≤ (C / 2) / 2^n)

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then `f` is a Cauchy sequence. -/
lemma cauchy_seq_of_le_geometric_two : cauchy_seq f :=
cauchy_seq_of_dist_le_of_summable _ hu₂ $ ⟨_, has_sum_geometric_two' C⟩

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then the distance from
`f 0` to the limit of `f` is bounded above by `C`. -/
lemma dist_le_of_le_geometric_two_of_tendsto₀ {a : α} (ha : tendsto f at_top (𝓝 a)) :
  dist (f 0) a ≤ C :=
(tsum_geometric_two' C) ▸ dist_le_tsum_of_dist_le_of_tendsto₀ _ hu₂ (summable_geometric_two' C) ha

include hu₂

/-- If `dist (f n) (f (n+1))` is bounded by `(C / 2) / 2^n`, then the distance from
`f n` to the limit of `f` is bounded above by `C / 2^n`. -/
lemma dist_le_of_le_geometric_two_of_tendsto {a : α} (ha : tendsto f at_top (𝓝 a)) (n : ℕ) :
  dist (f n) a ≤ C / 2^n :=
begin
  convert dist_le_tsum_of_dist_le_of_tendsto _ hu₂ (summable_geometric_two' C) ha n,
  simp only [add_comm n, pow_add, ← div_div],
  symmetry,
  exact ((has_sum_geometric_two' C).div_const _).tsum_eq
end

end le_geometric

/-! ### Summability tests based on comparison with geometric series -/

/-- A series whose terms are bounded by the terms of a converging geometric series converges. -/
lemma summable_one_div_pow_of_le {m : ℝ} {f : ℕ → ℕ} (hm : 1 < m) (fi : ∀ i, i ≤ f i) :
  summable (λ i, 1 / m ^ f i) :=
begin
  refine summable_of_nonneg_of_le
    (λ a, one_div_nonneg.mpr (pow_nonneg (zero_le_one.trans hm.le) _)) (λ a, _)
    (summable_geometric_of_lt_1 (one_div_nonneg.mpr (zero_le_one.trans hm.le))
      ((one_div_lt (zero_lt_one.trans hm) zero_lt_one).mpr (one_div_one.le.trans_lt hm))),
  rw [div_pow, one_pow],
  refine (one_div_le_one_div _ _).mpr (pow_le_pow hm.le (fi a));
  exact pow_pos (zero_lt_one.trans hm) _
end

/-! ### Positive sequences with small sums on encodable types -/

/-- For any positive `ε`, define on an encodable type a positive sequence with sum less than `ε` -/
def pos_sum_of_encodable {ε : ℝ} (hε : 0 < ε)
  (ι) [encodable ι] : {ε' : ι → ℝ // (∀ i, 0 < ε' i) ∧ ∃ c, has_sum ε' c ∧ c ≤ ε} :=
begin
  let f := λ n, (ε / 2) / 2 ^ n,
  have hf : has_sum f ε := has_sum_geometric_two' _,
  have f0 : ∀ n, 0 < f n := λ n, div_pos (half_pos hε) (pow_pos zero_lt_two _),
  refine ⟨f ∘ encodable.encode, λ i, f0 _, _⟩,
  rcases hf.summable.comp_injective (@encodable.encode_injective ι _) with ⟨c, hg⟩,
  refine ⟨c, hg, has_sum_le_inj _ (@encodable.encode_injective ι _) _ _ hg hf⟩,
  { assume i _, exact le_of_lt (f0 _) },
  { assume n, exact le_rfl }
end

lemma set.countable.exists_pos_has_sum_le {ι : Type*} {s : set ι} (hs : s.countable)
  {ε : ℝ} (hε : 0 < ε) :
  ∃ ε' : ι → ℝ, (∀ i, 0 < ε' i) ∧ ∃ c, has_sum (λ i : s, ε' i) c ∧ c ≤ ε :=
begin
  haveI := hs.to_encodable,
  rcases pos_sum_of_encodable hε s with ⟨f, hf0, ⟨c, hfc, hcε⟩⟩,
  refine ⟨λ i, if h : i ∈ s then f ⟨i, h⟩ else 1, λ i, _, ⟨c, _, hcε⟩⟩,
  { split_ifs, exacts [hf0 _, zero_lt_one] },
  { simpa only [subtype.coe_prop, dif_pos, subtype.coe_eta] }
end

lemma set.countable.exists_pos_forall_sum_le {ι : Type*} {s : set ι} (hs : s.countable)
  {ε : ℝ} (hε : 0 < ε) :
  ∃ ε' : ι → ℝ, (∀ i, 0 < ε' i) ∧ ∀ t : finset ι, ↑t ⊆ s → ∑ i in t, ε' i ≤ ε :=
begin
  rcases hs.exists_pos_has_sum_le hε with ⟨ε', hpos, c, hε'c, hcε⟩,
  refine ⟨ε', hpos, λ t ht, _⟩,
  rw [← sum_subtype_of_mem _ ht],
  refine (sum_le_has_sum _ _ hε'c).trans hcε,
  exact λ _ _, (hpos _).le
end

namespace nnreal

theorem exists_pos_sum_of_encodable {ε : ℝ≥0} (hε : ε ≠ 0) (ι) [encodable ι] :
  ∃ ε' : ι → ℝ≥0, (∀ i, 0 < ε' i) ∧ ∃c, has_sum ε' c ∧ c < ε :=
let ⟨a, a0, aε⟩ := exists_between (pos_iff_ne_zero.2 hε) in
let ⟨ε', hε', c, hc, hcε⟩ := pos_sum_of_encodable a0 ι in
⟨ λi, ⟨ε' i, le_of_lt $ hε' i⟩, assume i, nnreal.coe_lt_coe.1 $ hε' i,
  ⟨c, has_sum_le (assume i, le_of_lt $ hε' i) has_sum_zero hc ⟩, nnreal.has_sum_coe.1 hc,
   lt_of_le_of_lt (nnreal.coe_le_coe.1 hcε) aε ⟩

end nnreal

namespace ennreal

theorem exists_pos_sum_of_encodable {ε : ℝ≥0∞} (hε : ε ≠ 0) (ι) [encodable ι] :
  ∃ ε' : ι → ℝ≥0, (∀ i, 0 < ε' i) ∧ ∑' i, (ε' i : ℝ≥0∞) < ε :=
begin
  rcases exists_between (pos_iff_ne_zero.2 hε) with ⟨r, h0r, hrε⟩,
  rcases lt_iff_exists_coe.1 hrε with ⟨x, rfl, hx⟩,
  rcases nnreal.exists_pos_sum_of_encodable (coe_pos.1 h0r).ne' ι with ⟨ε', hp, c, hc, hcr⟩,
  exact ⟨ε', hp, (ennreal.tsum_coe_eq hc).symm ▸ lt_trans (coe_lt_coe.2 hcr) hrε⟩
end

theorem exists_pos_sum_of_encodable' {ε : ℝ≥0∞} (hε : ε ≠ 0) (ι) [encodable ι] :
  ∃ ε' : ι → ℝ≥0∞, (∀ i, 0 < ε' i) ∧ (∑' i, ε' i) < ε :=
let ⟨δ, δpos, hδ⟩ := exists_pos_sum_of_encodable hε ι in
  ⟨λ i, δ i, λ i, ennreal.coe_pos.2 (δpos i), hδ⟩

theorem exists_pos_tsum_mul_lt_of_encodable {ε : ℝ≥0∞} (hε : ε ≠ 0) {ι} [encodable ι]
  (w : ι → ℝ≥0∞) (hw : ∀ i, w i ≠ ∞) :
  ∃ δ : ι → ℝ≥0, (∀ i, 0 < δ i) ∧ ∑' i, (w i * δ i : ℝ≥0∞) < ε :=
begin
  lift w to ι → ℝ≥0 using hw,
  rcases exists_pos_sum_of_encodable hε ι with ⟨δ', Hpos, Hsum⟩,
  have : ∀ i, 0 < max 1 (w i), from λ i, zero_lt_one.trans_le (le_max_left _ _),
  refine ⟨λ i, δ' i / max 1 (w i), λ i, nnreal.div_pos (Hpos _) (this i), _⟩,
  refine lt_of_le_of_lt (ennreal.tsum_le_tsum $ λ i, _) Hsum,
  rw [coe_div (this i).ne'],
  refine mul_le_of_le_div' (ennreal.mul_le_mul le_rfl $ ennreal.inv_le_inv.2 _),
  exact coe_le_coe.2 (le_max_right _ _)
end

end ennreal

/-!
### Factorial
-/

lemma factorial_tendsto_at_top : tendsto nat.factorial at_top at_top :=
tendsto_at_top_at_top_of_monotone nat.monotone_factorial (λ n, ⟨n, n.self_le_factorial⟩)

lemma tendsto_factorial_div_pow_self_at_top : tendsto (λ n, n! / n^n : ℕ → ℝ) at_top (𝓝 0) :=
tendsto_of_tendsto_of_tendsto_of_le_of_le'
  tendsto_const_nhds
  (tendsto_const_div_at_top_nhds_0_nat 1)
  (eventually_of_forall $ λ n, div_nonneg (by exact_mod_cast n.factorial_pos.le)
    (pow_nonneg (by exact_mod_cast n.zero_le) _))
  begin
    refine (eventually_gt_at_top 0).mono (λ n hn, _),
    rcases nat.exists_eq_succ_of_ne_zero hn.ne.symm with ⟨k, rfl⟩,
    rw [← prod_range_add_one_eq_factorial, pow_eq_prod_const, div_eq_mul_inv, ← inv_eq_one_div,
      prod_nat_cast, nat.cast_succ, ← prod_inv_distrib, ← prod_mul_distrib,
      finset.prod_range_succ'],
    simp only [prod_range_succ', one_mul, nat.cast_add, zero_add, nat.cast_one],
    refine mul_le_of_le_one_left (inv_nonneg.mpr $ by exact_mod_cast hn.le) (prod_le_one _ _);
      intros x hx; rw finset.mem_range at hx,
    { refine mul_nonneg _ (inv_nonneg.mpr _); norm_cast; linarith },
    { refine (div_le_one $ by exact_mod_cast hn).mpr _, norm_cast, linarith }
  end

/-!
### Ceil and floor
-/

section

lemma tendsto_nat_floor_at_top {α : Type*} [linear_ordered_semiring α] [floor_semiring α] :
  tendsto (λ (x : α), ⌊x⌋₊) at_top at_top :=
nat.floor_mono.tendsto_at_top_at_top (λ x, ⟨max 0 (x + 1), by simp [nat.le_floor_iff]⟩)

variables {R : Type*} [topological_space R] [linear_ordered_field R] [order_topology R]
[floor_ring R]

lemma tendsto_nat_floor_mul_div_at_top {a : R} (ha : 0 ≤ a) :
  tendsto (λ x, (⌊a * x⌋₊ : R) / x) at_top (𝓝 a) :=
begin
  have A : tendsto (λ (x : R), a - x⁻¹) at_top (𝓝 (a - 0)) :=
    tendsto_const_nhds.sub tendsto_inv_at_top_zero,
  rw sub_zero at A,
  apply tendsto_of_tendsto_of_tendsto_of_le_of_le' A tendsto_const_nhds,
  { refine eventually_at_top.2 ⟨1, λ x hx, _⟩,
    simp only [le_div_iff (zero_lt_one.trans_le hx), sub_mul,
      inv_mul_cancel (zero_lt_one.trans_le hx).ne'],
    have := nat.lt_floor_add_one (a * x),
    linarith },
  { refine eventually_at_top.2 ⟨1, λ x hx, _⟩,
    rw div_le_iff (zero_lt_one.trans_le hx),
    simp [nat.floor_le (mul_nonneg ha (zero_le_one.trans hx))] }
end

lemma tendsto_nat_floor_div_at_top :
  tendsto (λ x, (⌊x⌋₊ : R) / x) at_top (𝓝 1) :=
by simpa using tendsto_nat_floor_mul_div_at_top (zero_le_one' R)

lemma tendsto_nat_ceil_mul_div_at_top {a : R} (ha : 0 ≤ a) :
  tendsto (λ x, (⌈a * x⌉₊ : R) / x) at_top (𝓝 a) :=
begin
  have A : tendsto (λ (x : R), a + x⁻¹) at_top (𝓝 (a + 0)) :=
    tendsto_const_nhds.add tendsto_inv_at_top_zero,
  rw add_zero at A,
  apply tendsto_of_tendsto_of_tendsto_of_le_of_le' tendsto_const_nhds A,
  { refine eventually_at_top.2 ⟨1, λ x hx, _⟩,
    rw le_div_iff (zero_lt_one.trans_le hx),
    exact nat.le_ceil _ },
  { refine eventually_at_top.2 ⟨1, λ x hx, _⟩,
    simp [div_le_iff (zero_lt_one.trans_le hx), inv_mul_cancel (zero_lt_one.trans_le hx).ne',
      (nat.ceil_lt_add_one ((mul_nonneg ha (zero_le_one.trans hx)))).le, add_mul] }
end

lemma tendsto_nat_ceil_div_at_top :
  tendsto (λ x, (⌈x⌉₊ : R) / x) at_top (𝓝 1) :=
by simpa using tendsto_nat_ceil_mul_div_at_top (zero_le_one' R)

end


<|start_filename|>src/analysis/special_functions/complex/log.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>
-/
import analysis.special_functions.complex.arg
import analysis.special_functions.log.basic

/-!
# The complex `log` function

Basic properties, relationship with `exp`.
-/

noncomputable theory

namespace complex

open set filter

open_locale real topological_space

/-- Inverse of the `exp` function. Returns values such that `(log x).im > - π` and `(log x).im ≤ π`.
  `log 0 = 0`-/
@[pp_nodot] noncomputable def log (x : ℂ) : ℂ := x.abs.log + arg x * I

lemma log_re (x : ℂ) : x.log.re = x.abs.log := by simp [log]

lemma log_im (x : ℂ) : x.log.im = x.arg := by simp [log]

lemma neg_pi_lt_log_im (x : ℂ) : -π < (log x).im := by simp only [log_im, neg_pi_lt_arg]
lemma log_im_le_pi (x : ℂ) : (log x).im ≤ π := by simp only [log_im, arg_le_pi]

lemma exp_log {x : ℂ} (hx : x ≠ 0) : exp (log x) = x :=
by rw [log, exp_add_mul_I, ← of_real_sin, sin_arg, ← of_real_cos, cos_arg hx,
  ← of_real_exp, real.exp_log (abs_pos.2 hx), mul_add, of_real_div, of_real_div,
  mul_div_cancel' _ (of_real_ne_zero.2 (mt abs_eq_zero.1 hx)), ← mul_assoc,
  mul_div_cancel' _ (of_real_ne_zero.2 (mt abs_eq_zero.1 hx)), re_add_im]

@[simp] lemma range_exp : range exp = {0}ᶜ :=
set.ext $ λ x, ⟨by { rintro ⟨x, rfl⟩, exact exp_ne_zero x }, λ hx, ⟨log x, exp_log hx⟩⟩

lemma log_exp {x : ℂ} (hx₁ : -π < x.im) (hx₂: x.im ≤ π) : log (exp x) = x :=
by rw [log, abs_exp, real.log_exp, exp_eq_exp_re_mul_sin_add_cos, ← of_real_exp,
  arg_mul_cos_add_sin_mul_I (real.exp_pos _) ⟨hx₁, hx₂⟩, re_add_im]

lemma exp_inj_of_neg_pi_lt_of_le_pi {x y : ℂ} (hx₁ : -π < x.im) (hx₂ : x.im ≤ π)
  (hy₁ : - π < y.im) (hy₂ : y.im ≤ π) (hxy : exp x = exp y) : x = y :=
by rw [← log_exp hx₁ hx₂, ← log_exp hy₁ hy₂, hxy]

lemma of_real_log {x : ℝ} (hx : 0 ≤ x) : (x.log : ℂ) = log x :=
complex.ext
  (by rw [log_re, of_real_re, abs_of_nonneg hx])
  (by rw [of_real_im, log_im, arg_of_real_of_nonneg hx])

lemma log_of_real_re (x : ℝ) : (log (x : ℂ)).re = real.log x := by simp [log_re]

@[simp] lemma log_zero : log 0 = 0 := by simp [log]

@[simp] lemma log_one : log 1 = 0 := by simp [log]

lemma log_neg_one : log (-1) = π * I := by simp [log]

lemma log_I : log I = π / 2 * I := by simp [log]

lemma log_neg_I : log (-I) = -(π / 2) * I := by simp [log]

lemma two_pi_I_ne_zero : (2 * π * I : ℂ) ≠ 0 :=
by norm_num [real.pi_ne_zero, I_ne_zero]

lemma exp_eq_one_iff {x : ℂ} : exp x = 1 ↔ ∃ n : ℤ, x = n * ((2 * π) * I) :=
begin
  split,
  { intro h,
    rcases exists_unique_add_zsmul_mem_Ioc real.two_pi_pos x.im (-π) with ⟨n, hn, -⟩,
    use -n,
    rw [int.cast_neg, neg_mul, eq_neg_iff_add_eq_zero],
    have : (x + n * (2 * π * I)).im ∈ Ioc (-π) π, by simpa [two_mul, mul_add] using hn,
    rw [← log_exp this.1 this.2, exp_periodic.int_mul n, h, log_one] },
  { rintro ⟨n, rfl⟩, exact (exp_periodic.int_mul n).eq.trans exp_zero }
end

lemma exp_eq_exp_iff_exp_sub_eq_one {x y : ℂ} : exp x = exp y ↔ exp (x - y) = 1 :=
by rw [exp_sub, div_eq_one_iff_eq (exp_ne_zero _)]

lemma exp_eq_exp_iff_exists_int {x y : ℂ} : exp x = exp y ↔ ∃ n : ℤ, x = y + n * ((2 * π) * I) :=
by simp only [exp_eq_exp_iff_exp_sub_eq_one, exp_eq_one_iff, sub_eq_iff_eq_add']

@[simp] lemma countable_preimage_exp {s : set ℂ} : countable (exp ⁻¹' s) ↔ countable s :=
begin
  refine ⟨λ hs, _, λ hs, _⟩,
  { refine ((hs.image exp).insert 0).mono _,
    rw [image_preimage_eq_inter_range, range_exp, ← diff_eq, ← union_singleton, diff_union_self],
    exact subset_union_left _ _ },
  { rw ← bUnion_preimage_singleton,
    refine hs.bUnion (λ z hz, _),
    rcases em (∃ w, exp w = z) with ⟨w, rfl⟩|hne,
    { simp only [preimage, mem_singleton_iff, exp_eq_exp_iff_exists_int, set_of_exists],
      exact countable_Union (λ m, countable_singleton _) },
    { push_neg at hne, simp [preimage, hne] } }
end

alias countable_preimage_exp ↔ _ set.countable.preimage_cexp

lemma tendsto_log_nhds_within_im_neg_of_re_neg_of_im_zero
  {z : ℂ} (hre : z.re < 0) (him : z.im = 0) :
  tendsto log (𝓝[{z : ℂ | z.im < 0}] z) (𝓝 $ real.log (abs z) - π * I) :=
begin
  have := (continuous_of_real.continuous_at.comp_continuous_within_at
    (continuous_abs.continuous_within_at.log _)).tendsto.add
    (((continuous_of_real.tendsto _).comp $
    tendsto_arg_nhds_within_im_neg_of_re_neg_of_im_zero hre him).mul tendsto_const_nhds),
  convert this,
  { simp [sub_eq_add_neg] },
  { lift z to ℝ using him, simpa using hre.ne }
end

lemma continuous_within_at_log_of_re_neg_of_im_zero
  {z : ℂ} (hre : z.re < 0) (him : z.im = 0) :
  continuous_within_at log {z : ℂ | 0 ≤ z.im} z :=
begin
  have := (continuous_of_real.continuous_at.comp_continuous_within_at
    (continuous_abs.continuous_within_at.log _)).tendsto.add
    ((continuous_of_real.continuous_at.comp_continuous_within_at $
    continuous_within_at_arg_of_re_neg_of_im_zero hre him).mul tendsto_const_nhds),
  convert this,
  { lift z to ℝ using him, simpa using hre.ne }
end

lemma tendsto_log_nhds_within_im_nonneg_of_re_neg_of_im_zero
  {z : ℂ} (hre : z.re < 0) (him : z.im = 0) :
  tendsto log (𝓝[{z : ℂ | 0 ≤ z.im}] z) (𝓝 $ real.log (abs z) + π * I) :=
by simpa only [log, arg_eq_pi_iff.2 ⟨hre, him⟩]
  using (continuous_within_at_log_of_re_neg_of_im_zero hre him).tendsto

@[simp] lemma map_exp_comap_re_at_bot : map exp (comap re at_bot) = 𝓝[≠] 0 :=
by rw [← comap_exp_nhds_zero, map_comap, range_exp, nhds_within]

@[simp] lemma map_exp_comap_re_at_top : map exp (comap re at_top) = comap abs at_top :=
begin
  rw [← comap_exp_comap_abs_at_top, map_comap, range_exp, inf_eq_left, le_principal_iff],
  exact eventually_ne_of_tendsto_norm_at_top tendsto_comap 0
end

end complex

section log_deriv

open complex filter
open_locale topological_space

variables {α : Type*}

lemma continuous_at_clog {x : ℂ} (h : 0 < x.re ∨ x.im ≠ 0) :
  continuous_at log x :=
begin
  refine continuous_at.add _ _,
  { refine continuous_of_real.continuous_at.comp _,
    refine (real.continuous_at_log _).comp complex.continuous_abs.continuous_at,
    rw abs_ne_zero,
    rintro rfl,
    simpa using h },
  { have h_cont_mul : continuous (λ x : ℂ, x * I), from continuous_id'.mul continuous_const,
    refine h_cont_mul.continuous_at.comp (continuous_of_real.continuous_at.comp _),
    exact continuous_at_arg h, },
end

lemma filter.tendsto.clog {l : filter α} {f : α → ℂ} {x : ℂ} (h : tendsto f l (𝓝 x))
  (hx : 0 < x.re ∨ x.im ≠ 0) :
  tendsto (λ t, log (f t)) l (𝓝 $ log x) :=
(continuous_at_clog hx).tendsto.comp h

variables [topological_space α]

lemma continuous_at.clog {f : α → ℂ} {x : α} (h₁ : continuous_at f x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous_at (λ t, log (f t)) x :=
h₁.clog h₂

lemma continuous_within_at.clog {f : α → ℂ} {s : set α} {x : α} (h₁ : continuous_within_at f s x)
  (h₂ : 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous_within_at (λ t, log (f t)) s x :=
h₁.clog h₂

lemma continuous_on.clog {f : α → ℂ} {s : set α} (h₁ : continuous_on f s)
  (h₂ : ∀ x ∈ s, 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous_on (λ t, log (f t)) s :=
λ x hx, (h₁ x hx).clog (h₂ x hx)

lemma continuous.clog {f : α → ℂ} (h₁ : continuous f) (h₂ : ∀ x, 0 < (f x).re ∨ (f x).im ≠ 0) :
  continuous (λ t, log (f t)) :=
continuous_iff_continuous_at.2 $ λ x, h₁.continuous_at.clog (h₂ x)

end log_deriv


<|start_filename|>src/category_theory/limits/bicones.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.limits.cones
import category_theory.structured_arrow
import category_theory.fin_category

/-!
# Bicones

Given a category `J`, a walking `bicone J` is a category whose objects are the objects of `J` and
two extra vertices `bicone.left` and `bicone.right`. The morphisms are the morphisms of `J` and
`left ⟶ j`, `right ⟶ j` for each `j : J` such that `⬝ ⟶ j` and `⬝ ⟶ k` commutes with each
`f : j ⟶ k`.

Given a diagram `F : J ⥤ C` and two `cone F`s, we can join them into a diagram `bicone J ⥤ C` via
`bicone_mk`.

This is used in `category_theory.flat_functors.preserves_finite_limits_of_flat`.
-/

universes v₁ u₁

noncomputable theory

open category_theory.limits
open_locale classical

namespace category_theory
section bicone
variables (J : Type u₁)

/-- Given a category `J`, construct a walking `bicone J` by adjoining two elements. -/
@[derive decidable_eq]
inductive bicone
| left : bicone
| right : bicone
| diagram (val : J) : bicone

instance : inhabited (bicone J) := ⟨bicone.left⟩

instance fin_bicone [fintype J] : fintype (bicone J) :=
{ elems := [bicone.left, bicone.right].to_finset ∪ finset.image bicone.diagram (fintype.elems J),
  complete := λ j, by { cases j; simp, exact fintype.complete j, }, }

variables [category.{v₁} J]

/-- The homs for a walking `bicone J`. -/
inductive bicone_hom : bicone J → bicone J → Type (max u₁ v₁)
| left_id  : bicone_hom bicone.left bicone.left
| right_id : bicone_hom bicone.right bicone.right
| left (j : J) : bicone_hom bicone.left (bicone.diagram j)
| right (j : J) : bicone_hom bicone.right (bicone.diagram j)
| diagram {j k : J} (f : j ⟶ k) : bicone_hom (bicone.diagram j) (bicone.diagram k)

instance : inhabited (bicone_hom J bicone.left bicone.left) := ⟨bicone_hom.left_id⟩

instance bicone_hom.decidable_eq {j k : bicone J} : decidable_eq (bicone_hom J j k) :=
λ f g, by { cases f; cases g; simp; apply_instance }

@[simps]
instance bicone_category_struct : category_struct (bicone J) :=
{ hom := bicone_hom J,
  id := λ j, bicone.cases_on j
    bicone_hom.left_id bicone_hom.right_id (λ k, bicone_hom.diagram (𝟙 k)),
  comp := λ X Y Z f g, by
  { cases f, exact g, exact g,
    cases g, exact bicone_hom.left g_k,
    cases g, exact bicone_hom.right g_k,
    cases g, exact bicone_hom.diagram (f_f ≫ g_f) } }

instance bicone_category : category (bicone J) :=
{ id_comp' := λ X Y f, by { cases f; simp },
  comp_id' := λ X Y f, by { cases f; simp },
  assoc' := λ W X Y Z f g h, by { cases f; cases g; cases h; simp } }

end bicone
section small_category
variables (J : Type v₁) [small_category J]

/--
Given a diagram `F : J ⥤ C` and two `cone F`s, we can join them into a diagram `bicone J ⥤ C`.
-/
@[simps] def bicone_mk {C : Type u₁} [category.{v₁} C]
  {F : J ⥤ C} (c₁ c₂ : cone F) : bicone J ⥤ C :=
{ obj := λ X, bicone.cases_on X c₁.X c₂.X (λ j, F.obj j),
  map := λ X Y f, by
  { cases f, exact (𝟙 _), exact (𝟙 _),
    exact c₁.π.app f_1,
    exact c₂.π.app f_1,
    exact F.map f_f, },
  map_id' := λ X, by { cases X; simp },
  map_comp' := λ X Y Z f g, by
  { cases f,
    exact (category.id_comp _).symm,
    exact (category.id_comp _).symm,
    cases g, exact (category.id_comp _).symm.trans (c₁.π.naturality g_f : _),
    cases g, exact (category.id_comp _).symm.trans (c₂.π.naturality g_f : _),
    cases g, exact F.map_comp _ _ } }

instance fin_bicone_hom [fin_category J] (j k : bicone J) : fintype (j ⟶ k) :=
begin
  cases j; cases k,
  exact { elems := {bicone_hom.left_id}, complete := λ f, by { cases f, simp } },
  exact { elems := ∅, complete := λ f, by { cases f } },
  exact { elems := {bicone_hom.left k}, complete := λ f, by { cases f, simp } },
  exact { elems := ∅, complete := λ f, by { cases f } },
  exact { elems := {bicone_hom.right_id}, complete := λ f, by { cases f, simp } },
  exact { elems := {bicone_hom.right k}, complete := λ f, by { cases f, simp } },
  exact { elems := ∅, complete := λ f, by { cases f } },
  exact { elems := ∅, complete := λ f, by { cases f } },
  exact { elems := finset.image (bicone_hom.diagram) (fintype.elems (j ⟶ k)),
          complete := λ f, by
            { cases f, simp only [finset.mem_image], use f_f, simpa using fintype.complete _, } },
end

instance bicone_small_category : small_category (bicone J) :=
category_theory.bicone_category J

instance bicone_fin_category [fin_category J] : fin_category (bicone J) := {}
end small_category
end category_theory


<|start_filename|>src/deprecated/submonoid.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>
-/
import group_theory.submonoid.basic
import algebra.big_operators.basic
import deprecated.group

/-!
# Unbundled submonoids (deprecated)

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines unbundled multiplicative and additive submonoids. Instead of using this file,
please use `submonoid G` and `add_submonoid A`, defined in `group_theory.submonoid.basic`.

## Main definitions

`is_add_submonoid (S : set M)` : the predicate that `S` is the underlying subset of an additive
submonoid of `M`. The bundled variant `add_submonoid M` should be used in preference to this.

`is_submonoid (S : set M)` : the predicate that `S` is the underlying subset of a submonoid
of `M`. The bundled variant `submonoid M` should be used in preference to this.

## Tags
submonoid, submonoids, is_submonoid
-/

open_locale big_operators

variables {M : Type*} [monoid M] {s : set M}
variables {A : Type*} [add_monoid A] {t : set A}

/-- `s` is an additive submonoid: a set containing 0 and closed under addition.
Note that this structure is deprecated, and the bundled variant `add_submonoid A` should be
preferred. -/
structure is_add_submonoid (s : set A) : Prop :=
(zero_mem : (0:A) ∈ s)
(add_mem {a b} : a ∈ s → b ∈ s → a + b ∈ s)

/-- `s` is a submonoid: a set containing 1 and closed under multiplication.
Note that this structure is deprecated, and the bundled variant `submonoid M` should be
preferred. -/
@[to_additive]
structure is_submonoid (s : set M) : Prop :=
(one_mem : (1:M) ∈ s)
(mul_mem {a b} : a ∈ s → b ∈ s → a * b ∈ s)

lemma additive.is_add_submonoid
  {s : set M} : ∀ (is : is_submonoid s), @is_add_submonoid (additive M) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem additive.is_add_submonoid_iff
  {s : set M} : @is_add_submonoid (additive M) _ s ↔ is_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, additive.is_add_submonoid⟩

lemma multiplicative.is_submonoid
  {s : set A} : ∀ (is : is_add_submonoid s), @is_submonoid (multiplicative A) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem multiplicative.is_submonoid_iff
  {s : set A} : @is_submonoid (multiplicative A) _ s ↔ is_add_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, multiplicative.is_submonoid⟩

/-- The intersection of two submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of two `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of M."]
lemma is_submonoid.inter {s₁ s₂ : set M} (is₁ : is_submonoid s₁) (is₂ : is_submonoid s₂) :
  is_submonoid (s₁ ∩ s₂) :=
{ one_mem := ⟨is₁.one_mem, is₂.one_mem⟩,
  mul_mem := λ x y hx hy,
    ⟨is₁.mul_mem hx.1 hy.1, is₂.mul_mem hx.2 hy.2⟩ }

/-- The intersection of an indexed set of submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of an indexed set of `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of `M`."]
lemma is_submonoid.Inter {ι : Sort*} {s : ι → set M} (h : ∀ y : ι, is_submonoid (s y)) :
  is_submonoid (set.Inter s) :=
{ one_mem := set.mem_Inter.2 $ λ y, (h y).one_mem,
  mul_mem := λ x₁ x₂ h₁ h₂, set.mem_Inter.2 $
    λ y, (h y).mul_mem (set.mem_Inter.1 h₁ y) (set.mem_Inter.1 h₂ y) }

/-- The union of an indexed, directed, nonempty set of submonoids of a monoid `M` is a submonoid
    of `M`. -/
@[to_additive "The union of an indexed, directed, nonempty set
of `add_submonoid`s of an `add_monoid` `M` is an `add_submonoid` of `M`. "]
lemma is_submonoid_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set M} (hs : ∀ i, is_submonoid (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_submonoid (⋃i, s i) :=
{ one_mem := let ⟨i⟩ := hι in set.mem_Union.2 ⟨i, (hs i).one_mem⟩,
  mul_mem := λ a b ha hb,
    let ⟨i, hi⟩ := set.mem_Union.1 ha in
    let ⟨j, hj⟩ := set.mem_Union.1 hb in
    let ⟨k, hk⟩ := directed i j in
    set.mem_Union.2 ⟨k, (hs k).mul_mem (hk.1 hi) (hk.2 hj)⟩ }

section powers

/-- The set of natural number powers `1, x, x², ...` of an element `x` of a monoid. -/
@[to_additive multiples
"The set of natural number multiples `0, x, 2x, ...` of an element `x` of an `add_monoid`."]
def powers (x : M) : set M := {y | ∃ n:ℕ, x^n = y}

/-- 1 is in the set of natural number powers of an element of a monoid. -/
@[to_additive "0 is in the set of natural number multiples of an element of an `add_monoid`."]
lemma powers.one_mem {x : M} : (1 : M) ∈ powers x := ⟨0, pow_zero _⟩

/-- An element of a monoid is in the set of that element's natural number powers. -/
@[to_additive
"An element of an `add_monoid` is in the set of that element's natural number multiples."]
lemma powers.self_mem {x : M} : x ∈ powers x := ⟨1, pow_one _⟩

/-- The set of natural number powers of an element of a monoid is closed under multiplication. -/
@[to_additive
"The set of natural number multiples of an element of an `add_monoid` is closed under addition."]
lemma powers.mul_mem {x y z : M} : (y ∈ powers x) → (z ∈ powers x) → (y * z ∈ powers x) :=
λ ⟨n₁, h₁⟩ ⟨n₂, h₂⟩, ⟨n₁ + n₂, by simp only [pow_add, *]⟩

/-- The set of natural number powers of an element of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The set of natural number multiples of an element of
an `add_monoid` `M` is an `add_submonoid` of `M`."]
lemma powers.is_submonoid (x : M) : is_submonoid (powers x) :=
{ one_mem := powers.one_mem,
  mul_mem := λ y z, powers.mul_mem }

/-- A monoid is a submonoid of itself. -/
@[to_additive "An `add_monoid` is an `add_submonoid` of itself."]
lemma univ.is_submonoid : is_submonoid (@set.univ M) := by split; simp

/-- The preimage of a submonoid under a monoid hom is a submonoid of the domain. -/
@[to_additive "The preimage of an `add_submonoid` under an `add_monoid` hom is
an `add_submonoid` of the domain."]
lemma is_submonoid.preimage {N : Type*} [monoid N] {f : M → N} (hf : is_monoid_hom f)
  {s : set N} (hs : is_submonoid s) : is_submonoid (f ⁻¹' s) :=
{ one_mem := show f 1 ∈ s, by rw is_monoid_hom.map_one hf; exact hs.one_mem,
  mul_mem := λ a b (ha : f a ∈ s) (hb : f b ∈ s),
    show f (a * b) ∈ s, by rw is_monoid_hom.map_mul hf; exact hs.mul_mem ha hb }

/-- The image of a submonoid under a monoid hom is a submonoid of the codomain. -/
@[to_additive "The image of an `add_submonoid` under an `add_monoid`
hom is an `add_submonoid` of the codomain."]
lemma is_submonoid.image {γ : Type*} [monoid γ] {f : M → γ} (hf : is_monoid_hom f)
  {s : set M} (hs : is_submonoid s) : is_submonoid (f '' s) :=
{ one_mem := ⟨1, hs.one_mem, hf.map_one⟩,
  mul_mem := λ a b ⟨x, hx⟩ ⟨y, hy⟩, ⟨x * y, hs.mul_mem hx.1 hy.1,
    by rw [hf.map_mul, hx.2, hy.2]⟩ }

/-- The image of a monoid hom is a submonoid of the codomain. -/
@[to_additive "The image of an `add_monoid` hom is an `add_submonoid`
of the codomain."]
lemma range.is_submonoid {γ : Type*} [monoid γ] {f : M → γ} (hf : is_monoid_hom f) :
  is_submonoid (set.range f) :=
by { rw ← set.image_univ, exact univ.is_submonoid.image hf }

/-- Submonoids are closed under natural powers. -/
@[to_additive is_add_submonoid.smul_mem
"An `add_submonoid` is closed under multiplication by naturals."]
lemma is_submonoid.pow_mem {a : M} (hs : is_submonoid s) (h : a ∈ s) : ∀ {n : ℕ}, a ^ n ∈ s
| 0 := by { rw pow_zero, exact hs.one_mem }
| (n + 1) := by { rw pow_succ, exact hs.mul_mem h is_submonoid.pow_mem }

/-- The set of natural number powers of an element of a submonoid is a subset of the submonoid. -/
@[to_additive is_add_submonoid.multiples_subset "The set of natural number multiples of an element
of an `add_submonoid` is a subset of the `add_submonoid`."]
lemma is_submonoid.power_subset {a : M} (hs : is_submonoid s) (h : a ∈ s) : powers a ⊆ s :=
assume x ⟨n, hx⟩, hx ▸ hs.pow_mem h

end powers

namespace is_submonoid

/-- The product of a list of elements of a submonoid is an element of the submonoid. -/
@[to_additive "The sum of a list of elements of an `add_submonoid` is an element of the
`add_submonoid`."]
lemma list_prod_mem (hs : is_submonoid s) : ∀{l : list M}, (∀x∈l, x ∈ s) → l.prod ∈ s
| []     h := hs.one_mem
| (a::l) h :=
  suffices a * l.prod ∈ s, by simpa,
  have a ∈ s ∧ (∀x∈l, x ∈ s), by simpa using h,
  hs.mul_mem this.1 (list_prod_mem this.2)

/-- The product of a multiset of elements of a submonoid of a `comm_monoid` is an element of
the submonoid. -/
@[to_additive "The sum of a multiset of elements of an `add_submonoid` of an `add_comm_monoid`
is an element of the `add_submonoid`. "]
lemma multiset_prod_mem {M} [comm_monoid M] {s : set M} (hs : is_submonoid s) (m : multiset M) :
  (∀a∈m, a ∈ s) → m.prod ∈ s :=
begin
  refine quotient.induction_on m (assume l hl, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod],
  exact list_prod_mem hs hl
end

/-- The product of elements of a submonoid of a `comm_monoid` indexed by a `finset` is an element
of the submonoid. -/
@[to_additive "The sum of elements of an `add_submonoid` of an `add_comm_monoid` indexed by
a `finset` is an element of the `add_submonoid`."]
lemma finset_prod_mem {M A} [comm_monoid M] {s : set M} (hs : is_submonoid s) (f : A → M) :
  ∀(t : finset A), (∀b∈t, f b ∈ s) → ∏ b in t, f b ∈ s
| ⟨m, hm⟩ _ := multiset_prod_mem hs _ (by simpa)

end is_submonoid

namespace add_monoid

/-- The inductively defined membership predicate for the submonoid generated by a subset of a
    monoid. -/
inductive in_closure (s : set A) : A → Prop
| basic {a : A} : a ∈ s → in_closure a
| zero : in_closure 0
| add {a b : A} : in_closure a → in_closure b → in_closure (a + b)

end add_monoid

namespace monoid

/-- The inductively defined membership predicate for the `submonoid` generated by a subset of an
    monoid. -/
@[to_additive]
inductive in_closure (s : set M) : M → Prop
| basic {a : M} : a ∈ s → in_closure a
| one : in_closure 1
| mul {a b : M} : in_closure a → in_closure b → in_closure (a * b)

/-- The inductively defined submonoid generated by a subset of a monoid. -/
@[to_additive "The inductively defined `add_submonoid` genrated by a subset of an `add_monoid`."]
def closure (s : set M) : set M := {a | in_closure s a }

@[to_additive]
lemma closure.is_submonoid (s : set M) : is_submonoid (closure s) :=
{ one_mem := in_closure.one, mul_mem := assume a b, in_closure.mul }

/-- A subset of a monoid is contained in the submonoid it generates. -/
@[to_additive "A subset of an `add_monoid` is contained in the `add_submonoid` it generates."]
theorem subset_closure {s : set M} : s ⊆ closure s :=
assume a, in_closure.basic

/-- The submonoid generated by a set is contained in any submonoid that contains the set. -/
@[to_additive "The `add_submonoid` generated by a set is contained in any `add_submonoid` that
contains the set."]
theorem closure_subset {s t : set M} (ht : is_submonoid t) (h : s ⊆ t) : closure s ⊆ t :=
assume a ha, by induction ha; simp [h _, *, is_submonoid.one_mem, is_submonoid.mul_mem]

/-- Given subsets `t` and `s` of a monoid `M`, if `s ⊆ t`, the submonoid of `M` generated by `s` is
    contained in the submonoid generated by `t`. -/
@[to_additive "Given subsets `t` and `s` of an `add_monoid M`, if `s ⊆ t`, the `add_submonoid`
of `M` generated by `s` is contained in the `add_submonoid` generated by `t`."]
theorem closure_mono {s t : set M} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset (closure.is_submonoid t) $ set.subset.trans h subset_closure

/-- The submonoid generated by an element of a monoid equals the set of natural number powers of
    the element. -/
@[to_additive "The `add_submonoid` generated by an element of an `add_monoid` equals the set of
natural number multiples of the element."]
theorem closure_singleton {x : M} : closure ({x} : set M) = powers x :=
set.eq_of_subset_of_subset (closure_subset (powers.is_submonoid x) $ set.singleton_subset_iff.2 $
  powers.self_mem) $ is_submonoid.power_subset (closure.is_submonoid _) $
  set.singleton_subset_iff.1 $ subset_closure

/-- The image under a monoid hom of the submonoid generated by a set equals the submonoid generated
    by the image of the set under the monoid hom. -/
@[to_additive "The image under an `add_monoid` hom of the `add_submonoid` generated by a set equals
the `add_submonoid` generated by the image of the set under the `add_monoid` hom."]
lemma image_closure {A : Type*} [monoid A] {f : M → A} (hf : is_monoid_hom f) (s : set M) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [hf.map_one], apply is_submonoid.one_mem (closure.is_submonoid (f '' s))},
    { rw [hf.map_mul], solve_by_elim [(closure.is_submonoid _).mul_mem] }
  end
  (closure_subset (is_submonoid.image hf (closure.is_submonoid _)) $
    set.image_subset _ subset_closure)

/-- Given an element `a` of the submonoid of a monoid `M` generated by a set `s`, there exists
a list of elements of `s` whose product is `a`. -/
@[to_additive "Given an element `a` of the `add_submonoid` of an `add_monoid M` generated by
a set `s`, there exists a list of elements of `s` whose sum is `a`."]
theorem exists_list_of_mem_closure {s : set M} {a : M} (h : a ∈ closure s) :
  (∃l:list M, (∀x∈l, x ∈ s) ∧ l.prod = a) :=
begin
  induction h,
  case in_closure.basic : a ha { existsi ([a]), simp [ha] },
  case in_closure.one { existsi ([]), simp },
  case in_closure.mul : a b _ _ ha hb
  { rcases ha with ⟨la, ha, eqa⟩,
    rcases hb with ⟨lb, hb, eqb⟩,
    existsi (la ++ lb),
    simp [eqa.symm, eqb.symm, or_imp_distrib],
    exact assume a, ⟨ha a, hb a⟩ }
end

/-- Given sets `s, t` of a commutative monoid `M`, `x ∈ M` is in the submonoid of `M` generated by
    `s ∪ t` iff there exists an element of the submonoid generated by `s` and an element of the
    submonoid generated by `t` whose product is `x`. -/
@[to_additive "Given sets `s, t` of a commutative `add_monoid M`, `x ∈ M` is in the `add_submonoid`
of `M` generated by `s ∪ t` iff there exists an element of the `add_submonoid` generated by `s`
and an element of the `add_submonoid` generated by `t` whose sum is `x`."]
theorem mem_closure_union_iff {M : Type*} [comm_monoid M] {s t : set M} {x : M} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y * z = x :=
⟨λ hx, let ⟨L, HL1, HL2⟩ := exists_list_of_mem_closure hx in HL2 ▸
  list.rec_on L (λ _, ⟨1, (closure.is_submonoid _).one_mem, 1,
    (closure.is_submonoid _).one_mem, mul_one _⟩)
    (λ hd tl ih HL1, let ⟨y, hy, z, hz, hyzx⟩ := ih (list.forall_mem_of_forall_mem_cons HL1) in
      or.cases_on (HL1 hd $ list.mem_cons_self _ _)
        (λ hs, ⟨hd * y, (closure.is_submonoid _).mul_mem (subset_closure hs) hy, z, hz,
          by rw [mul_assoc, list.prod_cons, ← hyzx]; refl⟩)
        (λ ht, ⟨y, hy, z * hd, (closure.is_submonoid _).mul_mem hz (subset_closure ht),
          by rw [← mul_assoc, list.prod_cons, ← hyzx, mul_comm hd]; refl⟩)) HL1,
λ ⟨y, hy, z, hz, hyzx⟩, hyzx ▸ (closure.is_submonoid _).mul_mem
  (closure_mono (set.subset_union_left _ _) hy)
  (closure_mono (set.subset_union_right _ _) hz)⟩

end monoid

/-- Create a bundled submonoid from a set `s` and `[is_submonoid s]`. -/
@[to_additive "Create a bundled additive submonoid from a set `s` and `[is_add_submonoid s]`."]
def submonoid.of {s : set M} (h : is_submonoid s) : submonoid M := ⟨s, h.2, h.1⟩

@[to_additive]
lemma submonoid.is_submonoid (S : submonoid M) : is_submonoid (S : set M) := ⟨S.3, S.2⟩


<|start_filename|>src/data/pi/lex.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import order.well_founded
import algebra.group.pi
import order.min_max

/-!
# Lexicographic order on Pi types

This file defines the lexicographic order for Pi types. `a` is less than `b` if `a i = b i` for all
`i` up to some point `k`, and `a k < b k`.

## Notation

* `Πₗ i, α i`: Pi type equipped with the lexicographic order. Type synonym of `Π i, α i`.

## See also

Related files are:
* `data.finset.colex`: Colexicographic order on finite sets.
* `data.list.lex`: Lexicographic order on lists.
* `data.sigma.order`: Lexicographic order on `Σₗ i, α i`.
* `data.psigma.order`: Lexicographic order on `Σₗ' i, α i`.
* `data.prod.lex`: Lexicographic order on `α × β`.
-/

variables {ι : Type*} {β : ι → Type*} (r : ι → ι → Prop)
  (s : Π {i}, β i → β i → Prop)

namespace pi

instance {α : Type*} : Π [inhabited α], inhabited (lex α) := id

/-- The lexicographic relation on `Π i : ι, β i`, where `ι` is ordered by `r`,
  and each `β i` is ordered by `s`. -/
protected def lex (x y : Π i, β i) : Prop :=
∃ i, (∀ j, r j i → x j = y j) ∧ s (x i) (y i)

/- This unfortunately results in a type that isn't delta-reduced, so we keep the notation out of the
basic API, just in case -/
notation `Πₗ` binders `, ` r:(scoped p, lex (Π i, p i)) := r

@[simp] lemma to_lex_apply (x : Π i, β i) (i : ι) : to_lex x i = x i := rfl
@[simp] lemma of_lex_apply (x : lex (Π i, β i)) (i : ι) : of_lex x i = x i := rfl

lemma is_trichotomous_lex [∀ i, is_trichotomous (β i) s] (wf : well_founded r) :
  is_trichotomous (Π i, β i) (pi.lex r @s) :=
{ trichotomous := λ a b,
    begin
      cases eq_or_ne a b with hab hab,
      { exact or.inr (or.inl hab) },
      { rw function.ne_iff at hab,
        let i := wf.min _ hab,
        have hri : ∀ j, r j i → a j = b j,
        { intro j, rw ← not_imp_not,
          exact λ h', wf.not_lt_min _ _ h' },
        have hne : a i ≠ b i, from wf.min_mem _ hab,
        cases trichotomous_of s (a i) (b i) with hi hi,
        exacts [or.inl ⟨i, hri, hi⟩,
          or.inr $ or.inr $ ⟨i, λ j hj, (hri j hj).symm, hi.resolve_left hne⟩] },
    end }

instance [has_lt ι] [Π a, has_lt (β a)] : has_lt (lex (Π i, β i)) := ⟨pi.lex (<) (λ _, (<))⟩

instance lex.is_strict_order [linear_order ι] [∀ a, partial_order (β a)] :
  is_strict_order (lex (Π i, β i)) (<) :=
{ irrefl := λ a ⟨k, hk₁, hk₂⟩, lt_irrefl (a k) hk₂,
  trans :=
    begin
      rintro a b c ⟨N₁, lt_N₁, a_lt_b⟩ ⟨N₂, lt_N₂, b_lt_c⟩,
      rcases lt_trichotomy N₁ N₂ with (H|rfl|H),
      exacts [⟨N₁, λ j hj, (lt_N₁ _ hj).trans (lt_N₂ _ $ hj.trans H), lt_N₂ _ H ▸ a_lt_b⟩,
        ⟨N₁, λ j hj, (lt_N₁ _ hj).trans (lt_N₂ _ hj), a_lt_b.trans b_lt_c⟩,
        ⟨N₂, λ j hj, (lt_N₁ _ (hj.trans H)).trans (lt_N₂ _ hj), (lt_N₁ _ H).symm ▸ b_lt_c⟩]
    end }

instance [linear_order ι] [Π a, partial_order (β a)] : partial_order (lex (Π i, β i)) :=
partial_order_of_SO (<)

/-- `Πₗ i, α i` is a linear order if the original order is well-founded. -/
noncomputable instance [linear_order ι] [is_well_order ι (<)] [∀ a, linear_order (β a)] :
  linear_order (lex (Π i, β i)) :=
@linear_order_of_STO' (Πₗ i, β i) (<)
  { to_is_trichotomous := is_trichotomous_lex _ _ is_well_order.wf } (classical.dec_rel _)

lemma lex.le_of_forall_le [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  {a b : lex (Π i, β i)} (h : ∀ i, a i ≤ b i) : a ≤ b :=
le_of_not_lt (λ ⟨i, hi⟩, (h i).not_lt hi.2)

lemma lex.le_of_of_lex_le [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  {a b : lex (Π i, β i)} (h : of_lex a ≤ of_lex b) : a ≤ b :=
lex.le_of_forall_le h

lemma to_lex_monotone [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)] :
  monotone (@to_lex (Π i, β i)) :=
λ _ _, lex.le_of_forall_le

instance [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  [Π a, order_bot (β a)] : order_bot (lex (Π a, β a)) :=
{ bot := to_lex ⊥,
  bot_le := λ f, lex.le_of_of_lex_le bot_le }

instance [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  [Π a, order_top (β a)] : order_top (lex (Π a, β a)) :=
{ top := to_lex ⊤,
  le_top := λ f, lex.le_of_of_lex_le le_top }

instance [linear_order ι] [is_well_order ι (<)] [Π a, linear_order (β a)]
  [Π a, bounded_order (β a)] : bounded_order (lex (Π a, β a)) :=
{ .. pi.lex.order_bot, .. pi.lex.order_top }

--we might want the analog of `pi.ordered_cancel_comm_monoid` as well in the future
@[to_additive]
instance lex.ordered_comm_group [linear_order ι] [∀ a, ordered_comm_group (β a)] :
  ordered_comm_group (lex (Π i, β i)) :=
{ mul_le_mul_left := λ x y hxy z,
    hxy.elim
      (λ hxyz, hxyz ▸ le_rfl)
      (λ ⟨i, hi⟩,
        or.inr ⟨i, λ j hji, show z j * x j = z j * y j, by rw hi.1 j hji,
          mul_lt_mul_left' hi.2 _⟩),
  ..pi.lex.partial_order,
  ..pi.comm_group }

end pi


<|start_filename|>counterexamples/direct_sum_is_internal.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import algebra.direct_sum.module
import tactic.fin_cases

/-!
# Not all complementary decompositions of a module over a semiring make up a direct sum

This shows that while `ℤ≤0` and `ℤ≥0` are complementary `ℕ`-submodules of `ℤ`, which in turn
implies as a collection they are `complete_lattice.independent` and that they span all of `ℤ`, they
do not form a decomposition into a direct sum.

This file demonstrates why `direct_sum.is_internal_submodule_of_independent_of_supr_eq_top` must
take `ring R` and not `semiring R`.
-/

lemma units_int.one_ne_neg_one : (1 : ℤˣ) ≠ -1 := dec_trivial

/-- Submodules of positive and negative integers, keyed by sign. -/
def with_sign (i : ℤˣ) : submodule ℕ ℤ :=
add_submonoid.to_nat_submodule $ show add_submonoid ℤ, from
  { carrier := {z | 0 ≤ i • z},
    zero_mem' := show 0 ≤ i • (0 : ℤ), from (smul_zero _).ge,
    add_mem' := λ x y (hx : 0 ≤ i • x) (hy : 0 ≤ i • y), show _ ≤ _, begin
      rw smul_add,
      exact add_nonneg hx hy
    end }

local notation `ℤ≥0` := with_sign 1
local notation `ℤ≤0` := with_sign (-1)

lemma mem_with_sign_one {x : ℤ} : x ∈ ℤ≥0 ↔ 0 ≤ x :=
show _ ≤ _ ↔ _, by rw one_smul

lemma mem_with_sign_neg_one {x : ℤ} : x ∈ ℤ≤0 ↔ x ≤ 0 :=
show _ ≤ _ ↔ _, by rw [units.neg_smul, le_neg, one_smul, neg_zero]

/-- The two submodules are complements. -/
lemma with_sign.is_compl : is_compl (ℤ≥0) (ℤ≤0) :=
begin
  split,
  { apply submodule.disjoint_def.2,
    intros x hx hx',
    exact le_antisymm (mem_with_sign_neg_one.mp hx') (mem_with_sign_one.mp hx), },
  { intros x hx,
    obtain hp | hn := (le_refl (0 : ℤ)).le_or_le x,
    exact submodule.mem_sup_left (mem_with_sign_one.mpr hp),
    exact submodule.mem_sup_right (mem_with_sign_neg_one.mpr hn), }
end

def with_sign.independent : complete_lattice.independent with_sign :=
begin
  refine (complete_lattice.independent_pair units_int.one_ne_neg_one _).mpr
    with_sign.is_compl.disjoint,
  intros i,
  fin_cases i; simp,
end

lemma with_sign.supr : supr with_sign = ⊤ :=
begin
  rw [←finset.sup_univ_eq_supr, units_int.univ, finset.sup_insert, finset.sup_singleton],
  exact with_sign.is_compl.sup_eq_top,
end

/-- But there is no embedding into `ℤ` from the direct sum. -/
lemma with_sign.not_injective :
  ¬function.injective (direct_sum.to_module ℕ ℤˣ ℤ (λ i, (with_sign i).subtype)) :=
begin
  intro hinj,
  let p1 : ℤ≥0 := ⟨1, mem_with_sign_one.2 zero_le_one⟩,
  let n1 : ℤ≤0 := ⟨-1, mem_with_sign_neg_one.2 $ neg_nonpos.2 zero_le_one⟩,
  let z := direct_sum.lof ℕ _ (λ i, with_sign i) 1 p1 +
           direct_sum.lof ℕ _ (λ i, with_sign i) (-1) n1,
  have : z ≠ 0,
  { intro h,
    dsimp [z, direct_sum.lof_eq_of, direct_sum.of] at h,
    replace h := dfinsupp.ext_iff.mp h 1,
    rw [dfinsupp.zero_apply, dfinsupp.add_apply, dfinsupp.single_eq_same,
      dfinsupp.single_eq_of_ne (units_int.one_ne_neg_one.symm), add_zero, subtype.ext_iff,
      submodule.coe_zero] at h,
    apply zero_ne_one h.symm, },
  apply hinj.ne this,
  rw [linear_map.map_zero, linear_map.map_add, direct_sum.to_module_lof, direct_sum.to_module_lof],
  simp,
end

/-- And so they do not represent an internal direct sum. -/
lemma with_sign.not_internal : ¬direct_sum.is_internal with_sign :=
with_sign.not_injective ∘ and.elim_left


<|start_filename|>src/topology/algebra/module/character_space.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import topology.algebra.module.weak_dual
import algebra.algebra.spectrum

/-!
# Character space of a topological algebra

The character space of a topological algebra is the subset of elements of the weak dual that
are also algebra homomorphisms. This space is used in the Gelfand transform, which gives an
isomorphism between a commutative C⋆-algebra and continuous functions on the character space
of the algebra. This, in turn, is used to construct the continuous functional calculus on
C⋆-algebras.


## Implementation notes

We define `character_space 𝕜 A` as a subset of the weak dual, which automatically puts the
correct topology on the space. We then define `to_alg_hom` which provides the algebra homomorphism
corresponding to any element. We also provide `to_clm` which provides the element as a
continuous linear map. (Even though `weak_dual 𝕜 A` is a type copy of `A →L[𝕜] 𝕜`, this is
often more convenient.)

## Tags

character space, Gelfand transform, functional calculus

-/

namespace weak_dual

/-- The character space of a topological algebra is the subset of elements of the weak dual that
are also algebra homomorphisms. -/
def character_space (𝕜 : Type*) (A : Type*) [comm_semiring 𝕜] [topological_space 𝕜]
  [has_continuous_add 𝕜] [has_continuous_const_smul 𝕜 𝕜]
  [non_unital_non_assoc_semiring A] [topological_space A] [module 𝕜 A] :=
  {φ : weak_dual 𝕜 A | (φ ≠ 0) ∧ (∀ (x y : A), φ (x * y) = (φ x) * (φ y))}

variables {𝕜 : Type*} {A : Type*}

namespace character_space

section non_unital_non_assoc_semiring

variables [comm_semiring 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [non_unital_non_assoc_semiring A] [topological_space A]
  [module 𝕜 A]

lemma coe_apply (φ : character_space 𝕜 A) (x : A) : (φ : weak_dual 𝕜 A) x = φ x := rfl

/-- An element of the character space, as a continuous linear map. -/
def to_clm (φ : character_space 𝕜 A) : A →L[𝕜] 𝕜 := (φ : weak_dual 𝕜 A)

lemma to_clm_apply (φ : character_space 𝕜 A) (x : A) : φ x = to_clm φ x := rfl

/-- An element of the character space, as an non-unital algebra homomorphism. -/
@[simps] def to_non_unital_alg_hom (φ : character_space 𝕜 A) : A →ₙₐ[𝕜] 𝕜 :=
{ to_fun := (φ : A → 𝕜),
  map_mul' := φ.prop.2,
  map_smul' := (to_clm φ).map_smul,
  map_zero' := continuous_linear_map.map_zero _,
  map_add' := continuous_linear_map.map_add _ }

lemma map_zero (φ : character_space 𝕜 A) : φ 0 = 0 := (to_non_unital_alg_hom φ).map_zero
lemma map_add (φ : character_space 𝕜 A) (x y : A) : φ (x + y) = φ x + φ y :=
  (to_non_unital_alg_hom φ).map_add _ _
lemma map_smul (φ : character_space 𝕜 A) (r : 𝕜) (x : A) : φ (r • x) = r • (φ x) :=
  (to_clm φ).map_smul _ _
lemma map_mul (φ : character_space 𝕜 A) (x y : A) : φ (x * y) = φ x * φ y :=
  (to_non_unital_alg_hom φ).map_mul _ _
lemma continuous (φ : character_space 𝕜 A) : continuous φ := (to_clm φ).continuous

end non_unital_non_assoc_semiring

section unital

variables [comm_ring 𝕜] [no_zero_divisors 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [topological_space A] [semiring A] [algebra 𝕜 A]

lemma map_one (φ : character_space 𝕜 A) : φ 1 = 1 :=
begin
  have h₁ : (φ 1) * (1 - φ 1) = 0 := by rw [mul_sub, sub_eq_zero, mul_one, ←map_mul φ, one_mul],
  rcases mul_eq_zero.mp h₁ with h₂|h₂,
  { exfalso,
    apply φ.prop.1,
    ext,
    rw [continuous_linear_map.zero_apply, ←one_mul x, coe_apply, map_mul φ, h₂, zero_mul] },
  { rw [sub_eq_zero] at h₂,
    exact h₂.symm },
end

/-- An element of the character space, as an algebra homomorphism. -/
@[simps] def to_alg_hom (φ : character_space 𝕜 A) : A →ₐ[𝕜] 𝕜 :=
{ map_one' := map_one φ,
  commutes' := λ r, by
  { rw [algebra.algebra_map_eq_smul_one, algebra.id.map_eq_id, ring_hom.id_apply],
    change ((φ : weak_dual 𝕜 A) : A →L[𝕜] 𝕜) (r • 1) = r,
    rw [continuous_linear_map.map_smul, algebra.id.smul_eq_mul, coe_apply, map_one φ, mul_one] },
  ..to_non_unital_alg_hom φ }

lemma eq_set_map_one_map_mul [nontrivial 𝕜] : character_space 𝕜 A =
  {φ : weak_dual 𝕜 A | (φ 1 = 1) ∧ (∀ (x y : A), φ (x * y) = (φ x) * (φ y))} :=
begin
  ext x,
  refine ⟨λ h, ⟨map_one ⟨x, h⟩, h.2⟩, λ h, ⟨_, h.2⟩⟩,
  rintro rfl,
  simpa using h.1,
end

lemma is_closed [nontrivial 𝕜] [t2_space 𝕜] [has_continuous_mul 𝕜] :
  is_closed (character_space 𝕜 A) :=
begin
  rw [eq_set_map_one_map_mul],
  refine is_closed.inter (is_closed_eq (eval_continuous _) continuous_const) _,
  change is_closed {φ : weak_dual 𝕜 A | ∀ x y : A, φ (x * y) = φ x * φ y},
  rw [set.set_of_forall],
  refine is_closed_Inter (λ a, _),
  rw [set.set_of_forall],
  exact is_closed_Inter (λ _, is_closed_eq (eval_continuous _)
    ((eval_continuous _).mul (eval_continuous _)))
end

end unital

section ring

variables [comm_ring 𝕜] [no_zero_divisors 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [topological_space A] [ring A] [algebra 𝕜 A]

lemma apply_mem_spectrum [nontrivial 𝕜] (φ : character_space 𝕜 A) (a : A) : φ a ∈ spectrum 𝕜 a :=
(to_alg_hom φ).apply_mem_spectrum a

end ring

end character_space

end weak_dual


<|start_filename|>src/data/matrix/block.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>
-/
import data.matrix.basic

/-!
# Block Matrices

## Main definitions

* `matrix.from_blocks`: build a block matrix out of 4 blocks
* `matrix.to_blocks₁₁`, `matrix.to_blocks₁₂`, `matrix.to_blocks₂₁`, `matrix.to_blocks₂₂`:
  extract each of the four blocks from `matrix.from_blocks`.
* `matrix.block_diagonal`: block diagonal of equally sized blocks. On square blocks, this is a
  ring homomorphisms, `matrix.block_diagonal_ring_hom`.
* `matrix.block_diag`: extract the blocks from the diagonal of a block diagonal matrix.
* `matrix.block_diagonal'`: block diagonal of unequally sized blocks. On square blocks, this is a
  ring homomorphisms, `matrix.block_diagonal'_ring_hom`.
* `matrix.block_diag'`: extract the blocks from the diagonal of a block diagonal matrix.
-/

variables {l m n o p q : Type*} {m' n' p' : o → Type*}
variables {R : Type*} {S : Type*} {α : Type*} {β : Type*}

open_locale matrix

namespace matrix

section block_matrices

/-- We can form a single large matrix by flattening smaller 'block' matrices of compatible
dimensions. -/
@[pp_nodot]
def from_blocks (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  matrix (n ⊕ o) (l ⊕ m) α :=
sum.elim (λ i, sum.elim (A i) (B i))
         (λ i, sum.elim (C i) (D i))

@[simp] lemma from_blocks_apply₁₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : n) (j : l) :
  from_blocks A B C D (sum.inl i) (sum.inl j) = A i j :=
rfl

@[simp] lemma from_blocks_apply₁₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : n) (j : m) :
  from_blocks A B C D (sum.inl i) (sum.inr j) = B i j :=
rfl

@[simp] lemma from_blocks_apply₂₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : o) (j : l) :
  from_blocks A B C D (sum.inr i) (sum.inl j) = C i j :=
rfl

@[simp] lemma from_blocks_apply₂₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (i : o) (j : m) :
  from_blocks A B C D (sum.inr i) (sum.inr j) = D i j :=
rfl

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"top left" submatrix. -/
def to_blocks₁₁ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix n l α :=
λ i j, M (sum.inl i) (sum.inl j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"top right" submatrix. -/
def to_blocks₁₂ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix n m α :=
λ i j, M (sum.inl i) (sum.inr j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"bottom left" submatrix. -/
def to_blocks₂₁ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix o l α :=
λ i j, M (sum.inr i) (sum.inl j)

/-- Given a matrix whose row and column indexes are sum types, we can extract the corresponding
"bottom right" submatrix. -/
def to_blocks₂₂ (M : matrix (n ⊕ o) (l ⊕ m) α) : matrix o m α :=
λ i j, M (sum.inr i) (sum.inr j)

lemma from_blocks_to_blocks (M : matrix (n ⊕ o) (l ⊕ m) α) :
  from_blocks M.to_blocks₁₁ M.to_blocks₁₂ M.to_blocks₂₁ M.to_blocks₂₂ = M :=
begin
  ext i j, rcases i; rcases j; refl,
end

@[simp] lemma to_blocks_from_blocks₁₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₁₁ = A :=
rfl

@[simp] lemma to_blocks_from_blocks₁₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₁₂ = B :=
rfl

@[simp] lemma to_blocks_from_blocks₂₁
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₂₁ = C :=
rfl

@[simp] lemma to_blocks_from_blocks₂₂
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D).to_blocks₂₂ = D :=
rfl

lemma from_blocks_map
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (f : α → β) :
  (from_blocks A B C D).map f = from_blocks (A.map f) (B.map f) (C.map f) (D.map f) :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_transpose
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D)ᵀ = from_blocks Aᵀ Cᵀ Bᵀ Dᵀ :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_conj_transpose [has_star α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  (from_blocks A B C D)ᴴ = from_blocks Aᴴ Cᴴ Bᴴ Dᴴ :=
begin
  simp only [conj_transpose, from_blocks_transpose, from_blocks_map]
end

/-- A 2x2 block matrix is block diagonal if the blocks outside of the diagonal vanish -/
def is_two_block_diagonal [has_zero α] (A : matrix (n ⊕ o) (l ⊕ m) α) : Prop :=
to_blocks₁₂ A = 0 ∧ to_blocks₂₁ A = 0

/-- Let `p` pick out certain rows and `q` pick out certain columns of a matrix `M`. Then
  `to_block M p q` is the corresponding block matrix. -/
def to_block (M : matrix m n α) (p : m → Prop) (q : n → Prop) :
  matrix {a // p a} {a // q a} α := M.minor coe coe

@[simp] lemma to_block_apply (M : matrix m n α) (p : m → Prop) (q : n → Prop)
  (i : {a // p a}) (j : {a // q a}) : to_block M p q i j = M ↑i ↑j := rfl

/-- Let `b` map rows and columns of a square matrix `M` to blocks. Then
  `to_square_block M b k` is the block `k` matrix. -/
def to_square_block (M : matrix m m α) {n : nat} (b : m → fin n) (k : fin n) :
  matrix {a // b a = k} {a // b a = k} α := M.minor coe coe

@[simp] lemma to_square_block_def (M : matrix m m α) {n : nat} (b : m → fin n) (k : fin n) :
  to_square_block M b k = λ i j, M ↑i ↑j := rfl

/-- Alternate version with `b : m → nat`. Let `b` map rows and columns of a square matrix `M` to
  blocks. Then `to_square_block' M b k` is the block `k` matrix. -/
def to_square_block' (M : matrix m m α) (b : m → nat) (k : nat) :
  matrix {a // b a = k} {a // b a = k} α := M.minor coe coe

@[simp] lemma to_square_block_def' (M : matrix m m α) (b : m → nat) (k : nat) :
  to_square_block' M b k = λ i j, M ↑i ↑j := rfl

/-- Let `p` pick out certain rows and columns of a square matrix `M`. Then
  `to_square_block_prop M p` is the corresponding block matrix. -/
def to_square_block_prop (M : matrix m m α) (p : m → Prop) :
  matrix {a // p a} {a // p a} α := M.minor coe coe

@[simp] lemma to_square_block_prop_def (M : matrix m m α) (p : m → Prop) :
  to_square_block_prop M p = λ i j, M ↑i ↑j := rfl

lemma from_blocks_smul [has_scalar R α]
  (x : R) (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) :
  x • (from_blocks A B C D) = from_blocks (x • A) (x • B) (x • C) (x • D) :=
begin
  ext i j, rcases i; rcases j; simp [from_blocks],
end

lemma from_blocks_add [has_add α]
  (A  : matrix n l α) (B  : matrix n m α) (C  : matrix o l α) (D  : matrix o m α)
  (A' : matrix n l α) (B' : matrix n m α) (C' : matrix o l α) (D' : matrix o m α) :
  (from_blocks A B C D) + (from_blocks A' B' C' D') =
  from_blocks (A + A') (B + B')
              (C + C') (D + D') :=
begin
  ext i j, rcases i; rcases j; refl,
end

lemma from_blocks_multiply [fintype l] [fintype m] [non_unital_non_assoc_semiring α]
  (A  : matrix n l α) (B  : matrix n m α) (C  : matrix o l α) (D  : matrix o m α)
  (A' : matrix l p α) (B' : matrix l q α) (C' : matrix m p α) (D' : matrix m q α) :
  (from_blocks A B C D) ⬝ (from_blocks A' B' C' D') =
  from_blocks (A ⬝ A' + B ⬝ C') (A ⬝ B' + B ⬝ D')
              (C ⬝ A' + D ⬝ C') (C ⬝ B' + D ⬝ D') :=
begin
  ext i j, rcases i; rcases j;
  simp only [from_blocks, mul_apply, fintype.sum_sum_type, sum.elim_inl, sum.elim_inr,
    pi.add_apply],
end

lemma from_blocks_mul_vec [fintype l] [fintype m] [non_unital_non_assoc_semiring α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (x : l ⊕ m → α) :
  mul_vec (from_blocks A B C D) x =
  sum.elim (mul_vec A (x ∘ sum.inl) + mul_vec B (x ∘ sum.inr))
           (mul_vec C (x ∘ sum.inl) + mul_vec D (x ∘ sum.inr)) :=
by { ext i, cases i; simp [mul_vec, dot_product] }

lemma vec_mul_from_blocks [fintype n] [fintype o] [non_unital_non_assoc_semiring α]
  (A : matrix n l α) (B : matrix n m α) (C : matrix o l α) (D : matrix o m α) (x : n ⊕ o → α) :
  vec_mul x (from_blocks A B C D) =
  sum.elim (vec_mul (x ∘ sum.inl) A + vec_mul (x ∘ sum.inr) C)
           (vec_mul (x ∘ sum.inl) B + vec_mul (x ∘ sum.inr) D) :=
by { ext i, cases i; simp [vec_mul, dot_product] }

variables [decidable_eq l] [decidable_eq m]

@[simp] lemma from_blocks_diagonal [has_zero α] (d₁ : l → α) (d₂ : m → α) :
  from_blocks (diagonal d₁) 0 0 (diagonal d₂) = diagonal (sum.elim d₁ d₂) :=
begin
  ext i j, rcases i; rcases j; simp [diagonal],
end

@[simp] lemma from_blocks_one [has_zero α] [has_one α] :
  from_blocks (1 : matrix l l α) 0 0 (1 : matrix m m α) = 1 :=
by { ext i j, rcases i; rcases j; simp [one_apply] }

end block_matrices

section block_diagonal
variables [decidable_eq o]

section has_zero
variables [has_zero α] [has_zero β]

/-- `matrix.block_diagonal M` turns a homogenously-indexed collection of matrices
`M : o → matrix m n α'` into a `m × o`-by-`n × o` block matrix which has the entries of `M` along
the diagonal and zero elsewhere.

See also `matrix.block_diagonal'` if the matrices may not have the same size everywhere.
-/
def block_diagonal (M : o → matrix m n α) : matrix (m × o) (n × o) α
| ⟨i, k⟩ ⟨j, k'⟩ := if k = k' then M k i j else 0

lemma block_diagonal_apply (M : o → matrix m n α) (ik jk) :
  block_diagonal M ik jk = if ik.2 = jk.2 then M ik.2 ik.1 jk.1 else 0 :=
by { cases ik, cases jk, refl }

@[simp]
lemma block_diagonal_apply_eq (M : o → matrix m n α) (i j k) :
  block_diagonal M (i, k) (j, k) = M k i j :=
if_pos rfl

lemma block_diagonal_apply_ne (M : o → matrix m n α) (i j) {k k'} (h : k ≠ k') :
  block_diagonal M (i, k) (j, k') = 0 :=
if_neg h

lemma block_diagonal_map (M : o → matrix m n α) (f : α → β) (hf : f 0 = 0) :
  (block_diagonal M).map f = block_diagonal (λ k, (M k).map f) :=
begin
  ext,
  simp only [map_apply, block_diagonal_apply, eq_comm],
  rw [apply_ite f, hf],
end

@[simp] lemma block_diagonal_transpose (M : o → matrix m n α) :
  (block_diagonal M)ᵀ = block_diagonal (λ k, (M k)ᵀ) :=
begin
  ext,
  simp only [transpose_apply, block_diagonal_apply, eq_comm],
  split_ifs with h,
  { rw h },
  { refl }
end

@[simp] lemma block_diagonal_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : o → matrix m n α) :
  (block_diagonal M)ᴴ = block_diagonal (λ k, (M k)ᴴ) :=
begin
  simp only [conj_transpose, block_diagonal_transpose],
  rw block_diagonal_map _ star (star_zero α),
end

@[simp] lemma block_diagonal_zero :
  block_diagonal (0 : o → matrix m n α) = 0 :=
by { ext, simp [block_diagonal_apply] }

@[simp] lemma block_diagonal_diagonal [decidable_eq m] (d : o → m → α) :
  block_diagonal (λ k, diagonal (d k)) = diagonal (λ ik, d ik.2 ik.1) :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal_apply, diagonal, prod.mk.inj_iff, ← ite_and],
  congr' 1,
  rw and_comm,
end

@[simp] lemma block_diagonal_one [decidable_eq m] [has_one α] :
  block_diagonal (1 : o → matrix m m α) = 1 :=
show block_diagonal (λ (_ : o), diagonal (λ (_ : m), (1 : α))) = diagonal (λ _, 1),
by rw [block_diagonal_diagonal]

end has_zero

@[simp] lemma block_diagonal_add [add_zero_class α] (M N : o → matrix m n α) :
  block_diagonal (M + N) = block_diagonal M + block_diagonal N :=
begin
  ext,
  simp only [block_diagonal_apply, pi.add_apply],
  split_ifs; simp
end

section
variables (o m n α)
/-- `matrix.block_diagonal` as an `add_monoid_hom`. -/
@[simps] def block_diagonal_add_monoid_hom [add_zero_class α] :
  (o → matrix m n α) →+ matrix (m × o) (n × o) α :=
{ to_fun := block_diagonal,
  map_zero' := block_diagonal_zero,
  map_add' := block_diagonal_add }
end

@[simp] lemma block_diagonal_neg [add_group α] (M : o → matrix m n α) :
  block_diagonal (-M) = - block_diagonal M :=
map_neg (block_diagonal_add_monoid_hom m n o α) M

@[simp] lemma block_diagonal_sub [add_group α] (M N : o → matrix m n α) :
  block_diagonal (M - N) = block_diagonal M - block_diagonal N :=
map_sub (block_diagonal_add_monoid_hom m n o α) M N

@[simp] lemma block_diagonal_mul [fintype n] [fintype o] [non_unital_non_assoc_semiring α]
  (M : o → matrix m n α) (N : o → matrix n p α) :
  block_diagonal (λ k, M k ⬝ N k) = block_diagonal M ⬝ block_diagonal N :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal_apply, mul_apply, ← finset.univ_product_univ, finset.sum_product],
  split_ifs with h; simp [h]
end

section
variables (α m o)
/-- `matrix.block_diagonal` as a `ring_hom`. -/
@[simps]
def block_diagonal_ring_hom [decidable_eq m] [fintype o] [fintype m] [non_assoc_semiring α] :
  (o → matrix m m α) →+* matrix (m × o) (m × o) α :=
{ to_fun := block_diagonal,
  map_one' := block_diagonal_one,
  map_mul' := block_diagonal_mul,
  ..block_diagonal_add_monoid_hom m m o α }
end

@[simp] lemma block_diagonal_pow [decidable_eq m] [fintype o] [fintype m] [semiring α]
  (M : o → matrix m m α) (n : ℕ)  :
  block_diagonal (M ^ n) = block_diagonal M ^ n :=
map_pow (block_diagonal_ring_hom m o α) M n

@[simp] lemma block_diagonal_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : o → matrix m n α) : block_diagonal (x • M) = x • block_diagonal M :=
by { ext, simp only [block_diagonal_apply, pi.smul_apply], split_ifs; simp }

end block_diagonal

section block_diag


/-- Extract a block from the diagonal of a block diagonal matrix.

This is the block form of `matrix.diag`, and the left-inverse of `matrix.block_diagonal`. -/
def block_diag (M : matrix (m × o) (n × o) α) (k : o) : matrix m n α
| i j := M (i, k) (j, k)

lemma block_diag_map (M : matrix (m × o) (n × o) α) (f : α → β) :
  block_diag (M.map f) = λ k, (block_diag M k).map f :=
rfl

@[simp] lemma block_diag_transpose (M : matrix (m × o) (n × o) α) (k : o) :
  block_diag Mᵀ k = (block_diag M k)ᵀ :=
ext $ λ i j, rfl

@[simp] lemma block_diag_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : matrix (m × o) (n × o) α) (k : o) :
  block_diag Mᴴ k = (block_diag M k)ᴴ :=
ext $ λ i j, rfl

section has_zero
variables [has_zero α] [has_zero β]

@[simp] lemma block_diag_zero :
  block_diag (0 : matrix (m × o) (n × o) α) = 0 :=
rfl

@[simp] lemma block_diag_diagonal [decidable_eq o] [decidable_eq m] (d : (m × o) → α) (k : o) :
  block_diag (diagonal d) k = diagonal (λ i, d (i, k)) :=
ext $ λ i j, begin
  obtain rfl | hij := decidable.eq_or_ne i j,
  { rw [block_diag, diagonal_apply_eq, diagonal_apply_eq] },
  { rw [block_diag, diagonal_apply_ne _ hij, diagonal_apply_ne _ (mt _ hij)],
    exact prod.fst_eq_iff.mpr },
end

@[simp] lemma block_diag_block_diagonal [decidable_eq o] (M : o → matrix m n α) :
  block_diag (block_diagonal M) = M :=
funext $ λ k, ext $ λ i j, block_diagonal_apply_eq _ _ _ _

@[simp] lemma block_diag_one [decidable_eq o] [decidable_eq m] [has_one α] :
  block_diag (1 : matrix (m × o) (m × o) α) = 1 :=
funext $ block_diag_diagonal _

end has_zero

@[simp] lemma block_diag_add [add_zero_class α] (M N : matrix (m × o) (n × o) α) :
  block_diag (M + N) = block_diag M + block_diag N :=
rfl

section
variables (o m n α)
/-- `matrix.block_diag` as an `add_monoid_hom`. -/
@[simps] def block_diag_add_monoid_hom [add_zero_class α] :
  matrix (m × o) (n × o) α →+ (o → matrix m n α) :=
{ to_fun := block_diag,
  map_zero' := block_diag_zero,
  map_add' := block_diag_add }
end

@[simp] lemma block_diag_neg [add_group α] (M : matrix (m × o) (n × o) α) :
  block_diag (-M) = - block_diag M :=
map_neg (block_diag_add_monoid_hom m n o α) M

@[simp] lemma block_diag_sub [add_group α] (M N : matrix (m × o) (n × o) α) :
  block_diag (M - N) = block_diag M - block_diag N :=
map_sub (block_diag_add_monoid_hom m n o α) M N

@[simp] lemma block_diag_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : matrix (m × o) (n × o) α) : block_diag (x • M) = x • block_diag M :=
rfl

end block_diag

section block_diagonal'

variables [decidable_eq o]

section has_zero
variables [has_zero α] [has_zero β]

/-- `matrix.block_diagonal' M` turns `M : Π i, matrix (m i) (n i) α` into a
`Σ i, m i`-by-`Σ i, n i` block matrix which has the entries of `M` along the diagonal
and zero elsewhere.

This is the dependently-typed version of `matrix.block_diagonal`. -/
def block_diagonal' (M : Π i, matrix (m' i) (n' i) α) : matrix (Σ i, m' i) (Σ i, n' i) α
| ⟨k, i⟩ ⟨k', j⟩ := if h : k = k' then M k i (cast (congr_arg n' h.symm) j) else 0

lemma block_diagonal'_eq_block_diagonal (M : o → matrix m n α) {k k'} (i j) :
  block_diagonal M (i, k) (j, k') = block_diagonal' M ⟨k, i⟩ ⟨k', j⟩ :=
rfl

lemma block_diagonal'_minor_eq_block_diagonal (M : o → matrix m n α) :
  (block_diagonal' M).minor (prod.to_sigma ∘ prod.swap) (prod.to_sigma ∘ prod.swap) =
    block_diagonal M :=
matrix.ext $ λ ⟨k, i⟩ ⟨k', j⟩, rfl

lemma block_diagonal'_apply (M : Π i, matrix (m' i) (n' i) α) (ik jk) :
  block_diagonal' M ik jk = if h : ik.1 = jk.1 then
    M ik.1 ik.2 (cast (congr_arg n' h.symm) jk.2) else 0 :=
by { cases ik, cases jk, refl }

@[simp]
lemma block_diagonal'_apply_eq (M : Π i, matrix (m' i) (n' i) α) (k i j) :
  block_diagonal' M ⟨k, i⟩ ⟨k, j⟩ = M k i j :=
dif_pos rfl

lemma block_diagonal'_apply_ne (M : Π i, matrix (m' i) (n' i) α) {k k'} (i j) (h : k ≠ k') :
  block_diagonal' M ⟨k, i⟩ ⟨k', j⟩ = 0 :=
dif_neg h

lemma block_diagonal'_map (M : Π i, matrix (m' i) (n' i) α) (f : α → β) (hf : f 0 = 0) :
  (block_diagonal' M).map f = block_diagonal' (λ k, (M k).map f) :=
begin
  ext,
  simp only [map_apply, block_diagonal'_apply, eq_comm],
  rw [apply_dite f, hf],
end

@[simp] lemma block_diagonal'_transpose (M : Π i, matrix (m' i) (n' i) α) :
  (block_diagonal' M)ᵀ = block_diagonal' (λ k, (M k)ᵀ) :=
begin
  ext ⟨ii, ix⟩ ⟨ji, jx⟩,
  simp only [transpose_apply, block_diagonal'_apply],
  split_ifs; cc
end

@[simp] lemma block_diagonal'_conj_transpose {α} [add_monoid α] [star_add_monoid α]
  (M : Π i, matrix (m' i) (n' i) α) :
  (block_diagonal' M)ᴴ = block_diagonal' (λ k, (M k)ᴴ) :=
begin
  simp only [conj_transpose, block_diagonal'_transpose],
  exact block_diagonal'_map _ star (star_zero α),
end

@[simp] lemma block_diagonal'_zero :
  block_diagonal' (0 : Π i, matrix (m' i) (n' i) α) = 0 :=
by { ext, simp [block_diagonal'_apply] }

@[simp] lemma block_diagonal'_diagonal [Π i, decidable_eq (m' i)] (d : Π i, m' i → α) :
  block_diagonal' (λ k, diagonal (d k)) = diagonal (λ ik, d ik.1 ik.2) :=
begin
  ext ⟨i, k⟩ ⟨j, k'⟩,
  simp only [block_diagonal'_apply, diagonal],
  obtain rfl | hij := decidable.eq_or_ne i j,
  { simp, },
  { simp [hij] },
end

@[simp] lemma block_diagonal'_one [∀ i, decidable_eq (m' i)] [has_one α] :
  block_diagonal' (1 : Π i, matrix (m' i) (m' i) α) = 1 :=
show block_diagonal' (λ (i : o), diagonal (λ (_ : m' i), (1 : α))) = diagonal (λ _, 1),
by rw [block_diagonal'_diagonal]

end has_zero

@[simp] lemma block_diagonal'_add [add_zero_class α] (M N : Π i, matrix (m' i) (n' i) α) :
  block_diagonal' (M + N) = block_diagonal' M + block_diagonal' N :=
begin
  ext,
  simp only [block_diagonal'_apply, pi.add_apply],
  split_ifs; simp
end


section
variables (m' n' α)
/-- `matrix.block_diagonal'` as an `add_monoid_hom`. -/
@[simps] def block_diagonal'_add_monoid_hom [add_zero_class α] :
  (Π i, matrix (m' i) (n' i) α) →+ matrix (Σ i, m' i) (Σ i, n' i) α :=
{ to_fun := block_diagonal',
  map_zero' := block_diagonal'_zero,
  map_add' := block_diagonal'_add }
end

@[simp] lemma block_diagonal'_neg [add_group α] (M : Π i, matrix (m' i) (n' i) α) :
  block_diagonal' (-M) = - block_diagonal' M :=
map_neg (block_diagonal'_add_monoid_hom m' n' α) M

@[simp] lemma block_diagonal'_sub [add_group α] (M N : Π i, matrix (m' i) (n' i) α) :
  block_diagonal' (M - N) = block_diagonal' M - block_diagonal' N :=
map_sub (block_diagonal'_add_monoid_hom m' n' α) M N

@[simp] lemma block_diagonal'_mul [non_unital_non_assoc_semiring α]
  [Π i, fintype (n' i)] [fintype o]
  (M : Π i, matrix (m' i) (n' i) α) (N : Π i, matrix (n' i) (p' i) α) :
  block_diagonal' (λ k, M k ⬝ N k) = block_diagonal' M ⬝ block_diagonal' N :=
begin
  ext ⟨k, i⟩ ⟨k', j⟩,
  simp only [block_diagonal'_apply, mul_apply, ← finset.univ_sigma_univ, finset.sum_sigma],
  rw fintype.sum_eq_single k,
  { split_ifs; simp },
  { intros j' hj', exact finset.sum_eq_zero (λ _ _, by rw [dif_neg hj'.symm, zero_mul]) },
end

section
variables (α m')
/-- `matrix.block_diagonal'` as a `ring_hom`. -/
@[simps]
def block_diagonal'_ring_hom [Π i, decidable_eq (m' i)] [fintype o] [Π i, fintype (m' i)]
  [non_assoc_semiring α] :
  (Π i, matrix (m' i) (m' i) α) →+* matrix (Σ i, m' i) (Σ i, m' i) α :=
{ to_fun := block_diagonal',
  map_one' := block_diagonal'_one,
  map_mul' := block_diagonal'_mul,
  ..block_diagonal'_add_monoid_hom m' m' α }
end

@[simp] lemma block_diagonal'_pow [Π i, decidable_eq (m' i)] [fintype o] [Π i, fintype (m' i)]
  [semiring α] (M : Π i, matrix (m' i) (m' i) α) (n : ℕ)  :
  block_diagonal' (M ^ n) = block_diagonal' M ^ n :=
map_pow (block_diagonal'_ring_hom m' α) M n

@[simp] lemma block_diagonal'_smul {R : Type*} [semiring R] [add_comm_monoid α] [module R α]
  (x : R) (M : Π i, matrix (m' i) (n' i) α) : block_diagonal' (x • M) = x • block_diagonal' M :=
by { ext, simp only [block_diagonal'_apply, pi.smul_apply], split_ifs; simp }

end block_diagonal'

section block_diag'

/-- Extract a block from the diagonal of a block diagonal matrix.

This is the block form of `matrix.diag`, and the left-inverse of `matrix.block_diagonal'`. -/
def block_diag' (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) : matrix (m' k) (n' k) α
| i j := M ⟨k, i⟩ ⟨k, j⟩

lemma block_diag'_map (M : matrix (Σ i, m' i) (Σ i, n' i) α) (f : α → β) :
  block_diag' (M.map f) = λ k, (block_diag' M k).map f :=
rfl

@[simp] lemma block_diag'_transpose (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) :
  block_diag' Mᵀ k = (block_diag' M k)ᵀ :=
ext $ λ i j, rfl

@[simp] lemma block_diag'_conj_transpose
  {α : Type*} [add_monoid α] [star_add_monoid α] (M : matrix (Σ i, m' i) (Σ i, n' i) α) (k : o) :
  block_diag' Mᴴ k = (block_diag' M k)ᴴ :=
ext $ λ i j, rfl

section has_zero
variables [has_zero α] [has_zero β]

@[simp] lemma block_diag'_zero :
  block_diag' (0 : matrix (Σ i, m' i) (Σ i, n' i) α) = 0 :=
rfl

@[simp] lemma block_diag'_diagonal [decidable_eq o] [Π i, decidable_eq (m' i)]
  (d : (Σ i, m' i) → α) (k : o) :
  block_diag' (diagonal d) k = diagonal (λ i, d ⟨k, i⟩) :=
ext $ λ i j, begin
  obtain rfl | hij := decidable.eq_or_ne i j,
  { rw [block_diag', diagonal_apply_eq, diagonal_apply_eq] },
  { rw [block_diag', diagonal_apply_ne _ hij, diagonal_apply_ne _ (mt (λ h, _) hij)],
    cases h, refl },
end

@[simp] lemma block_diag'_block_diagonal' [decidable_eq o] (M : Π i, matrix (m' i) (n' i) α) :
  block_diag' (block_diagonal' M) = M :=
funext $ λ k, ext $ λ i j, block_diagonal'_apply_eq _ _ _ _

@[simp] lemma block_diag'_one [decidable_eq o] [Π i, decidable_eq (m' i)] [has_one α] :
  block_diag' (1 : matrix (Σ i, m' i) (Σ i, m' i) α) = 1 :=
funext $ block_diag'_diagonal _

end has_zero

@[simp] lemma block_diag'_add [add_zero_class α] (M N : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (M + N) = block_diag' M + block_diag' N :=
rfl

section
variables (m' n' α)
/-- `matrix.block_diag'` as an `add_monoid_hom`. -/
@[simps] def block_diag'_add_monoid_hom [add_zero_class α] :
  matrix (Σ i, m' i) (Σ i, n' i) α →+ Π i, matrix (m' i) (n' i) α :=
{ to_fun := block_diag',
  map_zero' := block_diag'_zero,
  map_add' := block_diag'_add }
end

@[simp] lemma block_diag'_neg [add_group α] (M : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (-M) = - block_diag' M :=
map_neg (block_diag'_add_monoid_hom m' n' α) M

@[simp] lemma block_diag'_sub [add_group α] (M N : matrix (Σ i, m' i) (Σ i, n' i) α) :
  block_diag' (M - N) = block_diag' M - block_diag' N :=
map_sub (block_diag'_add_monoid_hom m' n' α) M N

@[simp] lemma block_diag'_smul {R : Type*} [monoid R] [add_monoid α] [distrib_mul_action R α]
  (x : R) (M : matrix (Σ i, m' i) (Σ i, n' i) α) : block_diag' (x • M) = x • block_diag' M :=
rfl

end block_diag'

end matrix


<|start_filename|>src/linear_algebra/quadratic_form/isometry.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import linear_algebra.quadratic_form.basic

/-!
# Isometries with respect to quadratic forms

## Main definitions

* `quadratic_form.isometry`: `linear_equiv`s which map between two different quadratic forms
* `quadratic_form.equvialent`: propositional version of the above

## Main results

* `equivalent_weighted_sum_squares`: in finite dimensions, any quadratic form is equivalent to a
  parametrization of `quadratic_form.weighted_sum_squares`.
-/

variables {ι R K M M₁ M₂ M₃ V : Type*}

namespace quadratic_form

variables [ring R]
variables [add_comm_group M] [add_comm_group M₁] [add_comm_group M₂] [add_comm_group M₃]
variables [module R M] [module R M₁] [module R M₂] [module R M₃]

/-- An isometry between two quadratic spaces `M₁, Q₁` and `M₂, Q₂` over a ring `R`,
is a linear equivalence between `M₁` and `M₂` that commutes with the quadratic forms. -/
@[nolint has_inhabited_instance] structure isometry
  (Q₁ : quadratic_form R M₁) (Q₂ : quadratic_form R M₂) extends M₁ ≃ₗ[R] M₂ :=
(map_app' : ∀ m, Q₂ (to_fun m) = Q₁ m)

/-- Two quadratic forms over a ring `R` are equivalent
if there exists an isometry between them:
a linear equivalence that transforms one quadratic form into the other. -/
def equivalent (Q₁ : quadratic_form R M₁) (Q₂ : quadratic_form R M₂) := nonempty (Q₁.isometry Q₂)

namespace isometry

variables {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} {Q₃ : quadratic_form R M₃}

instance : has_coe (Q₁.isometry Q₂) (M₁ ≃ₗ[R] M₂) := ⟨isometry.to_linear_equiv⟩

@[simp] lemma to_linear_equiv_eq_coe (f : Q₁.isometry Q₂) : f.to_linear_equiv = f := rfl

instance : has_coe_to_fun (Q₁.isometry Q₂) (λ _, M₁ → M₂) := ⟨λ f, ⇑(f : M₁ ≃ₗ[R] M₂)⟩

@[simp] lemma coe_to_linear_equiv (f : Q₁.isometry Q₂) : ⇑(f : M₁ ≃ₗ[R] M₂) = f := rfl

@[simp] lemma map_app (f : Q₁.isometry Q₂) (m : M₁) : Q₂ (f m) = Q₁ m := f.map_app' m

/-- The identity isometry from a quadratic form to itself. -/
@[refl]
def refl (Q : quadratic_form R M) : Q.isometry Q :=
{ map_app' := λ m, rfl,
  .. linear_equiv.refl R M }

/-- The inverse isometry of an isometry between two quadratic forms. -/
@[symm]
def symm (f : Q₁.isometry Q₂) : Q₂.isometry Q₁ :=
{ map_app' := by { intro m, rw ← f.map_app, congr, exact f.to_linear_equiv.apply_symm_apply m },
  .. (f : M₁ ≃ₗ[R] M₂).symm }

/-- The composition of two isometries between quadratic forms. -/
@[trans]
def trans (f : Q₁.isometry Q₂) (g : Q₂.isometry Q₃) : Q₁.isometry Q₃ :=
{ map_app' := by { intro m, rw [← f.map_app, ← g.map_app], refl },
  .. (f : M₁ ≃ₗ[R] M₂).trans (g : M₂ ≃ₗ[R] M₃) }

end isometry

namespace equivalent

variables {Q₁ : quadratic_form R M₁} {Q₂ : quadratic_form R M₂} {Q₃ : quadratic_form R M₃}

@[refl]
lemma refl (Q : quadratic_form R M) : Q.equivalent Q := ⟨isometry.refl Q⟩

@[symm]
lemma symm (h : Q₁.equivalent Q₂) : Q₂.equivalent Q₁ := h.elim $ λ f, ⟨f.symm⟩

@[trans]
lemma trans (h : Q₁.equivalent Q₂) (h' : Q₂.equivalent Q₃) : Q₁.equivalent Q₃ :=
h'.elim $ h.elim $ λ f g, ⟨f.trans g⟩

end equivalent

variables [fintype ι] {v : basis ι R M}

/-- A quadratic form composed with a `linear_equiv` is isometric to itself. -/
def isometry_of_comp_linear_equiv (Q : quadratic_form R M) (f : M₁ ≃ₗ[R] M) :
  Q.isometry (Q.comp (f : M₁ →ₗ[R] M)) :=
{ map_app' :=
  begin
    intro,
    simp only [comp_apply, linear_equiv.coe_coe, linear_equiv.to_fun_eq_coe,
               linear_equiv.apply_symm_apply, f.apply_symm_apply],
  end,
  .. f.symm }

/-- A quadratic form is isometric to its bases representations. -/
noncomputable def isometry_basis_repr (Q : quadratic_form R M) (v : basis ι R M) :
  isometry Q (Q.basis_repr v) :=
isometry_of_comp_linear_equiv Q v.equiv_fun.symm

variables [field K] [invertible (2 : K)] [add_comm_group V] [module K V]

/-- Given an orthogonal basis, a quadratic form is isometric with a weighted sum of squares. -/
noncomputable def isometry_weighted_sum_squares (Q : quadratic_form K V)
  (v : basis (fin (finite_dimensional.finrank K V)) K V)
  (hv₁ : (associated Q).is_Ortho v) :
  Q.isometry (weighted_sum_squares K (λ i, Q (v i))) :=
begin
  let iso := Q.isometry_basis_repr v,
  refine ⟨iso, λ m, _⟩,
  convert iso.map_app m,
  rw basis_repr_eq_of_is_Ortho _ _ hv₁,
end

variables [finite_dimensional K V]

open bilin_form

lemma equivalent_weighted_sum_squares (Q : quadratic_form K V) :
  ∃ w : fin (finite_dimensional.finrank K V) → K, equivalent Q (weighted_sum_squares K w) :=
let ⟨v, hv₁⟩ := exists_orthogonal_basis (associated_is_symm _ Q) in
  ⟨_, ⟨Q.isometry_weighted_sum_squares v hv₁⟩⟩

lemma equivalent_weighted_sum_squares_units_of_nondegenerate'
  (Q : quadratic_form K V) (hQ : (associated Q).nondegenerate) :
  ∃ w : fin (finite_dimensional.finrank K V) → Kˣ,
    equivalent Q (weighted_sum_squares K w) :=
begin
  obtain ⟨v, hv₁⟩ := exists_orthogonal_basis (associated_is_symm _ Q),
  have hv₂ := hv₁.not_is_ortho_basis_self_of_nondegenerate hQ,
  simp_rw [is_ortho, associated_eq_self_apply] at hv₂,
  exact ⟨λ i, units.mk0 _ (hv₂ i), ⟨Q.isometry_weighted_sum_squares v hv₁⟩⟩,
end

end quadratic_form


<|start_filename|>src/order/compactly_generated.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import tactic.tfae
import order.atoms
import order.order_iso_nat
import order.sup_indep
import order.zorn
import data.finset.order

/-!
# Compactness properties for complete lattices

For complete lattices, there are numerous equivalent ways to express the fact that the relation `>`
is well-founded. In this file we define three especially-useful characterisations and provide
proofs that they are indeed equivalent to well-foundedness.

## Main definitions
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `complete_lattice.is_compact_element`
 * `complete_lattice.is_compactly_generated`

## Main results
The main result is that the following four conditions are equivalent for a complete lattice:
 * `well_founded (>)`
 * `complete_lattice.is_sup_closed_compact`
 * `complete_lattice.is_Sup_finite_compact`
 * `∀ k, complete_lattice.is_compact_element k`

This is demonstrated by means of the following four lemmas:
 * `complete_lattice.well_founded.is_Sup_finite_compact`
 * `complete_lattice.is_Sup_finite_compact.is_sup_closed_compact`
 * `complete_lattice.is_sup_closed_compact.well_founded`
 * `complete_lattice.is_Sup_finite_compact_iff_all_elements_compact`

 We also show well-founded lattices are compactly generated
 (`complete_lattice.compactly_generated_of_well_founded`).

## References
- [<NAME>, *Lattice Concepts of Module Theory*][calugareanu]

## Tags

complete lattice, well-founded, compact
-/

variables {α : Type*} [complete_lattice α]

namespace complete_lattice

variables (α)

/-- A compactness property for a complete lattice is that any `sup`-closed non-empty subset
contains its `Sup`. -/
def is_sup_closed_compact : Prop :=
  ∀ (s : set α) (h : s.nonempty), (∀ a b ∈ s, a ⊔ b ∈ s) → (Sup s) ∈ s

/-- A compactness property for a complete lattice is that any subset has a finite subset with the
same `Sup`. -/
def is_Sup_finite_compact : Prop :=
∀ (s : set α), ∃ (t : finset α), ↑t ⊆ s ∧ Sup s = t.sup id

/-- An element `k` of a complete lattice is said to be compact if any set with `Sup`
above `k` has a finite subset with `Sup` above `k`.  Such an element is also called
"finite" or "S-compact". -/
def is_compact_element {α : Type*} [complete_lattice α] (k : α) :=
∀ s : set α, k ≤ Sup s → ∃ t : finset α, ↑t ⊆ s ∧ k ≤ t.sup id

/-- An element `k` is compact if and only if any directed set with `Sup` above
`k` already got above `k` at some point in the set. -/
theorem is_compact_element_iff_le_of_directed_Sup_le (k : α) :
  is_compact_element k ↔
  ∀ s : set α, s.nonempty → directed_on (≤) s → k ≤ Sup s → ∃ x : α, x ∈ s ∧ k ≤ x :=
begin
  classical,
  split,
  { intros hk s hne hdir hsup,
    obtain ⟨t, ht⟩ := hk s hsup,
    -- certainly every element of t is below something in s, since ↑t ⊆ s.
    have t_below_s : ∀ x ∈ t, ∃ y ∈ s, x ≤ y, from λ x hxt, ⟨x, ht.left hxt, le_rfl⟩,
    obtain ⟨x, ⟨hxs, hsupx⟩⟩ := finset.sup_le_of_le_directed s hne hdir t t_below_s,
    exact ⟨x, ⟨hxs, le_trans ht.right hsupx⟩⟩, },
  { intros hk s hsup,
    -- Consider the set of finite joins of elements of the (plain) set s.
    let S : set α := { x | ∃ t : finset α, ↑t ⊆ s ∧ x = t.sup id },
    -- S is directed, nonempty, and still has sup above k.
    have dir_US : directed_on (≤) S,
    { rintros x ⟨c, hc⟩ y ⟨d, hd⟩,
      use x ⊔ y,
      split,
      { use c ∪ d,
        split,
        { simp only [hc.left, hd.left, set.union_subset_iff, finset.coe_union, and_self], },
        { simp only [hc.right, hd.right, finset.sup_union], }, },
      simp only [and_self, le_sup_left, le_sup_right], },
    have sup_S : Sup s ≤ Sup S,
    { apply Sup_le_Sup,
      intros x hx, use {x},
      simpa only [and_true, id.def, finset.coe_singleton, eq_self_iff_true, finset.sup_singleton,
        set.singleton_subset_iff], },
    have Sne : S.nonempty,
    { suffices : ⊥ ∈ S, from set.nonempty_of_mem this,
      use ∅,
      simp only [set.empty_subset, finset.coe_empty, finset.sup_empty,
        eq_self_iff_true, and_self], },
    -- Now apply the defn of compact and finish.
    obtain ⟨j, ⟨hjS, hjk⟩⟩ := hk S Sne dir_US (le_trans hsup sup_S),
    obtain ⟨t, ⟨htS, htsup⟩⟩ := hjS,
    use t, exact ⟨htS, by rwa ←htsup⟩, },
end

/-- A compact element `k` has the property that any directed set lying strictly below `k` has
its Sup strictly below `k`. -/
lemma is_compact_element.directed_Sup_lt_of_lt {α : Type*} [complete_lattice α] {k : α}
  (hk : is_compact_element k) {s : set α} (hemp : s.nonempty) (hdir : directed_on (≤) s)
  (hbelow : ∀ x ∈ s, x < k) : Sup s < k :=
begin
  rw is_compact_element_iff_le_of_directed_Sup_le at hk,
  by_contradiction,
  have sSup : Sup s ≤ k, from Sup_le (λ s hs, (hbelow s hs).le),
  replace sSup : Sup s = k := eq_iff_le_not_lt.mpr ⟨sSup, h⟩,
  obtain ⟨x, hxs, hkx⟩ := hk s hemp hdir sSup.symm.le,
  obtain hxk := hbelow x hxs,
  exact hxk.ne (hxk.le.antisymm hkx),
end

lemma finset_sup_compact_of_compact {α β : Type*} [complete_lattice α] {f : β → α}
  (s : finset β) (h : ∀ x ∈ s, is_compact_element (f x)) : is_compact_element (s.sup f) :=
begin
  classical,
  rw is_compact_element_iff_le_of_directed_Sup_le,
  intros d hemp hdir hsup,
  change f with id ∘ f, rw ←finset.sup_finset_image,
  apply finset.sup_le_of_le_directed d hemp hdir,
  rintros x hx,
  obtain ⟨p, ⟨hps, rfl⟩⟩ := finset.mem_image.mp hx,
  specialize h p hps,
  rw is_compact_element_iff_le_of_directed_Sup_le at h,
  specialize h d hemp hdir (le_trans (finset.le_sup hps) hsup),
  simpa only [exists_prop],
end

lemma well_founded.is_Sup_finite_compact (h : well_founded ((>) : α → α → Prop)) :
  is_Sup_finite_compact α :=
begin
  intros s,
  let p : set α := { x | ∃ (t : finset α), ↑t ⊆ s ∧ t.sup id = x },
  have hp : p.nonempty, { use [⊥, ∅], simp, },
  obtain ⟨m, ⟨t, ⟨ht₁, ht₂⟩⟩, hm⟩ := well_founded.well_founded_iff_has_max'.mp h p hp,
  use t, simp only [ht₁, ht₂, true_and], apply le_antisymm,
  { apply Sup_le, intros y hy, classical,
    have hy' : (insert y t).sup id ∈ p,
    { use insert y t, simp, rw set.insert_subset, exact ⟨hy, ht₁⟩, },
    have hm' : m ≤ (insert y t).sup id, { rw ← ht₂, exact finset.sup_mono (t.subset_insert y), },
    rw ← hm _ hy' hm', simp, },
  { rw [← ht₂, finset.sup_id_eq_Sup], exact Sup_le_Sup ht₁, },
end

lemma is_Sup_finite_compact.is_sup_closed_compact (h : is_Sup_finite_compact α) :
  is_sup_closed_compact α :=
begin
  intros s hne hsc, obtain ⟨t, ht₁, ht₂⟩ := h s, clear h,
  cases t.eq_empty_or_nonempty with h h,
  { subst h, rw finset.sup_empty at ht₂, rw ht₂,
    simp [eq_singleton_bot_of_Sup_eq_bot_of_nonempty ht₂ hne], },
  { rw ht₂, exact t.sup_closed_of_sup_closed h ht₁ hsc, },
end

lemma is_sup_closed_compact.well_founded (h : is_sup_closed_compact α) :
  well_founded ((>) : α → α → Prop) :=
begin
  refine rel_embedding.well_founded_iff_no_descending_seq.mpr ⟨λ a, _⟩,
  suffices : Sup (set.range a) ∈ set.range a,
  { obtain ⟨n, hn⟩ := set.mem_range.mp this,
    have h' : Sup (set.range a) < a (n+1), { change _ > _, simp [← hn, a.map_rel_iff], },
    apply lt_irrefl (a (n+1)), apply lt_of_le_of_lt _ h', apply le_Sup, apply set.mem_range_self, },
  apply h (set.range a),
  { use a 37, apply set.mem_range_self, },
  { rintros x ⟨m, hm⟩ y ⟨n, hn⟩, use m ⊔ n, rw [← hm, ← hn], apply rel_hom_class.map_sup a, },
end

lemma is_Sup_finite_compact_iff_all_elements_compact :
  is_Sup_finite_compact α ↔ (∀ k : α, is_compact_element k) :=
begin
  refine ⟨λ h k s hs, _, λ h s, _⟩,
  { obtain ⟨t, ⟨hts, htsup⟩⟩ := h s,
    use [t, hts],
    rwa ←htsup, },
  { obtain ⟨t, ⟨hts, htsup⟩⟩ := h (Sup s) s (by refl),
    have : Sup s = t.sup id,
    { suffices : t.sup id ≤ Sup s, by { apply le_antisymm; assumption },
      simp only [id.def, finset.sup_le_iff],
      intros x hx,
      exact le_Sup (hts hx) },
    use [t, hts, this] },
end

lemma well_founded_characterisations :
  tfae [well_founded ((>) : α → α → Prop),
        is_Sup_finite_compact α,
        is_sup_closed_compact α,
        ∀ k : α, is_compact_element k] :=
begin
  tfae_have : 1 → 2, by { exact well_founded.is_Sup_finite_compact α, },
  tfae_have : 2 → 3, by { exact is_Sup_finite_compact.is_sup_closed_compact α, },
  tfae_have : 3 → 1, by { exact is_sup_closed_compact.well_founded α, },
  tfae_have : 2 ↔ 4, by { exact is_Sup_finite_compact_iff_all_elements_compact α },
  tfae_finish,
end

lemma well_founded_iff_is_Sup_finite_compact :
  well_founded ((>) : α → α → Prop) ↔ is_Sup_finite_compact α :=
(well_founded_characterisations α).out 0 1

lemma is_Sup_finite_compact_iff_is_sup_closed_compact :
  is_Sup_finite_compact α ↔ is_sup_closed_compact α :=
(well_founded_characterisations α).out 1 2

lemma is_sup_closed_compact_iff_well_founded :
  is_sup_closed_compact α ↔ well_founded ((>) : α → α → Prop) :=
(well_founded_characterisations α).out 2 0

alias well_founded_iff_is_Sup_finite_compact ↔ _ is_Sup_finite_compact.well_founded
alias is_Sup_finite_compact_iff_is_sup_closed_compact ↔
      _ is_sup_closed_compact.is_Sup_finite_compact
alias is_sup_closed_compact_iff_well_founded ↔ _ well_founded.is_sup_closed_compact

lemma well_founded.finite_of_set_independent (h : well_founded ((>) : α → α → Prop))
  {s : set α} (hs : set_independent s) : s.finite :=
begin
  classical,
  refine set.not_infinite.mp (λ contra, _),
  obtain ⟨t, ht₁, ht₂⟩ := well_founded.is_Sup_finite_compact α h s,
  replace contra : ∃ (x : α), x ∈ s ∧ x ≠ ⊥ ∧ x ∉ t,
  { have : (s \ (insert ⊥ t : finset α)).infinite := contra.diff (finset.finite_to_set _),
    obtain ⟨x, hx₁, hx₂⟩ := this.nonempty,
    exact ⟨x, hx₁, by simpa [not_or_distrib] using hx₂⟩, },
  obtain ⟨x, hx₀, hx₁, hx₂⟩ := contra,
  replace hs : x ⊓ Sup s = ⊥,
  { have := hs.mono (by simp [ht₁, hx₀, -set.union_singleton] : ↑t ∪ {x} ≤ s) (by simp : x ∈ _),
    simpa [disjoint, hx₂, ← t.sup_id_eq_Sup, ← ht₂] using this, },
  apply hx₁,
  rw [← hs, eq_comm, inf_eq_left],
  exact le_Sup hx₀,
end

end complete_lattice

/-- A complete lattice is said to be compactly generated if any
element is the `Sup` of compact elements. -/
class is_compactly_generated (α : Type*) [complete_lattice α] : Prop :=
(exists_Sup_eq :
  ∀ (x : α), ∃ (s : set α), (∀ x ∈ s, complete_lattice.is_compact_element x) ∧ Sup s = x)

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

@[simp]
lemma Sup_compact_le_eq (b) : Sup {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} = b :=
begin
  rcases is_compactly_generated.exists_Sup_eq b with ⟨s, hs, rfl⟩,
  exact le_antisymm (Sup_le (λ c hc, hc.2)) (Sup_le_Sup (λ c cs, ⟨hs c cs, le_Sup cs⟩)),
end

@[simp]
theorem Sup_compact_eq_top :
  Sup {a : α | complete_lattice.is_compact_element a} = ⊤ :=
begin
  refine eq.trans (congr rfl (set.ext (λ x, _))) (Sup_compact_le_eq ⊤),
  exact (and_iff_left le_top).symm,
end

theorem le_iff_compact_le_imp {a b : α} :
  a ≤ b ↔ ∀ c : α, complete_lattice.is_compact_element c → c ≤ a → c ≤ b :=
⟨λ ab c hc ca, le_trans ca ab, λ h, begin
  rw [← Sup_compact_le_eq a, ← Sup_compact_le_eq b],
  exact Sup_le_Sup (λ c hc, ⟨hc.1, h c hc.1 hc.2⟩),
end⟩

/-- This property is sometimes referred to as `α` being upper continuous. -/
theorem inf_Sup_eq_of_directed_on (h : directed_on (≤) s):
  a ⊓ Sup s = ⨆ b ∈ s, a ⊓ b :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  by_cases hs : s.nonempty,
  { intros c hc hcinf,
    rw le_inf_iff at hcinf,
    rw complete_lattice.is_compact_element_iff_le_of_directed_Sup_le at hc,
    rcases hc s hs h hcinf.2 with ⟨d, ds, cd⟩,
    exact (le_inf hcinf.1 cd).trans (le_supr₂ d ds) },
  { rw set.not_nonempty_iff_eq_empty at hs,
    simp [hs] }
end) supr_inf_le_inf_Sup

/-- This property is equivalent to `α` being upper continuous. -/
theorem inf_Sup_eq_supr_inf_sup_finset :
  a ⊓ Sup s = ⨆ (t : finset α) (H : ↑t ⊆ s), a ⊓ (t.sup id) :=
le_antisymm (begin
  rw le_iff_compact_le_imp,
  intros c hc hcinf,
  rw le_inf_iff at hcinf,
  rcases hc s hcinf.2 with ⟨t, ht1, ht2⟩,
  exact (le_inf hcinf.1 ht2).trans (le_supr₂ t ht1),
end)
  (supr_le $ λ t, supr_le $ λ h, inf_le_inf_left _ ((finset.sup_id_eq_Sup t).symm ▸ (Sup_le_Sup h)))

theorem complete_lattice.set_independent_iff_finite {s : set α} :
  complete_lattice.set_independent s ↔
    ∀ t : finset α, ↑t ⊆ s → complete_lattice.set_independent (↑t : set α) :=
⟨λ hs t ht, hs.mono ht, λ h a ha, begin
  rw [disjoint_iff, inf_Sup_eq_supr_inf_sup_finset, supr_eq_bot],
  intro t,
  rw [supr_eq_bot, finset.sup_id_eq_Sup],
  intro ht,
  classical,
  have h' := (h (insert a t) _ (t.mem_insert_self a)).eq_bot,
  { rwa [finset.coe_insert, set.insert_diff_self_of_not_mem] at h',
    exact λ con, ((set.mem_diff a).1 (ht con)).2 (set.mem_singleton a) },
  { rw [finset.coe_insert, set.insert_subset],
    exact ⟨ha, set.subset.trans ht (set.diff_subset _ _)⟩ }
end⟩

lemma complete_lattice.set_independent_Union_of_directed {η : Type*}
  {s : η → set α} (hs : directed (⊆) s)
  (h : ∀ i, complete_lattice.set_independent (s i)) :
  complete_lattice.set_independent (⋃ i, s i) :=
begin
  by_cases hη : nonempty η,
  { resetI,
    rw complete_lattice.set_independent_iff_finite,
    intros t ht,
    obtain ⟨I, fi, hI⟩ := set.finite_subset_Union t.finite_to_set ht,
    obtain ⟨i, hi⟩ := hs.finset_le fi.to_finset,
    exact (h i).mono (set.subset.trans hI $ set.Union₂_subset $
      λ j hj, hi j (fi.mem_to_finset.2 hj)) },
  { rintros a ⟨_, ⟨i, _⟩, _⟩,
    exfalso, exact hη ⟨i⟩, },
end

lemma complete_lattice.independent_sUnion_of_directed {s : set (set α)}
  (hs : directed_on (⊆) s)
  (h : ∀ a ∈ s, complete_lattice.set_independent a) :
  complete_lattice.set_independent (⋃₀ s) :=
by rw set.sUnion_eq_Union; exact
  complete_lattice.set_independent_Union_of_directed hs.directed_coe (by simpa using h)


end

namespace complete_lattice

lemma compactly_generated_of_well_founded (h : well_founded ((>) : α → α → Prop)) :
  is_compactly_generated α :=
begin
  rw [well_founded_iff_is_Sup_finite_compact, is_Sup_finite_compact_iff_all_elements_compact] at h,
  -- x is the join of the set of compact elements {x}
  exact ⟨λ x, ⟨{x}, ⟨λ x _, h x, Sup_singleton⟩⟩⟩,
end

/-- A compact element `k` has the property that any `b < k` lies below a "maximal element below
`k`", which is to say `[⊥, k]` is coatomic. -/
theorem Iic_coatomic_of_compact_element {k : α} (h : is_compact_element k) :
  is_coatomic (set.Iic k) :=
⟨λ ⟨b, hbk⟩, begin
  by_cases htriv : b = k,
  { left, ext, simp only [htriv, set.Iic.coe_top, subtype.coe_mk], },
  right,
  obtain ⟨a, a₀, ba, h⟩ := zorn_nonempty_partial_order₀ (set.Iio k) _ b (lt_of_le_of_ne hbk htriv),
  { refine ⟨⟨a, le_of_lt a₀⟩, ⟨ne_of_lt a₀, λ c hck, by_contradiction $ λ c₀, _⟩, ba⟩,
    cases h c.1 (lt_of_le_of_ne c.2 (λ con, c₀ (subtype.ext con))) hck.le,
    exact lt_irrefl _ hck, },
  { intros S SC cC I IS,
    by_cases hS : S.nonempty,
    { exact ⟨Sup S, h.directed_Sup_lt_of_lt hS cC.directed_on SC, λ _, le_Sup⟩, },
    exact ⟨b, lt_of_le_of_ne hbk htriv, by simp only [set.not_nonempty_iff_eq_empty.mp hS,
      set.mem_empty_eq, forall_const, forall_prop_of_false, not_false_iff]⟩, },
end⟩

lemma coatomic_of_top_compact (h : is_compact_element (⊤ : α)) : is_coatomic α :=
(@order_iso.Iic_top α _ _).is_coatomic_iff.mp (Iic_coatomic_of_compact_element h)

end complete_lattice

section
variables [is_modular_lattice α] [is_compactly_generated α]

@[priority 100]
instance is_atomic_of_is_complemented [is_complemented α] : is_atomic α :=
⟨λ b, begin
  by_cases h : {c : α | complete_lattice.is_compact_element c ∧ c ≤ b} ⊆ {⊥},
  { left,
    rw [← Sup_compact_le_eq b, Sup_eq_bot],
    exact h },
  { rcases set.not_subset.1 h with ⟨c, ⟨hc, hcb⟩, hcbot⟩,
    right,
    have hc' := complete_lattice.Iic_coatomic_of_compact_element hc,
    rw ← is_atomic_iff_is_coatomic at hc',
    haveI := hc',
    obtain con | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le (⟨c, le_refl c⟩ : set.Iic c),
    { exfalso,
      apply hcbot,
      simp only [subtype.ext_iff, set.Iic.coe_bot, subtype.coe_mk] at con,
      exact con },
    rw [← subtype.coe_le_coe, subtype.coe_mk] at hac,
    exact ⟨a, ha.of_is_atom_coe_Iic, hac.trans hcb⟩ },
end⟩

/-- See Lemma 5.1, Călugăreanu -/
@[priority 100]
instance is_atomistic_of_is_complemented [is_complemented α] : is_atomistic α :=
⟨λ b, ⟨{a | is_atom a ∧ a ≤ b}, begin
  symmetry,
  have hle : Sup {a : α | is_atom a ∧ a ≤ b} ≤ b := (Sup_le $ λ _, and.right),
  apply (lt_or_eq_of_le hle).resolve_left (λ con, _),
  obtain ⟨c, hc⟩ := exists_is_compl (⟨Sup {a : α | is_atom a ∧ a ≤ b}, hle⟩ : set.Iic b),
  obtain rfl | ⟨a, ha, hac⟩ := eq_bot_or_exists_atom_le c,
  { exact ne_of_lt con (subtype.ext_iff.1 (eq_top_of_is_compl_bot hc)) },
  { apply ha.1,
    rw eq_bot_iff,
    apply le_trans (le_inf _ hac) hc.1,
    rw [← subtype.coe_le_coe, subtype.coe_mk],
    exact le_Sup ⟨ha.of_is_atom_coe_Iic, a.2⟩ }
end, λ _, and.left⟩⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem is_complemented_of_Sup_atoms_eq_top (h : Sup {a : α | is_atom a} = ⊤) : is_complemented α :=
⟨λ b, begin
  obtain ⟨s, ⟨s_ind, b_inf_Sup_s, s_atoms⟩, s_max⟩ := zorn_subset
    {s : set α | complete_lattice.set_independent s ∧ b ⊓ Sup s = ⊥ ∧ ∀ a ∈ s, is_atom a} _,
  { refine ⟨Sup s, le_of_eq b_inf_Sup_s, _⟩,
    rw [← h, Sup_le_iff],
    intros a ha,
    rw ← inf_eq_left,
    refine (ha.le_iff.mp inf_le_left).resolve_left (λ con, ha.1 _),
    rw [eq_bot_iff, ← con],
    refine le_inf (le_refl a) ((le_Sup _).trans le_sup_right),
    rw ← disjoint_iff at *,
    have a_dis_Sup_s : disjoint a (Sup s) := con.mono_right le_sup_right,
    rw ← s_max (s ∪ {a}) ⟨λ x hx, _, ⟨_, λ x hx, _⟩⟩ (set.subset_union_left _ _),
    { exact set.mem_union_right _ (set.mem_singleton _) },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      by_cases xa : x = a,
      { simp only [xa, set.mem_singleton, set.insert_diff_of_mem, set.union_singleton],
        exact con.mono_right (le_trans (Sup_le_Sup (set.diff_subset s {a})) le_sup_right) },
      { have h : (s ∪ {a}) \ {x} = (s \ {x}) ∪ {a},
        { simp only [set.union_singleton],
          rw set.insert_diff_of_not_mem,
          rw set.mem_singleton_iff,
          exact ne.symm xa },
        rw [h, Sup_union, Sup_singleton],
        apply (s_ind (hx.resolve_right xa)).disjoint_sup_right_of_disjoint_sup_left
          (a_dis_Sup_s.mono_right _).symm,
        rw [← Sup_insert, set.insert_diff_singleton,
          set.insert_eq_of_mem (hx.resolve_right xa)] } },
    { rw [Sup_union, Sup_singleton, ← disjoint_iff],
      exact b_inf_Sup_s.disjoint_sup_right_of_disjoint_sup_left con.symm },
    { rw [set.mem_union, set.mem_singleton_iff] at hx,
      cases hx,
      { exact s_atoms x hx },
      { rw hx,
        exact ha } } },
  { intros c hc1 hc2,
    refine ⟨⋃₀ c, ⟨complete_lattice.independent_sUnion_of_directed hc2.directed_on
      (λ s hs, (hc1 hs).1), _, λ a ha, _⟩, λ _, set.subset_sUnion_of_mem⟩,
    { rw [Sup_sUnion, ← Sup_image, inf_Sup_eq_of_directed_on, supr_eq_bot],
      { intro i,
        rw supr_eq_bot,
        intro hi,
        obtain ⟨x, xc, rfl⟩ := (set.mem_image _ _ _).1 hi,
        exact (hc1 xc).2.1 },
      { rw directed_on_image,
        refine hc2.directed_on.mono (λ s t, Sup_le_Sup) } },
    { rcases set.mem_sUnion.1 ha with ⟨s, sc, as⟩,
      exact (hc1 sc).2.2 a as } }
end⟩

/-- See Theorem 6.6, Călugăreanu -/
theorem is_complemented_of_is_atomistic [is_atomistic α] : is_complemented α :=
is_complemented_of_Sup_atoms_eq_top Sup_atoms_eq_top

theorem is_complemented_iff_is_atomistic : is_complemented α ↔ is_atomistic α :=
begin
  split; introsI,
  { exact is_atomistic_of_is_complemented },
  { exact is_complemented_of_is_atomistic }
end

end


<|start_filename|>src/tactic/rewrite_search/explain.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>, <NAME>, <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/

import tactic.rewrite_search.types
import tactic.converter.interactive -- Required for us to emit more compact `conv` invocations

/-!
# Tools to extract valid Lean code from a path found by rewrite search.
-/

open interactive interactive.types expr tactic

namespace tactic.rewrite_search

universes u

/--
A `dir_pair` is a pair of items designed to be accessed according to
`dir`, a "direction" defined in the `expr_lens` library.
-/
@[derive inhabited]
structure dir_pair (α : Type u) :=
(l r : α)

namespace dir_pair
open expr_lens

variables {α β : Type} (p : dir_pair α)

/-- Get one side of the pair, picking the side according to the direction. -/
def get : dir → α
| dir.F := p.l
| dir.A := p.r

/-- Set one side of the pair, picking the side according to the direction. -/
def set : dir → α → dir_pair α
| dir.F v := ⟨v, p.r⟩
| dir.A v := ⟨p.l, v⟩

/-- Convert the pair to a list of its elements. -/
def to_list : list α := [p.l, p.r]

/-- Convert the pair to a readable string format. -/
def to_string [has_to_string α] (p : dir_pair α) : string :=
to_string p.l ++ "-" ++ to_string p.r

instance has_to_string [has_to_string α] : has_to_string (dir_pair α) := ⟨to_string⟩

end dir_pair

/-- Helper for getting the nth item in a list of rules -/
private meta def nth_rule (rs : list (expr × bool)) (i : ℕ) : expr × bool := (rs.nth i).iget

/-- Convert a rule into the string of Lean code used to refer to this rule. -/
private meta def pp_rule (r : expr × bool) : tactic string :=
do pp ← pp r.1, return $ (if r.2 then "←" else "") ++ to_string pp

private meta def how.to_rewrite (rs : list (expr × bool)) : how → option (expr × bool)
| h := nth_rule rs h.rule_index

/-- Explain a single rewrite using `nth_rewrite`. -/
private meta def explain_using_location (rs : list (expr × bool)) (s : side) :
  how → tactic (option string)
| h := do
  rule ← pp_rule $ nth_rule rs h.rule_index,
  return $ some ("nth_rewrite_" ++ s.to_xhs ++ " " ++ to_string h.location ++ " " ++ rule)

/-- Explain a list of rewrites using `nth_rewrite`. -/
private meta def using_location.explain_rewrites (rs : list (expr × bool)) (s : side)
  (steps : list how) : tactic string :=
do rules ← steps.mmap $ λ h : how, option.to_list <$> explain_using_location rs s h,
  return $ string.intercalate ",\n  " rules.join

namespace using_conv

/-- `app_addr` represents a tree structure that `conv` tactics use for a rewrite. -/
inductive app_addr
| node (children : dir_pair (option app_addr)) : app_addr
| rw : list ℕ → app_addr

open app_addr

private meta def app_addr.to_string : app_addr → string
| (node c) := "(node " ++ ((c.to_list.filter_map id).map app_addr.to_string).to_string ++ ")"
| (rw rws) := "(rw " ++ rws.to_string ++ ")"

/--
A data structure for the result of a splice operation.
obstructed:  There was more of the addr to be added left, but we hit a rw
contained:   The added addr was already contained, and did not terminate at an existing rw
new:         The added addr terminated at an existing rw or we could create a new one for it
-/
@[derive inhabited]
inductive splice_result
| obstructed
| contained
| new (addr : app_addr)

open splice_result

private meta def pack_splice_result (s : expr_lens.dir) :
  splice_result → dir_pair (option app_addr) → splice_result
| (new addr) c := new $ app_addr.node $ c.set s (some addr)
| sr _ := sr

private meta def splice_in_aux (new_rws : list ℕ) :
  option app_addr → list expr_lens.dir → splice_result
| (some $ node _) [] := contained
| (some $ node c) (s :: rest) := pack_splice_result s (splice_in_aux (c.get s) rest) c
| (some $ rw _) (_ :: _) := obstructed
| (some $ rw rws) [] := new $ rw (rws ++ new_rws)
| none [] := new $ rw new_rws
| none l := splice_in_aux (some $ node ⟨none, none⟩) l

open expr_lens

private meta def to_congr_form : list expr_lens.dir → tactic (list expr_lens.dir)
| [] := return []
| (dir.F :: (dir.A :: rest)) := do
  r ← to_congr_form rest,
  return (dir.F :: r)
| (dir.A :: rest) := do
  r ← to_congr_form rest,
  return (dir.A :: r)
| [dir.F] := fail "app list ends in side.L!"
| (dir.F :: (dir.F :: _)) := fail "app list has repeated side.L!"

/-- Attempt to add new rewrites into the `app_addr` tree. -/
private meta def splice_in (a : option app_addr) (rws : list ℕ) (s : list expr_lens.dir) :
  tactic splice_result :=
splice_in_aux rws a <$> to_congr_form s

/-- Construct a single `erw` tactic for the given rules. -/
private meta def build_rw_tactic (rs : list (expr × bool)) (hs : list ℕ) : tactic string :=
do rws ← (hs.map $ nth_rule rs).mmap pp_rule,
  return $ "erw [" ++ (string.intercalate ", " rws) ++ "]"

private meta def explain_tree_aux (rs : list (expr × bool)) :
app_addr → tactic (option (list string))
| (app_addr.rw rws) := (λ a, some [a]) <$> build_rw_tactic rs rws
| (app_addr.node ⟨func, arg⟩) := do
  sf ← match func with | none := pure none | some func := explain_tree_aux func end,
  sa ← match arg  with | none := pure none | some arg  := explain_tree_aux arg  end,
  return $ match (sf, sa) with
  | (none, none) := none
  | (some sf, none) := ["congr"].append sf
  | (none, some sa) := ["congr", "skip"].append sa
  | (some sf, some sa) := (["congr"].append sf).append (["skip"].append sf)
  end

/-- Construct a string of Lean code that does a rewrite for the provided tree. -/
private meta def explain_tree (rs : list (expr × bool)) (tree : app_addr) :
  tactic (list string) :=
list.join <$> option.to_list <$> explain_tree_aux rs tree

/--
Gather all rewrites into trees, then generate a line of code for each tree.
The return value has one `conv_x` tactic on each line.
-/
private meta def explanation_lines (rs : list (expr × bool)) (s : side) :
option app_addr → list how → tactic (list string)
| none [] := return []
| (some tree) [] := do
  tacs ← explain_tree rs tree,
  return $ if tacs.length = 0 then []
  else ["conv_" ++ s.to_xhs ++ " { " ++ string.intercalate ", " tacs ++ " }"]
| tree (h :: rest) := do
  (new_tree, rest_if_fail) ← match h.addr with
  | (some addr) := do
    new_tree ← splice_in tree [h.rule_index] addr,
    return (some new_tree, list.cons h rest)
  | none := do
    return (none, rest)
  end,
  match new_tree with
  | some (new new_tree) := explanation_lines new_tree rest
  | _ := do
    line ← explanation_lines tree [],
    lines ← explanation_lines none rest_if_fail,
    return $ line ++ lines
  end

/-- Explain a list of rewrites using `conv_x` tactics. -/
meta def explain_rewrites (rs : list (expr × bool)) (s : side) (hows : list how) :
  tactic string :=
string.intercalate ",\n  " <$> explanation_lines rs s none hows

end using_conv

private meta def explain_rewrites_concisely (steps : list (expr × bool)) (needs_refl : bool) :
  tactic string :=
do rules ← string.intercalate ", " <$> steps.mmap pp_rule,
  return $ "erw [" ++ rules ++ "]" ++ (if needs_refl then ", refl" else "")

/--
Fails if we can't just use rewrite.
Otherwise, returns 'tt' if we need a `refl` at the end.
-/
private meta def check_if_simple_rewrite_succeeds (rewrites : list (expr × bool)) (goal : expr) :
  tactic bool :=
lock_tactic_state $ do
  m ← mk_meta_var goal,
  set_goals [m],
  rewrites.mmap' $ λ q, rewrite_target q.1 {symm := q.2, md := semireducible},
  (reflexivity reducible >> return ff) <|> (reflexivity >> return tt)

/-- Construct a list of rewrites from a proof unit. -/
meta def proof_unit.rewrites (u : proof_unit) (rs : list (expr × bool)) : list (expr × bool) :=
u.steps.filter_map $ how.to_rewrite rs

/-- Construct an explanation string from a proof unit. -/
meta def proof_unit.explain (u : proof_unit) (rs : list (expr × bool))
  (explain_using_conv : bool) : tactic string :=
if explain_using_conv then
  using_conv.explain_rewrites rs u.side u.steps
else
  using_location.explain_rewrites rs u.side u.steps

private meta def explain_proof_full (rs : list (expr × bool)) (explain_using_conv : bool) :
list proof_unit → tactic string
| [] := return ""
| (u :: rest) := do
  -- Don't use transitivity for the last unit, since it must be redundant.
  head ← if rest.length = 0 ∨ u.side = side.L then pure [] else (do
    n ← infer_type u.proof >>= (λ e, prod.snd <$> (match_eq e <|> match_iff e)) >>= pp,
    pure $ ["transitivity " ++ to_string n]),
  unit_expl ← u.explain rs explain_using_conv,
  rest_expl ← explain_proof_full rest,
  let expls := (head ++ [unit_expl, rest_expl]).filter $ λ t, ¬(t.length = 0),
  return $ string.intercalate ",\n  " expls

private meta def explain_proof_concisely (rules : list (expr × bool)) (proof : expr)
  (l : list proof_unit) : tactic string :=
do let rws : list (expr × bool) := list.join $ l.map (λ u, do
    (r, s) ← u.rewrites rules,
    return (r, if u.side = side.L then s else ¬s)),
  goal ← infer_type proof,
  needs_refl ← check_if_simple_rewrite_succeeds rws goal,
  explain_rewrites_concisely rws needs_refl

/--
Trace a human-readable explanation in Lean code of a proof generated by rewrite search.
Emit it as `"Try this: <code>"` with each successive line of code indented.
-/
meta def explain_search_result (cfg : config) (rules : list (expr × bool)) (proof : expr)
  (units : list proof_unit) : tactic unit :=
if units.empty then trace "Try this: exact rfl" else do
  explanation ← explain_proof_concisely rules proof units <|>
                explain_proof_full rules cfg.explain_using_conv units,
  trace $ "Try this: " ++ explanation

end tactic.rewrite_search


<|start_filename|>src/analysis/normed_space/algebra.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import topology.algebra.module.character_space
import analysis.normed_space.weak_dual
import analysis.normed_space.spectrum

/-!
# Normed algebras

This file contains basic facts about normed algebras.

## Main results

* We show that the character space of a normed algebra is compact using the Banach-Alaoglu theorem.

## TODO

* Show compactness for topological vector spaces; this requires the TVS version of Banach-Alaoglu.

## Tags

normed algebra, character space, continuous functional calculus

-/

variables {𝕜 : Type*} {A : Type*}

namespace weak_dual
namespace character_space

variables [nondiscrete_normed_field 𝕜] [normed_ring A]
  [normed_algebra 𝕜 A] [complete_space A] [norm_one_class A]

lemma norm_one (φ : character_space 𝕜 A) : ∥to_normed_dual (φ : weak_dual 𝕜 A)∥ = 1 :=
begin
  refine continuous_linear_map.op_norm_eq_of_bounds zero_le_one (λ a, _) (λ x hx h, _),
  { rw [one_mul],
    exact spectrum.norm_le_norm_of_mem (apply_mem_spectrum φ a) },
  { have : ∥φ 1∥ ≤ x * ∥(1 : A)∥ := h 1,
    simpa only [norm_one, mul_one, map_one] using this },
end

instance [proper_space 𝕜] : compact_space (character_space 𝕜 A) :=
begin
  rw [←is_compact_iff_compact_space],
  have h : character_space 𝕜 A ⊆ to_normed_dual ⁻¹' metric.closed_ball 0 1,
  { intros φ hφ,
    rw [set.mem_preimage, mem_closed_ball_zero_iff],
    exact (le_of_eq $ norm_one ⟨φ, ⟨hφ.1, hφ.2⟩⟩ : _), },
  exact compact_of_is_closed_subset (is_compact_closed_ball 𝕜 0 1) is_closed h,
end

end character_space
end weak_dual


<|start_filename|>src/order/directed.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.set.basic
import order.lattice
import order.max

/-!
# Directed indexed families and sets

This file defines directed indexed families and directed sets. An indexed family/set is
directed iff each pair of elements has a shared upper bound.

## Main declarations

* `directed r f`: Predicate stating that the indexed family `f` is `r`-directed.
* `directed_on r s`: Predicate stating that the set `s` is `r`-directed.
* `is_directed α r`: Prop-valued mixin stating that `α` is `r`-directed. Follows the style of the
  unbundled relation classes such as `is_total`.
-/

open function

universes u v w

variables {α : Type u} {β : Type v} {ι : Sort w} (r s : α → α → Prop)
local infix ` ≼ ` : 50 := r

/-- A family of elements of α is directed (with respect to a relation `≼` on α)
  if there is a member of the family `≼`-above any pair in the family.  -/
def directed (f : ι → α) := ∀ x y, ∃ z, f x ≼ f z ∧ f y ≼ f z

/-- A subset of α is directed if there is an element of the set `≼`-above any
  pair of elements in the set. -/
def directed_on (s : set α) := ∀ (x ∈ s) (y ∈ s), ∃ z ∈ s, x ≼ z ∧ y ≼ z

variables {r}

theorem directed_on_iff_directed {s} : @directed_on α r s ↔ directed r (coe : s → α) :=
by simp [directed, directed_on]; refine ball_congr (λ x hx, by simp; refl)

alias directed_on_iff_directed ↔ directed_on.directed_coe _

theorem directed_on_image {s} {f : β → α} :
  directed_on r (f '' s) ↔ directed_on (f ⁻¹'o r) s :=
by simp only [directed_on, set.ball_image_iff, set.bex_image_iff, order.preimage]

theorem directed_on.mono {s : set α} (h : directed_on r s)
  {r' : α → α → Prop} (H : ∀ {a b}, r a b → r' a b) :
  directed_on r' s :=
λ x hx y hy, let ⟨z, zs, xz, yz⟩ := h x hx y hy in ⟨z, zs, H xz, H yz⟩

theorem directed_comp {ι} {f : ι → β} {g : β → α} :
  directed r (g ∘ f) ↔ directed (g ⁻¹'o r) f := iff.rfl

theorem directed.mono {s : α → α → Prop} {ι} {f : ι → α}
  (H : ∀ a b, r a b → s a b) (h : directed r f) : directed s f :=
λ a b, let ⟨c, h₁, h₂⟩ := h a b in ⟨c, H _ _ h₁, H _ _ h₂⟩

theorem directed.mono_comp {ι} {rb : β → β → Prop} {g : α → β} {f : ι → α}
  (hg : ∀ ⦃x y⦄, x ≼ y → rb (g x) (g y)) (hf : directed r f) :
  directed rb (g ∘ f) :=
directed_comp.2 $ hf.mono hg

/-- A monotone function on a sup-semilattice is directed. -/
lemma directed_of_sup [semilattice_sup α] {f : α → β} {r : β → β → Prop}
  (H : ∀ ⦃i j⦄, i ≤ j → r (f i) (f j)) : directed r f :=
λ a b, ⟨a ⊔ b, H le_sup_left, H le_sup_right⟩

lemma monotone.directed_le [semilattice_sup α] [preorder β] {f : α → β} :
  monotone f → directed (≤) f :=
directed_of_sup

lemma directed.extend_bot [preorder α] [order_bot α] {e : ι → β} {f : ι → α}
  (hf : directed (≤) f) (he : function.injective e) :
  directed (≤) (function.extend e f ⊥) :=
begin
  intros a b,
  rcases (em (∃ i, e i = a)).symm with ha | ⟨i, rfl⟩,
  { use b, simp [function.extend_apply' _ _ _ ha] },
  rcases (em (∃ i, e i = b)).symm with hb | ⟨j, rfl⟩,
  { use e i, simp [function.extend_apply' _ _ _ hb] },
  rcases hf i j with ⟨k, hi, hj⟩,
  use (e k),
  simp only [function.extend_apply he, *, true_and]
end

/-- An antitone function on an inf-semilattice is directed. -/
lemma directed_of_inf [semilattice_inf α] {r : β → β → Prop} {f : α → β}
  (hf : ∀ a₁ a₂, a₁ ≤ a₂ → r (f a₂) (f a₁)) : directed r f :=
λ x y, ⟨x ⊓ y, hf _ _ inf_le_left, hf _ _ inf_le_right⟩

/-- `is_directed α r` states that for any elements `a`, `b` there exists an element `c` such that
`r a c` and `r b c`. -/
class is_directed (α : Type*) (r : α → α → Prop) : Prop :=
(directed (a b : α) : ∃ c, r a c ∧ r b c)

lemma directed_of (r : α → α → Prop) [is_directed α r] (a b : α) : ∃ c, r a c ∧ r b c :=
is_directed.directed _ _

lemma directed_id [is_directed α r] : directed r id := by convert directed_of r
lemma directed_id_iff : directed r id ↔ is_directed α r := ⟨λ h, ⟨h⟩, @directed_id _ _⟩

lemma directed_on_univ [is_directed α r] : directed_on r set.univ :=
λ a _ b _, let ⟨c, hc⟩ := directed_of r a b in ⟨c, trivial, hc⟩

lemma directed_on_univ_iff : directed_on r set.univ ↔ is_directed α r :=
⟨λ h, ⟨λ a b, let ⟨c, _, hc⟩ := h a trivial b trivial in ⟨c, hc⟩⟩, @directed_on_univ _ _⟩

@[priority 100]  -- see Note [lower instance priority]
instance is_total.to_is_directed [is_total α r] : is_directed α r :=
⟨λ a b, or.cases_on (total_of r a b) (λ h, ⟨b, h, refl _⟩) (λ h, ⟨a, refl _, h⟩)⟩

lemma is_directed_mono [is_directed α r] (h : ∀ ⦃a b⦄, r a b → s a b) : is_directed α s :=
⟨λ a b, let ⟨c, ha, hb⟩ := is_directed.directed a b in ⟨c, h ha, h hb⟩⟩

lemma exists_ge_ge [has_le α] [is_directed α (≤)] (a b : α) : ∃ c, a ≤ c ∧ b ≤ c :=
directed_of (≤) a b

lemma exists_le_le [has_le α] [is_directed α (≥)] (a b : α) : ∃ c, c ≤ a ∧ c ≤ b :=
directed_of (≥) a b

instance order_dual.is_directed_ge [has_le α] [is_directed α (≤)] : is_directed αᵒᵈ (≥) :=
by assumption

instance order_dual.is_directed_le [has_le α] [is_directed α (≥)] : is_directed αᵒᵈ (≤) :=
by assumption

section preorder
variables [preorder α] {a : α}

protected lemma is_min.is_bot [is_directed α (≥)] (h : is_min a) : is_bot a :=
λ b, let ⟨c, hca, hcb⟩ := exists_le_le a b in (h hca).trans hcb

protected lemma is_max.is_top [is_directed α (≤)] (h : is_max a) : is_top a :=
h.to_dual.is_bot

lemma is_top_or_exists_gt [is_directed α (≤)] (a : α) : is_top a ∨ (∃ b, a < b) :=
(em (is_max a)).imp is_max.is_top not_is_max_iff.mp

lemma is_bot_or_exists_lt [is_directed α (≥)] (a : α) : is_bot a ∨ (∃ b, b < a) :=
@is_top_or_exists_gt αᵒᵈ _ _ a

lemma is_bot_iff_is_min [is_directed α (≥)] : is_bot a ↔ is_min a :=
⟨is_bot.is_min, is_min.is_bot⟩

lemma is_top_iff_is_max [is_directed α (≤)] : is_top a ↔ is_max a := ⟨is_top.is_max, is_max.is_top⟩

variables (β) [partial_order β]

theorem exists_lt_of_directed_ge [is_directed β (≥)] [nontrivial β] : ∃ a b : β, a < b :=
begin
  rcases exists_pair_ne β with ⟨a, b, hne⟩,
  rcases is_bot_or_exists_lt a with ha|⟨c, hc⟩,
  exacts [⟨a, b, (ha b).lt_of_ne hne⟩, ⟨_, _, hc⟩]
end

theorem exists_lt_of_directed_le [is_directed β (≤)] [nontrivial β] : ∃ a b : β, a < b :=
let ⟨a, b, h⟩ := exists_lt_of_directed_ge βᵒᵈ in ⟨b, a, h⟩

end preorder

@[priority 100]  -- see Note [lower instance priority]
instance semilattice_sup.to_is_directed_le [semilattice_sup α] : is_directed α (≤) :=
⟨λ a b, ⟨a ⊔ b, le_sup_left, le_sup_right⟩⟩

@[priority 100]  -- see Note [lower instance priority]
instance semilattice_inf.to_is_directed_ge [semilattice_inf α] : is_directed α (≥) :=
⟨λ a b, ⟨a ⊓ b, inf_le_left, inf_le_right⟩⟩

@[priority 100]  -- see Note [lower instance priority]
instance order_top.to_is_directed_le [has_le α] [order_top α] : is_directed α (≤) :=
⟨λ a b, ⟨⊤, le_top, le_top⟩⟩

@[priority 100]  -- see Note [lower instance priority]
instance order_bot.to_is_directed_ge [has_le α] [order_bot α] : is_directed α (≥) :=
⟨λ a b, ⟨⊥, bot_le, bot_le⟩⟩


<|start_filename|>src/number_theory/primes_congruent_one.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import ring_theory.polynomial.cyclotomic.eval

/-!
# Primes congruent to one

We prove that, for any positive `k : ℕ`, there are infinitely many primes `p` such that
`p ≡ 1 [MOD k]`.
-/

namespace nat

open polynomial nat filter

/-- For any positive `k : ℕ` there are infinitely many primes `p` such that `p ≡ 1 [MOD k]`. -/
lemma exists_prime_ge_modeq_one {k : ℕ} (n : ℕ) (hpos : 0 < k) :
  ∃ (p : ℕ), nat.prime p ∧ n ≤ p ∧ p ≡ 1 [MOD k] :=
begin
  let b := 3 * (k * n.factorial),
  have hgt : 1 < (eval ↑b (cyclotomic k ℤ)).nat_abs,
  { have hkey : ∀ l : ℕ, 2 < 3 * (l.succ * n.factorial) := λ l, lt_mul_of_lt_of_one_le
          (2 : ℕ).lt_succ_self (le_mul_of_le_of_one_le (nat.succ_pos _) n.factorial_pos),
    rcases k with _ | _ | k,
    { simpa using hpos, },
    { simp only [one_mul, int.coe_nat_mul, int.coe_nat_succ, int.coe_nat_zero, zero_add,
        cyclotomic_one, eval_sub, eval_X, eval_one],
      convert int.nat_abs_lt_nat_abs_of_nonneg_of_lt int.one_nonneg _,
      rw lt_sub_iff_add_lt,
      specialize hkey 0,
      norm_cast,
      rwa one_mul at hkey, },
    calc 1 ≤ _ : by { rw le_tsub_iff_left (one_le_two.trans (hkey _).le), exact (hkey _).le, }
       ... < _ : sub_one_lt_nat_abs_cyclotomic_eval (one_lt_succ_succ k)
                   (one_lt_two.trans (hkey k.succ)).ne.symm, },
  let p := min_fac (eval ↑b (cyclotomic k ℤ)).nat_abs,
  haveI hprime : fact p.prime := ⟨min_fac_prime (ne_of_lt hgt).symm⟩,
  have hroot : is_root (cyclotomic k (zmod p)) (cast_ring_hom (zmod p) b),
  { rw [is_root.def, ← map_cyclotomic_int k (zmod p), eval_map, coe_cast_ring_hom,
    ← int.cast_coe_nat, ← int.coe_cast_ring_hom, eval₂_hom, int.coe_cast_ring_hom,
      zmod.int_coe_zmod_eq_zero_iff_dvd _ _],
    apply int.dvd_nat_abs.1,
    exact_mod_cast min_fac_dvd (eval ↑b (cyclotomic k ℤ)).nat_abs },
  refine ⟨p, hprime.1, _, _⟩,
  { by_contra habs,
    exact (prime.dvd_iff_not_coprime hprime.1).1
      (dvd_factorial (min_fac_pos _) (le_of_not_ge habs))
      (coprime_of_root_cyclotomic hpos hroot).symm.coprime_mul_left_right.coprime_mul_left_right },
  { have hdiv := order_of_dvd_of_pow_eq_one (zmod.units_pow_card_sub_one_eq_one p
      (zmod.unit_of_coprime b (coprime_of_root_cyclotomic hpos hroot))),
    have : ¬p ∣ k := hprime.1.coprime_iff_not_dvd.1
      (coprime_of_root_cyclotomic hpos hroot).symm.coprime_mul_left_right.coprime_mul_right_right,
    haveI := ne_zero.of_not_dvd (zmod p) this,
    have : k = order_of (b : zmod p) := (is_root_cyclotomic_iff.mp hroot).eq_order_of,
    rw [←order_of_units, zmod.coe_unit_of_coprime, ←this] at hdiv,
    exact ((modeq_iff_dvd' hprime.1.pos).2 hdiv).symm }
end

lemma frequently_at_top_modeq_one {k : ℕ} (hpos : 0 < k) :
  ∃ᶠ p in at_top, nat.prime p ∧ p ≡ 1 [MOD k] :=
begin
  refine frequently_at_top.2 (λ n, _),
  obtain ⟨p, hp⟩ := exists_prime_ge_modeq_one n hpos,
  exact ⟨p, ⟨hp.2.1, hp.1, hp.2.2⟩⟩
end

lemma infinite_set_of_prime_modeq_one {k : ℕ} (hpos : 0 < k) :
  set.infinite {p : ℕ | nat.prime p ∧ p ≡ 1 [MOD k]} :=
frequently_at_top_iff_infinite.1 (frequently_at_top_modeq_one hpos)

end nat


<|start_filename|>src/topology/category/Top/basic.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import category_theory.concrete_category.bundled_hom
import category_theory.elementwise
import topology.continuous_function.basic

/-!
# Category instance for topological spaces

We introduce the bundled category `Top` of topological spaces together with the functors `discrete`
and `trivial` from the category of types to `Top` which equip a type with the corresponding
discrete, resp. trivial, topology. For a proof that these functors are left, resp. right adjoint
to the forgetful functor, see `topology.category.Top.adjunctions`.
-/

open category_theory
open topological_space

universe u

/-- The category of topological spaces and continuous maps. -/
def Top : Type (u+1) := bundled topological_space

namespace Top

instance bundled_hom : bundled_hom @continuous_map :=
⟨@continuous_map.to_fun, @continuous_map.id, @continuous_map.comp, @continuous_map.coe_injective⟩

attribute [derive [large_category, concrete_category]] Top

instance : has_coe_to_sort Top Type* := bundled.has_coe_to_sort

instance topological_space_unbundled (x : Top) : topological_space x := x.str

@[simp] lemma id_app (X : Top.{u}) (x : X) :
  (𝟙 X : X → X) x = x := rfl

@[simp] lemma comp_app {X Y Z : Top.{u}} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g : X → Z) x = g (f x) := rfl

/-- Construct a bundled `Top` from the underlying type and the typeclass. -/
def of (X : Type u) [topological_space X] : Top := ⟨X⟩

instance (X : Top) : topological_space X := X.str

@[simp] lemma coe_of (X : Type u) [topological_space X] : (of X : Type u) = X := rfl

instance : inhabited Top := ⟨Top.of empty⟩

/-- The discrete topology on any type. -/
def discrete : Type u ⥤ Top.{u} :=
{ obj := λ X, ⟨X, ⊥⟩,
  map := λ X Y f, { to_fun := f, continuous_to_fun := continuous_bot } }

/-- The trivial topology on any type. -/
def trivial : Type u ⥤ Top.{u} :=
{ obj := λ X, ⟨X, ⊤⟩,
  map := λ X Y f, { to_fun := f, continuous_to_fun := continuous_top } }

/-- Any homeomorphisms induces an isomorphism in `Top`. -/
@[simps] def iso_of_homeo {X Y : Top.{u}} (f : X ≃ₜ Y) : X ≅ Y :=
{ hom := ⟨f⟩,
  inv := ⟨f.symm⟩ }

/-- Any isomorphism in `Top` induces a homeomorphism. -/
@[simps] def homeo_of_iso {X Y : Top.{u}} (f : X ≅ Y) : X ≃ₜ Y :=
{ to_fun := f.hom,
  inv_fun := f.inv,
  left_inv := λ x, by simp,
  right_inv := λ x, by simp,
  continuous_to_fun := f.hom.continuous,
  continuous_inv_fun := f.inv.continuous }

@[simp] lemma of_iso_of_homeo {X Y : Top.{u}} (f : X ≃ₜ Y) : homeo_of_iso (iso_of_homeo f) = f :=
by { ext, refl }

@[simp] lemma of_homeo_of_iso {X Y : Top.{u}} (f : X ≅ Y) : iso_of_homeo (homeo_of_iso f) = f :=
by { ext, refl }

@[simp]
lemma open_embedding_iff_comp_is_iso {X Y Z : Top} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso g] :
  open_embedding (f ≫ g) ↔ open_embedding f :=
open_embedding_iff_open_embedding_compose f (Top.homeo_of_iso (as_iso g)).open_embedding

@[simp]
lemma open_embedding_iff_is_iso_comp {X Y Z : Top} (f : X ⟶ Y) (g : Y ⟶ Z) [is_iso f] :
  open_embedding (f ≫ g) ↔ open_embedding g :=
begin
  split,
  { intro h,
    convert h.comp (Top.homeo_of_iso (as_iso f).symm).open_embedding,
    exact congr_arg _ (is_iso.inv_hom_id_assoc f g).symm },
  { exact λ h, h.comp (Top.homeo_of_iso (as_iso f)).open_embedding }
end

end Top


<|start_filename|>src/algebra/ring/basic.lean<|end_filename|>
/-
Copyright (c) 2014 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>
-/
import algebra.divisibility
import algebra.regular.basic
import data.pi.algebra

/-!
# Semirings and rings

This file defines semirings, rings and domains. This is analogous to `algebra.group.defs` and
`algebra.group.basic`, the difference being that the former is about `+` and `*` separately, while
the present file is about their interaction.

## Main definitions

* `distrib`: Typeclass for distributivity of multiplication over addition.
* `has_distrib_neg`: Typeclass for commutativity of negation and multiplication. This is useful when
  dealing with multiplicative submonoids which are closed under negation without being closed under
  addition, for example `units`.
* `(non_unital_)(non_assoc_)(semi)ring`: Typeclasses for possibly non-unital or non-associative
  rings and semirings. Some combinations are not defined yet because they haven't found use.

## Tags

`semiring`, `comm_semiring`, `ring`, `comm_ring`, `domain`, `is_domain`, `nonzero`, `units`
-/
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {R : Type x}

set_option old_structure_cmd true
open function

/-!
### `distrib` class
-/

/-- A typeclass stating that multiplication is left and right distributive
over addition. -/
@[protect_proj, ancestor has_mul has_add]
class distrib (R : Type*) extends has_mul R, has_add R :=
(left_distrib : ∀ a b c : R, a * (b + c) = a * b + a * c)
(right_distrib : ∀ a b c : R, (a + b) * c = a * c + b * c)

/-- A typeclass stating that multiplication is left distributive over addition. -/
@[protect_proj]
class left_distrib_class (R : Type*) [has_mul R] [has_add R] :=
(left_distrib : ∀ a b c : R, a * (b + c) = a * b + a * c)

/-- A typeclass stating that multiplication is right distributive over addition. -/
@[protect_proj]
class right_distrib_class (R : Type*) [has_mul R] [has_add R] :=
(right_distrib : ∀ a b c : R, (a + b) * c = a * c + b * c)

@[priority 100] -- see Note [lower instance priority]
instance distrib.left_distrib_class (R : Type*) [distrib R] : left_distrib_class R :=
⟨distrib.left_distrib⟩

@[priority 100] -- see Note [lower instance priority]
instance distrib.right_distrib_class (R : Type*) [distrib R] : right_distrib_class R :=
⟨distrib.right_distrib⟩

lemma left_distrib [has_mul R] [has_add R] [left_distrib_class R] (a b c : R) :
  a * (b + c) = a * b + a * c :=
left_distrib_class.left_distrib a b c

alias left_distrib ← mul_add

lemma right_distrib [has_mul R] [has_add R] [right_distrib_class R] (a b c : R) :
  (a + b) * c = a * c + b * c :=
right_distrib_class.right_distrib a b c

alias right_distrib ← add_mul

lemma distrib_three_right [has_mul R] [has_add R] [right_distrib_class R] (a b c d : R) :
  (a + b + c) * d = a * d + b * d + c * d :=
by simp [right_distrib]

/-- Pullback a `distrib` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.distrib {S} [has_mul R] [has_add R] [distrib S]
  (f : R → S) (hf : injective f) (add : ∀ x y, f (x + y) = f x + f y)
  (mul : ∀ x y, f (x * y) = f x * f y) :
  distrib R :=
{ mul := (*),
  add := (+),
  left_distrib := λ x y z, hf $ by simp only [*, left_distrib],
  right_distrib := λ x y z, hf $ by simp only [*, right_distrib] }

/-- Pushforward a `distrib` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.distrib {S} [distrib R] [has_add S] [has_mul S]
  (f : R → S) (hf : surjective f) (add : ∀ x y, f (x + y) = f x + f y)
  (mul : ∀ x y, f (x * y) = f x * f y) :
  distrib S :=
{ mul := (*),
  add := (+),
  left_distrib := hf.forall₃.2 $ λ x y z, by simp only [← add, ← mul, left_distrib],
  right_distrib := hf.forall₃.2 $ λ x y z, by simp only [← add, ← mul, right_distrib] }

/-!
### Semirings
-/

/-- A not-necessarily-unital, not-necessarily-associative semiring. -/
@[protect_proj, ancestor add_comm_monoid distrib mul_zero_class]
class non_unital_non_assoc_semiring (α : Type u) extends
  add_comm_monoid α, distrib α, mul_zero_class α

/-- An associative but not-necessarily unital semiring. -/
@[protect_proj, ancestor non_unital_non_assoc_semiring semigroup_with_zero]
class non_unital_semiring (α : Type u) extends
  non_unital_non_assoc_semiring α, semigroup_with_zero α

/-- A unital but not-necessarily-associative semiring. -/
@[protect_proj, ancestor non_unital_non_assoc_semiring mul_zero_one_class]
class non_assoc_semiring (α : Type u) extends
  non_unital_non_assoc_semiring α, mul_zero_one_class α

/-- A semiring is a type with the following structures: additive commutative monoid
(`add_comm_monoid`), multiplicative monoid (`monoid`), distributive laws (`distrib`), and
multiplication by zero law (`mul_zero_class`). The actual definition extends `monoid_with_zero`
instead of `monoid` and `mul_zero_class`. -/
@[protect_proj, ancestor non_unital_semiring non_assoc_semiring monoid_with_zero]
class semiring (α : Type u) extends non_unital_semiring α, non_assoc_semiring α, monoid_with_zero α

section injective_surjective_maps

variables [has_zero β] [has_add β] [has_mul β] [has_scalar ℕ β]

/-- Pullback a `non_unital_non_assoc_semiring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_unital_non_assoc_semiring
  {α : Type u} [non_unital_non_assoc_semiring α]
  (f : β → α) (hf : injective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_unital_non_assoc_semiring β :=
{ .. hf.mul_zero_class f zero mul, .. hf.add_comm_monoid f zero add nsmul, .. hf.distrib f add mul }

/-- Pullback a `non_unital_semiring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_unital_semiring
  {α : Type u} [non_unital_semiring α]
  (f : β → α) (hf : injective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_unital_semiring β :=
{ .. hf.non_unital_non_assoc_semiring f zero add mul nsmul, .. hf.semigroup_with_zero f zero mul }

/-- Pullback a `non_assoc_semiring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_assoc_semiring
  {α : Type u} [non_assoc_semiring α] [has_one β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_assoc_semiring β :=
{ .. hf.non_unital_non_assoc_semiring f zero add mul nsmul, .. hf.mul_one_class f one mul }

/-- Pullback a `semiring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.semiring
  {α : Type u} [semiring α] [has_one β] [has_pow β ℕ]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  semiring β :=
{ .. hf.monoid_with_zero f zero one mul npow, .. hf.add_comm_monoid f zero add nsmul,
  .. hf.distrib f add mul }

/-- Pushforward a `non_unital_non_assoc_semiring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_unital_non_assoc_semiring
  {α : Type u} [non_unital_non_assoc_semiring α]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_unital_non_assoc_semiring β :=
{ .. hf.mul_zero_class f zero mul, .. hf.add_comm_monoid f zero add nsmul, .. hf.distrib f add mul }

/-- Pushforward a `non_unital_semiring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_unital_semiring
  {α : Type u} [non_unital_semiring α]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_unital_semiring β :=
{ .. hf.non_unital_non_assoc_semiring f zero add mul nsmul, .. hf.semigroup_with_zero f zero mul }

/-- Pushforward a `non_assoc_semiring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_assoc_semiring
  {α : Type u} [non_assoc_semiring α] [has_one β]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_assoc_semiring β :=
{ .. hf.non_unital_non_assoc_semiring f zero add mul nsmul, .. hf.mul_one_class f one mul }

/-- Pushforward a `semiring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.semiring
  {α : Type u} [semiring α] [has_one β] [has_pow β ℕ]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  semiring β :=
{ .. hf.monoid_with_zero f zero one mul npow, .. hf.add_comm_monoid f zero add nsmul,
  .. hf.distrib f add mul }

end injective_surjective_maps

section has_one_has_add

variables [has_one α] [has_add α]

lemma one_add_one_eq_two : 1 + 1 = (2 : α) := rfl

end has_one_has_add

section distrib_semigroup
variables [has_add α] [semigroup α]

theorem dvd_add [left_distrib_class α] {a b c : α} (h₁ : a ∣ b) (h₂ : a ∣ c) : a ∣ b + c :=
dvd.elim h₁ (λ d hd, dvd.elim h₂ (λ e he, dvd.intro (d + e) (by simp [left_distrib, hd, he])))

end distrib_semigroup

section distrib_mul_one_class
variables [has_add α] [mul_one_class α]

lemma add_one_mul [right_distrib_class α] (a b : α) : (a + 1) * b = a * b + b :=
by rw [add_mul, one_mul]
lemma mul_add_one [left_distrib_class α] (a b : α) : a * (b + 1) = a * b + a :=
by rw [mul_add, mul_one]
lemma one_add_mul [right_distrib_class α] (a b : α) : (1 + a) * b = b + a * b :=
by rw [add_mul, one_mul]
lemma mul_one_add [left_distrib_class α] (a b : α) : a * (1 + b) = a + a * b :=
by rw [mul_add, mul_one]

theorem two_mul [right_distrib_class α] (n : α) : 2 * n = n + n :=
eq.trans (right_distrib 1 1 n) (by simp)

theorem bit0_eq_two_mul [right_distrib_class α] (n : α) : bit0 n = 2 * n :=
(two_mul _).symm

theorem mul_two [left_distrib_class α] (n : α) : n * 2 = n + n :=
(left_distrib n 1 1).trans (by simp)

end distrib_mul_one_class

section semiring
variables [semiring α]

@[to_additive] lemma mul_ite {α} [has_mul α] (P : Prop) [decidable P] (a b c : α) :
  a * (if P then b else c) = if P then a * b else a * c :=
by split_ifs; refl

@[to_additive] lemma ite_mul {α} [has_mul α] (P : Prop) [decidable P] (a b c : α) :
  (if P then a else b) * c = if P then a * c else b * c :=
by split_ifs; refl

-- We make `mul_ite` and `ite_mul` simp lemmas,
-- but not `add_ite` or `ite_add`.
-- The problem we're trying to avoid is dealing with
-- summations of the form `∑ x in s, (f x + ite P 1 0)`,
-- in which `add_ite` followed by `sum_ite` would needlessly slice up
-- the `f x` terms according to whether `P` holds at `x`.
-- There doesn't appear to be a corresponding difficulty so far with
-- `mul_ite` and `ite_mul`.
attribute [simp] mul_ite ite_mul

@[simp] lemma mul_boole {α} [mul_zero_one_class α] (P : Prop) [decidable P] (a : α) :
  a * (if P then 1 else 0) = if P then a else 0 :=
by simp

@[simp] lemma boole_mul {α} [mul_zero_one_class α] (P : Prop) [decidable P] (a : α) :
  (if P then 1 else 0) * a = if P then a else 0 :=
by simp

lemma ite_mul_zero_left {α : Type*} [mul_zero_class α] (P : Prop) [decidable P] (a b : α) :
  ite P (a * b) 0 = ite P a 0 * b :=
by { by_cases h : P; simp [h], }

lemma ite_mul_zero_right {α : Type*} [mul_zero_class α] (P : Prop) [decidable P] (a b : α) :
  ite P (a * b) 0 = a * ite P b 0 :=
by { by_cases h : P; simp [h], }

lemma ite_and_mul_zero {α : Type*} [mul_zero_class α]
  (P Q : Prop) [decidable P] [decidable Q] (a b : α) :
  ite (P ∧ Q) (a * b) 0 = ite P a 0 * ite Q b 0 :=
by simp only [←ite_and, ite_mul, mul_ite, mul_zero, zero_mul, and_comm]

end semiring

namespace add_hom

/-- Left multiplication by an element of a type with distributive multiplication is an `add_hom`. -/
@[simps { fully_applied := ff}] def mul_left {R : Type*} [distrib R] (r : R) : add_hom R R :=
⟨(*) r, mul_add r⟩

/-- Left multiplication by an element of a type with distributive multiplication is an `add_hom`. -/
@[simps { fully_applied := ff}] def mul_right {R : Type*} [distrib R] (r : R) : add_hom R R :=
⟨λ a, a * r, λ _ _, add_mul _ _ r⟩

end add_hom

section add_hom_class

variables {F : Type*} [non_assoc_semiring α] [non_assoc_semiring β] [add_hom_class F α β]

/-- Additive homomorphisms preserve `bit0`. -/
@[simp] lemma map_bit0 (f : F) (a : α) : (f (bit0 a) : β) = bit0 (f a) :=
map_add _ _ _

end add_hom_class

namespace add_monoid_hom

/-- Left multiplication by an element of a (semi)ring is an `add_monoid_hom` -/
def mul_left {R : Type*} [non_unital_non_assoc_semiring R] (r : R) : R →+ R :=
{ to_fun := (*) r,
  map_zero' := mul_zero r,
  map_add' := mul_add r }

@[simp] lemma coe_mul_left {R : Type*} [non_unital_non_assoc_semiring R] (r : R) :
  ⇑(mul_left r) = (*) r := rfl

/-- Right multiplication by an element of a (semi)ring is an `add_monoid_hom` -/
def mul_right {R : Type*} [non_unital_non_assoc_semiring R] (r : R) : R →+ R :=
{ to_fun := λ a, a * r,
  map_zero' := zero_mul r,
  map_add' := λ _ _, add_mul _ _ r }

@[simp] lemma coe_mul_right {R : Type*} [non_unital_non_assoc_semiring R] (r : R) :
  ⇑(mul_right r) = (* r) := rfl

lemma mul_right_apply {R : Type*} [non_unital_non_assoc_semiring R] (a r : R) :
  mul_right r a = a * r := rfl

end add_monoid_hom

@[simp] theorem two_dvd_bit0 [semiring α] {a : α} : 2 ∣ bit0 a := ⟨a, bit0_eq_two_mul _⟩

/-- A non-unital commutative semiring is a `non_unital_semiring` with commutative multiplication.
In other words, it is a type with the following structures: additive commutative monoid
(`add_comm_monoid`), commutative semigroup (`comm_semigroup`), distributive laws (`distrib`), and
multiplication by zero law (`mul_zero_class`). -/
@[protect_proj, ancestor non_unital_semiring comm_semigroup]
class non_unital_comm_semiring (α : Type u) extends non_unital_semiring α, comm_semigroup α

section non_unital_comm_semiring
variables [non_unital_comm_semiring α] [non_unital_comm_semiring β] {a b c : α}

/-- Pullback a `non_unital_semiring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_unital_comm_semiring [has_zero γ] [has_add γ] [has_mul γ]
  [has_scalar ℕ γ] (f : γ → α) (hf : injective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_unital_comm_semiring γ :=
{ .. hf.non_unital_semiring f zero add mul nsmul, .. hf.comm_semigroup f mul }

/-- Pushforward a `non_unital_semiring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_unital_comm_semiring [has_zero γ] [has_add γ] [has_mul γ]
  [has_scalar ℕ γ] (f : α → γ) (hf : surjective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) :
  non_unital_comm_semiring γ :=
{ .. hf.non_unital_semiring f zero add mul nsmul, .. hf.comm_semigroup f mul }

lemma has_dvd.dvd.linear_comb {d x y : α} (hdx : d ∣ x) (hdy : d ∣ y) (a b : α) :
  d ∣ (a * x + b * y) :=
dvd_add (hdx.mul_left a) (hdy.mul_left b)

end non_unital_comm_semiring

/-- A commutative semiring is a `semiring` with commutative multiplication. In other words, it is a
type with the following structures: additive commutative monoid (`add_comm_monoid`), multiplicative
commutative monoid (`comm_monoid`), distributive laws (`distrib`), and multiplication by zero law
(`mul_zero_class`). -/
@[protect_proj, ancestor semiring comm_monoid]
class comm_semiring (α : Type u) extends semiring α, comm_monoid α

@[priority 100] -- see Note [lower instance priority]
instance comm_semiring.to_non_unital_comm_semiring [comm_semiring α] : non_unital_comm_semiring α :=
{ .. comm_semiring.to_comm_monoid α, .. comm_semiring.to_semiring α }

@[priority 100] -- see Note [lower instance priority]
instance comm_semiring.to_comm_monoid_with_zero [comm_semiring α] : comm_monoid_with_zero α :=
{ .. comm_semiring.to_comm_monoid α, .. comm_semiring.to_semiring α }

section comm_semiring
variables [comm_semiring α] [comm_semiring β] {a b c : α}

/-- Pullback a `semiring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.comm_semiring [has_zero γ] [has_one γ] [has_add γ] [has_mul γ]
  [has_scalar ℕ γ] [has_pow γ ℕ] (f : γ → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  comm_semiring γ :=
{ .. hf.semiring f zero one add mul nsmul npow, .. hf.comm_semigroup f mul }

/-- Pushforward a `semiring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.comm_semiring [has_zero γ] [has_one γ] [has_add γ] [has_mul γ]
  [has_scalar ℕ γ] [has_pow γ ℕ] (f : α → γ) (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  comm_semiring γ :=
{ .. hf.semiring f zero one add mul nsmul npow, .. hf.comm_semigroup f mul }

lemma add_mul_self_eq (a b : α) : (a + b) * (a + b) = a*a + 2*a*b + b*b :=
by simp only [two_mul, add_mul, mul_add, add_assoc, mul_comm b]

end comm_semiring

section has_distrib_neg

/-- Typeclass for a negation operator that distributes across multiplication.

This is useful for dealing with submonoids of a ring that contain `-1` without having to duplicate
lemmas. -/
class has_distrib_neg (α : Type*) [has_mul α] extends has_involutive_neg α :=
(neg_mul : ∀ x y : α, -x * y = -(x * y))
(mul_neg : ∀ x y : α, x * -y = -(x * y))

section has_mul
variables [has_mul α] [has_distrib_neg α]

@[simp] lemma neg_mul (a b : α) : - a * b = - (a * b) :=
has_distrib_neg.neg_mul _ _

@[simp] lemma mul_neg (a b : α) : a * - b = - (a * b) :=
has_distrib_neg.mul_neg _ _

lemma neg_mul_neg (a b : α) : -a * -b = a * b :=
by simp

lemma neg_mul_eq_neg_mul (a b : α) : -(a * b) = -a * b :=
(neg_mul _ _).symm

lemma neg_mul_eq_mul_neg (a b : α) : -(a * b) = a * -b :=
(mul_neg _ _).symm

lemma neg_mul_comm (a b : α) : -a * b = a * -b :=
by simp

/-- A type endowed with `-` and `*` has distributive negation, if it admits an injective map that
preserves `-` and `*` to a type which has distributive negation. -/
@[reducible] -- See note [reducible non-instances]
protected def function.injective.has_distrib_neg [has_neg β] [has_mul β] (f : β → α)
  (hf : injective f) (neg : ∀ a, f (-a) = -f a) (mul : ∀ a b, f (a * b) = f a * f b) :
  has_distrib_neg β :=
{ neg_mul := λ x y, hf $ by erw [neg, mul, neg, neg_mul, mul],
  mul_neg := λ x y, hf $ by erw [neg, mul, neg, mul_neg, mul],
  ..hf.has_involutive_neg _ neg, ..‹has_mul β› }

/-- A type endowed with `-` and `*` has distributive negation, if it admits a surjective map that
preserves `-` and `*` from a type which has distributive negation. -/
@[reducible] -- See note [reducible non-instances]
protected def function.surjective.has_distrib_neg [has_neg β] [has_mul β] (f : α → β)
  (hf : surjective f) (neg : ∀ a, f (-a) = -f a) (mul : ∀ a b, f (a * b) = f a * f b) :
  has_distrib_neg β :=
{ neg_mul := hf.forall₂.2 $ λ x y, by { erw [←neg, ← mul, neg_mul, neg, mul], refl },
  mul_neg := hf.forall₂.2 $ λ x y, by { erw [←neg, ← mul, mul_neg, neg, mul], refl },
  ..hf.has_involutive_neg _ neg, ..‹has_mul β› }

namespace add_opposite

instance : has_distrib_neg αᵃᵒᵖ := unop_injective.has_distrib_neg _ unop_neg unop_mul

end add_opposite

open mul_opposite

instance : has_distrib_neg αᵐᵒᵖ :=
{ neg_mul := λ _ _, unop_injective $ mul_neg _ _,
  mul_neg := λ _ _, unop_injective $ neg_mul _ _,
  ..mul_opposite.has_involutive_neg _ }

end has_mul

section mul_one_class
variables [mul_one_class α] [has_distrib_neg α]

theorem neg_eq_neg_one_mul (a : α) : -a = -1 * a :=
by simp

/-- An element of a ring multiplied by the additive inverse of one is the element's additive
  inverse. -/
lemma mul_neg_one (a : α) : a * -1 = -a := by simp

/-- The additive inverse of one multiplied by an element of a ring is the element's additive
  inverse. -/
lemma neg_one_mul (a : α) : -1 * a = -a := by simp

end mul_one_class

section mul_zero_class
variables [mul_zero_class α] [has_distrib_neg α]

/-- Prefer `neg_zero` if `subtraction_monoid` is available. -/
@[simp] lemma neg_zero' : (-0 : α) = 0 :=
by rw [←zero_mul (0 : α), ←neg_mul, mul_zero, mul_zero]

end mul_zero_class

section semigroup

variables [semigroup α] [has_distrib_neg α] {a b c : α}

theorem dvd_neg_of_dvd (h : a ∣ b) : (a ∣ -b) :=
let ⟨c, hc⟩ := h in ⟨-c, by simp [hc]⟩

theorem dvd_of_dvd_neg (h : a ∣ -b) : (a ∣ b) :=
let t := dvd_neg_of_dvd h in by rwa neg_neg at t

/-- An element a of a semigroup with a distributive negation divides the negation of an element b
iff a divides b. -/
@[simp] lemma dvd_neg (a b : α) : (a ∣ -b) ↔ (a ∣ b) :=
⟨dvd_of_dvd_neg, dvd_neg_of_dvd⟩

theorem neg_dvd_of_dvd (h : a ∣ b) : -a ∣ b :=
let ⟨c, hc⟩ := h in ⟨-c, by simp [hc]⟩

theorem dvd_of_neg_dvd (h : -a ∣ b) : a ∣ b :=
let t := neg_dvd_of_dvd h in by rwa neg_neg at t

/-- The negation of an element a of a semigroup with a distributive negation divides
another element b iff a divides b. -/
@[simp] lemma neg_dvd (a b : α) : (-a ∣ b) ↔ (a ∣ b) :=
⟨dvd_of_neg_dvd, neg_dvd_of_dvd⟩

end semigroup

section group
variables [group α] [has_distrib_neg α]

@[simp] lemma inv_neg' (a : α) : (- a)⁻¹ = - a⁻¹ :=
by rw [eq_comm, eq_inv_iff_mul_eq_one, neg_mul, mul_neg,neg_neg, mul_left_inv]

end group

end has_distrib_neg

/-!
### Rings
-/

/-- A not-necessarily-unital, not-necessarily-associative ring. -/
@[protect_proj, ancestor add_comm_group non_unital_non_assoc_semiring]
class non_unital_non_assoc_ring (α : Type u) extends
  add_comm_group α, non_unital_non_assoc_semiring α

section non_unital_non_assoc_ring
variables [non_unital_non_assoc_ring α]


/-- Pullback a `non_unital_non_assoc_ring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_unital_non_assoc_ring
  [has_zero β] [has_add β] [has_mul β] [has_neg β] [has_sub β] [has_scalar ℕ β] [has_scalar ℤ β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_unital_non_assoc_ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul zsmul, ..hf.mul_zero_class f zero mul,
  .. hf.distrib f add mul }

/-- Pushforward a `non_unital_non_assoc_ring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_unital_non_assoc_ring
  [has_zero β] [has_add β] [has_mul β] [has_neg β] [has_sub β] [has_scalar ℕ β] [has_scalar ℤ β]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_unital_non_assoc_ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul zsmul, .. hf.mul_zero_class f zero mul,
  .. hf.distrib f add mul }

@[priority 100]
instance non_unital_non_assoc_ring.to_has_distrib_neg : has_distrib_neg α :=
{ neg := has_neg.neg,
  neg_neg := neg_neg,
  neg_mul := λ a b, eq_neg_of_add_eq_zero_left $ by rw [←right_distrib, add_left_neg, zero_mul],
  mul_neg := λ a b, eq_neg_of_add_eq_zero_left $ by rw [←left_distrib, add_left_neg, mul_zero] }

lemma mul_sub_left_distrib (a b c : α) : a * (b - c) = a * b - a * c :=
by simpa only [sub_eq_add_neg, neg_mul_eq_mul_neg] using mul_add a b (-c)

alias mul_sub_left_distrib ← mul_sub

lemma mul_sub_right_distrib (a b c : α) : (a - b) * c = a * c - b * c :=
by simpa only [sub_eq_add_neg, neg_mul_eq_neg_mul] using add_mul a (-b) c

alias mul_sub_right_distrib ← sub_mul

variables {a b c d e : α}

/-- An iff statement following from right distributivity in rings and the definition
  of subtraction. -/
theorem mul_add_eq_mul_add_iff_sub_mul_add_eq : a * e + c = b * e + d ↔ (a - b) * e + c = d :=
calc
  a * e + c = b * e + d ↔ a * e + c = d + b * e : by simp [add_comm]
    ... ↔ a * e + c - b * e = d : iff.intro (λ h, begin rw h, simp end) (λ h,
                                                  begin rw ← h, simp end)
    ... ↔ (a - b) * e + c = d   : begin simp [sub_mul, sub_add_eq_add_sub] end

/-- A simplification of one side of an equation exploiting right distributivity in rings
  and the definition of subtraction. -/
theorem sub_mul_add_eq_of_mul_add_eq_mul_add : a * e + c = b * e + d → (a - b) * e + c = d :=
assume h,
calc
  (a - b) * e + c = (a * e + c) - b * e : begin simp [sub_mul, sub_add_eq_add_sub] end
              ... = d                   : begin rw h, simp [@add_sub_cancel α] end

end non_unital_non_assoc_ring

/-- An associative but not-necessarily unital ring. -/
@[protect_proj, ancestor non_unital_non_assoc_ring non_unital_semiring]
class non_unital_ring (α : Type*) extends
  non_unital_non_assoc_ring α, non_unital_semiring α

section non_unital_ring
variables [non_unital_ring α]

/-- Pullback a `non_unital_ring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_unital_ring
  [has_zero β] [has_add β] [has_mul β] [has_neg β] [has_sub β] [has_scalar ℕ β] [has_scalar ℤ β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (gsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_unital_ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul gsmul, ..hf.mul_zero_class f zero mul,
  .. hf.distrib f add mul, .. hf.semigroup f mul }

/-- Pushforward a `non_unital_ring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_unital_ring
  [has_zero β] [has_add β] [has_mul β] [has_neg β] [has_sub β] [has_scalar ℕ β] [has_scalar ℤ β]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (gsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_unital_ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul gsmul, .. hf.mul_zero_class f zero mul,
  .. hf.distrib f add mul, .. hf.semigroup f mul }

end non_unital_ring

/-- A unital but not-necessarily-associative ring. -/
@[protect_proj, ancestor non_unital_non_assoc_ring non_assoc_semiring]
class non_assoc_ring (α : Type*) extends
  non_unital_non_assoc_ring α, non_assoc_semiring α

section non_assoc_ring
variables [non_assoc_ring α]

/-- Pullback a `non_assoc_ring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_assoc_ring
  [has_zero β] [has_one β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (gsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_assoc_ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul gsmul,
  .. hf.mul_zero_class f zero mul, .. hf.distrib f add mul,
  .. hf.mul_one_class f one mul }

/-- Pushforward a `non_unital_ring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_assoc_ring
  [has_zero β] [has_one β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (gsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_assoc_ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul gsmul, .. hf.mul_zero_class f zero mul,
  .. hf.distrib f add mul, .. hf.mul_one_class f one mul }

lemma sub_one_mul (a b : α) : (a - 1) * b = a * b - b :=
by rw [sub_mul, one_mul]
lemma mul_sub_one (a b : α) : a * (b - 1) = a * b - a :=
by rw [mul_sub, mul_one]
lemma one_sub_mul (a b : α) : (1 - a) * b = b - a * b :=
by rw [sub_mul, one_mul]
lemma mul_one_sub (a b : α) : a * (1 - b) = a - a * b :=
by rw [mul_sub, mul_one]

end non_assoc_ring

/-- A ring is a type with the following structures: additive commutative group (`add_comm_group`),
multiplicative monoid (`monoid`), and distributive laws (`distrib`).  Equivalently, a ring is a
`semiring` with a negation operation making it an additive group.  -/
@[protect_proj, ancestor add_comm_group monoid distrib]
class ring (α : Type u) extends add_comm_group α, monoid α, distrib α

section ring
variables [ring α] {a b c d e : α}

/- A (unital, associative) ring is a not-necessarily-unital ring -/
@[priority 100] -- see Note [lower instance priority]
instance ring.to_non_unital_ring :
  non_unital_ring α :=
{ zero_mul := λ a, add_left_cancel $ show 0 * a + 0 * a = 0 * a + 0,
    by rw [← add_mul, zero_add, add_zero],
  mul_zero := λ a, add_left_cancel $ show a * 0 + a * 0 = a * 0 + 0,
    by rw [← mul_add, add_zero, add_zero],
  ..‹ring α› }

/- A (unital, associative) ring is a not-necessarily-associative ring -/
@[priority 100] -- see Note [lower instance priority]
instance ring.to_non_assoc_ring :
  non_assoc_ring α :=
{ zero_mul := λ a, add_left_cancel $ show 0 * a + 0 * a = 0 * a + 0,
    by rw [← add_mul, zero_add, add_zero],
  mul_zero := λ a, add_left_cancel $ show a * 0 + a * 0 = a * 0 + 0,
    by rw [← mul_add, add_zero, add_zero],
  ..‹ring α› }

/- The instance from `ring` to `semiring` happens often in linear algebra, for which all the basic
definitions are given in terms of semirings, but many applications use rings or fields. We increase
a little bit its priority above 100 to try it quickly, but remaining below the default 1000 so that
more specific instances are tried first. -/
@[priority 200]
instance ring.to_semiring : semiring α :=
{ ..‹ring α›, .. ring.to_non_unital_ring }

/-- Pullback a `ring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.ring
  [has_zero β] [has_one β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β] [has_pow β ℕ]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x)
  (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul zsmul,
  .. hf.monoid f one mul npow, .. hf.distrib f add mul }

/-- Pushforward a `ring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.ring
  [has_zero β] [has_one β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β] [has_pow β ℕ]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x)
  (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  ring β :=
{ .. hf.add_comm_group f zero add neg sub nsmul zsmul,
  .. hf.monoid f one mul npow, .. hf.distrib f add mul }

end ring

namespace units
variables [ring α] {a b : α}

/-- Each element of the group of units of a ring has an additive inverse. -/
instance : has_neg αˣ := ⟨λu, ⟨-↑u, -↑u⁻¹, by simp, by simp⟩ ⟩

/-- Representing an element of a ring's unit group as an element of the ring commutes with
    mapping this element to its additive inverse. -/
@[simp, norm_cast] protected theorem coe_neg (u : αˣ) : (↑-u : α) = -u := rfl

@[simp, norm_cast] protected theorem coe_neg_one : ((-1 : αˣ) : α) = -1 := rfl

instance : has_distrib_neg αˣ := units.ext.has_distrib_neg _ units.coe_neg units.coe_mul

end units

lemma is_unit.neg [ring α] {a : α} : is_unit a → is_unit (-a)
| ⟨x, hx⟩ := hx ▸ (-x).is_unit

lemma is_unit.neg_iff [ring α] (a : α) : is_unit (-a) ↔ is_unit a :=
⟨λ h, neg_neg a ▸ h.neg, is_unit.neg⟩

lemma is_unit.sub_iff [ring α] {x y : α} :
  is_unit (x - y) ↔ is_unit (y - x) :=
(is_unit.neg_iff _).symm.trans $ neg_sub x y ▸ iff.rfl

namespace ring_hom

end ring_hom

/-- A non-unital commutative ring is a `non_unital_ring` with commutative multiplication. -/
@[protect_proj, ancestor non_unital_ring comm_semigroup]
class non_unital_comm_ring (α : Type u) extends non_unital_ring α, comm_semigroup α

@[priority 100] -- see Note [lower instance priority]
instance non_unital_comm_ring.to_non_unital_comm_semiring [s : non_unital_comm_ring α] :
  non_unital_comm_semiring α :=
{ ..s }

/-- A commutative ring is a `ring` with commutative multiplication. -/
@[protect_proj, ancestor ring comm_semigroup]
class comm_ring (α : Type u) extends ring α, comm_monoid α

@[priority 100] -- see Note [lower instance priority]
instance comm_ring.to_comm_semiring [s : comm_ring α] : comm_semiring α :=
{ mul_zero := mul_zero, zero_mul := zero_mul, ..s }

@[priority 100] -- see Note [lower instance priority]
instance comm_ring.to_non_unital_comm_ring [s : comm_ring α] : non_unital_comm_ring α :=
{ mul_zero := mul_zero, zero_mul := zero_mul, ..s }

section non_unital_ring
variables [non_unital_ring α] {a b c : α}

theorem dvd_sub (h₁ : a ∣ b) (h₂ : a ∣ c) : a ∣ b - c :=
by { rw sub_eq_add_neg, exact dvd_add h₁ (dvd_neg_of_dvd h₂) }

theorem dvd_add_iff_left (h : a ∣ c) : a ∣ b ↔ a ∣ b + c :=
⟨λh₂, dvd_add h₂ h, λH, by have t := dvd_sub H h; rwa add_sub_cancel at t⟩

theorem dvd_add_iff_right (h : a ∣ b) : a ∣ c ↔ a ∣ b + c :=
by rw add_comm; exact dvd_add_iff_left h

/-- If an element a divides another element c in a commutative ring, a divides the sum of another
  element b with c iff a divides b. -/
theorem dvd_add_left (h : a ∣ c) : a ∣ b + c ↔ a ∣ b :=
(dvd_add_iff_left h).symm

/-- If an element a divides another element b in a commutative ring, a divides the sum of b and
  another element c iff a divides c. -/
theorem dvd_add_right (h : a ∣ b) : a ∣ b + c ↔ a ∣ c :=
(dvd_add_iff_right h).symm

lemma dvd_iff_dvd_of_dvd_sub {a b c : α} (h : a ∣ (b - c)) : (a ∣ b ↔ a ∣ c) :=
begin
  split,
  { intro h',
    convert dvd_sub h' h,
    exact eq.symm (sub_sub_self b c) },
  { intro h',
    convert dvd_add h h',
    exact eq_add_of_sub_eq rfl }
end

end non_unital_ring

section ring
variables [ring α] {a b c : α}

theorem two_dvd_bit1 : 2 ∣ bit1 a ↔ (2 : α) ∣ 1 := (dvd_add_iff_right (@two_dvd_bit0 _ _ a)).symm

/-- An element a divides the sum a + b if and only if a divides b.-/
@[simp] lemma dvd_add_self_left {a b : α} : a ∣ a + b ↔ a ∣ b :=
dvd_add_right (dvd_refl a)

/-- An element a divides the sum b + a if and only if a divides b.-/
@[simp] lemma dvd_add_self_right {a b : α} : a ∣ b + a ↔ a ∣ b :=
dvd_add_left (dvd_refl a)

end ring

section non_unital_comm_ring
variables [non_unital_comm_ring α] {a b c : α}

/-- Pullback a `comm_ring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.non_unital_comm_ring
  [has_zero β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β]
  (f : β → α) (hf : injective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_unital_comm_ring β :=
{ .. hf.non_unital_ring f zero add mul neg sub nsmul zsmul, .. hf.comm_semigroup f mul }

/-- Pushforward a `non_unital_comm_ring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.non_unital_comm_ring
  [has_zero β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x) :
  non_unital_comm_ring β :=
{ .. hf.non_unital_ring f zero add mul neg sub nsmul zsmul, .. hf.comm_semigroup f mul }

local attribute [simp] add_assoc add_comm add_left_comm mul_comm

/-- Vieta's formula for a quadratic equation, relating the coefficients of the polynomial with
  its roots. This particular version states that if we have a root `x` of a monic quadratic
  polynomial, then there is another root `y` such that `x + y` is negative the `a_1` coefficient
  and `x * y` is the `a_0` coefficient. -/
lemma Vieta_formula_quadratic {b c x : α} (h : x * x - b * x + c = 0) :
  ∃ y : α, y * y - b * y + c = 0 ∧ x + y = b ∧ x * y = c :=
begin
  have : c = x * (b - x) := (eq_neg_of_add_eq_zero_right h).trans (by simp [mul_sub, mul_comm]),
  refine ⟨b - x, _, by simp, by rw this⟩,
  rw [this, sub_add, ← sub_mul, sub_self]
end

lemma dvd_mul_sub_mul {k a b x y : α} (hab : k ∣ a - b) (hxy : k ∣ x - y) :
  k ∣ a * x - b * y :=
begin
  convert dvd_add (hxy.mul_left a) (hab.mul_right y),
  rw [mul_sub_left_distrib, mul_sub_right_distrib],
  simp only [sub_eq_add_neg, add_assoc, neg_add_cancel_left],
end

end non_unital_comm_ring

section comm_ring
variables [comm_ring α] {a b c : α}

/-- Pullback a `comm_ring` instance along an injective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.injective.comm_ring
  [has_zero β] [has_one β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β] [has_pow β ℕ]
  (f : β → α) (hf : injective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x)
  (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  comm_ring β :=
{ .. hf.ring f zero one add mul neg sub nsmul zsmul npow, .. hf.comm_semigroup f mul }

/-- Pushforward a `comm_ring` instance along a surjective function.
See note [reducible non-instances]. -/
@[reducible]
protected def function.surjective.comm_ring
  [has_zero β] [has_one β] [has_add β] [has_mul β] [has_neg β] [has_sub β]
  [has_scalar ℕ β] [has_scalar ℤ β] [has_pow β ℕ]
  (f : α → β) (hf : surjective f) (zero : f 0 = 0) (one : f 1 = 1)
  (add : ∀ x y, f (x + y) = f x + f y) (mul : ∀ x y, f (x * y) = f x * f y)
  (neg : ∀ x, f (-x) = -f x) (sub : ∀ x y, f (x - y) = f x - f y)
  (nsmul : ∀ x (n : ℕ), f (n • x) = n • f x) (zsmul : ∀ x (n : ℤ), f (n • x) = n • f x)
  (npow : ∀ x (n : ℕ), f (x ^ n) = f x ^ n) :
  comm_ring β :=
{ .. hf.ring f zero one add mul neg sub nsmul zsmul npow, .. hf.comm_semigroup f mul }

end comm_ring

lemma succ_ne_self [non_assoc_ring α] [nontrivial α] (a : α) : a + 1 ≠ a :=
λ h, one_ne_zero ((add_right_inj a).mp (by simp [h]))

lemma pred_ne_self [non_assoc_ring α] [nontrivial α] (a : α) : a - 1 ≠ a :=
λ h, one_ne_zero (neg_injective ((add_right_inj a).mp (by simpa [sub_eq_add_neg] using h)))

/-- Left `mul` by a `k : α` over `[ring α]` is injective, if `k` is not a zero divisor.
The typeclass that restricts all terms of `α` to have this property is `no_zero_divisors`. -/
lemma is_left_regular_of_non_zero_divisor [non_unital_non_assoc_ring α] (k : α)
  (h : ∀ (x : α), k * x = 0 → x = 0) : is_left_regular k :=
begin
  refine λ x y (h' : k * x = k * y), sub_eq_zero.mp (h _ _),
  rw [mul_sub, sub_eq_zero, h']
end

/-- Right `mul` by a `k : α` over `[ring α]` is injective, if `k` is not a zero divisor.
The typeclass that restricts all terms of `α` to have this property is `no_zero_divisors`. -/
lemma is_right_regular_of_non_zero_divisor [non_unital_non_assoc_ring α] (k : α)
  (h : ∀ (x : α), x * k = 0 → x = 0) : is_right_regular k :=
begin
  refine λ x y (h' : x * k = y * k), sub_eq_zero.mp (h _ _),
  rw [sub_mul, sub_eq_zero, h']
end

lemma is_regular_of_ne_zero' [non_unital_non_assoc_ring α] [no_zero_divisors α] {k : α}
  (hk : k ≠ 0) : is_regular k :=
⟨is_left_regular_of_non_zero_divisor k
  (λ x h, (no_zero_divisors.eq_zero_or_eq_zero_of_mul_eq_zero h).resolve_left hk),
 is_right_regular_of_non_zero_divisor k
  (λ x h, (no_zero_divisors.eq_zero_or_eq_zero_of_mul_eq_zero h).resolve_right hk)⟩

lemma is_regular_iff_ne_zero' [nontrivial α] [non_unital_non_assoc_ring α] [no_zero_divisors α]
  {k : α} : is_regular k ↔ k ≠ 0 :=
⟨λ h, by { rintro rfl, exact not_not.mpr h.left not_is_left_regular_zero }, is_regular_of_ne_zero'⟩

/-- A ring with no zero divisors is a `cancel_monoid_with_zero`.

Note this is not an instance as it forms a typeclass loop. -/
@[reducible]
def no_zero_divisors.to_cancel_monoid_with_zero [ring α] [no_zero_divisors α] :
  cancel_monoid_with_zero α :=
{ mul_left_cancel_of_ne_zero := λ a b c ha,
    @is_regular.left _ _ _ (is_regular_of_ne_zero' ha) _ _,
  mul_right_cancel_of_ne_zero := λ a b c hb,
    @is_regular.right _ _ _ (is_regular_of_ne_zero' hb) _ _,
  .. (by apply_instance : monoid_with_zero α) }

/-- A commutative ring with no zero divisors is a `cancel_comm_monoid_with_zero`.

Note this is not an instance as it forms a typeclass loop. -/
@[reducible]
def no_zero_divisors.to_cancel_comm_monoid_with_zero [comm_ring α] [no_zero_divisors α] :
  cancel_comm_monoid_with_zero α :=
{ .. no_zero_divisors.to_cancel_monoid_with_zero,
  .. (by apply_instance : comm_monoid_with_zero α) }

/-- A domain is a nontrivial ring with no zero divisors, i.e. satisfying
  the condition `a * b = 0 ↔ a = 0 ∨ b = 0`.

  This is implemented as a mixin for `ring α`.
  To obtain an integral domain use `[comm_ring α] [is_domain α]`. -/
@[protect_proj] class is_domain (α : Type u) [ring α]
  extends no_zero_divisors α, nontrivial α : Prop

section is_domain

@[priority 100] -- see Note [lower instance priority]
instance is_domain.to_cancel_monoid_with_zero [ring α] [is_domain α] : cancel_monoid_with_zero α :=
no_zero_divisors.to_cancel_monoid_with_zero

variables [comm_ring α] [is_domain α]

@[priority 100] -- see Note [lower instance priority]
instance is_domain.to_cancel_comm_monoid_with_zero : cancel_comm_monoid_with_zero α :=
no_zero_divisors.to_cancel_comm_monoid_with_zero

end is_domain

namespace semiconj_by

@[simp] lemma add_right [distrib R] {a x y x' y' : R}
  (h : semiconj_by a x y) (h' : semiconj_by a x' y') :
  semiconj_by a (x + x') (y + y') :=
by simp only [semiconj_by, left_distrib, right_distrib, h.eq, h'.eq]

@[simp] lemma add_left [distrib R] {a b x y : R}
  (ha : semiconj_by a x y) (hb : semiconj_by b x y) :
  semiconj_by (a + b) x y :=
by simp only [semiconj_by, left_distrib, right_distrib, ha.eq, hb.eq]

section
variables [has_mul R] [has_distrib_neg R] {a x y : R}

lemma neg_right (h : semiconj_by a x y) : semiconj_by a (-x) (-y) :=
by simp only [semiconj_by, h.eq, neg_mul, mul_neg]

@[simp] lemma neg_right_iff : semiconj_by a (-x) (-y) ↔ semiconj_by a x y :=
⟨λ h, neg_neg x ▸ neg_neg y ▸ h.neg_right, semiconj_by.neg_right⟩

lemma neg_left (h : semiconj_by a x y) : semiconj_by (-a) x y :=
by simp only [semiconj_by, h.eq, neg_mul, mul_neg]

@[simp] lemma neg_left_iff : semiconj_by (-a) x y ↔ semiconj_by a x y :=
⟨λ h, neg_neg a ▸ h.neg_left, semiconj_by.neg_left⟩

end

section
variables [mul_one_class R] [has_distrib_neg R] {a x y : R}

@[simp] lemma neg_one_right (a : R) : semiconj_by a (-1) (-1) :=
(one_right a).neg_right

@[simp] lemma neg_one_left (x : R) : semiconj_by (-1) x x :=
(semiconj_by.one_left x).neg_left

end

section
variables [non_unital_non_assoc_ring R] {a b x y x' y' : R}

@[simp] lemma sub_right (h : semiconj_by a x y) (h' : semiconj_by a x' y') :
  semiconj_by a (x - x') (y - y') :=
by simpa only [sub_eq_add_neg] using h.add_right h'.neg_right

@[simp] lemma sub_left (ha : semiconj_by a x y) (hb : semiconj_by b x y) :
  semiconj_by (a - b) x y :=
by simpa only [sub_eq_add_neg] using ha.add_left hb.neg_left

end

end semiconj_by

namespace commute

@[simp] theorem add_right [distrib R] {a b c : R} :
  commute a b → commute a c → commute a (b + c) :=
semiconj_by.add_right

@[simp] theorem add_left [distrib R] {a b c : R} :
  commute a c → commute b c → commute (a + b) c :=
semiconj_by.add_left

lemma bit0_right [distrib R] {x y : R} (h : commute x y) : commute x (bit0 y) :=
h.add_right h

lemma bit0_left [distrib R] {x y : R} (h : commute x y) : commute (bit0 x) y :=
h.add_left h

lemma bit1_right [non_assoc_semiring R] {x y : R} (h : commute x y) : commute x (bit1 y) :=
h.bit0_right.add_right (commute.one_right x)

lemma bit1_left [non_assoc_semiring R] {x y : R} (h : commute x y) : commute (bit1 x) y :=
h.bit0_left.add_left (commute.one_left y)

/-- Representation of a difference of two squares of commuting elements as a product. -/
lemma mul_self_sub_mul_self_eq [non_unital_non_assoc_ring R] {a b : R} (h : commute a b) :
  a * a - b * b = (a + b) * (a - b) :=
by rw [add_mul, mul_sub, mul_sub, h.eq, sub_add_sub_cancel]

lemma mul_self_sub_mul_self_eq' [non_unital_non_assoc_ring R] {a b : R} (h : commute a b) :
  a * a - b * b = (a - b) * (a + b) :=
by rw [mul_add, sub_mul, sub_mul, h.eq, sub_add_sub_cancel]

lemma mul_self_eq_mul_self_iff [non_unital_non_assoc_ring R] [no_zero_divisors R] {a b : R}
  (h : commute a b) : a * a = b * b ↔ a = b ∨ a = -b :=
by rw [← sub_eq_zero, h.mul_self_sub_mul_self_eq, mul_eq_zero, or_comm, sub_eq_zero,
  add_eq_zero_iff_eq_neg]

section
variables [has_mul R] [has_distrib_neg R] {a b : R}

theorem neg_right : commute a b → commute a (- b) := semiconj_by.neg_right
@[simp] theorem neg_right_iff : commute a (-b) ↔ commute a b := semiconj_by.neg_right_iff

theorem neg_left : commute a b → commute (- a) b := semiconj_by.neg_left
@[simp] theorem neg_left_iff : commute (-a) b ↔ commute a b := semiconj_by.neg_left_iff

end

section
variables [mul_one_class R] [has_distrib_neg R] {a : R}

@[simp] theorem neg_one_right (a : R) : commute a (-1) := semiconj_by.neg_one_right a
@[simp] theorem neg_one_left (a : R): commute (-1) a := semiconj_by.neg_one_left a

end

section
variables [non_unital_non_assoc_ring R] {a b c : R}

@[simp] theorem sub_right : commute a b → commute a c → commute a (b - c) := semiconj_by.sub_right
@[simp] theorem sub_left : commute a c → commute b c → commute (a - b) c := semiconj_by.sub_left

end

end commute

/-- Representation of a difference of two squares in a commutative ring as a product. -/
theorem mul_self_sub_mul_self [comm_ring R] (a b : R) : a * a - b * b = (a + b) * (a - b) :=
(commute.all a b).mul_self_sub_mul_self_eq

lemma mul_self_sub_one [non_assoc_ring R] (a : R) : a * a - 1 = (a + 1) * (a - 1) :=
by rw [←(commute.one_right a).mul_self_sub_mul_self_eq, mul_one]

lemma mul_self_eq_mul_self_iff [comm_ring R] [no_zero_divisors R] {a b : R} :
  a * a = b * b ↔ a = b ∨ a = -b :=
(commute.all a b).mul_self_eq_mul_self_iff

lemma mul_self_eq_one_iff [non_assoc_ring R] [no_zero_divisors R] {a : R} :
  a * a = 1 ↔ a = 1 ∨ a = -1 :=
by rw [←(commute.one_right a).mul_self_eq_mul_self_iff, mul_one]

/-- In the unit group of an integral domain, a unit is its own inverse iff the unit is one or
  one's additive inverse. -/
lemma units.inv_eq_self_iff [ring R] [no_zero_divisors R] (u : Rˣ) : u⁻¹ = u ↔ u = 1 ∨ u = -1 :=
begin
  rw inv_eq_iff_mul_eq_one,
  simp only [units.ext_iff],
  push_cast,
  exact mul_self_eq_one_iff
end


<|start_filename|>src/set_theory/lists.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.list.basic

/-!
# A computable model of ZFA without infinity

In this file we define finite hereditary lists. This is useful for calculations in naive set theory.

We distinguish two kinds of ZFA lists:
* Atoms. Directly correspond to an element of the original type.
* Proper ZFA lists. Can be thought of (but aren't implemented) as a list of ZFA lists (not
  necessarily proper).

For example, `lists ℕ` contains stuff like `23`, `[]`, `[37]`, `[1, [[2], 3], 4]`.

## Implementation note

As we want to be able to append both atoms and proper ZFA lists to proper ZFA lists, it's handy that
atoms and proper ZFA lists belong to the same type, even though atoms of `α` could be modelled as
`α` directly. But we don't want to be able to append anything to atoms.

This calls for a two-steps definition of ZFA lists:
* First, define ZFA prelists as atoms and proper ZFA prelists. Those proper ZFA prelists are defined
  by inductive appending of (not necessarily proper) ZFA lists.
* Second, define ZFA lists by rubbing out the distinction between atoms and proper lists.

## Main declarations

* `lists' α ff`: Atoms as ZFA prelists. Basically a copy of `α`.
* `lists' α tt`: Proper ZFA prelists. Defined inductively from the empty ZFA prelist (`lists'.nil`)
  and from appending a ZFA prelist to a proper ZFA prelist (`lists'.cons a l`).
* `lists α`: ZFA lists. Sum of the atoms and proper ZFA prelists.

## TODO

The next step is to define ZFA sets as lists quotiented by `lists.equiv`.
(-/

variables {α : Type*}

/-- Prelists, helper type to define `lists`. `lists' α ff` are the "atoms", a copy of `α`.
`lists' α tt` are the "proper" ZFA prelists, inductively defined from the empty ZFA prelist and from
appending a ZFA prelist to a proper ZFA prelist. It is made so that you can't append anything to an
atom while having only one appending function for appending both atoms and proper ZFC prelists to a
proper ZFA prelist. -/
@[derive decidable_eq]
inductive {u} lists' (α : Type u) : bool → Type u
| atom : α → lists' ff
| nil : lists' tt
| cons' {b} : lists' b → lists' tt → lists' tt

/-- Hereditarily finite list, aka ZFA list. A ZFA list is either an "atom" (`b = ff`), corresponding
to an element of `α`, or a "proper" ZFA list, inductively defined from the empty ZFA list and from
appending a ZFA list to a proper ZFA list. -/
def lists (α : Type*) := Σ b, lists' α b

namespace lists'

instance [inhabited α] : ∀ b, inhabited (lists' α b)
| tt := ⟨nil⟩
| ff := ⟨atom default⟩

/-- Appending a ZFA list to a proper ZFA prelist. -/
def cons : lists α → lists' α tt → lists' α tt
| ⟨b, a⟩ l := cons' a l

/-- Converts a ZFA prelist to a `list` of ZFA lists. Atoms are sent to `[]`. -/
@[simp] def to_list : ∀ {b}, lists' α b → list (lists α)
| _ (atom a)    := []
| _ nil         := []
| _ (cons' a l) := ⟨_, a⟩ :: l.to_list

@[simp] theorem to_list_cons (a : lists α) (l) :
  to_list (cons a l) = a :: l.to_list :=
by cases a; simp [cons]

/-- Converts a `list` of ZFA lists to a proper ZFA prelist. -/
@[simp] def of_list : list (lists α) → lists' α tt
| []       := nil
| (a :: l) := cons a (of_list l)

@[simp] theorem to_of_list (l : list (lists α)) : to_list (of_list l) = l :=
by induction l; simp *

@[simp] theorem of_to_list : ∀ (l : lists' α tt), of_list (to_list l) = l :=
suffices ∀ b (h : tt = b) (l : lists' α b),
  let l' : lists' α tt := by rw h; exact l in
  of_list (to_list l') = l', from this _ rfl,
λ b h l, begin
  induction l, {cases h}, {exact rfl},
  case lists'.cons' : b a l IH₁ IH₂
  { intro, change l' with cons' a l,
    simpa [cons] using IH₂ rfl }
end

end lists'

mutual inductive lists.equiv, lists'.subset
with lists.equiv : lists α → lists α → Prop
| refl (l) : lists.equiv l l
| antisymm {l₁ l₂ : lists' α tt} :
  lists'.subset l₁ l₂ → lists'.subset l₂ l₁ → lists.equiv ⟨_, l₁⟩ ⟨_, l₂⟩
with lists'.subset : lists' α tt → lists' α tt → Prop
| nil {l} : lists'.subset lists'.nil l
| cons {a a' l l'} : lists.equiv a a' → a' ∈ lists'.to_list l' →
  lists'.subset l l' → lists'.subset (lists'.cons a l) l'
local infix ` ~ `:50 := lists.equiv

/-- Equivalence of ZFA lists. Defined inductively. -/
add_decl_doc lists.equiv

/-- Subset relation for ZFA lists. Defined inductively. -/
add_decl_doc lists'.subset

namespace lists'

instance : has_subset (lists' α tt) := ⟨lists'.subset⟩

/-- ZFA prelist membership. A ZFA list is in a ZFA prelist if some element of this ZFA prelist is
equivalent as a ZFA list to this ZFA list. -/
instance {b} : has_mem (lists α) (lists' α b) :=
⟨λ a l, ∃ a' ∈ l.to_list, a ~ a'⟩

theorem mem_def {b a} {l : lists' α b} :
  a ∈ l ↔ ∃ a' ∈ l.to_list, a ~ a' := iff.rfl

@[simp] theorem mem_cons {a y l} : a ∈ @cons α y l ↔ a ~ y ∨ a ∈ l :=
by simp [mem_def, or_and_distrib_right, exists_or_distrib]

theorem cons_subset {a} {l₁ l₂ : lists' α tt} :
  lists'.cons a l₁ ⊆ l₂ ↔ a ∈ l₂ ∧ l₁ ⊆ l₂ :=
begin
  refine ⟨λ h, _, λ ⟨⟨a', m, e⟩, s⟩, subset.cons e m s⟩,
  generalize_hyp h' : lists'.cons a l₁ = l₁' at h,
  cases h with l a' a'' l l' e m s, {cases a, cases h'},
  cases a, cases a', cases h', exact ⟨⟨_, m, e⟩, s⟩
end

theorem of_list_subset {l₁ l₂ : list (lists α)} (h : l₁ ⊆ l₂) :
  lists'.of_list l₁ ⊆ lists'.of_list l₂ :=
begin
  induction l₁, {exact subset.nil},
  refine subset.cons (lists.equiv.refl _) _ (l₁_ih (list.subset_of_cons_subset h)),
  simp at h, simp [h]
end

@[refl] theorem subset.refl {l : lists' α tt} : l ⊆ l :=
by rw ← lists'.of_to_list l; exact
   of_list_subset (list.subset.refl _)

theorem subset_nil {l : lists' α tt} :
  l ⊆ lists'.nil → l = lists'.nil :=
begin
  rw ← of_to_list l,
  induction to_list l; intro h, {refl},
  rcases cons_subset.1 h with ⟨⟨_, ⟨⟩, _⟩, _⟩
end

theorem mem_of_subset' {a} {l₁ l₂ : lists' α tt}
  (s : l₁ ⊆ l₂) (h : a ∈ l₁.to_list) : a ∈ l₂ :=
begin
  induction s with _ a a' l l' e m s IH, {cases h},
  simp at h, rcases h with rfl|h,
  exacts [⟨_, m, e⟩, IH h]
end

theorem subset_def {l₁ l₂ : lists' α tt} :
  l₁ ⊆ l₂ ↔ ∀ a ∈ l₁.to_list, a ∈ l₂ :=
⟨λ H a, mem_of_subset' H, λ H, begin
  rw ← of_to_list l₁,
  revert H, induction to_list l₁; intro,
  { exact subset.nil },
  { simp at H, exact cons_subset.2 ⟨H.1, ih H.2⟩ }
end⟩

end lists'

namespace lists

/-- Sends `a : α` to the corresponding atom in `lists α`. -/
@[pattern] def atom (a : α) : lists α := ⟨_, lists'.atom a⟩

/-- Converts a proper ZFA prelist to a ZFA list. -/
@[pattern] def of' (l : lists' α tt) : lists α := ⟨_, l⟩

/-- Converts a ZFA list to a `list` of ZFA lists. Atoms are sent to `[]`. -/
@[simp] def to_list : lists α → list (lists α)
| ⟨b, l⟩ := l.to_list

/-- Predicate stating that a ZFA list is proper. -/
def is_list (l : lists α) : Prop := l.1

/-- Converts a `list` of ZFA lists to a ZFA list. -/
def of_list (l : list (lists α)) : lists α := of' (lists'.of_list l)

theorem is_list_to_list (l : list (lists α)) : is_list (of_list l) :=
eq.refl _

theorem to_of_list (l : list (lists α)) : to_list (of_list l) = l :=
by simp [of_list, of']

theorem of_to_list : ∀ {l : lists α}, is_list l → of_list (to_list l) = l
| ⟨tt, l⟩ _ := by simp [of_list, of']

instance : inhabited (lists α) :=
⟨of' lists'.nil⟩

instance [decidable_eq α] : decidable_eq (lists α) :=
by unfold lists; apply_instance

instance [has_sizeof α] : has_sizeof (lists α) :=
by unfold lists; apply_instance

/-- A recursion principle for pairs of ZFA lists and proper ZFA prelists. -/
def induction_mut (C : lists α → Sort*) (D : lists' α tt → Sort*)
  (C0 : ∀ a, C (atom a)) (C1 : ∀ l, D l → C (of' l))
  (D0 : D lists'.nil) (D1 : ∀ a l, C a → D l → D (lists'.cons a l)) :
  pprod (∀ l, C l) (∀ l, D l) :=
begin
  suffices : ∀ {b} (l : lists' α b),
    pprod (C ⟨_, l⟩) (match b, l with
    | tt, l := D l
    | ff, l := punit
    end),
  { exact ⟨λ ⟨b, l⟩, (this _).1, λ l, (this l).2⟩ },
  intros, induction l with a b a l IH₁ IH₂,
  { exact ⟨C0 _, ⟨⟩⟩ },
  { exact ⟨C1 _ D0, D0⟩ },
  { suffices, {exact ⟨C1 _ this, this⟩},
    exact D1 ⟨_, _⟩ _ IH₁.1 IH₂.2 }
end

/-- Membership of ZFA list. A ZFA list belongs to a proper ZFA list if it belongs to the latter as a
proper ZFA prelist. An atom has no members. -/
def mem (a : lists α) : lists α → Prop
| ⟨ff, l⟩ := false
| ⟨tt, l⟩ := a ∈ l

instance : has_mem (lists α) (lists α) := ⟨mem⟩

theorem is_list_of_mem {a : lists α} : ∀ {l : lists α}, a ∈ l → is_list l
| ⟨_, lists'.nil⟩       _ := rfl
| ⟨_, lists'.cons' _ _⟩ _ := rfl

theorem equiv.antisymm_iff {l₁ l₂ : lists' α tt} :
  of' l₁ ~ of' l₂ ↔ l₁ ⊆ l₂ ∧ l₂ ⊆ l₁ :=
begin
  refine ⟨λ h, _, λ ⟨h₁, h₂⟩, equiv.antisymm h₁ h₂⟩,
  cases h with _ _ _ h₁ h₂,
  { simp [lists'.subset.refl] }, { exact ⟨h₁, h₂⟩ }
end

attribute [refl] equiv.refl

theorem equiv_atom {a} {l : lists α} : atom a ~ l ↔ atom a = l :=
⟨λ h, by cases h; refl, λ h, h ▸ equiv.refl _⟩

theorem equiv.symm {l₁ l₂ : lists α} (h : l₁ ~ l₂) : l₂ ~ l₁ :=
by cases h with _ _ _ h₁ h₂; [refl, exact equiv.antisymm h₂ h₁]

theorem equiv.trans : ∀ {l₁ l₂ l₃ : lists α}, l₁ ~ l₂ → l₂ ~ l₃ → l₁ ~ l₃ :=
begin
  let trans := λ (l₁ : lists α), ∀ ⦃l₂ l₃⦄, l₁ ~ l₂ → l₂ ~ l₃ → l₁ ~ l₃,
  suffices : pprod (∀ l₁, trans l₁)
    (∀ (l : lists' α tt) (l' ∈ l.to_list), trans l'), {exact this.1},
  apply induction_mut,
  { intros a l₂ l₃ h₁ h₂,
    rwa ← equiv_atom.1 h₁ at h₂ },
  { intros l₁ IH l₂ l₃ h₁ h₂,
    cases h₁ with _ _ l₂, {exact h₂},
    cases h₂ with _ _ l₃, {exact h₁},
    cases equiv.antisymm_iff.1 h₁ with hl₁ hr₁,
    cases equiv.antisymm_iff.1 h₂ with hl₂ hr₂,
    apply equiv.antisymm_iff.2; split; apply lists'.subset_def.2,
    { intros a₁ m₁,
      rcases lists'.mem_of_subset' hl₁ m₁ with ⟨a₂, m₂, e₁₂⟩,
      rcases lists'.mem_of_subset' hl₂ m₂ with ⟨a₃, m₃, e₂₃⟩,
      exact ⟨a₃, m₃, IH _ m₁ e₁₂ e₂₃⟩ },
    { intros a₃ m₃,
      rcases lists'.mem_of_subset' hr₂ m₃ with ⟨a₂, m₂, e₃₂⟩,
      rcases lists'.mem_of_subset' hr₁ m₂ with ⟨a₁, m₁, e₂₁⟩,
      exact ⟨a₁, m₁, (IH _ m₁ e₂₁.symm e₃₂.symm).symm⟩ } },
  { rintro _ ⟨⟩ },
  { intros a l IH₁ IH₂, simpa [IH₁] using IH₂ }
end

instance : setoid (lists α) :=
⟨(~), equiv.refl, @equiv.symm _, @equiv.trans _⟩

section decidable

@[simp] def equiv.decidable_meas :
  (psum (Σ' (l₁ : lists α), lists α) $
   psum (Σ' (l₁ : lists' α tt), lists' α tt)
   Σ' (a : lists α), lists' α tt) → ℕ
| (psum.inl ⟨l₁, l₂⟩) := sizeof l₁ + sizeof l₂
| (psum.inr $ psum.inl ⟨l₁, l₂⟩) := sizeof l₁ + sizeof l₂
| (psum.inr $ psum.inr ⟨l₁, l₂⟩) := sizeof l₁ + sizeof l₂

open well_founded_tactics

theorem sizeof_pos {b} (l : lists' α b) : 0 < sizeof l :=
by cases l; unfold_sizeof; trivial_nat_lt

theorem lt_sizeof_cons' {b} (a : lists' α b) (l) :
  sizeof (⟨b, a⟩ : lists α) < sizeof (lists'.cons' a l) :=
by {unfold_sizeof, apply sizeof_pos}

@[instance] mutual def equiv.decidable, subset.decidable, mem.decidable [decidable_eq α]
with equiv.decidable : ∀ l₁ l₂ : lists α, decidable (l₁ ~ l₂)
| ⟨ff, l₁⟩ ⟨ff, l₂⟩ := decidable_of_iff' (l₁ = l₂) $
  by cases l₁; refine equiv_atom.trans (by simp [atom])
| ⟨ff, l₁⟩ ⟨tt, l₂⟩ := is_false $ by rintro ⟨⟩
| ⟨tt, l₁⟩ ⟨ff, l₂⟩ := is_false $ by rintro ⟨⟩
| ⟨tt, l₁⟩ ⟨tt, l₂⟩ := begin
  haveI :=
    have sizeof l₁ + sizeof l₂ <
         sizeof (⟨tt, l₁⟩ : lists α) + sizeof (⟨tt, l₂⟩ : lists α),
    by default_dec_tac,
    subset.decidable l₁ l₂,
  haveI :=
    have sizeof l₂ + sizeof l₁ <
         sizeof (⟨tt, l₁⟩ : lists α) + sizeof (⟨tt, l₂⟩ : lists α),
    by default_dec_tac,
    subset.decidable l₂ l₁,
  exact decidable_of_iff' _ equiv.antisymm_iff,
end
with subset.decidable : ∀ l₁ l₂ : lists' α tt, decidable (l₁ ⊆ l₂)
| lists'.nil l₂ := is_true subset.nil
| (@lists'.cons' _ b a l₁) l₂ := begin
  haveI :=
    have sizeof (⟨b, a⟩ : lists α) + sizeof l₂ <
         sizeof (lists'.cons' a l₁) + sizeof l₂,
    from add_lt_add_right (lt_sizeof_cons' _ _) _,
    mem.decidable ⟨b, a⟩ l₂,
  haveI :=
    have sizeof l₁ + sizeof l₂ <
         sizeof (lists'.cons' a l₁) + sizeof l₂,
    by default_dec_tac,
    subset.decidable l₁ l₂,
  exact decidable_of_iff' _ (@lists'.cons_subset _ ⟨_, _⟩ _ _)
end
with mem.decidable : ∀ (a : lists α) (l : lists' α tt), decidable (a ∈ l)
| a lists'.nil := is_false $ by rintro ⟨_, ⟨⟩, _⟩
| a (lists'.cons' b l₂) := begin
  haveI :=
    have sizeof a + sizeof (⟨_, b⟩ : lists α) <
         sizeof a + sizeof (lists'.cons' b l₂),
    from add_lt_add_left (lt_sizeof_cons' _ _) _,
    equiv.decidable a ⟨_, b⟩,
  haveI :=
    have sizeof a + sizeof l₂ <
         sizeof a + sizeof (lists'.cons' b l₂),
    by default_dec_tac,
    mem.decidable a l₂,
  refine decidable_of_iff' (a ~ ⟨_, b⟩ ∨ a ∈ l₂) _,
  rw ← lists'.mem_cons, refl
end
using_well_founded
{ rel_tac := λ _ _, `[exact ⟨_, measure_wf equiv.decidable_meas⟩],
  dec_tac := `[assumption] }

end decidable

end lists

namespace lists'

theorem mem_equiv_left {l : lists' α tt} :
  ∀ {a a'}, a ~ a' → (a ∈ l ↔ a' ∈ l) :=
suffices ∀ {a a'}, a ~ a' → a ∈ l → a' ∈ l,
  from λ a a' e, ⟨this e, this e.symm⟩,
λ a₁ a₂ e₁ ⟨a₃, m₃, e₂⟩, ⟨_, m₃, e₁.symm.trans e₂⟩

theorem mem_of_subset {a} {l₁ l₂ : lists' α tt}
  (s : l₁ ⊆ l₂) : a ∈ l₁ → a ∈ l₂ | ⟨a', m, e⟩ :=
(mem_equiv_left e).2 (mem_of_subset' s m)

theorem subset.trans {l₁ l₂ l₃ : lists' α tt}
  (h₁ : l₁ ⊆ l₂) (h₂ : l₂ ⊆ l₃) : l₁ ⊆ l₃ :=
subset_def.2 $ λ a₁ m₁, mem_of_subset h₂ $ mem_of_subset' h₁ m₁

end lists'

def finsets (α : Type*) := quotient (@lists.setoid α)

namespace finsets

instance : has_emptyc (finsets α) := ⟨⟦lists.of' lists'.nil⟧⟩

instance : inhabited (finsets α) := ⟨∅⟩

instance [decidable_eq α] : decidable_eq (finsets α) :=
by unfold finsets; apply_instance

end finsets


<|start_filename|>src/category_theory/monad/adjunction.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import category_theory.adjunction.reflective
import category_theory.monad.algebra

/-!
# Adjunctions and monads

We develop the basic relationship between adjunctions and monads.

Given an adjunction `h : L ⊣ R`, we have `h.to_monad : monad C` and `h.to_comonad : comonad D`.
We then have
`monad.comparison (h : L ⊣ R) : D ⥤ h.to_monad.algebra`
sending `Y : D` to the Eilenberg-Moore algebra for `L ⋙ R` with underlying object `R.obj X`,
and dually `comonad.comparison`.

We say `R : D ⥤ C` is `monadic_right_adjoint`, if it is a right adjoint and its `monad.comparison`
is an equivalence of categories. (Similarly for `monadic_left_adjoint`.)

Finally we prove that reflective functors are `monadic_right_adjoint`.
-/

namespace category_theory
open category

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {L : C ⥤ D} {R : D ⥤ C}

namespace adjunction

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a monad on
the category `C`.
-/
@[simps]
def to_monad (h : L ⊣ R) : monad C :=
{ to_functor := L ⋙ R,
  η' := h.unit,
  μ' := whisker_right (whisker_left L h.counit) R,
  assoc' := λ X, by { dsimp, rw [←R.map_comp], simp },
  right_unit' := λ X, by { dsimp, rw [←R.map_comp], simp } }

/--
For a pair of functors `L : C ⥤ D`, `R : D ⥤ C`, an adjunction `h : L ⊣ R` induces a comonad on
the category `D`.
-/
@[simps]
def to_comonad (h : L ⊣ R) : comonad D :=
{ to_functor := R ⋙ L,
  ε' := h.counit,
  δ' := whisker_right (whisker_left R h.unit) L,
  coassoc' := λ X, by { dsimp, rw ← L.map_comp, simp },
  right_counit' := λ X, by { dsimp, rw ← L.map_comp, simp } }

/-- The monad induced by the Eilenberg-Moore adjunction is the original monad.  -/
@[simps]
def adj_to_monad_iso (T : monad C) : T.adj.to_monad ≅ T :=
monad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

/-- The comonad induced by the Eilenberg-Moore adjunction is the original comonad. -/
@[simps]
def adj_to_comonad_iso (G : comonad C) : G.adj.to_comonad ≅ G :=
comonad_iso.mk (nat_iso.of_components (λ X, iso.refl _) (by tidy))
  (λ X, by { dsimp, simp })
  (λ X, by { dsimp, simp })

end adjunction

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.monad.comparison R`
sending objects `Y : D` to Eilenberg-Moore algebras for `L ⋙ R` with underlying object `R.obj X`.

We later show that this is full when `R` is full, faithful when `R` is faithful,
and essentially surjective when `R` is reflective.
-/
@[simps]
def monad.comparison (h : L ⊣ R) : D ⥤ h.to_monad.algebra :=
{ obj := λ X,
  { A := R.obj X,
    a := R.map (h.counit.app X),
    assoc' := by { dsimp, rw [← R.map_comp, ← adjunction.counit_naturality, R.map_comp], refl } },
  map := λ X Y f,
  { f := R.map f,
    h' := by { dsimp, rw [← R.map_comp, adjunction.counit_naturality, R.map_comp] } } }.

/--
The underlying object of `(monad.comparison R).obj X` is just `R.obj X`.
-/
@[simps]
def monad.comparison_forget (h : L ⊣ R) :
  monad.comparison h ⋙ h.to_monad.forget ≅ R :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma monad.left_comparison (h : L ⊣ R) : L ⋙ monad.comparison h = h.to_monad.free := rfl

instance [faithful R] (h : L ⊣ R) :
  faithful (monad.comparison h) :=
{ map_injective' := λ X Y f g w, R.map_injective (congr_arg monad.algebra.hom.f w : _) }

instance (T : monad C) : full (monad.comparison T.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (T : monad C) : ess_surj (monad.comparison T.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, unit' := by simpa using X.unit, assoc' := by simpa using X.assoc },
    ⟨monad.algebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
Gven any adjunction `L ⊣ R`, there is a comparison functor `category_theory.comonad.comparison L`
sending objects `X : C` to Eilenberg-Moore coalgebras for `L ⋙ R` with underlying object
`L.obj X`.
-/
@[simps]
def comonad.comparison (h : L ⊣ R) : C ⥤ h.to_comonad.coalgebra :=
{ obj := λ X,
  { A := L.obj X,
    a := L.map (h.unit.app X),
    coassoc' := by { dsimp, rw [← L.map_comp, ← adjunction.unit_naturality, L.map_comp], refl } },
  map := λ X Y f,
  { f := L.map f,
    h' := by { dsimp, rw ← L.map_comp, simp } } }

/--
The underlying object of `(comonad.comparison L).obj X` is just `L.obj X`.
-/
@[simps]
def comonad.comparison_forget {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R) :
  comonad.comparison h ⋙ h.to_comonad.forget ≅ L :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, } }

lemma comonad.left_comparison (h : L ⊣ R) : R ⋙ comonad.comparison h = h.to_comonad.cofree := rfl

instance comonad.comparison_faithful_of_faithful [faithful L] (h : L ⊣ R) :
  faithful (comonad.comparison h) :=
{ map_injective' := λ X Y f g w, L.map_injective (congr_arg comonad.coalgebra.hom.f w : _) }

instance (G : comonad C) : full (comonad.comparison G.adj) :=
{ preimage := λ X Y f, ⟨f.f, by simpa using f.h⟩ }

instance (G : comonad C) : ess_surj (comonad.comparison G.adj) :=
{ mem_ess_image := λ X,
  ⟨{ A := X.A, a := X.a, counit' := by simpa using X.counit, coassoc' := by simpa using X.coassoc },
    ⟨comonad.coalgebra.iso_mk (iso.refl _) (by simp)⟩⟩ }

/--
A right adjoint functor `R : D ⥤ C` is *monadic* if the comparison functor `monad.comparison R`
from `D` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class monadic_right_adjoint (R : D ⥤ C) extends is_right_adjoint R :=
(eqv : is_equivalence (monad.comparison (adjunction.of_right_adjoint R)))

/--
A left adjoint functor `L : C ⥤ D` is *comonadic* if the comparison functor `comonad.comparison L`
from `C` to the category of Eilenberg-Moore algebras for the adjunction is an equivalence.
-/
class comonadic_left_adjoint (L : C ⥤ D) extends is_left_adjoint L :=
(eqv : is_equivalence (comonad.comparison (adjunction.of_left_adjoint L)))

noncomputable instance (T : monad C) : monadic_right_adjoint T.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (monad.comparison T.adj))⟩

noncomputable instance (G : comonad C) : comonadic_left_adjoint G.forget :=
⟨(equivalence.of_fully_faithfully_ess_surj _ : is_equivalence (comonad.comparison G.adj))⟩

-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
instance μ_iso_of_reflective [reflective R] : is_iso (adjunction.of_right_adjoint R).to_monad.μ :=
by { dsimp, apply_instance }

attribute [instance] monadic_right_adjoint.eqv
attribute [instance] comonadic_left_adjoint.eqv

namespace reflective

instance [reflective R] (X : (adjunction.of_right_adjoint R).to_monad.algebra) :
  is_iso ((adjunction.of_right_adjoint R).unit.app X.A) :=
⟨⟨X.a, ⟨X.unit, begin
    dsimp only [functor.id_obj],
    rw ← (adjunction.of_right_adjoint R).unit_naturality,
    dsimp only [functor.comp_obj, adjunction.to_monad_coe],
    rw [unit_obj_eq_map_unit, ←functor.map_comp, ←functor.map_comp],
    erw X.unit,
    simp,
  end⟩⟩⟩

instance comparison_ess_surj [reflective R] :
  ess_surj (monad.comparison (adjunction.of_right_adjoint R)) :=
begin
  refine ⟨λ X, ⟨(left_adjoint R).obj X.A, ⟨_⟩⟩⟩,
  symmetry,
  refine monad.algebra.iso_mk _ _,
  { exact as_iso ((adjunction.of_right_adjoint R).unit.app X.A) },
  dsimp only [functor.comp_map, monad.comparison_obj_a, as_iso_hom, functor.comp_obj,
    monad.comparison_obj_A, monad_to_functor_eq_coe, adjunction.to_monad_coe],
  rw [←cancel_epi ((adjunction.of_right_adjoint R).unit.app X.A), adjunction.unit_naturality_assoc,
      adjunction.right_triangle_components, comp_id],
  apply (X.unit_assoc _).symm,
end

instance comparison_full [full R] [is_right_adjoint R] :
  full (monad.comparison (adjunction.of_right_adjoint R)) :=
{ preimage := λ X Y f, R.preimage f.f }

end reflective

-- It is possible to do this computably since the construction gives the data of the inverse, not
-- just the existence of an inverse on each object.
/-- Any reflective inclusion has a monadic right adjoint.
    cf Prop 5.3.3 of [Riehl][riehl2017] -/
@[priority 100] -- see Note [lower instance priority]
noncomputable instance monadic_of_reflective [reflective R] : monadic_right_adjoint R :=
{ eqv := equivalence.of_fully_faithfully_ess_surj _ }

end category_theory


<|start_filename|>src/order/cover.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>
-/
import data.set.intervals.ord_connected

/-!
# The covering relation

This file defines the covering relation in an order. `b` is said to cover `a` if `a < b` and there
is no element in between. We say that `b` weakly covers `a` if `a ≤ b` and there is no element
between `a` and `b`. In a partial order this is equivalent to `a ⋖ b ∨ a = b`, in a preorder this
is equivalent to `a ⋖ b ∨ (a ≤ b ∧ b ≤ a)`

## Notation

* `a ⋖ b` means that `b` covers `a`.
* `a ⩿ b` means that `b` weakly covers `a`.
-/

open set order_dual

variables {α β : Type*}

section weakly_covers

section preorder
variables [preorder α] [preorder β] {a b c: α}

/-- `wcovby a b` means that `a = b` or `b` covers `a`.
This means that `a ≤ b` and there is no element in between.
-/
def wcovby (a b : α) : Prop := a ≤ b ∧ ∀ ⦃c⦄, a < c → ¬ c < b

infix ` ⩿ `:50 := wcovby

lemma wcovby.le (h : a ⩿ b) : a ≤ b := h.1

lemma wcovby.refl (a : α) : a ⩿ a := ⟨le_rfl, λ c hc, hc.not_lt⟩
lemma wcovby.rfl : a ⩿ a := wcovby.refl a

protected lemma eq.wcovby (h : a = b) : a ⩿ b := h ▸ wcovby.rfl

lemma wcovby_of_le_of_le (h1 : a ≤ b) (h2 : b ≤ a) : a ⩿ b :=
⟨h1, λ c hac hcb, (hac.trans hcb).not_le h2⟩

alias wcovby_of_le_of_le ← has_le.le.wcovby_of_le

lemma wcovby.wcovby_iff_le (hab : a ⩿ b) : b ⩿ a ↔ b ≤ a :=
⟨λ h, h.le, λ h, h.wcovby_of_le hab.le⟩

lemma wcovby_of_eq_or_eq (hab : a ≤ b) (h : ∀ c, a ≤ c → c ≤ b → c = a ∨ c = b) : a ⩿ b :=
⟨hab, λ c ha hb, (h c ha.le hb.le).elim ha.ne' hb.ne⟩

/-- If `a ≤ b`, then `b` does not cover `a` iff there's an element in between. -/
lemma not_wcovby_iff (h : a ≤ b) : ¬ a ⩿ b ↔ ∃ c, a < c ∧ c < b :=
by simp_rw [wcovby, h, true_and, not_forall, exists_prop, not_not]

instance wcovby.is_refl : is_refl α (⩿) := ⟨wcovby.refl⟩

lemma wcovby.Ioo_eq (h : a ⩿ b) : Ioo a b = ∅ :=
eq_empty_iff_forall_not_mem.2 $ λ x hx, h.2 hx.1 hx.2

lemma wcovby.of_image (f : α ↪o β) (h : f a ⩿ f b) : a ⩿ b :=
⟨f.le_iff_le.mp h.le, λ c hac hcb, h.2 (f.lt_iff_lt.mpr hac) (f.lt_iff_lt.mpr hcb)⟩

lemma wcovby.image (f : α ↪o β) (hab : a ⩿ b) (h : (range f).ord_connected) : f a ⩿ f b :=
begin
  refine ⟨f.monotone hab.le, λ c ha hb, _⟩,
  obtain ⟨c, rfl⟩ := h.out (mem_range_self _) (mem_range_self _) ⟨ha.le, hb.le⟩,
  rw f.lt_iff_lt at ha hb,
  exact hab.2 ha hb,
end

lemma set.ord_connected.apply_wcovby_apply_iff (f : α ↪o β) (h : (range f).ord_connected) :
  f a ⩿ f b ↔ a ⩿ b :=
⟨λ h2, h2.of_image f, λ hab, hab.image f h⟩

@[simp] lemma apply_wcovby_apply_iff {E : Type*} [order_iso_class E α β] (e : E) :
  e a ⩿ e b ↔ a ⩿ b :=
(ord_connected_range (e : α ≃o β)).apply_wcovby_apply_iff ((e : α ≃o β) : α ↪o β)

@[simp] lemma to_dual_wcovby_to_dual_iff : to_dual b ⩿ to_dual a ↔ a ⩿ b :=
and_congr_right' $ forall_congr $ λ c, forall_swap

@[simp] lemma of_dual_wcovby_of_dual_iff {a b : αᵒᵈ} :
  of_dual a ⩿ of_dual b ↔ b ⩿ a :=
and_congr_right' $ forall_congr $ λ c, forall_swap

alias to_dual_wcovby_to_dual_iff ↔ _ wcovby.to_dual
alias of_dual_wcovby_of_dual_iff ↔ _ wcovby.of_dual

end preorder

section partial_order
variables [partial_order α] {a b c : α}

lemma wcovby.eq_or_eq (h : a ⩿ b) (h2 : a ≤ c) (h3 : c ≤ b) : c = a ∨ c = b :=
begin
  rcases h2.eq_or_lt with h2|h2, { exact or.inl h2.symm },
  rcases h3.eq_or_lt with h3|h3, { exact or.inr h3 },
  exact (h.2 h2 h3).elim
end

lemma wcovby.le_and_le_iff (h : a ⩿ b) : a ≤ c ∧ c ≤ b ↔ c = a ∨ c = b :=
begin
  refine ⟨λ h2, h.eq_or_eq h2.1 h2.2, _⟩, rintro (rfl|rfl), exacts [⟨le_rfl, h.le⟩, ⟨h.le, le_rfl⟩]
end

lemma wcovby.Icc_eq (h : a ⩿ b) : Icc a b = {a, b} :=
by { ext c, exact h.le_and_le_iff }

lemma wcovby.Ico_subset (h : a ⩿ b) : Ico a b ⊆ {a} :=
by rw [← Icc_diff_right, h.Icc_eq, diff_singleton_subset_iff, pair_comm]

lemma wcovby.Ioc_subset (h : a ⩿ b) : Ioc a b ⊆ {b} :=
by rw [← Icc_diff_left, h.Icc_eq, diff_singleton_subset_iff]

end partial_order

end weakly_covers

section has_lt
variables [has_lt α] {a b : α}

/-- `covby a b` means that `b` covers `a`: `a < b` and there is no element in between. -/
def covby (a b : α) : Prop := a < b ∧ ∀ ⦃c⦄, a < c → ¬ c < b

infix ` ⋖ `:50 := covby

lemma covby.lt (h : a ⋖ b) : a < b := h.1

/-- If `a < b`, then `b` does not cover `a` iff there's an element in between. -/
lemma not_covby_iff (h : a < b) : ¬a ⋖ b ↔ ∃ c, a < c ∧ c < b :=
by simp_rw [covby, h, true_and, not_forall, exists_prop, not_not]

alias not_covby_iff ↔ exists_lt_lt_of_not_covby _
alias exists_lt_lt_of_not_covby ← has_lt.lt.exists_lt_lt

/-- In a dense order, nothing covers anything. -/
lemma not_covby [densely_ordered α] : ¬ a ⋖ b :=
λ h, let ⟨c, hc⟩ := exists_between h.1 in h.2 hc.1 hc.2

lemma densely_ordered_iff_forall_not_covby : densely_ordered α ↔ ∀ a b : α, ¬ a ⋖ b :=
⟨λ h a b, @not_covby _ _ _ _ h, λ h, ⟨λ a b hab, exists_lt_lt_of_not_covby hab $ h _ _⟩⟩

@[simp] lemma to_dual_covby_to_dual_iff : to_dual b ⋖ to_dual a ↔ a ⋖ b :=
and_congr_right' $ forall_congr $ λ c, forall_swap

@[simp] lemma of_dual_covby_of_dual_iff {a b : αᵒᵈ} : of_dual a ⋖ of_dual b ↔ b ⋖ a :=
and_congr_right' $ forall_congr $ λ c, forall_swap

alias to_dual_covby_to_dual_iff ↔ _ covby.to_dual
alias of_dual_covby_of_dual_iff ↔ _ covby.of_dual

end has_lt

section preorder
variables [preorder α] [preorder β] {a b : α}

lemma covby.le (h : a ⋖ b) : a ≤ b := h.1.le
protected lemma covby.ne (h : a ⋖ b) : a ≠ b := h.lt.ne
lemma covby.ne' (h : a ⋖ b) : b ≠ a := h.lt.ne'

protected lemma covby.wcovby (h : a ⋖ b) : a ⩿ b := ⟨h.le, h.2⟩
lemma wcovby.covby_of_not_le (h : a ⩿ b) (h2 : ¬ b ≤ a) : a ⋖ b := ⟨h.le.lt_of_not_le h2, h.2⟩
lemma wcovby.covby_of_lt (h : a ⩿ b) (h2 : a < b) : a ⋖ b := ⟨h2, h.2⟩

lemma covby_iff_wcovby_and_lt : a ⋖ b ↔ a ⩿ b ∧ a < b :=
⟨λ h, ⟨h.wcovby, h.lt⟩, λ h, h.1.covby_of_lt h.2⟩

lemma covby_iff_wcovby_and_not_le : a ⋖ b ↔ a ⩿ b ∧ ¬ b ≤ a :=
⟨λ h, ⟨h.wcovby, h.lt.not_le⟩, λ h, h.1.covby_of_not_le h.2⟩

lemma wcovby_iff_covby_or_le_and_le : a ⩿ b ↔ a ⋖ b ∨ (a ≤ b ∧ b ≤ a) :=
⟨λ h, or_iff_not_imp_right.mpr $ λ h', h.covby_of_not_le $ λ hba, h' ⟨h.le, hba⟩,
  λ h', h'.elim (λ h, h.wcovby) (λ h, h.1.wcovby_of_le h.2)⟩

instance : is_nonstrict_strict_order α (⩿) (⋖) :=
⟨λ a b, covby_iff_wcovby_and_not_le.trans $ and_congr_right $ λ h, h.wcovby_iff_le.not.symm⟩

instance covby.is_irrefl : is_irrefl α (⋖) := ⟨λ a ha, ha.ne rfl⟩

lemma covby.Ioo_eq (h : a ⋖ b) : Ioo a b = ∅ :=
h.wcovby.Ioo_eq

lemma covby.of_image (f : α ↪o β) (h : f a ⋖ f b) : a ⋖ b :=
⟨f.lt_iff_lt.mp h.lt, λ c hac hcb, h.2 (f.lt_iff_lt.mpr hac) (f.lt_iff_lt.mpr hcb)⟩

lemma covby.image (f : α ↪o β) (hab : a ⋖ b) (h : (range f).ord_connected) : f a ⋖ f b :=
(hab.wcovby.image f h).covby_of_lt $ f.strict_mono hab.lt

lemma set.ord_connected.apply_covby_apply_iff (f : α ↪o β) (h : (range f).ord_connected) :
  f a ⋖ f b ↔ a ⋖ b :=
⟨covby.of_image f, λ hab, hab.image f h⟩

@[simp] lemma apply_covby_apply_iff {E : Type*} [order_iso_class E α β] (e : E) :
  e a ⋖ e b ↔ a ⋖ b :=
(ord_connected_range (e : α ≃o β)).apply_covby_apply_iff ((e : α ≃o β) : α ↪o β)

end preorder

section partial_order
variables [partial_order α] {a b : α}

lemma wcovby.covby_of_ne (h : a ⩿ b) (h2 : a ≠ b) : a ⋖ b := ⟨h.le.lt_of_ne h2, h.2⟩

lemma covby_iff_wcovby_and_ne : a ⋖ b ↔ a ⩿ b ∧ a ≠ b :=
⟨λ h, ⟨h.wcovby, h.ne⟩, λ h, h.1.covby_of_ne h.2⟩

lemma wcovby_iff_covby_or_eq : a ⩿ b ↔ a ⋖ b ∨ a = b :=
by rw [le_antisymm_iff, wcovby_iff_covby_or_le_and_le]

lemma covby.Ico_eq (h : a ⋖ b) : Ico a b = {a} :=
by rw [←Ioo_union_left h.lt, h.Ioo_eq, empty_union]

lemma covby.Ioc_eq (h : a ⋖ b) : Ioc a b = {b} :=
by rw [←Ioo_union_right h.lt, h.Ioo_eq, empty_union]

lemma covby.Icc_eq (h : a ⋖ b) : Icc a b = {a, b} :=
h.wcovby.Icc_eq

end partial_order

section linear_order
variables [linear_order α] {a b c : α}

lemma covby.Ioi_eq (h : a ⋖ b) : Ioi a = Ici b :=
by rw [← Ioo_union_Ici_eq_Ioi h.lt, h.Ioo_eq, empty_union]

lemma covby.Iio_eq (h : a ⋖ b) : Iio b = Iic a :=
by rw [← Iic_union_Ioo_eq_Iio h.lt, h.Ioo_eq, union_empty]

lemma wcovby.le_of_lt (hab : a ⩿ b) (hcb : c < b) : c ≤ a := not_lt.1 $ λ hac, hab.2 hac hcb
lemma wcovby.ge_of_gt (hab : a ⩿ b) (hac : a < c) : b ≤ c := not_lt.1 $ hab.2 hac
lemma covby.le_of_lt (hab : a ⋖ b) : c < b → c ≤ a := hab.wcovby.le_of_lt
lemma covby.ge_of_gt (hab : a ⋖ b) : a < c → b ≤ c := hab.wcovby.ge_of_gt

lemma covby.unique_left (ha : a ⋖ c) (hb : b ⋖ c) : a = b :=
(hb.le_of_lt ha.lt).antisymm $ ha.le_of_lt hb.lt

lemma covby.unique_right (hb : a ⋖ b) (hc : a ⋖ c) : b = c :=
(hb.ge_of_gt hc.lt).antisymm $ hc.ge_of_gt hb.lt

end linear_order

namespace set

lemma wcovby_insert (x : α) (s : set α) : s ⩿ insert x s :=
begin
  refine wcovby_of_eq_or_eq (subset_insert x s) (λ t hst h2t, _),
  by_cases h : x ∈ t,
  { exact or.inr (subset_antisymm h2t $ insert_subset.mpr ⟨h, hst⟩) },
  { refine or.inl (subset_antisymm _ hst),
    rwa [← diff_singleton_eq_self h, diff_singleton_subset_iff] }
end

lemma covby_insert {x : α} {s : set α} (hx : x ∉ s) : s ⋖ insert x s :=
(wcovby_insert x s).covby_of_lt $ ssubset_insert hx

end set


<|start_filename|>src/category_theory/bicategory/locally_discrete.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.discrete_category
import category_theory.bicategory.functor
import category_theory.bicategory.strict

/-!
# Locally discrete bicategories

A category `C` can be promoted to a strict bicategory `locally_discrete C`. The objects and the
1-morphisms in `locally_discrete C` are the same as the objects and the morphisms, respectively,
in `C`, and the 2-morphisms in `locally_discrete C` are the equalities between 1-morphisms. In
other words, the category consisting of the 1-morphisms between each pair of objects `X` and `Y`
in `locally_discrete C` is defined as the discrete category associated with the type `X ⟶ Y`.
-/

namespace category_theory

open bicategory discrete
open_locale bicategory

universes w₂ v v₁ v₂ u u₁ u₂

variables {C : Type u}

/--
A type synonym for promoting any type to a category,
with the only morphisms being equalities.
-/
def locally_discrete (C : Type u) := C

namespace locally_discrete

instance : Π [inhabited C], inhabited (locally_discrete C) := id

instance [category_struct.{v} C] : category_struct (locally_discrete C) :=
{ hom := λ (X Y : C), discrete (X ⟶ Y),
  id := λ X : C, ⟨𝟙 X⟩,
  comp := λ X Y Z f g, ⟨f.as ≫ g.as⟩ }

variables {C} [category_struct.{v} C]

@[priority 900]
instance hom_small_category (X Y : locally_discrete C) : small_category (X ⟶ Y) :=
category_theory.discrete_category (X ⟶ Y)

/-- Extract the equation from a 2-morphism in a locally discrete 2-category. -/
lemma eq_of_hom {X Y : locally_discrete C} {f g : X ⟶ Y} (η : f ⟶ g) : f = g :=
begin
  have : discrete.mk (f.as) = discrete.mk (g.as) := congr_arg discrete.mk (eq_of_hom η),
  simpa using this
end

end locally_discrete

variables (C) [category.{v} C]

/--
The locally discrete bicategory on a category is a bicategory in which the objects and the
1-morphisms are the same as those in the underlying category, and the 2-morphisms are the
equalities between 1-morphisms.
-/
instance locally_discrete_bicategory : bicategory (locally_discrete C) :=
{ whisker_left  := λ X Y Z f g h η, eq_to_hom (congr_arg2 (≫) rfl (locally_discrete.eq_of_hom η)),
  whisker_right := λ X Y Z f g η h, eq_to_hom (congr_arg2 (≫) (locally_discrete.eq_of_hom η) rfl),
  associator := λ W X Y Z f g h, eq_to_iso $ by { unfold_projs, simp only [category.assoc] },
  left_unitor  := λ X Y f, eq_to_iso $ by { unfold_projs, simp only [category.id_comp, mk_as] },
  right_unitor := λ X Y f, eq_to_iso $ by { unfold_projs, simp only [category.comp_id, mk_as] } }

/-- A locally discrete bicategory is strict. -/
instance locally_discrete_bicategory.strict : strict (locally_discrete C) :=
{ id_comp' := by { intros, ext1, unfold_projs, apply category.id_comp },
  comp_id' := by { intros, ext1, unfold_projs, apply category.comp_id },
  assoc' := by { intros, ext1, unfold_projs, apply category.assoc } }

variables {I : Type u₁} [category.{v₁} I] {B : Type u₂} [bicategory.{w₂ v₂} B] [strict B]

/--
If `B` is a strict bicategory and `I` is a (1-)category, any functor (of 1-categories) `I ⥤ B` can
be promoted to an oplax functor from `locally_discrete I` to `B`.
-/
@[simps]
def functor.to_oplax_functor (F : I ⥤ B) : oplax_functor (locally_discrete I) B :=
{ obj := F.obj,
  map := λ X Y f, F.map f.as,
  map₂ := λ i j f g η, eq_to_hom (congr_arg _ (eq_of_hom η)),
  map_id := λ i, eq_to_hom (F.map_id i),
  map_comp := λ i j k f g, eq_to_hom (F.map_comp f.as g.as) }

end category_theory


<|start_filename|>src/topology/uniform_space/equiv.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>,
<NAME>
-/
import topology.homeomorph
import topology.uniform_space.uniform_embedding
import topology.uniform_space.pi

/-!
# Uniform isomorphisms

This file defines uniform isomorphisms between two uniform spaces. They are bijections with both
directions uniformly continuous. We denote uniform isomorphisms with the notation `≃ᵤ`.

# Main definitions

* `uniform_equiv α β`: The type of uniform isomorphisms from `α` to `β`.
  This type can be denoted using the following notation: `α ≃ᵤ β`.

-/

open set filter
open_locale

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

/-- Uniform isomorphism between `α` and `β` -/
@[nolint has_inhabited_instance] -- not all spaces are homeomorphic to each other
structure uniform_equiv (α : Type*) (β : Type*) [uniform_space α] [uniform_space β]
  extends α ≃ β :=
(uniform_continuous_to_fun  : uniform_continuous to_fun)
(uniform_continuous_inv_fun : uniform_continuous inv_fun)

infix ` ≃ᵤ `:25 := uniform_equiv

namespace uniform_equiv
variables [uniform_space α] [uniform_space β] [uniform_space γ] [uniform_space δ]

instance : has_coe_to_fun (α ≃ᵤ β) (λ _, α → β) := ⟨λe, e.to_equiv⟩

@[simp] lemma uniform_equiv_mk_coe (a : equiv α β) (b c) :
  ((uniform_equiv.mk a b c) : α → β) = a :=
rfl

/-- Inverse of a uniform isomorphism. -/
protected def symm (h : α ≃ᵤ β) : β ≃ᵤ α :=
{ uniform_continuous_to_fun  := h.uniform_continuous_inv_fun,
  uniform_continuous_inv_fun := h.uniform_continuous_to_fun,
  to_equiv := h.to_equiv.symm }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : α ≃ᵤ β) : α → β := h
/-- See Note [custom simps projection] -/
def simps.symm_apply (h : α ≃ᵤ β) : β → α := h.symm

initialize_simps_projections uniform_equiv
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

@[simp] lemma coe_to_equiv (h : α ≃ᵤ β) : ⇑h.to_equiv = h := rfl
@[simp] lemma coe_symm_to_equiv (h : α ≃ᵤ β) : ⇑h.to_equiv.symm = h.symm := rfl

lemma to_equiv_injective : function.injective (to_equiv : α ≃ᵤ β → α ≃ β)
| ⟨e, h₁, h₂⟩ ⟨e', h₁', h₂'⟩ rfl := rfl

@[ext] lemma ext {h h' : α ≃ᵤ β} (H : ∀ x, h x = h' x) : h = h' :=
to_equiv_injective $ equiv.ext H

/-- Identity map as a uniform isomorphism. -/
@[simps apply {fully_applied := ff}]
protected def refl (α : Type*) [uniform_space α] : α ≃ᵤ α :=
{ uniform_continuous_to_fun := uniform_continuous_id,
  uniform_continuous_inv_fun := uniform_continuous_id,
  to_equiv := equiv.refl α }

/-- Composition of two uniform isomorphisms. -/
protected def trans (h₁ : α ≃ᵤ β) (h₂ : β ≃ᵤ γ) : α ≃ᵤ γ :=
{ uniform_continuous_to_fun  := h₂.uniform_continuous_to_fun.comp h₁.uniform_continuous_to_fun,
  uniform_continuous_inv_fun := h₁.uniform_continuous_inv_fun.comp h₂.uniform_continuous_inv_fun,
  to_equiv := equiv.trans h₁.to_equiv h₂.to_equiv }

@[simp] lemma trans_apply (h₁ : α ≃ᵤ β) (h₂ : β ≃ᵤ γ) (a : α) : h₁.trans h₂ a = h₂ (h₁ a) := rfl

@[simp] lemma uniform_equiv_mk_coe_symm (a : equiv α β) (b c) :
  ((uniform_equiv.mk a b c).symm : β → α) = a.symm :=
rfl

@[simp] lemma refl_symm : (uniform_equiv.refl α).symm = uniform_equiv.refl α := rfl

protected lemma uniform_continuous (h : α ≃ᵤ β) : uniform_continuous h :=
h.uniform_continuous_to_fun

@[continuity]
protected lemma continuous (h : α ≃ᵤ β) : continuous h :=
h.uniform_continuous.continuous

protected lemma uniform_continuous_symm (h : α ≃ᵤ β) : uniform_continuous (h.symm) :=
h.uniform_continuous_inv_fun

@[continuity] -- otherwise `by continuity` can't prove continuity of `h.to_equiv.symm`
protected lemma continuous_symm (h : α ≃ᵤ β) : continuous (h.symm) :=
h.uniform_continuous_symm.continuous

/-- A uniform isomorphism as a homeomorphism. -/
@[simps]
protected def to_homeomorph (e : α ≃ᵤ β) : α ≃ₜ β :=
{ continuous_to_fun := e.continuous,
  continuous_inv_fun := e.continuous_symm,
  .. e.to_equiv }

@[simp] lemma apply_symm_apply (h : α ≃ᵤ β) (x : β) : h (h.symm x) = x :=
h.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (h : α ≃ᵤ β) (x : α) : h.symm (h x) = x :=
h.to_equiv.symm_apply_apply x

protected lemma bijective (h : α ≃ᵤ β) : function.bijective h := h.to_equiv.bijective
protected lemma injective (h : α ≃ᵤ β) : function.injective h := h.to_equiv.injective
protected lemma surjective (h : α ≃ᵤ β) : function.surjective h := h.to_equiv.surjective

/-- Change the uniform equiv `f` to make the inverse function definitionally equal to `g`. -/
def change_inv (f : α ≃ᵤ β) (g : β → α) (hg : function.right_inverse g f) : α ≃ᵤ β :=
have g = f.symm, from funext (λ x, calc g x = f.symm (f (g x)) : (f.left_inv (g x)).symm
                                        ... = f.symm x : by rw hg x),
{ to_fun := f,
  inv_fun := g,
  left_inv := by convert f.left_inv,
  right_inv := by convert f.right_inv,
  uniform_continuous_to_fun := f.uniform_continuous,
  uniform_continuous_inv_fun := by convert f.symm.uniform_continuous }

@[simp] lemma symm_comp_self (h : α ≃ᵤ β) : ⇑h.symm ∘ ⇑h = id :=
funext h.symm_apply_apply

@[simp] lemma self_comp_symm (h : α ≃ᵤ β) : ⇑h ∘ ⇑h.symm = id :=
funext h.apply_symm_apply

@[simp] lemma range_coe (h : α ≃ᵤ β) : range h = univ :=
h.surjective.range_eq

lemma image_symm (h : α ≃ᵤ β) : image h.symm = preimage h :=
funext h.symm.to_equiv.image_eq_preimage

lemma preimage_symm (h : α ≃ᵤ β) : preimage h.symm = image h :=
(funext h.to_equiv.image_eq_preimage).symm

@[simp] lemma image_preimage (h : α ≃ᵤ β) (s : set β) : h '' (h ⁻¹' s) = s :=
h.to_equiv.image_preimage s

@[simp] lemma preimage_image (h : α ≃ᵤ β) (s : set α) : h ⁻¹' (h '' s) = s :=
h.to_equiv.preimage_image s

protected lemma uniform_inducing (h : α ≃ᵤ β) : uniform_inducing h :=
uniform_inducing_of_compose h.uniform_continuous h.symm.uniform_continuous $
  by simp only [symm_comp_self, uniform_inducing_id]

lemma comap_eq (h : α ≃ᵤ β) : uniform_space.comap h ‹_› = ‹_› :=
by ext : 1; exact h.uniform_inducing.comap_uniformity

protected lemma uniform_embedding (h : α ≃ᵤ β) : uniform_embedding h :=
⟨h.uniform_inducing, h.injective⟩

/-- Uniform equiv given a uniform embedding. -/
noncomputable def of_uniform_embedding (f : α → β) (hf : uniform_embedding f) :
  α ≃ᵤ (set.range f) :=
{ uniform_continuous_to_fun := uniform_continuous_subtype_mk
    hf.to_uniform_inducing.uniform_continuous _,
  uniform_continuous_inv_fun :=
    by simp [hf.to_uniform_inducing.uniform_continuous_iff, uniform_continuous_subtype_coe],
  to_equiv := equiv.of_injective f hf.inj }

/-- If two sets are equal, then they are uniformly equivalent. -/
def set_congr {s t : set α} (h : s = t) : s ≃ᵤ t :=
{ uniform_continuous_to_fun := uniform_continuous_subtype_mk uniform_continuous_subtype_val _,
  uniform_continuous_inv_fun := uniform_continuous_subtype_mk uniform_continuous_subtype_val _,
  to_equiv := equiv.set_congr h }

/-- Product of two uniform isomorphisms. -/
def prod_congr (h₁ : α ≃ᵤ β) (h₂ : γ ≃ᵤ δ) : α × γ ≃ᵤ β × δ :=
{ uniform_continuous_to_fun  := (h₁.uniform_continuous.comp uniform_continuous_fst).prod_mk
    (h₂.uniform_continuous.comp uniform_continuous_snd),
  uniform_continuous_inv_fun := (h₁.symm.uniform_continuous.comp uniform_continuous_fst).prod_mk
    (h₂.symm.uniform_continuous.comp uniform_continuous_snd),
  to_equiv := h₁.to_equiv.prod_congr h₂.to_equiv }

@[simp] lemma prod_congr_symm (h₁ : α ≃ᵤ β) (h₂ : γ ≃ᵤ δ) :
  (h₁.prod_congr h₂).symm = h₁.symm.prod_congr h₂.symm := rfl

@[simp] lemma coe_prod_congr (h₁ : α ≃ᵤ β) (h₂ : γ ≃ᵤ δ) :
  ⇑(h₁.prod_congr h₂) = prod.map h₁ h₂ := rfl

section
variables (α β γ)

/-- `α × β` is uniformly isomorphic to `β × α`. -/
def prod_comm : α × β ≃ᵤ β × α :=
{ uniform_continuous_to_fun  := uniform_continuous_snd.prod_mk uniform_continuous_fst,
  uniform_continuous_inv_fun := uniform_continuous_snd.prod_mk uniform_continuous_fst,
  to_equiv := equiv.prod_comm α β }

@[simp] lemma prod_comm_symm : (prod_comm α β).symm = prod_comm β α := rfl
@[simp] lemma coe_prod_comm : ⇑(prod_comm α β) = prod.swap := rfl

/-- `(α × β) × γ` is uniformly isomorphic to `α × (β × γ)`. -/
def prod_assoc : (α × β) × γ ≃ᵤ α × (β × γ) :=
{ uniform_continuous_to_fun  := (uniform_continuous_fst.comp uniform_continuous_fst).prod_mk
    ((uniform_continuous_snd.comp uniform_continuous_fst).prod_mk uniform_continuous_snd),
  uniform_continuous_inv_fun := (uniform_continuous_fst.prod_mk
    (uniform_continuous_fst.comp uniform_continuous_snd)).prod_mk
    (uniform_continuous_snd.comp uniform_continuous_snd),
  to_equiv := equiv.prod_assoc α β γ }

/-- `α × {*}` is uniformly isomorphic to `α`. -/
@[simps apply {fully_applied := ff}]
def prod_punit : α × punit ≃ᵤ α :=
{ to_equiv := equiv.prod_punit α,
  uniform_continuous_to_fun := uniform_continuous_fst,
  uniform_continuous_inv_fun := uniform_continuous_id.prod_mk uniform_continuous_const }

/-- `{*} × α` is uniformly isomorphic to `α`. -/
def punit_prod : punit × α ≃ᵤ α :=
(prod_comm _ _).trans (prod_punit _)

@[simp] lemma coe_punit_prod : ⇑(punit_prod α) = prod.snd := rfl

end

/-- If `ι` has a unique element, then `ι → α` is homeomorphic to `α`. -/
@[simps { fully_applied := ff }]
def fun_unique (ι α : Type*) [unique ι] [uniform_space α] : (ι → α) ≃ᵤ α :=
{ to_equiv := equiv.fun_unique ι α,
  uniform_continuous_to_fun := Pi.uniform_continuous_proj _ _,
  uniform_continuous_inv_fun := uniform_continuous_pi.mpr (λ _, uniform_continuous_id) }

/-- Uniform isomorphism between dependent functions `Π i : fin 2, α i` and `α 0 × α 1`. -/
@[simps { fully_applied := ff }]
def {u} pi_fin_two (α : fin 2 → Type u) [Π i, uniform_space (α i)] : (Π i, α i) ≃ᵤ α 0 × α 1 :=
{ to_equiv := pi_fin_two_equiv α,
  uniform_continuous_to_fun :=
    (Pi.uniform_continuous_proj _ 0).prod_mk (Pi.uniform_continuous_proj _ 1),
  uniform_continuous_inv_fun := uniform_continuous_pi.mpr $
    fin.forall_fin_two.2 ⟨uniform_continuous_fst, uniform_continuous_snd⟩ }

/-- Uniform isomorphism between `α² = fin 2 → α` and `α × α`. -/
@[simps { fully_applied := ff }] def fin_two_arrow : (fin 2 → α) ≃ᵤ α × α :=
{ to_equiv := fin_two_arrow_equiv α, .. pi_fin_two (λ _, α) }

/--
A subset of a uniform space is uniformly isomorphic to its image under a uniform isomorphism.
-/
def image (e : α ≃ᵤ β) (s : set α) : s ≃ᵤ e '' s :=
{ uniform_continuous_to_fun := uniform_continuous_subtype_mk
    (e.uniform_continuous.comp uniform_continuous_subtype_val) (λ x, mem_image_of_mem _ x.2),
  uniform_continuous_inv_fun := uniform_continuous_subtype_mk
    (e.symm.uniform_continuous.comp uniform_continuous_subtype_val)
    (λ x, by simpa using mem_image_of_mem e.symm x.2),
  to_equiv := e.to_equiv.image s }

end uniform_equiv

/-- A uniform inducing equiv between uniform spaces is a uniform isomorphism. -/
@[simps] def equiv.to_uniform_equiv_of_uniform_inducing [uniform_space α] [uniform_space β]
  (f : α ≃ β) (hf : uniform_inducing f) :
  α ≃ᵤ β :=
{ uniform_continuous_to_fun := hf.uniform_continuous,
  uniform_continuous_inv_fun := hf.uniform_continuous_iff.2 $ by simpa using uniform_continuous_id,
  .. f }


<|start_filename|>src/analysis/normed_space/hahn_banach/separation.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME> All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import analysis.convex.cone
import analysis.convex.gauge

/-!
# Separation Hahn-Banach theorem

In this file we prove the geometric Hahn-Banach theorem. For any two disjoint convex sets, there
exists a continuous linear functional separating them, geometrically meaning that we can intercalate
a plane between them.

We provide many variations to stricten the result under more assumptions on the convex sets:
* `geometric_hahn_banach_open`: One set is open. Weak separation.
* `geometric_hahn_banach_open_point`, `geometric_hahn_banach_point_open`: One set is open, the
  other is a singleton. Weak separation.
* `geometric_hahn_banach_open_open`: Both sets are open. Semistrict separation.
* `geometric_hahn_banach_compact_closed`, `geometric_hahn_banach_closed_compact`: One set is closed,
  the other one is compact. Strict separation.
* `geometric_hahn_banach_point_closed`, `geometric_hahn_banach_closed_point`: One set is closed, the
  other one is a singleton. Strict separation.
* `geometric_hahn_banach_point_point`: Both sets are singletons. Strict separation.

## TODO

* Eidelheit's theorem
* `convex ℝ s → interior (closure s) ⊆ s`
-/

open set
open_locale pointwise

variables {𝕜 E : Type*}

/-- Given a set `s` which is a convex neighbourhood of `0` and a point `x₀` outside of it, there is
a continuous linear functional `f` separating `x₀` and `s`, in the sense that it sends `x₀` to 1 and
all of `s` to values strictly below `1`. -/
lemma separate_convex_open_set [semi_normed_group E] [normed_space ℝ E] {s : set E}
  (hs₀ : (0 : E) ∈ s) (hs₁ : convex ℝ s) (hs₂ : is_open s) {x₀ : E} (hx₀ : x₀ ∉ s) :
  ∃ f : E →L[ℝ] ℝ, f x₀ = 1 ∧ ∀ x ∈ s, f x < 1 :=
begin
  let f : linear_pmap ℝ E ℝ :=
    linear_pmap.mk_span_singleton x₀ 1 (ne_of_mem_of_not_mem hs₀ hx₀).symm,
  obtain ⟨r, hr, hrs⟩ := metric.mem_nhds_iff.1
    (filter.inter_mem (hs₂.mem_nhds hs₀) $ hs₂.neg.mem_nhds $ by rwa [mem_neg, neg_zero]),
  obtain ⟨φ, hφ₁, hφ₂⟩ := exists_extension_of_le_sublinear f (gauge s)
    (λ c hc, gauge_smul_of_nonneg hc.le)
    (gauge_add_le hs₁ $ absorbent_nhds_zero $ hs₂.mem_nhds hs₀) _,
  { refine ⟨φ.mk_continuous (r⁻¹) $ λ x, _, _, _⟩,
    { rw [real.norm_eq_abs, abs_le, neg_le, ←linear_map.map_neg],
      nth_rewrite 0 ←norm_neg x,
      suffices : ∀ x, φ x ≤ r⁻¹ * ∥x∥,
      { exact ⟨this _, this _⟩ },
      refine λ x, (hφ₂ _).trans _,
      rw [←div_eq_inv_mul, ←gauge_ball hr],
      exact gauge_mono (absorbent_ball_zero hr) (hrs.trans $ inter_subset_left _ _) x },
    { dsimp,
      rw [←submodule.coe_mk x₀ (submodule.mem_span_singleton_self _), hφ₁,
        linear_pmap.mk_span_singleton'_apply_self] },
    { exact λ x hx, (hφ₂ x).trans_lt (gauge_lt_one_of_mem_of_open hs₁ hs₀ hs₂ hx) } },
  rintro ⟨x, hx⟩,
  obtain ⟨y, rfl⟩ := submodule.mem_span_singleton.1 hx,
  rw linear_pmap.mk_span_singleton'_apply,
  simp only [mul_one, algebra.id.smul_eq_mul, submodule.coe_mk],
  obtain h | h := le_or_lt y 0,
  { exact h.trans (gauge_nonneg _) },
  { rw [gauge_smul_of_nonneg h.le, smul_eq_mul, le_mul_iff_one_le_right h],
    exact one_le_gauge_of_not_mem (hs₁.star_convex hs₀)
      ((absorbent_ball_zero hr).subset $ hrs.trans $ inter_subset_left _ _).absorbs hx₀,
    apply_instance }
end

variables [normed_group E] [normed_space ℝ E] {s t : set E} {x y : E}

/-- A version of the **Hahn-Banach theorem**: given disjoint convex sets `s`, `t` where `s` is open,
there is a continuous linear functional which separates them. -/
theorem geometric_hahn_banach_open (hs₁ : convex ℝ s) (hs₂ : is_open s) (ht : convex ℝ t)
  (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), (∀ a ∈ s, f a < u) ∧ ∀ b ∈ t, u ≤ f b :=
begin
  obtain rfl | ⟨a₀, ha₀⟩ := s.eq_empty_or_nonempty,
  { exact ⟨0, 0, by simp, λ b hb, le_rfl⟩ },
  obtain rfl | ⟨b₀, hb₀⟩ := t.eq_empty_or_nonempty,
  { exact ⟨0, 1, λ a ha, zero_lt_one, by simp⟩ },
  let x₀ := b₀ - a₀,
  let C := x₀ +ᵥ (s - t),
  have : (0:E) ∈ C := ⟨a₀ - b₀, sub_mem_sub ha₀ hb₀,
    by rw [vadd_eq_add, sub_add_sub_cancel', sub_self]⟩,
  have : convex ℝ C := (hs₁.sub ht).vadd _,
  have : x₀ ∉ C,
  { intro hx₀,
    rw ←add_zero x₀ at hx₀,
    exact disj.zero_not_mem_sub_set (vadd_mem_vadd_set_iff.1 hx₀) },
  obtain ⟨f, hf₁, hf₂⟩ := separate_convex_open_set ‹0 ∈ C› ‹_› (hs₂.sub_right.vadd _) ‹x₀ ∉ C›,
  have : f b₀ = f a₀ + 1 := by simp [←hf₁],
  have forall_le : ∀ (a ∈ s) (b ∈ t), f a ≤ f b,
  { intros a ha b hb,
    have := hf₂ (x₀ + (a - b)) (vadd_mem_vadd_set $ sub_mem_sub ha hb),
    simp only [f.map_add, f.map_sub, hf₁] at this,
    linarith },
  refine ⟨f, Inf (f '' t), image_subset_iff.1 (_ : f '' s ⊆ Iio (Inf (f '' t))), λ b hb, _⟩,
  { rw ←interior_Iic,
    refine interior_maximal (image_subset_iff.2 $ λ a ha, _) (f.is_open_map_of_ne_zero _ _ hs₂),
    { exact le_cInf (nonempty.image _ ⟨_, hb₀⟩) (ball_image_of_ball $ forall_le _ ha) },
    { rintro rfl,
      simpa using hf₁ } },
  { exact cInf_le ⟨f a₀, ball_image_of_ball $ forall_le _ ha₀⟩ (mem_image_of_mem _ hb) }
end

theorem geometric_hahn_banach_open_point (hs₁ : convex ℝ s) (hs₂ : is_open s) (disj : x ∉ s) :
  ∃ f : E →L[ℝ] ℝ, ∀ a ∈ s, f a < f x :=
let ⟨f, s, hs, hx⟩ := geometric_hahn_banach_open hs₁ hs₂ (convex_singleton x)
  (disjoint_singleton_right.2 disj)
  in ⟨f, λ a ha, lt_of_lt_of_le (hs a ha) (hx x (mem_singleton _))⟩

theorem geometric_hahn_banach_point_open (ht₁ : convex ℝ t) (ht₂ : is_open t) (disj : x ∉ t) :
  ∃ f : E →L[ℝ] ℝ, ∀ b ∈ t, f x < f b :=
let ⟨f, hf⟩ := geometric_hahn_banach_open_point ht₁ ht₂ disj in ⟨-f, by simpa⟩

theorem geometric_hahn_banach_open_open (hs₁ : convex ℝ s) (hs₂ : is_open s) (ht₁ : convex ℝ t)
  (ht₃ : is_open t) (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), (∀ a ∈ s, f a < u) ∧ ∀ b ∈ t, u < f b :=
begin
  obtain (rfl | ⟨a₀, ha₀⟩) := s.eq_empty_or_nonempty,
  { exact ⟨0, -1, by simp, λ b hb, by norm_num⟩ },
  obtain (rfl | ⟨b₀, hb₀⟩) := t.eq_empty_or_nonempty,
  { exact ⟨0, 1, λ a ha, by norm_num, by simp⟩ },
  obtain ⟨f, s, hf₁, hf₂⟩ := geometric_hahn_banach_open hs₁ hs₂ ht₁ disj,
  have hf : is_open_map f,
  { refine f.is_open_map_of_ne_zero _,
    rintro rfl,
    exact (hf₁ _ ha₀).not_le (hf₂ _ hb₀) },
  refine ⟨f, s, hf₁, image_subset_iff.1 (_ : f '' t ⊆ Ioi s)⟩,
  rw ←interior_Ici,
  refine interior_maximal (image_subset_iff.2 hf₂) (f.is_open_map_of_ne_zero _ _ ht₃),
  rintro rfl,
  exact (hf₁ _ ha₀).not_le (hf₂ _ hb₀),
end

/-- A version of the **Hahn-Banach theorem**: given disjoint convex sets `s`, `t` where `s` is
compact and `t` is closed, there is a continuous linear functional which strongly separates them. -/
theorem geometric_hahn_banach_compact_closed (hs₁ : convex ℝ s) (hs₂ : is_compact s)
  (ht₁ : convex ℝ t) (ht₂ : is_closed t) (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u v : ℝ), (∀ a ∈ s, f a < u) ∧ u < v ∧ ∀ b ∈ t, v < f b :=
begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { exact ⟨0, -2, -1, by simp, by norm_num, λ b hb, by norm_num⟩ },
  unfreezingI { obtain rfl | ht := t.eq_empty_or_nonempty },
  { exact ⟨0, 1, 2, λ a ha, by norm_num, by norm_num, by simp⟩ },
  obtain ⟨U, V, hU, hV, hU₁, hV₁, sU, tV, disj'⟩ := disj.exists_open_convexes hs₁ hs₂ ht₁ ht₂,
  obtain ⟨f, u, hf₁, hf₂⟩ := geometric_hahn_banach_open_open hU₁ hU hV₁ hV disj',
  obtain ⟨x, hx₁, hx₂⟩ := hs₂.exists_forall_ge hs f.continuous.continuous_on,
  have : f x < u := hf₁ x (sU hx₁),
  exact ⟨f, (f x + u)/2, u, λ a ha, by linarith [hx₂ a ha], by linarith, λ b hb, hf₂ b (tV hb)⟩,
end

/-- A version of the **Hahn-Banach theorem**: given disjoint convex sets `s`, `t` where `s` is
closed, and `t` is compact, there is a continuous linear functional which strongly separates them.
-/
theorem geometric_hahn_banach_closed_compact (hs₁ : convex ℝ s) (hs₂ : is_closed s)
  (ht₁ : convex ℝ t) (ht₂ : is_compact t) (disj : disjoint s t) :
  ∃ (f : E →L[ℝ] ℝ) (u v : ℝ), (∀ a ∈ s, f a < u) ∧ u < v ∧ ∀ b ∈ t, v < f b :=
let ⟨f, s, t, hs, st, ht⟩ := geometric_hahn_banach_compact_closed ht₁ ht₂ hs₁ hs₂ disj.symm in
⟨-f, -t, -s, by simpa using ht, by simpa using st, by simpa using hs⟩

theorem geometric_hahn_banach_point_closed (ht₁ : convex ℝ t) (ht₂ : is_closed t) (disj : x ∉ t) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), f x < u ∧ ∀ b ∈ t, u < f b :=
let ⟨f, u, v, ha, hst, hb⟩ := geometric_hahn_banach_compact_closed (convex_singleton x)
  is_compact_singleton ht₁ ht₂ (disjoint_singleton_left.2 disj)
  in ⟨f, v, hst.trans' $ ha x $ mem_singleton _, hb⟩

theorem geometric_hahn_banach_closed_point (hs₁ : convex ℝ s) (hs₂ : is_closed s) (disj : x ∉ s) :
  ∃ (f : E →L[ℝ] ℝ) (u : ℝ), (∀ a ∈ s, f a < u) ∧ u < f x :=
let ⟨f, s, t, ha, hst, hb⟩ := geometric_hahn_banach_closed_compact hs₁ hs₂ (convex_singleton x)
  is_compact_singleton (disjoint_singleton_right.2 disj)
  in ⟨f, s, ha, hst.trans $ hb x $ mem_singleton _⟩

/-- Special case of `normed_space.eq_iff_forall_dual_eq`. -/
theorem geometric_hahn_banach_point_point (hxy : x ≠ y) : ∃ (f : E →L[ℝ] ℝ), f x < f y :=
begin
  obtain ⟨f, s, t, hs, st, ht⟩ :=
    geometric_hahn_banach_compact_closed (convex_singleton x) is_compact_singleton
      (convex_singleton y) is_closed_singleton (disjoint_singleton.2 hxy),
  exact ⟨f, by linarith [hs x rfl, ht y rfl]⟩,
end

/-- A closed convex set is the intersection of the halfspaces containing it. -/
lemma Inter_halfspaces_eq (hs₁ : convex ℝ s) (hs₂ : is_closed s) :
  (⋂ (l : E →L[ℝ] ℝ), {x | ∃ y ∈ s, l x ≤ l y}) = s :=
begin
  rw set.Inter_set_of,
  refine set.subset.antisymm (λ x hx, _) (λ x hx l, ⟨x, hx, le_rfl⟩),
  by_contra,
  obtain ⟨l, s, hlA, hl⟩ := geometric_hahn_banach_closed_point hs₁ hs₂ h,
  obtain ⟨y, hy, hxy⟩ := hx l,
  exact ((hxy.trans_lt (hlA y hy)).trans hl).not_le le_rfl,
end


<|start_filename|>src/measure_theory/decomposition/lebesgue.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.measure.complex
import measure_theory.measure.sub
import measure_theory.decomposition.jordan
import measure_theory.measure.with_density_vector_measure
import measure_theory.function.ae_eq_of_integral

/-!
# Lebesgue decomposition

This file proves the Lebesgue decomposition theorem. The Lebesgue decomposition theorem states that,
given two σ-finite measures `μ` and `ν`, there exists a σ-finite measure `ξ` and a measurable
function `f` such that `μ = ξ + fν` and `ξ` is mutually singular with respect to `ν`.

The Lebesgue decomposition provides the Radon-Nikodym theorem readily.

## Main definitions

* `measure_theory.measure.have_lebesgue_decomposition` : A pair of measures `μ` and `ν` is said
  to `have_lebesgue_decomposition` if there exist a measure `ξ` and a measurable function `f`,
  such that `ξ` is mutually singular with respect to `ν` and `μ = ξ + ν.with_density f`
* `measure_theory.measure.singular_part` : If a pair of measures `have_lebesgue_decomposition`,
  then `singular_part` chooses the measure from `have_lebesgue_decomposition`, otherwise it
  returns the zero measure.
* `measure_theory.measure.rn_deriv`: If a pair of measures
  `have_lebesgue_decomposition`, then `rn_deriv` chooses the measurable function from
  `have_lebesgue_decomposition`, otherwise it returns the zero function.
* `measure_theory.signed_measure.have_lebesgue_decomposition` : A signed measure `s` and a
  measure `μ` is said to `have_lebesgue_decomposition` if both the positive part and negative
  part of `s` `have_lebesgue_decomposition` with respect to `μ`.
* `measure_theory.signed_measure.singular_part` : The singular part between a signed measure `s`
  and a measure `μ` is simply the singular part of the positive part of `s` with respect to `μ`
  minus the singular part of the negative part of `s` with respect to `μ`.
* `measure_theory.signed_measure.rn_deriv` : The Radon-Nikodym derivative of a signed
  measure `s` with respect to a measure `μ` is the Radon-Nikodym derivative of the positive part of
  `s` with respect to `μ` minus the Radon-Nikodym derivative of the negative part of `s` with
  respect to `μ`.

## Main results

* `measure_theory.measure.have_lebesgue_decomposition_of_sigma_finite` :
  the Lebesgue decomposition theorem.
* `measure_theory.measure.eq_singular_part` : Given measures `μ` and `ν`, if `s` is a measure
  mutually singular to `ν` and `f` is a measurable function such that `μ = s + fν`, then
  `s = μ.singular_part ν`.
* `measure_theory.measure.eq_rn_deriv` : Given measures `μ` and `ν`, if `s` is a
  measure mutually singular to `ν` and `f` is a measurable function such that `μ = s + fν`,
  then `f = μ.rn_deriv ν`.
* `measure_theory.signed_measure.singular_part_add_with_density_rn_deriv_eq` :
  the Lebesgue decomposition theorem between a signed measure and a σ-finite positive measure.

# Tags

Lebesgue decomposition theorem
-/

noncomputable theory
open_locale classical measure_theory nnreal ennreal
open set

variables {α β : Type*} {m : measurable_space α} {μ ν : measure_theory.measure α}
include m

namespace measure_theory

namespace measure

/-- A pair of measures `μ` and `ν` is said to `have_lebesgue_decomposition` if there exists a
measure `ξ` and a measurable function `f`, such that `ξ` is mutually singular with respect to
`ν` and `μ = ξ + ν.with_density f`. -/
class have_lebesgue_decomposition (μ ν : measure α) : Prop :=
(lebesgue_decomposition :
  ∃ (p : measure α × (α → ℝ≥0∞)), measurable p.2 ∧ p.1 ⊥ₘ ν ∧ μ = p.1 + ν.with_density p.2)

/-- If a pair of measures `have_lebesgue_decomposition`, then `singular_part` chooses the
measure from `have_lebesgue_decomposition`, otherwise it returns the zero measure. For sigma-finite
measures, `μ = μ.singular_part ν + ν.with_density (μ.rn_deriv ν)`. -/
@[irreducible]
def singular_part (μ ν : measure α) : measure α :=
if h : have_lebesgue_decomposition μ ν then (classical.some h.lebesgue_decomposition).1 else 0

/-- If a pair of measures `have_lebesgue_decomposition`, then `rn_deriv` chooses the
measurable function from `have_lebesgue_decomposition`, otherwise it returns the zero function.
For sigma-finite measures, `μ = μ.singular_part ν + ν.with_density (μ.rn_deriv ν)`.-/
@[irreducible]
def rn_deriv (μ ν : measure α) : α → ℝ≥0∞ :=
if h : have_lebesgue_decomposition μ ν then (classical.some h.lebesgue_decomposition).2 else 0

lemma have_lebesgue_decomposition_spec (μ ν : measure α)
  [h : have_lebesgue_decomposition μ ν] :
  measurable (μ.rn_deriv ν) ∧ (μ.singular_part ν) ⊥ₘ ν ∧
  μ = (μ.singular_part ν) + ν.with_density (μ.rn_deriv ν) :=
begin
  rw [singular_part, rn_deriv, dif_pos h, dif_pos h],
  exact classical.some_spec h.lebesgue_decomposition,
end

lemma have_lebesgue_decomposition_add (μ ν : measure α)
  [have_lebesgue_decomposition μ ν] :
  μ = (μ.singular_part ν) + ν.with_density (μ.rn_deriv ν) :=
(have_lebesgue_decomposition_spec μ ν).2.2

instance have_lebesgue_decomposition_smul
  (μ ν : measure α) [have_lebesgue_decomposition μ ν] (r : ℝ≥0) :
  (r • μ).have_lebesgue_decomposition ν :=
{ lebesgue_decomposition :=
  begin
    obtain ⟨hmeas, hsing, hadd⟩ := have_lebesgue_decomposition_spec μ ν,
    refine ⟨⟨r • μ.singular_part ν, r • μ.rn_deriv ν⟩, _, hsing.smul _, _⟩,
    { change measurable ((r : ℝ≥0∞) • _), -- cannot remove this line
      exact hmeas.const_smul _ },
    { change _ = (r : ℝ≥0∞) • _ + ν.with_density ((r : ℝ≥0∞) • _),
      rw [with_density_smul _ hmeas, ← smul_add, ← hadd],
      refl }
  end }

@[measurability]
lemma measurable_rn_deriv (μ ν : measure α) :
  measurable $ μ.rn_deriv ν :=
begin
  by_cases h : have_lebesgue_decomposition μ ν,
  { exactI (have_lebesgue_decomposition_spec μ ν).1 },
  { rw [rn_deriv, dif_neg h],
    exact measurable_zero }
end

lemma mutually_singular_singular_part (μ ν : measure α) :
  μ.singular_part ν ⊥ₘ ν :=
begin
  by_cases h : have_lebesgue_decomposition μ ν,
  { exactI (have_lebesgue_decomposition_spec μ ν).2.1 },
  { rw [singular_part, dif_neg h],
    exact mutually_singular.zero_left }
end

lemma singular_part_le (μ ν : measure α) : μ.singular_part ν ≤ μ :=
begin
  by_cases hl : have_lebesgue_decomposition μ ν,
  { casesI (have_lebesgue_decomposition_spec μ ν).2 with _ h,
    conv_rhs { rw h },
    exact measure.le_add_right le_rfl },
  { rw [singular_part, dif_neg hl],
    exact measure.zero_le μ }
end

lemma with_density_rn_deriv_le (μ ν : measure α) :
  ν.with_density (μ.rn_deriv ν) ≤ μ :=
begin
  by_cases hl : have_lebesgue_decomposition μ ν,
  { casesI (have_lebesgue_decomposition_spec μ ν).2 with _ h,
    conv_rhs { rw h },
    exact measure.le_add_left le_rfl },
  { rw [rn_deriv, dif_neg hl, with_density_zero],
    exact measure.zero_le μ }
end

instance [is_finite_measure μ] : is_finite_measure (μ.singular_part ν) :=
is_finite_measure_of_le μ $ singular_part_le μ ν

instance [sigma_finite μ] : sigma_finite (μ.singular_part ν) :=
sigma_finite_of_le μ $ singular_part_le μ ν

instance [topological_space α] [is_locally_finite_measure μ] :
  is_locally_finite_measure (μ.singular_part ν) :=
is_locally_finite_measure_of_le $ singular_part_le μ ν

instance [is_finite_measure μ] : is_finite_measure (ν.with_density $ μ.rn_deriv ν) :=
is_finite_measure_of_le μ $ with_density_rn_deriv_le μ ν

instance [sigma_finite μ] : sigma_finite (ν.with_density $ μ.rn_deriv ν) :=
sigma_finite_of_le μ $ with_density_rn_deriv_le μ ν

instance [topological_space α] [is_locally_finite_measure μ] :
  is_locally_finite_measure (ν.with_density $ μ.rn_deriv ν) :=
is_locally_finite_measure_of_le $ with_density_rn_deriv_le μ ν

lemma lintegral_rn_deriv_lt_top_of_measure_ne_top
  {μ : measure α} (ν : measure α) {s : set α} (hs : μ s ≠ ∞) :
  ∫⁻ x in s, μ.rn_deriv ν x ∂ν < ∞ :=
begin
  by_cases hl : have_lebesgue_decomposition μ ν,
  { haveI := hl,
    obtain ⟨-, -, hadd⟩ := have_lebesgue_decomposition_spec μ ν,
    suffices : ∫⁻ x in to_measurable μ s, μ.rn_deriv ν x ∂ν < ∞,
      from lt_of_le_of_lt (lintegral_mono_set (subset_to_measurable _ _)) this,
    rw [← with_density_apply _ (measurable_set_to_measurable _ _)],
    refine lt_of_le_of_lt
      (le_add_left le_rfl : _ ≤ μ.singular_part ν (to_measurable μ s) +
        ν.with_density (μ.rn_deriv ν) (to_measurable μ s)) _,
    rw [← measure.add_apply, ← hadd, measure_to_measurable],
    exact hs.lt_top },
  { erw [measure.rn_deriv, dif_neg hl, lintegral_zero],
    exact with_top.zero_lt_top },
end

lemma lintegral_rn_deriv_lt_top
  (μ ν : measure α) [is_finite_measure μ] :
  ∫⁻ x, μ.rn_deriv ν x ∂ν < ∞ :=
begin
  rw [← set_lintegral_univ],
  exact lintegral_rn_deriv_lt_top_of_measure_ne_top _ (measure_lt_top _ _).ne,
end

/-- The Radon-Nikodym derivative of a sigma-finite measure `μ` with respect to another
measure `ν` is `ν`-almost everywhere finite. -/
theorem rn_deriv_lt_top (μ ν : measure α) [sigma_finite μ] :
  ∀ᵐ x ∂ν, μ.rn_deriv ν x < ∞ :=
begin
  suffices : ∀ n, ∀ᵐ x ∂ν, x ∈ spanning_sets μ n → μ.rn_deriv ν x < ∞,
  { filter_upwards [ae_all_iff.2 this] with _ hx using hx _ (mem_spanning_sets_index _ _), },
  assume n,
  rw ← ae_restrict_iff' (measurable_spanning_sets _ _),
  apply ae_lt_top (measurable_rn_deriv _ _),
  refine (lintegral_rn_deriv_lt_top_of_measure_ne_top _ _).ne,
  exact (measure_spanning_sets_lt_top _ _).ne
end

/-- Given measures `μ` and `ν`, if `s` is a measure mutually singular to `ν` and `f` is a
measurable function such that `μ = s + fν`, then `s = μ.singular_part μ`.

This theorem provides the uniqueness of the `singular_part` in the Lebesgue decomposition theorem,
while `measure_theory.measure.eq_rn_deriv` provides the uniqueness of the
`rn_deriv`. -/
theorem eq_singular_part {s : measure α} {f : α → ℝ≥0∞} (hf : measurable f)
  (hs : s ⊥ₘ ν) (hadd : μ = s + ν.with_density f) :
  s = μ.singular_part ν :=
begin
  haveI : have_lebesgue_decomposition μ ν := ⟨⟨⟨s, f⟩, hf, hs, hadd⟩⟩,
  obtain ⟨hmeas, hsing, hadd'⟩ := have_lebesgue_decomposition_spec μ ν,
  obtain ⟨⟨S, hS₁, hS₂, hS₃⟩, ⟨T, hT₁, hT₂, hT₃⟩⟩ := ⟨hs, hsing⟩,
  rw hadd' at hadd,
  have hνinter : ν (S ∩ T)ᶜ = 0,
  { rw compl_inter,
    refine nonpos_iff_eq_zero.1 (le_trans (measure_union_le _ _) _),
    rw [hT₃, hS₃, add_zero],
    exact le_rfl },
  have heq : s.restrict (S ∩ T)ᶜ = (μ.singular_part ν).restrict (S ∩ T)ᶜ,
  { ext1 A hA,
    have hf : ν.with_density f (A ∩ (S ∩ T)ᶜ) = 0,
    { refine with_density_absolutely_continuous ν _ _,
      rw ← nonpos_iff_eq_zero,
      exact hνinter ▸ measure_mono (inter_subset_right _ _) },
    have hrn : ν.with_density (μ.rn_deriv ν) (A ∩ (S ∩ T)ᶜ) = 0,
    { refine with_density_absolutely_continuous ν _ _,
      rw ← nonpos_iff_eq_zero,
      exact hνinter ▸ measure_mono (inter_subset_right _ _) },
    rw [restrict_apply hA, restrict_apply hA, ← add_zero (s (A ∩ (S ∩ T)ᶜ)), ← hf,
        ← add_apply, ← hadd, add_apply, hrn, add_zero] },
  have heq' : ∀ A : set α, measurable_set A → s A = s.restrict (S ∩ T)ᶜ A,
  { intros A hA,
    have hsinter : s (A ∩ (S ∩ T)) = 0,
    { rw ← nonpos_iff_eq_zero,
      exact hS₂ ▸ measure_mono ((inter_subset_right _ _).trans (inter_subset_left _ _)) },
    rw [restrict_apply hA, ← diff_eq, ae_disjoint.measure_diff_left hsinter] },
  ext1 A hA,
  have hμinter : μ.singular_part ν (A ∩ (S ∩ T)) = 0,
  { rw ← nonpos_iff_eq_zero,
    exact hT₂ ▸ measure_mono ((inter_subset_right _ _).trans (inter_subset_right _ _)) },
  rw [heq' A hA, heq, restrict_apply hA, ← diff_eq, ae_disjoint.measure_diff_left hμinter]
end

lemma singular_part_zero (ν : measure α) : (0 : measure α).singular_part ν = 0 :=
begin
  refine (eq_singular_part measurable_zero mutually_singular.zero_left _).symm,
  rw [zero_add, with_density_zero],
end

lemma singular_part_smul (μ ν : measure α) (r : ℝ≥0) :
  (r • μ).singular_part ν = r • (μ.singular_part ν) :=
begin
  by_cases hr : r = 0,
  { rw [hr, zero_smul, zero_smul, singular_part_zero] },
  by_cases hl : have_lebesgue_decomposition μ ν,
  { haveI := hl,
    refine (eq_singular_part ((measurable_rn_deriv μ ν).const_smul (r : ℝ≥0∞))
      (mutually_singular.smul r (have_lebesgue_decomposition_spec _ _).2.1) _).symm,
    rw [with_density_smul _ (measurable_rn_deriv _ _), ← smul_add,
      ← have_lebesgue_decomposition_add μ ν, ennreal.smul_def] },
  { rw [singular_part, singular_part, dif_neg hl, dif_neg, smul_zero],
    refine λ hl', hl _,
    rw ← inv_smul_smul₀ hr μ,
    exact @measure.have_lebesgue_decomposition_smul _ _ _ _ hl' _ }
end

lemma singular_part_add (μ₁ μ₂ ν : measure α)
  [have_lebesgue_decomposition μ₁ ν] [have_lebesgue_decomposition μ₂ ν] :
  (μ₁ + μ₂).singular_part ν = μ₁.singular_part ν + μ₂.singular_part ν :=
begin
  refine (eq_singular_part
    ((measurable_rn_deriv μ₁ ν).add (measurable_rn_deriv μ₂ ν))
    ((have_lebesgue_decomposition_spec _ _).2.1.add_left (have_lebesgue_decomposition_spec _ _).2.1)
    _).symm,
  erw with_density_add_left (measurable_rn_deriv μ₁ ν),
  conv_rhs { rw [add_assoc, add_comm (μ₂.singular_part ν), ← add_assoc, ← add_assoc] },
  rw [← have_lebesgue_decomposition_add μ₁ ν, add_assoc,
      add_comm (ν.with_density (μ₂.rn_deriv ν)),
      ← have_lebesgue_decomposition_add μ₂ ν]
end

lemma singular_part_with_density (ν : measure α) {f : α → ℝ≥0∞} (hf : measurable f) :
  (ν.with_density f).singular_part ν = 0 :=
begin
  have : ν.with_density f = 0 + ν.with_density f, by rw zero_add,
  exact (eq_singular_part hf mutually_singular.zero_left this).symm,
end

/-- Given measures `μ` and `ν`, if `s` is a measure mutually singular to `ν` and `f` is a
measurable function such that `μ = s + fν`, then `f = μ.rn_deriv ν`.

This theorem provides the uniqueness of the `rn_deriv` in the Lebesgue decomposition
theorem, while `measure_theory.measure.eq_singular_part` provides the uniqueness of the
`singular_part`. Here, the uniqueness is given in terms of the measures, while the uniqueness in
terms of the functions is given in `eq_rn_deriv`. -/
theorem eq_with_density_rn_deriv {s : measure α} {f : α → ℝ≥0∞} (hf : measurable f)
  (hs : s ⊥ₘ ν) (hadd : μ = s + ν.with_density f) :
  ν.with_density f = ν.with_density (μ.rn_deriv ν) :=
begin
  haveI : have_lebesgue_decomposition μ ν := ⟨⟨⟨s, f⟩, hf, hs, hadd⟩⟩,
  obtain ⟨hmeas, hsing, hadd'⟩ := have_lebesgue_decomposition_spec μ ν,
  obtain ⟨⟨S, hS₁, hS₂, hS₃⟩, ⟨T, hT₁, hT₂, hT₃⟩⟩ := ⟨hs, hsing⟩,
  rw hadd' at hadd,
  have hνinter : ν (S ∩ T)ᶜ = 0,
  { rw compl_inter,
    refine nonpos_iff_eq_zero.1 (le_trans (measure_union_le _ _) _),
    rw [hT₃, hS₃, add_zero],
    exact le_rfl },
  have heq : (ν.with_density f).restrict (S ∩ T) =
              (ν.with_density (μ.rn_deriv ν)).restrict (S ∩ T),
  { ext1 A hA,
    have hs : s (A ∩ (S ∩ T)) = 0,
    { rw ← nonpos_iff_eq_zero,
      exact hS₂ ▸ measure_mono ((inter_subset_right _ _).trans (inter_subset_left _ _)) },
    have hsing : μ.singular_part ν (A ∩ (S ∩ T)) = 0,
    { rw ← nonpos_iff_eq_zero,
      exact hT₂ ▸ measure_mono
        ((inter_subset_right _ _).trans (inter_subset_right _ _)) },
    rw [restrict_apply hA, restrict_apply hA, ← add_zero (ν.with_density f (A ∩ (S ∩ T))),
        ← hs, ← add_apply, add_comm, ← hadd, add_apply, hsing, zero_add] },
  have heq' : ∀ A : set α, measurable_set A →
    ν.with_density f A = (ν.with_density f).restrict (S ∩ T) A,
  { intros A hA,
    have hνfinter : ν.with_density f (A ∩ (S ∩ T)ᶜ) = 0,
    { rw ← nonpos_iff_eq_zero,
      exact with_density_absolutely_continuous ν f hνinter ▸
        measure_mono (inter_subset_right _ _) },
    rw [restrict_apply hA, ← add_zero (ν.with_density f (A ∩ (S ∩ T))), ← hνfinter,
        ← diff_eq, measure_inter_add_diff _ (hS₁.inter hT₁)] },
  ext1 A hA,
  have hνrn : ν.with_density (μ.rn_deriv ν) (A ∩ (S ∩ T)ᶜ) = 0,
  { rw ← nonpos_iff_eq_zero,
    exact with_density_absolutely_continuous ν (μ.rn_deriv ν) hνinter ▸
      measure_mono (inter_subset_right _ _) },
  rw [heq' A hA, heq, ← add_zero ((ν.with_density (μ.rn_deriv ν)).restrict (S ∩ T) A),
      ← hνrn, restrict_apply hA, ← diff_eq, measure_inter_add_diff _ (hS₁.inter hT₁)]
end

/-- Given measures `μ` and `ν`, if `s` is a measure mutually singular to `ν` and `f` is a
measurable function such that `μ = s + fν`, then `f = μ.rn_deriv ν`.

This theorem provides the uniqueness of the `rn_deriv` in the Lebesgue decomposition
theorem, while `measure_theory.measure.eq_singular_part` provides the uniqueness of the
`singular_part`. Here, the uniqueness is given in terms of the functions, while the uniqueness in
terms of the functions is given in `eq_with_density_rn_deriv`. -/
theorem eq_rn_deriv [sigma_finite ν] {s : measure α} {f : α → ℝ≥0∞} (hf : measurable f)
  (hs : s ⊥ₘ ν) (hadd : μ = s + ν.with_density f) :
  f =ᵐ[ν] μ.rn_deriv ν :=
begin
  refine ae_eq_of_forall_set_lintegral_eq_of_sigma_finite hf (measurable_rn_deriv μ ν) _,
  assume a ha h'a,
  calc ∫⁻ (x : α) in a, f x ∂ν = ν.with_density f a : (with_density_apply f ha).symm
  ... = ν.with_density (μ.rn_deriv ν) a : by rw eq_with_density_rn_deriv hf hs hadd
  ... = ∫⁻ (x : α) in a, μ.rn_deriv ν x ∂ν : with_density_apply _ ha
end

/-- The Radon-Nikodym derivative of `f ν` with respect to `ν` is `f`. -/
theorem rn_deriv_with_density (ν : measure α) [sigma_finite ν] {f : α → ℝ≥0∞} (hf : measurable f) :
  (ν.with_density f).rn_deriv ν =ᵐ[ν] f :=
begin
  have : ν.with_density f = 0 + ν.with_density f, by rw zero_add,
  exact (eq_rn_deriv hf mutually_singular.zero_left this).symm,
end

/-- The Radon-Nikodym derivative of the restriction of a measure to a measurable set is the
indicator function of this set. -/
theorem rn_deriv_restrict (ν : measure α) [sigma_finite ν] {s : set α} (hs : measurable_set s) :
  (ν.restrict s).rn_deriv ν =ᵐ[ν] s.indicator 1 :=
begin
  rw ← with_density_indicator_one hs,
  exact rn_deriv_with_density _ (measurable_one.indicator hs)
end

open vector_measure signed_measure

/-- If two finite measures `μ` and `ν` are not mutually singular, there exists some `ε > 0` and
a measurable set `E`, such that `ν(E) > 0` and `E` is positive with respect to `μ - εν`.

This lemma is useful for the Lebesgue decomposition theorem. -/
lemma exists_positive_of_not_mutually_singular
  (μ ν : measure α) [is_finite_measure μ] [is_finite_measure ν] (h : ¬ μ ⊥ₘ ν) :
  ∃ ε : ℝ≥0, 0 < ε ∧ ∃ E : set α, measurable_set E ∧ 0 < ν E ∧
  0 ≤[E] μ.to_signed_measure - (ε • ν).to_signed_measure :=
begin
  -- for all `n : ℕ`, obtain the Hahn decomposition for `μ - (1 / n) ν`
  have : ∀ n : ℕ, ∃ i : set α, measurable_set i ∧
    0 ≤[i] (μ.to_signed_measure - ((1 / (n + 1) : ℝ≥0) • ν).to_signed_measure) ∧
    (μ.to_signed_measure - ((1 / (n + 1) : ℝ≥0) • ν).to_signed_measure) ≤[iᶜ] 0,
  { intro, exact exists_compl_positive_negative _ },
  choose f hf₁ hf₂ hf₃ using this,
  -- set `A` to be the intersection of all the negative parts of obtained Hahn decompositions
  -- and we show that `μ A = 0`
  set A := ⋂ n, (f n)ᶜ with hA₁,
  have hAmeas : measurable_set A,
  { exact measurable_set.Inter (λ n, (hf₁ n).compl) },
  have hA₂ : ∀ n : ℕ, (μ.to_signed_measure - ((1 / (n + 1) : ℝ≥0) • ν).to_signed_measure) ≤[A] 0,
  { intro n, exact restrict_le_restrict_subset _ _ (hf₁ n).compl (hf₃ n) (Inter_subset _ _) },
  have hA₃ : ∀ n : ℕ, μ A ≤ (1 / (n + 1) : ℝ≥0) * ν A,
  { intro n,
    have := nonpos_of_restrict_le_zero _ (hA₂ n),
    rwa [to_signed_measure_sub_apply hAmeas, sub_nonpos, ennreal.to_real_le_to_real] at this,
    exacts [ne_of_lt (measure_lt_top _ _), ne_of_lt (measure_lt_top _ _)] },
  have hμ : μ A = 0,
  { lift μ A to ℝ≥0 using ne_of_lt (measure_lt_top _ _) with μA,
    lift ν A to ℝ≥0 using ne_of_lt (measure_lt_top _ _) with νA,
    rw ennreal.coe_eq_zero,
    by_cases hb : 0 < νA,
    { suffices : ∀ b, 0 < b → μA ≤ b,
      { by_contra,
        have h' := this (μA / 2) (nnreal.half_pos (zero_lt_iff.2 h)),
        rw ← @not_not (μA ≤ μA / 2) at h',
        exact h' (not_le.2 (nnreal.half_lt_self h)) },
      intros c hc,
      have : ∃ n : ℕ, 1 / (n + 1 : ℝ) < c * νA⁻¹, refine exists_nat_one_div_lt _,
      { refine mul_pos hc _,
        rw _root_.inv_pos, exact hb },
      rcases this with ⟨n, hn⟩,
      have hb₁ : (0 : ℝ) < νA⁻¹, { rw _root_.inv_pos, exact hb },
      have h' : 1 / (↑n + 1) * νA < c,
      { rw [← nnreal.coe_lt_coe, ← mul_lt_mul_right hb₁, nnreal.coe_mul, mul_assoc,
            ← nnreal.coe_inv, ← nnreal.coe_mul, _root_.mul_inv_cancel, ← nnreal.coe_mul,
            mul_one, nnreal.coe_inv],
        { convert hn, simp },
        { exact ne.symm (ne_of_lt hb) } },
      refine le_trans _ (le_of_lt h'),
      rw [← ennreal.coe_le_coe, ennreal.coe_mul],
      exact hA₃ n },
    { rw [not_lt, le_zero_iff] at hb,
      specialize hA₃ 0,
      simp [hb, le_zero_iff] at hA₃,
      assumption } },
  -- since `μ` and `ν` are not mutually singular, `μ A = 0` implies `ν Aᶜ > 0`
  rw mutually_singular at h, push_neg at h,
  have := h _ hAmeas hμ,
  simp_rw [hA₁, compl_Inter, compl_compl] at this,
  -- as `Aᶜ = ⋃ n, f n`, `ν Aᶜ > 0` implies there exists some `n` such that `ν (f n) > 0`
  obtain ⟨n, hn⟩ := exists_measure_pos_of_not_measure_Union_null this,
  -- thus, choosing `f n` as the set `E` suffices
  exact ⟨1 / (n + 1), by simp, f n, hf₁ n, hn, hf₂ n⟩,
end

namespace lebesgue_decomposition

/-- Given two measures `μ` and `ν`, `measurable_le μ ν` is the set of measurable
functions `f`, such that, for all measurable sets `A`, `∫⁻ x in A, f x ∂μ ≤ ν A`.

This is useful for the Lebesgue decomposition theorem. -/
def measurable_le (μ ν : measure α) : set (α → ℝ≥0∞) :=
{ f | measurable f ∧ ∀ (A : set α) (hA : measurable_set A), ∫⁻ x in A, f x ∂μ ≤ ν A }

lemma zero_mem_measurable_le : (0 : α → ℝ≥0∞) ∈ measurable_le μ ν :=
⟨measurable_zero, λ A hA, by simp⟩

lemma sup_mem_measurable_le {f g : α → ℝ≥0∞}
  (hf : f ∈ measurable_le μ ν) (hg : g ∈ measurable_le μ ν) :
  (λ a, f a ⊔ g a) ∈ measurable_le μ ν :=
begin
  simp_rw ennreal.sup_eq_max,
  refine ⟨measurable.max hf.1 hg.1, λ A hA, _⟩,
  have h₁ := hA.inter (measurable_set_le hf.1 hg.1),
  have h₂ := hA.inter (measurable_set_lt hg.1 hf.1),
  rw [set_lintegral_max hf.1 hg.1],
  refine (add_le_add (hg.2 _ h₁) (hf.2 _ h₂)).trans_eq _,
  { simp only [← not_le, ← compl_set_of, ← diff_eq],
    exact measure_inter_add_diff _ (measurable_set_le hf.1 hg.1) }
end

lemma supr_succ_eq_sup {α} (f : ℕ → α → ℝ≥0∞) (m : ℕ) (a : α) :
  (⨆ (k : ℕ) (hk : k ≤ m + 1), f k a) = f m.succ a ⊔ ⨆ (k : ℕ) (hk : k ≤ m), f k a :=
begin
  ext x,
  simp only [option.mem_def, ennreal.some_eq_coe],
  split; intro h; rw ← h, symmetry,
  all_goals
  { set c := (⨆ (k : ℕ) (hk : k ≤ m + 1), f k a) with hc,
    set d := (f m.succ a ⊔ ⨆ (k : ℕ) (hk : k ≤ m), f k a) with hd,
    rw [@le_antisymm_iff ℝ≥0∞, hc, hd], -- Specifying the type is weirdly necessary
    refine ⟨_, _⟩,
    { refine supr₂_le (λ n hn, _),
      rcases nat.of_le_succ hn with (h | h),
      { exact le_sup_of_le_right (le_supr₂ n h) },
      { exact h ▸ le_sup_left } },
    { refine sup_le _ (bsupr_mono $ λ n hn, hn.trans m.le_succ),
      convert @le_supr₂ _ _ (λ i, i ≤ m + 1) _ _ m.succ le_rfl,
      refl } }
end

lemma supr_mem_measurable_le
  (f : ℕ → α → ℝ≥0∞) (hf : ∀ n, f n ∈ measurable_le μ ν) (n : ℕ) :
  (λ x, ⨆ k (hk : k ≤ n), f k x) ∈ measurable_le μ ν :=
begin
  induction n with m hm,
  { refine ⟨_, _⟩,
    { simp [(hf 0).1] },
    { intros A hA, simp [(hf 0).2 A hA] } },
  { have : (λ (a : α), ⨆ (k : ℕ) (hk : k ≤ m + 1), f k a) =
      (λ a, f m.succ a ⊔ ⨆ (k : ℕ) (hk : k ≤ m), f k a),
    { exact funext (λ _, supr_succ_eq_sup _ _ _) },
    refine ⟨measurable_supr (λ n, measurable.supr_Prop _ (hf n).1), λ A hA, _⟩,
    rw this, exact (sup_mem_measurable_le (hf m.succ) hm).2 A hA }
end

lemma supr_mem_measurable_le'
  (f : ℕ → α → ℝ≥0∞) (hf : ∀ n, f n ∈ measurable_le μ ν) (n : ℕ) :
  (⨆ k (hk : k ≤ n), f k) ∈ measurable_le μ ν :=
begin
  convert supr_mem_measurable_le f hf n,
  ext, simp
end

section supr_lemmas --TODO: these statements should be moved elsewhere
omit m

lemma supr_monotone {α : Type*} (f : ℕ → α → ℝ≥0∞) :
  monotone (λ n x, ⨆ k (hk : k ≤ n), f k x) :=
λ n m hnm x, bsupr_mono $ λ i, ge_trans hnm

lemma supr_monotone' {α : Type*} (f : ℕ → α → ℝ≥0∞) (x : α) :
  monotone (λ n, ⨆ k (hk : k ≤ n), f k x) :=
λ n m hnm, supr_monotone f hnm x

lemma supr_le_le {α : Type*} (f : ℕ → α → ℝ≥0∞) (n k : ℕ) (hk : k ≤ n) :
  f k ≤ λ x, ⨆ k (hk : k ≤ n), f k x :=
λ x, le_supr₂ k hk

end supr_lemmas

/-- `measurable_le_eval μ ν` is the set of `∫⁻ x, f x ∂μ` for all `f ∈ measurable_le μ ν`. -/
def measurable_le_eval (μ ν : measure α) : set ℝ≥0∞ :=
(λ f : α → ℝ≥0∞, ∫⁻ x, f x ∂μ) '' measurable_le μ ν

end lebesgue_decomposition

open lebesgue_decomposition

/-- Any pair of finite measures `μ` and `ν`, `have_lebesgue_decomposition`. That is to say,
there exist a measure `ξ` and a measurable function `f`, such that `ξ` is mutually singular
with respect to `ν` and `μ = ξ + ν.with_density f`.

This is not an instance since this is also shown for the more general σ-finite measures with
`measure_theory.measure.have_lebesgue_decomposition_of_sigma_finite`. -/
theorem have_lebesgue_decomposition_of_finite_measure [is_finite_measure μ] [is_finite_measure ν] :
  have_lebesgue_decomposition μ ν :=
⟨begin
  have h := @exists_seq_tendsto_Sup _ _ _ _ _ (measurable_le_eval ν μ)
    ⟨0, 0, zero_mem_measurable_le, by simp⟩ (order_top.bdd_above _),
  choose g hmono hg₂ f hf₁ hf₂ using h,
  -- we set `ξ` to be the supremum of an increasing sequence of functions obtained from above
  set ξ := ⨆ n k (hk : k ≤ n), f k with hξ,
  -- we see that `ξ` has the largest integral among all functions in `measurable_le`
  have hξ₁ : Sup (measurable_le_eval ν μ) = ∫⁻ a, ξ a ∂ν,
  { have := @lintegral_tendsto_of_tendsto_of_monotone _ _ ν
      (λ n, ⨆ k (hk : k ≤ n), f k) (⨆ n k (hk : k ≤ n), f k) _ _ _,
    { refine tendsto_nhds_unique _ this,
      refine tendsto_of_tendsto_of_tendsto_of_le_of_le hg₂ tendsto_const_nhds _ _,
      { intro n, rw ← hf₂ n,
        apply lintegral_mono,
        simp only [supr_apply, supr_le_le f n n le_rfl] },
      { intro n,
        exact le_Sup ⟨⨆ (k : ℕ) (hk : k ≤ n), f k, supr_mem_measurable_le' _ hf₁ _, rfl⟩ } },
    { intro n,
      refine measurable.ae_measurable _,
      convert (supr_mem_measurable_le _ hf₁ n).1,
      ext, simp },
    { refine filter.eventually_of_forall (λ a, _),
      simp [supr_monotone' f _] },
    { refine filter.eventually_of_forall (λ a, _),
      simp [tendsto_at_top_supr (supr_monotone' f a)] } },
  have hξm : measurable ξ,
  { convert measurable_supr (λ n, (supr_mem_measurable_le _ hf₁ n).1),
    ext, simp [hξ] },
  -- `ξ` is the `f` in the theorem statement and we set `μ₁` to be `μ - ν.with_density ξ`
  -- since we need `μ₁ + ν.with_density ξ = μ`
  set μ₁ := μ - ν.with_density ξ with hμ₁,
  have hle : ν.with_density ξ ≤ μ,
  { intros B hB,
    rw [hξ, with_density_apply _ hB],
    simp_rw [supr_apply],
    rw lintegral_supr (λ i, (supr_mem_measurable_le _ hf₁ i).1) (supr_monotone _),
    exact supr_le (λ i, (supr_mem_measurable_le _ hf₁ i).2 B hB) },
  haveI : is_finite_measure (ν.with_density ξ),
  { refine is_finite_measure_with_density _,
    have hle' := hle univ measurable_set.univ,
    rw [with_density_apply _ measurable_set.univ, measure.restrict_univ] at hle',
    exact ne_top_of_le_ne_top (measure_ne_top _ _) hle' },
  refine ⟨⟨μ₁, ξ⟩, hξm, _, _⟩,
  { by_contra,
  -- if they are not mutually singular, then from `exists_positive_of_not_mutually_singular`,
  -- there exists some `ε > 0` and a measurable set `E`, such that `μ(E) > 0` and `E` is
  -- positive with respect to `ν - εμ`
    obtain ⟨ε, hε₁, E, hE₁, hE₂, hE₃⟩ := exists_positive_of_not_mutually_singular μ₁ ν h,
    simp_rw hμ₁ at hE₃,
    have hξle : ∀ A, measurable_set A → ∫⁻ a in A, ξ a ∂ν ≤ μ A,
    { intros A hA, rw hξ,
      simp_rw [supr_apply],
      rw lintegral_supr (λ n, (supr_mem_measurable_le _ hf₁ n).1) (supr_monotone _),
      exact supr_le (λ n, (supr_mem_measurable_le _ hf₁ n).2 A hA) },
  -- since `E` is positive, we have `∫⁻ a in A ∩ E, ε + ξ a ∂ν ≤ μ (A ∩ E)` for all `A`
    have hε₂ : ∀ A : set α, measurable_set A → ∫⁻ a in A ∩ E, ε + ξ a ∂ν ≤ μ (A ∩ E),
    { intros A hA,
      have := subset_le_of_restrict_le_restrict _ _ hE₁ hE₃ (inter_subset_right A E),
      rwa [zero_apply, to_signed_measure_sub_apply (hA.inter hE₁),
            measure.sub_apply (hA.inter hE₁) hle,
            ennreal.to_real_sub_of_le _ (ne_of_lt (measure_lt_top _ _)), sub_nonneg,
            le_sub_iff_add_le, ← ennreal.to_real_add, ennreal.to_real_le_to_real,
            measure.coe_smul, pi.smul_apply, with_density_apply _ (hA.inter hE₁),
            show ε • ν (A ∩ E) = (ε : ℝ≥0∞) * ν (A ∩ E), by refl,
            ← set_lintegral_const, ← lintegral_add_left measurable_const] at this,
      { rw [ne.def, ennreal.add_eq_top, not_or_distrib],
        exact ⟨ne_of_lt (measure_lt_top _ _), ne_of_lt (measure_lt_top _ _)⟩ },
      { exact ne_of_lt (measure_lt_top _ _) },
      { exact ne_of_lt (measure_lt_top _ _) },
      { exact ne_of_lt (measure_lt_top _ _) },
      { rw with_density_apply _ (hA.inter hE₁),
        exact hξle (A ∩ E) (hA.inter hE₁) },
      { apply_instance } },
  -- from this, we can show `ξ + ε * E.indicator` is a function in `measurable_le` with
  -- integral greater than `ξ`
    have hξε : ξ + E.indicator (λ _, ε) ∈ measurable_le ν μ,
    { refine ⟨measurable.add hξm (measurable.indicator measurable_const hE₁), λ A hA, _⟩,
      have : ∫⁻ a in A, (ξ + E.indicator (λ _, ε)) a ∂ν =
            ∫⁻ a in A ∩ E, ε + ξ a ∂ν + ∫⁻ a in A \ E, ξ a ∂ν,
      { simp only [lintegral_add_left measurable_const, lintegral_add_left hξm,
          set_lintegral_const, add_assoc, lintegral_inter_add_diff _ _ hE₁, pi.add_apply,
          lintegral_indicator _ hE₁, restrict_apply hE₁],
        rw [inter_comm, add_comm] },
      rw [this, ← measure_inter_add_diff A hE₁],
      exact add_le_add (hε₂ A hA) (hξle (A \ E) (hA.diff hE₁)) },
      have : ∫⁻ a, ξ a + E.indicator (λ _, ε) a ∂ν ≤ Sup (measurable_le_eval ν μ) :=
        le_Sup ⟨ξ + E.indicator (λ _, ε), hξε, rfl⟩,
  -- but this contradicts the maximality of `∫⁻ x, ξ x ∂ν`
      refine not_lt.2 this _,
      rw [hξ₁, lintegral_add_left hξm, lintegral_indicator _ hE₁, set_lintegral_const],
      refine ennreal.lt_add_right _ (ennreal.mul_pos_iff.2 ⟨ennreal.coe_pos.2 hε₁, hE₂⟩).ne',
      have := measure_ne_top (ν.with_density ξ) univ,
      rwa [with_density_apply _ measurable_set.univ, measure.restrict_univ] at this },
  -- since `ν.with_density ξ ≤ μ`, it is clear that `μ = μ₁ + ν.with_density ξ`
  { rw hμ₁, ext1 A hA,
    rw [measure.coe_add, pi.add_apply, measure.sub_apply hA hle,
        add_comm, add_tsub_cancel_of_le (hle A hA)] },
end⟩

local attribute [instance] have_lebesgue_decomposition_of_finite_measure

instance {S : μ.finite_spanning_sets_in {s : set α | measurable_set s}} (n : ℕ) :
  is_finite_measure (μ.restrict $ S.set n) :=
⟨by { rw [restrict_apply measurable_set.univ, univ_inter], exact S.finite _ }⟩

/-- **The Lebesgue decomposition theorem**: Any pair of σ-finite measures `μ` and `ν`
`have_lebesgue_decomposition`. That is to say, there exist a measure `ξ` and a measurable function
`f`, such that `ξ` is mutually singular with respect to `ν` and `μ = ξ + ν.with_density f` -/
@[priority 100] -- see Note [lower instance priority]
instance have_lebesgue_decomposition_of_sigma_finite
  (μ ν : measure α) [sigma_finite μ] [sigma_finite ν] :
  have_lebesgue_decomposition μ ν :=
⟨begin
  -- Since `μ` and `ν` are both σ-finite, there exists a sequence of pairwise disjoint spanning
  -- sets which are finite with respect to both `μ` and `ν`
  obtain ⟨S, T, h₁, h₂⟩ := exists_eq_disjoint_finite_spanning_sets_in μ ν,
  have h₃ : pairwise (disjoint on T.set) := h₁ ▸ h₂,
  -- We define `μn` and `νn` as sequences of measures such that `μn n = μ ∩ S n` and
  -- `νn n = ν ∩ S n` where `S` is the aforementioned finite spanning set sequence.
  -- Since `S` is spanning, it is clear that `sum μn = μ` and `sum νn = ν`
  set μn : ℕ → measure α := λ n, μ.restrict (S.set n) with hμn,
  have hμ : μ = sum μn,
    { rw [hμn, ← restrict_Union h₂ S.set_mem, S.spanning, restrict_univ] },
  set νn : ℕ → measure α := λ n, ν.restrict (T.set n) with hνn,
  have hν : ν = sum νn,
    { rw [hνn, ← restrict_Union h₃ T.set_mem, T.spanning, restrict_univ] },
  -- As `S` is finite with respect to both `μ` and `ν`, it is clear that `μn n` and `νn n` are
  -- finite measures for all `n : ℕ`. Thus, we may apply the finite Lebesgue decomposition theorem
  -- to `μn n` and `νn n`. We define `ξ` as the sum of the singular part of the Lebesgue
  -- decompositions of `μn n` and `νn n`, and `f` as the sum of the Radon-Nikodym derviatives of
  -- `μn n` and `νn n` restricted on `S n`
  set ξ := sum (λ n, singular_part (μn n) (νn n)) with hξ,
  set f := ∑' n, (S.set n).indicator (rn_deriv (μn n) (νn n)) with hf,
  -- I claim `ξ` and `f` form a Lebesgue decomposition of `μ` and `ν`
  refine ⟨⟨ξ, f⟩, _, _, _⟩,
  { exact measurable.ennreal_tsum' (λ n, measurable.indicator
      (measurable_rn_deriv (μn n) (νn n)) (S.set_mem n)) },
  -- We show that `ξ` is mutually singular with respect to `ν`
  { choose A hA₁ hA₂ hA₃ using λ n, mutually_singular_singular_part (μn n) (νn n),
    simp only [hξ],
  -- We use the set `B := ⋃ j, (S.set j) ∩ A j` where `A n` is the set provided as
  -- `singular_part (μn n) (νn n) ⊥ₘ νn n`
    refine ⟨⋃ j, (S.set j) ∩ A j,
      measurable_set.Union (λ n, (S.set_mem n).inter (hA₁ n)), _, _⟩,
  -- `ξ B = 0` since `ξ B = ∑ i j, singular_part (μn j) (νn j) (S.set i ∩ A i)`
  --                     `= ∑ i, singular_part (μn i) (νn i) (S.set i ∩ A i)`
  --                     `≤ ∑ i, singular_part (μn i) (νn i) (A i) = 0`
  -- where the second equality follows as `singular_part (μn j) (νn j) (S.set i ∩ A i)` vanishes
  -- for all `i ≠ j`
    { rw [measure_Union],
      { have : ∀ i, (sum (λ n, (μn n).singular_part (νn n))) (S.set i ∩ A i) =
          (μn i).singular_part (νn i) (S.set i ∩ A i),
        { intro i, rw [sum_apply _ ((S.set_mem i).inter (hA₁ i)), tsum_eq_single i],
          { intros j hij,
            rw [hμn, ← nonpos_iff_eq_zero],
            refine le_trans ((singular_part_le _ _) _ ((S.set_mem i).inter (hA₁ i))) (le_of_eq _),
            rw [restrict_apply ((S.set_mem i).inter (hA₁ i)), inter_comm, ← inter_assoc],
            have : disjoint (S.set j) (S.set i) := h₂ j i hij,
            rw disjoint_iff_inter_eq_empty at this,
            rw [this, empty_inter, measure_empty] },
          { apply_instance } },
        simp_rw [this, tsum_eq_zero_iff ennreal.summable],
        intro n, exact measure_mono_null (inter_subset_right _ _) (hA₂ n) },
      { exact h₂.mono (λ i j, disjoint.mono inf_le_left inf_le_left) },
      { exact λ n, (S.set_mem n).inter (hA₁ n) } },
  -- We will now show `ν Bᶜ = 0`. This follows since `Bᶜ = ⋃ n, S.set n ∩ (A n)ᶜ` and thus,
  -- `ν Bᶜ = ∑ i, ν (S.set i ∩ (A i)ᶜ) = ∑ i, (νn i) (A i)ᶜ = 0`
    { have hcompl : is_compl (⋃ n, (S.set n ∩ A n)) (⋃ n, S.set n ∩ (A n)ᶜ),
      { split,
        { rintro x ⟨hx₁, hx₂⟩, rw mem_Union at hx₁ hx₂,
          obtain ⟨⟨i, hi₁, hi₂⟩, ⟨j, hj₁, hj₂⟩⟩ := ⟨hx₁, hx₂⟩,
          have : i = j,
          { by_contra hij, exact h₂ i j hij ⟨hi₁, hj₁⟩ },
          exact hj₂ (this ▸ hi₂) },
        { intros x hx,
          simp only [mem_Union, sup_eq_union, mem_inter_eq,
                    mem_union_eq, mem_compl_eq, or_iff_not_imp_left],
          intro h, push_neg at h,
          rw [top_eq_univ, ← S.spanning, mem_Union] at hx,
          obtain ⟨i, hi⟩ := hx,
          exact ⟨i, hi, h i hi⟩ } },
      rw [hcompl.compl_eq, measure_Union, tsum_eq_zero_iff ennreal.summable],
      { intro n, rw [inter_comm, ← restrict_apply (hA₁ n).compl, ← hA₃ n, hνn, h₁] },
      { exact h₂.mono (λ i j, disjoint.mono inf_le_left inf_le_left) },
      { exact λ n, (S.set_mem n).inter (hA₁ n).compl } } },
  -- Finally, it remains to show `μ = ξ + ν.with_density f`. Since `μ = sum μn`, and
  -- `ξ + ν.with_density f = ∑ n, singular_part (μn n) (νn n)`
  --                        `+ ν.with_density (rn_deriv (μn n) (νn n)) ∩ (S.set n)`,
  -- it suffices to show that the individual summands are equal. This follows by the
  -- Lebesgue decomposition properties on the individual `μn n` and `νn n`
  { simp only [hξ, hf, hμ],
    rw [with_density_tsum _, sum_add_sum],
    { refine sum_congr (λ n, _),
      conv_lhs { rw have_lebesgue_decomposition_add (μn n) (νn n) },
      suffices heq : (νn n).with_density ((μn n).rn_deriv (νn n)) =
        ν.with_density ((S.set n).indicator ((μn n).rn_deriv (νn n))),
      { rw heq },
      rw [hν, with_density_indicator (S.set_mem n), restrict_sum _ (S.set_mem n)],
      suffices hsumeq : sum (λ (i : ℕ), (νn i).restrict (S.set n)) = νn n,
      { rw hsumeq },
      ext1 s hs,
      rw [sum_apply _ hs, tsum_eq_single n, hνn, h₁,
          restrict_restrict (T.set_mem n), inter_self],
      { intros m hm,
        rw [hνn, h₁, restrict_restrict (T.set_mem n),
            disjoint_iff_inter_eq_empty.1 (h₃ n m hm.symm), restrict_empty,
            coe_zero, pi.zero_apply] },
      { apply_instance } },
    { exact λ n, measurable.indicator (measurable_rn_deriv _ _) (S.set_mem n) } },
end⟩

end measure

namespace signed_measure

open measure

/-- A signed measure `s` is said to `have_lebesgue_decomposition` with respect to a measure `μ`
if the positive part and the negative part of `s` both `have_lebesgue_decomposition` with
respect to `μ`. -/
class have_lebesgue_decomposition (s : signed_measure α) (μ : measure α) : Prop :=
(pos_part : s.to_jordan_decomposition.pos_part.have_lebesgue_decomposition μ)
(neg_part : s.to_jordan_decomposition.neg_part.have_lebesgue_decomposition μ)

attribute [instance] have_lebesgue_decomposition.pos_part
attribute [instance] have_lebesgue_decomposition.neg_part

lemma not_have_lebesgue_decomposition_iff (s : signed_measure α)
  (μ : measure α) :
  ¬ s.have_lebesgue_decomposition μ ↔
  ¬ s.to_jordan_decomposition.pos_part.have_lebesgue_decomposition μ ∨
  ¬ s.to_jordan_decomposition.neg_part.have_lebesgue_decomposition μ :=
⟨λ h, not_or_of_imp (λ hp hn, h ⟨hp, hn⟩), λ h hl, (not_and_distrib.2 h) ⟨hl.1, hl.2⟩⟩

-- `infer_instance` directly does not work
@[priority 100] -- see Note [lower instance priority]
instance have_lebesgue_decomposition_of_sigma_finite
  (s : signed_measure α) (μ : measure α) [sigma_finite μ] :
  s.have_lebesgue_decomposition μ :=
{ pos_part := infer_instance,
  neg_part := infer_instance }

instance have_lebesgue_decomposition_neg
  (s : signed_measure α) (μ : measure α) [s.have_lebesgue_decomposition μ] :
  (-s).have_lebesgue_decomposition μ :=
{ pos_part :=
    by { rw [to_jordan_decomposition_neg, jordan_decomposition.neg_pos_part],
         apply_instance },
  neg_part :=
    by { rw [to_jordan_decomposition_neg, jordan_decomposition.neg_neg_part],
         apply_instance } }

instance have_lebesgue_decomposition_smul
  (s : signed_measure α) (μ : measure α) [s.have_lebesgue_decomposition μ] (r : ℝ≥0) :
  (r • s).have_lebesgue_decomposition μ :=
{ pos_part :=
    by { rw [to_jordan_decomposition_smul, jordan_decomposition.smul_pos_part],
         apply_instance },
  neg_part :=
    by { rw [to_jordan_decomposition_smul, jordan_decomposition.smul_neg_part],
         apply_instance } }

instance have_lebesgue_decomposition_smul_real
  (s : signed_measure α) (μ : measure α) [s.have_lebesgue_decomposition μ] (r : ℝ) :
  (r • s).have_lebesgue_decomposition μ :=
begin
  by_cases hr : 0 ≤ r,
  { lift r to ℝ≥0 using hr,
    exact s.have_lebesgue_decomposition_smul μ _ },
  { rw not_le at hr,
    refine
    { pos_part :=
      by { rw [to_jordan_decomposition_smul_real,
               jordan_decomposition.real_smul_pos_part_neg _ _ hr],
           apply_instance },
      neg_part :=
      by { rw [to_jordan_decomposition_smul_real,
               jordan_decomposition.real_smul_neg_part_neg _ _ hr],
           apply_instance } } }
end

/-- Given a signed measure `s` and a measure `μ`, `s.singular_part μ` is the signed measure
such that `s.singular_part μ + μ.with_densityᵥ (s.rn_deriv μ) = s` and
`s.singular_part μ` is mutually singular with respect to `μ`. -/
def singular_part (s : signed_measure α) (μ : measure α) : signed_measure α :=
(s.to_jordan_decomposition.pos_part.singular_part μ).to_signed_measure -
(s.to_jordan_decomposition.neg_part.singular_part μ).to_signed_measure

section

lemma singular_part_mutually_singular (s : signed_measure α) (μ : measure α) :
  s.to_jordan_decomposition.pos_part.singular_part μ ⊥ₘ
  s.to_jordan_decomposition.neg_part.singular_part μ :=
begin
  by_cases hl : s.have_lebesgue_decomposition μ,
  { haveI := hl,
    obtain ⟨i, hi, hpos, hneg⟩ := s.to_jordan_decomposition.mutually_singular,
    rw s.to_jordan_decomposition.pos_part.have_lebesgue_decomposition_add μ at hpos,
    rw s.to_jordan_decomposition.neg_part.have_lebesgue_decomposition_add μ at hneg,
    rw [add_apply, add_eq_zero_iff] at hpos hneg,
    exact ⟨i, hi, hpos.1, hneg.1⟩ },
  { rw not_have_lebesgue_decomposition_iff at hl,
    cases hl with hp hn,
    { rw [measure.singular_part, dif_neg hp],
      exact mutually_singular.zero_left },
    { rw [measure.singular_part, measure.singular_part, dif_neg hn],
      exact mutually_singular.zero_right } }
end

lemma singular_part_total_variation (s : signed_measure α) (μ : measure α) :
  (s.singular_part μ).total_variation =
  s.to_jordan_decomposition.pos_part.singular_part μ +
  s.to_jordan_decomposition.neg_part.singular_part μ :=
begin
  have : (s.singular_part μ).to_jordan_decomposition =
    ⟨s.to_jordan_decomposition.pos_part.singular_part μ,
     s.to_jordan_decomposition.neg_part.singular_part μ, singular_part_mutually_singular s μ⟩,
  { refine jordan_decomposition.to_signed_measure_injective _,
    rw to_signed_measure_to_jordan_decomposition,
    refl },
  { rw [total_variation, this] },
end

lemma mutually_singular_singular_part (s : signed_measure α) (μ : measure α) :
  singular_part s μ ⊥ᵥ μ.to_ennreal_vector_measure :=
begin
  rw [mutually_singular_ennreal_iff, singular_part_total_variation],
  change _ ⊥ₘ vector_measure.equiv_measure.to_fun (vector_measure.equiv_measure.inv_fun μ),
  rw vector_measure.equiv_measure.right_inv μ,
  exact (mutually_singular_singular_part _ _).add_left (mutually_singular_singular_part _ _)
end

end

/-- The Radon-Nikodym derivative between a signed measure and a positive measure.

`rn_deriv s μ` satisfies `μ.with_densityᵥ (s.rn_deriv μ) = s`
if and only if `s` is absolutely continuous with respect to `μ` and this fact is known as
`measure_theory.signed_measure.absolutely_continuous_iff_with_density_rn_deriv_eq`
and can be found in `measure_theory.decomposition.radon_nikodym`. -/
def rn_deriv (s : signed_measure α) (μ : measure α) : α → ℝ := λ x,
(s.to_jordan_decomposition.pos_part.rn_deriv μ x).to_real -
(s.to_jordan_decomposition.neg_part.rn_deriv μ x).to_real

variables {s t : signed_measure α}

@[measurability]
lemma measurable_rn_deriv (s : signed_measure α) (μ : measure α) :
  measurable (rn_deriv s μ) :=
begin
  rw [rn_deriv],
  measurability,
end

lemma integrable_rn_deriv (s : signed_measure α) (μ : measure α) :
  integrable (rn_deriv s μ) μ :=
begin
  refine integrable.sub _ _;
  { split,
    { apply measurable.ae_strongly_measurable, measurability },
    exact has_finite_integral_to_real_of_lintegral_ne_top
      (lintegral_rn_deriv_lt_top _ μ).ne }
end

variables (s μ)

/-- **The Lebesgue Decomposition theorem between a signed measure and a measure**:
Given a signed measure `s` and a σ-finite measure `μ`, there exist a signed measure `t` and a
measurable and integrable function `f`, such that `t` is mutually singular with respect to `μ`
and `s = t + μ.with_densityᵥ f`. In this case `t = s.singular_part μ` and
`f = s.rn_deriv μ`. -/
theorem singular_part_add_with_density_rn_deriv_eq
  [s.have_lebesgue_decomposition μ] :
  s.singular_part μ + μ.with_densityᵥ (s.rn_deriv μ) = s :=
begin
  conv_rhs { rw [← to_signed_measure_to_jordan_decomposition s,
                 jordan_decomposition.to_signed_measure] },
  rw [singular_part, rn_deriv, with_densityᵥ_sub'
        (integrable_to_real_of_lintegral_ne_top _ _) (integrable_to_real_of_lintegral_ne_top _ _),
      with_densityᵥ_to_real, with_densityᵥ_to_real, sub_eq_add_neg, sub_eq_add_neg,
      add_comm (s.to_jordan_decomposition.pos_part.singular_part μ).to_signed_measure, ← add_assoc,
      add_assoc (-(s.to_jordan_decomposition.neg_part.singular_part μ).to_signed_measure),
      ← to_signed_measure_add, add_comm, ← add_assoc, ← neg_add, ← to_signed_measure_add,
      add_comm, ← sub_eq_add_neg],
  convert rfl, -- `convert rfl` much faster than `congr`
  { exact (s.to_jordan_decomposition.pos_part.have_lebesgue_decomposition_add μ) },
  { rw add_comm,
    exact (s.to_jordan_decomposition.neg_part.have_lebesgue_decomposition_add μ) },
  all_goals { exact (lintegral_rn_deriv_lt_top _ _).ne <|> measurability }
end

variables {s μ}

lemma jordan_decomposition_add_with_density_mutually_singular
  {f : α → ℝ} (hf : measurable f) (htμ : t ⊥ᵥ μ.to_ennreal_vector_measure) :
  t.to_jordan_decomposition.pos_part + μ.with_density (λ (x : α), ennreal.of_real (f x)) ⊥ₘ
  t.to_jordan_decomposition.neg_part + μ.with_density (λ (x : α), ennreal.of_real (-f x)) :=
begin
  rw [mutually_singular_ennreal_iff, total_variation_mutually_singular_iff] at htμ,
  change _ ⊥ₘ vector_measure.equiv_measure.to_fun (vector_measure.equiv_measure.inv_fun μ) ∧
         _ ⊥ₘ vector_measure.equiv_measure.to_fun (vector_measure.equiv_measure.inv_fun μ) at htμ,
  rw [vector_measure.equiv_measure.right_inv] at htμ,
  exact ((jordan_decomposition.mutually_singular _).add_right
    (htμ.1.mono_ac (refl _) (with_density_absolutely_continuous _ _))).add_left
    ((htμ.2.symm.mono_ac (with_density_absolutely_continuous _ _) (refl _)).add_right
    (with_density_of_real_mutually_singular hf))
end

lemma to_jordan_decomposition_eq_of_eq_add_with_density
  {f : α → ℝ} (hf : measurable f) (hfi : integrable f μ)
  (htμ : t ⊥ᵥ μ.to_ennreal_vector_measure) (hadd : s = t + μ.with_densityᵥ f) :
  s.to_jordan_decomposition = @jordan_decomposition.mk α _
    (t.to_jordan_decomposition.pos_part + μ.with_density (λ x, ennreal.of_real (f x)))
    (t.to_jordan_decomposition.neg_part + μ.with_density (λ x, ennreal.of_real (- f x)))
    (by { haveI := is_finite_measure_with_density_of_real hfi.2, apply_instance })
    (by { haveI := is_finite_measure_with_density_of_real hfi.neg.2, apply_instance })
    (jordan_decomposition_add_with_density_mutually_singular hf htμ) :=
begin
  haveI := is_finite_measure_with_density_of_real hfi.2,
  haveI := is_finite_measure_with_density_of_real hfi.neg.2,
  refine to_jordan_decomposition_eq _,
  simp_rw [jordan_decomposition.to_signed_measure, hadd],
  ext i hi,
  rw [vector_measure.sub_apply, to_signed_measure_apply_measurable hi,
      to_signed_measure_apply_measurable hi, add_apply, add_apply,
      ennreal.to_real_add, ennreal.to_real_add, add_sub_add_comm,
      ← to_signed_measure_apply_measurable hi, ← to_signed_measure_apply_measurable hi,
      ← vector_measure.sub_apply, ← jordan_decomposition.to_signed_measure,
      to_signed_measure_to_jordan_decomposition, vector_measure.add_apply,
      ← to_signed_measure_apply_measurable hi, ← to_signed_measure_apply_measurable hi,
      with_densityᵥ_eq_with_density_pos_part_sub_with_density_neg_part hfi,
      vector_measure.sub_apply];
  exact (measure_lt_top _ _).ne
end

private lemma have_lebesgue_decomposition_mk' (μ : measure α)
  {f : α → ℝ} (hf : measurable f) (hfi : integrable f μ)
  (htμ : t ⊥ᵥ μ.to_ennreal_vector_measure) (hadd : s = t + μ.with_densityᵥ f) :
  s.have_lebesgue_decomposition μ :=
begin
  have htμ' := htμ,
  rw mutually_singular_ennreal_iff at htμ,
  change _ ⊥ₘ vector_measure.equiv_measure.to_fun (vector_measure.equiv_measure.inv_fun μ) at htμ,
  rw [vector_measure.equiv_measure.right_inv, total_variation_mutually_singular_iff] at htμ,
  refine
    { pos_part :=
      by { use ⟨t.to_jordan_decomposition.pos_part, λ x, ennreal.of_real (f x)⟩,
          refine ⟨hf.ennreal_of_real, htμ.1, _⟩,
          rw to_jordan_decomposition_eq_of_eq_add_with_density hf hfi htμ' hadd },
      neg_part :=
      by { use ⟨t.to_jordan_decomposition.neg_part, λ x, ennreal.of_real (-f x)⟩,
           refine ⟨hf.neg.ennreal_of_real, htμ.2, _⟩,
           rw to_jordan_decomposition_eq_of_eq_add_with_density hf hfi htμ' hadd } }
end

lemma have_lebesgue_decomposition_mk (μ : measure α) {f : α → ℝ} (hf : measurable f)
  (htμ : t ⊥ᵥ μ.to_ennreal_vector_measure) (hadd : s = t + μ.with_densityᵥ f) :
  s.have_lebesgue_decomposition μ :=
begin
  by_cases hfi : integrable f μ,
  { exact have_lebesgue_decomposition_mk' μ hf hfi htμ hadd },
  { rw [with_densityᵥ, dif_neg hfi, add_zero] at hadd,
    refine have_lebesgue_decomposition_mk' μ measurable_zero (integrable_zero _ _ μ) htμ _,
    rwa [with_densityᵥ_zero, add_zero] }
end

private theorem eq_singular_part'
  (t : signed_measure α) {f : α → ℝ} (hf : measurable f) (hfi : integrable f μ)
  (htμ : t ⊥ᵥ μ.to_ennreal_vector_measure) (hadd : s = t + μ.with_densityᵥ f) :
  t = s.singular_part μ :=
begin
  have htμ' := htμ,
  rw [mutually_singular_ennreal_iff, total_variation_mutually_singular_iff] at htμ,
  change _ ⊥ₘ vector_measure.equiv_measure.to_fun (vector_measure.equiv_measure.inv_fun μ) ∧
         _ ⊥ₘ vector_measure.equiv_measure.to_fun (vector_measure.equiv_measure.inv_fun μ) at htμ,
  rw [vector_measure.equiv_measure.right_inv] at htμ,
  { rw [singular_part, ← t.to_signed_measure_to_jordan_decomposition,
        jordan_decomposition.to_signed_measure],
    congr,
    { have hfpos : measurable (λ x, ennreal.of_real (f x)), { measurability },
      refine eq_singular_part hfpos htμ.1 _,
      rw to_jordan_decomposition_eq_of_eq_add_with_density hf hfi htμ' hadd },
    { have hfneg : measurable (λ x, ennreal.of_real (-f x)), { measurability },
      refine eq_singular_part hfneg htμ.2 _,
      rw to_jordan_decomposition_eq_of_eq_add_with_density hf hfi htμ' hadd } },
end

/-- Given a measure `μ`, signed measures `s` and `t`, and a function `f` such that `t` is
mutually singular with respect to `μ` and `s = t + μ.with_densityᵥ f`, we have
`t = singular_part s μ`, i.e. `t` is the singular part of the Lebesgue decomposition between
`s` and `μ`. -/
theorem eq_singular_part (t : signed_measure α) (f : α → ℝ)
  (htμ : t ⊥ᵥ μ.to_ennreal_vector_measure) (hadd : s = t + μ.with_densityᵥ f) :
  t = s.singular_part μ :=
begin
  by_cases hfi : integrable f μ,
  { refine eq_singular_part' t hfi.1.measurable_mk (hfi.congr hfi.1.ae_eq_mk) htμ _,
    convert hadd using 2,
    exact with_densityᵥ_eq.congr_ae hfi.1.ae_eq_mk.symm },
  { rw [with_densityᵥ, dif_neg hfi, add_zero] at hadd,
    refine eq_singular_part' t measurable_zero (integrable_zero _ _ μ) htμ _,
    rwa [with_densityᵥ_zero, add_zero] }
end

lemma singular_part_zero (μ : measure α) : (0 : signed_measure α).singular_part μ = 0 :=
begin
  refine (eq_singular_part 0 0
    vector_measure.mutually_singular.zero_left _).symm,
  rw [zero_add, with_densityᵥ_zero],
end

lemma singular_part_neg (s : signed_measure α) (μ : measure α) :
  (-s).singular_part μ = - s.singular_part μ :=
begin
  have h₁ : ((-s).to_jordan_decomposition.pos_part.singular_part μ).to_signed_measure =
    (s.to_jordan_decomposition.neg_part.singular_part μ).to_signed_measure,
  { refine to_signed_measure_congr _,
    rw [to_jordan_decomposition_neg, jordan_decomposition.neg_pos_part] },
  have h₂ : ((-s).to_jordan_decomposition.neg_part.singular_part μ).to_signed_measure =
    (s.to_jordan_decomposition.pos_part.singular_part μ).to_signed_measure,
  { refine to_signed_measure_congr _,
    rw [to_jordan_decomposition_neg, jordan_decomposition.neg_neg_part] },
  rw [singular_part, singular_part, neg_sub, h₁, h₂],
end

lemma singular_part_smul_nnreal (s : signed_measure α) (μ : measure α) (r : ℝ≥0) :
  (r • s).singular_part μ = r • s.singular_part μ :=
begin
  rw [singular_part, singular_part, smul_sub, ← to_signed_measure_smul, ← to_signed_measure_smul],
  conv_lhs { congr, congr,
             rw [to_jordan_decomposition_smul, jordan_decomposition.smul_pos_part,
                 singular_part_smul], skip, congr,
             rw [to_jordan_decomposition_smul, jordan_decomposition.smul_neg_part,
                 singular_part_smul] }
end

lemma singular_part_smul (s : signed_measure α) (μ : measure α) (r : ℝ) :
  (r • s).singular_part μ = r • s.singular_part μ :=
begin
  by_cases hr : 0 ≤ r,
  { lift r to ℝ≥0 using hr,
    exact singular_part_smul_nnreal s μ r },
  { rw [singular_part, singular_part],
    conv_lhs { congr, congr,
      rw [to_jordan_decomposition_smul_real,
          jordan_decomposition.real_smul_pos_part_neg _ _ (not_le.1 hr), singular_part_smul],
              skip, congr,
      rw [to_jordan_decomposition_smul_real,
          jordan_decomposition.real_smul_neg_part_neg _ _ (not_le.1 hr), singular_part_smul] },
    rw [to_signed_measure_smul, to_signed_measure_smul, ← neg_sub, ← smul_sub],
    change -(((-r).to_nnreal : ℝ) • _) = _,
    rw [← neg_smul, real.coe_to_nnreal _ (le_of_lt (neg_pos.mpr (not_le.1 hr))), neg_neg] }
end

lemma singular_part_add (s t : signed_measure α) (μ : measure α)
  [s.have_lebesgue_decomposition μ] [t.have_lebesgue_decomposition μ] :
  (s + t).singular_part μ = s.singular_part μ + t.singular_part μ :=
begin
  refine (eq_singular_part _ (s.rn_deriv μ + t.rn_deriv μ)
    ((mutually_singular_singular_part s μ).add_left (mutually_singular_singular_part t μ)) _).symm,
  erw [with_densityᵥ_add (integrable_rn_deriv s μ) (integrable_rn_deriv t μ)],
  rw [add_assoc, add_comm (t.singular_part μ), add_assoc, add_comm _ (t.singular_part μ),
      singular_part_add_with_density_rn_deriv_eq, ← add_assoc,
      singular_part_add_with_density_rn_deriv_eq],
end

lemma singular_part_sub (s t : signed_measure α) (μ : measure α)
  [s.have_lebesgue_decomposition μ] [t.have_lebesgue_decomposition μ] :
  (s - t).singular_part μ = s.singular_part μ - t.singular_part μ :=
by { rw [sub_eq_add_neg, sub_eq_add_neg, singular_part_add, singular_part_neg] }

/-- Given a measure `μ`, signed measures `s` and `t`, and a function `f` such that `t` is
mutually singular with respect to `μ` and `s = t + μ.with_densityᵥ f`, we have
`f = rn_deriv s μ`, i.e. `f` is the Radon-Nikodym derivative of `s` and `μ`. -/
theorem eq_rn_deriv (t : signed_measure α) (f : α → ℝ) (hfi : integrable f μ)
  (htμ : t ⊥ᵥ μ.to_ennreal_vector_measure) (hadd : s = t + μ.with_densityᵥ f) :
  f =ᵐ[μ] s.rn_deriv μ :=
begin
  set f' := hfi.1.mk f,
  have hadd' : s = t + μ.with_densityᵥ f',
  { convert hadd using 2,
    exact with_densityᵥ_eq.congr_ae hfi.1.ae_eq_mk.symm },
  haveI := have_lebesgue_decomposition_mk μ hfi.1.measurable_mk htμ hadd',
  refine (integrable.ae_eq_of_with_densityᵥ_eq (integrable_rn_deriv _ _) hfi _).symm,
  rw [← add_right_inj t, ← hadd, eq_singular_part _ f htμ hadd,
      singular_part_add_with_density_rn_deriv_eq],
end

lemma rn_deriv_neg (s : signed_measure α) (μ : measure α) [s.have_lebesgue_decomposition μ] :
  (-s).rn_deriv μ =ᵐ[μ] - s.rn_deriv μ :=
begin
  refine integrable.ae_eq_of_with_densityᵥ_eq
    (integrable_rn_deriv _ _) (integrable_rn_deriv _ _).neg _,
  rw [with_densityᵥ_neg, ← add_right_inj ((-s).singular_part μ),
      singular_part_add_with_density_rn_deriv_eq, singular_part_neg, ← neg_add,
      singular_part_add_with_density_rn_deriv_eq]
end

lemma rn_deriv_smul (s : signed_measure α) (μ : measure α) [s.have_lebesgue_decomposition μ]
  (r : ℝ) :
  (r • s).rn_deriv μ =ᵐ[μ] r • s.rn_deriv μ :=
begin
  refine integrable.ae_eq_of_with_densityᵥ_eq
    (integrable_rn_deriv _ _) ((integrable_rn_deriv _ _).smul r) _,
  change _ = μ.with_densityᵥ ((r : ℝ) • s.rn_deriv μ),
  rw [with_densityᵥ_smul (rn_deriv s μ) (r : ℝ),
      ← add_right_inj ((r • s).singular_part μ),
      singular_part_add_with_density_rn_deriv_eq, singular_part_smul],
  change _ = _ + r • _,
  rw [← smul_add, singular_part_add_with_density_rn_deriv_eq],
end

lemma rn_deriv_add (s t : signed_measure α) (μ : measure α)
  [s.have_lebesgue_decomposition μ] [t.have_lebesgue_decomposition μ]
  [(s + t).have_lebesgue_decomposition μ] :
  (s + t).rn_deriv μ =ᵐ[μ] s.rn_deriv μ + t.rn_deriv μ :=
begin
  refine integrable.ae_eq_of_with_densityᵥ_eq
    (integrable_rn_deriv _ _)
    ((integrable_rn_deriv _ _).add (integrable_rn_deriv _ _)) _,
  rw [← add_right_inj ((s + t).singular_part μ),
      singular_part_add_with_density_rn_deriv_eq,
      with_densityᵥ_add (integrable_rn_deriv _ _) (integrable_rn_deriv _ _),
      singular_part_add, add_assoc, add_comm (t.singular_part μ), add_assoc,
      add_comm _ (t.singular_part μ), singular_part_add_with_density_rn_deriv_eq,
      ← add_assoc, singular_part_add_with_density_rn_deriv_eq],
end

lemma rn_deriv_sub (s t : signed_measure α) (μ : measure α)
  [s.have_lebesgue_decomposition μ] [t.have_lebesgue_decomposition μ]
  [hst : (s - t).have_lebesgue_decomposition μ] :
  (s - t).rn_deriv μ =ᵐ[μ] s.rn_deriv μ - t.rn_deriv μ :=
begin
  rw sub_eq_add_neg at hst,
  rw [sub_eq_add_neg, sub_eq_add_neg],
  exactI ae_eq_trans (rn_deriv_add _ _ _)
    (filter.eventually_eq.add (ae_eq_refl _) (rn_deriv_neg _ _)),
end

end signed_measure

namespace complex_measure

/-- A complex measure is said to `have_lebesgue_decomposition` with respect to a positive measure
if both its real and imaginary part `have_lebesgue_decomposition` with respect to that measure. -/
class have_lebesgue_decomposition (c : complex_measure α) (μ : measure α) : Prop :=
(re_part : c.re.have_lebesgue_decomposition μ)
(im_part : c.im.have_lebesgue_decomposition μ)

attribute [instance] have_lebesgue_decomposition.re_part
attribute [instance] have_lebesgue_decomposition.im_part

/-- The singular part between a complex measure `c` and a positive measure `μ` is the complex
measure satisfying `c.singular_part μ + μ.with_densityᵥ (c.rn_deriv μ) = c`. This property is given
by `measure_theory.complex_measure.singular_part_add_with_density_rn_deriv_eq`. -/
def singular_part (c : complex_measure α) (μ : measure α) : complex_measure α :=
(c.re.singular_part μ).to_complex_measure (c.im.singular_part μ)

/-- The Radon-Nikodym derivative between a complex measure and a positive measure. -/
def rn_deriv (c : complex_measure α) (μ : measure α) : α → ℂ :=
λ x, ⟨c.re.rn_deriv μ x, c.im.rn_deriv μ x⟩

variable {c : complex_measure α}

lemma integrable_rn_deriv (c : complex_measure α) (μ : measure α) :
  integrable (c.rn_deriv μ) μ :=
begin
  rw [← mem_ℒp_one_iff_integrable, ← mem_ℒp_re_im_iff],
  exact ⟨mem_ℒp_one_iff_integrable.2 (signed_measure.integrable_rn_deriv _ _),
         mem_ℒp_one_iff_integrable.2 (signed_measure.integrable_rn_deriv _ _)⟩
end

theorem singular_part_add_with_density_rn_deriv_eq [c.have_lebesgue_decomposition μ] :
  c.singular_part μ + μ.with_densityᵥ (c.rn_deriv μ) = c :=
begin
  conv_rhs { rw [← c.to_complex_measure_to_signed_measure] },
  ext i hi : 1,
  rw [vector_measure.add_apply, signed_measure.to_complex_measure_apply],
  ext,
  { rw [complex.add_re, with_densityᵥ_apply (c.integrable_rn_deriv μ) hi,
      ←is_R_or_C.re_eq_complex_re, ←integral_re (c.integrable_rn_deriv μ).integrable_on,
      is_R_or_C.re_eq_complex_re, ← with_densityᵥ_apply _ hi],
    { change (c.re.singular_part μ + μ.with_densityᵥ (c.re.rn_deriv μ)) i = _,
      rw c.re.singular_part_add_with_density_rn_deriv_eq μ },
    { exact (signed_measure.integrable_rn_deriv _ _) } },
  { rw [complex.add_im, with_densityᵥ_apply (c.integrable_rn_deriv μ) hi,
      ←is_R_or_C.im_eq_complex_im, ←integral_im (c.integrable_rn_deriv μ).integrable_on,
      is_R_or_C.im_eq_complex_im, ← with_densityᵥ_apply _ hi],
    { change (c.im.singular_part μ + μ.with_densityᵥ (c.im.rn_deriv μ)) i = _,
      rw c.im.singular_part_add_with_density_rn_deriv_eq μ },
    { exact (signed_measure.integrable_rn_deriv _ _) } },
end

end complex_measure

end measure_theory


<|start_filename|>src/geometry/manifold/partition_of_unity.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import geometry.manifold.algebra.structures
import geometry.manifold.bump_function
import topology.paracompact
import topology.partition_of_unity
import topology.shrinking_lemma

/-!
# Smooth partition of unity

In this file we define two structures, `smooth_bump_covering` and `smooth_partition_of_unity`. Both
structures describe coverings of a set by a locally finite family of supports of smooth functions
with some additional properties. The former structure is mostly useful as an intermediate step in
the construction of a smooth partition of unity but some proofs that traditionally deal with a
partition of unity can use a `smooth_bump_covering` as well.

Given a real manifold `M` and its subset `s`, a `smooth_bump_covering ι I M s` is a collection of
`smooth_bump_function`s `f i` indexed by `i : ι` such that

* the center of each `f i` belongs to `s`;
* the family of sets `support (f i)` is locally finite;
* for each `x ∈ s`, there exists `i : ι` such that `f i =ᶠ[𝓝 x] 1`.
In the same settings, a `smooth_partition_of_unity ι I M s` is a collection of smooth nonnegative
functions `f i : C^∞⟮I, M; 𝓘(ℝ), ℝ⟯`, `i : ι`, such that

* the family of sets `support (f i)` is locally finite;
* for each `x ∈ s`, the sum `∑ᶠ i, f i x` equals one;
* for each `x`, the sum `∑ᶠ i, f i x` is less than or equal to one.

We say that `f : smooth_bump_covering ι I M s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `tsupport (f i) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.

We prove that on a smooth finitely dimensional real manifold with `σ`-compact Hausdorff topology,
for any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering ι I M s`
subordinate to `U`. Then we use this fact to prove a similar statement about smooth partitions of
unity.

## Implementation notes



## TODO

* Build a framework for to transfer local definitions to global using partition of unity and use it
  to define, e.g., the integral of a differential form over a manifold.

## Tags

smooth bump function, partition of unity
-/

universes uι uE uH uM

open function filter finite_dimensional set
open_locale topological_space manifold classical filter big_operators

noncomputable theory

variables {ι : Type uι}
{E : Type uE} [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
{H : Type uH} [topological_space H] (I : model_with_corners ℝ E H)
{M : Type uM} [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]

/-!
### Covering by supports of smooth bump functions

In this section we define `smooth_bump_covering ι I M s` to be a collection of
`smooth_bump_function`s such that their supports is a locally finite family of sets and for each `x
∈ s` some function `f i` from the collection is equal to `1` in a neighborhood of `x`. A covering of
this type is useful to construct a smooth partition of unity and can be used instead of a partition
of unity in some proofs.

We prove that on a smooth finite dimensional real manifold with `σ`-compact Hausdorff topology, for
any `U : M → set M` such that `∀ x ∈ s, U x ∈ 𝓝 x` there exists a `smooth_bump_covering ι I M s`
subordinate to `U`. Then we use this fact to prove a version of the Whitney embedding theorem: any
compact real manifold can be embedded into `ℝ^n` for large enough `n`.  -/

variables (ι M)

/-- We say that a collection of `smooth_bump_function`s is a `smooth_bump_covering` of a set `s` if

* `(f i).c ∈ s` for all `i`;
* the family `λ i, support (f i)` is locally finite;
* for each point `x ∈ s` there exists `i` such that `f i =ᶠ[𝓝 x] 1`;
  in other words, `x` belongs to the interior of `{y | f i y = 1}`;

If `M` is a finite dimensional real manifold which is a `σ`-compact Hausdorff topological space,
then for every covering `U : M → set M`, `∀ x, U x ∈ 𝓝 x`, there exists a `smooth_bump_covering`
subordinate to `U`, see `smooth_bump_covering.exists_is_subordinate`.

This covering can be used, e.g., to construct a partition of unity and to prove the weak
Whitney embedding theorem. -/
@[nolint has_inhabited_instance]
structure smooth_bump_covering (s : set M := univ) :=
(c : ι → M)
(to_fun : Π i, smooth_bump_function I (c i))
(c_mem' : ∀ i, c i ∈ s)
(locally_finite' : locally_finite (λ i, support (to_fun i)))
(eventually_eq_one' : ∀ x ∈ s, ∃ i, to_fun i =ᶠ[𝓝 x] 1)

/-- We say that that a collection of functions form a smooth partition of unity on a set `s` if

* all functions are infinitely smooth and nonnegative;
* the family `λ i, support (f i)` is locally finite;
* for all `x ∈ s` the sum `∑ᶠ i, f i x` equals one;
* for all `x`, the sum `∑ᶠ i, f i x` is less than or equal to one. -/
structure smooth_partition_of_unity (s : set M := univ) :=
(to_fun : ι → C^∞⟮I, M; 𝓘(ℝ), ℝ⟯)
(locally_finite' : locally_finite (λ i, support (to_fun i)))
(nonneg' : ∀ i x, 0 ≤ to_fun i x)
(sum_eq_one' : ∀ x ∈ s, ∑ᶠ i, to_fun i x = 1)
(sum_le_one' : ∀ x, ∑ᶠ i, to_fun i x ≤ 1)

variables {ι I M}

namespace smooth_partition_of_unity

variables {s : set M} (f : smooth_partition_of_unity ι I M s)

instance {s : set M} : has_coe_to_fun (smooth_partition_of_unity ι I M s)
  (λ _, ι → C^∞⟮I, M; 𝓘(ℝ), ℝ⟯) :=
⟨smooth_partition_of_unity.to_fun⟩

protected lemma locally_finite : locally_finite (λ i, support (f i)) :=
f.locally_finite'

lemma nonneg (i : ι) (x : M) : 0 ≤ f i x := f.nonneg' i x

lemma sum_eq_one {x} (hx : x ∈ s) : ∑ᶠ i, f i x = 1 := f.sum_eq_one' x hx

lemma sum_le_one (x : M) : ∑ᶠ i, f i x ≤ 1 := f.sum_le_one' x

/-- Reinterpret a smooth partition of unity as a continuous partition of unity. -/
def to_partition_of_unity : partition_of_unity ι M s :=
{ to_fun := λ i, f i, .. f }

lemma smooth_sum : smooth I 𝓘(ℝ) (λ x, ∑ᶠ i, f i x) :=
smooth_finsum (λ i, (f i).smooth) f.locally_finite

lemma le_one (i : ι) (x : M) : f i x ≤ 1 := f.to_partition_of_unity.le_one i x

lemma sum_nonneg (x : M) : 0 ≤ ∑ᶠ i, f i x := f.to_partition_of_unity.sum_nonneg x

/-- A smooth partition of unity `f i` is subordinate to a family of sets `U i` indexed by the same
type if for each `i` the closure of the support of `f i` is a subset of `U i`. -/
def is_subordinate (f : smooth_partition_of_unity ι I M s) (U : ι → set M) :=
∀ i, tsupport (f i) ⊆ U i

@[simp] lemma is_subordinate_to_partition_of_unity {f : smooth_partition_of_unity ι I M s}
  {U : ι → set M} :
  f.to_partition_of_unity.is_subordinate U ↔ f.is_subordinate U :=
iff.rfl

alias is_subordinate_to_partition_of_unity ↔
  _ smooth_partition_of_unity.is_subordinate.to_partition_of_unity

end smooth_partition_of_unity

namespace bump_covering

-- Repeat variables to drop [finite_dimensional ℝ E] and [smooth_manifold_with_corners I M]
lemma smooth_to_partition_of_unity {E : Type uE} [normed_group E] [normed_space ℝ E]
  {H : Type uH} [topological_space H] {I : model_with_corners ℝ E H}
  {M : Type uM} [topological_space M] [charted_space H M] {s : set M}
  (f : bump_covering ι M s) (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) (i : ι) :
  smooth I 𝓘(ℝ) (f.to_partition_of_unity i) :=
(hf i).mul $ smooth_finprod_cond (λ j _, smooth_const.sub (hf j)) $
  by { simp only [mul_support_one_sub], exact f.locally_finite }

variables {s : set M}

/-- A `bump_covering` such that all functions in this covering are smooth generates a smooth
partition of unity.

In our formalization, not every `f : bump_covering ι M s` with smooth functions `f i` is a
`smooth_bump_covering`; instead, a `smooth_bump_covering` is a covering by supports of
`smooth_bump_function`s. So, we define `bump_covering.to_smooth_partition_of_unity`, then reuse it
in `smooth_bump_covering.to_smooth_partition_of_unity`. -/
def to_smooth_partition_of_unity (f : bump_covering ι M s) (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) :
  smooth_partition_of_unity ι I M s :=
{ to_fun := λ i, ⟨f.to_partition_of_unity i, f.smooth_to_partition_of_unity hf i⟩,
  .. f.to_partition_of_unity }

@[simp] lemma to_smooth_partition_of_unity_to_partition_of_unity (f : bump_covering ι M s)
  (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) :
  (f.to_smooth_partition_of_unity hf).to_partition_of_unity = f.to_partition_of_unity :=
rfl

@[simp] lemma coe_to_smooth_partition_of_unity (f : bump_covering ι M s)
  (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) (i : ι) :
  ⇑(f.to_smooth_partition_of_unity hf i) = f.to_partition_of_unity i :=
rfl

lemma is_subordinate.to_smooth_partition_of_unity {f : bump_covering ι M s}
  {U : ι → set M} (h : f.is_subordinate U) (hf : ∀ i, smooth I 𝓘(ℝ) (f i)) :
  (f.to_smooth_partition_of_unity hf).is_subordinate U :=
h.to_partition_of_unity

end bump_covering

namespace smooth_bump_covering

variables {s : set M} {U : M → set M} (fs : smooth_bump_covering ι I M s) {I}

instance : has_coe_to_fun (smooth_bump_covering ι I M s)
  (λ x, Π (i : ι), smooth_bump_function I (x.c i)) :=
⟨to_fun⟩

@[simp] lemma coe_mk (c : ι → M) (to_fun : Π i, smooth_bump_function I (c i))
  (h₁ h₂ h₃) : ⇑(mk c to_fun h₁ h₂ h₃ : smooth_bump_covering ι I M s) = to_fun :=
rfl

/--
We say that `f : smooth_bump_covering ι I M s` is *subordinate* to a map `U : M → set M` if for each
index `i`, we have `tsupport (f i) ⊆ U (f i).c`. This notion is a bit more general than
being subordinate to an open covering of `M`, because we make no assumption about the way `U x`
depends on `x`.
-/
def is_subordinate {s : set M} (f : smooth_bump_covering ι I M s) (U : M → set M) :=
∀ i, tsupport (f i) ⊆ U (f.c i)

lemma is_subordinate.support_subset {fs : smooth_bump_covering ι I M s} {U : M → set M}
  (h : fs.is_subordinate U) (i : ι) :
  support (fs i) ⊆ U (fs.c i) :=
subset.trans subset_closure (h i)

variable (I)

/-- Let `M` be a smooth manifold with corners modelled on a finite dimensional real vector space.
Suppose also that `M` is a Hausdorff `σ`-compact topological space. Let `s` be a closed set
in `M` and `U : M → set M` be a collection of sets such that `U x ∈ 𝓝 x` for every `x ∈ s`.
Then there exists a smooth bump covering of `s` that is subordinate to `U`. -/
lemma exists_is_subordinate [t2_space M] [sigma_compact_space M] (hs : is_closed s)
  (hU : ∀ x ∈ s, U x ∈ 𝓝 x) :
  ∃ (ι : Type uM) (f : smooth_bump_covering ι I M s), f.is_subordinate U :=
begin
  -- First we deduce some missing instances
  haveI : locally_compact_space H := I.locally_compact,
  haveI : locally_compact_space M := charted_space.locally_compact H M,
  haveI : normal_space M := normal_of_paracompact_t2,
  -- Next we choose a covering by supports of smooth bump functions
  have hB := λ x hx, smooth_bump_function.nhds_basis_support I (hU x hx),
  rcases refinement_of_locally_compact_sigma_compact_of_nhds_basis_set hs hB
    with ⟨ι, c, f, hf, hsub', hfin⟩, choose hcs hfU using hf,
  /- Then we use the shrinking lemma to get a covering by smaller open -/
  rcases exists_subset_Union_closed_subset hs (λ i, (f i).open_support)
    (λ x hx, hfin.point_finite x) hsub' with ⟨V, hsV, hVc, hVf⟩,
  choose r hrR hr using λ i, (f i).exists_r_pos_lt_subset_ball (hVc i) (hVf i),
  refine ⟨ι, ⟨c, λ i, (f i).update_r (r i) (hrR i), hcs, _, λ x hx, _⟩, λ i, _⟩,
  { simpa only [smooth_bump_function.support_update_r] },
  { refine (mem_Union.1 $ hsV hx).imp (λ i hi, _),
    exact ((f i).update_r _ _).eventually_eq_one_of_dist_lt
      ((f i).support_subset_source $ hVf _ hi) (hr i hi).2 },
  { simpa only [coe_mk, smooth_bump_function.support_update_r, tsupport] using hfU i }
end

variables {I M}

protected lemma locally_finite : locally_finite (λ i, support (fs i)) := fs.locally_finite'

protected lemma point_finite (x : M) : {i | fs i x ≠ 0}.finite :=
fs.locally_finite.point_finite x

lemma mem_chart_at_source_of_eq_one {i : ι} {x : M} (h : fs i x = 1) :
  x ∈ (chart_at H (fs.c i)).source :=
(fs i).support_subset_source $ by simp [h]

lemma mem_ext_chart_at_source_of_eq_one {i : ι} {x : M} (h : fs i x = 1) :
  x ∈ (ext_chart_at I (fs.c i)).source :=
by { rw ext_chart_at_source, exact fs.mem_chart_at_source_of_eq_one h }

/-- Index of a bump function such that `fs i =ᶠ[𝓝 x] 1`. -/
def ind (x : M) (hx : x ∈ s) : ι := (fs.eventually_eq_one' x hx).some

lemma eventually_eq_one (x : M) (hx : x ∈ s) : fs (fs.ind x hx) =ᶠ[𝓝 x] 1 :=
(fs.eventually_eq_one' x hx).some_spec

lemma apply_ind (x : M) (hx : x ∈ s) : fs (fs.ind x hx) x = 1 :=
(fs.eventually_eq_one x hx).eq_of_nhds

lemma mem_support_ind (x : M) (hx : x ∈ s) : x ∈ support (fs $ fs.ind x hx) :=
by simp [fs.apply_ind x hx]

lemma mem_chart_at_ind_source (x : M) (hx : x ∈ s) :
  x ∈ (chart_at H (fs.c (fs.ind x hx))).source :=
fs.mem_chart_at_source_of_eq_one (fs.apply_ind x hx)

lemma mem_ext_chart_at_ind_source (x : M) (hx : x ∈ s) :
  x ∈ (ext_chart_at I (fs.c (fs.ind x hx))).source :=
fs.mem_ext_chart_at_source_of_eq_one (fs.apply_ind x hx)

/-- The index type of a `smooth_bump_covering` of a compact manifold is finite. -/
protected def fintype [compact_space M] : fintype ι :=
fs.locally_finite.fintype_of_compact $ λ i, (fs i).nonempty_support

variable [t2_space M]

/-- Reinterpret a `smooth_bump_covering` as a continuous `bump_covering`. Note that not every
`f : bump_covering ι M s` with smooth functions `f i` is a `smooth_bump_covering`. -/
def to_bump_covering : bump_covering ι M s :=
{ to_fun := λ i, ⟨fs i, (fs i).continuous⟩,
  locally_finite' := fs.locally_finite,
  nonneg' := λ i x, (fs i).nonneg,
  le_one' := λ i x, (fs i).le_one,
  eventually_eq_one' := fs.eventually_eq_one' }

@[simp] lemma is_subordinate_to_bump_covering {f : smooth_bump_covering ι I M s} {U : M → set M} :
  f.to_bump_covering.is_subordinate (λ i, U (f.c i)) ↔ f.is_subordinate U :=
iff.rfl

alias is_subordinate_to_bump_covering ↔
  _ smooth_bump_covering.is_subordinate.to_bump_covering

/-- Every `smooth_bump_covering` defines a smooth partition of unity. -/
def to_smooth_partition_of_unity : smooth_partition_of_unity ι I M s :=
fs.to_bump_covering.to_smooth_partition_of_unity (λ i, (fs i).smooth)

lemma to_smooth_partition_of_unity_apply (i : ι) (x : M) :
  fs.to_smooth_partition_of_unity i x = fs i x * ∏ᶠ j (hj : well_ordering_rel j i), (1 - fs j x) :=
rfl

lemma to_smooth_partition_of_unity_eq_mul_prod (i : ι) (x : M) (t : finset ι)
  (ht : ∀ j, well_ordering_rel j i → fs j x ≠ 0 → j ∈ t) :
  fs.to_smooth_partition_of_unity i x =
    fs i x * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - fs j x) :=
fs.to_bump_covering.to_partition_of_unity_eq_mul_prod i x t ht

lemma exists_finset_to_smooth_partition_of_unity_eventually_eq (i : ι) (x : M) :
  ∃ t : finset ι, fs.to_smooth_partition_of_unity i =ᶠ[𝓝 x]
    fs i * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - fs j) :=
fs.to_bump_covering.exists_finset_to_partition_of_unity_eventually_eq i x

lemma to_smooth_partition_of_unity_zero_of_zero {i : ι} {x : M} (h : fs i x = 0) :
  fs.to_smooth_partition_of_unity i x = 0 :=
fs.to_bump_covering.to_partition_of_unity_zero_of_zero h

lemma support_to_smooth_partition_of_unity_subset (i : ι) :
  support (fs.to_smooth_partition_of_unity i) ⊆ support (fs i) :=
fs.to_bump_covering.support_to_partition_of_unity_subset i

lemma is_subordinate.to_smooth_partition_of_unity {f : smooth_bump_covering ι I M s} {U : M → set M}
  (h : f.is_subordinate U) :
  f.to_smooth_partition_of_unity.is_subordinate (λ i, U (f.c i)) :=
h.to_bump_covering.to_partition_of_unity

lemma sum_to_smooth_partition_of_unity_eq (x : M) :
  ∑ᶠ i, fs.to_smooth_partition_of_unity i x = 1 - ∏ᶠ i, (1 - fs i x) :=
fs.to_bump_covering.sum_to_partition_of_unity_eq x

end smooth_bump_covering

variable (I)

/-- Given two disjoint closed sets in a Hausdorff σ-compact finite dimensional manifold, there
exists an infinitely smooth function that is equal to `0` on one of them and is equal to one on the
other. -/
lemma exists_smooth_zero_one_of_closed [t2_space M] [sigma_compact_space M] {s t : set M}
  (hs : is_closed s) (ht : is_closed t) (hd : disjoint s t) :
  ∃ f : C^∞⟮I, M; 𝓘(ℝ), ℝ⟯, eq_on f 0 s ∧ eq_on f 1 t ∧ ∀ x, f x ∈ Icc (0 : ℝ) 1 :=
begin
  have : ∀ x ∈ t, sᶜ ∈ 𝓝 x, from λ x hx, hs.is_open_compl.mem_nhds (disjoint_right.1 hd hx),
  rcases smooth_bump_covering.exists_is_subordinate I ht this with ⟨ι, f, hf⟩,
  set g := f.to_smooth_partition_of_unity,
  refine ⟨⟨_, g.smooth_sum⟩, λ x hx, _, λ x, g.sum_eq_one, λ x, ⟨g.sum_nonneg x, g.sum_le_one x⟩⟩,
  suffices : ∀ i, g i x = 0,
    by simp only [this, cont_mdiff_map.coe_fn_mk, finsum_zero, pi.zero_apply],
  refine λ i, f.to_smooth_partition_of_unity_zero_of_zero _,
  exact nmem_support.1 (subset_compl_comm.1 (hf.support_subset i) hx)
end

variable {I}

namespace smooth_partition_of_unity

/-- A `smooth_partition_of_unity` that consists of a single function, uniformly equal to one,
defined as an example for `inhabited` instance. -/
def single (i : ι) (s : set M) : smooth_partition_of_unity ι I M s :=
(bump_covering.single i s).to_smooth_partition_of_unity $ λ j,
  begin
    rcases eq_or_ne j i with rfl|h,
    { simp only [smooth_one, continuous_map.coe_one, bump_covering.coe_single, pi.single_eq_same] },
    { simp only [smooth_zero, bump_covering.coe_single, pi.single_eq_of_ne h,
        continuous_map.coe_zero] }
  end

instance [inhabited ι] (s : set M) : inhabited (smooth_partition_of_unity ι I M s) :=
⟨single default s⟩

variables [t2_space M] [sigma_compact_space M]

/-- If `X` is a paracompact normal topological space and `U` is an open covering of a closed set
`s`, then there exists a `bump_covering ι X s` that is subordinate to `U`. -/
lemma exists_is_subordinate {s : set M} (hs : is_closed s) (U : ι → set M) (ho : ∀ i, is_open (U i))
  (hU : s ⊆ ⋃ i, U i) :
  ∃ f : smooth_partition_of_unity ι I M s, f.is_subordinate U :=
begin
  haveI : locally_compact_space H := I.locally_compact,
  haveI : locally_compact_space M := charted_space.locally_compact H M,
  haveI : normal_space M := normal_of_paracompact_t2,
  rcases bump_covering.exists_is_subordinate_of_prop (smooth I 𝓘(ℝ)) _ hs U ho hU
    with ⟨f, hf, hfU⟩,
  { exact ⟨f.to_smooth_partition_of_unity hf, hfU.to_smooth_partition_of_unity hf⟩ },
  { intros s t hs ht hd,
    rcases exists_smooth_zero_one_of_closed I hs ht hd with ⟨f, hf⟩,
    exact ⟨f, f.smooth, hf⟩ }
end

end smooth_partition_of_unity


<|start_filename|>src/algebra/big_operators/multiset.lean<|end_filename|>
/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.group_with_zero.power
import data.list.big_operators
import data.multiset.basic

/-!
# Sums and products over multisets

In this file we define products and sums indexed by multisets. This is later used to define products
and sums indexed by finite sets.

## Main declarations

* `multiset.prod`: `s.prod f` is the product of `f i` over all `i ∈ s`. Not to be mistaken with
  the cartesian product `multiset.product`.
* `multiset.sum`: `s.sum f` is the sum of `f i` over all `i ∈ s`.
-/

variables {ι α β γ : Type*}

namespace multiset
section comm_monoid
variables [comm_monoid α] {s t : multiset α} {a : α} {m : multiset ι} {f g : ι → α}

/-- Product of a multiset given a commutative monoid structure on `α`.
  `prod {a, b, c} = a * b * c` -/
@[to_additive "Sum of a multiset given a commutative additive monoid structure on `α`.
  `sum {a, b, c} = a + b + c`"]
def prod : multiset α → α := foldr (*) (λ x y z, by simp [mul_left_comm]) 1

@[to_additive]
lemma prod_eq_foldr (s : multiset α) : prod s = foldr (*) (λ x y z, by simp [mul_left_comm]) 1 s :=
rfl

@[to_additive]
lemma prod_eq_foldl (s : multiset α) : prod s = foldl (*) (λ x y z, by simp [mul_right_comm]) 1 s :=
(foldr_swap _ _ _ _).trans (by simp [mul_comm])

@[simp, norm_cast, to_additive] lemma coe_prod (l : list α) : prod ↑l = l.prod := prod_eq_foldl _

@[simp, to_additive]
lemma prod_to_list (s : multiset α) : s.to_list.prod = s.prod :=
begin
  conv_rhs { rw ←coe_to_list s },
  rw coe_prod,
end

@[simp, to_additive] lemma prod_zero : @prod α _ 0 = 1 := rfl

@[simp, to_additive]
lemma prod_cons (a : α) (s) : prod (a ::ₘ s) = a * prod s := foldr_cons _ _ _ _ _

@[simp, to_additive]
lemma prod_erase [decidable_eq α] (h : a ∈ s) : a * (s.erase a).prod = s.prod :=
by rw [← s.coe_to_list, coe_erase, coe_prod, coe_prod, list.prod_erase ((s.mem_to_list a).2 h)]

@[simp, to_additive]
lemma prod_singleton (a : α) : prod {a} = a :=
by simp only [mul_one, prod_cons, singleton_eq_cons, eq_self_iff_true, prod_zero]

@[to_additive]
lemma prod_pair (a b : α) : ({a, b} : multiset α).prod = a * b :=
by rw [insert_eq_cons, prod_cons, prod_singleton]

@[simp, to_additive]
lemma prod_add (s t : multiset α) : prod (s + t) = prod s * prod t :=
quotient.induction_on₂ s t $ λ l₁ l₂, by simp

lemma prod_nsmul (m : multiset α) : ∀ (n : ℕ), (n • m).prod = m.prod ^ n
| 0       := by { rw [zero_nsmul, pow_zero], refl }
| (n + 1) :=
  by rw [add_nsmul, one_nsmul, pow_add, pow_one, prod_add, prod_nsmul n]

@[simp, to_additive] lemma prod_repeat (a : α) (n : ℕ) : (repeat a n).prod = a ^ n :=
by simp [repeat, list.prod_repeat]

@[to_additive]
lemma pow_count [decidable_eq α] (a : α) : a ^ s.count a = (s.filter (eq a)).prod :=
by rw [filter_eq, prod_repeat]

@[to_additive]
lemma prod_hom [comm_monoid β] (s : multiset α) {F : Type*} [monoid_hom_class F α β] (f : F) :
  (s.map f).prod = f s.prod :=
quotient.induction_on s $ λ l, by simp only [l.prod_hom f, quot_mk_to_coe, coe_map, coe_prod]

@[to_additive]
lemma prod_hom' [comm_monoid β] (s : multiset ι) {F : Type*} [monoid_hom_class F α β] (f : F)
  (g : ι → α) : (s.map $ λ i, f $ g i).prod = f (s.map g).prod :=
by { convert (s.map g).prod_hom f, exact (map_map _ _ _).symm }

@[to_additive]
lemma prod_hom₂ [comm_monoid β] [comm_monoid γ] (s : multiset ι) (f : α → β → γ)
  (hf : ∀ a b c d, f (a * b) (c * d) = f a c * f b d) (hf' : f 1 1 = 1) (f₁ : ι → α) (f₂ : ι → β) :
  (s.map $ λ i, f (f₁ i) (f₂ i)).prod = f (s.map f₁).prod (s.map f₂).prod :=
quotient.induction_on s $ λ l,
  by simp only [l.prod_hom₂ f hf hf', quot_mk_to_coe, coe_map, coe_prod]

@[to_additive]
lemma prod_hom_rel [comm_monoid β] (s : multiset ι) {r : α → β → Prop} {f : ι → α} {g : ι → β}
  (h₁ : r 1 1) (h₂ : ∀ ⦃a b c⦄, r b c → r (f a * b) (g a * c)) :
  r (s.map f).prod (s.map g).prod :=
quotient.induction_on s $ λ l,
  by simp only [l.prod_hom_rel h₁ h₂, quot_mk_to_coe, coe_map, coe_prod]

@[to_additive]
lemma prod_map_one : prod (m.map (λ i, (1 : α))) = 1 := by rw [map_const, prod_repeat, one_pow]

@[simp, to_additive]
lemma prod_map_mul : (m.map $ λ i, f i * g i).prod = (m.map f).prod * (m.map g).prod :=
m.prod_hom₂ (*) mul_mul_mul_comm (mul_one _) _ _

@[to_additive]
lemma prod_map_pow {n : ℕ} : (m.map $ λ i, f i ^ n).prod = (m.map f).prod ^ n :=
m.prod_hom' (pow_monoid_hom n : α →* α) f

@[to_additive]
lemma prod_map_prod_map (m : multiset β) (n : multiset γ) {f : β → γ → α} :
  prod (m.map $ λ a, prod $ n.map $ λ b, f a b) = prod (n.map $ λ b, prod $ m.map $ λ a, f a b) :=
multiset.induction_on m (by simp) (λ a m ih, by simp [ih])

@[to_additive]
lemma prod_induction (p : α → Prop) (s : multiset α) (p_mul : ∀ a b, p a → p b → p (a * b))
  (p_one : p 1) (p_s : ∀ a ∈ s, p a) :
  p s.prod :=
begin
  rw prod_eq_foldr,
  exact foldr_induction (*) (λ x y z, by simp [mul_left_comm]) 1 p s p_mul p_one p_s,
end

@[to_additive]
lemma prod_induction_nonempty (p : α → Prop) (p_mul : ∀ a b, p a → p b → p (a * b))
  (hs : s ≠ ∅) (p_s : ∀ a ∈ s, p a) :
  p s.prod :=
begin
  revert s,
  refine multiset.induction _ _,
  { intro h,
    exfalso,
    simpa using h },
  intros a s hs hsa hpsa,
  rw prod_cons,
  by_cases hs_empty : s = ∅,
  { simp [hs_empty, hpsa a] },
  have hps : ∀ x, x ∈ s → p x, from λ x hxs, hpsa x (mem_cons_of_mem hxs),
  exact p_mul a s.prod (hpsa a (mem_cons_self a s)) (hs hs_empty hps),
end

lemma dvd_prod : a ∈ s → a ∣ s.prod :=
quotient.induction_on s (λ l a h, by simpa using list.dvd_prod h) a

lemma prod_dvd_prod_of_le (h : s ≤ t) : s.prod ∣ t.prod :=
begin
  obtain ⟨z, rfl⟩ := multiset.le_iff_exists_add.1 h,
  simp only [prod_add, dvd_mul_right],
end

end comm_monoid

lemma prod_dvd_prod_of_dvd [comm_monoid β] {S : multiset α} (g1 g2 : α → β)
  (h : ∀ a ∈ S, g1 a ∣ g2 a) :
  (multiset.map g1 S).prod ∣ (multiset.map g2 S).prod :=
begin
  apply multiset.induction_on' S, { simp },
  intros a T haS _ IH,
  simp [mul_dvd_mul (h a haS) IH]
end


section add_comm_monoid
variables [add_comm_monoid α]

/-- `multiset.sum`, the sum of the elements of a multiset, promoted to a morphism of
`add_comm_monoid`s. -/
def sum_add_monoid_hom : multiset α →+ α :=
{ to_fun := sum,
  map_zero' := sum_zero,
  map_add' := sum_add }

@[simp] lemma coe_sum_add_monoid_hom : (sum_add_monoid_hom : multiset α → α) = sum := rfl

end add_comm_monoid

section comm_monoid_with_zero
variables [comm_monoid_with_zero α]

lemma prod_eq_zero {s : multiset α} (h : (0 : α) ∈ s) : s.prod = 0 :=
begin
  rcases multiset.exists_cons_of_mem h with ⟨s', hs'⟩,
  simp [hs', multiset.prod_cons]
end

variables [no_zero_divisors α] [nontrivial α] {s : multiset α}

lemma prod_eq_zero_iff : s.prod = 0 ↔ (0 : α) ∈ s :=
quotient.induction_on s $ λ l, by { rw [quot_mk_to_coe, coe_prod], exact list.prod_eq_zero_iff }

lemma prod_ne_zero (h : (0 : α) ∉ s) : s.prod ≠ 0 := mt prod_eq_zero_iff.1 h

end comm_monoid_with_zero

section division_comm_monoid
variables [division_comm_monoid α] {m : multiset ι} {f g : ι → α}

@[to_additive] lemma prod_map_inv' (m : multiset α) : (m.map has_inv.inv).prod = m.prod⁻¹ :=
m.prod_hom (inv_monoid_hom : α →* α)

@[simp, to_additive] lemma prod_map_inv : (m.map $ λ i, (f i)⁻¹).prod = (m.map f).prod ⁻¹ :=
by { convert (m.map f).prod_map_inv', rw map_map }

@[simp, to_additive]
lemma prod_map_div : (m.map $ λ i, f i / g i).prod = (m.map f).prod / (m.map g).prod :=
m.prod_hom₂ (/) mul_div_mul_comm (div_one _) _ _

@[to_additive]
lemma prod_map_zpow {n : ℤ} : (m.map $ λ i, f i ^ n).prod = (m.map f).prod ^ n :=
by { convert (m.map f).prod_hom (zpow_group_hom _ : α →* α), rw map_map, refl }

end division_comm_monoid

section non_unital_non_assoc_semiring
variables [non_unital_non_assoc_semiring α] {a : α} {s : multiset ι} {f : ι → α}

lemma _root_.commute.multiset_sum_right (s : multiset α) (a : α) (h : ∀ b ∈ s, commute a b) :
  commute a s.sum :=
begin
  induction s using quotient.induction_on,
  rw [quot_mk_to_coe, coe_sum],
  exact commute.list_sum_right _ _ h,
end

lemma _root_.commute.multiset_sum_left (s : multiset α) (b : α) (h : ∀ a ∈ s, commute a b) :
  commute s.sum b :=
(commute.multiset_sum_right _ _ $ λ a ha, (h _ ha).symm).symm

lemma sum_map_mul_left : sum (s.map (λ i, a * f i)) = a * sum (s.map f) :=
multiset.induction_on s (by simp) (λ i s ih, by simp [ih, mul_add])

lemma sum_map_mul_right : sum (s.map (λ i, f i * a)) = sum (s.map f) * a :=
multiset.induction_on s (by simp) (λ a s ih, by simp [ih, add_mul])

end non_unital_non_assoc_semiring

section semiring
variables [semiring α]

lemma dvd_sum {a : α} {s : multiset α} : (∀ x ∈ s, a ∣ x) → a ∣ s.sum :=
multiset.induction_on s (λ _, dvd_zero _)
  (λ x s ih h, by { rw sum_cons, exact dvd_add
    (h _ (mem_cons_self _ _)) (ih $ λ y hy, h _ $ mem_cons.2 $ or.inr hy) })

end semiring

/-! ### Order -/

section ordered_comm_monoid
variables [ordered_comm_monoid α] {s t : multiset α} {a : α}

@[to_additive sum_nonneg]
lemma one_le_prod_of_one_le : (∀ x ∈ s, (1 : α) ≤ x) → 1 ≤ s.prod :=
quotient.induction_on s $ λ l hl, by simpa using list.one_le_prod_of_one_le hl

@[to_additive]
lemma single_le_prod : (∀ x ∈ s, (1 : α) ≤ x) → ∀ x ∈ s, x ≤ s.prod :=
quotient.induction_on s $ λ l hl x hx, by simpa using list.single_le_prod hl x hx

@[to_additive sum_le_card_nsmul]
lemma prod_le_pow_card (s : multiset α) (n : α) (h : ∀ x ∈ s, x ≤ n) : s.prod ≤ n ^ s.card :=
begin
  induction s using quotient.induction_on,
  simpa using list.prod_le_pow_card _ _ h,
end

@[to_additive all_zero_of_le_zero_le_of_sum_eq_zero]
lemma all_one_of_le_one_le_of_prod_eq_one :
  (∀ x ∈ s, (1 : α) ≤ x) → s.prod = 1 → ∀ x ∈ s, x = (1 : α) :=
begin
  apply quotient.induction_on s,
  simp only [quot_mk_to_coe, coe_prod, mem_coe],
  exact λ l, list.all_one_of_le_one_le_of_prod_eq_one,
end

@[to_additive]
lemma prod_le_prod_of_rel_le (h : s.rel (≤) t) : s.prod ≤ t.prod :=
begin
  induction h with _ _ _ _ rh _ rt,
  { refl },
  { rw [prod_cons, prod_cons],
    exact mul_le_mul' rh rt }
end

@[to_additive]
lemma prod_map_le_prod (f : α → α) (h : ∀ x, x ∈ s → f x ≤ x) : (s.map f).prod ≤ s.prod :=
prod_le_prod_of_rel_le $ rel_map_left.2 $ rel_refl_of_refl_on h

@[to_additive]
lemma prod_le_sum_prod (f : α → α) (h : ∀ x, x ∈ s → x ≤ f x) : s.prod ≤ (s.map f).prod :=
@prod_map_le_prod αᵒᵈ _ _ f h

@[to_additive card_nsmul_le_sum]
lemma pow_card_le_prod (h : ∀ x ∈ s, a ≤ x) : a ^ s.card ≤ s.prod :=
by { rw [←multiset.prod_repeat, ←multiset.map_const], exact prod_map_le_prod _ h }

end ordered_comm_monoid

lemma prod_nonneg [ordered_comm_semiring α] {m : multiset α} (h : ∀ a ∈ m, (0 : α) ≤ a) :
  0 ≤ m.prod :=
begin
  revert h,
  refine m.induction_on _ _,
  { rintro -, rw prod_zero, exact zero_le_one },
  intros a s hs ih,
  rw prod_cons,
  exact mul_nonneg (ih _ $ mem_cons_self _ _) (hs $ λ a ha, ih _ $ mem_cons_of_mem ha),
end

@[to_additive]
lemma prod_eq_one_iff [canonically_ordered_monoid α] {m : multiset α} :
  m.prod = 1 ↔ ∀ x ∈ m, x = (1 : α) :=
quotient.induction_on m $ λ l, by simpa using list.prod_eq_one_iff l

@[to_additive]
lemma le_prod_of_mem [canonically_ordered_monoid α] {m : multiset α} {a : α} (h : a ∈ m) :
  a ≤ m.prod :=
begin
  obtain ⟨m', rfl⟩ := exists_cons_of_mem h,
  rw [prod_cons],
  exact _root_.le_mul_right (le_refl a),
end

@[to_additive le_sum_of_subadditive_on_pred]
lemma le_prod_of_submultiplicative_on_pred [comm_monoid α] [ordered_comm_monoid β]
  (f : α → β) (p : α → Prop) (h_one : f 1 = 1) (hp_one : p 1)
  (h_mul : ∀ a b, p a → p b → f (a * b) ≤ f a * f b)
  (hp_mul : ∀ a b, p a → p b → p (a * b)) (s : multiset α) (hps : ∀ a, a ∈ s → p a) :
  f s.prod ≤ (s.map f).prod :=
begin
  revert s,
  refine multiset.induction _ _,
  { simp [le_of_eq h_one] },
  intros a s hs hpsa,
  have hps : ∀ x, x ∈ s → p x, from λ x hx, hpsa x (mem_cons_of_mem hx),
  have hp_prod : p s.prod, from prod_induction p s hp_mul hp_one hps,
  rw [prod_cons, map_cons, prod_cons],
  exact (h_mul a s.prod (hpsa a (mem_cons_self a s)) hp_prod).trans (mul_le_mul_left' (hs hps) _),
end

@[to_additive le_sum_of_subadditive]
lemma le_prod_of_submultiplicative [comm_monoid α] [ordered_comm_monoid β]
  (f : α → β) (h_one : f 1 = 1) (h_mul : ∀ a b, f (a * b) ≤ f a * f b) (s : multiset α) :
  f s.prod ≤ (s.map f).prod :=
le_prod_of_submultiplicative_on_pred f (λ i, true) h_one trivial (λ x y _ _ , h_mul x y) (by simp)
  s (by simp)

@[to_additive le_sum_nonempty_of_subadditive_on_pred]
lemma le_prod_nonempty_of_submultiplicative_on_pred [comm_monoid α] [ordered_comm_monoid β]
  (f : α → β) (p : α → Prop) (h_mul : ∀ a b, p a → p b → f (a * b) ≤ f a * f b)
  (hp_mul : ∀ a b, p a → p b → p (a * b)) (s : multiset α) (hs_nonempty : s ≠ ∅)
  (hs : ∀ a, a ∈ s → p a) :
  f s.prod ≤ (s.map f).prod :=
begin
  revert s,
  refine multiset.induction _ _,
  { intro h,
    exfalso,
    exact h rfl },
  rintros a s hs hsa_nonempty hsa_prop,
  rw [prod_cons, map_cons, prod_cons],
  by_cases hs_empty : s = ∅,
  { simp [hs_empty] },
  have hsa_restrict : (∀ x, x ∈ s → p x), from λ x hx, hsa_prop x (mem_cons_of_mem hx),
  have hp_sup : p s.prod,
    from prod_induction_nonempty p hp_mul hs_empty hsa_restrict,
  have hp_a : p a, from hsa_prop a (mem_cons_self a s),
  exact (h_mul a _ hp_a hp_sup).trans (mul_le_mul_left' (hs hs_empty hsa_restrict) _),
end

@[to_additive le_sum_nonempty_of_subadditive]
lemma le_prod_nonempty_of_submultiplicative [comm_monoid α] [ordered_comm_monoid β]
  (f : α → β) (h_mul : ∀ a b, f (a * b) ≤ f a * f b) (s : multiset α) (hs_nonempty : s ≠ ∅) :
  f s.prod ≤ (s.map f).prod :=
le_prod_nonempty_of_submultiplicative_on_pred f (λ i, true) (by simp [h_mul]) (by simp) s
  hs_nonempty (by simp)

@[simp] lemma sum_map_singleton (s : multiset α) : (s.map (λ a, ({a} : multiset α))).sum = s :=
multiset.induction_on s (by simp) (by simp [singleton_eq_cons])

lemma abs_sum_le_sum_abs [linear_ordered_add_comm_group α] {s : multiset α} :
  abs s.sum ≤ (s.map abs).sum :=
le_sum_of_subadditive _ abs_zero abs_add s

end multiset

@[to_additive]
lemma map_multiset_prod [comm_monoid α] [comm_monoid β] {F : Type*} [monoid_hom_class F α β]
  (f : F) (s : multiset α) : f s.prod = (s.map f).prod :=
(s.prod_hom f).symm

@[to_additive]
protected lemma monoid_hom.map_multiset_prod [comm_monoid α] [comm_monoid β] (f : α →* β)
  (s : multiset α) : f s.prod = (s.map f).prod :=
(s.prod_hom f).symm


<|start_filename|>src/ring_theory/polynomial/cyclotomic/eval.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import ring_theory.polynomial.cyclotomic.basic
import tactic.by_contra
import topology.algebra.polynomial
import number_theory.padics.padic_val
import analysis.complex.arg

/-!
# Evaluating cyclotomic polynomials
This file states some results about evaluating cyclotomic polynomials in various different ways.
## Main definitions
* `polynomial.eval(₂)_one_cyclotomic_prime(_pow)`: `eval 1 (cyclotomic p^k R) = p`.
* `polynomial.eval_one_cyclotomic_not_prime_pow`: Otherwise, `eval 1 (cyclotomic n R) = 1`.
* `polynomial.cyclotomic_pos` : `∀ x, 0 < eval x (cyclotomic n R)` if `2 < n`.
-/

namespace polynomial

open finset nat
open_locale big_operators

@[simp] lemma eval_one_cyclotomic_prime {R : Type*} [comm_ring R] {p : ℕ} [hn : fact p.prime] :
  eval 1 (cyclotomic p R) = p :=
by simp only [cyclotomic_eq_geom_sum hn.out, eval_X, one_pow, sum_const, eval_pow,
              eval_finset_sum, card_range, smul_one_eq_coe]

@[simp] lemma eval₂_one_cyclotomic_prime {R S : Type*} [comm_ring R] [semiring S] (f : R →+* S)
  {p : ℕ} [fact p.prime] : eval₂ f 1 (cyclotomic p R) = p :=
by simp

@[simp] lemma eval_one_cyclotomic_prime_pow {R : Type*} [comm_ring R] {p : ℕ} (k : ℕ)
  [hn : fact p.prime] : eval 1 (cyclotomic (p ^ (k + 1)) R) = p :=
by simp only [cyclotomic_prime_pow_eq_geom_sum hn.out, eval_X, one_pow, sum_const,
              eval_pow, eval_finset_sum, card_range, smul_one_eq_coe]

@[simp] lemma eval₂_one_cyclotomic_prime_pow {R S : Type*} [comm_ring R] [semiring S] (f : R →+* S)
  {p : ℕ} (k : ℕ) [fact p.prime] : eval₂ f 1 (cyclotomic (p ^ (k + 1)) R) = p :=
by simp

private lemma cyclotomic_neg_one_pos {n : ℕ} (hn : 2 < n) {R} [linear_ordered_comm_ring R] :
  0 < eval (-1 : R) (cyclotomic n R) :=
begin
  haveI := ne_zero.of_gt hn,
  rw [←map_cyclotomic_int, ←int.cast_one, ←int.cast_neg, eval_int_cast_map,
      int.coe_cast_ring_hom, int.cast_pos],
  suffices : 0 < eval ↑(-1 : ℤ) (cyclotomic n ℝ),
  { rw [←map_cyclotomic_int n ℝ, eval_int_cast_map, int.coe_cast_ring_hom] at this,
    exact_mod_cast this },
  simp only [int.cast_one, int.cast_neg],
  have h0 := cyclotomic_coeff_zero ℝ hn.le,
  rw coeff_zero_eq_eval_zero at h0,
  by_contra' hx,
  have := intermediate_value_univ (-1) 0 (cyclotomic n ℝ).continuous,
  obtain ⟨y, hy : is_root _ y⟩ := this (show (0 : ℝ) ∈ set.Icc _ _, by simpa [h0] using hx),
  rw is_root_cyclotomic_iff at hy,
  rw hy.eq_order_of at hn,
  exact hn.not_le linear_ordered_ring.order_of_le_two,
end

lemma cyclotomic_pos {n : ℕ} (hn : 2 < n) {R} [linear_ordered_comm_ring R] (x : R) :
  0 < eval x (cyclotomic n R) :=
begin
  induction n using nat.strong_induction_on with n ih,
  have hn'  : 0 < n := pos_of_gt hn,
  have hn'' : 1 < n := one_lt_two.trans hn,
  dsimp at ih,
  have := prod_cyclotomic_eq_geom_sum hn' R,
  apply_fun eval x at this,
  rw [divisors_eq_proper_divisors_insert_self_of_pos hn', insert_sdiff_of_not_mem,
      prod_insert, eval_mul, eval_geom_sum] at this,
  rotate,
  { simp only [lt_self_iff_false, mem_sdiff, not_false_iff, mem_proper_divisors, and_false,
      false_and]},
  { simpa only [mem_singleton] using hn''.ne' },
  rcases lt_trichotomy 0 (∑ i in range n, x ^ i) with h | h | h,
  { apply pos_of_mul_pos_right,
    { rwa this },
    rw eval_prod,
    refine prod_nonneg (λ i hi, _),
    simp only [mem_sdiff, mem_proper_divisors, mem_singleton] at hi,
    rw geom_sum_pos_iff hn'' at h,
    cases h with hk hx,
    { refine (ih _ hi.1.2 (nat.two_lt_of_ne _ hi.2 _)).le; rintro rfl,
      { exact hn'.ne' (zero_dvd_iff.mp hi.1.1) },
      { exact even_iff_not_odd.mp (even_iff_two_dvd.mpr hi.1.1) hk } },
    { rcases eq_or_ne i 2 with rfl | hk,
      { simpa only [eval_X, eval_one, cyclotomic_two, eval_add] using hx.le },
      refine (ih _ hi.1.2 (nat.two_lt_of_ne _ hi.2 hk)).le,
      rintro rfl,
      exact (hn'.ne' $ zero_dvd_iff.mp hi.1.1) } },
  { rw [eq_comm, geom_sum_eq_zero_iff_neg_one hn''] at h,
    exact h.1.symm ▸ cyclotomic_neg_one_pos hn },
  { apply pos_of_mul_neg_left,
    { rwa this },
    rw [geom_sum_neg_iff hn''] at h,
    have h2 : {2} ⊆ n.proper_divisors \ {1},
    { rw [singleton_subset_iff, mem_sdiff, mem_proper_divisors, not_mem_singleton],
      exact ⟨⟨even_iff_two_dvd.mp h.1, hn⟩, (nat.one_lt_bit0 one_ne_zero).ne'⟩ },
    rw [eval_prod, ←prod_sdiff h2, prod_singleton]; try { apply_instance },
    apply mul_nonpos_of_nonneg_of_nonpos,
    { refine prod_nonneg (λ i hi, le_of_lt _),
      simp only [mem_sdiff, mem_proper_divisors, mem_singleton] at hi,
      refine ih _ hi.1.1.2 (nat.two_lt_of_ne _ hi.1.2 hi.2),
      rintro rfl,
      rw zero_dvd_iff at hi,
      exact hn'.ne' hi.1.1.1 },
    { simpa only [eval_X, eval_one, cyclotomic_two, eval_add] using h.right.le } }
end

lemma cyclotomic_pos_and_nonneg (n : ℕ) {R} [linear_ordered_comm_ring R] (x : R) :
  (1 < x → 0 < eval x (cyclotomic n R)) ∧ (1 ≤ x → 0 ≤ eval x (cyclotomic n R)) :=
begin
  rcases n with _ | _ | _ | n;
  simp only [cyclotomic_zero, cyclotomic_one, cyclotomic_two, succ_eq_add_one,
    eval_X, eval_one, eval_add, eval_sub, sub_nonneg, sub_pos,
    zero_lt_one, zero_le_one, implies_true_iff, imp_self, and_self],
  { split; intro; linarith, },
  { have : 2 < n + 3 := dec_trivial,
    split; intro; [skip, apply le_of_lt]; apply cyclotomic_pos this, },
end

/-- Cyclotomic polynomials are always positive on inputs larger than one.
Similar to `cyclotomic_pos` but with the condition on the input rather than index of the
cyclotomic polynomial. -/
lemma cyclotomic_pos' (n : ℕ) {R} [linear_ordered_comm_ring R] {x : R} (hx : 1 < x) :
  0 < eval x (cyclotomic n R) :=
(cyclotomic_pos_and_nonneg n x).1 hx

/-- Cyclotomic polynomials are always nonnegative on inputs one or more. -/
lemma cyclotomic_nonneg (n : ℕ) {R} [linear_ordered_comm_ring R] {x : R} (hx : 1 ≤ x) :
  0 ≤ eval x (cyclotomic n R) :=
(cyclotomic_pos_and_nonneg n x).2 hx

lemma eval_one_cyclotomic_not_prime_pow {R : Type*} [comm_ring R] {n : ℕ}
  (h : ∀ {p : ℕ}, p.prime → ∀ k : ℕ, p ^ k ≠ n) : eval 1 (cyclotomic n R) = 1 :=
begin
  rcases n.eq_zero_or_pos with rfl | hn',
  { simp },
  have hn : 1 < n := one_lt_iff_ne_zero_and_ne_one.mpr ⟨hn'.ne', (h nat.prime_two 0).symm⟩,
  suffices : eval 1 (cyclotomic n ℤ) = 1 ∨ eval 1 (cyclotomic n ℤ) = -1,
  { cases this with h h,
    { have := eval_int_cast_map (int.cast_ring_hom R) (cyclotomic n ℤ) 1,
      simpa only [map_cyclotomic, int.cast_one, h, ring_hom.eq_int_cast] using this },
    { exfalso,
      linarith [cyclotomic_nonneg n (le_refl (1 : ℤ))] }, },
  rw [←int.nat_abs_eq_nat_abs_iff, int.nat_abs_one, nat.eq_one_iff_not_exists_prime_dvd],
  intros p hp hpe,
  haveI := fact.mk hp,

  have hpn : p ∣ n,
  { apply hpe.trans,
    nth_rewrite 1 ←int.nat_abs_of_nat n,
    rw [int.nat_abs_dvd_iff_dvd, ←int.nat_cast_eq_coe_nat,
        ←one_geom_sum, ←eval_geom_sum, ←prod_cyclotomic_eq_geom_sum hn'],
    apply eval_dvd,
    apply finset.dvd_prod_of_mem,
    simpa using and.intro hn'.ne' hn.ne' },

  have := prod_cyclotomic_eq_geom_sum hn' ℤ,
  apply_fun eval 1 at this,
  rw [eval_geom_sum, one_geom_sum, eval_prod, eq_comm,
      ←finset.prod_sdiff $ range_pow_padic_val_nat_subset_divisors' p, finset.prod_image] at this,
  simp_rw [eval_one_cyclotomic_prime_pow, finset.prod_const, finset.card_range, mul_comm] at this,
  rw [←finset.prod_sdiff $ show {n} ⊆ _, from _] at this,
  any_goals {apply_instance},
  swap,
  { simp only [not_exists, true_and, exists_prop, dvd_rfl, finset.mem_image, finset.mem_range,
    finset.mem_singleton, finset.singleton_subset_iff, finset.mem_sdiff, nat.mem_divisors, not_and],
    exact ⟨⟨hn'.ne', hn.ne'⟩, λ t _, h hp _⟩ },
  rw [←int.nat_abs_of_nat p, int.nat_abs_dvd_iff_dvd] at hpe,
  obtain ⟨t, ht⟩ := hpe,
  rw [finset.prod_singleton, ht, mul_left_comm, mul_comm, ←mul_assoc, mul_assoc] at this,
  simp only [int.nat_cast_eq_coe_nat] at *,
  have : (p ^ (padic_val_nat p n) * p : ℤ) ∣ n := ⟨_, this⟩,
  simp only [←pow_succ', ←int.nat_abs_dvd_iff_dvd, int.nat_abs_of_nat, int.nat_abs_pow] at this,
  exact pow_succ_padic_val_nat_not_dvd hn' this,
  { rintro x - y - hxy,
    apply nat.succ_injective,
    exact nat.pow_right_injective hp.two_le hxy }
end

lemma sub_one_pow_totient_lt_cyclotomic_eval {n : ℕ} {q : ℝ} (hn' : 2 ≤ n) (hq' : 1 < q) :
  (q - 1) ^ totient n < (cyclotomic n ℝ).eval q :=
begin
  have hn : 0 < n := pos_of_gt hn',
  have hq := zero_lt_one.trans hq',
  have hfor : ∀ ζ' ∈ primitive_roots n ℂ, q - 1 ≤ ∥↑q - ζ'∥,
  { intros ζ' hζ',
    rw mem_primitive_roots hn at hζ',
    convert norm_sub_norm_le (↑q) ζ',
    { rw [complex.norm_real, real.norm_of_nonneg hq.le], },
    { rw [hζ'.norm'_eq_one hn.ne'] } },
  let ζ := complex.exp (2 * ↑real.pi * complex.I / ↑n),
  have hζ : is_primitive_root ζ n := complex.is_primitive_root_exp n hn.ne',
  have hex : ∃ ζ' ∈ primitive_roots n ℂ, q - 1 < ∥↑q - ζ'∥,
  { refine ⟨ζ, (mem_primitive_roots hn).mpr hζ, _⟩,
    suffices : ¬ same_ray ℝ (q : ℂ) ζ,
    { convert lt_norm_sub_of_not_same_ray this;
      simp [real.norm_of_nonneg hq.le, hζ.norm'_eq_one hn.ne'] },
    rw complex.same_ray_iff,
    push_neg,
    refine ⟨by exact_mod_cast hq.ne', hζ.ne_zero hn.ne', _⟩,
    rw [complex.arg_of_real_of_nonneg hq.le, ne.def, eq_comm, hζ.arg_eq_zero_iff hn.ne'],
    clear_value ζ,
    rintro rfl,
    linarith [hζ.unique is_primitive_root.one] },
  have : ¬eval ↑q (cyclotomic n ℂ) = 0,
  { erw cyclotomic.eval_apply q n (algebra_map ℝ ℂ),
    simpa using (cyclotomic_pos' n hq').ne' },
  suffices : (units.mk0 (real.to_nnreal (q - 1)) (by simp [hq'])) ^ totient n
              < units.mk0 (∥(cyclotomic n ℂ).eval q∥₊) (by simp [this]),
  { simp only [←units.coe_lt_coe, units.coe_pow, units.coe_mk0, ← nnreal.coe_lt_coe, hq'.le,
               real.to_nnreal_lt_to_nnreal_iff_of_nonneg, coe_nnnorm, complex.norm_eq_abs,
               nnreal.coe_pow, real.coe_to_nnreal', max_eq_left, sub_nonneg] at this,
    convert this,
    erw [(cyclotomic.eval_apply q n (algebra_map ℝ ℂ)), eq_comm],
    simp [cyclotomic_nonneg n hq'.le], },
  simp only [cyclotomic_eq_prod_X_sub_primitive_roots hζ, eval_prod, eval_C,
             eval_X, eval_sub, nnnorm_prod, units.mk0_prod],
  convert prod_lt_prod' _ _,
  swap, { exact λ _, units.mk0 (real.to_nnreal (q - 1)) (by simp [hq']) },
  { simp [complex.card_primitive_roots] },
  { simp only [subtype.coe_mk, mem_attach, forall_true_left, subtype.forall, ←units.coe_le_coe,
      ← nnreal.coe_le_coe, complex.abs_nonneg, hq'.le, units.coe_mk0, real.coe_to_nnreal',
      coe_nnnorm, complex.norm_eq_abs, max_le_iff, tsub_le_iff_right],
    intros x hx,
    simpa using hfor x hx, },
  { simp only [subtype.coe_mk, mem_attach, exists_true_left, subtype.exists,
      ← nnreal.coe_lt_coe, ← units.coe_lt_coe, units.coe_mk0 _, coe_nnnorm],
    simpa [hq'.le] using hex, },
end

lemma cyclotomic_eval_lt_sub_one_pow_totient {n : ℕ} {q : ℝ} (hn' : 3 ≤ n) (hq' : 1 < q) :
  (cyclotomic n ℝ).eval q < (q + 1) ^ totient n :=
begin
  have hn : 0 < n := pos_of_gt hn',
  have hq := zero_lt_one.trans hq',
  have hfor : ∀ ζ' ∈ primitive_roots n ℂ, ∥↑q - ζ'∥ ≤ q + 1,
  { intros ζ' hζ',
    rw mem_primitive_roots hn at hζ',
    convert norm_sub_le (↑q) ζ',
    { rw [complex.norm_real, real.norm_of_nonneg (zero_le_one.trans_lt hq').le], },
    { rw [hζ'.norm'_eq_one hn.ne'] }, },
  let ζ := complex.exp (2 * ↑real.pi * complex.I / ↑n),
  have hζ : is_primitive_root ζ n := complex.is_primitive_root_exp n hn.ne',
  have hex : ∃ ζ' ∈ primitive_roots n ℂ, ∥↑q - ζ'∥ < q + 1,
  { refine ⟨ζ, (mem_primitive_roots hn).mpr hζ, _⟩,
    suffices : ¬ same_ray ℝ (q : ℂ) (-ζ),
    { convert norm_add_lt_of_not_same_ray this;
      simp [real.norm_of_nonneg hq.le, hζ.norm'_eq_one hn.ne', -complex.norm_eq_abs] },
    rw complex.same_ray_iff,
    push_neg,
    refine ⟨by exact_mod_cast hq.ne', neg_ne_zero.mpr $ hζ.ne_zero hn.ne', _⟩,
    rw [complex.arg_of_real_of_nonneg hq.le, ne.def, eq_comm],
    intro h,
    rw [complex.arg_eq_zero_iff, complex.neg_re, neg_nonneg, complex.neg_im, neg_eq_zero] at h,
    have hζ₀ : ζ ≠ 0,
    { clear_value ζ,
      rintro rfl,
      exact hn.ne' (hζ.unique is_primitive_root.zero) },
    have : ζ.re < 0 ∧ ζ.im = 0 := ⟨h.1.lt_of_ne _, h.2⟩,
    rw [←complex.arg_eq_pi_iff, hζ.arg_eq_pi_iff hn.ne'] at this,
    rw this at hζ,
    linarith [hζ.unique $ is_primitive_root.neg_one 0 two_ne_zero.symm],
    { contrapose! hζ₀,
      ext; simp [hζ₀, h.2] } },
  have : ¬eval ↑q (cyclotomic n ℂ) = 0,
  { erw cyclotomic.eval_apply q n (algebra_map ℝ ℂ),
    simp only [complex.coe_algebra_map, complex.of_real_eq_zero],
    exact (cyclotomic_pos' n hq').ne.symm, },
  suffices : units.mk0 (∥(cyclotomic n ℂ).eval q∥₊) (by simp [this])
           < (units.mk0 (real.to_nnreal (q + 1)) (by simp; linarith)) ^ totient n,
  { simp only [←units.coe_lt_coe, units.coe_pow, units.coe_mk0, ← nnreal.coe_lt_coe, hq'.le,
               real.to_nnreal_lt_to_nnreal_iff_of_nonneg, coe_nnnorm, complex.norm_eq_abs,
               nnreal.coe_pow, real.coe_to_nnreal', max_eq_left, sub_nonneg] at this,
    convert this,
    { erw [(cyclotomic.eval_apply q n (algebra_map ℝ ℂ)), eq_comm],
      simp [cyclotomic_nonneg n hq'.le] },
    rw [eq_comm, max_eq_left_iff],
    linarith },
  simp only [cyclotomic_eq_prod_X_sub_primitive_roots hζ, eval_prod, eval_C,
             eval_X, eval_sub, nnnorm_prod, units.mk0_prod],
  convert prod_lt_prod' _ _,
  swap, { exact λ _, units.mk0 (real.to_nnreal (q + 1)) (by simp; linarith only [hq']) },
  { simp [complex.card_primitive_roots], },
  { simp only [subtype.coe_mk, mem_attach, forall_true_left, subtype.forall, ←units.coe_le_coe,
      ← nnreal.coe_le_coe, complex.abs_nonneg, hq'.le, units.coe_mk0, real.coe_to_nnreal,
      coe_nnnorm, complex.norm_eq_abs, max_le_iff],
    intros x hx,
    have : complex.abs _ ≤ _ := hfor x hx,
    simp [this], },
  { simp only [subtype.coe_mk, mem_attach, exists_true_left, subtype.exists,
      ← nnreal.coe_lt_coe, ← units.coe_lt_coe, units.coe_mk0 _, coe_nnnorm],
    obtain ⟨ζ, hζ, hhζ : complex.abs _ < _⟩ := hex,
    exact ⟨ζ, hζ, by simp [hhζ]⟩ },
end

lemma sub_one_lt_nat_abs_cyclotomic_eval {n : ℕ} {q : ℕ} (hn' : 1 < n) (hq' : q ≠ 1) :
  q - 1 < ((cyclotomic n ℤ).eval ↑q).nat_abs :=
begin
  rcases q with _ | _ | q,
  iterate 2
  { rw [pos_iff_ne_zero, ne.def, int.nat_abs_eq_zero],
    intro h,
    have := degree_eq_one_of_irreducible_of_root (cyclotomic.irreducible (pos_of_gt hn')) h,
    rw [degree_cyclotomic, with_top.coe_eq_one, totient_eq_one_iff] at this,
    rcases this with rfl|rfl; simpa using h },
  suffices : (q.succ : ℝ) < (eval (↑q + 1 + 1) (cyclotomic n ℤ)).nat_abs,
  { exact_mod_cast this },
  calc _ ≤ ((q + 2 - 1) ^ n.totient : ℝ) : _
    ...  < _ : _,
  { norm_num,
    convert pow_mono (by simp : 1 ≤ (q : ℝ) + 1) (totient_pos (pos_of_gt hn') : 1 ≤ n.totient),
    { simp },
    { ring }, },
  convert sub_one_pow_totient_lt_cyclotomic_eval (show 2 ≤ n, by linarith)
                          (show (1 : ℝ) < q + 2, by {norm_cast, linarith}),
  norm_cast,
  erw cyclotomic.eval_apply (q + 2 : ℤ) n (algebra_map ℤ ℝ),
  simp only [int.coe_nat_succ, ring_hom.eq_int_cast],
  norm_cast,
  rw [int.coe_nat_abs_eq_normalize, int.normalize_of_nonneg],
  simp only [int.coe_nat_succ],
  exact cyclotomic_nonneg n (by linarith),
end

end polynomial


<|start_filename|>src/category_theory/elements.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.structured_arrow
import category_theory.groupoid
import category_theory.punit

/-!
# The category of elements

This file defines the category of elements, also known as (a special case of) the Grothendieck
construction.

Given a functor `F : C ⥤ Type`, an object of `F.elements` is a pair `(X : C, x : F.obj X)`.
A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.

## Implementation notes

This construction is equivalent to a special case of a comma construction, so this is mostly just a
more convenient API. We prove the equivalence in
`category_theory.category_of_elements.structured_arrow_equivalence`.

## References
* [<NAME>, *Category Theory in Context*, Section 2.4][riehl2017]
* <https://en.wikipedia.org/wiki/Category_of_elements>
* <https://ncatlab.org/nlab/show/category+of+elements>

## Tags
category of elements, Grothendieck construction, comma category
-/

namespace category_theory

universes w v u
variables {C : Type u} [category.{v} C]

/--
The type of objects for the category of elements of a functor `F : C ⥤ Type`
is a pair `(X : C, x : F.obj X)`.
-/
@[nolint has_inhabited_instance]
def functor.elements (F : C ⥤ Type w) := (Σ c : C, F.obj c)

/-- The category structure on `F.elements`, for `F : C ⥤ Type`.
    A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.
 -/
instance category_of_elements (F : C ⥤ Type w) : category.{v} F.elements :=
{ hom := λ p q, { f : p.1 ⟶ q.1 // (F.map f) p.2 = q.2 },
  id := λ p, ⟨𝟙 p.1, by obviously⟩,
  comp := λ p q r f g, ⟨f.val ≫ g.val, by obviously⟩ }

namespace category_of_elements

@[ext]
lemma ext (F : C ⥤ Type w) {x y : F.elements} (f g : x ⟶ y) (w : f.val = g.val) : f = g :=
subtype.ext_val w

@[simp] lemma comp_val {F : C ⥤ Type w} {p q r : F.elements} {f : p ⟶ q} {g : q ⟶ r} :
  (f ≫ g).val = f.val ≫ g.val := rfl

@[simp] lemma id_val {F : C ⥤ Type w} {p : F.elements} : (𝟙 p : p ⟶ p).val = 𝟙 p.1 := rfl

end category_of_elements

noncomputable
instance groupoid_of_elements {G : Type u} [groupoid.{v} G] (F : G ⥤ Type w) :
  groupoid F.elements :=
{ inv := λ p q f, ⟨inv f.val,
    calc F.map (inv f.val) q.2 = F.map (inv f.val) (F.map f.val p.2) : by rw f.2
                           ... = (F.map f.val ≫ F.map (inv f.val)) p.2 : rfl
                           ... = p.2 : by {rw ← F.map_comp, simp} ⟩,
  inv_comp' := λ _ _ _, by { ext, simp },
  comp_inv' := λ _ _ _, by { ext, simp } }

namespace category_of_elements
variable (F : C ⥤ Type w)

/-- The functor out of the category of elements which forgets the element. -/
@[simps]
def π : F.elements ⥤ C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.val }

/--
A natural transformation between functors induces a functor between the categories of elements.
-/
@[simps]
def map {F₁ F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) : F₁.elements ⥤ F₂.elements :=
{ obj := λ t, ⟨t.1, α.app t.1 t.2⟩,
  map := λ t₁ t₂ k, ⟨k.1, by simpa [←k.2] using (functor_to_types.naturality _ _ α k.1 t₁.2).symm⟩ }

@[simp] lemma map_π {F₁ F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) : map α ⋙ π F₂ = π F₁ := rfl

/-- The forward direction of the equivalence `F.elements ≅ (*, F)`. -/
def to_structured_arrow : F.elements ⥤ structured_arrow punit F :=
{ obj := λ X, structured_arrow.mk (λ _, X.2),
  map := λ X Y f, structured_arrow.hom_mk f.val (by tidy) }

@[simp] lemma to_structured_arrow_obj (X) :
  (to_structured_arrow F).obj X = { left := ⟨⟨⟩⟩, right := X.1, hom := λ _, X.2 } := rfl
@[simp] lemma to_comma_map_right {X Y} (f : X ⟶ Y) :
  ((to_structured_arrow F).map f).right = f.val := rfl

/-- The reverse direction of the equivalence `F.elements ≅ (*, F)`. -/
def from_structured_arrow : structured_arrow punit F ⥤ F.elements :=
{ obj := λ X, ⟨X.right, X.hom (punit.star)⟩,
  map := λ X Y f, ⟨f.right, congr_fun f.w'.symm punit.star⟩ }

@[simp] lemma from_structured_arrow_obj (X) :
  (from_structured_arrow F).obj X = ⟨X.right, X.hom (punit.star)⟩ := rfl
@[simp] lemma from_structured_arrow_map {X Y} (f : X ⟶ Y) :
  (from_structured_arrow F).map f = ⟨f.right, congr_fun f.w'.symm punit.star⟩ := rfl

/-- The equivalence between the category of elements `F.elements`
    and the comma category `(*, F)`. -/
@[simps]
def structured_arrow_equivalence : F.elements ≌ structured_arrow punit F :=
equivalence.mk (to_structured_arrow F) (from_structured_arrow F)
  (nat_iso.of_components (λ X, eq_to_iso (by tidy)) (by tidy))
  (nat_iso.of_components
    (λ X, { hom := { right := 𝟙 _ }, inv := { right := 𝟙 _ } })
    (by tidy))

open opposite

/--
The forward direction of the equivalence `F.elementsᵒᵖ ≅ (yoneda, F)`,
given by `category_theory.yoneda_sections`.
-/
@[simps]
def to_costructured_arrow (F : Cᵒᵖ ⥤ Type v) : (F.elements)ᵒᵖ ⥤ costructured_arrow yoneda F :=
{ obj := λ X, costructured_arrow.mk
    ((yoneda_sections (unop (unop X).fst) F).inv (ulift.up (unop X).2)),
  map := λ X Y f,
  begin
    fapply costructured_arrow.hom_mk,
    exact f.unop.val.unop,
    ext y,
    simp only [costructured_arrow.mk_hom_eq_self, yoneda_map_app, functor_to_types.comp, op_comp,
      yoneda_sections_inv_app, functor_to_types.map_comp_apply, quiver.hom.op_unop,
      subtype.val_eq_coe],
    congr,
    exact f.unop.2,
  end }

/--
The reverse direction of the equivalence `F.elementsᵒᵖ ≅ (yoneda, F)`,
given by `category_theory.yoneda_equiv`.
-/
@[simps]
def from_costructured_arrow (F : Cᵒᵖ ⥤ Type v) : (costructured_arrow yoneda F)ᵒᵖ ⥤ F.elements :=
{ obj := λ X, ⟨op (unop X).1, yoneda_equiv.1 (unop X).3⟩,
  map := λ X Y f, ⟨f.unop.1.op,
  begin
    convert (congr_fun ((unop X).hom.naturality f.unop.left.op) (𝟙 _)).symm,
    simp only [equiv.to_fun_as_coe, quiver.hom.unop_op, yoneda_equiv_apply,
      types_comp_apply, category.comp_id, yoneda_obj_map],
    have : yoneda.map f.unop.left ≫ (unop X).hom = (unop Y).hom,
    { convert f.unop.3, erw category.comp_id },
    erw ← this,
    simp only [yoneda_map_app, functor_to_types.comp],
    erw category.id_comp
  end ⟩}

@[simp]
lemma from_costructured_arrow_obj_mk (F : Cᵒᵖ ⥤ Type v) {X : C} (f : yoneda.obj X ⟶ F) :
  (from_costructured_arrow F).obj (op (costructured_arrow.mk f)) = ⟨op X, yoneda_equiv.1 f⟩ := rfl

/-- The unit of the equivalence `F.elementsᵒᵖ ≅ (yoneda, F)` is indeed iso. -/
lemma from_to_costructured_arrow_eq (F : Cᵒᵖ ⥤ Type v) :
 (to_costructured_arrow F).right_op ⋙ from_costructured_arrow F = 𝟭 _ :=
begin
  apply functor.ext,
  intros X Y f,
  have : ∀ {a b : F.elements} (H : a = b),
    ↑(eq_to_hom H) = eq_to_hom (show a.fst = b.fst, by { cases H, refl }) :=
    λ _ _ H, by { cases H, refl },
  ext, simp[this],
  tidy
end

/-- The counit of the equivalence `F.elementsᵒᵖ ≅ (yoneda, F)` is indeed iso. -/
lemma to_from_costructured_arrow_eq (F : Cᵒᵖ ⥤ Type v) :
  (from_costructured_arrow F).right_op ⋙ to_costructured_arrow F = 𝟭 _ :=
begin
  apply functor.hext,
  { intro X, cases X, cases X_right,
    simp only [functor.id_obj, functor.right_op_obj,
      to_costructured_arrow_obj, functor.comp_obj, costructured_arrow.mk],
    congr,
    ext x f,
    convert congr_fun (X_hom.naturality f.op).symm (𝟙 X_left),
    simp only [quiver.hom.unop_op, yoneda_obj_map],
    erw category.comp_id },
  intros X Y f,
  rcases X with ⟨X_left, ⟨⟨⟩⟩⟩, rcases Y with ⟨Y_left, ⟨⟨⟩⟩⟩, cases f,
  simp [costructured_arrow.hom_mk],
  delta costructured_arrow.mk,
  congr,
  { ext x f,
    convert congr_fun (X_hom.naturality f.op).symm (𝟙 X_left),
    simp only [quiver.hom.unop_op, category_theory.yoneda_obj_map],
    erw category.comp_id },
  { ext x f,
    convert congr_fun (Y_hom.naturality f.op).symm (𝟙 Y_left),
    simp only [quiver.hom.unop_op, category_theory.yoneda_obj_map],
    erw category.comp_id },
  simp,
  exact proof_irrel_heq _ _,
end


/-- The equivalence `F.elementsᵒᵖ ≅ (yoneda, F)` given by yoneda lemma. -/
@[simps] def costructured_arrow_yoneda_equivalence (F : Cᵒᵖ ⥤ Type v) :
  (F.elements)ᵒᵖ ≌ costructured_arrow yoneda F :=
equivalence.mk (to_costructured_arrow F) (from_costructured_arrow F).right_op
  (nat_iso.op (eq_to_iso (from_to_costructured_arrow_eq F)))
  (eq_to_iso $ to_from_costructured_arrow_eq F)

/--
The equivalence `(-.elements)ᵒᵖ ≅ (yoneda, -)` of is actually a natural isomorphism of functors.
-/
lemma costructured_arrow_yoneda_equivalence_naturality {F₁ F₂ : Cᵒᵖ ⥤ Type v}
  (α : F₁ ⟶ F₂) : (map α).op ⋙ to_costructured_arrow F₂ =
    to_costructured_arrow F₁ ⋙ costructured_arrow.map α :=
begin
  fapply functor.ext,
  { intro X,
    simp only [costructured_arrow.map_mk, to_costructured_arrow_obj,
      functor.op_obj, functor.comp_obj],
    congr,
    ext x f,
    simpa using congr_fun (α.naturality f.op).symm (unop X).snd },
  { intros X Y f, ext,
    have : ∀ {F : Cᵒᵖ ⥤ Type v} {a b : costructured_arrow yoneda F} (H : a = b),
      comma_morphism.left (eq_to_hom H) = eq_to_hom (show a.left = b.left, by { cases H, refl }) :=
      λ _ _ _ H, by { cases H, refl },
    simp [this] }
end

end category_of_elements
end category_theory


<|start_filename|>src/topology/inseparable.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import topology.constructions

/-!
# Inseparable points

In this file we require two relations on a topological space: `specializes` (notation : `x ⤳ y`) and
`inseparable`, then prove some basic lemmas about these relations.

## Main definitions

* `specializes` : `specializes x y` (`x ⤳ y`) means that `x` specializes to `y`, i.e.
  `y` is in the closure of `x`.

* `specialization_preorder` : specialization gives a preorder on a topological space. In case of a
  T₀ space, this preorder is a partial order, see `specialization_order`.

* `inseparable x y` means that two points can't be separated by an open set.
-/

open_locale topological_space
open set

variables {X Y : Type*} [topological_space X] [topological_space Y] {x y z : X}

/-- `x` specializes to `y` if `y` is in the closure of `x`. The notation used is `x ⤳ y`. -/
def specializes (x y : X) : Prop := y ∈ closure ({x} : set X)

infix ` ⤳ `:300 := specializes

lemma specializes_def (x y : X) : x ⤳ y ↔ y ∈ closure ({x} : set X) := iff.rfl

lemma specializes_iff_closure_subset : x ⤳ y ↔ closure ({y} : set X) ⊆ closure ({x} : set X) :=
is_closed_closure.mem_iff_closure_subset

lemma specializes_rfl : x ⤳ x := subset_closure (mem_singleton x)

lemma specializes_refl (x : X) : x ⤳ x := specializes_rfl

lemma specializes.trans : x ⤳ y → y ⤳ z → x ⤳ z :=
by { simp_rw specializes_iff_closure_subset, exact λ a b, b.trans a }

lemma specializes_iff_forall_closed :
  x ⤳ y ↔ ∀ (Z : set X) (h : is_closed Z), x ∈ Z → y ∈ Z :=
begin
  split,
  { intros h Z hZ,
    rw [hZ.mem_iff_closure_subset, hZ.mem_iff_closure_subset],
    exact (specializes_iff_closure_subset.mp h).trans },
  { intro h, exact h _ is_closed_closure (subset_closure $ set.mem_singleton x) }
end

lemma specializes_iff_forall_open :
  x ⤳ y ↔ ∀ (U : set X) (h : is_open U), y ∈ U → x ∈ U :=
begin
  rw specializes_iff_forall_closed,
  exact ⟨λ h U hU, not_imp_not.mp (h _ (is_closed_compl_iff.mpr hU)),
    λ h U hU, not_imp_not.mp (h _ (is_open_compl_iff.mpr hU))⟩,
end

lemma specializes.map (h : x ⤳ y) {f : X → Y} (hf : continuous f) : f x ⤳ f y :=
begin
  rw [specializes_def, ← set.image_singleton],
  exact image_closure_subset_closure_image hf ⟨_, h, rfl⟩,
end

section specialize_order

variable (X)

/-- Specialization forms a preorder on the topological space. -/
def specialization_preorder : preorder X :=
{ le := λ x y, y ⤳ x,
  le_refl := λ x, specializes_refl x,
  le_trans := λ _ _ _ h₁ h₂, specializes.trans h₂ h₁ }

local attribute [instance] specialization_preorder

variable {X}

lemma specialization_order.monotone_of_continuous (f : X → Y) (hf : continuous f) : monotone f :=
λ x y h, specializes.map h hf

end specialize_order

/-- Two points are topologically inseparable if no open set separates them. -/
def inseparable (x y : X) : Prop := ∀ (U : set X) (hU : is_open U), x ∈ U ↔ y ∈ U

lemma inseparable_iff_nhds_eq : inseparable x y ↔ 𝓝 x = 𝓝 y :=
⟨λ h, by simp only [nhds_def', h _] { contextual := tt },
  λ h U hU, by simp only [← hU.mem_nhds_iff, h]⟩

alias inseparable_iff_nhds_eq ↔ inseparable.nhds_eq _

lemma inseparable.map {f : X → Y} (h : inseparable x y) (hf : continuous f) :
  inseparable (f x) (f y) :=
λ U hU, h (f ⁻¹' U) (hU.preimage hf)

lemma inseparable_iff_closed :
  inseparable x y ↔ ∀ (U : set X) (hU : is_closed U), x ∈ U ↔ y ∈ U :=
⟨λ h U hU, not_iff_not.mp (h _ hU.1), λ h U hU, not_iff_not.mp (h _ (is_closed_compl_iff.mpr hU))⟩

lemma inseparable_iff_closure (x y : X) :
  inseparable x y ↔ x ∈ closure ({y} : set X) ∧ y ∈ closure ({x} : set X) :=
begin
  rw inseparable_iff_closed,
  exact ⟨λ h, ⟨(h _ is_closed_closure).mpr (subset_closure $ set.mem_singleton y),
      (h _ is_closed_closure).mp (subset_closure $ set.mem_singleton x)⟩,
    λ h U hU, ⟨λ hx, (is_closed.closure_subset_iff hU).mpr (set.singleton_subset_iff.mpr hx) h.2,
      λ hy, (is_closed.closure_subset_iff hU).mpr (set.singleton_subset_iff.mpr hy) h.1⟩⟩
end

lemma inseparable_iff_specializes_and (x y : X) :
  inseparable x y ↔ x ⤳ y ∧ y ⤳ x :=
(inseparable_iff_closure x y).trans (and_comm _ _)

lemma subtype_inseparable_iff {U : set X} (x y : U) :
  inseparable x y ↔ inseparable (x : X) y :=
by { simp_rw [inseparable_iff_closure, closure_subtype, image_singleton] }


<|start_filename|>archive/100-theorems-list/30_ballot_problem.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>, <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import probability.cond_count

/-!
# Ballot problem

This file proves Theorem 30 from the [100 Theorems List](https://www.cs.ru.nl/~freek/100/).

The ballot problem asks, if in an election, candidate A receives `p` votes whereas candidate B
receives `q` votes where `p > q`, what is the probability that candidate A is strictly ahead
throughout the count. The probability of this is `(p - q) / (p + q)`.

## Main definitions

* `counted_sequence`: given natural numbers `p` and `q`, `counted_sequence p q` is the set of
  all lists containing `p` of `1`s and `q` of `-1`s representing the votes of candidate A and B
  respectively.
* `stays_positive`: is the set of lists of integers which suffix has positive sum. In particular,
  the intersection of this set with `counted_sequence` is the set of lists where candidate A is
  strictly ahead.

## Main result

* `ballot`: the ballot problem.

-/

open set probability_theory measure_theory

namespace ballot

/-- The set of nonempty lists of integers which suffix has positive sum. -/
def stays_positive : set (list ℤ) := {l | ∀ l₂, l₂ ≠ [] → l₂ <:+ l → 0 < l₂.sum}

@[simp] lemma stays_positive_nil : [] ∈ stays_positive :=
λ l hl hl₁, (hl (list.eq_nil_of_suffix_nil hl₁)).elim

lemma stays_positive_cons_pos (x : ℤ) (hx : 0 < x) (l : list ℤ) :
  (x :: l) ∈ stays_positive ↔ l ∈ stays_positive :=
begin
  split,
  { intros hl l₁ hl₁ hl₂,
    apply hl l₁ hl₁ (hl₂.trans (list.suffix_cons _ _)) },
  { intros hl l₁ hl₁ hl₂,
    rw list.suffix_cons_iff at hl₂,
    rcases hl₂ with (rfl | hl₂),
    { rw list.sum_cons,
      apply add_pos_of_pos_of_nonneg hx,
      cases l with hd tl,
      { simp },
      { apply le_of_lt (hl (hd :: tl) (list.cons_ne_nil hd tl) (hd :: tl).suffix_refl) } },
    { apply hl _ hl₁ hl₂ } }
end

/--
`counted_sequence p q` is the set of lists of integers for which every element is `+1` or `-1`,
there are `p` lots of `+1` and `q` lots of `-1`.

This represents vote sequences where candidate `+1` receives `p` votes and candidate `-1` receives
`q` votes.
-/
def counted_sequence (p q : ℕ) : set (list ℤ) :=
{l | l.count 1 = p ∧ l.count (-1) = q ∧ ∀ x ∈ l, x = (1 : ℤ) ∨ x = -1}

@[simp] lemma counted_right_zero (p : ℕ) : counted_sequence p 0 = {list.repeat 1 p} :=
begin
  ext l,
  rw [counted_sequence, mem_singleton_iff],
  split,
  { rintro ⟨hl₀, hl₁, hl₂⟩,
    rw list.eq_repeat,
    have : ∀ x ∈ l, (1 : ℤ) = x,
    { intros x hx,
      obtain rfl | rfl := hl₂ x hx,
      { refl },
      { exact false.elim (list.not_mem_of_count_eq_zero hl₁ hx) } },
    split,
    { rwa ← list.count_eq_length.2 this },
    { exact λ x hx, (this x hx).symm } },
  { rintro rfl,
    simp only [mem_set_of_eq, list.count_repeat, eq_self_iff_true, true_and],
    refine ⟨list.count_eq_zero_of_not_mem _, λ x, _⟩; rw list.mem_repeat,
    { norm_num },
    { rintro ⟨-, rfl⟩,
      exact or.inl rfl } }
end

@[simp] lemma counted_left_zero (q : ℕ) : counted_sequence 0 q = {list.repeat (-1) q} :=
begin
  ext l,
  rw [counted_sequence, mem_singleton_iff],
  split,
  { rintro ⟨hl₀, hl₁, hl₂⟩,
    rw list.eq_repeat,
    have : ∀ x ∈ l, (-1 : ℤ) = x,
    { intros x hx,
      obtain rfl | rfl := hl₂ x hx,
      { exact false.elim (list.not_mem_of_count_eq_zero hl₀ hx) },
      { refl } },
    split,
    { rwa ← list.count_eq_length.2 this },
    { exact λ x hx, (this x hx).symm } },
  { rintro rfl,
    simp only [mem_set_of_eq, list.count_repeat, eq_self_iff_true, true_and],
    refine ⟨list.count_eq_zero_of_not_mem _, λ x, _⟩; rw list.mem_repeat,
    { norm_num },
    { rintro ⟨-, rfl⟩,
      exact or.inr rfl } }
end

lemma counted_ne_nil_left {p q : ℕ} (hp : p ≠ 0) {l : list ℤ} (hl : l ∈ counted_sequence p q) :
  l ≠ list.nil :=
begin
  obtain ⟨hl₀, hl₁, hl₂⟩ := hl,
  rintro rfl,
  rw list.count_nil at hl₀,
  exact hp hl₀.symm,
end

lemma counted_ne_nil_right {p q : ℕ} (hp : q ≠ 0) {l : list ℤ} (hl : l ∈ counted_sequence p q) :
  l ≠ list.nil :=
begin
  obtain ⟨hl₀, hl₁, hl₂⟩ := hl,
  rintro rfl,
  rw list.count_nil at hl₁,
  exact hp hl₁.symm,
end

lemma counted_succ_succ (p q : ℕ) : counted_sequence (p + 1) (q + 1) =
  (counted_sequence p (q + 1)).image (list.cons 1) ∪
  (counted_sequence (p + 1) q).image (list.cons (-1)) :=
begin
  ext l,
  rw [counted_sequence, counted_sequence, counted_sequence],
  split,
  { intro hl,
    have hlnil := counted_ne_nil_left (nat.succ_ne_zero p) hl,
    obtain ⟨hl₀, hl₁, hl₂⟩ := hl,
    obtain hlast | hlast := hl₂ l.head (list.head_mem_self hlnil),
    { refine or.inl ⟨l.tail, ⟨_, _, _⟩, _⟩,
      { rw [list.count_tail l 1 (list.length_pos_of_ne_nil hlnil), hl₀, if_pos,
          nat.add_succ_sub_one, add_zero],
        rw [list.nth_le_zero, hlast] },
      { rw [list.count_tail l (-1) (list.length_pos_of_ne_nil hlnil), hl₁, if_neg, nat.sub_zero],
        rw [list.nth_le_zero, hlast],
        norm_num },
      { exact λ x hx, hl₂ x (list.mem_of_mem_tail hx) },
      { rw [← hlast, list.cons_head_tail hlnil] } },
    { refine or.inr ⟨l.tail, ⟨_, _, _⟩, _⟩,
      { rw [list.count_tail l 1 (list.length_pos_of_ne_nil hlnil), hl₀, if_neg, nat.sub_zero],
        rw [list.nth_le_zero, hlast],
        norm_num },
      { rw [list.count_tail l (-1) (list.length_pos_of_ne_nil hlnil), hl₁, if_pos,
          nat.add_succ_sub_one, add_zero],
        rw [list.nth_le_zero, hlast] },
      { exact λ x hx, hl₂ x (list.mem_of_mem_tail hx) },
      { rw [← hlast, list.cons_head_tail hlnil] } } },
  { rintro (⟨t, ⟨ht₀, ht₁, ht₂⟩, rfl⟩ | ⟨t, ⟨ht₀, ht₁, ht₂⟩, rfl⟩),
    { refine ⟨_, _, _⟩,
      { rw [list.count_cons, if_pos rfl, ht₀] },
      { rw [list.count_cons, if_neg, ht₁],
        norm_num },
      { rintro x (hx | hx),
        exacts [or.inl hx, ht₂ x hx] } },
    { refine ⟨_, _, _⟩,
      { rw [list.count_cons, if_neg, ht₀],
        norm_num },
      { rw [list.count_cons, if_pos rfl, ht₁] },
      { rintro x (hx | hx),
        exacts [or.inr hx, ht₂ x hx] } } }
end

lemma counted_sequence_finite : ∀ (p q : ℕ), (counted_sequence p q).finite
| 0 q := by simp
| (p + 1) 0 := by simp
| (p + 1) (q + 1) :=
  begin
    rw [counted_succ_succ, set.finite_union, set.finite_image_iff (list.cons_injective.inj_on _),
      set.finite_image_iff (list.cons_injective.inj_on _)],
    exact ⟨counted_sequence_finite _ _, counted_sequence_finite _ _⟩
  end

lemma counted_sequence_nonempty : ∀ (p q : ℕ), (counted_sequence p q).nonempty
| 0 q := by simp
| (p + 1) 0 := by simp
| (p + 1) (q + 1) :=
  begin
    rw [counted_succ_succ, union_nonempty, nonempty_image_iff],
    exact or.inl (counted_sequence_nonempty _ _),
  end

lemma sum_of_mem_counted_sequence :
  ∀ {p q : ℕ} {l : list ℤ} (hl : l ∈ counted_sequence p q), l.sum = p - q
| 0 q l hl :=
  begin
    rw [counted_left_zero, mem_singleton_iff] at hl,
    simp [hl],
  end
| p 0 l hl :=
  begin
    rw [counted_right_zero, mem_singleton_iff] at hl,
    simp [hl],
  end
| (p + 1) (q + 1) l hl :=
  begin
    simp only [counted_succ_succ, mem_union, mem_image] at hl,
    rcases hl with (⟨l, hl, rfl⟩ | ⟨l, hl, rfl⟩),
    { rw [list.sum_cons, sum_of_mem_counted_sequence hl],
      push_cast,
      ring },
    { rw [list.sum_cons, sum_of_mem_counted_sequence hl],
      push_cast,
      ring }
  end

lemma mem_of_mem_counted_sequence :
  ∀ {p q : ℕ} {l} (hl : l ∈ counted_sequence p q) {x : ℤ} (hx : x ∈ l), x = 1 ∨ x = -1
| 0 q l hl x hx :=
  begin
    rw [counted_left_zero, mem_singleton_iff] at hl,
    subst hl,
    exact or.inr (list.eq_of_mem_repeat hx),
  end
| p 0 l hl x hx :=
  begin
    rw [counted_right_zero, mem_singleton_iff] at hl,
    subst hl,
    exact or.inl (list.eq_of_mem_repeat hx),
  end
| (p + 1) (q + 1) l hl x hx :=
  begin
    simp only [counted_succ_succ, mem_union, mem_image] at hl,
    rcases hl with (⟨l, hl, rfl⟩ | ⟨l, hl, rfl⟩);
    rcases hx with (rfl | hx),
    { left, refl },
    { exact mem_of_mem_counted_sequence hl hx },
    { right, refl },
    { exact mem_of_mem_counted_sequence hl hx },
  end

lemma length_of_mem_counted_sequence :
  ∀ {p q : ℕ} {l : list ℤ} (hl : l ∈ counted_sequence p q), l.length = p + q
| 0 q l hl :=
  begin
    rw [counted_left_zero, mem_singleton_iff] at hl,
    simp [hl],
  end
| p 0 l hl :=
  begin
    rw [counted_right_zero, mem_singleton_iff] at hl,
    simp [hl],
  end
| (p + 1) (q + 1) l hl :=
  begin
    simp only [counted_succ_succ, mem_union, mem_image] at hl,
    rcases hl with (⟨l, hl, rfl⟩ | ⟨l, hl, rfl⟩),
    { rw [list.length_cons, length_of_mem_counted_sequence hl, add_right_comm] },
    { rw [list.length_cons, length_of_mem_counted_sequence hl, ←add_assoc] }
  end

lemma disjoint_bits (p q : ℕ) :
  disjoint
    ((counted_sequence p (q + 1)).image (list.cons 1))
    ((counted_sequence (p + 1) q).image (list.cons (-1))) :=
begin
  simp_rw [disjoint_left, mem_image, not_exists, exists_imp_distrib],
  rintros _ _ ⟨_, rfl⟩ _ ⟨_, _, _⟩,
end

open measure_theory.measure

private def measureable_space_list_int : measurable_space (list ℤ) := ⊤

local attribute [instance] measureable_space_list_int

private def measurable_singleton_class_list_int : measurable_singleton_class (list ℤ) :=
{ measurable_set_singleton := λ s, trivial }

local attribute [instance] measurable_singleton_class_list_int

private lemma list_int_measurable_set {s : set (list ℤ)} : measurable_set s :=
trivial

lemma count_counted_sequence : ∀ p q : ℕ, count (counted_sequence p q) = (p + q).choose p
| p 0 := by simp [counted_right_zero, count_singleton]
| 0 q := by simp [counted_left_zero, count_singleton]
| (p + 1) (q + 1) :=
  begin
    rw [counted_succ_succ, measure_union (disjoint_bits _ _) list_int_measurable_set,
      count_injective_image list.cons_injective, count_counted_sequence,
      count_injective_image list.cons_injective, count_counted_sequence],
    { norm_cast,
      rw [add_assoc, add_comm 1 q, ← nat.choose_succ_succ, nat.succ_eq_add_one, add_right_comm] },
    all_goals { try { apply_instance } },
  end

lemma first_vote_pos :
  ∀ p q, 0 < p + q →
    cond_count (counted_sequence p q : set (list ℤ)) {l | l.head = 1} = p / (p + q)
| (p + 1) 0 h :=
  begin
    rw [counted_right_zero, cond_count_singleton],
    simp [ennreal.div_self _ _],
  end
| 0 (q + 1) _ :=
  begin
    rw [counted_left_zero, cond_count_singleton],
    simpa,
  end
| (p + 1) (q + 1) h :=
  begin
    simp_rw [counted_succ_succ],
    rw [← cond_count_disjoint_union ((counted_sequence_finite _ _).image _)
        ((counted_sequence_finite _ _).image _) (disjoint_bits _ _), ← counted_succ_succ,
      cond_count_eq_one_of ((counted_sequence_finite p (q + 1)).image _)
        (nonempty_image_iff.2 (counted_sequence_nonempty _ _))],
    { have : list.cons (-1) '' counted_sequence (p + 1) q ∩ {l : list ℤ | l.head = 1} = ∅,
      { ext,
        simp only [mem_inter_eq, mem_image, mem_set_of_eq, mem_empty_eq, iff_false, not_and,
          forall_exists_index, and_imp],
        rintro l _ rfl,
        norm_num },
      have hint : counted_sequence (p + 1) (q + 1) ∩ list.cons 1 '' counted_sequence p (q + 1) =
        list.cons 1 '' counted_sequence p (q + 1),
      { rw [inter_eq_right_iff_subset, counted_succ_succ],
        exact subset_union_left _ _ },
      rw [(cond_count_eq_zero_iff $ (counted_sequence_finite _ _).image _).2 this,
        cond_count, cond_apply _ list_int_measurable_set, hint,
        count_injective_image list.cons_injective, count_counted_sequence, count_counted_sequence,
        one_mul, zero_mul, add_zero, nat.cast_add, nat.cast_one],
      { rw [mul_comm, ← div_eq_mul_inv, ennreal.div_eq_div_iff],
        { norm_cast,
          rw [mul_comm _ (p + 1), ← nat.succ_eq_add_one p, nat.succ_add,
            nat.succ_mul_choose_eq, mul_comm] },
          all_goals { simp [(nat.choose_pos $ (le_add_iff_nonneg_right _).2 zero_le').ne.symm] } },
      all_goals { apply_instance } },
    { simp },
    { apply_instance }
  end

lemma head_mem_of_nonempty {α : Type*} [inhabited α] :
  ∀ {l : list α} (hl : l ≠ []), l.head ∈ l
| [] h := h rfl
| (x :: l) _ := or.inl rfl

lemma first_vote_neg (p q : ℕ) (h : 0 < p + q) :
  cond_count (counted_sequence p q) {l | l.head = 1}ᶜ = q / (p + q) :=
begin
  have := cond_count_compl {l : list ℤ | l.head = 1}ᶜ
    (counted_sequence_finite p q) (counted_sequence_nonempty p q),
  rw [compl_compl, first_vote_pos _ _ h] at this,
  rw [(_ : (q / (p + q) : ennreal) = 1 - p / (p + q)), ← this, ennreal.add_sub_cancel_right],
  { simp only [ne.def, ennreal.div_eq_top, nat.cast_eq_zero, add_eq_zero_iff,
      ennreal.nat_ne_top, false_and, or_false, not_and],
    intros,
    contradiction },
  rw [eq_comm, ennreal.eq_div_iff, ennreal.mul_sub, ennreal.mul_div_cancel'],
  all_goals { simp, try { rintro rfl, rw zero_add at h, exact h.ne.symm } },
end

lemma ballot_same (p : ℕ) : cond_count (counted_sequence (p + 1) (p + 1)) stays_positive = 0 :=
begin
  rw [cond_count_eq_zero_iff (counted_sequence_finite _ _), eq_empty_iff_forall_not_mem],
  rintro x ⟨hx, t⟩,
  apply ne_of_gt (t x _ x.suffix_refl),
  { simpa using sum_of_mem_counted_sequence hx },
  { refine list.ne_nil_of_length_pos _,
    rw length_of_mem_counted_sequence hx,
    exact nat.add_pos_left (nat.succ_pos _) _ },
end

lemma ballot_edge (p : ℕ) : cond_count (counted_sequence (p + 1) 0) stays_positive = 1 :=
begin
  rw counted_right_zero,
  refine cond_count_eq_one_of (finite_singleton _) (singleton_nonempty _) _,
  { intros l hl,
    rw mem_singleton_iff at hl,
    subst hl,
    refine λ l hl₁ hl₂, list.sum_pos _ (λ x hx, _) hl₁,
    rw list.eq_of_mem_repeat (list.mem_of_mem_suffix hx hl₂),
    norm_num },
end

lemma counted_sequence_int_pos_counted_succ_succ (p q : ℕ) :
  (counted_sequence (p + 1) (q + 1)) ∩ {l | l.head = 1} =
  (counted_sequence p (q + 1)).image (list.cons 1) :=
begin
  rw [counted_succ_succ, union_inter_distrib_right,
    (_ : list.cons (-1) '' counted_sequence (p + 1) q ∩ {l | l.head = 1} = ∅), union_empty];
  { ext,
    simp only [mem_inter_eq, mem_image, mem_set_of_eq, and_iff_left_iff_imp, mem_empty_eq,
      iff_false, not_and, forall_exists_index, and_imp],
    rintro y hy rfl,
    norm_num }
end

lemma ballot_pos (p q : ℕ) :
  cond_count ((counted_sequence (p + 1) (q + 1)) ∩ {l | l.head = 1}) stays_positive =
  cond_count (counted_sequence p (q + 1)) stays_positive :=
begin
  rw [counted_sequence_int_pos_counted_succ_succ, cond_count, cond_count,
    cond_apply _ list_int_measurable_set, cond_apply _ list_int_measurable_set,
    count_injective_image list.cons_injective],
  all_goals { try { apply_instance } },
  congr' 1,
  have : (counted_sequence p (q + 1)).image (list.cons 1) ∩ stays_positive =
         (counted_sequence p (q + 1) ∩ stays_positive).image (list.cons 1),
  { ext t,
    simp only [mem_inter_eq, mem_image],
    split,
    { simp only [and_imp, exists_imp_distrib],
      rintro l hl rfl t,
      refine ⟨l, ⟨hl, _⟩, rfl⟩,
      rwa stays_positive_cons_pos at t,
      norm_num },
    { simp only [and_imp, exists_imp_distrib],
      rintro l hl₁ hl₂ rfl,
      refine ⟨⟨_, hl₁, rfl⟩, _⟩,
      rwa stays_positive_cons_pos,
      norm_num } },
  rw [this, count_injective_image],
  exact list.cons_injective,
end

lemma counted_sequence_int_neg_counted_succ_succ (p q : ℕ) :
  (counted_sequence (p + 1) (q + 1)) ∩ {l | l.head = 1}ᶜ =
  (counted_sequence (p + 1) q).image (list.cons (-1)) :=
begin
  rw [counted_succ_succ, union_inter_distrib_right,
    (_ : list.cons 1 '' counted_sequence p (q + 1) ∩ {l : list ℤ | l.head = 1}ᶜ = ∅), empty_union];
  { ext,
    simp only [mem_inter_eq, mem_image, mem_set_of_eq, and_iff_left_iff_imp, mem_empty_eq,
      iff_false, not_and, forall_exists_index, and_imp],
    rintro y hy rfl,
    norm_num }
end

lemma ballot_neg (p q : ℕ) (qp : q < p) :
  cond_count ((counted_sequence (p + 1) (q + 1)) ∩ {l | l.head = 1}ᶜ) stays_positive =
  cond_count (counted_sequence (p + 1) q) stays_positive :=
begin
  rw [counted_sequence_int_neg_counted_succ_succ, cond_count, cond_count,
    cond_apply _ list_int_measurable_set, cond_apply _ list_int_measurable_set,
    count_injective_image list.cons_injective],
  all_goals { try { apply_instance } },
  congr' 1,
  have : (counted_sequence (p + 1) q).image (list.cons (-1)) ∩ stays_positive =
         ((counted_sequence (p + 1) q) ∩ stays_positive).image (list.cons (-1)),
  { ext t,
    simp only [mem_inter_eq, mem_image],
    split,
    { simp only [and_imp, exists_imp_distrib],
      rintro l hl rfl t,
      exact ⟨_, ⟨hl, λ l₁ hl₁ hl₂, t l₁ hl₁ (hl₂.trans (list.suffix_cons _ _))⟩, rfl⟩ },
    { simp only [and_imp, exists_imp_distrib],
      rintro l hl₁ hl₂ rfl,
      refine ⟨⟨l, hl₁, rfl⟩, λ l₁ hl₃ hl₄, _⟩,
      rw list.suffix_cons_iff at hl₄,
      rcases hl₄ with (rfl | hl₄),
      { simp [list.sum_cons, sum_of_mem_counted_sequence hl₁, sub_eq_add_neg, ← add_assoc, qp] },
      exact hl₂ _ hl₃ hl₄ } },
  rw [this, count_injective_image],
  exact list.cons_injective
end

theorem ballot_problem' :
  ∀ q p, q < p → (cond_count (counted_sequence p q) stays_positive).to_real = (p - q) / (p + q) :=
begin
  classical,
  apply nat.diag_induction,
  { intro p,
    rw ballot_same,
    simp },
  { intro p,
    rw ballot_edge,
    simp only [ennreal.one_to_real, nat.cast_add, nat.cast_one, nat.cast_zero, sub_zero, add_zero],
    rw div_self ,
    exact nat.cast_add_one_ne_zero p },
  { intros q p qp h₁ h₂,
    haveI := cond_count_is_probability_measure
      (counted_sequence_finite p (q + 1)) (counted_sequence_nonempty _ _),
    haveI := cond_count_is_probability_measure
      (counted_sequence_finite (p + 1) q) (counted_sequence_nonempty _ _),
    have h₃ : p + 1 + (q + 1) > 0 := nat.add_pos_left (nat.succ_pos _) _,
    rw [← cond_count_add_compl_eq {l : list ℤ | l.head = 1} _ (counted_sequence_finite _ _),
      first_vote_pos _ _ h₃, first_vote_neg _ _ h₃, ballot_pos, ballot_neg _ _ qp],
    rw [ennreal.to_real_add, ennreal.to_real_mul, ennreal.to_real_mul, ← nat.cast_add,
      ennreal.to_real_div, ennreal.to_real_div, ennreal.to_real_nat, ennreal.to_real_nat,
      ennreal.to_real_nat, h₁, h₂],
    { have h₄ : (↑(p + 1) + ↑(q + 1)) ≠ (0 : ℝ),
      { apply ne_of_gt,
        assumption_mod_cast },
      have h₅ : (↑(p + 1) + ↑q) ≠ (0 : ℝ),
      { apply ne_of_gt,
        norm_cast,
        linarith },
      have h₆ : (↑p + ↑(q + 1)) ≠ (0 : ℝ),
      { apply ne_of_gt,
        norm_cast,
        linarith },
      field_simp [h₄, h₅, h₆],
      ring },
    all_goals { refine (ennreal.mul_lt_top (measure_lt_top _ _).ne _).ne,
      simp [ne.def, ennreal.div_eq_top] } }
end

/-- The ballot problem. -/
theorem ballot_problem :
  ∀ q p, q < p → cond_count (counted_sequence p q) stays_positive = (p - q) / (p + q) :=
begin
  intros q p qp,
  haveI := cond_count_is_probability_measure
    (counted_sequence_finite p q) (counted_sequence_nonempty _ _),
  have : (cond_count (counted_sequence p q) stays_positive).to_real =
    ((p - q) / (p + q) : ennreal).to_real,
  { rw ballot_problem' q p qp,
    rw [ennreal.to_real_div, ← nat.cast_add, ← nat.cast_add, ennreal.to_real_nat,
      ennreal.to_real_sub_of_le, ennreal.to_real_nat, ennreal.to_real_nat],
    exacts [ennreal.coe_nat_le_coe_nat.2 qp.le, ennreal.nat_ne_top _] },
  rwa ennreal.to_real_eq_to_real (measure_lt_top _ _).ne at this,
  { simp only [ne.def, ennreal.div_eq_top, tsub_eq_zero_iff_le, ennreal.coe_nat_le_coe_nat,
      not_le, add_eq_zero_iff, nat.cast_eq_zero, ennreal.add_eq_top, ennreal.nat_ne_top,
      or_self, not_false_iff, and_true],
    push_neg,
    exact ⟨λ _ _, by linarith, (lt_of_le_of_lt tsub_le_self (ennreal.nat_ne_top p).lt_top).ne⟩ },
  apply_instance,
end

end ballot


<|start_filename|>src/measure_theory/integral/set_to_l1.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>
-/
import measure_theory.function.simple_func_dense_lp

/-!
# Extension of a linear function from indicators to L1

Let `T : set α → E →L[ℝ] F` be additive for measurable sets with finite measure, in the sense that
for `s, t` two such sets, `s ∩ t = ∅ → T (s ∪ t) = T s + T t`. `T` is akin to a bilinear map on
`set α × E`, or a linear map on indicator functions.

This file constructs an extension of `T` to integrable simple functions, which are finite sums of
indicators of measurable sets with finite measure, then to integrable functions, which are limits of
integrable simple functions.

The main result is a continuous linear map `(α →₁[μ] E) →L[ℝ] F`. This extension process is used to
define the Bochner integral in the `measure_theory.integral.bochner` file and the conditional
expectation of an integrable function in `measure_theory.function.conditional_expectation`.

## Main Definitions

- `fin_meas_additive μ T`: the property that `T` is additive on measurable sets with finite measure.
  For two such sets, `s ∩ t = ∅ → T (s ∪ t) = T s + T t`.
- `dominated_fin_meas_additive μ T C`: `fin_meas_additive μ T ∧ ∀ s, ∥T s∥ ≤ C * (μ s).to_real`.
  This is the property needed to perform the extension from indicators to L1.
- `set_to_L1 (hT : dominated_fin_meas_additive μ T C) : (α →₁[μ] E) →L[ℝ] F`: the extension of `T`
  from indicators to L1.
- `set_to_fun μ T (hT : dominated_fin_meas_additive μ T C) (f : α → E) : F`: a version of the
  extension which applies to functions (with value 0 if the function is not integrable).

## Properties

For most properties of `set_to_fun`, we provide two lemmas. One version uses hypotheses valid on
all sets, like `T = T'`, and a second version which uses a primed name uses hypotheses on
measurable sets with finite measure, like `∀ s, measurable_set s → μ s < ∞ → T s = T' s`.

The lemmas listed here don't show all hypotheses. Refer to the actual lemmas for details.

Linearity:
- `set_to_fun_zero_left : set_to_fun μ 0 hT f = 0`
- `set_to_fun_add_left : set_to_fun μ (T + T') _ f = set_to_fun μ T hT f + set_to_fun μ T' hT' f`
- `set_to_fun_smul_left : set_to_fun μ (λ s, c • (T s)) (hT.smul c) f = c • set_to_fun μ T hT f`
- `set_to_fun_zero : set_to_fun μ T hT (0 : α → E) = 0`
- `set_to_fun_neg : set_to_fun μ T hT (-f) = - set_to_fun μ T hT f`
If `f` and `g` are integrable:
- `set_to_fun_add : set_to_fun μ T hT (f + g) = set_to_fun μ T hT f + set_to_fun μ T hT g`
- `set_to_fun_sub : set_to_fun μ T hT (f - g) = set_to_fun μ T hT f - set_to_fun μ T hT g`
If `T` is verifies `∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x`:
- `set_to_fun_smul : set_to_fun μ T hT (c • f) = c • set_to_fun μ T hT f`

Other:
- `set_to_fun_congr_ae (h : f =ᵐ[μ] g) : set_to_fun μ T hT f = set_to_fun μ T hT g`
- `set_to_fun_measure_zero (h : μ = 0) : set_to_fun μ T hT f = 0`

If the space is a `normed_lattice_add_comm_group` and `T` is such that `0 ≤ T s x` for `0 ≤ x`, we
also prove order-related properties:
- `set_to_fun_mono_left (h : ∀ s x, T s x ≤ T' s x) : set_to_fun μ T hT f ≤ set_to_fun μ T' hT' f`
- `set_to_fun_nonneg (hf : 0 ≤ᵐ[μ] f) : 0 ≤ set_to_fun μ T hT f`
- `set_to_fun_mono (hfg : f ≤ᵐ[μ] g) : set_to_fun μ T hT f ≤ set_to_fun μ T hT g`

## Implementation notes

The starting object `T : set α → E →L[ℝ] F` matters only through its restriction on measurable sets
with finite measure. Its value on other sets is ignored.
-/

noncomputable theory
open_locale classical topological_space big_operators nnreal ennreal measure_theory pointwise
open set filter topological_space ennreal emetric

namespace measure_theory

variables {α E F F' G 𝕜 : Type*} {p : ℝ≥0∞}
  [normed_group E] [normed_space ℝ E]
  [normed_group F] [normed_space ℝ F]
  [normed_group F'] [normed_space ℝ F']
  [normed_group G]
  {m : measurable_space α} {μ : measure α}

local infixr ` →ₛ `:25 := simple_func

open finset

section fin_meas_additive

/-- A set function is `fin_meas_additive` if its value on the union of two disjoint measurable
sets with finite measure is the sum of its values on each set. -/
def fin_meas_additive {β} [add_monoid β] {m : measurable_space α}
  (μ : measure α) (T : set α → β) : Prop :=
∀ s t, measurable_set s → measurable_set t → μ s ≠ ∞ → μ t ≠ ∞ → s ∩ t = ∅ → T (s ∪ t) = T s + T t

namespace fin_meas_additive

variables {β : Type*} [add_comm_monoid β] {T T' : set α → β}

lemma zero : fin_meas_additive μ (0 : set α → β) := λ s t hs ht hμs hμt hst, by simp

lemma add (hT : fin_meas_additive μ T) (hT' : fin_meas_additive μ T') :
  fin_meas_additive μ (T + T') :=
begin
  intros s t hs ht hμs hμt hst,
  simp only [hT s t hs ht hμs hμt hst, hT' s t hs ht hμs hμt hst, pi.add_apply],
  abel,
end

lemma smul [monoid 𝕜] [distrib_mul_action 𝕜 β] (hT : fin_meas_additive μ T) (c : 𝕜) :
  fin_meas_additive μ (λ s, c • (T s)) :=
λ s t hs ht hμs hμt hst, by simp [hT s t hs ht hμs hμt hst]

lemma of_eq_top_imp_eq_top {μ' : measure α}
  (h : ∀ s, measurable_set s → μ s = ∞ → μ' s = ∞) (hT : fin_meas_additive μ T) :
  fin_meas_additive μ' T :=
λ s t hs ht hμ's hμ't hst, hT s t hs ht (mt (h s hs) hμ's) (mt (h t ht) hμ't) hst

lemma of_smul_measure (c : ℝ≥0∞) (hc_ne_top : c ≠ ∞) (hT : fin_meas_additive (c • μ) T) :
  fin_meas_additive μ T :=
begin
  refine of_eq_top_imp_eq_top (λ s hs hμs, _) hT,
  rw [measure.smul_apply, smul_eq_mul, with_top.mul_eq_top_iff] at hμs,
  simp only [hc_ne_top, or_false, ne.def, false_and] at hμs,
  exact hμs.2,
end

lemma smul_measure (c : ℝ≥0∞) (hc_ne_zero : c ≠ 0) (hT : fin_meas_additive μ T) :
  fin_meas_additive (c • μ) T :=
begin
  refine of_eq_top_imp_eq_top (λ s hs hμs, _) hT,
  rw [measure.smul_apply, smul_eq_mul, with_top.mul_eq_top_iff],
  simp only [hc_ne_zero, true_and, ne.def, not_false_iff],
  exact or.inl hμs,
end

lemma smul_measure_iff (c : ℝ≥0∞) (hc_ne_zero : c ≠ 0) (hc_ne_top : c ≠ ∞) :
  fin_meas_additive (c • μ) T ↔ fin_meas_additive μ T :=
⟨λ hT, of_smul_measure c hc_ne_top hT, λ hT, smul_measure c hc_ne_zero hT⟩

lemma map_empty_eq_zero {β} [add_cancel_monoid β] {T : set α → β} (hT : fin_meas_additive μ T) :
  T ∅ = 0 :=
begin
  have h_empty : μ ∅ ≠ ∞, from (measure_empty.le.trans_lt ennreal.coe_lt_top).ne,
  specialize hT ∅ ∅ measurable_set.empty measurable_set.empty h_empty h_empty
    (set.inter_empty ∅),
  rw set.union_empty at hT,
  nth_rewrite 0 ← add_zero (T ∅) at hT,
  exact (add_left_cancel hT).symm,
end

lemma map_Union_fin_meas_set_eq_sum (T : set α → β) (T_empty : T ∅ = 0)
  (h_add : fin_meas_additive μ T)
  {ι} (S : ι → set α) (sι : finset ι) (hS_meas : ∀ i, measurable_set (S i))
  (hSp : ∀ i ∈ sι, μ (S i) ≠ ∞) (h_disj : ∀ i j ∈ sι, i ≠ j → disjoint (S i) (S j)) :
  T (⋃ i ∈ sι, S i) = ∑ i in sι, T (S i) :=
begin
  revert hSp h_disj,
  refine finset.induction_on sι _ _,
  { simp only [finset.not_mem_empty, forall_false_left, Union_false, Union_empty, sum_empty,
    forall_2_true_iff, implies_true_iff, forall_true_left, not_false_iff, T_empty], },
  intros a s has h hps h_disj,
  rw [finset.sum_insert has, ← h],
  swap, { exact λ i hi, hps i (finset.mem_insert_of_mem hi), },
  swap, { exact λ i hi j hj hij,
    h_disj i (finset.mem_insert_of_mem hi) j (finset.mem_insert_of_mem hj) hij, },
  rw ← h_add (S a) (⋃ i ∈ s, S i) (hS_meas a) (measurable_set_bUnion _ (λ i _, hS_meas i))
    (hps a (finset.mem_insert_self a s)),
  { congr, convert finset.supr_insert a s S, },
  { exact ((measure_bUnion_finset_le _ _).trans_lt $
      ennreal.sum_lt_top $ λ i hi, hps i $ finset.mem_insert_of_mem hi).ne, },
  { simp_rw set.inter_Union,
    refine Union_eq_empty.mpr (λ i, Union_eq_empty.mpr (λ hi, _)),
    rw ← set.disjoint_iff_inter_eq_empty,
    refine h_disj a (finset.mem_insert_self a s) i (finset.mem_insert_of_mem hi) (λ hai, _),
    rw ← hai at hi,
    exact has hi, },
end

end fin_meas_additive

/-- A `fin_meas_additive` set function whose norm on every set is less than the measure of the
set (up to a multiplicative constant). -/
def dominated_fin_meas_additive {β} [semi_normed_group β] {m : measurable_space α}
  (μ : measure α) (T : set α → β) (C : ℝ) : Prop :=
fin_meas_additive μ T ∧ ∀ s, measurable_set s → μ s < ∞ → ∥T s∥ ≤ C * (μ s).to_real

namespace dominated_fin_meas_additive

variables {β : Type*} [semi_normed_group β] {T T' : set α → β} {C C' : ℝ}

lemma zero {m : measurable_space α} (μ : measure α) (hC : 0 ≤ C) :
  dominated_fin_meas_additive μ (0 : set α → β) C :=
begin
  refine ⟨fin_meas_additive.zero, λ s hs hμs, _⟩,
  rw [pi.zero_apply, norm_zero],
  exact mul_nonneg hC to_real_nonneg,
end

lemma eq_zero_of_measure_zero {β : Type*} [normed_group β] {T : set α → β} {C : ℝ}
  (hT : dominated_fin_meas_additive μ T C) {s : set α}
  (hs : measurable_set s) (hs_zero : μ s = 0) :
  T s = 0 :=
begin
  refine norm_eq_zero.mp _,
  refine ((hT.2 s hs (by simp [hs_zero])).trans (le_of_eq _)).antisymm (norm_nonneg _),
  rw [hs_zero, ennreal.zero_to_real, mul_zero],
end

lemma eq_zero {β : Type*} [normed_group β] {T : set α → β} {C : ℝ}
  {m : measurable_space α} (hT : dominated_fin_meas_additive (0 : measure α) T C)
  {s : set α} (hs : measurable_set s) :
  T s = 0 :=
eq_zero_of_measure_zero hT hs (by simp only [measure.coe_zero, pi.zero_apply])

lemma add (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C') :
  dominated_fin_meas_additive μ (T + T') (C + C') :=
begin
  refine ⟨hT.1.add hT'.1, λ s hs hμs, _⟩,
  rw [pi.add_apply, add_mul],
  exact (norm_add_le _ _).trans (add_le_add (hT.2 s hs hμs) (hT'.2 s hs hμs)),
end

lemma smul [normed_field 𝕜] [normed_space 𝕜 β] (hT : dominated_fin_meas_additive μ T C)
  (c : 𝕜) :
  dominated_fin_meas_additive μ (λ s, c • (T s)) (∥c∥ * C) :=
begin
  refine ⟨hT.1.smul c, λ s hs hμs, _⟩,
  dsimp only,
  rw [norm_smul, mul_assoc],
  exact mul_le_mul le_rfl (hT.2 s hs hμs) (norm_nonneg _) (norm_nonneg _),
end

lemma of_measure_le {μ' : measure α} (h : μ ≤ μ') (hT : dominated_fin_meas_additive μ T C)
  (hC : 0 ≤ C) :
  dominated_fin_meas_additive μ' T C :=
begin
  have h' : ∀ s, measurable_set s → μ s = ∞ → μ' s = ∞,
  { intros s hs hμs, rw [eq_top_iff, ← hμs], exact h s hs, },
  refine ⟨hT.1.of_eq_top_imp_eq_top h', λ s hs hμ's, _⟩,
  have hμs : μ s < ∞, from (h s hs).trans_lt hμ's,
  refine (hT.2 s hs hμs).trans (mul_le_mul le_rfl _ ennreal.to_real_nonneg hC),
  rw to_real_le_to_real hμs.ne hμ's.ne,
  exact h s hs,
end

lemma add_measure_right {m : measurable_space α}
  (μ ν : measure α) (hT : dominated_fin_meas_additive μ T C) (hC : 0 ≤ C) :
  dominated_fin_meas_additive (μ + ν) T C :=
 of_measure_le (measure.le_add_right le_rfl) hT hC

lemma add_measure_left {m : measurable_space α}
  (μ ν : measure α) (hT : dominated_fin_meas_additive ν T C) (hC : 0 ≤ C) :
  dominated_fin_meas_additive (μ + ν) T C :=
 of_measure_le (measure.le_add_left le_rfl) hT hC

lemma of_smul_measure (c : ℝ≥0∞) (hc_ne_top : c ≠ ∞)
  (hT : dominated_fin_meas_additive (c • μ) T C) :
  dominated_fin_meas_additive μ T (c.to_real * C) :=
begin
  have h : ∀ s, measurable_set s → c • μ s = ∞ → μ s = ∞,
  { intros s hs hcμs,
    simp only [hc_ne_top, algebra.id.smul_eq_mul, with_top.mul_eq_top_iff, or_false, ne.def,
      false_and] at hcμs,
    exact hcμs.2, },
  refine ⟨hT.1.of_eq_top_imp_eq_top h, λ s hs hμs, _⟩,
  have hcμs : c • μ s ≠ ∞, from mt (h s hs) hμs.ne,
  rw smul_eq_mul at hcμs,
  simp_rw [dominated_fin_meas_additive, measure.smul_apply, smul_eq_mul, to_real_mul] at hT,
  refine (hT.2 s hs hcμs.lt_top).trans (le_of_eq _),
  ring,
end

lemma of_measure_le_smul {μ' : measure α} (c : ℝ≥0∞) (hc : c ≠ ∞) (h : μ ≤ c • μ')
  (hT : dominated_fin_meas_additive μ T C) (hC : 0 ≤ C) :
  dominated_fin_meas_additive μ' T (c.to_real * C) :=
(hT.of_measure_le h hC).of_smul_measure c hc

end dominated_fin_meas_additive

end fin_meas_additive

namespace simple_func

/-- Extend `set α → (F →L[ℝ] F')` to `(α →ₛ F) → F'`. -/
def set_to_simple_func {m : measurable_space α} (T : set α → F →L[ℝ] F') (f : α →ₛ F) : F' :=
∑ x in f.range, T (f ⁻¹' {x}) x

@[simp] lemma set_to_simple_func_zero {m : measurable_space α} (f : α →ₛ F) :
  set_to_simple_func (0 : set α → F →L[ℝ] F') f = 0 :=
by simp [set_to_simple_func]

lemma set_to_simple_func_zero' {T : set α → E →L[ℝ] F'}
  (h_zero : ∀ s, measurable_set s → μ s < ∞ → T s = 0) (f : α →ₛ E) (hf : integrable f μ) :
  set_to_simple_func T f = 0 :=
begin
  simp_rw set_to_simple_func,
  refine sum_eq_zero (λ x hx, _),
  by_cases hx0 : x = 0,
  { simp [hx0], },
  rw [h_zero (f ⁻¹' ({x} : set E)) (measurable_set_fiber _ _)
      (measure_preimage_lt_top_of_integrable f hf hx0),
    continuous_linear_map.zero_apply],
end

@[simp] lemma set_to_simple_func_zero_apply {m : measurable_space α} (T : set α → F →L[ℝ] F') :
  set_to_simple_func T (0 : α →ₛ F) = 0 :=
by casesI is_empty_or_nonempty α; simp [set_to_simple_func]

lemma set_to_simple_func_eq_sum_filter {m : measurable_space α}
  (T : set α → F →L[ℝ] F') (f : α →ₛ F) :
  set_to_simple_func T f = ∑ x in f.range.filter (λ x, x ≠ 0), (T (f ⁻¹' {x})) x :=
begin
  symmetry,
  refine sum_filter_of_ne (λ x hx, mt (λ hx0, _)),
  rw hx0,
  exact continuous_linear_map.map_zero _,
end

lemma map_set_to_simple_func (T : set α → F →L[ℝ] F') (h_add : fin_meas_additive μ T)
  {f : α →ₛ G} (hf : integrable f μ) {g : G → F} (hg : g 0 = 0) :
  (f.map g).set_to_simple_func T = ∑ x in f.range, T (f ⁻¹' {x}) (g x) :=
begin
  have T_empty : T ∅ = 0, from h_add.map_empty_eq_zero,
  have hfp : ∀ x ∈ f.range, x ≠ 0 → μ (f ⁻¹' {x}) ≠ ∞,
    from λ x hx hx0, (measure_preimage_lt_top_of_integrable f hf hx0).ne,
  simp only [set_to_simple_func, range_map],
  refine finset.sum_image' _ (assume b hb, _),
  rcases mem_range.1 hb with ⟨a, rfl⟩,
  by_cases h0 : g (f a) = 0,
  { simp_rw h0,
    rw [continuous_linear_map.map_zero, finset.sum_eq_zero (λ x hx, _)],
    rw mem_filter at hx,
    rw [hx.2, continuous_linear_map.map_zero], },
  have h_left_eq : T ((map g f) ⁻¹' {g (f a)}) (g (f a))
    = T (f ⁻¹' ↑(f.range.filter (λ b, g b = g (f a)))) (g (f a)),
  { congr, rw map_preimage_singleton, },
  rw h_left_eq,
  have h_left_eq' : T (f ⁻¹' ↑(filter (λ (b : G), g b = g (f a)) f.range)) (g (f a))
    = T (⋃ y ∈ (filter (λ (b : G), g b = g (f a)) f.range), f ⁻¹' {y}) (g (f a)),
  { congr, rw ← finset.set_bUnion_preimage_singleton, },
  rw h_left_eq',
  rw h_add.map_Union_fin_meas_set_eq_sum T T_empty,
  { simp only [filter_congr_decidable, sum_apply, continuous_linear_map.coe_sum'],
    refine finset.sum_congr rfl (λ x hx, _),
    rw mem_filter at hx,
    rw hx.2, },
  { exact λ i, measurable_set_fiber _ _, },
  { intros i hi,
    rw mem_filter at hi,
    refine hfp i hi.1 (λ hi0, _),
    rw [hi0, hg] at hi,
    exact h0 hi.2.symm, },
  { intros i j hi hj hij,
    rw set.disjoint_iff,
    intros x hx,
    rw [set.mem_inter_iff, set.mem_preimage, set.mem_preimage, set.mem_singleton_iff,
      set.mem_singleton_iff] at hx,
    rw [← hx.1, ← hx.2] at hij,
    exact absurd rfl hij, },
end

lemma set_to_simple_func_congr' (T : set α → E →L[ℝ] F) (h_add : fin_meas_additive μ T)
  {f g : α →ₛ E} (hf : integrable f μ) (hg : integrable g μ)
  (h : ∀ x y, x ≠ y → T ((f ⁻¹' {x}) ∩ (g ⁻¹' {y})) = 0) :
  f.set_to_simple_func T = g.set_to_simple_func T :=
show ((pair f g).map prod.fst).set_to_simple_func T
  = ((pair f g).map prod.snd).set_to_simple_func T, from
begin
  have h_pair : integrable (f.pair g) μ, from integrable_pair hf hg,
  rw map_set_to_simple_func T h_add h_pair prod.fst_zero,
  rw map_set_to_simple_func T h_add h_pair prod.snd_zero,
  refine finset.sum_congr rfl (λ p hp, _),
  rcases mem_range.1 hp with ⟨a, rfl⟩,
  by_cases eq : f a = g a,
  { dsimp only [pair_apply], rw eq },
  { have : T ((pair f g) ⁻¹' {(f a, g a)}) = 0,
    { have h_eq : T (⇑(f.pair g) ⁻¹' {(f a, g a)}) = T ((f ⁻¹' {f a}) ∩ (g ⁻¹' {g a})),
      { congr, rw pair_preimage_singleton f g, },
      rw h_eq,
      exact h (f a) (g a) eq, },
    simp only [this, continuous_linear_map.zero_apply, pair_apply], },
end

lemma set_to_simple_func_congr (T : set α → (E →L[ℝ] F))
  (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0) (h_add : fin_meas_additive μ T)
  {f g : α →ₛ E} (hf : integrable f μ) (h : f =ᵐ[μ] g) :
  f.set_to_simple_func T = g.set_to_simple_func T :=
begin
  refine set_to_simple_func_congr' T h_add hf ((integrable_congr h).mp hf) _,
  refine λ x y hxy, h_zero _ ((measurable_set_fiber f x).inter (measurable_set_fiber g y)) _,
  rw [eventually_eq, ae_iff] at h,
  refine measure_mono_null (λ z, _) h,
  simp_rw [set.mem_inter_iff, set.mem_set_of_eq, set.mem_preimage, set.mem_singleton_iff],
  intro h,
  rwa [h.1, h.2],
end

lemma set_to_simple_func_congr_left (T T' : set α → E →L[ℝ] F)
  (h : ∀ s, measurable_set s → μ s < ∞ → T s = T' s) (f : α →ₛ E) (hf : integrable f μ) :
  set_to_simple_func T f = set_to_simple_func T' f :=
begin
  simp_rw set_to_simple_func,
  refine sum_congr rfl (λ x hx, _),
  by_cases hx0 : x = 0,
  { simp [hx0], },
  { rw h (f ⁻¹' {x}) (simple_func.measurable_set_fiber _ _)
      (simple_func.measure_preimage_lt_top_of_integrable _ hf hx0), },
end

lemma set_to_simple_func_add_left {m : measurable_space α} (T T' : set α → F →L[ℝ] F')
  {f : α →ₛ F} :
  set_to_simple_func (T + T') f = set_to_simple_func T f + set_to_simple_func T' f :=
begin
  simp_rw [set_to_simple_func, pi.add_apply],
  push_cast,
  simp_rw [pi.add_apply, sum_add_distrib],
end

lemma set_to_simple_func_add_left' (T T' T'' : set α → E →L[ℝ] F)
  (h_add : ∀ s, measurable_set s → μ s < ∞ → T'' s = T s + T' s) {f : α →ₛ E}
  (hf : integrable f μ) :
  set_to_simple_func (T'') f = set_to_simple_func T f + set_to_simple_func T' f :=
begin
  simp_rw [set_to_simple_func_eq_sum_filter],
  suffices : ∀ x ∈ filter (λ (x : E), x ≠ 0) f.range,
    T'' (f ⁻¹' {x}) = T (f ⁻¹' {x}) + T' (f ⁻¹' {x}),
  { rw ← sum_add_distrib,
    refine finset.sum_congr rfl (λ x hx, _),
    rw this x hx,
    push_cast,
    rw pi.add_apply, },
  intros x hx,
  refine h_add (f ⁻¹' {x}) (measurable_set_preimage _ _)
    (measure_preimage_lt_top_of_integrable _ hf _),
  rw mem_filter at hx,
  exact hx.2,
end

lemma set_to_simple_func_smul_left {m : measurable_space α}
  (T : set α → F →L[ℝ] F') (c : ℝ) (f : α →ₛ F) :
  set_to_simple_func (λ s, c • (T s)) f = c • set_to_simple_func T f :=
by simp_rw [set_to_simple_func, continuous_linear_map.smul_apply, smul_sum]

lemma set_to_simple_func_smul_left'
  (T T' : set α → E →L[ℝ] F') (c : ℝ) (h_smul : ∀ s, measurable_set s → μ s < ∞ → T' s = c • (T s))
  {f : α →ₛ E} (hf : integrable f μ) :
  set_to_simple_func T' f = c • set_to_simple_func T f :=
begin
  simp_rw [set_to_simple_func_eq_sum_filter],
  suffices : ∀ x ∈ filter (λ (x : E), x ≠ 0) f.range, T' (f ⁻¹' {x}) = c • (T (f ⁻¹' {x})),
  { rw smul_sum,
    refine finset.sum_congr rfl (λ x hx, _),
    rw this x hx,
    refl, },
  intros x hx,
  refine h_smul (f ⁻¹' {x}) (measurable_set_preimage _ _)
    (measure_preimage_lt_top_of_integrable _ hf _),
  rw mem_filter at hx,
  exact hx.2,
end

lemma set_to_simple_func_add (T : set α → E →L[ℝ] F) (h_add : fin_meas_additive μ T)
  {f g : α →ₛ E} (hf : integrable f μ) (hg : integrable g μ) :
  set_to_simple_func T (f + g) = set_to_simple_func T f + set_to_simple_func T g :=
have hp_pair : integrable (f.pair g) μ, from integrable_pair hf hg,
calc set_to_simple_func T (f + g) = ∑ x in (pair f g).range,
       T ((pair f g) ⁻¹' {x}) (x.fst + x.snd) :
  by { rw [add_eq_map₂, map_set_to_simple_func T h_add hp_pair], simp, }
... = ∑ x in (pair f g).range, (T ((pair f g) ⁻¹' {x}) x.fst + T ((pair f g) ⁻¹' {x}) x.snd) :
  finset.sum_congr rfl $ assume a ha, continuous_linear_map.map_add _ _ _
... = ∑ x in (pair f g).range, T ((pair f g) ⁻¹' {x}) x.fst +
      ∑ x in (pair f g).range, T ((pair f g) ⁻¹' {x}) x.snd :
  by rw finset.sum_add_distrib
... = ((pair f g).map prod.fst).set_to_simple_func T
    + ((pair f g).map prod.snd).set_to_simple_func T :
  by rw [map_set_to_simple_func T h_add hp_pair prod.snd_zero,
    map_set_to_simple_func T h_add hp_pair prod.fst_zero]

lemma set_to_simple_func_neg (T : set α → E →L[ℝ] F) (h_add : fin_meas_additive μ T)
  {f : α →ₛ E} (hf : integrable f μ) :
  set_to_simple_func T (-f) = - set_to_simple_func T f :=
calc set_to_simple_func T (-f) = set_to_simple_func T (f.map (has_neg.neg)) : rfl
  ... = - set_to_simple_func T f :
  begin
    rw [map_set_to_simple_func T h_add hf neg_zero, set_to_simple_func,
      ← sum_neg_distrib],
    exact finset.sum_congr rfl (λ x h, continuous_linear_map.map_neg _ _),
  end

lemma set_to_simple_func_sub (T : set α → E →L[ℝ] F) (h_add : fin_meas_additive μ T)
  {f g : α →ₛ E} (hf : integrable f μ) (hg : integrable g μ) :
  set_to_simple_func T (f - g) = set_to_simple_func T f - set_to_simple_func T g :=
begin
  rw [sub_eq_add_neg, set_to_simple_func_add T h_add hf,
    set_to_simple_func_neg T h_add hg, sub_eq_add_neg],
  rw integrable_iff at hg ⊢,
  intros x hx_ne,
  change μ ((has_neg.neg ∘ g) ⁻¹' {x}) < ∞,
  rw [preimage_comp, neg_preimage, set.neg_singleton],
  refine hg (-x) _,
  simp [hx_ne],
end

lemma set_to_simple_func_smul_real (T : set α → E →L[ℝ] F) (h_add : fin_meas_additive μ T)
  (c : ℝ) {f : α →ₛ E} (hf : integrable f μ) :
  set_to_simple_func T (c • f) = c • set_to_simple_func T f :=
calc set_to_simple_func T (c • f) = ∑ x in f.range, T (f ⁻¹' {x}) (c • x) :
  by { rw [smul_eq_map c f, map_set_to_simple_func T h_add hf], rw smul_zero, }
... = ∑ x in f.range, c • (T (f ⁻¹' {x}) x) :
  finset.sum_congr rfl $ λ b hb, by { rw continuous_linear_map.map_smul (T (f ⁻¹' {b})) c b, }
... = c • set_to_simple_func T f :
by simp only [set_to_simple_func, smul_sum, smul_smul, mul_comm]

lemma set_to_simple_func_smul {E} [normed_group E] [normed_field 𝕜]
  [normed_space 𝕜 E] [normed_space ℝ E] [normed_space 𝕜 F] (T : set α → E →L[ℝ] F)
  (h_add : fin_meas_additive μ T) (h_smul : ∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x)
  (c : 𝕜) {f : α →ₛ E} (hf : integrable f μ) :
  set_to_simple_func T (c • f) = c • set_to_simple_func T f :=
calc set_to_simple_func T (c • f) = ∑ x in f.range, T (f ⁻¹' {x}) (c • x) :
  by { rw [smul_eq_map c f, map_set_to_simple_func T h_add hf],
    rw smul_zero, }
... = ∑ x in f.range, c • (T (f ⁻¹' {x}) x) : finset.sum_congr rfl $ λ b hb, by { rw h_smul, }
... = c • set_to_simple_func T f : by simp only [set_to_simple_func, smul_sum, smul_smul, mul_comm]

section order

variables {G' G'' : Type*} [normed_lattice_add_comm_group G''] [normed_space ℝ G'']
  [normed_lattice_add_comm_group G'] [normed_space ℝ G']

lemma set_to_simple_func_mono_left {m : measurable_space α}
  (T T' : set α → F →L[ℝ] G'') (hTT' : ∀ s x, T s x ≤ T' s x) (f : α →ₛ F) :
  set_to_simple_func T f ≤ set_to_simple_func T' f :=
by { simp_rw set_to_simple_func, exact sum_le_sum (λ i hi, hTT' _ i), }

lemma set_to_simple_func_mono_left'
  (T T' : set α → E →L[ℝ] G'') (hTT' : ∀ s, measurable_set s → μ s < ∞ → ∀ x, T s x ≤ T' s x)
  (f : α →ₛ E) (hf : integrable f μ) :
  set_to_simple_func T f ≤ set_to_simple_func T' f :=
begin
  refine sum_le_sum (λ i hi, _),
  by_cases h0 : i = 0,
  { simp [h0], },
  { exact hTT' _ (measurable_set_fiber _ _) (measure_preimage_lt_top_of_integrable _ hf h0) i, }
end

lemma set_to_simple_func_nonneg {m : measurable_space α}
  (T : set α → G' →L[ℝ] G'') (hT_nonneg : ∀ s x, 0 ≤ x → 0 ≤ T s x) (f : α →ₛ G') (hf : 0 ≤ f) :
  0 ≤ set_to_simple_func T f :=
begin
  refine sum_nonneg (λ i hi, hT_nonneg _ i _),
  rw mem_range at hi,
  obtain ⟨y, hy⟩ := set.mem_range.mp hi,
  rw ← hy,
  refine le_trans _ (hf y),
  simp,
end

lemma set_to_simple_func_nonneg' (T : set α → G' →L[ℝ] G'')
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  (f : α →ₛ G') (hf : 0 ≤ f) (hfi : integrable f μ) :
  0 ≤ set_to_simple_func T f :=
begin
  refine sum_nonneg (λ i hi, _),
  by_cases h0 : i = 0,
  { simp [h0], },
  refine hT_nonneg _ (measurable_set_fiber _ _)
    (measure_preimage_lt_top_of_integrable _ hfi h0) i _,
  rw mem_range at hi,
  obtain ⟨y, hy⟩ := set.mem_range.mp hi,
  rw ← hy,
  convert (hf y),
end

lemma set_to_simple_func_mono
  {T : set α → G' →L[ℝ] G''} (h_add : fin_meas_additive μ T)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x) {f g : α →ₛ G'}
  (hfi : integrable f μ) (hgi : integrable g μ) (hfg : f ≤ g) :
  set_to_simple_func T f ≤ set_to_simple_func T g :=
begin
  rw [← sub_nonneg, ← set_to_simple_func_sub T h_add hgi hfi],
  refine set_to_simple_func_nonneg' T hT_nonneg _ _ (hgi.sub hfi),
  intro x,
  simp only [coe_sub, sub_nonneg, coe_zero, pi.zero_apply, pi.sub_apply],
  exact hfg x,
end

end order

lemma norm_set_to_simple_func_le_sum_op_norm {m : measurable_space α}
  (T : set α → F' →L[ℝ] F) (f : α →ₛ F') :
  ∥f.set_to_simple_func T∥ ≤ ∑ x in f.range, ∥T (f ⁻¹' {x})∥ * ∥x∥ :=
calc ∥∑ x in f.range, T (f ⁻¹' {x}) x∥
    ≤ ∑ x in f.range, ∥T (f ⁻¹' {x}) x∥ : norm_sum_le _ _
... ≤ ∑ x in f.range, ∥T (f ⁻¹' {x})∥ * ∥x∥ :
  by { refine finset.sum_le_sum (λb hb, _), simp_rw continuous_linear_map.le_op_norm, }

lemma norm_set_to_simple_func_le_sum_mul_norm (T : set α → F →L[ℝ] F') {C : ℝ}
  (hT_norm : ∀ s, measurable_set s → ∥T s∥ ≤ C * (μ s).to_real) (f : α →ₛ F) :
  ∥f.set_to_simple_func T∥ ≤ C * ∑ x in f.range, (μ (f ⁻¹' {x})).to_real * ∥x∥ :=
calc ∥f.set_to_simple_func T∥
    ≤ ∑ x in f.range, ∥T (f ⁻¹' {x})∥ * ∥x∥ : norm_set_to_simple_func_le_sum_op_norm T f
... ≤ ∑ x in f.range, C * (μ (f ⁻¹' {x})).to_real * ∥x∥ :
  begin
    refine finset.sum_le_sum (λ b hb, _),
    by_cases hb : ∥b∥ = 0,
    { rw hb, simp, },
    rw _root_.mul_le_mul_right _,
    { exact hT_norm _ (simple_func.measurable_set_fiber _ _), },
    { exact lt_of_le_of_ne (norm_nonneg _) (ne.symm hb), },
  end
... ≤ C * ∑ x in f.range, (μ (f ⁻¹' {x})).to_real * ∥x∥ : by simp_rw [mul_sum, ← mul_assoc]

lemma norm_set_to_simple_func_le_sum_mul_norm_of_integrable (T : set α → E →L[ℝ] F') {C : ℝ}
  (hT_norm : ∀ s, measurable_set s → μ s < ∞ → ∥T s∥ ≤ C * (μ s).to_real) (f : α →ₛ E)
  (hf : integrable f μ) :
  ∥f.set_to_simple_func T∥ ≤ C * ∑ x in f.range, (μ (f ⁻¹' {x})).to_real * ∥x∥ :=
calc ∥f.set_to_simple_func T∥
    ≤ ∑ x in f.range, ∥T (f ⁻¹' {x})∥ * ∥x∥ : norm_set_to_simple_func_le_sum_op_norm T f
... ≤ ∑ x in f.range, C * (μ (f ⁻¹' {x})).to_real * ∥x∥ :
  begin
    refine finset.sum_le_sum (λ b hb, _),
    by_cases hb : ∥b∥ = 0,
    { rw hb, simp, },
    rw _root_.mul_le_mul_right _,
    { refine hT_norm _ (simple_func.measurable_set_fiber _ _)
        (simple_func.measure_preimage_lt_top_of_integrable _ hf _),
      rwa norm_eq_zero at hb, },
    { exact lt_of_le_of_ne (norm_nonneg _) (ne.symm hb), },
  end
... ≤ C * ∑ x in f.range, (μ (f ⁻¹' {x})).to_real * ∥x∥ : by simp_rw [mul_sum, ← mul_assoc]

lemma set_to_simple_func_indicator (T : set α → F →L[ℝ] F') (hT_empty : T ∅ = 0)
  {m : measurable_space α} {s : set α} (hs : measurable_set s) (x : F) :
  simple_func.set_to_simple_func T
    (simple_func.piecewise s hs (simple_func.const α x) (simple_func.const α 0))
  = T s x :=
begin
  by_cases hs_empty : s = ∅,
  { simp only [hs_empty, hT_empty, continuous_linear_map.zero_apply, piecewise_empty, const_zero,
    set_to_simple_func_zero_apply], },
  by_cases hs_univ : s = univ,
  { casesI hα : is_empty_or_nonempty α,
    { refine absurd _ hs_empty,
      haveI : subsingleton (set α), by { unfold set, apply_instance, },
      exact subsingleton.elim s ∅, },
    simp [hs_univ, set_to_simple_func], },
  simp_rw set_to_simple_func,
  rw [← ne.def, set.ne_empty_iff_nonempty] at hs_empty,
  rw range_indicator hs hs_empty hs_univ,
  by_cases hx0 : x = 0,
  { simp_rw hx0, simp, },
  rw sum_insert,
  swap, { rw finset.mem_singleton, exact hx0, },
  rw [sum_singleton, (T _).map_zero, add_zero],
  congr,
  simp only [coe_piecewise, piecewise_eq_indicator, coe_const, pi.const_zero,
    piecewise_eq_indicator],
  rw [indicator_preimage, preimage_const_of_mem],
  swap, { exact set.mem_singleton x, },
  rw [← pi.const_zero, preimage_const_of_not_mem],
  swap, { rw set.mem_singleton_iff, exact ne.symm hx0, },
  simp,
end

lemma set_to_simple_func_const' [nonempty α] (T : set α → F →L[ℝ] F') (x : F)
  {m : measurable_space α} :
  simple_func.set_to_simple_func T (simple_func.const α x) = T univ x :=
by simp only [set_to_simple_func, range_const, set.mem_singleton, preimage_const_of_mem,
  sum_singleton, coe_const]

lemma set_to_simple_func_const (T : set α → F →L[ℝ] F') (hT_empty : T ∅ = 0) (x : F)
  {m : measurable_space α} :
  simple_func.set_to_simple_func T (simple_func.const α x) = T univ x :=
begin
  casesI hα : is_empty_or_nonempty α,
  { have h_univ_empty : (univ : set α) = ∅, from subsingleton.elim _ _,
    rw [h_univ_empty, hT_empty],
    simp only [set_to_simple_func, continuous_linear_map.zero_apply, sum_empty,
      range_eq_empty_of_is_empty], },
  { exact set_to_simple_func_const' T x, },
end

end simple_func

namespace L1

open ae_eq_fun Lp.simple_func Lp

variables {α E μ}

namespace simple_func

lemma norm_eq_sum_mul (f : α →₁ₛ[μ] G) :
  ∥f∥ = ∑ x in (to_simple_func f).range, (μ ((to_simple_func f) ⁻¹' {x})).to_real * ∥x∥ :=
begin
  rw [norm_to_simple_func, snorm_one_eq_lintegral_nnnorm],
  have h_eq := simple_func.map_apply (λ x, (∥x∥₊ : ℝ≥0∞)) (to_simple_func f),
  dsimp only at h_eq,
  simp_rw ← h_eq,
  rw [simple_func.lintegral_eq_lintegral, simple_func.map_lintegral, ennreal.to_real_sum],
  { congr,
    ext1 x,
    rw [ennreal.to_real_mul, mul_comm, ← of_real_norm_eq_coe_nnnorm,
      ennreal.to_real_of_real (norm_nonneg _)], },
  { intros x hx,
    by_cases hx0 : x = 0,
    { rw hx0, simp, },
    { exact ennreal.mul_ne_top ennreal.coe_ne_top
        (simple_func.measure_preimage_lt_top_of_integrable _ (simple_func.integrable f) hx0).ne } }
end

section set_to_L1s

variables [normed_field 𝕜] [normed_space 𝕜 E]

local attribute [instance] Lp.simple_func.module
local attribute [instance] Lp.simple_func.normed_space

/-- Extend `set α → (E →L[ℝ] F')` to `(α →₁ₛ[μ] E) → F'`. -/
def set_to_L1s (T : set α → E →L[ℝ] F) (f : α →₁ₛ[μ] E) : F :=
(to_simple_func f).set_to_simple_func T

lemma set_to_L1s_eq_set_to_simple_func (T : set α → E →L[ℝ] F) (f : α →₁ₛ[μ] E) :
  set_to_L1s T f = (to_simple_func f).set_to_simple_func T :=
rfl

@[simp] lemma set_to_L1s_zero_left (f : α →₁ₛ[μ] E) :
  set_to_L1s (0 : set α → E →L[ℝ] F) f = 0 :=
simple_func.set_to_simple_func_zero _

lemma set_to_L1s_zero_left' {T : set α → E →L[ℝ] F}
  (h_zero : ∀ s, measurable_set s → μ s < ∞ → T s = 0) (f : α →₁ₛ[μ] E) :
  set_to_L1s T f = 0 :=
simple_func.set_to_simple_func_zero' h_zero _ (simple_func.integrable f)

lemma set_to_L1s_congr (T : set α → E →L[ℝ] F) (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0)
  (h_add : fin_meas_additive μ T)
  {f g : α →₁ₛ[μ] E} (h : to_simple_func f =ᵐ[μ] to_simple_func g) :
  set_to_L1s T f = set_to_L1s T g :=
simple_func.set_to_simple_func_congr T h_zero h_add (simple_func.integrable f) h

lemma set_to_L1s_congr_left (T T' : set α → E →L[ℝ] F)
  (h : ∀ s, measurable_set s → μ s < ∞ → T s = T' s) (f : α →₁ₛ[μ] E) :
  set_to_L1s T f = set_to_L1s T' f :=
simple_func.set_to_simple_func_congr_left T T' h (simple_func.to_simple_func f)
  (simple_func.integrable f)

/-- `set_to_L1s` does not change if we replace the measure `μ` by `μ'` with `μ ≪ μ'`. The statement
uses two functions `f` and `f'` because they have to belong to different types, but morally these
are the same function (we have `f =ᵐ[μ] f'`). -/
lemma set_to_L1s_congr_measure {μ' : measure α} (T : set α → E →L[ℝ] F)
  (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0) (h_add : fin_meas_additive μ T)
  (hμ : μ ≪ μ') (f : α →₁ₛ[μ] E) (f' : α →₁ₛ[μ'] E) (h : f =ᵐ[μ] f') :
  set_to_L1s T f = set_to_L1s T f' :=
begin
  refine simple_func.set_to_simple_func_congr T h_zero h_add (simple_func.integrable f) _,
  refine (to_simple_func_eq_to_fun f).trans _,
  suffices : f' =ᵐ[μ] ⇑(simple_func.to_simple_func f'), from h.trans this,
  have goal' : f' =ᵐ[μ'] simple_func.to_simple_func f', from (to_simple_func_eq_to_fun f').symm,
  exact hμ.ae_eq goal',
end

lemma set_to_L1s_add_left (T T' : set α → E →L[ℝ] F) (f : α →₁ₛ[μ] E) :
  set_to_L1s (T + T') f = set_to_L1s T f + set_to_L1s T' f :=
simple_func.set_to_simple_func_add_left T T'

lemma set_to_L1s_add_left' (T T' T'' : set α → E →L[ℝ] F)
  (h_add : ∀ s, measurable_set s → μ s < ∞ → T'' s = T s + T' s) (f : α →₁ₛ[μ] E) :
  set_to_L1s T'' f = set_to_L1s T f + set_to_L1s T' f :=
simple_func.set_to_simple_func_add_left' T T' T'' h_add (simple_func.integrable f)

lemma set_to_L1s_smul_left (T : set α → E →L[ℝ] F) (c : ℝ) (f : α →₁ₛ[μ] E) :
  set_to_L1s (λ s, c • (T s)) f = c • set_to_L1s T f :=
simple_func.set_to_simple_func_smul_left T c _

lemma set_to_L1s_smul_left' (T T' : set α → E →L[ℝ] F) (c : ℝ)
  (h_smul : ∀ s, measurable_set s → μ s < ∞ → T' s = c • (T s)) (f : α →₁ₛ[μ] E) :
  set_to_L1s T' f = c • set_to_L1s T f :=
simple_func.set_to_simple_func_smul_left' T T' c h_smul (simple_func.integrable f)

lemma set_to_L1s_add (T : set α → E →L[ℝ] F) (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0)
  (h_add : fin_meas_additive μ T) (f g : α →₁ₛ[μ] E) :
  set_to_L1s T (f + g) = set_to_L1s T f + set_to_L1s T g :=
begin
  simp_rw set_to_L1s,
  rw ← simple_func.set_to_simple_func_add T h_add
    (simple_func.integrable f) (simple_func.integrable g),
  exact simple_func.set_to_simple_func_congr T h_zero h_add (simple_func.integrable _)
    (add_to_simple_func f g),
end

lemma set_to_L1s_neg {T : set α → E →L[ℝ] F}
  (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0) (h_add : fin_meas_additive μ T)
  (f : α →₁ₛ[μ] E) :
  set_to_L1s T (-f) = - set_to_L1s T f :=
begin
  simp_rw set_to_L1s,
  have : simple_func.to_simple_func (-f) =ᵐ[μ] ⇑(-simple_func.to_simple_func f),
    from neg_to_simple_func f,
  rw simple_func.set_to_simple_func_congr T h_zero h_add (simple_func.integrable _) this,
  exact simple_func.set_to_simple_func_neg T h_add (simple_func.integrable f),
end

lemma set_to_L1s_sub {T : set α → E →L[ℝ] F}
  (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0) (h_add : fin_meas_additive μ T)
  (f g : α →₁ₛ[μ] E) :
  set_to_L1s T (f - g) = set_to_L1s T f - set_to_L1s T g :=
by rw [sub_eq_add_neg, set_to_L1s_add T h_zero h_add, set_to_L1s_neg h_zero h_add, sub_eq_add_neg]

lemma set_to_L1s_smul_real (T : set α → E →L[ℝ] F)
  (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0) (h_add : fin_meas_additive μ T)
  (c : ℝ) (f : α →₁ₛ[μ] E) :
  set_to_L1s T (c • f) = c • set_to_L1s T f :=
begin
  simp_rw set_to_L1s,
  rw ← simple_func.set_to_simple_func_smul_real T h_add c (simple_func.integrable f),
  refine simple_func.set_to_simple_func_congr T h_zero h_add (simple_func.integrable _) _,
  exact smul_to_simple_func c f,
end

lemma set_to_L1s_smul {E} [normed_group E] [normed_space ℝ E]
  [normed_space 𝕜 E] [normed_space 𝕜 F]
  (T : set α → E →L[ℝ] F) (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0)
  (h_add : fin_meas_additive μ T)
  (h_smul : ∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x) (c : 𝕜) (f : α →₁ₛ[μ] E) :
  set_to_L1s T (c • f) = c • set_to_L1s T f :=
begin
  simp_rw set_to_L1s,
  rw ← simple_func.set_to_simple_func_smul T h_add h_smul c (simple_func.integrable f),
  refine simple_func.set_to_simple_func_congr T h_zero h_add (simple_func.integrable _) _,
  exact smul_to_simple_func c f,
end

lemma norm_set_to_L1s_le (T : set α → E →L[ℝ] F) {C : ℝ}
  (hT_norm : ∀ s, measurable_set s → μ s < ∞ → ∥T s∥ ≤ C * (μ s).to_real) (f : α →₁ₛ[μ] E) :
  ∥set_to_L1s T f∥ ≤ C * ∥f∥ :=
begin
  rw [set_to_L1s, norm_eq_sum_mul f],
  exact simple_func.norm_set_to_simple_func_le_sum_mul_norm_of_integrable T hT_norm _
    (simple_func.integrable f),
end

lemma set_to_L1s_indicator_const {T : set α → E →L[ℝ] F} {s : set α}
  (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0) (h_add : fin_meas_additive μ T)
  (hs : measurable_set s) (hμs : μ s < ∞) (x : E) :
  set_to_L1s T (simple_func.indicator_const 1 hs hμs.ne x) = T s x :=
begin
  have h_empty : T ∅ = 0, from h_zero _ measurable_set.empty measure_empty,
  rw set_to_L1s_eq_set_to_simple_func,
  refine eq.trans _ (simple_func.set_to_simple_func_indicator T h_empty hs x),
  refine simple_func.set_to_simple_func_congr T h_zero h_add (simple_func.integrable _) _,
  exact to_simple_func_indicator_const hs hμs.ne x,
end

lemma set_to_L1s_const [is_finite_measure μ] {T : set α → E →L[ℝ] F}
  (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0) (h_add : fin_meas_additive μ T) (x : E) :
  set_to_L1s T (simple_func.indicator_const 1 measurable_set.univ (measure_ne_top μ _) x)
    = T univ x :=
set_to_L1s_indicator_const h_zero h_add measurable_set.univ (measure_lt_top _ _) x

section order

variables {G'' G' : Type*} [normed_lattice_add_comm_group G'] [normed_space ℝ G']
  [normed_lattice_add_comm_group G'']  [normed_space ℝ G'']
  {T : set α → G'' →L[ℝ] G'}

lemma set_to_L1s_mono_left {T T' : set α → E →L[ℝ] G''} (hTT' : ∀ s x, T s x ≤ T' s x)
  (f : α →₁ₛ[μ] E) :
  set_to_L1s T f ≤ set_to_L1s T' f :=
simple_func.set_to_simple_func_mono_left T T' hTT' _

lemma set_to_L1s_mono_left' {T T' : set α → E →L[ℝ] G''}
  (hTT' : ∀ s, measurable_set s → μ s < ∞ → ∀ x, T s x ≤ T' s x) (f : α →₁ₛ[μ] E) :
  set_to_L1s T f ≤ set_to_L1s T' f :=
simple_func.set_to_simple_func_mono_left' T T' hTT' _ (simple_func.integrable f)

lemma set_to_L1s_nonneg (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0)
  (h_add : fin_meas_additive μ T)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f : α →₁ₛ[μ] G''} (hf : 0 ≤ f) :
  0 ≤ set_to_L1s T f :=
begin
  simp_rw set_to_L1s,
  obtain ⟨f', hf', hff'⟩ : ∃ f' : α →ₛ G'', 0 ≤ f' ∧ simple_func.to_simple_func f =ᵐ[μ] f',
  { obtain ⟨f'', hf'', hff''⟩ := exists_simple_func_nonneg_ae_eq hf,
    exact ⟨f'', hf'', (Lp.simple_func.to_simple_func_eq_to_fun f).trans hff''⟩, },
  rw simple_func.set_to_simple_func_congr _ h_zero h_add (simple_func.integrable _) hff',
  exact simple_func.set_to_simple_func_nonneg' T hT_nonneg _ hf'
    ((simple_func.integrable f).congr hff'),
end

lemma set_to_L1s_mono (h_zero : ∀ s, measurable_set s → μ s = 0 → T s = 0)
  (h_add : fin_meas_additive μ T)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f g : α →₁ₛ[μ] G''} (hfg : f ≤ g) :
  set_to_L1s T f ≤ set_to_L1s T g :=
begin
  rw ← sub_nonneg at ⊢ hfg,
  rw ← set_to_L1s_sub h_zero h_add,
  exact set_to_L1s_nonneg h_zero h_add hT_nonneg hfg,
end

end order

variables [normed_space 𝕜 F]

variables (α E μ 𝕜)
/-- Extend `set α → E →L[ℝ] F` to `(α →₁ₛ[μ] E) →L[𝕜] F`. -/
def set_to_L1s_clm' {T : set α → E →L[ℝ] F} {C : ℝ} (hT : dominated_fin_meas_additive μ T C)
  (h_smul : ∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x) :
  (α →₁ₛ[μ] E) →L[𝕜] F :=
linear_map.mk_continuous ⟨set_to_L1s T, set_to_L1s_add T (λ _, hT.eq_zero_of_measure_zero) hT.1,
  set_to_L1s_smul T (λ _, hT.eq_zero_of_measure_zero) hT.1 h_smul⟩ C
  (λ f, norm_set_to_L1s_le T hT.2 f)

/-- Extend `set α → E →L[ℝ] F` to `(α →₁ₛ[μ] E) →L[ℝ] F`. -/
def set_to_L1s_clm {T : set α → E →L[ℝ] F} {C : ℝ} (hT : dominated_fin_meas_additive μ T C) :
  (α →₁ₛ[μ] E) →L[ℝ] F :=
linear_map.mk_continuous ⟨set_to_L1s T, set_to_L1s_add T (λ _, hT.eq_zero_of_measure_zero) hT.1,
  set_to_L1s_smul_real T (λ _, hT.eq_zero_of_measure_zero) hT.1⟩ C
  (λ f, norm_set_to_L1s_le T hT.2 f)

variables {α E μ 𝕜}

variables {T T' T'' : set α → E →L[ℝ] F} {C C' C'' : ℝ}

@[simp] lemma set_to_L1s_clm_zero_left
  (hT : dominated_fin_meas_additive μ (0 : set α → E →L[ℝ] F) C) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT f = 0 :=
set_to_L1s_zero_left _

lemma set_to_L1s_clm_zero_left' (hT : dominated_fin_meas_additive μ T C)
  (h_zero : ∀ s, measurable_set s → μ s < ∞ → T s = 0) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT f = 0 :=
set_to_L1s_zero_left' h_zero f

lemma set_to_L1s_clm_congr_left (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (h : T = T') (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT f = set_to_L1s_clm α E μ hT' f :=
set_to_L1s_congr_left T T' (λ _ _ _, by rw h) f

lemma set_to_L1s_clm_congr_left' (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C')
  (h : ∀ s, measurable_set s → μ s < ∞ → T s = T' s) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT f = set_to_L1s_clm α E μ hT' f :=
set_to_L1s_congr_left T T' h f

lemma set_to_L1s_clm_congr_measure {μ' : measure α}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ' T C')
  (hμ : μ ≪ μ') (f : α →₁ₛ[μ] E) (f' : α →₁ₛ[μ'] E) (h : f =ᵐ[μ] f') :
  set_to_L1s_clm α E μ hT f = set_to_L1s_clm α E μ' hT' f' :=
set_to_L1s_congr_measure T (λ s, hT.eq_zero_of_measure_zero) hT.1 hμ _ _ h

lemma set_to_L1s_clm_add_left (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ (hT.add hT') f = set_to_L1s_clm α E μ hT f + set_to_L1s_clm α E μ hT' f :=
set_to_L1s_add_left T T' f

lemma set_to_L1s_clm_add_left' (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (hT'' : dominated_fin_meas_additive μ T'' C'')
  (h_add : ∀ s, measurable_set s → μ s < ∞ → T'' s = T s + T' s) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT'' f = set_to_L1s_clm α E μ hT f + set_to_L1s_clm α E μ hT' f :=
set_to_L1s_add_left' T T' T'' h_add f

lemma set_to_L1s_clm_smul_left (c : ℝ) (hT : dominated_fin_meas_additive μ T C) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ (hT.smul c) f = c • set_to_L1s_clm α E μ hT f :=
set_to_L1s_smul_left T c f

lemma set_to_L1s_clm_smul_left' (c : ℝ)
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (h_smul : ∀ s, measurable_set s → μ s < ∞ → T' s = c • (T s)) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT' f = c • set_to_L1s_clm α E μ hT f :=
set_to_L1s_smul_left' T T' c h_smul f

lemma norm_set_to_L1s_clm_le {T : set α → E →L[ℝ] F} {C : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hC : 0 ≤ C) :
  ∥set_to_L1s_clm α E μ hT∥ ≤ C :=
linear_map.mk_continuous_norm_le _ hC _

lemma norm_set_to_L1s_clm_le' {T : set α → E →L[ℝ] F} {C : ℝ}
  (hT : dominated_fin_meas_additive μ T C) :
  ∥set_to_L1s_clm α E μ hT∥ ≤ max C 0 :=
linear_map.mk_continuous_norm_le' _ _

lemma set_to_L1s_clm_const [is_finite_measure μ] {T : set α → E →L[ℝ] F} {C : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (x : E) :
  set_to_L1s_clm α E μ hT (simple_func.indicator_const 1 measurable_set.univ (measure_ne_top μ _) x)
    = T univ x :=
set_to_L1s_const (λ s, hT.eq_zero_of_measure_zero) hT.1 x

section order

variables {G' G'' : Type*} [normed_lattice_add_comm_group G''] [normed_space ℝ G'']
  [normed_lattice_add_comm_group G'] [normed_space ℝ G']

lemma set_to_L1s_clm_mono_left {T T' : set α → E →L[ℝ] G''} {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (hTT' : ∀ s x, T s x ≤ T' s x) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT f ≤ set_to_L1s_clm α E μ hT' f :=
simple_func.set_to_simple_func_mono_left T T' hTT' _

lemma set_to_L1s_clm_mono_left' {T T' : set α → E →L[ℝ] G''} {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (hTT' : ∀ s, measurable_set s → μ s < ∞ → ∀ x, T s x ≤ T' s x) (f : α →₁ₛ[μ] E) :
  set_to_L1s_clm α E μ hT f ≤ set_to_L1s_clm α E μ hT' f :=
simple_func.set_to_simple_func_mono_left' T T' hTT' _ (simple_func.integrable f)

lemma set_to_L1s_clm_nonneg {T : set α → G' →L[ℝ] G''} {C : ℝ}
  (hT : dominated_fin_meas_additive μ T C)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f : α →₁ₛ[μ] G'} (hf : 0 ≤ f) :
  0 ≤ set_to_L1s_clm α G' μ hT f :=
set_to_L1s_nonneg (λ s, hT.eq_zero_of_measure_zero) hT.1 hT_nonneg hf

lemma set_to_L1s_clm_mono {T : set α → G' →L[ℝ] G''} {C : ℝ}
  (hT : dominated_fin_meas_additive μ T C)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f g : α →₁ₛ[μ] G'} (hfg : f ≤ g) :
  set_to_L1s_clm α G' μ hT f ≤ set_to_L1s_clm α G' μ hT g :=
set_to_L1s_mono (λ s, hT.eq_zero_of_measure_zero) hT.1 hT_nonneg hfg

end order

end set_to_L1s

end simple_func

open simple_func

section set_to_L1

local attribute [instance] Lp.simple_func.module
local attribute [instance] Lp.simple_func.normed_space

variables (𝕜) [nondiscrete_normed_field 𝕜] [normed_space 𝕜 E]
  [normed_space 𝕜 F] [complete_space F]
  {T T' T'' : set α → E →L[ℝ] F} {C C' C'' : ℝ}

/-- Extend `set α → (E →L[ℝ] F)` to `(α →₁[μ] E) →L[𝕜] F`. -/
def set_to_L1' (hT : dominated_fin_meas_additive μ T C)
  (h_smul : ∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x) :
  (α →₁[μ] E) →L[𝕜] F :=
(set_to_L1s_clm' α E 𝕜 μ hT h_smul).extend
  (coe_to_Lp α E 𝕜) (simple_func.dense_range one_ne_top) simple_func.uniform_inducing

variables {𝕜}

/-- Extend `set α → E →L[ℝ] F` to `(α →₁[μ] E) →L[ℝ] F`. -/
def set_to_L1 (hT : dominated_fin_meas_additive μ T C) : (α →₁[μ] E) →L[ℝ] F :=
(set_to_L1s_clm α E μ hT).extend
  (coe_to_Lp α E ℝ) (simple_func.dense_range one_ne_top) simple_func.uniform_inducing

lemma set_to_L1_eq_set_to_L1s_clm (hT : dominated_fin_meas_additive μ T C) (f : α →₁ₛ[μ] E) :
  set_to_L1 hT f = set_to_L1s_clm α E μ hT f :=
uniformly_extend_of_ind simple_func.uniform_inducing (simple_func.dense_range one_ne_top)
  (set_to_L1s_clm α E μ hT).uniform_continuous _

lemma set_to_L1_eq_set_to_L1' (hT : dominated_fin_meas_additive μ T C)
  (h_smul : ∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x) (f : α →₁[μ] E) :
  set_to_L1 hT f = set_to_L1' 𝕜 hT h_smul f :=
rfl

@[simp] lemma set_to_L1_zero_left
  (hT : dominated_fin_meas_additive μ (0 : set α → E →L[ℝ] F) C) (f : α →₁[μ] E) :
  set_to_L1 hT f = 0 :=
begin
  suffices : set_to_L1 hT = 0, by { rw this, simp, },
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ hT) _ _ _ _ _,
  ext1 f,
  rw [set_to_L1s_clm_zero_left hT f, continuous_linear_map.zero_comp,
    continuous_linear_map.zero_apply],
end

lemma set_to_L1_zero_left' (hT : dominated_fin_meas_additive μ T C)
  (h_zero : ∀ s, measurable_set s → μ s < ∞ → T s = 0) (f : α →₁[μ] E) :
  set_to_L1 hT f = 0 :=
begin
  suffices : set_to_L1 hT = 0, by { rw this, simp, },
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ hT) _ _ _ _ _,
  ext1 f,
  rw [set_to_L1s_clm_zero_left' hT h_zero f, continuous_linear_map.zero_comp,
    continuous_linear_map.zero_apply],
end

lemma set_to_L1_congr_left (T T' : set α → E →L[ℝ] F) {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (h : T = T') (f : α →₁[μ] E) :
  set_to_L1 hT f = set_to_L1 hT' f :=
begin
  suffices : set_to_L1 hT = set_to_L1 hT', by rw this,
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ hT) _ _ _ _ _,
  ext1 f,
  suffices : set_to_L1 hT' f = set_to_L1s_clm α E μ hT f,
    by { rw ← this, congr' 1, },
  rw set_to_L1_eq_set_to_L1s_clm,
  exact set_to_L1s_clm_congr_left hT' hT h.symm f,
end

lemma set_to_L1_congr_left' (T T' : set α → E →L[ℝ] F) {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (h : ∀ s, measurable_set s → μ s < ∞ → T s = T' s) (f : α →₁[μ] E) :
  set_to_L1 hT f = set_to_L1 hT' f :=
begin
  suffices : set_to_L1 hT = set_to_L1 hT', by rw this,
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ hT) _ _ _ _ _,
  ext1 f,
  suffices : set_to_L1 hT' f = set_to_L1s_clm α E μ hT f,
    by { rw ← this, congr' 1, },
  rw set_to_L1_eq_set_to_L1s_clm,
  exact (set_to_L1s_clm_congr_left' hT hT' h f).symm,
end

lemma set_to_L1_add_left (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (f : α →₁[μ] E) :
  set_to_L1 (hT.add hT') f = set_to_L1 hT f + set_to_L1 hT' f :=
begin
  suffices : set_to_L1 (hT.add hT') = set_to_L1 hT + set_to_L1 hT',
    by { rw [this, continuous_linear_map.add_apply], },
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ (hT.add hT')) _ _ _ _ _,
  ext1 f,
  simp only [continuous_linear_map.add_comp, continuous_linear_map.coe_comp', function.comp_app,
    continuous_linear_map.add_apply],
  suffices : set_to_L1 hT f + set_to_L1 hT' f = set_to_L1s_clm α E μ (hT.add hT') f,
    by { rw ← this, congr, },
  rw [set_to_L1_eq_set_to_L1s_clm, set_to_L1_eq_set_to_L1s_clm, set_to_L1s_clm_add_left hT hT'],
end

lemma set_to_L1_add_left' (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (hT'' : dominated_fin_meas_additive μ T'' C'')
  (h_add : ∀ s, measurable_set s → μ s < ∞ → T'' s = T s + T' s) (f : α →₁[μ] E) :
  set_to_L1 hT'' f = set_to_L1 hT f + set_to_L1 hT' f :=
begin
  suffices : set_to_L1 hT'' = set_to_L1 hT + set_to_L1 hT',
    by { rw [this, continuous_linear_map.add_apply], },
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ hT'') _ _ _ _ _,
  ext1 f,
  simp only [continuous_linear_map.add_comp, continuous_linear_map.coe_comp', function.comp_app,
    continuous_linear_map.add_apply],
  suffices : set_to_L1 hT f + set_to_L1 hT' f = set_to_L1s_clm α E μ hT'' f,
    by { rw ← this, congr, },
  rw [set_to_L1_eq_set_to_L1s_clm, set_to_L1_eq_set_to_L1s_clm,
    set_to_L1s_clm_add_left' hT hT' hT'' h_add],
end

lemma set_to_L1_smul_left (hT : dominated_fin_meas_additive μ T C) (c : ℝ) (f : α →₁[μ] E) :
  set_to_L1 (hT.smul c) f = c • set_to_L1 hT f :=
begin
  suffices : set_to_L1 (hT.smul c) = c • set_to_L1 hT,
    by { rw [this, continuous_linear_map.smul_apply], },
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ (hT.smul c)) _ _ _ _ _,
  ext1 f,
  simp only [continuous_linear_map.coe_comp', function.comp_app, continuous_linear_map.smul_comp,
    pi.smul_apply, continuous_linear_map.coe_smul'],
  suffices : c • set_to_L1 hT f = set_to_L1s_clm α E μ (hT.smul c) f, by { rw ← this, congr, },
  rw [set_to_L1_eq_set_to_L1s_clm, set_to_L1s_clm_smul_left c hT],
end

lemma set_to_L1_smul_left' (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (c : ℝ)
  (h_smul : ∀ s, measurable_set s → μ s < ∞ → T' s = c • (T s)) (f : α →₁[μ] E) :
  set_to_L1 hT' f = c • set_to_L1 hT f :=
begin
  suffices : set_to_L1 hT' = c • set_to_L1 hT,
    by { rw [this, continuous_linear_map.smul_apply], },
  refine continuous_linear_map.extend_unique (set_to_L1s_clm α E μ hT') _ _ _ _ _,
  ext1 f,
  simp only [continuous_linear_map.coe_comp', function.comp_app, continuous_linear_map.smul_comp,
    pi.smul_apply, continuous_linear_map.coe_smul'],
  suffices : c • set_to_L1 hT f = set_to_L1s_clm α E μ hT' f, by { rw ← this, congr, },
  rw [set_to_L1_eq_set_to_L1s_clm, set_to_L1s_clm_smul_left' c hT hT' h_smul],
end

lemma set_to_L1_smul (hT : dominated_fin_meas_additive μ T C)
  (h_smul : ∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x) (c : 𝕜) (f : α →₁[μ] E) :
  set_to_L1 hT (c • f) = c • set_to_L1 hT f :=
begin
  rw [set_to_L1_eq_set_to_L1' hT h_smul, set_to_L1_eq_set_to_L1' hT h_smul],
  exact continuous_linear_map.map_smul _ _ _,
end

lemma set_to_L1_simple_func_indicator_const (hT : dominated_fin_meas_additive μ T C) {s : set α}
  (hs : measurable_set s) (hμs : μ s < ∞) (x : E) :
  set_to_L1 hT (simple_func.indicator_const 1 hs hμs.ne x) = T s x :=
begin
  rw set_to_L1_eq_set_to_L1s_clm,
  exact set_to_L1s_indicator_const (λ s, hT.eq_zero_of_measure_zero) hT.1 hs hμs x,
end

lemma set_to_L1_indicator_const_Lp (hT : dominated_fin_meas_additive μ T C) {s : set α}
  (hs : measurable_set s) (hμs : μ s ≠ ∞) (x : E) :
  set_to_L1 hT (indicator_const_Lp 1 hs hμs x) = T s x :=
begin
  rw ← Lp.simple_func.coe_indicator_const hs hμs x,
  exact set_to_L1_simple_func_indicator_const hT hs hμs.lt_top x,
end

lemma set_to_L1_const [is_finite_measure μ] (hT : dominated_fin_meas_additive μ T C) (x : E) :
  set_to_L1 hT (indicator_const_Lp 1 measurable_set.univ (measure_ne_top _ _) x) = T univ x :=
set_to_L1_indicator_const_Lp hT measurable_set.univ (measure_ne_top _ _) x

section order

variables {G' G'' : Type*} [normed_lattice_add_comm_group G''] [normed_space ℝ G'']
  [complete_space G'']
  [normed_lattice_add_comm_group G'] [normed_space ℝ G']

lemma set_to_L1_mono_left' {T T' : set α → E →L[ℝ] G''} {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (hTT' : ∀ s, measurable_set s → μ s < ∞ → ∀ x, T s x ≤ T' s x) (f : α →₁[μ] E) :
  set_to_L1 hT f ≤ set_to_L1 hT' f :=
begin
  refine Lp.induction one_ne_top _ _ _ _ f,
  { intros c s hs hμs,
    rw [set_to_L1_simple_func_indicator_const hT hs hμs,
      set_to_L1_simple_func_indicator_const hT' hs hμs],
    exact hTT' s hs hμs c, },
  { intros f g hf hg hfg_disj hf_le hg_le,
    rw [(set_to_L1 hT).map_add, (set_to_L1 hT').map_add],
    exact add_le_add hf_le hg_le, },
  { exact is_closed_le (set_to_L1 hT).continuous (set_to_L1 hT').continuous, },
end

lemma set_to_L1_mono_left {T T' : set α → E →L[ℝ] G''} {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (hTT' : ∀ s x, T s x ≤ T' s x) (f : α →₁[μ] E) :
  set_to_L1 hT f ≤ set_to_L1 hT' f :=
set_to_L1_mono_left' hT hT' (λ s _ _ x, hTT' s x) f

lemma set_to_L1_nonneg {T : set α → G' →L[ℝ] G''} {C : ℝ} (hT : dominated_fin_meas_additive μ T C)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f : α →₁[μ] G'} (hf : 0 ≤ f) :
  0 ≤ set_to_L1 hT f :=
begin
  suffices : ∀ f : {g : α →₁[μ] G' // 0 ≤ g}, 0 ≤ set_to_L1 hT f,
    from this (⟨f, hf⟩ : {g : α →₁[μ] G' // 0 ≤ g}),
  refine λ g, @is_closed_property {g : α →₁ₛ[μ] G' // 0 ≤ g} {g : α →₁[μ] G' // 0 ≤ g} _ _ _
    (dense_range_coe_simple_func_nonneg_to_Lp_nonneg 1 μ G' one_ne_top) _ _ g,
  { exact is_closed_le continuous_zero ((set_to_L1 hT).continuous.comp continuous_induced_dom), },
  { intros g,
    have : (coe_simple_func_nonneg_to_Lp_nonneg 1 μ G' g : α →₁[μ] G') = (g : α →₁ₛ[μ] G') := rfl,
    rw [this, set_to_L1_eq_set_to_L1s_clm],
    exact set_to_L1s_nonneg (λ s, hT.eq_zero_of_measure_zero) hT.1 hT_nonneg g.2, },
end

lemma set_to_L1_mono {T : set α → G' →L[ℝ] G''} {C : ℝ} (hT : dominated_fin_meas_additive μ T C)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f g : α →₁[μ] G'} (hfg : f ≤ g) :
  set_to_L1 hT f ≤ set_to_L1 hT g :=
begin
  rw ← sub_nonneg at hfg ⊢,
  rw ← (set_to_L1 hT).map_sub,
  exact set_to_L1_nonneg hT hT_nonneg hfg,
end

end order

lemma norm_set_to_L1_le_norm_set_to_L1s_clm (hT : dominated_fin_meas_additive μ T C) :
  ∥set_to_L1 hT∥ ≤ ∥set_to_L1s_clm α E μ hT∥ :=
calc ∥set_to_L1 hT∥
    ≤ (1 : ℝ≥0) * ∥set_to_L1s_clm α E μ hT∥ : begin
      refine continuous_linear_map.op_norm_extend_le (set_to_L1s_clm α E μ hT) (coe_to_Lp α E ℝ)
        (simple_func.dense_range one_ne_top) (λ x, le_of_eq _),
      rw [nnreal.coe_one, one_mul],
      refl,
    end
... = ∥set_to_L1s_clm α E μ hT∥ : by rw [nnreal.coe_one, one_mul]

lemma norm_set_to_L1_le_mul_norm (hT : dominated_fin_meas_additive μ T C) (hC : 0 ≤ C)
  (f : α →₁[μ] E) :
  ∥set_to_L1 hT f∥ ≤ C * ∥f∥ :=
calc ∥set_to_L1 hT f∥
    ≤ ∥set_to_L1s_clm α E μ hT∥ * ∥f∥ :
  continuous_linear_map.le_of_op_norm_le _ (norm_set_to_L1_le_norm_set_to_L1s_clm hT) _
... ≤ C * ∥f∥ : mul_le_mul (norm_set_to_L1s_clm_le hT hC) le_rfl (norm_nonneg _) hC

lemma norm_set_to_L1_le_mul_norm' (hT : dominated_fin_meas_additive μ T C) (f : α →₁[μ] E) :
  ∥set_to_L1 hT f∥ ≤ max C 0 * ∥f∥ :=
calc ∥set_to_L1 hT f∥
    ≤ ∥set_to_L1s_clm α E μ hT∥ * ∥f∥ :
  continuous_linear_map.le_of_op_norm_le _ (norm_set_to_L1_le_norm_set_to_L1s_clm hT) _
... ≤ max C 0 * ∥f∥ :
  mul_le_mul (norm_set_to_L1s_clm_le' hT) le_rfl (norm_nonneg _) (le_max_right _ _)

lemma norm_set_to_L1_le (hT : dominated_fin_meas_additive μ T C) (hC : 0 ≤ C) :
  ∥set_to_L1 hT∥ ≤ C :=
continuous_linear_map.op_norm_le_bound _ hC (norm_set_to_L1_le_mul_norm hT hC)

lemma norm_set_to_L1_le' (hT : dominated_fin_meas_additive μ T C) :
  ∥set_to_L1 hT∥ ≤ max C 0 :=
continuous_linear_map.op_norm_le_bound _ (le_max_right _ _) (norm_set_to_L1_le_mul_norm' hT)

lemma set_to_L1_lipschitz (hT : dominated_fin_meas_additive μ T C) :
  lipschitz_with (real.to_nnreal C) (set_to_L1 hT) :=
(set_to_L1 hT).lipschitz.weaken (norm_set_to_L1_le' hT)

/-- If `fs i → f` in `L1`, then `set_to_L1 hT (fs i) → set_to_L1 hT f`. -/
lemma tendsto_set_to_L1 (hT : dominated_fin_meas_additive μ T C) (f : α →₁[μ] E)
  {ι} (fs : ι → α →₁[μ] E) {l : filter ι} (hfs : tendsto fs l (𝓝 f)) :
  tendsto (λ i, set_to_L1 hT (fs i)) l (𝓝 $ set_to_L1 hT f) :=
((set_to_L1 hT).continuous.tendsto _).comp hfs

end set_to_L1

end L1

section function

variables [complete_space F]
  {T T' T'': set α → E →L[ℝ] F} {C C' C'' : ℝ} {f g : α → E}

variables (μ T)
/-- Extend `T : set α → E →L[ℝ] F` to `(α → E) → F` (for integrable functions `α → E`). We set it to
0 if the function is not integrable. -/
def set_to_fun (hT : dominated_fin_meas_additive μ T C) (f : α → E) : F :=
if hf : integrable f μ then L1.set_to_L1 hT (hf.to_L1 f) else 0

variables {μ T}

lemma set_to_fun_eq (hT : dominated_fin_meas_additive μ T C) (hf : integrable f μ) :
  set_to_fun μ T hT f = L1.set_to_L1 hT (hf.to_L1 f) :=
dif_pos hf

lemma L1.set_to_fun_eq_set_to_L1 (hT : dominated_fin_meas_additive μ T C) (f : α →₁[μ] E) :
  set_to_fun μ T hT f = L1.set_to_L1 hT f :=
by rw [set_to_fun_eq hT (L1.integrable_coe_fn f), integrable.to_L1_coe_fn]

lemma set_to_fun_undef (hT : dominated_fin_meas_additive μ T C) (hf : ¬ integrable f μ) :
  set_to_fun μ T hT f = 0 :=
dif_neg hf

lemma set_to_fun_non_ae_strongly_measurable (hT : dominated_fin_meas_additive μ T C)
  (hf : ¬ ae_strongly_measurable f μ) :
  set_to_fun μ T hT f = 0 :=
set_to_fun_undef hT (not_and_of_not_left _ hf)

lemma set_to_fun_congr_left (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (h : T = T') (f : α → E) :
  set_to_fun μ T hT f = set_to_fun μ T' hT' f :=
begin
  by_cases hf : integrable f μ,
  { simp_rw [set_to_fun_eq _ hf, L1.set_to_L1_congr_left T T' hT hT' h], },
  { simp_rw [set_to_fun_undef _ hf], },
end

lemma set_to_fun_congr_left'
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (h : ∀ s, measurable_set s → μ s < ∞ → T s = T' s) (f : α → E) :
  set_to_fun μ T hT f = set_to_fun μ T' hT' f :=
begin
  by_cases hf : integrable f μ,
  { simp_rw [set_to_fun_eq _ hf, L1.set_to_L1_congr_left' T T' hT hT' h], },
  { simp_rw [set_to_fun_undef _ hf], },
end

lemma set_to_fun_add_left (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (f : α → E) :
  set_to_fun μ (T + T') (hT.add hT') f = set_to_fun μ T hT f + set_to_fun μ T' hT' f :=
begin
  by_cases hf : integrable f μ,
  { simp_rw [set_to_fun_eq _ hf, L1.set_to_L1_add_left hT hT'], },
  { simp_rw [set_to_fun_undef _ hf, add_zero], },
end

lemma set_to_fun_add_left' (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (hT'' : dominated_fin_meas_additive μ T'' C'')
  (h_add : ∀ s, measurable_set s → μ s < ∞ → T'' s = T s + T' s) (f : α → E) :
  set_to_fun μ T'' hT'' f = set_to_fun μ T hT f + set_to_fun μ T' hT' f :=
begin
  by_cases hf : integrable f μ,
  { simp_rw [set_to_fun_eq _ hf, L1.set_to_L1_add_left' hT hT' hT'' h_add], },
  { simp_rw [set_to_fun_undef _ hf, add_zero], },
end

lemma set_to_fun_smul_left (hT : dominated_fin_meas_additive μ T C) (c : ℝ) (f : α → E) :
  set_to_fun μ (λ s, c • (T s)) (hT.smul c) f = c • set_to_fun μ T hT f :=
begin
  by_cases hf : integrable f μ,
  { simp_rw [set_to_fun_eq _ hf, L1.set_to_L1_smul_left hT c], },
  { simp_rw [set_to_fun_undef _ hf, smul_zero], },
end

lemma set_to_fun_smul_left' (hT : dominated_fin_meas_additive μ T C)
  (hT' : dominated_fin_meas_additive μ T' C') (c : ℝ)
  (h_smul : ∀ s, measurable_set s → μ s < ∞ → T' s = c • (T s)) (f : α → E) :
  set_to_fun μ T' hT' f = c • set_to_fun μ T hT f :=
begin
  by_cases hf : integrable f μ,
  { simp_rw [set_to_fun_eq _ hf, L1.set_to_L1_smul_left' hT hT' c h_smul], },
  { simp_rw [set_to_fun_undef _ hf, smul_zero], },
end

@[simp] lemma set_to_fun_zero (hT : dominated_fin_meas_additive μ T C) :
  set_to_fun μ T hT (0 : α → E) = 0 :=
begin
  rw set_to_fun_eq hT,
  { simp only [integrable.to_L1_zero, continuous_linear_map.map_zero], },
  { exact integrable_zero _ _ _, },
end

@[simp] lemma set_to_fun_zero_left {hT : dominated_fin_meas_additive μ (0 : set α → E →L[ℝ] F) C} :
  set_to_fun μ 0 hT f = 0 :=
begin
  by_cases hf : integrable f μ,
  { rw set_to_fun_eq hT hf, exact L1.set_to_L1_zero_left hT _, },
  { exact set_to_fun_undef hT hf, },
end

lemma set_to_fun_zero_left' (hT : dominated_fin_meas_additive μ T C)
  (h_zero : ∀ s, measurable_set s → μ s < ∞ → T s = 0) :
  set_to_fun μ T hT f = 0 :=
begin
  by_cases hf : integrable f μ,
  { rw set_to_fun_eq hT hf, exact L1.set_to_L1_zero_left' hT h_zero _, },
  { exact set_to_fun_undef hT hf, },
end

lemma set_to_fun_add (hT : dominated_fin_meas_additive μ T C)
  (hf : integrable f μ) (hg : integrable g μ) :
  set_to_fun μ T hT (f + g) = set_to_fun μ T hT f + set_to_fun μ T hT g :=
by rw [set_to_fun_eq hT (hf.add hg), set_to_fun_eq hT hf, set_to_fun_eq hT hg, integrable.to_L1_add,
  (L1.set_to_L1 hT).map_add]

lemma set_to_fun_finset_sum' (hT : dominated_fin_meas_additive μ T C) {ι} (s : finset ι)
  {f : ι → α → E} (hf : ∀ i ∈ s, integrable (f i) μ) :
  set_to_fun μ T hT (∑ i in s, f i) = ∑ i in s, set_to_fun μ T hT (f i) :=
begin
  revert hf,
  refine finset.induction_on s _ _,
  { intro h,
    simp only [set_to_fun_zero, finset.sum_empty] },
  { assume i s his ih hf,
    simp only [his, finset.sum_insert, not_false_iff],
    rw set_to_fun_add hT (hf i (finset.mem_insert_self i s)) _,
    { rw ih (λ i hi, hf i (finset.mem_insert_of_mem hi)), },
    { convert (integrable_finset_sum s (λ i hi, hf i (finset.mem_insert_of_mem hi))),
      ext1 x,
      simp, }, }
end

lemma set_to_fun_finset_sum (hT : dominated_fin_meas_additive μ T C) {ι} (s : finset ι)
  {f : ι → α → E} (hf : ∀ i ∈ s, integrable (f i) μ) :
  set_to_fun μ T hT (λ a, ∑ i in s, f i a) = ∑ i in s, set_to_fun μ T hT (f i) :=
by { convert set_to_fun_finset_sum' hT s hf, ext1 a, simp, }

lemma set_to_fun_neg (hT : dominated_fin_meas_additive μ T C) (f : α → E) :
  set_to_fun μ T hT (-f) = - set_to_fun μ T hT f :=
begin
  by_cases hf : integrable f μ,
  { rw [set_to_fun_eq hT hf, set_to_fun_eq hT hf.neg,
      integrable.to_L1_neg, (L1.set_to_L1 hT).map_neg], },
  { rw [set_to_fun_undef hT hf, set_to_fun_undef hT, neg_zero],
    rwa [← integrable_neg_iff] at hf, }
end

lemma set_to_fun_sub (hT : dominated_fin_meas_additive μ T C)
  (hf : integrable f μ) (hg : integrable g μ) :
  set_to_fun μ T hT (f - g) = set_to_fun μ T hT f - set_to_fun μ T hT g :=
by rw [sub_eq_add_neg, sub_eq_add_neg, set_to_fun_add hT hf hg.neg, set_to_fun_neg hT g]

lemma set_to_fun_smul [nondiscrete_normed_field 𝕜]
  [normed_space 𝕜 E] [normed_space 𝕜 F] (hT : dominated_fin_meas_additive μ T C)
  (h_smul : ∀ c : 𝕜, ∀ s x, T s (c • x) = c • T s x) (c : 𝕜) (f : α → E) :
  set_to_fun μ T hT (c • f) = c • set_to_fun μ T hT f :=
begin
  by_cases hf : integrable f μ,
  { rw [set_to_fun_eq hT hf, set_to_fun_eq hT, integrable.to_L1_smul',
      L1.set_to_L1_smul hT h_smul c _], },
  { by_cases hr : c = 0,
    { rw hr, simp, },
    { have hf' : ¬ integrable (c • f) μ, by rwa [integrable_smul_iff hr f],
      rw [set_to_fun_undef hT hf, set_to_fun_undef hT hf',
        smul_zero], }, },
end

lemma set_to_fun_congr_ae (hT : dominated_fin_meas_additive μ T C) (h : f =ᵐ[μ] g) :
  set_to_fun μ T hT f = set_to_fun μ T hT g :=
begin
  by_cases hfi : integrable f μ,
  { have hgi : integrable g μ := hfi.congr h,
    rw [set_to_fun_eq hT hfi, set_to_fun_eq hT hgi,
      (integrable.to_L1_eq_to_L1_iff f g hfi hgi).2 h] },
  { have hgi : ¬ integrable g μ, { rw integrable_congr h at hfi, exact hfi },
    rw [set_to_fun_undef hT hfi, set_to_fun_undef hT hgi] },
end

lemma set_to_fun_measure_zero (hT : dominated_fin_meas_additive μ T C) (h : μ = 0) :
  set_to_fun μ T hT f = 0 :=
by { have : f =ᵐ[μ] 0, by simp [h], rw [set_to_fun_congr_ae hT this, set_to_fun_zero], }

lemma set_to_fun_measure_zero' (hT : dominated_fin_meas_additive μ T C)
  (h : ∀ s, measurable_set s → μ s < ∞ → μ s = 0) :
  set_to_fun μ T hT f = 0 :=
set_to_fun_zero_left' hT (λ s hs hμs, hT.eq_zero_of_measure_zero hs (h s hs hμs))

lemma set_to_fun_to_L1 (hT : dominated_fin_meas_additive μ T C) (hf : integrable f μ) :
  set_to_fun μ T hT (hf.to_L1 f) = set_to_fun μ T hT f :=
set_to_fun_congr_ae hT hf.coe_fn_to_L1

lemma set_to_fun_indicator_const (hT : dominated_fin_meas_additive μ T C) {s : set α}
  (hs : measurable_set s) (hμs : μ s ≠ ∞) (x : E) :
  set_to_fun μ T hT (s.indicator (λ _, x)) = T s x :=
begin
  rw set_to_fun_congr_ae hT (@indicator_const_Lp_coe_fn _ _ _ 1 _ _ _ hs hμs x).symm,
  rw L1.set_to_fun_eq_set_to_L1 hT,
  exact L1.set_to_L1_indicator_const_Lp hT hs hμs x,
end

lemma set_to_fun_const [is_finite_measure μ] (hT : dominated_fin_meas_additive μ T C) (x : E) :
  set_to_fun μ T hT (λ _, x) = T univ x :=
begin
  have : (λ (_ : α) , x) = set.indicator univ (λ _, x), from (indicator_univ _).symm,
  rw this,
  exact set_to_fun_indicator_const hT measurable_set.univ (measure_ne_top _ _) x,
end

section order

variables {G' G'' : Type*} [normed_lattice_add_comm_group G''] [normed_space ℝ G'']
  [complete_space G'']
  [normed_lattice_add_comm_group G'] [normed_space ℝ G']

lemma set_to_fun_mono_left' {T T' : set α → E →L[ℝ] G''} {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (hTT' : ∀ s, measurable_set s → μ s < ∞ → ∀ x, T s x ≤ T' s x) (f : α → E) :
  set_to_fun μ T hT f ≤ set_to_fun μ T' hT' f :=
begin
  by_cases hf : integrable f μ,
  { simp_rw set_to_fun_eq _ hf, exact L1.set_to_L1_mono_left' hT hT' hTT' _, },
  { simp_rw set_to_fun_undef _ hf, },
end

lemma set_to_fun_mono_left {T T' : set α → E →L[ℝ] G''} {C C' : ℝ}
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ T' C')
  (hTT' : ∀ s x, T s x ≤ T' s x) (f : α →₁[μ] E) :
  set_to_fun μ T hT f ≤ set_to_fun μ T' hT' f :=
set_to_fun_mono_left' hT hT' (λ s _ _ x, hTT' s x) f

lemma set_to_fun_nonneg {T : set α → G' →L[ℝ] G''} {C : ℝ} (hT : dominated_fin_meas_additive μ T C)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f : α → G'} (hf : 0 ≤ᵐ[μ] f) :
  0 ≤ set_to_fun μ T hT f :=
begin
  by_cases hfi : integrable f μ,
  { simp_rw set_to_fun_eq _ hfi,
    refine L1.set_to_L1_nonneg hT hT_nonneg _,
    rw ← Lp.coe_fn_le,
    have h0 := Lp.coe_fn_zero G' 1 μ,
    have h := integrable.coe_fn_to_L1 hfi,
    filter_upwards [h0, h, hf] with _ h0a ha hfa,
    rw [h0a, ha],
    exact hfa, },
  { simp_rw set_to_fun_undef _ hfi, },
end

lemma set_to_fun_mono {T : set α → G' →L[ℝ] G''} {C : ℝ} (hT : dominated_fin_meas_additive μ T C)
  (hT_nonneg : ∀ s, measurable_set s → μ s < ∞ → ∀ x, 0 ≤ x → 0 ≤ T s x)
  {f g : α → G'} (hf : integrable f μ) (hg : integrable g μ) (hfg : f ≤ᵐ[μ] g) :
  set_to_fun μ T hT f ≤ set_to_fun μ T hT g :=
begin
  rw [← sub_nonneg, ← set_to_fun_sub hT hg hf],
  refine set_to_fun_nonneg hT hT_nonneg (hfg.mono (λ a ha, _)),
  rw [pi.sub_apply, pi.zero_apply, sub_nonneg],
  exact ha,
end

end order

@[continuity]
lemma continuous_set_to_fun (hT : dominated_fin_meas_additive μ T C) :
  continuous (λ (f : α →₁[μ] E), set_to_fun μ T hT f) :=
by { simp_rw L1.set_to_fun_eq_set_to_L1 hT, exact continuous_linear_map.continuous _, }

/-- Auxiliary lemma for `set_to_fun_congr_measure`: the function sending `f : α →₁[μ] G` to
`f : α →₁[μ'] G` is continuous when `μ' ≤ c' • μ` for `c' ≠ ∞`. -/
lemma continuous_L1_to_L1
  {μ' : measure α} (c' : ℝ≥0∞) (hc' : c' ≠ ∞) (hμ'_le : μ' ≤ c' • μ) :
  continuous (λ f : α →₁[μ] G,
    (integrable.of_measure_le_smul c' hc' hμ'_le (L1.integrable_coe_fn f)).to_L1 f) :=
begin
  by_cases hc'0 : c' = 0,
  { have hμ'0 : μ' = 0,
    { rw ← measure.nonpos_iff_eq_zero', refine hμ'_le.trans _, simp [hc'0], },
    have h_im_zero : (λ f : α →₁[μ] G,
        (integrable.of_measure_le_smul c' hc' hμ'_le (L1.integrable_coe_fn f)).to_L1 f) = 0,
      by { ext1 f, ext1, simp_rw hμ'0, simp only [ae_zero], },
    rw h_im_zero,
    exact continuous_zero, },
  rw metric.continuous_iff,
  intros f ε hε_pos,
  use (ε / 2) / c'.to_real,
  refine ⟨div_pos (half_pos hε_pos) (to_real_pos hc'0 hc'), _⟩,
  intros g hfg,
  rw Lp.dist_def at hfg ⊢,
  let h_int := λ f' : α →₁[μ] G, (L1.integrable_coe_fn f').of_measure_le_smul c' hc' hμ'_le,
  have : snorm (integrable.to_L1 g (h_int g) - integrable.to_L1 f (h_int f)) 1 μ'
      = snorm (g - f) 1 μ',
    from snorm_congr_ae ((integrable.coe_fn_to_L1 _).sub (integrable.coe_fn_to_L1 _)),
  rw this,
  have h_snorm_ne_top : snorm (g - f) 1 μ ≠ ∞,
    by { rw ← snorm_congr_ae (Lp.coe_fn_sub _ _), exact Lp.snorm_ne_top _, },
  have h_snorm_ne_top' : snorm (g - f) 1 μ' ≠ ∞,
  { refine ((snorm_mono_measure _ hμ'_le).trans_lt _).ne,
    rw [snorm_smul_measure_of_ne_zero hc'0, smul_eq_mul],
    refine ennreal.mul_lt_top _ h_snorm_ne_top,
    simp [hc', hc'0], },
  calc (snorm (g - f) 1 μ').to_real ≤ (c' * snorm (g - f) 1 μ).to_real :
    by { rw to_real_le_to_real h_snorm_ne_top' (ennreal.mul_ne_top hc' h_snorm_ne_top),
      refine (snorm_mono_measure (⇑g - ⇑f) hμ'_le).trans _,
    rw [snorm_smul_measure_of_ne_zero hc'0, smul_eq_mul],
    simp, }
  ... = c'.to_real * (snorm (⇑g - ⇑f) 1 μ).to_real : to_real_mul
  ... ≤ c'.to_real * ((ε / 2) / c'.to_real) :
    mul_le_mul le_rfl hfg.le to_real_nonneg to_real_nonneg
  ... = ε / 2 :
    by { refine mul_div_cancel' (ε / 2) _, rw [ne.def, to_real_eq_zero_iff], simp [hc', hc'0], }
  ... < ε : half_lt_self hε_pos,
end

lemma set_to_fun_congr_measure_of_integrable {μ' : measure α} (c' : ℝ≥0∞)
  (hc' : c' ≠ ∞) (hμ'_le : μ' ≤ c' • μ)
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ' T C') (f : α → E)
  (hfμ : integrable f μ) :
  set_to_fun μ T hT f = set_to_fun μ' T hT' f :=
begin
  /- integrability for `μ` implies integrability for `μ'`. -/
  have h_int : ∀ g : α → E, integrable g μ → integrable g μ',
    from λ g hg, integrable.of_measure_le_smul c' hc' hμ'_le hg,
  /- We use `integrable.induction` -/
  refine hfμ.induction _ _ _ _ _,
  { intros c s hs hμs,
    have hμ's : μ' s ≠ ∞,
    { refine ((hμ'_le s hs).trans_lt _).ne,
      rw [measure.smul_apply, smul_eq_mul],
      exact ennreal.mul_lt_top hc' hμs.ne, },
    rw [set_to_fun_indicator_const hT hs hμs.ne, set_to_fun_indicator_const hT' hs hμ's], },
  { intros f₂ g₂ h_dish hf₂ hg₂ h_eq_f h_eq_g,
    rw [set_to_fun_add hT hf₂ hg₂,
      set_to_fun_add hT' (h_int f₂ hf₂) (h_int g₂ hg₂), h_eq_f, h_eq_g], },
  { refine is_closed_eq (continuous_set_to_fun hT) _,
    have : (λ f : α →₁[μ] E, set_to_fun μ' T hT' f)
      = (λ f : α →₁[μ] E, set_to_fun μ' T hT' ((h_int f (L1.integrable_coe_fn f)).to_L1 f)),
    { ext1 f, exact set_to_fun_congr_ae hT' (integrable.coe_fn_to_L1 _).symm, },
    rw this,
    exact (continuous_set_to_fun hT').comp (continuous_L1_to_L1 c' hc' hμ'_le), },
  { intros f₂ g₂ hfg hf₂ hf_eq,
    have hfg' : f₂ =ᵐ[μ'] g₂, from (measure.absolutely_continuous_of_le_smul hμ'_le).ae_eq hfg,
    rw [← set_to_fun_congr_ae hT hfg, hf_eq, set_to_fun_congr_ae hT' hfg'], },
end

lemma set_to_fun_congr_measure {μ' : measure α} (c c' : ℝ≥0∞) (hc : c ≠ ∞) (hc' : c' ≠ ∞)
  (hμ_le : μ ≤ c • μ') (hμ'_le : μ' ≤ c' • μ)
  (hT : dominated_fin_meas_additive μ T C) (hT' : dominated_fin_meas_additive μ' T C') (f : α → E) :
  set_to_fun μ T hT f = set_to_fun μ' T hT' f :=
begin
  by_cases hf : integrable f μ,
  { exact set_to_fun_congr_measure_of_integrable c' hc' hμ'_le hT hT' f hf, },
  { /- if `f` is not integrable, both `set_to_fun` are 0. -/
    have h_int : ∀ g : α → E, ¬ integrable g μ → ¬ integrable g μ',
      from λ g, mt (λ h, h.of_measure_le_smul _ hc hμ_le),
    simp_rw [set_to_fun_undef _ hf, set_to_fun_undef _ (h_int f hf)], },
end

lemma set_to_fun_congr_measure_of_add_right {μ' : measure α}
  (hT_add : dominated_fin_meas_additive (μ + μ') T C') (hT : dominated_fin_meas_additive μ T C)
  (f : α → E) (hf : integrable f (μ + μ')) :
  set_to_fun (μ + μ') T hT_add f = set_to_fun μ T hT f :=
begin
  refine set_to_fun_congr_measure_of_integrable 1 one_ne_top _ hT_add hT f hf,
  rw one_smul,
  nth_rewrite 0 ← add_zero μ,
  exact add_le_add le_rfl bot_le,
end

lemma set_to_fun_congr_measure_of_add_left {μ' : measure α}
  (hT_add : dominated_fin_meas_additive (μ + μ') T C') (hT : dominated_fin_meas_additive μ' T C)
  (f : α → E) (hf : integrable f (μ + μ')) :
  set_to_fun (μ + μ') T hT_add f = set_to_fun μ' T hT f :=
begin
  refine set_to_fun_congr_measure_of_integrable 1 one_ne_top _ hT_add hT f hf,
  rw one_smul,
  nth_rewrite 0 ← zero_add μ',
  exact add_le_add bot_le le_rfl,
end

lemma set_to_fun_top_smul_measure (hT : dominated_fin_meas_additive (∞ • μ) T C) (f : α → E) :
  set_to_fun (∞ • μ) T hT f = 0 :=
begin
  refine set_to_fun_measure_zero' hT (λ s hs hμs, _),
  rw lt_top_iff_ne_top at hμs,
  simp only [true_and, measure.smul_apply, with_top.mul_eq_top_iff, eq_self_iff_true, top_ne_zero,
    ne.def, not_false_iff, not_or_distrib, not_not, smul_eq_mul] at hμs,
  simp only [hμs.right, measure.smul_apply, mul_zero, smul_eq_mul],
end

lemma set_to_fun_congr_smul_measure (c : ℝ≥0∞) (hc_ne_top : c ≠ ∞)
  (hT : dominated_fin_meas_additive μ T C) (hT_smul : dominated_fin_meas_additive (c • μ) T C')
  (f : α → E) :
  set_to_fun μ T hT f = set_to_fun (c • μ) T hT_smul f :=
begin
  by_cases hc0 : c = 0,
  { simp [hc0] at hT_smul,
    have h : ∀ s, measurable_set s → μ s < ∞ → T s = 0,
      from λ s hs hμs, hT_smul.eq_zero hs,
    rw [set_to_fun_zero_left' _ h, set_to_fun_measure_zero],
    simp [hc0], },
  refine set_to_fun_congr_measure c⁻¹ c _ hc_ne_top (le_of_eq _) le_rfl hT hT_smul f,
  { simp [hc0], },
  { rw [smul_smul, ennreal.inv_mul_cancel hc0 hc_ne_top, one_smul], },
end

lemma norm_set_to_fun_le_mul_norm (hT : dominated_fin_meas_additive μ T C) (f : α →₁[μ] E)
  (hC : 0 ≤ C) :
  ∥set_to_fun μ T hT f∥ ≤ C * ∥f∥ :=
by { rw L1.set_to_fun_eq_set_to_L1, exact L1.norm_set_to_L1_le_mul_norm hT hC f, }

lemma norm_set_to_fun_le_mul_norm' (hT : dominated_fin_meas_additive μ T C) (f : α →₁[μ] E) :
  ∥set_to_fun μ T hT f∥ ≤ max C 0 * ∥f∥ :=
by { rw L1.set_to_fun_eq_set_to_L1, exact L1.norm_set_to_L1_le_mul_norm' hT f, }

lemma norm_set_to_fun_le (hT : dominated_fin_meas_additive μ T C) (hf : integrable f μ)
  (hC : 0 ≤ C) :
  ∥set_to_fun μ T hT f∥ ≤ C * ∥hf.to_L1 f∥ :=
by { rw set_to_fun_eq hT hf, exact L1.norm_set_to_L1_le_mul_norm hT hC _, }

lemma norm_set_to_fun_le' (hT : dominated_fin_meas_additive μ T C) (hf : integrable f μ) :
  ∥set_to_fun μ T hT f∥ ≤ max C 0 * ∥hf.to_L1 f∥ :=
by { rw set_to_fun_eq hT hf, exact L1.norm_set_to_L1_le_mul_norm' hT _, }

/-- Lebesgue dominated convergence theorem provides sufficient conditions under which almost
  everywhere convergence of a sequence of functions implies the convergence of their image by
  `set_to_fun`.
  We could weaken the condition `bound_integrable` to require `has_finite_integral bound μ` instead
  (i.e. not requiring that `bound` is measurable), but in all applications proving integrability
  is easier. -/
theorem tendsto_set_to_fun_of_dominated_convergence (hT : dominated_fin_meas_additive μ T C)
  {fs : ℕ → α → E} {f : α → E} (bound : α → ℝ)
  (fs_measurable : ∀ n, ae_strongly_measurable (fs n) μ)
  (bound_integrable : integrable bound μ) (h_bound : ∀ n, ∀ᵐ a ∂μ, ∥fs n a∥ ≤ bound a)
  (h_lim : ∀ᵐ a ∂μ, tendsto (λ n, fs n a) at_top (𝓝 (f a))) :
  tendsto (λ n, set_to_fun μ T hT (fs n)) at_top (𝓝 $ set_to_fun μ T hT f) :=
begin
  /- `f` is a.e.-measurable, since it is the a.e.-pointwise limit of a.e.-measurable functions. -/
  have f_measurable : ae_strongly_measurable f μ :=
    ae_strongly_measurable_of_tendsto_ae _ fs_measurable h_lim,
  /- all functions we consider are integrable -/
  have fs_int : ∀ n, integrable (fs n) μ :=
    λ n, bound_integrable.mono' (fs_measurable n) (h_bound _),
  have f_int : integrable f μ :=
  ⟨f_measurable, has_finite_integral_of_dominated_convergence
    bound_integrable.has_finite_integral h_bound h_lim⟩,
  /- it suffices to prove the result for the corresponding L1 functions -/
  suffices : tendsto (λ n, L1.set_to_L1 hT ((fs_int n).to_L1 (fs n))) at_top
    (𝓝 (L1.set_to_L1 hT (f_int.to_L1 f))),
  { convert this,
    { ext1 n, exact set_to_fun_eq hT (fs_int n), },
    { exact set_to_fun_eq hT f_int, }, },
  /- the convergence of set_to_L1 follows from the convergence of the L1 functions -/
  refine L1.tendsto_set_to_L1 hT _ _ _,
  /- up to some rewriting, what we need to prove is `h_lim` -/
  rw tendsto_iff_norm_tendsto_zero,
  have lintegral_norm_tendsto_zero :
    tendsto (λn, ennreal.to_real $ ∫⁻ a, (ennreal.of_real ∥fs n a - f a∥) ∂μ) at_top (𝓝 0) :=
  (tendsto_to_real zero_ne_top).comp
    (tendsto_lintegral_norm_of_dominated_convergence
      fs_measurable bound_integrable.has_finite_integral h_bound h_lim),
  convert lintegral_norm_tendsto_zero,
  ext1 n,
  rw L1.norm_def,
  congr' 1,
  refine lintegral_congr_ae _,
  rw ← integrable.to_L1_sub,
  refine ((fs_int n).sub f_int).coe_fn_to_L1.mono (λ x hx, _),
  dsimp only,
  rw [hx, of_real_norm_eq_coe_nnnorm, pi.sub_apply],
end

/-- Lebesgue dominated convergence theorem for filters with a countable basis -/
lemma tendsto_set_to_fun_filter_of_dominated_convergence (hT : dominated_fin_meas_additive μ T C)
  {ι} {l : _root_.filter ι} [l.is_countably_generated]
  {fs : ι → α → E} {f : α → E} (bound : α → ℝ)
  (hfs_meas : ∀ᶠ n in l, ae_strongly_measurable (fs n) μ)
  (h_bound : ∀ᶠ n in l, ∀ᵐ a ∂μ, ∥fs n a∥ ≤ bound a)
  (bound_integrable : integrable bound μ)
  (h_lim : ∀ᵐ a ∂μ, tendsto (λ n, fs n a) l (𝓝 (f a))) :
  tendsto (λ n, set_to_fun μ T hT (fs n)) l (𝓝 $ set_to_fun μ T hT f) :=
begin
  rw tendsto_iff_seq_tendsto,
  intros x xl,
  have hxl : ∀ s ∈ l, ∃ a, ∀ b ≥ a, x b ∈ s, by { rwa tendsto_at_top' at xl, },
  have h : {x : ι | (λ n, ae_strongly_measurable (fs n) μ) x}
      ∩ {x : ι | (λ n, ∀ᵐ a ∂μ, ∥fs n a∥ ≤ bound a) x} ∈ l,
    from inter_mem hfs_meas h_bound,
  obtain ⟨k, h⟩ := hxl _ h,
  rw ← tendsto_add_at_top_iff_nat k,
  refine tendsto_set_to_fun_of_dominated_convergence hT bound _ bound_integrable _ _,
  { exact λ n, (h _ (self_le_add_left _ _)).1, },
  { exact λ n, (h _ (self_le_add_left _ _)).2, },
  { filter_upwards [h_lim],
    refine λ a h_lin, @tendsto.comp _ _ _ (λ n, x (n + k)) (λ n, fs n a) _ _ _ h_lin _,
    rw tendsto_add_at_top_iff_nat,
    assumption }
end

variables {X : Type*} [topological_space X] [first_countable_topology X]

lemma continuous_at_set_to_fun_of_dominated (hT : dominated_fin_meas_additive μ T C)
  {fs : X → α → E} {x₀ : X} {bound : α → ℝ}
  (hfs_meas : ∀ᶠ x in 𝓝 x₀, ae_strongly_measurable (fs x) μ)
  (h_bound : ∀ᶠ x in 𝓝 x₀, ∀ᵐ a ∂μ, ∥fs x a∥ ≤ bound a)
  (bound_integrable : integrable bound μ) (h_cont : ∀ᵐ a ∂μ, continuous_at (λ x, fs x a) x₀) :
  continuous_at (λ x, set_to_fun μ T hT (fs x)) x₀ :=
tendsto_set_to_fun_filter_of_dominated_convergence hT bound ‹_› ‹_› ‹_› ‹_›

lemma continuous_set_to_fun_of_dominated (hT : dominated_fin_meas_additive μ T C)
  {fs : X → α → E} {bound : α → ℝ}
  (hfs_meas : ∀ x, ae_strongly_measurable (fs x) μ) (h_bound : ∀ x, ∀ᵐ a ∂μ, ∥fs x a∥ ≤ bound a)
  (bound_integrable : integrable bound μ) (h_cont : ∀ᵐ a ∂μ, continuous (λ x, fs x a)) :
  continuous (λ x, set_to_fun μ T hT (fs x)) :=
continuous_iff_continuous_at.mpr (λ x₀, continuous_at_set_to_fun_of_dominated hT
  (eventually_of_forall hfs_meas) (eventually_of_forall h_bound) ‹_› $ h_cont.mono $
    λ _, continuous.continuous_at)

end function

end measure_theory


<|start_filename|>src/category_theory/limits/punit.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import category_theory.punit
import category_theory.limits.has_limits

/-!
# `discrete punit` has limits and colimits

Mostly for the sake of constructing trivial examples, we show all (co)cones into `discrete punit`
are (co)limit (co)cones. We also show that such (co)cones exist, and that `discrete punit` has all
(co)limits.
-/

universe v

open category_theory
namespace category_theory.limits

variables {J : Type v} [small_category J] {F : J ⥤ discrete punit.{v+1}}

/-- A trivial cone for a functor into `punit`. `punit_cone_is_limit` shows it is a limit. -/
def punit_cone : cone F :=
⟨⟨⟨⟩⟩, (functor.punit_ext _ _).hom⟩

/-- A trivial cocone for a functor into `punit`. `punit_cocone_is_limit` shows it is a colimit. -/
def punit_cocone : cocone F :=
⟨⟨⟨⟩⟩, (functor.punit_ext _ _).hom⟩

/--
Any cone over a functor into `punit` is a limit cone.
-/
def punit_cone_is_limit {c : cone F} : is_limit c :=
by tidy

/--
Any cocone over a functor into `punit` is a colimit cocone.
-/
def punit_cocone_is_colimit {c : cocone F} : is_colimit c :=
by tidy

instance : has_limits (discrete punit) :=
by tidy

instance : has_colimits (discrete punit) :=
by tidy

end category_theory.limits


<|start_filename|>src/measure_theory/measure/ae_disjoint.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.measure.measure_space_def

/-!
# Almost everywhere disjoint sets

We say that sets `s` and `t` are `μ`-a.e. disjoint (see `measure_theory.ae_disjoint`) if their
intersection has measure zero. This assumption can be used instead of `disjoint` in most theorems in
measure theory.
-/

open set function

namespace measure_theory

variables {ι α : Type*} {m : measurable_space α} (μ : measure α)

/-- Two sets are said to be `μ`-a.e. disjoint if their intersection has measure zero. -/
def ae_disjoint (s t : set α) := μ (s ∩ t) = 0

variables {μ} {s t u v : set α}

/-- If `s : ι → set α` is a countable family of pairwise a.e. disjoint sets, then there exists a
family of measurable null sets `t i` such that `s i \ t i` are pairwise disjoint. -/
lemma exists_null_pairwise_disjoint_diff [encodable ι] {s : ι → set α}
  (hd : pairwise (ae_disjoint μ on s)) :
  ∃ t : ι → set α, (∀ i, measurable_set (t i)) ∧ (∀ i, μ (t i) = 0) ∧ 
    pairwise (disjoint on (λ i, s i \ t i)) :=
begin
  refine ⟨λ i, to_measurable μ (s i ∩ ⋃ j ∈ ({i}ᶜ : set ι), s j),
    λ i, measurable_set_to_measurable _ _, λ i, _, _⟩,
  { simp only [measure_to_measurable, inter_Union, measure_bUnion_null_iff (countable_encodable _)],
    exact λ j hj, hd _ _ (ne.symm hj) },
  { simp only [pairwise, disjoint_left, on_fun, mem_diff, not_and, and_imp, not_not],
    intros i j hne x hi hU hj,
    replace hU : x ∉ s i ∩ ⋃ j ≠ i, s j := λ h, hU (subset_to_measurable _ _ h),
    simp only [mem_inter_eq, mem_Union, not_and, not_exists] at hU,
    exact (hU hi j hne.symm hj).elim }
end

namespace ae_disjoint

protected lemma eq (h : ae_disjoint μ s t) : μ (s ∩ t) = 0 := h

@[symm] protected lemma symm (h : ae_disjoint μ s t) : ae_disjoint μ t s :=
by rwa [ae_disjoint, inter_comm]

protected lemma symmetric : symmetric (ae_disjoint μ) := λ s t h, h.symm

protected lemma comm : ae_disjoint μ s t ↔ ae_disjoint μ t s := ⟨λ h, h.symm, λ h, h.symm⟩

protected lemma _root_.disjoint.ae_disjoint (h : disjoint s t) : ae_disjoint μ s t :=
by rw [ae_disjoint, disjoint_iff_inter_eq_empty.1 h, measure_empty]

protected lemma _root_.pairwise.ae_disjoint {f : ι → set α} (hf : pairwise (disjoint on f)) :
  pairwise (ae_disjoint μ on f) :=
hf.mono $ λ i j h, h.ae_disjoint

protected lemma _root_.set.pairwise_disjoint.ae_disjoint {f : ι → set α} {s : set ι}
  (hf : s.pairwise_disjoint f) :
  s.pairwise (ae_disjoint μ on f) :=
hf.mono' $ λ i j h, h.ae_disjoint

lemma mono_ae (h : ae_disjoint μ s t) (hu : u ≤ᵐ[μ] s) (hv : v ≤ᵐ[μ] t) : ae_disjoint μ u v :=
measure_mono_null_ae (hu.inter hv) h

lemma mono (h : ae_disjoint μ s t) (hu : u ⊆ s) (hv : v ⊆ t) : ae_disjoint μ u v :=
h.mono_ae hu.eventually_le hv.eventually_le

@[simp] lemma Union_left_iff [encodable ι] {s : ι → set α} :
  ae_disjoint μ (⋃ i, s i) t ↔ ∀ i, ae_disjoint μ (s i) t :=
by simp only [ae_disjoint, Union_inter, measure_Union_null_iff]

@[simp] lemma Union_right_iff [encodable ι] {t : ι → set α} :
  ae_disjoint μ s (⋃ i, t i) ↔ ∀ i, ae_disjoint μ s (t i) :=
by simp only [ae_disjoint, inter_Union, measure_Union_null_iff]

@[simp] lemma union_left_iff : ae_disjoint μ (s ∪ t) u ↔ ae_disjoint μ s u ∧ ae_disjoint μ t u :=
by simp [union_eq_Union, and.comm]

@[simp] lemma union_right_iff : ae_disjoint μ s (t ∪ u) ↔ ae_disjoint μ s t ∧ ae_disjoint μ s u :=
by simp [union_eq_Union, and.comm]

lemma union_left (hs : ae_disjoint μ s u) (ht : ae_disjoint μ t u) : ae_disjoint μ (s ∪ t) u :=
union_left_iff.mpr ⟨hs, ht⟩

lemma union_right (ht : ae_disjoint μ s t) (hu : ae_disjoint μ s u) : ae_disjoint μ s (t ∪ u) :=
union_right_iff.2 ⟨ht, hu⟩

lemma diff_ae_eq_left (h : ae_disjoint μ s t) : (s \ t : set α) =ᵐ[μ] s :=
@diff_self_inter _ s t ▸ diff_null_ae_eq_self h

lemma diff_ae_eq_right (h : ae_disjoint μ s t) : (t \ s : set α) =ᵐ[μ] t := h.symm.diff_ae_eq_left

lemma measure_diff_left (h : ae_disjoint μ s t) : μ (s \ t) = μ s := measure_congr h.diff_ae_eq_left

lemma measure_diff_right (h : ae_disjoint μ s t) : μ (t \ s) = μ t :=
measure_congr h.diff_ae_eq_right

/-- If `s` and `t` are `μ`-a.e. disjoint, then `s \ u` and `t` are disjoint for some measurable null
set `u`. -/
lemma exists_disjoint_diff (h : ae_disjoint μ s t) :
  ∃ u, measurable_set u ∧ μ u = 0 ∧ disjoint (s \ u) t :=
⟨to_measurable μ (s ∩ t), measurable_set_to_measurable _ _, (measure_to_measurable _).trans h,
  disjoint_diff.symm.mono_left (λ x hx, ⟨hx.1, λ hxt, hx.2 $ subset_to_measurable _ _ ⟨hx.1, hxt⟩⟩)⟩

lemma of_null_right (h : μ t = 0) : ae_disjoint μ s t :=
measure_mono_null (inter_subset_right _ _) h

lemma of_null_left (h : μ s = 0) : ae_disjoint μ s t := (of_null_right h).symm

end ae_disjoint

lemma ae_disjoint_compl_left : ae_disjoint μ sᶜ s := (@disjoint_compl_left _ s _).ae_disjoint
lemma ae_disjoint_compl_right : ae_disjoint μ s sᶜ := (@disjoint_compl_right _ s _).ae_disjoint

end measure_theory


<|start_filename|>src/algebra/category/Group/biproducts.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.group.pi
import algebra.category.Group.preadditive
import category_theory.limits.shapes.biproducts
import algebra.category.Group.limits

/-!
# The category of abelian groups has finite biproducts
-/

open category_theory
open category_theory.limits

open_locale big_operators

universe u

namespace AddCommGroup

-- As `AddCommGroup` is preadditive, and has all limits, it automatically has biproducts.
instance : has_binary_biproducts AddCommGroup :=
has_binary_biproducts.of_has_binary_products

instance : has_finite_biproducts AddCommGroup :=
has_finite_biproducts.of_has_finite_products

-- We now construct explicit limit data,
-- so we can compare the biproducts to the usual unbundled constructions.

/--
Construct limit data for a binary product in `AddCommGroup`, using `AddCommGroup.of (G × H)`.
-/
@[simps cone_X is_limit_lift]
def binary_product_limit_cone (G H : AddCommGroup.{u}) : limits.limit_cone (pair G H) :=
{ cone :=
  { X := AddCommGroup.of (G × H),
    π := { app := λ j, discrete.cases_on j
      (λ j, walking_pair.cases_on j (add_monoid_hom.fst G H) (add_monoid_hom.snd G H)),
      naturality' := by rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟨⟩⟩⟩; refl, }},
  is_limit :=
  { lift := λ s, add_monoid_hom.prod (s.π.app ⟨walking_pair.left⟩) (s.π.app ⟨walking_pair.right⟩),
    fac' := by { rintros s (⟨⟩|⟨⟩); { ext x, simp, } },
    uniq' := λ s m w, begin
      ext; [rw ← w ⟨walking_pair.left⟩, rw ← w ⟨walking_pair.right⟩]; refl,
    end, } }

@[simp] lemma binary_product_limit_cone_cone_π_app_left (G H : AddCommGroup.{u}) :
  (binary_product_limit_cone G H).cone.π.app ⟨walking_pair.left⟩ = add_monoid_hom.fst G H := rfl

@[simp] lemma binary_product_limit_cone_cone_π_app_right (G H : AddCommGroup.{u}) :
  (binary_product_limit_cone G H).cone.π.app ⟨walking_pair.right⟩ = add_monoid_hom.snd G H := rfl

/--
We verify that the biproduct in AddCommGroup is isomorphic to
the cartesian product of the underlying types:
-/
@[simps hom_apply] noncomputable
def biprod_iso_prod (G H : AddCommGroup.{u}) : (G ⊞ H : AddCommGroup) ≅ AddCommGroup.of (G × H) :=
is_limit.cone_point_unique_up_to_iso
  (binary_biproduct.is_limit G H)
  (binary_product_limit_cone G H).is_limit

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_fst (G H : AddCommGroup.{u}) :
  (biprod_iso_prod G H).inv ≫ biprod.fst = add_monoid_hom.fst G H :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.left)

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_snd (G H : AddCommGroup.{u}) :
  (biprod_iso_prod G H).inv ≫ biprod.snd = add_monoid_hom.snd G H :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.right)

variables {J : Type u} (f : J → AddCommGroup.{u})

namespace has_limit

/--
The map from an arbitrary cone over a indexed family of abelian groups
to the cartesian product of those groups.
-/
@[simps]
def lift (s : fan f) :
  s.X ⟶ AddCommGroup.of (Π j,f j) :=
{ to_fun := λ x j, s.π.app ⟨j⟩ x,
  map_zero' := by { ext, simp },
  map_add' := λ x y, by { ext, simp }, }

/--
Construct limit data for a product in `AddCommGroup`, using `AddCommGroup.of (Π j, F.obj j)`.
-/
@[simps] def product_limit_cone : limits.limit_cone (discrete.functor f) :=
{ cone :=
  { X := AddCommGroup.of (Π j, f j),
    π := discrete.nat_trans (λ j, pi.eval_add_monoid_hom (λ j, f j) j.as), },
  is_limit :=
  { lift := lift f,
    fac' := λ s j, by { cases j, ext, simp, },
    uniq' := λ s m w,
    begin
      ext x j,
      dsimp only [has_limit.lift],
      simp only [add_monoid_hom.coe_mk],
      exact congr_arg (λ g : s.X ⟶ f j, (g : s.X → f j) x) (w ⟨j⟩),
    end, }, }

end has_limit

open has_limit

/--
We verify that the biproduct we've just defined is isomorphic to the AddCommGroup structure
on the dependent function type
-/
@[simps hom_apply] noncomputable
def biproduct_iso_pi [fintype J] (f : J → AddCommGroup.{u}) :
  (⨁ f : AddCommGroup) ≅ AddCommGroup.of (Π j, f j) :=
is_limit.cone_point_unique_up_to_iso
  (biproduct.is_limit f)
  (product_limit_cone f).is_limit

@[simp, elementwise] lemma biproduct_iso_pi_inv_comp_π [fintype J]
  (f : J → AddCommGroup.{u}) (j : J) :
  (biproduct_iso_pi f).inv ≫ biproduct.π f j = pi.eval_add_monoid_hom (λ j, f j) j :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk j)

end AddCommGroup


<|start_filename|>src/category_theory/preadditive/projective.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.homology.exact
import category_theory.types
import category_theory.limits.shapes.biproducts

/-!
# Projective objects and categories with enough projectives

An object `P` is called projective if every morphism out of `P` factors through every epimorphism.

A category `C` has enough projectives if every object admits an epimorphism from some
projective object.

`projective.over X` picks an arbitrary such projective object,
and `projective.π X : projective.over X ⟶ X` is the corresponding epimorphism.

Given a morphism `f : X ⟶ Y`, `projective.left f` is a projective object over `kernel f`,
and `projective.d f : projective.left f ⟶ X` is the morphism `π (kernel f) ≫ kernel.ι f`.
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v u

namespace category_theory
variables {C : Type u} [category.{v} C]

/--
An object `P` is called projective if every morphism out of `P` factors through every epimorphism.
-/
class projective (P : C) : Prop :=
(factors : ∀ {E X : C} (f : P ⟶ X) (e : E ⟶ X) [epi e], ∃ f', f' ≫ e = f)

section

/--
A projective presentation of an object `X` consists of an epimorphism `f : P ⟶ X`
from some projective object `P`.
-/
@[nolint has_inhabited_instance]
structure projective_presentation (X : C) :=
(P : C)
(projective : projective P . tactic.apply_instance)
(f : P ⟶ X)
(epi : epi f . tactic.apply_instance)

variables (C)

/-- A category "has enough projectives" if for every object `X` there is a projective object `P` and
    an epimorphism `P ↠ X`. -/
class enough_projectives : Prop :=
(presentation : ∀ (X : C), nonempty (projective_presentation X))

end

namespace projective

/--
An arbitrarily chosen factorisation of a morphism out of a projective object through an epimorphism.
-/
def factor_thru {P X E : C} [projective P] (f : P ⟶ X) (e : E ⟶ X) [epi e] : P ⟶ E :=
(projective.factors f e).some

@[simp] lemma factor_thru_comp {P X E : C} [projective P] (f : P ⟶ X) (e : E ⟶ X) [epi e] :
  factor_thru f e ≫ e = f :=
(projective.factors f e).some_spec

section
open_locale zero_object

instance zero_projective [has_zero_object C] [has_zero_morphisms C] : projective (0 : C) :=
{ factors := λ E X f e epi, by { use 0, ext, }}

end

lemma of_iso {P Q : C} (i : P ≅ Q) (hP : projective P) : projective Q :=
begin
  fsplit,
  introsI E X f e e_epi,
  obtain ⟨f', hf'⟩ := projective.factors (i.hom ≫ f) e,
  exact ⟨i.inv ≫ f', by simp [hf']⟩
end

lemma iso_iff {P Q : C} (i : P ≅ Q) : projective P ↔ projective Q :=
⟨of_iso i, of_iso i.symm⟩

/-- The axiom of choice says that every type is a projective object in `Type`. -/
instance (X : Type u) : projective X :=
{ factors := λ E X' f e epi,
  ⟨λ x, ((epi_iff_surjective _).mp epi (f x)).some,
  by { ext x, exact ((epi_iff_surjective _).mp epi (f x)).some_spec, }⟩ }

instance Type.enough_projectives : enough_projectives (Type u) :=
{ presentation := λ X, ⟨{ P := X, f := 𝟙 X, }⟩, }

instance {P Q : C} [has_binary_coproduct P Q] [projective P] [projective Q] :
  projective (P ⨿ Q) :=
{ factors := λ E X' f e epi, by exactI
  ⟨coprod.desc (factor_thru (coprod.inl ≫ f) e) (factor_thru (coprod.inr ≫ f) e), by tidy⟩, }

section
local attribute [tidy] tactic.discrete_cases

instance {β : Type v} (g : β → C) [has_coproduct g] [∀ b, projective (g b)] :
  projective (∐ g) :=
{ factors := λ E X' f e epi, by exactI
  ⟨sigma.desc (λ b, factor_thru (sigma.ι g b ≫ f) e), by tidy⟩, }

end

instance {P Q : C} [has_zero_morphisms C] [has_binary_biproduct P Q]
  [projective P] [projective Q] :
  projective (P ⊞ Q) :=
{ factors := λ E X' f e epi, by exactI
  ⟨biprod.desc (factor_thru (biprod.inl ≫ f) e) (factor_thru (biprod.inr ≫ f) e), by tidy⟩, }

instance {β : Type v} (g : β → C) [has_zero_morphisms C] [has_biproduct g]
  [∀ b, projective (g b)] : projective (⨁ g) :=
{ factors := λ E X' f e epi, by exactI
  ⟨biproduct.desc (λ b, factor_thru (biproduct.ι g b ≫ f) e), by tidy⟩, }

section enough_projectives
variables [enough_projectives C]

/--
`projective.over X` provides an arbitrarily chosen projective object equipped with
an epimorphism `projective.π : projective.over X ⟶ X`.
-/
def over (X : C) : C :=
(enough_projectives.presentation X).some.P

instance projective_over (X : C) : projective (over X) :=
(enough_projectives.presentation X).some.projective

/--
The epimorphism `projective.π : projective.over X ⟶ X`
from the arbitrarily chosen projective object over `X`.
-/
def π (X : C) : over X ⟶ X :=
(enough_projectives.presentation X).some.f

instance π_epi (X : C) : epi (π X) :=
(enough_projectives.presentation X).some.epi

section
variables [has_zero_morphisms C] {X Y : C} (f : X ⟶ Y) [has_kernel f]

/--
When `C` has enough projectives, the object `projective.syzygies f` is
an arbitrarily chosen projective object over `kernel f`.
-/
@[derive projective]
def syzygies : C := over (kernel f)

/--
When `C` has enough projectives,
`projective.d f : projective.syzygies f ⟶ X` is the composition
`π (kernel f) ≫ kernel.ι f`.

(When `C` is abelian, we have `exact (projective.d f) f`.)
-/
abbreviation d : syzygies f ⟶ X :=
π (kernel f) ≫ kernel.ι f

end

end enough_projectives

end projective

open projective

section
variables [has_zero_morphisms C] [has_equalizers C] [has_images C]

/--
Given a projective object `P` mapping via `h` into
the middle object `R` of a pair of exact morphisms `f : Q ⟶ R` and `g : R ⟶ S`,
such that `h ≫ g = 0`, there is a lift of `h` to `Q`.
-/
def exact.lift {P Q R S : C} [projective P] (h : P ⟶ R) (f : Q ⟶ R) (g : R ⟶ S)
  (hfg : exact f g) (w : h ≫ g = 0) : P ⟶ Q :=
factor_thru
  (factor_thru
    (factor_thru_kernel_subobject g h w)
    (image_to_kernel f g hfg.w))
  (factor_thru_image_subobject f)

@[simp] lemma exact.lift_comp {P Q R S : C} [projective P] (h : P ⟶ R) (f : Q ⟶ R) (g : R ⟶ S)
  (hfg : exact f g) (w : h ≫ g = 0) : exact.lift h f g hfg w ≫ f = h :=
begin
  simp [exact.lift],
  conv_lhs { congr, skip, rw ← image_subobject_arrow_comp f, },
  rw [←category.assoc, factor_thru_comp, ←image_to_kernel_arrow,
    ←category.assoc, category_theory.projective.factor_thru_comp,
    factor_thru_kernel_subobject_comp_arrow],
end

end

end category_theory


<|start_filename|>src/topology/uniform_space/compare_reals.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
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

* [<NAME>, *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 : ℚ → ℚ) = pseudo_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


<|start_filename|>src/analysis/normed_space/M_structure.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.normed_space.basic
import algebra.ring.idempotents
import tactic.noncomm_ring

/-!
# M-structure

A projection P on a normed space X is said to be an L-projection (`is_Lprojection`) if, for all `x`
in `X`,
$\|x\| = \|P x\| + \|(1 - P) x\|$.

A projection P on a normed space X is said to be an M-projection if, for all `x` in `X`,
$\|x\| = max(\|P x\|,\|(1 - P) x\|)$.

The L-projections on `X` form a Boolean algebra (`is_Lprojection.subtype.boolean_algebra`).

## TODO (Motivational background)

The M-projections on a normed space form a Boolean algebra.

The range of an L-projection on a normed space `X` is said to be an L-summand of `X`. The range of
an M-projection is said to be an M-summand of `X`.

When `X` is a Banach space, the Boolean algebra of L-projections is complete. Let `X` be a normed
space with dual `X^*`. A closed subspace `M` of `X` is said to be an M-ideal if the topological
annihilator `M^∘` is an L-summand of `X^*`.

M-ideal, M-summands and L-summands were introduced by Alfsen and Effros in [alfseneffros1972] to
study the structure of general Banach spaces. When `A` is a JB*-triple, the M-ideals of `A` are
exactly the norm-closed ideals of `A`. When `A` is a JBW*-triple with predual `X`, the M-summands of
`A` are exactly the weak*-closed ideals, and their pre-duals can be identified with the L-summands
of `X`. In the special case when `A` is a C*-algebra, the M-ideals are exactly the norm-closed
two-sided ideals of `A`, when `A` is also a W*-algebra the M-summands are exactly the weak*-closed
two-sided ideals of `A`.

## Implementation notes

The approach to showing that the L-projections form a Boolean algebra is inspired by
`measure_theory.measurable_space`.

Instead of using `P : X →L[𝕜] X` to represent projections, we use an arbitrary ring `M` with a
faithful action on `X`. `continuous_linear_map.apply_module` can be used to recover the `X →L[𝕜] X`
special case.

## References

* [Behrends, M-structure and the Banach-Stone Theorem][behrends1979]
* [<NAME>, M-ideals in Banach spaces and Banach algebras][harmandwernerwerner1993]

## Tags

M-summand, M-projection, L-summand, L-projection, M-ideal, M-structure

-/

variables (X : Type*) [normed_group X]
variables {M : Type} [ring M] [module M X]
/--
A projection on a normed space `X` is said to be an L-projection if, for all `x` in `X`,
$\|x\| = \|P x\| + \|(1 - P) x\|$.

Note that we write `P • x` instead of `P x` for reasons described in the module docstring.
-/
structure is_Lprojection (P : M) : Prop :=
(proj : is_idempotent_elem P)
(Lnorm : ∀ (x : X), ∥x∥ = ∥P • x∥ + ∥(1 - P) • x∥)

/--
A projection on a normed space `X` is said to be an M-projection if, for all `x` in `X`,
$\|x\| = max(\|P x\|,\|(1 - P) x\|)$.

Note that we write `P • x` instead of `P x` for reasons described in the module docstring.
-/
structure is_Mprojection (P : M) : Prop :=
(proj : is_idempotent_elem P)
(Mnorm : ∀ (x : X), ∥x∥ = (max ∥P • x∥ ∥(1 - P) • x∥))

variables {X}

namespace is_Lprojection

lemma Lcomplement {P : M} (h: is_Lprojection X P) : is_Lprojection X (1 - P) :=
⟨h.proj.one_sub, λ x, by { rw [add_comm, sub_sub_cancel], exact h.Lnorm x }⟩

lemma Lcomplement_iff (P : M) : is_Lprojection X P ↔ is_Lprojection X (1 - P) :=
⟨Lcomplement, λ h, sub_sub_cancel 1 P ▸ h.Lcomplement⟩

lemma commute [has_faithful_smul M X] {P Q : M} (h₁ : is_Lprojection X P)
  (h₂ : is_Lprojection X Q) : commute P Q :=
begin
  have PR_eq_RPR : ∀ R : M, is_Lprojection X R → P * R = R * P * R := λ R h₃,
  begin
    refine @eq_of_smul_eq_smul _ X _ _ _ _ (λ x, _),
    rw ← norm_sub_eq_zero_iff,
    have e1 : ∥R • x∥ ≥ ∥R • x∥ + 2 • ∥ (P * R) • x - (R * P * R) • x∥ :=
    calc ∥R • x∥ = ∥R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥ +
                   (∥(R * R) • x - R • (P • (R • x))∥ + ∥(1 - R) • ((1 - P) • (R • x))∥) :
      by rw [h₁.Lnorm, h₃.Lnorm, h₃.Lnorm ((1 - P) • (R • x)), sub_smul 1 P,
        one_smul, smul_sub, mul_smul]
    ... = ∥R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥ + (∥R • x - R • (P • (R • x))∥
      + ∥((1 - R) * R) • x - (1 - R) • (P • (R • x))∥) : by rw [h₃.proj.eq,
        sub_smul 1 P, one_smul, smul_sub, mul_smul]
    ... = ∥R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥ +
          (∥R • x - R • (P • (R • x))∥ + ∥(1 - R) • (P • (R • x))∥) :
      by rw [sub_mul, h₃.proj.eq, one_mul, sub_self, zero_smul, zero_sub,
        norm_neg]
    ... = ∥R • (P • (R • x))∥ + ∥R • x - R • (P • (R • x))∥ + 2•∥(1 - R) • (P • (R • x))∥ : by abel
    ... ≥ ∥R • x∥ + 2 • ∥ (P * R) • x - (R * P * R) • x∥ : by
      { rw ge,
        have := add_le_add_right
          (norm_le_insert' (R • x) (R • (P • (R • x)))) (2•∥(1 - R) • (P • (R • x))∥),
        simpa only [mul_smul, sub_smul, one_smul] using this },
    rw ge at e1,
    nth_rewrite_rhs 0 ← add_zero (∥R • x∥) at e1,
    rw [add_le_add_iff_left, two_smul, ← two_mul] at e1,
    rw le_antisymm_iff,
    refine ⟨_, norm_nonneg _⟩,
    rwa [←mul_zero (2 : ℝ), mul_le_mul_left (show (0 : ℝ) < 2, by norm_num)] at e1
  end,
  have QP_eq_QPQ : Q * P = Q * P * Q,
  { have e1 : P * (1 - Q) = P * (1 - Q) - (Q * P - Q * P * Q) :=
    calc P * (1 - Q) = (1 - Q) * P * (1 - Q) : by rw PR_eq_RPR (1 - Q) h₂.Lcomplement
    ... = P * (1 - Q) - (Q * P - Q * P * Q) : by noncomm_ring,
    rwa [eq_sub_iff_add_eq, add_right_eq_self, sub_eq_zero] at e1 },
  show P * Q = Q * P, by rw [QP_eq_QPQ, PR_eq_RPR Q h₂]
end

lemma mul [has_faithful_smul M X] {P Q : M} (h₁ : is_Lprojection X P) (h₂ : is_Lprojection X Q) :
  is_Lprojection X (P * Q) :=
begin
  refine ⟨is_idempotent_elem.mul_of_commute (h₁.commute h₂) h₁.proj h₂.proj, _⟩,
  intro x,
  refine le_antisymm _ _,
  { calc ∥ x ∥ = ∥(P * Q) • x + (x - (P * Q) • x)∥ : by rw add_sub_cancel'_right ((P * Q) • x) x
    ... ≤ ∥(P * Q) • x∥ + ∥ x - (P * Q) • x ∥ : by apply norm_add_le
    ... = ∥(P * Q) • x∥ + ∥(1 - P * Q) • x∥ : by rw [sub_smul,
      one_smul] },
  { calc ∥x∥ = ∥P • (Q • x)∥ + (∥Q • x - P • (Q • x)∥ + ∥x - Q • x∥) : by
      rw [h₂.Lnorm x, h₁.Lnorm (Q • x),
          sub_smul, one_smul,
          sub_smul, one_smul, add_assoc]
    ... ≥ ∥P • (Q • x)∥ + ∥(Q • x - P • (Q • x)) + (x - Q • x)∥ :
      (add_le_add_iff_left (∥P • (Q • x)∥)).mpr (norm_add_le (Q • x - P • (Q • x)) (x - Q • x))
    ... = ∥(P * Q) • x∥ + ∥(1 - P * Q) • x∥ : by rw [sub_add_sub_cancel',
      sub_smul, one_smul,
      mul_smul] }
end

lemma join [has_faithful_smul M X] {P Q : M} (h₁ : is_Lprojection X P) (h₂ : is_Lprojection X Q) :
  is_Lprojection X (P + Q - P * Q) :=
begin
  convert (Lcomplement_iff _).mp (h₁.Lcomplement.mul h₂.Lcomplement) using 1,
  noncomm_ring,
end

instance : has_compl { f : M // is_Lprojection X f } :=
⟨λ P, ⟨1 - P, P.prop.Lcomplement⟩⟩

@[simp] lemma coe_compl (P : {P : M // is_Lprojection X P}) :
  ↑(Pᶜ) = (1 : M) - ↑P := rfl

instance [has_faithful_smul M X] : has_inf {P : M // is_Lprojection X P} :=
⟨λ P Q, ⟨P * Q, P.prop.mul Q.prop⟩ ⟩

@[simp] lemma coe_inf [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  ↑(P ⊓ Q) = ((↑P : (M)) * ↑Q) := rfl

instance [has_faithful_smul M X] : has_sup {P : M // is_Lprojection X P} :=
⟨λ P Q, ⟨P + Q - P * Q, P.prop.join Q.prop⟩ ⟩

@[simp] lemma coe_sup [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  ↑(P ⊔ Q) = ((↑P : M) + ↑Q - ↑P * ↑Q) := rfl

instance [has_faithful_smul M X] : has_sdiff {P : M // is_Lprojection X P} :=
⟨λ P Q, ⟨P * (1 - Q), by exact P.prop.mul Q.prop.Lcomplement ⟩⟩

@[simp] lemma coe_sdiff [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  ↑(P \ Q) = (↑P : M) * (1 - ↑Q) := rfl

instance [has_faithful_smul M X] : partial_order {P : M // is_Lprojection X P} :=
{ le := λ P Q, (↑P : M) = ↑(P ⊓ Q),
  le_refl := λ P, by simpa only [coe_inf, ←sq] using (P.prop.proj.eq).symm,
  le_trans := λ P Q R h₁ h₂, by { simp only [coe_inf] at ⊢ h₁ h₂, rw [h₁, mul_assoc, ←h₂] },
  le_antisymm := λ P Q h₁ h₂, subtype.eq (by convert (P.prop.commute Q.prop).eq) }

lemma le_def [has_faithful_smul M X] (P Q : {P : M // is_Lprojection X P}) :
  P ≤ Q ↔ (P : M) = ↑(P ⊓ Q) :=
iff.rfl

instance : has_zero {P : M // is_Lprojection X P} :=
⟨⟨0, ⟨by rw [is_idempotent_elem, zero_mul],
     λ x, by simp only [zero_smul, norm_zero, sub_zero,
                        one_smul, zero_add]⟩⟩⟩

@[simp] lemma coe_zero : ↑(0 : {P : M // is_Lprojection X P}) = (0 : M) :=
rfl

instance : has_one {P : M // is_Lprojection X P} :=
⟨⟨1, sub_zero (1 : M) ▸ (0 : {P : M // is_Lprojection X P}).prop.Lcomplement⟩⟩

@[simp] lemma coe_one : ↑(1 : {P : M // is_Lprojection X P}) = (1 : M) :=
rfl

instance [has_faithful_smul M X] : bounded_order {P : M // is_Lprojection X P} :=
{ top := 1,
  le_top := λ P, (mul_one (P : M)).symm,
  bot := 0,
  bot_le := λ P, (zero_mul (P : M)).symm, }

@[simp] lemma coe_bot [has_faithful_smul M X] :
  ↑(bounded_order.bot : {P : M // is_Lprojection X P}) = (0 : M) := rfl

@[simp] lemma coe_top [has_faithful_smul M X] :
  ↑(bounded_order.top : {P : M // is_Lprojection X P}) = (1 : M) := rfl

lemma compl_mul {P : {P : M // is_Lprojection X P}} {Q : M} :
  ↑Pᶜ * Q = Q - ↑P * Q := by rw [coe_compl, sub_mul, one_mul]

lemma mul_compl_self {P : {P : M // is_Lprojection X P}} :
  (↑P : M) * (↑Pᶜ) = 0 :=
by rw [coe_compl, mul_sub, mul_one, P.prop.proj.eq, sub_self]

lemma distrib_lattice_lemma [has_faithful_smul M X] {P Q R : {P : M // is_Lprojection X P}} :
  ((↑P : M) + ↑Pᶜ * R) * (↑P + ↑Q * ↑R * ↑Pᶜ) = (↑P + ↑Q * ↑R * ↑Pᶜ) :=
by rw [add_mul, mul_add, mul_add, mul_assoc ↑Pᶜ ↑R (↑Q * ↑R * ↑Pᶜ), ← mul_assoc ↑R (↑Q * ↑R) ↑Pᶜ,
    ← coe_inf Q, (Pᶜ.prop.commute R.prop).eq, ((Q ⊓ R).prop.commute Pᶜ.prop).eq,
    (R.prop.commute (Q ⊓ R).prop).eq, coe_inf Q, mul_assoc ↑Q, ← mul_assoc, mul_assoc ↑R,
    (Pᶜ.prop.commute P.prop).eq, mul_compl_self, zero_mul, mul_zero, zero_add, add_zero,
    ← mul_assoc,
    P.prop.proj.eq, R.prop.proj.eq, ← coe_inf Q, mul_assoc, ((Q ⊓ R).prop.commute Pᶜ.prop).eq,
    ← mul_assoc, Pᶜ.prop.proj.eq]

instance [has_faithful_smul M X] : distrib_lattice {P : M // is_Lprojection X P} :=
{ le_sup_left := λ P Q, by rw [le_def, coe_inf, coe_sup, ← add_sub, mul_add, mul_sub, ← mul_assoc,
    P.prop.proj.eq, sub_self, add_zero],
  le_sup_right := λ P Q,
  begin
    rw [le_def, coe_inf, coe_sup, ← add_sub, mul_add, mul_sub, commute.eq (commute P.prop Q.prop),
      ← mul_assoc, Q.prop.proj.eq, add_sub_cancel'_right],
  end,
  sup_le := λ P Q R,
  begin
    rw [le_def, le_def, le_def, coe_inf, coe_inf, coe_sup, coe_inf, coe_sup, ← add_sub, add_mul,
      sub_mul, mul_assoc],
    intros h₁ h₂,
    rw [← h₂, ← h₁],
  end,
  inf_le_left := λ P Q, by rw [le_def, coe_inf, coe_inf, coe_inf, mul_assoc,
    (Q.prop.commute P.prop).eq, ← mul_assoc, P.prop.proj.eq],
  inf_le_right := λ P Q, by rw [le_def, coe_inf, coe_inf, coe_inf, mul_assoc, Q.prop.proj.eq],
  le_inf := λ P Q R,
  begin
    rw [le_def, le_def, le_def, coe_inf, coe_inf, coe_inf, coe_inf, ← mul_assoc],
    intros h₁ h₂,
    rw [← h₁, ← h₂],
  end,
  le_sup_inf := λ P Q R,
  begin
    have e₁: ↑((P ⊔ Q) ⊓ (P ⊔ R)) = ↑P + ↑Q * ↑R * ↑Pᶜ :=
    by rw [coe_inf, coe_sup, coe_sup,
      ← add_sub, ← add_sub, ←compl_mul, ←compl_mul, add_mul, mul_add,
      (Pᶜ.prop.commute Q.prop).eq, mul_add, ← mul_assoc, mul_assoc ↑Q, (Pᶜ.prop.commute P.prop).eq,
      mul_compl_self, zero_mul, mul_zero, zero_add, add_zero, ← mul_assoc, mul_assoc ↑Q,
      P.prop.proj.eq, Pᶜ.prop.proj.eq, mul_assoc, (Pᶜ.prop.commute R.prop).eq, ← mul_assoc],
    have e₂ : ↑((P ⊔ Q) ⊓ (P ⊔ R)) * ↑(P ⊔ Q ⊓ R) = ↑P + ↑Q * ↑R * ↑Pᶜ := by rw [coe_inf, coe_sup,
      coe_sup, coe_sup, ← add_sub, ← add_sub, ← add_sub, ←compl_mul, ←compl_mul,
      ←compl_mul, (Pᶜ.prop.commute (Q⊓R).prop).eq, coe_inf, mul_assoc, distrib_lattice_lemma,
      (Q.prop.commute R.prop).eq, distrib_lattice_lemma],
    rw [le_def, e₁, coe_inf, e₂],
  end,
  .. is_Lprojection.subtype.has_inf,
  .. is_Lprojection.subtype.has_sup,
  .. is_Lprojection.subtype.partial_order }

instance [has_faithful_smul M X] : boolean_algebra {P : M // is_Lprojection X P} :=
{ sup_inf_sdiff := λ P Q, subtype.ext $
    by rw [coe_sup, coe_inf, coe_sdiff, mul_assoc, ← mul_assoc ↑Q,
    (Q.prop.commute P.prop).eq, mul_assoc ↑P ↑Q, ← coe_compl, mul_compl_self, mul_zero, mul_zero,
    sub_zero, ← mul_add, coe_compl, add_sub_cancel'_right, mul_one],
  inf_inf_sdiff := λ P Q, subtype.ext $
    by rw [coe_inf, coe_inf, coe_sdiff, coe_bot, mul_assoc, ← mul_assoc ↑Q,
      (Q.prop.commute P.prop).eq, ← coe_compl, mul_assoc, mul_compl_self, mul_zero, mul_zero],
  inf_compl_le_bot := λ P,
    (subtype.ext (by rw [coe_inf, coe_compl, coe_bot, ← coe_compl, mul_compl_self])).le,
  top_le_sup_compl := λ P, (subtype.ext(by rw [coe_top, coe_sup, coe_compl,
    add_sub_cancel'_right, ← coe_compl, mul_compl_self, sub_zero])).le,
  sdiff_eq := λ P Q, subtype.ext $ by rw [coe_sdiff, ← coe_compl, coe_inf],
  .. is_Lprojection.subtype.has_compl,
  .. is_Lprojection.subtype.has_sdiff,
  .. is_Lprojection.subtype.bounded_order,
  .. is_Lprojection.subtype.distrib_lattice }

end is_Lprojection


<|start_filename|>src/topology/bornology/basic.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import order.filter.cofinite

/-!
# Basic theory of bornology

We develop the basic theory of bornologies. Instead of axiomatizing bounded sets and defining
bornologies in terms of those, we recognize that the cobounded sets form a filter and define a
bornology as a filter of cobounded sets which contains the cofinite filter.  This allows us to make
use of the extensive library for filters, but we also provide the relevant connecting results for
bounded sets.

The specification of a bornology in terms of the cobounded filter is equivalent to the standard
one (e.g., see [Bourbaki, *Topological Vector Spaces*][bourbaki1987], **covering bornology**, now
often called simply **bornology**) in terms of bounded sets (see `bornology.of_bounded`,
`is_bounded.union`, `is_bounded.subset`), except that we do not allow the empty bornology (that is,
we require that *some* set must be bounded; equivalently, `∅` is bounded). In the literature the
cobounded filter is generally referred to as the *filter at infinity*.

## Main definitions

- `bornology α`: a class consisting of `cobounded : filter α` and a proof that this filter
  contains the `cofinite` filter.
- `bornology.is_cobounded`: the predicate that a set is a member of the `cobounded α` filter. For
  `s : set α`, one should prefer `bornology.is_cobounded s` over `s ∈ cobounded α`.
- `bornology.is_bounded`: the predicate that states a set is bounded (i.e., the complement of a
  cobounded set). One should prefer `bornology.is_bounded s` over `sᶜ ∈ cobounded α`.
- `bounded_space α`: a class extending `bornology α` with the condition
  `bornology.is_bounded (set.univ : set α)`

Although use of `cobounded α` is discouraged for indicating the (co)boundedness of individual sets,
it is intended for regular use as a filter on `α`.
-/

open set filter

variables {ι α β : Type*}

/-- A **bornology** on a type `α` is a filter of cobounded sets which contains the cofinite filter.
Such spaces are equivalently specified by their bounded sets, see `bornology.of_bounded`
and `bornology.ext_iff_is_bounded`-/
@[ext]
class bornology (α : Type*) :=
(cobounded [] : filter α)
(le_cofinite [] : cobounded ≤ cofinite)

/-- A constructor for bornologies by specifying the bounded sets,
and showing that they satisfy the appropriate conditions. -/
@[simps]
def bornology.of_bounded {α : Type*} (B : set (set α))
  (empty_mem : ∅ ∈ B) (subset_mem : ∀ s₁ ∈ B, ∀ s₂ : set α, s₂ ⊆ s₁ → s₂ ∈ B)
  (union_mem : ∀ s₁ s₂ ∈ B, s₁ ∪ s₂ ∈ B) (singleton_mem : ∀ x, {x} ∈ B) :
  bornology α :=
{ cobounded :=
  { sets := {s : set α | sᶜ ∈ B},
    univ_sets := by rwa ←compl_univ at empty_mem,
    sets_of_superset := λ x y hx hy, subset_mem xᶜ hx yᶜ (compl_subset_compl.mpr hy),
    inter_sets := λ x y hx hy, by simpa [compl_inter] using union_mem xᶜ hx yᶜ hy, },
  le_cofinite :=
  begin
    rw le_cofinite_iff_compl_singleton_mem,
    intros x,
    change {x}ᶜᶜ ∈ B,
    rw compl_compl,
    exact singleton_mem x
  end }

/-- A constructor for bornologies by specifying the bounded sets,
and showing that they satisfy the appropriate conditions. -/
@[simps]
def bornology.of_bounded' {α : Type*} (B : set (set α))
  (empty_mem : ∅ ∈ B) (subset_mem : ∀ s₁ ∈ B, ∀ s₂ : set α, s₂ ⊆ s₁ → s₂ ∈ B)
  (union_mem : ∀ s₁ s₂ ∈ B, s₁ ∪ s₂ ∈ B) (sUnion_univ : ⋃₀ B = univ) :
  bornology α :=
bornology.of_bounded B empty_mem subset_mem union_mem $ λ x,
  begin
    rw sUnion_eq_univ_iff at sUnion_univ,
    rcases sUnion_univ x with ⟨s, hs, hxs⟩,
    exact subset_mem s hs {x} (singleton_subset_iff.mpr hxs)
  end

namespace bornology

section
variables [bornology α] {s t : set α} {x : α}

/-- `is_cobounded` is the predicate that `s` is in the filter of cobounded sets in the ambient
bornology on `α` -/
def is_cobounded (s : set α) : Prop := s ∈ cobounded α

/-- `is_bounded` is the predicate that `s` is bounded relative to the ambient bornology on `α`. -/
def is_bounded (s : set α) : Prop := is_cobounded sᶜ

lemma is_cobounded_def {s : set α} : is_cobounded s ↔ s ∈ cobounded α := iff.rfl

lemma is_bounded_def {s : set α} : is_bounded s ↔ sᶜ ∈ cobounded α := iff.rfl

@[simp] lemma is_bounded_compl_iff : is_bounded sᶜ ↔ is_cobounded s :=
by rw [is_bounded_def, is_cobounded_def, compl_compl]

@[simp] lemma is_cobounded_compl_iff : is_cobounded sᶜ ↔ is_bounded s := iff.rfl

alias is_bounded_compl_iff ↔ bornology.is_bounded.of_compl bornology.is_cobounded.compl
alias is_cobounded_compl_iff ↔ bornology.is_cobounded.of_compl bornology.is_bounded.compl

@[simp] lemma is_bounded_empty : is_bounded (∅ : set α) :=
by { rw [is_bounded_def, compl_empty], exact univ_mem}

@[simp] lemma is_bounded_singleton : is_bounded ({x} : set α) :=
by {rw [is_bounded_def], exact le_cofinite _ (finite_singleton x).compl_mem_cofinite}

@[simp] lemma is_cobounded_univ : is_cobounded (univ : set α) := univ_mem

@[simp] lemma is_cobounded_inter : is_cobounded (s ∩ t) ↔ is_cobounded s ∧ is_cobounded t :=
inter_mem_iff

lemma is_cobounded.inter (hs : is_cobounded s) (ht : is_cobounded t) : is_cobounded (s ∩ t) :=
is_cobounded_inter.2 ⟨hs, ht⟩

@[simp] lemma is_bounded_union : is_bounded (s ∪ t) ↔ is_bounded s ∧ is_bounded t :=
by simp only [← is_cobounded_compl_iff, compl_union, is_cobounded_inter]

lemma is_bounded.union (hs : is_bounded s) (ht : is_bounded t) : is_bounded (s ∪ t) :=
is_bounded_union.2 ⟨hs, ht⟩

lemma is_cobounded.superset (hs : is_cobounded s) (ht : s ⊆ t) : is_cobounded t :=
mem_of_superset hs ht

lemma is_bounded.subset (ht : is_bounded t) (hs : s ⊆ t) : is_bounded s :=
ht.superset (compl_subset_compl.mpr hs)

@[simp]
lemma sUnion_bounded_univ : (⋃₀ {s : set α | is_bounded s}) = univ :=
sUnion_eq_univ_iff.2 $ λ a, ⟨{a}, is_bounded_singleton, mem_singleton a⟩

lemma comap_cobounded_le_iff [bornology β] {f : α → β} :
  (cobounded β).comap f ≤ cobounded α ↔ ∀ ⦃s⦄, is_bounded s → is_bounded (f '' s) :=
begin
  refine ⟨λ h s hs, _, λ h t ht,
    ⟨(f '' tᶜ)ᶜ, h $ is_cobounded.compl ht, compl_subset_comm.1 $ subset_preimage_image _ _⟩⟩,
  obtain ⟨t, ht, hts⟩ := h hs.compl,
  rw [subset_compl_comm, ←preimage_compl] at hts,
  exact (is_cobounded.compl ht).subset ((image_subset f hts).trans $ image_preimage_subset _ _),
end

end

lemma ext_iff' {t t' : bornology α} :
  t = t' ↔ ∀ s, (@cobounded α t).sets s ↔ (@cobounded α t').sets s :=
(ext_iff _ _).trans filter.ext_iff

lemma ext_iff_is_bounded {t t' : bornology α} :
  t = t' ↔ ∀ s, @is_bounded α t s ↔ @is_bounded α t' s :=
⟨λ h s, h ▸ iff.rfl, λ h, by { ext, simpa only [is_bounded_def, compl_compl] using h sᶜ, }⟩

variables {s : set α}

lemma is_cobounded_of_bounded_iff (B : set (set α)) {empty_mem subset_mem union_mem sUnion_univ} :
  @is_cobounded _ (of_bounded B empty_mem subset_mem union_mem sUnion_univ) s ↔ sᶜ ∈ B := iff.rfl

lemma is_bounded_of_bounded_iff (B : set (set α)) {empty_mem subset_mem union_mem sUnion_univ} :
  @is_bounded _ (of_bounded B empty_mem subset_mem union_mem sUnion_univ) s ↔ s ∈ B :=
by rw [is_bounded_def, ←filter.mem_sets, of_bounded_cobounded_sets, set.mem_set_of_eq, compl_compl]

variables [bornology α]

lemma is_cobounded_bInter {s : set ι} {f : ι → set α} (hs : s.finite) :
  is_cobounded (⋂ i ∈ s, f i) ↔ ∀ i ∈ s, is_cobounded (f i) :=
bInter_mem hs

@[simp] lemma is_cobounded_bInter_finset (s : finset ι) {f : ι → set α} :
  is_cobounded (⋂ i ∈ s, f i) ↔ ∀ i ∈ s, is_cobounded (f i) :=
bInter_finset_mem s

@[simp] lemma is_cobounded_Inter [fintype ι] {f : ι → set α} :
  is_cobounded (⋂ i, f i) ↔ ∀ i, is_cobounded (f i) :=
Inter_mem

lemma is_cobounded_sInter {S : set (set α)} (hs : S.finite) :
  is_cobounded (⋂₀ S) ↔ ∀ s ∈ S, is_cobounded s :=
sInter_mem hs

lemma is_bounded_bUnion {s : set ι} {f : ι → set α} (hs : s.finite) :
  is_bounded (⋃ i ∈ s, f i) ↔ ∀ i ∈ s, is_bounded (f i) :=
by simp only [← is_cobounded_compl_iff, compl_Union, is_cobounded_bInter hs]

lemma is_bounded_bUnion_finset (s : finset ι) {f : ι → set α} :
  is_bounded (⋃ i ∈ s, f i) ↔ ∀ i ∈ s, is_bounded (f i) :=
is_bounded_bUnion s.finite_to_set

lemma is_bounded_sUnion {S : set (set α)} (hs : S.finite) :
  is_bounded (⋃₀ S) ↔ (∀ s ∈ S, is_bounded s) :=
by rw [sUnion_eq_bUnion, is_bounded_bUnion hs]

@[simp] lemma is_bounded_Union [fintype ι] {s : ι → set α} :
  is_bounded (⋃ i, s i) ↔ ∀ i, is_bounded (s i) :=
by rw [← sUnion_range, is_bounded_sUnion (finite_range s), forall_range_iff]

end bornology

open bornology

lemma set.finite.is_bounded [bornology α] {s : set α} (hs : s.finite) : is_bounded s :=
bornology.le_cofinite α hs.compl_mem_cofinite

instance : bornology punit := ⟨⊥, bot_le⟩

/-- The cofinite filter as a bornology -/
@[reducible] def bornology.cofinite : bornology α :=
{ cobounded := cofinite,
  le_cofinite := le_rfl }

/-- A space with a `bornology` is a **bounded space** if `set.univ : set α` is bounded. -/
class bounded_space (α : Type*) [bornology α] : Prop :=
(bounded_univ : bornology.is_bounded (univ : set α))

namespace bornology

variables [bornology α]

lemma is_bounded_univ : is_bounded (univ : set α) ↔ bounded_space α :=
⟨λ h, ⟨h⟩, λ h, h.1⟩

lemma cobounded_eq_bot_iff : cobounded α = ⊥ ↔ bounded_space α :=
by rw [← is_bounded_univ, is_bounded_def, compl_univ, empty_mem_iff_bot]

variables [bounded_space α]

lemma is_bounded.all (s : set α) : is_bounded s := bounded_space.bounded_univ.subset s.subset_univ
lemma is_cobounded.all (s : set α) : is_cobounded s := compl_compl s ▸ is_bounded.all sᶜ

variable (α)

@[simp] lemma cobounded_eq_bot : cobounded α = ⊥ := cobounded_eq_bot_iff.2 ‹_›

end bornology


<|start_filename|>src/algebra/homology/short_exact/abelian.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import algebra.homology.short_exact.preadditive
import category_theory.abelian.diagram_lemmas.four

/-!
# Short exact sequences in abelian categories

In an abelian category, a left-split or right-split short exact sequence admits a splitting.
-/

noncomputable theory

open category_theory category_theory.limits category_theory.preadditive

variables {𝒜 : Type*} [category 𝒜]

namespace category_theory

variables {A B C A' B' C' : 𝒜} {f : A ⟶ B} {g : B ⟶ C} {f' : A' ⟶ B'} {g' : B' ⟶ C'}
variables [abelian 𝒜]
open_locale zero_object

lemma is_iso_of_short_exact_of_is_iso_of_is_iso (h : short_exact f g) (h' : short_exact f' g')
  (i₁ : A ⟶ A') (i₂ : B ⟶ B') (i₃ : C ⟶ C')
  (comm₁ : i₁ ≫ f' = f ≫ i₂) (comm₂ : i₂ ≫ g' = g ≫ i₃) [is_iso i₁] [is_iso i₃] :
  is_iso i₂ :=
begin
  obtain ⟨_, _, _⟩ := h,
  obtain ⟨_, _, _⟩ := h',
  resetI,
  refine @abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso 𝒜 _ _ 0 _ _ _ 0 _ _ _
    0 f g 0 f' g' 0 i₁ i₂ i₃ _ comm₁ comm₂ 0 0 0 0 0 _ _ _ _ _ _ _ _ _ _ _;
  try { simp };
  try { apply exact_zero_left_of_mono };
  try { assumption };
  rwa ← epi_iff_exact_zero_right,
end

/-- To construct a splitting of `A -f⟶ B -g⟶ C` it suffices to supply
a *morphism* `i : B ⟶ A ⊞ C` such that `f ≫ i` is the canonical map `biprod.inl : A ⟶ A ⊞ C` and
`i ≫ q = g`, where `q` is the canonical map `biprod.snd : A ⊞ C ⟶ C`,
together with proofs that `f` is mono and `g` is epi.

The morphism `i` is then automatically an isomorphism. -/
def splitting.mk' (h : short_exact f g) (i : B ⟶ A ⊞ C)
  (h1 : f ≫ i = biprod.inl) (h2 : i ≫ biprod.snd = g) : splitting f g :=
{ iso :=
  begin
    refine @as_iso _ _ _ _ i (id _),
    refine is_iso_of_short_exact_of_is_iso_of_is_iso h _ _ _ _
      (h1.trans (category.id_comp _).symm).symm (h2.trans (category.comp_id _).symm),
    split,
    apply exact_inl_snd
  end,
  comp_iso_eq_inl := by { rwa as_iso_hom, },
  iso_comp_snd_eq := h2 }

/-- To construct a splitting of `A -f⟶ B -g⟶ C` it suffices to supply
a *morphism* `i : A ⊞ C ⟶ B` such that `p ≫ i = f` where `p` is the canonical map
`biprod.inl : A ⟶ A ⊞ C`, and `i ≫ g` is the canonical map `biprod.snd : A ⊞ C ⟶ C`,
together with proofs that `f` is mono and `g` is epi.

The morphism `i` is then automatically an isomorphism. -/
def splitting.mk'' (h : short_exact f g) (i : A ⊞ C ⟶ B)
  (h1 : biprod.inl ≫ i = f) (h2 : i ≫ g = biprod.snd) : splitting f g :=
{ iso :=
  begin
    refine (@as_iso _ _ _ _ i (id _)).symm,
    refine is_iso_of_short_exact_of_is_iso_of_is_iso _ h _ _ _
      (h1.trans (category.id_comp _).symm).symm (h2.trans (category.comp_id _).symm),
    split,
    apply exact_inl_snd
  end,
  comp_iso_eq_inl := by rw [iso.symm_hom, as_iso_inv, is_iso.comp_inv_eq, h1],
  iso_comp_snd_eq := by rw [iso.symm_hom, as_iso_inv, is_iso.inv_comp_eq, h2] }

/-- A short exact sequence that is left split admits a splitting. -/
def left_split.splitting {f : A ⟶ B} {g : B ⟶ C} (h : left_split f g) : splitting f g :=
splitting.mk' h.short_exact (biprod.lift h.left_split.some g)
(by { ext,
  { simpa only [biprod.inl_fst, biprod.lift_fst, category.assoc] using h.left_split.some_spec },
  { simp only [biprod.inl_snd, biprod.lift_snd, category.assoc, h.exact.w], } })
(by { simp only [biprod.lift_snd], })

/-- A short exact sequence that is right split admits a splitting. -/
def right_split.splitting {f : A ⟶ B} {g : B ⟶ C} (h : right_split f g) : splitting f g :=
splitting.mk'' h.short_exact (biprod.desc f h.right_split.some)
(biprod.inl_desc _ _)
(by { ext,
  { rw [biprod.inl_snd, ← category.assoc, biprod.inl_desc, h.exact.w] },
  { rw [biprod.inr_snd, ← category.assoc, biprod.inr_desc, h.right_split.some_spec] } })

end category_theory


<|start_filename|>archive/imo/imo1975_q1.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.real.basic
import data.nat.interval
import algebra.order.rearrangement
import algebra.big_operators.ring

/-!
# IMO 1975 Q1

Let `x₁, x₂, ... , xₙ` and `y₁, y₂, ... , yₙ` be two sequences of real numbers, such that
`x₁ ≥ x₂ ≥ ... ≥ xₙ` and `y₁ ≥ y₂ ≥ ... ≥ yₙ`. Prove that if `z₁, z₂, ... , zₙ` is any permutation
of `y₁, y₂, ... , yₙ`, then `∑ (xᵢ - yᵢ)^2 ≤ ∑ (xᵢ - zᵢ)^2`

# Solution

Firstly, we expand the squares withing both sums and distribute into separate finite sums. Then,
noting that `∑ yᵢ ^ 2 = ∑ zᵢ ^ 2`, it remains to prove that `∑ xᵢ * zᵢ ≤ ∑ xᵢ * yᵢ`, which is true
by the Rearrangement Inequality
-/

open_locale big_operators

/- Let `n` be a natural number, `x` and `y` be as in the problem statement and `σ` be the
permutation of natural numbers such that `z = y ∘ σ` -/
variables (n : ℕ) (σ : equiv.perm ℕ) (hσ : {x | σ x ≠ x} ⊆ finset.Icc 1 n) (x y : ℕ → ℝ)
variables (hx : antitone_on x (finset.Icc 1 n))
variables (hy : antitone_on y (finset.Icc 1 n))
include hx hy hσ

theorem IMO_1975_Q1 :
  ∑ i in finset.Icc 1 n, (x i - y i) ^ 2 ≤ ∑ i in finset.Icc 1 n, (x i - y (σ i)) ^ 2 :=
begin
  simp only [sub_sq, finset.sum_add_distrib, finset.sum_sub_distrib],
  -- a finite sum is invariant if we permute the order of summation
  have hσy : ∑ (i : ℕ) in finset.Icc 1 n, y i ^ 2 = ∑ (i : ℕ) in finset.Icc 1 n, y (σ i) ^ 2,
  { rw ← equiv.perm.sum_comp σ (finset.Icc 1 n) _ hσ },
  -- let's cancel terms appearing on both sides
  norm_num [hσy, mul_assoc, ← finset.mul_sum],
  -- what's left to prove is a version of the rearrangement inequality
  apply monovary_on.sum_mul_comp_perm_le_sum_mul _ hσ,
  -- finally we need to show that `x` and `y` 'vary' together on `[1, n]` and this is due to both of
  -- them being `decreasing`
  exact antitone_on.monovary_on hx hy
end


<|start_filename|>src/set_theory/ordinal/principal.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import set_theory.ordinal.fixed_point

/-!
### Principal ordinals

We define principal or indecomposable ordinals, and we prove the standard properties about them.

### Main definitions and results
* `principal`: A principal or indecomposable ordinal under some binary operation. We include 0 and
  any other typically excluded edge cases for simplicity.
* `unbounded_principal`: Principal ordinals are unbounded.
* `principal_add_iff_zero_or_omega_opow`: The main characterization theorem for additive principal
  ordinals.
* `principal_mul_iff_le_two_or_omega_opow_opow`: The main characterization theorem for
  multiplicative principal ordinals.

### Todo
* Prove that exponential principal ordinals are 0, 1, 2, ω, or epsilon numbers, i.e. fixed points
  of `λ x, ω ^ x`.
-/

universe u

noncomputable theory

open order

namespace ordinal
local infixr ^ := @pow ordinal ordinal ordinal.has_pow

/-! ### Principal ordinals -/

/-- An ordinal `o` is said to be principal or indecomposable under an operation when the set of
ordinals less than it is closed under that operation. In standard mathematical usage, this term is
almost exclusively used for additive and multiplicative principal ordinals.

For simplicity, we break usual convention and regard 0 as principal. -/
def principal (op : ordinal → ordinal → ordinal) (o : ordinal) : Prop :=
∀ ⦃a b⦄, a < o → b < o → op a b < o

theorem principal_iff_principal_swap {op : ordinal → ordinal → ordinal} {o : ordinal} :
  principal op o ↔ principal (function.swap op) o :=
by split; exact λ h a b ha hb, h hb ha

theorem principal_zero {op : ordinal → ordinal → ordinal} : principal op 0 :=
λ a _ h, (ordinal.not_lt_zero a h).elim

@[simp] theorem principal_one_iff {op : ordinal → ordinal → ordinal} :
  principal op 1 ↔ op 0 0 = 0 :=
begin
  refine ⟨λ h, _, λ h a b ha hb, _⟩,
  { rwa ←lt_one_iff_zero,
    exact h zero_lt_one zero_lt_one },
  { rwa [lt_one_iff_zero, ha, hb] at * }
end

theorem principal.iterate_lt {op : ordinal → ordinal → ordinal} {a o : ordinal} (hao : a < o)
  (ho : principal op o) (n : ℕ) : (op a)^[n] a < o :=
begin
  induction n with n hn,
  { rwa function.iterate_zero },
  { rw function.iterate_succ', exact ho hao hn }
end

theorem op_eq_self_of_principal {op : ordinal → ordinal → ordinal} {a o : ordinal.{u}}
  (hao : a < o) (H : is_normal (op a)) (ho : principal op o) (ho' : is_limit o) : op a o = o :=
begin
  refine le_antisymm _ (H.self_le _),
  rw [←is_normal.bsup_eq.{u u} H ho', bsup_le_iff],
  exact λ b hbo, (ho hao hbo).le
end

theorem nfp_le_of_principal {op : ordinal → ordinal → ordinal}
  {a o : ordinal} (hao : a < o) (ho : principal op o) : nfp (op a) a ≤ o :=
nfp_le $ λ n, (ho.iterate_lt hao n).le

/-! ### Principal ordinals are unbounded -/

/-- The least strict upper bound of `op` applied to all pairs of ordinals less than `o`. This is
essentially a two-argument version of `ordinal.blsub`. -/
def blsub₂ (op : ordinal → ordinal → ordinal) (o : ordinal) : ordinal :=
lsub (λ x : o.out.α × o.out.α, op (typein (<) x.1) (typein (<) x.2))

theorem lt_blsub₂ (op : ordinal → ordinal → ordinal) {o : ordinal} {a b : ordinal} (ha : a < o)
  (hb : b < o) : op a b < blsub₂ op o :=
begin
  convert lt_lsub _ (prod.mk (enum (<) a (by rwa type_lt)) (enum (<) b (by rwa type_lt))),
  simp only [typein_enum]
end

theorem principal_nfp_blsub₂ (op : ordinal → ordinal → ordinal) (o : ordinal) :
  principal op (nfp (blsub₂.{u u} op) o) :=
λ a b ha hb, begin
  rw lt_nfp at *,
  cases ha with m hm,
  cases hb with n hn,
  cases le_total ((blsub₂.{u u} op)^[m] o) ((blsub₂.{u u} op)^[n] o) with h h,
  { use n + 1,
    rw function.iterate_succ',
    exact lt_blsub₂ op (hm.trans_le h) hn },
  { use m + 1,
    rw function.iterate_succ',
    exact lt_blsub₂ op hm (hn.trans_le h) },
end

theorem unbounded_principal (op : ordinal → ordinal → ordinal) :
  set.unbounded (<) {o | principal op o} :=
λ o, ⟨_, principal_nfp_blsub₂ op o, (le_nfp _ o).not_lt⟩

/-! #### Additive principal ordinals -/

theorem principal_add_one : principal (+) 1 :=
principal_one_iff.2 $ zero_add 0

theorem principal_add_of_le_one {o : ordinal} (ho : o ≤ 1) : principal (+) o :=
begin
  rcases le_one_iff.1 ho with rfl | rfl,
  { exact principal_zero },
  { exact principal_add_one }
end

theorem principal_add_is_limit {o : ordinal} (ho₁ : 1 < o) (ho : principal (+) o) :
  o.is_limit :=
begin
  refine ⟨λ ho₀, _, λ a hao, _⟩,
  { rw ho₀ at ho₁,
    exact not_lt_of_gt ordinal.zero_lt_one ho₁ },
  { cases eq_or_ne a 0 with ha ha,
    { rw [ha, succ_zero],
      exact ho₁ },
    { refine lt_of_le_of_lt _ (ho hao hao),
      rwa [←add_one_eq_succ, add_le_add_iff_left, one_le_iff_ne_zero] } }
end

theorem principal_add_iff_add_left_eq_self {o : ordinal} :
  principal (+) o ↔ ∀ a < o, a + o = o :=
begin
  refine ⟨λ ho a hao, _, λ h a b hao hbo, _⟩,
  { cases lt_or_le 1 o with ho₁ ho₁,
    { exact op_eq_self_of_principal hao (add_is_normal a) ho (principal_add_is_limit ho₁ ho) },
    { rcases le_one_iff.1 ho₁ with rfl | rfl,
      { exact (ordinal.not_lt_zero a hao).elim },
      { rw lt_one_iff_zero at hao,
        rw [hao, zero_add] }}},
  { rw ←h a hao,
    exact (add_is_normal a).strict_mono hbo }
end

theorem exists_lt_add_of_not_principal_add {a} (ha : ¬ principal (+) a) :
  ∃ (b c) (hb : b < a) (hc : c < a), b + c = a :=
begin
  unfold principal at ha,
  push_neg at ha,
  rcases ha with ⟨b, c, hb, hc, H⟩,
  refine ⟨b, _, hb, lt_of_le_of_ne (sub_le_self a b) (λ hab, _),
    ordinal.add_sub_cancel_of_le hb.le⟩,
  rw [←sub_le, hab] at H,
  exact H.not_lt hc
end

theorem principal_add_iff_add_lt_ne_self {a} :
  principal (+) a ↔ ∀ ⦃b c⦄, b < a → c < a → b + c ≠ a :=
⟨λ ha b c hb hc, (ha hb hc).ne, λ H, begin
  by_contra' ha,
  rcases exists_lt_add_of_not_principal_add ha with ⟨b, c, hb, hc, rfl⟩,
  exact (H hb hc).irrefl
end⟩

theorem add_omega {a : ordinal} (h : a < omega) : a + omega = omega :=
begin
  rcases lt_omega.1 h with ⟨n, rfl⟩,
  clear h, induction n with n IH,
  { rw [nat.cast_zero, zero_add] },
  { rwa [nat.cast_succ, add_assoc, one_add_of_omega_le (le_refl _)] }
end

theorem principal_add_omega : principal (+) omega :=
principal_add_iff_add_left_eq_self.2 (λ a, add_omega)

theorem add_omega_opow {a b : ordinal} (h : a < omega ^ b) : a + omega ^ b = omega ^ b :=
begin
  refine le_antisymm _ (le_add_left _ _),
  revert h, refine limit_rec_on b (λ h, _) (λ b _ h, _) (λ b l IH h, _),
  { rw [opow_zero, ← succ_zero, lt_succ_iff, ordinal.le_zero] at h,
    rw [h, zero_add] },
  { rw opow_succ at h,
    rcases (lt_mul_of_limit omega_is_limit).1 h with ⟨x, xo, ax⟩,
    refine le_trans (add_le_add_right (le_of_lt ax) _) _,
    rw [opow_succ, ← mul_add, add_omega xo] },
  { rcases (lt_opow_of_limit omega_ne_zero l).1 h with ⟨x, xb, ax⟩,
    exact (((add_is_normal a).trans (opow_is_normal one_lt_omega)).limit_le l).2 (λ y yb,
      (add_le_add_left (opow_le_opow_right omega_pos (le_max_right _ _)) _).trans
      (le_trans (IH _ (max_lt xb yb) (ax.trans_le $ opow_le_opow_right omega_pos (le_max_left _ _)))
      (opow_le_opow_right omega_pos $ le_of_lt $ max_lt xb yb))) }
end

theorem principal_add_omega_opow (o : ordinal) : principal (+) (omega ^ o) :=
principal_add_iff_add_left_eq_self.2 (λ a, add_omega_opow)

/-- The main characterization theorem for additive principal ordinals. -/
theorem principal_add_iff_zero_or_omega_opow {o : ordinal} :
  principal (+) o ↔ o = 0 ∨ ∃ a, o = omega ^ a :=
begin
  rcases eq_or_ne o 0 with rfl | ho,
  { simp only [principal_zero, or.inl] },
  { rw [principal_add_iff_add_left_eq_self],
    simp only [ho, false_or],
    refine ⟨λ H, ⟨_, ((lt_or_eq_of_le (opow_log_le_self _ (ordinal.pos_iff_ne_zero.2 ho)))
        .resolve_left $ λ h, _).symm⟩, λ ⟨b, e⟩, e.symm ▸ λ a, add_omega_opow⟩,
    have := H _ h,
    have := lt_opow_succ_log_self one_lt_omega o,
    rw [opow_succ, lt_mul_of_limit omega_is_limit] at this,
    rcases this with ⟨a, ao, h'⟩,
    rcases lt_omega.1 ao with ⟨n, rfl⟩, clear ao,
    revert h', apply not_lt_of_le,
    suffices e : omega ^ log omega o * ↑n + o = o,
    { simpa only [e] using le_add_right (omega ^ log omega o * ↑n) o },
    induction n with n IH, {simp only [nat.cast_zero, mul_zero, zero_add]},
    simp only [nat.cast_succ, mul_add_one, add_assoc, this, IH] }
end

theorem opow_principal_add_of_principal_add {a} (ha : principal (+) a) (b : ordinal) :
  principal (+) (a ^ b) :=
begin
  rcases principal_add_iff_zero_or_omega_opow.1 ha with rfl | ⟨c, rfl⟩,
  { rcases eq_or_ne b 0 with rfl | hb,
    { rw opow_zero, exact principal_add_one },
    { rwa zero_opow hb } },
  { rw ←opow_mul, exact principal_add_omega_opow _ }
end

theorem add_absorp {a b c : ordinal} (h₁ : a < omega ^ b) (h₂ : omega ^ b ≤ c) : a + c = c :=
by rw [← ordinal.add_sub_cancel_of_le h₂, ← add_assoc, add_omega_opow h₁]

theorem mul_principal_add_is_principal_add (a : ordinal.{u}) {b : ordinal.{u}} (hb₁ : b ≠ 1)
  (hb : principal (+) b) : principal (+) (a * b) :=
begin
  rcases eq_zero_or_pos a with rfl | ha,
  { rw zero_mul,
    exact principal_zero },
  { rcases eq_zero_or_pos b with rfl | hb₁',
    { rw mul_zero,
      exact principal_zero },
    { rw [← succ_le_iff, succ_zero] at hb₁',
      intros c d hc hd,
      rw lt_mul_of_limit (principal_add_is_limit (lt_of_le_of_ne hb₁' hb₁.symm) hb) at *,
      { rcases hc with ⟨x, hx, hx'⟩,
        rcases hd with ⟨y, hy, hy'⟩,
        use [x + y, hb hx hy],
        rw mul_add,
        exact left.add_lt_add hx' hy' },
      assumption' } }
end

/-! #### Multiplicative principal ordinals -/

theorem principal_mul_one : principal (*) 1 :=
by { rw principal_one_iff, exact zero_mul _ }

theorem principal_mul_two : principal (*) 2 :=
λ a b ha hb, begin
  have h₂ : succ (1 : ordinal) = 2 := rfl,
  rw [←h₂, lt_succ_iff] at *,
  convert mul_le_mul' ha hb,
  exact (mul_one 1).symm
end

theorem principal_mul_of_le_two {o : ordinal} (ho : o ≤ 2) : principal (*) o :=
begin
  rcases lt_or_eq_of_le ho with ho | rfl,
  { have h₂ : succ (1 : ordinal) = 2 := rfl,
    rw [←h₂, lt_succ_iff] at ho,
    rcases lt_or_eq_of_le ho with ho | rfl,
    { rw lt_one_iff_zero.1 ho,
      exact principal_zero },
    { exact principal_mul_one } },
  { exact principal_mul_two }
end

theorem principal_add_of_principal_mul {o : ordinal} (ho : principal (*) o) (ho₂ : o ≠ 2) :
  principal (+) o :=
begin
  cases lt_or_gt_of_ne ho₂ with ho₁ ho₂,
  { change o < succ 1 at ho₁,
    rw lt_succ_iff at ho₁,
    exact principal_add_of_le_one ho₁ },
  { refine λ a b hao hbo, lt_of_le_of_lt _ (ho (max_lt hao hbo) ho₂),
    rw mul_two,
    exact add_le_add (le_max_left a b) (le_max_right a b) }
end

theorem principal_mul_is_limit {o : ordinal.{u}} (ho₂ : 2 < o) (ho : principal (*) o) :
  o.is_limit :=
principal_add_is_limit
  ((lt_succ 1).trans ho₂)
  (principal_add_of_principal_mul ho (ne_of_gt ho₂))

theorem principal_mul_iff_mul_left_eq {o : ordinal} :
  principal (*) o ↔ ∀ a, 0 < a → a < o → a * o = o :=
begin
  refine ⟨λ h a ha₀ hao, _, λ h a b hao hbo, _⟩,
  { cases le_or_gt o 2 with ho ho,
    { convert one_mul o,
      apply le_antisymm,
      { have : a < succ 1 := hao.trans_le ho,
        rwa lt_succ_iff at this },
      { rwa [←succ_le_iff, succ_zero] at ha₀ } },
    { exact op_eq_self_of_principal hao (mul_is_normal ha₀) h (principal_mul_is_limit ho h) } },
  { rcases eq_or_ne a 0 with rfl | ha, { rwa zero_mul },
    rw ←ordinal.pos_iff_ne_zero at ha,
    rw ←h a ha hao,
    exact (mul_is_normal ha).strict_mono hbo }
end

theorem principal_mul_omega : principal (*) omega :=
λ a b ha hb, match a, b, lt_omega.1 ha, lt_omega.1 hb with
| _, _, ⟨m, rfl⟩, ⟨n, rfl⟩ := by { rw [← nat_cast_mul], apply nat_lt_omega }
end

theorem mul_omega {a : ordinal} (a0 : 0 < a) (ha : a < omega) : a * omega = omega :=
principal_mul_iff_mul_left_eq.1 (principal_mul_omega) a a0 ha

theorem mul_lt_omega_opow {a b c : ordinal}
  (c0 : 0 < c) (ha : a < omega ^ c) (hb : b < omega) : a * b < omega ^ c :=
begin
  rcases zero_or_succ_or_limit c with rfl|⟨c,rfl⟩|l,
  { exact (lt_irrefl _).elim c0 },
  { rw opow_succ at ha,
    rcases ((mul_is_normal $ opow_pos _ omega_pos).limit_lt
      omega_is_limit).1 ha with ⟨n, hn, an⟩,
    apply (mul_le_mul_right' (le_of_lt an) _).trans_lt,
    rw [opow_succ, mul_assoc, mul_lt_mul_iff_left (opow_pos _ omega_pos)],
    exact principal_mul_omega hn hb },
  { rcases ((opow_is_normal one_lt_omega).limit_lt l).1 ha with ⟨x, hx, ax⟩,
    refine (mul_le_mul' (le_of_lt ax) (le_of_lt hb)).trans_lt _,
    rw [← opow_succ, opow_lt_opow_iff_right one_lt_omega],
    exact l.2 _ hx }
end

theorem mul_omega_opow_opow {a b : ordinal} (a0 : 0 < a) (h : a < omega ^ omega ^ b) :
  a * omega ^ omega ^ b = omega ^ omega ^ b :=
begin
  by_cases b0 : b = 0, {rw [b0, opow_zero, opow_one] at h ⊢, exact mul_omega a0 h},
  refine le_antisymm _
    (by simpa only [one_mul] using mul_le_mul_right' (one_le_iff_pos.2 a0) (omega ^ omega ^ b)),
  rcases (lt_opow_of_limit omega_ne_zero (opow_is_limit_left omega_is_limit b0)).1 h
    with ⟨x, xb, ax⟩,
  apply (mul_le_mul_right' (le_of_lt ax) _).trans,
  rw [← opow_add, add_omega_opow xb]
end

theorem principal_mul_omega_opow_opow (o : ordinal) : principal (*) (omega ^ omega ^ o) :=
principal_mul_iff_mul_left_eq.2 (λ a, mul_omega_opow_opow)

theorem principal_add_of_principal_mul_opow {o b : ordinal} (hb : 1 < b)
  (ho : principal (*) (b ^ o)) : principal (+) o :=
λ x y hx hy, begin
  have := ho ((opow_lt_opow_iff_right hb).2 hx) ((opow_lt_opow_iff_right hb).2 hy),
  rwa [←opow_add, opow_lt_opow_iff_right hb] at this
end

/-- The main characterization theorem for multiplicative principal ordinals. -/
theorem principal_mul_iff_le_two_or_omega_opow_opow {o : ordinal} :
  principal (*) o ↔ o ≤ 2 ∨ ∃ a, o = omega ^ omega ^ a :=
begin
  refine ⟨λ ho, _, _⟩,
  { cases le_or_lt o 2 with ho₂ ho₂,
    { exact or.inl ho₂ },
    rcases principal_add_iff_zero_or_omega_opow.1 (principal_add_of_principal_mul ho ho₂.ne')
      with rfl | ⟨a, rfl⟩,
    { exact (ordinal.not_lt_zero 2 ho₂).elim },
    rcases principal_add_iff_zero_or_omega_opow.1
      (principal_add_of_principal_mul_opow one_lt_omega ho) with rfl | ⟨b, rfl⟩,
    { rw opow_zero at ho₂,
      exact ((lt_succ 1).not_le ho₂.le).elim },
    exact or.inr ⟨b, rfl⟩ },
  { rintro (ho₂ | ⟨a, rfl⟩),
    { exact principal_mul_of_le_two ho₂ },
    { exact principal_mul_omega_opow_opow a } }
end

theorem mul_omega_dvd {a : ordinal}
  (a0 : 0 < a) (ha : a < omega) : ∀ {b}, omega ∣ b → a * b = b
| _ ⟨b, rfl⟩ := by rw [← mul_assoc, mul_omega a0 ha]

theorem mul_eq_opow_log_succ {a b : ordinal.{u}} (ha : 0 < a) (hb : principal (*) b) (hb₂ : 2 < b) :
  a * b = b ^ succ (log b a) :=
begin
  apply le_antisymm,
  { have hbl := principal_mul_is_limit hb₂ hb,
    rw [←is_normal.bsup_eq.{u u} (mul_is_normal ha) hbl, bsup_le_iff],
    intros c hcb,
    have hb₁ : 1 < b := (lt_succ 1).trans hb₂,
    have hbo₀ : b ^ b.log a ≠ 0 := ordinal.pos_iff_ne_zero.1 (opow_pos _ (zero_lt_one.trans hb₁)),
    apply le_trans (mul_le_mul_right' (le_of_lt (lt_mul_succ_div a hbo₀)) c),
    rw [mul_assoc, opow_succ],
    refine mul_le_mul_left' (le_of_lt (hb (hbl.2 _ _) hcb)) _,
    rw [div_lt hbo₀, ←opow_succ],
    exact lt_opow_succ_log_self hb₁ _ },
  { rw opow_succ,
    exact mul_le_mul_right' (opow_log_le_self b ha) b }
end

/-! #### Exponential principal ordinals -/

theorem principal_opow_omega : principal (^) omega :=
λ a b ha hb, match a, b, lt_omega.1 ha, lt_omega.1 hb with
| _, _, ⟨m, rfl⟩, ⟨n, rfl⟩ := by { simp_rw ←nat_cast_opow, apply nat_lt_omega }
end

theorem opow_omega {a : ordinal} (a1 : 1 < a) (h : a < omega) : a ^ omega = omega :=
le_antisymm
  ((opow_le_of_limit (one_le_iff_ne_zero.1 $ le_of_lt a1) omega_is_limit).2
    (λ b hb, (principal_opow_omega h hb).le))
  (right_le_opow _ a1)

end ordinal


<|start_filename|>src/order/ideal.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import logic.encodable.basic
import order.atoms
import order.upper_lower

/-!
# Order ideals, cofinal sets, and the Rasiowa–Sikorski lemma

## Main definitions

Throughout this file, `P` is at least a preorder, but some sections require more
structure, such as a bottom element, a top element, or a join-semilattice structure.
- `order.ideal P`: the type of nonempty, upward directed, and downward closed subsets of `P`.
  Dual to the notion of a filter on a preorder.
- `order.is_ideal P`: a predicate for when a `set P` is an ideal.
- `order.ideal.principal p`: the principal ideal generated by `p : P`.
- `order.ideal.is_proper P`: a predicate for proper ideals.
  Dual to the notion of a proper filter.
- `order.ideal.is_maximal`: a predicate for maximal ideals.
  Dual to the notion of an ultrafilter.
- `order.cofinal P`: the type of subsets of `P` containing arbitrarily large elements.
  Dual to the notion of 'dense set' used in forcing.
- `order.ideal_of_cofinals p 𝒟`, where `p : P`, and `𝒟` is a countable family of cofinal
  subsets of P: an ideal in `P` which contains `p` and intersects every set in `𝒟`. (This a form
  of the Rasiowa–Sikorski lemma.)

## References

- <https://en.wikipedia.org/wiki/Ideal_(order_theory)>
- <https://en.wikipedia.org/wiki/Cofinal_(mathematics)>
- <https://en.wikipedia.org/wiki/Rasiowa%E2%80%93Sikorski_lemma>

Note that for the Rasiowa–Sikorski lemma, Wikipedia uses the opposite ordering on `P`,
in line with most presentations of forcing.

## Tags

ideal, cofinal, dense, countable, generic

-/

open function set

namespace order

variables {P : Type*}

/-- An ideal on an order `P` is a subset of `P` that is
  - nonempty
  - upward directed (any pair of elements in the ideal has an upper bound in the ideal)
  - downward closed (any element less than an element of the ideal is in the ideal). -/
structure ideal (P) [has_le P] extends lower_set P :=
(nonempty'  : carrier.nonempty)
(directed'  : directed_on (≤) carrier)

/-- A subset of a preorder `P` is an ideal if it is
  - nonempty
  - upward directed (any pair of elements in the ideal has an upper bound in the ideal)
  - downward closed (any element less than an element of the ideal is in the ideal). -/
@[mk_iff] structure is_ideal {P} [has_le P] (I : set P) : Prop :=
(is_lower_set : is_lower_set I)
(nonempty : I.nonempty)
(directed : directed_on (≤) I)

/-- Create an element of type `order.ideal` from a set satisfying the predicate
`order.is_ideal`. -/
def is_ideal.to_ideal [has_le P] {I : set P} (h : is_ideal I) : ideal P :=
⟨⟨I, h.is_lower_set⟩, h.nonempty, h.directed⟩

namespace ideal
section has_le
variables [has_le P]

section
variables {I J s t : ideal P} {x y : P}

lemma to_lower_set_injective : injective (to_lower_set : ideal P → lower_set P) :=
λ s t h, by { cases s, cases t, congr' }

instance : set_like (ideal P) P :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, to_lower_set_injective $ set_like.coe_injective h }

@[ext] lemma ext {s t : ideal P} : (s : set P) = t → s = t := set_like.ext'

@[simp] lemma carrier_eq_coe (s : ideal P) : s.carrier = s := rfl
@[simp] lemma coe_to_lower_set (s : ideal P) : (s.to_lower_set : set P) = s := rfl

protected lemma lower (s : ideal P) : is_lower_set (s : set P) := s.lower'
protected lemma nonempty (s : ideal P) : (s : set P).nonempty := s.nonempty'
protected lemma directed (s : ideal P) : directed_on (≤) (s : set P) := s.directed'
protected lemma is_ideal (s : ideal P) : is_ideal (s : set P) := ⟨s.lower, s.nonempty, s.directed⟩

lemma mem_compl_of_ge {x y : P} : x ≤ y → x ∈ (I : set P)ᶜ → y ∈ (I : set P)ᶜ := λ h, mt $ I.lower h

/-- The partial ordering by subset inclusion, inherited from `set P`. -/
instance : partial_order (ideal P) := partial_order.lift coe set_like.coe_injective

@[simp] lemma coe_subset_coe : (s : set P) ⊆ t ↔ s ≤ t := iff.rfl
@[simp] lemma coe_ssubset_coe : (s : set P) ⊂ t ↔ s < t := iff.rfl

@[trans] lemma mem_of_mem_of_le {x : P} {I J : ideal P} : x ∈ I → I ≤ J → x ∈ J :=
@set.mem_of_mem_of_subset P x I J

/-- A proper ideal is one that is not the whole set.
    Note that the whole set might not be an ideal. -/
@[mk_iff] class is_proper (I : ideal P) : Prop := (ne_univ : (I : set P) ≠ univ)

lemma is_proper_of_not_mem {I : ideal P} {p : P} (nmem : p ∉ I) : is_proper I :=
⟨λ hp, begin
  change p ∉ ↑I at nmem,
  rw hp at nmem,
  exact nmem (mem_univ p),
end⟩

/-- An ideal is maximal if it is maximal in the collection of proper ideals.

Note that `is_coatom` is less general because ideals only have a top element when `P` is directed
and nonempty. -/
@[mk_iff] class is_maximal (I : ideal P) extends is_proper I : Prop :=
(maximal_proper : ∀ ⦃J : ideal P⦄, I < J → (J : set P) = univ)

lemma inter_nonempty [is_directed P (≥)] (I J : ideal P) : (I ∩ J : set P).nonempty :=
begin
  obtain ⟨a, ha⟩ := I.nonempty,
  obtain ⟨b, hb⟩ := J.nonempty,
  obtain ⟨c, hac, hbc⟩ := exists_le_le a b,
  exact ⟨c, I.lower hac ha, J.lower hbc hb⟩,
end

end

section directed
variables [is_directed P (≤)] [nonempty P] {I : ideal P}

/-- In a directed and nonempty order, the top ideal of a is `univ`. -/
instance : order_top (ideal P) :=
{ top := ⟨⊤, univ_nonempty, directed_on_univ⟩,
  le_top := λ I, le_top }

@[simp] lemma top_to_lower_set : (⊤ : ideal P).to_lower_set = ⊤ := rfl
@[simp] lemma coe_top : ((⊤ : ideal P) : set P) = univ := rfl

lemma is_proper_of_ne_top (ne_top : I ≠ ⊤) : is_proper I := ⟨λ h, ne_top $ ext h⟩

lemma is_proper.ne_top (hI : is_proper I) : I ≠ ⊤ := λ h, is_proper.ne_univ $ congr_arg coe h

lemma _root_.is_coatom.is_proper (hI : is_coatom I) : is_proper I := is_proper_of_ne_top hI.1

lemma is_proper_iff_ne_top : is_proper I ↔ I ≠ ⊤ := ⟨λ h, h.ne_top, λ h, is_proper_of_ne_top h⟩

lemma is_maximal.is_coatom (h : is_maximal I) : is_coatom I :=
⟨is_maximal.to_is_proper.ne_top, λ J h, ext $ is_maximal.maximal_proper h⟩

lemma is_maximal.is_coatom' [is_maximal I] : is_coatom I := is_maximal.is_coatom ‹_›

lemma _root_.is_coatom.is_maximal (hI : is_coatom I) : is_maximal I :=
{ maximal_proper := λ _ _, by simp [hI.2 _ ‹_›],
  ..is_coatom.is_proper ‹_› }

lemma is_maximal_iff_is_coatom : is_maximal I ↔ is_coatom I := ⟨λ h, h.is_coatom, λ h, h.is_maximal⟩

end directed

section order_bot
variables [order_bot P]

@[simp] lemma bot_mem (s : ideal P) : ⊥ ∈ s := s.lower bot_le s.nonempty.some_mem

end order_bot

section order_top
variables [order_top P] {I : ideal P}

lemma top_of_top_mem (h : ⊤ ∈ I) : I = ⊤ := by { ext, exact iff_of_true (I.lower le_top h) trivial }

lemma is_proper.top_not_mem (hI : is_proper I) : ⊤ ∉ I := λ h, hI.ne_top $ top_of_top_mem h

end order_top
end has_le

section preorder
variables [preorder P]

section
variables {I J : ideal P} {x y : P}

/-- The smallest ideal containing a given element. -/
@[simps] def principal (p : P) : ideal P :=
{ to_lower_set := lower_set.Iic p,
  nonempty' := nonempty_Iic,
  directed' := λ x hx y hy, ⟨p, le_rfl, hx, hy⟩ }

instance [inhabited P] : inhabited (ideal P) := ⟨ideal.principal default⟩

@[simp] lemma principal_le_iff : principal x ≤ I ↔ x ∈ I :=
⟨λ h, h le_rfl, λ hx y hy, I.lower hy hx⟩

@[simp] lemma mem_principal : x ∈ principal y ↔ x ≤ y := iff.rfl

end

section order_bot
variables [order_bot P]

/-- There is a bottom ideal when `P` has a bottom element. -/
instance : order_bot (ideal P) :=
{ bot := principal ⊥,
  bot_le := by simp }

@[simp] lemma principal_bot : principal (⊥ : P) = ⊥ := rfl

end order_bot

section order_top
variables [order_top P]

@[simp] lemma principal_top : principal (⊤ : P) = ⊤ := to_lower_set_injective $ lower_set.Iic_top

end order_top
end preorder

section semilattice_sup
variables [semilattice_sup P] {x y : P} {I s : ideal P}

/-- A specific witness of `I.directed` when `P` has joins. -/
lemma sup_mem (hx : x ∈ s) (hy : y ∈ s) : x ⊔ y ∈ s :=
let ⟨z, hz, hx, hy⟩ := s.directed x hx y hy in s.lower (sup_le hx hy) hz

@[simp] lemma sup_mem_iff : x ⊔ y ∈ I ↔ x ∈ I ∧ y ∈ I :=
⟨λ h, ⟨I.lower le_sup_left h, I.lower le_sup_right h⟩, λ h, sup_mem h.1 h.2⟩

end semilattice_sup

section semilattice_sup_directed
variables [semilattice_sup P] [is_directed P (≥)] {x : P} {I J K s t : ideal P}

/-- The infimum of two ideals of a co-directed order is their intersection. -/
instance : has_inf (ideal P) :=
⟨λ I J, { to_lower_set := I.to_lower_set ⊓ J.to_lower_set,
  nonempty' := inter_nonempty I J,
  directed' := λ x hx y hy, ⟨x ⊔ y, ⟨sup_mem hx.1 hy.1, sup_mem hx.2 hy.2⟩, by simp⟩ }⟩

/-- The supremum of two ideals of a co-directed order is the union of the down sets of the pointwise
supremum of `I` and `J`. -/
instance : has_sup (ideal P) :=
⟨λ I J, { carrier   := {x | ∃ (i ∈ I) (j ∈ J), x ≤ i ⊔ j},
  nonempty' := by { cases inter_nonempty I J, exact ⟨w, w, h.1, w, h.2, le_sup_left⟩ },
  directed' := λ x ⟨xi, _, xj, _, _⟩ y ⟨yi, _, yj, _, _⟩,
    ⟨x ⊔ y,
     ⟨xi ⊔ yi, sup_mem ‹_› ‹_›,
      xj ⊔ yj, sup_mem ‹_› ‹_›,
      sup_le
        (calc x ≤ xi ⊔ xj               : ‹_›
         ...    ≤ (xi ⊔ yi) ⊔ (xj ⊔ yj) : sup_le_sup le_sup_left le_sup_left)
        (calc y ≤ yi ⊔ yj               : ‹_›
         ...    ≤ (xi ⊔ yi) ⊔ (xj ⊔ yj) : sup_le_sup le_sup_right le_sup_right)⟩,
     le_sup_left, le_sup_right⟩,
  lower' := λ x y h ⟨yi, _, yj, _, _⟩, ⟨yi, ‹_›, yj, ‹_›, h.trans ‹_›⟩ }⟩

instance : lattice (ideal P) :=
{ sup          := (⊔),
  le_sup_left  := λ I J (i ∈ I), by { cases J.nonempty, exact ⟨i, ‹_›, w, ‹_›, le_sup_left⟩ },
  le_sup_right := λ I J (j ∈ J), by { cases I.nonempty, exact ⟨w, ‹_›, j, ‹_›, le_sup_right⟩ },
  sup_le       := λ I J K hIK hJK a ⟨i, hi, j, hj, ha⟩,
    K.lower ha $ sup_mem (mem_of_mem_of_le hi hIK) (mem_of_mem_of_le hj hJK),
  inf          := (⊓),
  inf_le_left  := λ I J, inter_subset_left I J,
  inf_le_right := λ I J, inter_subset_right I J,
  le_inf       := λ I J K, subset_inter,
  .. ideal.partial_order }

@[simp] lemma coe_sup : ↑(s ⊔ t) = {x | ∃ (a ∈ s) (b ∈ t), x ≤ a ⊔ b} := rfl
@[simp] lemma coe_inf : (↑(s ⊓ t) : set P) = s ∩ t := rfl
@[simp] lemma mem_inf : x ∈ I ⊓ J ↔ x ∈ I ∧ x ∈ J := iff.rfl
@[simp] lemma mem_sup : x ∈ I ⊔ J ↔ ∃ (i ∈ I) (j ∈ J), x ≤ i ⊔ j := iff.rfl

lemma lt_sup_principal_of_not_mem (hx : x ∉ I) : I < I ⊔ principal x :=
le_sup_left.lt_of_ne $ λ h, hx $ by simpa only [left_eq_sup, principal_le_iff] using h

end semilattice_sup_directed

section semilattice_sup_order_bot
variables [semilattice_sup P] [order_bot P] {x : P} {I J K : ideal P}

instance : has_Inf (ideal P) :=
⟨λ S, { to_lower_set := ⨅ s ∈ S, to_lower_set s,
  nonempty' := ⟨⊥, begin
    rw [lower_set.carrier_eq_coe, lower_set.coe_infi₂, set.mem_Inter₂],
    exact λ s _, s.bot_mem,
  end⟩,
  directed' := λ a ha b hb, ⟨a ⊔ b, ⟨
    begin
      rw [lower_set.carrier_eq_coe, lower_set.coe_infi₂, set.mem_Inter₂] at ⊢ ha hb,
      exact λ s hs, sup_mem (ha _ hs) (hb _ hs),
    end,
    le_sup_left, le_sup_right⟩⟩ }⟩

variables {S : set (ideal P)}

@[simp] lemma coe_Inf : (↑(Inf S) : set P) = ⋂ s ∈ S, ↑s := lower_set.coe_infi₂ _

@[simp] lemma mem_Inf : x ∈ Inf S ↔ ∀ s ∈ S, x ∈ s :=
by simp_rw [←set_like.mem_coe, coe_Inf, mem_Inter₂]

instance : complete_lattice (ideal P) :=
{ ..ideal.lattice,
  ..complete_lattice_of_Inf (ideal P) (λ S, begin
    refine ⟨λ s hs, _, λ s hs, by rwa [←coe_subset_coe, coe_Inf, subset_Inter₂_iff]⟩,
    rw [←coe_subset_coe, coe_Inf],
    exact bInter_subset_of_mem hs,
  end) }

end semilattice_sup_order_bot

section distrib_lattice

variables [distrib_lattice P]
variables {I J : ideal P}

lemma eq_sup_of_le_sup {x i j: P} (hi : i ∈ I) (hj : j ∈ J) (hx : x ≤ i ⊔ j) :
  ∃ (i' ∈ I) (j' ∈ J), x = i' ⊔ j' :=
begin
  refine ⟨x ⊓ i, I.lower inf_le_right hi, x ⊓ j, J.lower inf_le_right hj, _⟩,
  calc
  x    = x ⊓ (i ⊔ j)       : left_eq_inf.mpr hx
  ...  = (x ⊓ i) ⊔ (x ⊓ j) : inf_sup_left,
end

lemma coe_sup_eq : ↑(I ⊔ J) = {x | ∃ i ∈ I, ∃ j ∈ J, x = i ⊔ j} :=
set.ext $ λ _, ⟨λ ⟨_, _, _, _, _⟩, eq_sup_of_le_sup ‹_› ‹_› ‹_›,
  λ ⟨i, _, j, _, _⟩, ⟨i, ‹_›, j, ‹_›, le_of_eq ‹_›⟩⟩

end distrib_lattice

section boolean_algebra

variables [boolean_algebra P] {x : P} {I : ideal P}

lemma is_proper.not_mem_of_compl_mem (hI : is_proper I) (hxc : xᶜ ∈ I) : x ∉ I :=
begin
  intro hx,
  apply hI.top_not_mem,
  have ht : x ⊔ xᶜ ∈ I := sup_mem ‹_› ‹_›,
  rwa sup_compl_eq_top at ht,
end

lemma is_proper.not_mem_or_compl_not_mem (hI : is_proper I) : x ∉ I ∨ xᶜ ∉ I :=
have h : xᶜ ∈ I → x ∉ I := hI.not_mem_of_compl_mem, by tauto

end boolean_algebra

end ideal

/-- For a preorder `P`, `cofinal P` is the type of subsets of `P`
  containing arbitrarily large elements. They are the dense sets in
  the topology whose open sets are terminal segments. -/
structure cofinal (P) [preorder P] :=
(carrier : set P)
(mem_gt  : ∀ x : P, ∃ y ∈ carrier, x ≤ y)

namespace cofinal

variables [preorder P]

instance : inhabited (cofinal P) :=
⟨{ carrier := univ, mem_gt := λ x, ⟨x, trivial, le_rfl⟩ }⟩

instance : has_mem P (cofinal P) := ⟨λ x D, x ∈ D.carrier⟩

variables (D : cofinal P) (x : P)
/-- A (noncomputable) element of a cofinal set lying above a given element. -/
noncomputable def above : P := classical.some $ D.mem_gt x

lemma above_mem : D.above x ∈ D :=
exists.elim (classical.some_spec $ D.mem_gt x) $ λ a _, a

lemma le_above : x ≤ D.above x :=
exists.elim (classical.some_spec $ D.mem_gt x) $ λ _ b, b

end cofinal

section ideal_of_cofinals

variables [preorder P] (p : P) {ι : Type*} [encodable ι] (𝒟 : ι → cofinal P)

/-- Given a starting point, and a countable family of cofinal sets,
  this is an increasing sequence that intersects each cofinal set. -/
noncomputable def sequence_of_cofinals : ℕ → P
| 0 := p
| (n+1) := match encodable.decode ι n with
           | none   := sequence_of_cofinals n
           | some i := (𝒟 i).above (sequence_of_cofinals n)
           end

lemma sequence_of_cofinals.monotone : monotone (sequence_of_cofinals p 𝒟) :=
by { apply monotone_nat_of_le_succ, intros n, dunfold sequence_of_cofinals,
  cases encodable.decode ι n, { refl }, { apply cofinal.le_above }, }

lemma sequence_of_cofinals.encode_mem (i : ι) :
  sequence_of_cofinals p 𝒟 (encodable.encode i + 1) ∈ 𝒟 i :=
by { dunfold sequence_of_cofinals, rw encodable.encodek, apply cofinal.above_mem, }

/-- Given an element `p : P` and a family `𝒟` of cofinal subsets of a preorder `P`,
  indexed by a countable type, `ideal_of_cofinals p 𝒟` is an ideal in `P` which
  - contains `p`, according to `mem_ideal_of_cofinals p 𝒟`, and
  - intersects every set in `𝒟`, according to `cofinal_meets_ideal_of_cofinals p 𝒟`.

  This proves the Rasiowa–Sikorski lemma. -/
def ideal_of_cofinals : ideal P :=
{ carrier   := { x : P | ∃ n, x ≤ sequence_of_cofinals p 𝒟 n },
  lower'     := λ x y hxy ⟨n, hn⟩, ⟨n, le_trans hxy hn⟩,
  nonempty' := ⟨p, 0, le_rfl⟩,
  directed' := λ x ⟨n, hn⟩ y ⟨m, hm⟩,
               ⟨_, ⟨max n m, le_rfl⟩,
               le_trans hn $ sequence_of_cofinals.monotone p 𝒟 (le_max_left _ _),
               le_trans hm $ sequence_of_cofinals.monotone p 𝒟 (le_max_right _ _) ⟩ }

lemma mem_ideal_of_cofinals : p ∈ ideal_of_cofinals p 𝒟 := ⟨0, le_rfl⟩

/-- `ideal_of_cofinals p 𝒟` is `𝒟`-generic. -/
lemma cofinal_meets_ideal_of_cofinals (i : ι) : ∃ x : P, x ∈ 𝒟 i ∧ x ∈ ideal_of_cofinals p 𝒟 :=
⟨_, sequence_of_cofinals.encode_mem p 𝒟 i, _, le_rfl⟩

end ideal_of_cofinals

end order


<|start_filename|>src/algebra/homology/short_exact/preadditive.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.homology.exact
import category_theory.preadditive.additive_functor

/-!
# Short exact sequences, and splittings.

`short_exact f g` is the proposition that `0 ⟶ A -f⟶ B -g⟶ C ⟶ 0` is an exact sequence.

We define when a short exact sequence is left-split, right-split, and split.

## See also
In `algebra.homology.short_exact.abelian` we show that in an abelian category
a left-split short exact sequences admits a splitting.
-/

noncomputable theory

open category_theory category_theory.limits category_theory.preadditive

variables {𝒜 : Type*} [category 𝒜]

namespace category_theory
variables {A B C A' B' C' : 𝒜} (f : A ⟶ B) (g : B ⟶ C) (f' : A' ⟶ B') (g' : B' ⟶ C')

section has_zero_morphisms
variables [has_zero_morphisms 𝒜] [has_kernels 𝒜] [has_images 𝒜]

/-- If `f : A ⟶ B` and `g : B ⟶ C` then `short_exact f g` is the proposition saying
  the resulting diagram `0 ⟶ A ⟶ B ⟶ C ⟶ 0` is an exact sequence. -/
structure short_exact : Prop :=
[mono  : mono f]
[epi   : epi g]
(exact : exact f g)

/-- An exact sequence `A -f⟶ B -g⟶ C` is *left split*
if there exists a morphism `φ : B ⟶ A` such that `f ≫ φ = 𝟙 A` and `g` is epi.

Such a sequence is automatically short exact (i.e., `f` is mono). -/
structure left_split : Prop :=
(left_split : ∃ φ : B ⟶ A, f ≫ φ = 𝟙 A)
[epi   : epi g]
(exact : exact f g)

lemma left_split.short_exact {f : A ⟶ B} {g : B ⟶ C} (h : left_split f g) : short_exact f g :=
{ mono :=
  begin
    obtain ⟨φ, hφ⟩ := h.left_split,
    haveI : mono (f ≫ φ) := by { rw hφ, apply_instance },
    exact mono_of_mono f φ,
  end,
  epi := h.epi,
  exact := h.exact }

/-- An exact sequence `A -f⟶ B -g⟶ C` is *right split*
if there exists a morphism `φ : C ⟶ B` such that `f ≫ φ = 𝟙 A` and `f` is mono.

Such a sequence is automatically short exact (i.e., `g` is epi). -/
structure right_split : Prop :=
(right_split : ∃ χ : C ⟶ B, χ ≫ g = 𝟙 C)
[mono  : mono f]
(exact : exact f g)

lemma right_split.short_exact {f : A ⟶ B} {g : B ⟶ C} (h : right_split f g) : short_exact f g :=
{ epi :=
  begin
    obtain ⟨χ, hχ⟩ := h.right_split,
    haveI : epi (χ ≫ g) := by { rw hχ, apply_instance },
    exact epi_of_epi χ g,
  end,
  mono := h.mono,
  exact := h.exact }

end has_zero_morphisms

section preadditive
variables [preadditive 𝒜]

/-- An exact sequence `A -f⟶ B -g⟶ C` is *split* if there exist
`φ : B ⟶ A` and `χ : C ⟶ B` such that:
* `f ≫ φ = 𝟙 A`
* `χ ≫ g = 𝟙 C`
* `f ≫ g = 0`
* `χ ≫ φ = 0`
* `φ ≫ f + g ≫ χ = 𝟙 B`

Such a sequence is automatically short exact (i.e., `f` is mono and `g` is epi). -/
structure split : Prop :=
(split : ∃ (φ : B ⟶ A) (χ : C ⟶ B),
  f ≫ φ = 𝟙 A ∧ χ ≫ g = 𝟙 C ∧ f ≫ g = 0 ∧ χ ≫ φ = 0 ∧ φ ≫ f + g ≫ χ = 𝟙 B)

variables [has_kernels 𝒜] [has_images 𝒜]

lemma exact_of_split {A B C : 𝒜} {f : A ⟶ B} {g : B ⟶ C} {χ : C ⟶ B} {φ : B ⟶ A}
  (hfg : f ≫ g = 0) (H : φ ≫ f + g ≫ χ = 𝟙 B) : exact f g :=
{ w := hfg,
  epi :=
  begin
    let ψ : (kernel_subobject g : 𝒜) ⟶ image_subobject f :=
      subobject.arrow _ ≫ φ ≫ factor_thru_image_subobject f,
    suffices : ψ ≫ image_to_kernel f g hfg = 𝟙 _,
    { convert epi_of_epi ψ _, rw this, apply_instance },
    rw ← cancel_mono (subobject.arrow _), swap, { apply_instance },
    simp only [image_to_kernel_arrow, image_subobject_arrow_comp, category.id_comp, category.assoc],
    calc (kernel_subobject g).arrow ≫ φ ≫ f
        = (kernel_subobject g).arrow ≫ 𝟙 B : _
    ... = (kernel_subobject g).arrow        : category.comp_id _,
    rw [← H, preadditive.comp_add],
    simp only [add_zero, zero_comp, kernel_subobject_arrow_comp_assoc],
  end }

section

variables {f g}

lemma split.exact (h : split f g) : exact f g :=
by { obtain ⟨φ, χ, -, -, h1, -, h2⟩ := h, exact exact_of_split h1 h2 }

lemma split.left_split (h : split f g) : left_split f g :=
{ left_split := by { obtain ⟨φ, χ, h1, -⟩ := h, exact ⟨φ, h1⟩, },
  epi := begin
    obtain ⟨φ, χ, -, h2, -⟩ := h,
    have : epi (χ ≫ g), { rw h2, apply_instance },
    exactI epi_of_epi χ g,
  end,
  exact := h.exact }

lemma split.right_split (h : split f g) : right_split f g :=
{ right_split := by { obtain ⟨φ, χ, -, h1, -⟩ := h, exact ⟨χ, h1⟩, },
  mono := begin
    obtain ⟨φ, χ, h1, -⟩ := h,
    have : mono (f ≫ φ), { rw h1, apply_instance },
    exactI mono_of_mono f φ,
  end,
  exact := h.exact }

lemma split.short_exact (h : split f g) : short_exact f g :=
h.left_split.short_exact

end

lemma split.map {𝒜 ℬ : Type*} [category 𝒜] [preadditive 𝒜] [category ℬ] [preadditive ℬ]
  (F : 𝒜 ⥤ ℬ) [functor.additive F] {A B C : 𝒜} {f : A ⟶ B} {g : B ⟶ C} (h : split f g) :
  split (F.map f) (F.map g) :=
begin
  obtain ⟨φ, χ, h1, h2, h3, h4, h5⟩ := h,
  refine ⟨⟨F.map φ, F.map χ, _⟩⟩,
  simp only [← F.map_comp, ← F.map_id, ← F.map_add, F.map_zero, *, eq_self_iff_true, and_true],
end

/-- The sequence `A ⟶ A ⊞ B ⟶ B` is exact. -/
lemma exact_inl_snd [has_binary_biproducts 𝒜] (A B : 𝒜) :
  exact (biprod.inl : A ⟶ A ⊞ B) biprod.snd :=
exact_of_split biprod.inl_snd biprod.total

/-- The sequence `B ⟶ A ⊞ B ⟶ A` is exact. -/
lemma exact_inr_fst [has_binary_biproducts 𝒜] (A B : 𝒜) :
  exact (biprod.inr : B ⟶ A ⊞ B) biprod.fst :=
exact_of_split biprod.inr_fst ((add_comm _ _).trans biprod.total)

end preadditive

/-- A *splitting* of a sequence `A -f⟶ B -g⟶ C` is an isomorphism
to the short exact sequence `0 ⟶ A ⟶ A ⊞ C ⟶ C ⟶ 0` such that
the vertical maps on the left and the right are the identity. -/
@[nolint has_inhabited_instance]
structure splitting [has_zero_morphisms 𝒜] [has_binary_biproducts 𝒜] :=
(iso : B ≅ A ⊞ C)
(comp_iso_eq_inl : f ≫ iso.hom = biprod.inl)
(iso_comp_snd_eq : iso.hom ≫ biprod.snd = g)

variables {f g}

namespace splitting

section has_zero_morphisms
variables [has_zero_morphisms 𝒜] [has_binary_biproducts 𝒜]

attribute [simp, reassoc] comp_iso_eq_inl iso_comp_snd_eq

variables (h : splitting f g)

@[simp, reassoc] lemma inl_comp_iso_eq : biprod.inl ≫ h.iso.inv = f :=
by rw [iso.comp_inv_eq, h.comp_iso_eq_inl]

@[simp, reassoc] lemma iso_comp_eq_snd : h.iso.inv ≫ g = biprod.snd :=
by rw [iso.inv_comp_eq, h.iso_comp_snd_eq]

/-- If `h` is a splitting of `A -f⟶ B -g⟶ C`,
then `h.section : C ⟶ B` is the morphism satisfying `h.section ≫ g = 𝟙 C`. -/
def _root_.category_theory.splitting.section : C ⟶ B := biprod.inr ≫ h.iso.inv

/-- If `h` is a splitting of `A -f⟶ B -g⟶ C`,
then `h.retraction : B ⟶ A` is the morphism satisfying `f ≫ h.retraction = 𝟙 A`. -/
def retraction : B ⟶ A := h.iso.hom ≫ biprod.fst

@[simp, reassoc] lemma section_π : h.section ≫ g = 𝟙 C := by { delta splitting.section, simp }

@[simp, reassoc] lemma ι_retraction : f ≫ h.retraction = 𝟙 A := by { delta retraction, simp }

@[simp, reassoc] lemma section_retraction : h.section ≫ h.retraction = 0 :=
by { delta splitting.section retraction, simp }

/-- The retraction in a splitting is a split mono. -/
protected def split_mono : split_mono f := ⟨h.retraction, by simp⟩

/-- The section in a splitting is a split epi. -/
protected def split_epi : split_epi g := ⟨h.section, by simp⟩

@[simp, reassoc] lemma inr_iso_inv : biprod.inr ≫ h.iso.inv = h.section := rfl

@[simp, reassoc] lemma iso_hom_fst : h.iso.hom ≫ biprod.fst = h.retraction := rfl

/-- A short exact sequence of the form `X -f⟶ Y -0⟶ Z` where `f` is an iso and `Z` is zero
has a splitting. -/
def splitting_of_is_iso_zero {X Y Z : 𝒜} (f : X ⟶ Y) [is_iso f] (hZ : is_zero Z) :
  splitting f (0 : Y ⟶ Z) :=
⟨(as_iso f).symm ≪≫ iso_biprod_zero hZ, by simp [hZ.eq_of_tgt _ 0], by simp⟩

include h

protected lemma mono : mono f :=
begin
  apply mono_of_mono _ h.retraction,
  rw h.ι_retraction,
  apply_instance
end

protected lemma epi : epi g :=
begin
  apply_with (epi_of_epi h.section) { instances := ff },
  rw h.section_π,
  apply_instance
end

instance : mono h.section :=
by { delta splitting.section, apply_instance }

instance : epi h.retraction :=
by { delta retraction, apply epi_comp }

end has_zero_morphisms

section preadditive
variables [preadditive 𝒜] [has_binary_biproducts 𝒜]
variables (h : splitting f g)

lemma split_add : h.retraction ≫ f + g ≫ h.section = 𝟙 _ :=
begin
  delta splitting.section retraction,
  rw [← cancel_mono h.iso.hom, ← cancel_epi h.iso.inv],
  simp only [category.comp_id, category.id_comp, category.assoc,
    iso.inv_hom_id_assoc, iso.inv_hom_id, limits.biprod.total,
    preadditive.comp_add, preadditive.add_comp,
    splitting.comp_iso_eq_inl, splitting.iso_comp_eq_snd_assoc]
end

@[reassoc]
lemma retraction_ι_eq_id_sub :
  h.retraction ≫ f = 𝟙 _ - g ≫ h.section :=
eq_sub_iff_add_eq.mpr h.split_add

@[reassoc]
lemma π_section_eq_id_sub :
  g ≫ h.section = 𝟙 _ - h.retraction ≫ f :=
eq_sub_iff_add_eq.mpr ((add_comm _ _).trans h.split_add)

lemma splittings_comm (h h' : splitting f g) :
  h'.section ≫ h.retraction = - h.section ≫ h'.retraction :=
begin
  haveI := h.mono,
  rw ← cancel_mono f,
  simp [retraction_ι_eq_id_sub],
end

include h

lemma split : split f g :=
begin
  let φ := h.iso.hom ≫ biprod.fst,
  let χ := biprod.inr ≫ h.iso.inv,
  refine ⟨⟨h.retraction, h.section, h.ι_retraction, h.section_π, _,
    h.section_retraction, h.split_add⟩⟩,
  rw [← h.inl_comp_iso_eq, category.assoc, h.iso_comp_eq_snd, biprod.inl_snd],
end

@[reassoc] lemma comp_eq_zero : f ≫ g = 0 :=
h.split.1.some_spec.some_spec.2.2.1

variables [has_kernels 𝒜] [has_images 𝒜] [has_zero_object 𝒜] [has_cokernels 𝒜]

protected lemma exact : exact f g :=
begin
  rw exact_iff_exact_of_iso f g (biprod.inl : A ⟶ A ⊞ C) (biprod.snd : A ⊞ C ⟶ C) _ _ _,
  { exact exact_inl_snd _ _ },
  { refine arrow.iso_mk (iso.refl _) h.iso _,
    simp only [iso.refl_hom, arrow.mk_hom, category.id_comp, comp_iso_eq_inl], },
  { refine arrow.iso_mk h.iso (iso.refl _) _,
    dsimp, simp, },
  { refl }
end

protected
lemma short_exact : short_exact f g :=
{ mono := h.mono, epi := h.epi, exact := h.exact }

end preadditive

end splitting

end category_theory


<|start_filename|>src/topology/metric_space/metrizable.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import topology.urysohns_lemma
import topology.continuous_function.bounded

/-!
# Metrizability of a regular topological space with second countable topology

In this file we define metrizable topological spaces, i.e., topological spaces for which there
exists a metric space structure that generates the same topology.

We also show that a regular topological space with second countable topology `X` is metrizable.

First we prove that `X` can be embedded into `l^∞`, then use this embedding to pull back the metric
space structure.
-/

open set filter metric
open_locale bounded_continuous_function filter topological_space

namespace topological_space

variables {ι X Y : Type*} {π : ι → Type*} [topological_space X] [topological_space Y]
  [fintype ι] [Π i, topological_space (π i)]

/-- A topological space is *pseudo metrizable* if there exists a pseudo metric space structure
compatible with the topology. To endow such a space with a compatible distance, use
`letI : pseudo_metric_space X := topological_space.pseudo_metrizable_space_pseudo_metric X`. -/
class pseudo_metrizable_space (X : Type*) [t : topological_space X] : Prop :=
(exists_pseudo_metric : ∃ (m : pseudo_metric_space X), m.to_uniform_space.to_topological_space = t)

@[priority 100]
instance _root_.pseudo_metric_space.to_pseudo_metrizable_space {X : Type*}
  [m : pseudo_metric_space X] :
  pseudo_metrizable_space X :=
⟨⟨m, rfl⟩⟩

/-- Construct on a metrizable space a metric compatible with the topology. -/
noncomputable def pseudo_metrizable_space_pseudo_metric
  (X : Type*) [topological_space X] [h : pseudo_metrizable_space X] :
  pseudo_metric_space X :=
h.exists_pseudo_metric.some.replace_topology h.exists_pseudo_metric.some_spec.symm

instance pseudo_metrizable_space_prod [pseudo_metrizable_space X] [pseudo_metrizable_space Y] :
  pseudo_metrizable_space (X × Y) :=
begin
  letI : pseudo_metric_space X := pseudo_metrizable_space_pseudo_metric X,
  letI : pseudo_metric_space Y := pseudo_metrizable_space_pseudo_metric Y,
  apply_instance
end

/-- Given an inducing map of a topological space into a pseudo metrizable space, the source space
is also pseudo metrizable. -/
lemma _root_.inducing.pseudo_metrizable_space [pseudo_metrizable_space Y] {f : X → Y}
  (hf : inducing f) :
  pseudo_metrizable_space X :=
begin
  letI : pseudo_metric_space Y := pseudo_metrizable_space_pseudo_metric Y,
  exact ⟨⟨hf.comap_pseudo_metric_space, rfl⟩⟩
end

instance pseudo_metrizable_space.subtype [pseudo_metrizable_space X]
  (s : set X) : pseudo_metrizable_space s :=
inducing_coe.pseudo_metrizable_space

instance pseudo_metrizable_space_pi [Π i, pseudo_metrizable_space (π i)] :
  pseudo_metrizable_space (Π i, π i) :=
by { letI := λ i, pseudo_metrizable_space_pseudo_metric (π i), apply_instance }

/-- A topological space is metrizable if there exists a metric space structure compatible with the
topology. To endow such a space with a compatible distance, use
`letI : metric_space X := topological_space.metrizable_space_metric X` -/
class metrizable_space (X : Type*) [t : topological_space X] : Prop :=
(exists_metric : ∃ (m : metric_space X), m.to_uniform_space.to_topological_space = t)

@[priority 100]
instance _root_.metric_space.to_metrizable_space {X : Type*} [m : metric_space X] :
  metrizable_space X :=
⟨⟨m, rfl⟩⟩

@[priority 100]
instance metrizable_space.to_pseudo_metrizable_space [h : metrizable_space X] :
  pseudo_metrizable_space X :=
⟨let ⟨m, hm⟩ := h.1 in ⟨m.to_pseudo_metric_space, hm⟩⟩

/-- Construct on a metrizable space a metric compatible with the topology. -/
noncomputable def metrizable_space_metric (X : Type*) [topological_space X]
  [h : metrizable_space X] :
  metric_space X :=
h.exists_metric.some.replace_topology h.exists_metric.some_spec.symm

@[priority 100]
instance t2_space_of_metrizable_space [metrizable_space X] : t2_space X :=
by { letI : metric_space X := metrizable_space_metric X, apply_instance }

instance metrizable_space_prod [metrizable_space X] [metrizable_space Y] :
  metrizable_space (X × Y) :=
begin
  letI : metric_space X := metrizable_space_metric X,
  letI : metric_space Y := metrizable_space_metric Y,
  apply_instance
end

/-- Given an embedding of a topological space into a metrizable space, the source space is also
metrizable. -/
lemma _root_.embedding.metrizable_space [metrizable_space Y] {f : X → Y} (hf : embedding f) :
  metrizable_space X :=
begin
  letI : metric_space Y := metrizable_space_metric Y,
  exact ⟨⟨hf.comap_metric_space f, rfl⟩⟩
end

instance metrizable_space.subtype [metrizable_space X] (s : set X) : metrizable_space s :=
embedding_subtype_coe.metrizable_space

instance metrizable_space_pi [Π i, metrizable_space (π i)] : metrizable_space (Π i, π i) :=
by { letI := λ i, metrizable_space_metric (π i), apply_instance }

variables (X) [regular_space X] [second_countable_topology X]

/-- A regular topological space with second countable topology can be embedded into `l^∞ = ℕ →ᵇ ℝ`.
-/
lemma exists_embedding_l_infty : ∃ f : X → (ℕ →ᵇ ℝ), embedding f :=
begin
  haveI : normal_space X := normal_space_of_regular_second_countable X,
  -- Choose a countable basis, and consider the set `s` of pairs of set `(U, V)` such that `U ∈ B`,
  -- `V ∈ B`, and `closure U ⊆ V`.
  rcases exists_countable_basis X with ⟨B, hBc, -, hB⟩,
  set s : set (set X × set X) := {UV ∈ B ×ˢ B| closure UV.1 ⊆ UV.2},
  -- `s` is a countable set.
  haveI : encodable s := ((hBc.prod hBc).mono (inter_subset_left _ _)).to_encodable,
  -- We don't have the space of bounded (possibly discontinuous) functions, so we equip `s`
  -- with the discrete topology and deal with `s →ᵇ ℝ` instead.
  letI : topological_space s := ⊥, haveI : discrete_topology s := ⟨rfl⟩,
  suffices : ∃ f : X → (s →ᵇ ℝ), embedding f,
  { rcases this with ⟨f, hf⟩,
    exact ⟨λ x, (f x).extend (encodable.encode' s) 0, (bounded_continuous_function.isometry_extend
      (encodable.encode' s) (0 : ℕ →ᵇ ℝ)).embedding.comp hf⟩ },
  have hd : ∀ UV : s, disjoint (closure UV.1.1) (UV.1.2ᶜ) :=
    λ UV, disjoint_compl_right.mono_right (compl_subset_compl.2 UV.2.2),
  -- Choose a sequence of `εₙ > 0`, `n : s`, that is bounded above by `1` and tends to zero
  -- along the `cofinite` filter.
  obtain ⟨ε, ε01, hε⟩ : ∃ ε : s → ℝ, (∀ UV, ε UV ∈ Ioc (0 : ℝ) 1) ∧ tendsto ε cofinite (𝓝 0),
  { rcases pos_sum_of_encodable zero_lt_one s with ⟨ε, ε0, c, hεc, hc1⟩,
    refine ⟨ε, λ UV, ⟨ε0 UV, _⟩, hεc.summable.tendsto_cofinite_zero⟩,
    exact (le_has_sum hεc UV $ λ _ _, (ε0 _).le).trans hc1 },
  /- For each `UV = (U, V) ∈ s` we use Urysohn's lemma to choose a function `f UV` that is equal to
  zero on `U` and is equal to `ε UV` on the complement to `V`. -/
  have : ∀ UV : s, ∃ f : C(X, ℝ), eq_on f 0 UV.1.1 ∧ eq_on f (λ _, ε UV) UV.1.2ᶜ ∧
    ∀ x, f x ∈ Icc 0 (ε UV),
  { intro UV,
    rcases exists_continuous_zero_one_of_closed is_closed_closure
      (hB.is_open UV.2.1.2).is_closed_compl (hd UV) with ⟨f, hf₀, hf₁, hf01⟩,
    exact ⟨ε UV • f, λ x hx, by simp [hf₀ (subset_closure hx)], λ x hx, by simp [hf₁ hx],
      λ x, ⟨mul_nonneg (ε01 _).1.le (hf01 _).1, mul_le_of_le_one_right (ε01 _).1.le (hf01 _).2⟩⟩ },
  choose f hf0 hfε hf0ε,
  have hf01 : ∀ UV x, f UV x ∈ Icc (0 : ℝ) 1,
    from λ UV x, Icc_subset_Icc_right (ε01 _).2 (hf0ε _ _),
  /- The embedding is given by `F x UV = f UV x`. -/
  set F : X → s →ᵇ ℝ := λ x, ⟨⟨λ UV, f UV x, continuous_of_discrete_topology⟩, 1, λ UV₁ UV₂,
    real.dist_le_of_mem_Icc_01 (hf01 _ _) (hf01 _ _)⟩,
  have hF : ∀ x UV, F x UV = f UV x := λ _ _, rfl,
  refine ⟨F, embedding.mk' _ (λ x y hxy, _) (λ x, le_antisymm _ _)⟩,
  { /- First we prove that `F` is injective. Indeed, if `F x = F y` and `x ≠ y`, then we can find
    `(U, V) ∈ s` such that `x ∈ U` and `y ∉ V`, hence `F x UV = 0 ≠ ε UV = F y UV`. -/
    refine not_not.1 (λ Hne, _), -- `by_contra Hne` timeouts
    rcases hB.mem_nhds_iff.1 (is_open_ne.mem_nhds Hne) with ⟨V, hVB, hxV, hVy⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    apply (ε01 UV).1.ne,
    calc (0 : ℝ) = F x UV : (hf0 UV hxU).symm
             ... = F y UV : by rw hxy
             ... = ε UV   : hfε UV (λ h : y ∈ V, hVy h rfl) },
  { /- Now we prove that each neighborhood `V` of `x : X` include a preimage of a neighborhood of
    `F x` under `F`. Without loss of generality, `V` belongs to `B`. Choose `U ∈ B` such that
    `x ∈ V` and `closure V ⊆ U`. Then the preimage of the `(ε (U, V))`-neighborhood of `F x`
    is included by `V`. -/
    refine ((nhds_basis_ball.comap _).le_basis_iff hB.nhds_has_basis).2 _,
    rintro V ⟨hVB, hxV⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    refine ⟨ε UV, (ε01 UV).1, λ y (hy : dist (F y) (F x) < ε UV), _⟩,
    replace hy : dist (F y UV) (F x UV) < ε UV,
      from (bounded_continuous_function.dist_coe_le_dist _).trans_lt hy,
    contrapose! hy,
    rw [hF, hF, hfε UV hy, hf0 UV hxU, pi.zero_apply, dist_zero_right],
    exact le_abs_self _ },
  { /- Finally, we prove that `F` is continuous. Given `δ > 0`, consider the set `T` of `(U, V) ∈ s`
    such that `ε (U, V) ≥ δ`. Since `ε` tends to zero, `T` is finite. Since each `f` is continuous,
    we can choose a neighborhood such that `dist (F y (U, V)) (F x (U, V)) ≤ δ` for any
    `(U, V) ∈ T`. For `(U, V) ∉ T`, the same inequality is true because both `F y (U, V)` and
    `F x (U, V)` belong to the interval `[0, ε (U, V)]`. -/
    refine (nhds_basis_closed_ball.comap _).ge_iff.2 (λ δ δ0, _),
    have h_fin : {UV : s | δ ≤ ε UV}.finite, by simpa only [← not_lt] using hε (gt_mem_nhds δ0),
    have : ∀ᶠ y in 𝓝 x, ∀ UV, δ ≤ ε UV → dist (F y UV) (F x UV) ≤ δ,
    { refine (eventually_all_finite h_fin).2 (λ UV hUV, _),
      exact (f UV).continuous.tendsto x (closed_ball_mem_nhds _ δ0) },
    refine this.mono (λ y hy, (bounded_continuous_function.dist_le δ0.le).2 $ λ UV, _),
    cases le_total δ (ε UV) with hle hle,
    exacts [hy _ hle, (real.dist_le_of_mem_Icc (hf0ε _ _) (hf0ε _ _)).trans (by rwa sub_zero)] }
end

/-- *Urysohn's metrization theorem* (Tychonoff's version): a regular topological space with second
countable topology `X` is metrizable, i.e., there exists a metric space structure that generates the
same topology. -/
lemma metrizable_space_of_regular_second_countable : metrizable_space X :=
let ⟨f, hf⟩ := exists_embedding_l_infty X in hf.metrizable_space

instance : metrizable_space ennreal := metrizable_space_of_regular_second_countable ennreal

end topological_space


<|start_filename|>src/algebra/group_with_zero/power.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.group_power.lemmas

/-!
# Powers of elements of groups with an adjoined zero element

In this file we define integer power functions for groups with an adjoined zero element.
This generalises the integer power function on a division ring.
-/

section zero
variables {M : Type*} [monoid_with_zero M]

@[simp] lemma zero_pow' : ∀ n : ℕ, n ≠ 0 → (0 : M) ^ n = 0
| 0     h := absurd rfl h
| (k+1) h := by { rw [pow_succ], exact zero_mul _ }

lemma ne_zero_pow {a : M} {n : ℕ} (hn : n ≠ 0) : a ^ n ≠ 0 → a ≠ 0 :=
by { contrapose!, rintro rfl, exact zero_pow' n hn }

@[simp] lemma zero_pow_eq_zero [nontrivial M] {n : ℕ} : (0 : M) ^ n = 0 ↔ 0 < n :=
begin
  split; intro h,
  { rw [pos_iff_ne_zero], rintro rfl, simpa using h },
  { exact zero_pow' n h.ne.symm }
end

lemma ring.inverse_pow (r : M) : ∀ (n : ℕ), ring.inverse r ^ n = ring.inverse (r ^ n)
| 0 := by rw [pow_zero, pow_zero, ring.inverse_one]
| (n + 1) := by rw [pow_succ, pow_succ', ring.mul_inverse_rev' ((commute.refl r).pow_left n),
                    ring.inverse_pow]

end zero

section group_with_zero
variables {G₀ : Type*} [group_with_zero G₀] {a : G₀} {m n : ℕ}

section nat_pow

theorem pow_sub₀ (a : G₀) {m n : ℕ} (ha : a ≠ 0) (h : n ≤ m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
have h1 : m - n + n = m, from tsub_add_cancel_of_le h,
have h2 : a ^ (m - n) * a ^ n = a ^ m, by rw [←pow_add, h1],
by simpa only [div_eq_mul_inv] using eq_div_of_mul_eq (pow_ne_zero _ ha) h2

lemma pow_sub_of_lt (a : G₀) {m n : ℕ} (h : n < m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
begin
  obtain rfl | ha := eq_or_ne a 0,
  { rw [zero_pow (tsub_pos_of_lt h), zero_pow (n.zero_le.trans_lt h), zero_mul] },
  { exact pow_sub₀ _ ha h.le }
end

theorem pow_inv_comm₀ (a : G₀) (m n : ℕ) : (a⁻¹) ^ m * a ^ n = a ^ n * (a⁻¹) ^ m :=
(commute.refl a).inv_left₀.pow_pow m n

lemma inv_pow_sub₀ (ha : a ≠ 0) (h : n ≤ m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub₀ _ (inv_ne_zero ha) h, inv_pow, inv_pow, inv_inv]

lemma inv_pow_sub_of_lt (a : G₀) (h : n < m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub_of_lt a⁻¹ h, inv_pow, inv_pow, inv_inv]

end nat_pow

end group_with_zero

section zpow
open int
variables {G₀ : Type*} [group_with_zero G₀]

local attribute [ematch] le_of_lt

lemma zero_zpow : ∀ z : ℤ, z ≠ 0 → (0 : G₀) ^ z = 0
| (n : ℕ) h := by { rw [zpow_coe_nat, zero_pow'], simpa using h }
| -[1+n]  h := by simp

lemma zero_zpow_eq (n : ℤ) : (0 : G₀) ^ n = if n = 0 then 1 else 0 :=
begin
  split_ifs with h,
  { rw [h, zpow_zero] },
  { rw [zero_zpow _ h] }
end

lemma zpow_add_one₀ {a : G₀} (ha : a ≠ 0) : ∀ n : ℤ, a ^ (n + 1) = a ^ n * a
| (n : ℕ)    := by simp [← int.coe_nat_succ, pow_succ']
| -[1+n] := by rw [int.neg_succ_of_nat_eq, zpow_neg, neg_add, neg_add_cancel_right, zpow_neg,
  ← int.coe_nat_succ, zpow_coe_nat, zpow_coe_nat, pow_succ _ n, mul_inv_rev, mul_assoc,
  inv_mul_cancel ha, mul_one]

lemma zpow_sub_one₀ {a : G₀} (ha : a ≠ 0) (n : ℤ) : a ^ (n - 1) = a ^ n * a⁻¹ :=
calc a ^ (n - 1) = a ^ (n - 1) * a * a⁻¹ : by rw [mul_assoc, mul_inv_cancel ha, mul_one]
             ... = a^n * a⁻¹             : by rw [← zpow_add_one₀ ha, sub_add_cancel]

lemma zpow_add₀ {a : G₀} (ha : a ≠ 0) (m n : ℤ) : a ^ (m + n) = a ^ m * a ^ n :=
begin
  induction n using int.induction_on with n ihn n ihn,
  case hz : { simp },
  { simp only [← add_assoc, zpow_add_one₀ ha, ihn, mul_assoc] },
  { rw [zpow_sub_one₀ ha, ← mul_assoc, ← ihn, ← zpow_sub_one₀ ha, add_sub_assoc] }
end

lemma zpow_add' {a : G₀} {m n : ℤ} (h : a ≠ 0 ∨ m + n ≠ 0 ∨ m = 0 ∧ n = 0) :
  a ^ (m + n) = a ^ m * a ^ n :=
begin
  by_cases hm : m = 0, { simp [hm] },
  by_cases hn : n = 0, { simp [hn] },
  by_cases ha : a = 0,
  { subst a,
    simp only [false_or, eq_self_iff_true, not_true, ne.def, hm, hn, false_and, or_false] at h,
    rw [zero_zpow _ h, zero_zpow _ hm, zero_mul] },
  { exact zpow_add₀ ha m n }
end

theorem zpow_one_add₀ {a : G₀} (h : a ≠ 0) (i : ℤ) : a ^ (1 + i) = a * a ^ i :=
by rw [zpow_add₀ h, zpow_one]

theorem semiconj_by.zpow_right₀ {a x y : G₀} (h : semiconj_by a x y) :
  ∀ m : ℤ, semiconj_by a (x^m) (y^m)
| (n : ℕ) := by simp [h.pow_right n]
| -[1+n]  := by simp [(h.pow_right (n + 1)).inv_right₀]

theorem commute.zpow_right₀ {a b : G₀} (h : commute a b) : ∀ m : ℤ, commute a (b^m) :=
h.zpow_right₀

theorem commute.zpow_left₀ {a b : G₀} (h : commute a b) (m : ℤ) : commute (a^m) b :=
(h.symm.zpow_right₀ m).symm

theorem commute.zpow_zpow₀ {a b : G₀} (h : commute a b) (m n : ℤ) : commute (a^m) (b^n) :=
(h.zpow_left₀ m).zpow_right₀ n

theorem commute.zpow_self₀ (a : G₀) (n : ℤ) : commute (a^n) a := (commute.refl a).zpow_left₀ n

theorem commute.self_zpow₀ (a : G₀) (n : ℤ) : commute a (a^n) := (commute.refl a).zpow_right₀ n

theorem commute.zpow_zpow_self₀ (a : G₀) (m n : ℤ) : commute (a^m) (a^n) :=
(commute.refl a).zpow_zpow₀ m n

theorem zpow_bit1₀ (a : G₀) (n : ℤ) : a ^ bit1 n = a ^ n * a ^ n * a :=
begin
  rw [← zpow_bit0, bit1, zpow_add', zpow_one],
  right, left,
  apply bit1_ne_zero
end

@[simp, norm_cast] lemma units.coe_zpow₀ (u : G₀ˣ) :
  ∀ (n : ℤ), ((u ^ n : G₀ˣ) : G₀) = u ^ n
| (n : ℕ) := by { rw [zpow_coe_nat, zpow_coe_nat], exact u.coe_pow n }
| -[1+k] := by rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat, units.coe_inv', u.coe_pow]

lemma zpow_ne_zero_of_ne_zero {a : G₀} (ha : a ≠ 0) : ∀ (z : ℤ), a ^ z ≠ 0
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_ne_zero _ ha }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_ne_zero (pow_ne_zero _ ha) }

lemma zpow_sub₀ {a : G₀} (ha : a ≠ 0) (z1 z2 : ℤ) : a ^ (z1 - z2) = a ^ z1 / a ^ z2 :=
by rw [sub_eq_add_neg, zpow_add₀ ha, zpow_neg, div_eq_mul_inv]

theorem zpow_bit1' (a : G₀) (n : ℤ) : a ^ bit1 n = (a * a) ^ n * a :=
by rw [zpow_bit1₀, (commute.refl a).mul_zpow]

lemma zpow_eq_zero {x : G₀} {n : ℤ} (h : x ^ n = 0) : x = 0 :=
classical.by_contradiction $ λ hx, zpow_ne_zero_of_ne_zero hx n h

lemma zpow_eq_zero_iff {a : G₀} {n : ℤ} (hn : 0 < n) :
  a ^ n = 0 ↔ a = 0 :=
begin
  refine ⟨zpow_eq_zero, _⟩,
  rintros rfl,
  exact zero_zpow _ hn.ne'
end

lemma zpow_ne_zero {x : G₀} (n : ℤ) : x ≠ 0 → x ^ n ≠ 0 :=
mt zpow_eq_zero

theorem zpow_neg_mul_zpow_self (n : ℤ) {x : G₀} (h : x ≠ 0) :
  x ^ (-n) * x ^ n = 1 :=
begin
  rw [zpow_neg],
  exact inv_mul_cancel (zpow_ne_zero n h)
end

end zpow

section
variables {G₀ : Type*} [comm_group_with_zero G₀]

lemma div_sq_cancel (a b : G₀) : a ^ 2 * b / a = a * b :=
begin
  by_cases ha : a = 0,
  { simp [ha] },
  rw [sq, mul_assoc, mul_div_cancel_left _ ha]
end

end

/-- If a monoid homomorphism `f` between two `group_with_zero`s maps `0` to `0`, then it maps `x^n`,
`n : ℤ`, to `(f x)^n`. -/
lemma monoid_with_zero_hom.map_zpow {G₀ G₀' : Type*} [group_with_zero G₀] [group_with_zero G₀']
  (f : G₀ →*₀ G₀') (x : G₀) :
  ∀ n : ℤ, f (x ^ n) = f x ^ n
| (n : ℕ) := by { rw [zpow_coe_nat, zpow_coe_nat], exact f.to_monoid_hom.map_pow x n }
| -[1+n] := begin
    rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat],
    exact ((f.map_inv _).trans $ congr_arg _ $ f.to_monoid_hom.map_pow x _)
  end

-- I haven't been able to find a better home for this:
-- it belongs with other lemmas on `linear_ordered_field`, but
-- we need to wait until `zpow` has been defined in this file.
section
variables {R : Type*} [linear_ordered_field R] {a : R}

lemma pow_minus_two_nonneg : 0 ≤ a^(-2 : ℤ) :=
begin
  simp only [inv_nonneg, zpow_neg],
  change 0 ≤ a ^ ((2 : ℕ) : ℤ),
  rw zpow_coe_nat,
  apply sq_nonneg,
end

end


<|start_filename|>test/linear_combination.lean<|end_filename|>
import tactic.linear_combination
import data.real.basic


/-! ### Simple Cases with ℤ and two or less equations -/

example (x y : ℤ) (h1 : 3*x + 2*y = 10):
  3*x + 2*y = 10 :=
by linear_combination 1*h1

example (x y : ℤ) (h1 : 3*x + 2*y = 10):
  3*x + 2*y = 10 :=
by linear_combination (h1)

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  2*x + 4 = -6 :=
by linear_combination 2*h1

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination 1*h1 - 2*h2

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination -2*h2 + h1

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  2*x + 4 - y = -16 :=
by linear_combination 2*h1 + -1*h2

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  -y + 2*x + 4 = -16 :=
by linear_combination -h2 + 2*h1

example (x y : ℤ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  11*y = -11 :=
by linear_combination -2*h1 + 3*h2

example (x y : ℤ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y = 11 :=
by linear_combination 2*h1 - 3*h2

example (x y : ℤ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y = 11 + 1 - 1 :=
by linear_combination 2*h1 + -3*h2

example (x y : ℤ) (h1 : 10 = 3*x + 2*y) (h2 : 3 = 2*x + 5*y) :
  11 + 1 - 1 = -11*y :=
by linear_combination 2*h1 - 3*h2


/-! ### More complicated cases with two equations -/

example (x y : ℤ) (h1 : x + 2 = -3) (h2 : y = 10) :
  -y + 2*x + 4 = -16 :=
by linear_combination 2*h1 - h2

example (x y : ℚ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y + 1 = 11 + 1 :=
by linear_combination 2*h1 - 3*h2

example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) :
  b = 2 / 3 :=
by linear_combination 1/6 * ha + 1/3 * hab


/-! ### Cases with more than 2 equations -/

example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) (hignore : 3 = a + b) :
  b = 2 / 3 :=
by linear_combination 1/6 * ha + 1/3 * hab + 0 * hignore

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  -3*x - 3*y - 4*z = 2 :=
by linear_combination ha - hb - 2*hc

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  6*x = -10 :=
by linear_combination 1*ha + 4*hb - 3*hc

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  10 = 6*-x :=
by linear_combination ha + 4*hb - 3*hc

example (w x y z : ℝ) (h1 : x + 2.1*y + 2*z = 2) (h2 : x + 8*z + 5*w = -6.5)
    (h3 : x + y + 5*z + 5*w = 3) :
  x + 2.2*y + 2*z - 5*w = -8.5 :=
by linear_combination 2*h1 + 1*h2 - 2*h3

example (w x y z : ℝ) (h1 : x + 2.1*y + 2*z = 2) (h2 : x + 8*z + 5*w = -6.5)
    (h3 : x + y + 5*z + 5*w = 3) :
  x + 2.2*y + 2*z - 5*w = -8.5 :=
by linear_combination 2*h1 + h2 - 2*h3

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c*3 = d) (h4 : -d = a) :
  2*a - 3 + 9*c + 3*d = 8 - b + 3*d - 3*a :=
by linear_combination 2*h1 -1*h2 +3*h3 -3*h4

example (a b c d : ℚ) (h1 : a = 4) (h2 : 3 = b) (h3 : c*3 = d) (h4 : -d = a) :
  6 - 3*c + 3*a + 3*d = 2*b - d + 12 - 3*a :=
by linear_combination 2*h2 -h3 +3*h1 -3*h4


/-! ### Cases with non-hypothesis inputs -/

constants (qc : ℚ) (hqc : qc = 2*qc)

example (a b : ℚ) (h : ∀ p q : ℚ, p = q) : 3*a + qc = 3*b + 2*qc :=
by linear_combination 3 * h a b + hqc

constant bad (q : ℚ) : q = 0

example (a b : ℚ) : a + b^3 = 0 :=
by linear_combination bad a + b * bad (b*b)

/-! ### Cases with arbitrary coefficients -/

example (a b : ℤ) (h : a = b) :
  a * a = a * b :=
by linear_combination a*h

example (a b c : ℤ) (h : a = b) :
  a * c = b * c :=
by linear_combination c*h

example (a b c : ℤ) (h1 : a = b) (h2 : b = 1) :
  c * a + b = c * b + 1 :=
by linear_combination c*h1 + h2

example (x y : ℚ) (h1 : x + y = 3) (h2 : 3*x = 7) :
  x*x*y + y*x*y + 6*x = 3*x*y + 14 :=
by linear_combination x*y*h1 + 2*h2

example {α} [h : comm_ring α] {a b c d e f : α} (h1 : a*d = b*c) (h2 : c*f = e*d) :
  c * (a*f - b*e) = 0 :=
by linear_combination e*h1 + a*h2

example (x y z w : ℚ) (hzw : z = w) : x*z + 2*y*z = x*w + 2*y*w :=
by linear_combination (x + 2*y)*hzw

/-! ### Cases that explicitly use a linear_combination_config -/

example (x y : ℚ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y + 1 = 11 + 1 :=
by linear_combination 2*h1 -3*h2 with {normalization_tactic := `[ring]}

example (x y : ℚ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  -11*y + 1 = 11 + 1 :=
by linear_combination 2*h1 + -3*h2 with {normalization_tactic := `[ring1]}

example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) :
  b = 2 / 3 :=
by linear_combination 1/6*ha + 1/3*hab with {normalization_tactic := `[ring_nf]}

example (x y : ℤ) (h1 : 3*x + 2*y = 10):
  3*x + 2*y = 10 :=
by linear_combination h1 with {normalization_tactic := `[simp]}


/-! ### Cases that have linear_combination skip normalization -/


example (a b : ℝ) (ha : 2*a = 4) (hab : 2*b = a - b) :
  b = 2 / 3 :=
begin
  linear_combination 1/6*ha + 1/3*hab with {normalize := ff},
  linarith
end

example (x y : ℤ) (h1 : x = -3) (h2 : y = 10) :
  2*x = -6 :=
begin
  linear_combination 2*h1 with {normalize := ff},
  simp,
  norm_cast
end


/-! ### Cases without any arguments provided -/

-- the corner case is "just apply the normalization procedure".
-- an empty `linear_combination` at the end of a declaration is a bad edge case for the parser.
example {x y z w : ℤ} (h₁ : 3 * x = 4 + y) (h₂ : x + 2 * y = 1) : z + w = w + z :=
by linear_combination

.

-- this interacts as expected with options
example {x y z w : ℤ} (h₁ : 3 * x = 4 + y) (h₂ : x + 2 * y = 1) : z + w = w + z :=
begin
  linear_combination with {normalize := ff},
  guard_target' z + w - (w + z) = 0 - 0,
  simp [add_comm]
end

example {x y z w : ℤ} (h₁ : 3 * x = 4 + y) (h₂ : x + 2 * y = 1) : z + w = w + z :=
by linear_combination with {normalization_tactic := `[simp [add_comm]]}

/-! ### Cases that should fail -/

-- This should fail because there are no hypotheses given
example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
begin
  success_if_fail {linear_combination},
  linear_combination h1 - 2 * h2,
end

-- This should fail because the second coefficient has a different type than
--   the equations it is being combined with.  This was a design choice for the
--   sake of simplicity, but the tactic could potentially be modified to allow
--   this behavior.
example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y + 2*x = 1 :=
begin
  success_if_fail_with_msg {linear_combination h1 + (0 : ℝ) * h2}
    "invalid type ascription, term has type
  ℝ
but is expected to have type
  ℤ",
  linear_combination h1
end

-- This should fail because the second coefficient has a different type than
--   the equations it is being combined with.  This was a design choice for the
--   sake of simplicity, but the tactic could potentially be modified to allow
--   this behavior.
example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y + 2*x = 1 :=
begin
  success_if_fail {linear_combination h1 + (0 : ℕ)  * h2},
  linear_combination h1
end

-- This should fail because the coefficients are incorrect.  They should instead
--   be -2 and 3, respectively.
example (x y : ℤ) (h1 : 3*x + 2*y = 10) (h2 : 2*x + 5*y = 3) :
  11*y = -11 :=
begin
  success_if_fail {linear_combination 2*h1 - 3*h2},
  linear_combination -2*h1 + 3*h2
end

-- This fails because the linear_combination tactic requires the equations
--   and coefficients to use a type that fulfills the add_group condition,
--   and ℕ does not.
example (a b : ℕ) (h1 : a = 3) :
  a = 3 :=
begin
  success_if_fail {linear_combination h1},
  exact h1
end

example (a b : ℤ) (x y : ℝ) (hab : a = b) (hxy : x = y) : 2*x = 2*y :=
begin
  success_if_fail_with_msg {linear_combination 2*hab}
    "hab is an equality between terms of type ℤ, but is expected to be between terms of type ℝ",
  linear_combination 2*hxy
end


<|start_filename|>src/model_theory/finitely_generated.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import model_theory.substructures

/-!
# Finitely Generated First-Order Structures
This file defines what it means for a first-order (sub)structure to be finitely or countably
generated, similarly to other finitely-generated objects in the algebra library.

## Main Definitions
* `first_order.language.substructure.fg` indicates that a substructure is finitely generated.
* `first_order.language.Structure.fg` indicates that a structure is finitely generated.
* `first_order.language.substructure.cg` indicates that a substructure is countably generated.
* `first_order.language.Structure.cg` indicates that a structure is countably generated.


## TODO
Develop a more unified definition of finite generation using the theory of closure operators, or use
this definition of finite generation to define the others.

-/

open_locale first_order
open set

namespace first_order
namespace language
open Structure

variables {L : language} {M : Type*} [L.Structure M]

namespace substructure

/-- A substructure of `M` is finitely generated if it is the closure of a finite subset of `M`. -/
def fg (N : L.substructure M) : Prop := ∃ S : finset M, closure L ↑S = N

theorem fg_def {N : L.substructure M} :
  N.fg ↔ ∃ S : set M, S.finite ∧ closure L S = N :=
⟨λ ⟨t, h⟩, ⟨_, finset.finite_to_set t, h⟩, begin
  rintro ⟨t', h, rfl⟩,
  rcases finite.exists_finset_coe h with ⟨t, rfl⟩,
  exact ⟨t, rfl⟩
end⟩

lemma fg_iff_exists_fin_generating_family {N : L.substructure M} :
  N.fg ↔ ∃ (n : ℕ) (s : fin n → M), closure L (range s) = N :=
begin
  rw fg_def,
  split,
  { rintros ⟨S, Sfin, hS⟩,
    obtain ⟨n, f, rfl⟩ := Sfin.fin_embedding,
    exact ⟨n, f, hS⟩, },
  { rintros ⟨n, s, hs⟩,
    refine ⟨range s, finite_range s, hs⟩ },
end

theorem fg_bot : (⊥ : L.substructure M).fg :=
⟨∅, by rw [finset.coe_empty, closure_empty]⟩

theorem fg_closure {s : set M} (hs : s.finite) : fg (closure L s) :=
⟨hs.to_finset, by rw [hs.coe_to_finset]⟩

theorem fg_closure_singleton (x : M) : fg (closure L ({x} : set M)) :=
fg_closure (finite_singleton x)

theorem fg.sup {N₁ N₂ : L.substructure M}
  (hN₁ : N₁.fg) (hN₂ : N₂.fg) : (N₁ ⊔ N₂).fg :=
let ⟨t₁, ht₁⟩ := fg_def.1 hN₁, ⟨t₂, ht₂⟩ := fg_def.1 hN₂ in
fg_def.2 ⟨t₁ ∪ t₂, ht₁.1.union ht₂.1, by rw [closure_union, ht₁.2, ht₂.2]⟩

theorem fg.map {N : Type*} [L.Structure N] (f : M →[L] N) {s : L.substructure M} (hs : s.fg) :
  (s.map f).fg :=
let ⟨t, ht⟩ := fg_def.1 hs in fg_def.2 ⟨f '' t, ht.1.image _, by rw [closure_image, ht.2]⟩

theorem fg.of_map_embedding {N : Type*} [L.Structure N] (f : M ↪[L] N) {s : L.substructure M}
  (hs : (s.map f.to_hom).fg) : s.fg :=
begin
  rcases hs with ⟨t, h⟩,
  rw fg_def,
  refine ⟨f ⁻¹' t, t.finite_to_set.preimage (f.injective.inj_on _), _⟩,
  have hf : function.injective f.to_hom := f.injective,
  refine map_injective_of_injective hf _,
  rw [← h, map_closure, embedding.coe_to_hom, image_preimage_eq_of_subset],
  intros x hx,
  have h' := subset_closure hx,
  rw h at h',
  exact hom.map_le_range h'
end

/-- A substructure of `M` is countably generated if it is the closure of a countable subset of `M`.
-/
def cg (N : L.substructure M) : Prop := ∃ S : set M, S.countable ∧ closure L S = N

theorem cg_def {N : L.substructure M} :
  N.cg ↔ ∃ S : set M, S.countable ∧ closure L S = N := iff.refl _

theorem fg.cg {N : L.substructure M} (h : N.fg) : N.cg :=
begin
  obtain ⟨s, hf, rfl⟩ := fg_def.1 h,
  refine ⟨s, hf.countable, rfl⟩,
end

lemma cg_iff_empty_or_exists_nat_generating_family {N : L.substructure M} :
  N.cg ↔ (↑N = (∅ : set M)) ∨ ∃ (s : ℕ → M), closure L (range s) = N :=
begin
  rw cg_def,
  split,
  { rintros ⟨S, Scount, hS⟩,
    cases eq_empty_or_nonempty ↑N with h h,
    { exact or.intro_left _ h },
    obtain ⟨f, h'⟩ := (Scount.union (set.countable_singleton h.some)).exists_surjective
      (singleton_nonempty h.some).inr,
    refine or.intro_right _ ⟨f, _⟩,
    rw [← h', closure_union, hS, sup_eq_left, closure_le],
    exact singleton_subset_iff.2 h.some_mem },
  { intro h,
    cases h with h h,
    { refine ⟨∅, countable_empty, closure_eq_of_le (empty_subset _) _⟩,
      rw [← set_like.coe_subset_coe, h],
      exact empty_subset _ },
    { obtain ⟨f, rfl⟩ := h,
      exact ⟨range f, countable_range _, rfl⟩ } },
end

theorem cg_bot : (⊥ : L.substructure M).cg := fg_bot.cg

theorem cg_closure {s : set M} (hs : s.countable) : cg (closure L s) :=
⟨s, hs, rfl⟩

theorem cg_closure_singleton (x : M) : cg (closure L ({x} : set M)) := (fg_closure_singleton x).cg

theorem cg.sup {N₁ N₂ : L.substructure M}
  (hN₁ : N₁.cg) (hN₂ : N₂.cg) : (N₁ ⊔ N₂).cg :=
let ⟨t₁, ht₁⟩ := cg_def.1 hN₁, ⟨t₂, ht₂⟩ := cg_def.1 hN₂ in
cg_def.2 ⟨t₁ ∪ t₂, ht₁.1.union ht₂.1, by rw [closure_union, ht₁.2, ht₂.2]⟩

theorem cg.map {N : Type*} [L.Structure N] (f : M →[L] N) {s : L.substructure M} (hs : s.cg) :
  (s.map f).cg :=
let ⟨t, ht⟩ := cg_def.1 hs in cg_def.2 ⟨f '' t, ht.1.image _, by rw [closure_image, ht.2]⟩

theorem cg.of_map_embedding {N : Type*} [L.Structure N] (f : M ↪[L] N) {s : L.substructure M}
  (hs : (s.map f.to_hom).cg) : s.cg :=
begin
  rcases hs with ⟨t, h1, h2⟩,
  rw cg_def,
  refine ⟨f ⁻¹' t, h1.preimage f.injective, _⟩,
  have hf : function.injective f.to_hom := f.injective,
  refine map_injective_of_injective hf _,
  rw [← h2, map_closure, embedding.coe_to_hom, image_preimage_eq_of_subset],
  intros x hx,
  have h' := subset_closure hx,
  rw h2 at h',
  exact hom.map_le_range h'
end

theorem cg_iff_countable [L.countable_functions] {s : L.substructure M} :
  s.cg ↔ nonempty (encodable s) :=
begin
  refine ⟨_, λ h, ⟨s, h, s.closure_eq⟩⟩,
  rintro ⟨s, h, rfl⟩,
  exact h.substructure_closure L
end

end substructure

open substructure

namespace Structure

variables (L) (M)

/-- A structure is finitely generated if it is the closure of a finite subset. -/
class fg : Prop := (out : (⊤ : L.substructure M).fg)

/-- A structure is countably generated if it is the closure of a countable subset. -/
class cg : Prop := (out : (⊤ : L.substructure M).cg)

variables {L M}

lemma fg_def : fg L M ↔ (⊤ : L.substructure M).fg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

/-- An equivalent expression of `Structure.fg` in terms of `set.finite` instead of `finset`. -/
lemma fg_iff : fg L M ↔ ∃ S : set M, S.finite ∧ closure L S = (⊤ : L.substructure M) :=
by rw [fg_def, substructure.fg_def]

lemma fg.range {N : Type*} [L.Structure N] (h : fg L M) (f : M →[L] N) :
  f.range.fg :=
begin
  rw [hom.range_eq_map],
  exact (fg_def.1 h).map f,
end

lemma fg.map_of_surjective {N : Type*} [L.Structure N] (h : fg L M) (f : M →[L] N)
  (hs : function.surjective f) :
  fg L N :=
begin
  rw ← hom.range_eq_top at hs,
  rw [fg_def, ← hs],
  exact h.range f,
end

lemma cg_def : cg L M ↔ (⊤ : L.substructure M).cg := ⟨λ h, h.1, λ h, ⟨h⟩⟩

/-- An equivalent expression of `Structure.cg`. -/
lemma cg_iff : cg L M ↔ ∃ S : set M, S.countable ∧ closure L S = (⊤ : L.substructure M) :=
by rw [cg_def, substructure.cg_def]

lemma cg.range {N : Type*} [L.Structure N] (h : cg L M) (f : M →[L] N) :
  f.range.cg :=
begin
  rw [hom.range_eq_map],
  exact (cg_def.1 h).map f,
end

lemma cg.map_of_surjective {N : Type*} [L.Structure N] (h : cg L M) (f : M →[L] N)
  (hs : function.surjective f) :
  cg L N :=
begin
  rw ← hom.range_eq_top at hs,
  rw [cg_def, ← hs],
  exact h.range f,
end

lemma cg_iff_countable [L.countable_functions] :
  cg L M ↔ nonempty (encodable M) :=
by rw [cg_def, cg_iff_countable, cardinal.encodable_iff, cardinal.encodable_iff,
  top_equiv.to_equiv.cardinal_eq]

lemma fg.cg (h : fg L M) : cg L M :=
cg_def.2 (fg_def.1 h).cg

@[priority 100] instance cg_of_fg [h : fg L M] : cg L M := h.cg

end Structure

lemma equiv.fg_iff {N : Type*} [L.Structure N] (f : M ≃[L] N) :
  Structure.fg L M ↔ Structure.fg L N :=
⟨λ h, h.map_of_surjective f.to_hom f.to_equiv.surjective,
  λ h, h.map_of_surjective f.symm.to_hom f.to_equiv.symm.surjective⟩

lemma substructure.fg_iff_Structure_fg (S : L.substructure M) :
  S.fg ↔ Structure.fg L S :=
begin
  rw Structure.fg_def,
  refine ⟨λ h, fg.of_map_embedding S.subtype _, λ h, _⟩,
  { rw [← hom.range_eq_map, range_subtype],
    exact h },
  { have h := h.map S.subtype.to_hom,
    rw [← hom.range_eq_map, range_subtype] at h,
    exact h }
end

lemma equiv.cg_iff {N : Type*} [L.Structure N] (f : M ≃[L] N) :
  Structure.cg L M ↔ Structure.cg L N :=
⟨λ h, h.map_of_surjective f.to_hom f.to_equiv.surjective,
  λ h, h.map_of_surjective f.symm.to_hom f.to_equiv.symm.surjective⟩

lemma substructure.cg_iff_Structure_cg (S : L.substructure M) :
  S.cg ↔ Structure.cg L S :=
begin
  rw Structure.cg_def,
  refine ⟨λ h, cg.of_map_embedding S.subtype _, λ h, _⟩,
  { rw [← hom.range_eq_map, range_subtype],
    exact h },
  { have h := h.map S.subtype.to_hom,
    rw [← hom.range_eq_map, range_subtype] at h,
    exact h }
end

end language
end first_order


<|start_filename|>src/algebra/lie/centralizer.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.lie.abelian
import algebra.lie.ideal_operations
import algebra.lie.quotient

/-!
# The centralizer of a Lie submodule and the normalizer of a Lie subalgebra.

Given a Lie module `M` over a Lie subalgebra `L`, the centralizer of a Lie submodule `N ⊆ M` is
the Lie submodule with underlying set `{ m | ∀ (x : L), ⁅x, m⁆ ∈ N }`.

The lattice of Lie submodules thus has two natural operations, the centralizer: `N ↦ N.centralizer`
and the ideal operation: `N ↦ ⁅⊤, N⁆`; these are adjoint, i.e., they form a Galois connection. This
adjointness is the reason that we may define nilpotency in terms of either the upper or lower
central series.

Given a Lie subalgebra `H ⊆ L`, we may regard `H` as a Lie submodule of `L` over `H`, and thus
consider the centralizer. This turns out to be a Lie subalgebra and is known as the normalizer.

## Main definitions

  * `lie_submodule.centralizer`
  * `lie_subalgebra.normalizer`
  * `lie_submodule.gc_top_lie_centralizer`

## Tags

lie algebra, centralizer, normalizer
-/

variables {R L M M' : Type*}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group M'] [module R M'] [lie_ring_module L M'] [lie_module R L M']

namespace lie_submodule

variables (N : lie_submodule R L M) {N₁ N₂ : lie_submodule R L M}

/-- The centralizer of a Lie submodule. -/
def centralizer : lie_submodule R L M :=
{ carrier   := { m | ∀ (x : L), ⁅x, m⁆ ∈ N },
  add_mem'  := λ m₁ m₂ hm₁ hm₂ x, by {  rw lie_add, exact N.add_mem' (hm₁ x) (hm₂ x), },
  zero_mem' := λ x, by simp,
  smul_mem' := λ t m hm x, by { rw lie_smul, exact N.smul_mem' t (hm x), },
  lie_mem   := λ x m hm y, by { rw leibniz_lie, exact N.add_mem' (hm ⁅y, x⁆) (N.lie_mem (hm y)), } }

@[simp] lemma mem_centralizer (m : M) :
  m ∈ N.centralizer ↔ ∀ (x : L), ⁅x, m⁆ ∈ N :=
iff.rfl

lemma le_centralizer : N ≤ N.centralizer :=
begin
  intros m hm,
  rw mem_centralizer,
  exact λ x, N.lie_mem hm,
end

lemma centralizer_inf :
  (N₁ ⊓ N₂).centralizer = N₁.centralizer ⊓ N₂.centralizer :=
by { ext, simp [← forall_and_distrib], }

@[mono] lemma monotone_centalizer :
  monotone (centralizer : lie_submodule R L M → lie_submodule R L M) :=
begin
  intros N₁ N₂ h m hm,
  rw mem_centralizer at hm ⊢,
  exact λ x, h (hm x),
end

@[simp] lemma comap_centralizer (f : M' →ₗ⁅R,L⁆ M) :
  N.centralizer.comap f = (N.comap f).centralizer :=
by { ext, simp, }

lemma top_lie_le_iff_le_centralizer (N' : lie_submodule R L M) :
  ⁅(⊤ : lie_ideal R L), N⁆ ≤ N' ↔ N ≤ N'.centralizer :=
by { rw lie_le_iff, tauto, }

lemma gc_top_lie_centralizer :
  galois_connection (λ N : lie_submodule R L M, ⁅(⊤ : lie_ideal R L), N⁆) centralizer :=
top_lie_le_iff_le_centralizer

variables (R L M)

lemma centralizer_bot_eq_max_triv_submodule :
  (⊥ : lie_submodule R L M).centralizer = lie_module.max_triv_submodule R L M :=
rfl

end lie_submodule

namespace lie_subalgebra

variables (H : lie_subalgebra R L)

/-- Regarding a Lie subalgebra `H ⊆ L` as a module over itself, its centralizer is in fact a Lie
subalgebra. This is called the normalizer of the Lie subalgebra. -/
def normalizer : lie_subalgebra R L :=
{ lie_mem' := λ y z hy hz x,
  begin
    rw [coe_bracket_of_module, mem_to_lie_submodule, leibniz_lie, ← lie_skew y, ← sub_eq_add_neg],
    exact H.sub_mem (hz ⟨_, hy x⟩) (hy ⟨_, hz x⟩),
  end,
  .. H.to_lie_submodule.centralizer }

lemma mem_normalizer_iff' (x : L) : x ∈ H.normalizer ↔ ∀ (y : L), (y ∈ H) → ⁅y, x⁆ ∈ H :=
by { rw subtype.forall', refl, }

lemma mem_normalizer_iff (x : L) : x ∈ H.normalizer ↔ ∀ (y : L), (y ∈ H) → ⁅x, y⁆ ∈ H :=
begin
  rw mem_normalizer_iff',
  refine forall₂_congr (λ y hy, _),
  rw [← lie_skew, neg_mem_iff],
end

lemma le_normalizer : H ≤ H.normalizer := H.to_lie_submodule.le_centralizer

lemma coe_centralizer_eq_normalizer :
  (H.to_lie_submodule.centralizer : submodule R L) = H.normalizer :=
rfl

variables {H}

lemma lie_mem_sup_of_mem_normalizer {x y z : L} (hx : x ∈ H.normalizer)
  (hy : y ∈ (R ∙ x) ⊔ ↑H) (hz : z ∈ (R ∙ x) ⊔ ↑H) : ⁅y, z⁆ ∈ (R ∙ x) ⊔ ↑H :=
begin
  rw submodule.mem_sup at hy hz,
  obtain ⟨u₁, hu₁, v, hv : v ∈ H, rfl⟩ := hy,
  obtain ⟨u₂, hu₂, w, hw : w ∈ H, rfl⟩ := hz,
  obtain ⟨t, rfl⟩ := submodule.mem_span_singleton.mp hu₁,
  obtain ⟨s, rfl⟩ := submodule.mem_span_singleton.mp hu₂,
  apply submodule.mem_sup_right,
  simp only [lie_subalgebra.mem_coe_submodule, smul_lie, add_lie, zero_add, lie_add, smul_zero,
    lie_smul, lie_self],
  refine H.add_mem (H.smul_mem s _) (H.add_mem (H.smul_mem t _) (H.lie_mem hv hw)),
  exacts [(H.mem_normalizer_iff' x).mp hx v hv, (H.mem_normalizer_iff x).mp hx w hw],
end

/-- A Lie subalgebra is an ideal of its normalizer. -/
lemma ideal_in_normalizer {x y : L} (hx : x ∈ H.normalizer) (hy : y ∈ H) : ⁅x,y⁆ ∈ H :=
begin
  rw [← lie_skew, neg_mem_iff],
  exact hx ⟨y, hy⟩,
end

/-- A Lie subalgebra `H` is an ideal of any Lie subalgebra `K` containing `H` and contained in the
normalizer of `H`. -/
lemma exists_nested_lie_ideal_of_le_normalizer
  {K : lie_subalgebra R L} (h₁ : H ≤ K) (h₂ : K ≤ H.normalizer) :
  ∃ (I : lie_ideal R K), (I : lie_subalgebra R K) = of_le h₁ :=
begin
  rw exists_nested_lie_ideal_coe_eq_iff,
  exact λ x y hx hy, ideal_in_normalizer (h₂ hx) hy,
end

variables (H)

lemma normalizer_eq_self_iff :
  H.normalizer = H ↔ (lie_module.max_triv_submodule R H $ L ⧸ H.to_lie_submodule) = ⊥ :=
begin
  rw lie_submodule.eq_bot_iff,
  refine ⟨λ h, _, λ h, le_antisymm (λ x hx, _) H.le_normalizer⟩,
  { rintros ⟨x⟩ hx,
    suffices : x ∈ H, by simpa,
    rw [← h, H.mem_normalizer_iff'],
    intros y hy,
    replace hx : ⁅_, lie_submodule.quotient.mk' _ x⁆ = 0 := hx ⟨y, hy⟩,
    rwa [← lie_module_hom.map_lie, lie_submodule.quotient.mk_eq_zero] at hx, },
  { let y := lie_submodule.quotient.mk' H.to_lie_submodule x,
    have hy : y ∈ lie_module.max_triv_submodule R H (L ⧸ H.to_lie_submodule),
    { rintros ⟨z, hz⟩,
      rw [← lie_module_hom.map_lie, lie_submodule.quotient.mk_eq_zero, coe_bracket_of_module,
        submodule.coe_mk, mem_to_lie_submodule],
      exact (H.mem_normalizer_iff' x).mp hx z hz, },
    simpa using h y hy, },
end

end lie_subalgebra


<|start_filename|>src/analysis/complex/upper_half_plane.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME> and <NAME> and <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/

import linear_algebra.special_linear_group
import analysis.complex.basic
import group_theory.group_action.defs
import linear_algebra.general_linear_group


/-!
# The upper half plane and its automorphisms

This file defines `upper_half_plane` to be the upper half plane in `ℂ`.

We furthermore equip it with the structure of an `GL_pos 2 ℝ` action by
fractional linear transformations.

We define the notation `ℍ` for the upper half plane available in the locale
`upper_half_plane` so as not to conflict with the quaternions.
-/

noncomputable theory

open matrix matrix.special_linear_group

open_locale classical big_operators matrix_groups

local attribute [instance] fintype.card_fin_even

/- Disable this instances as it is not the simp-normal form, and having them disabled ensures
we state lemmas in this file without spurious `coe_fn` terms. -/
local attribute [-instance] matrix.special_linear_group.has_coe_to_fun

local prefix `↑ₘ`:1024 := @coe _ (matrix (fin 2) (fin 2) _) _

local notation `GL(` n `, ` R `)`⁺ := matrix.GL_pos (fin n) R

/-- The open upper half plane -/
@[derive [topological_space, λ α, has_coe α ℂ]]
def upper_half_plane := {point : ℂ // 0 < point.im}

localized "notation `ℍ` := upper_half_plane" in upper_half_plane

namespace upper_half_plane

instance : inhabited ℍ := ⟨⟨complex.I, by simp⟩⟩

/-- Imaginary part -/
def im (z : ℍ) := (z : ℂ).im

/-- Real part -/
def re (z : ℍ) := (z : ℂ).re

@[simp] lemma coe_im (z : ℍ) : (z : ℂ).im = z.im := rfl

@[simp] lemma coe_re (z : ℍ) : (z : ℂ).re = z.re := rfl

lemma im_pos (z : ℍ) : 0 < z.im := z.2

lemma im_ne_zero (z : ℍ) : z.im ≠ 0 := z.im_pos.ne'

lemma ne_zero (z : ℍ) : (z : ℂ) ≠ 0 :=
mt (congr_arg complex.im) z.im_ne_zero

lemma norm_sq_pos (z : ℍ) : 0 < complex.norm_sq (z : ℂ) :=
by { rw complex.norm_sq_pos, exact z.ne_zero }

lemma norm_sq_ne_zero (z : ℍ) : complex.norm_sq (z : ℂ) ≠ 0 := (norm_sq_pos z).ne'

/-- Numerator of the formula for a fractional linear transformation -/
@[simp] def num (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ := (↑ₘg 0 0 : ℝ) * z + (↑ₘg 0 1 : ℝ)

/-- Denominator of the formula for a fractional linear transformation -/
@[simp] def denom (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ := (↑ₘg 1 0 : ℝ) * z + (↑ₘg 1 1 : ℝ)

lemma linear_ne_zero (cd : fin 2 → ℝ) (z : ℍ) (h : cd ≠ 0) : (cd 0 : ℂ) * z + cd 1 ≠ 0 :=
begin
  contrapose! h,
  have : cd 0 = 0, -- we will need this twice
  { apply_fun complex.im at h,
    simpa only [z.im_ne_zero, complex.add_im, add_zero, coe_im, zero_mul, or_false,
      complex.of_real_im, complex.zero_im, complex.mul_im, mul_eq_zero] using h, },
  simp only [this, zero_mul, complex.of_real_zero, zero_add, complex.of_real_eq_zero] at h,
  ext i,
  fin_cases i; assumption,
end

lemma denom_ne_zero (g : GL(2, ℝ)⁺) (z : ℍ) : denom g z ≠ 0 :=
begin
  intro H,
  have DET := (mem_GL_pos _).1 g.prop,
  have hz := z.prop,
  simp only [general_linear_group.coe_det_apply] at DET,
  have H1 : (↑ₘg 1 0 : ℝ) = 0 ∨ z.im = 0, by simpa using congr_arg complex.im H,
  cases H1,
  { simp only [H1, complex.of_real_zero, denom, coe_fn_eq_coe, zero_mul, zero_add,
    complex.of_real_eq_zero] at H,
    rw [←coe_coe, (matrix.det_fin_two (↑g : matrix (fin 2) (fin 2) ℝ))] at DET,
    simp only [coe_coe,H, H1, mul_zero, sub_zero, lt_self_iff_false] at DET,
    exact DET, },
  { change z.im > 0 at hz,
    linarith, }
end

lemma norm_sq_denom_pos (g : GL(2, ℝ)⁺) (z : ℍ) : 0 < complex.norm_sq (denom g z) :=
complex.norm_sq_pos.mpr (denom_ne_zero g z)

lemma norm_sq_denom_ne_zero (g : GL(2, ℝ)⁺) (z : ℍ) : complex.norm_sq (denom g z) ≠ 0 :=
ne_of_gt (norm_sq_denom_pos g z)

/-- Fractional linear transformation, also known as the Moebius transformation -/
def smul_aux' (g : GL(2, ℝ)⁺) (z : ℍ) : ℂ := num g z / denom g z

lemma smul_aux'_im (g : GL(2, ℝ)⁺) (z : ℍ) :
  (smul_aux' g z).im = ((det ↑ₘg) * z.im) / (denom g z).norm_sq :=
begin
  rw [smul_aux', complex.div_im],
  set NsqBot := (denom g z).norm_sq,
  have : NsqBot ≠ 0,
  { simp only [denom_ne_zero g z, monoid_with_zero_hom.map_eq_zero, ne.def, not_false_iff], },
  field_simp [smul_aux', -coe_coe],
  rw (matrix.det_fin_two (↑ₘg)),
  ring,
end

/-- Fractional linear transformation, also known as the Moebius transformation -/
def smul_aux (g : GL(2, ℝ)⁺) (z : ℍ) : ℍ :=
 ⟨smul_aux' g z, begin
  rw smul_aux'_im,
  convert (mul_pos ((mem_GL_pos _).1 g.prop)
    (div_pos z.im_pos (complex.norm_sq_pos.mpr (denom_ne_zero g z)))),
  simp only [general_linear_group.coe_det_apply, coe_coe],
  ring
end⟩

lemma denom_cocycle (x y : GL(2, ℝ)⁺) (z : ℍ) :
  denom (x * y) z = denom x (smul_aux y z) * denom y z :=
begin
  change _ = (_ * (_ / _) + _) * _,
  field_simp [denom_ne_zero, -denom, -num],
  simp only [matrix.mul, dot_product, fin.sum_univ_succ, denom, num, coe_coe, subgroup.coe_mul,
    general_linear_group.coe_mul, fintype.univ_of_subsingleton, fin.mk_eq_subtype_mk, fin.mk_zero,
    finset.sum_singleton, fin.succ_zero_eq_one, complex.of_real_add, complex.of_real_mul],
  ring
end

lemma mul_smul' (x y : GL(2, ℝ)⁺) (z : ℍ) :
  smul_aux (x * y) z = smul_aux x (smul_aux y z) :=
begin
  ext1,
  change _ / _ = (_ * (_ / _) + _) * _,
  rw denom_cocycle,
  field_simp [denom_ne_zero, -denom, -num],
  simp only [matrix.mul, dot_product, fin.sum_univ_succ, num, denom, coe_coe, subgroup.coe_mul,
    general_linear_group.coe_mul, fintype.univ_of_subsingleton, fin.mk_eq_subtype_mk, fin.mk_zero,
    finset.sum_singleton, fin.succ_zero_eq_one, complex.of_real_add, complex.of_real_mul],
  ring
end

/-- The action of ` GL_pos 2 ℝ` on the upper half-plane by fractional linear transformations. -/
instance : mul_action (GL(2, ℝ)⁺) ℍ :=
{ smul := smul_aux,
  one_smul := λ z, by { ext1, change _ / _ = _,
   simp [coe_fn_coe_base'] },
  mul_smul := mul_smul' }

section modular_scalar_towers

variable (Γ : subgroup (special_linear_group (fin 2) ℤ))

instance SL_action {R : Type*} [comm_ring R] [algebra R ℝ] : mul_action SL(2, R) ℍ :=
mul_action.comp_hom ℍ $ (special_linear_group.to_GL_pos).comp $ map (algebra_map R ℝ)

instance : has_coe SL(2,ℤ) (GL(2, ℝ)⁺) := ⟨λ g , ((g : SL(2, ℝ)) : (GL(2, ℝ)⁺))⟩

instance SL_on_GL_pos : has_scalar SL(2,ℤ) (GL(2, ℝ)⁺) := ⟨λ s g, s * g⟩

lemma SL_on_GL_pos_smul_apply (s : SL(2,ℤ)) (g : (GL(2, ℝ)⁺)) (z : ℍ) :
  (s • g) • z = ( (s : GL(2, ℝ)⁺) * g) • z := rfl

instance SL_to_GL_tower : is_scalar_tower SL(2,ℤ) (GL(2, ℝ)⁺) ℍ :=
{ smul_assoc := by {intros s g z, simp only [SL_on_GL_pos_smul_apply, coe_coe], apply mul_smul',},}

instance subgroup_GL_pos : has_scalar Γ (GL(2, ℝ)⁺) := ⟨λ s g, s * g⟩

lemma subgroup_on_GL_pos_smul_apply (s : Γ) (g : (GL(2, ℝ)⁺)) (z : ℍ) :
  (s • g) • z = ( (s : GL(2, ℝ)⁺) * g) • z := rfl

instance subgroup_on_GL_pos : is_scalar_tower Γ (GL(2, ℝ)⁺) ℍ :=
{ smul_assoc :=
  by {intros s g z, simp only [subgroup_on_GL_pos_smul_apply, coe_coe], apply mul_smul',},}

instance subgroup_SL : has_scalar Γ SL(2,ℤ) := ⟨λ s g, s * g⟩

lemma subgroup_on_SL_apply (s : Γ) (g : SL(2,ℤ) ) (z : ℍ) :
  (s • g) • z = ( (s : SL(2, ℤ)) * g) • z := rfl

instance subgroup_to_SL_tower : is_scalar_tower Γ SL(2,ℤ) ℍ :=
{ smul_assoc := λ s g z, by { rw subgroup_on_SL_apply, apply mul_action.mul_smul } }

end modular_scalar_towers

@[simp] lemma coe_smul (g : GL(2, ℝ)⁺) (z : ℍ) : ↑(g • z) = num g z / denom g z := rfl
@[simp] lemma re_smul (g : GL(2, ℝ)⁺) (z : ℍ) : (g • z).re = (num g z / denom g z).re := rfl
lemma im_smul (g : GL(2, ℝ)⁺) (z : ℍ) : (g • z).im = (num g z / denom g z).im := rfl

lemma im_smul_eq_div_norm_sq (g : GL(2, ℝ)⁺) (z : ℍ) :
  (g • z).im = (det ↑ₘg * z.im) / (complex.norm_sq (denom g z)) := smul_aux'_im g z

@[simp] lemma neg_smul (g : GL(2, ℝ)⁺) (z : ℍ) : -g • z = g • z :=
begin
  ext1,
  change _ / _ = _ / _,
  field_simp [denom_ne_zero, -denom, -num],
  simp only [num, denom, coe_coe, complex.of_real_neg, neg_mul, GL_pos.coe_neg_GL, units.coe_neg,
    pi.neg_apply],
  ring_nf,
end

section SL_modular_action

variables (g : SL(2, ℤ)) (z : ℍ) (Γ : subgroup SL(2,ℤ))

@[simp] lemma sl_moeb (A : SL(2,ℤ)) (z : ℍ) : A • z = (A : (GL(2, ℝ)⁺)) • z := rfl
lemma subgroup_moeb (A : Γ) (z : ℍ) : A • z = (A : (GL(2, ℝ)⁺)) • z := rfl
@[simp] lemma subgroup_to_sl_moeb (A : Γ) (z : ℍ) : A • z = (A : SL(2,ℤ)) • z := rfl

@[simp] lemma SL_neg_smul (g : SL(2,ℤ)) (z : ℍ) : -g • z = g • z :=
begin
simp only [coe_GL_pos_neg, sl_moeb, coe_coe, coe_int_neg, neg_smul],
end

lemma c_mul_im_sq_le_norm_sq_denom (z : ℍ) (g : SL(2, ℝ)) :
  ((↑ₘg 1 0 : ℝ) * (z.im))^2 ≤ complex.norm_sq (denom g z) :=
begin
  let c := (↑ₘg 1 0 : ℝ),
  let d := (↑ₘg 1 1 : ℝ),
  calc (c * z.im)^2 ≤ (c * z.im)^2 + (c * z.re + d)^2 : by nlinarith
                ... = complex.norm_sq (denom g z) : by simp [complex.norm_sq]; ring,
end

lemma special_linear_group.im_smul_eq_div_norm_sq :
  (g • z).im = z.im / (complex.norm_sq (denom g z)) :=
begin
  convert (im_smul_eq_div_norm_sq g z),
  simp only [coe_coe, general_linear_group.coe_det_apply,coe_GL_pos_coe_GL_coe_matrix,
    int.coe_cast_ring_hom,(g : SL(2,ℝ)).prop, one_mul],
end

lemma denom_apply (g : SL(2, ℤ)) (z : ℍ) : denom g z = (↑g : matrix (fin 2) (fin 2) ℤ) 1 0 * z +
  (↑g : matrix (fin 2) (fin 2) ℤ) 1 1 := by simp

end SL_modular_action

end upper_half_plane


<|start_filename|>src/data/finsupp/multiset.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.finsupp.order

/-!
# Equivalence between `multiset` and `ℕ`-valued finitely supported functions

This defines `finsupp.to_multiset` the equivalence between `α →₀ ℕ` and `multiset α`, along
with `multiset.to_finsupp` the reverse equivalence and `finsupp.order_iso_multiset` the equivalence
promoted to an order isomorphism.
-/

open finset
open_locale big_operators classical
noncomputable theory

variables {α β ι  : Type*}

namespace finsupp

/-- Given `f : α →₀ ℕ`, `f.to_multiset` is the multiset with multiplicities given by the values of
`f` on the elements of `α`. We define this function as an `add_equiv`. -/
def to_multiset : (α →₀ ℕ) ≃+ multiset α :=
{ to_fun := λ f, f.sum (λa n, n • {a}),
  inv_fun := λ s, ⟨s.to_finset, λ a, s.count a, λ a, by simp⟩,
  left_inv := λ f, ext $ λ a, by
    { simp only [sum, multiset.count_sum', multiset.count_singleton, mul_boole, coe_mk,
        mem_support_iff, multiset.count_nsmul, finset.sum_ite_eq, ite_not, ite_eq_right_iff],
      exact eq.symm },
  right_inv := λ s, by simp only [sum, coe_mk, multiset.to_finset_sum_count_nsmul_eq],
  map_add' := λ f g, sum_add_index' (λ a, zero_nsmul _) (λ a, add_nsmul _) }

lemma to_multiset_zero : (0 : α →₀ ℕ).to_multiset = 0 := rfl

lemma to_multiset_add (m n : α →₀ ℕ) : (m + n).to_multiset = m.to_multiset + n.to_multiset :=
to_multiset.map_add m n

lemma to_multiset_apply (f : α →₀ ℕ) : f.to_multiset = f.sum (λ a n, n • {a}) := rfl

@[simp]
lemma to_multiset_symm_apply [decidable_eq α] (s : multiset α) (x : α) :
  finsupp.to_multiset.symm s x = s.count x :=
by convert rfl

@[simp] lemma to_multiset_single (a : α) (n : ℕ) : to_multiset (single a n) = n • {a} :=
by rw [to_multiset_apply, sum_single_index]; apply zero_nsmul

lemma to_multiset_sum {f : ι → α →₀ ℕ} (s : finset ι) :
  finsupp.to_multiset (∑ i in s, f i) = ∑ i in s, finsupp.to_multiset (f i) :=
add_equiv.map_sum _ _ _

lemma to_multiset_sum_single (s : finset ι) (n : ℕ) :
  finsupp.to_multiset (∑ i in s, single i n) = n • s.val :=
by simp_rw [to_multiset_sum, finsupp.to_multiset_single, sum_nsmul, sum_multiset_singleton]

lemma card_to_multiset (f : α →₀ ℕ) : f.to_multiset.card = f.sum (λ a, id) :=
by simp [to_multiset_apply, add_monoid_hom.map_finsupp_sum, function.id_def]

lemma to_multiset_map (f : α →₀ ℕ) (g : α → β) :
  f.to_multiset.map g = (f.map_domain g).to_multiset :=
begin
  refine f.induction _ _,
  { rw [to_multiset_zero, multiset.map_zero, map_domain_zero, to_multiset_zero] },
  { assume a n f _ _ ih,
    rw [to_multiset_add, multiset.map_add, ih, map_domain_add, map_domain_single,
        to_multiset_single, to_multiset_add, to_multiset_single,
        ← multiset.coe_map_add_monoid_hom, (multiset.map_add_monoid_hom g).map_nsmul],
    refl }
end

@[simp] lemma prod_to_multiset [comm_monoid α] (f : α →₀ ℕ) :
  f.to_multiset.prod = f.prod (λ a n, a ^ n) :=
begin
  refine f.induction _ _,
  { rw [to_multiset_zero, multiset.prod_zero, finsupp.prod_zero_index] },
  { assume a n f _ _ ih,
    rw [to_multiset_add, multiset.prod_add, ih, to_multiset_single, multiset.prod_nsmul,
      finsupp.prod_add_index' pow_zero pow_add, finsupp.prod_single_index, multiset.prod_singleton],
    { exact pow_zero a } }
end

@[simp] lemma to_finset_to_multiset [decidable_eq α] (f : α →₀ ℕ) :
  f.to_multiset.to_finset = f.support :=
begin
  refine f.induction _ _,
  { rw [to_multiset_zero, multiset.to_finset_zero, support_zero] },
  { assume a n f ha hn ih,
    rw [to_multiset_add, multiset.to_finset_add, ih, to_multiset_single, support_add_eq,
      support_single_ne_zero _ hn, multiset.to_finset_nsmul _ _ hn, multiset.to_finset_singleton],
    refine disjoint.mono_left support_single_subset _,
    rwa [finset.disjoint_singleton_left] }
end

@[simp] lemma count_to_multiset [decidable_eq α] (f : α →₀ ℕ) (a : α) :
  f.to_multiset.count a = f a :=
calc f.to_multiset.count a = f.sum (λx n, (n • {x} : multiset α).count a) :
  (multiset.count_add_monoid_hom a).map_sum _ f.support
  ... = f.sum (λx n, n * ({x} : multiset α).count a) : by simp only [multiset.count_nsmul]
  ... = f a * ({a} : multiset α).count a : sum_eq_single _
    (λ a' _ H, by simp only [multiset.count_singleton, if_false, H.symm, mul_zero])
    (λ H, by simp only [not_mem_support_iff.1 H, zero_mul])
  ... = f a : by rw [multiset.count_singleton_self, mul_one]

@[simp] lemma mem_to_multiset (f : α →₀ ℕ) (i : α) : i ∈ f.to_multiset ↔ i ∈ f.support :=
by rw [←multiset.count_ne_zero, finsupp.count_to_multiset, finsupp.mem_support_iff]

end finsupp

namespace multiset

/-- Given a multiset `s`, `s.to_finsupp` returns the finitely supported function on `ℕ` given by
the multiplicities of the elements of `s`. -/
def to_finsupp : multiset α ≃+ (α →₀ ℕ) := finsupp.to_multiset.symm

@[simp] lemma to_finsupp_support [decidable_eq α] (s : multiset α) :
  s.to_finsupp.support = s.to_finset :=
by convert rfl

@[simp] lemma to_finsupp_apply [decidable_eq α] (s : multiset α) (a : α) :
  to_finsupp s a = s.count a :=
by convert rfl

lemma to_finsupp_zero : to_finsupp (0 : multiset α) = 0 := add_equiv.map_zero _

lemma to_finsupp_add (s t : multiset α) : to_finsupp (s + t) = to_finsupp s + to_finsupp t :=
to_finsupp.map_add s t

@[simp] lemma to_finsupp_singleton (a : α) : to_finsupp ({a} : multiset α) = finsupp.single a 1 :=
finsupp.to_multiset.symm_apply_eq.2 $ by simp

@[simp] lemma to_finsupp_to_multiset (s : multiset α) : s.to_finsupp.to_multiset = s :=
finsupp.to_multiset.apply_symm_apply s

lemma to_finsupp_eq_iff {s : multiset α} {f : α →₀ ℕ} : s.to_finsupp = f ↔ s = f.to_multiset :=
finsupp.to_multiset.symm_apply_eq

end multiset

@[simp] lemma finsupp.to_multiset_to_finsupp (f : α →₀ ℕ) : f.to_multiset.to_finsupp = f :=
finsupp.to_multiset.symm_apply_apply f

/-! ### As an order isomorphism -/

namespace finsupp

/-- `finsupp.to_multiset` as an order isomorphism. -/
def order_iso_multiset : (ι →₀ ℕ) ≃o multiset ι :=
{ to_equiv := to_multiset.to_equiv,
  map_rel_iff' := λ f g, by simp [multiset.le_iff_count, le_def] }

@[simp] lemma coe_order_iso_multiset : ⇑(@order_iso_multiset ι) = to_multiset := rfl

@[simp] lemma coe_order_iso_multiset_symm : ⇑(@order_iso_multiset ι).symm = multiset.to_finsupp :=
rfl

lemma to_multiset_strict_mono : strict_mono (@to_multiset ι) := (@order_iso_multiset ι).strict_mono

lemma sum_id_lt_of_lt (m n : ι →₀ ℕ) (h : m < n) : m.sum (λ _, id) < n.sum (λ _, id) :=
begin
  rw [←card_to_multiset, ←card_to_multiset],
  apply multiset.card_lt_of_lt,
  exact to_multiset_strict_mono h
end

variable (ι)

/-- The order on `ι →₀ ℕ` is well-founded. -/
lemma lt_wf : well_founded (@has_lt.lt (ι →₀ ℕ) _) :=
subrelation.wf (sum_id_lt_of_lt) $ inv_image.wf _ nat.lt_wf

end finsupp

lemma multiset.to_finsupp_strict_mono : strict_mono (@multiset.to_finsupp ι) :=
(@finsupp.order_iso_multiset ι).symm.strict_mono


<|start_filename|>src/linear_algebra/contraction.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import linear_algebra.dual
import linear_algebra.matrix.to_lin
import linear_algebra.tensor_product_basis
import linear_algebra.free_module.finite.rank

/-!
# Contractions

Given modules $M, N$ over a commutative ring $R$, this file defines the natural linear maps:
$M^* \otimes M \to R$, $M \otimes M^* \to R$, and $M^* \otimes N → Hom(M, N)$, as well as proving
some basic properties of these maps.

## Tags

contraction, dual module, tensor product
-/

variables {ι : Type*} (R M N P Q : Type*)

local attribute [ext] tensor_product.ext

section contraction

open tensor_product linear_map matrix module
open_locale tensor_product big_operators

section comm_semiring
variables [comm_semiring R]
variables [add_comm_monoid M] [add_comm_monoid N] [add_comm_monoid P] [add_comm_monoid Q]
variables [module R M] [module R N] [module R P] [module R Q]
variables [decidable_eq ι] [fintype ι] (b : basis ι R M)

/-- The natural left-handed pairing between a module and its dual. -/
def contract_left : (module.dual R M) ⊗ M →ₗ[R] R := (uncurry _ _ _ _).to_fun linear_map.id

/-- The natural right-handed pairing between a module and its dual. -/
def contract_right : M ⊗ (module.dual R M) →ₗ[R] R :=
(uncurry _ _ _ _).to_fun (linear_map.flip linear_map.id)

/-- The natural map associating a linear map to the tensor product of two modules. -/
def dual_tensor_hom : (module.dual R M) ⊗ N →ₗ[R] M →ₗ[R] N :=
  let M' := module.dual R M in
  (uncurry R M' N (M →ₗ[R] N) : _ → M' ⊗ N →ₗ[R] M →ₗ[R] N) linear_map.smul_rightₗ

variables {R M N P Q}

@[simp] lemma contract_left_apply (f : module.dual R M) (m : M) :
  contract_left R M (f ⊗ₜ m) = f m := by apply uncurry_apply

@[simp] lemma contract_right_apply (f : module.dual R M) (m : M) :
  contract_right R M (m ⊗ₜ f) = f m := by apply uncurry_apply

@[simp] lemma dual_tensor_hom_apply (f : module.dual R M) (m : M) (n : N) :
  dual_tensor_hom R M N (f ⊗ₜ n) m = (f m) • n :=
by { dunfold dual_tensor_hom, rw uncurry_apply, refl, }

@[simp] lemma transpose_dual_tensor_hom (f : module.dual R M) (m : M) :
  dual.transpose (dual_tensor_hom R M M (f ⊗ₜ m)) = dual_tensor_hom R _ _ (dual.eval R M m ⊗ₜ f) :=
by { ext f' m', simp only [dual.transpose_apply, coe_comp, function.comp_app, dual_tensor_hom_apply,
  linear_map.map_smulₛₗ, ring_hom.id_apply, algebra.id.smul_eq_mul, dual.eval_apply, smul_apply],
  exact mul_comm _ _ }

@[simp] lemma dual_tensor_hom_prod_map_zero (f : module.dual R M) (p : P) :
  ((dual_tensor_hom R M P) (f ⊗ₜ[R] p)).prod_map (0 : N →ₗ[R] Q) =
  dual_tensor_hom R (M × N) (P × Q) ((f ∘ₗ fst R M N) ⊗ₜ inl R P Q p) :=
by {ext; simp only [coe_comp, coe_inl, function.comp_app, prod_map_apply, dual_tensor_hom_apply,
fst_apply, prod.smul_mk, zero_apply, smul_zero]}

@[simp] lemma zero_prod_map_dual_tensor_hom (g : module.dual R N) (q : Q) :
  (0 : M →ₗ[R] P).prod_map ((dual_tensor_hom R N Q) (g ⊗ₜ[R] q)) =
  dual_tensor_hom R (M × N) (P × Q) ((g ∘ₗ snd R M N) ⊗ₜ inr R P Q q) :=
by {ext; simp only [coe_comp, coe_inr, function.comp_app, prod_map_apply, dual_tensor_hom_apply,
  snd_apply, prod.smul_mk, zero_apply, smul_zero]}

lemma map_dual_tensor_hom (f : module.dual R M) (p : P) (g : module.dual R N) (q : Q) :
  tensor_product.map (dual_tensor_hom R M P (f ⊗ₜ[R] p)) (dual_tensor_hom R N Q (g ⊗ₜ[R] q)) =
  dual_tensor_hom R (M ⊗[R] N) (P ⊗[R] Q) (dual_distrib R M N (f ⊗ₜ g) ⊗ₜ[R] (p ⊗ₜ[R] q)) :=
begin
  ext m n, simp only [compr₂_apply, mk_apply, map_tmul, dual_tensor_hom_apply,
  dual_distrib_apply, ←smul_tmul_smul],
end

@[simp] lemma comp_dual_tensor_hom (f : module.dual R M) (n : N) (g : module.dual R N) (p : P) :
  (dual_tensor_hom R N P (g ⊗ₜ[R] p)) ∘ₗ (dual_tensor_hom R M N (f ⊗ₜ[R] n)) =
  g n • dual_tensor_hom R M P (f ⊗ₜ p) :=
begin
  ext m, simp only [coe_comp, function.comp_app, dual_tensor_hom_apply, linear_map.map_smul,
                    ring_hom.id_apply, smul_apply], rw smul_comm,
end

/-- As a matrix, `dual_tensor_hom` evaluated on a basis element of `M* ⊗ N` is a matrix with a
single one and zeros elsewhere -/
theorem to_matrix_dual_tensor_hom
  {m : Type*} {n : Type*} [fintype m] [fintype n] [decidable_eq m] [decidable_eq n]
  (bM : basis m R M) (bN : basis n R N) (j : m) (i : n) :
    to_matrix bM bN (dual_tensor_hom R M N (bM.coord j ⊗ₜ bN i)) = std_basis_matrix i j 1 :=
begin
  ext i' j',
  by_cases hij : (i = i' ∧ j = j');
  simp [linear_map.to_matrix_apply, finsupp.single_eq_pi_single, hij],
  rw [and_iff_not_or_not, not_not] at hij, cases hij; simp [hij],
end

end comm_semiring

section comm_ring
variables [comm_ring R]
variables [add_comm_group M] [add_comm_group N] [add_comm_group P] [add_comm_group Q]
variables [module R M] [module R N] [module R P] [module R Q]
variables [decidable_eq ι] [fintype ι] (b : basis ι R M)

variables {R M N P Q}

/-- If `M` is free, the natural linear map $M^* ⊗ N → Hom(M, N)$ is an equivalence. This function
provides this equivalence in return for a basis of `M`. -/
@[simps apply]
noncomputable def dual_tensor_hom_equiv_of_basis :
  (module.dual R M) ⊗[R] N ≃ₗ[R] M →ₗ[R] N :=
linear_equiv.of_linear
  (dual_tensor_hom R M N)
  (∑ i, (tensor_product.mk R _ N (b.dual_basis i)) ∘ₗ linear_map.applyₗ (b i))
  (begin
    ext f m,
    simp only [applyₗ_apply_apply, coe_fn_sum, dual_tensor_hom_apply, mk_apply, id_coe, id.def,
      fintype.sum_apply, function.comp_app, basis.coe_dual_basis, coe_comp,
      basis.coord_apply, ← f.map_smul, (dual_tensor_hom R M N).map_sum, ← f.map_sum, b.sum_repr],
  end)
  (begin
    ext f m,
    simp only [applyₗ_apply_apply, coe_fn_sum, dual_tensor_hom_apply, mk_apply, id_coe, id.def,
      fintype.sum_apply, function.comp_app, basis.coe_dual_basis, coe_comp,
      compr₂_apply, tmul_smul, smul_tmul', ← sum_tmul, basis.sum_dual_apply_smul_coord],
end)

@[simp] lemma dual_tensor_hom_equiv_of_basis_to_linear_map :
  (dual_tensor_hom_equiv_of_basis b : (module.dual R M) ⊗[R] N ≃ₗ[R] M →ₗ[R] N).to_linear_map =
  dual_tensor_hom R M N :=
rfl

@[simp] lemma dual_tensor_hom_equiv_of_basis_symm_cancel_left (x : (module.dual R M) ⊗[R] N) :
  (dual_tensor_hom_equiv_of_basis b).symm (dual_tensor_hom R M N x) = x :=
by rw [←dual_tensor_hom_equiv_of_basis_apply b, linear_equiv.symm_apply_apply]

@[simp] lemma dual_tensor_hom_equiv_of_basis_symm_cancel_right (x : M →ₗ[R] N) :
  dual_tensor_hom R M N ((dual_tensor_hom_equiv_of_basis b).symm x)  = x :=
by rw [←dual_tensor_hom_equiv_of_basis_apply b, linear_equiv.apply_symm_apply]

variables (R M N P Q)

variables [module.free R M] [module.finite R M] [nontrivial R]

open_locale classical

/-- If `M` is finite free, the natural map $M^* ⊗ N → Hom(M, N)$ is an
equivalence. -/
@[simp] noncomputable def dual_tensor_hom_equiv : (module.dual R M) ⊗[R] N ≃ₗ[R] M →ₗ[R] N :=
dual_tensor_hom_equiv_of_basis (module.free.choose_basis R M)

end comm_ring

end contraction

section hom_tensor_hom

open_locale tensor_product

open module tensor_product linear_map

section comm_ring

variables [comm_ring R]
variables [add_comm_group M] [add_comm_group N] [add_comm_group P] [add_comm_group Q]
variables [module R M] [module R N] [module R P] [module R Q]
variables [free R M] [finite R M] [free R N] [finite R N] [nontrivial R]

/-- When `M` is a finite free module, the map `ltensor_hom_to_hom_ltensor` is an equivalence. Note
that `ltensor_hom_equiv_hom_ltensor` is not defined directly in terms of
`ltensor_hom_to_hom_ltensor`, but the equivalence between the two is given by
`ltensor_hom_equiv_hom_ltensor_to_linear_map` and `ltensor_hom_equiv_hom_ltensor_apply`. -/
noncomputable def ltensor_hom_equiv_hom_ltensor : P ⊗[R] (M →ₗ[R] Q) ≃ₗ[R] (M →ₗ[R] P ⊗[R] Q) :=
congr (linear_equiv.refl R P) (dual_tensor_hom_equiv R M Q).symm ≪≫ₗ
  tensor_product.left_comm R P _ Q ≪≫ₗ dual_tensor_hom_equiv R M _

/-- When `M` is a finite free module, the map `rtensor_hom_to_hom_rtensor` is an equivalence. Note
that `rtensor_hom_equiv_hom_rtensor` is not defined directly in terms of
`rtensor_hom_to_hom_rtensor`, but the equivalence between the two is given by
`rtensor_hom_equiv_hom_rtensor_to_linear_map` and `rtensor_hom_equiv_hom_rtensor_apply`. -/
noncomputable def rtensor_hom_equiv_hom_rtensor : (M →ₗ[R] P) ⊗[R] Q ≃ₗ[R] (M →ₗ[R] P ⊗[R] Q) :=
congr (dual_tensor_hom_equiv R M P).symm (linear_equiv.refl R Q) ≪≫ₗ
  tensor_product.assoc R _ P Q ≪≫ₗ dual_tensor_hom_equiv R M _

@[simp] lemma ltensor_hom_equiv_hom_ltensor_to_linear_map :
  (ltensor_hom_equiv_hom_ltensor R M P Q).to_linear_map = ltensor_hom_to_hom_ltensor R M P Q :=
begin
  let e := congr (linear_equiv.refl R P) (dual_tensor_hom_equiv R M Q),
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext p f q m,
  simp only [ltensor_hom_equiv_hom_ltensor, dual_tensor_hom_equiv, compr₂_apply, mk_apply, coe_comp,
  linear_equiv.coe_to_linear_map, function.comp_app, map_tmul, linear_equiv.coe_coe,
  dual_tensor_hom_equiv_of_basis_apply, linear_equiv.trans_apply, congr_tmul,
  linear_equiv.refl_apply, dual_tensor_hom_equiv_of_basis_symm_cancel_left, left_comm_tmul,
  dual_tensor_hom_apply, ltensor_hom_to_hom_ltensor_apply, tmul_smul],
end

@[simp] lemma rtensor_hom_equiv_hom_rtensor_to_linear_map :
  (rtensor_hom_equiv_hom_rtensor R M P Q).to_linear_map = rtensor_hom_to_hom_rtensor R M P Q :=
begin
  let e := congr (dual_tensor_hom_equiv R M P) (linear_equiv.refl R Q),
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext f p q m,
  simp only [rtensor_hom_equiv_hom_rtensor, dual_tensor_hom_equiv, compr₂_apply, mk_apply, coe_comp,
  linear_equiv.coe_to_linear_map, function.comp_app, map_tmul, linear_equiv.coe_coe,
  dual_tensor_hom_equiv_of_basis_apply, linear_equiv.trans_apply, congr_tmul,
  dual_tensor_hom_equiv_of_basis_symm_cancel_left, linear_equiv.refl_apply, assoc_tmul,
  dual_tensor_hom_apply, rtensor_hom_to_hom_rtensor_apply, smul_tmul'],
end

variables {R M N P Q}

@[simp] lemma ltensor_hom_equiv_hom_ltensor_apply (x : P ⊗[R] (M →ₗ[R] Q)) :
  ltensor_hom_equiv_hom_ltensor R M P Q x = ltensor_hom_to_hom_ltensor R M P Q x :=
by rw [←linear_equiv.coe_to_linear_map, ltensor_hom_equiv_hom_ltensor_to_linear_map]

@[simp] lemma rtensor_hom_equiv_hom_rtensor_apply (x : (M →ₗ[R] P) ⊗[R] Q) :
  rtensor_hom_equiv_hom_rtensor R M P Q x = rtensor_hom_to_hom_rtensor R M P Q x :=
by rw [←linear_equiv.coe_to_linear_map, rtensor_hom_equiv_hom_rtensor_to_linear_map]

variables (R M N P Q)

/--
When `M` and `N` are free `R` modules, the map `hom_tensor_hom_map` is an equivalence. Note that
`hom_tensor_hom_equiv` is not defined directly in terms of `hom_tensor_hom_map`, but the equivalence
between the two is given by `hom_tensor_hom_equiv_to_linear_map` and `hom_tensor_hom_equiv_apply`.
-/
noncomputable
def hom_tensor_hom_equiv : (M →ₗ[R] P) ⊗[R] (N →ₗ[R] Q) ≃ₗ[R] (M ⊗[R] N →ₗ[R] P ⊗[R] Q) :=
rtensor_hom_equiv_hom_rtensor R M P _ ≪≫ₗ
  (linear_equiv.refl R M).arrow_congr (ltensor_hom_equiv_hom_ltensor R N _ Q) ≪≫ₗ
  lift.equiv R M N _

@[simp]
lemma hom_tensor_hom_equiv_to_linear_map :
  (hom_tensor_hom_equiv R M N P Q).to_linear_map = hom_tensor_hom_map R M N P Q :=
begin
  ext f g m n,
  simp only [hom_tensor_hom_equiv, compr₂_apply, mk_apply, linear_equiv.coe_to_linear_map,
  linear_equiv.trans_apply, lift.equiv_apply, linear_equiv.arrow_congr_apply,
  linear_equiv.refl_symm, linear_equiv.refl_apply, rtensor_hom_equiv_hom_rtensor_apply,
  ltensor_hom_equiv_hom_ltensor_apply, ltensor_hom_to_hom_ltensor_apply,
  rtensor_hom_to_hom_rtensor_apply, hom_tensor_hom_map_apply, map_tmul],
end

variables {R M N P Q}

@[simp]
lemma hom_tensor_hom_equiv_apply (x : (M →ₗ[R] P) ⊗[R] (N →ₗ[R] Q)) :
  hom_tensor_hom_equiv R M N P Q x = hom_tensor_hom_map R M N P Q x :=
by rw [←linear_equiv.coe_to_linear_map, hom_tensor_hom_equiv_to_linear_map]

end comm_ring

end hom_tensor_hom


<|start_filename|>src/deprecated/ring.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import deprecated.group

/-!
# Unbundled semiring and ring homomorphisms (deprecated)

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines predicates for unbundled semiring and ring homomorphisms. Instead of using
this file, please use `ring_hom`, defined in `algebra.hom.ring`, with notation `→+*`, for
morphisms between semirings or rings. For example use `φ : A →+* B` to represent a
ring homomorphism.

## Main Definitions

`is_semiring_hom` (deprecated), `is_ring_hom` (deprecated)

## Tags

is_semiring_hom, is_ring_hom

-/

universes u v w

variable {α : Type u}

/-- Predicate for semiring homomorphisms (deprecated -- use the bundled `ring_hom` version). -/
structure is_semiring_hom {α : Type u} {β : Type v} [semiring α] [semiring β] (f : α → β) : Prop :=
(map_zero [] : f 0 = 0)
(map_one [] : f 1 = 1)
(map_add [] : ∀ {x y}, f (x + y) = f x + f y)
(map_mul [] : ∀ {x y}, f (x * y) = f x * f y)

namespace is_semiring_hom

variables {β : Type v} [semiring α] [semiring β]
variables {f : α → β} (hf : is_semiring_hom f) {x y : α}

/-- The identity map is a semiring homomorphism. -/
lemma id : is_semiring_hom (@id α) := by refine {..}; intros; refl

/-- The composition of two semiring homomorphisms is a semiring homomorphism. -/
lemma comp (hf : is_semiring_hom f) {γ} [semiring γ] {g : β → γ} (hg : is_semiring_hom g) :
  is_semiring_hom (g ∘ f) :=
{ map_zero := by simpa [map_zero hf] using map_zero hg,
  map_one := by simpa [map_one hf] using map_one hg,
  map_add := λ x y, by simp [map_add hf, map_add hg],
  map_mul := λ x y, by simp [map_mul hf, map_mul hg] }

/-- A semiring homomorphism is an additive monoid homomorphism. -/
lemma to_is_add_monoid_hom (hf : is_semiring_hom f) : is_add_monoid_hom f :=
{ ..‹is_semiring_hom f› }

/-- A semiring homomorphism is a monoid homomorphism. -/
lemma to_is_monoid_hom (hf : is_semiring_hom f) : is_monoid_hom f :=
{ ..‹is_semiring_hom f› }

end is_semiring_hom

/-- Predicate for ring homomorphisms (deprecated -- use the bundled `ring_hom` version). -/
structure is_ring_hom {α : Type u} {β : Type v} [ring α] [ring β] (f : α → β) : Prop :=
(map_one [] : f 1 = 1)
(map_mul [] : ∀ {x y}, f (x * y) = f x * f y)
(map_add [] : ∀ {x y}, f (x + y) = f x + f y)

namespace is_ring_hom

variables {β : Type v} [ring α] [ring β]

/-- A map of rings that is a semiring homomorphism is also a ring homomorphism. -/
lemma of_semiring {f : α → β} (H : is_semiring_hom f) : is_ring_hom f := {..H}

variables {f : α → β} (hf : is_ring_hom f) {x y : α}

/-- Ring homomorphisms map zero to zero. -/
lemma map_zero (hf : is_ring_hom f) : f 0 = 0 :=
calc f 0 = f (0 + 0) - f 0 : by rw [hf.map_add]; simp
     ... = 0 : by simp

/-- Ring homomorphisms preserve additive inverses. -/
lemma map_neg (hf : is_ring_hom f) : f (-x) = -f x :=
calc f (-x) = f (-x + x) - f x : by rw [hf.map_add]; simp
        ... = -f x : by simp [hf.map_zero]

/-- Ring homomorphisms preserve subtraction. -/
lemma map_sub (hf : is_ring_hom f) : f (x - y) = f x - f y :=
by simp [sub_eq_add_neg, hf.map_add, hf.map_neg]

/-- The identity map is a ring homomorphism. -/
lemma id : is_ring_hom (@id α) := by refine {..}; intros; refl

/-- The composition of two ring homomorphisms is a ring homomorphism. -/
-- see Note [no instance on morphisms]
lemma comp (hf : is_ring_hom f) {γ} [ring γ] {g : β → γ} (hg : is_ring_hom g) :
  is_ring_hom (g ∘ f) :=
{ map_add := λ x y, by simp [map_add hf]; rw map_add hg; refl,
  map_mul := λ x y, by simp [map_mul hf]; rw map_mul hg; refl,
  map_one := by simp [map_one hf]; exact map_one hg }

/-- A ring homomorphism is also a semiring homomorphism. -/
lemma to_is_semiring_hom (hf : is_ring_hom f) : is_semiring_hom f :=
{ map_zero := map_zero hf, ..‹is_ring_hom f› }

lemma to_is_add_group_hom (hf : is_ring_hom f) : is_add_group_hom f := { map_add := hf.map_add }

end is_ring_hom

variables {β : Type v} {γ : Type w} [rα : semiring α] [rβ : semiring β]

namespace ring_hom

section
include rα rβ

/-- Interpret `f : α → β` with `is_semiring_hom f` as a ring homomorphism. -/
def of {f : α → β} (hf : is_semiring_hom f) : α →+* β :=
{ to_fun := f,
  .. monoid_hom.of hf.to_is_monoid_hom,
  .. add_monoid_hom.of hf.to_is_add_monoid_hom }

@[simp] lemma coe_of {f : α → β} (hf : is_semiring_hom f) : ⇑(of hf) = f := rfl

lemma to_is_semiring_hom (f : α →+* β) : is_semiring_hom f :=
{ map_zero := f.map_zero,
  map_one := f.map_one,
  map_add := f.map_add,
  map_mul := f.map_mul }

end

lemma to_is_ring_hom {α γ} [ring α] [ring γ] (g : α →+* γ) : is_ring_hom g :=
is_ring_hom.of_semiring g.to_is_semiring_hom

end ring_hom


<|start_filename|>src/measure_theory/integral/exp_decay.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.integral.interval_integral
import analysis.special_functions.exponential
import analysis.special_functions.integrals
import measure_theory.integral.integral_eq_improper

/-!
# Integrals with exponential decay at ∞

As easy special cases of general theorems in the library, we prove the following test
for integrability:

* `integrable_of_is_O_exp_neg`: If `f` is continuous on `[a,∞)`, for some `a ∈ ℝ`, and there
  exists `b > 0` such that `f(x) = O(exp(-b x))` as `x → ∞`, then `f` is integrable on `(a, ∞)`.
-/

noncomputable theory
open real interval_integral measure_theory set filter

/-- Integral of `exp (-b * x)` over `(a, X)` is bounded as `X → ∞`. -/
lemma integral_exp_neg_le {b : ℝ} (a X : ℝ) (h2 : 0 < b) :
  (∫ x in a .. X, exp (-b * x)) ≤ exp (-b * a) / b :=
begin
  rw integral_deriv_eq_sub' (λ x, -exp (-b * x) / b),
  -- goal 1/4: F(X) - F(a) is bounded
  { simp only [tsub_le_iff_right],
    rw [neg_div b (exp (-b * a)), neg_div b (exp (-b * X)), add_neg_self, neg_le, neg_zero],
    exact (div_pos (exp_pos _) h2).le, },
  -- goal 2/4: the derivative of F is exp(-b x)
  { ext1, simp [h2.ne'] },
  -- goal 3/4: F is differentiable
  { intros x hx, simp [h2.ne'], },
  -- goal 4/4: exp(-b x) is continuous
  { apply continuous.continuous_on, continuity }
end

/-- `exp (-b * x)` is integrable on `(a, ∞)`. -/
lemma exp_neg_integrable_on_Ioi (a : ℝ) {b : ℝ} (h : 0 < b) :
  integrable_on (λ x : ℝ, exp (-b * x)) (Ioi a) :=
begin
  have : ∀ (X : ℝ), integrable_on (λ x : ℝ, exp (-b * x) ) (Ioc a X),
  { intro X, exact (continuous_const.mul continuous_id).exp.integrable_on_Ioc },
  apply (integrable_on_Ioi_of_interval_integral_norm_bounded (exp (-b * a) / b) a this tendsto_id),
  simp only [eventually_at_top, norm_of_nonneg (exp_pos _).le],
  exact ⟨a, λ b2 hb2, integral_exp_neg_le a b2 h⟩,
end

/-- If `f` is continuous on `[a, ∞)`, and is `O (exp (-b * x))` at `∞` for some `b > 0`, then
`f` is integrable on `(a, ∞)`. -/
lemma integrable_of_is_O_exp_neg {f : ℝ → ℝ} {a b : ℝ} (h0 : 0 < b)
  (h1 : continuous_on f (Ici a)) (h2 : f =O[at_top] (λ x, exp (-b * x))) :
  integrable_on f (Ioi a) :=
begin
  cases h2.is_O_with with c h3,
  rw [asymptotics.is_O_with_iff, eventually_at_top] at h3,
  cases h3 with r bdr,
  let v := max a r,
  -- show integrable on `(a, v]` from continuity
  have int_left : integrable_on f (Ioc a v),
  { rw ←(interval_integrable_iff_integrable_Ioc_of_le (le_max_left a r)),
    have u : Icc a v ⊆ Ici a := Icc_subset_Ici_self,
    exact (h1.mono u).interval_integrable_of_Icc (le_max_left a r), },
  suffices : integrable_on f (Ioi v),
  { have t : integrable_on f (Ioc a v ∪ Ioi v) := integrable_on_union.mpr ⟨int_left, this⟩,
    simpa only [Ioc_union_Ioi_eq_Ioi, le_max_iff, le_refl, true_or] using t },
  -- now show integrable on `(v, ∞)` from asymptotic
  split,
  { exact (h1.mono $ Ioi_subset_Ici $ le_max_left a r).ae_strongly_measurable measurable_set_Ioi },
  have : has_finite_integral (λ x : ℝ, c * exp (-b * x)) (volume.restrict (Ioi v)),
  { exact (exp_neg_integrable_on_Ioi v h0).has_finite_integral.const_mul c },
  apply this.mono,
  refine (ae_restrict_iff' measurable_set_Ioi).mpr _,
  refine ae_of_all _ (λ x h1x, _),
  rw [norm_mul, norm_eq_abs],
  rw [mem_Ioi] at h1x,
  specialize bdr x ((le_max_right a r).trans h1x.le),
  exact bdr.trans (mul_le_mul_of_nonneg_right (le_abs_self c) (norm_nonneg _))
end


<|start_filename|>src/algebra/hom/ring.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.ring.basic

/-!
# Homomorphisms of semirings and rings

This file defines bundled homomorphisms of (non-unital) semirings and rings. As with monoid and
groups, we use the same structure `ring_hom a β`, a.k.a. `α →+* β`, for both types of homomorphisms.

The unbundled homomorphisms are defined in `deprecated.ring`. They are deprecated and the plan is to
slowly remove them from mathlib.

## Main definitions

* `non_unital_ring_hom`: Non-unital (semi)ring homomorphisms. Additive monoid homomorphism which
  preserve multiplication.
* `ring_hom`: (Semi)ring homomorphisms. Monoid homomorphisms which are also additive monoid
  homomorphism.

## Notations

* `→ₙ+*`: Non-unital (semi)ring homs
* `→+*`: (Semi)ring homs

## Implementation notes

* There's a coercion from bundled homs to fun, and the canonical notation is to
  use the bundled hom as a function via this coercion.

* There is no `semiring_hom` -- the idea is that `ring_hom` is used.
  The constructor for a `ring_hom` between semirings needs a proof of `map_zero`,
  `map_one` and `map_add` as well as `map_mul`; a separate constructor
  `ring_hom.mk'` will construct ring homs between rings from monoid homs given
  only a proof that addition is preserved.

## Tags

`ring_hom`, `semiring_hom`
-/

set_option old_structure_cmd true

open function

variables {F α β γ : Type*}

/-- Bundled non-unital semiring homomorphisms `α →ₙ+* β`; use this for bundled non-unital ring
homomorphisms too.

When possible, instead of parametrizing results over `(f : α →ₙ+* β)`,
you should parametrize over `(F : Type*) [non_unital_ring_hom_class F α β] (f : F)`.

When you extend this structure, make sure to extend `non_unital_ring_hom_class`. -/
structure non_unital_ring_hom (α β : Type*) [non_unital_non_assoc_semiring α]
  [non_unital_non_assoc_semiring β] extends α →ₙ* β, α →+ β

infixr ` →ₙ+* `:25 := non_unital_ring_hom

/-- Reinterpret a non-unital ring homomorphism `f : α →ₙ+* β` as a semigroup
homomorphism `α →ₙ* β`. The `simp`-normal form is `(f : α →ₙ* β)`. -/
add_decl_doc non_unital_ring_hom.to_mul_hom

/-- Reinterpret a non-unital ring homomorphism `f : α →ₙ+* β` as an additive
monoid homomorphism `α →+ β`. The `simp`-normal form is `(f : α →+ β)`. -/
add_decl_doc non_unital_ring_hom.to_add_monoid_hom

section non_unital_ring_hom_class

/-- `non_unital_ring_hom_class F α β` states that `F` is a type of non-unital (semi)ring
homomorphisms. You should extend this class when you extend `non_unital_ring_hom`. -/
class non_unital_ring_hom_class (F : Type*) (α β : out_param Type*)
  [non_unital_non_assoc_semiring α] [non_unital_non_assoc_semiring β]
  extends mul_hom_class F α β, add_monoid_hom_class F α β

variables [non_unital_non_assoc_semiring α] [non_unital_non_assoc_semiring β]
  [non_unital_ring_hom_class F α β]

instance : has_coe_t F (α →ₙ+* β) :=
⟨λ f, { to_fun := f, map_zero' := map_zero f, map_mul' := map_mul f, map_add' := map_add f }⟩

end non_unital_ring_hom_class

namespace non_unital_ring_hom

section coe

/-!
Throughout this section, some `semiring` arguments are specified with `{}` instead of `[]`.
See note [implicit instance arguments].
-/
variables {rα : non_unital_non_assoc_semiring α} {rβ : non_unital_non_assoc_semiring β}

include rα rβ

instance : non_unital_ring_hom_class (α →ₙ+* β) α β :=
{ coe := non_unital_ring_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_add := non_unital_ring_hom.map_add',
  map_zero := non_unital_ring_hom.map_zero',
  map_mul := non_unital_ring_hom.map_mul' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (α →ₙ+* β) (λ _, α → β) := ⟨non_unital_ring_hom.to_fun⟩

@[simp] lemma to_fun_eq_coe (f : α →ₙ+* β) : f.to_fun = f := rfl

@[simp] lemma coe_mk (f : α → β) (h₁ h₂ h₃) : ⇑(⟨f, h₁, h₂, h₃⟩ : α →ₙ+* β) = f := rfl

@[simp] lemma coe_coe [non_unital_ring_hom_class F α β] (f : F) : ((f : α →ₙ+* β) : α → β) = f :=
rfl

@[simp] lemma coe_to_mul_hom (f : α →ₙ+* β) : ⇑f.to_mul_hom = f := rfl

@[simp] lemma coe_mul_hom_mk (f : α → β) (h₁ h₂ h₃) :
  ((⟨f, h₁, h₂, h₃⟩ : α →ₙ+* β) : α →ₙ* β) = ⟨f, h₁⟩ := rfl

@[simp] lemma coe_to_add_monoid_hom (f : α →ₙ+* β) : ⇑f.to_add_monoid_hom = f := rfl

@[simp] lemma coe_add_monoid_hom_mk (f : α → β) (h₁ h₂ h₃) :
  ((⟨f, h₁, h₂, h₃⟩ : α →ₙ+* β) : α →+ β) = ⟨f, h₂, h₃⟩ := rfl

/-- Copy of a `ring_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : α →ₙ+* β) (f' : α → β) (h : f' = f) : α →ₙ+* β :=
{ ..f.to_mul_hom.copy f' h, ..f.to_add_monoid_hom.copy f' h }

end coe

variables [rα : non_unital_non_assoc_semiring α] [rβ : non_unital_non_assoc_semiring β]

section
include rα rβ

variables (f : α →ₙ+* β) {x y : α} {rα rβ}

@[ext] lemma ext ⦃f g : α →ₙ+* β⦄ : (∀ x, f x = g x) → f = g := fun_like.ext _ _

lemma ext_iff {f g : α →ₙ+* β} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

@[simp] lemma mk_coe (f : α →ₙ+* β) (h₁ h₂ h₃) : non_unital_ring_hom.mk f h₁ h₂ h₃ = f :=
ext $ λ _, rfl

lemma coe_add_monoid_hom_injective : injective (coe : (α →ₙ+* β) → (α →+ β)) :=
λ f g h, ext $ add_monoid_hom.congr_fun h

lemma coe_mul_hom_injective : injective (coe : (α →ₙ+* β) → (α →ₙ* β)) :=
λ f g h, ext $ mul_hom.congr_fun h

end

/-- The identity non-unital ring homomorphism from a non-unital semiring to itself. -/
protected def id (α : Type*) [non_unital_non_assoc_semiring α] : α →ₙ+* α :=
by refine {to_fun := id, ..}; intros; refl

include rα rβ

instance : has_zero (α →ₙ+* β) :=
⟨{ to_fun := 0,
   map_mul' := λ x y, (mul_zero (0 : β)).symm,
   map_zero' := rfl,
   map_add' := λ x y, (add_zero (0 : β)).symm }⟩

instance : inhabited (α →ₙ+* β) := ⟨0⟩

@[simp] lemma coe_zero : ⇑(0 : α →ₙ+* β) = 0 := rfl
@[simp] lemma zero_apply (x : α) : (0 : α →ₙ+* β) x = 0 := rfl

omit rβ

@[simp] lemma id_apply (x : α) : non_unital_ring_hom.id α x = x := rfl
@[simp] lemma coe_add_monoid_hom_id :
  (non_unital_ring_hom.id α : α →+ α) = add_monoid_hom.id α := rfl
@[simp] lemma coe_mul_hom_id : (non_unital_ring_hom.id α : α →ₙ* α) = mul_hom.id α := rfl

variable {rγ : non_unital_non_assoc_semiring γ}
include rβ rγ

/-- Composition of non-unital ring homomorphisms is a non-unital ring homomorphism. -/
def comp (g : β →ₙ+* γ) (f : α →ₙ+* β) : α →ₙ+* γ :=
{ ..g.to_mul_hom.comp f.to_mul_hom, ..g.to_add_monoid_hom.comp f.to_add_monoid_hom }

/-- Composition of non-unital ring homomorphisms is associative. -/
lemma comp_assoc {δ} {rδ : non_unital_non_assoc_semiring δ} (f : α →ₙ+* β) (g : β →ₙ+* γ)
  (h : γ →ₙ+* δ) : (h.comp g).comp f = h.comp (g.comp f) := rfl

@[simp] lemma coe_comp (g : β →ₙ+* γ) (f : α →ₙ+* β) : ⇑(g.comp f) = g ∘ f := rfl
@[simp] lemma comp_apply (g : β →ₙ+* γ) (f : α →ₙ+* β) (x : α) : g.comp f x = g (f x) := rfl

@[simp] lemma coe_comp_add_monoid_hom (g : β →ₙ+* γ) (f : α →ₙ+* β) :
  (g.comp f : α →+ γ) = (g : β →+ γ).comp f := rfl
@[simp] lemma coe_comp_mul_hom (g : β →ₙ+* γ) (f : α →ₙ+* β) :
  (g.comp f : α →ₙ* γ) = (g : β →ₙ* γ).comp f := rfl

@[simp] lemma comp_zero (g : β →ₙ+* γ) : g.comp (0 : α →ₙ+* β) = 0 := by { ext, simp }
@[simp] lemma zero_comp (f : α →ₙ+* β) : (0 : β →ₙ+* γ).comp f = 0 := by { ext, refl }

omit rγ

@[simp] lemma comp_id (f : α →ₙ+* β) : f.comp (non_unital_ring_hom.id α) = f := ext $ λ x, rfl
@[simp] lemma id_comp (f : α →ₙ+* β) : (non_unital_ring_hom.id β).comp f = f := ext $ λ x, rfl

omit rβ

instance : monoid_with_zero (α →ₙ+* α) :=
{ one := non_unital_ring_hom.id α,
  mul := comp,
  mul_one := comp_id,
  one_mul := id_comp,
  mul_assoc := λ f g h, comp_assoc _ _ _,
  zero := 0,
  mul_zero := comp_zero,
  zero_mul := zero_comp }

lemma one_def : (1 : α →ₙ+* α) = non_unital_ring_hom.id α := rfl

@[simp] lemma coe_one : ⇑(1 : α →ₙ+* α) = id := rfl

lemma mul_def (f g : α →ₙ+* α) : f * g = f.comp g := rfl

@[simp] lemma coe_mul (f g : α →ₙ+* α) : ⇑(f * g) = f ∘ g := rfl

include rβ rγ

lemma cancel_right {g₁ g₂ : β →ₙ+* γ} {f : α →ₙ+* β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 (ext_iff.1 h), λ h, h ▸ rfl⟩

lemma cancel_left {g : β →ₙ+* γ} {f₁ f₂ : α →ₙ+* β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ext $ λ x, hg $ by rw [← comp_apply, h, comp_apply], λ h, h ▸ rfl⟩

omit rα rβ rγ

end non_unital_ring_hom

/-- Bundled semiring homomorphisms; use this for bundled ring homomorphisms too.

This extends from both `monoid_hom` and `monoid_with_zero_hom` in order to put the fields in a
sensible order, even though `monoid_with_zero_hom` already extends `monoid_hom`. -/
structure ring_hom (α : Type*) (β : Type*) [non_assoc_semiring α] [non_assoc_semiring β]
  extends α →* β, α →+ β, α →ₙ+* β, α →*₀ β

infixr ` →+* `:25 := ring_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as a monoid with zero homomorphism `α →*₀ β`.
The `simp`-normal form is `(f : α →*₀ β)`. -/
add_decl_doc ring_hom.to_monoid_with_zero_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as a monoid homomorphism `α →* β`.
The `simp`-normal form is `(f : α →* β)`. -/
add_decl_doc ring_hom.to_monoid_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as an additive monoid homomorphism `α →+ β`.
The `simp`-normal form is `(f : α →+ β)`. -/
add_decl_doc ring_hom.to_add_monoid_hom

/-- Reinterpret a ring homomorphism `f : α →+* β` as a non-unital ring homomorphism `α →ₙ+* β`. The
`simp`-normal form is `(f : α →ₙ+* β)`. -/
add_decl_doc ring_hom.to_non_unital_ring_hom

section ring_hom_class

/-- `ring_hom_class F α β` states that `F` is a type of (semi)ring homomorphisms.
You should extend this class when you extend `ring_hom`.

This extends from both `monoid_hom_class` and `monoid_with_zero_hom_class` in
order to put the fields in a sensible order, even though
`monoid_with_zero_hom_class` already extends `monoid_hom_class`. -/
class ring_hom_class (F : Type*) (α β : out_param Type*)
  [non_assoc_semiring α] [non_assoc_semiring β]
  extends monoid_hom_class F α β, add_monoid_hom_class F α β, monoid_with_zero_hom_class F α β

variables [non_assoc_semiring α] [non_assoc_semiring β] [ring_hom_class F α β]

/-- Ring homomorphisms preserve `bit1`. -/
@[simp] lemma map_bit1 (f : F) (a : α) : (f (bit1 a) : β) = bit1 (f a) := by simp [bit1]

instance : has_coe_t F (α →+* β) :=
⟨λ f, { to_fun := f, map_zero' := map_zero f, map_one' := map_one f, map_mul' := map_mul f,
  map_add' := map_add f }⟩

@[priority 100]
instance ring_hom_class.to_non_unital_ring_hom_class : non_unital_ring_hom_class F α β :=
{ .. ‹ring_hom_class F α β› }

end ring_hom_class

namespace ring_hom

section coe

/-!
Throughout this section, some `semiring` arguments are specified with `{}` instead of `[]`.
See note [implicit instance arguments].
-/
variables {rα : non_assoc_semiring α} {rβ : non_assoc_semiring β}

include rα rβ

instance : ring_hom_class (α →+* β) α β :=
{ coe := ring_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_add := ring_hom.map_add',
  map_zero := ring_hom.map_zero',
  map_mul := ring_hom.map_mul',
  map_one := ring_hom.map_one' }

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly.
-/
instance : has_coe_to_fun (α →+* β) (λ _, α → β) := ⟨ring_hom.to_fun⟩

initialize_simps_projections ring_hom (to_fun → apply)

@[simp] lemma to_fun_eq_coe (f : α →+* β) : f.to_fun = f := rfl

@[simp] lemma coe_mk (f : α → β) (h₁ h₂ h₃ h₄) : ⇑(⟨f, h₁, h₂, h₃, h₄⟩ : α →+* β) = f := rfl

@[simp] lemma coe_coe {F : Type*} [ring_hom_class F α β] (f : F) : ((f : α →+* β) : α → β) = f :=
rfl

instance has_coe_monoid_hom : has_coe (α →+* β) (α →* β) := ⟨ring_hom.to_monoid_hom⟩

@[simp, norm_cast] lemma coe_monoid_hom (f : α →+* β) : ⇑(f : α →* β) = f := rfl

@[simp] lemma to_monoid_hom_eq_coe (f : α →+* β) : f.to_monoid_hom = f := rfl
@[simp] lemma to_monoid_with_zero_hom_eq_coe (f : α →+* β) :
  (f.to_monoid_with_zero_hom : α → β) = f := rfl

@[simp] lemma coe_monoid_hom_mk (f : α → β) (h₁ h₂ h₃ h₄) :
  ((⟨f, h₁, h₂, h₃, h₄⟩ : α →+* β) : α →* β) = ⟨f, h₁, h₂⟩ := rfl

@[simp, norm_cast] lemma coe_add_monoid_hom (f : α →+* β) : ⇑(f : α →+ β) = f := rfl

@[simp] lemma to_add_monoid_hom_eq_coe (f : α →+* β) : f.to_add_monoid_hom = f := rfl

@[simp] lemma coe_add_monoid_hom_mk (f : α → β) (h₁ h₂ h₃ h₄) :
  ((⟨f, h₁, h₂, h₃, h₄⟩ : α →+* β) : α →+ β) = ⟨f, h₃, h₄⟩ := rfl

/-- Copy of a `ring_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
def copy (f : α →+* β) (f' : α → β) (h : f' = f) : α →+* β :=
{ ..f.to_monoid_with_zero_hom.copy f' h, ..f.to_add_monoid_hom.copy f' h }

end coe

variables [rα : non_assoc_semiring α] [rβ : non_assoc_semiring β]

section
include rα rβ

variables (f : α →+* β) {x y : α} {rα rβ}

lemma congr_fun {f g : α →+* β} (h : f = g) (x : α) : f x = g x := fun_like.congr_fun h x
lemma congr_arg (f : α →+* β) {x y : α} (h : x = y) : f x = f y := fun_like.congr_arg f h

lemma coe_inj ⦃f g : α →+* β⦄ (h : (f : α → β) = g) : f = g := fun_like.coe_injective h

@[ext] lemma ext ⦃f g : α →+* β⦄ : (∀ x, f x = g x) → f = g := fun_like.ext _ _

lemma ext_iff {f g : α →+* β} : f = g ↔ ∀ x, f x = g x := fun_like.ext_iff

@[simp] lemma mk_coe (f : α →+* β) (h₁ h₂ h₃ h₄) : ring_hom.mk f h₁ h₂ h₃ h₄ = f := ext $ λ _, rfl

lemma coe_add_monoid_hom_injective : injective (coe : (α →+* β) → (α →+ β)) :=
λ f g h, ext $ add_monoid_hom.congr_fun h

lemma coe_monoid_hom_injective : injective (coe : (α →+* β) → (α →* β)) :=
λ f g h, ext $ monoid_hom.congr_fun h

/-- Ring homomorphisms map zero to zero. -/
protected lemma map_zero (f : α →+* β) : f 0 = 0 := map_zero f

/-- Ring homomorphisms map one to one. -/
protected lemma map_one (f : α →+* β) : f 1 = 1 := map_one f

/-- Ring homomorphisms preserve addition. -/
protected lemma map_add (f : α →+* β) : ∀ a b, f (a + b) = f a + f b := map_add f

/-- Ring homomorphisms preserve multiplication. -/
protected lemma map_mul (f : α →+* β) : ∀ a b, f (a * b) = f a * f b := map_mul f

/-- Ring homomorphisms preserve `bit0`. -/
protected lemma map_bit0 (f : α →+* β) : ∀ a, f (bit0 a) = bit0 (f a) := map_bit0 f

/-- Ring homomorphisms preserve `bit1`. -/
protected lemma map_bit1 (f : α →+* β) : ∀ a, f (bit1 a) = bit1 (f a) := map_bit1 f

/-- `f : α →+* β` has a trivial codomain iff `f 1 = 0`. -/
lemma codomain_trivial_iff_map_one_eq_zero : (0 : β) = 1 ↔ f 1 = 0 := by rw [map_one, eq_comm]

/-- `f : α →+* β` has a trivial codomain iff it has a trivial range. -/
lemma codomain_trivial_iff_range_trivial : (0 : β) = 1 ↔ ∀ x, f x = 0 :=
f.codomain_trivial_iff_map_one_eq_zero.trans
  ⟨λ h x, by rw [←mul_one x, map_mul, h, mul_zero], λ h, h 1⟩

/-- `f : α →+* β` has a trivial codomain iff its range is `{0}`. -/
lemma codomain_trivial_iff_range_eq_singleton_zero : (0 : β) = 1 ↔ set.range f = {0} :=
f.codomain_trivial_iff_range_trivial.trans
  ⟨ λ h, set.ext (λ y, ⟨λ ⟨x, hx⟩, by simp [←hx, h x], λ hy, ⟨0, by simpa using hy.symm⟩⟩),
    λ h x, set.mem_singleton_iff.mp (h ▸ set.mem_range_self x)⟩

/-- `f : α →+* β` doesn't map `1` to `0` if `β` is nontrivial -/
lemma map_one_ne_zero [nontrivial β] : f 1 ≠ 0 :=
mt f.codomain_trivial_iff_map_one_eq_zero.mpr zero_ne_one

/-- If there is a homomorphism `f : α →+* β` and `β` is nontrivial, then `α` is nontrivial. -/
lemma domain_nontrivial [nontrivial β] : nontrivial α :=
⟨⟨1, 0, mt (λ h, show f 1 = 0, by rw [h, map_zero]) f.map_one_ne_zero⟩⟩

end

/-- Ring homomorphisms preserve additive inverse. -/
protected theorem map_neg [non_assoc_ring α] [non_assoc_ring β] (f : α →+* β) (x : α) :
  f (-x) = -(f x) :=
map_neg f x

/-- Ring homomorphisms preserve subtraction. -/
protected theorem map_sub [non_assoc_ring α] [non_assoc_ring β] (f : α →+* β) (x y : α) :
  f (x - y) = (f x) - (f y) := map_sub f x y

/-- Makes a ring homomorphism from a monoid homomorphism of rings which preserves addition. -/
def mk' [non_assoc_semiring α] [non_assoc_ring β] (f : α →* β)
  (map_add : ∀ a b, f (a + b) = f a + f b) :
  α →+* β :=
{ ..add_monoid_hom.mk' f map_add, ..f }

section semiring
variables [semiring α] [semiring β]

lemma is_unit_map (f : α →+* β) {a : α} : is_unit a → is_unit (f a) := is_unit.map f

protected lemma map_dvd (f : α →+* β) {a b : α} : a ∣ b → f a ∣ f b := map_dvd f

end semiring

/-- The identity ring homomorphism from a semiring to itself. -/
def id (α : Type*) [non_assoc_semiring α] : α →+* α := by refine {to_fun := id, ..}; intros; refl

include rα

instance : inhabited (α →+* α) := ⟨id α⟩

@[simp] lemma id_apply (x : α) : ring_hom.id α x = x := rfl
@[simp] lemma coe_add_monoid_hom_id : (id α : α →+ α) = add_monoid_hom.id α := rfl
@[simp] lemma coe_monoid_hom_id : (id α : α →* α) = monoid_hom.id α := rfl

variable {rγ : non_assoc_semiring γ}
include rβ rγ

/-- Composition of ring homomorphisms is a ring homomorphism. -/
def comp (g : β →+* γ) (f : α →+* β) : α →+* γ :=
{ to_fun := g ∘ f,
  map_one' := by simp,
  ..g.to_non_unital_ring_hom.comp f.to_non_unital_ring_hom }

/-- Composition of semiring homomorphisms is associative. -/
lemma comp_assoc {δ} {rδ: non_assoc_semiring δ} (f : α →+* β) (g : β →+* γ) (h : γ →+* δ) :
  (h.comp g).comp f = h.comp (g.comp f) := rfl

@[simp] lemma coe_comp (hnp : β →+* γ) (hmn : α →+* β) : (hnp.comp hmn : α → γ) = hnp ∘ hmn := rfl

lemma comp_apply (hnp : β →+* γ) (hmn : α →+* β) (x : α) : (hnp.comp hmn : α → γ) x =
  (hnp (hmn x)) := rfl

omit rγ

@[simp] lemma comp_id (f : α →+* β) : f.comp (id α) = f := ext $ λ x, rfl

@[simp] lemma id_comp (f : α →+* β) : (id β).comp f = f := ext $ λ x, rfl

omit rβ

instance : monoid (α →+* α) :=
{ one := id α,
  mul := comp,
  mul_one := comp_id,
  one_mul := id_comp,
  mul_assoc := λ f g h, comp_assoc _ _ _ }

lemma one_def : (1 : α →+* α) = id α := rfl
lemma mul_def (f g : α →+* α) : f * g = f.comp g := rfl

@[simp] lemma coe_one : ⇑(1 : α →+* α) = _root_.id := rfl
@[simp] lemma coe_mul (f g : α →+* α) : ⇑(f * g) = f ∘ g := rfl

include rβ rγ

lemma cancel_right {g₁ g₂ : β →+* γ} {f : α →+* β} (hf : surjective f) :
  g₁.comp f = g₂.comp f ↔ g₁ = g₂ :=
⟨λ h, ring_hom.ext $ hf.forall.2 (ext_iff.1 h), λ h, h ▸ rfl⟩

lemma cancel_left {g : β →+* γ} {f₁ f₂ : α →+* β} (hg : injective g) :
  g.comp f₁ = g.comp f₂ ↔ f₁ = f₂ :=
⟨λ h, ring_hom.ext $ λ x, hg $ by rw [← comp_apply, h, comp_apply], λ h, h ▸ rfl⟩

end ring_hom

/-- Pullback `is_domain` instance along an injective function. -/
protected theorem function.injective.is_domain [ring α] [is_domain α] [ring β] (f : β →+* α)
  (hf : injective f) :
  is_domain β :=
{ .. pullback_nonzero f f.map_zero f.map_one, .. hf.no_zero_divisors f f.map_zero f.map_mul }

namespace add_monoid_hom
variables [comm_ring α] [is_domain α] [comm_ring β] (f : β →+ α)

/-- Make a ring homomorphism from an additive group homomorphism from a commutative ring to an
integral domain that commutes with self multiplication, assumes that two is nonzero and `1` is sent
to `1`. -/
def mk_ring_hom_of_mul_self_of_two_ne_zero (h : ∀ x, f (x * x) = f x * f x) (h_two : (2 : α) ≠ 0)
  (h_one : f 1 = 1) : β →+* α :=
{ map_one' := h_one,
  map_mul' := λ x y, begin
    have hxy := h (x + y),
    rw [mul_add, add_mul, add_mul, f.map_add, f.map_add, f.map_add, f.map_add, h x, h y, add_mul,
      mul_add, mul_add, ← sub_eq_zero, add_comm, ← sub_sub, ← sub_sub, ← sub_sub,
      mul_comm y x, mul_comm (f y) (f x)] at hxy,
    simp only [add_assoc, add_sub_assoc, add_sub_cancel'_right] at hxy,
    rw [sub_sub, ← two_mul, ← add_sub_assoc, ← two_mul, ← mul_sub, mul_eq_zero, sub_eq_zero,
      or_iff_not_imp_left] at hxy,
    exact hxy h_two,
  end,
  ..f }

@[simp] lemma coe_fn_mk_ring_hom_of_mul_self_of_two_ne_zero (h h_two h_one) :
  (f.mk_ring_hom_of_mul_self_of_two_ne_zero h h_two h_one : β → α) = f := rfl

@[simp] lemma coe_add_monoid_hom_mk_ring_hom_of_mul_self_of_two_ne_zero (h h_two h_one) :
  (f.mk_ring_hom_of_mul_self_of_two_ne_zero h h_two h_one : β →+ α) = f :=
by { ext, refl }

end add_monoid_hom


<|start_filename|>src/data/int/log.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.nat.log
import algebra.order.floor
import algebra.field_power

/-!
# Integer logarithms in a field with respect to a natural base

This file defines two `ℤ`-valued analogs of the logarithm of `r : R` with base `b : ℕ`:

* `int.log b r`: Lower logarithm, or floor **log**. Greatest `k` such that `↑b^k ≤ r`.
* `int.clog b r`: Upper logarithm, or **c**eil **log**. Least `k` such that `r ≤ ↑b^k`.

Note that `int.log` gives the position of the left-most non-zero digit:
```lean
#eval (int.log 10 (0.09 : ℚ), int.log 10 (0.10 : ℚ), int.log 10 (0.11 : ℚ))
--    (-2,                    -1,                    -1)
#eval (int.log 10 (9 : ℚ),    int.log 10 (10 : ℚ),   int.log 10 (11 : ℚ))
--    (0,                     1,                     1)
```
which means it can be used for computing digit expansions
```lean
import data.fin.vec_notation

def digits (b : ℕ) (q : ℚ) (n : ℕ) : ℕ :=
⌊q*b^(↑n - int.log b q)⌋₊ % b

#eval digits 10 (1/7) ∘ (coe : fin 8 → ℕ)
-- ![1, 4, 2, 8, 5, 7, 1, 4]
```

## Main results

* For `int.log`:
  * `int.zpow_log_le_self`, `int.lt_zpow_succ_log_self`: the bounds formed by `int.log`,
    `(b : R) ^ log b r ≤ r < (b : R) ^ (log b r + 1)`.
  * `int.zpow_log_gi`: the galois coinsertion between `zpow` and `int.log`.
* For `int.clog`:
  * `int.zpow_pred_clog_lt_self`, `int.self_le_zpow_clog`: the bounds formed by `int.clog`,
    `(b : R) ^ (clog b r - 1) < r ≤ (b : R) ^ clog b r`.
  * `int.clog_zpow_gi`:  the galois insertion between `int.clog` and `zpow`.
* `int.neg_log_inv_eq_clog`, `int.neg_clog_inv_eq_log`: the link between the two definitions.

-/
variables {R : Type*} [linear_ordered_field R] [floor_ring R]

namespace int

/-- The greatest power of `b` such that `b ^ log b r ≤ r`. -/
def log (b : ℕ) (r : R) : ℤ :=
if 1 ≤ r then
  nat.log b ⌊r⌋₊
else
  -nat.clog b ⌈r⁻¹⌉₊

lemma log_of_one_le_right (b : ℕ) {r : R} (hr : 1 ≤ r) : log b r = nat.log b ⌊r⌋₊ :=
if_pos hr

lemma log_of_right_le_one (b : ℕ) {r : R} (hr : r ≤ 1) : log b r = -nat.clog b ⌈r⁻¹⌉₊ :=
begin
  obtain rfl | hr := hr.eq_or_lt,
  { rw [log, if_pos hr, inv_one, nat.ceil_one, nat.floor_one, nat.log_one_right, nat.clog_one_right,
        int.coe_nat_zero, neg_zero], },
  { exact if_neg hr.not_le }
end

@[simp, norm_cast] lemma log_nat_cast (b : ℕ) (n : ℕ) : log b (n : R) = nat.log b n :=
begin
  cases n,
  { simp [log_of_right_le_one _ _, nat.log_zero_right] },
  { have : 1 ≤ (n.succ : R) := by simp,
    simp [log_of_one_le_right _ this, ←nat.cast_succ] }
end

lemma log_of_left_le_one {b : ℕ} (hb : b ≤ 1) (r : R) : log b r = 0 :=
begin
  cases le_total 1 r,
  { rw [log_of_one_le_right _ h, nat.log_of_left_le_one hb, int.coe_nat_zero] },
  { rw [log_of_right_le_one _ h, nat.clog_of_left_le_one hb, int.coe_nat_zero, neg_zero] },
end

lemma log_of_right_le_zero (b : ℕ) {r : R} (hr : r ≤ 0) : log b r = 0 :=
by rw [log_of_right_le_one _ (hr.trans zero_le_one),
    nat.clog_of_right_le_one ((nat.ceil_eq_zero.mpr $ inv_nonpos.2 hr).trans_le zero_le_one),
    int.coe_nat_zero, neg_zero]

lemma zpow_log_le_self {b : ℕ} {r : R} (hb : 1 < b) (hr : 0 < r) :
  (b : R) ^ log b r ≤ r :=
begin
  cases le_total 1 r with hr1 hr1,
  { rw log_of_one_le_right _ hr1,
    refine le_trans _ (nat.floor_le hr.le),
    rw [zpow_coe_nat, ←nat.cast_pow, nat.cast_le],
    exact nat.pow_log_le_self hb (nat.floor_pos.mpr hr1) },
  { rw [log_of_right_le_one _ hr1, zpow_neg, zpow_coe_nat, ← nat.cast_pow],
    apply inv_le_of_inv_le hr,
    refine (nat.le_ceil _).trans (nat.cast_le.2 _),
    exact nat.le_pow_clog hb _ },
end

lemma lt_zpow_succ_log_self {b : ℕ} (hb : 1 < b) (r : R) :
  r < (b : R) ^ (log b r + 1) :=
begin
  cases le_or_lt r 0 with hr hr,
  { rw [log_of_right_le_zero _ hr, zero_add, zpow_one],
    exact hr.trans_lt (zero_lt_one.trans_le $ by exact_mod_cast hb.le) },
  cases le_or_lt 1 r with hr1 hr1,
  { rw log_of_one_le_right _ hr1,
    rw [int.coe_nat_add_one_out, zpow_coe_nat, ←nat.cast_pow],
    apply nat.lt_of_floor_lt,
    exact nat.lt_pow_succ_log_self hb _, },
  { rw log_of_right_le_one _ hr1.le,
    have hcri : 1 < r⁻¹ := one_lt_inv hr hr1,
    have : 1 ≤ nat.clog b ⌈r⁻¹⌉₊ :=
      nat.succ_le_of_lt (nat.clog_pos hb $ nat.one_lt_cast.1 $ hcri.trans_le (nat.le_ceil _)),
    rw [neg_add_eq_sub, ←neg_sub, ←int.coe_nat_one, ← int.coe_nat_sub this,
      zpow_neg, zpow_coe_nat, lt_inv hr (pow_pos (nat.cast_pos.mpr $ zero_lt_one.trans hb) _),
      ←nat.cast_pow],
    refine nat.lt_ceil.1 _,
    exact (nat.pow_pred_clog_lt_self hb $ nat.one_lt_cast.1 $ hcri.trans_le $ nat.le_ceil _), }
end

@[simp] lemma log_zero_right (b : ℕ) : log b (0 : R) = 0 :=
log_of_right_le_zero b le_rfl

@[simp] lemma log_one_right (b : ℕ) : log b (1 : R) = 0 :=
by rw [log_of_one_le_right _ le_rfl, nat.floor_one, nat.log_one_right, int.coe_nat_zero]

lemma log_zpow {b : ℕ} (hb : 1 < b) (z : ℤ) : log b (b ^ z : R) = z :=
begin
  obtain ⟨n, rfl | rfl⟩ := z.eq_coe_or_neg,
  { rw [log_of_one_le_right _ (one_le_zpow_of_nonneg _ $ int.coe_nat_nonneg _),
      zpow_coe_nat, ←nat.cast_pow, nat.floor_coe, nat.log_pow hb],
    exact_mod_cast hb.le, },
  { rw [log_of_right_le_one _ (zpow_le_one_of_nonpos _ $ neg_nonpos.mpr (int.coe_nat_nonneg _)),
      zpow_neg, inv_inv, zpow_coe_nat, ←nat.cast_pow, nat.ceil_coe, nat.clog_pow _ _ hb],
    exact_mod_cast hb.le, },
end

@[mono] lemma log_mono_right {b : ℕ} {r₁ r₂ : R} (h₀ : 0 < r₁) (h : r₁ ≤ r₂) :
  log b r₁ ≤ log b r₂ :=
begin
  cases le_or_lt b 1 with hb hb,
  { rw [log_of_left_le_one hb, log_of_left_le_one hb], },
  cases le_total r₁ 1 with h₁ h₁; cases le_total r₂ 1 with h₂ h₂,
  { rw [log_of_right_le_one _ h₁, log_of_right_le_one _ h₂, neg_le_neg_iff, int.coe_nat_le],
    exact nat.clog_mono_right _ (nat.ceil_mono $ inv_le_inv_of_le h₀ h), },
  { rw [log_of_right_le_one _ h₁, log_of_one_le_right _ h₂],
    exact (neg_nonpos.mpr (int.coe_nat_nonneg _)).trans (int.coe_nat_nonneg _) },
  { obtain rfl := le_antisymm h (h₂.trans h₁), refl, },
  { rw [log_of_one_le_right _ h₁, log_of_one_le_right _ h₂, int.coe_nat_le],
    exact nat.log_mono_right (nat.floor_mono h), },
end

variables (R)

/-- Over suitable subtypes, `zpow` and `int.log` form a galois coinsertion -/
def zpow_log_gi {b : ℕ} (hb : 1 < b) :
  galois_coinsertion
    (λ z : ℤ, subtype.mk ((b : R) ^ z) $ zpow_pos_of_pos (by exact_mod_cast zero_lt_one.trans hb) z)
    (λ r : set.Ioi (0 : R), int.log b (r : R)) :=
galois_coinsertion.monotone_intro
  (λ r₁ r₂, log_mono_right r₁.prop)
  (λ z₁ z₂ hz, subtype.coe_le_coe.mp $ (zpow_strict_mono $ by exact_mod_cast hb).monotone hz)
  (λ r, subtype.coe_le_coe.mp $ zpow_log_le_self hb r.prop)
  (λ _, log_zpow hb _)

variables {R}

/-- `zpow b` and `int.log b` (almost) form a Galois connection. -/
lemma lt_zpow_iff_log_lt {b : ℕ} (hb : 1 < b) {x : ℤ} {r : R} (hr : 0 < r) :
  r < (b : R) ^ x ↔ log b r < x :=
@galois_connection.lt_iff_lt _ _ _ _ _ _ (zpow_log_gi R hb).gc x ⟨r, hr⟩

/-- `zpow b` and `int.log b` (almost) form a Galois connection. -/
lemma zpow_le_iff_le_log {b : ℕ} (hb : 1 < b) {x : ℤ} {r : R} (hr : 0 < r) :
  (b : R) ^ x ≤ r ↔ x ≤ log b r :=
@galois_connection.le_iff_le _ _ _ _ _ _ (zpow_log_gi R hb).gc x ⟨r, hr⟩

/-- The least power of `b` such that `r ≤ b ^ log b r`. -/
def clog (b : ℕ) (r : R) : ℤ :=
if 1 ≤ r then
  nat.clog b ⌈r⌉₊
else
  -nat.log b ⌊r⁻¹⌋₊

lemma clog_of_one_le_right (b : ℕ) {r : R} (hr : 1 ≤ r) : clog b r = nat.clog b ⌈r⌉₊ :=
if_pos hr

lemma clog_of_right_le_one (b : ℕ) {r : R} (hr : r ≤ 1) : clog b r = -nat.log b ⌊r⁻¹⌋₊ :=
begin
  obtain rfl | hr := hr.eq_or_lt,
  { rw [clog, if_pos hr, inv_one, nat.ceil_one, nat.floor_one, nat.log_one_right,
        nat.clog_one_right, int.coe_nat_zero, neg_zero], },
  { exact if_neg hr.not_le }
end

lemma clog_of_right_le_zero (b : ℕ) {r : R} (hr : r ≤ 0) : clog b r = 0 :=
begin
  rw [clog, if_neg (hr.trans_lt zero_lt_one).not_le, neg_eq_zero, int.coe_nat_eq_zero,
    nat.log_eq_zero_iff],
  cases le_or_lt b 1 with hb hb,
  { exact or.inr hb },
  { refine or.inl (lt_of_le_of_lt _ hb),
    exact nat.floor_le_one_of_le_one ((inv_nonpos.2 hr).trans zero_le_one) },
end

@[simp] lemma clog_inv (b : ℕ) (r : R) : clog b r⁻¹ = -log b r :=
begin
  cases lt_or_le 0 r with hrp hrp,
  { obtain hr | hr := le_total 1 r,
    { rw [clog_of_right_le_one _ (inv_le_one hr), log_of_one_le_right _ hr, inv_inv] },
    { rw [clog_of_one_le_right _ (one_le_inv hrp hr),  log_of_right_le_one _ hr, neg_neg] }, },
  { rw [clog_of_right_le_zero _ (inv_nonpos.mpr hrp), log_of_right_le_zero _ hrp, neg_zero], },
end

@[simp] lemma log_inv (b : ℕ) (r : R) : log b r⁻¹ = -clog b r :=
by rw [←inv_inv r, clog_inv, neg_neg, inv_inv]

-- note this is useful for writing in reverse
lemma neg_log_inv_eq_clog (b : ℕ) (r : R) : -log b r⁻¹ = clog b r :=
by rw [log_inv, neg_neg]

lemma neg_clog_inv_eq_log (b : ℕ) (r : R) : -clog b r⁻¹ = log b r :=
by rw [clog_inv, neg_neg]

@[simp, norm_cast] lemma clog_nat_cast (b : ℕ) (n : ℕ) : clog b (n : R) = nat.clog b n :=
begin
  cases n,
  { simp [clog_of_right_le_one _ _, nat.clog_zero_right] },
  { have : 1 ≤ (n.succ : R) := by simp,
    simp [clog_of_one_le_right _ this, ←nat.cast_succ] }
end

lemma clog_of_left_le_one {b : ℕ} (hb : b ≤ 1) (r : R) : clog b r = 0 :=
by rw [←neg_log_inv_eq_clog, log_of_left_le_one hb, neg_zero]

lemma self_le_zpow_clog {b : ℕ} (hb : 1 < b) (r : R) : r ≤ (b : R) ^ clog b r :=
begin
  cases le_or_lt r 0 with hr hr,
  { rw [clog_of_right_le_zero _ hr, zpow_zero],
    exact hr.trans zero_le_one },
  rw [←neg_log_inv_eq_clog, zpow_neg, le_inv hr (zpow_pos_of_pos _ _)],
  { exact zpow_log_le_self hb (inv_pos.mpr hr), },
  { exact nat.cast_pos.mpr (zero_le_one.trans_lt hb), },
end

lemma zpow_pred_clog_lt_self {b : ℕ} {r : R} (hb : 1 < b) (hr : 0 < r) :
  (b : R) ^ (clog b r - 1) < r :=
begin
  rw [←neg_log_inv_eq_clog, ←neg_add', zpow_neg, inv_lt (zpow_pos_of_pos _ _) hr],
  { exact lt_zpow_succ_log_self hb _, },
  { exact nat.cast_pos.mpr (zero_le_one.trans_lt hb), },
end

@[simp] lemma clog_zero_right (b : ℕ) : clog b (0 : R) = 0 :=
clog_of_right_le_zero _ le_rfl

@[simp] lemma clog_one_right (b : ℕ) : clog b (1 : R) = 0 :=
by rw [clog_of_one_le_right _ le_rfl, nat.ceil_one, nat.clog_one_right, int.coe_nat_zero]

lemma clog_zpow {b : ℕ} (hb : 1 < b) (z : ℤ) : clog b (b ^ z : R) = z :=
by rw [←neg_log_inv_eq_clog, ←zpow_neg, log_zpow hb, neg_neg]

@[mono] lemma clog_mono_right {b : ℕ} {r₁ r₂ : R} (h₀ : 0 < r₁) (h : r₁ ≤ r₂) :
  clog b r₁ ≤ clog b r₂ :=
begin
  rw [←neg_log_inv_eq_clog, ←neg_log_inv_eq_clog, neg_le_neg_iff],
  exact log_mono_right (inv_pos.mpr $ h₀.trans_le h) (inv_le_inv_of_le h₀ h),
end

variables (R)
/-- Over suitable subtypes, `int.clog` and `zpow` form a galois insertion -/
def clog_zpow_gi {b : ℕ} (hb : 1 < b) :
  galois_insertion
    (λ r : set.Ioi (0 : R), int.clog b (r : R))
    (λ z : ℤ, ⟨(b : R) ^ z, zpow_pos_of_pos (by exact_mod_cast zero_lt_one.trans hb) z⟩) :=
galois_insertion.monotone_intro
  (λ z₁ z₂ hz, subtype.coe_le_coe.mp $ (zpow_strict_mono $ by exact_mod_cast hb).monotone hz)
  (λ r₁ r₂, clog_mono_right r₁.prop)
  (λ r, subtype.coe_le_coe.mp $ self_le_zpow_clog hb _)
  (λ _, clog_zpow hb _)
variables {R}

/-- `int.clog b` and `zpow b` (almost) form a Galois connection. -/
lemma zpow_lt_iff_lt_clog {b : ℕ} (hb : 1 < b) {x : ℤ} {r : R} (hr : 0 < r) :
  (b : R) ^ x < r ↔ x < clog b r :=
(@galois_connection.lt_iff_lt _ _ _ _ _ _ (clog_zpow_gi R hb).gc ⟨r, hr⟩ x).symm

/-- `int.clog b` and `zpow b` (almost) form a Galois connection. -/
lemma le_zpow_iff_clog_le {b : ℕ} (hb : 1 < b) {x : ℤ} {r : R} (hr : 0 < r) :
  r ≤ (b : R) ^ x ↔ clog b r ≤ x :=
(@galois_connection.le_iff_le _ _ _ _ _ _ (clog_zpow_gi R hb).gc ⟨r, hr⟩ x).symm

end int


<|start_filename|>src/measure_theory/function/jacobian.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.covering.besicovitch_vector_space
import measure_theory.measure.haar_lebesgue
import analysis.normed_space.pointwise
import measure_theory.covering.differentiation
import measure_theory.constructions.polish

/-!
# Change of variables in higher-dimensional integrals

Let `μ` be a Lebesgue measure on a finite-dimensional real vector space `E`.
Let `f : E → E` be a function which is injective and differentiable on a measurable set `s`,
with derivative `f'`. Then we prove that `f '' s` is measurable, and
its measure is given by the formula `μ (f '' s) = ∫⁻ x in s, |(f' x).det| ∂μ` (where `(f' x).det`
is almost everywhere measurable, but not Borel-measurable in general). This formula is proved in
`lintegral_abs_det_fderiv_eq_add_haar_image`. We deduce the change of variables
formula for the Lebesgue and Bochner integrals, in `lintegral_image_eq_lintegral_abs_det_fderiv_mul`
and `integral_image_eq_integral_abs_det_fderiv_smul` respectively.

## Main results

* `add_haar_image_eq_zero_of_differentiable_on_of_add_haar_eq_zero`: if `f` is differentiable on a
  set `s` with zero measure, then `f '' s` also has zero measure.
* `add_haar_image_eq_zero_of_det_fderiv_within_eq_zero`: if `f` is differentiable on a set `s`, and
  its derivative is never invertible, then `f '' s` has zero measure (a version of Sard's lemma).
* `ae_measurable_fderiv_within`: if `f` is differentiable on a measurable set `s`, then `f'`
  is almost everywhere measurable on `s`.

For the next statements, `s` is a measurable set and `f` is differentiable on `s`
(with a derivative `f'`) and injective on `s`.

* `measurable_image_of_fderiv_within`: the image `f '' s` is measurable.
* `measurable_embedding_of_fderiv_within`: the function `s.restrict f` is a measurable embedding.
* `lintegral_abs_det_fderiv_eq_add_haar_image`: the image measure is given by
    `μ (f '' s) = ∫⁻ x in s, |(f' x).det| ∂μ`.
* `lintegral_image_eq_lintegral_abs_det_fderiv_mul`: for `g : E → ℝ≥0∞`, one has
    `∫⁻ x in f '' s, g x ∂μ = ∫⁻ x in s, ennreal.of_real (|(f' x).det|) * g (f x) ∂μ`.
* `integral_image_eq_integral_abs_det_fderiv_smul`: for `g : E → F`, one has
    `∫ x in f '' s, g x ∂μ = ∫ x in s, |(f' x).det| • g (f x) ∂μ`.
* `integrable_on_image_iff_integrable_on_abs_det_fderiv_smul`: for `g : E → F`, the function `g` is
  integrable on `f '' s` if and only if `|(f' x).det| • g (f x))` is integrable on `s`.

## Implementation

Typical versions of these results in the literature have much stronger assumptions: `s` would
typically be open, and the derivative `f' x` would depend continuously on `x` and be invertible
everywhere, to have the local inverse theorem at our disposal. The proof strategy under our weaker
assumptions is more involved. We follow [Fremlin, *Measure Theory* (volume 2)][fremlin_vol2].

The first remark is that, if `f` is sufficiently well approximated by a linear map `A` on a set
`s`, then `f` expands the volume of `s` by at least `A.det - ε` and at most `A.det + ε`, where
the closeness condition depends on `A` in a non-explicit way (see `add_haar_image_le_mul_of_det_lt`
and `mul_le_add_haar_image_of_lt_det`). This fact holds for balls by a simple inclusion argument,
and follows for general sets using the Besicovitch covering theorem to cover the set by balls with
measures adding up essentially to `μ s`.

When `f` is differentiable on `s`, one may partition `s` into countably many subsets `s ∩ t n`
(where `t n` is measurable), on each of which `f` is well approximated by a linear map, so that the
above results apply. See `exists_partition_approximates_linear_on_of_has_fderiv_within_at`, which
follows from the pointwise differentiability (in a non-completely trivial way, as one should ensure
a form of uniformity on the sets of the partition).

Combining the above two results would give the conclusion, except for two difficulties: it is not
obvious why `f '' s` and `f'` should be measurable, which prevents us from using countable
additivity for the measure and the integral. It turns out that `f '' s` is indeed measurable,
and that `f'` is almost everywhere measurable, which is enough to recover countable additivity.

The measurability of `f '' s` follows from the deep Lusin-Souslin theorem ensuring that, in a
Polish space, a continuous injective image of a measurable set is measurable.

The key point to check the almost everywhere measurability of `f'` is that, if `f` is approximated
up to `δ` by a linear map on a set `s`, then `f'` is within `δ` of `A` on a full measure subset
of `s` (namely, its density points). With the above approximation argument, it follows that `f'`
is the almost everywhere limit of a sequence of measurable functions (which are constant on the
pieces of the good discretization), and is therefore almost everywhere measurable.

## Tags
Change of variables in integrals

## References
[Fremlin, *Measure Theory* (volume 2)][fremlin_vol2]
-/

open measure_theory measure_theory.measure metric filter set finite_dimensional asymptotics
topological_space
open_locale nnreal ennreal topological_space pointwise

variables {E F : Type*} [normed_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
[normed_group F] [normed_space ℝ F] {s : set E} {f : E → E} {f' : E → E →L[ℝ] E}

/-!
### Decomposition lemmas

We state lemmas ensuring that a differentiable function can be approximated, on countably many
measurable pieces, by linear maps (with a prescribed precision depending on the linear map).
-/

/-- Assume that a function `f` has a derivative at every point of a set `s`. Then one may cover `s`
with countably many closed sets `t n` on which `f` is well approximated by linear maps `A n`. -/
lemma exists_closed_cover_approximates_linear_on_of_has_fderiv_within_at
  [second_countable_topology F]
  (f : E → F) (s : set E) (f' : E → E →L[ℝ] F) (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x)
  (r : (E →L[ℝ] F) → ℝ≥0) (rpos : ∀ A, r A ≠ 0) :
  ∃ (t : ℕ → set E) (A : ℕ → (E →L[ℝ] F)), (∀ n, is_closed (t n)) ∧ (s ⊆ ⋃ n, t n)
    ∧ (∀ n, approximates_linear_on f (A n) (s ∩ t n) (r (A n)))
    ∧ (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
begin
  /- Choose countably many linear maps `f' z`. For every such map, if `f` has a derivative at `x`
  close enough to `f' z`, then `f y - f x` is well approximated by `f' z (y - x)` for `y` close
  enough to `x`, say on a ball of radius `r` (or even `u n` for some `n`, where `u` is a fixed
  sequence tending to `0`).
  Let `M n z` be the points where this happens. Then this set is relatively closed inside `s`,
  and moreover in every closed ball of radius `u n / 3` inside it the map is well approximated by
  `f' z`. Using countably many closed balls to split `M n z` into small diameter subsets `K n z p`,
  one obtains the desired sets `t q` after reindexing.
  -/
  -- exclude the trivial case where `s` is empty
  rcases eq_empty_or_nonempty s with rfl|hs,
  { refine ⟨λ n, ∅, λ n, 0, _, _, _, _⟩;
    simp },
  -- we will use countably many linear maps. Select these from all the derivatives since the
  -- space of linear maps is second-countable
  obtain ⟨T, T_count, hT⟩ : ∃ T : set s, countable T ∧
    (⋃ x ∈ T, ball (f' (x : E)) (r (f' x))) = ⋃ (x : s), ball (f' x) (r (f' x)) :=
    topological_space.is_open_Union_countable _ (λ x, is_open_ball),
  -- fix a sequence `u` of positive reals tending to zero.
  obtain ⟨u, u_anti, u_pos, u_lim⟩ :
    ∃ (u : ℕ → ℝ), strict_anti u ∧ (∀ (n : ℕ), 0 < u n) ∧ tendsto u at_top (𝓝 0) :=
      exists_seq_strict_anti_tendsto (0 : ℝ),
  -- `M n z` is the set of points `x` such that `f y - f x` is close to `f' z (y - x)` for `y`
  -- in the ball of radius `u n` around `x`.
  let M : ℕ → T → set E := λ n z, {x | x ∈ s ∧
    ∀ y ∈ s ∩ ball x (u n), ∥f y - f x - f' z (y - x)∥ ≤ r (f' z) * ∥y - x∥},
  -- As `f` is differentiable everywhere on `s`, the sets `M n z` cover `s` by design.
  have s_subset : ∀ x ∈ s, ∃ (n : ℕ) (z : T), x ∈ M n z,
  { assume x xs,
    obtain ⟨z, zT, hz⟩ : ∃ z ∈ T, f' x ∈ ball (f' (z : E)) (r (f' z)),
    { have : f' x ∈ ⋃ (z ∈ T), ball (f' (z : E)) (r (f' z)),
      { rw hT,
        refine mem_Union.2 ⟨⟨x, xs⟩, _⟩,
        simpa only [mem_ball, subtype.coe_mk, dist_self] using (rpos (f' x)).bot_lt },
      rwa mem_Union₂ at this },
    obtain ⟨ε, εpos, hε⟩ : ∃ (ε : ℝ), 0 < ε ∧ ∥f' x - f' z∥ + ε ≤ r (f' z),
    { refine ⟨r (f' z) - ∥f' x - f' z∥, _, le_of_eq (by abel)⟩,
      simpa only [sub_pos] using mem_ball_iff_norm.mp hz },
    obtain ⟨δ, δpos, hδ⟩ : ∃ (δ : ℝ) (H : 0 < δ),
      ball x δ ∩ s ⊆ {y | ∥f y - f x - (f' x) (y - x)∥ ≤ ε * ∥y - x∥} :=
        metric.mem_nhds_within_iff.1 (is_o.def (hf' x xs) εpos),
    obtain ⟨n, hn⟩ : ∃ n, u n < δ := ((tendsto_order.1 u_lim).2 _ δpos).exists,
    refine ⟨n, ⟨z, zT⟩, ⟨xs, _⟩⟩,
    assume y hy,
    calc ∥f y - f x - (f' z) (y - x)∥
        = ∥(f y - f x - (f' x) (y - x)) + (f' x - f' z) (y - x)∥ :
      begin
        congr' 1,
        simp only [continuous_linear_map.coe_sub', map_sub, pi.sub_apply],
        abel,
      end
    ... ≤ ∥f y - f x - (f' x) (y - x)∥ + ∥(f' x - f' z) (y - x)∥ : norm_add_le _ _
    ... ≤ ε * ∥y - x∥ + ∥f' x - f' z∥ * ∥y - x∥ :
      begin
        refine add_le_add (hδ _) (continuous_linear_map.le_op_norm _ _),
        rw inter_comm,
        exact inter_subset_inter_right _ (ball_subset_ball hn.le) hy,
      end
    ... ≤ r (f' z) * ∥y - x∥ :
      begin
        rw [← add_mul, add_comm],
        exact mul_le_mul_of_nonneg_right hε (norm_nonneg _),
      end },
  -- the sets `M n z` are relatively closed in `s`, as all the conditions defining it are clearly
  -- closed
  have closure_M_subset : ∀ n z, s ∩ closure (M n z) ⊆ M n z,
  { rintros n z x ⟨xs, hx⟩,
    refine ⟨xs, λ y hy, _⟩,
    obtain ⟨a, aM, a_lim⟩ : ∃ (a : ℕ → E), (∀ k, a k ∈ M n z) ∧ tendsto a at_top (𝓝 x) :=
      mem_closure_iff_seq_limit.1 hx,
    have L1 : tendsto (λ (k : ℕ), ∥f y - f (a k) - (f' z) (y - a k)∥) at_top
      (𝓝 ∥f y - f x - (f' z) (y - x)∥),
    { apply tendsto.norm,
      have L : tendsto (λ k, f (a k)) at_top (𝓝 (f x)),
      { apply (hf' x xs).continuous_within_at.tendsto.comp,
        apply tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ a_lim,
        exact eventually_of_forall (λ k, (aM k).1) },
      apply tendsto.sub (tendsto_const_nhds.sub L),
      exact ((f' z).continuous.tendsto _).comp (tendsto_const_nhds.sub a_lim) },
    have L2 : tendsto (λ (k : ℕ), (r (f' z) : ℝ) * ∥y - a k∥) at_top (𝓝 (r (f' z) * ∥y - x∥)) :=
      (tendsto_const_nhds.sub a_lim).norm.const_mul _,
    have I : ∀ᶠ k in at_top, ∥f y - f (a k) - (f' z) (y - a k)∥ ≤ r (f' z) * ∥y - a k∥,
    { have L : tendsto (λ k, dist y (a k)) at_top (𝓝 (dist y x)) := tendsto_const_nhds.dist a_lim,
      filter_upwards [(tendsto_order.1 L).2 _ hy.2],
      assume k hk,
      exact (aM k).2 y ⟨hy.1, hk⟩ },
    exact le_of_tendsto_of_tendsto L1 L2 I },
  -- choose a dense sequence `d p`
  rcases topological_space.exists_dense_seq E with ⟨d, hd⟩,
  -- split `M n z` into subsets `K n z p` of small diameters by intersecting with the ball
  -- `closed_ball (d p) (u n / 3)`.
  let K : ℕ → T → ℕ → set E := λ n z p, closure (M n z) ∩ closed_ball (d p) (u n / 3),
  -- on the sets `K n z p`, the map `f` is well approximated by `f' z` by design.
  have K_approx : ∀ n (z : T) p, approximates_linear_on f (f' z) (s ∩ K n z p) (r (f' z)),
  { assume n z p x hx y hy,
    have yM : y ∈ M n z := closure_M_subset _ _ ⟨hy.1, hy.2.1⟩,
    refine yM.2 _ ⟨hx.1, _⟩,
    calc dist x y ≤ dist x (d p) + dist y (d p) : dist_triangle_right _ _ _
    ... ≤ u n / 3 + u n / 3 : add_le_add hx.2.2 hy.2.2
    ... < u n : by linarith [u_pos n] },
  -- the sets `K n z p` are also closed, again by design.
  have K_closed : ∀ n (z : T) p, is_closed (K n z p) :=
    λ n z p, is_closed_closure.inter is_closed_ball,
  -- reindex the sets `K n z p`, to let them only depend on an integer parameter `q`.
  obtain ⟨F, hF⟩ : ∃ F : ℕ → ℕ × T × ℕ, function.surjective F,
  { haveI : encodable T := T_count.to_encodable,
    haveI : nonempty T,
    { unfreezingI { rcases eq_empty_or_nonempty T with rfl|hT },
      { rcases hs with ⟨x, xs⟩,
        rcases s_subset x xs with ⟨n, z, hnz⟩,
        exact false.elim z.2 },
      { exact (nonempty_coe_sort _).2 hT } },
    inhabit (ℕ × T × ℕ),
    exact ⟨_, encodable.surjective_decode_iget _⟩ },
  -- these sets `t q = K n z p` will do
  refine ⟨λ q, K (F q).1 (F q).2.1 (F q).2.2, λ q, f' (F q).2.1, λ n, K_closed _ _ _, λ x xs, _,
    λ q, K_approx _ _ _, λ h's q, ⟨(F q).2.1, (F q).2.1.1.2, rfl⟩⟩,
  -- the only fact that needs further checking is that they cover `s`.
  -- we already know that any point `x ∈ s` belongs to a set `M n z`.
  obtain ⟨n, z, hnz⟩ : ∃ (n : ℕ) (z : T), x ∈ M n z := s_subset x xs,
  -- by density, it also belongs to a ball `closed_ball (d p) (u n / 3)`.
  obtain ⟨p, hp⟩ : ∃ (p : ℕ), x ∈ closed_ball (d p) (u n / 3),
  { have : set.nonempty (ball x (u n / 3)),
    { simp only [nonempty_ball], linarith [u_pos n] },
    obtain ⟨p, hp⟩ : ∃ (p : ℕ), d p ∈ ball x (u n / 3) := hd.exists_mem_open is_open_ball this,
    exact ⟨p, (mem_ball'.1 hp).le⟩ },
  -- choose `q` for which `t q = K n z p`.
  obtain ⟨q, hq⟩ : ∃ q, F q = (n, z, p) := hF _,
  -- then `x` belongs to `t q`.
  apply mem_Union.2 ⟨q, _⟩,
  simp only [hq, subset_closure hnz, hp, mem_inter_eq, and_self],
end

variables [measurable_space E] [borel_space E] (μ : measure E) [is_add_haar_measure μ]

/-- Assume that a function `f` has a derivative at every point of a set `s`. Then one may
partition `s` into countably many disjoint relatively measurable sets (i.e., intersections
of `s` with measurable sets `t n`) on which `f` is well approximated by linear maps `A n`. -/
lemma exists_partition_approximates_linear_on_of_has_fderiv_within_at
  [second_countable_topology F]
  (f : E → F) (s : set E) (f' : E → E →L[ℝ] F) (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x)
  (r : (E →L[ℝ] F) → ℝ≥0) (rpos : ∀ A, r A ≠ 0) :
  ∃ (t : ℕ → set E) (A : ℕ → (E →L[ℝ] F)), pairwise (disjoint on t)
    ∧ (∀ n, measurable_set (t n)) ∧ (s ⊆ ⋃ n, t n)
    ∧ (∀ n, approximates_linear_on f (A n) (s ∩ t n) (r (A n)))
    ∧ (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
begin
  rcases exists_closed_cover_approximates_linear_on_of_has_fderiv_within_at f s f' hf' r rpos
    with ⟨t, A, t_closed, st, t_approx, ht⟩,
  refine ⟨disjointed t, A, disjoint_disjointed _,
          measurable_set.disjointed (λ n, (t_closed n).measurable_set), _, _, ht⟩,
  { rw Union_disjointed, exact st },
  { assume n, exact (t_approx n).mono_set (inter_subset_inter_right _ (disjointed_subset _ _)) },
end

namespace measure_theory

/-!
### Local lemmas

We check that a function which is well enough approximated by a linear map expands the volume
essentially like this linear map, and that its derivative (if it exists) is almost everywhere close
to the approximating linear map.
-/

/-- Let `f` be a function which is sufficiently close (in the Lipschitz sense) to a given linear
map `A`. Then it expands the volume of any set by at most `m` for any `m > det A`. -/
lemma add_haar_image_le_mul_of_det_lt
  (A : E →L[ℝ] E) {m : ℝ≥0} (hm : ennreal.of_real (|A.det|) < m) :
  ∀ᶠ δ in 𝓝[>] (0 : ℝ≥0), ∀ (s : set E) (f : E → E) (hf : approximates_linear_on f A s δ),
  μ (f '' s) ≤ m * μ s :=
begin
  apply nhds_within_le_nhds,
  let d := ennreal.of_real (|A.det|),
  -- construct a small neighborhood of `A '' (closed_ball 0 1)` with measure comparable to
  -- the determinant of `A`.
  obtain ⟨ε, hε, εpos⟩ : ∃ (ε : ℝ),
    μ (closed_ball 0 ε + A '' (closed_ball 0 1)) < m * μ (closed_ball 0 1) ∧ 0 < ε,
  { have HC : is_compact (A '' closed_ball 0 1) :=
      (proper_space.is_compact_closed_ball _ _).image A.continuous,
    have L0 : tendsto (λ ε, μ (cthickening ε (A '' (closed_ball 0 1))))
      (𝓝[>] 0) (𝓝 (μ (A '' (closed_ball 0 1)))),
    { apply tendsto.mono_left _ nhds_within_le_nhds,
      exact tendsto_measure_cthickening_of_is_compact HC },
    have L1 : tendsto (λ ε, μ (closed_ball 0 ε + A '' (closed_ball 0 1)))
      (𝓝[>] 0) (𝓝 (μ (A '' (closed_ball 0 1)))),
    { apply L0.congr' _,
      filter_upwards [self_mem_nhds_within] with r hr,
      rw [←HC.add_closed_ball_zero (le_of_lt hr), add_comm] },
    have L2 : tendsto (λ ε, μ (closed_ball 0 ε + A '' (closed_ball 0 1)))
      (𝓝[>] 0) (𝓝 (d * μ (closed_ball 0 1))),
    { convert L1,
      exact (add_haar_image_continuous_linear_map _ _ _).symm },
    have I : d * μ (closed_ball 0 1) < m * μ (closed_ball 0 1) :=
      (ennreal.mul_lt_mul_right ((measure_closed_ball_pos μ _ zero_lt_one).ne')
        measure_closed_ball_lt_top.ne).2 hm,
    have H : ∀ᶠ (b : ℝ) in 𝓝[>] 0,
      μ (closed_ball 0 b + A '' closed_ball 0 1) < m * μ (closed_ball 0 1) :=
        (tendsto_order.1 L2).2 _ I,
    exact (H.and self_mem_nhds_within).exists },
  have : Iio (⟨ε, εpos.le⟩ : ℝ≥0) ∈ 𝓝 (0 : ℝ≥0), { apply Iio_mem_nhds, exact εpos },
  filter_upwards [this],
  -- fix a function `f` which is close enough to `A`.
  assume δ hδ s f hf,
  -- This function expands the volume of any ball by at most `m`
  have I : ∀ x r, x ∈ s → 0 ≤ r → μ (f '' (s ∩ closed_ball x r)) ≤ m * μ (closed_ball x r),
  { assume x r xs r0,
    have K : f '' (s ∩ closed_ball x r) ⊆ A '' (closed_ball 0 r) + closed_ball (f x) (ε * r),
    { rintros y ⟨z, ⟨zs, zr⟩, rfl⟩,
      apply set.mem_add.2 ⟨A (z - x), f z - f x - A (z - x) + f x, _, _, _⟩,
      { apply mem_image_of_mem,
        simpa only [dist_eq_norm, mem_closed_ball, mem_closed_ball_zero_iff] using zr },
      { rw [mem_closed_ball_iff_norm, add_sub_cancel],
        calc ∥f z - f x - A (z - x)∥
            ≤ δ * ∥z - x∥ : hf _ zs _ xs
        ... ≤ ε * r :
          mul_le_mul (le_of_lt hδ) (mem_closed_ball_iff_norm.1 zr) (norm_nonneg _) εpos.le },
      { simp only [map_sub, pi.sub_apply],
        abel } },
    have : A '' (closed_ball 0 r) + closed_ball (f x) (ε * r)
      = {f x} + r • (A '' (closed_ball 0 1) + closed_ball 0 ε),
      by rw [smul_add, ← add_assoc, add_comm ({f x}), add_assoc, smul_closed_ball _ _ εpos.le,
        smul_zero, singleton_add_closed_ball_zero, ← A.image_smul_set,
        smul_closed_ball _ _ zero_le_one, smul_zero, real.norm_eq_abs, abs_of_nonneg r0, mul_one,
        mul_comm],
    rw this at K,
    calc μ (f '' (s ∩ closed_ball x r))
        ≤ μ ({f x} + r • (A '' (closed_ball 0 1) + closed_ball 0 ε)) : measure_mono K
    ... = ennreal.of_real (r ^ finrank ℝ E) * μ (A '' closed_ball 0 1 + closed_ball 0 ε) :
      by simp only [abs_of_nonneg r0, add_haar_smul, image_add_left, abs_pow, singleton_add,
                    measure_preimage_add]
    ... ≤ ennreal.of_real (r ^ finrank ℝ E) * (m * μ (closed_ball 0 1)) :
      by { rw add_comm, exact ennreal.mul_le_mul le_rfl hε.le }
    ... = m * μ (closed_ball x r) :
      by { simp only [add_haar_closed_ball' _ _ r0], ring } },
  -- covering `s` by closed balls with total measure very close to `μ s`, one deduces that the
  -- measure of `f '' s` is at most `m * (μ s + a)` for any positive `a`.
  have J : ∀ᶠ a in 𝓝[>] (0 : ℝ≥0∞), μ (f '' s) ≤ m * (μ s + a),
  { filter_upwards [self_mem_nhds_within] with a ha,
    change 0 < a at ha,
    obtain ⟨t, r, t_count, ts, rpos, st, μt⟩ : ∃ (t : set E) (r : E → ℝ), t.countable ∧ t ⊆ s
      ∧ (∀ (x : E), x ∈ t → 0 < r x) ∧ (s ⊆ ⋃ (x ∈ t), closed_ball x (r x))
      ∧ ∑' (x : ↥t), μ (closed_ball ↑x (r ↑x)) ≤ μ s + a :=
        besicovitch.exists_closed_ball_covering_tsum_measure_le μ ha.ne' (λ x, Ioi 0) s
        (λ x xs δ δpos, ⟨δ/2, by simp [half_pos δpos, half_lt_self δpos]⟩),
    haveI : encodable t := t_count.to_encodable,
    calc μ (f '' s)
        ≤ μ (⋃ (x : t), f '' (s ∩ closed_ball x (r x))) :
      begin
        rw bUnion_eq_Union at st,
        apply measure_mono,
        rw [← image_Union, ← inter_Union],
        exact image_subset _ (subset_inter (subset.refl _) st)
      end
    ... ≤ ∑' (x : t), μ (f '' (s ∩ closed_ball x (r x))) : measure_Union_le _
    ... ≤ ∑' (x : t), m * μ (closed_ball x (r x)) :
      ennreal.tsum_le_tsum (λ x, I x (r x) (ts x.2) (rpos x x.2).le)
    ... ≤ m * (μ s + a) :
      by { rw ennreal.tsum_mul_left, exact ennreal.mul_le_mul le_rfl μt } },
  -- taking the limit in `a`, one obtains the conclusion
  have L : tendsto (λ a, (m : ℝ≥0∞) * (μ s + a)) (𝓝[>] 0) (𝓝 (m * (μ s + 0))),
  { apply tendsto.mono_left _ nhds_within_le_nhds,
    apply ennreal.tendsto.const_mul (tendsto_const_nhds.add tendsto_id),
    simp only [ennreal.coe_ne_top, ne.def, or_true, not_false_iff] },
  rw add_zero at L,
  exact ge_of_tendsto L J,
end

/-- Let `f` be a function which is sufficiently close (in the Lipschitz sense) to a given linear
map `A`. Then it expands the volume of any set by at least `m` for any `m < det A`. -/
lemma mul_le_add_haar_image_of_lt_det
  (A : E →L[ℝ] E) {m : ℝ≥0} (hm : (m : ℝ≥0∞) < ennreal.of_real (|A.det|)) :
  ∀ᶠ δ in 𝓝[>] (0 : ℝ≥0), ∀ (s : set E) (f : E → E) (hf : approximates_linear_on f A s δ),
  (m : ℝ≥0∞) * μ s ≤ μ (f '' s) :=
begin
  apply nhds_within_le_nhds,
  -- The assumption `hm` implies that `A` is invertible. If `f` is close enough to `A`, it is also
  -- invertible. One can then pass to the inverses, and deduce the estimate from
  -- `add_haar_image_le_mul_of_det_lt` applied to `f⁻¹` and `A⁻¹`.
  -- exclude first the trivial case where `m = 0`.
  rcases eq_or_lt_of_le (zero_le m) with rfl|mpos,
  { apply eventually_of_forall,
    simp only [forall_const, zero_mul, implies_true_iff, zero_le, ennreal.coe_zero] },
  have hA : A.det ≠ 0,
  { assume h, simpa only [h, ennreal.not_lt_zero, ennreal.of_real_zero, abs_zero] using hm },
  -- let `B` be the continuous linear equiv version of `A`.
  let B := A.to_continuous_linear_equiv_of_det_ne_zero hA,
  -- the determinant of `B.symm` is bounded by `m⁻¹`
  have I : ennreal.of_real (|(B.symm : E →L[ℝ] E).det|) < (m⁻¹ : ℝ≥0),
  { simp only [ennreal.of_real, abs_inv, real.to_nnreal_inv, continuous_linear_equiv.det_coe_symm,
      continuous_linear_map.coe_to_continuous_linear_equiv_of_det_ne_zero, ennreal.coe_lt_coe]
      at ⊢ hm,
    exact nnreal.inv_lt_inv mpos.ne' hm },
  -- therefore, we may apply `add_haar_image_le_mul_of_det_lt` to `B.symm` and `m⁻¹`.
  obtain ⟨δ₀, δ₀pos, hδ₀⟩ : ∃ (δ : ℝ≥0), 0 < δ ∧ ∀ (t : set E) (g : E → E),
    approximates_linear_on g (B.symm : E →L[ℝ] E) t δ → μ (g '' t) ≤ ↑m⁻¹ * μ t,
  { have : ∀ᶠ (δ : ℝ≥0) in 𝓝[>] 0, ∀ (t : set E) (g : E → E),
      approximates_linear_on g (B.symm : E →L[ℝ] E) t δ → μ (g '' t) ≤ ↑m⁻¹ * μ t :=
        add_haar_image_le_mul_of_det_lt μ B.symm I,
    rcases (this.and self_mem_nhds_within).exists with ⟨δ₀, h, h'⟩,
    exact ⟨δ₀, h', h⟩, },
  -- record smallness conditions for `δ` that will be needed to apply `hδ₀` below.
  have L1 : ∀ᶠ δ in 𝓝 (0 : ℝ≥0), subsingleton E ∨ δ < ∥(B.symm : E →L[ℝ] E)∥₊⁻¹,
  { by_cases (subsingleton E),
    { simp only [h, true_or, eventually_const] },
    simp only [h, false_or],
    apply Iio_mem_nhds,
    simpa only [h, false_or, nnreal.inv_pos] using B.subsingleton_or_nnnorm_symm_pos },
  have L2 : ∀ᶠ δ in 𝓝 (0 : ℝ≥0),
    ∥(B.symm : E →L[ℝ] E)∥₊ * (∥(B.symm : E →L[ℝ] E)∥₊⁻¹ - δ)⁻¹ * δ < δ₀,
  { have : tendsto (λ δ, ∥(B.symm : E →L[ℝ] E)∥₊ * (∥(B.symm : E →L[ℝ] E)∥₊⁻¹ - δ)⁻¹ * δ)
      (𝓝 0) (𝓝 (∥(B.symm : E →L[ℝ] E)∥₊ * (∥(B.symm : E →L[ℝ] E)∥₊⁻¹ - 0)⁻¹ * 0)),
    { rcases eq_or_ne (∥(B.symm : E →L[ℝ] E)∥₊) 0 with H|H,
      { simpa only [H, zero_mul] using tendsto_const_nhds },
      refine tendsto.mul (tendsto_const_nhds.mul _) tendsto_id,
      refine (tendsto.sub tendsto_const_nhds tendsto_id).inv₀ _,
      simpa only [tsub_zero, inv_eq_zero, ne.def] using H },
    simp only [mul_zero] at this,
    exact (tendsto_order.1 this).2 δ₀ δ₀pos },
  -- let `δ` be small enough, and `f` approximated by `B` up to `δ`.
  filter_upwards [L1, L2],
  assume δ h1δ h2δ s f hf,
  have hf' : approximates_linear_on f (B : E →L[ℝ] E) s δ,
    by { convert hf, exact A.coe_to_continuous_linear_equiv_of_det_ne_zero _ },
  let F := hf'.to_local_equiv h1δ,
  -- the condition to be checked can be reformulated in terms of the inverse maps
  suffices H : μ ((F.symm) '' F.target) ≤ (m⁻¹ : ℝ≥0) * μ F.target,
  { change (m : ℝ≥0∞) * μ (F.source) ≤ μ (F.target),
    rwa [← F.symm_image_target_eq_source, mul_comm, ← ennreal.le_div_iff_mul_le, div_eq_mul_inv,
         mul_comm, ← ennreal.coe_inv (mpos.ne')],
    { apply or.inl,
      simpa only [ennreal.coe_eq_zero, ne.def] using mpos.ne'},
    { simp only [ennreal.coe_ne_top, true_or, ne.def, not_false_iff] } },
  -- as `f⁻¹` is well approximated by `B⁻¹`, the conclusion follows from `hδ₀`
  -- and our choice of `δ`.
  exact hδ₀ _ _ ((hf'.to_inv h1δ).mono_num h2δ.le),
end

/-- If a differentiable function `f` is approximated by a linear map `A` on a set `s`, up to `δ`,
then at almost every `x` in `s` one has `∥f' x - A∥ ≤ δ`. -/
lemma _root_.approximates_linear_on.norm_fderiv_sub_le
  {A : E →L[ℝ] E} {δ : ℝ≥0}
  (hf : approximates_linear_on f A s δ) (hs : measurable_set s)
  (f' : E → E →L[ℝ] E) (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) :
  ∀ᵐ x ∂(μ.restrict s), ∥f' x - A∥₊ ≤ δ :=
begin
  /- The conclusion will hold at the Lebesgue density points of `s` (which have full measure).
  At such a point `x`, for any `z` and any `ε > 0` one has for small `r`
  that `{x} + r • closed_ball z ε` intersects `s`. At a point `y` in the intersection,
  `f y - f x` is close both to `f' x (r z)` (by differentiability) and to `A (r z)`
  (by linear approximation), so these two quantities are close, i.e., `(f' x - A) z` is small. -/
  filter_upwards [besicovitch.ae_tendsto_measure_inter_div μ s, ae_restrict_mem hs],
  -- start from a Lebesgue density point `x`, belonging to `s`.
  assume x hx xs,
  -- consider an arbitrary vector `z`.
  apply continuous_linear_map.op_norm_le_bound _ δ.2 (λ z, _),
  -- to show that `∥(f' x - A) z∥ ≤ δ ∥z∥`, it suffices to do it up to some error that vanishes
  -- asymptotically in terms of `ε > 0`.
  suffices H : ∀ ε, 0 < ε → ∥(f' x - A) z∥ ≤ (δ + ε) * (∥z∥ + ε) + ∥(f' x - A)∥ * ε,
  { have : tendsto (λ (ε : ℝ), ((δ : ℝ) + ε) * (∥z∥ + ε) + ∥(f' x - A)∥ * ε) (𝓝[>] 0)
      (𝓝 ((δ + 0) * (∥z∥ + 0) + ∥(f' x - A)∥ * 0)) :=
        tendsto.mono_left (continuous.tendsto (by continuity) 0) nhds_within_le_nhds,
    simp only [add_zero, mul_zero] at this,
    apply le_of_tendsto_of_tendsto tendsto_const_nhds this,
    filter_upwards [self_mem_nhds_within],
    exact H },
  -- fix a positive `ε`.
  assume ε εpos,
  -- for small enough `r`, the rescaled ball `r • closed_ball z ε` intersects `s`, as `x` is a
  -- density point
  have B₁ : ∀ᶠ r in 𝓝[>] (0 : ℝ), (s ∩ ({x} + r • closed_ball z ε)).nonempty :=
    eventually_nonempty_inter_smul_of_density_one μ s x hx
      _ measurable_set_closed_ball (measure_closed_ball_pos μ z εpos).ne',
  obtain ⟨ρ, ρpos, hρ⟩ :
    ∃ ρ > 0, ball x ρ ∩ s ⊆ {y : E | ∥f y - f x - (f' x) (y - x)∥ ≤ ε * ∥y - x∥} :=
      mem_nhds_within_iff.1 (is_o.def (hf' x xs) εpos),
  -- for small enough `r`, the rescaled ball `r • closed_ball z ε` is included in the set where
  -- `f y - f x` is well approximated by `f' x (y - x)`.
  have B₂ : ∀ᶠ r in 𝓝[>] (0 : ℝ), {x} + r • closed_ball z ε ⊆ ball x ρ := nhds_within_le_nhds
    (eventually_singleton_add_smul_subset bounded_closed_ball (ball_mem_nhds x ρpos)),
  -- fix a small positive `r` satisfying the above properties, as well as a corresponding `y`.
  obtain ⟨r, ⟨y, ⟨ys, hy⟩⟩, rρ, rpos⟩ : ∃ (r : ℝ), (s ∩ ({x} + r • closed_ball z ε)).nonempty ∧
    {x} + r • closed_ball z ε ⊆ ball x ρ ∧ 0 < r := (B₁.and (B₂.and self_mem_nhds_within)).exists,
  -- write `y = x + r a` with `a ∈ closed_ball z ε`.
  obtain ⟨a, az, ya⟩ : ∃ a, a ∈ closed_ball z ε ∧ y = x + r • a,
  { simp only [mem_smul_set, image_add_left, mem_preimage, singleton_add] at hy,
    rcases hy with ⟨a, az, ha⟩,
    exact ⟨a, az, by simp only [ha, add_neg_cancel_left]⟩ },
  have norm_a : ∥a∥ ≤ ∥z∥ + ε := calc
    ∥a∥ = ∥z + (a - z)∥ : by simp only [add_sub_cancel'_right]
    ... ≤ ∥z∥ + ∥a - z∥ : norm_add_le _ _
    ... ≤ ∥z∥ + ε : add_le_add_left (mem_closed_ball_iff_norm.1 az) _,
  -- use the approximation properties to control `(f' x - A) a`, and then `(f' x - A) z` as `z` is
  -- close to `a`.
  have I : r * ∥(f' x - A) a∥ ≤ r * (δ + ε) * (∥z∥ + ε) := calc
    r * ∥(f' x - A) a∥ = ∥(f' x - A) (r • a)∥ :
      by simp only [continuous_linear_map.map_smul, norm_smul, real.norm_eq_abs,
                    abs_of_nonneg rpos.le]
    ... = ∥(f y - f x - A (y - x)) -
            (f y - f x - (f' x) (y - x))∥ :
      begin
        congr' 1,
        simp only [ya, add_sub_cancel', sub_sub_sub_cancel_left, continuous_linear_map.coe_sub',
          eq_self_iff_true, sub_left_inj, pi.sub_apply, continuous_linear_map.map_smul, smul_sub],
      end
    ... ≤ ∥f y - f x - A (y - x)∥ +
             ∥f y - f x - (f' x) (y - x)∥ : norm_sub_le _ _
    ... ≤ δ * ∥y - x∥ + ε * ∥y - x∥ :
      add_le_add (hf _ ys _ xs) (hρ ⟨rρ hy, ys⟩)
    ... = r * (δ + ε) * ∥a∥ :
      by { simp only [ya, add_sub_cancel', norm_smul, real.norm_eq_abs, abs_of_nonneg rpos.le],
           ring }
    ... ≤ r * (δ + ε) * (∥z∥ + ε) :
      mul_le_mul_of_nonneg_left norm_a (mul_nonneg rpos.le (add_nonneg δ.2 εpos.le)),
  show ∥(f' x - A) z∥ ≤ (δ + ε) * (∥z∥ + ε) + ∥(f' x - A)∥ * ε, from calc
    ∥(f' x - A) z∥ = ∥(f' x - A) a + (f' x - A) (z - a)∥ :
      begin
        congr' 1,
        simp only [continuous_linear_map.coe_sub', map_sub, pi.sub_apply],
        abel
      end
    ... ≤ ∥(f' x - A) a∥ + ∥(f' x - A) (z - a)∥ : norm_add_le _ _
    ... ≤ (δ + ε) * (∥z∥ + ε) + ∥f' x - A∥ * ∥z - a∥ :
      begin
        apply add_le_add,
        { rw mul_assoc at I, exact (mul_le_mul_left rpos).1 I },
        { apply continuous_linear_map.le_op_norm }
      end
    ... ≤ (δ + ε) * (∥z∥ + ε) + ∥f' x - A∥ * ε : add_le_add le_rfl
      (mul_le_mul_of_nonneg_left (mem_closed_ball_iff_norm'.1 az) (norm_nonneg _)),
end

/-!
### Measure zero of the image, over non-measurable sets

If a set has measure `0`, then its image under a differentiable map has measure zero. This doesn't
require the set to be measurable. In the same way, if `f` is differentiable on a set `s` with
non-invertible derivative everywhere, then `f '' s` has measure `0`, again without measurability
assumptions.
-/

/-- A differentiable function maps sets of measure zero to sets of measure zero. -/
lemma add_haar_image_eq_zero_of_differentiable_on_of_add_haar_eq_zero
  (hf : differentiable_on ℝ f s) (hs : μ s = 0) :
  μ (f '' s) = 0 :=
begin
  refine le_antisymm _ (zero_le _),
  have : ∀ (A : E →L[ℝ] E), ∃ (δ : ℝ≥0), 0 < δ ∧ ∀ (t : set E)
    (hf : approximates_linear_on f A t δ), μ (f '' t) ≤ (real.to_nnreal (|A.det|) + 1 : ℝ≥0) * μ t,
  { assume A,
    let m : ℝ≥0 := real.to_nnreal ((|A.det|)) + 1,
    have I : ennreal.of_real (|A.det|) < m,
      by simp only [ennreal.of_real, m, lt_add_iff_pos_right, zero_lt_one, ennreal.coe_lt_coe],
    rcases ((add_haar_image_le_mul_of_det_lt μ A I).and self_mem_nhds_within).exists
      with ⟨δ, h, h'⟩,
    exact ⟨δ, h', λ t ht, h t f ht⟩ },
  choose δ hδ using this,
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, -⟩ : ∃ (t : ℕ → set E) (A : ℕ → (E →L[ℝ] E)),
    pairwise (disjoint on t) ∧ (∀ (n : ℕ), measurable_set (t n)) ∧ (s ⊆ ⋃ (n : ℕ), t n)
    ∧ (∀ (n : ℕ), approximates_linear_on f (A n) (s ∩ t n) (δ (A n)))
    ∧ (s.nonempty → ∀ n, ∃ y ∈ s, A n = fderiv_within ℝ f s y) :=
        exists_partition_approximates_linear_on_of_has_fderiv_within_at f s
        (fderiv_within ℝ f s) (λ x xs, (hf x xs).has_fderiv_within_at) δ (λ A, (hδ A).1.ne'),
  calc μ (f '' s)
      ≤ μ (⋃ n, f '' (s ∩ t n)) :
    begin
      apply measure_mono,
      rw [← image_Union, ← inter_Union],
      exact image_subset f (subset_inter subset.rfl t_cover)
    end
  ... ≤ ∑' n, μ (f '' (s ∩ t n)) : measure_Union_le _
  ... ≤ ∑' n, (real.to_nnreal (|(A n).det|) + 1 : ℝ≥0) * μ (s ∩ t n) :
    begin
      apply ennreal.tsum_le_tsum (λ n, _),
      apply (hδ (A n)).2,
      exact ht n,
    end
  ... ≤ ∑' n, (real.to_nnreal (|(A n).det|) + 1 : ℝ≥0) * 0 :
    begin
      refine ennreal.tsum_le_tsum (λ n, ennreal.mul_le_mul le_rfl _),
      exact le_trans (measure_mono (inter_subset_left _ _)) (le_of_eq hs),
    end
  ... = 0 : by simp only [tsum_zero, mul_zero]
end

/-- A version of Sard lemma in fixed dimension: given a differentiable function from `E` to `E` and
a set where the differential is not invertible, then the image of this set has zero measure.
Here, we give an auxiliary statement towards this result. -/
lemma add_haar_image_eq_zero_of_det_fderiv_within_eq_zero_aux
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x)
  (R : ℝ) (hs : s ⊆ closed_ball 0 R) (ε : ℝ≥0) (εpos : 0 < ε)
  (h'f' : ∀ x ∈ s, (f' x).det = 0) :
  μ (f '' s) ≤ ε * μ (closed_ball 0 R) :=
begin
  rcases eq_empty_or_nonempty s with rfl|h's, { simp only [measure_empty, zero_le, image_empty] },
  have : ∀ (A : E →L[ℝ] E), ∃ (δ : ℝ≥0), 0 < δ ∧ ∀ (t : set E)
    (hf : approximates_linear_on f A t δ), μ (f '' t) ≤ (real.to_nnreal (|A.det|) + ε : ℝ≥0) * μ t,
  { assume A,
    let m : ℝ≥0 := real.to_nnreal (|A.det|) + ε,
    have I : ennreal.of_real (|A.det|) < m,
      by simp only [ennreal.of_real, m, lt_add_iff_pos_right, εpos, ennreal.coe_lt_coe],
    rcases ((add_haar_image_le_mul_of_det_lt μ A I).and self_mem_nhds_within).exists
      with ⟨δ, h, h'⟩,
    exact ⟨δ, h', λ t ht, h t f ht⟩ },
  choose δ hδ using this,
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, Af'⟩ : ∃ (t : ℕ → set E) (A : ℕ → (E →L[ℝ] E)),
    pairwise (disjoint on t) ∧ (∀ (n : ℕ), measurable_set (t n)) ∧ (s ⊆ ⋃ (n : ℕ), t n)
    ∧ (∀ (n : ℕ), approximates_linear_on f (A n) (s ∩ t n) (δ (A n)))
    ∧  (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
      exists_partition_approximates_linear_on_of_has_fderiv_within_at f s
      f' hf' δ (λ A, (hδ A).1.ne'),
  calc μ (f '' s)
      ≤ μ (⋃ n, f '' (s ∩ t n)) :
    begin
      apply measure_mono,
      rw [← image_Union, ← inter_Union],
      exact image_subset f (subset_inter subset.rfl t_cover)
    end
  ... ≤ ∑' n, μ (f '' (s ∩ t n)) : measure_Union_le _
  ... ≤ ∑' n, (real.to_nnreal (|(A n).det|) + ε : ℝ≥0) * μ (s ∩ t n) :
    begin
      apply ennreal.tsum_le_tsum (λ n, _),
      apply (hδ (A n)).2,
      exact ht n,
    end
  ... = ∑' n, ε * μ (s ∩ t n) :
    begin
      congr' with n,
      rcases Af' h's n with ⟨y, ys, hy⟩,
      simp only [hy, h'f' y ys, real.to_nnreal_zero, abs_zero, zero_add]
    end
  ... ≤ ε * ∑' n, μ (closed_ball 0 R ∩ t n) :
    begin
      rw ennreal.tsum_mul_left,
      refine ennreal.mul_le_mul le_rfl (ennreal.tsum_le_tsum (λ n, measure_mono _)),
      exact inter_subset_inter_left _ hs,
    end
  ... = ε * μ (⋃ n, closed_ball 0 R ∩ t n) :
    begin
      rw measure_Union,
      { exact pairwise_disjoint.mono t_disj (λ n, inter_subset_right _ _) },
      { assume n,
        exact measurable_set_closed_ball.inter (t_meas n) }
    end
  ... ≤ ε * μ (closed_ball 0 R) :
    begin
      rw ← inter_Union,
      exact ennreal.mul_le_mul le_rfl (measure_mono (inter_subset_left _ _)),
    end
end

/-- A version of Sard lemma in fixed dimension: given a differentiable function from `E` to `E` and
a set where the differential is not invertible, then the image of this set has zero measure. -/
lemma add_haar_image_eq_zero_of_det_fderiv_within_eq_zero
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x)
  (h'f' : ∀ x ∈ s, (f' x).det = 0) :
  μ (f '' s) = 0 :=
begin
  suffices H : ∀ R, μ (f '' (s ∩ closed_ball 0 R)) = 0,
  { apply le_antisymm _ (zero_le _),
    rw ← Union_inter_closed_ball_nat s 0,
    calc μ (f '' ⋃ (n : ℕ), s ∩ closed_ball 0 n) ≤ ∑' (n : ℕ), μ (f '' (s ∩ closed_ball 0 n)) :
      by { rw image_Union, exact measure_Union_le _ }
    ... ≤ 0 : by simp only [H, tsum_zero, nonpos_iff_eq_zero] },
  assume R,
  have A : ∀ (ε : ℝ≥0) (εpos : 0 < ε), μ (f '' (s ∩ closed_ball 0 R)) ≤ ε * μ (closed_ball 0 R) :=
    λ ε εpos, add_haar_image_eq_zero_of_det_fderiv_within_eq_zero_aux μ
      (λ x hx, (hf' x hx.1).mono (inter_subset_left _ _)) R (inter_subset_right _ _) ε εpos
      (λ x hx, h'f' x hx.1),
  have B : tendsto (λ (ε : ℝ≥0), (ε : ℝ≥0∞) * μ (closed_ball 0 R)) (𝓝[>] 0) (𝓝 0),
  { have : tendsto (λ (ε : ℝ≥0), (ε : ℝ≥0∞) * μ (closed_ball 0 R))
      (𝓝 0) (𝓝 (((0 : ℝ≥0) : ℝ≥0∞) * μ (closed_ball 0 R))) :=
        ennreal.tendsto.mul_const (ennreal.tendsto_coe.2 tendsto_id)
          (or.inr ((measure_closed_ball_lt_top).ne)),
    simp only [zero_mul, ennreal.coe_zero] at this,
    exact tendsto.mono_left this nhds_within_le_nhds },
  apply le_antisymm _ (zero_le _),
  apply ge_of_tendsto B,
  filter_upwards [self_mem_nhds_within],
  exact A,
end

/-!
### Weak measurability statements

We show that the derivative of a function on a set is almost everywhere measurable, and that the
image `f '' s` is measurable if `f` is injective on `s`. The latter statement follows from the
Lusin-Souslin theorem.
-/

/-- The derivative of a function on a measurable set is almost everywhere measurable on this set
with respect to Lebesgue measure. Note that, in general, it is not genuinely measurable there,
as `f'` is not unique (but only on a set of measure `0`, as the argument shows). -/
lemma ae_measurable_fderiv_within (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) :
  ae_measurable f' (μ.restrict s) :=
begin
  /- It suffices to show that `f'` can be uniformly approximated by a measurable function.
  Fix `ε > 0`. Thanks to `exists_partition_approximates_linear_on_of_has_fderiv_within_at`, one
  can find a countable measurable partition of `s` into sets `s ∩ t n` on which `f` is well
  approximated by linear maps `A n`. On almost all of `s ∩ t n`, it follows from
  `approximates_linear_on.norm_fderiv_sub_le` that `f'` is uniformly approximated by `A n`, which
  gives the conclusion. -/
  -- fix a precision `ε`
  refine ae_measurable_of_unif_approx (λ ε εpos, _),
  let δ : ℝ≥0 := ⟨ε, le_of_lt εpos⟩,
  have δpos : 0 < δ := εpos,
  -- partition `s` into sets `s ∩ t n` on which `f` is approximated by linear maps `A n`.
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, Af'⟩ : ∃ (t : ℕ → set E) (A : ℕ → (E →L[ℝ] E)),
    pairwise (disjoint on t) ∧ (∀ (n : ℕ), measurable_set (t n)) ∧ (s ⊆ ⋃ (n : ℕ), t n)
    ∧ (∀ (n : ℕ), approximates_linear_on f (A n) (s ∩ t n) δ)
    ∧ (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
      exists_partition_approximates_linear_on_of_has_fderiv_within_at f s
      f' hf' (λ A, δ) (λ A, δpos.ne'),
  -- define a measurable function `g` which coincides with `A n` on `t n`.
  obtain ⟨g, g_meas, hg⟩ : ∃ g : E → (E →L[ℝ] E), measurable g ∧
    ∀ (n : ℕ) (x : E), x ∈ t n → g x = A n :=
      exists_measurable_piecewise_nat t t_meas t_disj (λ n x, A n) (λ n, measurable_const),
  refine ⟨g, g_meas.ae_measurable, _⟩,
  -- reduce to checking that `f'` and `g` are close on almost all of `s ∩ t n`, for all `n`.
  suffices H : ∀ᵐ (x : E) ∂(sum (λ n, μ.restrict (s ∩ t n))), dist (g x) (f' x) ≤ ε,
  { have : μ.restrict s ≤ sum (λ n, μ.restrict (s ∩ t n)),
    { have : s = ⋃ n, s ∩ t n,
      { rw ← inter_Union,
        exact subset.antisymm (subset_inter subset.rfl t_cover) (inter_subset_left _ _) },
      conv_lhs { rw this },
      exact restrict_Union_le },
    exact ae_mono this H },
  -- fix such an `n`.
  refine ae_sum_iff.2 (λ n, _),
  -- on almost all `s ∩ t n`, `f' x` is close to `A n` thanks to
  -- `approximates_linear_on.norm_fderiv_sub_le`.
  have E₁ : ∀ᵐ (x : E) ∂μ.restrict (s ∩ t n), ∥f' x - A n∥₊ ≤ δ :=
    (ht n).norm_fderiv_sub_le μ (hs.inter (t_meas n)) f'
      (λ x hx, (hf' x hx.1).mono (inter_subset_left _ _)),
  -- moreover, `g x` is equal to `A n` there.
  have E₂ : ∀ᵐ (x : E) ∂μ.restrict (s ∩ t n), g x = A n,
  { suffices H : ∀ᵐ (x : E) ∂μ.restrict (t n), g x = A n,
      from ae_mono (restrict_mono (inter_subset_right _ _) le_rfl) H,
    filter_upwards [ae_restrict_mem (t_meas n)],
    exact hg n },
  -- putting these two properties together gives the conclusion.
  filter_upwards [E₁, E₂] with x hx1 hx2,
  rw ← nndist_eq_nnnorm at hx1,
  rw [hx2, dist_comm],
  exact hx1,
end

lemma ae_measurable_of_real_abs_det_fderiv_within (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) :
  ae_measurable (λ x, ennreal.of_real (|(f' x).det|)) (μ.restrict s) :=
begin
  apply ennreal.measurable_of_real.comp_ae_measurable,
  refine continuous_abs.measurable.comp_ae_measurable _,
  refine continuous_linear_map.continuous_det.measurable.comp_ae_measurable _,
  exact ae_measurable_fderiv_within μ hs hf'
end

lemma ae_measurable_to_nnreal_abs_det_fderiv_within (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) :
  ae_measurable (λ x, |(f' x).det|.to_nnreal) (μ.restrict s) :=
begin
  apply measurable_real_to_nnreal.comp_ae_measurable,
  refine continuous_abs.measurable.comp_ae_measurable _,
  refine continuous_linear_map.continuous_det.measurable.comp_ae_measurable _,
  exact ae_measurable_fderiv_within μ hs hf'
end

/-- If a function is differentiable and injective on a measurable set,
then the image is measurable.-/
lemma measurable_image_of_fderiv_within (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) :
  measurable_set (f '' s) :=
begin
  have : differentiable_on ℝ f s := λ x hx, (hf' x hx).differentiable_within_at,
  exact hs.image_of_continuous_on_inj_on (differentiable_on.continuous_on this) hf,
end

/-- If a function is differentiable and injective on a measurable set `s`, then its restriction
to `s` is a measurable embedding. -/
lemma measurable_embedding_of_fderiv_within (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) :
  measurable_embedding (s.restrict f) :=
begin
  have : differentiable_on ℝ f s := λ x hx, (hf' x hx).differentiable_within_at,
  exact this.continuous_on.measurable_embedding hs hf
end

/-!
### Proving the estimate for the measure of the image

We show the formula `∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ = μ (f '' s)`,
in `lintegral_abs_det_fderiv_eq_add_haar_image`. For this, we show both inequalities in both
directions, first up to controlled errors and then letting these errors tend to `0`.
-/

lemma add_haar_image_le_lintegral_abs_det_fderiv_aux1 (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) {ε : ℝ≥0} (εpos : 0 < ε) :
  μ (f '' s) ≤ ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ + 2 * ε * μ s :=
begin
  /- To bound `μ (f '' s)`, we cover `s` by sets where `f` is well-approximated by linear maps
  `A n` (and where `f'` is almost everywhere close to `A n`), and then use that `f` expands the
  measure of such a set by at most `(A n).det + ε`. -/
  have : ∀ (A : E →L[ℝ] E), ∃ (δ : ℝ≥0), 0 < δ ∧
    (∀ (B : E →L[ℝ] E), ∥B - A∥ ≤ δ → |B.det - A.det| ≤ ε) ∧
    ∀ (t : set E) (g : E → E) (hf : approximates_linear_on g A t δ),
     μ (g '' t) ≤ (ennreal.of_real (|A.det|) + ε) * μ t,
  { assume A,
    let m : ℝ≥0 := real.to_nnreal (|A.det|) + ε,
    have I : ennreal.of_real (|A.det|) < m,
      by simp only [ennreal.of_real, m, lt_add_iff_pos_right, εpos, ennreal.coe_lt_coe],
    rcases ((add_haar_image_le_mul_of_det_lt μ A I).and self_mem_nhds_within).exists
      with ⟨δ, h, δpos⟩,
    obtain ⟨δ', δ'pos, hδ'⟩ :
      ∃ (δ' : ℝ) (H : 0 < δ'), ∀ B, dist B A < δ' → dist B.det A.det < ↑ε :=
        continuous_at_iff.1 continuous_linear_map.continuous_det.continuous_at ε εpos,
    let δ'' : ℝ≥0 := ⟨δ' / 2, (half_pos δ'pos).le⟩,
    refine ⟨min δ δ'', lt_min δpos (half_pos δ'pos), _, _⟩,
    { assume B hB,
      rw ← real.dist_eq,
      apply (hδ' B _).le,
      rw dist_eq_norm,
      calc ∥B - A∥ ≤ (min δ δ'' : ℝ≥0) : hB
      ... ≤ δ'' : by simp only [le_refl, nnreal.coe_min, min_le_iff, or_true]
      ... < δ' : half_lt_self δ'pos },
    { assume t g htg,
      exact h t g (htg.mono_num (min_le_left _ _)) } },
  choose δ hδ using this,
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, -⟩ : ∃ (t : ℕ → set E) (A : ℕ → (E →L[ℝ] E)),
    pairwise (disjoint on t) ∧ (∀ (n : ℕ), measurable_set (t n)) ∧ (s ⊆ ⋃ (n : ℕ), t n)
    ∧ (∀ (n : ℕ), approximates_linear_on f (A n) (s ∩ t n) (δ (A n)))
    ∧ (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
      exists_partition_approximates_linear_on_of_has_fderiv_within_at f s
      f' hf' δ (λ A, (hδ A).1.ne'),
  calc μ (f '' s)
      ≤ μ (⋃ n, f '' (s ∩ t n)) :
    begin
      apply measure_mono,
      rw [← image_Union, ← inter_Union],
      exact image_subset f (subset_inter subset.rfl t_cover)
    end
  ... ≤ ∑' n, μ (f '' (s ∩ t n)) : measure_Union_le _
  ... ≤ ∑' n, (ennreal.of_real (|(A n).det|) + ε) * μ (s ∩ t n) :
    begin
      apply ennreal.tsum_le_tsum (λ n, _),
      apply (hδ (A n)).2.2,
      exact ht n,
    end
  ... = ∑' n, ∫⁻ x in s ∩ t n, ennreal.of_real (|(A n).det|) + ε ∂μ :
    by simp only [lintegral_const, measurable_set.univ, measure.restrict_apply, univ_inter]
  ... ≤ ∑' n, ∫⁻ x in s ∩ t n, ennreal.of_real (|(f' x).det|) + 2 * ε ∂μ :
    begin
      apply ennreal.tsum_le_tsum (λ n, _),
      apply lintegral_mono_ae,
      filter_upwards [(ht n).norm_fderiv_sub_le μ (hs.inter (t_meas n)) f'
          (λ x hx, (hf' x hx.1).mono (inter_subset_left _ _))],
      assume x hx,
      have I : |(A n).det| ≤ |(f' x).det| + ε := calc
        |(A n).det| = |(f' x).det - ((f' x).det - (A n).det)| : by { congr' 1, abel }
        ... ≤ |(f' x).det| + |(f' x).det - (A n).det| : abs_sub _ _
        ... ≤ |(f' x).det| + ε : add_le_add le_rfl ((hδ (A n)).2.1 _ hx),
      calc ennreal.of_real (|(A n).det|) + ε
          ≤ ennreal.of_real (|(f' x).det| + ε) + ε :
        add_le_add (ennreal.of_real_le_of_real I) le_rfl
      ... = ennreal.of_real (|(f' x).det|) + 2 * ε :
        by simp only [ennreal.of_real_add, abs_nonneg, two_mul, add_assoc, nnreal.zero_le_coe,
                      ennreal.of_real_coe_nnreal],
    end
  ... = ∫⁻ x in ⋃ n, s ∩ t n, ennreal.of_real (|(f' x).det|) + 2 * ε ∂μ :
    begin
      have M : ∀ (n : ℕ), measurable_set (s ∩ t n) := λ n, hs.inter (t_meas n),
      rw lintegral_Union M,
      exact pairwise_disjoint.mono t_disj (λ n, inter_subset_right _ _),
    end
  ... = ∫⁻ x in s, ennreal.of_real (|(f' x).det|) + 2 * ε ∂μ :
    begin
      have : s = ⋃ n, s ∩ t n,
      { rw ← inter_Union,
        exact subset.antisymm (subset_inter subset.rfl t_cover) (inter_subset_left _ _) },
      rw ← this,
    end
  ... = ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ + 2 * ε * μ s :
    by simp only [lintegral_add_right' _ ae_measurable_const, set_lintegral_const]
end

lemma add_haar_image_le_lintegral_abs_det_fderiv_aux2 (hs : measurable_set s) (h's : μ s ≠ ∞)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) :
  μ (f '' s) ≤ ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ :=
begin
  /- We just need to let the error tend to `0` in the previous lemma. -/
  have : tendsto (λ (ε : ℝ≥0), ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ + 2 * ε * μ s)
    (𝓝[>] 0) (𝓝 (∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ + 2 * (0 : ℝ≥0) * μ s)),
  { apply tendsto.mono_left _ nhds_within_le_nhds,
    refine tendsto_const_nhds.add _,
    refine ennreal.tendsto.mul_const _ (or.inr h's),
    exact ennreal.tendsto.const_mul (ennreal.tendsto_coe.2 tendsto_id)
      (or.inr ennreal.coe_ne_top) },
  simp only [add_zero, zero_mul, mul_zero, ennreal.coe_zero] at this,
  apply ge_of_tendsto this,
  filter_upwards [self_mem_nhds_within],
  rintros ε (εpos : 0 < ε),
  exact add_haar_image_le_lintegral_abs_det_fderiv_aux1 μ hs hf' εpos,
end

lemma add_haar_image_le_lintegral_abs_det_fderiv (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) :
  μ (f '' s) ≤ ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ :=
begin
  /- We already know the result for finite-measure sets. We cover `s` by finite-measure sets using
  `spanning_sets μ`, and apply the previous result to each of these parts. -/
  let u := λ n, disjointed (spanning_sets μ) n,
  have u_meas : ∀ n, measurable_set (u n),
  { assume n,
    apply measurable_set.disjointed (λ i, _),
    exact measurable_spanning_sets μ i },
  have A : s = ⋃ n, s ∩ u n,
    by rw [← inter_Union, Union_disjointed, Union_spanning_sets, inter_univ],
  calc μ (f '' s) ≤ ∑' n, μ (f '' (s ∩ u n)) :
    begin
      conv_lhs { rw [A, image_Union] },
      exact measure_Union_le _,
    end
  ... ≤ ∑' n, ∫⁻ x in s ∩ u n, ennreal.of_real (|(f' x).det|) ∂μ :
    begin
      apply ennreal.tsum_le_tsum (λ n, _),
      apply add_haar_image_le_lintegral_abs_det_fderiv_aux2 μ (hs.inter (u_meas n)) _
        (λ x hx, (hf' x hx.1).mono (inter_subset_left _ _)),
      have : μ (u n) < ∞ :=
        lt_of_le_of_lt (measure_mono (disjointed_subset _ _)) (measure_spanning_sets_lt_top μ n),
      exact ne_of_lt (lt_of_le_of_lt (measure_mono (inter_subset_right _ _)) this),
    end
  ... = ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ :
    begin
      conv_rhs { rw A },
      rw lintegral_Union,
      { assume n, exact hs.inter (u_meas n) },
      { exact pairwise_disjoint.mono (disjoint_disjointed _) (λ n, inter_subset_right _ _) }
    end
end

lemma lintegral_abs_det_fderiv_le_add_haar_image_aux1 (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s)
  {ε : ℝ≥0} (εpos : 0 < ε) :
  ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ ≤ μ (f '' s) + 2 * ε * μ s :=
begin
  /- To bound `∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ`, we cover `s` by sets where `f` is
  well-approximated by linear maps `A n` (and where `f'` is almost everywhere close to `A n`),
  and then use that `f` expands the measure of such a set by at least `(A n).det - ε`. -/
  have : ∀ (A : E →L[ℝ] E), ∃ (δ : ℝ≥0), 0 < δ ∧
    (∀ (B : E →L[ℝ] E), ∥B - A∥ ≤ δ → |B.det - A.det| ≤ ε) ∧
    ∀ (t : set E) (g : E → E) (hf : approximates_linear_on g A t δ),
     ennreal.of_real (|A.det|) * μ t ≤ μ (g '' t) + ε * μ t,
  { assume A,
    obtain ⟨δ', δ'pos, hδ'⟩ :
      ∃ (δ' : ℝ) (H : 0 < δ'), ∀ B, dist B A < δ' → dist B.det A.det < ↑ε :=
        continuous_at_iff.1 continuous_linear_map.continuous_det.continuous_at ε εpos,
    let δ'' : ℝ≥0 := ⟨δ' / 2, (half_pos δ'pos).le⟩,
    have I'' : ∀ (B : E →L[ℝ] E), ∥B - A∥ ≤ ↑δ'' → |B.det - A.det| ≤ ↑ε,
    { assume B hB,
      rw ← real.dist_eq,
      apply (hδ' B _).le,
      rw dist_eq_norm,
      exact hB.trans_lt (half_lt_self δ'pos) },
    rcases eq_or_ne A.det 0 with hA|hA,
    { refine ⟨δ'', half_pos δ'pos, I'', _⟩,
      simp only [hA, forall_const, zero_mul, ennreal.of_real_zero, implies_true_iff, zero_le,
        abs_zero] },
    let m : ℝ≥0 := real.to_nnreal (|A.det|) - ε,
    have I : (m : ℝ≥0∞) < ennreal.of_real (|A.det|),
    { simp only [ennreal.of_real, with_top.coe_sub],
      apply ennreal.sub_lt_self ennreal.coe_ne_top,
      { simpa only [abs_nonpos_iff, real.to_nnreal_eq_zero, ennreal.coe_eq_zero, ne.def] using hA },
      { simp only [εpos.ne', ennreal.coe_eq_zero, ne.def, not_false_iff] } },
    rcases ((mul_le_add_haar_image_of_lt_det μ A I).and self_mem_nhds_within).exists
      with ⟨δ, h, δpos⟩,
    refine ⟨min δ δ'', lt_min δpos (half_pos δ'pos), _, _⟩,
    { assume B hB,
      apply I'' _ (hB.trans _),
      simp only [le_refl, nnreal.coe_min, min_le_iff, or_true] },
    { assume t g htg,
      rcases eq_or_ne (μ t) ∞ with ht|ht,
      { simp only [ht, εpos.ne', with_top.mul_top, ennreal.coe_eq_zero, le_top, ne.def,
                   not_false_iff, ennreal.add_top] },
      have := h t g (htg.mono_num (min_le_left _ _)),
      rwa [with_top.coe_sub, ennreal.sub_mul, tsub_le_iff_right] at this,
      simp only [ht, implies_true_iff, ne.def, not_false_iff] } },
  choose δ hδ using this,
  obtain ⟨t, A, t_disj, t_meas, t_cover, ht, -⟩ : ∃ (t : ℕ → set E) (A : ℕ → (E →L[ℝ] E)),
    pairwise (disjoint on t) ∧ (∀ (n : ℕ), measurable_set (t n)) ∧ (s ⊆ ⋃ (n : ℕ), t n)
    ∧ (∀ (n : ℕ), approximates_linear_on f (A n) (s ∩ t n) (δ (A n)))
    ∧ (s.nonempty → ∀ n, ∃ y ∈ s, A n = f' y) :=
      exists_partition_approximates_linear_on_of_has_fderiv_within_at f s
      f' hf' δ (λ A, (hδ A).1.ne'),
  have s_eq : s = ⋃ n, s ∩ t n,
  { rw ← inter_Union,
    exact subset.antisymm (subset_inter subset.rfl t_cover) (inter_subset_left _ _) },
  calc ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ
      = ∑' n, ∫⁻ x in s ∩ t n, ennreal.of_real (|(f' x).det|) ∂μ :
    begin
      conv_lhs { rw s_eq },
      rw lintegral_Union,
      { exact λ n, hs.inter (t_meas n) },
      { exact pairwise_disjoint.mono t_disj (λ n, inter_subset_right _ _) }
    end
  ... ≤ ∑' n, ∫⁻ x in s ∩ t n, ennreal.of_real (|(A n).det|) + ε ∂μ :
    begin
      apply ennreal.tsum_le_tsum (λ n, _),
      apply lintegral_mono_ae,
      filter_upwards [(ht n).norm_fderiv_sub_le μ (hs.inter (t_meas n)) f'
          (λ x hx, (hf' x hx.1).mono (inter_subset_left _ _))],
      assume x hx,
      have I : |(f' x).det| ≤ |(A n).det| + ε := calc
        |(f' x).det| = |(A n).det + ((f' x).det - (A n).det)| : by { congr' 1, abel }
        ... ≤ |(A n).det| + |(f' x).det - (A n).det| : abs_add _ _
        ... ≤ |(A n).det| + ε : add_le_add le_rfl ((hδ (A n)).2.1 _ hx),
      calc ennreal.of_real (|(f' x).det|) ≤ ennreal.of_real (|(A n).det| + ε) :
        ennreal.of_real_le_of_real I
      ... = ennreal.of_real (|(A n).det|) + ε :
        by simp only [ennreal.of_real_add, abs_nonneg, nnreal.zero_le_coe,
                      ennreal.of_real_coe_nnreal]
    end
  ... = ∑' n, (ennreal.of_real (|(A n).det|) * μ (s ∩ t n) + ε * μ (s ∩ t n)) :
    by simp only [set_lintegral_const, lintegral_add_right _ measurable_const]
  ... ≤ ∑' n, ((μ (f '' (s ∩ t n)) + ε * μ (s ∩ t n)) + ε * μ (s ∩ t n)) :
    begin
      refine ennreal.tsum_le_tsum (λ n, add_le_add_right _ _),
      exact (hδ (A n)).2.2 _ _ (ht n),
    end
  ... = μ (f '' s) + 2 * ε * μ s :
    begin
      conv_rhs { rw s_eq },
      rw [image_Union, measure_Union], rotate,
      { assume i j hij,
        apply (disjoint.image _ hf (inter_subset_left _ _) (inter_subset_left _ _)),
        exact disjoint.mono (inter_subset_right _ _) (inter_subset_right _ _) (t_disj i j hij) },
      { assume i,
        exact measurable_image_of_fderiv_within (hs.inter (t_meas i)) (λ x hx,
          (hf' x hx.1).mono (inter_subset_left _ _)) (hf.mono (inter_subset_left _ _)) },
      rw measure_Union, rotate,
      { exact pairwise_disjoint.mono t_disj (λ i, inter_subset_right _ _) },
      { exact λ i, hs.inter (t_meas i) },
      rw [← ennreal.tsum_mul_left, ← ennreal.tsum_add],
      congr' 1,
      ext1 i,
      rw [mul_assoc, two_mul, add_assoc],
    end
end

lemma lintegral_abs_det_fderiv_le_add_haar_image_aux2 (hs : measurable_set s) (h's : μ s ≠ ∞)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) :
  ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ ≤ μ (f '' s) :=
begin
  /- We just need to let the error tend to `0` in the previous lemma. -/
  have : tendsto (λ (ε : ℝ≥0), μ (f '' s) + 2 * ε * μ s)
    (𝓝[>] 0) (𝓝 (μ (f '' s) + 2 * (0 : ℝ≥0) * μ s)),
  { apply tendsto.mono_left _ nhds_within_le_nhds,
    refine tendsto_const_nhds.add _,
    refine ennreal.tendsto.mul_const _ (or.inr h's),
    exact ennreal.tendsto.const_mul (ennreal.tendsto_coe.2 tendsto_id)
      (or.inr ennreal.coe_ne_top) },
  simp only [add_zero, zero_mul, mul_zero, ennreal.coe_zero] at this,
  apply ge_of_tendsto this,
  filter_upwards [self_mem_nhds_within],
  rintros ε (εpos : 0 < ε),
  exact lintegral_abs_det_fderiv_le_add_haar_image_aux1 μ hs hf' hf εpos
end

lemma lintegral_abs_det_fderiv_le_add_haar_image (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) :
  ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ ≤ μ (f '' s) :=
begin
  /- We already know the result for finite-measure sets. We cover `s` by finite-measure sets using
  `spanning_sets μ`, and apply the previous result to each of these parts. -/
  let u := λ n, disjointed (spanning_sets μ) n,
  have u_meas : ∀ n, measurable_set (u n),
  { assume n,
    apply measurable_set.disjointed (λ i, _),
    exact measurable_spanning_sets μ i },
  have A : s = ⋃ n, s ∩ u n,
    by rw [← inter_Union, Union_disjointed, Union_spanning_sets, inter_univ],
  calc ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ
      = ∑' n, ∫⁻ x in s ∩ u n, ennreal.of_real (|(f' x).det|) ∂μ :
    begin
      conv_lhs { rw A },
      rw lintegral_Union,
      { assume n, exact hs.inter (u_meas n) },
      { exact pairwise_disjoint.mono (disjoint_disjointed _) (λ n, inter_subset_right _ _) }
    end
  ... ≤ ∑' n, μ (f '' (s ∩ u n)) :
    begin
      apply ennreal.tsum_le_tsum (λ n, _),
      apply lintegral_abs_det_fderiv_le_add_haar_image_aux2 μ (hs.inter (u_meas n)) _
        (λ x hx, (hf' x hx.1).mono (inter_subset_left _ _)) (hf.mono (inter_subset_left _ _)),
      have : μ (u n) < ∞ :=
        lt_of_le_of_lt (measure_mono (disjointed_subset _ _)) (measure_spanning_sets_lt_top μ n),
      exact ne_of_lt (lt_of_le_of_lt (measure_mono (inter_subset_right _ _)) this),
    end
  ... = μ (f '' s) :
    begin
      conv_rhs { rw [A, image_Union] },
      rw measure_Union,
      { assume i j hij,
        apply disjoint.image _ hf (inter_subset_left _ _) (inter_subset_left _ _),
        exact disjoint.mono (inter_subset_right _ _) (inter_subset_right _ _)
          (disjoint_disjointed _ i j hij) },
      { assume i,
        exact measurable_image_of_fderiv_within (hs.inter (u_meas i)) (λ x hx,
          (hf' x hx.1).mono (inter_subset_left _ _)) (hf.mono (inter_subset_left _ _)) },
    end
end

/-- Change of variable formula for differentiable functions, set version: if a function `f` is
injective and differentiable on a measurable set `s`, then the measure of `f '' s` is given by the
integral of `|(f' x).det|` on `s`.
Note that the measurability of `f '' s` is given by `measurable_image_of_fderiv_within`. -/
theorem lintegral_abs_det_fderiv_eq_add_haar_image (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) :
  ∫⁻ x in s, ennreal.of_real (|(f' x).det|) ∂μ = μ (f '' s) :=
le_antisymm (lintegral_abs_det_fderiv_le_add_haar_image μ hs hf' hf)
  (add_haar_image_le_lintegral_abs_det_fderiv μ hs hf')

/-- Change of variable formula for differentiable functions, set version: if a function `f` is
injective and differentiable on a measurable set `s`, then the pushforward of the measure with
density `|(f' x).det|` on `s` is the Lebesgue measure on the image set. This version requires
that `f` is measurable, as otherwise `measure.map f` is zero per our definitions.
For a version without measurability assumption but dealing with the restricted
function `s.restrict f`, see `restrict_map_with_density_abs_det_fderiv_eq_add_haar`.
-/
theorem map_with_density_abs_det_fderiv_eq_add_haar (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s)
  (h'f : measurable f) :
  measure.map f ((μ.restrict s).with_density (λ x, ennreal.of_real (|(f' x).det|)))
    = μ.restrict (f '' s) :=
begin
  apply measure.ext (λ t ht, _),
  rw [map_apply h'f ht, with_density_apply _ (h'f ht), measure.restrict_apply ht,
      restrict_restrict (h'f ht),
      lintegral_abs_det_fderiv_eq_add_haar_image μ ((h'f ht).inter hs)
        (λ x hx, (hf' x hx.2).mono (inter_subset_right _ _)) (hf.mono (inter_subset_right _ _)),
      image_preimage_inter]
end

/-- Change of variable formula for differentiable functions, set version: if a function `f` is
injective and differentiable on a measurable set `s`, then the pushforward of the measure with
density `|(f' x).det|` on `s` is the Lebesgue measure on the image set. This version is expressed
in terms of the restricted function `s.restrict f`.
For a version for the original function, but with a measurability assumption,
see `map_with_density_abs_det_fderiv_eq_add_haar`.
-/
theorem restrict_map_with_density_abs_det_fderiv_eq_add_haar (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) :
  measure.map (s.restrict f)
    (comap coe (μ.with_density (λ x, ennreal.of_real (|(f' x).det|)))) = μ.restrict (f '' s) :=
begin
  obtain ⟨u, u_meas, uf⟩ : ∃ u, measurable u ∧ eq_on u f s,
  { classical,
    refine ⟨piecewise s f 0, _, piecewise_eq_on _ _ _⟩,
    refine continuous_on.measurable_piecewise _ continuous_zero.continuous_on hs,
    have : differentiable_on ℝ f s := λ x hx, (hf' x hx).differentiable_within_at,
    exact this.continuous_on },
  have u' : ∀ x ∈ s, has_fderiv_within_at u (f' x) s x :=
    λ x hx, (hf' x hx).congr (λ y hy, uf hy) (uf hx),
  set F : s → E := u ∘ coe with hF,
  have A : measure.map F
    (comap coe (μ.with_density (λ x, ennreal.of_real (|(f' x).det|)))) = μ.restrict (u '' s),
  { rw [hF, ← measure.map_map u_meas measurable_subtype_coe, map_comap_subtype_coe hs,
        restrict_with_density hs],
    exact map_with_density_abs_det_fderiv_eq_add_haar μ hs u' (hf.congr uf.symm) u_meas },
  rw uf.image_eq at A,
  have : F = s.restrict f,
  { ext x,
    exact uf x.2 },
  rwa this at A,
end

/-! ### Change of variable formulas in integrals -/

/- Change of variable formula for differentiable functions: if a function `f` is
injective and differentiable on a measurable set `s`, then the Lebesgue integral of a function
`g : E → ℝ≥0∞` on `f '' s` coincides with the integral of `|(f' x).det| * g ∘ f` on `s`.
Note that the measurability of `f '' s` is given by `measurable_image_of_fderiv_within`. -/
theorem lintegral_image_eq_lintegral_abs_det_fderiv_mul (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) (g : E → ℝ≥0∞) :
  ∫⁻ x in f '' s, g x ∂μ = ∫⁻ x in s, ennreal.of_real (|(f' x).det|) * g (f x) ∂μ :=
begin
  rw [← restrict_map_with_density_abs_det_fderiv_eq_add_haar μ hs hf' hf,
      (measurable_embedding_of_fderiv_within hs hf' hf).lintegral_map],
  have : ∀ (x : s), g (s.restrict f x) = (g ∘ f) x := λ x, rfl,
  simp only [this],
  rw [← (measurable_embedding.subtype_coe hs).lintegral_map, map_comap_subtype_coe hs,
      set_lintegral_with_density_eq_set_lintegral_mul_non_measurable₀ _ _ _ hs],
  { refl },
  { simp only [eventually_true, ennreal.of_real_lt_top] },
  { exact ae_measurable_of_real_abs_det_fderiv_within μ hs hf' }
end

/-- Integrability in the change of variable formula for differentiable functions: if a
function `f` is injective and differentiable on a measurable set `s`, then a function
`g : E → F` is integrable on `f '' s` if and only if `|(f' x).det| • g ∘ f` is
integrable on `s`. -/
theorem integrable_on_image_iff_integrable_on_abs_det_fderiv_smul (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) (g : E → F) :
  integrable_on g (f '' s) μ ↔ integrable_on (λ x, |(f' x).det| • g (f x)) s μ :=
begin
  rw [integrable_on, ← restrict_map_with_density_abs_det_fderiv_eq_add_haar μ hs hf' hf,
      (measurable_embedding_of_fderiv_within hs hf' hf).integrable_map_iff],
  change (integrable ((g ∘ f) ∘ (coe : s → E)) _) ↔ _,
  rw [← (measurable_embedding.subtype_coe hs).integrable_map_iff, map_comap_subtype_coe hs],
  simp only [ennreal.of_real],
  rw [restrict_with_density hs, integrable_with_density_iff_integrable_coe_smul₀, integrable_on],
  { congr' 2 with x,
    rw real.coe_to_nnreal,
    exact abs_nonneg _ },
  { exact ae_measurable_to_nnreal_abs_det_fderiv_within μ hs hf' }
end

/-- Change of variable formula for differentiable functions: if a function `f` is
injective and differentiable on a measurable set `s`, then the Bochner integral of a function
`g : E → F` on `f '' s` coincides with the integral of `|(f' x).det| • g ∘ f` on `s`. -/
theorem integral_image_eq_integral_abs_det_fderiv_smul [complete_space F] (hs : measurable_set s)
  (hf' : ∀ x ∈ s, has_fderiv_within_at f (f' x) s x) (hf : inj_on f s) (g : E → F) :
  ∫ x in f '' s, g x ∂μ = ∫ x in s, |(f' x).det| • g (f x) ∂μ :=
begin
  rw [← restrict_map_with_density_abs_det_fderiv_eq_add_haar μ hs hf' hf,
      (measurable_embedding_of_fderiv_within hs hf' hf).integral_map],
  have : ∀ (x : s), g (s.restrict f x) = (g ∘ f) x := λ x, rfl,
  simp only [this, ennreal.of_real],
  rw [← (measurable_embedding.subtype_coe hs).integral_map, map_comap_subtype_coe hs,
      set_integral_with_density_eq_set_integral_smul₀
        (ae_measurable_to_nnreal_abs_det_fderiv_within μ hs hf') _ hs],
  congr' with x,
  conv_rhs { rw ← real.coe_to_nnreal _ (abs_nonneg (f' x).det) },
  refl
end

end measure_theory


<|start_filename|>src/measure_theory/measure/finite_measure_weak_convergence.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.measure.measure_space
import measure_theory.integral.set_integral
import topology.continuous_function.bounded
import topology.algebra.module.weak_dual
import topology.metric_space.thickened_indicator

/-!
# Weak convergence of (finite) measures

This file defines the topology of weak convergence of finite measures and probability measures
on topological spaces. The topology of weak convergence is the coarsest topology w.r.t. which
for every bounded continuous `ℝ≥0`-valued function `f`, the integration of `f` against the
measure is continuous.

TODOs:
* Prove that an equivalent definition of the topologies is obtained requiring continuity of
  integration of bounded continuous `ℝ`-valued functions instead.
* Include the portmanteau theorem on characterizations of weak convergence of (Borel) probability
  measures.

## Main definitions

The main definitions are the
 * types `finite_measure α` and `probability_measure α` with topologies of weak convergence;
 * `to_weak_dual_bcnn : finite_measure α → (weak_dual ℝ≥0 (α →ᵇ ℝ≥0))`
   allowing to interpret a finite measure as a continuous linear functional on the space of
   bounded continuous nonnegative functions on `α`. This is used for the definition of the
   topology of weak convergence.

## Main results

 * Finite measures `μ` on `α` give rise to continuous linear functionals on the space of
   bounded continuous nonnegative functions on `α` via integration:
   `to_weak_dual_bcnn : finite_measure α → (weak_dual ℝ≥0 (α →ᵇ ℝ≥0))`.
 * `tendsto_iff_forall_lintegral_tendsto`: Convergence of finite measures and probability measures
   is characterized by the convergence of integrals of all bounded continuous (nonnegative)
   functions. This essentially shows that the given definition of topology corresponds to the
   common textbook definition of weak convergence of measures.

TODO:
* Portmanteau theorem:
  * `finite_measure.limsup_measure_closed_le_of_tendsto` proves one implication.
    The current formulation assumes `pseudo_emetric_space`. The only reason is to have
    bounded continuous pointwise approximations to the indicator function of a closed set. Clearly
    for example metrizability or pseudo-emetrizability would be sufficient assumptions. The
    typeclass assumptions should be later adjusted in a way that takes into account use cases, but
    the proof will presumably remain essentially the same.
  * Prove the rest of the implications.

## Notations

No new notation is introduced.

## Implementation notes

The topology of weak convergence of finite Borel measures will be defined using a mapping from
`finite_measure α` to `weak_dual ℝ≥0 (α →ᵇ ℝ≥0)`, inheriting the topology from the latter.

The current implementation of `finite_measure α` and `probability_measure α` is directly as
subtypes of `measure α`, and the coercion to a function is the composition `ennreal.to_nnreal`
and the coercion to function of `measure α`. Another alternative would be to use a bijection
with `vector_measure α ℝ≥0` as an intermediate step. The choice of implementation should not have
drastic downstream effects, so it can be changed later if appropriate.

Potential advantages of using the `nnreal`-valued vector measure alternative:
 * The coercion to function would avoid need to compose with `ennreal.to_nnreal`, the
   `nnreal`-valued API could be more directly available.
Potential drawbacks of the vector measure alternative:
 * The coercion to function would lose monotonicity, as non-measurable sets would be defined to
   have measure 0.
 * No integration theory directly. E.g., the topology definition requires `lintegral` w.r.t.
   a coercion to `measure α` in any case.

## References

* [Billingsley, *Convergence of probability measures*][billingsley1999]

## Tags

weak convergence of measures, finite measure, probability measure

-/

noncomputable theory
open measure_theory
open set
open filter
open bounded_continuous_function
open_locale topological_space ennreal nnreal bounded_continuous_function

namespace measure_theory

variables {α : Type*} [measurable_space α]

/-- Finite measures are defined as the subtype of measures that have the property of being finite
measures (i.e., their total mass is finite). -/
def finite_measure (α : Type*) [measurable_space α] : Type* :=
{μ : measure α // is_finite_measure μ}

namespace finite_measure

/-- A finite measure can be interpreted as a measure. -/
instance : has_coe (finite_measure α) (measure_theory.measure α) := coe_subtype

instance is_finite_measure (μ : finite_measure α) :
  is_finite_measure (μ : measure α) := μ.prop

instance : has_coe_to_fun (finite_measure α) (λ _, set α → ℝ≥0) :=
⟨λ μ s, (μ s).to_nnreal⟩

lemma coe_fn_eq_to_nnreal_coe_fn_to_measure (ν : finite_measure α) :
  (ν : set α → ℝ≥0) = λ s, ((ν : measure α) s).to_nnreal := rfl

@[simp] lemma ennreal_coe_fn_eq_coe_fn_to_measure (ν : finite_measure α) (s : set α) :
  (ν s : ℝ≥0∞) = (ν : measure α) s := ennreal.coe_to_nnreal (measure_lt_top ↑ν s).ne

@[simp] lemma val_eq_to_measure (ν : finite_measure α) : ν.val = (ν : measure α) := rfl

lemma coe_injective : function.injective (coe : finite_measure α → measure α) :=
subtype.coe_injective

/-- The (total) mass of a finite measure `μ` is `μ univ`, i.e., the cast to `nnreal` of
`(μ : measure α) univ`. -/
def mass (μ : finite_measure α) : ℝ≥0 := μ univ

@[simp] lemma ennreal_mass {μ : finite_measure α} :
  (μ.mass : ℝ≥0∞) = (μ : measure α) univ := ennreal_coe_fn_eq_coe_fn_to_measure μ set.univ

instance has_zero : has_zero (finite_measure α) :=
{ zero := ⟨0, measure_theory.is_finite_measure_zero⟩ }

instance : inhabited (finite_measure α) := ⟨0⟩

instance : has_add (finite_measure α) :=
{ add := λ μ ν, ⟨μ + ν, measure_theory.is_finite_measure_add⟩ }

variables {R : Type*} [has_scalar R ℝ≥0] [has_scalar R ℝ≥0∞] [is_scalar_tower R ℝ≥0 ℝ≥0∞]
  [is_scalar_tower R ℝ≥0∞ ℝ≥0∞]

instance : has_scalar R (finite_measure α) :=
{ smul := λ (c : R) μ, ⟨c • μ, measure_theory.is_finite_measure_smul_of_nnreal_tower⟩, }

@[simp, norm_cast] lemma coe_zero : (coe : finite_measure α → measure α) 0 = 0 := rfl

@[simp, norm_cast] lemma coe_add (μ ν : finite_measure α) : ↑(μ + ν) = (↑μ + ↑ν : measure α) := rfl

@[simp, norm_cast] lemma coe_smul (c : R) (μ : finite_measure α) :
  ↑(c • μ) = (c • ↑μ : measure α) := rfl

@[simp, norm_cast] lemma coe_fn_zero :
  (⇑(0 : finite_measure α) : set α → ℝ≥0) = (0 : set α → ℝ≥0) := by { funext, refl, }

@[simp, norm_cast] lemma coe_fn_add (μ ν : finite_measure α) :
  (⇑(μ + ν) : set α → ℝ≥0) = (⇑μ + ⇑ν : set α → ℝ≥0) :=
by { funext, simp [← ennreal.coe_eq_coe], }

@[simp, norm_cast] lemma coe_fn_smul [is_scalar_tower R ℝ≥0 ℝ≥0] (c : R) (μ : finite_measure α) :
  (⇑(c • μ) : set α → ℝ≥0) = c • (⇑μ : set α → ℝ≥0) :=
by { funext, simp [← ennreal.coe_eq_coe, ennreal.coe_smul], }

instance : add_comm_monoid (finite_measure α) :=
finite_measure.coe_injective.add_comm_monoid coe coe_zero coe_add (λ _ _, coe_smul _ _)

/-- Coercion is an `add_monoid_hom`. -/
@[simps]
def coe_add_monoid_hom : finite_measure α →+ measure α :=
{ to_fun := coe, map_zero' := coe_zero, map_add' := coe_add }

instance {α : Type*} [measurable_space α] : module ℝ≥0 (finite_measure α) :=
function.injective.module _ coe_add_monoid_hom finite_measure.coe_injective coe_smul

variables [topological_space α]

/-- The pairing of a finite (Borel) measure `μ` with a nonnegative bounded continuous
function is obtained by (Lebesgue) integrating the (test) function against the measure.
This is `finite_measure.test_against_nn`. -/
def test_against_nn (μ : finite_measure α) (f : α →ᵇ ℝ≥0) : ℝ≥0 :=
(∫⁻ x, f x ∂(μ : measure α)).to_nnreal

lemma _root_.bounded_continuous_function.nnreal.to_ennreal_comp_measurable {α : Type*}
  [topological_space α] [measurable_space α] [opens_measurable_space α] (f : α →ᵇ ℝ≥0) :
  measurable (λ x, (f x : ℝ≥0∞)) :=
measurable_coe_nnreal_ennreal.comp f.continuous.measurable

lemma lintegral_lt_top_of_bounded_continuous_to_nnreal (μ : finite_measure α) (f : α →ᵇ ℝ≥0) :
  ∫⁻ x, f x ∂(μ : measure α) < ∞ :=
begin
  apply is_finite_measure.lintegral_lt_top_of_bounded_to_ennreal,
  use nndist f 0,
  intros x,
  have key := bounded_continuous_function.nnreal.upper_bound f x,
  rw ennreal.coe_le_coe,
  have eq : nndist f 0 = ⟨dist f 0, dist_nonneg⟩,
  { ext,
    simp only [real.coe_to_nnreal', max_eq_left_iff, subtype.coe_mk, coe_nndist], },
  rwa eq at key,
end

@[simp] lemma test_against_nn_coe_eq {μ : finite_measure α} {f : α →ᵇ ℝ≥0} :
  (μ.test_against_nn f : ℝ≥0∞) = ∫⁻ x, f x ∂(μ : measure α) :=
ennreal.coe_to_nnreal (lintegral_lt_top_of_bounded_continuous_to_nnreal μ f).ne

lemma test_against_nn_const (μ : finite_measure α) (c : ℝ≥0) :
  μ.test_against_nn (bounded_continuous_function.const α c) = c * μ.mass :=
by simp [← ennreal.coe_eq_coe]

lemma test_against_nn_mono (μ : finite_measure α)
  {f g : α →ᵇ ℝ≥0} (f_le_g : (f : α → ℝ≥0) ≤ g) :
  μ.test_against_nn f ≤ μ.test_against_nn g :=
begin
  simp only [←ennreal.coe_le_coe, test_against_nn_coe_eq],
  apply lintegral_mono,
  exact λ x, ennreal.coe_mono (f_le_g x),
end

variables [opens_measurable_space α]

lemma test_against_nn_add (μ : finite_measure α) (f₁ f₂ : α →ᵇ ℝ≥0) :
  μ.test_against_nn (f₁ + f₂) = μ.test_against_nn f₁ + μ.test_against_nn f₂ :=
begin
  simp only [←ennreal.coe_eq_coe, bounded_continuous_function.coe_add, ennreal.coe_add,
             pi.add_apply, test_against_nn_coe_eq],
  exact lintegral_add_left (bounded_continuous_function.nnreal.to_ennreal_comp_measurable _) _
end

lemma test_against_nn_smul [is_scalar_tower R ℝ≥0 ℝ≥0] [pseudo_metric_space R] [has_zero R]
  [has_bounded_smul R ℝ≥0]
  (μ : finite_measure α) (c : R) (f : α →ᵇ ℝ≥0) :
  μ.test_against_nn (c • f) = c • μ.test_against_nn f :=
begin
  simp only [←ennreal.coe_eq_coe, bounded_continuous_function.coe_smul,
             test_against_nn_coe_eq, ennreal.coe_smul],
  simp_rw [←smul_one_smul ℝ≥0∞ c (f _ : ℝ≥0∞), ←smul_one_smul ℝ≥0∞ c (lintegral _ _ : ℝ≥0∞),
           smul_eq_mul],
  exact @lintegral_const_mul _ _ (μ : measure α) (c • 1)  _
                   (bounded_continuous_function.nnreal.to_ennreal_comp_measurable f),
end

lemma test_against_nn_lipschitz_estimate (μ : finite_measure α) (f g : α →ᵇ ℝ≥0) :
  μ.test_against_nn f ≤ μ.test_against_nn g + (nndist f g) * μ.mass :=
begin
  simp only [←μ.test_against_nn_const (nndist f g), ←test_against_nn_add, ←ennreal.coe_le_coe,
             bounded_continuous_function.coe_add, const_apply, ennreal.coe_add, pi.add_apply,
             coe_nnreal_ennreal_nndist, test_against_nn_coe_eq],
  apply lintegral_mono,
  have le_dist : ∀ x, dist (f x) (g x) ≤ nndist f g :=
  bounded_continuous_function.dist_coe_le_dist,
  intros x,
  have le' : f(x) ≤ g(x) + nndist f g,
  { apply (nnreal.le_add_nndist (f x) (g x)).trans,
    rw add_le_add_iff_left,
    exact dist_le_coe.mp (le_dist x), },
  have le : (f(x) : ℝ≥0∞) ≤ (g(x) : ℝ≥0∞) + (nndist f g),
  by { rw ←ennreal.coe_add, exact ennreal.coe_mono le', },
  rwa [coe_nnreal_ennreal_nndist] at le,
end

lemma test_against_nn_lipschitz (μ : finite_measure α) :
  lipschitz_with μ.mass (λ (f : α →ᵇ ℝ≥0), μ.test_against_nn f) :=
begin
  rw lipschitz_with_iff_dist_le_mul,
  intros f₁ f₂,
  suffices : abs (μ.test_against_nn f₁ - μ.test_against_nn f₂ : ℝ) ≤ μ.mass * (dist f₁ f₂),
  { rwa nnreal.dist_eq, },
  apply abs_le.mpr,
  split,
  { have key' := μ.test_against_nn_lipschitz_estimate f₂ f₁,
    rw mul_comm at key',
    suffices : ↑(μ.test_against_nn f₂) ≤ ↑(μ.test_against_nn f₁) + ↑(μ.mass) * dist f₁ f₂,
    { linarith, },
    have key := nnreal.coe_mono key',
    rwa [nnreal.coe_add, nnreal.coe_mul, nndist_comm] at key, },
  { have key' := μ.test_against_nn_lipschitz_estimate f₁ f₂,
    rw mul_comm at key',
    suffices : ↑(μ.test_against_nn f₁) ≤ ↑(μ.test_against_nn f₂) + ↑(μ.mass) * dist f₁ f₂,
    { linarith, },
    have key := nnreal.coe_mono key',
    rwa [nnreal.coe_add, nnreal.coe_mul] at key, },
end

/-- Finite measures yield elements of the `weak_dual` of bounded continuous nonnegative
functions via `finite_measure.test_against_nn`, i.e., integration. -/
def to_weak_dual_bcnn (μ : finite_measure α) :
  weak_dual ℝ≥0 (α →ᵇ ℝ≥0) :=
{ to_fun := λ f, μ.test_against_nn f,
  map_add' := test_against_nn_add μ,
  map_smul' := test_against_nn_smul μ,
  cont := μ.test_against_nn_lipschitz.continuous, }

@[simp] lemma coe_to_weak_dual_bcnn (μ : finite_measure α) :
  ⇑μ.to_weak_dual_bcnn = μ.test_against_nn := rfl

@[simp] lemma to_weak_dual_bcnn_apply (μ : finite_measure α) (f : α →ᵇ ℝ≥0) :
  μ.to_weak_dual_bcnn f = (∫⁻ x, f x ∂(μ : measure α)).to_nnreal := rfl

/-- The topology of weak convergence on `finite_measures α` is inherited (induced) from the weak-*
topology on `weak_dual ℝ≥0 (α →ᵇ ℝ≥0)` via the function `finite_measures.to_weak_dual_bcnn`. -/
instance : topological_space (finite_measure α) :=
topological_space.induced to_weak_dual_bcnn infer_instance

lemma to_weak_dual_bcnn_continuous :
  continuous (@finite_measure.to_weak_dual_bcnn α _ _ _) :=
continuous_induced_dom

/- Integration of (nonnegative bounded continuous) test functions against finite Borel measures
depends continuously on the measure. -/
lemma continuous_test_against_nn_eval (f : α →ᵇ ℝ≥0) :
  continuous (λ (μ : finite_measure α), μ.test_against_nn f) :=
(by apply (weak_bilin.eval_continuous _ _).comp to_weak_dual_bcnn_continuous :
  continuous ((λ φ : weak_dual ℝ≥0 (α →ᵇ ℝ≥0), φ f) ∘ to_weak_dual_bcnn))

lemma tendsto_iff_weak_star_tendsto {γ : Type*} {F : filter γ}
  {μs : γ → finite_measure α} {μ : finite_measure α} :
  tendsto μs F (𝓝 μ) ↔ tendsto (λ i, (μs(i)).to_weak_dual_bcnn) F (𝓝 μ.to_weak_dual_bcnn) :=
inducing.tendsto_nhds_iff ⟨rfl⟩

theorem tendsto_iff_forall_test_against_nn_tendsto {γ : Type*} {F : filter γ}
  {μs : γ → finite_measure α} {μ : finite_measure α} :
  tendsto μs F (𝓝 μ) ↔
  ∀ (f : α →ᵇ ℝ≥0), tendsto (λ i, (μs(i)).to_weak_dual_bcnn f) F (𝓝 (μ.to_weak_dual_bcnn f)) :=
by { rw [tendsto_iff_weak_star_tendsto, tendsto_iff_forall_eval_tendsto_top_dual_pairing], refl, }

theorem tendsto_iff_forall_lintegral_tendsto {γ : Type*} {F : filter γ}
  {μs : γ → finite_measure α} {μ : finite_measure α} :
  tendsto μs F (𝓝 μ) ↔
  ∀ (f : α →ᵇ ℝ≥0),
    tendsto (λ i, (∫⁻ x, (f x) ∂(μs(i) : measure α))) F (𝓝 ((∫⁻ x, (f x) ∂(μ : measure α)))) :=
begin
  rw tendsto_iff_forall_test_against_nn_tendsto,
  simp_rw [to_weak_dual_bcnn_apply _ _, ←test_against_nn_coe_eq,
           ennreal.tendsto_coe, ennreal.to_nnreal_coe],
end

/-- A bounded convergence theorem for a finite measure:
If bounded continuous non-negative functions are uniformly bounded by a constant and tend to a
limit, then their integrals against the finite measure tend to the integral of the limit.
This formulation assumes:
 * the functions tend to a limit along a countably generated filter;
 * the limit is in the almost everywhere sense;
 * boundedness holds almost everywhere;
 * integration is `lintegral`, i.e., the functions and their integrals are `ℝ≥0∞`-valued.
-/
lemma tendsto_lintegral_nn_filter_of_le_const {ι : Type*} {L : filter ι} [L.is_countably_generated]
  (μ : finite_measure α) {fs : ι → (α →ᵇ ℝ≥0)} {c : ℝ≥0}
  (fs_le_const : ∀ᶠ i in L, ∀ᵐ (a : α) ∂(μ : measure α), fs i a ≤ c) {f : α → ℝ≥0}
  (fs_lim : ∀ᵐ (a : α) ∂(μ : measure α), tendsto (λ i, fs i a) L (𝓝 (f a))) :
  tendsto (λ i, (∫⁻ a, fs i a ∂(μ : measure α))) L (𝓝 (∫⁻ a, (f a) ∂(μ : measure α))) :=
begin
  simpa only using tendsto_lintegral_filter_of_dominated_convergence (λ _, c)
    (eventually_of_forall ((λ i, (ennreal.continuous_coe.comp (fs i).continuous).measurable)))
    _ ((@lintegral_const_lt_top _ _ (μ : measure α) _ _ (@ennreal.coe_ne_top c)).ne) _,
  { simpa only [ennreal.coe_le_coe] using fs_le_const, },
  { simpa only [ennreal.tendsto_coe] using fs_lim, },
end

/-- A bounded convergence theorem for a finite measure:
If a sequence of bounded continuous non-negative functions are uniformly bounded by a constant
and tend pointwise to a limit, then their integrals (`lintegral`) against the finite measure tend
to the integral of the limit.

A related result with more general assumptions is `tendsto_lintegral_nn_filter_of_le_const`.
-/
lemma tendsto_lintegral_nn_of_le_const (μ : finite_measure α) {fs : ℕ → (α →ᵇ ℝ≥0)} {c : ℝ≥0}
  (fs_le_const : ∀ n a, fs n a ≤ c) {f : α → ℝ≥0}
  (fs_lim : ∀ a, tendsto (λ n, fs n a) at_top (𝓝 (f a))) :
  tendsto (λ n, (∫⁻ a, fs n a ∂(μ : measure α))) at_top (𝓝 (∫⁻ a, (f a) ∂(μ : measure α))) :=
tendsto_lintegral_nn_filter_of_le_const μ
  (eventually_of_forall (λ n, eventually_of_forall (fs_le_const n))) (eventually_of_forall fs_lim)

/-- A bounded convergence theorem for a finite measure:
If bounded continuous non-negative functions are uniformly bounded by a constant and tend to a
limit, then their integrals against the finite measure tend to the integral of the limit.
This formulation assumes:
 * the functions tend to a limit along a countably generated filter;
 * the limit is in the almost everywhere sense;
 * boundedness holds almost everywhere;
 * integration is the pairing against non-negative continuous test functions (`test_against_nn`).

A related result using `lintegral` for integration is `tendsto_lintegral_nn_filter_of_le_const`.
-/
lemma tendsto_test_against_nn_filter_of_le_const {ι : Type*} {L : filter ι}
  [L.is_countably_generated] {μ : finite_measure α} {fs : ι → (α →ᵇ ℝ≥0)} {c : ℝ≥0}
  (fs_le_const : ∀ᶠ i in L, ∀ᵐ (a : α) ∂(μ : measure α), fs i a ≤ c) {f : α →ᵇ ℝ≥0}
  (fs_lim : ∀ᵐ (a : α) ∂(μ : measure α), tendsto (λ i, fs i a) L (𝓝 (f a))) :
  tendsto (λ i, μ.test_against_nn (fs i)) L (𝓝 (μ.test_against_nn f)) :=
begin
  apply (ennreal.tendsto_to_nnreal
         (μ.lintegral_lt_top_of_bounded_continuous_to_nnreal f).ne).comp,
  exact finite_measure.tendsto_lintegral_nn_filter_of_le_const μ fs_le_const fs_lim,
end

/-- A bounded convergence theorem for a finite measure:
If a sequence of bounded continuous non-negative functions are uniformly bounded by a constant
and tend pointwise to a limit, then their integrals (`test_against_nn`) against the finite measure
tend to the integral of the limit.

Related results:
 * `tendsto_test_against_nn_filter_of_le_const`: more general assumptions
 * `tendsto_lintegral_nn_of_le_const`: using `lintegral` for integration.
-/
lemma tendsto_test_against_nn_of_le_const {μ : finite_measure α}
  {fs : ℕ → (α →ᵇ ℝ≥0)} {c : ℝ≥0} (fs_le_const : ∀ n a, fs n a ≤ c) {f : α →ᵇ ℝ≥0}
  (fs_lim : ∀ a, tendsto (λ n, fs n a) at_top (𝓝 (f a))) :
  tendsto (λ n, μ.test_against_nn (fs n)) at_top (𝓝 (μ.test_against_nn f)) :=
tendsto_test_against_nn_filter_of_le_const
  (eventually_of_forall (λ n, eventually_of_forall (fs_le_const n))) (eventually_of_forall fs_lim)

end finite_measure

/-- Probability measures are defined as the subtype of measures that have the property of being
probability measures (i.e., their total mass is one). -/
def probability_measure (α : Type*) [measurable_space α] : Type* :=
{μ : measure α // is_probability_measure μ}

namespace probability_measure

instance [inhabited α] : inhabited (probability_measure α) :=
⟨⟨measure.dirac default, measure.dirac.is_probability_measure⟩⟩

/-- A probability measure can be interpreted as a measure. -/
instance : has_coe (probability_measure α) (measure_theory.measure α) := coe_subtype

instance : has_coe_to_fun (probability_measure α) (λ _, set α → ℝ≥0) :=
⟨λ μ s, (μ s).to_nnreal⟩

instance (μ : probability_measure α) : is_probability_measure (μ : measure α) := μ.prop

lemma coe_fn_eq_to_nnreal_coe_fn_to_measure (ν : probability_measure α) :
  (ν : set α → ℝ≥0) = λ s, ((ν : measure α) s).to_nnreal := rfl

@[simp] lemma val_eq_to_measure (ν : probability_measure α) : ν.val = (ν : measure α) := rfl

lemma coe_injective : function.injective (coe : probability_measure α → measure α) :=
subtype.coe_injective

@[simp] lemma coe_fn_univ (ν : probability_measure α) : ν univ = 1 :=
congr_arg ennreal.to_nnreal ν.prop.measure_univ

/-- A probability measure can be interpreted as a finite measure. -/
def to_finite_measure (μ : probability_measure α) : finite_measure α := ⟨μ, infer_instance⟩

@[simp] lemma coe_comp_to_finite_measure_eq_coe (ν : probability_measure α) :
  (ν.to_finite_measure : measure α) = (ν : measure α) := rfl

@[simp] lemma coe_fn_comp_to_finite_measure_eq_coe_fn (ν : probability_measure α) :
  (ν.to_finite_measure : set α → ℝ≥0) = (ν : set α → ℝ≥0) := rfl

@[simp] lemma ennreal_coe_fn_eq_coe_fn_to_measure (ν : probability_measure α) (s : set α) :
  (ν s : ℝ≥0∞) = (ν : measure α) s :=
by { rw [← coe_fn_comp_to_finite_measure_eq_coe_fn,
     finite_measure.ennreal_coe_fn_eq_coe_fn_to_measure], refl, }

@[simp] lemma mass_to_finite_measure (μ : probability_measure α) :
  μ.to_finite_measure.mass = 1 := μ.coe_fn_univ

variables [topological_space α]

lemma lintegral_lt_top_of_bounded_continuous_to_nnreal (μ : probability_measure α) (f : α →ᵇ ℝ≥0) :
  ∫⁻ x, f x ∂(μ : measure α) < ∞ :=
μ.to_finite_measure.lintegral_lt_top_of_bounded_continuous_to_nnreal f

variables [opens_measurable_space α]

lemma test_against_nn_lipschitz (μ : probability_measure α) :
  lipschitz_with 1 (λ (f : α →ᵇ ℝ≥0), μ.to_finite_measure.test_against_nn f) :=
μ.mass_to_finite_measure ▸ μ.to_finite_measure.test_against_nn_lipschitz

/-- The topology of weak convergence on `probability_measures α`. This is inherited (induced) from
the weak-*  topology on `weak_dual ℝ≥0 (α →ᵇ ℝ≥0)` via the function
`probability_measures.to_weak_dual_bcnn`. -/
instance : topological_space (probability_measure α) :=
topological_space.induced to_finite_measure infer_instance

lemma to_finite_measure_continuous :
  continuous (to_finite_measure : probability_measure α → finite_measure α) :=
continuous_induced_dom

/-- Probability measures yield elements of the `weak_dual` of bounded continuous nonnegative
functions via `finite_measure.test_against_nn`, i.e., integration. -/
def to_weak_dual_bcnn : probability_measure α → weak_dual ℝ≥0 (α →ᵇ ℝ≥0) :=
finite_measure.to_weak_dual_bcnn ∘ to_finite_measure

@[simp] lemma coe_to_weak_dual_bcnn (μ : probability_measure α) :
  ⇑μ.to_weak_dual_bcnn = μ.to_finite_measure.test_against_nn := rfl

@[simp] lemma to_weak_dual_bcnn_apply (μ : probability_measure α) (f : α →ᵇ ℝ≥0) :
  μ.to_weak_dual_bcnn f = (∫⁻ x, f x ∂(μ : measure α)).to_nnreal := rfl

lemma to_weak_dual_bcnn_continuous :
  continuous (λ (μ : probability_measure α), μ.to_weak_dual_bcnn) :=
finite_measure.to_weak_dual_bcnn_continuous.comp to_finite_measure_continuous

/- Integration of (nonnegative bounded continuous) test functions against Borel probability
measures depends continuously on the measure. -/
lemma continuous_test_against_nn_eval (f : α →ᵇ ℝ≥0) :
  continuous (λ (μ : probability_measure α), μ.to_finite_measure.test_against_nn f) :=
(finite_measure.continuous_test_against_nn_eval f).comp to_finite_measure_continuous

/- The canonical mapping from probability measures to finite measures is an embedding. -/
lemma to_finite_measure_embedding (α : Type*)
  [measurable_space α] [topological_space α] [opens_measurable_space α] :
  embedding (to_finite_measure : probability_measure α → finite_measure α) :=
{ induced := rfl,
  inj := λ μ ν h, subtype.eq (by convert congr_arg coe h) }

lemma tendsto_nhds_iff_to_finite_measures_tendsto_nhds {δ : Type*}
  (F : filter δ) {μs : δ → probability_measure α} {μ₀ : probability_measure α} :
  tendsto μs F (𝓝 μ₀) ↔ tendsto (to_finite_measure ∘ μs) F (𝓝 (μ₀.to_finite_measure)) :=
embedding.tendsto_nhds_iff (probability_measure.to_finite_measure_embedding α)

/-- The usual definition of weak convergence of probability measures is given in terms of sequences
of probability measures: it is the requirement that the integrals of all continuous bounded
functions against members of the sequence converge. This version is a characterization using
nonnegative bounded continuous functions. -/
theorem tendsto_iff_forall_lintegral_tendsto {γ : Type*} {F : filter γ}
  {μs : γ → probability_measure α} {μ : probability_measure α} :
  tendsto μs F (𝓝 μ) ↔
  ∀ (f : α →ᵇ ℝ≥0), tendsto (λ i, (∫⁻ x, (f x) ∂(μs(i) : measure α))) F
    (𝓝 ((∫⁻ x, (f x) ∂(μ : measure α)))) :=
begin
  rw tendsto_nhds_iff_to_finite_measures_tendsto_nhds,
  exact finite_measure.tendsto_iff_forall_lintegral_tendsto,
end

end probability_measure

section convergence_implies_limsup_closed_le

/-- If bounded continuous functions tend to the indicator of a measurable set and are
uniformly bounded, then their integrals against a finite measure tend to the measure of the set.
This formulation assumes:
 * the functions tend to a limit along a countably generated filter;
 * the limit is in the almost everywhere sense;
 * boundedness holds almost everywhere.
-/
lemma measure_of_cont_bdd_of_tendsto_filter_indicator {ι : Type*} {L : filter ι}
  [L.is_countably_generated] [topological_space α] [opens_measurable_space α]
  (μ : finite_measure α) {c : ℝ≥0} {E : set α} (E_mble : measurable_set E)
  (fs : ι → (α →ᵇ ℝ≥0)) (fs_bdd : ∀ᶠ i in L, ∀ᵐ (a : α) ∂(μ : measure α), fs i a ≤ c)
  (fs_lim : ∀ᵐ (a : α) ∂(μ : measure α),
            tendsto (λ (i : ι), (coe_fn : (α →ᵇ ℝ≥0) → (α → ℝ≥0)) (fs i) a) L
                    (𝓝 (indicator E (λ x, (1 : ℝ≥0)) a))) :
  tendsto (λ n, lintegral (μ : measure α) (λ a, fs n a)) L (𝓝 ((μ : measure α) E)) :=
begin
  convert finite_measure.tendsto_lintegral_nn_filter_of_le_const μ fs_bdd fs_lim,
  have aux : ∀ a, indicator E (λ x, (1 : ℝ≥0∞)) a = ↑(indicator E (λ x, (1 : ℝ≥0)) a),
  from λ a, by simp only [ennreal.coe_indicator, ennreal.coe_one],
  simp_rw [←aux, lintegral_indicator _ E_mble],
  simp only [lintegral_one, measure.restrict_apply, measurable_set.univ, univ_inter],
end

/-- If a sequence of bounded continuous functions tends to the indicator of a measurable set and
the functions are uniformly bounded, then their integrals against a finite measure tend to the
measure of the set.

A similar result with more general assumptions is `measure_of_cont_bdd_of_tendsto_filter_indicator`.
-/
lemma measure_of_cont_bdd_of_tendsto_indicator
  [topological_space α] [opens_measurable_space α]
  (μ : finite_measure α) {c : ℝ≥0} {E : set α} (E_mble : measurable_set E)
  (fs : ℕ → (α →ᵇ ℝ≥0)) (fs_bdd : ∀ n a, fs n a ≤ c)
  (fs_lim : tendsto (λ (n : ℕ), (coe_fn : (α →ᵇ ℝ≥0) → (α → ℝ≥0)) (fs n))
            at_top (𝓝 (indicator E (λ x, (1 : ℝ≥0))))) :
  tendsto (λ n, lintegral (μ : measure α) (λ a, fs n a)) at_top (𝓝 ((μ : measure α) E)) :=
begin
  have fs_lim' : ∀ a, tendsto (λ (n : ℕ), (fs n a : ℝ≥0))
                 at_top (𝓝 (indicator E (λ x, (1 : ℝ≥0)) a)),
  by { rw tendsto_pi_nhds at fs_lim, exact λ a, fs_lim a, },
  apply measure_of_cont_bdd_of_tendsto_filter_indicator μ E_mble fs
      (eventually_of_forall (λ n, eventually_of_forall (fs_bdd n))) (eventually_of_forall fs_lim'),
end

/-- The integrals of thickenined indicators of a closed set against a finite measure tend to the
measure of the closed set if the thickening radii tend to zero.
-/
lemma tendsto_lintegral_thickened_indicator_of_is_closed
  {α : Type*} [measurable_space α] [pseudo_emetric_space α] [opens_measurable_space α]
  (μ : finite_measure α) {F : set α} (F_closed : is_closed F) {δs : ℕ → ℝ}
  (δs_pos : ∀ n, 0 < δs n) (δs_lim : tendsto δs at_top (𝓝 0)) :
  tendsto (λ n, lintegral (μ : measure α) (λ a, (thickened_indicator (δs_pos n) F a : ℝ≥0∞)))
          at_top (𝓝 ((μ : measure α) F)) :=
begin
  apply measure_of_cont_bdd_of_tendsto_indicator μ F_closed.measurable_set
          (λ n, thickened_indicator (δs_pos n) F)
          (λ n a, thickened_indicator_le_one (δs_pos n) F a),
  have key := thickened_indicator_tendsto_indicator_closure δs_pos δs_lim F,
  rwa F_closed.closure_eq at key,
end

/-- One implication of the portmanteau theorem:
Weak convergence of finite measures implies that the limsup of the measures of any closed set is
at most the measure of the closed set under the limit measure.
-/
lemma finite_measure.limsup_measure_closed_le_of_tendsto
  {α ι : Type*} {L : filter ι}
  [measurable_space α] [pseudo_emetric_space α] [opens_measurable_space α]
  {μ : finite_measure α} {μs : ι → finite_measure α}
  (μs_lim : tendsto μs L (𝓝 μ)) {F : set α} (F_closed : is_closed F) :
  L.limsup (λ i, (μs i : measure α) F) ≤ (μ : measure α) F :=
begin
  by_cases L = ⊥,
  { simp only [h, limsup, filter.map_bot, Limsup_bot, ennreal.bot_eq_zero, zero_le], },
  apply ennreal.le_of_forall_pos_le_add,
  intros ε ε_pos μ_F_finite,
  set δs := λ (n : ℕ), (1 : ℝ) / (n+1) with def_δs,
  have δs_pos : ∀ n, 0 < δs n, from λ n, nat.one_div_pos_of_nat,
  have δs_lim : tendsto δs at_top (𝓝 0), from tendsto_one_div_add_at_top_nhds_0_nat,
  have key₁ := tendsto_lintegral_thickened_indicator_of_is_closed μ F_closed δs_pos δs_lim,
  have room₁ : (μ : measure α) F < (μ : measure α) F + ε / 2,
  { apply ennreal.lt_add_right (measure_lt_top (μ : measure α) F).ne
          ((ennreal.div_pos_iff.mpr
              ⟨(ennreal.coe_pos.mpr ε_pos).ne.symm, ennreal.two_ne_top⟩).ne.symm), },
  rcases eventually_at_top.mp (eventually_lt_of_tendsto_lt room₁ key₁) with ⟨M, hM⟩,
  have key₂ := finite_measure.tendsto_iff_forall_lintegral_tendsto.mp
                μs_lim (thickened_indicator (δs_pos M) F),
  have room₂ : lintegral (μ : measure α) (λ a, thickened_indicator (δs_pos M) F a)
                < lintegral (μ : measure α) (λ a, thickened_indicator (δs_pos M) F a) + ε / 2,
  { apply ennreal.lt_add_right
          (finite_measure.lintegral_lt_top_of_bounded_continuous_to_nnreal μ _).ne
          ((ennreal.div_pos_iff.mpr
              ⟨(ennreal.coe_pos.mpr ε_pos).ne.symm, ennreal.two_ne_top⟩).ne.symm), },
  have ev_near := eventually.mono (eventually_lt_of_tendsto_lt room₂ key₂) (λ n, le_of_lt),
  have aux := λ n, le_trans (measure_le_lintegral_thickened_indicator
                            (μs n : measure α) F_closed.measurable_set (δs_pos M)),
  have ev_near' := eventually.mono ev_near aux,
  apply (filter.limsup_le_limsup ev_near').trans,
  haveI : ne_bot L, from ⟨h⟩,
  rw limsup_const,
  apply le_trans (add_le_add (hM M rfl.le).le (le_refl (ε/2 : ℝ≥0∞))),
  simp only [add_assoc, ennreal.add_halves, le_refl],
end

end convergence_implies_limsup_closed_le

end measure_theory


<|start_filename|>src/logic/lemmas.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import tactic.split_ifs

/-!
# More basic logic properties

A few more logic lemmas. These are in their own file, rather than `logic.basic`, because it is
convenient to be able to use the `split_ifs` tactic.

## Implementation notes

We spell those lemmas out with `dite` and `ite` rather than the `if then else` notation because this
would result in less delta-reduced statements.
-/

variables {α : Sort*} {p q r : Prop} [decidable p] [decidable q] {a b c : α}

lemma dite_dite_distrib_left {a : p → α} {b : ¬ p → q → α} {c : ¬ p → ¬ q → α} :
  dite p a (λ hp, dite q (b hp) (c hp)) =
    dite q (λ hq, dite p a $ λ hp, b hp hq) (λ hq, dite p a $ λ hp, c hp hq) :=
by split_ifs; refl

lemma dite_dite_distrib_right {a : p → q → α} {b : p → ¬ q → α} {c : ¬ p → α} :
  dite p (λ hp, dite q (a hp) (b hp)) c =
    dite q (λ hq, dite p (λ hp, a hp hq) c) (λ hq, dite p (λ hp, b hp hq) c) :=
by split_ifs; refl

lemma ite_dite_distrib_left {a : α} {b : q → α} {c : ¬ q → α} :
  ite p a (dite q b c) = dite q (λ hq, ite p a $ b hq) (λ hq, ite p a $ c hq) :=
dite_dite_distrib_left

lemma ite_dite_distrib_right {a : q → α} {b : ¬ q → α} {c : α} :
  ite p (dite q a b) c = dite q (λ hq, ite p (a hq) c) (λ hq, ite p (b hq) c) :=
dite_dite_distrib_right

lemma dite_ite_distrib_left {a : p → α} {b : ¬ p → α} {c : ¬ p → α} :
  dite p a (λ hp, ite q (b hp) (c hp)) = ite q (dite p a b) (dite p a c) :=
dite_dite_distrib_left

lemma dite_ite_distrib_right {a : p → α} {b : p → α} {c : ¬ p → α} :
  dite p (λ hp, ite q (a hp) (b hp)) c = ite q (dite p a c) (dite p b c) :=
dite_dite_distrib_right

lemma ite_ite_distrib_left : ite p a (ite q b c) = ite q (ite p a b) (ite p a c) :=
dite_dite_distrib_left

lemma ite_ite_distrib_right : ite p (ite q a b) c = ite q (ite p a c) (ite p b c) :=
dite_dite_distrib_right


<|start_filename|>src/probability/stopping.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.constructions.borel_space
import measure_theory.function.l1_space
import measure_theory.function.strongly_measurable
import topology.instances.discrete

/-!
# Filtration and stopping time

This file defines some standard definition from the theory of stochastic processes including
filtrations and stopping times. These definitions are used to model the amount of information
at a specific time and is the first step in formalizing stochastic processes.

## Main definitions

* `measure_theory.filtration`: a filtration on a measurable space
* `measure_theory.adapted`: a sequence of functions `u` is said to be adapted to a
  filtration `f` if at each point in time `i`, `u i` is `f i`-strongly measurable
* `measure_theory.prog_measurable`: a sequence of functions `u` is said to be progressively
  measurable with respect to a filtration `f` if at each point in time `i`, `u` restricted to
  `set.Iic i × α` is strongly measurable with respect to the product `measurable_space` structure
  where the σ-algebra used for `α` is `f i`.
* `measure_theory.filtration.natural`: the natural filtration with respect to a sequence of
  measurable functions is the smallest filtration to which it is adapted to
* `measure_theory.is_stopping_time`: a stopping time with respect to some filtration `f` is a
  function `τ` such that for all `i`, the preimage of `{j | j ≤ i}` along `τ` is
  `f i`-measurable
* `measure_theory.is_stopping_time.measurable_space`: the σ-algebra associated with a stopping time

## Main results

* `adapted.prog_measurable_of_continuous`: a continuous adapted process is progressively measurable.
* `prog_measurable.stopped_process`: the stopped process of a progressively measurable process is
  progressively measurable.
* `mem_ℒp_stopped_process`: if a process belongs to `ℒp` at every time in `ℕ`, then its stopped
  process belongs to `ℒp` as well.

## Tags

filtration, stopping time, stochastic process

-/

open filter order topological_space
open_locale classical measure_theory nnreal ennreal topological_space big_operators

namespace measure_theory

/-! ### Filtrations -/

/-- A `filtration` on measurable space `α` with σ-algebra `m` is a monotone
sequence of sub-σ-algebras of `m`. -/
structure filtration {α : Type*} (ι : Type*) [preorder ι] (m : measurable_space α) :=
(seq   : ι → measurable_space α)
(mono' : monotone seq)
(le'   : ∀ i : ι, seq i ≤ m)

variables {α β ι : Type*} {m : measurable_space α}

instance [preorder ι] : has_coe_to_fun (filtration ι m) (λ _, ι → measurable_space α) :=
⟨λ f, f.seq⟩

namespace filtration
variables [preorder ι]

protected lemma mono {i j : ι} (f : filtration ι m) (hij : i ≤ j) : f i ≤ f j := f.mono' hij

protected lemma le (f : filtration ι m) (i : ι) : f i ≤ m := f.le' i

@[ext] protected lemma ext {f g : filtration ι m} (h : (f : ι → measurable_space α) = g) : f = g :=
by { cases f, cases g, simp only, exact h, }

variable (ι)
/-- The constant filtration which is equal to `m` for all `i : ι`. -/
def const (m' : measurable_space α) (hm' : m' ≤ m) : filtration ι m :=
⟨λ _, m', monotone_const, λ _, hm'⟩
variable {ι}

@[simp]
lemma const_apply {m' : measurable_space α} {hm' : m' ≤ m} (i : ι) : const ι m' hm' i = m' := rfl

instance : inhabited (filtration ι m) := ⟨const ι m le_rfl⟩

instance : has_le (filtration ι m) := ⟨λ f g, ∀ i, f i ≤ g i⟩

instance : has_bot (filtration ι m) := ⟨const ι ⊥ bot_le⟩

instance : has_top (filtration ι m) := ⟨const ι m le_rfl⟩

instance : has_sup (filtration ι m) := ⟨λ f g,
{ seq   := λ i, f i ⊔ g i,
  mono' := λ i j hij, sup_le ((f.mono hij).trans le_sup_left) ((g.mono hij).trans le_sup_right),
  le'   := λ i, sup_le (f.le i) (g.le i) }⟩

@[norm_cast] lemma coe_fn_sup {f g : filtration ι m} : ⇑(f ⊔ g) = f ⊔ g := rfl

instance : has_inf (filtration ι m) := ⟨λ f g,
{ seq   := λ i, f i ⊓ g i,
  mono' := λ i j hij, le_inf (inf_le_left.trans (f.mono hij)) (inf_le_right.trans (g.mono hij)),
  le'   := λ i, inf_le_left.trans (f.le i) }⟩

@[norm_cast] lemma coe_fn_inf {f g : filtration ι m} : ⇑(f ⊓ g) = f ⊓ g := rfl

instance : has_Sup (filtration ι m) := ⟨λ s,
{ seq   := λ i, Sup ((λ f : filtration ι m, f i) '' s),
  mono' := λ i j hij,
  begin
    refine Sup_le (λ m' hm', _),
    rw [set.mem_image] at hm',
    obtain ⟨f, hf_mem, hfm'⟩ := hm',
    rw ← hfm',
    refine (f.mono hij).trans _,
    have hfj_mem : f j ∈ ((λ g : filtration ι m, g j) '' s), from ⟨f, hf_mem, rfl⟩,
    exact le_Sup hfj_mem,
  end,
  le'   := λ i,
  begin
    refine Sup_le (λ m' hm', _),
    rw [set.mem_image] at hm',
    obtain ⟨f, hf_mem, hfm'⟩ := hm',
    rw ← hfm',
    exact f.le i,
  end, }⟩

lemma Sup_def (s : set (filtration ι m)) (i : ι) :
  Sup s i = Sup ((λ f : filtration ι m, f i) '' s) :=
rfl

noncomputable
instance : has_Inf (filtration ι m) := ⟨λ s,
{ seq   := λ i, if set.nonempty s then Inf ((λ f : filtration ι m, f i) '' s) else m,
  mono' := λ i j hij,
  begin
    by_cases h_nonempty : set.nonempty s,
    swap, { simp only [h_nonempty, set.nonempty_image_iff, if_false, le_refl], },
    simp only [h_nonempty, if_true, le_Inf_iff, set.mem_image, forall_exists_index, and_imp,
      forall_apply_eq_imp_iff₂],
    refine λ f hf_mem, le_trans _ (f.mono hij),
    have hfi_mem : f i ∈ ((λ g : filtration ι m, g i) '' s), from ⟨f, hf_mem, rfl⟩,
    exact Inf_le hfi_mem,
  end,
  le'   := λ i,
  begin
    by_cases h_nonempty : set.nonempty s,
    swap, { simp only [h_nonempty, if_false, le_refl], },
    simp only [h_nonempty, if_true],
    obtain ⟨f, hf_mem⟩ := h_nonempty,
    exact le_trans (Inf_le ⟨f, hf_mem, rfl⟩) (f.le i),
  end, }⟩

lemma Inf_def (s : set (filtration ι m)) (i : ι) :
  Inf s i = if set.nonempty s then Inf ((λ f : filtration ι m, f i) '' s) else m :=
rfl

noncomputable
instance : complete_lattice (filtration ι m) :=
{ le           := (≤),
  le_refl      := λ f i, le_rfl,
  le_trans     := λ f g h h_fg h_gh i, (h_fg i).trans (h_gh i),
  le_antisymm  := λ f g h_fg h_gf, filtration.ext $ funext $ λ i, (h_fg i).antisymm (h_gf i),
  sup          := (⊔),
  le_sup_left  := λ f g i, le_sup_left,
  le_sup_right := λ f g i, le_sup_right,
  sup_le       := λ f g h h_fh h_gh i, sup_le (h_fh i) (h_gh _),
  inf          := (⊓),
  inf_le_left  := λ f g i, inf_le_left,
  inf_le_right := λ f g i, inf_le_right,
  le_inf       := λ f g h h_fg h_fh i, le_inf (h_fg i) (h_fh i),
  Sup          := Sup,
  le_Sup       := λ s f hf_mem i, le_Sup ⟨f, hf_mem, rfl⟩,
  Sup_le       := λ s f h_forall i, Sup_le $ λ m' hm',
  begin
    obtain ⟨g, hg_mem, hfm'⟩ := hm',
    rw ← hfm',
    exact h_forall g hg_mem i,
  end,
  Inf          := Inf,
  Inf_le       := λ s f hf_mem i,
  begin
    have hs : s.nonempty := ⟨f, hf_mem⟩,
    simp only [Inf_def, hs, if_true],
    exact Inf_le ⟨f, hf_mem, rfl⟩,
  end,
  le_Inf       := λ s f h_forall i,
  begin
    by_cases hs : s.nonempty,
    swap, { simp only [Inf_def, hs, if_false], exact f.le i, },
    simp only [Inf_def, hs, if_true, le_Inf_iff, set.mem_image, forall_exists_index, and_imp,
      forall_apply_eq_imp_iff₂],
    exact λ g hg_mem, h_forall g hg_mem i,
  end,
  top          := ⊤,
  bot          := ⊥,
  le_top       := λ f i, f.le' i,
  bot_le       := λ f i, bot_le, }

end filtration

lemma measurable_set_of_filtration [preorder ι] {f : filtration ι m} {s : set α} {i : ι}
  (hs : measurable_set[f i] s) : measurable_set[m] s :=
f.le i s hs

/-- A measure is σ-finite with respect to filtration if it is σ-finite with respect
to all the sub-σ-algebra of the filtration. -/
class sigma_finite_filtration [preorder ι] (μ : measure α) (f : filtration ι m) : Prop :=
(sigma_finite : ∀ i : ι, sigma_finite (μ.trim (f.le i)))

instance sigma_finite_of_sigma_finite_filtration [preorder ι] (μ : measure α) (f : filtration ι m)
  [hf : sigma_finite_filtration μ f] (i : ι) :
  sigma_finite (μ.trim (f.le i)) :=
by apply hf.sigma_finite -- can't exact here

@[priority 100]
instance is_finite_measure.sigma_finite_filtration [preorder ι] (μ : measure α) (f : filtration ι m)
  [is_finite_measure μ] :
  sigma_finite_filtration μ f :=
⟨λ n, by apply_instance⟩

section adapted_process

variables [topological_space β] [preorder ι]
  {u v : ι → α → β} {f : filtration ι m}

/-- A sequence of functions `u` is adapted to a filtration `f` if for all `i`,
`u i` is `f i`-measurable. -/
def adapted (f : filtration ι m) (u : ι → α → β) : Prop :=
∀ i : ι, strongly_measurable[f i] (u i)

namespace adapted

lemma add [has_add β] [has_continuous_add β] (hu : adapted f u) (hv : adapted f v) :
  adapted f (u + v) :=
λ i, (hu i).add (hv i)

lemma neg [add_group β] [topological_add_group β] (hu : adapted f u) : adapted f (-u) :=
λ i, (hu i).neg

lemma smul [has_scalar ℝ β] [has_continuous_smul ℝ β] (c : ℝ) (hu : adapted f u) :
  adapted f (c • u) :=
λ i, (hu i).const_smul c

end adapted

variable (β)
lemma adapted_zero [has_zero β] (f : filtration ι m) : adapted f (0 : ι → α → β) :=
λ i, @strongly_measurable_zero α β (f i) _ _
variable {β}

/-- Progressively measurable process. A sequence of functions `u` is said to be progressively
measurable with respect to a filtration `f` if at each point in time `i`, `u` restricted to
`set.Iic i × α` is measurable with respect to the product `measurable_space` structure where the
σ-algebra used for `α` is `f i`.
The usual definition uses the interval `[0,i]`, which we replace by `set.Iic i`. We recover the
usual definition for index types `ℝ≥0` or `ℕ`. -/
def prog_measurable [measurable_space ι] (f : filtration ι m) (u : ι → α → β) : Prop :=
∀ i, strongly_measurable[subtype.measurable_space.prod (f i)] (λ p : set.Iic i × α, u p.1 p.2)

lemma prog_measurable_const [measurable_space ι] (f : filtration ι m) (b : β) :
  prog_measurable f ((λ _ _, b) : ι → α → β) :=
λ i, @strongly_measurable_const _ _ (subtype.measurable_space.prod (f i)) _ _

namespace prog_measurable

variables [measurable_space ι]

protected lemma adapted (h : prog_measurable f u) : adapted f u :=
begin
  intro i,
  have : u i = (λ p : set.Iic i × α, u p.1 p.2) ∘ (λ x, (⟨i, set.mem_Iic.mpr le_rfl⟩, x)) := rfl,
  rw this,
  exact (h i).comp_measurable measurable_prod_mk_left,
end

protected lemma comp {t : ι → α → ι} [topological_space ι] [borel_space ι] [metrizable_space ι]
  (h : prog_measurable f u) (ht : prog_measurable f t)
  (ht_le : ∀ i x, t i x ≤ i) :
  prog_measurable f (λ i x, u (t i x) x) :=
begin
  intro i,
  have : (λ p : ↥(set.Iic i) × α, u (t (p.fst : ι) p.snd) p.snd)
    = (λ p : ↥(set.Iic i) × α, u (p.fst : ι) p.snd) ∘ (λ p : ↥(set.Iic i) × α,
      (⟨t (p.fst : ι) p.snd, set.mem_Iic.mpr ((ht_le _ _).trans p.fst.prop)⟩, p.snd)) := rfl,
  rw this,
  exact (h i).comp_measurable ((ht i).measurable.subtype_mk.prod_mk measurable_snd),
end

section arithmetic

@[to_additive] protected lemma mul [has_mul β] [has_continuous_mul β]
  (hu : prog_measurable f u) (hv : prog_measurable f v) :
  prog_measurable f (λ i x, u i x * v i x) :=
λ i, (hu i).mul (hv i)

@[to_additive] protected lemma finset_prod' {γ} [comm_monoid β] [has_continuous_mul β]
  {U : γ → ι → α → β} {s : finset γ} (h : ∀ c ∈ s, prog_measurable f (U c)) :
  prog_measurable f (∏ c in s, U c) :=
finset.prod_induction U (prog_measurable f) (λ _ _, prog_measurable.mul)
  (prog_measurable_const _ 1) h

@[to_additive] protected lemma finset_prod {γ} [comm_monoid β] [has_continuous_mul β]
  {U : γ → ι → α → β} {s : finset γ} (h : ∀ c ∈ s, prog_measurable f (U c)) :
  prog_measurable f (λ i a, ∏ c in s, U c i a) :=
by { convert prog_measurable.finset_prod' h, ext i a, simp only [finset.prod_apply], }

@[to_additive] protected lemma inv [group β] [topological_group β] (hu : prog_measurable f u) :
  prog_measurable f (λ i x, (u i x)⁻¹) :=
λ i, (hu i).inv

@[to_additive] protected lemma div [group β] [topological_group β]
  (hu : prog_measurable f u) (hv : prog_measurable f v) :
  prog_measurable f (λ i x, u i x / v i x) :=
λ i, (hu i).div (hv i)

end arithmetic

end prog_measurable

lemma prog_measurable_of_tendsto' {γ} [measurable_space ι] [metrizable_space β]
  (fltr : filter γ) [fltr.ne_bot] [fltr.is_countably_generated] {U : γ → ι → α → β}
  (h : ∀ l, prog_measurable f (U l)) (h_tendsto : tendsto U fltr (𝓝 u)) :
  prog_measurable f u :=
begin
  assume i,
  apply @strongly_measurable_of_tendsto (set.Iic i × α) β γ (measurable_space.prod _ (f i))
   _ _ fltr _ _ _ _ (λ l, h l i),
  rw tendsto_pi_nhds at h_tendsto ⊢,
  intro x,
  specialize h_tendsto x.fst,
  rw tendsto_nhds at h_tendsto ⊢,
  exact λ s hs h_mem, h_tendsto {g | g x.snd ∈ s} (hs.preimage (continuous_apply x.snd)) h_mem,
end

lemma prog_measurable_of_tendsto [measurable_space ι] [metrizable_space β]
  {U : ℕ → ι → α → β}
  (h : ∀ l, prog_measurable f (U l)) (h_tendsto : tendsto U at_top (𝓝 u)) :
  prog_measurable f u :=
prog_measurable_of_tendsto' at_top h h_tendsto


/-- A continuous and adapted process is progressively measurable. -/
theorem adapted.prog_measurable_of_continuous
  [topological_space ι] [metrizable_space ι] [measurable_space ι]
  [second_countable_topology ι] [opens_measurable_space ι] [metrizable_space β]
  (h : adapted f u) (hu_cont : ∀ x, continuous (λ i, u i x)) :
  prog_measurable f u :=
λ i, @strongly_measurable_uncurry_of_continuous_of_strongly_measurable _ _ (set.Iic i) _ _ _ _ _ _ _
  (f i) _ (λ x, (hu_cont x).comp continuous_induced_dom) (λ j, (h j).mono (f.mono j.prop))

end adapted_process

namespace filtration
variables [topological_space β] [metrizable_space β] [mβ : measurable_space β] [borel_space β]
  [preorder ι]

include mβ

/-- Given a sequence of functions, the natural filtration is the smallest sequence
of σ-algebras such that that sequence of functions is measurable with respect to
the filtration. -/
def natural (u : ι → α → β) (hum : ∀ i, strongly_measurable (u i)) : filtration ι m :=
{ seq   := λ i, ⨆ j ≤ i, measurable_space.comap (u j) mβ,
  mono' := λ i j hij, bsupr_mono $ λ k, ge_trans hij,
  le'   := λ i,
  begin
    refine supr₂_le _,
    rintros j hj s ⟨t, ht, rfl⟩,
    exact (hum j).measurable ht,
  end }

lemma adapted_natural {u : ι → α → β} (hum : ∀ i, strongly_measurable[m] (u i)) :
  adapted (natural u hum) u :=
begin
  assume i,
  refine strongly_measurable.mono _ (le_supr₂_of_le i (le_refl i) le_rfl),
  rw strongly_measurable_iff_measurable_separable,
  exact ⟨measurable_iff_comap_le.2 le_rfl, (hum i).is_separable_range⟩
end

end filtration

/-! ### Stopping times -/

/-- A stopping time with respect to some filtration `f` is a function
`τ` such that for all `i`, the preimage of `{j | j ≤ i}` along `τ` is measurable
with respect to `f i`.

Intuitively, the stopping time `τ` describes some stopping rule such that at time
`i`, we may determine it with the information we have at time `i`. -/
def is_stopping_time [preorder ι] (f : filtration ι m) (τ : α → ι) :=
∀ i : ι, measurable_set[f i] $ {x | τ x ≤ i}

lemma is_stopping_time_const [preorder ι] (f : filtration ι m) (i : ι) :
  is_stopping_time f (λ x, i) :=
λ j, by simp only [measurable_set.const]

section measurable_set

section preorder
variables [preorder ι] {f : filtration ι m} {τ : α → ι}

protected lemma is_stopping_time.measurable_set_le (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[f i] {x | τ x ≤ i} :=
hτ i

lemma is_stopping_time.measurable_set_lt_of_pred [pred_order ι]
  (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[f i] {x | τ x < i} :=
begin
  by_cases hi_min : is_min i,
  { suffices : {x : α | τ x < i} = ∅, by { rw this, exact @measurable_set.empty _ (f i), },
    ext1 x,
    simp only [set.mem_set_of_eq, set.mem_empty_eq, iff_false],
    rw is_min_iff_forall_not_lt at hi_min,
    exact hi_min (τ x), },
  have : {x : α | τ x < i} = τ ⁻¹' (set.Iio i) := rfl,
  rw [this, ←Iic_pred_of_not_is_min hi_min],
  exact f.mono (pred_le i) _ (hτ.measurable_set_le $ pred i),
end

end preorder

section linear_order
variables [linear_order ι] {f : filtration ι m} {τ : α → ι}

lemma is_stopping_time.measurable_set_gt (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[f i] {x | i < τ x} :=
begin
  have : {x | i < τ x} = {x | τ x ≤ i}ᶜ,
  { ext1 x, simp only [set.mem_set_of_eq, set.mem_compl_eq, not_le], },
  rw this,
  exact (hτ.measurable_set_le i).compl,
end

variables [topological_space ι] [order_topology ι] [first_countable_topology ι]

/-- Auxiliary lemma for `is_stopping_time.measurable_set_lt`. -/
lemma is_stopping_time.measurable_set_lt_of_is_lub
  (hτ : is_stopping_time f τ) (i : ι) (h_lub : is_lub (set.Iio i) i) :
  measurable_set[f i] {x | τ x < i} :=
begin
  by_cases hi_min : is_min i,
  { suffices : {x : α | τ x < i} = ∅, by { rw this, exact @measurable_set.empty _ (f i), },
    ext1 x,
    simp only [set.mem_set_of_eq, set.mem_empty_eq, iff_false],
    exact is_min_iff_forall_not_lt.mp hi_min (τ x), },
  obtain ⟨seq, -, -, h_tendsto, h_bound⟩ : ∃ seq : ℕ → ι,
      monotone seq ∧ (∀ j, seq j ≤ i) ∧ tendsto seq at_top (𝓝 i) ∧ (∀ j, seq j < i),
    from h_lub.exists_seq_monotone_tendsto (not_is_min_iff.mp hi_min),
  have h_Ioi_eq_Union : set.Iio i = ⋃ j, { k | k ≤ seq j},
  { ext1 k,
    simp only [set.mem_Iio, set.mem_Union, set.mem_set_of_eq],
    refine ⟨λ hk_lt_i, _, λ h_exists_k_le_seq, _⟩,
    { rw tendsto_at_top' at h_tendsto,
      have h_nhds : set.Ici k ∈ 𝓝 i,
        from mem_nhds_iff.mpr ⟨set.Ioi k, set.Ioi_subset_Ici le_rfl, is_open_Ioi, hk_lt_i⟩,
      obtain ⟨a, ha⟩ : ∃ (a : ℕ), ∀ (b : ℕ), b ≥ a → k ≤ seq b := h_tendsto (set.Ici k) h_nhds,
      exact ⟨a, ha a le_rfl⟩, },
    { obtain ⟨j, hk_seq_j⟩ := h_exists_k_le_seq,
      exact hk_seq_j.trans_lt (h_bound j), }, },
  have h_lt_eq_preimage : {x : α | τ x < i} = τ ⁻¹' (set.Iio i),
  { ext1 x, simp only [set.mem_set_of_eq, set.mem_preimage, set.mem_Iio], },
  rw [h_lt_eq_preimage, h_Ioi_eq_Union],
  simp only [set.preimage_Union, set.preimage_set_of_eq],
  exact measurable_set.Union
    (λ n, f.mono (h_bound n).le _ (hτ.measurable_set_le (seq n))),
end

lemma is_stopping_time.measurable_set_lt (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[f i] {x | τ x < i} :=
begin
  obtain ⟨i', hi'_lub⟩ : ∃ i', is_lub (set.Iio i) i', from exists_lub_Iio i,
  cases lub_Iio_eq_self_or_Iio_eq_Iic i hi'_lub with hi'_eq_i h_Iio_eq_Iic,
  { rw ← hi'_eq_i at hi'_lub ⊢,
    exact hτ.measurable_set_lt_of_is_lub i' hi'_lub, },
  { have h_lt_eq_preimage : {x : α | τ x < i} = τ ⁻¹' (set.Iio i) := rfl,
    rw [h_lt_eq_preimage, h_Iio_eq_Iic],
    exact f.mono (lub_Iio_le i hi'_lub) _ (hτ.measurable_set_le i'), },
end

lemma is_stopping_time.measurable_set_ge (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[f i] {x | i ≤ τ x} :=
begin
  have : {x | i ≤ τ x} = {x | τ x < i}ᶜ,
  { ext1 x, simp only [set.mem_set_of_eq, set.mem_compl_eq, not_lt], },
  rw this,
  exact (hτ.measurable_set_lt i).compl,
end

lemma is_stopping_time.measurable_set_eq (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[f i] {x | τ x = i} :=
begin
  have : {x | τ x = i} = {x | τ x ≤ i} ∩ {x | τ x ≥ i},
  { ext1 x, simp only [set.mem_set_of_eq, ge_iff_le, set.mem_inter_eq, le_antisymm_iff], },
  rw this,
  exact (hτ.measurable_set_le i).inter (hτ.measurable_set_ge i),
end

lemma is_stopping_time.measurable_set_eq_le (hτ : is_stopping_time f τ) {i j : ι} (hle : i ≤ j) :
  measurable_set[f j] {x | τ x = i} :=
f.mono hle _ $ hτ.measurable_set_eq i

lemma is_stopping_time.measurable_set_lt_le (hτ : is_stopping_time f τ) {i j : ι} (hle : i ≤ j) :
  measurable_set[f j] {x | τ x < i} :=
f.mono hle _ $ hτ.measurable_set_lt i

end linear_order

section encodable

lemma is_stopping_time_of_measurable_set_eq [preorder ι] [encodable ι]
  {f : filtration ι m} {τ : α → ι} (hτ : ∀ i, measurable_set[f i] {x | τ x = i}) :
  is_stopping_time f τ :=
begin
  intro i,
  rw show {x | τ x ≤ i} = ⋃ k ≤ i, {x | τ x = k}, by { ext, simp },
  refine measurable_set.bUnion (set.countable_encodable _) (λ k hk, _),
  exact f.mono hk _ (hτ k),
end

end encodable

end measurable_set

namespace is_stopping_time

protected lemma max [linear_order ι] {f : filtration ι m} {τ π : α → ι}
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  is_stopping_time f (λ x, max (τ x) (π x)) :=
begin
  intro i,
  simp_rw [max_le_iff, set.set_of_and],
  exact (hτ i).inter (hπ i),
end

protected lemma max_const [linear_order ι] {f : filtration ι m} {τ : α → ι}
  (hτ : is_stopping_time f τ) (i : ι) :
  is_stopping_time f (λ x, max (τ x) i) :=
hτ.max (is_stopping_time_const f i)

protected lemma min [linear_order ι] {f : filtration ι m} {τ π : α → ι}
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  is_stopping_time f (λ x, min (τ x) (π x)) :=
begin
  intro i,
  simp_rw [min_le_iff, set.set_of_or],
  exact (hτ i).union (hπ i),
end

protected lemma min_const [linear_order ι] {f : filtration ι m} {τ : α → ι}
  (hτ : is_stopping_time f τ) (i : ι) :
  is_stopping_time f (λ x, min (τ x) i) :=
hτ.min (is_stopping_time_const f i)

lemma add_const [add_group ι] [preorder ι] [covariant_class ι ι (function.swap (+)) (≤)]
  [covariant_class ι ι (+) (≤)]
  {f : filtration ι m} {τ : α → ι} (hτ : is_stopping_time f τ) {i : ι} (hi : 0 ≤ i) :
  is_stopping_time f (λ x, τ x + i) :=
begin
  intro j,
  simp_rw [← le_sub_iff_add_le],
  exact f.mono (sub_le_self j hi) _ (hτ (j - i)),
end

lemma add_const_nat
  {f : filtration ℕ m} {τ : α → ℕ} (hτ : is_stopping_time f τ) {i : ℕ} :
  is_stopping_time f (λ x, τ x + i) :=
begin
  refine is_stopping_time_of_measurable_set_eq (λ j, _),
  by_cases hij : i ≤ j,
  { simp_rw [eq_comm, ← nat.sub_eq_iff_eq_add hij, eq_comm],
    exact f.mono (j.sub_le i) _ (hτ.measurable_set_eq (j - i)) },
  { rw not_le at hij,
    convert measurable_set.empty,
    ext x,
    simp only [set.mem_empty_eq, iff_false],
    rintro (hx : τ x + i = j),
    linarith },
end

-- generalize to certain encodable type?
lemma add
  {f : filtration ℕ m} {τ π : α → ℕ} (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  is_stopping_time f (τ + π) :=
begin
  intro i,
  rw (_ : {x | (τ + π) x ≤ i} = ⋃ k ≤ i, {x | π x = k} ∩ {x | τ x + k ≤ i}),
  { exact measurable_set.Union (λ k, measurable_set.Union_Prop
      (λ hk, (hπ.measurable_set_eq_le hk).inter (hτ.add_const_nat i))) },
  ext,
  simp only [pi.add_apply, set.mem_set_of_eq, set.mem_Union, set.mem_inter_eq, exists_prop],
  refine ⟨λ h, ⟨π x, by linarith, rfl, h⟩, _⟩,
  rintro ⟨j, hj, rfl, h⟩,
  assumption
end

section preorder

variables [preorder ι] {f : filtration ι m} {τ π : α → ι}

/-- The associated σ-algebra with a stopping time. -/
protected def measurable_space (hτ : is_stopping_time f τ) : measurable_space α :=
{ measurable_set' := λ s, ∀ i : ι, measurable_set[f i] (s ∩ {x | τ x ≤ i}),
  measurable_set_empty :=
    λ i, (set.empty_inter {x | τ x ≤ i}).symm ▸ @measurable_set.empty _ (f i),
  measurable_set_compl := λ s hs i,
    begin
      rw (_ : sᶜ ∩ {x | τ x ≤ i} = (sᶜ ∪ {x | τ x ≤ i}ᶜ) ∩ {x | τ x ≤ i}),
      { refine measurable_set.inter _ _,
        { rw ← set.compl_inter,
          exact (hs i).compl },
        { exact hτ i} },
      { rw set.union_inter_distrib_right,
        simp only [set.compl_inter_self, set.union_empty] }
    end,
  measurable_set_Union := λ s hs i,
    begin
      rw forall_swap at hs,
      rw set.Union_inter,
      exact measurable_set.Union (hs i),
    end }

protected lemma measurable_set (hτ : is_stopping_time f τ) (s : set α) :
  measurable_set[hτ.measurable_space] s ↔
  ∀ i : ι, measurable_set[f i] (s ∩ {x | τ x ≤ i}) :=
iff.rfl

lemma measurable_space_mono
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) (hle : τ ≤ π) :
  hτ.measurable_space ≤ hπ.measurable_space :=
begin
  intros s hs i,
  rw (_ : s ∩ {x | π x ≤ i} = s ∩ {x | τ x ≤ i} ∩ {x | π x ≤ i}),
  { exact (hs i).inter (hπ i) },
  { ext,
    simp only [set.mem_inter_eq, iff_self_and, and.congr_left_iff, set.mem_set_of_eq],
    intros hle' _,
    exact le_trans (hle _) hle' },
end

lemma measurable_space_le_of_encodable [encodable ι] (hτ : is_stopping_time f τ) :
  hτ.measurable_space ≤ m :=
begin
  intros s hs,
  change ∀ i, measurable_set[f i] (s ∩ {x | τ x ≤ i}) at hs,
  rw (_ : s = ⋃ i, s ∩ {x | τ x ≤ i}),
  { exact measurable_set.Union (λ i, f.le i _ (hs i)) },
  { ext x, split; rw set.mem_Union,
    { exact λ hx, ⟨τ x, hx, le_rfl⟩ },
    { rintro ⟨_, hx, _⟩,
      exact hx } }
end

lemma measurable_space_le' [is_countably_generated (at_top : filter ι)] [(at_top : filter ι).ne_bot]
  (hτ : is_stopping_time f τ) :
  hτ.measurable_space ≤ m :=
begin
  intros s hs,
  change ∀ i, measurable_set[f i] (s ∩ {x | τ x ≤ i}) at hs,
  obtain ⟨seq : ℕ → ι, h_seq_tendsto⟩ := at_top.exists_seq_tendsto,
  rw (_ : s = ⋃ n, s ∩ {x | τ x ≤ seq n}),
  { exact measurable_set.Union (λ i, f.le (seq i) _ (hs (seq i))), },
  { ext x, split; rw set.mem_Union,
    { intros hx,
      suffices : ∃ i, τ x ≤ seq i, from ⟨this.some, hx, this.some_spec⟩,
      rw tendsto_at_top at h_seq_tendsto,
      exact (h_seq_tendsto (τ x)).exists, },
    { rintro ⟨_, hx, _⟩,
      exact hx }, },
  all_goals { apply_instance, },
end

lemma measurable_space_le {ι} [semilattice_sup ι] {f : filtration ι m} {τ : α → ι}
  [is_countably_generated (at_top : filter ι)] (hτ : is_stopping_time f τ) :
  hτ.measurable_space ≤ m :=
begin
  casesI is_empty_or_nonempty ι,
  { haveI : is_empty α := ⟨λ x, is_empty.false (τ x)⟩,
    intros s hsτ,
    suffices hs : s = ∅, by { rw hs, exact measurable_set.empty, },
    haveI : unique (set α) := set.unique_empty,
    rw [unique.eq_default s, unique.eq_default ∅], },
  exact measurable_space_le' hτ,
end

example {f : filtration ℕ m} {τ : α → ℕ} (hτ : is_stopping_time f τ) : hτ.measurable_space ≤ m :=
hτ.measurable_space_le

example {f : filtration ℝ m} {τ : α → ℝ} (hτ : is_stopping_time f τ) : hτ.measurable_space ≤ m :=
hτ.measurable_space_le

@[simp] lemma measurable_space_const (f : filtration ι m) (i : ι) :
  (is_stopping_time_const f i).measurable_space = f i :=
begin
  ext1 s,
  change measurable_set[(is_stopping_time_const f i).measurable_space] s ↔ measurable_set[f i] s,
  rw is_stopping_time.measurable_set,
  split; intro h,
  { specialize h i,
    simpa only [le_refl, set.set_of_true, set.inter_univ] using h, },
  { intro j,
    by_cases hij : i ≤ j,
    { simp only [hij, set.set_of_true, set.inter_univ],
      exact f.mono hij _ h, },
    { simp only [hij, set.set_of_false, set.inter_empty, measurable_set.empty], }, },
end

lemma measurable_set_inter_eq_iff (hτ : is_stopping_time f τ) (s : set α) (i : ι) :
  measurable_set[hτ.measurable_space] (s ∩ {x | τ x = i})
    ↔ measurable_set[f i] (s ∩ {x | τ x = i}) :=
begin
  have : ∀ j, ({x : α | τ x = i} ∩ {x : α | τ x ≤ j}) = {x : α | τ x = i} ∩ {x | i ≤ j},
  { intro j,
    ext1 x,
    simp only [set.mem_inter_eq, set.mem_set_of_eq, and.congr_right_iff],
    intro hxi,
    rw hxi, },
  split; intro h,
  { specialize h i,
    simpa only [set.inter_assoc, this, le_refl, set.set_of_true, set.inter_univ] using h, },
  { intro j,
    rw [set.inter_assoc, this],
    by_cases hij : i ≤ j,
    { simp only [hij, set.set_of_true, set.inter_univ],
      exact f.mono hij _ h, },
    { simp [hij], }, },
end

lemma measurable_space_le_of_le_const (hτ : is_stopping_time f τ) {i : ι} (hτ_le : ∀ x, τ x ≤ i) :
  hτ.measurable_space ≤ f i :=
(measurable_space_mono hτ _ hτ_le).trans (measurable_space_const _ _).le

lemma le_measurable_space_of_const_le (hτ : is_stopping_time f τ) {i : ι} (hτ_le : ∀ x, i ≤ τ x) :
  f i ≤ hτ.measurable_space :=
(measurable_space_const _ _).symm.le.trans (measurable_space_mono _ hτ hτ_le)

end preorder

section linear_order

variables [linear_order ι] {f : filtration ι m} {τ π : α → ι}

protected lemma measurable_set_le' (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[hτ.measurable_space] {x | τ x ≤ i} :=
begin
  intro j,
  have : {x : α | τ x ≤ i} ∩ {x : α | τ x ≤ j} = {x : α | τ x ≤ min i j},
  { ext1 x, simp only [set.mem_inter_eq, set.mem_set_of_eq, le_min_iff], },
  rw this,
  exact f.mono (min_le_right i j) _ (hτ _),
end

protected lemma measurable_set_gt' (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[hτ.measurable_space] {x | i < τ x} :=
begin
  have : {x : α | i < τ x} = {x : α | τ x ≤ i}ᶜ, by { ext1 x, simp, },
  rw this,
  exact (hτ.measurable_set_le' i).compl,
end

protected lemma measurable_set_eq' [topological_space ι] [order_topology ι]
  [first_countable_topology ι]
  (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[hτ.measurable_space] {x | τ x = i} :=
begin
  rw [← set.univ_inter {x | τ x = i}, measurable_set_inter_eq_iff, set.univ_inter],
  exact hτ.measurable_set_eq i,
end

protected lemma measurable_set_ge' [topological_space ι] [order_topology ι]
  [first_countable_topology ι]
  (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[hτ.measurable_space] {x | i ≤ τ x} :=
begin
  have : {x | i ≤ τ x} = {x | τ x = i} ∪ {x | i < τ x},
  { ext1 x,
    simp only [le_iff_lt_or_eq, set.mem_set_of_eq, set.mem_union_eq],
    rw [@eq_comm _ i, or_comm], },
  rw this,
  exact (hτ.measurable_set_eq' i).union (hτ.measurable_set_gt' i),
end

protected lemma measurable_set_lt' [topological_space ι] [order_topology ι]
  [first_countable_topology ι]
  (hτ : is_stopping_time f τ) (i : ι) :
  measurable_set[hτ.measurable_space] {x | τ x < i} :=
begin
  have : {x | τ x < i} = {x | τ x ≤ i} \ {x | τ x = i},
  { ext1 x,
    simp only [lt_iff_le_and_ne, set.mem_set_of_eq, set.mem_diff], },
  rw this,
  exact (hτ.measurable_set_le' i).diff (hτ.measurable_set_eq' i),
end

protected lemma measurable [topological_space ι] [measurable_space ι]
  [borel_space ι] [order_topology ι] [second_countable_topology ι]
  (hτ : is_stopping_time f τ) :
  measurable[hτ.measurable_space] τ :=
@measurable_of_Iic ι α _ _ _ hτ.measurable_space _ _ _ _ (λ i, hτ.measurable_set_le' i)

protected lemma measurable_of_le [topological_space ι] [measurable_space ι]
  [borel_space ι] [order_topology ι] [second_countable_topology ι]
  (hτ : is_stopping_time f τ) {i : ι} (hτ_le : ∀ x, τ x ≤ i) :
  measurable[f i] τ :=
hτ.measurable.mono (measurable_space_le_of_le_const _ hτ_le) le_rfl

lemma measurable_space_min (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  (hτ.min hπ).measurable_space = hτ.measurable_space ⊓ hπ.measurable_space :=
begin
  refine le_antisymm _ _,
  { exact le_inf (measurable_space_mono _ hτ (λ _, min_le_left _ _))
      (measurable_space_mono _ hπ (λ _, min_le_right _ _)), },
  { intro s,
    change measurable_set[hτ.measurable_space] s ∧ measurable_set[hπ.measurable_space] s
      → measurable_set[(hτ.min hπ).measurable_space] s,
    simp_rw is_stopping_time.measurable_set,
    have : ∀ i, {x | min (τ x) (π x) ≤ i} = {x | τ x ≤ i} ∪ {x | π x ≤ i},
    { intro i, ext1 x, simp, },
    simp_rw [this, set.inter_union_distrib_left],
    exact λ h i, (h.left i).union (h.right i), },
end

lemma measurable_set_min_iff (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) (s : set α) :
  measurable_set[(hτ.min hπ).measurable_space] s
    ↔ measurable_set[hτ.measurable_space] s ∧ measurable_set[hπ.measurable_space] s :=
by { rw measurable_space_min, refl, }

lemma measurable_space_min_const (hτ : is_stopping_time f τ) {i : ι} :
  (hτ.min_const i).measurable_space = hτ.measurable_space ⊓ f i :=
by rw [hτ.measurable_space_min (is_stopping_time_const _ i), measurable_space_const]

lemma measurable_set_min_const_iff (hτ : is_stopping_time f τ) (s : set α)
  {i : ι} :
  measurable_set[(hτ.min_const i).measurable_space] s
    ↔ measurable_set[hτ.measurable_space] s ∧ measurable_set[f i] s :=
by rw [measurable_space_min_const, measurable_space.measurable_set_inf]

lemma measurable_set_inter_le [topological_space ι] [second_countable_topology ι] [order_topology ι]
  [measurable_space ι] [borel_space ι]
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) (s : set α)
  (hs : measurable_set[hτ.measurable_space] s) :
  measurable_set[(hτ.min hπ).measurable_space] (s ∩ {x | τ x ≤ π x}) :=
begin
  simp_rw is_stopping_time.measurable_set at ⊢ hs,
  intro i,
  have : (s ∩ {x | τ x ≤ π x} ∩ {x | min (τ x) (π x) ≤ i})
    = (s ∩ {x | τ x ≤ i}) ∩ {x | min (τ x) (π x) ≤ i} ∩ {x | min (τ x) i ≤ min (min (τ x) (π x)) i},
  { ext1 x,
    simp only [min_le_iff, set.mem_inter_eq, set.mem_set_of_eq, le_min_iff, le_refl, true_and,
      and_true, true_or, or_true],
    by_cases hτi : τ x ≤ i,
    { simp only [hτi, true_or, and_true, and.congr_right_iff],
      intro hx,
      split; intro h,
      { exact or.inl h, },
      { cases h,
        { exact h, },
        { exact hτi.trans h, }, }, },
    simp only [hτi, false_or, and_false, false_and, iff_false, not_and, not_le, and_imp],
    refine λ hx hτ_le_π, lt_of_lt_of_le _ hτ_le_π,
    rw ← not_le,
    exact hτi, },
  rw this,
  refine ((hs i).inter ((hτ.min hπ) i)).inter _,
  apply measurable_set_le,
  { exact (hτ.min_const i).measurable_of_le (λ _, min_le_right _ _), },
  { exact ((hτ.min hπ).min_const i).measurable_of_le (λ _, min_le_right _ _),  },
end

lemma measurable_set_inter_le_iff [topological_space ι]
  [second_countable_topology ι] [order_topology ι] [measurable_space ι] [borel_space ι]
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π)
  (s : set α) :
  measurable_set[hτ.measurable_space] (s ∩ {x | τ x ≤ π x})
    ↔ measurable_set[(hτ.min hπ).measurable_space] (s ∩ {x | τ x ≤ π x}) :=
begin
  split; intro h,
  { have : s ∩ {x | τ x ≤ π x} = s ∩ {x | τ x ≤ π x} ∩ {x | τ x ≤ π x},
      by rw [set.inter_assoc, set.inter_self],
    rw this,
    exact measurable_set_inter_le _ _ _ h, },
  { rw measurable_set_min_iff at h,
    exact h.1, },
end

lemma measurable_set_le_stopping_time [topological_space ι]
  [second_countable_topology ι] [order_topology ι] [measurable_space ι] [borel_space ι]
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  measurable_set[hτ.measurable_space] {x | τ x ≤ π x} :=
begin
  rw hτ.measurable_set,
  intro j,
  have : {x | τ x ≤ π x} ∩ {x | τ x ≤ j} = {x | min (τ x) j ≤ min (π x) j} ∩ {x | τ x ≤ j},
  { ext1 x,
    simp only [set.mem_inter_eq, set.mem_set_of_eq, min_le_iff, le_min_iff, le_refl, and_true,
      and.congr_left_iff],
    intro h,
    simp only [h, or_self, and_true],
    by_cases hj : j ≤ π x,
    { simp only [hj, h.trans hj, or_self], },
    { simp only [hj, or_false], }, },
  rw this,
  refine measurable_set.inter _ (hτ.measurable_set_le j),
  apply measurable_set_le,
  { exact (hτ.min_const j).measurable_of_le (λ _, min_le_right _ _), },
  { exact (hπ.min_const j).measurable_of_le (λ _, min_le_right _ _), },
end

lemma measurable_set_stopping_time_le [topological_space ι]
  [second_countable_topology ι] [order_topology ι] [measurable_space ι] [borel_space ι]
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  measurable_set[hπ.measurable_space] {x | τ x ≤ π x} :=
begin
  suffices : measurable_set[(hτ.min hπ).measurable_space] {x : α | τ x ≤ π x},
    by { rw measurable_set_min_iff hτ hπ at this, exact this.2, },
  rw [← set.univ_inter {x : α | τ x ≤ π x}, ← hτ.measurable_set_inter_le_iff hπ, set.univ_inter],
  exact measurable_set_le_stopping_time hτ hπ,
end

lemma measurable_set_eq_stopping_time [add_group ι]
  [topological_space ι] [measurable_space ι] [borel_space ι] [order_topology ι]
  [measurable_singleton_class ι] [second_countable_topology ι] [has_measurable_sub₂ ι]
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  measurable_set[hτ.measurable_space] {x | τ x = π x} :=
begin
  rw hτ.measurable_set,
  intro j,
  have : {x | τ x = π x} ∩ {x | τ x ≤ j}
    = {x | min (τ x) j = min (π x) j} ∩ {x | τ x ≤ j} ∩ {x | π x ≤ j},
  { ext1 x,
    simp only [set.mem_inter_eq, set.mem_set_of_eq],
    refine ⟨λ h, ⟨⟨_, h.2⟩, _⟩, λ h, ⟨_, h.1.2⟩⟩,
    { rw h.1, },
    { rw ← h.1, exact h.2, },
    { cases h with h' hσ_le,
      cases h' with h_eq hτ_le,
      rwa [min_eq_left hτ_le, min_eq_left hσ_le] at h_eq, }, },
  rw this,
  refine measurable_set.inter (measurable_set.inter _ (hτ.measurable_set_le j))
    (hπ.measurable_set_le j),
  apply measurable_set_eq_fun,
  { exact (hτ.min_const j).measurable_of_le (λ _, min_le_right _ _), },
  { exact (hπ.min_const j).measurable_of_le (λ _, min_le_right _ _), },
end

lemma measurable_set_eq_stopping_time_of_encodable [encodable ι]
  [topological_space ι] [measurable_space ι] [borel_space ι] [order_topology ι]
  [measurable_singleton_class ι] [second_countable_topology ι]
  (hτ : is_stopping_time f τ) (hπ : is_stopping_time f π) :
  measurable_set[hτ.measurable_space] {x | τ x = π x} :=
begin
  rw hτ.measurable_set,
  intro j,
  have : {x | τ x = π x} ∩ {x | τ x ≤ j}
    = {x | min (τ x) j = min (π x) j} ∩ {x | τ x ≤ j} ∩ {x | π x ≤ j},
  { ext1 x,
    simp only [set.mem_inter_eq, set.mem_set_of_eq],
    refine ⟨λ h, ⟨⟨_, h.2⟩, _⟩, λ h, ⟨_, h.1.2⟩⟩,
    { rw h.1, },
    { rw ← h.1, exact h.2, },
    { cases h with h' hπ_le,
      cases h' with h_eq hτ_le,
      rwa [min_eq_left hτ_le, min_eq_left hπ_le] at h_eq, }, },
  rw this,
  refine measurable_set.inter (measurable_set.inter _ (hτ.measurable_set_le j))
    (hπ.measurable_set_le j),
  apply measurable_set_eq_fun_of_encodable,
  { exact (hτ.min_const j).measurable_of_le (λ _, min_le_right _ _), },
  { exact (hπ.min_const j).measurable_of_le (λ _, min_le_right _ _), },
end

end linear_order

end is_stopping_time

section linear_order

/-! ## Stopped value and stopped process -/

/-- Given a map `u : ι → α → E`, its stopped value with respect to the stopping
time `τ` is the map `x ↦ u (τ x) x`. -/
def stopped_value (u : ι → α → β) (τ : α → ι) : α → β :=
λ x, u (τ x) x

lemma stopped_value_const (u : ι → α → β) (i : ι) : stopped_value u (λ x, i) = u i :=
rfl

variable [linear_order ι]

/-- Given a map `u : ι → α → E`, the stopped process with respect to `τ` is `u i x` if
`i ≤ τ x`, and `u (τ x) x` otherwise.

Intuitively, the stopped process stops evolving once the stopping time has occured. -/
def stopped_process (u : ι → α → β) (τ : α → ι) : ι → α → β :=
λ i x, u (min i (τ x)) x

lemma stopped_process_eq_of_le {u : ι → α → β} {τ : α → ι}
  {i : ι} {x : α} (h : i ≤ τ x) : stopped_process u τ i x = u i x :=
by simp [stopped_process, min_eq_left h]

lemma stopped_process_eq_of_ge {u : ι → α → β} {τ : α → ι}
  {i : ι} {x : α} (h : τ x ≤ i) : stopped_process u τ i x = u (τ x) x :=
by simp [stopped_process, min_eq_right h]

section prog_measurable

variables [measurable_space ι] [topological_space ι] [order_topology ι]
  [second_countable_topology ι] [borel_space ι]
  [topological_space β]
  {u : ι → α → β} {τ : α → ι} {f : filtration ι m}

lemma prog_measurable_min_stopping_time [metrizable_space ι] (hτ : is_stopping_time f τ) :
  prog_measurable f (λ i x, min i (τ x)) :=
begin
  intro i,
  let m_prod : measurable_space (set.Iic i × α) := measurable_space.prod _ (f i),
  let m_set : ∀ t : set (set.Iic i × α), measurable_space t :=
    λ _, @subtype.measurable_space (set.Iic i × α) _ m_prod,
  let s := {p : set.Iic i × α | τ p.2 ≤ i},
  have hs : measurable_set[m_prod] s, from @measurable_snd (set.Iic i) α _ (f i) _ (hτ i),
  have h_meas_fst : ∀ t : set (set.Iic i × α),
      measurable[m_set t] (λ x : t, ((x : set.Iic i × α).fst : ι)),
    from λ t, (@measurable_subtype_coe (set.Iic i × α) m_prod _).fst.subtype_coe,
  apply measurable.strongly_measurable,
  refine measurable_of_restrict_of_restrict_compl hs _ _,
  { refine @measurable.min _ _ _ _ _ (m_set s) _ _ _ _ _ (h_meas_fst s) _,
    refine @measurable_of_Iic ι s _ _ _ (m_set s) _ _ _ _ (λ j, _),
    have h_set_eq : (λ x : s, τ (x : set.Iic i × α).snd) ⁻¹' set.Iic j
      = (λ x : s, (x : set.Iic i × α).snd) ⁻¹' {x | τ x ≤ min i j},
    { ext1 x,
      simp only [set.mem_preimage, set.mem_Iic, iff_and_self, le_min_iff, set.mem_set_of_eq],
      exact λ _, x.prop, },
    rw h_set_eq,
    suffices h_meas : @measurable _ _ (m_set s) (f i) (λ x : s, (x : set.Iic i × α).snd),
      from h_meas (f.mono (min_le_left _ _) _ (hτ.measurable_set_le (min i j))),
    exact measurable_snd.comp (@measurable_subtype_coe _ m_prod _), },
  { suffices h_min_eq_left : (λ x : sᶜ, min ↑((x : set.Iic i × α).fst) (τ (x : set.Iic i × α).snd))
      = λ x : sᶜ, ↑((x : set.Iic i × α).fst),
    { rw [set.restrict, h_min_eq_left],
      exact h_meas_fst _, },
    ext1 x,
    rw min_eq_left,
    have hx_fst_le : ↑(x : set.Iic i × α).fst ≤ i, from (x : set.Iic i × α).fst.prop,
    refine hx_fst_le.trans (le_of_lt _),
    convert x.prop,
    simp only [not_le, set.mem_compl_eq, set.mem_set_of_eq], },
end

lemma prog_measurable.stopped_process [metrizable_space ι]
  (h : prog_measurable f u) (hτ : is_stopping_time f τ) :
  prog_measurable f (stopped_process u τ) :=
h.comp (prog_measurable_min_stopping_time hτ) (λ i x, min_le_left _ _)

lemma prog_measurable.adapted_stopped_process [metrizable_space ι]
  (h : prog_measurable f u) (hτ : is_stopping_time f τ) :
  adapted f (stopped_process u τ) :=
(h.stopped_process hτ).adapted

lemma prog_measurable.strongly_measurable_stopped_process [metrizable_space ι]
  (hu : prog_measurable f u) (hτ : is_stopping_time f τ) (i : ι) :
  strongly_measurable (stopped_process u τ i) :=
(hu.adapted_stopped_process hτ i).mono (f.le _)

lemma strongly_measurable_stopped_value_of_le
  (h : prog_measurable f u) (hτ : is_stopping_time f τ) {n : ι} (hτ_le : ∀ x, τ x ≤ n) :
  strongly_measurable[f n] (stopped_value u τ) :=
begin
  have : stopped_value u τ = (λ (p : set.Iic n × α), u ↑(p.fst) p.snd) ∘ (λ x, (⟨τ x, hτ_le x⟩, x)),
  { ext1 x, simp only [stopped_value, function.comp_app, subtype.coe_mk], },
  rw this,
  refine strongly_measurable.comp_measurable (h n) _,
  exact (hτ.measurable_of_le hτ_le).subtype_mk.prod_mk measurable_id,
end

lemma measurable_stopped_value [metrizable_space β] [measurable_space β] [borel_space β]
  (hf_prog : prog_measurable f u) (hτ : is_stopping_time f τ) :
  measurable[hτ.measurable_space] (stopped_value u τ) :=
begin
  have h_str_meas : ∀ i, strongly_measurable[f i] (stopped_value u (λ x, min (τ x) i)),
    from λ i, strongly_measurable_stopped_value_of_le hf_prog (hτ.min_const i)
      (λ _, min_le_right _ _),
  intros t ht i,
  suffices : stopped_value u τ ⁻¹' t ∩ {x : α | τ x ≤ i}
      = stopped_value u (λ x, min (τ x) i) ⁻¹' t ∩ {x : α | τ x ≤ i},
    by { rw this, exact ((h_str_meas i).measurable ht).inter (hτ.measurable_set_le i), },
  ext1 x,
  simp only [stopped_value, set.mem_inter_eq, set.mem_preimage, set.mem_set_of_eq,
    and.congr_left_iff],
  intro h,
  rw min_eq_left h,
end

end prog_measurable

end linear_order

section nat
/-! ### Filtrations indexed by `ℕ` -/

open filtration

variables {f : filtration ℕ m} {u : ℕ → α → β} {τ π : α → ℕ}

lemma stopped_value_sub_eq_sum [add_comm_group β] (hle : τ ≤ π) :
  stopped_value u π - stopped_value u τ =
  λ x, (∑ i in finset.Ico (τ x) (π x), (u (i + 1) - u i)) x :=
begin
  ext x,
  rw [finset.sum_Ico_eq_sub _ (hle x), finset.sum_range_sub, finset.sum_range_sub],
  simp [stopped_value],
end

lemma stopped_value_sub_eq_sum' [add_comm_group β] (hle : τ ≤ π) {N : ℕ} (hbdd : ∀ x, π x ≤ N) :
  stopped_value u π - stopped_value u τ =
  λ x, (∑ i in finset.range (N + 1),
    set.indicator {x | τ x ≤ i ∧ i < π x} (u (i + 1) - u i)) x :=
begin
  rw stopped_value_sub_eq_sum hle,
  ext x,
  simp only [finset.sum_apply, finset.sum_indicator_eq_sum_filter],
  refine finset.sum_congr _ (λ _ _, rfl),
  ext i,
  simp only [finset.mem_filter, set.mem_set_of_eq, finset.mem_range, finset.mem_Ico],
  exact ⟨λ h, ⟨lt_trans h.2 (nat.lt_succ_iff.2 $ hbdd _), h⟩, λ h, h.2⟩
end

section add_comm_monoid

variables [add_comm_monoid β]

/-- For filtrations indexed by `ℕ`, `adapted` and `prog_measurable` are equivalent. This lemma
provides `adapted f u → prog_measurable f u`. See `prog_measurable.adapted` for the reverse
direction, which is true more generally. -/
lemma adapted.prog_measurable_of_nat [topological_space β] [has_continuous_add β]
  (h : adapted f u) : prog_measurable f u :=
begin
  intro i,
  have : (λ p : ↥(set.Iic i) × α, u ↑(p.fst) p.snd)
    = λ p : ↥(set.Iic i) × α, ∑ j in finset.range (i + 1), if ↑p.fst = j then u j p.snd else 0,
  { ext1 p,
    rw finset.sum_ite_eq,
    have hp_mem : (p.fst : ℕ) ∈ finset.range (i + 1) := finset.mem_range_succ_iff.mpr p.fst.prop,
    simp only [hp_mem, if_true], },
  rw this,
  refine finset.strongly_measurable_sum _ (λ j hj, strongly_measurable.ite _ _ _),
  { suffices h_meas : measurable[measurable_space.prod _ (f i)]
        (λ a : ↥(set.Iic i) × α, (a.fst : ℕ)),
      from h_meas (measurable_set_singleton j),
    exact measurable_fst.subtype_coe, },
  { have h_le : j ≤ i, from finset.mem_range_succ_iff.mp hj,
    exact (strongly_measurable.mono (h j) (f.mono h_le)).comp_measurable measurable_snd, },
  { exact strongly_measurable_const, },
end

/-- For filtrations indexed by `ℕ`, the stopped process obtained from an adapted process is
adapted. -/
lemma adapted.stopped_process_of_nat [topological_space β] [has_continuous_add β]
  (hu : adapted f u) (hτ : is_stopping_time f τ) :
  adapted f (stopped_process u τ) :=
(hu.prog_measurable_of_nat.stopped_process hτ).adapted

lemma adapted.strongly_measurable_stopped_process_of_nat [topological_space β]
  [has_continuous_add β]
  (hτ : is_stopping_time f τ) (hu : adapted f u) (n : ℕ) :
  strongly_measurable (stopped_process u τ n) :=
hu.prog_measurable_of_nat.strongly_measurable_stopped_process hτ n

lemma stopped_value_eq {N : ℕ} (hbdd : ∀ x, τ x ≤ N) :
  stopped_value u τ =
  λ x, (∑ i in finset.range (N + 1), set.indicator {x | τ x = i} (u i)) x :=
begin
  ext y,
  rw [stopped_value, finset.sum_apply, finset.sum_eq_single (τ y)],
  { rw set.indicator_of_mem,
    exact rfl },
  { exact λ i hi hneq, set.indicator_of_not_mem hneq.symm _ },
  { intro hy,
    rw set.indicator_of_not_mem,
    exact λ _, hy (finset.mem_range.2 $ lt_of_le_of_lt (hbdd _) (nat.lt_succ_self _)) }
end

lemma stopped_process_eq (n : ℕ) :
  stopped_process u τ n =
  set.indicator {a | n ≤ τ a} (u n) +
    ∑ i in finset.range n, set.indicator {a | τ a = i} (u i) :=
begin
  ext x,
  rw [pi.add_apply, finset.sum_apply],
  cases le_or_lt n (τ x),
  { rw [stopped_process_eq_of_le h, set.indicator_of_mem, finset.sum_eq_zero, add_zero],
    { intros m hm,
      rw finset.mem_range at hm,
      exact set.indicator_of_not_mem ((lt_of_lt_of_le hm h).ne.symm) _ },
    { exact h } },
  { rw [stopped_process_eq_of_ge (le_of_lt h), finset.sum_eq_single_of_mem (τ x)],
    { rw [set.indicator_of_not_mem, zero_add, set.indicator_of_mem],
      { exact rfl }, -- refl does not work
      { exact not_le.2 h } },
    { rwa [finset.mem_range] },
    { intros b hb hneq,
      rw set.indicator_of_not_mem,
      exact hneq.symm } },
end

end add_comm_monoid

section normed_group

variables [normed_group β] {p : ℝ≥0∞} {μ : measure α}

lemma mem_ℒp_stopped_process (hτ : is_stopping_time f τ) (hu : ∀ n, mem_ℒp (u n) p μ) (n : ℕ) :
  mem_ℒp (stopped_process u τ n) p μ :=
begin
  rw stopped_process_eq,
  refine mem_ℒp.add _ _,
  { exact mem_ℒp.indicator (f.le n {a : α | n ≤ τ a} (hτ.measurable_set_ge n)) (hu n) },
  { suffices : mem_ℒp (λ x, ∑ (i : ℕ) in finset.range n, {a : α | τ a = i}.indicator (u i) x) p μ,
    { convert this, ext1 x, simp only [finset.sum_apply] },
    refine mem_ℒp_finset_sum _ (λ i hi, mem_ℒp.indicator _ (hu i)),
    exact f.le i {a : α | τ a = i} (hτ.measurable_set_eq i) },
end

lemma integrable_stopped_process (hτ : is_stopping_time f τ)
  (hu : ∀ n, integrable (u n) μ) (n : ℕ) :
  integrable (stopped_process u τ n) μ :=
by { simp_rw ← mem_ℒp_one_iff_integrable at hu ⊢, exact mem_ℒp_stopped_process hτ hu n, }

lemma mem_ℒp_stopped_value (hτ : is_stopping_time f τ)
  (hu : ∀ n, mem_ℒp (u n) p μ) {N : ℕ} (hbdd : ∀ x, τ x ≤ N) :
  mem_ℒp (stopped_value u τ) p μ :=
begin
  rw stopped_value_eq hbdd,
  suffices : mem_ℒp (λ x, ∑ (i : ℕ) in finset.range (N + 1),
    {a : α | τ a = i}.indicator (u i) x) p μ,
  { convert this, ext1 x, simp only [finset.sum_apply] },
  refine mem_ℒp_finset_sum _ (λ i hi, mem_ℒp.indicator _ (hu i)),
  exact f.le i {a : α | τ a = i} (hτ.measurable_set_eq i)
end

lemma integrable_stopped_value (hτ : is_stopping_time f τ)
  (hu : ∀ n, integrable (u n) μ) {N : ℕ} (hbdd : ∀ x, τ x ≤ N) :
  integrable (stopped_value u τ) μ :=
by { simp_rw ← mem_ℒp_one_iff_integrable at hu ⊢, exact mem_ℒp_stopped_value hτ hu hbdd, }

end normed_group

end nat

section piecewise_const

variables [preorder ι] {𝒢 : filtration ι m} {τ η : α → ι} {i j : ι} {s : set α}
  [decidable_pred (∈ s)]

/-- Given stopping times `τ` and `η` which are bounded below, `set.piecewise s τ η` is also
a stopping time with respect to the same filtration. -/
lemma is_stopping_time.piecewise_of_le (hτ_st : is_stopping_time 𝒢 τ)
  (hη_st : is_stopping_time 𝒢 η) (hτ : ∀ x, i ≤ τ x) (hη : ∀ x, i ≤ η x)
  (hs : measurable_set[𝒢 i] s) :
  is_stopping_time 𝒢 (s.piecewise τ η) :=
begin
  intro n,
  have : {x | s.piecewise τ η x ≤ n}
    = (s ∩ {x | τ x ≤ n}) ∪ (sᶜ ∩ {x | η x ≤ n}),
  { ext1 x,
    simp only [set.piecewise, set.mem_inter_eq, set.mem_set_of_eq, and.congr_right_iff],
    by_cases hx : x ∈ s; simp [hx], },
  rw this,
  by_cases hin : i ≤ n,
  { have hs_n : measurable_set[𝒢 n] s, from 𝒢.mono hin _ hs,
    exact (hs_n.inter (hτ_st n)).union (hs_n.compl.inter (hη_st n)), },
  { have hτn : ∀ x, ¬ τ x ≤ n := λ x hτn, hin ((hτ x).trans hτn),
    have hηn : ∀ x, ¬ η x ≤ n := λ x hηn, hin ((hη x).trans hηn),
    simp [hτn, hηn], },
end

lemma is_stopping_time_piecewise_const (hij : i ≤ j) (hs : measurable_set[𝒢 i] s) :
  is_stopping_time 𝒢 (s.piecewise (λ _, i) (λ _, j)) :=
(is_stopping_time_const 𝒢 i).piecewise_of_le (is_stopping_time_const 𝒢 j)
  (λ x, le_rfl) (λ _, hij) hs

lemma stopped_value_piecewise_const {ι' : Type*} {i j : ι'} {f : ι' → α → ℝ} :
  stopped_value f (s.piecewise (λ _, i) (λ _, j)) = s.piecewise (f i) (f j) :=
by { ext x, rw stopped_value, by_cases hx : x ∈ s; simp [hx] }

lemma stopped_value_piecewise_const' {ι' : Type*} {i j : ι'} {f : ι' → α → ℝ} :
  stopped_value f (s.piecewise (λ _, i) (λ _, j)) = s.indicator (f i) + sᶜ.indicator (f j) :=
by { ext x, rw stopped_value, by_cases hx : x ∈ s; simp [hx] }

end piecewise_const

end measure_theory


<|start_filename|>src/data/nat/squarefree.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import ring_theory.int.basic
import data.nat.factorization.prime_pow
import algebra.squarefree

/-!
# Lemmas about squarefreeness of natural numbers
A number is squarefree when it is not divisible by any squares except the squares of units.

## Main Results
 - `nat.squarefree_iff_nodup_factors`: A positive natural number `x` is squarefree iff
  the list `factors x` has no duplicate factors.

## Tags
squarefree, multiplicity

-/

namespace nat

lemma squarefree_iff_nodup_factors {n : ℕ} (h0 : n ≠ 0) :
  squarefree n ↔ n.factors.nodup :=
begin
  rw [unique_factorization_monoid.squarefree_iff_nodup_normalized_factors h0, nat.factors_eq],
  simp,
end

theorem squarefree_iff_prime_squarefree {n : ℕ} : squarefree n ↔ ∀ x, prime x → ¬ x * x ∣ n :=
squarefree_iff_irreducible_sq_not_dvd_of_exists_irreducible ⟨_, prime_two⟩

lemma squarefree.factorization_le_one {n : ℕ} (p : ℕ) (hn : squarefree n) :
  n.factorization p ≤ 1 :=
begin
  rcases eq_or_ne n 0 with rfl | hn',
  { simp },
  rw [multiplicity.squarefree_iff_multiplicity_le_one] at hn,
  by_cases hp : p.prime,
  { have := hn p,
    simp only [multiplicity_eq_factorization hp hn', nat.is_unit_iff, hp.ne_one, or_false] at this,
    exact_mod_cast this },
  { rw factorization_eq_zero_of_non_prime _ hp,
    exact zero_le_one }
end

lemma squarefree_of_factorization_le_one {n : ℕ} (hn : n ≠ 0) (hn' : ∀ p, n.factorization p ≤ 1) :
  squarefree n :=
begin
  rw [squarefree_iff_nodup_factors hn, list.nodup_iff_count_le_one],
  intro a,
  rw factors_count_eq,
  apply hn',
end

lemma squarefree_iff_factorization_le_one {n : ℕ} (hn : n ≠ 0) :
  squarefree n ↔ ∀ p, n.factorization p ≤ 1 :=
⟨λ p hn, squarefree.factorization_le_one hn p, squarefree_of_factorization_le_one hn⟩

lemma squarefree.ext_iff {n m : ℕ} (hn : squarefree n) (hm : squarefree m) :
  n = m ↔ ∀ p, prime p → (p ∣ n ↔ p ∣ m) :=
begin
  refine ⟨by { rintro rfl, simp }, λ h, eq_of_factorization_eq hn.ne_zero hm.ne_zero (λ p, _)⟩,
  by_cases hp : p.prime,
  { have h₁ := h _ hp,
    rw [←not_iff_not, hp.dvd_iff_one_le_factorization hn.ne_zero, not_le, lt_one_iff,
      hp.dvd_iff_one_le_factorization hm.ne_zero, not_le, lt_one_iff] at h₁,
    have h₂ := squarefree.factorization_le_one p hn,
    have h₃ := squarefree.factorization_le_one p hm,
    rw [nat.le_add_one_iff, le_zero_iff] at h₂ h₃,
    cases h₂,
    { rwa [h₂, eq_comm, ←h₁] },
    { rw [h₂, h₃.resolve_left],
      rw [←h₁, h₂],
      simp only [nat.one_ne_zero, not_false_iff] } },
  rw [factorization_eq_zero_of_non_prime _ hp, factorization_eq_zero_of_non_prime _ hp],
end

lemma squarefree_pow_iff {n k : ℕ} (hn : n ≠ 1) (hk : k ≠ 0) :
  squarefree (n ^ k) ↔ squarefree n ∧ k = 1 :=
begin
  refine ⟨λ h, _, by { rintro ⟨hn, rfl⟩, simpa }⟩,
  rcases eq_or_ne n 0 with rfl | hn₀,
  { simpa [zero_pow hk.bot_lt] using h },
  refine ⟨squarefree_of_dvd_of_squarefree (dvd_pow_self _ hk) h, by_contradiction $ λ h₁, _⟩,
  have : 2 ≤ k := k.two_le_iff.mpr ⟨hk, h₁⟩,
  apply hn (nat.is_unit_iff.1 (h _ _)),
  rw ←sq,
  exact pow_dvd_pow _ this
end

lemma squarefree_and_prime_pow_iff_prime {n : ℕ} :
  squarefree n ∧ is_prime_pow n ↔ prime n :=
begin
  refine iff.symm ⟨λ hn, ⟨hn.squarefree, hn.is_prime_pow⟩, _⟩,
  rw is_prime_pow_nat_iff,
  rintro ⟨h, p, k, hp, hk, rfl⟩,
  rw squarefree_pow_iff hp.ne_one hk.ne' at h,
  rwa [h.2, pow_one],
end

/-- Assuming that `n` has no factors less than `k`, returns the smallest prime `p` such that
  `p^2 ∣ n`. -/
def min_sq_fac_aux : ℕ → ℕ → option ℕ
| n k :=
  if h : n < k * k then none else
  have nat.sqrt n + 2 - (k + 2) < nat.sqrt n + 2 - k,
    by { rw nat.add_sub_add_right, exact nat.min_fac_lemma n k h },
  if k ∣ n then
    let n' := n / k in
    have nat.sqrt n' + 2 - (k + 2) < nat.sqrt n + 2 - k, from
      lt_of_le_of_lt (nat.sub_le_sub_right
        (nat.add_le_add_right (nat.sqrt_le_sqrt $ nat.div_le_self _ _) _) _) this,
    if k ∣ n' then some k else min_sq_fac_aux n' (k + 2)
  else min_sq_fac_aux n (k + 2)
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ ⟨n, k⟩, nat.sqrt n + 2 - k)⟩]}

/-- Returns the smallest prime factor `p` of `n` such that `p^2 ∣ n`, or `none` if there is no
  such `p` (that is, `n` is squarefree). See also `squarefree_iff_min_sq_fac`. -/
def min_sq_fac (n : ℕ) : option ℕ :=
if 2 ∣ n then
  let n' := n / 2 in
  if 2 ∣ n' then some 2 else min_sq_fac_aux n' 3
else min_sq_fac_aux n 3

/-- The correctness property of the return value of `min_sq_fac`.
  * If `none`, then `n` is squarefree;
  * If `some d`, then `d` is a minimal square factor of `n` -/
def min_sq_fac_prop (n : ℕ) : option ℕ → Prop
| none := squarefree n
| (some d) := prime d ∧ d * d ∣ n ∧ ∀ p, prime p → p * p ∣ n → d ≤ p

theorem min_sq_fac_prop_div (n) {k} (pk : prime k) (dk : k ∣ n) (dkk : ¬ k * k ∣ n)
  {o} (H : min_sq_fac_prop (n / k) o) : min_sq_fac_prop n o :=
begin
  have : ∀ p, prime p → p*p ∣ n → k*(p*p) ∣ n := λ p pp dp,
    have _ := (coprime_primes pk pp).2 (λ e, by { subst e, contradiction }),
    (coprime_mul_iff_right.2 ⟨this, this⟩).mul_dvd_of_dvd_of_dvd dk dp,
  cases o with d,
  { rw [min_sq_fac_prop, squarefree_iff_prime_squarefree] at H ⊢,
    exact λ p pp dp, H p pp ((dvd_div_iff dk).2 (this _ pp dp)) },
  { obtain ⟨H1, H2, H3⟩ := H,
    simp only [dvd_div_iff dk] at H2 H3,
    exact ⟨H1, dvd_trans (dvd_mul_left _ _) H2, λ p pp dp, H3 _ pp (this _ pp dp)⟩ }
end

theorem min_sq_fac_aux_has_prop : ∀ {n : ℕ} k, 0 < n → ∀ i, k = 2*i+3 →
  (∀ m, prime m → m ∣ n → k ≤ m) → min_sq_fac_prop n (min_sq_fac_aux n k)
| n k := λ n0 i e ih, begin
  rw min_sq_fac_aux,
  by_cases h : n < k*k; simp [h],
  { refine squarefree_iff_prime_squarefree.2 (λ p pp d, _),
    have := ih p pp (dvd_trans ⟨_, rfl⟩ d),
    have := nat.mul_le_mul this this,
    exact not_le_of_lt h (le_trans this (le_of_dvd n0 d)) },
  have k2 : 2 ≤ k, { subst e, exact dec_trivial },
  have k0 : 0 < k := lt_of_lt_of_le dec_trivial k2,
  have IH : ∀ n', n' ∣ n → ¬ k ∣ n' → min_sq_fac_prop n' (n'.min_sq_fac_aux (k + 2)),
  { intros n' nd' nk,
    have hn' := le_of_dvd n0 nd',
    refine
      have nat.sqrt n' - k < nat.sqrt n + 2 - k, from
        lt_of_le_of_lt (nat.sub_le_sub_right (nat.sqrt_le_sqrt hn') _) (nat.min_fac_lemma n k h),
      @min_sq_fac_aux_has_prop n' (k+2) (pos_of_dvd_of_pos nd' n0)
        (i+1) (by simp [e, left_distrib]) (λ m m2 d, _),
    cases nat.eq_or_lt_of_le (ih m m2 (dvd_trans d nd')) with me ml,
    { subst me, contradiction },
    apply (nat.eq_or_lt_of_le ml).resolve_left, intro me,
    rw [← me, e] at d, change 2 * (i + 2) ∣ n' at d,
    have := ih _ prime_two (dvd_trans (dvd_of_mul_right_dvd d) nd'),
    rw e at this, exact absurd this dec_trivial },
  have pk : k ∣ n → prime k,
  { refine λ dk, prime_def_min_fac.2 ⟨k2, le_antisymm (min_fac_le k0) _⟩,
    exact ih _ (min_fac_prime (ne_of_gt k2)) (dvd_trans (min_fac_dvd _) dk) },
  split_ifs with dk dkk,
  { exact ⟨pk dk, (nat.dvd_div_iff dk).1 dkk, λ p pp d, ih p pp (dvd_trans ⟨_, rfl⟩ d)⟩ },
  { specialize IH (n/k) (div_dvd_of_dvd dk) dkk,
    exact min_sq_fac_prop_div _ (pk dk) dk (mt (nat.dvd_div_iff dk).2 dkk) IH },
  { exact IH n (dvd_refl _) dk }
end
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ ⟨n, k⟩, nat.sqrt n + 2 - k)⟩]}

theorem min_sq_fac_has_prop (n : ℕ) : min_sq_fac_prop n (min_sq_fac n) :=
begin
  dunfold min_sq_fac, split_ifs with d2 d4,
  { exact ⟨prime_two, (dvd_div_iff d2).1 d4, λ p pp _, pp.two_le⟩ },
  { cases nat.eq_zero_or_pos n with n0 n0, { subst n0, cases d4 dec_trivial },
    refine min_sq_fac_prop_div _ prime_two d2 (mt (dvd_div_iff d2).2 d4) _,
    refine min_sq_fac_aux_has_prop 3 (nat.div_pos (le_of_dvd n0 d2) dec_trivial) 0 rfl _,
    refine λ p pp dp, succ_le_of_lt (lt_of_le_of_ne pp.two_le _),
    rintro rfl, contradiction },
  { cases nat.eq_zero_or_pos n with n0 n0, { subst n0, cases d2 dec_trivial },
    refine min_sq_fac_aux_has_prop _ n0 0 rfl _,
    refine λ p pp dp, succ_le_of_lt (lt_of_le_of_ne pp.two_le _),
    rintro rfl, contradiction },
end

theorem min_sq_fac_prime {n d : ℕ} (h : n.min_sq_fac = some d) : prime d :=
by { have := min_sq_fac_has_prop n, rw h at this, exact this.1 }

theorem min_sq_fac_dvd {n d : ℕ} (h : n.min_sq_fac = some d) : d * d ∣ n :=
by { have := min_sq_fac_has_prop n, rw h at this, exact this.2.1 }

theorem min_sq_fac_le_of_dvd {n d : ℕ} (h : n.min_sq_fac = some d)
  {m} (m2 : 2 ≤ m) (md : m * m ∣ n) : d ≤ m :=
begin
  have := min_sq_fac_has_prop n, rw h at this,
  have fd := min_fac_dvd m,
  exact le_trans
    (this.2.2 _ (min_fac_prime $ ne_of_gt m2) (dvd_trans (mul_dvd_mul fd fd) md))
    (min_fac_le $ lt_of_lt_of_le dec_trivial m2),
end

lemma squarefree_iff_min_sq_fac {n : ℕ} :
  squarefree n ↔ n.min_sq_fac = none :=
begin
  have := min_sq_fac_has_prop n,
  split; intro H,
  { cases n.min_sq_fac with d, {refl},
    cases squarefree_iff_prime_squarefree.1 H _ this.1 this.2.1 },
  { rwa H at this }
end

instance : decidable_pred (squarefree : ℕ → Prop) :=
λ n, decidable_of_iff' _ squarefree_iff_min_sq_fac

theorem squarefree_two : squarefree 2 := by rw squarefree_iff_nodup_factors; norm_num

open unique_factorization_monoid

lemma divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0) :
  (n.divisors.filter squarefree).val =
    (unique_factorization_monoid.normalized_factors n).to_finset.powerset.val.map
      (λ x, x.val.prod) :=
begin
  rw (finset.nodup _).ext ((finset.nodup _).map_on _),
  { intro a,
    simp only [multiset.mem_filter, id.def, multiset.mem_map, finset.filter_val, ← finset.mem_def,
      mem_divisors],
    split,
    { rintro ⟨⟨an, h0⟩, hsq⟩,
      use (unique_factorization_monoid.normalized_factors a).to_finset,
      simp only [id.def, finset.mem_powerset],
      rcases an with ⟨b, rfl⟩,
      rw mul_ne_zero_iff at h0,
      rw unique_factorization_monoid.squarefree_iff_nodup_normalized_factors h0.1 at hsq,
      rw [multiset.to_finset_subset, multiset.to_finset_val, hsq.dedup, ← associated_iff_eq,
        normalized_factors_mul h0.1 h0.2],
      exact ⟨multiset.subset_of_le (multiset.le_add_right _ _), normalized_factors_prod h0.1⟩ },
    { rintro ⟨s, hs, rfl⟩,
      rw [finset.mem_powerset, ← finset.val_le_iff, multiset.to_finset_val] at hs,
      have hs0 : s.val.prod ≠ 0,
      { rw [ne.def, multiset.prod_eq_zero_iff],
        simp only [exists_prop, id.def, exists_eq_right],
        intro con,
        apply not_irreducible_zero (irreducible_of_normalized_factor 0
            (multiset.mem_dedup.1 (multiset.mem_of_le hs con))) },
      rw (normalized_factors_prod h0).symm.dvd_iff_dvd_right,
      refine ⟨⟨multiset.prod_dvd_prod_of_le (le_trans hs (multiset.dedup_le _)), h0⟩, _⟩,
      have h := unique_factorization_monoid.factors_unique irreducible_of_normalized_factor
        (λ x hx, irreducible_of_normalized_factor x (multiset.mem_of_le
          (le_trans hs (multiset.dedup_le _)) hx)) (normalized_factors_prod hs0),
      rw [associated_eq_eq, multiset.rel_eq] at h,
      rw [unique_factorization_monoid.squarefree_iff_nodup_normalized_factors hs0, h],
      apply s.nodup } },
  { intros x hx y hy h,
    rw [← finset.val_inj, ← multiset.rel_eq, ← associated_eq_eq],
    rw [← finset.mem_def, finset.mem_powerset] at hx hy,
    apply unique_factorization_monoid.factors_unique _ _ (associated_iff_eq.2 h),
    { intros z hz,
      apply irreducible_of_normalized_factor z,
      rw ← multiset.mem_to_finset,
      apply hx hz },
    { intros z hz,
      apply irreducible_of_normalized_factor z,
      rw ← multiset.mem_to_finset,
      apply hy hz } }
end

open_locale big_operators

lemma sum_divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0)
  {α : Type*} [add_comm_monoid α] {f : ℕ → α} :
  ∑ i in (n.divisors.filter squarefree), f i =
    ∑ i in (unique_factorization_monoid.normalized_factors n).to_finset.powerset, f (i.val.prod) :=
by rw [finset.sum_eq_multiset_sum, divisors_filter_squarefree h0, multiset.map_map,
    finset.sum_eq_multiset_sum]

lemma sq_mul_squarefree_of_pos {n : ℕ} (hn : 0 < n) :
  ∃ a b : ℕ, 0 < a ∧ 0 < b ∧ b ^ 2 * a = n ∧ squarefree a :=
begin
  let S := {s ∈ finset.range (n + 1) | s ∣ n ∧ ∃ x, s = x ^ 2},
  have hSne : S.nonempty,
  { use 1,
    have h1 : 0 < n ∧ ∃ (x : ℕ), 1 = x ^ 2 := ⟨hn, ⟨1, (one_pow 2).symm⟩⟩,
    simpa [S] },
  let s := finset.max' S hSne,
  have hs : s ∈ S := finset.max'_mem S hSne,
  simp only [finset.sep_def, S, finset.mem_filter, finset.mem_range] at hs,
  obtain ⟨hsn1, ⟨a, hsa⟩, ⟨b, hsb⟩⟩ := hs,
  rw hsa at hn,
  obtain ⟨hlts, hlta⟩ := canonically_ordered_comm_semiring.mul_pos.mp hn,
  rw hsb at hsa hn hlts,
  refine ⟨a, b, hlta, (pow_pos_iff zero_lt_two).mp hlts, hsa.symm, _⟩,
  rintro x ⟨y, hy⟩,
  rw nat.is_unit_iff,
  by_contra hx,
  refine lt_le_antisymm _ (finset.le_max' S ((b * x) ^ 2) _),
  { simp_rw [S, hsa, finset.sep_def, finset.mem_filter, finset.mem_range],
    refine ⟨lt_succ_iff.mpr (le_of_dvd hn _), _, ⟨b * x, rfl⟩⟩; use y; rw hy; ring },
  { convert lt_mul_of_one_lt_right hlts
      (one_lt_pow 2 x zero_lt_two (one_lt_iff_ne_zero_and_ne_one.mpr ⟨λ h, by simp * at *, hx⟩)),
    rw mul_pow },
end

lemma sq_mul_squarefree_of_pos' {n : ℕ} (h : 0 < n) :
  ∃ a b : ℕ, (b + 1) ^ 2 * (a + 1) = n ∧ squarefree (a + 1) :=
begin
  obtain ⟨a₁, b₁, ha₁, hb₁, hab₁, hab₂⟩ := sq_mul_squarefree_of_pos h,
  refine ⟨a₁.pred, b₁.pred, _, _⟩;
  simpa only [add_one, succ_pred_eq_of_pos, ha₁, hb₁],
end

lemma sq_mul_squarefree (n : ℕ) : ∃ a b : ℕ, b ^ 2 * a = n ∧ squarefree a :=
begin
  cases n,
  { exact ⟨1, 0, (by simp), squarefree_one⟩ },
  { obtain ⟨a, b, -, -, h₁, h₂⟩ := sq_mul_squarefree_of_pos (succ_pos n),
    exact ⟨a, b, h₁, h₂⟩ },
end

/-- `squarefree` is multiplicative. Note that the → direction does not require `hmn`
and generalizes to arbitrary commutative monoids. See `squarefree.of_mul_left` and
`squarefree.of_mul_right` above for auxiliary lemmas. -/
lemma squarefree_mul {m n : ℕ} (hmn : m.coprime n) :
  squarefree (m * n) ↔ squarefree m ∧ squarefree n :=
begin
  simp only [squarefree_iff_prime_squarefree, ←sq, ←forall_and_distrib],
  refine ball_congr (λ p hp, _),
  simp only [hmn.is_prime_pow_dvd_mul (hp.is_prime_pow.pow two_ne_zero), not_or_distrib],
end

end nat

/-! ### Square-free prover -/

open norm_num

namespace tactic
namespace norm_num

/-- A predicate representing partial progress in a proof of `squarefree`. -/
def squarefree_helper (n k : ℕ) : Prop :=
0 < k → (∀ m, nat.prime m → m ∣ bit1 n → bit1 k ≤ m) → squarefree (bit1 n)

lemma squarefree_bit10 (n : ℕ) (h : squarefree_helper n 1) :
  squarefree (bit0 (bit1 n)) :=
begin
  refine @nat.min_sq_fac_prop_div _ _ nat.prime_two two_dvd_bit0 _ none _,
  { rw [bit0_eq_two_mul (bit1 n), mul_dvd_mul_iff_left (@two_ne_zero ℕ _ _)],
    exact nat.not_two_dvd_bit1 _ },
  { rw [bit0_eq_two_mul, nat.mul_div_right _ (dec_trivial:0<2)],
    refine h dec_trivial (λ p pp dp, nat.succ_le_of_lt (lt_of_le_of_ne pp.two_le _)),
    rintro rfl, exact nat.not_two_dvd_bit1 _ dp }
end

lemma squarefree_bit1 (n : ℕ) (h : squarefree_helper n 1) :
  squarefree (bit1 n) :=
begin
  refine h dec_trivial (λ p pp dp, nat.succ_le_of_lt (lt_of_le_of_ne pp.two_le _)),
  rintro rfl, exact nat.not_two_dvd_bit1 _ dp
end

lemma squarefree_helper_0 {k} (k0 : 0 < k)
  {p : ℕ} (pp : nat.prime p) (h : bit1 k ≤ p) : bit1 (k + 1) ≤ p ∨ bit1 k = p :=
begin
  rcases lt_or_eq_of_le h with (hp:_+1≤_) | hp,
  { rw [bit1, bit0_eq_two_mul] at hp, change 2*(_+1) ≤ _ at hp,
    rw [bit1, bit0_eq_two_mul],
    refine or.inl (lt_of_le_of_ne hp _), unfreezingI { rintro rfl },
    exact nat.not_prime_mul dec_trivial (lt_add_of_pos_left _ k0) pp },
  { exact or.inr hp }
end

lemma squarefree_helper_1 (n k k' : ℕ) (e : k + 1 = k')
  (hk : nat.prime (bit1 k) → ¬ bit1 k ∣ bit1 n)
  (H : squarefree_helper n k') : squarefree_helper n k :=
λ k0 ih, begin
  subst e,
  refine H (nat.succ_pos _) (λ p pp dp, _),
  refine (squarefree_helper_0 k0 pp (ih p pp dp)).resolve_right (λ hp, _),
  subst hp, cases hk pp dp
end

lemma squarefree_helper_2 (n k k' c : ℕ) (e : k + 1 = k')
  (hc : bit1 n % bit1 k = c) (c0 : 0 < c)
  (h : squarefree_helper n k') : squarefree_helper n k :=
begin
  refine squarefree_helper_1 _ _ _ e (λ _, _) h,
  refine mt _ (ne_of_gt c0), intro e₁,
  rwa [← hc, ← nat.dvd_iff_mod_eq_zero],
end

lemma squarefree_helper_3 (n n' k k' c : ℕ) (e : k + 1 = k')
  (hn' : bit1 n' * bit1 k = bit1 n)
  (hc : bit1 n' % bit1 k = c) (c0 : 0 < c)
  (H : squarefree_helper n' k') : squarefree_helper n k :=
λ k0 ih, begin
  subst e,
  have k0' : 0 < bit1 k := bit1_pos (nat.zero_le _),
  have dn' : bit1 n' ∣ bit1 n := ⟨_, hn'.symm⟩,
  have dk : bit1 k ∣ bit1 n := ⟨_, ((mul_comm _ _).trans hn').symm⟩,
  have : bit1 n / bit1 k = bit1 n',
  { rw [← hn', nat.mul_div_cancel _ k0'] },
  have k2 : 2 ≤ bit1 k := nat.succ_le_succ (bit0_pos k0),
  have pk : (bit1 k).prime,
  { refine nat.prime_def_min_fac.2 ⟨k2, le_antisymm (nat.min_fac_le k0') _⟩,
    exact ih _ (nat.min_fac_prime (ne_of_gt k2)) (dvd_trans (nat.min_fac_dvd _) dk) },
  have dkk' : ¬ bit1 k ∣ bit1 n', {rw [nat.dvd_iff_mod_eq_zero, hc], exact ne_of_gt c0},
  have dkk : ¬ bit1 k * bit1 k ∣ bit1 n, {rwa [← nat.dvd_div_iff dk, this]},
  refine @nat.min_sq_fac_prop_div _ _ pk dk dkk none _,
  rw this, refine H (nat.succ_pos _) (λ p pp dp, _),
  refine (squarefree_helper_0 k0 pp (ih p pp $ dvd_trans dp dn')).resolve_right (λ e, _),
  subst e, contradiction
end

lemma squarefree_helper_4 (n k k' : ℕ) (e : bit1 k * bit1 k = k')
  (hd : bit1 n < k') : squarefree_helper n k :=
begin
  cases nat.eq_zero_or_pos n with h h,
  { subst n, exact λ _ _, squarefree_one },
  subst e,
  refine λ k0 ih, irreducible.squarefree (nat.prime_def_le_sqrt.2 ⟨bit1_lt_bit1.2 h, _⟩),
  intros m m2 hm md,
  obtain ⟨p, pp, hp⟩ := nat.exists_prime_and_dvd (ne_of_gt m2),
  have := (ih p pp (dvd_trans hp md)).trans
    (le_trans (nat.le_of_dvd (lt_of_lt_of_le dec_trivial m2) hp) hm),
  rw nat.le_sqrt at this,
  exact not_le_of_lt hd this
end

lemma not_squarefree_mul (a aa b n : ℕ) (ha : a * a = aa) (hb : aa * b = n)
  (h₁ : 1 < a) : ¬ squarefree n :=
by { rw [← hb, ← ha], exact λ H, ne_of_gt h₁ (nat.is_unit_iff.1 $ H _ ⟨_, rfl⟩) }

/-- Given `e` a natural numeral and `a : nat` with `a^2 ∣ n`, return `⊢ ¬ squarefree e`. -/
meta def prove_non_squarefree (e : expr) (n a : ℕ) : tactic expr := do
  let ea := reflect a,
  let eaa := reflect (a*a),
  c ← mk_instance_cache `(nat),
  (c, p₁) ← prove_lt_nat c `(1) ea,
  let b := n / (a*a), let eb := reflect b,
  (c, eaa, pa) ← prove_mul_nat c ea ea,
  (c, e', pb) ← prove_mul_nat c eaa eb,
  guard (e' =ₐ e),
  return $ `(@not_squarefree_mul).mk_app [ea, eaa, eb, e, pa, pb, p₁]

/-- Given `en`,`en1 := bit1 en`, `n1` the value of `en1`, `ek`,
  returns `⊢ squarefree_helper en ek`. -/
meta def prove_squarefree_aux : ∀ (ic : instance_cache) (en en1 : expr) (n1 : ℕ)
  (ek : expr) (k : ℕ), tactic expr
| ic en en1 n1 ek k := do
  let k1 := bit1 k,
  let ek1 := `(bit1:ℕ→ℕ).mk_app [ek],
  if n1 < k1*k1 then do
    (ic, ek', p₁) ← prove_mul_nat ic ek1 ek1,
    (ic, p₂) ← prove_lt_nat ic en1 ek',
    pure $ `(squarefree_helper_4).mk_app [en, ek, ek', p₁, p₂]
  else do
    let c := n1 % k1,
    let k' := k+1, let ek' := reflect k',
    (ic, p₁) ← prove_succ ic ek ek',
    if c = 0 then do
      let n1' := n1 / k1,
      let n' := n1' / 2, let en' := reflect n',
      let en1' := `(bit1:ℕ→ℕ).mk_app [en'],
      (ic, _, pn') ← prove_mul_nat ic en1' ek1,
      let c := n1' % k1,
      guard (c ≠ 0),
      (ic, ec, pc) ← prove_div_mod ic en1' ek1 tt,
      (ic, p₀) ← prove_pos ic ec,
      p₂ ← prove_squarefree_aux ic en' en1' n1' ek' k',
      pure $ `(squarefree_helper_3).mk_app [en, en', ek, ek', ec, p₁, pn', pc, p₀, p₂]
    else do
      (ic, ec, pc) ← prove_div_mod ic en1 ek1 tt,
      (ic, p₀) ← prove_pos ic ec,
      p₂ ← prove_squarefree_aux ic en en1 n1 ek' k',
      pure $ `(squarefree_helper_2).mk_app [en, ek, ek', ec, p₁, pc, p₀, p₂]

/-- Given `n > 0` a squarefree natural numeral, returns `⊢ squarefree n`. -/
meta def prove_squarefree (en : expr) (n : ℕ) : tactic expr :=
match match_numeral en with
| match_numeral_result.one := pure `(@squarefree_one ℕ _)
| match_numeral_result.bit0 en1 := match match_numeral en1 with
  | match_numeral_result.one := pure `(nat.squarefree_two)
  | match_numeral_result.bit1 en := do
    ic ← mk_instance_cache `(ℕ),
    p ← prove_squarefree_aux ic en en1 (n / 2) `(1:ℕ) 1,
    pure $ `(squarefree_bit10).mk_app [en, p]
  | _ := failed
  end
| match_numeral_result.bit1 en' := do
  ic ← mk_instance_cache `(ℕ),
  p ← prove_squarefree_aux ic en' en n `(1:ℕ) 1,
  pure $ `(squarefree_bit1).mk_app [en', p]
| _ := failed
end

/-- Evaluates the `prime` and `min_fac` functions. -/
@[norm_num] meta def eval_squarefree : expr → tactic (expr × expr)
| `(squarefree (%%e : ℕ)) := do
  n ← e.to_nat,
  match n with
  | 0 := false_intro `(@not_squarefree_zero ℕ _ _)
  | 1 := true_intro `(@squarefree_one ℕ _)
  | _ := match n.min_sq_fac with
    | some d := prove_non_squarefree e n d >>= false_intro
    | none := prove_squarefree e n >>= true_intro
    end
  end
| _ := failed

end norm_num
end tactic


<|start_filename|>src/category_theory/differential_object.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.int.basic
import category_theory.shift
import category_theory.concrete_category.basic

/-!
# Differential objects in a category.

A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.

We build the category of differential objects, and some basic constructions
such as the forgetful functor, zero morphisms and zero objects, and the shift functor
on differential objects.
-/

open category_theory.limits

universes v u

namespace category_theory

variables (C : Type u) [category.{v} C]

-- TODO: generaize to `has_shift C A` for an arbitrary `[add_monoid A]` `[has_one A]`.
variables [has_zero_morphisms C] [has_shift C ℤ]

/--
A differential object in a category with zero morphisms and a shift is
an object `X` equipped with
a morphism `d : X ⟶ X⟦1⟧`, such that `d^2 = 0`.
-/
@[nolint has_inhabited_instance]
structure differential_object :=
(X : C)
(d : X ⟶ X⟦1⟧)
(d_squared' : d ≫ d⟦(1:ℤ)⟧' = 0 . obviously)

restate_axiom differential_object.d_squared'
attribute [simp] differential_object.d_squared

variables {C}

namespace differential_object

/--
A morphism of differential objects is a morphism commuting with the differentials.
-/
@[ext, nolint has_inhabited_instance]
structure hom (X Y : differential_object C) :=
(f : X.X ⟶ Y.X)
(comm' : X.d ≫ f⟦1⟧' = f ≫ Y.d . obviously)

restate_axiom hom.comm'
attribute [simp, reassoc] hom.comm

namespace hom

/-- The identity morphism of a differential object. -/
@[simps]
def id (X : differential_object C) : hom X X :=
{ f := 𝟙 X.X }

/-- The composition of morphisms of differential objects. -/
@[simps]
def comp {X Y Z : differential_object C} (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ f := f.f ≫ g.f, }

end hom

instance category_of_differential_objects : category (differential_object C) :=
{ hom := hom,
  id := hom.id,
  comp := λ X Y Z f g, hom.comp f g, }

@[simp]
lemma id_f (X : differential_object C) : ((𝟙 X) : X ⟶ X).f = 𝟙 (X.X) := rfl

@[simp]
lemma comp_f {X Y Z : differential_object C} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).f = f.f ≫ g.f :=
rfl

@[simp]
lemma eq_to_hom_f {X Y : differential_object C} (h : X = Y) :
  hom.f (eq_to_hom h) = eq_to_hom (congr_arg _ h) :=
by { subst h, rw [eq_to_hom_refl, eq_to_hom_refl], refl }

variables (C)

/-- The forgetful functor taking a differential object to its underlying object. -/
def forget : (differential_object C) ⥤ C :=
{ obj := λ X, X.X,
  map := λ X Y f, f.f, }

instance forget_faithful : faithful (forget C) :=
{ }

instance has_zero_morphisms : has_zero_morphisms (differential_object C) :=
{ has_zero := λ X Y,
  ⟨{ f := 0 }⟩}

variables {C}

@[simp]
lemma zero_f (P Q : differential_object C) : (0 : P ⟶ Q).f = 0 := rfl

/--
An isomorphism of differential objects gives an isomorphism of the underlying objects.
-/
@[simps] def iso_app {X Y : differential_object C} (f : X ≅ Y) : X.X ≅ Y.X :=
⟨f.hom.f, f.inv.f, by { dsimp, rw [← comp_f, iso.hom_inv_id, id_f] },
  by { dsimp, rw [← comp_f, iso.inv_hom_id, id_f] }⟩

@[simp] lemma iso_app_refl (X : differential_object C) : iso_app (iso.refl X) = iso.refl X.X := rfl
@[simp] lemma iso_app_symm {X Y : differential_object C} (f : X ≅ Y) :
  iso_app f.symm = (iso_app f).symm := rfl
@[simp] lemma iso_app_trans {X Y Z : differential_object C} (f : X ≅ Y) (g : Y ≅ Z) :
  iso_app (f ≪≫ g) = iso_app f ≪≫ iso_app g := rfl

/-- An isomorphism of differential objects can be constructed
from an isomorphism of the underlying objects that commutes with the differentials. -/
@[simps] def mk_iso {X Y : differential_object C}
  (f : X.X ≅ Y.X) (hf : X.d ≫ f.hom⟦1⟧' = f.hom ≫ Y.d) : X ≅ Y :=
{ hom := ⟨f.hom, hf⟩,
  inv := ⟨f.inv, by { dsimp, rw [← functor.map_iso_inv, iso.comp_inv_eq, category.assoc,
    iso.eq_inv_comp, functor.map_iso_hom, hf] }⟩,
  hom_inv_id' := by { ext1, dsimp, exact f.hom_inv_id },
  inv_hom_id' := by { ext1, dsimp, exact f.inv_hom_id } }

end differential_object

namespace functor

universes v' u'
variables (D : Type u') [category.{v'} D]
variables [has_zero_morphisms D] [has_shift D ℤ]

/--
A functor `F : C ⥤ D` which commutes with shift functors on `C` and `D` and preserves zero morphisms
can be lifted to a functor `differential_object C ⥤ differential_object D`.
-/
@[simps]
def map_differential_object (F : C ⥤ D)
  (η : (shift_functor C (1:ℤ)).comp F ⟶ F.comp (shift_functor D (1:ℤ)))
  (hF : ∀ c c', F.map (0 : c ⟶ c') = 0) :
  differential_object C ⥤ differential_object D :=
{ obj := λ X, { X := F.obj X.X,
    d := F.map X.d ≫ η.app X.X,
    d_squared' := begin
      rw [functor.map_comp, ← functor.comp_map F (shift_functor D (1:ℤ))],
      slice_lhs 2 3 { rw [← η.naturality X.d] },
      rw [functor.comp_map],
      slice_lhs 1 2 { rw [← F.map_comp, X.d_squared, hF] },
      rw [zero_comp, zero_comp],
    end },
  map := λ X Y f, { f := F.map f.f,
    comm' := begin
      dsimp,
      slice_lhs 2 3 { rw [← functor.comp_map F (shift_functor D (1:ℤ)), ← η.naturality f.f] },
      slice_lhs 1 2 { rw [functor.comp_map, ← F.map_comp, f.comm, F.map_comp] },
      rw [category.assoc]
    end },
  map_id' := by { intros, ext, simp },
  map_comp' := by { intros, ext, simp }, }

end functor

end category_theory

namespace category_theory

namespace differential_object

variables (C : Type u) [category.{v} C]

variables [has_zero_object C] [has_zero_morphisms C] [has_shift C ℤ]

open_locale zero_object

instance has_zero_object : has_zero_object (differential_object C) :=
by { refine ⟨⟨⟨0, 0⟩, λ X, ⟨⟨⟨⟨0⟩⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨⟨0⟩⟩, λ f, _⟩⟩⟩⟩; ext, }

end differential_object

namespace differential_object

variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_zero_morphisms C] [has_shift C ℤ]

instance concrete_category_of_differential_objects :
  concrete_category (differential_object C) :=
{ forget := forget C ⋙ category_theory.forget C }

instance : has_forget₂ (differential_object C) C :=
{ forget₂ := forget C }

end differential_object

/-! The category of differential objects itself has a shift functor. -/
namespace differential_object

variables (C : Type u) [category.{v} C]
variables [has_zero_morphisms C] [has_shift C ℤ]

noncomputable theory

/-- The shift functor on `differential_object C`. -/
@[simps]
def shift_functor (n : ℤ) : differential_object C ⥤ differential_object C :=
{ obj := λ X,
  { X := X.X⟦n⟧,
    d := X.d⟦n⟧' ≫ (shift_comm _ _ _).hom,
    d_squared' := by rw [functor.map_comp, category.assoc, shift_comm_hom_comp_assoc,
        ←functor.map_comp_assoc, X.d_squared, functor.map_zero, zero_comp] },
  map := λ X Y f,
  { f := f.f⟦n⟧',
    comm' := by { dsimp, rw [category.assoc, shift_comm_hom_comp, ← functor.map_comp_assoc,
      f.comm, functor.map_comp_assoc], }, },
  map_id' := by { intros X, ext1, dsimp, rw functor.map_id },
  map_comp' := by { intros X Y Z f g, ext1, dsimp, rw functor.map_comp } }

local attribute [simp] eq_to_hom_map
local attribute [reducible] discrete.add_monoidal shift_comm

/-- The shift functor on `differential_object C` is additive. -/
@[simps] def shift_functor_add (m n : ℤ) :
  shift_functor C (m + n) ≅ shift_functor C m ⋙ shift_functor C n :=
begin
  refine nat_iso.of_components (λ X, mk_iso (shift_add X.X _ _) _) _,
  { dsimp,
    -- This is just `simp, simp [eq_to_hom_map]`.
    simp_rw [category.assoc, obj_μ_inv_app, μ_inv_hom_app_assoc, functor.map_comp, obj_μ_app,
      category.assoc, μ_naturality_assoc, μ_inv_hom_app_assoc, obj_μ_inv_app, category.assoc,
      μ_naturalityₗ_assoc, μ_inv_hom_app_assoc, μ_inv_naturalityᵣ_assoc],
    simp only [eq_to_hom_map, eq_to_hom_app, eq_to_iso.hom, eq_to_hom_trans_assoc,
      eq_to_iso.inv], },
  { intros X Y f, ext, dsimp, exact nat_trans.naturality _ _ }
end

local attribute [reducible] endofunctor_monoidal_category

section
local attribute [instance] endofunctor_monoidal_category

/-- The shift by zero is naturally isomorphic to the identity. -/
@[simps]
def shift_ε : 𝟭 (differential_object C) ≅ shift_functor C 0 :=
begin
  refine nat_iso.of_components (λ X, mk_iso ((shift_monoidal_functor C ℤ).ε_iso.app X.X) _) _,
  { dsimp, simp, dsimp, simp },
  { introv, ext, dsimp, simp }
end

end

local attribute [simp] eq_to_hom_map

instance : has_shift (differential_object C) ℤ :=
has_shift_mk _ _
{ F := shift_functor C,
  ε := shift_ε C,
  μ := λ m n, (shift_functor_add C m n).symm }

end differential_object

end category_theory


<|start_filename|>src/data/prod/tprod.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.list.nodup

/-!
# Finite products of types

This file defines the product of types over a list. For `l : list ι` and `α : ι → Type*` we define
`list.tprod α l = l.foldr (λ i β, α i × β) punit`.
This type should not be used if `Π i, α i` or `Π i ∈ l, α i` can be used instead
(in the last expression, we could also replace the list `l` by a set or a finset).
This type is used as an intermediary between binary products and finitary products.
The application of this type is finitary product measures, but it could be used in any
construction/theorem that is easier to define/prove on binary products than on finitary products.

* Once we have the construction on binary products (like binary product measures in
  `measure_theory.prod`), we can easily define a finitary version on the type `tprod l α`
  by iterating. Properties can also be easily extended from the binary case to the finitary case
  by iterating.
* Then we can use the equivalence `list.tprod.pi_equiv_tprod` below (or enhanced versions of it,
  like a `measurable_equiv` for product measures) to get the construction on `Π i : ι, α i`, at
  least when assuming `[fintype ι] [encodable ι]` (using `encodable.sorted_univ`).
  Using `local attribute [instance] fintype.to_encodable` we can get rid of the argument
  `[encodable ι]`.

## Main definitions

* We have the equivalence `tprod.pi_equiv_tprod : (Π i, α i) ≃ tprod α l`
  if `l` contains every element of `ι` exactly once.
* The product of sets is `set.tprod : (Π i, set (α i)) → set (tprod α l)`.
-/

open list function

variables {ι : Type*} {α : ι → Type*} {i j : ι} {l : list ι} {f : Π i, α i}

namespace list

variable (α)

/-- The product of a family of types over a list. -/
def tprod (l : list ι) : Type* :=
l.foldr (λ i β, α i × β) punit

variable {α}

namespace tprod

open list

/-- Turning a function `f : Π i, α i` into an element of the iterated product `tprod α l`. -/
protected def mk : ∀ (l : list ι) (f : Π i, α i), tprod α l
| []        := λ f, punit.star
| (i :: is) := λ f, (f i, mk is f)

instance [∀ i, inhabited (α i)] : inhabited (tprod α l) :=
⟨tprod.mk l default⟩

@[simp] lemma fst_mk (i : ι) (l : list ι) (f : Π i, α i) : (tprod.mk (i::l) f).1 = f i := rfl

@[simp]
lemma snd_mk (i : ι) (l : list ι) (f : Π i, α i) : (tprod.mk (i::l) f).2 = tprod.mk l f := rfl

variables [decidable_eq ι]

/-- Given an element of the iterated product `l.prod α`, take a projection into direction `i`.
  If `i` appears multiple times in `l`, this chooses the first component in direction `i`. -/
protected def elim : ∀ {l : list ι} (v : tprod α l) {i : ι} (hi : i ∈ l), α i
| (i :: is) v j hj :=
  if hji : j = i then by { subst hji, exact v.1 } else elim v.2 (hj.resolve_left hji)

@[simp] lemma elim_self (v : tprod α (i :: l)) : v.elim (l.mem_cons_self i) = v.1 :=
by simp [tprod.elim]

@[simp] lemma elim_of_ne (hj : j ∈ i :: l) (hji : j ≠ i) (v : tprod α (i :: l)) :
  v.elim hj = tprod.elim v.2 (hj.resolve_left hji) :=
by simp [tprod.elim, hji]

@[simp] lemma elim_of_mem (hl : (i :: l).nodup) (hj : j ∈ l) (v : tprod α (i :: l)) :
  v.elim (mem_cons_of_mem _ hj) = tprod.elim v.2 hj :=
by { apply elim_of_ne, rintro rfl, exact hl.not_mem hj }

lemma elim_mk : ∀ (l : list ι) (f : Π i, α i) {i : ι} (hi : i ∈ l),
  (tprod.mk l f).elim hi = f i
| (i :: is) f j hj := begin
      by_cases hji : j = i,
      { subst hji, simp },
      { rw [elim_of_ne _ hji, snd_mk, elim_mk] }
  end

@[ext] lemma ext : ∀ {l : list ι} (hl : l.nodup) {v w : tprod α l}
  (hvw : ∀ i (hi : i ∈ l), v.elim hi = w.elim hi), v = w
| []        hl v w hvw := punit.ext
| (i :: is) hl v w hvw := begin
    ext, rw [← elim_self v, hvw, elim_self],
    refine ext (nodup_cons.mp hl).2 (λ j hj, _),
    rw [← elim_of_mem hl, hvw, elim_of_mem hl]
  end

/-- A version of `tprod.elim` when `l` contains all elements. In this case we get a function into
  `Π i, α i`. -/
@[simp] protected def elim' (h : ∀ i, i ∈ l) (v : tprod α l) (i : ι) : α i :=
v.elim (h i)

lemma mk_elim (hnd : l.nodup) (h : ∀ i, i ∈ l) (v : tprod α l) : tprod.mk l (v.elim' h) = v :=
tprod.ext hnd (λ i hi, by simp [elim_mk])

/-- Pi-types are equivalent to iterated products. -/
def pi_equiv_tprod (hnd : l.nodup) (h : ∀ i, i ∈ l) : (Π i, α i) ≃ tprod α l :=
⟨tprod.mk l, tprod.elim' h, λ f, funext $ λ i, elim_mk l f (h i), mk_elim hnd h⟩

end tprod

end list

namespace set

open list
/-- A product of sets in `tprod α l`. -/
@[simp] protected def tprod : ∀ (l : list ι) (t : Π i, set (α i)), set (tprod α l)
| []        t := univ
| (i :: is) t := t i ×ˢ tprod is t

lemma mk_preimage_tprod : ∀ (l : list ι) (t : Π i, set (α i)),
  tprod.mk l ⁻¹' set.tprod l t = {i | i ∈ l}.pi t
| []        t := by simp [set.tprod]
| (i :: l) t := begin
  ext f,
  have : f ∈ tprod.mk l ⁻¹' set.tprod l t ↔ f ∈ {x | x ∈ l}.pi t, { rw [mk_preimage_tprod l t] },
  change tprod.mk l f ∈ set.tprod l t ↔ ∀ (i : ι), i ∈ l → f i ∈ t i at this,
  /- `simp [set.tprod, tprod.mk, this]` can close this goal but is slow. -/
  rw [set.tprod, tprod.mk, mem_preimage, mem_pi, prod_mk_mem_set_prod_eq],
  simp_rw [mem_set_of_eq, mem_cons_iff],
  rw [forall_eq_or_imp, and.congr_right_iff],
  exact λ _, this
end

lemma elim_preimage_pi [decidable_eq ι] {l : list ι} (hnd : l.nodup) (h : ∀ i, i ∈ l)
  (t : Π i, set (α i)) : tprod.elim' h ⁻¹' pi univ t = set.tprod l t :=
begin
  have : { i | i ∈ l} = univ, { ext i, simp [h] },
  rw [← this, ← mk_preimage_tprod, preimage_preimage],
  convert preimage_id, simp [tprod.mk_elim hnd h, id_def]
end

end set


<|start_filename|>src/analysis/complex/abs_max.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.complex.cauchy_integral
import analysis.convex.integral
import analysis.normed_space.completion
import topology.algebra.order.extr_closure

/-!
# Maximum modulus principle

In this file we prove several versions of the maximum modulus principle.

There are several statements that can be called "the maximum modulus principle" for maps between
normed complex spaces.

In the most general case, see `complex.norm_eventually_eq_of_is_local_max`, we can only say that for
a differentiable function `f : E → F`, if the norm has a local maximum at `z`, then *the norm* is
constant in a neighborhood of `z`.

If the domain is a nontrivial finite dimensional space, then this implies the following version of
the maximum modulus principle, see `complex.exists_mem_frontier_is_max_on_norm`. If `f : E → F` is
complex differentiable on a nonempty compact set `K`, then there exists a point `z ∈ frontier K`
such that `λ z, ∥f z∥` takes it maximum value on `K` at `z`.

Finally, if the codomain is a strictly convex space, then the function cannot have a local maximum
of the norm unless the function (not only its norm) is a constant. This version is not formalized
yet.
-/

open topological_space metric set filter asymptotics function measure_theory affine_map
open_locale topological_space filter nnreal real

universes u v w
variables {E : Type u} [normed_group E] [normed_space ℂ E]
  {F : Type v} [normed_group F] [normed_space ℂ F]

local postfix `̂`:100 := uniform_space.completion

namespace complex

/-!
### Auxiliary lemmas

We split the proof into a series of lemmas. First we prove the principle for a function `f : ℂ → F`
with an additional assumption that `F` is a complete space, then drop unneeded assumptions one by
one.

The only "public API" lemmas in this section are TODO and
`complex.norm_eq_norm_of_is_max_on_of_closed_ball_subset`.
-/

lemma norm_max_aux₁ [complete_space F] {f : ℂ → F} {z w : ℂ}
  (hd : diff_cont_on_cl ℂ f (ball z (dist w z)))
  (hz : is_max_on (norm ∘ f) (closed_ball z (dist w z)) z) :
  ∥f w∥ = ∥f z∥ :=
begin
  /- Consider a circle of radius `r = dist w z`. -/
  set r : ℝ := dist w z,
  have hw : w ∈ closed_ball z r, from mem_closed_ball.2 le_rfl,
  /- Assume the converse. Since `∥f w∥ ≤ ∥f z∥`, we have `∥f w∥ < ∥f z∥`. -/
  refine (is_max_on_iff.1 hz _ hw).antisymm (not_lt.1 _),
  rintro hw_lt : ∥f w∥ < ∥f z∥,
  have hr : 0 < r, from dist_pos.2 (ne_of_apply_ne (norm ∘ f) hw_lt.ne),
  /- Due to Cauchy integral formula, it suffices to prove the following inequality. -/
  suffices : ∥∮ ζ in C(z, r), (ζ - z)⁻¹ • f ζ∥ < 2 * π * ∥f z∥,
  { refine this.ne _,
    have A : ∮ ζ in C(z, r), (ζ - z)⁻¹ • f ζ = (2 * π * I : ℂ) • f z :=
      hd.circle_integral_sub_inv_smul (mem_ball_self hr),
    simp [A, norm_smul, real.pi_pos.le] },
  suffices : ∥∮ ζ in C(z, r), (ζ - z)⁻¹ • f ζ∥ < 2 * π * r * (∥f z∥ / r),
    by rwa [mul_assoc, mul_div_cancel' _ hr.ne'] at this,
  /- This inequality is true because `∥(ζ - z)⁻¹ • f ζ∥ ≤ ∥f z∥ / r` for all `ζ` on the circle and
  this inequality is strict at `ζ = w`. -/
  have hsub : sphere z r ⊆ closed_ball z r, from sphere_subset_closed_ball,
  refine circle_integral.norm_integral_lt_of_norm_le_const_of_lt hr _ _ ⟨w, rfl, _⟩,
  show continuous_on (λ (ζ : ℂ), (ζ - z)⁻¹ • f ζ) (sphere z r),
  { refine ((continuous_on_id.sub continuous_on_const).inv₀ _).smul
      (hd.continuous_on_ball.mono hsub),
    exact λ ζ hζ, sub_ne_zero.2 (ne_of_mem_sphere hζ hr.ne') },
  show ∀ ζ ∈ sphere z r, ∥(ζ - z)⁻¹ • f ζ∥ ≤ ∥f z∥ / r,
  { rintros ζ (hζ : abs (ζ - z) = r),
    rw [le_div_iff hr, norm_smul, norm_inv, norm_eq_abs, hζ, mul_comm, mul_inv_cancel_left₀ hr.ne'],
    exact hz (hsub hζ) },
  show ∥(w - z)⁻¹ • f w∥ < ∥f z∥ / r,
  { rw [norm_smul, norm_inv, norm_eq_abs, ← div_eq_inv_mul],
    exact (div_lt_div_right hr).2 hw_lt }
end

/-!
Now we drop the assumption `complete_space F` by embedding `F` into its completion.
-/

lemma norm_max_aux₂ {f : ℂ → F} {z w : ℂ} (hd : diff_cont_on_cl ℂ f (ball z (dist w z)))
  (hz : is_max_on (norm ∘ f) (closed_ball z (dist w z)) z) :
  ∥f w∥ = ∥f z∥ :=
begin
  set e : F →L[ℂ] F̂ := uniform_space.completion.to_complL,
  have he : ∀ x, ∥e x∥ = ∥x∥, from uniform_space.completion.norm_coe,
  replace hz : is_max_on (norm ∘ (e ∘ f)) (closed_ball z (dist w z)) z,
    by simpa only [is_max_on, (∘), he] using hz,
  simpa only [he] using norm_max_aux₁ (e.differentiable.comp_diff_cont_on_cl hd) hz
end

/-!
Then we replace the assumption `is_max_on (norm ∘ f) (closed_ball z r) z` with a seemingly weaker
assumption `is_max_on (norm ∘ f) (ball z r) z`.
-/

lemma norm_max_aux₃ {f : ℂ → F} {z w : ℂ} {r : ℝ} (hr : dist w z = r)
  (hd : diff_cont_on_cl ℂ f (ball z r)) (hz : is_max_on (norm ∘ f) (ball z r) z) :
  ∥f w∥ = ∥f z∥ :=
begin
  subst r,
  rcases eq_or_ne w z with rfl|hne, { refl },
  rw ← dist_ne_zero at hne,
  exact norm_max_aux₂ hd (closure_ball z hne ▸ hz.closure hd.continuous_on.norm)
end

/-!
Finally, we generalize the theorem from a disk in `ℂ` to a closed ball in any normed space.
-/

/-- **Maximum modulus principle** on a closed ball: if `f : E → F` is continuous on a closed ball,
is complex differentiable on the corresponding open ball, and the norm `∥f w∥` takes its maximum
value on the open ball at its center, then the norm `∥f w∥` is constant on the closed ball.  -/
lemma norm_eq_on_closed_ball_of_is_max_on {f : E → F} {z : E} {r : ℝ}
  (hd : diff_cont_on_cl ℂ f (ball z r)) (hz : is_max_on (norm ∘ f) (ball z r) z) :
  eq_on (norm ∘ f) (const E ∥f z∥) (closed_ball z r) :=
begin
  intros w hw,
  rw [mem_closed_ball, dist_comm] at hw,
  rcases eq_or_ne z w with rfl|hne, { refl },
  set e : ℂ → E := line_map z w,
  have hde : differentiable ℂ e := (differentiable_id.smul_const (w - z)).add_const z,
  suffices : ∥(f ∘ e) (1 : ℂ)∥ = ∥(f ∘ e) (0 : ℂ)∥, by simpa [e],
  have hr : dist (1 : ℂ) 0 = 1, by simp,
  have hball : maps_to e (ball 0 1) (ball z r),
  { refine ((lipschitz_with_line_map z w).maps_to_ball
      (mt nndist_eq_zero.1 hne) 0 1).mono subset.rfl _,
    simpa only [line_map_apply_zero, mul_one, coe_nndist] using ball_subset_ball hw },
  exact norm_max_aux₃ hr (hd.comp hde.diff_cont_on_cl hball)
    (hz.comp_maps_to hball (line_map_apply_zero z w))
end

/-!
### Different forms of the maximum modulus principle
-/

/-- **Maximum modulus principle**: if `f : E → F` is complex differentiable on a set `s`, the norm
of `f` takes it maximum on `s` at `z` and `w` is a point such that the closed ball with center `z`
and radius `dist w z` is included in `s`, then `∥f w∥ = ∥f z∥`. -/
lemma norm_eq_norm_of_is_max_on_of_ball_subset {f : E → F} {s : set E} {z w : E}
  (hd : diff_cont_on_cl ℂ f s) (hz : is_max_on (norm ∘ f) s z) (hsub : ball z (dist w z) ⊆ s) :
  ∥f w∥ = ∥f z∥ :=
norm_eq_on_closed_ball_of_is_max_on (hd.mono hsub) (hz.on_subset hsub) (mem_closed_ball.2 le_rfl)

/-- **Maximum modulus principle**: if `f : E → F` is complex differentiable in a neighborhood of `c`
and the norm `∥f z∥` has a local maximum at `c`, then `∥f z∥` is locally constant in a neighborhood
of `c`. -/
lemma norm_eventually_eq_of_is_local_max {f : E → F} {c : E}
  (hd : ∀ᶠ z in 𝓝 c, differentiable_at ℂ f z) (hc : is_local_max (norm ∘ f) c) :
  ∀ᶠ y in 𝓝 c, ∥f y∥ = ∥f c∥ :=
begin
  rcases nhds_basis_closed_ball.eventually_iff.1 (hd.and hc) with ⟨r, hr₀, hr⟩,
  exact nhds_basis_closed_ball.eventually_iff.2 ⟨r, hr₀, norm_eq_on_closed_ball_of_is_max_on
    (differentiable_on.diff_cont_on_cl $
      λ x hx, (hr $ closure_ball_subset_closed_ball hx).1.differentiable_within_at)
    (λ x hx, (hr $ ball_subset_closed_ball hx).2)⟩
end

lemma is_open_set_of_mem_nhds_and_is_max_on_norm {f : E → F} {s : set E}
  (hd : differentiable_on ℂ f s) :
  is_open {z | s ∈ 𝓝 z ∧ is_max_on (norm ∘ f) s z} :=
begin
  refine is_open_iff_mem_nhds.2 (λ z hz, (eventually_eventually_nhds.2 hz.1).and _),
  replace hd : ∀ᶠ w in 𝓝 z, differentiable_at ℂ f w, from hd.eventually_differentiable_at hz.1,
  exact (norm_eventually_eq_of_is_local_max hd $ (hz.2.is_local_max hz.1)).mono
    (λ x hx y hy, le_trans (hz.2 hy) hx.ge)
end

/-- **Maximum modulus principle**: if `f : E → F` is complex differentiable on a nonempty bounded
set `U` and is continuous on its closure, then there exists a point `z ∈ frontier U` such that
`λ z, ∥f z∥` takes it maximum value on `closure U` at `z`. -/
lemma exists_mem_frontier_is_max_on_norm [nontrivial E] [finite_dimensional ℂ E]
  {f : E → F} {U : set E} (hb : bounded U) (hne : U.nonempty) (hd : diff_cont_on_cl ℂ f U) :
  ∃ z ∈ frontier U, is_max_on (norm ∘ f) (closure U) z :=
begin
  have hc : is_compact (closure U), from hb.is_compact_closure,
  obtain ⟨w, hwU, hle⟩ : ∃ w ∈ closure U, is_max_on (norm ∘ f) (closure U) w,
    from hc.exists_forall_ge hne.closure hd.continuous_on.norm,
  rw [closure_eq_interior_union_frontier, mem_union_eq] at hwU,
  cases hwU, rotate, { exact ⟨w, hwU, hle⟩ },
  have : interior U ≠ univ, from ne_top_of_le_ne_top hc.ne_univ interior_subset_closure,
  rcases exists_mem_frontier_inf_dist_compl_eq_dist hwU this with ⟨z, hzU, hzw⟩,
  refine ⟨z, frontier_interior_subset hzU, λ x hx, (mem_set_of_eq.mp $ hle hx).trans_eq _⟩,
  refine (norm_eq_norm_of_is_max_on_of_ball_subset hd (hle.on_subset subset_closure) _).symm,
  rw [dist_comm, ← hzw],
  exact ball_inf_dist_compl_subset.trans interior_subset
end

/-- **Maximum modulus principle**: if `f : E → F` is complex differentiable on a bounded set `U` and
`∥f z∥ ≤ C` for any `z ∈ frontier U`, then the same is true for any `z ∈ closure U`. -/
lemma norm_le_of_forall_mem_frontier_norm_le [nontrivial E] {f : E → F} {U : set E} (hU : bounded U)
  (hd : diff_cont_on_cl ℂ f U) {C : ℝ} (hC : ∀ z ∈ frontier U, ∥f z∥ ≤ C)
  {z : E} (hz : z ∈ closure U) :
  ∥f z∥ ≤ C :=
begin
  rw [closure_eq_self_union_frontier, union_comm, mem_union_eq] at hz,
  cases hz, { exact hC z hz },
  /- In case of a finite dimensional domain, one can just apply
  `complex.exists_mem_frontier_is_max_on_norm`. To make it work in any Banach space, we restrict
  the function to a line first. -/
  rcases exists_ne z with ⟨w, hne⟩,
  set e : ℂ → E := line_map z w,
  have hde : differentiable ℂ e := (differentiable_id.smul_const (w - z)).add_const z,
  have hL : antilipschitz_with (nndist z w)⁻¹ e, from antilipschitz_with_line_map hne.symm,
  replace hd : diff_cont_on_cl ℂ (f ∘ e) (e ⁻¹' U),
    from hd.comp hde.diff_cont_on_cl (maps_to_preimage _ _),
  have h₀ : (0 : ℂ) ∈ e ⁻¹' U, by simpa only [e, mem_preimage, line_map_apply_zero],
  rcases exists_mem_frontier_is_max_on_norm (hL.bounded_preimage hU) ⟨0, h₀⟩ hd with ⟨ζ, hζU, hζ⟩,
  calc ∥f z∥ = ∥f (e 0)∥ : by simp only [e, line_map_apply_zero]
  ... ≤ ∥f (e ζ)∥ : hζ (subset_closure h₀)
  ... ≤ C : hC _ (hde.continuous.frontier_preimage_subset _ hζU)
end

/-- If two complex differentiable functions `f g : E → F` are equal on the boundary of a bounded set
`U`, then they are equal on `closure U`. -/
lemma eq_on_closure_of_eq_on_frontier [nontrivial E] {f g : E → F} {U : set E} (hU : bounded U)
  (hf : diff_cont_on_cl ℂ f U) (hg : diff_cont_on_cl ℂ g U) (hfg : eq_on f g (frontier U)) :
  eq_on f g (closure U) :=
begin
  suffices H : ∀ z ∈ closure U, ∥(f - g) z∥ ≤ 0, by simpa [sub_eq_zero] using H,
  refine λ z hz, norm_le_of_forall_mem_frontier_norm_le hU (hf.sub hg) (λ w hw, _) hz,
  simp [hfg hw]
end

/-- If two complex differentiable functions `f g : E → F` are equal on the boundary of a bounded set
`U`, then they are equal on `U`. -/
lemma eq_on_of_eq_on_frontier [nontrivial E] {f g : E → F} {U : set E} (hU : bounded U)
  (hf : diff_cont_on_cl ℂ f U) (hg : diff_cont_on_cl ℂ g U) (hfg : eq_on f g (frontier U)) :
  eq_on f g U :=
(eq_on_closure_of_eq_on_frontier hU hf hg hfg).mono subset_closure

end complex


<|start_filename|>src/category_theory/adjunction/comma.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.adjunction.basic
import category_theory.punit
import category_theory.structured_arrow

/-!
# Properties of comma categories relating to adjunctions

This file shows that for a functor `G : D ⥤ C` the data of an initial object in each
`structured_arrow` category on `G` is equivalent to a left adjoint to `G`, as well as the dual.

Specifically, `adjunction_of_structured_arrow_initials` gives the left adjoint assuming the
appropriate initial objects exist, and `mk_initial_of_left_adjoint` constructs the initial objects
provided a left adjoint.

The duals are also shown.
-/
universes v u₁ u₂

noncomputable theory

namespace category_theory
open limits

variables {C : Type u₁} {D : Type u₂} [category.{v} C] [category.{v} D] (G : D ⥤ C)

section of_initials
variables [∀ A, has_initial (structured_arrow A G)]

/--
Implementation: If each structured arrow category on `G` has an initial object, an equivalence
which is helpful for constructing a left adjoint to `G`.
-/
@[simps]
def left_adjoint_of_structured_arrow_initials_aux (A : C) (B : D) :
  ((⊥_ (structured_arrow A G)).right ⟶ B) ≃ (A ⟶ G.obj B) :=
{ to_fun := λ g, (⊥_ (structured_arrow A G)).hom ≫ G.map g,
  inv_fun := λ f, comma_morphism.right (initial.to (structured_arrow.mk f)),
  left_inv := λ g,
  begin
    let B' : structured_arrow A G :=
      structured_arrow.mk ((⊥_ (structured_arrow A G)).hom ≫ G.map g),
    let g' : ⊥_ (structured_arrow A G) ⟶ B' := structured_arrow.hom_mk g rfl,
    have : initial.to _ = g',
    { apply colimit.hom_ext, rintro ⟨⟨⟩⟩ },
    change comma_morphism.right (initial.to B') = _,
    rw this,
    refl
  end,
  right_inv := λ f,
  begin
    let B' : structured_arrow A G := { right := B, hom := f },
    apply (comma_morphism.w (initial.to B')).symm.trans (category.id_comp _),
  end }

/--
If each structured arrow category on `G` has an initial object, construct a left adjoint to `G`. It
is shown that it is a left adjoint in `adjunction_of_structured_arrow_initials`.
-/
def left_adjoint_of_structured_arrow_initials : C ⥤ D :=
adjunction.left_adjoint_of_equiv (left_adjoint_of_structured_arrow_initials_aux G) (λ _ _, by simp)

/--
If each structured arrow category on `G` has an initial object, we have a constructed left adjoint
to `G`.
-/
def adjunction_of_structured_arrow_initials :
  left_adjoint_of_structured_arrow_initials G ⊣ G :=
adjunction.adjunction_of_equiv_left _ _

/-- If each structured arrow category on `G` has an initial object, `G` is a right adjoint. -/
def is_right_adjoint_of_structured_arrow_initials : is_right_adjoint G :=
{ left := _, adj := adjunction_of_structured_arrow_initials G }

end of_initials

section of_terminals
variables [∀ A, has_terminal (costructured_arrow G A)]

/--
Implementation: If each costructured arrow category on `G` has a terminal object, an equivalence
which is helpful for constructing a right adjoint to `G`.
-/
@[simps]
def right_adjoint_of_costructured_arrow_terminals_aux (B : D) (A : C) :
  (G.obj B ⟶ A) ≃ (B ⟶ (⊤_ (costructured_arrow G A)).left) :=
{ to_fun := λ g, comma_morphism.left (terminal.from (costructured_arrow.mk g)),
  inv_fun := λ g, G.map g ≫ (⊤_ (costructured_arrow G A)).hom,
  left_inv := by tidy,
  right_inv := λ g,
  begin
    let B' : costructured_arrow G A :=
      costructured_arrow.mk (G.map g ≫ (⊤_ (costructured_arrow G A)).hom),
    let g' : B' ⟶ ⊤_ (costructured_arrow G A) := costructured_arrow.hom_mk g rfl,
    have : terminal.from _ = g',
    { apply limit.hom_ext, rintro ⟨⟨⟩⟩ },
    change comma_morphism.left (terminal.from B') = _,
    rw this,
    refl
  end }

/--
If each costructured arrow category on `G` has a terminal object, construct a right adjoint to `G`.
It is shown that it is a right adjoint in `adjunction_of_structured_arrow_initials`.
-/
def right_adjoint_of_costructured_arrow_terminals : C ⥤ D :=
adjunction.right_adjoint_of_equiv (right_adjoint_of_costructured_arrow_terminals_aux G)
  (λ B₁ B₂ A f g, by { rw ←equiv.eq_symm_apply, simp })

/--
If each costructured arrow category on `G` has a terminal object, we have a constructed right
adjoint to `G`.
-/
def adjunction_of_costructured_arrow_terminals :
  G ⊣ right_adjoint_of_costructured_arrow_terminals G :=
adjunction.adjunction_of_equiv_right _ _

/-- If each costructured arrow category on `G` has an terminal object, `G` is a left adjoint. -/
def is_right_adjoint_of_costructured_arrow_terminals : is_left_adjoint G :=
{ right := right_adjoint_of_costructured_arrow_terminals G,
  adj := adjunction.adjunction_of_equiv_right _ _ }

end of_terminals

section
variables {F : C ⥤ D}

local attribute [tidy] tactic.discrete_cases

/-- Given a left adjoint to `G`, we can construct an initial object in each structured arrow
category on `G`. -/
def mk_initial_of_left_adjoint (h : F ⊣ G) (A : C) :
  is_initial (structured_arrow.mk (h.unit.app A) : structured_arrow A G) :=
{ desc := λ B, structured_arrow.hom_mk ((h.hom_equiv _ _).symm B.X.hom) (by tidy),
  uniq' := λ s m w,
  begin
    ext,
    dsimp,
    rw [equiv.eq_symm_apply, adjunction.hom_equiv_unit],
    apply structured_arrow.w m,
  end }

/-- Given a right adjoint to `F`, we can construct a terminal object in each costructured arrow
category on `F`. -/
def mk_terminal_of_right_adjoint (h : F ⊣ G) (A : D) :
  is_terminal (costructured_arrow.mk (h.counit.app A) : costructured_arrow F A) :=
{ lift := λ B, costructured_arrow.hom_mk (h.hom_equiv _ _ B.X.hom) (by tidy),
  uniq' := λ s m w,
  begin
    ext,
    dsimp,
    rw [h.eq_hom_equiv_apply, adjunction.hom_equiv_counit],
    exact costructured_arrow.w m,
  end }

end

end category_theory


<|start_filename|>src/category_theory/punit.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import category_theory.functor.const
import category_theory.discrete_category

/-!
# The category `discrete punit`

We define `star : C ⥤ discrete punit` sending everything to `punit.star`,
show that any two functors to `discrete punit` are naturally isomorphic,
and construct the equivalence `(discrete punit ⥤ C) ≌ C`.
-/

universes v u -- morphism levels before object levels. See note [category_theory universes].

namespace category_theory
variables (C : Type u) [category.{v} C]

namespace functor

/-- The constant functor sending everything to `punit.star`. -/
@[simps]
def star : C ⥤ discrete punit :=
(functor.const _).obj ⟨⟨⟩⟩

variable {C}
/-- Any two functors to `discrete punit` are isomorphic. -/
@[simps]
def punit_ext (F G : C ⥤ discrete punit) : F ≅ G :=
nat_iso.of_components (λ _, eq_to_iso dec_trivial) (λ _ _ _, dec_trivial)

/--
Any two functors to `discrete punit` are *equal*.
You probably want to use `punit_ext` instead of this.
-/
lemma punit_ext' (F G : C ⥤ discrete punit) : F = G :=
functor.ext (λ _, dec_trivial) (λ _ _ _, dec_trivial)

/-- The functor from `discrete punit` sending everything to the given object. -/
abbreviation from_punit (X : C) : discrete punit.{v+1} ⥤ C :=
(functor.const _).obj X

/-- Functors from `discrete punit` are equivalent to the category itself. -/
@[simps]
def equiv : (discrete punit ⥤ C) ≌ C :=
{ functor :=
  { obj := λ F, F.obj ⟨⟨⟩⟩,
    map := λ F G θ, θ.app ⟨⟨⟩⟩ },
  inverse := functor.const _,
  unit_iso :=
  begin
    apply nat_iso.of_components _ _,
    intro X,
    apply discrete.nat_iso,
    rintro ⟨⟨⟩⟩,
    apply iso.refl _,
    intros,
    ext ⟨⟨⟩⟩,
    simp,
  end,
  counit_iso :=
  begin
    refine nat_iso.of_components iso.refl _,
    intros X Y f,
    dsimp, simp,  -- See note [dsimp, simp].
  end }

end functor

/-- A category being equivalent to `punit` is equivalent to it having a unique morphism between
  any two objects. (In fact, such a category is also a groupoid; see `groupoid.of_hom_unique`) -/
theorem equiv_punit_iff_unique :
  nonempty (C ≌ discrete punit) ↔ (nonempty C) ∧ (∀ x y : C, nonempty $ unique (x ⟶ y)) :=
begin
  split,
  { rintro ⟨h⟩,
    refine ⟨⟨h.inverse.obj ⟨⟨⟩⟩⟩, λ x y, nonempty.intro _⟩,
    apply (unique_of_subsingleton _), swap,
    { have hx : x ⟶ h.inverse.obj ⟨⟨⟩⟩ := by convert h.unit.app x,
      have hy : h.inverse.obj ⟨⟨⟩⟩ ⟶ y := by convert h.unit_inv.app y,
      exact hx ≫ hy, },
    have : ∀ z, z = h.unit.app x ≫ (h.functor ⋙ h.inverse).map z ≫ h.unit_inv.app y,
    { intro z, simpa using congr_arg (≫ (h.unit_inv.app y)) (h.unit.naturality z), },
    apply subsingleton.intro,
    intros a b,
    rw [this a, this b],
    simp only [functor.comp_map], congr, },
  { rintro ⟨⟨p⟩, h⟩,
    haveI := λ x y, (h x y).some,
    refine nonempty.intro (category_theory.equivalence.mk
      ((functor.const _).obj ⟨⟨⟩⟩) ((functor.const _).obj p) _ (by apply functor.punit_ext)),
    exact nat_iso.of_components (λ _, { hom := default, inv := default }) (λ _ _ _, by tidy), },
end

end category_theory


<|start_filename|>src/category_theory/discrete_category.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import category_theory.eq_to_hom
import data.ulift

/-!
# Discrete categories

We define `discrete α` as a structure containing a term `a : α` for any type `α`,
and use this type alias to provide a `small_category` instance
whose only morphisms are the identities.

There is an annoying technical difficulty that it has turned out to be inconvenient
to allow categories with morphisms living in `Prop`,
so instead of defining `X ⟶ Y` in `discrete α` as `X = Y`,
one might define it as `plift (X = Y)`.
In fact, to allow `discrete α` to be a `small_category`
(i.e. with morphisms in the same universe as the objects),
we actually define the hom type `X ⟶ Y` as `ulift (plift (X = Y))`.

`discrete.functor` promotes a function `f : I → C` (for any category `C`) to a functor
`discrete.functor f : discrete I ⥤ C`.

Similarly, `discrete.nat_trans` and `discrete.nat_iso` promote `I`-indexed families of morphisms,
or `I`-indexed families of isomorphisms to natural transformations or natural isomorphism.

We show equivalences of types are the same as (categorical) equivalences of the corresponding
discrete categories.
-/

namespace category_theory

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ v₃ u₁ u₂ u₃

/--
A wrapper for promoting any type to a category,
with the only morphisms being equalities.
-/
-- This is intentionally a structure rather than a type synonym
-- to enforce using `discrete_equiv` (or `discrete.mk` and `discrete.as`) to move between
-- `discrete α` and `α`. Otherwise there is too much API leakage.
@[ext] structure discrete (α : Type u₁) :=
(as : α)

@[simp] lemma discrete.mk_as {α : Type u₁} (X : discrete α) : discrete.mk X.as = X :=
by { ext, refl, }

/-- `discrete α` is equivalent to the original type `α`.-/
@[simps] def discrete_equiv {α : Type u₁} : discrete α ≃ α :=
{ to_fun := discrete.as,
  inv_fun := discrete.mk,
  left_inv := by tidy,
  right_inv := by tidy, }

instance {α : Type u₁} [decidable_eq α] : decidable_eq (discrete α) :=
discrete_equiv.decidable_eq

/--
The "discrete" category on a type, whose morphisms are equalities.

Because we do not allow morphisms in `Prop` (only in `Type`),
somewhat annoyingly we have to define `X ⟶ Y` as `ulift (plift (X = Y))`.

See <https://stacks.math.columbia.edu/tag/001A>
-/
instance discrete_category (α : Type u₁) : small_category (discrete α) :=
{ hom  := λ X Y, ulift (plift (X.as = Y.as)),
  id   := λ X, ulift.up (plift.up rfl),
  comp := λ X Y Z g f, by { cases X, cases Y, cases Z, rcases f with ⟨⟨⟨⟩⟩⟩, exact g } }

namespace discrete

variables {α : Type u₁}

instance [inhabited α] : inhabited (discrete α) :=
⟨⟨default⟩⟩

instance [subsingleton α] : subsingleton (discrete α) :=
⟨by { intros, ext, apply subsingleton.elim, }⟩

/-- A simple tactic to run `cases` on any `discrete α` hypotheses. -/
meta def _root_.tactic.discrete_cases : tactic unit :=
`[cases_matching* [discrete _, (_ : discrete _) ⟶ (_ : discrete _), plift _]]

run_cmd add_interactive [``tactic.discrete_cases]

local attribute [tidy] tactic.discrete_cases

instance [unique α] : unique (discrete α) :=
unique.mk' (discrete α)

/-- Extract the equation from a morphism in a discrete category. -/
lemma eq_of_hom {X Y : discrete α} (i : X ⟶ Y) : X.as = Y.as := i.down.down

/-- Promote an equation between the wrapped terms in `X Y : discrete α` to a morphism `X ⟶ Y`
in the discrete category. -/
abbreviation eq_to_hom {X Y : discrete α} (h : X.as = Y.as) : X ⟶ Y :=
eq_to_hom (by { ext, exact h, })

/-- Promote an equation between the wrapped terms in `X Y : discrete α` to an isomorphism `X ≅ Y`
in the discrete category. -/
abbreviation eq_to_iso {X Y : discrete α} (h : X.as = Y.as) : X ≅ Y :=
eq_to_iso (by { ext, exact h, })

/-- A variant of `eq_to_hom` that lifts terms to the discrete category. -/
abbreviation eq_to_hom' {a b : α} (h : a = b) : discrete.mk a ⟶ discrete.mk b :=
eq_to_hom h

/-- A variant of `eq_to_iso` that lifts terms to the discrete category. -/
abbreviation eq_to_iso' {a b : α} (h : a = b) : discrete.mk a ≅ discrete.mk b :=
eq_to_iso h

@[simp] lemma id_def (X : discrete α) : ulift.up (plift.up (eq.refl X.as)) = 𝟙 X := rfl

variables {C : Type u₂} [category.{v₂} C]

instance {I : Type u₁} {i j : discrete I} (f : i ⟶ j) : is_iso f :=
⟨⟨eq_to_hom (eq_of_hom f).symm, by tidy⟩⟩

/--
Any function `I → C` gives a functor `discrete I ⥤ C`.
-/
def functor {I : Type u₁} (F : I → C) : discrete I ⥤ C :=
{ obj := F ∘ discrete.as,
  map := λ X Y f, by { discrete_cases, cases f, exact 𝟙 (F X), } }

@[simp] lemma functor_obj  {I : Type u₁} (F : I → C) (i : I) :
  (discrete.functor F).obj (discrete.mk i) = F i := rfl

lemma functor_map  {I : Type u₁} (F : I → C) {i : discrete I} (f : i ⟶ i) :
  (discrete.functor F).map f = 𝟙 (F i.as) :=
by tidy

/--
For functors out of a discrete category,
a natural transformation is just a collection of maps,
as the naturality squares are trivial.
-/
@[simps]
def nat_trans {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ⟶ G.obj i) : F ⟶ G :=
{ app := f,
  naturality' := λ X Y g, by { discrete_cases, cases g, simp, } }

/--
For functors out of a discrete category,
a natural isomorphism is just a collection of isomorphisms,
as the naturality squares are trivial.
-/
@[simps]
def nat_iso {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) : F ≅ G :=
nat_iso.of_components f (λ X Y g, by { discrete_cases, cases g, simp, })

@[simp]
lemma nat_iso_app {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) (i : discrete I) :
  (discrete.nat_iso f).app i = f i :=
by tidy

/-- Every functor `F` from a discrete category is naturally isomorphic (actually, equal) to
  `discrete.functor (F.obj)`. -/
@[simp]
def nat_iso_functor {I : Type u₁} {F : discrete I ⥤ C} :
  F ≅ discrete.functor (F.obj ∘ discrete.mk) :=
nat_iso $ λ i, by { discrete_cases, refl, }

/-- Composing `discrete.functor F` with another functor `G` amounts to composing `F` with `G.obj` -/
@[simp]
def comp_nat_iso_discrete {I : Type u₁} {D : Type u₃} [category.{v₃} D]
 (F : I → C) (G : C ⥤ D) : discrete.functor F ⋙ G ≅ discrete.functor (G.obj ∘ F) :=
nat_iso $ λ i, iso.refl _

/--
We can promote a type-level `equiv` to
an equivalence between the corresponding `discrete` categories.
-/
@[simps]
def equivalence {I : Type u₁} {J : Type u₂} (e : I ≃ J) : discrete I ≌ discrete J :=
{ functor := discrete.functor (discrete.mk ∘ (e : I → J)),
  inverse := discrete.functor (discrete.mk ∘ (e.symm : J → I)),
  unit_iso := discrete.nat_iso (λ i, eq_to_iso (by { discrete_cases, simp })),
  counit_iso := discrete.nat_iso (λ j, eq_to_iso (by { discrete_cases, simp })), }

/-- We can convert an equivalence of `discrete` categories to a type-level `equiv`. -/
@[simps]
def equiv_of_equivalence {α : Type u₁} {β : Type u₂} (h : discrete α ≌ discrete β) : α ≃ β :=
{ to_fun := discrete.as ∘ h.functor.obj ∘ discrete.mk,
  inv_fun := discrete.as ∘ h.inverse.obj ∘ discrete.mk,
  left_inv := λ a, by simpa using eq_of_hom (h.unit_iso.app (discrete.mk a)).2,
  right_inv := λ a, by simpa using eq_of_hom (h.counit_iso.app (discrete.mk a)).1, }

end discrete

namespace discrete
variables {J : Type v₁}

open opposite

/-- A discrete category is equivalent to its opposite category. -/
@[simps functor_obj_as inverse_obj]
protected def opposite (α : Type u₁) : (discrete α)ᵒᵖ ≌ discrete α :=
let F : discrete α ⥤ (discrete α)ᵒᵖ := discrete.functor (λ x, op (discrete.mk x)) in
begin
  refine equivalence.mk (functor.left_op F) F _
    (discrete.nat_iso $ λ X, by { discrete_cases, simp [F] }),
  refine nat_iso.of_components (λ X, by { tactic.op_induction', discrete_cases, simp [F], }) _,
  tidy
end

variables {C : Type u₂} [category.{v₂} C]

@[simp] lemma functor_map_id
  (F : discrete J ⥤ C) {j : discrete J} (f : j ⟶ j) : F.map f = 𝟙 (F.obj j) :=
begin
  have h : f = 𝟙 j, { cases f, cases f, ext, },
  rw h,
  simp,
end

end discrete

end category_theory


<|start_filename|>src/linear_algebra/quadratic_form/complex.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import linear_algebra.quadratic_form.isometry
import analysis.special_functions.pow

/-!
# Quadratic forms over the complex numbers

`equivalent_sum_squares`: A nondegenerate quadratic form over the complex numbers is equivalent to
a sum of squares.

-/

namespace quadratic_form

open_locale big_operators
open finset

variables {ι : Type*} [fintype ι]

/-- The isometry between a weighted sum of squares on the complex numbers and the
sum of squares, i.e. `weighted_sum_squares` with weights 1 or 0. -/
noncomputable def isometry_sum_squares [decidable_eq ι] (w' : ι → ℂ) :
  isometry (weighted_sum_squares ℂ w')
    (weighted_sum_squares ℂ (λ i, if w' i = 0 then 0 else 1 : ι → ℂ)) :=
begin
  let w := λ i, if h : w' i = 0 then (1 : units ℂ) else units.mk0 (w' i) h,
  have hw' : ∀ i : ι, (w i : ℂ) ^ - (1 / 2 : ℂ) ≠ 0,
  { intros i hi,
    exact (w i).ne_zero ((complex.cpow_eq_zero_iff _ _).1 hi).1 },
  convert (weighted_sum_squares ℂ w').isometry_basis_repr
    ((pi.basis_fun ℂ ι).units_smul (λ i, (is_unit_iff_ne_zero.2 $ hw' i).unit)),
  ext1 v,
  erw [basis_repr_apply, weighted_sum_squares_apply, weighted_sum_squares_apply],
  refine sum_congr rfl (λ j hj, _),
  have hsum : (∑ (i : ι), v i • ((is_unit_iff_ne_zero.2 $ hw' i).unit : ℂ) •
    (pi.basis_fun ℂ ι) i) j = v j • w j ^ - (1 / 2 : ℂ),
  { rw [finset.sum_apply, sum_eq_single j, pi.basis_fun_apply, is_unit.unit_spec,
        linear_map.std_basis_apply, pi.smul_apply, pi.smul_apply, function.update_same,
        smul_eq_mul, smul_eq_mul, smul_eq_mul, mul_one],
    intros i _ hij,
    rw [pi.basis_fun_apply, linear_map.std_basis_apply, pi.smul_apply, pi.smul_apply,
        function.update_noteq hij.symm, pi.zero_apply, smul_eq_mul, smul_eq_mul,
        mul_zero, mul_zero],
    intro hj', exact false.elim (hj' hj) },
  simp_rw basis.units_smul_apply,
  erw [hsum, smul_eq_mul],
  split_ifs,
  { simp only [h, zero_smul, zero_mul]},
  have hww' : w' j = w j,
  { simp only [w, dif_neg h, units.coe_mk0] },
  simp only [hww', one_mul],
  change v j * v j = ↑(w j) * ((v j * ↑(w j) ^ -(1 / 2 : ℂ)) * (v j * ↑(w j) ^ -(1 / 2 : ℂ))),
  suffices : v j * v j = w j ^ - (1 / 2 : ℂ) * w j ^ - (1 / 2 : ℂ) * w j * v j * v j,
  { rw [this], ring },
  rw [← complex.cpow_add _ _ (w j).ne_zero, show - (1 / 2 : ℂ) + - (1 / 2) = -1, by ring,
      complex.cpow_neg_one, inv_mul_cancel (w j).ne_zero, one_mul],
end

/-- The isometry between a weighted sum of squares on the complex numbers and the
sum of squares, i.e. `weighted_sum_squares` with weight `λ i : ι, 1`. -/
noncomputable def isometry_sum_squares_units [decidable_eq ι] (w : ι → units ℂ) :
  isometry (weighted_sum_squares ℂ w) (weighted_sum_squares ℂ (1 : ι → ℂ)) :=
begin
  have hw1 : (λ i, if (w i : ℂ) = 0 then 0 else 1 : ι → ℂ) = 1,
  { ext i : 1, exact dif_neg (w i).ne_zero },
  have := isometry_sum_squares (coe ∘ w),
  rw hw1 at this,
  exact this,
end

/-- A nondegenerate quadratic form on the complex numbers is equivalent to
the sum of squares, i.e. `weighted_sum_squares` with weight `λ i : ι, 1`. -/
theorem equivalent_sum_squares {M : Type*} [add_comm_group M] [module ℂ M]
  [finite_dimensional ℂ M] (Q : quadratic_form ℂ M) (hQ : (associated Q).nondegenerate) :
  equivalent Q (weighted_sum_squares ℂ (1 : fin (finite_dimensional.finrank ℂ M) → ℂ)) :=
let ⟨w, ⟨hw₁⟩⟩ := Q.equivalent_weighted_sum_squares_units_of_nondegenerate' hQ in
  ⟨hw₁.trans (isometry_sum_squares_units w)⟩

/-- All nondegenerate quadratic forms on the complex numbers are equivalent. -/
theorem complex_equivalent {M : Type*} [add_comm_group M] [module ℂ M]
  [finite_dimensional ℂ M] (Q₁ Q₂ : quadratic_form ℂ M) (hQ₁ : (associated Q₁).nondegenerate)
  (hQ₂ : (associated Q₂).nondegenerate) : equivalent Q₁ Q₂ :=
(Q₁.equivalent_sum_squares hQ₁).trans (Q₂.equivalent_sum_squares hQ₂).symm

end quadratic_form


<|start_filename|>src/algebraic_topology/nerve.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import algebraic_topology.simplicial_set

/-!

# The nerve of a category

This file provides the definition of the nerve of a category `C`,
which is a simplicial set `nerve C` (see [goerss-jardine-2009], Example I.1.4).

## References
* [<NAME>, <NAME>, *Simplical Homotopy Theory*][goerss-jardine-2009]

-/

open category_theory.category

universes v u

namespace category_theory

/-- The nerve of a category -/
@[simps]
def nerve (C : Type u) [category.{v} C] : sSet.{max u v} :=
{ obj := λ Δ, (simplex_category.to_Cat.obj Δ.unop) ⥤ C,
  map := λ Δ₁ Δ₂ f x, simplex_category.to_Cat.map f.unop ⋙ x,
  map_id' := λ Δ, begin
    rw [unop_id, functor.map_id],
    ext x,
    apply functor.id_comp,
  end, }

instance {C : Type*} [category C] {Δ : simplex_categoryᵒᵖ} : category ((nerve C).obj Δ) :=
(infer_instance : category ((simplex_category.to_Cat.obj Δ.unop) ⥤ C))

/-- The nerve of a category, as a functor `Cat ⥤ sSet` -/
@[simps]
def nerve_functor : Cat ⥤ sSet :=
{ obj := λ C, nerve C,
  map := λ C C' F,
  { app := λ Δ x, x ⋙ F, },
  map_id' := λ C, begin
    ext Δ x,
    apply functor.comp_id,
  end, }

end category_theory


<|start_filename|>src/category_theory/preadditive/Mat.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.big_operators.basic
import algebra.big_operators.pi
import category_theory.limits.shapes.biproducts
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import data.matrix.dmatrix
import data.matrix.basic
import category_theory.Fintype
import category_theory.preadditive.single_obj
import algebra.opposites

/-!
# Matrices over a category.

When `C` is a preadditive category, `Mat_ C` is the preadditive category
whose objects are finite tuples of objects in `C`, and
whose morphisms are matrices of morphisms from `C`.

There is a functor `Mat_.embedding : C ⥤ Mat_ C` sending morphisms to one-by-one matrices.

`Mat_ C` has finite biproducts.

## The additive envelope

We show that this construction is the "additive envelope" of `C`,
in the sense that any additive functor `F : C ⥤ D` to a category `D` with biproducts
lifts to a functor `Mat_.lift F : Mat_ C ⥤ D`,
Moreover, this functor is unique (up to natural isomorphisms) amongst functors `L : Mat_ C ⥤ D`
such that `embedding C ⋙ L ≅ F`.
(As we don't have 2-category theory, we can't explicitly state that `Mat_ C` is
the initial object in the 2-category of categories under `C` which have biproducts.)

As a consequence, when `C` already has finite biproducts we have `Mat_ C ≌ C`.

## Future work

We should provide a more convenient `Mat R`, when `R` is a ring,
as a category with objects `n : FinType`,
and whose morphisms are matrices with components in `R`.

Ideally this would conveniently interact with both `Mat_` and `matrix`.

-/

open category_theory category_theory.preadditive
open_locale big_operators classical
noncomputable theory

namespace category_theory

universes w v₁ v₂ u₁ u₂
variables (C : Type u₁) [category.{v₁} C] [preadditive C]

/--
An object in `Mat_ C` is a finite tuple of objects in `C`.
-/
structure Mat_ : Type (max (v₁+1) u₁) :=
(ι : Type v₁)
[F : fintype ι]
(X : ι → C)

attribute [instance] Mat_.F

namespace Mat_

variables {C}

/-- A morphism in `Mat_ C` is a dependently typed matrix of morphisms. -/
@[nolint has_inhabited_instance]
def hom (M N : Mat_ C) : Type v₁ := dmatrix M.ι N.ι (λ i j, M.X i ⟶ N.X j)

namespace hom

/-- The identity matrix consists of identity morphisms on the diagonal, and zeros elsewhere. -/
def id (M : Mat_ C) : hom M M := λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0

/-- Composition of matrices using matrix multiplication. -/
def comp {M N K : Mat_ C} (f : hom M N) (g : hom N K) : hom M K :=
λ i k, ∑ j : N.ι, f i j ≫ g j k

end hom

section
local attribute [simp] hom.id hom.comp

instance : category.{v₁} (Mat_ C) :=
{ hom := hom,
  id := hom.id,
  comp := λ M N K f g, f.comp g,
  id_comp' := λ M N f, by simp [dite_comp],
  comp_id' := λ M N f, by simp [comp_dite],
  assoc' := λ M N K L f g h, begin
    ext i k,
    simp_rw [hom.comp, sum_comp, comp_sum, category.assoc],
    rw finset.sum_comm,
  end, }.

lemma id_def (M : Mat_ C) :
  (𝟙 M : hom M M) = λ i j, if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

lemma id_apply (M : Mat_ C) (i j : M.ι) :
  (𝟙 M : hom M M) i j = if h : i = j then eq_to_hom (congr_arg M.X h) else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat_ C) (i : M.ι) :
  (𝟙 M : hom M M) i i = 𝟙 _ :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat_ C) (i j : M.ι) (h : i ≠ j) :
  (𝟙 M : hom M M) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N.ι, f i j ≫ g j k := rfl

@[simp] lemma comp_apply {M N K : Mat_ C} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N.ι, f i j ≫ g j k := rfl

instance (M N : Mat_ C) : inhabited (M ⟶ N) := ⟨λ i j, (0 : M.X i ⟶ N.X j)⟩

end

instance : preadditive (Mat_ C) :=
{ hom_group := λ M N, by { change add_comm_group (dmatrix M.ι N.ι _), apply_instance, },
  add_comp' := λ M N K f f' g, by { ext, simp [finset.sum_add_distrib], },
  comp_add' := λ M N K f g g', by { ext, simp [finset.sum_add_distrib], }, }

@[simp] lemma add_apply {M N : Mat_ C} (f g : M ⟶ N) (i j) : (f + g) i j = f i j + g i j := rfl

open category_theory.limits

/--
We now prove that `Mat_ C` has finite biproducts.

Be warned, however, that `Mat_ C` is not necessarily Krull-Schmidt,
and so the internal indexing of a biproduct may have nothing to do with the external indexing,
even though the construction we give uses a sigma type.
See however `iso_biproduct_embedding`.
-/
instance has_finite_biproducts : has_finite_biproducts (Mat_ C) :=
{ has_biproducts_of_shape := λ J 𝒟, by exactI
  { has_biproduct := λ f,
    has_biproduct_of_total
    { X := ⟨Σ j : J, (f j).ι, λ p, (f p.1).X p.2⟩,
      π := λ j x y,
      begin
        dsimp at x ⊢,
        refine if h : x.1 = j then _ else 0,
        refine if h' : (@eq.rec J x.1 (λ j, (f j).ι) x.2 _ h) = y then _ else 0,
        apply eq_to_hom,
        substs h h', -- Notice we were careful not to use `subst` until we had a goal in `Prop`.
      end,
      ι := λ j x y,
      begin
        dsimp at y ⊢,
        refine if h : y.1 = j then _ else 0,
        refine if h' : (@eq.rec J y.1 (λ j, (f j).ι) y.2 _ h) = x then _ else 0,
        apply eq_to_hom,
        substs h h',
      end,
      ι_π := λ j j',
      begin
        ext x y,
        dsimp,
        simp_rw [dite_comp, comp_dite],
        simp only [if_t_t, dite_eq_ite, dif_ctx_congr, limits.comp_zero, limits.zero_comp,
          eq_to_hom_trans, finset.sum_congr],
        erw finset.sum_sigma,
        dsimp,
        simp only [if_congr, if_true, dif_ctx_congr, finset.sum_dite_irrel, finset.mem_univ,
          finset.sum_const_zero, finset.sum_congr, finset.sum_dite_eq'],
        split_ifs with h h',
        { substs h h',
          simp only [category_theory.eq_to_hom_refl, category_theory.Mat_.id_apply_self], },
        { subst h,
          simp only [id_apply_of_ne _ _ _ h', category_theory.eq_to_hom_refl], },
        { refl, },
      end, }
    begin
      dsimp,
      funext i₁,
      dsimp at i₁ ⊢,
      rcases i₁ with ⟨j₁, i₁⟩,
      -- I'm not sure why we can't just `simp` by `finset.sum_apply`: something doesn't quite match
      convert finset.sum_apply _ _ _ using 1,
      { refl, },
      { apply heq_of_eq,
        symmetry,
        funext i₂,
        rcases i₂ with ⟨j₂, i₂⟩,
        simp only [comp_apply, dite_comp, comp_dite,
          if_t_t, dite_eq_ite, if_congr, if_true, dif_ctx_congr,
          finset.sum_dite_irrel, finset.sum_dite_eq, finset.mem_univ, finset.sum_const_zero,
          finset.sum_congr, finset.sum_dite_eq, finset.sum_apply,
          limits.comp_zero, limits.zero_comp, eq_to_hom_trans, Mat_.id_apply],
        by_cases h : j₁ = j₂,
        { subst h, simp, },
        { simp [h], }, },
    end }}.

end Mat_

namespace functor
variables {C} {D : Type*} [category.{v₁} D] [preadditive D]

local attribute [simp] Mat_.id_apply eq_to_hom_map

/--
A functor induces a functor of matrix categories.
-/
@[simps]
def map_Mat_ (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ Mat_ D :=
{ obj := λ M, ⟨M.ι, λ i, F.obj (M.X i)⟩,
  map := λ M N f i j, F.map (f i j),
  map_comp' := λ M N K f g, by { ext i k, simp,}, }

/--
The identity functor induces the identity functor on matrix categories.
-/
@[simps]
def map_Mat_id : (𝟭 C).map_Mat_ ≅ 𝟭 (Mat_ C) :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

/--
Composite functors induce composite functors on matrix categories.
-/
@[simps]
def map_Mat_comp {E : Type*} [category.{v₁} E] [preadditive E]
  (F : C ⥤ D) [functor.additive F] (G : D ⥤ E) [functor.additive G] :
  (F ⋙ G).map_Mat_ ≅ F.map_Mat_ ⋙ G.map_Mat_ :=
nat_iso.of_components (λ M, eq_to_iso (by { cases M, refl, }))
(λ M N f, begin
  ext i j,
  cases M, cases N,
  simp [comp_dite, dite_comp],
end)

end functor

namespace Mat_

variables (C)

/-- The embedding of `C` into `Mat_ C` as one-by-one matrices.
(We index the summands by `punit`.) -/
@[simps]
def embedding : C ⥤ Mat_ C :=
{ obj := λ X, ⟨punit, λ _, X⟩,
  map := λ X Y f, λ _ _, f,
  map_id' := λ X, by { ext ⟨⟩ ⟨⟩, simp, },
  map_comp' := λ X Y Z f g, by { ext ⟨⟩ ⟨⟩, simp, }, }

namespace embedding

instance : faithful (embedding C) :=
{ map_injective' := λ X Y f g h, congr_fun (congr_fun h punit.star) punit.star, }

instance : full (embedding C) :=
{ preimage := λ X Y f, f punit.star punit.star, }

instance : functor.additive (embedding C) := {}

end embedding

instance [inhabited C] : inhabited (Mat_ C) := ⟨(embedding C).obj default⟩

open category_theory.limits

variables {C}

/--
Every object in `Mat_ C` is isomorphic to the biproduct of its summands.
-/
@[simps]
def iso_biproduct_embedding (M : Mat_ C) : M ≅ ⨁ (λ i, (embedding C).obj (M.X i)) :=
{ hom := biproduct.lift (λ i j k, if h : j = i then eq_to_hom (congr_arg M.X h) else 0),
  inv := biproduct.desc (λ i j k, if h : i = k then eq_to_hom (congr_arg M.X h) else 0),
  hom_inv_id' :=
  begin
    simp only [biproduct.lift_desc],
    funext i,
    dsimp,
    convert finset.sum_apply _ _ _,
    { dsimp, refl, },
    { apply heq_of_eq,
      symmetry,
      funext j,
      simp only [finset.sum_apply],
      dsimp,
      simp [dite_comp, comp_dite, Mat_.id_apply], }
  end,
  inv_hom_id' :=
  begin
    apply biproduct.hom_ext,
    intro i,
    apply biproduct.hom_ext',
    intro j,
    simp only [category.id_comp, category.assoc,
      biproduct.lift_π, biproduct.ι_desc_assoc, biproduct.ι_π],
    ext ⟨⟩ ⟨⟩,
    simp [dite_comp, comp_dite],
    split_ifs,
    { subst h, simp, },
    { simp [h], },
  end, }.

variables {D : Type u₁} [category.{v₁} D] [preadditive D]

/-- Every `M` is a direct sum of objects from `C`, and `F` preserves biproducts. -/
@[simps]
def additive_obj_iso_biproduct (F : Mat_ C ⥤ D) [functor.additive F] (M : Mat_ C) :
  F.obj M ≅ ⨁ (λ i, F.obj ((embedding C).obj (M.X i))) :=
(F.map_iso (iso_biproduct_embedding M)) ≪≫ (F.map_biproduct _)

variables [has_finite_biproducts D]

@[reassoc] lemma additive_obj_iso_biproduct_naturality (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  F.map f ≫ (additive_obj_iso_biproduct F N).hom =
    (additive_obj_iso_biproduct F M).hom ≫
      biproduct.matrix (λ i j, F.map ((embedding C).map (f i j))) :=
begin
  -- This is disappointingly tedious.
  ext,
  simp only [additive_obj_iso_biproduct_hom, category.assoc, biproduct.lift_π, functor.map_bicone_π,
    biproduct.bicone_π, biproduct.lift_matrix],
  dsimp [embedding],
  simp only [←F.map_comp, biproduct.lift_π, biproduct.matrix_π, category.assoc],
  simp only [←F.map_comp, ←F.map_sum, biproduct.lift_desc, biproduct.lift_π_assoc, comp_sum],
  simp only [comp_def, comp_dite, comp_zero, finset.sum_dite_eq', finset.mem_univ, if_true],
  dsimp,
  simp only [finset.sum_singleton, dite_comp, zero_comp],
  congr,
  symmetry,
  convert finset.sum_fn _ _, -- It's hard to use this as a simp lemma!
  simp only [finset.sum_fn, finset.sum_dite_eq],
  ext,
  simp,
end

@[reassoc] lemma additive_obj_iso_biproduct_naturality' (F : Mat_ C ⥤ D) [functor.additive F]
  {M N : Mat_ C} (f : M ⟶ N) :
  (additive_obj_iso_biproduct F M).inv ≫ F.map f =
    biproduct.matrix (λ i j, F.map ((embedding C).map (f i j)) : _) ≫
      (additive_obj_iso_biproduct F N).inv :=
by rw [iso.inv_comp_eq, ←category.assoc, iso.eq_comp_inv, additive_obj_iso_biproduct_naturality]

/-- Any additive functor `C ⥤ D` to a category `D` with finite biproducts extends to
a functor `Mat_ C ⥤ D`. -/
@[simps]
def lift (F : C ⥤ D) [functor.additive F] : Mat_ C ⥤ D :=
{ obj := λ X, ⨁ (λ i, F.obj (X.X i)),
  map := λ X Y f, biproduct.matrix (λ i j, F.map (f i j)),
  map_id' := λ X, begin
    ext i j,
    by_cases h : i = j,
    { subst h, simp, },
    { simp [h, Mat_.id_apply], },
  end,
  map_comp' := λ X Y Z f g, by { ext i j, simp, }, }.

instance lift_additive (F : C ⥤ D) [functor.additive F] : functor.additive (lift F) := {}

/-- An additive functor `C ⥤ D` factors through its lift to `Mat_ C ⥤ D`. -/
@[simps]
def embedding_lift_iso (F : C ⥤ D) [functor.additive F] : embedding C ⋙ lift F ≅ F :=
nat_iso.of_components (λ X,
  { hom := biproduct.desc (λ P, 𝟙 (F.obj X)),
    inv := biproduct.lift (λ P, 𝟙 (F.obj X)), })
(λ X Y f, begin
  dsimp,
  ext,
  simp only [category.id_comp, biproduct.ι_desc_assoc],
  erw biproduct.ι_matrix_assoc, -- Not sure why this doesn't fire via `simp`.
  simp,
end).

/--
`Mat_.lift F` is the unique additive functor `L : Mat_ C ⥤ D` such that `F ≅ embedding C ⋙ L`.
-/
def lift_unique (F : C ⥤ D) [functor.additive F] (L : Mat_ C ⥤ D) [functor.additive L]
  (α : embedding C ⋙ L ≅ F) :
  L ≅ lift F :=
nat_iso.of_components
  (λ M, (additive_obj_iso_biproduct L M) ≪≫
    (biproduct.map_iso (λ i, α.app (M.X i))) ≪≫
    (biproduct.map_iso (λ i, (embedding_lift_iso F).symm.app (M.X i))) ≪≫
    (additive_obj_iso_biproduct (lift F) M).symm)
(λ M N f, begin
  dsimp only [iso.trans_hom, iso.symm_hom, biproduct.map_iso_hom],
  simp only [additive_obj_iso_biproduct_naturality_assoc],
  simp only [biproduct.matrix_map_assoc, category.assoc],
  simp only [additive_obj_iso_biproduct_naturality'],
  simp only [biproduct.map_matrix_assoc, category.assoc],
  congr,
  ext j k ⟨⟩,
  dsimp, simp,
  exact α.hom.naturality (f j k),
end).

-- TODO is there some uniqueness statement for the natural isomorphism in `lift_unique`?

/-- Two additive functors `Mat_ C ⥤ D` are naturally isomorphic if
their precompositions with `embedding C` are naturally isomorphic as functors `C ⥤ D`. -/
@[ext]
def ext {F G : Mat_ C ⥤ D} [functor.additive F] [functor.additive G]
  (α : embedding C ⋙ F ≅ embedding C ⋙ G) : F ≅ G :=
(lift_unique (embedding C ⋙ G) _ α) ≪≫ (lift_unique _ _ (iso.refl _)).symm

/--
Natural isomorphism needed in the construction of `equivalence_self_of_has_finite_biproducts`.
-/
def equivalence_self_of_has_finite_biproducts_aux [has_finite_biproducts C] :
  embedding C ⋙ 𝟭 (Mat_ C) ≅ embedding C ⋙ lift (𝟭 C) ⋙ embedding C :=
functor.right_unitor _ ≪≫
  (functor.left_unitor _).symm ≪≫
  (iso_whisker_right (embedding_lift_iso _).symm _) ≪≫
  functor.associator _ _ _

/--
A preadditive category that already has finite biproducts is equivalent to its additive envelope.

Note that we only prove this for a large category;
otherwise there are universe issues that I haven't attempted to sort out.
-/
def equivalence_self_of_has_finite_biproducts
  (C : Type (u₁+1)) [large_category C] [preadditive C] [has_finite_biproducts C] :
  Mat_ C ≌ C :=
equivalence.mk -- I suspect this is already an adjoint equivalence, but it seems painful to verify.
  (lift (𝟭 C))
  (embedding C)
  (ext equivalence_self_of_has_finite_biproducts_aux)
  (embedding_lift_iso (𝟭 C))

@[simp] lemma equivalence_self_of_has_finite_biproducts_functor
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).functor = lift (𝟭 C) :=
rfl

@[simp] lemma equivalence_self_of_has_finite_biproducts_inverse
  {C : Type (u₁+1)} [large_category C] [preadditive C] [has_finite_biproducts C] :
  (equivalence_self_of_has_finite_biproducts C).inverse = embedding C :=
rfl

end Mat_

universe u

/-- A type synonym for `Fintype`, which we will equip with a category structure
where the morphisms are matrices with components in `R`. -/
@[nolint unused_arguments, derive inhabited]
def Mat (R : Type u) := Fintype.{u}

instance (R : Type u) : has_coe_to_sort (Mat R) (Type u) := bundled.has_coe_to_sort

open_locale classical matrix

instance (R : Type u) [semiring R] : category (Mat R) :=
{ hom := λ X Y, matrix X Y R,
  id := λ X, 1,
  comp := λ X Y Z f g, f ⬝ g,
  assoc' := by { intros, simp [matrix.mul_assoc], }, }

namespace Mat

section
variables (R : Type u) [semiring R]

lemma id_def (M : Mat R) :
  𝟙 M = λ i j, if h : i = j then 1 else 0 :=
rfl

lemma id_apply (M : Mat R) (i j : M) :
  (𝟙 M : matrix M M R) i j = if h : i = j then 1 else 0 :=
rfl

@[simp] lemma id_apply_self (M : Mat R) (i : M) :
  (𝟙 M : matrix M M R) i i = 1 :=
by simp [id_apply]

@[simp] lemma id_apply_of_ne (M : Mat R) (i j : M) (h : i ≠ j) :
  (𝟙 M : matrix M M R) i j = 0 :=
by simp [id_apply, h]

lemma comp_def {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g) = λ i k, ∑ j : N, f i j * g j k := rfl

@[simp] lemma comp_apply {M N K : Mat R} (f : M ⟶ N) (g : N ⟶ K) (i k) :
  (f ≫ g) i k = ∑ j : N, f i j * g j k := rfl

instance (M N : Mat R) : inhabited (M ⟶ N) := ⟨λ (i : M) (j : N), (0 : R)⟩

end

variables (R : Type u) [ring R]

open opposite

/-- Auxiliary definition for `category_theory.Mat.equivalence_single_obj`. -/
@[simps]
def equivalence_single_obj_inverse : Mat_ (single_obj Rᵐᵒᵖ) ⥤ Mat R :=
{ obj := λ X, Fintype.of X.ι,
  map := λ X Y f i j, mul_opposite.unop (f i j),
  map_id' := λ X, by { ext i j, simp [id_def, Mat_.id_def], split_ifs; refl, }, }

instance : faithful (equivalence_single_obj_inverse R) :=
{ map_injective' := λ X Y f g w, begin
    ext i j,
    apply_fun mul_opposite.unop using mul_opposite.unop_injective,
    exact (congr_fun (congr_fun w i) j),
  end }

instance : full (equivalence_single_obj_inverse R) :=
{ preimage := λ X Y f i j, mul_opposite.op (f i j), }

instance : ess_surj (equivalence_single_obj_inverse R) :=
{ mem_ess_image := λ X,
  ⟨{ ι := X, X := λ _, punit.star }, ⟨eq_to_iso (by { dsimp, cases X, congr, })⟩⟩, }

/-- The categorical equivalence between the category of matrices over a ring,
and the category of matrices over that ring considered as a single-object category. -/
def equivalence_single_obj : Mat R ≌ Mat_ (single_obj Rᵐᵒᵖ) :=
begin
  haveI := equivalence.of_fully_faithfully_ess_surj (equivalence_single_obj_inverse R),
  exact (equivalence_single_obj_inverse R).as_equivalence.symm,
end

instance : preadditive (Mat R) :=
{ add_comp' := by { intros, ext, simp [add_mul, finset.sum_add_distrib], },
  comp_add' := by { intros, ext, simp [mul_add, finset.sum_add_distrib], }, }

-- TODO show `Mat R` has biproducts, and that `biprod.map` "is" forming a block diagonal matrix.

end Mat

end category_theory


<|start_filename|>src/topology/sets/compacts.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import topology.sets.closeds

/-!
# Compact sets

We define a few types of compact sets in a topological space.

## Main Definitions

For a topological space `α`,
* `compacts α`: The type of compact sets.
* `nonempty_compacts α`: The type of non-empty compact sets.
* `positive_compacts α`: The type of compact sets with non-empty interior.
* `compact_opens α`: The type of compact open sets. This is a central object in the study of
  spectral spaces.
-/

open set

variables {α β : Type*} [topological_space α] [topological_space β]

namespace topological_space

/-! ### Compact sets -/

/-- The type of compact sets of a topological space. -/
structure compacts (α : Type*) [topological_space α] :=
(carrier : set α)
(compact' : is_compact carrier)

namespace compacts
variables {α}

instance : set_like (compacts α) α :=
{ coe := compacts.carrier,
  coe_injective' := λ s t h, by { cases s, cases t, congr' } }

lemma compact (s : compacts α) : is_compact (s : set α) := s.compact'

instance (K : compacts α) : compact_space K := is_compact_iff_compact_space.1 K.compact

instance : can_lift (set α) (compacts α) :=
{ coe := coe,
  cond := is_compact,
  prf := λ K hK, ⟨⟨K, hK⟩, rfl⟩ }

@[ext] protected lemma ext {s t : compacts α} (h : (s : set α) = t) : s = t := set_like.ext' h

@[simp] lemma coe_mk (s : set α) (h) : (mk s h : set α) = s := rfl

instance : has_sup (compacts α) := ⟨λ s t, ⟨s ∪ t, s.compact.union t.compact⟩⟩
instance [t2_space α] : has_inf (compacts α) := ⟨λ s t, ⟨s ∩ t, s.compact.inter t.compact⟩⟩
instance [compact_space α] : has_top (compacts α) := ⟨⟨univ, compact_univ⟩⟩
instance : has_bot (compacts α) := ⟨⟨∅, is_compact_empty⟩⟩

instance : semilattice_sup (compacts α) := set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance [t2_space α] : distrib_lattice (compacts α) :=
set_like.coe_injective.distrib_lattice _ (λ _ _, rfl) (λ _ _, rfl)

instance : order_bot (compacts α) := order_bot.lift (coe : _ → set α) (λ _ _, id) rfl

instance [compact_space α] : bounded_order (compacts α) :=
bounded_order.lift (coe : _ → set α) (λ _ _, id) rfl rfl

/-- The type of compact sets is inhabited, with default element the empty set. -/
instance : inhabited (compacts α) := ⟨⊥⟩

@[simp] lemma coe_sup (s t : compacts α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_inf [t2_space α] (s t : compacts α) : (↑(s ⊓ t) : set α) = s ∩ t := rfl
@[simp] lemma coe_top [compact_space α] : (↑(⊤ : compacts α) : set α) = univ := rfl
@[simp] lemma coe_bot : (↑(⊥ : compacts α) : set α) = ∅ := rfl

@[simp] lemma coe_finset_sup {ι : Type*} {s : finset ι} {f : ι → compacts α} :
  (↑(s.sup f) : set α) = s.sup (λ i, f i) :=
begin
  classical,
  refine finset.induction_on s rfl (λ a s _ h, _),
  simp_rw [finset.sup_insert, coe_sup, sup_eq_union],
  congr',
end

/-- The image of a compact set under a continuous function. -/
protected def map (f : α → β) (hf : continuous f) (K : compacts α) : compacts β :=
⟨f '' K.1, K.2.image hf⟩

@[simp] lemma coe_map {f : α → β} (hf : continuous f) (s : compacts α) :
  (s.map f hf : set β) = f '' s := rfl

/-- A homeomorphism induces an equivalence on compact sets, by taking the image. -/
@[simp] protected def equiv (f : α ≃ₜ β) : compacts α ≃ compacts β :=
{ to_fun := compacts.map f f.continuous,
  inv_fun := compacts.map _ f.symm.continuous,
  left_inv := λ s, by { ext1, simp only [coe_map, ← image_comp, f.symm_comp_self, image_id] },
  right_inv := λ s, by { ext1, simp only [coe_map, ← image_comp, f.self_comp_symm, image_id] } }

/-- The image of a compact set under a homeomorphism can also be expressed as a preimage. -/
lemma equiv_to_fun_val (f : α ≃ₜ β) (K : compacts α) :
  (compacts.equiv f K).1 = f.symm ⁻¹' K.1 :=
congr_fun (image_eq_preimage_of_inverse f.left_inv f.right_inv) K.1

end compacts

/-! ### Nonempty compact sets -/

/-- The type of nonempty compact sets of a topological space. -/
structure nonempty_compacts (α : Type*) [topological_space α] extends compacts α :=
(nonempty' : carrier.nonempty)

namespace nonempty_compacts

instance : set_like (nonempty_compacts α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { obtain ⟨⟨_, _⟩, _⟩ := s, obtain ⟨⟨_, _⟩, _⟩ := t, congr' } }

lemma compact (s : nonempty_compacts α) : is_compact (s : set α) := s.compact'
protected lemma nonempty (s : nonempty_compacts α) : (s : set α).nonempty := s.nonempty'

/-- Reinterpret a nonempty compact as a closed set. -/
def to_closeds [t2_space α] (s : nonempty_compacts α) : closeds α := ⟨s, s.compact.is_closed⟩

@[ext] protected lemma ext {s t : nonempty_compacts α} (h : (s : set α) = t) : s = t :=
set_like.ext' h

@[simp] lemma coe_mk (s : compacts α) (h) : (mk s h : set α) = s := rfl

instance : has_sup (nonempty_compacts α) :=
⟨λ s t, ⟨s.to_compacts ⊔ t.to_compacts, s.nonempty.mono $ subset_union_left _ _⟩⟩
instance [compact_space α] [nonempty α] : has_top (nonempty_compacts α) := ⟨⟨⊤, univ_nonempty⟩⟩

instance : semilattice_sup (nonempty_compacts α) :=
set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance [compact_space α] [nonempty α] : order_top (nonempty_compacts α) :=
order_top.lift (coe : _ → set α) (λ _ _, id) rfl

@[simp] lemma coe_sup (s t : nonempty_compacts α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_top [compact_space α] [nonempty α] :
  (↑(⊤ : nonempty_compacts α) : set α) = univ := rfl

/-- In an inhabited space, the type of nonempty compact subsets is also inhabited, with
default element the singleton set containing the default element. -/
instance [inhabited α] : inhabited (nonempty_compacts α) :=
⟨{ carrier := {default}, compact' := is_compact_singleton, nonempty' := singleton_nonempty _ }⟩

instance to_compact_space {s : nonempty_compacts α} : compact_space s :=
is_compact_iff_compact_space.1 s.compact

instance to_nonempty {s : nonempty_compacts α} : nonempty s := s.nonempty.to_subtype

end nonempty_compacts

/-! ### Positive compact sets -/

/-- The type of compact sets nonempty interior of a topological space. See also `compacts` and
`nonempty_compacts` -/
structure positive_compacts (α : Type*) [topological_space α] extends compacts α :=
(interior_nonempty' : (interior carrier).nonempty)

namespace positive_compacts

instance : set_like (positive_compacts α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { obtain ⟨⟨_, _⟩, _⟩ := s, obtain ⟨⟨_, _⟩, _⟩ := t, congr' } }

lemma compact (s : positive_compacts α) : is_compact (s : set α) := s.compact'
lemma interior_nonempty (s : positive_compacts α) : (interior (s : set α)).nonempty :=
s.interior_nonempty'

protected lemma nonempty (s : positive_compacts α) : (s : set α).nonempty :=
s.interior_nonempty.mono interior_subset

/-- Reinterpret a positive compact as a nonempty compact. -/
def to_nonempty_compacts (s : positive_compacts α) : nonempty_compacts α :=
⟨s.to_compacts, s.nonempty⟩

@[ext] protected lemma ext {s t : positive_compacts α} (h : (s : set α) = t) : s = t :=
set_like.ext' h

@[simp] lemma coe_mk (s : compacts α) (h) : (mk s h : set α) = s := rfl

instance : has_sup (positive_compacts α) :=
⟨λ s t, ⟨s.to_compacts ⊔ t.to_compacts,
  s.interior_nonempty.mono $ interior_mono $ subset_union_left _ _⟩⟩

instance [compact_space α] [nonempty α] : has_top (positive_compacts α) :=
⟨⟨⊤, interior_univ.symm.subst univ_nonempty⟩⟩

instance : semilattice_sup (positive_compacts α) :=
set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance [compact_space α] [nonempty α] : order_top (positive_compacts α) :=
order_top.lift (coe : _ → set α) (λ _ _, id) rfl

@[simp] lemma coe_sup (s t : positive_compacts α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_top [compact_space α] [nonempty α] :
  (↑(⊤ : positive_compacts α) : set α) = univ := rfl

lemma _root_.exists_positive_compacts_subset [locally_compact_space α] {U : set α} (ho : is_open U)
  (hn : U.nonempty) : ∃ K : positive_compacts α, ↑K ⊆ U :=
let ⟨x, hx⟩ := hn, ⟨K, hKc, hxK, hKU⟩ := exists_compact_subset ho hx in ⟨⟨⟨K, hKc⟩, ⟨x, hxK⟩⟩, hKU⟩

instance [compact_space α] [nonempty α] : inhabited (positive_compacts α) := ⟨⊤⟩

/-- In a nonempty locally compact space, there exists a compact set with nonempty interior. -/
instance nonempty' [locally_compact_space α] [nonempty α] : nonempty (positive_compacts α) :=
nonempty_of_exists $ exists_positive_compacts_subset is_open_univ univ_nonempty

end positive_compacts

/-! ### Compact open sets -/

/-- The type of compact open sets of a topological space. This is useful in non Hausdorff contexts,
in particular spectral spaces. -/
structure compact_opens (α : Type*) [topological_space α] extends compacts α :=
(open' : is_open carrier)

namespace compact_opens

instance : set_like (compact_opens α) α :=
{ coe := λ s, s.carrier,
  coe_injective' := λ s t h, by { obtain ⟨⟨_, _⟩, _⟩ := s, obtain ⟨⟨_, _⟩, _⟩ := t, congr' } }

lemma compact (s : compact_opens α) : is_compact (s : set α) := s.compact'
lemma «open» (s : compact_opens α) : is_open (s : set α) := s.open'

/-- Reinterpret a compact open as an open. -/
@[simps] def to_opens (s : compact_opens α) : opens α := ⟨s, s.open⟩

/-- Reinterpret a compact open as a clopen. -/
@[simps] def to_clopens [t2_space α] (s : compact_opens α) : clopens α :=
⟨s, s.open, s.compact.is_closed⟩

@[ext] protected lemma ext {s t : compact_opens α} (h : (s : set α) = t) : s = t := set_like.ext' h

@[simp] lemma coe_mk (s : compacts α) (h) : (mk s h : set α) = s := rfl

instance : has_sup (compact_opens α) :=
⟨λ s t, ⟨s.to_compacts ⊔ t.to_compacts, s.open.union t.open⟩⟩
instance [t2_space α] : has_inf (compact_opens α) :=
⟨λ s t, ⟨s.to_compacts ⊓ t.to_compacts, s.open.inter t.open⟩⟩
instance [compact_space α] : has_top (compact_opens α) := ⟨⟨⊤, is_open_univ⟩⟩
instance : has_bot (compact_opens α) := ⟨⟨⊥, is_open_empty⟩⟩
instance [t2_space α] : has_sdiff (compact_opens α) :=
⟨λ s t, ⟨⟨s \ t, s.compact.diff t.open⟩, s.open.sdiff t.compact.is_closed⟩⟩
instance [t2_space α] [compact_space α] : has_compl (compact_opens α) :=
⟨λ s, ⟨⟨sᶜ, s.open.is_closed_compl.is_compact⟩, s.compact.is_closed.is_open_compl⟩⟩

instance : semilattice_sup (compact_opens α) :=
set_like.coe_injective.semilattice_sup _ (λ _ _, rfl)

instance : order_bot (compact_opens α) := order_bot.lift (coe : _ → set α) (λ _ _, id) rfl

instance [t2_space α] : generalized_boolean_algebra (compact_opens α) :=
set_like.coe_injective.generalized_boolean_algebra _ (λ _ _, rfl) (λ _ _, rfl) rfl (λ _ _, rfl)

instance [compact_space α] : bounded_order (compact_opens α) :=
bounded_order.lift (coe : _ → set α) (λ _ _, id) rfl rfl

instance [t2_space α] [compact_space α] : boolean_algebra (compact_opens α) :=
set_like.coe_injective.boolean_algebra _ (λ _ _, rfl) (λ _ _, rfl) rfl rfl (λ _, rfl) (λ _ _, rfl)

@[simp] lemma coe_sup (s t : compact_opens α) : (↑(s ⊔ t) : set α) = s ∪ t := rfl
@[simp] lemma coe_inf [t2_space α] (s t : compact_opens α) : (↑(s ⊓ t) : set α) = s ∩ t := rfl
@[simp] lemma coe_top [compact_space α] : (↑(⊤ : compact_opens α) : set α) = univ := rfl
@[simp] lemma coe_bot : (↑(⊥ : compact_opens α) : set α) = ∅ := rfl
@[simp] lemma coe_sdiff [t2_space α] (s t : compact_opens α) : (↑(s \ t) : set α) = s \ t := rfl
@[simp] lemma coe_compl [t2_space α] [compact_space α] (s : compact_opens α) : (↑sᶜ : set α) = sᶜ :=
rfl

instance : inhabited (compact_opens α) := ⟨⊥⟩

/-- The image of a compact open under a continuous open map. -/
@[simps] def map (f : α → β) (hf : continuous f) (hf' : is_open_map f) (s : compact_opens α) :
  compact_opens β :=
⟨s.to_compacts.map f hf, hf' _ s.open⟩

@[simp] lemma coe_map {f : α → β} (hf : continuous f) (hf' : is_open_map f) (s : compact_opens α) :
  (s.map f hf hf' : set β) = f '' s := rfl

end compact_opens
end topological_space


<|start_filename|>src/data/nat/factorization/prime_pow.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.is_prime_pow
import data.nat.factorization.basic

/-!
# Prime powers and factorizations

This file deals with factorizations of prime powers.
-/

variables {R : Type*} [comm_monoid_with_zero R] (n p : R) (k : ℕ)

lemma is_prime_pow.min_fac_pow_factorization_eq {n : ℕ} (hn : is_prime_pow n) :
  n.min_fac ^ n.factorization n.min_fac = n :=
begin
  obtain ⟨p, k, hp, hk, rfl⟩ := hn,
  rw ←nat.prime_iff at hp,
  rw [hp.pow_min_fac hk.ne', hp.factorization_pow, finsupp.single_eq_same],
end

lemma is_prime_pow_of_min_fac_pow_factorization_eq {n : ℕ}
  (h : n.min_fac ^ n.factorization n.min_fac = n) (hn : n ≠ 1) :
  is_prime_pow n :=
begin
  rcases eq_or_ne n 0 with rfl | hn',
  { simpa using h },
  refine ⟨_, _, nat.prime_iff.1 (nat.min_fac_prime hn), _, h⟩,
  rw [pos_iff_ne_zero, ←finsupp.mem_support_iff, nat.factor_iff_mem_factorization,
    nat.mem_factors_iff_dvd hn' (nat.min_fac_prime hn)],
  apply nat.min_fac_dvd
end

lemma is_prime_pow_iff_min_fac_pow_factorization_eq {n : ℕ} (hn : n ≠ 1) :
  is_prime_pow n ↔ n.min_fac ^ n.factorization n.min_fac = n :=
⟨λ h, h.min_fac_pow_factorization_eq, λ h, is_prime_pow_of_min_fac_pow_factorization_eq h hn⟩

lemma is_prime_pow_iff_factorization_eq_single {n : ℕ} :
  is_prime_pow n ↔ ∃ p k : ℕ, 0 < k ∧ n.factorization = finsupp.single p k :=
begin
  rw is_prime_pow_nat_iff,
  refine exists₂_congr (λ p k, _),
  split,
  { rintros ⟨hp, hk, hn⟩,
    exact ⟨hk, by rw [←hn, nat.prime.factorization_pow hp]⟩ },
  { rintros ⟨hk, hn⟩,
    have hn0 : n ≠ 0,
    { rintro rfl,
      simpa only [finsupp.single_eq_zero, eq_comm, nat.factorization_zero, hk.ne'] using hn },
    rw nat.eq_pow_of_factorization_eq_single hn0 hn,
    exact ⟨nat.prime_of_mem_factorization
      (by simp [hn, hk.ne'] : p ∈ n.factorization.support), hk, rfl⟩ }
end

lemma is_prime_pow_iff_card_support_factorization_eq_one {n : ℕ} :
  is_prime_pow n ↔ n.factorization.support.card = 1 :=
by simp_rw [is_prime_pow_iff_factorization_eq_single, finsupp.card_support_eq_one', exists_prop,
  pos_iff_ne_zero]

/-- An equivalent definition for prime powers: `n` is a prime power iff there is a unique prime
dividing it. -/
lemma is_prime_pow_iff_unique_prime_dvd {n : ℕ} :
  is_prime_pow n ↔ ∃! p : ℕ, p.prime ∧ p ∣ n :=
begin
  rw is_prime_pow_nat_iff,
  split,
  { rintro ⟨p, k, hp, hk, rfl⟩,
    refine ⟨p, ⟨hp, dvd_pow_self _ hk.ne'⟩, _⟩,
    rintro q ⟨hq, hq'⟩,
    exact (nat.prime_dvd_prime_iff_eq hq hp).1 (hq.dvd_of_dvd_pow hq') },
  rintro ⟨p, ⟨hp, hn⟩, hq⟩,
  -- Take care of the n = 0 case
  rcases eq_or_ne n 0 with rfl | hn₀,
  { obtain ⟨q, hq', hq''⟩ := nat.exists_infinite_primes (p + 1),
    cases hq q ⟨hq'', by simp⟩,
    simpa using hq' },
  -- So assume 0 < n
  refine ⟨p, n.factorization p, hp, hp.factorization_pos_of_dvd hn₀ hn, _⟩,
  simp only [and_imp] at hq,
  apply nat.dvd_antisymm (nat.pow_factorization_dvd _ _),
  -- We need to show n ∣ p ^ n.factorization p
  apply nat.dvd_of_factors_subperm hn₀,
  rw [hp.factors_pow, list.subperm_ext_iff],
  intros q hq',
  rw nat.mem_factors hn₀ at hq',
  cases hq _ hq'.1 hq'.2,
  simp,
end

lemma is_prime_pow_pow_iff {n k : ℕ} (hk : k ≠ 0) :
  is_prime_pow (n ^ k) ↔ is_prime_pow n :=
begin
  simp only [is_prime_pow_iff_unique_prime_dvd],
  apply exists_unique_congr,
  simp only [and.congr_right_iff],
  intros p hp,
  exact ⟨hp.dvd_of_dvd_pow, λ t, t.trans (dvd_pow_self _ hk)⟩,
end

lemma nat.coprime.is_prime_pow_dvd_mul {n a b : ℕ} (hab : nat.coprime a b) (hn : is_prime_pow n) :
  n ∣ a * b ↔ n ∣ a ∨ n ∣ b :=
begin
  rcases eq_or_ne a 0 with rfl | ha,
  { simp only [nat.coprime_zero_left] at hab,
    simp [hab, finset.filter_singleton, not_is_prime_pow_one] },
  rcases eq_or_ne b 0 with rfl | hb,
  { simp only [nat.coprime_zero_right] at hab,
    simp [hab, finset.filter_singleton, not_is_prime_pow_one] },
  refine ⟨_, λ h, or.elim h (λ i, i.trans (dvd_mul_right _ _)) (λ i, i.trans (dvd_mul_left _ _))⟩,
  obtain ⟨p, k, hp, hk, rfl⟩ := (is_prime_pow_nat_iff _).1 hn,
  simp only [hp.pow_dvd_iff_le_factorization (mul_ne_zero ha hb),
    nat.factorization_mul ha hb, hp.pow_dvd_iff_le_factorization ha,
    hp.pow_dvd_iff_le_factorization hb, pi.add_apply, finsupp.coe_add],
  have : a.factorization p = 0 ∨ b.factorization p = 0,
  { rw [←finsupp.not_mem_support_iff, ←finsupp.not_mem_support_iff, ←not_and_distrib,
      ←finset.mem_inter],
    exact λ t, nat.factorization_disjoint_of_coprime hab t },
  cases this;
  simp [this, imp_or_distrib],
end

lemma nat.mul_divisors_filter_prime_pow {a b : ℕ} (hab : a.coprime b) :
  (a * b).divisors.filter is_prime_pow = (a.divisors ∪ b.divisors).filter is_prime_pow :=
begin
  rcases eq_or_ne a 0 with rfl | ha,
  { simp only [nat.coprime_zero_left] at hab,
    simp [hab, finset.filter_singleton, not_is_prime_pow_one] },
  rcases eq_or_ne b 0 with rfl | hb,
  { simp only [nat.coprime_zero_right] at hab,
    simp [hab, finset.filter_singleton, not_is_prime_pow_one] },
  ext n,
  simp only [ha, hb, finset.mem_union, finset.mem_filter, nat.mul_eq_zero, and_true, ne.def,
    and.congr_left_iff, not_false_iff, nat.mem_divisors, or_self],
  apply hab.is_prime_pow_dvd_mul,
end


<|start_filename|>src/measure_theory/function/convergence_in_measure.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>, <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import measure_theory.function.egorov

/-!
# Convergence in measure

We define convergence in measure which is one of the many notions of convergence in probability.
A sequence of functions `f` is said to converge in measure to some function `g`
if for all `ε > 0`, the measure of the set `{x | ε ≤ dist (f i x) (g x)}` tends to 0 as `i`
converges along some given filter `l`.

Convergence in measure is most notably used in the formulation of the weak law of large numbers
and is also useful in theorems such as the Vitali convergence theorem. This file provides some
basic lemmas for working with convergence in measure and establishes some relations between
convergence in measure and other notions of convergence.

## Main definitions

* `measure_theory.tendsto_in_measure (μ : measure α) (f : ι → α → E) (g : α → E)`: `f` converges
  in `μ`-measure to `g`.

## Main results

* `measure_theory.tendsto_in_measure_of_tendsto_ae`: convergence almost everywhere in a finite
  measure space implies convergence in measure.
* `measure_theory.tendsto_in_measure.exists_seq_tendsto_ae`: if `f` is a sequence of functions
  which converges in measure to `g`, then `f` has a subsequence which convergence almost
  everywhere to `g`.
* `measure_theory.tendsto_in_measure_of_tendsto_snorm`: convergence in Lp implies convergence
  in measure.
-/

open topological_space filter
open_locale nnreal ennreal measure_theory topological_space

namespace measure_theory

variables {α ι E : Type*} {m : measurable_space α} {μ : measure α}

/-- A sequence of functions `f` is said to converge in measure to some function `g` if for all
`ε > 0`, the measure of the set `{x | ε ≤ dist (f i x) (g x)}` tends to 0 as `i` converges along
some given filter `l`. -/
def tendsto_in_measure [has_dist E] {m : measurable_space α}
  (μ : measure α) (f : ι → α → E) (l : filter ι) (g : α → E) : Prop :=
∀ ε (hε : 0 < ε), tendsto (λ i, μ {x | ε ≤ dist (f i x) (g x)}) l (𝓝 0)

lemma tendsto_in_measure_iff_norm [semi_normed_group E] {l : filter ι}
  {f : ι → α → E} {g : α → E} :
  tendsto_in_measure μ f l g
  ↔ ∀ ε (hε : 0 < ε), tendsto (λ i, μ {x | ε ≤ ∥f i x - g x∥}) l (𝓝 0) :=
by simp_rw [tendsto_in_measure, dist_eq_norm]

namespace tendsto_in_measure

variables [has_dist E] {l : filter ι} {f f' : ι → α → E} {g g' : α → E}

protected lemma congr' (h_left : ∀ᶠ i in l, f i =ᵐ[μ] f' i) (h_right : g =ᵐ[μ] g')
  (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f' l g' :=
begin
  intros ε hε,
  suffices : (λ i, μ {x | ε ≤ dist (f' i x) (g' x)})
      =ᶠ[l] (λ i, μ {x | ε ≤ dist (f i x) (g x)}),
  { rw tendsto_congr' this,
    exact h_tendsto ε hε, },
  filter_upwards [h_left] with i h_ae_eq,
  refine measure_congr _,
  filter_upwards [h_ae_eq, h_right] with x hxf hxg,
  rw eq_iff_iff,
  change ε ≤ dist (f' i x) (g' x) ↔ ε ≤ dist (f i x) (g x),
  rw [hxg, hxf],
end

protected lemma congr (h_left : ∀ i, f i =ᵐ[μ] f' i) (h_right : g =ᵐ[μ] g')
  (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f' l g' :=
tendsto_in_measure.congr' (eventually_of_forall h_left) h_right h_tendsto

lemma congr_left (h : ∀ i, f i =ᵐ[μ] f' i) (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f' l g :=
h_tendsto.congr h (eventually_eq.rfl)

lemma congr_right (h : g =ᵐ[μ] g') (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f l g' :=
h_tendsto.congr (λ i, eventually_eq.rfl) h

end tendsto_in_measure

section exists_seq_tendsto_ae

variables [metric_space E]
variables {f : ℕ → α → E} {g : α → E}

/-- Auxiliary lemma for `tendsto_in_measure_of_tendsto_ae`. -/
lemma tendsto_in_measure_of_tendsto_ae_of_strongly_measurable [is_finite_measure μ]
  (hf : ∀ n, strongly_measurable (f n)) (hg : strongly_measurable g)
  (hfg : ∀ᵐ x ∂μ, tendsto (λ n, f n x) at_top (𝓝 (g x))) :
  tendsto_in_measure μ f at_top g :=
begin
  refine λ ε hε, ennreal.tendsto_at_top_zero.mpr (λ δ hδ, _),
  by_cases hδi : δ = ∞,
  { simp only [hδi, implies_true_iff, le_top, exists_const], },
  lift δ to ℝ≥0 using hδi,
  rw [gt_iff_lt, ennreal.coe_pos, ← nnreal.coe_pos] at hδ,
  obtain ⟨t, htm, ht, hunif⟩ := tendsto_uniformly_on_of_ae_tendsto' hf hg hfg hδ,
  rw ennreal.of_real_coe_nnreal at ht,
  rw metric.tendsto_uniformly_on_iff at hunif,
  obtain ⟨N, hN⟩ := eventually_at_top.1 (hunif ε hε),
  refine ⟨N, λ n hn, _⟩,
  suffices : {x : α | ε ≤ dist (f n x) (g x)} ⊆ t, from (measure_mono this).trans ht,
  rw ← set.compl_subset_compl,
  intros x hx,
  rw [set.mem_compl_eq, set.nmem_set_of_eq, dist_comm, not_le],
  exact hN n hn x hx,
end

/-- Convergence a.e. implies convergence in measure in a finite measure space. -/
lemma tendsto_in_measure_of_tendsto_ae [is_finite_measure μ]
  (hf : ∀ n, ae_strongly_measurable (f n) μ)
  (hfg : ∀ᵐ x ∂μ, tendsto (λ n, f n x) at_top (𝓝 (g x))) :
  tendsto_in_measure μ f at_top g :=
begin
  have hg : ae_strongly_measurable g μ, from ae_strongly_measurable_of_tendsto_ae _ hf hfg,
  refine tendsto_in_measure.congr (λ i, (hf i).ae_eq_mk.symm) hg.ae_eq_mk.symm _,
  refine tendsto_in_measure_of_tendsto_ae_of_strongly_measurable
    (λ i, (hf i).strongly_measurable_mk) hg.strongly_measurable_mk _,
  have hf_eq_ae : ∀ᵐ x ∂μ, ∀ n, (hf n).mk (f n) x = f n x,
    from ae_all_iff.mpr (λ n, (hf n).ae_eq_mk.symm),
  filter_upwards [hf_eq_ae, hg.ae_eq_mk, hfg] with x hxf hxg hxfg,
  rw [← hxg, funext (λ n, hxf n)],
  exact hxfg,
end

namespace exists_seq_tendsto_ae

lemma exists_nat_measure_lt_two_inv (hfg : tendsto_in_measure μ f at_top g) (n : ℕ) :
  ∃ N, ∀ m ≥ N, μ {x | 2⁻¹ ^ n ≤ dist (f m x) (g x)} ≤ 2⁻¹ ^ n :=
begin
  specialize hfg (2⁻¹ ^ n) (by simp only [zero_lt_bit0, pow_pos, zero_lt_one, inv_pos]),
  rw ennreal.tendsto_at_top_zero at hfg,
  exact hfg (2⁻¹ ^ n) (pos_iff_ne_zero.mpr (λ h_zero, by simpa using pow_eq_zero h_zero))
end

/-- Given a sequence of functions `f` which converges in measure to `g`,
`seq_tendsto_ae_seq_aux` is a sequence such that
`∀ m ≥ seq_tendsto_ae_seq_aux n, μ {x | 2⁻¹ ^ n ≤ dist (f m x) (g x)} ≤ 2⁻¹ ^ n`. -/
noncomputable
def seq_tendsto_ae_seq_aux (hfg : tendsto_in_measure μ f at_top g) (n : ℕ) :=
classical.some (exists_nat_measure_lt_two_inv hfg n)

/-- Transformation of `seq_tendsto_ae_seq_aux` to makes sure it is strictly monotone. -/
noncomputable
def seq_tendsto_ae_seq (hfg : tendsto_in_measure μ f at_top g) : ℕ → ℕ
| 0 := seq_tendsto_ae_seq_aux hfg 0
| (n + 1) := max (seq_tendsto_ae_seq_aux hfg (n + 1))
  (seq_tendsto_ae_seq n + 1)

lemma seq_tendsto_ae_seq_succ (hfg : tendsto_in_measure μ f at_top g) {n : ℕ} :
  seq_tendsto_ae_seq hfg (n + 1) =
  max (seq_tendsto_ae_seq_aux hfg (n + 1)) (seq_tendsto_ae_seq hfg n + 1) :=
by rw seq_tendsto_ae_seq

lemma seq_tendsto_ae_seq_spec (hfg : tendsto_in_measure μ f at_top g)
  (n k : ℕ) (hn : seq_tendsto_ae_seq hfg n ≤ k) :
  μ {x | 2⁻¹ ^ n ≤ dist (f k x) (g x)} ≤ 2⁻¹ ^ n :=
begin
  cases n,
  { exact classical.some_spec (exists_nat_measure_lt_two_inv hfg 0) k hn },
  { exact classical.some_spec (exists_nat_measure_lt_two_inv hfg _) _
      (le_trans (le_max_left _ _) hn) }
end

lemma seq_tendsto_ae_seq_strict_mono (hfg : tendsto_in_measure μ f at_top g) :
  strict_mono (seq_tendsto_ae_seq hfg) :=
begin
  refine strict_mono_nat_of_lt_succ (λ n, _),
  rw seq_tendsto_ae_seq_succ,
  exact lt_of_lt_of_le (lt_add_one $ seq_tendsto_ae_seq hfg n) (le_max_right _ _),
end

end exists_seq_tendsto_ae

/-- If `f` is a sequence of functions which converges in measure to `g`, then there exists a
subsequence of `f` which converges a.e. to `g`. -/
lemma tendsto_in_measure.exists_seq_tendsto_ae
  (hfg : tendsto_in_measure μ f at_top g) :
  ∃ ns : ℕ → ℕ, strict_mono ns ∧ ∀ᵐ x ∂μ, tendsto (λ i, f (ns i) x) at_top (𝓝 (g x)) :=
begin
  /- Since `f` tends to `g` in measure, it has a subsequence `k ↦ f (ns k)` such that
  `μ {|f (ns k) - g| ≥ 2⁻ᵏ} ≤ 2⁻ᵏ` for all `k`. Defining
  `s := ⋂ k, ⋃ i ≥ k, {|f (ns k) - g| ≥ 2⁻ᵏ}`, we see that `μ s = 0` by the
  first Borel-Cantelli lemma.

  On the other hand, as `s` is precisely the set for which `f (ns k)`
  doesn't converge to `g`, `f (ns k)` converges almost everywhere to `g` as required. -/
  have h_lt_ε_real : ∀ (ε : ℝ) (hε : 0 < ε), ∃ k : ℕ, 2 * 2⁻¹ ^ k < ε,
  { intros ε hε,
    obtain ⟨k, h_k⟩ : ∃ (k : ℕ), 2⁻¹ ^ k < ε := exists_pow_lt_of_lt_one hε (by norm_num),
    refine ⟨k + 1, (le_of_eq _).trans_lt h_k⟩,
    rw pow_add, ring },
  set ns := exists_seq_tendsto_ae.seq_tendsto_ae_seq hfg,
  use ns,
  let S := λ k, {x | 2⁻¹ ^ k ≤ dist (f (ns k) x) (g x)},
  have hμS_le : ∀ k, μ (S k) ≤ 2⁻¹ ^ k :=
    λ k, exists_seq_tendsto_ae.seq_tendsto_ae_seq_spec hfg k (ns k) (le_rfl),
  set s := filter.at_top.limsup S with hs,
  have hμs : μ s = 0,
  { refine measure_limsup_eq_zero (ne_of_lt $ lt_of_le_of_lt (ennreal.tsum_le_tsum hμS_le) _),
    simp only [ennreal.tsum_geometric, ennreal.one_sub_inv_two, inv_inv],
    dec_trivial },
  have h_tendsto : ∀ x ∈ sᶜ, tendsto (λ i, f (ns i) x) at_top (𝓝 (g x)),
  { refine λ x hx, metric.tendsto_at_top.mpr (λ ε hε, _),
    rw [hs, limsup_eq_infi_supr_of_nat] at hx,
    simp only [set.supr_eq_Union, set.infi_eq_Inter, set.compl_Inter, set.compl_Union,
      set.mem_Union, set.mem_Inter, set.mem_compl_eq, set.mem_set_of_eq, not_le] at hx,
    obtain ⟨N, hNx⟩ := hx,
    obtain ⟨k, hk_lt_ε⟩ := h_lt_ε_real ε hε,
    refine ⟨max N (k - 1), λ n hn_ge, lt_of_le_of_lt _ hk_lt_ε⟩,
    specialize hNx n ((le_max_left _ _).trans hn_ge),
    have h_inv_n_le_k : (2 : ℝ)⁻¹ ^ n ≤ 2 * 2⁻¹ ^ k,
    { rw [mul_comm, ← inv_mul_le_iff' (@two_pos ℝ _ _)],
      conv_lhs { congr, rw ← pow_one (2 : ℝ)⁻¹ },
      rw [← pow_add, add_comm],
      exact pow_le_pow_of_le_one ((one_div (2 : ℝ)) ▸ one_half_pos.le) (inv_le_one one_le_two)
        ((le_tsub_add.trans (add_le_add_right (le_max_right _ _) 1)).trans
        (add_le_add_right hn_ge 1)) },
    exact le_trans hNx.le h_inv_n_le_k },
  rw ae_iff,
  refine ⟨exists_seq_tendsto_ae.seq_tendsto_ae_seq_strict_mono hfg, measure_mono_null (λ x, _) hμs⟩,
  rw [set.mem_set_of_eq, ← @not_not (x ∈ s), not_imp_not],
  exact h_tendsto x,
end

lemma tendsto_in_measure.exists_seq_tendsto_in_measure_at_top
  {u : filter ι} [ne_bot u] [is_countably_generated u] {f : ι → α → E} {g : α → E}
  (hfg : tendsto_in_measure μ f u g) :
  ∃ ns : ℕ → ι, tendsto_in_measure μ (λ n, f (ns n)) at_top g :=
begin
  obtain ⟨ns, h_tendsto_ns⟩ : ∃ (ns : ℕ → ι), tendsto ns at_top u := exists_seq_tendsto u,
  exact ⟨ns, λ ε hε, (hfg ε hε).comp h_tendsto_ns⟩,
end

lemma tendsto_in_measure.exists_seq_tendsto_ae'
  {u : filter ι} [ne_bot u] [is_countably_generated u] {f : ι → α → E} {g : α → E}
  (hfg : tendsto_in_measure μ f u g) :
  ∃ ns : ℕ → ι, ∀ᵐ x ∂μ, tendsto (λ i, f (ns i) x) at_top (𝓝 (g x)) :=
begin
  obtain ⟨ms, hms⟩ := hfg.exists_seq_tendsto_in_measure_at_top,
  obtain ⟨ns, -, hns⟩ := hms.exists_seq_tendsto_ae,
  exact ⟨ms ∘ ns, hns⟩,
end

end exists_seq_tendsto_ae

section ae_measurable_of

variables [measurable_space E] [normed_group E] [borel_space E]

lemma tendsto_in_measure.ae_measurable
  {u : filter ι} [ne_bot u] [is_countably_generated u]
  {f : ι → α → E} {g : α → E} (hf : ∀ n, ae_measurable (f n) μ)
  (h_tendsto : tendsto_in_measure μ f u g) :
  ae_measurable g μ :=
begin
  obtain ⟨ns, hns⟩ := h_tendsto.exists_seq_tendsto_ae',
  exact ae_measurable_of_tendsto_metrizable_ae at_top (λ n, hf (ns n)) hns,
end

end ae_measurable_of

section tendsto_in_measure_of

variables [normed_group E] {p : ℝ≥0∞}
variables {f : ι → α → E} {g : α → E}

/-- This lemma is superceded by `measure_theory.tendsto_in_measure_of_tendsto_snorm` where we
allow `p = ∞` and only require `ae_strongly_measurable`. -/
lemma tendsto_in_measure_of_tendsto_snorm_of_strongly_measurable
  (hp_ne_zero : p ≠ 0) (hp_ne_top : p ≠ ∞)
  (hf : ∀ n, strongly_measurable (f n)) (hg : strongly_measurable g) {l : filter ι}
  (hfg : tendsto (λ n, snorm (f n - g) p μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  intros ε hε,
  replace hfg := ennreal.tendsto.const_mul (tendsto.ennrpow_const p.to_real hfg)
    (or.inr $ @ennreal.of_real_ne_top (1 / ε ^ (p.to_real))),
  simp only [mul_zero, ennreal.zero_rpow_of_pos (ennreal.to_real_pos hp_ne_zero hp_ne_top)] at hfg,
  rw ennreal.tendsto_nhds_zero at hfg ⊢,
  intros δ hδ,
  refine (hfg δ hδ).mono (λ n hn, _),
  refine le_trans _ hn,
  rw [ennreal.of_real_div_of_pos (real.rpow_pos_of_pos hε _), ennreal.of_real_one, mul_comm,
    mul_one_div, ennreal.le_div_iff_mul_le _ (or.inl (ennreal.of_real_ne_top)), mul_comm],
  { convert mul_meas_ge_le_pow_snorm' μ hp_ne_zero hp_ne_top ((hf n).sub hg).ae_strongly_measurable
      (ennreal.of_real ε),
    { exact (ennreal.of_real_rpow_of_pos hε).symm },
    { ext x,
      rw [dist_eq_norm, ← ennreal.of_real_le_of_real_iff (norm_nonneg _),
          of_real_norm_eq_coe_nnnorm],
      exact iff.rfl } },
  { rw [ne, ennreal.of_real_eq_zero, not_le],
    exact or.inl (real.rpow_pos_of_pos hε _) },
end

/-- This lemma is superceded by `measure_theory.tendsto_in_measure_of_tendsto_snorm` where we
allow `p = ∞`. -/
lemma tendsto_in_measure_of_tendsto_snorm_of_ne_top
  (hp_ne_zero : p ≠ 0) (hp_ne_top : p ≠ ∞)
  (hf : ∀ n, ae_strongly_measurable (f n) μ) (hg : ae_strongly_measurable g μ) {l : filter ι}
  (hfg : tendsto (λ n, snorm (f n - g) p μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  refine tendsto_in_measure.congr (λ i, (hf i).ae_eq_mk.symm) hg.ae_eq_mk.symm _,
  refine tendsto_in_measure_of_tendsto_snorm_of_strongly_measurable hp_ne_zero hp_ne_top
    (λ i, (hf i).strongly_measurable_mk) hg.strongly_measurable_mk _,
  have : (λ n, snorm ((hf n).mk (f n) - hg.mk g) p μ) = (λ n, snorm (f n - g) p μ),
  { ext1 n, refine snorm_congr_ae (eventually_eq.sub (hf n).ae_eq_mk.symm hg.ae_eq_mk.symm), },
  rw this,
  exact hfg,
end

/-- See also `measure_theory.tendsto_in_measure_of_tendsto_snorm` which work for general
Lp-convergence for all `p ≠ 0`. -/
lemma tendsto_in_measure_of_tendsto_snorm_top {E} [normed_group E] {f : ι → α → E} {g : α → E}
  {l : filter ι} (hfg : tendsto (λ n, snorm (f n - g) ∞ μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  intros δ hδ,
  simp only [snorm_exponent_top, snorm_ess_sup] at hfg,
  rw ennreal.tendsto_nhds_zero at hfg ⊢,
  intros ε hε,
  specialize hfg ((ennreal.of_real δ) / 2) (ennreal.div_pos_iff.2
    ⟨(ennreal.of_real_pos.2 hδ).ne.symm, ennreal.two_ne_top⟩),
  refine hfg.mono (λ n hn, _),
  simp only [true_and, gt_iff_lt, ge_iff_le, zero_tsub, zero_le, zero_add, set.mem_Icc,
    pi.sub_apply] at *,
  have : ess_sup (λ (x : α), (∥f n x - g x∥₊ : ℝ≥0∞)) μ < ennreal.of_real δ :=
    lt_of_le_of_lt hn (ennreal.half_lt_self (ennreal.of_real_pos.2 hδ).ne.symm
      ennreal.of_real_lt_top.ne),
  refine ((le_of_eq _).trans (ae_lt_of_ess_sup_lt this).le).trans hε.le,
  congr' with x,
  simp only [ennreal.of_real_le_iff_le_to_real ennreal.coe_lt_top.ne, ennreal.coe_to_real,
    not_lt, coe_nnnorm, set.mem_set_of_eq, set.mem_compl_eq],
  rw ← dist_eq_norm (f n x) (g x),
  refl
end

/-- Convergence in Lp implies convergence in measure. -/
lemma tendsto_in_measure_of_tendsto_snorm {l : filter ι}
  (hp_ne_zero : p ≠ 0) (hf : ∀ n, ae_strongly_measurable (f n) μ) (hg : ae_strongly_measurable g μ)
  (hfg : tendsto (λ n, snorm (f n - g) p μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  by_cases hp_ne_top : p = ∞,
  { subst hp_ne_top,
    exact tendsto_in_measure_of_tendsto_snorm_top hfg },
  { exact tendsto_in_measure_of_tendsto_snorm_of_ne_top hp_ne_zero hp_ne_top hf hg hfg }
end

/-- Convergence in Lp implies convergence in measure. -/
lemma tendsto_in_measure_of_tendsto_Lp [hp : fact (1 ≤ p)]
  {f : ι → Lp E p μ} {g : Lp E p μ} {l : filter ι} (hfg : tendsto f l (𝓝 g)) :
  tendsto_in_measure μ (λ n, f n) l g :=
tendsto_in_measure_of_tendsto_snorm (ennreal.zero_lt_one.trans_le hp.elim).ne.symm
  (λ n, Lp.ae_strongly_measurable _) (Lp.ae_strongly_measurable _)
  ((Lp.tendsto_Lp_iff_tendsto_ℒp' _ _).mp hfg)

end tendsto_in_measure_of

end measure_theory


<|start_filename|>src/ring_theory/polynomial/vieta.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import ring_theory.polynomial.basic
import ring_theory.polynomial.symmetric

/-!
# Vieta's Formula

The main result is `vieta.prod_X_add_C_eq_sum_esymm`, which shows that the product of linear terms
`λ + X i` is equal to a linear combination of the symmetric polynomials `esymm σ R j`.

## Implementation Notes:

We first take the viewpoint where the "roots" `X i` are variables. This means we work over
`polynomial (mv_polynomial σ R)`, which enables us to talk about linear combinations of
`esymm σ R j`. We then derive Vieta's formula in `polynomial R` by giving a
valuation from each `X i` to `r i`.

-/

open_locale big_operators polynomial

open finset polynomial fintype

namespace mv_polynomial

variables {R : Type*} [comm_semiring R]
variables (σ : Type*) [fintype σ]

/-- A sum version of Vieta's formula. Viewing `X i` as variables,
the product of linear terms `λ + X i` is equal to a linear combination of
the symmetric polynomials `esymm σ R j`. -/
lemma prod_X_add_C_eq_sum_esymm :
  (∏ i : σ, (polynomial.C (X i) + polynomial.X) : polynomial (mv_polynomial σ R) )=
  ∑ j in range (card σ + 1),
    (polynomial.C (esymm σ R j) * polynomial.X ^ (card σ - j)) :=
begin
  classical,
  rw [prod_add, sum_powerset],
  refine sum_congr begin congr end (λ j hj, _),
  rw [esymm, map_sum, sum_mul],
  refine sum_congr rfl (λ t ht, _),
  have h : (univ \ t).card = card σ - j :=
  by { rw card_sdiff (mem_powerset_len.mp ht).1, congr, exact (mem_powerset_len.mp ht).2 },
  rw [map_prod, prod_const, ← h],
end

/-- A fully expanded sum version of Vieta's formula, evaluated at the roots.
The product of linear terms `X + r i` is equal to `∑ j in range (n + 1), e_j * X ^ (n - j)`,
where `e_j` is the `j`th symmetric polynomial of the constant terms `r i`. -/
lemma prod_X_add_C_eval (r : σ → R) : ∏ i : σ, (polynomial.C (r i) + polynomial.X) =
  ∑ i in range (card σ + 1), (∑ t in powerset_len i (univ : finset σ),
    ∏ i in t, polynomial.C (r i)) * polynomial.X ^ (card σ - i) :=
begin
  classical,
  have h := @prod_X_add_C_eq_sum_esymm _ _ σ _,
  apply_fun (polynomial.map (eval r)) at h,
  rw [polynomial.map_prod, polynomial.map_sum] at h,
  convert h,
  simp only [eval_X, polynomial.map_add, polynomial.map_C, polynomial.map_X, eq_self_iff_true],
  funext,
  simp only [function.funext_iff, esymm, polynomial.map_C, polynomial.map_sum, map_sum,
    polynomial.map_C, polynomial.map_pow, polynomial.map_X, polynomial.map_mul],
  congr,
  funext,
  simp only [eval_prod, eval_X, map_prod],
end

lemma esymm_to_sum (r : σ → R) (j : ℕ) : polynomial.C (eval r (esymm σ R j)) =
  ∑ t in powerset_len j (univ : finset σ), ∏ i in t, polynomial.C (r i) :=
by simp only [esymm, eval_sum, eval_prod, eval_X, map_sum, map_prod]

/-- Vieta's formula for the coefficients of the product of linear terms `X + r i`,
The `k`th coefficient is `∑ t in powerset_len (card σ - k) (univ : finset σ), ∏ i in t, r i`,
i.e. the symmetric polynomial `esymm σ R (card σ - k)` of the constant terms `r i`. -/
lemma prod_X_add_C_coeff (r : σ → R) (k : ℕ) (h : k ≤ card σ):
  polynomial.coeff (∏ i : σ, (polynomial.C (r i) + polynomial.X)) k =
  ∑ t in powerset_len (card σ - k) (univ : finset σ), ∏ i in t, r i :=
begin
  have hk : filter (λ (x : ℕ), k = card σ - x) (range (card σ + 1)) = {card σ - k} :=
  begin
    refine finset.ext (λ a, ⟨λ ha, _, λ ha, _ ⟩),
    rw mem_singleton,
    have hσ := (tsub_eq_iff_eq_add_of_le (mem_range_succ_iff.mp
      (mem_filter.mp ha).1)).mp ((mem_filter.mp ha).2).symm,
    symmetry,
    rwa [(tsub_eq_iff_eq_add_of_le h), add_comm],
    rw mem_filter,
    have haσ : a ∈ range (card σ + 1) :=
    by { rw mem_singleton.mp ha, exact mem_range_succ_iff.mpr (@tsub_le_self _ _ _ _ _ k) },
    refine ⟨haσ, eq.symm _⟩,
    rw tsub_eq_iff_eq_add_of_le (mem_range_succ_iff.mp haσ),
    have hσ := (tsub_eq_iff_eq_add_of_le h).mp (mem_singleton.mp ha).symm,
    rwa add_comm,
  end,
  simp only [prod_X_add_C_eval, ← esymm_to_sum, finset_sum_coeff, coeff_C_mul_X_pow, sum_ite, hk,
    sum_singleton, esymm, eval_sum, eval_prod, eval_X, add_zero, sum_const_zero],
end

end mv_polynomial


<|start_filename|>src/category_theory/monoidal/discrete.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.hom.group
import category_theory.discrete_category
import category_theory.monoidal.natural_transformation

/-!
# Monoids as discrete monoidal categories

The discrete category on a monoid is a monoidal category.
Multiplicative morphisms induced monoidal functors.
-/

universes u

open category_theory
open category_theory.discrete

variables (M : Type u) [monoid M]

namespace category_theory

@[to_additive discrete.add_monoidal, simps tensor_obj_as tensor_unit_as]
instance discrete.monoidal : monoidal_category (discrete M) :=
{ tensor_unit := discrete.mk 1,
  tensor_obj := λ X Y, discrete.mk (X.as * Y.as),
  tensor_hom := λ W X Y Z f g, eq_to_hom (by rw [eq_of_hom f, eq_of_hom g]),
  left_unitor := λ X, discrete.eq_to_iso (one_mul X.as),
  right_unitor := λ X, discrete.eq_to_iso (mul_one X.as),
  associator := λ X Y Z, discrete.eq_to_iso (mul_assoc _ _ _ ), }

variables {M} {N : Type u} [monoid N]

/--
A multiplicative morphism between monoids gives a monoidal functor between the corresponding
discrete monoidal categories.
-/
@[to_additive discrete.add_monoidal_functor "An additive morphism between add_monoids gives a
  monoidal functor between the corresponding discrete monoidal categories.", simps]
def discrete.monoidal_functor (F : M →* N) : monoidal_functor (discrete M) (discrete N) :=
{ obj := λ X, discrete.mk (F X.as),
  map := λ X Y f, discrete.eq_to_hom (F.congr_arg (eq_of_hom f)),
  ε := discrete.eq_to_hom F.map_one.symm,
  μ := λ X Y, discrete.eq_to_hom (F.map_mul X.as Y.as).symm, }

variables {K : Type u} [monoid K]

/--
The monoidal natural isomorphism corresponding to composing two multiplicative morphisms.
-/
@[to_additive discrete.add_monoidal_functor_comp "The monoidal natural isomorphism corresponding to
composing two additive morphisms."]
def discrete.monoidal_functor_comp (F : M →* N) (G : N →* K) :
  discrete.monoidal_functor F ⊗⋙ discrete.monoidal_functor G ≅
  discrete.monoidal_functor (G.comp F) :=
{ hom := { app := λ X, 𝟙 _, },
  inv := { app := λ X, 𝟙 _, }, }

end category_theory


<|start_filename|>src/data/prod/basic.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import tactic.basic

/-!
# Extra facts about `prod`

This file defines `prod.swap : α × β → β × α` and proves various simple lemmas about `prod`.
-/

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

@[simp] lemma prod_map (f : α → γ) (g : β → δ) (p : α × β) : prod.map f g p = (f p.1, g p.2) := rfl

namespace prod

@[simp] theorem «forall» {p : α × β → Prop} : (∀ x, p x) ↔ (∀ a b, p (a, b)) :=
⟨assume h a b, h (a, b), assume h ⟨a, b⟩, h a b⟩

@[simp] theorem «exists» {p : α × β → Prop} : (∃ x, p x) ↔ (∃ a b, p (a, b)) :=
⟨assume ⟨⟨a, b⟩, h⟩, ⟨a, b, h⟩, assume ⟨a, b, h⟩, ⟨⟨a, b⟩, h⟩⟩

theorem forall' {p : α → β → Prop} : (∀ x : α × β, p x.1 x.2) ↔ ∀ a b, p a b :=
prod.forall

theorem exists' {p : α → β → Prop} : (∃ x : α × β, p x.1 x.2) ↔ ∃ a b, p a b :=
prod.exists

@[simp] lemma snd_comp_mk (x : α) : prod.snd ∘ (prod.mk x : β → α × β) = id := rfl

@[simp] lemma fst_comp_mk (x : α) : prod.fst ∘ (prod.mk x : β → α × β) = function.const β x := rfl

@[simp] lemma map_mk (f : α → γ) (g : β → δ) (a : α) (b : β) : map f g (a, b) = (f a, g b) := rfl

lemma map_fst (f : α → γ) (g : β → δ) (p : α × β) : (map f g p).1 = f (p.1) := rfl

lemma map_snd (f : α → γ) (g : β → δ) (p : α × β) : (map f g p).2 = g (p.2) := rfl

lemma map_fst' (f : α → γ) (g : β → δ) : (prod.fst ∘ map f g) = f ∘ prod.fst :=
funext $ map_fst f g

lemma map_snd' (f : α → γ) (g : β → δ) : (prod.snd ∘ map f g) = g ∘ prod.snd :=
funext $ map_snd f g

/--
Composing a `prod.map` with another `prod.map` is equal to
a single `prod.map` of composed functions.
-/
lemma map_comp_map {ε ζ : Type*}
  (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) :
  prod.map g g' ∘ prod.map f f' = prod.map (g ∘ f) (g' ∘ f') :=
rfl

/--
Composing a `prod.map` with another `prod.map` is equal to
a single `prod.map` of composed functions, fully applied.
-/
lemma map_map {ε ζ : Type*}
  (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) (x : α × γ) :
  prod.map g g' (prod.map f f' x) = prod.map (g ∘ f) (g' ∘ f') x :=
rfl

@[simp] theorem mk.inj_iff {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) = (a₂, b₂) ↔ (a₁ = a₂ ∧ b₁ = b₂) :=
⟨prod.mk.inj, by cc⟩

lemma mk.inj_left {α β : Type*} (a : α) :
  function.injective (prod.mk a : β → α × β) :=
by { intros b₁ b₂ h, simpa only [true_and, prod.mk.inj_iff, eq_self_iff_true] using h }

lemma mk.inj_right {α β : Type*} (b : β) :
  function.injective (λ a, prod.mk a b : α → α × β) :=
by { intros b₁ b₂ h, by simpa only [and_true, eq_self_iff_true, mk.inj_iff] using h }

lemma ext_iff {p q : α × β} : p = q ↔ p.1 = q.1 ∧ p.2 = q.2 :=
by rw [← @mk.eta _ _ p, ← @mk.eta _ _ q, mk.inj_iff]

@[ext]
lemma ext {α β} {p q : α × β} (h₁ : p.1 = q.1) (h₂ : p.2 = q.2) : p = q :=
ext_iff.2 ⟨h₁, h₂⟩

lemma map_def {f : α → γ} {g : β → δ} : prod.map f g = λ (p : α × β), (f p.1, g p.2) :=
funext (λ p, ext (map_fst f g p) (map_snd f g p))

lemma id_prod : (λ (p : α × β), (p.1, p.2)) = id :=
funext $ λ ⟨a, b⟩, rfl

lemma map_id : (prod.map (@id α) (@id β)) = id :=
id_prod

lemma fst_surjective [h : nonempty β] : function.surjective (@fst α β) :=
λ x, h.elim $ λ y, ⟨⟨x, y⟩, rfl⟩

lemma snd_surjective [h : nonempty α] : function.surjective (@snd α β) :=
λ y, h.elim $ λ x, ⟨⟨x, y⟩, rfl⟩

lemma fst_injective [subsingleton β] : function.injective (@fst α β) :=
λ x y h, ext h (subsingleton.elim _ _)

lemma snd_injective [subsingleton α] : function.injective (@snd α β) :=
λ x y h, ext (subsingleton.elim _ _) h

/-- Swap the factors of a product. `swap (a, b) = (b, a)` -/
def swap : α × β → β × α := λp, (p.2, p.1)

@[simp] lemma swap_swap : ∀ x : α × β, swap (swap x) = x
| ⟨a, b⟩ := rfl

@[simp] lemma fst_swap {p : α × β} : (swap p).1 = p.2 := rfl

@[simp] lemma snd_swap {p : α × β} : (swap p).2 = p.1 := rfl

@[simp] lemma swap_prod_mk {a : α} {b : β} : swap (a, b) = (b, a) := rfl

@[simp] lemma swap_swap_eq : swap ∘ swap = @id (α × β) :=
funext swap_swap

@[simp] lemma swap_left_inverse : function.left_inverse (@swap α β) swap :=
swap_swap

@[simp] lemma swap_right_inverse : function.right_inverse (@swap α β) swap :=
swap_swap

lemma swap_injective : function.injective (@swap α β) :=
swap_left_inverse.injective

lemma swap_surjective : function.surjective (@swap α β) :=
swap_left_inverse.surjective

lemma swap_bijective : function.bijective (@swap α β) :=
⟨swap_injective, swap_surjective⟩

@[simp] lemma swap_inj {p q : α × β} : swap p = swap q ↔ p = q := swap_injective.eq_iff

lemma eq_iff_fst_eq_snd_eq : ∀{p q : α × β}, p = q ↔ (p.1 = q.1 ∧ p.2 = q.2)
| ⟨p₁, p₂⟩ ⟨q₁, q₂⟩ := by simp

lemma fst_eq_iff : ∀ {p : α × β} {x : α}, p.1 = x ↔ p = (x, p.2)
| ⟨a, b⟩ x := by simp

lemma snd_eq_iff : ∀ {p : α × β} {x : β}, p.2 = x ↔ p = (p.1, x)
| ⟨a, b⟩ x := by simp

theorem lex_def (r : α → α → Prop) (s : β → β → Prop)
  {p q : α × β} : prod.lex r s p q ↔ r p.1 q.1 ∨ p.1 = q.1 ∧ s p.2 q.2 :=
⟨λ h, by cases h; simp *,
 λ h, match p, q, h with
 | (a, b), (c, d), or.inl h := lex.left _ _ h
 | (a, b), (c, d), or.inr ⟨e, h⟩ :=
   by change a = c at e; subst e; exact lex.right _ h
 end⟩

instance lex.decidable [decidable_eq α]
  (r : α → α → Prop) (s : β → β → Prop) [decidable_rel r] [decidable_rel s] :
  decidable_rel (prod.lex r s) :=
λ p q, decidable_of_decidable_of_iff (by apply_instance) (lex_def r s).symm

@[refl] lemma lex.refl_left (r : α → α → Prop) (s : β → β → Prop) [is_refl α r] :
  ∀ x, prod.lex r s x x
| (x₁, x₂) := lex.left _ _ (refl _)

instance is_refl_left {r : α → α → Prop} {s : β → β → Prop} [is_refl α r] :
  is_refl (α × β) (lex r s) :=
⟨lex.refl_left _ _⟩

@[refl] lemma lex.refl_right (r : α → α → Prop) (s : β → β → Prop) [is_refl β s] :
  ∀ x, prod.lex r s x x
| (x₁, x₂) := lex.right _ (refl _)

instance is_refl_right {r : α → α → Prop} {s : β → β → Prop} [is_refl β s] :
  is_refl (α × β) (lex r s) :=
⟨lex.refl_right _ _⟩

@[trans] lemma lex.trans {r : α → α → Prop} {s : β → β → Prop} [is_trans α r] [is_trans β s] :
  ∀ {x y z : α × β}, prod.lex r s x y → prod.lex r s y z → prod.lex r s x z
| (x₁, x₂) (y₁, y₂) (z₁, z₂) (lex.left _ _ hxy₁) (lex.left _ _ hyz₁) :=
    lex.left _ _ (trans hxy₁ hyz₁)
| (x₁, x₂) (y₁, y₂) (z₁, z₂) (lex.left _ _ hxy₁) (lex.right _ hyz₂) := lex.left _ _ hxy₁
| (x₁, x₂) (y₁, y₂) (z₁, z₂) (lex.right _ _) (lex.left _ _ hyz₁) := lex.left _ _ hyz₁
| (x₁, x₂) (y₁, y₂) (z₁, z₂) (lex.right _ hxy₂) (lex.right _ hyz₂) := lex.right _ (trans hxy₂ hyz₂)

instance {r : α → α → Prop} {s : β → β → Prop} [is_trans α r] [is_trans β s] :
  is_trans (α × β) (lex r s) :=
⟨λ _ _ _, lex.trans⟩

instance {r : α → α → Prop} {s : β → β → Prop} [is_strict_order α r] [is_antisymm β s] :
  is_antisymm (α × β) (lex r s) :=
⟨λ x₁ x₂ h₁₂ h₂₁, match x₁, x₂, h₁₂, h₂₁ with
  | (a₁, b₁), (a₂, b₂), lex.left _ _ hr₁, lex.left _ _ hr₂ := (irrefl a₁ (trans hr₁ hr₂)).elim
  | (a₁, b₁), (a₂, b₂), lex.left _ _ hr₁, lex.right _ _ := (irrefl _ hr₁).elim
  | (a₁, b₁), (a₂, b₂), lex.right _ _, lex.left _ _ hr₂ := (irrefl _ hr₂).elim
  | (a₁, b₁), (a₂, b₂), lex.right _ hs₁, lex.right _ hs₂ := antisymm hs₁ hs₂ ▸ rfl
end⟩

instance is_total_left {r : α → α → Prop} {s : β → β → Prop} [is_total α r] :
  is_total (α × β) (lex r s) :=
⟨λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩, (is_total.total a₁ a₂).imp (lex.left _ _) (lex.left _ _)⟩

instance is_total_right {r : α → α → Prop} {s : β → β → Prop} [is_trichotomous α r] [is_total β s] :
  is_total (α × β) (lex r s) :=
⟨λ ⟨i, a⟩ ⟨j, b⟩, begin
  obtain hij | rfl | hji := trichotomous_of r i j,
  { exact or.inl (lex.left _ _ hij) },
  { exact (total_of (s) a b).imp (lex.right _) (lex.right _), },
  { exact or.inr (lex.left _ _ hji) }
end⟩

end prod

open function

lemma function.injective.prod_map {f : α → γ} {g : β → δ} (hf : injective f) (hg : injective g) :
  injective (prod.map f g) :=
λ x y h, prod.ext (hf (prod.ext_iff.1 h).1) (hg $ (prod.ext_iff.1 h).2)

lemma function.surjective.prod_map {f : α → γ} {g : β → δ} (hf : surjective f) (hg : surjective g) :
  surjective (prod.map f g) :=
λ p, let ⟨x, hx⟩ := hf p.1 in let ⟨y, hy⟩ := hg p.2 in ⟨(x, y), prod.ext hx hy⟩


<|start_filename|>src/category_theory/preadditive/hom_orthogonal.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.linear
import category_theory.limits.shapes.biproducts
import linear_algebra.matrix.invariant_basis_number

/-!
# Hom orthogonal families.

A family of objects in a category with zero morphisms is "hom orthogonal" if the only
morphism between distinct objects is the zero morphism.

We show that in any category with zero morphisms and finite biproducts,
a morphism between biproducts drawn from a hom orthogonal family `s : ι → C`
can be decomposed into a block diagonal matrix with entries in the endomorphism rings of the `s i`.

When the category is preadditive, this decomposition is an additive equivalence,
and intertwines composition and matrix multiplication.
When the category is `R`-linear, the decomposition is an `R`-linear equivalence.

If every object in the hom orthogonal family has an endomorphism ring with invariant basis number
(e.g. if each object in the family is simple, so its endomorphism ring is a division ring,
or otherwise if each endomorphism ring is commutative),
then decompositions of an object as a biproduct of the family have uniquely defined multiplicities.
We state this as:
```
lemma hom_orthogonal.equiv_of_iso (o : hom_orthogonal s) {f : α → ι} {g : β → ι}
  (i : ⨁ (λ a, s (f a)) ≅ ⨁ (λ b, s (g b))) : ∃ e : α ≃ β, ∀ a, g (e a) = f a
```

This is preliminary to defining semisimple categories.
-/

open_locale classical matrix

open category_theory.limits

universes v u

namespace category_theory

variables {C : Type u} [category.{v} C]

/-- A family of objects is "hom orthogonal" if
there is at most one morphism between distinct objects.

(In a category with zero morphisms, that must be the zero morphism.) -/
def hom_orthogonal {ι : Type*} (s : ι → C) : Prop :=
∀ i j, i ≠ j → subsingleton (s i ⟶ s j)

namespace hom_orthogonal

variables {ι : Type*} {s : ι → C}

lemma eq_zero [has_zero_morphisms C] (o : hom_orthogonal s)
  {i j : ι} (w : i ≠ j) (f : s i ⟶ s j) : f = 0 :=
by { haveI := o i j w, apply subsingleton.elim, }

section
variables [has_zero_morphisms C] [has_finite_biproducts C]

/-- Morphisms between two direct sums over a hom orthogonal family `s : ι → C`
are equivalent to block diagonal matrices,
with blocks indexed by `ι`,
and matrix entries in `i`-th block living in the endomorphisms of `s i`. -/
@[simps] noncomputable
def matrix_decomposition
  (o : hom_orthogonal s) {α β : Type*} [fintype α] [fintype β] {f : α → ι} {g : β → ι} :
  (⨁ (λ a, s (f a)) ⟶ ⨁ (λ b, s (g b))) ≃
    Π (i : ι), matrix (g ⁻¹' {i}) (f ⁻¹' {i}) (End (s i)) :=
{ to_fun := λ z i j k,
    eq_to_hom (by { rcases k with ⟨k, ⟨⟩⟩, simp, }) ≫
      biproduct.components z k j ≫ eq_to_hom (by { rcases j with ⟨j, ⟨⟩⟩, simp, }),
  inv_fun := λ z, biproduct.matrix (λ j k, if h : f j = g k then
      z (f j) ⟨k, by simp [h]⟩ ⟨j, by simp⟩ ≫ eq_to_hom (by simp [h])
    else
      0),
  left_inv := λ z, begin
    ext j k,
    simp only [category.assoc, biproduct.lift_π, biproduct.ι_matrix],
    split_ifs,
    { simp, refl, },
    { symmetry, apply o.eq_zero h, },
  end,
  right_inv := λ z, begin
    ext i ⟨j, w⟩ ⟨k, ⟨⟩⟩,
    simp only [set.mem_preimage, set.mem_singleton_iff],
    simp [w.symm], refl,
  end, }

end

section
variables [preadditive C] [has_finite_biproducts C]

/-- `hom_orthogonal.matrix_decomposition` as an additive equivalence. -/
@[simps] noncomputable
def matrix_decomposition_add_equiv
  (o : hom_orthogonal s) {α β : Type*} [fintype α] [fintype β] {f : α → ι} {g : β → ι} :
  (⨁ (λ a, s (f a)) ⟶ ⨁ (λ b, s (g b))) ≃+
    Π (i : ι), matrix (g ⁻¹' {i}) (f ⁻¹' {i}) (End (s i)) :=
{ map_add' := λ w z, by { ext, dsimp [biproduct.components], simp, },
  ..o.matrix_decomposition, }.

@[simp]
lemma matrix_decomposition_id
  (o : hom_orthogonal s) {α : Type*} [fintype α] {f : α → ι} (i : ι) :
  o.matrix_decomposition (𝟙 (⨁ (λ a, s (f a)))) i = 1 :=
begin
  ext ⟨b, ⟨⟩⟩ ⟨a⟩,
  simp only [set.mem_preimage, set.mem_singleton_iff] at j_property,
  simp only [category.comp_id, category.id_comp, category.assoc, End.one_def, eq_to_hom_refl,
    matrix.one_apply, hom_orthogonal.matrix_decomposition_apply, biproduct.components],
  split_ifs with h,
  { cases h, simp, },
  { convert comp_zero,
    simpa using biproduct.ι_π_ne _ (ne.symm h), },
end

lemma matrix_decomposition_comp
  (o : hom_orthogonal s)
  {α β γ : Type*} [fintype α] [fintype β] [fintype γ] {f : α → ι} {g : β → ι} {h : γ → ι}
  (z : (⨁ (λ a, s (f a)) ⟶ ⨁ (λ b, s (g b)))) (w : (⨁ (λ b, s (g b)) ⟶ ⨁ (λ c, s (h c))))
  (i : ι) :
  o.matrix_decomposition (z ≫ w) i = o.matrix_decomposition w i ⬝ o.matrix_decomposition z i :=
begin
  ext ⟨c, ⟨⟩⟩ ⟨a⟩,
  simp only [set.mem_preimage, set.mem_singleton_iff] at j_property,
  simp only [matrix.mul_apply, limits.biproduct.components,
    hom_orthogonal.matrix_decomposition_apply,
    category.comp_id, category.id_comp, category.assoc, End.mul_def,
    eq_to_hom_refl, eq_to_hom_trans_assoc, finset.sum_congr],
  conv_lhs { rw [←category.id_comp w, ←biproduct.total], },
  simp only [preadditive.sum_comp, preadditive.comp_sum],
  apply finset.sum_congr_set,
  { intros, simp, refl, },
  { intros b nm,
    simp only [set.mem_preimage, set.mem_singleton_iff] at nm,
    simp only [category.assoc],
    convert comp_zero,
    convert comp_zero,
    convert comp_zero,
    convert comp_zero,
    apply o.eq_zero nm, },
end

section
variables {R : Type*} [semiring R] [linear R C]

/-- `hom_orthogonal.matrix_decomposition` as an `R`-linear equivalence. -/
@[simps] noncomputable
def matrix_decomposition_linear_equiv
(o : hom_orthogonal s)
  {α β : Type*} [fintype α] [fintype β] {f : α → ι} {g : β → ι} :
  (⨁ (λ a, s (f a)) ⟶ ⨁ (λ b, s (g b))) ≃ₗ[R]
    Π (i : ι), matrix (g ⁻¹' {i}) (f ⁻¹' {i}) (End (s i)) :=
{ map_smul' := λ w z, by { ext, dsimp [biproduct.components], simp, },
  ..o.matrix_decomposition_add_equiv, }

end

/-!
The hypothesis that `End (s i)` has invariant basis number is automatically satisfied
if `s i` is simple (as then `End (s i)` is a division ring).
-/
variables [∀ i, invariant_basis_number (End (s i))]

/--
Given a hom orthogonal family `s : ι → C`
for which each `End (s i)` is a ring with invariant basis number (e.g. if each `s i` is simple),
if two direct sums over `s` are isomorphic, then they have the same multiplicities.
-/
lemma equiv_of_iso (o : hom_orthogonal s)
  {α β : Type*} [fintype α] [fintype β] {f : α → ι} {g : β → ι}
  (i : ⨁ (λ a, s (f a)) ≅ ⨁ (λ b, s (g b))) :
  ∃ e : α ≃ β, ∀ a, g (e a) = f a :=
begin
  refine ⟨equiv.of_preimage_equiv _, λ a, equiv.of_preimage_equiv_map _ _⟩,
  intro c,
  apply nonempty.some,
  apply cardinal.eq.1,
  simp only [cardinal.mk_fintype, nat.cast_inj],
  exact matrix.square_of_invertible
    (o.matrix_decomposition i.inv c) (o.matrix_decomposition i.hom c)
    (by { rw ←o.matrix_decomposition_comp, simp, })
    (by { rw ←o.matrix_decomposition_comp, simp, })
end

end

end hom_orthogonal

end category_theory


<|start_filename|>src/topology/continuous_function/stone_weierstrass.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import topology.continuous_function.weierstrass
import analysis.complex.basic

/-!
# The Stone-Weierstrass theorem

If a subalgebra `A` of `C(X, ℝ)`, where `X` is a compact topological space,
separates points, then it is dense.

We argue as follows.

* In any subalgebra `A` of `C(X, ℝ)`, if `f ∈ A`, then `abs f ∈ A.topological_closure`.
  This follows from the Weierstrass approximation theorem on `[-∥f∥, ∥f∥]` by
  approximating `abs` uniformly thereon by polynomials.
* This ensures that `A.topological_closure` is actually a sublattice:
  if it contains `f` and `g`, then it contains the pointwise supremum `f ⊔ g`
  and the pointwise infimum `f ⊓ g`.
* Any nonempty sublattice `L` of `C(X, ℝ)` which separates points is dense,
  by a nice argument approximating a given `f` above and below using separating functions.
  For each `x y : X`, we pick a function `g x y ∈ L` so `g x y x = f x` and `g x y y = f y`.
  By continuity these functions remain close to `f` on small patches around `x` and `y`.
  We use compactness to identify a certain finitely indexed infimum of finitely indexed supremums
  which is then close to `f` everywhere, obtaining the desired approximation.
* Finally we put these pieces together. `L = A.topological_closure` is a nonempty sublattice
  which separates points since `A` does, and so is dense (in fact equal to `⊤`).

We then prove the complex version for self-adjoint subalgebras `A`, by separately approximating
the real and imaginary parts using the real subalgebra of real-valued functions in `A`
(which still separates points, by taking the norm-square of a separating function).

## Future work

Extend to cover the case of subalgebras of the continuous functions vanishing at infinity,
on non-compact spaces.

-/

noncomputable theory

namespace continuous_map

variables {X : Type*} [topological_space X] [compact_space X]

/--
Turn a function `f : C(X, ℝ)` into a continuous map into `set.Icc (-∥f∥) (∥f∥)`,
thereby explicitly attaching bounds.
-/
def attach_bound (f : C(X, ℝ)) : C(X, set.Icc (-∥f∥) (∥f∥)) :=
{ to_fun := λ x, ⟨f x, ⟨neg_norm_le_apply f x, apply_le_norm f x⟩⟩ }

@[simp] lemma attach_bound_apply_coe (f : C(X, ℝ)) (x : X) : ((attach_bound f) x : ℝ) = f x := rfl

lemma polynomial_comp_attach_bound (A : subalgebra ℝ C(X, ℝ)) (f : A) (g : polynomial ℝ) :
  (g.to_continuous_map_on (set.Icc (-∥f∥) ∥f∥)).comp (f : C(X, ℝ)).attach_bound =
    polynomial.aeval f g :=
begin
  ext,
  simp only [continuous_map.coe_comp, function.comp_app,
    continuous_map.attach_bound_apply_coe,
    polynomial.to_continuous_map_on_to_fun,
    polynomial.aeval_subalgebra_coe,
    polynomial.aeval_continuous_map_apply,
    polynomial.to_continuous_map_to_fun],
end

/--
Given a continuous function `f` in a subalgebra of `C(X, ℝ)`, postcomposing by a polynomial
gives another function in `A`.

This lemma proves something slightly more subtle than this:
we take `f`, and think of it as a function into the restricted target `set.Icc (-∥f∥) ∥f∥)`,
and then postcompose with a polynomial function on that interval.
This is in fact the same situation as above, and so also gives a function in `A`.
-/
lemma polynomial_comp_attach_bound_mem (A : subalgebra ℝ C(X, ℝ)) (f : A) (g : polynomial ℝ) :
  (g.to_continuous_map_on (set.Icc (-∥f∥) ∥f∥)).comp (f : C(X, ℝ)).attach_bound ∈ A :=
begin
  rw polynomial_comp_attach_bound,
  apply set_like.coe_mem,
end

theorem comp_attach_bound_mem_closure
  (A : subalgebra ℝ C(X, ℝ)) (f : A) (p : C(set.Icc (-∥f∥) (∥f∥), ℝ)) :
  p.comp (attach_bound f) ∈ A.topological_closure :=
begin
  -- `p` itself is in the closure of polynomials, by the Weierstrass theorem,
  have mem_closure : p ∈ (polynomial_functions (set.Icc (-∥f∥) (∥f∥))).topological_closure :=
    continuous_map_mem_polynomial_functions_closure _ _ p,
  -- and so there are polynomials arbitrarily close.
  have frequently_mem_polynomials := mem_closure_iff_frequently.mp mem_closure,
  -- To prove `p.comp (attached_bound f)` is in the closure of `A`,
  -- we show there are elements of `A` arbitrarily close.
  apply mem_closure_iff_frequently.mpr,
  -- To show that, we pull back the polynomials close to `p`,
  refine ((comp_right_continuous_map ℝ (attach_bound (f : C(X, ℝ)))).continuous_at p).tendsto
    .frequently_map _ _ frequently_mem_polynomials,
  -- but need to show that those pullbacks are actually in `A`.
  rintros _ ⟨g, ⟨-,rfl⟩⟩,
  simp only [set_like.mem_coe, alg_hom.coe_to_ring_hom, comp_right_continuous_map_apply,
    polynomial.to_continuous_map_on_alg_hom_apply],
  apply polynomial_comp_attach_bound_mem,
end

theorem abs_mem_subalgebra_closure (A : subalgebra ℝ C(X, ℝ)) (f : A) :
  (f : C(X, ℝ)).abs ∈ A.topological_closure :=
begin
  let M := ∥f∥,
  let f' := attach_bound (f : C(X, ℝ)),
  let abs : C(set.Icc (-∥f∥) (∥f∥), ℝ) :=
  { to_fun := λ x : set.Icc (-∥f∥) (∥f∥), |(x : ℝ)| },
  change (abs.comp f') ∈ A.topological_closure,
  apply comp_attach_bound_mem_closure,
end

theorem inf_mem_subalgebra_closure (A : subalgebra ℝ C(X, ℝ)) (f g : A) :
  (f : C(X, ℝ)) ⊓ (g : C(X, ℝ)) ∈ A.topological_closure :=
begin
  rw inf_eq,
  refine A.topological_closure.smul_mem
    (A.topological_closure.sub_mem
      (A.topological_closure.add_mem (A.subalgebra_topological_closure f.property)
          (A.subalgebra_topological_closure g.property)) _) _,
  exact_mod_cast abs_mem_subalgebra_closure A _,
end

theorem inf_mem_closed_subalgebra (A : subalgebra ℝ C(X, ℝ)) (h : is_closed (A : set C(X, ℝ)))
  (f g : A) : (f : C(X, ℝ)) ⊓ (g : C(X, ℝ)) ∈ A :=
begin
  convert inf_mem_subalgebra_closure A f g,
  apply set_like.ext',
  symmetry,
  erw closure_eq_iff_is_closed,
  exact h,
end

theorem sup_mem_subalgebra_closure (A : subalgebra ℝ C(X, ℝ)) (f g : A) :
  (f : C(X, ℝ)) ⊔ (g : C(X, ℝ)) ∈ A.topological_closure :=
begin
  rw sup_eq,
  refine A.topological_closure.smul_mem
    (A.topological_closure.add_mem
      (A.topological_closure.add_mem (A.subalgebra_topological_closure f.property)
          (A.subalgebra_topological_closure g.property)) _) _,
  exact_mod_cast abs_mem_subalgebra_closure A _,
end

theorem sup_mem_closed_subalgebra (A : subalgebra ℝ C(X, ℝ)) (h : is_closed (A : set C(X, ℝ)))
  (f g : A) : (f : C(X, ℝ)) ⊔ (g : C(X, ℝ)) ∈ A :=
begin
  convert sup_mem_subalgebra_closure A f g,
  apply set_like.ext',
  symmetry,
  erw closure_eq_iff_is_closed,
  exact h,
end

open_locale topological_space

-- Here's the fun part of Stone-Weierstrass!
theorem sublattice_closure_eq_top
  (L : set C(X, ℝ)) (nA : L.nonempty)
  (inf_mem : ∀ f g ∈ L, f ⊓ g ∈ L) (sup_mem : ∀ f g ∈ L, f ⊔ g ∈ L)
  (sep : L.separates_points_strongly) :
  closure L = ⊤ :=
begin
  -- We start by boiling down to a statement about close approximation.
  apply eq_top_iff.mpr,
  rintros f -,
  refine filter.frequently.mem_closure
    ((filter.has_basis.frequently_iff metric.nhds_basis_ball).mpr (λ ε pos, _)),
  simp only [exists_prop, metric.mem_ball],

  -- It will be helpful to assume `X` is nonempty later,
  -- so we get that out of the way here.
  by_cases nX : nonempty X,
  swap,
  exact ⟨nA.some, (dist_lt_iff pos).mpr (λ x, false.elim (nX ⟨x⟩)), nA.some_spec⟩,

  /-
  The strategy now is to pick a family of continuous functions `g x y` in `A`
  with the property that `g x y x = f x` and `g x y y = f y`
  (this is immediate from `h : separates_points_strongly`)
  then use continuity to see that `g x y` is close to `f` near both `x` and `y`,
  and finally using compactness to produce the desired function `h`
  as a maximum over finitely many `x` of a minimum over finitely many `y` of the `g x y`.
  -/
  dsimp [set.separates_points_strongly] at sep,

  let g : X → X → L := λ x y, (sep f x y).some,
  have w₁ : ∀ x y, g x y x = f x := λ x y, (sep f x y).some_spec.1,
  have w₂ : ∀ x y, g x y y = f y := λ x y, (sep f x y).some_spec.2,

  -- For each `x y`, we define `U x y` to be `{z | f z - ε < g x y z}`,
  -- and observe this is a neighbourhood of `y`.
  let U : X → X → set X := λ x y, {z | f z - ε < g x y z},
  have U_nhd_y : ∀ x y, U x y ∈ 𝓝 y,
  { intros x y,
    refine is_open.mem_nhds _ _,
    { apply is_open_lt; continuity, },
    { rw [set.mem_set_of_eq, w₂],
      exact sub_lt_self _ pos, }, },

  -- Fixing `x` for a moment, we have a family of functions `λ y, g x y`
  -- which on different patches (the `U x y`) are greater than `f z - ε`.
  -- Taking the supremum of these functions
  -- indexed by a finite collection of patches which cover `X`
  -- will give us an element of `A` that is globally greater than `f z - ε`
  -- and still equal to `f x` at `x`.

  -- Since `X` is compact, for every `x` there is some finset `ys t`
  -- so the union of the `U x y` for `y ∈ ys x` still covers everything.
  let ys : Π x, finset X := λ x, (compact_space.elim_nhds_subcover (U x) (U_nhd_y x)).some,
  let ys_w : ∀ x, (⋃ y ∈ ys x, U x y) = ⊤ :=
    λ x, (compact_space.elim_nhds_subcover (U x) (U_nhd_y x)).some_spec,

  have ys_nonempty : ∀ x, (ys x).nonempty :=
    λ x, set.nonempty_of_union_eq_top_of_nonempty _ _ nX (ys_w x),

  -- Thus for each `x` we have the desired `h x : A` so `f z - ε < h x z` everywhere
  -- and `h x x = f x`.
  let h : Π x, L := λ x,
    ⟨(ys x).sup' (ys_nonempty x) (λ y, (g x y : C(X, ℝ))),
      finset.sup'_mem _ sup_mem _ _ _ (λ y _, (g x y).2)⟩,
  have lt_h : ∀ x z, f z - ε < h x z,
  { intros x z,
    obtain ⟨y, ym, zm⟩ := set.exists_set_mem_of_union_eq_top _ _ (ys_w x) z,
    dsimp [h],
    simp only [coe_fn_coe_base', subtype.coe_mk, sup'_coe, finset.sup'_apply, finset.lt_sup'_iff],
    exact ⟨y, ym, zm⟩ },
  have h_eq : ∀ x, h x x = f x,
  { intro x, simp only [coe_fn_coe_base'] at w₁, simp [coe_fn_coe_base', w₁], },

  -- For each `x`, we define `W x` to be `{z | h x z < f z + ε}`,
  let W : Π x, set X := λ x, {z | h x z < f z + ε},
  -- This is still a neighbourhood of `x`.
  have W_nhd : ∀ x, W x ∈ 𝓝 x,
  { intros x,
    refine is_open.mem_nhds _ _,
    { apply is_open_lt; continuity, },
    { dsimp only [W, set.mem_set_of_eq],
      rw h_eq,
      exact lt_add_of_pos_right _ pos}, },

  -- Since `X` is compact, there is some finset `ys t`
  -- so the union of the `W x` for `x ∈ xs` still covers everything.
  let xs : finset X := (compact_space.elim_nhds_subcover W W_nhd).some,
  let xs_w : (⋃ x ∈ xs, W x) = ⊤ :=
    (compact_space.elim_nhds_subcover W W_nhd).some_spec,
  have xs_nonempty : xs.nonempty := set.nonempty_of_union_eq_top_of_nonempty _ _ nX xs_w,

  -- Finally our candidate function is the infimum over `x ∈ xs` of the `h x`.
  -- This function is then globally less than `f z + ε`.
  let k : (L : Type*) :=
    ⟨xs.inf' xs_nonempty (λ x, (h x : C(X, ℝ))),
      finset.inf'_mem _ inf_mem _ _ _ (λ x _, (h x).2)⟩,

  refine ⟨k.1, _, k.2⟩,

  -- We just need to verify the bound, which we do pointwise.
  rw dist_lt_iff pos,
  intro z,

  -- We rewrite into this particular form,
  -- so that simp lemmas about inequalities involving `finset.inf'` can fire.
  rw [(show ∀ a b ε : ℝ, dist a b < ε ↔ a < b + ε ∧ b - ε < a,
    by { intros, simp only [← metric.mem_ball, real.ball_eq_Ioo, set.mem_Ioo, and_comm], })],

  fsplit,
  { dsimp [k],
    simp only [finset.inf'_lt_iff, continuous_map.inf'_apply],
    exact set.exists_set_mem_of_union_eq_top _ _ xs_w z, },
  { dsimp [k],
    simp only [finset.lt_inf'_iff, continuous_map.inf'_apply],
    intros x xm,
    apply lt_h, },
end

/--
The **Stone-Weierstrass Approximation Theorem**,
that a subalgebra `A` of `C(X, ℝ)`, where `X` is a compact topological space,
is dense if it separates points.
-/
theorem subalgebra_topological_closure_eq_top_of_separates_points
  (A : subalgebra ℝ C(X, ℝ)) (w : A.separates_points) :
  A.topological_closure = ⊤ :=
begin
  -- The closure of `A` is closed under taking `sup` and `inf`,
  -- and separates points strongly (since `A` does),
  -- so we can apply `sublattice_closure_eq_top`.
  apply set_like.ext',
  let L := A.topological_closure,
  have n : set.nonempty (L : set C(X, ℝ)) :=
    ⟨(1 : C(X, ℝ)), A.subalgebra_topological_closure A.one_mem⟩,
  convert sublattice_closure_eq_top
    (L : set C(X, ℝ)) n
    (λ f fm g gm, inf_mem_closed_subalgebra L A.is_closed_topological_closure ⟨f, fm⟩ ⟨g, gm⟩)
    (λ f fm g gm, sup_mem_closed_subalgebra L A.is_closed_topological_closure ⟨f, fm⟩ ⟨g, gm⟩)
    (subalgebra.separates_points.strongly
      (subalgebra.separates_points_monotone (A.subalgebra_topological_closure) w)),
  { simp, },
end

/--
An alternative statement of the Stone-Weierstrass theorem.

If `A` is a subalgebra of `C(X, ℝ)` which separates points (and `X` is compact),
every real-valued continuous function on `X` is a uniform limit of elements of `A`.
-/
theorem continuous_map_mem_subalgebra_closure_of_separates_points
  (A : subalgebra ℝ C(X, ℝ)) (w : A.separates_points)
  (f : C(X, ℝ)) :
  f ∈ A.topological_closure :=
begin
  rw subalgebra_topological_closure_eq_top_of_separates_points A w,
  simp,
end

/--
An alternative statement of the Stone-Weierstrass theorem,
for those who like their epsilons.

If `A` is a subalgebra of `C(X, ℝ)` which separates points (and `X` is compact),
every real-valued continuous function on `X` is within any `ε > 0` of some element of `A`.
-/
theorem exists_mem_subalgebra_near_continuous_map_of_separates_points
  (A : subalgebra ℝ C(X, ℝ)) (w : A.separates_points)
  (f : C(X, ℝ)) (ε : ℝ) (pos : 0 < ε) :
  ∃ (g : A), ∥(g : C(X, ℝ)) - f∥ < ε :=
begin
  have w := mem_closure_iff_frequently.mp
    (continuous_map_mem_subalgebra_closure_of_separates_points A w f),
  rw metric.nhds_basis_ball.frequently_iff at w,
  obtain ⟨g, H, m⟩ := w ε pos,
  rw [metric.mem_ball, dist_eq_norm] at H,
  exact ⟨⟨g, m⟩, H⟩,
end

/--
An alternative statement of the Stone-Weierstrass theorem,
for those who like their epsilons and don't like bundled continuous functions.

If `A` is a subalgebra of `C(X, ℝ)` which separates points (and `X` is compact),
every real-valued continuous function on `X` is within any `ε > 0` of some element of `A`.
-/
theorem exists_mem_subalgebra_near_continuous_of_separates_points
  (A : subalgebra ℝ C(X, ℝ)) (w : A.separates_points)
  (f : X → ℝ) (c : continuous f) (ε : ℝ) (pos : 0 < ε) :
  ∃ (g : A), ∀ x, ∥g x - f x∥ < ε :=
begin
  obtain ⟨g, b⟩ := exists_mem_subalgebra_near_continuous_map_of_separates_points A w ⟨f, c⟩ ε pos,
  use g,
  rwa norm_lt_iff _ pos at b,
end

end continuous_map

section is_R_or_C
open is_R_or_C

-- Redefine `X`, since for the next few lemmas it need not be compact
variables {𝕜 : Type*} {X : Type*} [is_R_or_C 𝕜] [topological_space X]

namespace continuous_map

/-- A real subalgebra of `C(X, 𝕜)` is `conj_invariant`, if it contains all its conjugates. -/
def conj_invariant_subalgebra (A : subalgebra ℝ C(X, 𝕜)) : Prop :=
A.map (conj_ae.to_alg_hom.comp_left_continuous ℝ conj_cle.continuous) ≤ A

lemma mem_conj_invariant_subalgebra {A : subalgebra ℝ C(X, 𝕜)} (hA : conj_invariant_subalgebra A)
  {f : C(X, 𝕜)} (hf : f ∈ A) :
  (conj_ae.to_alg_hom.comp_left_continuous ℝ conj_cle.continuous) f ∈ A :=
hA ⟨f, hf, rfl⟩

end continuous_map

open continuous_map

/-- If a conjugation-invariant subalgebra of `C(X, 𝕜)` separates points, then the real subalgebra
of its purely real-valued elements also separates points. -/
lemma subalgebra.separates_points.is_R_or_C_to_real {A : subalgebra 𝕜 C(X, 𝕜)}
  (hA : A.separates_points) (hA' : conj_invariant_subalgebra (A.restrict_scalars ℝ)) :
  ((A.restrict_scalars ℝ).comap'
    (of_real_am.comp_left_continuous ℝ continuous_of_real)).separates_points :=
begin
  intros x₁ x₂ hx,
  -- Let `f` in the subalgebra `A` separate the points `x₁`, `x₂`
  obtain ⟨_, ⟨f, hfA, rfl⟩, hf⟩ := hA hx,
  let F : C(X, 𝕜) := f - const _ (f x₂),
  -- Subtract the constant `f x₂` from `f`; this is still an element of the subalgebra
  have hFA : F ∈ A,
  { refine A.sub_mem hfA _,
    convert A.smul_mem A.one_mem (f x₂),
    ext1,
    simp },
  -- Consider now the function `λ x, |f x - f x₂| ^ 2`
  refine ⟨_, ⟨(⟨is_R_or_C.norm_sq, continuous_norm_sq⟩ : C(𝕜, ℝ)).comp F, _, rfl⟩, _⟩,
  { -- This is also an element of the subalgebra, and takes only real values
    rw [set_like.mem_coe, subalgebra.mem_comap],
    convert (A.restrict_scalars ℝ).mul_mem (mem_conj_invariant_subalgebra hA' hFA) hFA,
    ext1,
    rw [mul_comm],
    exact (is_R_or_C.mul_conj _).symm },
  { -- And it also separates the points `x₁`, `x₂`
    have : f x₁ - f x₂ ≠ 0 := sub_ne_zero.mpr hf,
    simpa using this },
end

variables [compact_space X]

/--
The Stone-Weierstrass approximation theorem, `is_R_or_C` version,
that a subalgebra `A` of `C(X, 𝕜)`, where `X` is a compact topological space and `is_R_or_C 𝕜`,
is dense if it is conjugation-invariant and separates points.
-/
theorem continuous_map.subalgebra_is_R_or_C_topological_closure_eq_top_of_separates_points
  (A : subalgebra 𝕜 C(X, 𝕜)) (hA : A.separates_points)
  (hA' : conj_invariant_subalgebra (A.restrict_scalars ℝ)) :
  A.topological_closure = ⊤ :=
begin
  rw algebra.eq_top_iff,
  -- Let `I` be the natural inclusion of `C(X, ℝ)` into `C(X, 𝕜)`
  let I : C(X, ℝ) →ₗ[ℝ] C(X, 𝕜) := of_real_clm.comp_left_continuous ℝ X,
  -- The main point of the proof is that its range (i.e., every real-valued function) is contained
  -- in the closure of `A`
  have key : I.range ≤ (A.to_submodule.restrict_scalars ℝ).topological_closure,
  { -- Let `A₀` be the subalgebra of `C(X, ℝ)` consisting of `A`'s purely real elements; it is the
    -- preimage of `A` under `I`.  In this argument we only need its submodule structure.
    let A₀ : submodule ℝ C(X, ℝ) := (A.to_submodule.restrict_scalars ℝ).comap I,
    -- By `subalgebra.separates_points.complex_to_real`, this subalgebra also separates points, so
    -- we may apply the real Stone-Weierstrass result to it.
    have SW : A₀.topological_closure = ⊤,
    { have := subalgebra_topological_closure_eq_top_of_separates_points _
                (hA.is_R_or_C_to_real hA'),
      exact congr_arg subalgebra.to_submodule this },
    rw [← submodule.map_top, ← SW],
    -- So it suffices to prove that the image under `I` of the closure of `A₀` is contained in the
    -- closure of `A`, which follows by abstract nonsense
    have h₁ := A₀.topological_closure_map ((@of_real_clm 𝕜 _).comp_left_continuous_compact X),
    have h₂ := (A.to_submodule.restrict_scalars ℝ).map_comap_le I,
    exact h₁.trans (submodule.topological_closure_mono h₂) },
  -- In particular, for a function `f` in `C(X, 𝕜)`, the real and imaginary parts of `f` are in the
  -- closure of `A`
  intros f,
  let f_re : C(X, ℝ) := (⟨is_R_or_C.re, is_R_or_C.re_clm.continuous⟩ : C(𝕜, ℝ)).comp f,
  let f_im : C(X, ℝ) := (⟨is_R_or_C.im, is_R_or_C.im_clm.continuous⟩ : C(𝕜, ℝ)).comp f,
  have h_f_re : I f_re ∈ A.topological_closure := key ⟨f_re, rfl⟩,
  have h_f_im : I f_im ∈ A.topological_closure := key ⟨f_im, rfl⟩,
  -- So `f_re + I • f_im` is in the closure of `A`
  convert A.topological_closure.add_mem h_f_re (A.topological_closure.smul_mem h_f_im is_R_or_C.I),
  -- And this, of course, is just `f`
  ext,
  apply eq.symm,
  simp [I, mul_comm is_R_or_C.I _],
end

end is_R_or_C


<|start_filename|>src/algebra/order/rearrangement.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.order.module
import data.prod.lex
import group_theory.perm.support
import order.monovary
import tactic.abel

/-!
# Rearrangement inequality

This file proves the rearrangement inequality and deduces the conditions for equality and strict
inequality.

The rearrangement inequality tells you that for two functions `f g : ι → α`, the sum
`∑ i, f i * g (σ i)` is maximized over all `σ : perm ι` when `g ∘ σ` monovaries with `f` and
minimized when `g ∘ σ` antivaries with `f`.

The inequality also tells you that `∑ i, f i * g (σ i) = ∑ i, f i * g i` if and only if `g ∘ σ`
monovaries with `f` when `g` monovaries with `f`. The above equality also holds if and only if
`g ∘ σ` antivaries with `f` when `g` antivaries with `f`.

From the above two statements, we deduce that the inequality is strict if and only if `g ∘ σ` does
not monovary with `f` when `g` monovaries with `f`. Analogously, the inequality is strict if and
only if `g ∘ σ` does not antivary with `f` when `g` antivaries with `f`.

## Implementation notes

In fact, we don't need much compatibility between the addition and multiplication of `α`, so we can
actually decouple them by replacing multiplication with scalar multiplication and making `f` and `g`
land in different types.
As a bonus, this makes the dual statement trivial. The multiplication versions are provided for
convenience.

The case for `monotone`/`antitone` pairs of functions over a `linear_order` is not deduced in this
file because it is easily deducible from the `monovary` API.
-/

open equiv equiv.perm finset function order_dual
open_locale big_operators

variables {ι α β : Type*}

/-! ### Scalar multiplication versions -/

section smul
variables [linear_ordered_ring α] [linear_ordered_add_comm_group β] [module α β]
  [ordered_smul α β] {s : finset ι} {σ : perm ι} {f : ι → α} {g : ι → β}

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_smul_comp_perm_le_sum_smul (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) ≤ ∑ i in s, f i • g i :=
begin
  classical,
  revert hσ σ hfg,
  apply finset.induction_on_max_value (λ i, to_lex (g i, f i)) s,
  { simp only [le_rfl, finset.sum_empty, implies_true_iff] },
  intros a s has hamax hind σ hfg hσ,
  set τ : perm ι := σ.trans (swap a (σ a)) with hτ,
  have hτs : {x | τ x ≠ x} ⊆ s,
  { intros x hx,
    simp only [ne.def, set.mem_set_of_eq, equiv.coe_trans, equiv.swap_comp_apply] at hx,
    split_ifs at hx with h₁ h₂ h₃,
    { obtain rfl | hax := eq_or_ne x a,
      { contradiction },
      { exact mem_of_mem_insert_of_ne (hσ $ λ h, hax $ h.symm.trans h₁) hax } },
    { exact (hx $ σ.injective h₂.symm).elim },
    { exact mem_of_mem_insert_of_ne (hσ hx) (ne_of_apply_ne _ h₂) } },
  specialize hind (hfg.subset $ subset_insert _ _) hτs,
  simp_rw sum_insert has,
  refine le_trans _ (add_le_add_left hind _),
  obtain hσa | hσa := eq_or_ne a (σ a),
  { rw [hτ, ←hσa, swap_self, trans_refl] },
  have h1s : σ⁻¹ a ∈ s,
  { rw [ne.def, ←inv_eq_iff_eq] at hσa,
    refine mem_of_mem_insert_of_ne (hσ $ λ h, hσa _) hσa,
    rwa [apply_inv_self, eq_comm] at h },
  simp only [← s.sum_erase_add _ h1s, add_comm],
  rw [← add_assoc, ← add_assoc],
  simp only [hτ, swap_apply_left, function.comp_app, equiv.coe_trans, apply_inv_self],
  refine add_le_add (smul_add_smul_le_smul_add_smul' _ _) (sum_congr rfl $ λ x hx, _).le,
  { specialize hamax (σ⁻¹ a) h1s,
    rw prod.lex.le_iff at hamax,
    cases hamax,
    { exact hfg (mem_insert_of_mem h1s) (mem_insert_self _ _) hamax },
    { exact hamax.2 } },
  { specialize hamax (σ a) (mem_of_mem_insert_of_ne (hσ $ σ.injective.ne hσa.symm) hσa.symm),
    rw prod.lex.le_iff at hamax,
    cases hamax,
    { exact hamax.le },
    { exact hamax.1.le } },
  { rw [mem_erase, ne.def, eq_inv_iff_eq] at hx,
    rw swap_apply_of_ne_of_ne hx.1 (σ.injective.ne _),
    rintro rfl,
    exact has hx.2 }
end

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_smul_comp_perm_eq_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) = ∑ i in s, f i • g i ↔ monovary_on f (g ∘ σ) s :=
begin
  classical,
  refine ⟨not_imp_not.1 $ λ h, _, λ h, (hfg.sum_smul_comp_perm_le_sum_smul hσ).antisymm _⟩,
  { rw monovary_on at h,
    push_neg at h,
    obtain ⟨x, hx, y, hy, hgxy, hfxy⟩ := h,
    set τ : perm ι := (swap x y).trans σ,
    have hτs : {x | τ x ≠ x} ⊆ s,
    { refine (set_support_mul_subset σ $ swap x y).trans (set.union_subset hσ $ λ z hz, _),
      obtain ⟨_, rfl | rfl⟩ := swap_apply_ne_self_iff.1 hz; assumption },
    refine ((hfg.sum_smul_comp_perm_le_sum_smul hτs).trans_lt' _).ne,
    obtain rfl | hxy := eq_or_ne x y,
    { cases lt_irrefl _ hfxy },
    simp only [←s.sum_erase_add _ hx, ←(s.erase x).sum_erase_add _ (mem_erase.2 ⟨hxy.symm, hy⟩),
      add_assoc, equiv.coe_trans, function.comp_app, swap_apply_right, swap_apply_left],
    refine add_lt_add_of_le_of_lt (finset.sum_congr rfl $ λ z hz, _).le
      (smul_add_smul_lt_smul_add_smul hfxy hgxy),
    simp_rw mem_erase at hz,
    rw swap_apply_of_ne_of_ne hz.2.1 hz.1 },
  { convert h.sum_smul_comp_perm_le_sum_smul ((set_support_inv_eq _).subset.trans hσ) using 1,
    simp_rw [function.comp_app, apply_inv_self] }
end

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_smul_comp_perm_lt_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) < ∑ i in s, f i • g i ↔ ¬ monovary_on f (g ∘ σ) s :=
by simp [←hfg.sum_smul_comp_perm_eq_sum_smul_iff hσ,
  lt_iff_le_and_ne, hfg.sum_smul_comp_perm_le_sum_smul hσ]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_smul_le_sum_smul (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i ≤ ∑ i in s, f i • g i :=
begin
  convert hfg.sum_smul_comp_perm_le_sum_smul
    (show {x | σ⁻¹ x ≠ x} ⊆ s, by simp only [set_support_inv_eq, hσ]) using 1,
  exact σ.sum_comp' s (λ i j, f i • g j) hσ,
end

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_smul_eq_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i = ∑ i in s, f i • g i ↔ monovary_on (f ∘ σ) g s :=
begin
  have hσinv : {x | σ⁻¹ x ≠ x} ⊆ s := (set_support_inv_eq _).subset.trans hσ,
  refine (iff.trans _ $ hfg.sum_smul_comp_perm_eq_sum_smul_iff hσinv).trans ⟨λ h, _, λ h, _⟩,
  { simpa only [σ.sum_comp' s (λ i j, f i • g j) hσ] },
  { convert h.comp_right σ,
    { rw [comp.assoc, inv_def, symm_comp_self, comp.right_id] },
    { rw [σ.eq_preimage_iff_image_eq, set.image_perm hσ] } },
  { convert h.comp_right σ.symm,
    { rw [comp.assoc, self_comp_symm, comp.right_id] },
    { rw σ.symm.eq_preimage_iff_image_eq,
      exact set.image_perm hσinv } }
end

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_smul_lt_sum_smul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i < ∑ i in s, f i • g i ↔ ¬ monovary_on (f ∘ σ) g s :=
by simp [←hfg.sum_comp_perm_smul_eq_sum_smul_iff hσ,
  lt_iff_le_and_ne, hfg.sum_comp_perm_smul_le_sum_smul hσ]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_smul_le_sum_smul_comp_perm (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i ≤ ∑ i in s, f i • g (σ i) :=
hfg.dual_right.sum_smul_comp_perm_le_sum_smul hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_smul_eq_sum_smul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) = ∑ i in s, f i • g i ↔ antivary_on f (g ∘ σ) s :=
(hfg.dual_right.sum_smul_comp_perm_eq_sum_smul_iff hσ).trans monovary_on_to_dual_right

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_smul_lt_sum_smul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i < ∑ i in s, f i • g (σ i) ↔ ¬ antivary_on f (g ∘ σ) s :=
by simp [←hfg.sum_smul_eq_sum_smul_comp_perm_iff hσ, lt_iff_le_and_ne, eq_comm,
  hfg.sum_smul_le_sum_smul_comp_perm hσ]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_smul_le_sum_comp_perm_smul (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i ≤ ∑ i in s, f (σ i) • g i :=
hfg.dual_right.sum_comp_perm_smul_le_sum_smul hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_smul_eq_sum_comp_perm_smul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) • g i = ∑ i in s, f i • g i ↔ antivary_on (f ∘ σ) g s :=
(hfg.dual_right.sum_comp_perm_smul_eq_sum_smul_iff hσ).trans monovary_on_to_dual_right

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_smul_lt_sum_comp_perm_smul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g i < ∑ i in s, f (σ i) • g i ↔ ¬ antivary_on (f ∘ σ) g s :=
by simp [←hfg.sum_smul_eq_sum_comp_perm_smul_iff hσ, eq_comm, lt_iff_le_and_ne,
  hfg.sum_smul_le_sum_comp_perm_smul hσ]

variables [fintype ι]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_smul_comp_perm_le_sum_smul (hfg : monovary f g) :
  ∑ i, f i • g (σ i) ≤ ∑ i, f i • g i :=
(hfg.monovary_on _).sum_smul_comp_perm_le_sum_smul $ λ i _, mem_univ _

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_smul_comp_perm_eq_sum_smul_iff (hfg : monovary f g) :
  ∑ i, f i • g (σ i) = ∑ i, f i • g i ↔ monovary f (g ∘ σ) :=
by simp [(hfg.monovary_on _).sum_smul_comp_perm_eq_sum_smul_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_smul_comp_perm_lt_sum_smul_iff (hfg : monovary f g) :
  ∑ i, f i • g (σ i) < ∑ i, f i • g i ↔ ¬ monovary f (g ∘ σ) :=
by simp [(hfg.monovary_on _).sum_smul_comp_perm_lt_sum_smul_iff (λ i _, mem_univ _)]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is maximized when
`f` and `g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary.sum_comp_perm_smul_le_sum_smul (hfg : monovary f g) :
  ∑ i, f (σ i) • g i ≤ ∑ i, f i • g i :=
(hfg.monovary_on _).sum_comp_perm_smul_le_sum_smul $ λ i _, mem_univ _

/-- **Equality case of Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_smul_eq_sum_smul_iff (hfg : monovary f g) :
  ∑ i, f (σ i) • g i = ∑ i, f i • g i ↔ monovary (f ∘ σ) g :=
by simp [(hfg.monovary_on _).sum_comp_perm_smul_eq_sum_smul_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_smul_lt_sum_smul_iff (hfg : monovary f g) :
   ∑ i, f (σ i) • g i < ∑ i, f i • g i ↔ ¬ monovary (f ∘ σ) g :=
by simp [(hfg.monovary_on _).sum_comp_perm_smul_lt_sum_smul_iff (λ i _, mem_univ _)]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_smul_le_sum_smul_comp_perm (hfg : antivary f g) :
  ∑ i, f i • g i ≤ ∑ i, f i • g (σ i) :=
(hfg.antivary_on _).sum_smul_le_sum_smul_comp_perm $ λ i _, mem_univ _

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_smul_eq_sum_smul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i • g (σ i) = ∑ i, f i • g i ↔ antivary f (g ∘ σ) :=
by simp [(hfg.antivary_on _).sum_smul_eq_sum_smul_comp_perm_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_smul_lt_sum_smul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i • g i < ∑ i, f i • g (σ i) ↔ ¬ antivary f (g ∘ σ) :=
by simp [(hfg.antivary_on _).sum_smul_lt_sum_smul_comp_perm_iff (λ i _, mem_univ _)]

/-- **Rearrangement Inequality**: Pointwise scalar multiplication of `f` and `g` is minimized when
`f` and `g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_smul_le_sum_comp_perm_smul (hfg : antivary f g) :
  ∑ i, f i • g i ≤ ∑ i, f (σ i) • g i :=
(hfg.antivary_on _).sum_smul_le_sum_comp_perm_smul $ λ i _, mem_univ _

/-- **Equality case of the Rearrangement Inequality**: Pointwise scalar multiplication of `f` and
`g`, which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_smul_eq_sum_comp_perm_smul_iff (hfg : antivary f g) :
  ∑ i, f (σ i) • g i = ∑ i, f i • g i ↔ antivary (f ∘ σ) g :=
by simp [(hfg.antivary_on _).sum_smul_eq_sum_comp_perm_smul_iff (λ i _, mem_univ _)]

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_smul_lt_sum_comp_perm_smul_iff (hfg : antivary f g) :
  ∑ i, f i • g i < ∑ i, f (σ i) • g i ↔ ¬ antivary (f ∘ σ) g :=
by simp [(hfg.antivary_on _).sum_smul_lt_sum_comp_perm_smul_iff (λ i _, mem_univ _)]

end smul

/-!
### Multiplication versions

Special cases of the above when scalar multiplication is actually multiplication.
-/

section mul
variables [linear_ordered_ring α] {s : finset ι} {σ : perm ι} {f g : ι → α}

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_mul_comp_perm_le_sum_mul (hfg : monovary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g (σ i) ≤ ∑ i in s, f i * g i :=
hfg.sum_smul_comp_perm_le_sum_smul hσ

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_mul_comp_perm_eq_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g (σ i) = ∑ i in s, f i * g i ↔ monovary_on f (g ∘ σ) s :=
hfg.sum_smul_comp_perm_eq_sum_smul_iff hσ

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise scalar multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary_on.sum_mul_comp_perm_lt_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i • g (σ i) < ∑ i in s, f i • g i ↔ ¬ monovary_on f (g ∘ σ) s :=
hfg.sum_smul_comp_perm_lt_sum_smul_iff hσ

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_mul_le_sum_mul (hfg : monovary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i ≤ ∑ i in s, f i * g i :=
hfg.sum_comp_perm_smul_le_sum_smul hσ

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_mul_eq_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i = ∑ i in s, f i * g i ↔ monovary_on (f ∘ σ) g s :=
hfg.sum_comp_perm_smul_eq_sum_smul_iff hσ

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not monovary together. Stated by permuting the entries of `f`. -/
lemma monovary_on.sum_comp_perm_mul_lt_sum_mul_iff (hfg : monovary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i < ∑ i in s, f i * g i ↔ ¬ monovary_on (f ∘ σ) g s :=
hfg.sum_comp_perm_smul_lt_sum_smul_iff hσ

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_mul_le_sum_mul_comp_perm (hfg : antivary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i ≤ ∑ i in s, f i * g (σ i) :=
hfg.sum_smul_le_sum_smul_comp_perm hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_mul_eq_sum_mul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g (σ i) = ∑ i in s, f i * g i ↔ antivary_on f (g ∘ σ) s :=
hfg.sum_smul_eq_sum_smul_comp_perm_iff hσ

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary_on.sum_mul_lt_sum_mul_comp_perm_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i < ∑ i in s, f i * g (σ i) ↔ ¬ antivary_on f (g ∘ σ) s :=
hfg.sum_smul_lt_sum_smul_comp_perm_iff hσ

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_mul_le_sum_comp_perm_mul (hfg : antivary_on f g s) (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i ≤ ∑ i in s, f (σ i) * g i :=
hfg.sum_smul_le_sum_comp_perm_smul hσ

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_mul_eq_sum_comp_perm_mul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f (σ i) * g i = ∑ i in s, f i * g i ↔ antivary_on (f ∘ σ) g s :=
hfg.sum_smul_eq_sum_comp_perm_smul_iff hσ

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary_on.sum_mul_lt_sum_comp_perm_mul_iff (hfg : antivary_on f g s)
  (hσ : {x | σ x ≠ x} ⊆ s) :
  ∑ i in s, f i * g i < ∑ i in s, f (σ i) * g i ↔ ¬ antivary_on (f ∘ σ) g s :=
hfg.sum_smul_lt_sum_comp_perm_smul_iff hσ

variables [fintype ι]

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_mul_comp_perm_le_sum_mul (hfg : monovary f g) :
  ∑ i, f i * g (σ i) ≤ ∑ i, f i * g i :=
hfg.sum_smul_comp_perm_le_sum_smul

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_mul_comp_perm_eq_sum_mul_iff (hfg : monovary f g) :
  ∑ i, f i * g (σ i) = ∑ i, f i * g i ↔ monovary f (g ∘ σ) :=
hfg.sum_smul_comp_perm_eq_sum_smul_iff

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_mul_comp_perm_lt_sum_mul_iff (hfg : monovary f g) :
  ∑ i, f i * g (σ i) < ∑ i, f i * g i ↔ ¬ monovary f (g ∘ σ) :=
hfg.sum_smul_comp_perm_lt_sum_smul_iff

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is maximized when `f` and
`g` monovary together. Stated by permuting the entries of `f`. -/
lemma monovary.sum_comp_perm_mul_le_sum_mul (hfg : monovary f g) :
  ∑ i, f (σ i) * g i ≤ ∑ i, f i * g i :=
hfg.sum_comp_perm_smul_le_sum_smul

/-- **Equality case of Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which monovary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` monovary
together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_mul_eq_sum_mul_iff (hfg : monovary f g) :
  ∑ i, f (σ i) * g i = ∑ i, f i * g i ↔ monovary (f ∘ σ) g :=
hfg.sum_comp_perm_smul_eq_sum_smul_iff

/-- **Strict inequality case of Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which monovary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not monovary together. Stated by permuting the entries of `g`. -/
lemma monovary.sum_comp_perm_mul_lt_sum_mul_iff (hfg : monovary f g) :
   ∑ i, f (σ i) * g i < ∑ i, f i * g i ↔ ¬ monovary (f ∘ σ) g :=
hfg.sum_comp_perm_smul_lt_sum_smul_iff

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_mul_le_sum_mul_comp_perm (hfg : antivary f g) :
  ∑ i, f i * g i ≤ ∑ i, f i * g (σ i) :=
hfg.sum_smul_le_sum_smul_comp_perm

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f` and `g ∘ σ` antivary
together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_mul_eq_sum_mul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i * g (σ i) = ∑ i, f i * g i ↔ antivary f (g ∘ σ) :=
hfg.sum_smul_eq_sum_smul_comp_perm_iff

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f` and `g ∘ σ` do not antivary together. Stated by permuting the entries of `g`. -/
lemma antivary.sum_mul_lt_sum_mul_comp_perm_iff (hfg : antivary f g) :
  ∑ i, f i • g i < ∑ i, f i • g (σ i) ↔ ¬ antivary f (g ∘ σ) :=
hfg.sum_smul_lt_sum_smul_comp_perm_iff

/-- **Rearrangement Inequality**: Pointwise multiplication of `f` and `g` is minimized when `f` and
`g` antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_mul_le_sum_comp_perm_mul (hfg : antivary f g) :
  ∑ i, f i * g i ≤ ∑ i, f (σ i) * g i :=
hfg.sum_smul_le_sum_comp_perm_smul

/-- **Equality case of the Rearrangement Inequality**: Pointwise multiplication of `f` and `g`,
which antivary together, is unchanged by a permutation if and only if `f ∘ σ` and `g` antivary
together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_mul_eq_sum_comp_perm_mul_iff (hfg : antivary f g) :
  ∑ i, f (σ i) * g i = ∑ i, f i * g i ↔ antivary (f ∘ σ) g :=
hfg.sum_smul_eq_sum_comp_perm_smul_iff

/-- **Strict inequality case of the Rearrangement Inequality**: Pointwise multiplication of
`f` and `g`, which antivary together, is strictly decreased by a permutation if and only if
`f ∘ σ` and `g` do not antivary together. Stated by permuting the entries of `f`. -/
lemma antivary.sum_mul_lt_sum_comp_perm_mul_iff (hfg : antivary f g) :
  ∑ i, f i * g i < ∑ i, f (σ i) * g i ↔ ¬ antivary (f ∘ σ) g :=
hfg.sum_smul_lt_sum_comp_perm_smul_iff

end mul


<|start_filename|>src/algebra/category/Module/biproducts.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.group.pi
import category_theory.limits.shapes.biproducts
import algebra.category.Module.limits
import algebra.homology.short_exact.abelian

/-!
# The category of `R`-modules has finite biproducts
-/

open category_theory
open category_theory.limits

open_locale big_operators

universes v u

namespace Module

variables {R : Type u} [ring R]

-- As `Module R` is preadditive, and has all limits, it automatically has biproducts.
instance : has_binary_biproducts (Module.{v} R) :=
has_binary_biproducts.of_has_binary_products

instance : has_finite_biproducts (Module.{v} R) :=
has_finite_biproducts.of_has_finite_products

-- We now construct explicit limit data,
-- so we can compare the biproducts to the usual unbundled constructions.

/--
Construct limit data for a binary product in `Module R`, using `Module.of R (M × N)`.
-/
@[simps cone_X is_limit_lift]
def binary_product_limit_cone (M N : Module.{v} R) : limits.limit_cone (pair M N) :=
{ cone :=
  { X := Module.of R (M × N),
    π :=
    { app := λ j, discrete.cases_on j
        (λ j, walking_pair.cases_on j (linear_map.fst R M N) (linear_map.snd R M N)),
      naturality' := by rintros ⟨⟨⟩⟩ ⟨⟨⟩⟩ ⟨⟨⟨⟩⟩⟩; refl,  }},
  is_limit :=
  { lift := λ s, linear_map.prod (s.π.app ⟨walking_pair.left⟩) (s.π.app ⟨walking_pair.right⟩),
    fac' := by { rintros s (⟨⟩|⟨⟩); { ext x, simp, }, },
    uniq' := λ s m w,
    begin
      ext; [rw ← w ⟨walking_pair.left⟩, rw ← w ⟨walking_pair.right⟩]; refl,
    end, } }

@[simp] lemma binary_product_limit_cone_cone_π_app_left (M N : Module.{v} R) :
  (binary_product_limit_cone M N).cone.π.app ⟨walking_pair.left⟩ = linear_map.fst R M N := rfl

@[simp] lemma binary_product_limit_cone_cone_π_app_right (M N : Module.{v} R) :
  (binary_product_limit_cone M N).cone.π.app ⟨walking_pair.right⟩ = linear_map.snd R M N := rfl

/--
We verify that the biproduct in `Module R` is isomorphic to
the cartesian product of the underlying types:
-/
@[simps hom_apply] noncomputable
def biprod_iso_prod (M N : Module.{v} R) : (M ⊞ N : Module.{v} R) ≅ Module.of R (M × N) :=
is_limit.cone_point_unique_up_to_iso
  (binary_biproduct.is_limit M N)
  (binary_product_limit_cone M N).is_limit

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_fst (M N : Module.{v} R) :
  (biprod_iso_prod M N).inv ≫ biprod.fst = linear_map.fst R M N :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.left)

@[simp, elementwise] lemma biprod_iso_prod_inv_comp_snd (M N : Module.{v} R) :
  (biprod_iso_prod M N).inv ≫ biprod.snd = linear_map.snd R M N :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk walking_pair.right)

variables {J : Type v} (f : J → Module.{v} R)

namespace has_limit

/--
The map from an arbitrary cone over a indexed family of abelian groups
to the cartesian product of those groups.
-/
@[simps]
def lift (s : fan f) :
  s.X ⟶ Module.of R (Π j, f j) :=
{ to_fun := λ x j, s.π.app ⟨j⟩ x,
  map_add' := λ x y, by { ext, simp, },
  map_smul' := λ r x, by { ext, simp, }, }

/--
Construct limit data for a product in `Module R`, using `Module.of R (Π j, F.obj j)`.
-/
@[simps] def product_limit_cone : limits.limit_cone (discrete.functor f) :=
{ cone :=
  { X := Module.of R (Π j, f j),
    π := discrete.nat_trans (λ j, (linear_map.proj j.as : (Π j, f j) →ₗ[R] f j.as)), },
  is_limit :=
  { lift := lift f,
    fac' := λ s j, by { cases j, ext, simp, },
    uniq' := λ s m w,
    begin
      ext x j,
      dsimp only [has_limit.lift],
      simp only [linear_map.coe_mk],
      exact congr_arg (λ g : s.X ⟶ f j, (g : s.X → f j) x) (w ⟨j⟩),
    end, }, }

end has_limit

open has_limit

/--
We verify that the biproduct we've just defined is isomorphic to the `Module R` structure
on the dependent function type
-/
@[simps hom_apply] noncomputable
def biproduct_iso_pi [fintype J] (f : J → Module.{v} R) :
  (⨁ f : Module.{v} R) ≅ Module.of R (Π j, f j) :=
is_limit.cone_point_unique_up_to_iso
  (biproduct.is_limit f)
  (product_limit_cone f).is_limit

@[simp, elementwise] lemma biproduct_iso_pi_inv_comp_π [fintype J]
  (f : J → Module.{v} R) (j : J) :
  (biproduct_iso_pi f).inv ≫ biproduct.π f j = (linear_map.proj j : (Π j, f j) →ₗ[R] f j) :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ (discrete.mk j)

end Module

section split_exact

variables {R : Type u} {A M B : Type v} [ring R] [add_comm_group A] [module R A]
  [add_comm_group B] [module R B] [add_comm_group M] [module R M]
variables {j : A →ₗ[R] M} {g : M →ₗ[R] B}
open Module

/--The isomorphism `A × B ≃ₗ[R] M` coming from a right split exact sequence `0 ⟶ A ⟶ M ⟶ B ⟶ 0`
of modules.-/
noncomputable def lequiv_prod_of_right_split_exact {f : B →ₗ[R] M}
  (hj : function.injective j) (exac : j.range = g.ker) (h : g.comp f = linear_map.id) :
  (A × B) ≃ₗ[R] M :=
(({ right_split := ⟨as_hom f, h⟩,
    mono := (Module.mono_iff_injective $ as_hom j).mpr hj,
    exact := (exact_iff _ _).mpr exac } : right_split _ _).splitting.iso.trans $
  biprod_iso_prod _ _).to_linear_equiv.symm

/--The isomorphism `A × B ≃ₗ[R] M` coming from a left split exact sequence `0 ⟶ A ⟶ M ⟶ B ⟶ 0`
of modules.-/
noncomputable def lequiv_prod_of_left_split_exact {f : M →ₗ[R] A}
  (hg : function.surjective g) (exac : j.range = g.ker) (h : f.comp j = linear_map.id) :
  (A × B) ≃ₗ[R] M :=
(({ left_split := ⟨as_hom f, h⟩,
    epi := (Module.epi_iff_surjective $ as_hom g).mpr hg,
    exact := (exact_iff _ _).mpr exac } : left_split _ _).splitting.iso.trans $
  biprod_iso_prod _ _).to_linear_equiv.symm

end split_exact


<|start_filename|>src/set_theory/ordinal/natural_ops.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import set_theory.ordinal.arithmetic

/-!
# Natural operations on ordinals

The goal of this file is to define natural addition and multiplication on ordinals, also known as
the Hessenberg sum and product, and provide a basic API. The natural addition of two ordinals
`a ♯ b` is recursively defined as the least ordinal greater than `a' ♯ b` and `a ♯ b'` for `a' < a`
and `b' < b`. The natural multiplication `a ⨳ b` is likewise recursively defined as the least
ordinal such that `a ⨳ b ♯ a' ⨳ b'` is greater than `a' ⨳ b ♯ a ⨳ b'` for any `a' < a` and
`b' < b`.

These operations form a rich algebraic structure: they're commutative, associative, preserve order,
have the usual `0` and `1` from ordinals, and distribute over one another.

Moreover, these operations are the addition and multiplication of ordinals when viewed as
combinatorial `game`s. This makes them particularly useful for game theory.

Finally, both operations admit simple, intuitive descriptions in terms of the Cantor normal form.
The natural addition of two ordinals corresponds to adding their Cantor normal forms as if they were
polynomials in `ω`. Likewise, their natural multiplication corresponds to multiplying the Cantor
normal forms as polynomials.

# Implementation notes

Given the rich algebraic structure of these two operations, we choose to create a type synonym
`nat_ordinal`, where we provide the appropriate instances. However, to avoid casting back and forth
between both types, we attempt to prove and state most results on `ordinal`.

# Todo

- Define natural multiplication and provide a basic API.
- Prove the characterizations of natural addition and multiplication in terms of the Cantor normal
  form.
-/

universes u v

open function order

noncomputable theory

/-- A type synonym for ordinals with natural addition and multiplication. -/
def nat_ordinal : Type* := ordinal

instance : linear_order nat_ordinal := ordinal.linear_order

/-- The identity function between `ordinal` and `nat_ordinal`. -/
@[pattern] def ordinal.to_nat_ordinal : ordinal ≃o nat_ordinal := order_iso.refl _

/-- The identity function between `nat_ordinal` and `ordinal`. -/
@[pattern] def nat_ordinal.to_ordinal : nat_ordinal ≃o ordinal := order_iso.refl _

open ordinal

namespace nat_ordinal

variables {a b c : nat_ordinal.{u}}

@[simp] theorem to_ordinal_symm_eq : nat_ordinal.to_ordinal.symm = ordinal.to_nat_ordinal := rfl
@[simp] theorem to_ordinal_to_nat_ordinal (a : nat_ordinal) : a.to_ordinal.to_nat_ordinal = a := rfl

instance : has_zero nat_ordinal := ⟨to_nat_ordinal 0⟩
instance : inhabited nat_ordinal := ⟨0⟩
instance : has_one nat_ordinal := ⟨to_nat_ordinal 1⟩
instance : succ_order nat_ordinal := ordinal.succ_order

theorem lt_wf : @well_founded nat_ordinal (<) := ordinal.lt_wf
instance : has_well_founded nat_ordinal := ordinal.has_well_founded
instance : is_well_order nat_ordinal (<) := ordinal.has_lt.lt.is_well_order

@[simp] theorem to_ordinal_zero : to_ordinal 0 = 0 := rfl
@[simp] theorem to_ordinal_one : to_ordinal 1 = 1 := rfl

@[simp] theorem to_ordinal_eq_zero (a) : to_ordinal a = 0 ↔ a = 0 := iff.rfl
@[simp] theorem to_ordinal_eq_one (a) : to_ordinal a = 1 ↔ a = 1 := iff.rfl

@[simp] theorem to_ordinal_max : (max a b).to_ordinal = max a.to_ordinal b.to_ordinal := rfl
@[simp] theorem to_ordinal_min : (min a b).to_ordinal = min a.to_ordinal b.to_ordinal := rfl

theorem succ_def (a : nat_ordinal) : succ a = (a.to_ordinal + 1).to_nat_ordinal := rfl

/-- A recursor for `nat_ordinal`. Use as `induction x using nat_ordinal.rec`. -/
protected def rec {β : nat_ordinal → Sort*} (h : Π a, β (to_nat_ordinal a)) : Π a, β a :=
λ a, h a.to_ordinal

/-- `ordinal.induction` but for `nat_ordinal`. -/
theorem induction {p : nat_ordinal → Prop} : ∀ i (h : ∀ j, (∀ k, k < j → p k) → p j), p i :=
ordinal.induction

end nat_ordinal

namespace ordinal

variables {a b c : ordinal.{u}}

@[simp] theorem to_nat_ordinal_symm_eq : to_nat_ordinal.symm = nat_ordinal.to_ordinal := rfl
@[simp] theorem to_nat_ordinal_to_ordinal (a : ordinal) : a.to_nat_ordinal.to_ordinal = a := rfl

@[simp] theorem to_nat_ordinal_zero : to_nat_ordinal 0 = 0 := rfl
@[simp] theorem to_nat_ordinal_one : to_nat_ordinal 1 = 1 := rfl

@[simp] theorem to_nat_ordinal_eq_zero (a) : to_nat_ordinal a = 0 ↔ a = 0 := iff.rfl
@[simp] theorem to_nat_ordinal_eq_one (a) : to_nat_ordinal a = 1 ↔ a = 1 := iff.rfl

@[simp] theorem to_nat_ordinal_max :
  to_nat_ordinal (max a b) = max a.to_nat_ordinal b.to_nat_ordinal := rfl
@[simp] theorem to_nat_ordinal_min :
  (linear_order.min a b).to_nat_ordinal = linear_order.min a.to_nat_ordinal b.to_nat_ordinal := rfl

/-- Natural addition on ordinals `a ♯ b`, also known as the Hessenberg sum, is recursively defined
as the least ordinal greater than `a' ♯ b` and `a ♯ b'` for all `a' < a` and `b' < b`. In contrast
to normal ordinal addition, it is commutative.

Natural addition can equivalently be characterized as the ordinal resulting from adding up
corresponding coefficients in the Cantor normal forms of `a` and `b`. -/
noncomputable def nadd : ordinal → ordinal → ordinal
| a b := max
  (blsub.{u u} a $ λ a' h, nadd a' b)
  (blsub.{u u} b $ λ b' h, nadd a b')
using_well_founded { dec_tac := `[solve_by_elim [psigma.lex.left, psigma.lex.right]] }

local infix ` ♯ `:65 := nadd

theorem nadd_def (a b : ordinal) : a ♯ b = max
  (blsub.{u u} a $ λ a' h, a' ♯ b)
  (blsub.{u u} b $ λ b' h, a ♯ b') :=
by rw nadd

theorem lt_nadd_iff : a < b ♯ c ↔ (∃ b' < b, a ≤ b' ♯ c) ∨ ∃ c' < c, a ≤ b ♯ c' :=
by { rw nadd_def, simp [lt_blsub_iff] }

theorem nadd_le_iff : b ♯ c ≤ a ↔ (∀ b' < b, b' ♯ c < a) ∧ ∀ c' < c, b ♯ c' < a :=
by { rw nadd_def, simp [blsub_le_iff] }

theorem nadd_lt_nadd_left (h : b < c) (a) : a ♯ b < a ♯ c :=
lt_nadd_iff.2 (or.inr ⟨b, h, le_rfl⟩)

theorem nadd_lt_nadd_right (h : b < c) (a) : b ♯ a < c ♯ a :=
lt_nadd_iff.2 (or.inl ⟨b, h, le_rfl⟩)

theorem nadd_le_nadd_left (h : b ≤ c) (a) : a ♯ b ≤ a ♯ c :=
begin
  rcases lt_or_eq_of_le h with h | rfl,
  { exact (nadd_lt_nadd_left h a).le },
  { exact le_rfl }
end

theorem nadd_le_nadd_right (h : b ≤ c) (a) : b ♯ a ≤ c ♯ a :=
begin
  rcases lt_or_eq_of_le h with h | rfl,
  { exact (nadd_lt_nadd_right h a).le },
  { exact le_rfl }
end

variables (a b)

theorem nadd_comm : ∀ a b, a ♯ b = b ♯ a
| a b := begin
  rw [nadd_def, nadd_def, max_comm],
  congr; ext c hc;
  apply nadd_comm
end
using_well_founded { dec_tac := `[solve_by_elim [psigma.lex.left, psigma.lex.right]] }

theorem blsub_nadd_of_mono {f : Π c < a ♯ b, ordinal.{max u v}}
  (hf : ∀ {i j} hi hj, i ≤ j → f i hi ≤ f j hj) : blsub _ f = max
  (blsub.{u v} a (λ a' ha', f (a' ♯ b) $ nadd_lt_nadd_right ha' b))
  (blsub.{u v} b (λ b' hb', f (a ♯ b') $ nadd_lt_nadd_left hb' a)) :=
begin
  apply (blsub_le_iff.2 (λ i h, _)).antisymm (max_le _ _),
  { rcases lt_nadd_iff.1 h with ⟨a', ha', hi⟩ | ⟨b', hb', hi⟩,
    { exact lt_max_of_lt_left ((hf h (nadd_lt_nadd_right ha' b) hi).trans_lt (lt_blsub _ _ _)) },
    { exact lt_max_of_lt_right ((hf h (nadd_lt_nadd_left hb' a) hi).trans_lt (lt_blsub _ _ _)) } },
  all_goals
  { apply blsub_le_of_brange_subset.{u u v},
    rintro c ⟨d, hd, rfl⟩,
    apply mem_brange_self }
end

theorem nadd_assoc : ∀ a b c, a ♯ b ♯ c = a ♯ (b ♯ c)
| a b c := begin
  rw [nadd_def a (b ♯ c), nadd_def, blsub_nadd_of_mono, blsub_nadd_of_mono, max_assoc],
  { congr; ext d hd;
    apply nadd_assoc },
  { exact λ i j _ _ h, nadd_le_nadd_left h a },
  { exact λ i j _ _ h, nadd_le_nadd_right h c }
end
using_well_founded { dec_tac := `[solve_by_elim [psigma.lex.left, psigma.lex.right]] }

@[simp] theorem nadd_zero : a ♯ 0 = a :=
begin
  induction a using ordinal.induction with a IH,
  rw [nadd_def, blsub_zero, max_zero_right],
  convert blsub_id a,
  ext b hb,
  exact IH _ hb
end

@[simp] theorem zero_nadd : 0 ♯ a = a :=
by rw [nadd_comm, nadd_zero]

@[simp] theorem nadd_one : a ♯ 1 = succ a :=
begin
  induction a using ordinal.induction with a IH,
  rw [nadd_def, blsub_one, nadd_zero, max_eq_right_iff, blsub_le_iff],
  intros i hi,
  rwa [IH i hi, succ_lt_succ_iff]
end

@[simp] theorem one_nadd : 1 ♯ a = succ a :=
by rw [nadd_comm, nadd_one]

theorem nadd_succ : a ♯ succ b = succ (a ♯ b) :=
by rw [←nadd_one (a ♯ b), nadd_assoc, nadd_one]

theorem succ_nadd : succ a ♯ b = succ (a ♯ b) :=
by rw [←one_nadd (a ♯ b), ←nadd_assoc, one_nadd]

@[simp] theorem nadd_nat (n : ℕ) : a ♯ n = a + n :=
begin
  induction n with n hn,
  { simp },
  { rw [nat.cast_succ, add_one_eq_succ, nadd_succ, add_succ, hn] }
end

@[simp] theorem nat_nadd (n : ℕ) : ↑n ♯ a = a + n :=
by rw [nadd_comm, nadd_nat]

theorem add_le_nadd : a + b ≤ a ♯ b :=
begin
  apply b.limit_rec_on,
  { simp },
  { intros c h,
    rwa [add_succ, nadd_succ, succ_le_succ_iff] },
  { intros c hc H,
    rw [←is_normal.blsub_eq.{u u} (add_is_normal a) hc, blsub_le_iff],
    exact λ i hi, (H i hi).trans_lt (nadd_lt_nadd_left hi a) }
end

end ordinal

open ordinal

namespace nat_ordinal

instance : has_add nat_ordinal := ⟨nadd⟩

instance add_covariant_class_lt :
  covariant_class nat_ordinal.{u} nat_ordinal.{u} (+) (<) :=
⟨λ a b c h, nadd_lt_nadd_left h a⟩

instance add_covariant_class_le :
  covariant_class nat_ordinal.{u} nat_ordinal.{u} (+) (≤) :=
⟨λ a b c h, nadd_le_nadd_left h a⟩

instance add_contravariant_class_le :
  contravariant_class nat_ordinal.{u} nat_ordinal.{u} (+) (≤) :=
⟨λ a b c h, by { by_contra' h', exact h.not_lt (add_lt_add_left h' a) }⟩

instance : ordered_cancel_add_comm_monoid nat_ordinal :=
{ add := (+),
  add_assoc := nadd_assoc,
  add_left_cancel := λ a b c, add_left_cancel'',
  add_le_add_left := λ a b, add_le_add_left,
  le_of_add_le_add_left := λ a b c, le_of_add_le_add_left,
  zero := 0,
  zero_add := zero_nadd,
  add_zero := nadd_zero,
  add_comm := nadd_comm,
  ..nat_ordinal.linear_order }

@[simp] theorem add_one_eq_succ : ∀ a : nat_ordinal, a + 1 = succ a := nadd_one

@[simp] theorem to_ordinal_cast_nat (n : ℕ) : to_ordinal n = n :=
begin
  induction n with n hn,
  { refl },
  { change nadd (to_ordinal n) 1 = n + 1,
    rw hn,
    apply nadd_one }
end

end nat_ordinal

open nat_ordinal

namespace ordinal

local infix ` ♯ `:65 := nadd

@[simp] theorem to_nat_ordinal_cast_nat (n : ℕ) : to_nat_ordinal n = n :=
by { rw ←to_ordinal_cast_nat n, refl }

theorem lt_of_nadd_lt_nadd_left : ∀ {a b c}, a ♯ b < a ♯ c → b < c :=
@lt_of_add_lt_add_left nat_ordinal _ _ _
theorem lt_of_nadd_lt_nadd_right : ∀ {a b c}, b ♯ a < c ♯ a → b < c :=
@_root_.lt_of_add_lt_add_right nat_ordinal _ _ _
theorem le_of_nadd_le_nadd_left : ∀ {a b c}, a ♯ b ≤ a ♯ c → b ≤ c :=
@le_of_add_le_add_left nat_ordinal _ _ _
theorem le_of_nadd_le_nadd_right : ∀ {a b c}, b ♯ a ≤ c ♯ a → b ≤ c :=
@le_of_add_le_add_right nat_ordinal _ _ _

theorem nadd_lt_nadd_iff_left : ∀ a {b c}, a ♯ b < a ♯ c ↔ b < c :=
@add_lt_add_iff_left nat_ordinal _ _ _ _
theorem nadd_lt_nadd_iff_right : ∀ a {b c}, b ♯ a < c ♯ a ↔ b < c :=
@add_lt_add_iff_right nat_ordinal _ _ _ _
theorem nadd_le_nadd_iff_left : ∀ a {b c}, a ♯ b ≤ a ♯ c ↔ b ≤ c :=
@add_le_add_iff_left nat_ordinal _ _ _ _
theorem nadd_le_nadd_iff_right : ∀ a {b c}, b ♯ a ≤ c ♯ a ↔ b ≤ c :=
@_root_.add_le_add_iff_right nat_ordinal _ _ _ _

theorem nadd_left_cancel : ∀ {a b c}, a ♯ b = a ♯ c → b = c :=
@_root_.add_left_cancel nat_ordinal _
theorem nadd_right_cancel : ∀ {a b c}, a ♯ b = c ♯ b → a = c :=
@_root_.add_right_cancel nat_ordinal _
theorem nadd_left_cancel_iff : ∀ {a b c}, a ♯ b = a ♯ c ↔ b = c :=
@add_left_cancel_iff nat_ordinal _
theorem nadd_right_cancel_iff : ∀ {a b c}, b ♯ a = c ♯ a ↔ b = c :=
@add_right_cancel_iff nat_ordinal _

end ordinal


<|start_filename|>src/data/finset/powerset.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.finset.lattice

/-!
# The powerset of a finset
-/

namespace finset
open multiset

variables {α : Type*}

/-! ### powerset -/
section powerset

/-- When `s` is a finset, `s.powerset` is the finset of all subsets of `s` (seen as finsets). -/
def powerset (s : finset α) : finset (finset α) :=
⟨s.1.powerset.pmap finset.mk $ λ t h, nodup_of_le (mem_powerset.1 h) s.nodup,
 s.nodup.powerset.pmap $ λ a ha b hb, congr_arg finset.val⟩

@[simp] theorem mem_powerset {s t : finset α} : s ∈ powerset t ↔ s ⊆ t :=
by cases s; simp only [powerset, mem_mk, mem_pmap, mem_powerset, exists_prop, exists_eq_right];
  rw ← val_le_iff

@[simp] theorem empty_mem_powerset (s : finset α) : ∅ ∈ powerset s :=
mem_powerset.2 (empty_subset _)

@[simp] theorem mem_powerset_self (s : finset α) : s ∈ powerset s :=
mem_powerset.2 (subset.refl _)

@[simp] lemma powerset_empty : finset.powerset (∅ : finset α) = {∅} := rfl

@[simp] theorem powerset_mono {s t : finset α} : powerset s ⊆ powerset t ↔ s ⊆ t :=
⟨λ h, (mem_powerset.1 $ h $ mem_powerset_self _),
 λ st u h, mem_powerset.2 $ subset.trans (mem_powerset.1 h) st⟩

/-- **Number of Subsets of a Set** -/
@[simp] theorem card_powerset (s : finset α) :
  card (powerset s) = 2 ^ card s :=
(card_pmap _ _ _).trans (card_powerset s.1)

lemma not_mem_of_mem_powerset_of_not_mem {s t : finset α} {a : α}
  (ht : t ∈ s.powerset) (h : a ∉ s) : a ∉ t :=
by { apply mt _ h, apply mem_powerset.1 ht }

lemma powerset_insert [decidable_eq α] (s : finset α) (a : α) :
  powerset (insert a s) = s.powerset ∪ s.powerset.image (insert a) :=
begin
  ext t,
  simp only [exists_prop, mem_powerset, mem_image, mem_union, subset_insert_iff],
  by_cases h : a ∈ t,
  { split,
    { exact λH, or.inr ⟨_, H, insert_erase h⟩ },
    { intros H,
      cases H,
      { exact subset.trans (erase_subset a t) H },
      { rcases H with ⟨u, hu⟩,
        rw ← hu.2,
        exact subset.trans (erase_insert_subset a u) hu.1 } } },
  { have : ¬ ∃ (u : finset α), u ⊆ s ∧ insert a u = t,
      by simp [ne.symm (ne_insert_of_not_mem _ _ h)],
    simp [finset.erase_eq_of_not_mem h, this] }
end

/-- For predicate `p` decidable on subsets, it is decidable whether `p` holds for any subset. -/
instance decidable_exists_of_decidable_subsets {s : finset α} {p : Π t ⊆ s, Prop}
  [Π t (h : t ⊆ s), decidable (p t h)] : decidable (∃ t (h : t ⊆ s), p t h) :=
decidable_of_iff (∃ t (hs : t ∈ s.powerset), p t (mem_powerset.1 hs))
⟨(λ ⟨t, _, hp⟩, ⟨t, _, hp⟩), (λ ⟨t, hs, hp⟩, ⟨t, mem_powerset.2 hs, hp⟩)⟩

/-- For predicate `p` decidable on subsets, it is decidable whether `p` holds for every subset. -/
instance decidable_forall_of_decidable_subsets {s : finset α} {p : Π t ⊆ s, Prop}
  [Π t (h : t ⊆ s), decidable (p t h)] : decidable (∀ t (h : t ⊆ s), p t h) :=
decidable_of_iff (∀ t (h : t ∈ s.powerset), p t (mem_powerset.1 h))
⟨(λ h t hs, h t (mem_powerset.2 hs)), (λ h _ _, h _ _)⟩

/-- A version of `finset.decidable_exists_of_decidable_subsets` with a non-dependent `p`.
Typeclass inference cannot find `hu` here, so this is not an instance. -/
def decidable_exists_of_decidable_subsets' {s : finset α} {p : finset α → Prop}
  (hu : Π t (h : t ⊆ s), decidable (p t)) : decidable (∃ t (h : t ⊆ s), p t) :=
@finset.decidable_exists_of_decidable_subsets _ _ _ hu

/-- A version of `finset.decidable_forall_of_decidable_subsets` with a non-dependent `p`.
Typeclass inference cannot find `hu` here, so this is not an instance. -/
def decidable_forall_of_decidable_subsets' {s : finset α} {p : finset α → Prop}
  (hu : Π t (h : t ⊆ s), decidable (p t)) : decidable (∀ t (h : t ⊆ s), p t) :=
@finset.decidable_forall_of_decidable_subsets _ _ _ hu

end powerset

section ssubsets
variables [decidable_eq α]

/-- For `s` a finset, `s.ssubsets` is the finset comprising strict subsets of `s`. -/
def ssubsets (s : finset α) : finset (finset α) :=
erase (powerset s) s

@[simp] lemma mem_ssubsets {s t : finset α} : t ∈ s.ssubsets ↔ t ⊂ s :=
by rw [ssubsets, mem_erase, mem_powerset, ssubset_iff_subset_ne, and.comm]

lemma empty_mem_ssubsets {s : finset α} (h : s.nonempty) : ∅ ∈ s.ssubsets :=
by { rw [mem_ssubsets, ssubset_iff_subset_ne], exact ⟨empty_subset s, h.ne_empty.symm⟩, }

/-- For predicate `p` decidable on ssubsets, it is decidable whether `p` holds for any ssubset. -/
instance decidable_exists_of_decidable_ssubsets {s : finset α} {p : Π t ⊂ s, Prop}
  [Π t (h : t ⊂ s), decidable (p t h)] : decidable (∃ t h, p t h) :=
decidable_of_iff (∃ t (hs : t ∈ s.ssubsets), p t (mem_ssubsets.1 hs))
⟨(λ ⟨t, _, hp⟩, ⟨t, _, hp⟩), (λ ⟨t, hs, hp⟩, ⟨t, mem_ssubsets.2 hs, hp⟩)⟩

/-- For predicate `p` decidable on ssubsets, it is decidable whether `p` holds for every ssubset. -/
instance decidable_forall_of_decidable_ssubsets {s : finset α} {p : Π t ⊂ s, Prop}
  [Π t (h : t ⊂ s), decidable (p t h)] : decidable (∀ t h, p t h) :=
decidable_of_iff (∀ t (h : t ∈ s.ssubsets), p t (mem_ssubsets.1 h))
⟨(λ h t hs, h t (mem_ssubsets.2 hs)), (λ h _ _, h _ _)⟩

/-- A version of `finset.decidable_exists_of_decidable_ssubsets` with a non-dependent `p`.
Typeclass inference cannot find `hu` here, so this is not an instance. -/
def decidable_exists_of_decidable_ssubsets' {s : finset α} {p : finset α → Prop}
  (hu : Π t (h : t ⊂ s), decidable (p t)) : decidable (∃ t (h : t ⊂ s), p t) :=
@finset.decidable_exists_of_decidable_ssubsets _ _ _ _ hu

/-- A version of `finset.decidable_forall_of_decidable_ssubsets` with a non-dependent `p`.
Typeclass inference cannot find `hu` here, so this is not an instance. -/
def decidable_forall_of_decidable_ssubsets' {s : finset α} {p : finset α → Prop}
  (hu : Π t (h : t ⊂ s), decidable (p t)) : decidable (∀ t (h : t ⊂ s), p t) :=
@finset.decidable_forall_of_decidable_ssubsets _ _ _ _ hu

end ssubsets

section powerset_len

/-- Given an integer `n` and a finset `s`, then `powerset_len n s` is the finset of subsets of `s`
of cardinality `n`. -/
def powerset_len (n : ℕ) (s : finset α) : finset (finset α) :=
⟨(s.1.powerset_len n).pmap finset.mk $ λ t h, nodup_of_le (mem_powerset_len.1 h).1 s.2,
 s.2.powerset_len.pmap $ λ a ha b hb, congr_arg finset.val⟩

/-- **Formula for the Number of Combinations** -/
theorem mem_powerset_len {n} {s t : finset α} :
  s ∈ powerset_len n t ↔ s ⊆ t ∧ card s = n :=
by cases s; simp [powerset_len, val_le_iff.symm]; refl

@[simp] theorem powerset_len_mono {n} {s t : finset α} (h : s ⊆ t) :
  powerset_len n s ⊆ powerset_len n t :=
λ u h', mem_powerset_len.2 $
  and.imp (λ h₂, subset.trans h₂ h) id (mem_powerset_len.1 h')

/-- **Formula for the Number of Combinations** -/
@[simp] theorem card_powerset_len (n : ℕ) (s : finset α) :
  card (powerset_len n s) = nat.choose (card s) n :=
(card_pmap _ _ _).trans (card_powerset_len n s.1)

@[simp] lemma powerset_len_zero (s : finset α) : finset.powerset_len 0 s = {∅} :=
begin
  ext, rw [mem_powerset_len, mem_singleton, card_eq_zero],
  refine ⟨λ h, h.2, λ h, by { rw h, exact ⟨empty_subset s, rfl⟩ }⟩,
end

@[simp] theorem powerset_len_empty (n : ℕ) {s : finset α} (h : s.card < n) :
  powerset_len n s = ∅ :=
finset.card_eq_zero.mp (by rw [card_powerset_len, nat.choose_eq_zero_of_lt h])

theorem powerset_len_eq_filter {n} {s : finset α} :
  powerset_len n s = (powerset s).filter (λ x, x.card = n) :=
by { ext, simp [mem_powerset_len] }

lemma powerset_len_succ_insert [decidable_eq α] {x : α} {s : finset α} (h : x ∉ s) (n : ℕ) :
  powerset_len n.succ (insert x s) = powerset_len n.succ s ∪ (powerset_len n s).image (insert x) :=
begin
  rw [powerset_len_eq_filter, powerset_insert, filter_union, ←powerset_len_eq_filter],
  congr,
  rw [powerset_len_eq_filter, image_filter],
  congr' 1,
  ext t,
  simp only [mem_powerset, mem_filter, function.comp_app, and.congr_right_iff],
  intro ht,
  have : x ∉ t := λ H, h (ht H),
  simp [card_insert_of_not_mem this, nat.succ_inj']
end

lemma powerset_len_nonempty {n : ℕ} {s : finset α} (h : n < s.card) :
  (powerset_len n s).nonempty :=
begin
  classical,
  induction s using finset.induction_on with x s hx IH generalizing n,
  { simpa using h },
  { cases n,
    { simp },
    { rw [card_insert_of_not_mem hx, nat.succ_lt_succ_iff] at h,
      rw powerset_len_succ_insert hx,
      refine nonempty.mono _ ((IH h).image (insert x)),
      convert (subset_union_right _ _) } }
end

@[simp] lemma powerset_len_self (s : finset α) :
  powerset_len s.card s = {s} :=
begin
  ext,
  rw [mem_powerset_len, mem_singleton],
  split,
  { exact λ ⟨hs, hc⟩, eq_of_subset_of_card_le hs hc.ge },
  { rintro rfl,
    simp }
end

lemma powerset_card_bUnion [decidable_eq (finset α)] (s : finset α) :
  finset.powerset s = (range (s.card + 1)).bUnion (λ i, powerset_len i s) :=
begin
  refine ext (λ a, ⟨λ ha, _, λ ha, _ ⟩),
  { rw mem_bUnion,
    exact ⟨a.card, mem_range.mpr (nat.lt_succ_of_le (card_le_of_subset (mem_powerset.mp ha))),
      mem_powerset_len.mpr ⟨mem_powerset.mp ha, rfl⟩⟩ },
  { rcases mem_bUnion.mp ha with ⟨i, hi, ha⟩,
    exact mem_powerset.mpr (mem_powerset_len.mp ha).1, }
end

lemma powerset_len_sup [decidable_eq α] (u : finset α) (n : ℕ) (hn : n < u.card) :
  (powerset_len n.succ u).sup id = u :=
begin
  apply le_antisymm,
  { simp_rw [finset.sup_le_iff, mem_powerset_len],
    rintros x ⟨h, -⟩,
    exact h },
  { rw [sup_eq_bUnion, le_iff_subset, subset_iff],
    cases (nat.succ_le_of_lt hn).eq_or_lt with h' h',
    { simp [h'] },
    { intros x hx,
      simp only [mem_bUnion, exists_prop, id.def],
      obtain ⟨t, ht⟩ : ∃ t, t ∈ powerset_len n (u.erase x) := powerset_len_nonempty _,
      { refine ⟨insert x t, _, mem_insert_self _ _⟩,
        rw [←insert_erase hx, powerset_len_succ_insert (not_mem_erase _ _)],
        exact mem_union_right _ (mem_image_of_mem _ ht) },
      { rwa [card_erase_of_mem hx, lt_tsub_iff_right] } } }
end

@[simp]
lemma powerset_len_card_add (s : finset α) {i : ℕ} (hi : 0 < i) :
  s.powerset_len (s.card + i) = ∅ :=
finset.powerset_len_empty _ (lt_add_of_pos_right (finset.card s) hi)

@[simp] theorem map_val_val_powerset_len (s : finset α) (i : ℕ) :
  (s.powerset_len i).val.map finset.val = s.1.powerset_len i :=
by simp [finset.powerset_len, map_pmap, pmap_eq_map, map_id']

end powerset_len
end finset


<|start_filename|>src/topology/G_delta.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import topology.uniform_space.basic
import topology.separation

/-!
# `Gδ` sets

In this file we define `Gδ` sets and prove their basic properties.

## Main definitions

* `is_Gδ`: a set `s` is a `Gδ` set if it can be represented as an intersection
  of countably many open sets;

* `residual`: the filter of residual sets. A set `s` is called *residual* if it includes a dense
  `Gδ` set. In a Baire space (e.g., in a complete (e)metric space), residual sets form a filter.

  For technical reasons, we define `residual` in any topological space but the definition agrees
  with the description above only in Baire spaces.

## Main results

We prove that finite or countable intersections of Gδ sets is a Gδ set. We also prove that the
continuity set of a function from a topological space to an (e)metric space is a Gδ set.

## Tags

Gδ set, residual set
-/

noncomputable theory
open_locale classical topological_space filter uniformity

open filter encodable set

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

section is_Gδ
variable [topological_space α]

/-- A Gδ set is a countable intersection of open sets. -/
def is_Gδ (s : set α) : Prop :=
  ∃T : set (set α), (∀t ∈ T, is_open t) ∧ countable T ∧ s = (⋂₀ T)

/-- An open set is a Gδ set. -/
lemma is_open.is_Gδ {s : set α} (h : is_open s) : is_Gδ s :=
⟨{s}, by simp [h], countable_singleton _, (set.sInter_singleton _).symm⟩

@[simp] lemma is_Gδ_empty : is_Gδ (∅ : set α) := is_open_empty.is_Gδ

@[simp] lemma is_Gδ_univ : is_Gδ (univ : set α) := is_open_univ.is_Gδ

lemma is_Gδ_bInter_of_open {I : set ι} (hI : countable I) {f : ι → set α}
  (hf : ∀i ∈ I, is_open (f i)) : is_Gδ (⋂i∈I, f i) :=
⟨f '' I, by rwa ball_image_iff, hI.image _, by rw sInter_image⟩

lemma is_Gδ_Inter_of_open [encodable ι] {f : ι → set α}
  (hf : ∀i, is_open (f i)) : is_Gδ (⋂i, f i) :=
⟨range f, by rwa forall_range_iff, countable_range _, by rw sInter_range⟩

/-- The intersection of an encodable family of Gδ sets is a Gδ set. -/
lemma is_Gδ_Inter [encodable ι] {s : ι → set α} (hs : ∀ i, is_Gδ (s i)) : is_Gδ (⋂ i, s i) :=
begin
  choose T hTo hTc hTs using hs,
  obtain rfl : s = λ i, ⋂₀ T i := funext hTs,
  refine ⟨⋃ i, T i, _, countable_Union hTc, (sInter_Union _).symm⟩,
  simpa [@forall_swap ι] using hTo
end

lemma is_Gδ_bInter {s : set ι} (hs : countable s) {t : Π i ∈ s, set α}
  (ht : ∀ i ∈ s, is_Gδ (t i ‹_›)) : is_Gδ (⋂ i ∈ s, t i ‹_›) :=
begin
  rw [bInter_eq_Inter],
  haveI := hs.to_encodable,
  exact is_Gδ_Inter (λ x, ht x x.2)
end

/-- A countable intersection of Gδ sets is a Gδ set. -/
lemma is_Gδ_sInter {S : set (set α)} (h : ∀s∈S, is_Gδ s) (hS : countable S) : is_Gδ (⋂₀ S) :=
by simpa only [sInter_eq_bInter] using is_Gδ_bInter hS h

lemma is_Gδ.inter {s t : set α} (hs : is_Gδ s) (ht : is_Gδ t) : is_Gδ (s ∩ t) :=
by { rw inter_eq_Inter, exact is_Gδ_Inter (bool.forall_bool.2 ⟨ht, hs⟩) }

/-- The union of two Gδ sets is a Gδ set. -/
lemma is_Gδ.union {s t : set α} (hs : is_Gδ s) (ht : is_Gδ t) : is_Gδ (s ∪ t) :=
begin
  rcases hs with ⟨S, Sopen, Scount, rfl⟩,
  rcases ht with ⟨T, Topen, Tcount, rfl⟩,
  rw [sInter_union_sInter],
  apply is_Gδ_bInter_of_open (Scount.prod Tcount),
  rintros ⟨a, b⟩ ⟨ha, hb⟩,
  exact (Sopen a ha).union (Topen b hb)
end

/-- The union of finitely many Gδ sets is a Gδ set. -/
lemma is_Gδ_bUnion {s : set ι} (hs : s.finite) {f : ι → set α} (h : ∀ i ∈ s, is_Gδ (f i)) :
  is_Gδ (⋃ i ∈ s, f i) :=
begin
  refine finite.induction_on hs (by simp) _ h,
  simp only [ball_insert_iff, bUnion_insert],
  exact λ a s _ _ ihs H, H.1.union (ihs H.2)
end

lemma is_closed.is_Gδ {α} [uniform_space α] [is_countably_generated (𝓤 α)]
  {s : set α} (hs : is_closed s) : is_Gδ s :=
begin
  rcases (@uniformity_has_basis_open α _).exists_antitone_subbasis  with ⟨U, hUo, hU, -⟩,
  rw [← hs.closure_eq, ← hU.bInter_bUnion_ball],
  refine is_Gδ_bInter (countable_encodable _) (λ n hn, is_open.is_Gδ _),
  exact is_open_bUnion (λ x hx, uniform_space.is_open_ball _ (hUo _).2)
end

section t1_space

variable [t1_space α]

lemma is_Gδ_compl_singleton (a : α) : is_Gδ ({a}ᶜ : set α) :=
is_open_compl_singleton.is_Gδ

lemma set.countable.is_Gδ_compl {s : set α} (hs : countable s) : is_Gδ sᶜ :=
begin
  rw [← bUnion_of_singleton s, compl_Union₂],
  exact is_Gδ_bInter hs (λ x _, is_Gδ_compl_singleton x)
end

lemma set.finite.is_Gδ_compl {s : set α} (hs : s.finite) : is_Gδ sᶜ :=
hs.countable.is_Gδ_compl

lemma set.subsingleton.is_Gδ_compl {s : set α} (hs : s.subsingleton) : is_Gδ sᶜ :=
hs.finite.is_Gδ_compl

lemma finset.is_Gδ_compl (s : finset α) : is_Gδ (sᶜ : set α) :=
s.finite_to_set.is_Gδ_compl

open topological_space

variables [first_countable_topology α]

lemma is_Gδ_singleton (a : α) : is_Gδ ({a} : set α) :=
begin
  rcases (nhds_basis_opens a).exists_antitone_subbasis with ⟨U, hU, h_basis⟩,
  rw [← bInter_basis_nhds h_basis.to_has_basis],
  exact is_Gδ_bInter (countable_encodable _) (λ n hn, (hU n).2.is_Gδ),
end

lemma set.finite.is_Gδ {s : set α} (hs : s.finite) : is_Gδ s :=
finite.induction_on hs is_Gδ_empty $ λ a s _ _ hs, (is_Gδ_singleton a).union hs

end t1_space

end is_Gδ

section continuous_at

open topological_space
open_locale uniformity

variables [topological_space α]

/-- The set of points where a function is continuous is a Gδ set. -/
lemma is_Gδ_set_of_continuous_at [uniform_space β] [is_countably_generated (𝓤 β)] (f : α → β) :
  is_Gδ {x | continuous_at f x} :=
begin
  obtain ⟨U, hUo, hU⟩ := (@uniformity_has_basis_open_symmetric β _).exists_antitone_subbasis,
  simp only [uniform.continuous_at_iff_prod, nhds_prod_eq],
  simp only [(nhds_basis_opens _).prod_self.tendsto_iff hU.to_has_basis, forall_prop_of_true,
    set_of_forall, id],
  refine is_Gδ_Inter (λ k, is_open.is_Gδ $ is_open_iff_mem_nhds.2 $ λ x, _),
  rintros ⟨s, ⟨hsx, hso⟩, hsU⟩,
  filter_upwards [is_open.mem_nhds hso hsx] with _ hy using ⟨s, ⟨hy, hso⟩, hsU⟩,
end

end continuous_at

/-- A set `s` is called *residual* if it includes a dense `Gδ` set. If `α` is a Baire space
(e.g., a complete metric space), then residual sets form a filter, see `mem_residual`.

For technical reasons we define the filter `residual` in any topological space but in a non-Baire
space it is not useful because it may contain some non-residual sets. -/
def residual (α : Type*) [topological_space α] : filter α :=
⨅ t (ht : is_Gδ t) (ht' : dense t), 𝓟 t


<|start_filename|>src/measure_theory/function/strongly_measurable.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import measure_theory.function.ess_sup
import measure_theory.integral.mean_inequalities
import topology.continuous_function.compact
import topology.metric_space.metrizable
import measure_theory.function.simple_func_dense

/-!
# Strongly measurable and finitely strongly measurable functions

A function `f` is said to be strongly measurable if `f` is the sequential limit of simple functions.
It is said to be finitely strongly measurable with respect to a measure `μ` if the supports
of those simple functions have finite measure. We also provide almost everywhere versions of
these notions.

Almost everywhere strongly measurable functions form the largest class of functions that can be
integrated using the Bochner integral.

If the target space has a second countable topology, strongly measurable and measurable are
equivalent.

If the measure is sigma-finite, strongly measurable and finitely strongly measurable are equivalent.

The main property of finitely strongly measurable functions is
`fin_strongly_measurable.exists_set_sigma_finite`: there exists a measurable set `t` such that the
function is supported on `t` and `μ.restrict t` is sigma-finite. As a consequence, we can prove some
results for those functions as if the measure was sigma-finite.

## Main definitions

* `strongly_measurable f`: `f : α → β` is the limit of a sequence `fs : ℕ → simple_func α β`.
* `fin_strongly_measurable f μ`: `f : α → β` is the limit of a sequence `fs : ℕ → simple_func α β`
  such that for all `n ∈ ℕ`, the measure of the support of `fs n` is finite.
* `ae_strongly_measurable f μ`: `f` is almost everywhere equal to a `strongly_measurable` function.
* `ae_fin_strongly_measurable f μ`: `f` is almost everywhere equal to a `fin_strongly_measurable`
  function.

* `ae_fin_strongly_measurable.sigma_finite_set`: a measurable set `t` such that
  `f =ᵐ[μ.restrict tᶜ] 0` and `μ.restrict t` is sigma-finite.

## Main statements

* `ae_fin_strongly_measurable.exists_set_sigma_finite`: there exists a measurable set `t` such that
  `f =ᵐ[μ.restrict tᶜ] 0` and `μ.restrict t` is sigma-finite.

We provide a solid API for strongly measurable functions, and for almost everywhere strongly
measurable functions, as a basis for the Bochner integral.

## References

* Hytönen, Tuomas, <NAME>, <NAME>, and <NAME>. Analysis in Banach spaces.
  Springer, 2016.

-/

open measure_theory filter topological_space function set measure_theory.measure
open_locale ennreal topological_space measure_theory nnreal big_operators

/-- The typeclass `second_countable_topology_either α β` registers the fact that at least one of
the two spaces has second countable topology. This is the right assumption to ensure that continuous
maps from `α` to `β` are strongly measurable. -/
class second_countable_topology_either
  (α β : Type*) [topological_space α] [topological_space β] : Prop :=
(out : second_countable_topology α ∨ second_countable_topology β)

@[priority 100] instance second_countable_topology_either_of_left
  (α β : Type*) [topological_space α] [topological_space β] [second_countable_topology α] :
  second_countable_topology_either α β :=
{ out := or.inl (by apply_instance) }

@[priority 100] instance second_countable_topology_either_of_right
  (α β : Type*) [topological_space α] [topological_space β] [second_countable_topology β] :
  second_countable_topology_either α β :=
{ out := or.inr (by apply_instance) }

variables {α β γ ι : Type*} [encodable ι]
namespace measure_theory

local infixr ` →ₛ `:25 := simple_func

section definitions
variable [topological_space β]

/-- A function is `strongly_measurable` if it is the limit of simple functions. -/
def strongly_measurable [measurable_space α] (f : α → β) : Prop :=
∃ fs : ℕ → α →ₛ β, ∀ x, tendsto (λ n, fs n x) at_top (𝓝 (f x))

localized "notation `strongly_measurable[` m `]` := @measure_theory.strongly_measurable _ _ _ m"
in measure_theory

/-- A function is `fin_strongly_measurable` with respect to a measure if it is the limit of simple
  functions with support with finite measure. -/
def fin_strongly_measurable [has_zero β] {m0 : measurable_space α} (f : α → β) (μ : measure α) :
  Prop :=
∃ fs : ℕ → α →ₛ β, (∀ n, μ (support (fs n)) < ∞) ∧ (∀ x, tendsto (λ n, fs n x) at_top (𝓝 (f x)))

/-- A function is `ae_strongly_measurable` with respect to a measure `μ` if it is almost everywhere
equal to the limit of a sequence of simple functions. -/
def ae_strongly_measurable {m0 : measurable_space α} (f : α → β) (μ : measure α) : Prop :=
∃ g, strongly_measurable g ∧ f =ᵐ[μ] g

/-- A function is `ae_fin_strongly_measurable` with respect to a measure if it is almost everywhere
equal to the limit of a sequence of simple functions with support with finite measure. -/
def ae_fin_strongly_measurable [has_zero β] {m0 : measurable_space α} (f : α → β) (μ : measure α) :
  Prop :=
∃ g, fin_strongly_measurable g μ ∧ f =ᵐ[μ] g

end definitions

open_locale measure_theory

/-! ## Strongly measurable functions -/

lemma strongly_measurable.ae_strongly_measurable {α β} {m0 : measurable_space α}
  [topological_space β] {f : α → β} {μ : measure α} (hf : strongly_measurable f) :
  ae_strongly_measurable f μ :=
⟨f, hf, eventually_eq.refl _ _⟩

@[simp] lemma subsingleton.strongly_measurable {α β} [measurable_space α] [topological_space β]
  [subsingleton β] (f : α → β) :
  strongly_measurable f :=
begin
  let f_sf : α →ₛ β := ⟨f, λ x, _, set.subsingleton.finite set.subsingleton_of_subsingleton⟩,
  { exact ⟨λ n, f_sf, λ x, tendsto_const_nhds⟩, },
  { have h_univ : f ⁻¹' {x} = set.univ, by { ext1 y, simp, },
    rw h_univ,
    exact measurable_set.univ, },
end

lemma simple_func.strongly_measurable {α β} {m : measurable_space α} [topological_space β]
  (f : α →ₛ β) :
  strongly_measurable f :=
⟨λ _, f, λ x, tendsto_const_nhds⟩

lemma strongly_measurable_of_is_empty [is_empty α] {m : measurable_space α} [topological_space β]
  (f : α → β) : strongly_measurable f :=
⟨λ n, simple_func.of_is_empty, is_empty_elim⟩

lemma strongly_measurable_const {α β} {m : measurable_space α} [topological_space β] {b : β} :
  strongly_measurable (λ a : α, b) :=
⟨λ n, simple_func.const α b, λ a, tendsto_const_nhds⟩

@[to_additive]
lemma strongly_measurable_one {α β} {m : measurable_space α} [topological_space β] [has_one β] :
  strongly_measurable (1 : α → β) :=
@strongly_measurable_const _ _ _ _ 1

/-- A version of `strongly_measurable_const` that assumes `f x = f y` for all `x, y`.
This version works for functions between empty types. -/
lemma strongly_measurable_const' {α β} {m : measurable_space α} [topological_space β] {f : α → β}
  (hf : ∀ x y, f x = f y) : strongly_measurable f :=
begin
  casesI is_empty_or_nonempty α,
  { exact strongly_measurable_of_is_empty f },
  { convert strongly_measurable_const, exact funext (λ x, hf x h.some) }
end

@[simp] lemma subsingleton.strongly_measurable' {α β} [measurable_space α] [topological_space β]
  [subsingleton α] (f : α → β) :
  strongly_measurable f :=
strongly_measurable_const' (λ x y, by rw subsingleton.elim x y)

namespace strongly_measurable

variables {f g : α → β}

section basic_properties_in_any_topological_space
variables [topological_space β]

/-- A sequence of simple functions such that `∀ x, tendsto (λ n, hf.approx n x) at_top (𝓝 (f x))`.
That property is given by `strongly_measurable.tendsto_approx`. -/
protected noncomputable
def approx {m : measurable_space α} (hf : strongly_measurable f) : ℕ → α →ₛ β :=
hf.some

protected lemma tendsto_approx {m : measurable_space α} (hf : strongly_measurable f) :
  ∀ x, tendsto (λ n, hf.approx n x) at_top (𝓝 (f x)) :=
hf.some_spec

end basic_properties_in_any_topological_space

lemma fin_strongly_measurable_of_set_sigma_finite [topological_space β] [has_zero β]
  {m : measurable_space α} {μ : measure α} (hf_meas : strongly_measurable f) {t : set α}
  (ht : measurable_set t) (hft_zero : ∀ x ∈ tᶜ, f x = 0) (htμ : sigma_finite (μ.restrict t)) :
  fin_strongly_measurable f μ :=
begin
  haveI : sigma_finite (μ.restrict t) := htμ,
  let S := spanning_sets (μ.restrict t),
  have hS_meas : ∀ n, measurable_set (S n), from measurable_spanning_sets (μ.restrict t),
  let f_approx := hf_meas.approx,
  let fs := λ n, simple_func.restrict (f_approx n) (S n ∩ t),
  have h_fs_t_compl : ∀ n, ∀ x ∉ t, fs n x = 0,
  { intros n x hxt,
    rw simple_func.restrict_apply _ ((hS_meas n).inter ht),
    refine set.indicator_of_not_mem _ _,
    simp [hxt], },
  refine ⟨fs, _, λ x, _⟩,
  { simp_rw simple_func.support_eq,
    refine λ n, (measure_bUnion_finset_le _ _).trans_lt _,
    refine ennreal.sum_lt_top_iff.mpr (λ y hy, _),
    rw simple_func.restrict_preimage_singleton _ ((hS_meas n).inter ht),
    swap, { rw finset.mem_filter at hy, exact hy.2, },
    refine (measure_mono (set.inter_subset_left _ _)).trans_lt _,
    have h_lt_top := measure_spanning_sets_lt_top (μ.restrict t) n,
    rwa measure.restrict_apply' ht at h_lt_top, },
  { by_cases hxt : x ∈ t,
    swap, { rw [funext (λ n, h_fs_t_compl n x hxt), hft_zero x hxt], exact tendsto_const_nhds, },
    have h : tendsto (λ n, (f_approx n) x) at_top (𝓝 (f x)), from hf_meas.tendsto_approx x,
    obtain ⟨n₁, hn₁⟩ : ∃ n, ∀ m, n ≤ m → fs m x = f_approx m x,
    { obtain ⟨n, hn⟩ : ∃ n, ∀ m, n ≤ m → x ∈ S m ∩ t,
      { suffices : ∃ n, ∀ m, n ≤ m → x ∈ S m,
        { obtain ⟨n, hn⟩ := this,
          exact ⟨n, λ m hnm, set.mem_inter (hn m hnm) hxt⟩, },
        suffices : ∃ n, x ∈ S n,
        { rcases this with ⟨n, hn⟩,
          exact ⟨n, λ m hnm, monotone_spanning_sets (μ.restrict t) hnm hn⟩, },
        rw [← set.mem_Union, Union_spanning_sets (μ.restrict t)],
        trivial, },
      refine ⟨n, λ m hnm, _⟩,
      simp_rw [fs, simple_func.restrict_apply _ ((hS_meas m).inter ht),
        set.indicator_of_mem (hn m hnm)], },
    rw tendsto_at_top' at h ⊢,
    intros s hs,
    obtain ⟨n₂, hn₂⟩ := h s hs,
    refine ⟨max n₁ n₂, λ m hm, _⟩,
    rw hn₁ m ((le_max_left _ _).trans hm.le),
    exact hn₂ m ((le_max_right _ _).trans hm.le), },
end

/-- If the measure is sigma-finite, all strongly measurable functions are
  `fin_strongly_measurable`. -/
protected lemma fin_strongly_measurable [topological_space β] [has_zero β] {m0 : measurable_space α}
  (hf : strongly_measurable f) (μ : measure α) [sigma_finite μ] :
  fin_strongly_measurable f μ :=
hf.fin_strongly_measurable_of_set_sigma_finite measurable_set.univ (by simp)
  (by rwa measure.restrict_univ)

/-- A strongly measurable function is measurable. -/
protected lemma measurable {m : measurable_space α} [topological_space β]
  [pseudo_metrizable_space β] [measurable_space β] [borel_space β] (hf : strongly_measurable f) :
  measurable f :=
measurable_of_tendsto_metrizable (λ n, (hf.approx n).measurable)
  (tendsto_pi_nhds.mpr hf.tendsto_approx)

/-- A strongly measurable function is almost everywhere measurable. -/
protected lemma ae_measurable {m : measurable_space α} [topological_space β]
  [pseudo_metrizable_space β] [measurable_space β] [borel_space β] {μ : measure α}
  (hf : strongly_measurable f) :
  ae_measurable f μ :=
hf.measurable.ae_measurable

lemma _root_.continuous.comp_strongly_measurable
  {m : measurable_space α} [topological_space β] [topological_space γ] {g : β → γ} {f : α → β}
  (hg : continuous g) (hf : strongly_measurable f) : strongly_measurable (λ x, g (f x)) :=
⟨λ n, simple_func.map g (hf.approx n), λ x, (hg.tendsto _).comp (hf.tendsto_approx x)⟩

@[to_additive]
lemma measurable_set_mul_support {m : measurable_space α}
  [has_one β] [topological_space β] [metrizable_space β] (hf : strongly_measurable f) :
  measurable_set (mul_support f) :=
by { borelize β, exact measurable_set_mul_support hf.measurable }

protected lemma mono {m m' : measurable_space α} [topological_space β]
  (hf : strongly_measurable[m'] f) (h_mono : m' ≤ m) :
  strongly_measurable[m] f :=
begin
  let f_approx : ℕ → @simple_func α m β := λ n,
  { to_fun := hf.approx n,
    measurable_set_fiber' := λ x, h_mono _ (simple_func.measurable_set_fiber' _ x),
    finite_range' := simple_func.finite_range (hf.approx n) },
  exact ⟨f_approx, hf.tendsto_approx⟩,
end

protected lemma prod_mk {m : measurable_space α} [topological_space β] [topological_space γ]
  {f : α → β} {g : α → γ} (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (λ x, (f x, g x)) :=
begin
  refine ⟨λ n, simple_func.pair (hf.approx n) (hg.approx n), λ x, _⟩,
  rw nhds_prod_eq,
  exact tendsto.prod_mk (hf.tendsto_approx x) (hg.tendsto_approx x),
end

lemma comp_measurable [topological_space β] {m : measurable_space α} {m' : measurable_space γ}
  {f : α → β} {g : γ → α} (hf : strongly_measurable f) (hg : measurable g) :
  strongly_measurable (f ∘ g) :=
⟨λ n, simple_func.comp (hf.approx n) g hg, λ x, hf.tendsto_approx (g x)⟩

lemma of_uncurry_left [topological_space β] {mα : measurable_space α} {mγ : measurable_space γ}
  {f : α → γ → β} (hf : strongly_measurable (uncurry f)) {x : α} :
  strongly_measurable (f x) :=
hf.comp_measurable measurable_prod_mk_left

lemma of_uncurry_right [topological_space β] {mα : measurable_space α} {mγ : measurable_space γ}
  {f : α → γ → β} (hf : strongly_measurable (uncurry f)) {y : γ} :
  strongly_measurable (λ x, f x y) :=
hf.comp_measurable measurable_prod_mk_right

section arithmetic
variables {mα : measurable_space α} [topological_space β]
include mα

@[to_additive]
protected lemma mul [has_mul β] [has_continuous_mul β]
  (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (f * g) :=
⟨λ n, hf.approx n * hg.approx n, λ x, (hf.tendsto_approx x).mul (hg.tendsto_approx x)⟩

@[to_additive]
lemma mul_const [has_mul β] [has_continuous_mul β] (hf : strongly_measurable f) (c : β) :
  strongly_measurable (λ x, f x * c) :=
hf.mul strongly_measurable_const

@[to_additive]
lemma const_mul [has_mul β] [has_continuous_mul β] (hf : strongly_measurable f) (c : β) :
  strongly_measurable (λ x, c * f x) :=
strongly_measurable_const.mul hf

@[to_additive]
protected lemma inv [group β] [topological_group β] (hf : strongly_measurable f) :
  strongly_measurable f⁻¹ :=
⟨λ n, (hf.approx n)⁻¹, λ x, (hf.tendsto_approx x).inv⟩

@[to_additive]
protected lemma div [has_div β] [has_continuous_div β]
  (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (f / g) :=
⟨λ n, hf.approx n / hg.approx n, λ x, (hf.tendsto_approx x).div' (hg.tendsto_approx x)⟩

@[to_additive]
protected lemma smul {𝕜} [topological_space 𝕜] [has_scalar 𝕜 β] [has_continuous_smul 𝕜 β]
  {f : α → 𝕜} {g : α → β} (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (λ x, f x • g x) :=
continuous_smul.comp_strongly_measurable (hf.prod_mk hg)

protected lemma const_smul {𝕜} [has_scalar 𝕜 β] [has_continuous_const_smul 𝕜 β]
  (hf : strongly_measurable f) (c : 𝕜) :
  strongly_measurable (c • f) :=
⟨λ n, c • (hf.approx n), λ x, (hf.tendsto_approx x).const_smul c⟩

protected lemma const_smul' {𝕜} [has_scalar 𝕜 β] [has_continuous_const_smul 𝕜 β]
  (hf : strongly_measurable f) (c : 𝕜) :
  strongly_measurable (λ x, c • (f x)) :=
hf.const_smul c

@[to_additive]
protected lemma smul_const {𝕜} [topological_space 𝕜] [has_scalar 𝕜 β] [has_continuous_smul 𝕜 β]
  {f : α → 𝕜} (hf : strongly_measurable f) (c : β) :
  strongly_measurable (λ x, f x • c) :=
continuous_smul.comp_strongly_measurable (hf.prod_mk strongly_measurable_const)

end arithmetic

section mul_action

variables [topological_space β] {G : Type*} [group G] [mul_action G β]
  [has_continuous_const_smul G β]

lemma _root_.strongly_measurable_const_smul_iff {m : measurable_space α} (c : G) :
  strongly_measurable (λ x, c • f x) ↔ strongly_measurable f :=
⟨λ h, by simpa only [inv_smul_smul] using h.const_smul' c⁻¹, λ h, h.const_smul c⟩

variables {G₀ : Type*} [group_with_zero G₀] [mul_action G₀ β]
  [has_continuous_const_smul G₀ β]

lemma _root_.strongly_measurable_const_smul_iff₀ {m : measurable_space α} {c : G₀} (hc : c ≠ 0) :
  strongly_measurable (λ x, c • f x) ↔ strongly_measurable f :=
begin
  refine ⟨λ h, _, λ h, h.const_smul c⟩,
  convert h.const_smul' c⁻¹,
  simp [smul_smul, inv_mul_cancel hc]
end

end mul_action

section order
variables [measurable_space α] [topological_space β]

open filter
open_locale filter

protected lemma sup [has_sup β] [has_continuous_sup β] (hf : strongly_measurable f)
  (hg : strongly_measurable g) :
  strongly_measurable (f ⊔ g) :=
⟨λ n, hf.approx n ⊔ hg.approx n, λ x, (hf.tendsto_approx x).sup_right_nhds (hg.tendsto_approx x)⟩

protected lemma inf [has_inf β] [has_continuous_inf β] (hf : strongly_measurable f)
  (hg : strongly_measurable g) :
  strongly_measurable (f ⊓ g) :=
⟨λ n, hf.approx n ⊓ hg.approx n, λ x, (hf.tendsto_approx x).inf_right_nhds (hg.tendsto_approx x)⟩

end order

/-!
### Big operators: `∏` and `∑`
-/

section monoid
variables {M : Type*} [monoid M] [topological_space M] [has_continuous_mul M]
  {m : measurable_space α}

include m

@[to_additive]
lemma _root_.list.strongly_measurable_prod'
  (l : list (α → M)) (hl : ∀ f ∈ l, strongly_measurable f) :
  strongly_measurable l.prod :=
begin
  induction l with f l ihl, { exact strongly_measurable_one },
  rw [list.forall_mem_cons] at hl,
  rw [list.prod_cons],
  exact hl.1.mul (ihl hl.2)
end

@[to_additive]
lemma _root_.list.strongly_measurable_prod
  (l : list (α → M)) (hl : ∀ f ∈ l, strongly_measurable f) :
  strongly_measurable (λ x, (l.map (λ f : α → M, f x)).prod) :=
by simpa only [← pi.list_prod_apply] using l.strongly_measurable_prod' hl

end monoid

section comm_monoid
variables {M : Type*} [comm_monoid M] [topological_space M] [has_continuous_mul M]
  {m : measurable_space α}

include m

@[to_additive]
lemma _root_.multiset.strongly_measurable_prod'
  (l : multiset (α → M)) (hl : ∀ f ∈ l, strongly_measurable f) :
  strongly_measurable l.prod :=
by { rcases l with ⟨l⟩, simpa using l.strongly_measurable_prod' (by simpa using hl) }

@[to_additive]
lemma _root_.multiset.strongly_measurable_prod
  (s : multiset (α → M)) (hs : ∀ f ∈ s, strongly_measurable f) :
  strongly_measurable (λ x, (s.map (λ f : α → M, f x)).prod) :=
by simpa only [← pi.multiset_prod_apply] using s.strongly_measurable_prod' hs

@[to_additive]
lemma _root_.finset.strongly_measurable_prod'
  {ι : Type*} {f : ι → α → M} (s : finset ι) (hf : ∀i ∈ s, strongly_measurable (f i)) :
  strongly_measurable (∏ i in s, f i) :=
finset.prod_induction _ _ (λ a b ha hb, ha.mul hb) (@strongly_measurable_one α M _ _ _) hf

@[to_additive]
lemma _root_.finset.strongly_measurable_prod
  {ι : Type*} {f : ι → α → M} (s : finset ι) (hf : ∀i ∈ s, strongly_measurable (f i)) :
  strongly_measurable (λ a, ∏ i in s, f i a) :=
by simpa only [← finset.prod_apply] using s.strongly_measurable_prod' hf

end comm_monoid

/-- The range of a strongly measurable function is separable. -/
lemma is_separable_range {m : measurable_space α} [topological_space β]
  (hf : strongly_measurable f) :
  topological_space.is_separable (range f) :=
begin
  have : is_separable (closure (⋃ n, range (hf.approx n))) :=
    (is_separable_Union (λ n, (simple_func.finite_range (hf.approx n)).is_separable)).closure,
  apply this.mono,
  rintros - ⟨x, rfl⟩,
  apply mem_closure_of_tendsto (hf.tendsto_approx x),
  apply eventually_of_forall (λ n, _),
  apply mem_Union_of_mem n,
  exact mem_range_self _
end

lemma separable_space_range_union_singleton {m : measurable_space α} [topological_space β]
  [pseudo_metrizable_space β] (hf : strongly_measurable f) {b : β} :
  separable_space (range f ∪ {b} : set β) :=
begin
  letI := pseudo_metrizable_space_pseudo_metric β,
  exact (hf.is_separable_range.union (finite_singleton _).is_separable).separable_space
end

section second_countable_strongly_measurable

variables {mα : measurable_space α} [measurable_space β]
include mα

/-- In a space with second countable topology, measurable implies strongly measurable. -/
lemma _root_.measurable.strongly_measurable [topological_space β] [pseudo_metrizable_space β]
  [second_countable_topology β] [opens_measurable_space β] (hf : measurable f) :
  strongly_measurable f :=
begin
  letI := pseudo_metrizable_space_pseudo_metric β,
  rcases is_empty_or_nonempty β; resetI,
  { exact subsingleton.strongly_measurable f, },
  { inhabit β,
    exact ⟨simple_func.approx_on f hf set.univ default (set.mem_univ _),
      λ x, simple_func.tendsto_approx_on hf (set.mem_univ _) (by simp)⟩, },
end

/-- In a space with second countable topology, strongly measurable and measurable are equivalent. -/
lemma _root_.strongly_measurable_iff_measurable
  [topological_space β] [metrizable_space β] [borel_space β] [second_countable_topology β] :
  strongly_measurable f ↔ measurable f :=
⟨λ h, h.measurable, λ h, measurable.strongly_measurable h⟩

lemma _root_.strongly_measurable_id [topological_space α] [pseudo_metrizable_space α]
  [opens_measurable_space α] [second_countable_topology α] :
  strongly_measurable (id : α → α) :=
measurable_id.strongly_measurable

end second_countable_strongly_measurable

/-- A function is strongly measurable if and only if it is measurable and has separable
range. -/
theorem _root_.strongly_measurable_iff_measurable_separable {m : measurable_space α}
  [topological_space β] [pseudo_metrizable_space β] [measurable_space β] [borel_space β] :
  strongly_measurable f ↔ (measurable f ∧ is_separable (range f)) :=
begin
  refine ⟨λ H, ⟨H.measurable, H.is_separable_range⟩, _⟩,
  rintros ⟨H, H'⟩,
  letI := pseudo_metrizable_space_pseudo_metric β,
  let g := cod_restrict f (closure (range f)) (λ x, subset_closure (mem_range_self x)),
  have fg : f = (coe : closure (range f) → β) ∘ g, by { ext x, refl },
  have T : measurable_embedding (coe : closure (range f) → β),
  { apply closed_embedding.measurable_embedding,
    exact closed_embedding_subtype_coe is_closed_closure },
  have g_meas : measurable g,
  { rw fg at H, exact T.measurable_comp_iff.1 H },
  haveI : second_countable_topology (closure (range f)),
  { suffices : separable_space (closure (range f)),
      by exactI uniform_space.second_countable_of_separable _,
    exact (is_separable.closure H').separable_space },
  have g_smeas : strongly_measurable g := measurable.strongly_measurable g_meas,
  rw fg,
  exact continuous_subtype_coe.comp_strongly_measurable g_smeas,
end

/-- A continuous function is strongly measurable when either the source space or the target space
is second-countable. -/
lemma _root_.continuous.strongly_measurable [measurable_space α]
  [topological_space α] [opens_measurable_space α]
  {β : Type*} [topological_space β] [pseudo_metrizable_space β]
  [h : second_countable_topology_either α β]
  {f : α → β} (hf : continuous f) :
  strongly_measurable f :=
begin
  borelize β,
  casesI h.out,
  { rw strongly_measurable_iff_measurable_separable,
    refine ⟨hf.measurable, _⟩,
    rw ← image_univ,
    exact (is_separable_of_separable_space univ).image hf },
  { exact hf.measurable.strongly_measurable }
end

/-- If `g` is a topological embedding, then `f` is strongly measurable iff `g ∘ f` is. -/
lemma _root_.embedding.comp_strongly_measurable_iff {m : measurable_space α}
  [topological_space β] [pseudo_metrizable_space β] [topological_space γ]
  [pseudo_metrizable_space γ]
  {g : β → γ} {f : α → β} (hg : embedding g) :
  strongly_measurable (λ x, g (f x)) ↔ strongly_measurable f :=
begin
  letI := pseudo_metrizable_space_pseudo_metric γ,
  borelize [β, γ],
  refine ⟨λ H, strongly_measurable_iff_measurable_separable.2 ⟨_, _⟩,
    λ H, hg.continuous.comp_strongly_measurable H⟩,
  { let G : β → range g := cod_restrict g (range g) mem_range_self,
    have hG : closed_embedding G :=
    { closed_range :=
      begin
        convert is_closed_univ,
        apply eq_univ_of_forall,
        rintros ⟨-, ⟨x, rfl⟩⟩,
        exact mem_range_self x
      end,
      .. hg.cod_restrict _ _ },
    have : measurable (G ∘ f) := measurable.subtype_mk H.measurable,
    exact hG.measurable_embedding.measurable_comp_iff.1 this },
  { have : is_separable (g ⁻¹' (range (g ∘ f))) := hg.is_separable_preimage H.is_separable_range,
    convert this,
    ext x,
    simp [hg.inj.eq_iff] }
end

/-- A sequential limit of strongly measurable functions is strongly measurable. -/
lemma _root_.strongly_measurable_of_tendsto {ι : Type*} {m : measurable_space α}
  [topological_space β] [pseudo_metrizable_space β] (u : filter ι) [ne_bot u]
  [is_countably_generated u] {f : ι → α → β} {g : α → β} (hf : ∀ i, strongly_measurable (f i))
  (lim : tendsto f u (𝓝 g)) :
  strongly_measurable g :=
begin
  borelize β,
  refine strongly_measurable_iff_measurable_separable.2 ⟨_, _⟩,
  { exact measurable_of_tendsto_metrizable' u (λ i, (hf i).measurable) lim },
  { rcases u.exists_seq_tendsto with ⟨v, hv⟩,
    have : is_separable (closure (⋃ i, range (f (v i)))) :=
      (is_separable_Union (λ i, (hf (v i)).is_separable_range)).closure,
    apply this.mono,
    rintros - ⟨x, rfl⟩,
    rw [tendsto_pi_nhds] at lim,
    apply mem_closure_of_tendsto ((lim x).comp hv),
    apply eventually_of_forall (λ n, _),
    apply mem_Union_of_mem n,
    exact mem_range_self _ }
end

protected lemma piecewise {m : measurable_space α} [topological_space β]
  {s : set α} {_ : decidable_pred (∈ s)} (hs : measurable_set s)
  (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (set.piecewise s f g) :=
begin
  refine ⟨λ n, simple_func.piecewise s hs (hf.approx n) (hg.approx n), λ x, _⟩,
  by_cases hx : x ∈ s,
  { simpa [hx] using hf.tendsto_approx x },
  { simpa [hx] using hg.tendsto_approx x },
end

/-- this is slightly different from `strongly_measurable.piecewise`. It can be used to show
`strongly_measurable (ite (x=0) 0 1)` by
`exact strongly_measurable.ite (measurable_set_singleton 0) strongly_measurable_const
strongly_measurable_const`, but replacing `strongly_measurable.ite` by
`strongly_measurable.piecewise` in that example proof does not work. -/
protected lemma ite {m : measurable_space α} [topological_space β]
  {p : α → Prop} {_ : decidable_pred p}
  (hp : measurable_set {a : α | p a}) (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (λ x, ite (p x) (f x) (g x)) :=
strongly_measurable.piecewise hp hf hg

lemma _root_.strongly_measurable_of_strongly_measurable_union_cover
  {m : measurable_space α} [topological_space β]
  {f : α → β} (s t : set α) (hs : measurable_set s) (ht : measurable_set t) (h : univ ⊆ s ∪ t)
  (hc : strongly_measurable (λ a : s, f a)) (hd : strongly_measurable (λ a : t, f a)) :
  strongly_measurable f :=
begin
  classical,
  let f : ℕ → α →ₛ β := λ n,
  { to_fun := λ x, if hx : x ∈ s then hc.approx n ⟨x, hx⟩
                   else hd.approx n ⟨x, by simpa [hx] using h (mem_univ x)⟩,
    measurable_set_fiber' :=
    begin
      assume x,
      convert (hs.subtype_image
        ((hc.approx n).measurable_set_fiber x)).union
        ((ht.subtype_image
        ((hd.approx n).measurable_set_fiber x)).diff hs),
      ext1 y,
      simp only [mem_union_eq, mem_preimage, mem_singleton_iff, mem_image, set_coe.exists,
        subtype.coe_mk, exists_and_distrib_right, exists_eq_right, mem_diff],
      by_cases hy : y ∈ s,
      { rw dif_pos hy,
        simp only [hy, exists_true_left, not_true, and_false, or_false]},
      { rw dif_neg hy,
        have A : y ∈ t, by simpa [hy] using h (mem_univ y),
        simp only [A, hy, false_or, exists_false_left, not_false_iff, and_true, exists_true_left] }
    end,
    finite_range' :=
    begin
      apply ((hc.approx n).finite_range.union (hd.approx n).finite_range).subset,
      rintros - ⟨y, rfl⟩,
      dsimp,
      by_cases hy : y ∈ s,
      { left,
        rw dif_pos hy,
        exact mem_range_self _ },
      { right,
        rw dif_neg hy,
        exact mem_range_self _ }
    end },
  refine ⟨f, λ y, _⟩,
  by_cases hy : y ∈ s,
  { convert hc.tendsto_approx ⟨y, hy⟩ using 1,
    ext1 n,
    simp only [dif_pos hy, simple_func.apply_mk] },
  { have A : y ∈ t, by simpa [hy] using h (mem_univ y),
    convert hd.tendsto_approx ⟨y, A⟩ using 1,
    ext1 n,
    simp only [dif_neg hy, simple_func.apply_mk] }
end

lemma _root_.strongly_measurable_of_restrict_of_restrict_compl
  {m : measurable_space α} [topological_space β] {f : α → β} {s : set α} (hs : measurable_set s)
  (h₁ : strongly_measurable (s.restrict f)) (h₂ : strongly_measurable (sᶜ.restrict f)) :
  strongly_measurable f :=
strongly_measurable_of_strongly_measurable_union_cover s sᶜ hs hs.compl
  (union_compl_self s).ge h₁ h₂

protected lemma indicator {m : measurable_space α} [topological_space β] [has_zero β]
  (hf : strongly_measurable f) {s : set α} (hs : measurable_set s) :
  strongly_measurable (s.indicator f) :=
hf.piecewise hs strongly_measurable_const

protected lemma dist {m : measurable_space α} {β : Type*} [pseudo_metric_space β] {f g : α → β}
  (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (λ x, dist (f x) (g x)) :=
continuous_dist.comp_strongly_measurable (hf.prod_mk hg)

protected lemma norm {m : measurable_space α} {β : Type*} [normed_group β] {f : α → β}
  (hf : strongly_measurable f) :
  strongly_measurable (λ x, ∥f x∥) :=
continuous_norm.comp_strongly_measurable hf

protected lemma nnnorm {m : measurable_space α} {β : Type*} [normed_group β] {f : α → β}
  (hf : strongly_measurable f) :
  strongly_measurable (λ x, ∥f x∥₊) :=
continuous_nnnorm.comp_strongly_measurable hf

protected lemma ennnorm {m : measurable_space α} {β : Type*} [normed_group β] {f : α → β}
  (hf : strongly_measurable f) :
  measurable (λ a, (∥f a∥₊ : ℝ≥0∞)) :=
(ennreal.continuous_coe.comp_strongly_measurable hf.nnnorm).measurable

protected lemma real_to_nnreal {m : measurable_space α} {f : α → ℝ}
  (hf : strongly_measurable f) :
  strongly_measurable (λ x, (f x).to_nnreal) :=
continuous_real_to_nnreal.comp_strongly_measurable hf

lemma _root_.measurable_embedding.strongly_measurable_extend {f : α → β} {g : α → γ} {g' : γ → β}
  {mα : measurable_space α} {mγ : measurable_space γ} [topological_space β]
  (hg : measurable_embedding g)
  (hf : strongly_measurable f) (hg' : strongly_measurable g') :
  strongly_measurable (function.extend g f g') :=
begin
  refine ⟨λ n, simple_func.extend (hf.approx n) g hg (hg'.approx n), _⟩,
  assume x,
  by_cases hx : ∃ y, g y = x,
  { rcases hx with ⟨y, rfl⟩,
    simpa only [simple_func.extend_apply, hg.injective, extend_apply] using hf.tendsto_approx y },
  { simpa only [hx, simple_func.extend_apply', not_false_iff, extend_apply']
      using hg'.tendsto_approx x }
end

lemma _root_.measurable_embedding.exists_strongly_measurable_extend
  {f : α → β} {g : α → γ}
  {mα : measurable_space α} {mγ : measurable_space γ} [topological_space β]
  (hg : measurable_embedding g) (hf : strongly_measurable f) (hne : γ → nonempty β) :
  ∃ f' : γ → β, strongly_measurable f' ∧ f' ∘ g = f :=
⟨function.extend g f (λ x, classical.choice (hne x)),
  hg.strongly_measurable_extend hf (strongly_measurable_const' $ λ _ _, rfl),
  funext $ λ x, extend_apply hg.injective _ _ _⟩

protected lemma inner {𝕜 : Type*} {E : Type*} [is_R_or_C 𝕜] [inner_product_space 𝕜 E]
  {m : measurable_space α} {f g : α → E} (hf : strongly_measurable f) (hg : strongly_measurable g) :
  strongly_measurable (λ t, @inner 𝕜 _ _(f t) (g t)) :=
continuous.comp_strongly_measurable continuous_inner (hf.prod_mk hg)

lemma measurable_set_eq_fun {m : measurable_space α} {E} [topological_space E] [metrizable_space E]
  {f g : α → E} (hf : strongly_measurable f) (hg : strongly_measurable g) :
  measurable_set {x | f x = g x} :=
begin
  borelize E × E,
  exact (hf.prod_mk hg).measurable is_closed_diagonal.measurable_set
end

lemma measurable_set_lt {m : measurable_space α} [topological_space β]
  [linear_order β] [order_closed_topology β] [pseudo_metrizable_space β]
  {f g : α → β} (hf : strongly_measurable f) (hg : strongly_measurable g) :
  measurable_set {a | f a < g a} :=
begin
  borelize β × β,
  exact (hf.prod_mk hg).measurable is_open_lt_prod.measurable_set
end

lemma measurable_set_le {m : measurable_space α} [topological_space β]
  [preorder β] [order_closed_topology β] [pseudo_metrizable_space β]
  {f g : α → β} (hf : strongly_measurable f) (hg : strongly_measurable g) :
  measurable_set {a | f a ≤ g a} :=
begin
  borelize β × β,
  exact (hf.prod_mk hg).measurable is_closed_le_prod.measurable_set
end

lemma strongly_measurable_in_set {m : measurable_space α} [topological_space β] [has_zero β]
  {s : set α} {f : α → β}
  (hs : measurable_set s) (hf : strongly_measurable f) (hf_zero : ∀ x ∉ s, f x = 0) :
  ∃ fs : ℕ → α →ₛ β, (∀ x, tendsto (λ n, fs n x) at_top (𝓝 (f x))) ∧ (∀ (x ∉ s) n, fs n x = 0) :=
begin
  let g_seq_s : ℕ → @simple_func α m β := λ n, (hf.approx n).restrict s,
  have hg_eq : ∀ x ∈ s, ∀ n, g_seq_s n x = hf.approx n x,
  { intros x hx n,
    rw [simple_func.coe_restrict _ hs, set.indicator_of_mem hx], },
  have hg_zero : ∀ x ∉ s, ∀ n, g_seq_s n x = 0,
  { intros x hx n,
    rw [simple_func.coe_restrict _ hs, set.indicator_of_not_mem hx], },
  refine ⟨g_seq_s, λ x, _, hg_zero⟩,
  by_cases hx : x ∈ s,
  { simp_rw hg_eq x hx,
    exact hf.tendsto_approx x, },
  { simp_rw [hg_zero x hx, hf_zero x hx],
    exact tendsto_const_nhds, },
end

/-- If the restriction to a set `s` of a σ-algebra `m` is included in the restriction to `s` of
another σ-algebra `m₂` (hypothesis `hs`), the set `s` is `m` measurable and a function `f` supported
on `s` is `m`-strongly-measurable, then `f` is also `m₂`-strongly-measurable. -/
lemma strongly_measurable_of_measurable_space_le_on {α E} {m m₂ : measurable_space α}
  [topological_space E] [has_zero E] {s : set α} {f : α → E}
  (hs_m : measurable_set[m] s) (hs : ∀ t, measurable_set[m] (s ∩ t) → measurable_set[m₂] (s ∩ t))
  (hf : strongly_measurable[m] f) (hf_zero : ∀ x ∉ s, f x = 0) :
  strongly_measurable[m₂] f :=
begin
  have hs_m₂ : measurable_set[m₂] s,
  { rw ← set.inter_univ s,
    refine hs set.univ _,
    rwa [set.inter_univ], },
  obtain ⟨g_seq_s, hg_seq_tendsto, hg_seq_zero⟩ := strongly_measurable_in_set hs_m hf hf_zero,
  let g_seq_s₂ : ℕ → @simple_func α m₂ E := λ n,
  { to_fun := g_seq_s n,
    measurable_set_fiber' := λ x, begin
      rw [← set.inter_univ ((g_seq_s n) ⁻¹' {x}), ← set.union_compl_self s,
        set.inter_union_distrib_left, set.inter_comm ((g_seq_s n) ⁻¹' {x})],
      refine measurable_set.union (hs _ (hs_m.inter _)) _,
      { exact @simple_func.measurable_set_fiber _ _ m _ _, },
      by_cases hx : x = 0,
      { suffices : (g_seq_s n) ⁻¹' {x} ∩ sᶜ = sᶜ, by { rw this, exact hs_m₂.compl, },
        ext1 y,
        rw [hx, set.mem_inter_iff, set.mem_preimage, set.mem_singleton_iff],
        exact ⟨λ h, h.2, λ h, ⟨hg_seq_zero y h n, h⟩⟩, },
      { suffices : (g_seq_s n) ⁻¹' {x} ∩ sᶜ = ∅, by { rw this, exact measurable_set.empty, },
        ext1 y,
        simp only [mem_inter_eq, mem_preimage, mem_singleton_iff, mem_compl_eq, mem_empty_eq,
          iff_false, not_and, not_not_mem],
        refine imp_of_not_imp_not _ _ (λ hys, _),
        rw hg_seq_zero y hys n,
        exact ne.symm hx, },
    end,
    finite_range' := @simple_func.finite_range _ _ m (g_seq_s n), },
  have hg_eq : ∀ x n, g_seq_s₂ n x = g_seq_s n x := λ x n, rfl,
  refine ⟨g_seq_s₂, λ x, _⟩,
  simp_rw hg_eq,
  exact hg_seq_tendsto x,
end

end strongly_measurable

/-! ## Finitely strongly measurable functions -/

lemma fin_strongly_measurable_zero {α β} {m : measurable_space α} {μ : measure α} [has_zero β]
  [topological_space β] :
  fin_strongly_measurable (0 : α → β) μ :=
⟨0, by simp only [pi.zero_apply, simple_func.coe_zero, support_zero', measure_empty,
    with_top.zero_lt_top, forall_const],
  λ n, tendsto_const_nhds⟩

namespace fin_strongly_measurable

variables {m0 : measurable_space α} {μ : measure α} {f g : α → β}

lemma ae_fin_strongly_measurable [has_zero β] [topological_space β]
  (hf : fin_strongly_measurable f μ) :
  ae_fin_strongly_measurable f μ :=
⟨f, hf, ae_eq_refl f⟩

section sequence
variables [has_zero β] [topological_space β] (hf : fin_strongly_measurable f μ)

/-- A sequence of simple functions such that `∀ x, tendsto (λ n, hf.approx n x) at_top (𝓝 (f x))`
and `∀ n, μ (support (hf.approx n)) < ∞`. These properties are given by
`fin_strongly_measurable.tendsto_approx` and `fin_strongly_measurable.fin_support_approx`. -/
protected noncomputable def approx : ℕ → α →ₛ β := hf.some

protected lemma fin_support_approx : ∀ n, μ (support (hf.approx n)) < ∞ := hf.some_spec.1

protected lemma tendsto_approx : ∀ x, tendsto (λ n, hf.approx n x) at_top (𝓝 (f x)) :=
hf.some_spec.2

end sequence

protected lemma strongly_measurable [has_zero β] [topological_space β]
  (hf : fin_strongly_measurable f μ) :
  strongly_measurable f :=
⟨hf.approx, hf.tendsto_approx⟩

lemma exists_set_sigma_finite [has_zero β] [topological_space β] [t2_space β]
  (hf : fin_strongly_measurable f μ) :
  ∃ t, measurable_set t ∧ (∀ x ∈ tᶜ, f x = 0) ∧ sigma_finite (μ.restrict t) :=
begin
  rcases hf with ⟨fs, hT_lt_top, h_approx⟩,
  let T := λ n, support (fs n),
  have hT_meas : ∀ n, measurable_set (T n), from λ n, simple_func.measurable_set_support (fs n),
  let t := ⋃ n, T n,
  refine ⟨t, measurable_set.Union hT_meas, _, _⟩,
  { have h_fs_zero : ∀ n, ∀ x ∈ tᶜ, fs n x = 0,
    { intros n x hxt,
      rw [set.mem_compl_iff, set.mem_Union, not_exists] at hxt,
      simpa using (hxt n), },
    refine λ x hxt, tendsto_nhds_unique (h_approx x) _,
    rw funext (λ n, h_fs_zero n x hxt),
    exact tendsto_const_nhds, },
  { refine ⟨⟨⟨λ n, tᶜ ∪ T n, λ n, trivial, λ n, _, _⟩⟩⟩,
    { rw [measure.restrict_apply' (measurable_set.Union hT_meas), set.union_inter_distrib_right,
        set.compl_inter_self t, set.empty_union],
      exact (measure_mono (set.inter_subset_left _ _)).trans_lt (hT_lt_top n), },
    { rw ← set.union_Union tᶜ T,
      exact set.compl_union_self _ } }
end

/-- A finitely strongly measurable function is measurable. -/
protected lemma measurable [has_zero β] [topological_space β] [pseudo_metrizable_space β]
  [measurable_space β] [borel_space β] (hf : fin_strongly_measurable f μ) :
  measurable f :=
hf.strongly_measurable.measurable

section arithmetic
variables [topological_space β]

protected lemma mul [monoid_with_zero β] [has_continuous_mul β]
  (hf : fin_strongly_measurable f μ) (hg : fin_strongly_measurable g μ) :
  fin_strongly_measurable (f * g) μ :=
begin
  refine ⟨λ n, hf.approx n * hg.approx n, _, λ x, (hf.tendsto_approx x).mul (hg.tendsto_approx x)⟩,
  intro n,
  exact (measure_mono (support_mul_subset_left _ _)).trans_lt (hf.fin_support_approx n),
end

protected lemma add [add_monoid β] [has_continuous_add β]
  (hf : fin_strongly_measurable f μ) (hg : fin_strongly_measurable g μ) :
  fin_strongly_measurable (f + g) μ :=
⟨λ n, hf.approx n + hg.approx n,
  λ n, (measure_mono (function.support_add _ _)).trans_lt ((measure_union_le _ _).trans_lt
    (ennreal.add_lt_top.mpr ⟨hf.fin_support_approx n, hg.fin_support_approx n⟩)),
  λ x, (hf.tendsto_approx x).add (hg.tendsto_approx x)⟩

protected lemma neg [add_group β] [topological_add_group β] (hf : fin_strongly_measurable f μ) :
  fin_strongly_measurable (-f) μ :=
begin
  refine ⟨λ n, -hf.approx n, λ n, _, λ x, (hf.tendsto_approx x).neg⟩,
  suffices : μ (function.support (λ x, - (hf.approx n) x)) < ∞, by convert this,
  rw function.support_neg (hf.approx n),
  exact hf.fin_support_approx n,
end

protected lemma sub [add_group β] [has_continuous_sub β]
  (hf : fin_strongly_measurable f μ) (hg : fin_strongly_measurable g μ) :
  fin_strongly_measurable (f - g) μ :=
⟨λ n, hf.approx n - hg.approx n,
  λ n, (measure_mono (function.support_sub _ _)).trans_lt ((measure_union_le _ _).trans_lt
    (ennreal.add_lt_top.mpr ⟨hf.fin_support_approx n, hg.fin_support_approx n⟩)),
  λ x, (hf.tendsto_approx x).sub (hg.tendsto_approx x)⟩

protected lemma const_smul {𝕜} [topological_space 𝕜] [add_monoid β] [monoid 𝕜]
  [distrib_mul_action 𝕜 β] [has_continuous_smul 𝕜 β]
  (hf : fin_strongly_measurable f μ) (c : 𝕜) :
  fin_strongly_measurable (c • f) μ :=
begin
  refine ⟨λ n, c • (hf.approx n), λ n, _, λ x, (hf.tendsto_approx x).const_smul c⟩,
  rw simple_func.coe_smul,
  refine (measure_mono (support_smul_subset_right c _)).trans_lt (hf.fin_support_approx n),
end

end arithmetic

section order
variables [topological_space β] [has_zero β]

protected lemma sup [semilattice_sup β] [has_continuous_sup β]
  (hf : fin_strongly_measurable f μ) (hg : fin_strongly_measurable g μ) :
  fin_strongly_measurable (f ⊔ g) μ :=
begin
  refine ⟨λ n, hf.approx n ⊔ hg.approx n, λ n, _,
    λ x, (hf.tendsto_approx x).sup_right_nhds (hg.tendsto_approx x)⟩,
  refine (measure_mono (support_sup _ _)).trans_lt _,
  exact measure_union_lt_top_iff.mpr ⟨hf.fin_support_approx n, hg.fin_support_approx n⟩,
end

protected lemma inf [semilattice_inf β] [has_continuous_inf β]
  (hf : fin_strongly_measurable f μ) (hg : fin_strongly_measurable g μ) :
  fin_strongly_measurable (f ⊓ g) μ :=
begin
  refine ⟨λ n, hf.approx n ⊓ hg.approx n, λ n, _,
    λ x, (hf.tendsto_approx x).inf_right_nhds (hg.tendsto_approx x)⟩,
  refine (measure_mono (support_inf _ _)).trans_lt _,
  exact measure_union_lt_top_iff.mpr ⟨hf.fin_support_approx n, hg.fin_support_approx n⟩,
end

end order

end fin_strongly_measurable

lemma fin_strongly_measurable_iff_strongly_measurable_and_exists_set_sigma_finite {α β} {f : α → β}
  [topological_space β] [t2_space β] [has_zero β] {m : measurable_space α} {μ : measure α} :
  fin_strongly_measurable f μ ↔ (strongly_measurable f
    ∧ (∃ t, measurable_set t ∧ (∀ x ∈ tᶜ, f x = 0) ∧ sigma_finite (μ.restrict t))) :=
⟨λ hf, ⟨hf.strongly_measurable, hf.exists_set_sigma_finite⟩,
  λ hf, hf.1.fin_strongly_measurable_of_set_sigma_finite hf.2.some_spec.1 hf.2.some_spec.2.1
    hf.2.some_spec.2.2⟩

lemma ae_fin_strongly_measurable_zero {α β} {m : measurable_space α} (μ : measure α) [has_zero β]
  [topological_space β] :
  ae_fin_strongly_measurable (0 : α → β) μ :=
⟨0, fin_strongly_measurable_zero, eventually_eq.rfl⟩


/-! ## Almost everywhere strongly measurable functions -/

lemma ae_strongly_measurable_const {α β} {m : measurable_space α} {μ : measure α}
  [topological_space β] {b : β} :
  ae_strongly_measurable (λ a : α, b) μ :=
strongly_measurable_const.ae_strongly_measurable

@[to_additive] lemma ae_strongly_measurable_one {α β} {m : measurable_space α} {μ : measure α}
  [topological_space β] [has_one β] :
  ae_strongly_measurable (1 : α → β) μ :=
strongly_measurable_one.ae_strongly_measurable

@[simp] lemma subsingleton.ae_strongly_measurable {m : measurable_space α} [topological_space β]
  [subsingleton β] {μ : measure α} (f : α → β) :
  ae_strongly_measurable f μ :=
(subsingleton.strongly_measurable f).ae_strongly_measurable

@[simp] lemma subsingleton.ae_strongly_measurable' {m : measurable_space α} [topological_space β]
  [subsingleton α] {μ : measure α} (f : α → β) :
  ae_strongly_measurable f μ :=
(subsingleton.strongly_measurable' f).ae_strongly_measurable

@[simp] lemma ae_measurable_zero_measure [measurable_space α] [topological_space β]
  (f : α → β) :
  ae_strongly_measurable f (0 : measure α) :=
begin
  nontriviality α,
  inhabit α,
  exact ⟨λ x, f default, strongly_measurable_const, rfl⟩
end

lemma simple_func.ae_strongly_measurable {m : measurable_space α} {μ : measure α}
  [topological_space β] (f : α →ₛ β) :
  ae_strongly_measurable f μ :=
f.strongly_measurable.ae_strongly_measurable

namespace ae_strongly_measurable

variables {m : measurable_space α} {μ : measure α} [topological_space β] [topological_space γ]
  {f g : α → β}

section mk

/-- A `strongly_measurable` function such that `f =ᵐ[μ] hf.mk f`. See lemmas
`strongly_measurable_mk` and `ae_eq_mk`. -/
protected noncomputable def mk (f : α → β) (hf : ae_strongly_measurable f μ) : α → β := hf.some

lemma strongly_measurable_mk (hf : ae_strongly_measurable f μ) :
  strongly_measurable (hf.mk f) :=
hf.some_spec.1

lemma measurable_mk [pseudo_metrizable_space β] [measurable_space β] [borel_space β]
  (hf : ae_strongly_measurable f μ) :
  measurable (hf.mk f) :=
hf.strongly_measurable_mk.measurable

lemma ae_eq_mk (hf : ae_strongly_measurable f μ) : f =ᵐ[μ] hf.mk f :=
hf.some_spec.2

protected lemma ae_measurable {β} [measurable_space β] [topological_space β]
  [pseudo_metrizable_space β] [borel_space β] {f : α → β} (hf : ae_strongly_measurable f μ) :
  ae_measurable f μ :=
⟨hf.mk f, hf.strongly_measurable_mk.measurable, hf.ae_eq_mk⟩

end mk

lemma congr (hf : ae_strongly_measurable f μ) (h : f =ᵐ[μ] g) : ae_strongly_measurable g μ :=
⟨hf.mk f, hf.strongly_measurable_mk, h.symm.trans hf.ae_eq_mk⟩

lemma _root_.ae_strongly_measurable_congr (h : f =ᵐ[μ] g) :
  ae_strongly_measurable f μ ↔ ae_strongly_measurable g μ :=
⟨λ hf, hf.congr h, λ hg, hg.congr h.symm⟩

lemma mono_measure {ν : measure α} (hf : ae_strongly_measurable f μ) (h : ν ≤ μ) :
  ae_strongly_measurable f ν :=
⟨hf.mk f, hf.strongly_measurable_mk, eventually.filter_mono (ae_mono h) hf.ae_eq_mk⟩

protected lemma mono' {ν : measure α} (h : ae_strongly_measurable f μ) (h' : ν ≪ μ) :
  ae_strongly_measurable f ν :=
⟨h.mk f, h.strongly_measurable_mk, h' h.ae_eq_mk⟩

lemma mono_set {s t} (h : s ⊆ t) (ht : ae_strongly_measurable f (μ.restrict t)) :
  ae_strongly_measurable f (μ.restrict s) :=
ht.mono_measure (restrict_mono h le_rfl)

protected lemma restrict (hfm : ae_strongly_measurable f μ) {s} :
  ae_strongly_measurable f (μ.restrict s) :=
hfm.mono_measure measure.restrict_le_self

lemma ae_mem_imp_eq_mk {s} (h : ae_strongly_measurable f (μ.restrict s)) :
  ∀ᵐ x ∂μ, x ∈ s → f x = h.mk f x :=
ae_imp_of_ae_restrict h.ae_eq_mk

/-- The composition of a continuous function and an ae strongly measurable function is ae strongly
measurable. -/
lemma _root_.continuous.comp_ae_strongly_measurable {g : β → γ} {f : α → β}
  (hg : continuous g) (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, g (f x)) μ :=
⟨_, hg.comp_strongly_measurable hf.strongly_measurable_mk, eventually_eq.fun_comp hf.ae_eq_mk g⟩

/-- A continuous function from `α` to `β` is ae strongly measurable when one of the two spaces is
second countable. -/
lemma _root_.continuous.ae_strongly_measurable [topological_space α] [opens_measurable_space α]
  [pseudo_metrizable_space β] [second_countable_topology_either α β] (hf : continuous f) :
  ae_strongly_measurable f μ :=
hf.strongly_measurable.ae_strongly_measurable

protected lemma prod_mk {f : α → β} {g : α → γ}
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (λ x, (f x, g x)) μ :=
⟨λ x, (hf.mk f x, hg.mk g x), hf.strongly_measurable_mk.prod_mk hg.strongly_measurable_mk,
  hf.ae_eq_mk.prod_mk hg.ae_eq_mk⟩

/-- In a space with second countable topology, measurable implies ae strongly measurable. -/
lemma _root_.measurable.ae_strongly_measurable {m : measurable_space α}
  {μ : measure α} [measurable_space β] [pseudo_metrizable_space β]
  [second_countable_topology β] [opens_measurable_space β] (hf : measurable f) :
  ae_strongly_measurable f μ :=
hf.strongly_measurable.ae_strongly_measurable

section arithmetic

@[to_additive]
protected lemma mul [has_mul β] [has_continuous_mul β]
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (f * g) μ :=
⟨hf.mk f * hg.mk g, hf.strongly_measurable_mk.mul hg.strongly_measurable_mk,
  hf.ae_eq_mk.mul hg.ae_eq_mk⟩

@[to_additive]
protected lemma mul_const [has_mul β] [has_continuous_mul β]
  (hf : ae_strongly_measurable f μ) (c : β) :
  ae_strongly_measurable (λ x, f x * c) μ :=
hf.mul ae_strongly_measurable_const

@[to_additive]
protected lemma const_mul [has_mul β] [has_continuous_mul β]
  (hf : ae_strongly_measurable f μ) (c : β) :
  ae_strongly_measurable (λ x, c * f x) μ :=
ae_strongly_measurable_const.mul hf

@[to_additive]
protected lemma inv [group β] [topological_group β] (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable (f⁻¹) μ :=
⟨(hf.mk f)⁻¹, hf.strongly_measurable_mk.inv, hf.ae_eq_mk.inv⟩

@[to_additive]
protected lemma div [group β] [topological_group β]
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (f / g) μ :=
⟨hf.mk f / hg.mk g, hf.strongly_measurable_mk.div hg.strongly_measurable_mk,
  hf.ae_eq_mk.div hg.ae_eq_mk⟩

@[to_additive]
protected lemma smul {𝕜} [topological_space 𝕜] [has_scalar 𝕜 β] [has_continuous_smul 𝕜 β]
  {f : α → 𝕜} {g : α → β} (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (λ x, f x • g x) μ :=
continuous_smul.comp_ae_strongly_measurable (hf.prod_mk hg)

protected lemma const_smul {𝕜} [has_scalar 𝕜 β] [has_continuous_const_smul 𝕜 β]
  (hf : ae_strongly_measurable f μ) (c : 𝕜) :
  ae_strongly_measurable (c • f) μ :=
⟨c • hf.mk f, hf.strongly_measurable_mk.const_smul c, hf.ae_eq_mk.const_smul c⟩

protected lemma const_smul' {𝕜} [has_scalar 𝕜 β] [has_continuous_const_smul 𝕜 β]
  (hf : ae_strongly_measurable f μ) (c : 𝕜) :
  ae_strongly_measurable (λ x, c • (f x)) μ :=
hf.const_smul c

@[to_additive]
protected lemma smul_const {𝕜} [topological_space 𝕜] [has_scalar 𝕜 β] [has_continuous_smul 𝕜 β]
  {f : α → 𝕜} (hf : ae_strongly_measurable f μ) (c : β) :
  ae_strongly_measurable (λ x, f x • c) μ :=
continuous_smul.comp_ae_strongly_measurable (hf.prod_mk ae_strongly_measurable_const)

end arithmetic

section order

protected lemma sup [semilattice_sup β] [has_continuous_sup β]
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (f ⊔ g) μ :=
⟨hf.mk f ⊔ hg.mk g, hf.strongly_measurable_mk.sup hg.strongly_measurable_mk,
  hf.ae_eq_mk.sup hg.ae_eq_mk⟩

protected lemma inf [semilattice_inf β] [has_continuous_inf β]
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (f ⊓ g) μ :=
⟨hf.mk f ⊓ hg.mk g, hf.strongly_measurable_mk.inf hg.strongly_measurable_mk,
  hf.ae_eq_mk.inf hg.ae_eq_mk⟩

end order

/-!
### Big operators: `∏` and `∑`
-/

section monoid
variables {M : Type*} [monoid M] [topological_space M] [has_continuous_mul M]

@[to_additive]
lemma _root_.list.ae_strongly_measurable_prod' (l : list (α → M))
  (hl : ∀ f ∈ l, ae_strongly_measurable f μ) : ae_strongly_measurable l.prod μ :=
begin
  induction l with f l ihl, { exact ae_strongly_measurable_one },
  rw [list.forall_mem_cons] at hl,
  rw [list.prod_cons],
  exact hl.1.mul (ihl hl.2)
end

@[to_additive]
lemma _root_.list.ae_strongly_measurable_prod
  (l : list (α → M)) (hl : ∀ f ∈ l, ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, (l.map (λ f : α → M, f x)).prod) μ :=
by simpa only [← pi.list_prod_apply] using l.ae_strongly_measurable_prod' hl

end monoid

section comm_monoid
variables {M : Type*} [comm_monoid M] [topological_space M] [has_continuous_mul M]

@[to_additive]
lemma _root_.multiset.ae_strongly_measurable_prod' (l : multiset (α → M))
  (hl : ∀ f ∈ l, ae_strongly_measurable f μ) : ae_strongly_measurable l.prod μ :=
by { rcases l with ⟨l⟩, simpa using l.ae_strongly_measurable_prod' (by simpa using hl) }

@[to_additive]
lemma _root_.multiset.ae_strongly_measurable_prod (s : multiset (α → M))
  (hs : ∀ f ∈ s, ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, (s.map (λ f : α → M, f x)).prod) μ :=
by simpa only [← pi.multiset_prod_apply] using s.ae_strongly_measurable_prod' hs

@[to_additive]
lemma _root_.finset.ae_strongly_measurable_prod' {ι : Type*}  {f : ι → α → M}
  (s : finset ι) (hf : ∀i ∈ s, ae_strongly_measurable (f i) μ) :
  ae_strongly_measurable (∏ i in s, f i) μ :=
multiset.ae_strongly_measurable_prod' _ $
  λ g hg, let ⟨i, hi, hg⟩ := multiset.mem_map.1 hg in (hg ▸ hf _ hi)

@[to_additive]
lemma _root_.finset.ae_strongly_measurable_prod {ι : Type*}  {f : ι → α → M}
  (s : finset ι) (hf : ∀i ∈ s, ae_strongly_measurable (f i) μ) :
  ae_strongly_measurable (λ a, ∏ i in s, f i a) μ :=
by simpa only [← finset.prod_apply] using s.ae_strongly_measurable_prod' hf

end comm_monoid

section second_countable_ae_strongly_measurable

variables [measurable_space β]

/-- In a space with second countable topology, measurable implies strongly measurable. -/
lemma _root_.ae_measurable.ae_strongly_measurable [pseudo_metrizable_space β]
  [opens_measurable_space β] [second_countable_topology β] (hf : ae_measurable f μ) :
  ae_strongly_measurable f μ :=
⟨hf.mk f, hf.measurable_mk.strongly_measurable, hf.ae_eq_mk⟩

lemma _root_.ae_strongly_measurable_id {α : Type*} [topological_space α] [pseudo_metrizable_space α]
  {m : measurable_space α} [opens_measurable_space α] [second_countable_topology α]
  {μ : measure α} :
  ae_strongly_measurable (id : α → α) μ :=
ae_measurable_id.ae_strongly_measurable

/-- In a space with second countable topology, strongly measurable and measurable are equivalent. -/
lemma _root_.ae_strongly_measurable_iff_ae_measurable [pseudo_metrizable_space β] [borel_space β]
  [second_countable_topology β] :
  ae_strongly_measurable f μ ↔ ae_measurable f μ :=
⟨λ h, h.ae_measurable, λ h, h.ae_strongly_measurable⟩

end second_countable_ae_strongly_measurable

protected lemma dist {β : Type*} [pseudo_metric_space β] {f g : α → β}
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (λ x, dist (f x) (g x)) μ :=
continuous_dist.comp_ae_strongly_measurable (hf.prod_mk hg)

protected lemma norm {β : Type*} [normed_group β] {f : α → β} (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, ∥f x∥) μ :=
continuous_norm.comp_ae_strongly_measurable hf

protected lemma nnnorm {β : Type*} [normed_group β] {f : α → β} (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, ∥f x∥₊) μ :=
continuous_nnnorm.comp_ae_strongly_measurable hf

protected lemma ennnorm {β : Type*} [normed_group β] {f : α → β} (hf : ae_strongly_measurable f μ) :
  ae_measurable (λ a, (∥f a∥₊ : ℝ≥0∞)) μ :=
(ennreal.continuous_coe.comp_ae_strongly_measurable hf.nnnorm).ae_measurable

protected lemma edist {β : Type*} [normed_group β] {f g : α → β}
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_measurable (λ a, edist (f a) (g a)) μ :=
(continuous_edist.comp_ae_strongly_measurable (hf.prod_mk hg)).ae_measurable

protected lemma real_to_nnreal {f : α → ℝ}
  (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, (f x).to_nnreal) μ :=
continuous_real_to_nnreal.comp_ae_strongly_measurable hf

section
variables {𝕜 : Type*} {E : Type*} [is_R_or_C 𝕜] [inner_product_space 𝕜 E]
local notation `⟪`x`, `y`⟫` := @inner 𝕜 _ _ x y

protected lemma re {f : α → 𝕜} (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, is_R_or_C.re (f x)) μ :=
is_R_or_C.continuous_re.comp_ae_strongly_measurable hf

protected lemma im {f : α → 𝕜} (hf : ae_strongly_measurable f μ) :
  ae_strongly_measurable (λ x, is_R_or_C.im (f x)) μ :=
is_R_or_C.continuous_im.comp_ae_strongly_measurable hf

protected lemma inner {m : measurable_space α} {μ : measure α} {f g : α → E}
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (λ x, ⟪f x, g x⟫) μ :=
continuous_inner.comp_ae_strongly_measurable (hf.prod_mk hg)

end

lemma _root_.ae_strongly_measurable_indicator_iff [has_zero β] {s : set α} (hs : measurable_set s) :
  ae_strongly_measurable (indicator s f) μ ↔ ae_strongly_measurable f (μ.restrict s)  :=
begin
  split,
  { intro h,
    exact (h.mono_measure measure.restrict_le_self).congr (indicator_ae_eq_restrict hs) },
  { intro h,
    refine ⟨indicator s (h.mk f), h.strongly_measurable_mk.indicator hs, _⟩,
    have A : s.indicator f =ᵐ[μ.restrict s] s.indicator (h.mk f) :=
      (indicator_ae_eq_restrict hs).trans (h.ae_eq_mk.trans $ (indicator_ae_eq_restrict hs).symm),
    have B : s.indicator f =ᵐ[μ.restrict sᶜ] s.indicator (h.mk f) :=
      (indicator_ae_eq_restrict_compl hs).trans (indicator_ae_eq_restrict_compl hs).symm,
    exact ae_of_ae_restrict_of_ae_restrict_compl _ A B },
end

protected lemma indicator [has_zero β]
  (hfm : ae_strongly_measurable f μ) {s : set α} (hs : measurable_set s) :
  ae_strongly_measurable (s.indicator f) μ :=
(ae_strongly_measurable_indicator_iff hs).mpr hfm.restrict

lemma _root_.ae_strongly_measurable_of_ae_strongly_measurable_trim {α} {m m0 : measurable_space α}
  {μ : measure α} (hm : m ≤ m0) {f : α → β} (hf : ae_strongly_measurable f (μ.trim hm)) :
  ae_strongly_measurable f μ :=
⟨hf.mk f, strongly_measurable.mono hf.strongly_measurable_mk hm, ae_eq_of_ae_eq_trim hf.ae_eq_mk⟩

lemma comp_ae_measurable {γ : Type*} {mγ : measurable_space γ} {mα : measurable_space α} {f : γ → α}
  {μ : measure γ} (hg : ae_strongly_measurable g (measure.map f μ)) (hf : ae_measurable f μ) :
  ae_strongly_measurable (g ∘ f) μ :=
⟨(hg.mk g) ∘ hf.mk f, hg.strongly_measurable_mk.comp_measurable hf.measurable_mk,
  (ae_eq_comp hf hg.ae_eq_mk).trans ((hf.ae_eq_mk).fun_comp (hg.mk g))⟩

lemma comp_measurable {γ : Type*} {mγ : measurable_space γ} {mα : measurable_space α} {f : γ → α}
  {μ : measure γ} (hg : ae_strongly_measurable g (measure.map f μ)) (hf : measurable f) :
  ae_strongly_measurable (g ∘ f) μ :=
hg.comp_ae_measurable hf.ae_measurable

lemma comp_measurable' {γ : Type*} {mγ : measurable_space γ} {mα : measurable_space α} {f : γ → α}
  {μ : measure γ} {ν : measure α} (hg : ae_strongly_measurable g ν) (hf : measurable f)
  (h : μ.map f ≪ ν) : ae_strongly_measurable (g ∘ f) μ :=
(hg.mono' h).comp_measurable hf

lemma is_separable_ae_range (hf : ae_strongly_measurable f μ) :
  ∃ (t : set β), is_separable t ∧ ∀ᵐ x ∂μ, f x ∈ t :=
begin
  refine ⟨range (hf.mk f), hf.strongly_measurable_mk.is_separable_range, _⟩,
  filter_upwards [hf.ae_eq_mk] with x hx,
  simp [hx]
end

/-- A function is almost everywhere strongly measurable if and only if it is almost everywhere
measurable, and up to a zero measure set its range is contained in a separable set. -/
theorem _root_.ae_strongly_measurable_iff_ae_measurable_separable
  [pseudo_metrizable_space β] [measurable_space β] [borel_space β] :
  ae_strongly_measurable f μ ↔
    (ae_measurable f μ ∧ ∃ (t : set β), is_separable t ∧ ∀ᵐ x ∂μ, f x ∈ t) :=
begin
  refine ⟨λ H, ⟨H.ae_measurable, H.is_separable_ae_range⟩, _⟩,
  rintros ⟨H, ⟨t, t_sep, ht⟩⟩,
  rcases eq_empty_or_nonempty t with rfl|h₀,
  { simp only [mem_empty_eq, eventually_false_iff_eq_bot, ae_eq_bot] at ht,
    rw ht,
    exact ae_measurable_zero_measure f },
  { obtain ⟨g, g_meas, gt, fg⟩ : ∃ (g : α → β), measurable g ∧ range g ⊆ t ∧ f =ᵐ[μ] g :=
      H.exists_ae_eq_range_subset ht h₀,
    refine ⟨g, _, fg⟩,
    exact strongly_measurable_iff_measurable_separable.2 ⟨g_meas, t_sep.mono gt⟩ }
end

lemma _root_.measurable_embedding.ae_strongly_measurable_map_iff
  {γ : Type*} {mγ : measurable_space γ} {mα : measurable_space α}
  {f : γ → α} {μ : measure γ} (hf : measurable_embedding f) {g : α → β} :
  ae_strongly_measurable g (measure.map f μ) ↔ ae_strongly_measurable (g ∘ f) μ :=
begin
  refine ⟨λ H, H.comp_measurable hf.measurable, _⟩,
  rintro ⟨g₁, hgm₁, heq⟩,
  rcases hf.exists_strongly_measurable_extend hgm₁ (λ x, ⟨g x⟩) with ⟨g₂, hgm₂, rfl⟩,
  exact ⟨g₂, hgm₂, hf.ae_map_iff.2 heq⟩
end

lemma _root_.embedding.ae_strongly_measurable_comp_iff
  [pseudo_metrizable_space β] [pseudo_metrizable_space γ]
  {g : β → γ} {f : α → β} (hg : embedding g) :
  ae_strongly_measurable (λ x, g (f x)) μ ↔ ae_strongly_measurable f μ :=
begin
  letI := pseudo_metrizable_space_pseudo_metric γ,
  borelize [β, γ],
  refine ⟨λ H, ae_strongly_measurable_iff_ae_measurable_separable.2 ⟨_, _⟩,
    λ H, hg.continuous.comp_ae_strongly_measurable H⟩,
  { let G : β → range g := cod_restrict g (range g) mem_range_self,
    have hG : closed_embedding G :=
    { closed_range :=
      begin
        convert is_closed_univ,
        apply eq_univ_of_forall,
        rintros ⟨-, ⟨x, rfl⟩⟩,
        exact mem_range_self x
      end,
      .. hg.cod_restrict _ _ },
    have : ae_measurable (G ∘ f) μ := ae_measurable.subtype_mk H.ae_measurable,
    exact hG.measurable_embedding.ae_measurable_comp_iff.1 this },
  { rcases (ae_strongly_measurable_iff_ae_measurable_separable.1 H).2 with ⟨t, ht, h't⟩,
    exact ⟨g⁻¹' t, hg.is_separable_preimage ht, h't⟩ }
end

lemma _root_.measure_theory.measure_preserving.ae_strongly_measurable_comp_iff {β : Type*}
  {f : α → β} {mα : measurable_space α} {μa : measure α}  {mβ : measurable_space β} {μb : measure β}
  (hf : measure_preserving f μa μb) (h₂ : measurable_embedding f) {g : β → γ} :
  ae_strongly_measurable (g ∘ f) μa ↔ ae_strongly_measurable g μb :=
by rw [← hf.map_eq, h₂.ae_strongly_measurable_map_iff]

/-- An almost everywhere sequential limit of almost everywhere strongly measurable functions is
almost everywhere strongly measurable. -/
lemma _root_.ae_strongly_measurable_of_tendsto_ae {ι : Type*}
  [pseudo_metrizable_space β] (u : filter ι) [ne_bot u] [is_countably_generated u]
  {f : ι → α → β} {g : α → β} (hf : ∀ i, ae_strongly_measurable (f i) μ)
  (lim : ∀ᵐ x ∂μ, tendsto (λ n, f n x) u (𝓝 (g x))) :
  ae_strongly_measurable g μ :=
begin
  borelize β,
  refine ae_strongly_measurable_iff_ae_measurable_separable.2 ⟨_, _⟩,
  { exact ae_measurable_of_tendsto_metrizable_ae _ (λ n, (hf n).ae_measurable) lim },
  { rcases u.exists_seq_tendsto with ⟨v, hv⟩,
    have : ∀ (n : ℕ), ∃ (t : set β), is_separable t ∧ f (v n) ⁻¹' t ∈ μ.ae :=
      λ n, (ae_strongly_measurable_iff_ae_measurable_separable.1 (hf (v n))).2,
    choose t t_sep ht using this,
    refine ⟨closure (⋃ i, (t i)), (is_separable_Union (λ i, (t_sep i))).closure, _⟩,
    filter_upwards [ae_all_iff.2 ht, lim] with x hx h'x,
    apply mem_closure_of_tendsto ((h'x).comp hv),
    apply eventually_of_forall (λ n, _),
    apply mem_Union_of_mem n,
    exact hx n }
end

/-- If a sequence of almost everywhere strongly measurable functions converges almost everywhere,
one can select a strongly measurable function as the almost everywhere limit. -/
lemma _root_.exists_strongly_measurable_limit_of_tendsto_ae [pseudo_metrizable_space β]
  {f : ℕ → α → β} (hf : ∀ n, ae_strongly_measurable (f n) μ)
  (h_ae_tendsto : ∀ᵐ x ∂μ, ∃ l : β, tendsto (λ n, f n x) at_top (𝓝 l)) :
  ∃ (f_lim : α → β) (hf_lim_meas : strongly_measurable f_lim),
    ∀ᵐ x ∂μ, tendsto (λ n, f n x) at_top (𝓝 (f_lim x)) :=
begin
  borelize β,
  obtain ⟨g, g_meas, hg⟩ : ∃ (g : α → β) (g_meas : measurable g),
      ∀ᵐ x ∂μ, tendsto (λ n, f n x) at_top (𝓝 (g x)) :=
    measurable_limit_of_tendsto_metrizable_ae (λ n, (hf n).ae_measurable) h_ae_tendsto,
  have Hg : ae_strongly_measurable g μ := ae_strongly_measurable_of_tendsto_ae _ hf hg,
  refine ⟨Hg.mk g, Hg.strongly_measurable_mk, _⟩,
  filter_upwards [hg, Hg.ae_eq_mk] with x hx h'x,
  rwa h'x at hx,
end

lemma sum_measure [pseudo_metrizable_space β]
  {m : measurable_space α} {μ : ι → measure α} (h : ∀ i, ae_strongly_measurable f (μ i)) :
  ae_strongly_measurable f (measure.sum μ) :=
begin
  borelize β,
  refine ae_strongly_measurable_iff_ae_measurable_separable.2
    ⟨ae_measurable.sum_measure (λ i, (h i).ae_measurable), _⟩,
  have A : ∀ (i : ι), ∃ (t : set β), is_separable t ∧ f ⁻¹' t ∈ (μ i).ae :=
    λ i, (ae_strongly_measurable_iff_ae_measurable_separable.1 (h i)).2,
  choose t t_sep ht using A,
  refine ⟨(⋃ i, t i), is_separable_Union t_sep, _⟩,
  simp only [measure.ae_sum_eq, mem_Union, eventually_supr],
  assume i,
  filter_upwards [ht i] with x hx,
  exact ⟨i, hx⟩
end

@[simp] lemma _root_.ae_strongly_measurable_sum_measure_iff
  [pseudo_metrizable_space β] {m : measurable_space α} {μ : ι → measure α} :
  ae_strongly_measurable f (sum μ) ↔ ∀ i, ae_strongly_measurable f (μ i) :=
⟨λ h i, h.mono_measure (measure.le_sum _ _), sum_measure⟩

@[simp] lemma _root_.ae_strongly_measurable_add_measure_iff [pseudo_metrizable_space β]
  {ν : measure α} :
  ae_strongly_measurable f (μ + ν) ↔ ae_strongly_measurable f μ ∧ ae_strongly_measurable f ν :=
by { rw [← sum_cond, ae_strongly_measurable_sum_measure_iff, bool.forall_bool, and.comm], refl }

lemma add_measure [pseudo_metrizable_space β] {ν : measure α} {f : α → β}
  (hμ : ae_strongly_measurable f μ) (hν : ae_strongly_measurable f ν) :
  ae_strongly_measurable f (μ + ν) :=
ae_strongly_measurable_add_measure_iff.2 ⟨hμ, hν⟩

protected lemma Union [pseudo_metrizable_space β] {s : ι → set α}
  (h : ∀ i, ae_strongly_measurable f (μ.restrict (s i))) :
  ae_strongly_measurable f (μ.restrict (⋃ i, s i)) :=
(sum_measure h).mono_measure $ restrict_Union_le

@[simp] lemma _root_.ae_strongly_measurable_Union_iff [pseudo_metrizable_space β] {s : ι → set α} :
  ae_strongly_measurable f (μ.restrict (⋃ i, s i)) ↔
    ∀ i, ae_strongly_measurable f (μ.restrict (s i)) :=
⟨λ h i, h.mono_measure $ restrict_mono (subset_Union _ _) le_rfl, ae_strongly_measurable.Union⟩

@[simp] lemma _root_.ae_strongly_measurable_union_iff [pseudo_metrizable_space β] {s t : set α} :
  ae_strongly_measurable f (μ.restrict (s ∪ t)) ↔
    ae_strongly_measurable f (μ.restrict s) ∧ ae_strongly_measurable f (μ.restrict t) :=
by simp only [union_eq_Union, ae_strongly_measurable_Union_iff, bool.forall_bool, cond, and.comm]

lemma smul_measure {R : Type*} [monoid R] [distrib_mul_action R ℝ≥0∞]
  [is_scalar_tower R ℝ≥0∞ ℝ≥0∞] (h : ae_strongly_measurable f μ) (c : R) :
  ae_strongly_measurable f (c • μ) :=
⟨h.mk f, h.strongly_measurable_mk, ae_smul_measure h.ae_eq_mk c⟩

section normed_space
variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜] [complete_space 𝕜]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]

lemma _root_.ae_strongly_measurable_smul_const_iff {f : α → 𝕜} {c : E} (hc : c ≠ 0) :
  ae_strongly_measurable (λ x, f x • c) μ ↔ ae_strongly_measurable f μ :=
(closed_embedding_smul_left hc).to_embedding.ae_strongly_measurable_comp_iff

end normed_space

section mul_action

variables {G : Type*} [group G] [mul_action G β]
  [has_continuous_const_smul G β]

lemma _root_.ae_strongly_measurable_const_smul_iff (c : G) :
  ae_strongly_measurable (λ x, c • f x) μ ↔ ae_strongly_measurable f μ :=
⟨λ h, by simpa only [inv_smul_smul] using h.const_smul' c⁻¹, λ h, h.const_smul c⟩

variables {G₀ : Type*} [group_with_zero G₀] [mul_action G₀ β]
  [has_continuous_const_smul G₀ β]

lemma _root_.ae_strongly_measurable_const_smul_iff₀ {c : G₀} (hc : c ≠ 0) :
  ae_strongly_measurable (λ x, c • f x) μ ↔ ae_strongly_measurable f μ :=
begin
  refine ⟨λ h, _, λ h, h.const_smul c⟩,
  convert h.const_smul' c⁻¹,
  simp [smul_smul, inv_mul_cancel hc]
end

end mul_action

section continuous_linear_map_nondiscrete_normed_field

variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜]
variables {E : Type*} [normed_group E] [normed_space 𝕜 E]
variables {F : Type*} [normed_group F] [normed_space 𝕜 F]
variables {G : Type*} [normed_group G] [normed_space 𝕜 G]

lemma _root_.strongly_measurable.apply_continuous_linear_map
  {m : measurable_space α} {φ : α → F →L[𝕜] E} (hφ : strongly_measurable φ) (v : F) :
  strongly_measurable (λ a, φ a v) :=
(continuous_linear_map.apply 𝕜 E v).continuous.comp_strongly_measurable hφ

lemma apply_continuous_linear_map {φ : α → F →L[𝕜] E}
  (hφ : ae_strongly_measurable φ μ) (v : F) :
  ae_strongly_measurable (λ a, φ a v) μ :=
(continuous_linear_map.apply 𝕜 E v).continuous.comp_ae_strongly_measurable hφ

lemma _root_.continuous_linear_map.ae_strongly_measurable_comp₂ (L : E →L[𝕜] F →L[𝕜] G)
  {f : α → E} {g : α → F}
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (λ x, L (f x) (g x)) μ :=
L.continuous₂.comp_ae_strongly_measurable $ hf.prod_mk hg

end continuous_linear_map_nondiscrete_normed_field

lemma _root_.ae_strongly_measurable_with_density_iff {E : Type*} [normed_group E] [normed_space ℝ E]
  {f : α → ℝ≥0} (hf : measurable f) {g : α → E} :
  ae_strongly_measurable g (μ.with_density (λ x, (f x : ℝ≥0∞))) ↔
    ae_strongly_measurable (λ x, (f x : ℝ) • g x) μ :=
begin
  split,
  { rintros ⟨g', g'meas, hg'⟩,
    have A : measurable_set {x : α | f x ≠ 0} := (hf (measurable_set_singleton 0)).compl,
    refine ⟨λ x, (f x : ℝ) • g' x, hf.coe_nnreal_real.strongly_measurable.smul g'meas, _⟩,
    apply @ae_of_ae_restrict_of_ae_restrict_compl _ _ _ {x | f x ≠ 0},
    { rw [eventually_eq, ae_with_density_iff hf.coe_nnreal_ennreal] at hg',
      rw ae_restrict_iff' A,
      filter_upwards [hg'] with a ha h'a,
      have : (f a : ℝ≥0∞) ≠ 0, by simpa only [ne.def, ennreal.coe_eq_zero] using h'a,
      rw ha this },
    { filter_upwards [ae_restrict_mem A.compl] with x hx,
      simp only [not_not, mem_set_of_eq, mem_compl_eq] at hx,
      simp [hx] } },
  { rintros ⟨g', g'meas, hg'⟩,
    refine ⟨λ x, (f x : ℝ)⁻¹ • g' x, hf.coe_nnreal_real.inv.strongly_measurable.smul g'meas, _⟩,
    rw [eventually_eq, ae_with_density_iff hf.coe_nnreal_ennreal],
    filter_upwards [hg'] with x hx h'x,
    rw [← hx, smul_smul, _root_.inv_mul_cancel, one_smul],
    simp only [ne.def, ennreal.coe_eq_zero] at h'x,
    simpa only [nnreal.coe_eq_zero, ne.def] using h'x }
end

end ae_strongly_measurable


/-! ## Almost everywhere finitely strongly measurable functions -/

namespace ae_fin_strongly_measurable

variables {m : measurable_space α} {μ : measure α} [topological_space β]
  {f g : α → β}

section mk
variables [has_zero β]

/-- A `fin_strongly_measurable` function such that `f =ᵐ[μ] hf.mk f`. See lemmas
`fin_strongly_measurable_mk` and `ae_eq_mk`. -/
protected noncomputable def mk (f : α → β) (hf : ae_fin_strongly_measurable f μ) : α → β := hf.some

lemma fin_strongly_measurable_mk (hf : ae_fin_strongly_measurable f μ) :
  fin_strongly_measurable (hf.mk f) μ :=
hf.some_spec.1

lemma ae_eq_mk (hf : ae_fin_strongly_measurable f μ) : f =ᵐ[μ] hf.mk f :=
hf.some_spec.2

protected lemma ae_measurable {β} [has_zero β] [measurable_space β] [topological_space β]
  [pseudo_metrizable_space β] [borel_space β]
  {f : α → β} (hf : ae_fin_strongly_measurable f μ) :
  ae_measurable f μ :=
⟨hf.mk f, hf.fin_strongly_measurable_mk.measurable, hf.ae_eq_mk⟩

end mk

section arithmetic

protected lemma mul [monoid_with_zero β] [has_continuous_mul β]
  (hf : ae_fin_strongly_measurable f μ) (hg : ae_fin_strongly_measurable g μ) :
  ae_fin_strongly_measurable (f * g) μ :=
⟨hf.mk f * hg.mk g, hf.fin_strongly_measurable_mk.mul hg.fin_strongly_measurable_mk,
  hf.ae_eq_mk.mul hg.ae_eq_mk⟩

protected lemma add [add_monoid β] [has_continuous_add β]
  (hf : ae_fin_strongly_measurable f μ) (hg : ae_fin_strongly_measurable g μ) :
  ae_fin_strongly_measurable (f + g) μ :=
⟨hf.mk f + hg.mk g, hf.fin_strongly_measurable_mk.add hg.fin_strongly_measurable_mk,
  hf.ae_eq_mk.add hg.ae_eq_mk⟩

protected lemma neg [add_group β] [topological_add_group β] (hf : ae_fin_strongly_measurable f μ) :
  ae_fin_strongly_measurable (-f) μ :=
⟨-hf.mk f, hf.fin_strongly_measurable_mk.neg, hf.ae_eq_mk.neg⟩

protected lemma sub [add_group β] [has_continuous_sub β]
  (hf : ae_fin_strongly_measurable f μ) (hg : ae_fin_strongly_measurable g μ) :
  ae_fin_strongly_measurable (f - g) μ :=
⟨hf.mk f - hg.mk g, hf.fin_strongly_measurable_mk.sub hg.fin_strongly_measurable_mk,
  hf.ae_eq_mk.sub hg.ae_eq_mk⟩

protected lemma const_smul {𝕜} [topological_space 𝕜] [add_monoid β] [monoid 𝕜]
  [distrib_mul_action 𝕜 β] [has_continuous_smul 𝕜 β]
  (hf : ae_fin_strongly_measurable f μ) (c : 𝕜) :
  ae_fin_strongly_measurable (c • f) μ :=
⟨c • hf.mk f, hf.fin_strongly_measurable_mk.const_smul c, hf.ae_eq_mk.const_smul c⟩

end arithmetic

section order
variables [has_zero β]

protected lemma sup [semilattice_sup β] [has_continuous_sup β]
  (hf : ae_fin_strongly_measurable f μ) (hg : ae_fin_strongly_measurable g μ) :
  ae_fin_strongly_measurable (f ⊔ g) μ :=
⟨hf.mk f ⊔ hg.mk g, hf.fin_strongly_measurable_mk.sup hg.fin_strongly_measurable_mk,
  hf.ae_eq_mk.sup hg.ae_eq_mk⟩

protected lemma inf [semilattice_inf β] [has_continuous_inf β]
  (hf : ae_fin_strongly_measurable f μ) (hg : ae_fin_strongly_measurable g μ) :
  ae_fin_strongly_measurable (f ⊓ g) μ :=
⟨hf.mk f ⊓ hg.mk g, hf.fin_strongly_measurable_mk.inf hg.fin_strongly_measurable_mk,
  hf.ae_eq_mk.inf hg.ae_eq_mk⟩

end order

variables [has_zero β] [t2_space β]

lemma exists_set_sigma_finite (hf : ae_fin_strongly_measurable f μ) :
  ∃ t, measurable_set t ∧ f =ᵐ[μ.restrict tᶜ] 0 ∧ sigma_finite (μ.restrict t) :=
begin
  rcases hf with ⟨g, hg, hfg⟩,
  obtain ⟨t, ht, hgt_zero, htμ⟩ := hg.exists_set_sigma_finite,
  refine ⟨t, ht, _, htμ⟩,
  refine eventually_eq.trans (ae_restrict_of_ae hfg) _,
  rw [eventually_eq, ae_restrict_iff' ht.compl],
  exact eventually_of_forall hgt_zero,
end

/-- A measurable set `t` such that `f =ᵐ[μ.restrict tᶜ] 0` and `sigma_finite (μ.restrict t)`. -/
def sigma_finite_set (hf : ae_fin_strongly_measurable f μ) : set α :=
hf.exists_set_sigma_finite.some

protected lemma measurable_set (hf : ae_fin_strongly_measurable f μ) :
  measurable_set hf.sigma_finite_set :=
hf.exists_set_sigma_finite.some_spec.1

lemma ae_eq_zero_compl (hf : ae_fin_strongly_measurable f μ) :
  f =ᵐ[μ.restrict hf.sigma_finite_setᶜ] 0 :=
hf.exists_set_sigma_finite.some_spec.2.1

instance sigma_finite_restrict (hf : ae_fin_strongly_measurable f μ) :
  sigma_finite (μ.restrict hf.sigma_finite_set) :=
hf.exists_set_sigma_finite.some_spec.2.2

end ae_fin_strongly_measurable

section second_countable_topology

variables {G : Type*} {p : ℝ≥0∞} {m m0 : measurable_space α} {μ : measure α}
  [normed_group G] [measurable_space G] [borel_space G] [second_countable_topology G]
  {f : α → G}

/-- In a space with second countable topology and a sigma-finite measure, `fin_strongly_measurable`
  and `measurable` are equivalent. -/
lemma fin_strongly_measurable_iff_measurable {m0 : measurable_space α} (μ : measure α)
  [sigma_finite μ] :
  fin_strongly_measurable f μ ↔ measurable f :=
⟨λ h, h.measurable, λ h, (measurable.strongly_measurable h).fin_strongly_measurable μ⟩

/-- In a space with second countable topology and a sigma-finite measure,
  `ae_fin_strongly_measurable` and `ae_measurable` are equivalent. -/
lemma ae_fin_strongly_measurable_iff_ae_measurable {m0 : measurable_space α} (μ : measure α)
  [sigma_finite μ] :
  ae_fin_strongly_measurable f μ ↔ ae_measurable f μ :=
by simp_rw [ae_fin_strongly_measurable, ae_measurable, fin_strongly_measurable_iff_measurable]

end second_countable_topology

lemma measurable_uncurry_of_continuous_of_measurable {α β ι : Type*} [topological_space ι]
  [metrizable_space ι] [measurable_space ι] [second_countable_topology ι] [opens_measurable_space ι]
  {mβ : measurable_space β} [topological_space β] [pseudo_metrizable_space β] [borel_space β]
  {m : measurable_space α} {u : ι → α → β}
  (hu_cont : ∀ x, continuous (λ i, u i x)) (h : ∀ i, measurable (u i)) :
  measurable (function.uncurry u) :=
begin
  obtain ⟨t_sf, ht_sf⟩ : ∃ t : ℕ → simple_func ι ι, ∀ j x,
    tendsto (λ n, u (t n j) x) at_top (𝓝 $ u j x),
  { have h_str_meas : strongly_measurable (id : ι → ι), from strongly_measurable_id,
    refine ⟨h_str_meas.approx, λ j x, _⟩,
    exact ((hu_cont x).tendsto j).comp (h_str_meas.tendsto_approx j), },
  let U := λ (n : ℕ) (p : ι × α), u (t_sf n p.fst) p.snd,
  have h_tendsto : tendsto U at_top (𝓝 (λ p, u p.fst p.snd)),
  { rw tendsto_pi_nhds,
    exact λ p, ht_sf p.fst p.snd, },
  refine measurable_of_tendsto_metrizable (λ n, _) h_tendsto,
  haveI : encodable (t_sf n).range, from fintype.to_encodable ↥(t_sf n).range,
  have h_meas : measurable (λ (p : (t_sf n).range × α), u ↑p.fst p.snd),
  { have : (λ (p : ↥((t_sf n).range) × α), u ↑(p.fst) p.snd)
        = (λ (p : α × ((t_sf n).range)), u ↑(p.snd) p.fst) ∘ prod.swap := rfl,
    rw [this, @measurable_swap_iff α ↥((t_sf n).range) β m],
    exact measurable_from_prod_encodable (λ j, h j), },
  have : (λ p : ι × α, u (t_sf n p.fst) p.snd)
    = (λ p : ↥(t_sf n).range × α, u p.fst p.snd)
      ∘ (λ p : ι × α, (⟨t_sf n p.fst, simple_func.mem_range_self _ _⟩, p.snd)) := rfl,
  simp_rw [U, this],
  refine h_meas.comp (measurable.prod_mk _ measurable_snd),
  exact ((t_sf n).measurable.comp measurable_fst).subtype_mk,
end

lemma strongly_measurable_uncurry_of_continuous_of_strongly_measurable {α β ι : Type*}
  [topological_space ι] [metrizable_space ι] [measurable_space ι] [second_countable_topology ι]
  [opens_measurable_space ι] [topological_space β] [pseudo_metrizable_space β]
  [measurable_space α] {u : ι → α → β}
  (hu_cont : ∀ x, continuous (λ i, u i x)) (h : ∀ i, strongly_measurable (u i)) :
  strongly_measurable (function.uncurry u) :=
begin
  borelize β,
  obtain ⟨t_sf, ht_sf⟩ : ∃ t : ℕ → simple_func ι ι, ∀ j x,
    tendsto (λ n, u (t n j) x) at_top (𝓝 $ u j x),
  { have h_str_meas : strongly_measurable (id : ι → ι), from strongly_measurable_id,
    refine ⟨h_str_meas.approx, λ j x, _⟩,
    exact ((hu_cont x).tendsto j).comp (h_str_meas.tendsto_approx j), },
  let U := λ (n : ℕ) (p : ι × α), u (t_sf n p.fst) p.snd,
  have h_tendsto : tendsto U at_top (𝓝 (λ p, u p.fst p.snd)),
  { rw tendsto_pi_nhds,
    exact λ p, ht_sf p.fst p.snd, },
  refine strongly_measurable_of_tendsto _ (λ n, _) h_tendsto,
  haveI : encodable (t_sf n).range, from fintype.to_encodable ↥(t_sf n).range,
  have h_str_meas : strongly_measurable (λ (p : (t_sf n).range × α), u ↑p.fst p.snd),
  { refine strongly_measurable_iff_measurable_separable.2 ⟨_, _⟩,
    { have : (λ (p : ↥((t_sf n).range) × α), u ↑(p.fst) p.snd)
          = (λ (p : α × ((t_sf n).range)), u ↑(p.snd) p.fst) ∘ prod.swap := rfl,
      rw [this, measurable_swap_iff],
      exact measurable_from_prod_encodable (λ j, (h j).measurable), },
    { have : is_separable (⋃ (i : (t_sf n).range), range (u i)) :=
        is_separable_Union (λ i, (h i).is_separable_range),
      apply this.mono,
      rintros - ⟨⟨i, x⟩, rfl⟩,
      simp only [mem_Union, mem_range],
      exact ⟨i, x, rfl⟩ } },
  have : (λ p : ι × α, u (t_sf n p.fst) p.snd)
    = (λ p : ↥(t_sf n).range × α, u p.fst p.snd)
      ∘ (λ p : ι × α, (⟨t_sf n p.fst, simple_func.mem_range_self _ _⟩, p.snd)) := rfl,
  simp_rw [U, this],
  refine h_str_meas.comp_measurable (measurable.prod_mk _ measurable_snd),
  exact ((t_sf n).measurable.comp measurable_fst).subtype_mk,
end

end measure_theory


<|start_filename|>src/linear_algebra/linear_independent.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>
-/
import algebra.big_operators.fin
import linear_algebra.finsupp
import linear_algebra.prod
import set_theory.cardinal.basic

/-!

# Linear independence

This file defines linear independence in a module or vector space.

It is inspired by Isabelle/HOL's linear algebra, and hence indirectly by HOL Light.

We define `linear_independent R v` as `ker (finsupp.total ι M R v) = ⊥`. Here `finsupp.total` is the
linear map sending a function `f : ι →₀ R` with finite support to the linear combination of vectors
from `v` with these coefficients. Then we prove that several other statements are equivalent to this
one, including injectivity of `finsupp.total ι M R v` and some versions with explicitly written
linear combinations.

## Main definitions
All definitions are given for families of vectors, i.e. `v : ι → M` where `M` is the module or
vector space and `ι : Type*` is an arbitrary indexing type.

* `linear_independent R v` states that the elements of the family `v` are linearly independent.

* `linear_independent.repr hv x` returns the linear combination representing `x : span R (range v)`
on the linearly independent vectors `v`, given `hv : linear_independent R v`
(using classical choice). `linear_independent.repr hv` is provided as a linear map.

## Main statements

We prove several specialized tests for linear independence of families of vectors and of sets of
vectors.

* `fintype.linear_independent_iff`: if `ι` is a finite type, then any function `f : ι → R` has
  finite support, so we can reformulate the statement using `∑ i : ι, f i • v i` instead of a sum
  over an auxiliary `s : finset ι`;
* `linear_independent_empty_type`: a family indexed by an empty type is linearly independent;
* `linear_independent_unique_iff`: if `ι` is a singleton, then `linear_independent K v` is
  equivalent to `v default ≠ 0`;
* linear_independent_option`, `linear_independent_sum`, `linear_independent_fin_cons`,
  `linear_independent_fin_succ`: type-specific tests for linear independence of families of vector
  fields;
* `linear_independent_insert`, `linear_independent_union`, `linear_independent_pair`,
  `linear_independent_singleton`: linear independence tests for set operations.

In many cases we additionally provide dot-style operations (e.g., `linear_independent.union`) to
make the linear independence tests usable as `hv.insert ha` etc.

We also prove that, when working over a division ring,
any family of vectors includes a linear independent subfamily spanning the same subspace.

## Implementation notes

We use families instead of sets because it allows us to say that two identical vectors are linearly
dependent.

If you want to use sets, use the family `(λ x, x : s → M)` given a set `s : set M`. The lemmas
`linear_independent.to_subtype_range` and `linear_independent.of_subtype_range` connect those two
worlds.

## Tags

linearly dependent, linear dependence, linearly independent, linear independence

-/

noncomputable theory

open function set submodule
open_locale classical big_operators cardinal

universes u

variables {ι : Type*} {ι' : Type*} {R : Type*} {K : Type*}
variables {M : Type*} {M' M'' : Type*} {V : Type u} {V' : Type*}


section module

variables {v : ι → M}
variables [semiring R] [add_comm_monoid M] [add_comm_monoid M'] [add_comm_monoid M'']
variables [module R M] [module R M'] [module R M'']
variables {a b : R} {x y : M}

variables (R) (v)

/-- `linear_independent R v` states the family of vectors `v` is linearly independent over `R`. -/
def linear_independent : Prop := (finsupp.total ι M R v).ker = ⊥
variables {R} {v}

theorem linear_independent_iff : linear_independent R v ↔
  ∀l, finsupp.total ι M R v l = 0 → l = 0 :=
by simp [linear_independent, linear_map.ker_eq_bot']

theorem linear_independent_iff' : linear_independent R v ↔
  ∀ s : finset ι, ∀ g : ι → R, ∑ i in s, g i • v i = 0 → ∀ i ∈ s, g i = 0 :=
linear_independent_iff.trans
⟨λ hf s g hg i his, have h : _ := hf (∑ i in s, finsupp.single i (g i)) $
      by simpa only [linear_map.map_sum, finsupp.total_single] using hg, calc
    g i = (finsupp.lapply i : (ι →₀ R) →ₗ[R] R) (finsupp.single i (g i)) :
      by rw [finsupp.lapply_apply, finsupp.single_eq_same]
    ... = ∑ j in s, (finsupp.lapply i : (ι →₀ R) →ₗ[R] R) (finsupp.single j (g j)) :
      eq.symm $ finset.sum_eq_single i
        (λ j hjs hji, by rw [finsupp.lapply_apply, finsupp.single_eq_of_ne hji])
        (λ hnis, hnis.elim his)
    ... = (∑ j in s, finsupp.single j (g j)) i : (finsupp.lapply i : (ι →₀ R) →ₗ[R] R).map_sum.symm
    ... = 0 : finsupp.ext_iff.1 h i,
λ hf l hl, finsupp.ext $ λ i, classical.by_contradiction $ λ hni, hni $ hf _ _ hl _ $
  finsupp.mem_support_iff.2 hni⟩

theorem linear_independent_iff'' :
  linear_independent R v ↔ ∀ (s : finset ι) (g : ι → R) (hg : ∀ i ∉ s, g i = 0),
    ∑ i in s, g i • v i = 0 → ∀ i, g i = 0 :=
linear_independent_iff'.trans ⟨λ H s g hg hv i, if his : i ∈ s then H s g hv i his else hg i his,
λ H s g hg i hi, by { convert H s (λ j, if j ∈ s then g j else 0) (λ j hj, if_neg hj)
    (by simp_rw [ite_smul, zero_smul, finset.sum_extend_by_zero, hg]) i,
  exact (if_pos hi).symm }⟩

theorem not_linear_independent_iff : ¬ linear_independent R v ↔
  ∃ s : finset ι, ∃ g : ι → R, (∑ i in s, g i • v i) = 0 ∧ (∃ i ∈ s, g i ≠ 0) :=
begin
  rw linear_independent_iff',
  simp only [exists_prop, not_forall],
end

theorem fintype.linear_independent_iff [fintype ι] :
  linear_independent R v ↔ ∀ g : ι → R, ∑ i, g i • v i = 0 → ∀ i, g i = 0 :=
begin
  refine ⟨λ H g, by simpa using linear_independent_iff'.1 H finset.univ g,
    λ H, linear_independent_iff''.2 $ λ s g hg hs i, H _ _ _⟩,
  rw ← hs,
  refine (finset.sum_subset (finset.subset_univ _) (λ i _ hi, _)).symm,
  rw [hg i hi, zero_smul]
end

/-- A finite family of vectors `v i` is linear independent iff the linear map that sends
`c : ι → R` to `∑ i, c i • v i` has the trivial kernel. -/
theorem fintype.linear_independent_iff' [fintype ι] :
  linear_independent R v ↔
    (linear_map.lsum R (λ i : ι, R) ℕ (λ i, linear_map.id.smul_right (v i))).ker = ⊥ :=
by simp [fintype.linear_independent_iff, linear_map.ker_eq_bot', funext_iff]

lemma fintype.not_linear_independent_iff [fintype ι] :
  ¬linear_independent R v ↔ ∃ g : ι → R, (∑ i, g i • v i) = 0 ∧ (∃ i, g i ≠ 0) :=
by simpa using (not_iff_not.2 fintype.linear_independent_iff)

lemma linear_independent_empty_type [is_empty ι] : linear_independent R v :=
linear_independent_iff.mpr $ λ v hv, subsingleton.elim v 0

lemma linear_independent.ne_zero [nontrivial R]
  (i : ι) (hv : linear_independent R v) : v i ≠ 0 :=
λ h, @zero_ne_one R _ _ $ eq.symm begin
  suffices : (finsupp.single i 1 : ι →₀ R) i = 0, {simpa},
  rw linear_independent_iff.1 hv (finsupp.single i 1),
  { simp },
  { simp [h] }
end

/-- A subfamily of a linearly independent family (i.e., a composition with an injective map) is a
linearly independent family. -/
lemma linear_independent.comp
  (h : linear_independent R v) (f : ι' → ι) (hf : injective f) : linear_independent R (v ∘ f) :=
begin
  rw [linear_independent_iff, finsupp.total_comp],
  intros l hl,
  have h_map_domain : ∀ x, (finsupp.map_domain f l) (f x) = 0,
    by rw linear_independent_iff.1 h (finsupp.map_domain f l) hl; simp,
  ext x,
  convert h_map_domain x,
  rw [finsupp.map_domain_apply hf]
end

lemma linear_independent.coe_range (i : linear_independent R v) :
  linear_independent R (coe : range v → M) :=
by simpa using i.comp _ (range_splitting_injective v)

/-- If `v` is a linearly independent family of vectors and the kernel of a linear map `f` is
disjoint with the submodule spanned by the vectors of `v`, then `f ∘ v` is a linearly independent
family of vectors. See also `linear_independent.map'` for a special case assuming `ker f = ⊥`. -/
lemma linear_independent.map (hv : linear_independent R v) {f : M →ₗ[R] M'}
  (hf_inj : disjoint (span R (range v)) f.ker) : linear_independent R (f ∘ v) :=
begin
  rw [disjoint, ← set.image_univ, finsupp.span_image_eq_map_total, map_inf_eq_map_inf_comap,
    map_le_iff_le_comap, comap_bot, finsupp.supported_univ, top_inf_eq] at hf_inj,
  unfold linear_independent at hv ⊢,
  rw [hv, le_bot_iff] at hf_inj,
  haveI : inhabited M := ⟨0⟩,
  rw [finsupp.total_comp, @finsupp.lmap_domain_total _ _ R _ _ _ _ _ _ _ _ _ _ f,
    linear_map.ker_comp, hf_inj],
  exact λ _, rfl,
end

/-- An injective linear map sends linearly independent families of vectors to linearly independent
families of vectors. See also `linear_independent.map` for a more general statement. -/
lemma linear_independent.map' (hv : linear_independent R v) (f : M →ₗ[R] M')
  (hf_inj : f.ker = ⊥) : linear_independent R (f ∘ v) :=
hv.map $ by simp [hf_inj]

/-- If the image of a family of vectors under a linear map is linearly independent, then so is
the original family. -/
lemma linear_independent.of_comp (f : M →ₗ[R] M') (hfv : linear_independent R (f ∘ v)) :
  linear_independent R v :=
linear_independent_iff'.2 $ λ s g hg i his,
have ∑ (i : ι) in s, g i • f (v i) = 0,
  by simp_rw [← f.map_smul, ← f.map_sum, hg, f.map_zero],
linear_independent_iff'.1 hfv s g this i his

/-- If `f` is an injective linear map, then the family `f ∘ v` is linearly independent
if and only if the family `v` is linearly independent. -/
protected lemma linear_map.linear_independent_iff (f : M →ₗ[R] M') (hf_inj : f.ker = ⊥) :
  linear_independent R (f ∘ v) ↔ linear_independent R v :=
⟨λ h, h.of_comp f, λ h, h.map $ by simp only [hf_inj, disjoint_bot_right]⟩

@[nontriviality]
lemma linear_independent_of_subsingleton [subsingleton R] : linear_independent R v :=
linear_independent_iff.2 (λ l hl, subsingleton.elim _ _)

theorem linear_independent_equiv (e : ι ≃ ι') {f : ι' → M} :
  linear_independent R (f ∘ e) ↔ linear_independent R f :=
⟨λ h, function.comp.right_id f ▸ e.self_comp_symm ▸ h.comp _ e.symm.injective,
λ h, h.comp _ e.injective⟩

theorem linear_independent_equiv' (e : ι ≃ ι') {f : ι' → M} {g : ι → M} (h : f ∘ e = g) :
  linear_independent R g ↔ linear_independent R f :=
h ▸ linear_independent_equiv e

theorem linear_independent_subtype_range {ι} {f : ι → M} (hf : injective f) :
  linear_independent R (coe : range f → M) ↔ linear_independent R f :=
iff.symm $ linear_independent_equiv' (equiv.of_injective f hf) rfl

alias linear_independent_subtype_range ↔ linear_independent.of_subtype_range _

theorem linear_independent_image {ι} {s : set ι} {f : ι → M} (hf : set.inj_on f s) :
  linear_independent R (λ x : s, f x) ↔ linear_independent R (λ x : f '' s, (x : M)) :=
linear_independent_equiv' (equiv.set.image_of_inj_on _ _ hf) rfl

lemma linear_independent_span (hs : linear_independent R v) :
  @linear_independent ι R (span R (range v))
      (λ i : ι, ⟨v i, subset_span (mem_range_self i)⟩) _ _ _ :=
linear_independent.of_comp (span R (range v)).subtype hs

/-- See `linear_independent.fin_cons` for a family of elements in a vector space. -/
lemma linear_independent.fin_cons' {m : ℕ} (x : M) (v : fin m → M)
  (hli : linear_independent R v)
  (x_ortho : (∀ (c : R) (y : submodule.span R (set.range v)), c • x + y = (0 : M) → c = 0)) :
  linear_independent R (fin.cons x v : fin m.succ → M) :=
begin
  rw fintype.linear_independent_iff at hli ⊢,
  rintros g total_eq j,
  simp_rw [fin.sum_univ_succ, fin.cons_zero, fin.cons_succ] at total_eq,
  have : g 0 = 0,
  { refine x_ortho (g 0) ⟨∑ (i : fin m), g i.succ • v i, _⟩ total_eq,
    exact sum_mem (λ i _, smul_mem _ _ (subset_span ⟨i, rfl⟩)) },
  rw [this, zero_smul, zero_add] at total_eq,
  exact fin.cases this (hli _ total_eq) j,
end

/-- A set of linearly independent vectors in a module `M` over a semiring `K` is also linearly
independent over a subring `R` of `K`.
The implementation uses minimal assumptions about the relationship between `R`, `K` and `M`.
The version where `K` is an `R`-algebra is `linear_independent.restrict_scalars_algebras`.
 -/
lemma linear_independent.restrict_scalars [semiring K] [smul_with_zero R K] [module K M]
  [is_scalar_tower R K M]
  (hinj : function.injective (λ r : R, r • (1 : K))) (li : linear_independent K v) :
  linear_independent R v :=
begin
  refine linear_independent_iff'.mpr (λ s g hg i hi, hinj (eq.trans _ (zero_smul _ _).symm)),
  refine (linear_independent_iff'.mp li : _) _ _ _ i hi,
  simp_rw [smul_assoc, one_smul],
  exact hg,
end

/-- Every finite subset of a linearly independent set is linearly independent. -/
lemma linear_independent_finset_map_embedding_subtype
  (s : set M) (li : linear_independent R (coe : s → M)) (t : finset s) :
  linear_independent R (coe : (finset.map (embedding.subtype s) t) → M) :=
begin
  let f : t.map (embedding.subtype s) → s := λ x, ⟨x.1, begin
    obtain ⟨x, h⟩ := x,
    rw [finset.mem_map] at h,
    obtain ⟨a, ha, rfl⟩ := h,
    simp only [subtype.coe_prop, embedding.coe_subtype],
  end⟩,
  convert linear_independent.comp li f _,
  rintros ⟨x, hx⟩ ⟨y, hy⟩,
  rw [finset.mem_map] at hx hy,
  obtain ⟨a, ha, rfl⟩ := hx,
  obtain ⟨b, hb, rfl⟩ := hy,
  simp only [imp_self, subtype.mk_eq_mk],
end

/--
If every finite set of linearly independent vectors has cardinality at most `n`,
then the same is true for arbitrary sets of linearly independent vectors.
-/
lemma linear_independent_bounded_of_finset_linear_independent_bounded {n : ℕ}
  (H : ∀ s : finset M, linear_independent R (λ i : s, (i : M)) → s.card ≤ n) :
  ∀ s : set M, linear_independent R (coe : s → M) → #s ≤ n :=
begin
  intros s li,
  apply cardinal.card_le_of,
  intro t,
  rw ← finset.card_map (embedding.subtype s),
  apply H,
  apply linear_independent_finset_map_embedding_subtype _ li,
end

section subtype
/-! The following lemmas use the subtype defined by a set in `M` as the index set `ι`. -/

theorem linear_independent_comp_subtype {s : set ι} :
  linear_independent R (v ∘ coe : s → M) ↔
  ∀ l ∈ (finsupp.supported R R s), (finsupp.total ι M R v) l = 0 → l = 0 :=
begin
  simp only [linear_independent_iff, (∘), finsupp.mem_supported, finsupp.total_apply,
    set.subset_def, finset.mem_coe],
  split,
  { intros h l hl₁ hl₂,
    have := h (l.subtype_domain s) ((finsupp.sum_subtype_domain_index hl₁).trans hl₂),
    exact (finsupp.subtype_domain_eq_zero_iff hl₁).1 this },
  { intros h l hl,
    refine finsupp.emb_domain_eq_zero.1 (h (l.emb_domain $ function.embedding.subtype s) _ _),
    { suffices : ∀ i hi, ¬l ⟨i, hi⟩ = 0 → i ∈ s, by simpa,
      intros, assumption },
    { rwa [finsupp.emb_domain_eq_map_domain, finsupp.sum_map_domain_index],
      exacts [λ _, zero_smul _ _, λ _ _ _, add_smul _ _ _] } }
end

lemma linear_dependent_comp_subtype' {s : set ι} :
  ¬ linear_independent R (v ∘ coe : s → M) ↔
  ∃ f : ι →₀ R, f ∈ finsupp.supported R R s ∧ finsupp.total ι M R v f = 0 ∧ f ≠ 0 :=
by simp [linear_independent_comp_subtype]

/-- A version of `linear_dependent_comp_subtype'` with `finsupp.total` unfolded. -/
lemma linear_dependent_comp_subtype {s : set ι} :
  ¬ linear_independent R (v ∘ coe : s → M) ↔
  ∃ f : ι →₀ R, f ∈ finsupp.supported R R s ∧ ∑ i in f.support, f i • v i = 0 ∧ f ≠ 0 :=
linear_dependent_comp_subtype'

theorem linear_independent_subtype {s : set M} :
  linear_independent R (λ x, x : s → M) ↔
  ∀ l ∈ (finsupp.supported R R s), (finsupp.total M M R id) l = 0 → l = 0 :=
by apply @linear_independent_comp_subtype _ _ _ id

theorem linear_independent_comp_subtype_disjoint {s : set ι} :
  linear_independent R (v ∘ coe : s → M) ↔
  disjoint (finsupp.supported R R s) (finsupp.total ι M R v).ker :=
by rw [linear_independent_comp_subtype, linear_map.disjoint_ker]

theorem linear_independent_subtype_disjoint {s : set M} :
  linear_independent R (λ x, x : s → M) ↔
  disjoint (finsupp.supported R R s) (finsupp.total M M R id).ker :=
by apply @linear_independent_comp_subtype_disjoint _ _ _ id

theorem linear_independent_iff_total_on {s : set M} :
  linear_independent R (λ x, x : s → M) ↔ (finsupp.total_on M M R id s).ker = ⊥ :=
by rw [finsupp.total_on, linear_map.ker, linear_map.comap_cod_restrict, map_bot, comap_bot,
  linear_map.ker_comp, linear_independent_subtype_disjoint, disjoint, ← map_comap_subtype,
  map_le_iff_le_comap, comap_bot, ker_subtype, le_bot_iff]

lemma linear_independent.restrict_of_comp_subtype {s : set ι}
  (hs : linear_independent R (v ∘ coe : s → M)) :
  linear_independent R (s.restrict v) :=
hs

variables (R M)
lemma linear_independent_empty : linear_independent R (λ x, x : (∅ : set M) → M) :=
by simp [linear_independent_subtype_disjoint]
variables {R M}

lemma linear_independent.mono {t s : set M} (h : t ⊆ s) :
  linear_independent R (λ x, x : s → M) → linear_independent R (λ x, x : t → M) :=
begin
 simp only [linear_independent_subtype_disjoint],
 exact (disjoint.mono_left (finsupp.supported_mono h))
end

lemma linear_independent_of_finite (s : set M)
  (H : ∀ t ⊆ s, set.finite t → linear_independent R (λ x, x : t → M)) :
  linear_independent R (λ x, x : s → M) :=
linear_independent_subtype.2 $
  λ l hl, linear_independent_subtype.1 (H _ hl (finset.finite_to_set _)) l (subset.refl _)

lemma linear_independent_Union_of_directed {η : Type*}
  {s : η → set M} (hs : directed (⊆) s)
  (h : ∀ i, linear_independent R (λ x, x : s i → M)) :
  linear_independent R (λ x, x : (⋃ i, s i) → M) :=
begin
  by_cases hη : nonempty η,
  { resetI,
    refine linear_independent_of_finite (⋃ i, s i) (λ t ht ft, _),
    rcases finite_subset_Union ft ht with ⟨I, fi, hI⟩,
    rcases hs.finset_le fi.to_finset with ⟨i, hi⟩,
    exact (h i).mono (subset.trans hI $ Union₂_subset $
      λ j hj, hi j (fi.mem_to_finset.2 hj)) },
  { refine (linear_independent_empty _ _).mono _,
    rintro _ ⟨_, ⟨i, _⟩, _⟩, exact hη ⟨i⟩ }
end

lemma linear_independent_sUnion_of_directed {s : set (set M)}
  (hs : directed_on (⊆) s)
  (h : ∀ a ∈ s, linear_independent R (λ x, x : (a : set M) → M)) :
  linear_independent R (λ x, x : (⋃₀ s) → M) :=
by rw sUnion_eq_Union; exact
linear_independent_Union_of_directed hs.directed_coe (by simpa using h)

lemma linear_independent_bUnion_of_directed {η} {s : set η} {t : η → set M}
  (hs : directed_on (t ⁻¹'o (⊆)) s) (h : ∀a∈s, linear_independent R (λ x, x : t a → M)) :
  linear_independent R (λ x, x : (⋃a∈s, t a) → M) :=
by rw bUnion_eq_Union; exact
linear_independent_Union_of_directed (directed_comp.2 $ hs.directed_coe) (by simpa using h)

end subtype

end module

/-! ### Properties which require `ring R` -/

section module
variables {v : ι → M}
variables [ring R] [add_comm_group M] [add_comm_group M'] [add_comm_group M'']
variables [module R M] [module R M'] [module R M'']
variables {a b : R} {x y : M}

theorem linear_independent_iff_injective_total : linear_independent R v ↔
  function.injective (finsupp.total ι M R v) :=
linear_independent_iff.trans
  (injective_iff_map_eq_zero (finsupp.total ι M R v).to_add_monoid_hom).symm

alias linear_independent_iff_injective_total ↔ linear_independent.injective_total _

lemma linear_independent.injective [nontrivial R] (hv : linear_independent R v) :
  injective v :=
begin
  intros i j hij,
  let l : ι →₀ R := finsupp.single i (1 : R) - finsupp.single j 1,
  have h_total : finsupp.total ι M R v l = 0,
  { simp_rw [linear_map.map_sub, finsupp.total_apply],
    simp [hij] },
  have h_single_eq : finsupp.single i (1 : R) = finsupp.single j 1,
  { rw linear_independent_iff at hv,
    simp [eq_add_of_sub_eq' (hv l h_total)] },
  simpa [finsupp.single_eq_single_iff] using h_single_eq
end

theorem linear_independent.to_subtype_range {ι} {f : ι → M} (hf : linear_independent R f) :
  linear_independent R (coe : range f → M) :=
begin
  nontriviality R,
  exact (linear_independent_subtype_range hf.injective).2 hf
end

theorem linear_independent.to_subtype_range' {ι} {f : ι → M} (hf : linear_independent R f)
  {t} (ht : range f = t) :
  linear_independent R (coe : t → M) :=
ht ▸ hf.to_subtype_range

theorem linear_independent.image_of_comp {ι ι'} (s : set ι) (f : ι → ι') (g : ι' → M)
  (hs : linear_independent R (λ x : s, g (f x))) :
  linear_independent R (λ x : f '' s, g x) :=
begin
  nontriviality R,
  have : inj_on f s, from inj_on_iff_injective.2 hs.injective.of_comp,
  exact (linear_independent_equiv' (equiv.set.image_of_inj_on f s this) rfl).1 hs
end

theorem linear_independent.image {ι} {s : set ι} {f : ι → M}
  (hs : linear_independent R (λ x : s, f x)) : linear_independent R (λ x : f '' s, (x : M)) :=
by convert linear_independent.image_of_comp s f id hs

lemma linear_independent.group_smul
  {G : Type*} [hG : group G] [distrib_mul_action G R] [distrib_mul_action G M]
  [is_scalar_tower G R M] [smul_comm_class G R M] {v : ι → M} (hv : linear_independent R v)
  (w : ι → G) : linear_independent R (w • v) :=
begin
  rw linear_independent_iff'' at hv ⊢,
  intros s g hgs hsum i,
  refine (smul_eq_zero_iff_eq (w i)).1 _,
  refine hv s (λ i, w i • g i) (λ i hi, _) _ i,
  { dsimp only,
    exact (hgs i hi).symm ▸ smul_zero _ },
  { rw [← hsum, finset.sum_congr rfl _],
    intros, erw [pi.smul_apply, smul_assoc, smul_comm] },
end

-- This lemma cannot be proved with `linear_independent.group_smul` since the action of
-- `Rˣ` on `R` is not commutative.
lemma linear_independent.units_smul {v : ι → M} (hv : linear_independent R v)
  (w : ι → Rˣ) : linear_independent R (w • v) :=
begin
  rw linear_independent_iff'' at hv ⊢,
  intros s g hgs hsum i,
  rw ← (w i).mul_left_eq_zero,
  refine hv s (λ i, g i • w i) (λ i hi, _) _ i,
  { dsimp only,
    exact (hgs i hi).symm ▸ zero_smul _ _ },
  { rw [← hsum, finset.sum_congr rfl _],
    intros,
    erw [pi.smul_apply, smul_assoc],
    refl }
end


section maximal
universes v w

/--
A linearly independent family is maximal if there is no strictly larger linearly independent family.
-/
@[nolint unused_arguments]
def linear_independent.maximal {ι : Type w} {R : Type u} [semiring R]
  {M : Type v} [add_comm_monoid M] [module R M] {v : ι → M} (i : linear_independent R v) : Prop :=
∀ (s : set M) (i' : linear_independent R (coe : s → M)) (h : range v ≤ s), range v = s

/--
An alternative characterization of a maximal linearly independent family,
quantifying over types (in the same universe as `M`) into which the indexing family injects.
-/
lemma linear_independent.maximal_iff {ι : Type w} {R : Type u} [ring R] [nontrivial R]
  {M : Type v} [add_comm_group M] [module R M] {v : ι → M} (i : linear_independent R v) :
  i.maximal ↔ ∀ (κ : Type v) (w : κ → M) (i' : linear_independent R w)
    (j : ι → κ) (h : w ∘ j = v), surjective j :=
begin
  fsplit,
  { rintros p κ w i' j rfl,
    specialize p (range w) i'.coe_range (range_comp_subset_range _ _),
    rw [range_comp, ←@image_univ _ _ w] at p,
    exact range_iff_surjective.mp (image_injective.mpr i'.injective p), },
  { intros p w i' h,
    specialize p w (coe : w → M) i'
      (λ i, ⟨v i, range_subset_iff.mp h i⟩)
      (by { ext, simp, }),
    have q := congr_arg (λ s, (coe : w → M) '' s) p.range_eq,
    dsimp at q,
    rw [←image_univ, image_image] at q,
    simpa using q, },
end

end maximal

/-- Linear independent families are injective, even if you multiply either side. -/
lemma linear_independent.eq_of_smul_apply_eq_smul_apply {M : Type*} [add_comm_group M] [module R M]
  {v : ι → M} (li : linear_independent R v) (c d : R) (i j : ι)
  (hc : c ≠ 0) (h : c • v i = d • v j) : i = j :=
begin
  let l : ι →₀ R := finsupp.single i c - finsupp.single j d,
  have h_total : finsupp.total ι M R v l = 0,
  { simp_rw [linear_map.map_sub, finsupp.total_apply],
    simp [h] },
  have h_single_eq : finsupp.single i c = finsupp.single j d,
  { rw linear_independent_iff at li,
    simp [eq_add_of_sub_eq' (li l h_total)] },
  rcases (finsupp.single_eq_single_iff _ _ _ _).mp h_single_eq with ⟨this, _⟩ | ⟨hc, _⟩,
  { exact this },
  { contradiction },
end

section subtype
/-! The following lemmas use the subtype defined by a set in `M` as the index set `ι`. -/

lemma linear_independent.disjoint_span_image (hv : linear_independent R v) {s t : set ι}
  (hs : disjoint s t) :
  disjoint (submodule.span R $ v '' s) (submodule.span R $ v '' t) :=
begin
  simp only [disjoint_def, finsupp.mem_span_image_iff_total],
  rintros _ ⟨l₁, hl₁, rfl⟩ ⟨l₂, hl₂, H⟩,
  rw [hv.injective_total.eq_iff] at H, subst l₂,
  have : l₁ = 0 := finsupp.disjoint_supported_supported hs (submodule.mem_inf.2 ⟨hl₁, hl₂⟩),
  simp [this]
end

lemma linear_independent.not_mem_span_image [nontrivial R] (hv : linear_independent R v) {s : set ι}
  {x : ι} (h : x ∉ s) :
  v x ∉ submodule.span R (v '' s) :=
begin
  have h' : v x ∈ submodule.span R (v '' {x}),
  { rw set.image_singleton,
    exact mem_span_singleton_self (v x), },
  intro w,
  apply linear_independent.ne_zero x hv,
  refine disjoint_def.1 (hv.disjoint_span_image _) (v x) h' w,
  simpa using h,
end

lemma linear_independent.total_ne_of_not_mem_support [nontrivial R] (hv : linear_independent R v)
  {x : ι} (f : ι →₀ R) (h : x ∉ f.support) :
  finsupp.total ι M R v f ≠ v x :=
begin
  replace h : x ∉ (f.support : set ι) := h,
  have p := hv.not_mem_span_image h,
  intro w,
  rw ←w at p,
  rw finsupp.span_image_eq_map_total at p,
  simp only [not_exists, not_and, mem_map] at p,
  exact p f (f.mem_supported_support R) rfl,
end

lemma linear_independent_sum {v : ι ⊕ ι' → M} :
  linear_independent R v ↔ linear_independent R (v ∘ sum.inl) ∧
    linear_independent R (v ∘ sum.inr) ∧
      disjoint (submodule.span R (range (v ∘ sum.inl))) (submodule.span R (range (v ∘ sum.inr))) :=
begin
  rw [range_comp v, range_comp v],
  refine ⟨λ h, ⟨h.comp _ sum.inl_injective, h.comp _ sum.inr_injective,
    h.disjoint_span_image is_compl_range_inl_range_inr.1⟩, _⟩,
  rintro ⟨hl, hr, hlr⟩,
  rw [linear_independent_iff'] at *,
  intros s g hg i hi,
  have : ∑ i in s.preimage sum.inl (sum.inl_injective.inj_on _), (λ x, g x • v x) (sum.inl i) +
    ∑ i in s.preimage sum.inr (sum.inr_injective.inj_on _), (λ x, g x • v x) (sum.inr i) = 0,
  { rw [finset.sum_preimage', finset.sum_preimage', ← finset.sum_union, ← finset.filter_or],
    { simpa only [← mem_union, range_inl_union_range_inr, mem_univ, finset.filter_true] },
    { exact finset.disjoint_filter.2 (λ x hx, disjoint_left.1 is_compl_range_inl_range_inr.1) } },
  { rw ← eq_neg_iff_add_eq_zero at this,
    rw [disjoint_def'] at hlr,
    have A := hlr _ (sum_mem $ λ i hi, _) _ (neg_mem $ sum_mem $ λ i hi, _) this,
    { cases i with i i,
      { exact hl _ _ A i (finset.mem_preimage.2 hi) },
      { rw [this, neg_eq_zero] at A,
        exact hr _ _ A i (finset.mem_preimage.2 hi) } },
    { exact smul_mem _ _ (subset_span ⟨sum.inl i, mem_range_self _, rfl⟩) },
    { exact smul_mem _ _ (subset_span ⟨sum.inr i, mem_range_self _, rfl⟩) } }
end

lemma linear_independent.sum_type {v' : ι' → M} (hv : linear_independent R v)
  (hv' : linear_independent R v')
  (h : disjoint (submodule.span R (range v)) (submodule.span R (range v'))) :
  linear_independent R (sum.elim v v') :=
linear_independent_sum.2 ⟨hv, hv', h⟩

lemma linear_independent.union {s t : set M}
  (hs : linear_independent R (λ x, x : s → M)) (ht : linear_independent R (λ x, x : t → M))
  (hst : disjoint (span R s) (span R t)) :
  linear_independent R (λ x, x : (s ∪ t) → M) :=
(hs.sum_type ht $ by simpa).to_subtype_range' $ by simp

lemma linear_independent_Union_finite_subtype {ι : Type*} {f : ι → set M}
  (hl : ∀i, linear_independent R (λ x, x : f i → M))
  (hd : ∀i, ∀t:set ι, t.finite → i ∉ t → disjoint (span R (f i)) (⨆i∈t, span R (f i))) :
  linear_independent R (λ x, x : (⋃i, f i) → M) :=
begin
  rw [Union_eq_Union_finset f],
  apply linear_independent_Union_of_directed,
  { apply directed_of_sup,
    exact (λ t₁ t₂ ht, Union_mono $ λ i, Union_subset_Union_const $ λ h, ht h) },
  assume t,
  induction t using finset.induction_on with i s his ih,
  { refine (linear_independent_empty _ _).mono _,
    simp },
  { rw [finset.set_bUnion_insert],
    refine (hl _).union ih _,
    rw span_Union₂,
    exact hd i s s.finite_to_set his }
end

lemma linear_independent_Union_finite {η : Type*} {ιs : η → Type*}
  {f : Π j : η, ιs j → M}
  (hindep : ∀j, linear_independent R (f j))
  (hd : ∀i, ∀t:set η, t.finite → i ∉ t →
      disjoint (span R (range (f i))) (⨆i∈t, span R (range (f i)))) :
  linear_independent R (λ ji : Σ j, ιs j, f ji.1 ji.2) :=
begin
  nontriviality R,
  apply linear_independent.of_subtype_range,
  { rintros ⟨x₁, x₂⟩ ⟨y₁, y₂⟩ hxy,
    by_cases h_cases : x₁ = y₁,
    subst h_cases,
    { apply sigma.eq,
      rw linear_independent.injective (hindep _) hxy,
      refl },
    { have h0 : f x₁ x₂ = 0,
      { apply disjoint_def.1 (hd x₁ {y₁} (finite_singleton y₁)
          (λ h, h_cases (eq_of_mem_singleton h))) (f x₁ x₂) (subset_span (mem_range_self _)),
        rw supr_singleton,
        simp only at hxy,
        rw hxy,
        exact (subset_span (mem_range_self y₂)) },
      exact false.elim ((hindep x₁).ne_zero _ h0) } },
  rw range_sigma_eq_Union_range,
  apply linear_independent_Union_finite_subtype (λ j, (hindep j).to_subtype_range) hd,
end

end subtype

section repr
variables (hv : linear_independent R v)

/-- Canonical isomorphism between linear combinations and the span of linearly independent vectors.
-/
@[simps {rhs_md := semireducible}]
def linear_independent.total_equiv (hv : linear_independent R v) :
  (ι →₀ R) ≃ₗ[R] span R (range v) :=
begin
  apply linear_equiv.of_bijective
    (linear_map.cod_restrict (span R (range v)) (finsupp.total ι M R v) _),
  { rw [← linear_map.ker_eq_bot, linear_map.ker_cod_restrict],
    apply hv },
  { rw [← linear_map.range_eq_top, linear_map.range_eq_map, linear_map.map_cod_restrict,
      ← linear_map.range_le_iff_comap, range_subtype, map_top],
    rw finsupp.range_total,
    exact le_rfl },
  { intro l,
    rw ← finsupp.range_total,
    rw linear_map.mem_range,
    apply mem_range_self l }
end

/-- Linear combination representing a vector in the span of linearly independent vectors.

Given a family of linearly independent vectors, we can represent any vector in their span as
a linear combination of these vectors. These are provided by this linear map.
It is simply one direction of `linear_independent.total_equiv`. -/
def linear_independent.repr (hv : linear_independent R v) :
  span R (range v) →ₗ[R] ι →₀ R := hv.total_equiv.symm

@[simp] lemma linear_independent.total_repr (x) : finsupp.total ι M R v (hv.repr x) = x :=
subtype.ext_iff.1 (linear_equiv.apply_symm_apply hv.total_equiv x)

lemma linear_independent.total_comp_repr :
  (finsupp.total ι M R v).comp hv.repr = submodule.subtype _ :=
linear_map.ext $ hv.total_repr

lemma linear_independent.repr_ker : hv.repr.ker = ⊥ :=
by rw [linear_independent.repr, linear_equiv.ker]

lemma linear_independent.repr_range : hv.repr.range = ⊤ :=
by rw [linear_independent.repr, linear_equiv.range]

lemma linear_independent.repr_eq
  {l : ι →₀ R} {x} (eq : finsupp.total ι M R v l = ↑x) :
  hv.repr x = l :=
begin
  have : ↑((linear_independent.total_equiv hv : (ι →₀ R) →ₗ[R] span R (range v)) l)
      = finsupp.total ι M R v l := rfl,
  have : (linear_independent.total_equiv hv : (ι →₀ R) →ₗ[R] span R (range v)) l = x,
  { rw eq at this,
    exact subtype.ext_iff.2 this },
  rw ←linear_equiv.symm_apply_apply hv.total_equiv l,
  rw ←this,
  refl,
end

lemma linear_independent.repr_eq_single (i) (x) (hx : ↑x = v i) :
  hv.repr x = finsupp.single i 1 :=
begin
  apply hv.repr_eq,
  simp [finsupp.total_single, hx]
end

lemma linear_independent.span_repr_eq [nontrivial R] (x) :
  span.repr R (set.range v) x = (hv.repr x).equiv_map_domain (equiv.of_injective _ hv.injective) :=
begin
  have p : (span.repr R (set.range v) x).equiv_map_domain (equiv.of_injective _ hv.injective).symm =
    hv.repr x,
  { apply (linear_independent.total_equiv hv).injective,
    ext,
    simp only [linear_independent.total_equiv_apply_coe, equiv.self_comp_of_injective_symm,
       linear_independent.total_repr, finsupp.total_equiv_map_domain, span.finsupp_total_repr], },
  ext ⟨_, ⟨i, rfl⟩⟩,
  simp [←p],
end

-- TODO: why is this so slow?
lemma linear_independent_iff_not_smul_mem_span :
  linear_independent R v ↔ (∀ (i : ι) (a : R), a • (v i) ∈ span R (v '' (univ \ {i})) → a = 0) :=
⟨ λ hv i a ha, begin
  rw [finsupp.span_image_eq_map_total, mem_map] at ha,
  rcases ha with ⟨l, hl, e⟩,
  rw sub_eq_zero.1 (linear_independent_iff.1 hv (l - finsupp.single i a) (by simp [e])) at hl,
  by_contra hn,
  exact (not_mem_of_mem_diff (hl $ by simp [hn])) (mem_singleton _),
end, λ H, linear_independent_iff.2 $ λ l hl, begin
  ext i, simp only [finsupp.zero_apply],
  by_contra hn,
  refine hn (H i _ _),
  refine (finsupp.mem_span_image_iff_total _).2 ⟨finsupp.single i (l i) - l, _, _⟩,
  { rw finsupp.mem_supported',
    intros j hj,
    have hij : j = i :=
      not_not.1
          (λ hij : j ≠ i, hj ((mem_diff _).2 ⟨mem_univ _, λ h, hij (eq_of_mem_singleton h)⟩)),
    simp [hij] },
  { simp [hl] }
end⟩

variable (R)

lemma exists_maximal_independent' (s : ι → M) :
  ∃ I : set ι, linear_independent R (λ x : I, s x) ∧
    ∀ J : set ι, I ⊆ J → linear_independent R (λ x : J, s x) → I = J :=
begin
  let indep : set ι → Prop := λ I, linear_independent R (s ∘ coe : I → M),
  let X := { I : set ι // indep I },
  let r : X → X → Prop := λ I J, I.1 ⊆ J.1,
  have key : ∀ c : set X, is_chain r c → indep (⋃ (I : X) (H : I ∈ c), I),
  { intros c hc,
    dsimp [indep],
    rw [linear_independent_comp_subtype],
    intros f hsupport hsum,
    rcases eq_empty_or_nonempty c with rfl | hn,
    { simpa using hsupport },
    haveI : is_refl X r := ⟨λ _, set.subset.refl _⟩,
    obtain ⟨I, I_mem, hI⟩ : ∃ I ∈ c, (f.support : set ι) ⊆ I :=
      hc.directed_on.exists_mem_subset_of_finset_subset_bUnion hn hsupport,
    exact linear_independent_comp_subtype.mp I.2 f hI hsum },
  have trans : transitive r := λ I J K, set.subset.trans,
  obtain ⟨⟨I, hli : indep I⟩, hmax : ∀ a, r ⟨I, hli⟩ a → r a ⟨I, hli⟩⟩ :=
    @exists_maximal_of_chains_bounded _ r
    (λ c hc, ⟨⟨⋃ I ∈ c, (I : set ι), key c hc⟩, λ I, set.subset_bUnion_of_mem⟩) trans,
  exact ⟨I, hli, λ J hsub hli, set.subset.antisymm hsub (hmax ⟨J, hli⟩ hsub)⟩,
end

lemma exists_maximal_independent (s : ι → M) : ∃ I : set ι, linear_independent R (λ x : I, s x) ∧
  ∀ i ∉ I, ∃ a : R, a ≠ 0 ∧ a • s i ∈ span R (s '' I) :=
begin
  classical,
  rcases exists_maximal_independent' R s with ⟨I, hIlinind, hImaximal⟩,
  use [I, hIlinind],
  intros i hi,
  specialize hImaximal (I ∪ {i}) (by simp),
  set J := I ∪ {i} with hJ,
  have memJ : ∀ {x}, x ∈ J ↔ x = i ∨ x ∈ I, by simp [hJ],
  have hiJ : i ∈ J := by simp,
  have h := mt hImaximal _, swap,
  { intro h2,
    rw h2 at hi,
    exact absurd hiJ hi },
  obtain ⟨f, supp_f, sum_f, f_ne⟩ := linear_dependent_comp_subtype.mp h,
  have hfi : f i ≠ 0,
  { contrapose hIlinind,
    refine linear_dependent_comp_subtype.mpr ⟨f, _, sum_f, f_ne⟩,
    simp only [finsupp.mem_supported, hJ] at ⊢ supp_f,
    rintro x hx,
    refine (memJ.mp (supp_f hx)).resolve_left _,
    rintro rfl,
    exact hIlinind (finsupp.mem_support_iff.mp hx) },
  use [f i, hfi],
  have hfi' : i ∈ f.support := finsupp.mem_support_iff.mpr hfi,
  rw [← finset.insert_erase hfi', finset.sum_insert (finset.not_mem_erase _ _),
      add_eq_zero_iff_eq_neg] at sum_f,
  rw sum_f,
  refine neg_mem (sum_mem (λ c hc, smul_mem _ _ (subset_span ⟨c, _, rfl⟩))),
  exact (memJ.mp (supp_f (finset.erase_subset _ _ hc))).resolve_left (finset.ne_of_mem_erase hc),
end
end repr

lemma surjective_of_linear_independent_of_span [nontrivial R]
  (hv : linear_independent R v) (f : ι' ↪ ι)
  (hss : range v ⊆ span R (range (v ∘ f))) :
  surjective f :=
begin
  intros i,
  let repr : (span R (range (v ∘ f)) : Type*) → ι' →₀ R := (hv.comp f f.injective).repr,
  let l := (repr ⟨v i, hss (mem_range_self i)⟩).map_domain f,
  have h_total_l : finsupp.total ι M R v l = v i,
  { dsimp only [l],
    rw finsupp.total_map_domain,
    rw (hv.comp f f.injective).total_repr,
    { refl },
    { exact f.injective } },
  have h_total_eq : (finsupp.total ι M R v) l = (finsupp.total ι M R v) (finsupp.single i 1),
    by rw [h_total_l, finsupp.total_single, one_smul],
  have l_eq : l = _ := linear_map.ker_eq_bot.1 hv h_total_eq,
  dsimp only [l] at l_eq,
  rw ←finsupp.emb_domain_eq_map_domain at l_eq,
  rcases finsupp.single_of_emb_domain_single (repr ⟨v i, _⟩) f i (1 : R) zero_ne_one.symm l_eq
    with ⟨i', hi'⟩,
  use i',
  exact hi'.2
end

lemma eq_of_linear_independent_of_span_subtype [nontrivial R] {s t : set M}
  (hs : linear_independent R (λ x, x : s → M)) (h : t ⊆ s) (hst : s ⊆ span R t) : s = t :=
begin
  let f : t ↪ s := ⟨λ x, ⟨x.1, h x.2⟩, λ a b hab, subtype.coe_injective (subtype.mk.inj hab)⟩,
  have h_surj : surjective f,
  { apply surjective_of_linear_independent_of_span hs f _,
    convert hst; simp [f, comp], },
  show s = t,
  { apply subset.antisymm _ h,
    intros x hx,
    rcases h_surj ⟨x, hx⟩ with ⟨y, hy⟩,
    convert y.mem,
    rw ← subtype.mk.inj hy,
    refl }
end

open linear_map

lemma linear_independent.image_subtype {s : set M} {f : M →ₗ[R] M'}
  (hs : linear_independent R (λ x, x : s → M))
  (hf_inj : disjoint (span R s) f.ker) : linear_independent R (λ x, x : f '' s → M') :=
begin
  rw [← @subtype.range_coe _ s] at hf_inj,
  refine (hs.map hf_inj).to_subtype_range' _,
  simp [set.range_comp f]
end

lemma linear_independent.inl_union_inr {s : set M} {t : set M'}
  (hs : linear_independent R (λ x, x : s → M))
  (ht : linear_independent R (λ x, x : t → M')) :
  linear_independent R (λ x, x : inl R M M' '' s ∪ inr R M M' '' t → M × M') :=
begin
  refine (hs.image_subtype _).union (ht.image_subtype _) _; [simp, simp, skip],
  simp only [span_image],
  simp [disjoint_iff, prod_inf_prod]
end

lemma linear_independent_inl_union_inr' {v : ι → M} {v' : ι' → M'}
  (hv : linear_independent R v) (hv' : linear_independent R v') :
  linear_independent R (sum.elim (inl R M M' ∘ v) (inr R M M' ∘ v')) :=
(hv.map' (inl R M M') ker_inl).sum_type (hv'.map' (inr R M M') ker_inr) $
begin
  refine is_compl_range_inl_inr.disjoint.mono _ _;
    simp only [span_le, range_coe, range_comp_subset_range],
end

/-- Dedekind's linear independence of characters -/
-- See, for example, <NAME>'s note
--  <https://kconrad.math.uconn.edu/blurbs/galoistheory/linearchar.pdf>
theorem linear_independent_monoid_hom (G : Type*) [monoid G] (L : Type*) [comm_ring L]
  [no_zero_divisors L] :
  @linear_independent _ L (G → L) (λ f, f : (G →* L) → (G → L)) _ _ _ :=
by letI := classical.dec_eq (G →* L);
   letI : mul_action L L := distrib_mul_action.to_mul_action;
-- We prove linear independence by showing that only the trivial linear combination vanishes.
exact linear_independent_iff'.2
-- To do this, we use `finset` induction,
(λ s, finset.induction_on s (λ g hg i, false.elim) $ λ a s has ih g hg,
-- Here
-- * `a` is a new character we will insert into the `finset` of characters `s`,
-- * `ih` is the fact that only the trivial linear combination of characters in `s` is zero
-- * `hg` is the fact that `g` are the coefficients of a linear combination summing to zero
-- and it remains to prove that `g` vanishes on `insert a s`.

-- We now make the key calculation:
-- For any character `i` in the original `finset`, we have `g i • i = g i • a` as functions on the
-- monoid `G`.
have h1 : ∀ i ∈ s, (g i • i : G → L) = g i • a, from λ i his, funext $ λ x : G,
  -- We prove these expressions are equal by showing
  -- the differences of their values on each monoid element `x` is zero
  eq_of_sub_eq_zero $ ih (λ j, g j * j x - g j * a x)
    (funext $ λ y : G, calc
    -- After that, it's just a chase scene.
          (∑ i in s, ((g i * i x - g i * a x) • i : G → L)) y
        = ∑ i in s, (g i * i x - g i * a x) * i y : finset.sum_apply _ _ _
    ... = ∑ i in s, (g i * i x * i y - g i * a x * i y) : finset.sum_congr rfl
      (λ _ _, sub_mul _ _ _)
    ... = ∑ i in s, g i * i x * i y - ∑ i in s, g i * a x * i y : finset.sum_sub_distrib
    ... = (g a * a x * a y + ∑ i in s, g i * i x * i y)
          - (g a * a x * a y + ∑ i in s, g i * a x * i y) : by rw add_sub_add_left_eq_sub
    ... = ∑ i in insert a s, g i * i x * i y - ∑ i in insert a s, g i * a x * i y :
      by rw [finset.sum_insert has, finset.sum_insert has]
    ... = ∑ i in insert a s, g i * i (x * y) - ∑ i in insert a s, a x * (g i * i y) :
      congr (congr_arg has_sub.sub (finset.sum_congr rfl $ λ i _, by rw [i.map_mul, mul_assoc]))
        (finset.sum_congr rfl $ λ _ _, by rw [mul_assoc, mul_left_comm])
    ... = (∑ i in insert a s, (g i • i : G → L)) (x * y)
          - a x * (∑ i in insert a s, (g i • i : G → L)) y :
      by rw [finset.sum_apply, finset.sum_apply, finset.mul_sum]; refl
    ... = 0 - a x * 0 : by rw hg; refl
    ... = 0 : by rw [mul_zero, sub_zero])
    i
    his,
-- On the other hand, since `a` is not already in `s`, for any character `i ∈ s`
-- there is some element of the monoid on which it differs from `a`.
have h2 : ∀ i : G →* L, i ∈ s → ∃ y, i y ≠ a y, from λ i his,
  classical.by_contradiction $ λ h,
  have hia : i = a, from monoid_hom.ext $ λ y, classical.by_contradiction $ λ hy, h ⟨y, hy⟩,
  has $ hia ▸ his,
-- From these two facts we deduce that `g` actually vanishes on `s`,
have h3 : ∀ i ∈ s, g i = 0, from λ i his, let ⟨y, hy⟩ := h2 i his in
  have h : g i • i y = g i • a y, from congr_fun (h1 i his) y,
  or.resolve_right (mul_eq_zero.1 $ by rw [mul_sub, sub_eq_zero]; exact h) (sub_ne_zero_of_ne hy),
-- And so, using the fact that the linear combination over `s` and over `insert a s` both vanish,
-- we deduce that `g a = 0`.
have h4 : g a = 0, from calc
  g a = g a * 1 : (mul_one _).symm
  ... = (g a • a : G → L) 1 : by rw ← a.map_one; refl
  ... = (∑ i in insert a s, (g i • i : G → L)) 1 : begin
      rw finset.sum_eq_single a,
      { intros i his hia, rw finset.mem_insert at his,
        rw [h3 i (his.resolve_left hia), zero_smul] },
      { intros haas, exfalso, apply haas, exact finset.mem_insert_self a s }
    end
  ... = 0 : by rw hg; refl,
-- Now we're done; the last two facts together imply that `g` vanishes on every element
-- of `insert a s`.
(finset.forall_mem_insert _ _ _).2 ⟨h4, h3⟩)

lemma le_of_span_le_span [nontrivial R] {s t u: set M}
  (hl : linear_independent R (coe : u → M )) (hsu : s ⊆ u) (htu : t ⊆ u)
  (hst : span R s ≤ span R t) : s ⊆ t :=
begin
  have := eq_of_linear_independent_of_span_subtype
    (hl.mono (set.union_subset hsu htu))
    (set.subset_union_right _ _)
    (set.union_subset (set.subset.trans subset_span hst) subset_span),
  rw ← this, apply set.subset_union_left
end

lemma span_le_span_iff [nontrivial R] {s t u: set M}
  (hl : linear_independent R (coe : u → M)) (hsu : s ⊆ u) (htu : t ⊆ u) :
  span R s ≤ span R t ↔ s ⊆ t :=
⟨le_of_span_le_span hl hsu htu, span_mono⟩

end module

section nontrivial

variables [ring R] [nontrivial R] [add_comm_group M] [add_comm_group M']
variables [module R M] [no_zero_smul_divisors R M] [module R M']
variables {v : ι → M} {s t : set M} {x y z : M}

lemma linear_independent_unique_iff
  (v : ι → M) [unique ι] :
  linear_independent R v ↔ v default ≠ 0 :=
begin
  simp only [linear_independent_iff, finsupp.total_unique, smul_eq_zero],
  refine ⟨λ h hv, _, λ hv l hl, finsupp.unique_ext $ hl.resolve_right hv⟩,
  have := h (finsupp.single default 1) (or.inr hv),
  exact one_ne_zero (finsupp.single_eq_zero.1 this)
end

alias linear_independent_unique_iff ↔ _ linear_independent_unique

lemma linear_independent_singleton {x : M} (hx : x ≠ 0) :
  linear_independent R (λ x, x : ({x} : set M) → M) :=
linear_independent_unique coe hx

end nontrivial

/-!
### Properties which require `division_ring K`

These can be considered generalizations of properties of linear independence in vector spaces.
-/

section module

variables [division_ring K] [add_comm_group V] [add_comm_group V']
variables [module K V] [module K V']
variables {v : ι → V} {s t : set V} {x y z : V}

open submodule

/- TODO: some of the following proofs can generalized with a zero_ne_one predicate type class
   (instead of a data containing type class) -/

lemma mem_span_insert_exchange : x ∈ span K (insert y s) → x ∉ span K s → y ∈ span K (insert x s) :=
begin
  simp [mem_span_insert],
  rintro a z hz rfl h,
  refine ⟨a⁻¹, -a⁻¹ • z, smul_mem _ _ hz, _⟩,
  have a0 : a ≠ 0, {rintro rfl, simp * at *},
  simp [a0, smul_add, smul_smul]
end

lemma linear_independent_iff_not_mem_span :
  linear_independent K v ↔ (∀i, v i ∉ span K (v '' (univ \ {i}))) :=
begin
  apply linear_independent_iff_not_smul_mem_span.trans,
  split,
  { intros h i h_in_span,
    apply one_ne_zero (h i 1 (by simp [h_in_span])) },
  { intros h i a ha,
    by_contradiction ha',
    exact false.elim (h _ ((smul_mem_iff _ ha').1 ha)) }
end

lemma linear_independent.insert (hs : linear_independent K (λ b, b : s → V)) (hx : x ∉ span K s) :
  linear_independent K (λ b, b : insert x s → V) :=
begin
  rw ← union_singleton,
  have x0 : x ≠ 0 := mt (by rintro rfl; apply zero_mem (span K s)) hx,
  apply hs.union (linear_independent_singleton x0),
  rwa [disjoint_span_singleton' x0]
end

lemma linear_independent_option' :
  linear_independent K (λ o, option.cases_on' o x v : option ι → V) ↔
    linear_independent K v ∧ (x ∉ submodule.span K (range v)) :=
begin
  rw [← linear_independent_equiv (equiv.option_equiv_sum_punit ι).symm, linear_independent_sum,
    @range_unique _ punit, @linear_independent_unique_iff punit, disjoint_span_singleton],
  dsimp [(∘)],
  refine ⟨λ h, ⟨h.1, λ hx, h.2.1 $ h.2.2 hx⟩, λ h, ⟨h.1, _, λ hx, (h.2 hx).elim⟩⟩,
  rintro rfl,
  exact h.2 (zero_mem _)
end

lemma linear_independent.option (hv : linear_independent K v)
  (hx : x ∉ submodule.span K (range v)) :
  linear_independent K (λ o, option.cases_on' o x v : option ι → V) :=
linear_independent_option'.2 ⟨hv, hx⟩

lemma linear_independent_option {v : option ι → V} :
  linear_independent K v ↔
    linear_independent K (v ∘ coe : ι → V) ∧ v none ∉ submodule.span K (range (v ∘ coe : ι → V)) :=
by simp only [← linear_independent_option', option.cases_on'_none_coe]

theorem linear_independent_insert' {ι} {s : set ι} {a : ι} {f : ι → V} (has : a ∉ s) :
  linear_independent K (λ x : insert a s, f x) ↔
  linear_independent K (λ x : s, f x) ∧ f a ∉ submodule.span K (f '' s) :=
by { rw [← linear_independent_equiv ((equiv.option_equiv_sum_punit _).trans
  (equiv.set.insert has).symm), linear_independent_option], simp [(∘), range_comp f] }

theorem linear_independent_insert (hxs : x ∉ s) :
  linear_independent K (λ b : insert x s, (b : V)) ↔
  linear_independent K (λ b : s, (b : V)) ∧ x ∉ submodule.span K s :=
(@linear_independent_insert' _ _ _ _ _ _ _ _ id hxs).trans $ by simp

lemma linear_independent_pair {x y : V} (hx : x ≠ 0) (hy : ∀ a : K, a • x ≠ y) :
  linear_independent K (coe : ({x, y} : set V) → V) :=
pair_comm y x ▸ (linear_independent_singleton hx).insert $ mt mem_span_singleton.1
  (not_exists.2 hy)

lemma linear_independent_fin_cons {n} {v : fin n → V} :
  linear_independent K (fin.cons x v : fin (n + 1) → V) ↔
    linear_independent K v ∧ x ∉ submodule.span K (range v) :=
begin
  rw [← linear_independent_equiv (fin_succ_equiv n).symm, linear_independent_option],
  convert iff.rfl,
  { ext,
    -- TODO: why doesn't simp use `fin_succ_equiv_symm_coe` here?
    rw [comp_app, comp_app, fin_succ_equiv_symm_coe, fin.cons_succ] },
  { ext,
    rw [comp_app, comp_app, fin_succ_equiv_symm_coe, fin.cons_succ] }
end

lemma linear_independent_fin_snoc {n} {v : fin n → V} :
  linear_independent K (fin.snoc v x : fin (n + 1) → V) ↔
    linear_independent K v ∧ x ∉ submodule.span K (range v) :=
by rw [fin.snoc_eq_cons_rotate, linear_independent_equiv, linear_independent_fin_cons]

/-- See `linear_independent.fin_cons'` for an uglier version that works if you
only have a module over a semiring. -/
lemma linear_independent.fin_cons {n} {v : fin n → V} (hv : linear_independent K v)
  (hx : x ∉ submodule.span K (range v)) :
  linear_independent K (fin.cons x v : fin (n + 1) → V) :=
linear_independent_fin_cons.2 ⟨hv, hx⟩

lemma linear_independent_fin_succ {n} {v : fin (n + 1) → V} :
  linear_independent K v ↔
    linear_independent K (fin.tail v) ∧ v 0 ∉ submodule.span K (range $ fin.tail v) :=
by rw [← linear_independent_fin_cons, fin.cons_self_tail]

lemma linear_independent_fin_succ' {n} {v : fin (n + 1) → V} :
  linear_independent K v ↔
    linear_independent K (fin.init v) ∧ v (fin.last _) ∉ submodule.span K (range $ fin.init v) :=
by rw [← linear_independent_fin_snoc, fin.snoc_init_self]

lemma linear_independent_fin2 {f : fin 2 → V} :
  linear_independent K f ↔ f 1 ≠ 0 ∧ ∀ a : K, a • f 1 ≠ f 0 :=
by rw [linear_independent_fin_succ, linear_independent_unique_iff, range_unique,
  mem_span_singleton, not_exists,
  show fin.tail f default = f 1, by rw ← fin.succ_zero_eq_one; refl]

lemma exists_linear_independent_extension (hs : linear_independent K (coe : s → V)) (hst : s ⊆ t) :
  ∃b⊆t, s ⊆ b ∧ t ⊆ span K b ∧ linear_independent K (coe : b → V) :=
begin
  rcases zorn_subset_nonempty {b | b ⊆ t ∧ linear_independent K (coe : b → V)} _ _
    ⟨hst, hs⟩ with ⟨b, ⟨bt, bi⟩, sb, h⟩,
  { refine ⟨b, bt, sb, λ x xt, _, bi⟩,
    by_contra hn,
    apply hn,
    rw ← h _ ⟨insert_subset.2 ⟨xt, bt⟩, bi.insert hn⟩ (subset_insert _ _),
    exact subset_span (mem_insert _ _) },
  { refine λ c hc cc c0, ⟨⋃₀ c, ⟨_, _⟩, λ x, _⟩,
    { exact sUnion_subset (λ x xc, (hc xc).1) },
    { exact linear_independent_sUnion_of_directed cc.directed_on (λ x xc, (hc xc).2) },
    { exact subset_sUnion_of_mem } }
end

variables (K t)

lemma exists_linear_independent :
  ∃ b ⊆ t, span K b = span K t ∧ linear_independent K (coe : b → V) :=
begin
  obtain ⟨b, hb₁, -, hb₂, hb₃⟩ :=
    exists_linear_independent_extension (linear_independent_empty K V) (set.empty_subset t),
  exact ⟨b, hb₁, (span_eq_of_le _ hb₂ (submodule.span_mono hb₁)).symm, hb₃⟩,
end

variables {K t}

/-- `linear_independent.extend` adds vectors to a linear independent set `s ⊆ t` until it spans
all elements of `t`. -/
noncomputable def linear_independent.extend (hs : linear_independent K (λ x, x : s → V))
  (hst : s ⊆ t) : set V :=
classical.some (exists_linear_independent_extension hs hst)

lemma linear_independent.extend_subset (hs : linear_independent K (λ x, x : s → V))
  (hst : s ⊆ t) : hs.extend hst ⊆ t :=
let ⟨hbt, hsb, htb, hli⟩ := classical.some_spec (exists_linear_independent_extension hs hst) in hbt

lemma linear_independent.subset_extend (hs : linear_independent K (λ x, x : s → V))
  (hst : s ⊆ t) : s ⊆ hs.extend hst :=
let ⟨hbt, hsb, htb, hli⟩ := classical.some_spec (exists_linear_independent_extension hs hst) in hsb

lemma linear_independent.subset_span_extend (hs : linear_independent K (λ x, x : s → V))
  (hst : s ⊆ t) : t ⊆ span K (hs.extend hst) :=
let ⟨hbt, hsb, htb, hli⟩ := classical.some_spec (exists_linear_independent_extension hs hst) in htb

lemma linear_independent.linear_independent_extend (hs : linear_independent K (λ x, x : s → V))
  (hst : s ⊆ t) : linear_independent K (coe : hs.extend hst → V) :=
let ⟨hbt, hsb, htb, hli⟩ := classical.some_spec (exists_linear_independent_extension hs hst) in hli

variables {K V}

-- TODO(Mario): rewrite?
lemma exists_of_linear_independent_of_finite_span {t : finset V}
  (hs : linear_independent K (λ x, x : s → V)) (hst : s ⊆ (span K ↑t : submodule K V)) :
  ∃t':finset V, ↑t' ⊆ s ∪ ↑t ∧ s ⊆ ↑t' ∧ t'.card = t.card :=
have ∀t, ∀(s' : finset V), ↑s' ⊆ s → s ∩ ↑t = ∅ → s ⊆ (span K ↑(s' ∪ t) : submodule K V) →
  ∃t':finset V, ↑t' ⊆ s ∪ ↑t ∧ s ⊆ ↑t' ∧ t'.card = (s' ∪ t).card :=
assume t, finset.induction_on t
  (assume s' hs' _ hss',
    have s = ↑s',
      from eq_of_linear_independent_of_span_subtype hs hs' $
          by simpa using hss',
    ⟨s', by simp [this]⟩)
  (assume b₁ t hb₁t ih s' hs' hst hss',
    have hb₁s : b₁ ∉ s,
      from assume h,
      have b₁ ∈ s ∩ ↑(insert b₁ t), from ⟨h, finset.mem_insert_self _ _⟩,
      by rwa [hst] at this,
    have hb₁s' : b₁ ∉ s', from assume h, hb₁s $ hs' h,
    have hst : s ∩ ↑t = ∅,
      from eq_empty_of_subset_empty $ subset.trans
        (by simp [inter_subset_inter, subset.refl]) (le_of_eq hst),
    classical.by_cases
      (assume : s ⊆ (span K ↑(s' ∪ t) : submodule K V),
        let ⟨u, hust, hsu, eq⟩ := ih _ hs' hst this in
        have hb₁u : b₁ ∉ u, from assume h, (hust h).elim hb₁s hb₁t,
        ⟨insert b₁ u, by simp [insert_subset_insert hust],
          subset.trans hsu (by simp), by simp [eq, hb₁t, hb₁s', hb₁u]⟩)
      (assume : ¬ s ⊆ (span K ↑(s' ∪ t) : submodule K V),
        let ⟨b₂, hb₂s, hb₂t⟩ := not_subset.mp this in
        have hb₂t' : b₂ ∉ s' ∪ t, from assume h, hb₂t $ subset_span h,
        have s ⊆ (span K ↑(insert b₂ s' ∪ t) : submodule K V), from
          assume b₃ hb₃,
          have ↑(s' ∪ insert b₁ t) ⊆ insert b₁ (insert b₂ ↑(s' ∪ t) : set V),
            by simp [insert_eq, -singleton_union, -union_singleton, union_subset_union, subset.refl,
              subset_union_right],
          have hb₃ : b₃ ∈ span K (insert b₁ (insert b₂ ↑(s' ∪ t) : set V)),
            from span_mono this (hss' hb₃),
          have s ⊆ (span K (insert b₁ ↑(s' ∪ t)) : submodule K V),
            by simpa [insert_eq, -singleton_union, -union_singleton] using hss',
          have hb₁ : b₁ ∈ span K (insert b₂ ↑(s' ∪ t)),
            from mem_span_insert_exchange (this hb₂s) hb₂t,
          by rw [span_insert_eq_span hb₁] at hb₃; simpa using hb₃,
        let ⟨u, hust, hsu, eq⟩ := ih _ (by simp [insert_subset, hb₂s, hs']) hst this in
        ⟨u, subset.trans hust $ union_subset_union (subset.refl _) (by simp [subset_insert]),
          hsu, by simp [eq, hb₂t', hb₁t, hb₁s']⟩)),
begin
  have eq : t.filter (λx, x ∈ s) ∪ t.filter (λx, x ∉ s) = t,
  { ext1 x,
    by_cases x ∈ s; simp * },
  apply exists.elim (this (t.filter (λx, x ∉ s)) (t.filter (λx, x ∈ s))
    (by simp [set.subset_def]) (by simp [set.ext_iff] {contextual := tt}) (by rwa [eq])),
  intros u h,
  exact ⟨u, subset.trans h.1 (by simp [subset_def, and_imp, or_imp_distrib] {contextual:=tt}),
    h.2.1, by simp only [h.2.2, eq]⟩
end

lemma exists_finite_card_le_of_finite_of_linear_independent_of_span
  (ht : t.finite) (hs : linear_independent K (λ x, x : s → V)) (hst : s ⊆ span K t) :
  ∃h : s.finite, h.to_finset.card ≤ ht.to_finset.card :=
have s ⊆ (span K ↑(ht.to_finset) : submodule K V), by simp; assumption,
let ⟨u, hust, hsu, eq⟩ := exists_of_linear_independent_of_finite_span hs this in
have s.finite, from u.finite_to_set.subset hsu,
⟨this, by rw [←eq]; exact (finset.card_le_of_subset $ finset.coe_subset.mp $ by simp [hsu])⟩

end module


<|start_filename|>src/linear_algebra/affine_space/pointwise.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import linear_algebra.affine_space.affine_subspace


/-! # Pointwise instances on `affine_subspace`s

This file provides the additive action `affine_subspace.pointwise_add_action` in the
`pointwise` locale.

-/

open_locale affine pointwise

open set

namespace affine_subspace

variables {k : Type*} [ring k]
variables {V P V₁ P₁ V₂ P₂ : Type*}

variables [add_comm_group V] [module k V] [affine_space V P]
variables [add_comm_group V₁] [module k V₁] [add_torsor V₁ P₁]
variables [add_comm_group V₂] [module k V₂] [add_torsor V₂ P₂]

include V

/-- The additive action on an affine subspace corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_add_action : add_action V (affine_subspace k P) :=
{ vadd := λ x S, S.map (affine_equiv.const_vadd k P x),
  zero_vadd := λ p,
    (congr_arg (λ f, p.map f) $ affine_map.ext $ by exact zero_vadd _).trans (p.map_id),
  add_vadd := λ x y p,
    (congr_arg (λ f, p.map f) $ affine_map.ext $ by exact add_vadd _ _).trans (p.map_map _ _).symm }

localized "attribute [instance] affine_subspace.pointwise_add_action" in pointwise
open_locale pointwise

@[simp] lemma coe_pointwise_vadd (v : V) (s : affine_subspace k P) :
  ((v +ᵥ s : affine_subspace k P) : set P) = v +ᵥ s := rfl

lemma vadd_mem_pointwise_vadd_iff {v : V} {s : affine_subspace k P} {p : P} :
  v +ᵥ p ∈ v +ᵥ s ↔ p ∈ s :=
vadd_mem_vadd_set_iff

lemma pointwise_vadd_bot (v : V) : v +ᵥ (⊥ : affine_subspace k P) = ⊥ :=
by { ext, simp, }

lemma pointwise_vadd_direction (v : V) (s : affine_subspace k P) :
  (v +ᵥ s).direction = s.direction :=
begin
  unfold has_vadd.vadd,
  rw map_direction,
  exact submodule.map_id _,
end

lemma pointwise_vadd_span (v : V) (s : set P) :
  v +ᵥ affine_span k s = affine_span k (v +ᵥ s) :=
map_span _ s

omit V
include V₁ V₂

lemma map_pointwise_vadd (f : P₁ →ᵃ[k] P₂) (v : V₁) (s : affine_subspace k P₁) :
  (v +ᵥ s).map f = f.linear v +ᵥ s.map f :=
begin
  unfold has_vadd.vadd,
  rw [map_map, map_map],
  congr' 1,
  ext,
  exact f.map_vadd _ _,
end

end affine_subspace


<|start_filename|>src/ring_theory/coprime/ideal.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import linear_algebra.dfinsupp
import ring_theory.ideal.operations

/-!
# An additional lemma about coprime ideals

This lemma generalises `exists_sum_eq_one_iff_pairwise_coprime` to the case of non-principal ideals.
It is on a separate file due to import requirements.
-/

namespace ideal
variables {ι R : Type*} [comm_semiring R]

/--A finite family of ideals is pairwise coprime (that is, any two of them generate the whole ring)
iff when taking all the possible intersections of all but one of these ideals, the resulting family
of ideals still generate the whole ring.

For example with three ideals : `I ⊔ J = I ⊔ K = J ⊔ K = ⊤ ↔ (I ⊓ J) ⊔ (I ⊓ K) ⊔ (J ⊓ K) = ⊤`.

When ideals are all of the form `I i = R ∙ s i`, this is equivalent to the
`exists_sum_eq_one_iff_pairwise_coprime` lemma.-/
lemma supr_infi_eq_top_iff_pairwise {t : finset ι} (h : t.nonempty) (I : ι → ideal R) :
  (⨆ i ∈ t, ⨅ j (hj : j ∈ t) (ij : j ≠ i), I j) = ⊤ ↔
    (t : set ι).pairwise (λ i j, I i ⊔ I j = ⊤) :=
begin
  haveI : decidable_eq ι := classical.dec_eq ι,
  rw [eq_top_iff_one, submodule.mem_supr_finset_iff_exists_sum],
  refine h.cons_induction _ _; clear' t h,
  { simp only [finset.sum_singleton, finset.coe_singleton, set.pairwise_singleton, iff_true],
    refine λ a, ⟨λ i, if h : i = a then ⟨1, _⟩ else 0, _⟩,
    { rw h, simp only [finset.mem_singleton, ne.def, infi_infi_eq_left, eq_self_iff_true,
        not_true, infi_false]},
    { simp only [dif_pos, dif_ctx_congr, submodule.coe_mk, eq_self_iff_true] } },
  intros a t hat h ih,
  rw [finset.coe_cons,
    set.pairwise_insert_of_symmetric (λ i j (h : I i ⊔ I j = ⊤), sup_comm.trans h)],
  split,
  { rintro ⟨μ, hμ⟩, rw finset.sum_cons at hμ,
    refine ⟨ih.mp ⟨pi.single h.some ⟨μ a, _⟩ + λ i, ⟨μ i, _⟩, _⟩, λ b hb ab, _⟩,
    { have := submodule.coe_mem (μ a), rw mem_infi at this ⊢,
      --for some reason `simp only [mem_infi]` times out
      intro i, specialize this i, rw [mem_infi, mem_infi] at this ⊢,
      intros hi _, apply this (finset.subset_cons _ hi),
      rintro rfl, exact hat hi },
    { have := submodule.coe_mem (μ i), simp only [mem_infi] at this ⊢,
      intros j hj ij, exact this _ (finset.subset_cons _ hj) ij },
    { rw [← @if_pos _ _ h.some_spec R (μ a) 0, ← finset.sum_pi_single',
        ← finset.sum_add_distrib] at hμ,
      convert hμ, ext i, rw [pi.add_apply, submodule.coe_add, submodule.coe_mk],
      by_cases hi : i = h.some,
      { rw [hi, pi.single_eq_same, pi.single_eq_same, submodule.coe_mk] },
      { rw [pi.single_eq_of_ne hi, pi.single_eq_of_ne hi, submodule.coe_zero] } },
    { rw [eq_top_iff_one, submodule.mem_sup],
      rw add_comm at hμ, refine ⟨_, _, _, _, hμ⟩,
      { refine sum_mem _ (λ x hx, _),
        have := submodule.coe_mem (μ x), simp only [mem_infi] at this,
        apply this _ (finset.mem_cons_self _ _), rintro rfl, exact hat hx },
      { have := submodule.coe_mem (μ a), simp only [mem_infi] at this,
        exact this _ (finset.subset_cons _ hb) ab.symm } } },
  { rintro ⟨hs, Hb⟩, obtain ⟨μ, hμ⟩ := ih.mpr hs,
    obtain ⟨u, hu, v, hv, huv⟩ := submodule.mem_sup.mp
      ((eq_top_iff_one _).mp $ sup_infi_eq_top $ λ b hb, Hb b hb $ by { rintro rfl, exact hat hb }),
    refine ⟨λ i, if hi : i = a then ⟨v, _⟩ else ⟨u * μ i, _⟩, _⟩,
    { simp only [mem_infi] at hv ⊢,
      intros j hj ij, rw [finset.mem_cons, ← hi] at hj,
      exact hv _ (hj.resolve_left ij) },
    { have := submodule.coe_mem (μ i), simp only [mem_infi] at this ⊢,
      intros j hj ij,
      rcases finset.mem_cons.mp hj with rfl | hj,
      { exact mul_mem_right _ _ hu },
      { exact mul_mem_left _ _ (this _ hj ij) } },
    { rw [finset.sum_cons, dif_pos rfl, add_comm],
      rw ← mul_one u at huv, rw [← huv, ← hμ, finset.mul_sum],
      congr' 1, apply finset.sum_congr rfl, intros j hj,
      rw dif_neg, refl,
      rintro rfl, exact hat hj } }
end

end ideal


<|start_filename|>src/algebra/lie/ideal_operations.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.lie.submodule

/-!
# Ideal operations for Lie algebras

Given a Lie module `M` over a Lie algebra `L`, there is a natural action of the Lie ideals of `L`
on the Lie submodules of `M`. In the special case that `M = L` with the adjoint action, this
provides a pairing of Lie ideals which is especially important. For example, it can be used to
define solvability / nilpotency of a Lie algebra via the derived / lower-central series.

## Main definitions

  * `lie_submodule.has_bracket`
  * `lie_submodule.lie_ideal_oper_eq_linear_span`
  * `lie_ideal.map_bracket_le`
  * `lie_ideal.comap_bracket_le`

## Notation

Given a Lie module `M` over a Lie algebra `L`, together with a Lie submodule `N ⊆ M` and a Lie
ideal `I ⊆ L`, we introduce the notation `⁅I, N⁆` for the Lie submodule of `M` corresponding to
the action defined in this file.

## Tags

lie algebra, ideal operation
-/

universes u v w w₁ w₂

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w} {M₂ : Type w₁}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group M₂] [module R M₂] [lie_ring_module L M₂] [lie_module R L M₂]
variables (N N' : lie_submodule R L M) (I J : lie_ideal R L) (N₂ : lie_submodule R L M₂)

section lie_ideal_operations

/-- Given a Lie module `M` over a Lie algebra `L`, the set of Lie ideals of `L` acts on the set
of submodules of `M`. -/
instance has_bracket : has_bracket (lie_ideal R L) (lie_submodule R L M) :=
⟨λ I N, lie_span R L { m | ∃ (x : I) (n : N), ⁅(x : L), (n : M)⁆ = m }⟩

lemma lie_ideal_oper_eq_span :
  ⁅I, N⁆ = lie_span R L { m | ∃ (x : I) (n : N), ⁅(x : L), (n : M)⁆ = m } := rfl

/-- See also `lie_submodule.lie_ideal_oper_eq_linear_span'` and
`lie_submodule.lie_ideal_oper_eq_tensor_map_range`. -/
lemma lie_ideal_oper_eq_linear_span :
  (↑⁅I, N⁆ : submodule R M) = submodule.span R { m | ∃ (x : I) (n : N), ⁅(x : L), (n : M)⁆ = m } :=
begin
  apply le_antisymm,
  { let s := {m : M | ∃ (x : ↥I) (n : ↥N), ⁅(x : L), (n : M)⁆ = m},
    have aux : ∀ (y : L) (m' ∈ submodule.span R s), ⁅y, m'⁆ ∈ submodule.span R s,
    { intros y m' hm', apply submodule.span_induction hm',
      { rintros m'' ⟨x, n, hm''⟩, rw [← hm'', leibniz_lie],
        refine submodule.add_mem _ _ _; apply submodule.subset_span,
        { use [⟨⁅y, ↑x⁆, I.lie_mem x.property⟩, n], refl, },
        { use [x, ⟨⁅y, ↑n⁆, N.lie_mem n.property⟩], refl, }, },
      { simp only [lie_zero, submodule.zero_mem], },
      { intros m₁ m₂ hm₁ hm₂, rw lie_add, exact submodule.add_mem _ hm₁ hm₂, },
      { intros t m'' hm'', rw lie_smul, exact submodule.smul_mem _ t hm'', }, },
    change _ ≤ ↑({ lie_mem := aux, ..submodule.span R s } : lie_submodule R L M),
    rw [coe_submodule_le_coe_submodule, lie_ideal_oper_eq_span, lie_span_le],
    exact submodule.subset_span, },
  { rw lie_ideal_oper_eq_span, apply submodule_span_le_lie_span, },
end

lemma lie_ideal_oper_eq_linear_span' :
  (↑⁅I, N⁆ : submodule R M) = submodule.span R { m | ∃ (x ∈ I) (n ∈ N), ⁅x, n⁆ = m } :=
begin
  rw lie_ideal_oper_eq_linear_span,
  congr,
  ext m,
  split,
  { rintros ⟨⟨x, hx⟩, ⟨n, hn⟩, rfl⟩,
    exact ⟨x, hx, n, hn, rfl⟩, },
  { rintros ⟨x, hx, n, hn, rfl⟩,
    exact ⟨⟨x, hx⟩, ⟨n, hn⟩, rfl⟩, },
end

lemma lie_le_iff : ⁅I, N⁆ ≤ N' ↔ ∀ (x ∈ I) (m ∈ N), ⁅x, m⁆ ∈ N' :=
begin
  rw [lie_ideal_oper_eq_span, lie_submodule.lie_span_le],
  refine ⟨λ h x hx m hm, h ⟨⟨x, hx⟩, ⟨m, hm⟩, rfl⟩, _⟩,
  rintros h - ⟨⟨x, hx⟩, ⟨m, hm⟩, rfl⟩,
  exact h x hx m hm,
end

lemma lie_coe_mem_lie (x : I) (m : N) : ⁅(x : L), (m : M)⁆ ∈ ⁅I, N⁆ :=
by { rw lie_ideal_oper_eq_span, apply subset_lie_span, use [x, m], }

lemma lie_mem_lie {x : L} {m : M} (hx : x ∈ I) (hm : m ∈ N) : ⁅x, m⁆ ∈ ⁅I, N⁆ :=
N.lie_coe_mem_lie I ⟨x, hx⟩ ⟨m, hm⟩

lemma lie_comm : ⁅I, J⁆ = ⁅J, I⁆ :=
begin
  suffices : ∀ (I J : lie_ideal R L), ⁅I, J⁆ ≤ ⁅J, I⁆, { exact le_antisymm (this I J) (this J I), },
  clear I J, intros I J,
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros x ⟨y, z, h⟩, rw ← h,
  rw [← lie_skew, ← lie_neg, ← submodule.coe_neg],
  apply lie_coe_mem_lie,
end

lemma lie_le_right : ⁅I, N⁆ ≤ N :=
begin
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨x, n, hn⟩, rw ← hn,
  exact N.lie_mem n.property,
end

lemma lie_le_left : ⁅I, J⁆ ≤ I :=
by { rw lie_comm, exact lie_le_right I J, }

lemma lie_le_inf : ⁅I, J⁆ ≤ I ⊓ J :=
by { rw le_inf_iff, exact ⟨lie_le_left I J, lie_le_right J I⟩, }

@[simp] lemma lie_bot : ⁅I, (⊥ : lie_submodule R L M)⁆ = ⊥ :=
by { rw eq_bot_iff, apply lie_le_right, }

@[simp] lemma bot_lie : ⁅(⊥ : lie_ideal R L), N⁆ = ⊥ :=
begin
  suffices : ⁅(⊥ : lie_ideal R L), N⁆ ≤ ⊥, { exact le_bot_iff.mp this, },
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨⟨x, hx⟩, n, hn⟩, rw ← hn,
  change x ∈ (⊥ : lie_ideal R L) at hx, rw mem_bot at hx, simp [hx],
end

lemma lie_eq_bot_iff : ⁅I, N⁆ = ⊥ ↔ ∀ (x ∈ I) (m ∈ N), ⁅(x : L), m⁆ = 0 :=
begin
  rw [lie_ideal_oper_eq_span, lie_submodule.lie_span_eq_bot_iff],
  refine ⟨λ h x hx m hm, h ⁅x, m⁆ ⟨⟨x, hx⟩, ⟨m, hm⟩, rfl⟩, _⟩,
  rintros h - ⟨⟨x, hx⟩, ⟨⟨n, hn⟩, rfl⟩⟩,
  exact h x hx n hn,
end

lemma mono_lie (h₁ : I ≤ J) (h₂ : N ≤ N') : ⁅I, N⁆ ≤ ⁅J, N'⁆ :=
begin
  intros m h,
  rw [lie_ideal_oper_eq_span, mem_lie_span] at h, rw [lie_ideal_oper_eq_span, mem_lie_span],
  intros N hN, apply h, rintros m' ⟨⟨x, hx⟩, ⟨n, hn⟩, hm⟩, rw ← hm, apply hN,
  use [⟨x, h₁ hx⟩, ⟨n, h₂ hn⟩], refl,
end

lemma mono_lie_left (h : I ≤ J) : ⁅I, N⁆ ≤ ⁅J, N⁆ := mono_lie _ _ _ _ h (le_refl N)

lemma mono_lie_right (h : N ≤ N') : ⁅I, N⁆ ≤ ⁅I, N'⁆ := mono_lie _ _ _ _ (le_refl I) h

@[simp] lemma lie_sup : ⁅I, N ⊔ N'⁆ = ⁅I, N⁆ ⊔ ⁅I, N'⁆ :=
begin
  have h : ⁅I, N⁆ ⊔ ⁅I, N'⁆ ≤ ⁅I, N ⊔ N'⁆,
  { rw sup_le_iff, split; apply mono_lie_right; [exact le_sup_left, exact le_sup_right], },
  suffices : ⁅I, N ⊔ N'⁆ ≤ ⁅I, N⁆ ⊔ ⁅I, N'⁆, { exact le_antisymm this h, }, clear h,
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨x, ⟨n, hn⟩, h⟩, erw lie_submodule.mem_sup,
  erw lie_submodule.mem_sup at hn, rcases hn with ⟨n₁, hn₁, n₂, hn₂, hn'⟩,
  use ⁅(x : L), (⟨n₁, hn₁⟩ : N)⁆, split, { apply lie_coe_mem_lie, },
  use ⁅(x : L), (⟨n₂, hn₂⟩ : N')⁆, split, { apply lie_coe_mem_lie, },
  simp [← h, ← hn'],
end

@[simp] lemma sup_lie : ⁅I ⊔ J, N⁆ = ⁅I, N⁆ ⊔ ⁅J, N⁆ :=
begin
  have h : ⁅I, N⁆ ⊔ ⁅J, N⁆ ≤ ⁅I ⊔ J, N⁆,
  { rw sup_le_iff, split; apply mono_lie_left; [exact le_sup_left, exact le_sup_right], },
  suffices : ⁅I ⊔ J, N⁆ ≤ ⁅I, N⁆ ⊔ ⁅J, N⁆, { exact le_antisymm this h, }, clear h,
  rw [lie_ideal_oper_eq_span, lie_span_le], rintros m ⟨⟨x, hx⟩, n, h⟩, erw lie_submodule.mem_sup,
  erw lie_submodule.mem_sup at hx, rcases hx with ⟨x₁, hx₁, x₂, hx₂, hx'⟩,
  use ⁅((⟨x₁, hx₁⟩ : I) : L), (n : N)⁆, split, { apply lie_coe_mem_lie, },
  use ⁅((⟨x₂, hx₂⟩ : J) : L), (n : N)⁆, split, { apply lie_coe_mem_lie, },
  simp [← h, ← hx'],
end

@[simp] lemma lie_inf : ⁅I, N ⊓ N'⁆ ≤ ⁅I, N⁆ ⊓ ⁅I, N'⁆ :=
by { rw le_inf_iff, split; apply mono_lie_right; [exact inf_le_left, exact inf_le_right], }

@[simp] lemma inf_lie : ⁅I ⊓ J, N⁆ ≤ ⁅I, N⁆ ⊓ ⁅J, N⁆ :=
by { rw le_inf_iff, split; apply mono_lie_left; [exact inf_le_left, exact inf_le_right], }

variables (f : M →ₗ⁅R,L⁆ M₂)

lemma map_bracket_eq : map f ⁅I, N⁆ = ⁅I, map f N⁆ :=
begin
  rw [← coe_to_submodule_eq_iff, coe_submodule_map, lie_ideal_oper_eq_linear_span,
    lie_ideal_oper_eq_linear_span, submodule.map_span],
  congr,
  ext m,
  split,
  { rintros ⟨-, ⟨⟨x, ⟨n, hn⟩, rfl⟩, hm⟩⟩,
    simp only [lie_module_hom.coe_to_linear_map, lie_module_hom.map_lie] at hm,
    exact ⟨x, ⟨f n, (mem_map (f n)).mpr ⟨n, hn, rfl⟩⟩, hm⟩, },
  { rintros ⟨x, ⟨m₂, hm₂ : m₂ ∈ map f N⟩, rfl⟩,
    obtain ⟨n, hn, rfl⟩ := (mem_map m₂).mp hm₂,
    exact ⟨⁅x, n⁆, ⟨x, ⟨n, hn⟩, rfl⟩, by simp⟩, },
end

lemma map_comap_le : map f (comap f N₂) ≤ N₂ :=
(N₂ : set M₂).image_preimage_subset f

lemma map_comap_eq (hf : N₂ ≤ f.range) : map f (comap f N₂) = N₂ :=
begin
  rw set_like.ext'_iff,
  exact set.image_preimage_eq_of_subset hf,
end

lemma le_comap_map : N ≤ comap f (map f N) :=
(N : set M).subset_preimage_image f

lemma comap_map_eq (hf : f.ker = ⊥) : comap f (map f N) = N :=
begin
  rw set_like.ext'_iff,
  exact (N : set M).preimage_image_eq (f.ker_eq_bot.mp hf),
end

lemma comap_bracket_eq (hf₁ : f.ker = ⊥) (hf₂ : N₂ ≤ f.range) :
  comap f ⁅I, N₂⁆ = ⁅I, comap f N₂⁆ :=
begin
  conv_lhs { rw ← map_comap_eq N₂ f hf₂, },
  rw [← map_bracket_eq, comap_map_eq _ f hf₁],
end

@[simp] lemma map_comap_incl : map N.incl (comap N.incl N') = N ⊓ N' :=
begin
  rw ← coe_to_submodule_eq_iff,
  exact (N : submodule R M).map_comap_subtype N',
end

end lie_ideal_operations

end lie_submodule

namespace lie_ideal

open lie_algebra

variables {R : Type u} {L : Type v} {L' : Type w₂}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
variables (f : L →ₗ⁅R⁆ L') (I : lie_ideal R L) (J : lie_ideal R L')

/-- Note that the inequality can be strict; e.g., the inclusion of an Abelian subalgebra of a
simple algebra. -/
lemma map_bracket_le {I₁ I₂ : lie_ideal R L} : map f ⁅I₁, I₂⁆ ≤ ⁅map f I₁, map f I₂⁆ :=
begin
  rw map_le_iff_le_comap, erw lie_submodule.lie_span_le,
  intros x hx, obtain ⟨⟨y₁, hy₁⟩, ⟨y₂, hy₂⟩, hx⟩ := hx, rw ← hx,
  let fy₁ : ↥(map f I₁) := ⟨f y₁, mem_map hy₁⟩,
  let fy₂ : ↥(map f I₂) := ⟨f y₂, mem_map hy₂⟩,
  change _ ∈ comap f ⁅map f I₁, map f I₂⁆,
  simp only [submodule.coe_mk, mem_comap, lie_hom.map_lie],
  exact lie_submodule.lie_coe_mem_lie _ _ fy₁ fy₂,
end

lemma map_bracket_eq {I₁ I₂ : lie_ideal R L} (h : function.surjective f) :
  map f ⁅I₁, I₂⁆ = ⁅map f I₁, map f I₂⁆ :=
begin
  suffices : ⁅map f I₁, map f I₂⁆ ≤ map f ⁅I₁, I₂⁆, { exact le_antisymm (map_bracket_le f) this, },
  rw [← lie_submodule.coe_submodule_le_coe_submodule, coe_map_of_surjective h,
    lie_submodule.lie_ideal_oper_eq_linear_span,
    lie_submodule.lie_ideal_oper_eq_linear_span, linear_map.map_span],
  apply submodule.span_mono,
  rintros x ⟨⟨z₁, h₁⟩, ⟨z₂, h₂⟩, rfl⟩,
  obtain ⟨y₁, rfl⟩ := mem_map_of_surjective h h₁,
  obtain ⟨y₂, rfl⟩ := mem_map_of_surjective h h₂,
  use [⁅(y₁ : L), (y₂ : L)⁆, y₁, y₂],
  apply f.map_lie,
end

lemma comap_bracket_le {J₁ J₂ : lie_ideal R L'} : ⁅comap f J₁, comap f J₂⁆ ≤ comap f ⁅J₁, J₂⁆ :=
begin
  rw ← map_le_iff_le_comap,
  exact le_trans (map_bracket_le f) (lie_submodule.mono_lie _ _ _ _ map_comap_le map_comap_le),
end

variables {f}

lemma map_comap_incl {I₁ I₂ : lie_ideal R L} : map I₁.incl (comap I₁.incl I₂) = I₁ ⊓ I₂ :=
by { conv_rhs { rw ← I₁.incl_ideal_range, }, rw ← map_comap_eq, exact I₁.incl_is_ideal_morphism, }

lemma comap_bracket_eq {J₁ J₂ : lie_ideal R L'} (h : f.is_ideal_morphism) :
  comap f ⁅f.ideal_range ⊓ J₁, f.ideal_range ⊓ J₂⁆ = ⁅comap f J₁, comap f J₂⁆ ⊔ f.ker :=
begin
  rw [← lie_submodule.coe_to_submodule_eq_iff, comap_coe_submodule,
    lie_submodule.sup_coe_to_submodule, f.ker_coe_submodule, ← submodule.comap_map_eq,
    lie_submodule.lie_ideal_oper_eq_linear_span, lie_submodule.lie_ideal_oper_eq_linear_span,
    linear_map.map_span],
  congr, simp only [lie_hom.coe_to_linear_map, set.mem_set_of_eq], ext y,
  split,
  { rintros ⟨⟨x₁, hx₁⟩, ⟨x₂, hx₂⟩, hy⟩, rw ← hy,
    erw [lie_submodule.mem_inf, f.mem_ideal_range_iff h] at hx₁ hx₂,
    obtain ⟨⟨z₁, hz₁⟩, hz₁'⟩ := hx₁, rw ← hz₁ at hz₁',
    obtain ⟨⟨z₂, hz₂⟩, hz₂'⟩ := hx₂, rw ← hz₂ at hz₂',
    use [⁅z₁, z₂⁆, ⟨z₁, hz₁'⟩, ⟨z₂, hz₂'⟩, rfl],
    simp only [hz₁, hz₂, submodule.coe_mk, lie_hom.map_lie], },
  { rintros ⟨x, ⟨⟨z₁, hz₁⟩, ⟨z₂, hz₂⟩, hx⟩, hy⟩, rw [← hy, ← hx],
    have hz₁' : f z₁ ∈ f.ideal_range ⊓ J₁,
    { rw lie_submodule.mem_inf, exact ⟨f.mem_ideal_range, hz₁⟩, },
    have hz₂' : f z₂ ∈ f.ideal_range ⊓ J₂,
    { rw lie_submodule.mem_inf, exact ⟨f.mem_ideal_range, hz₂⟩, },
    use [⟨f z₁, hz₁'⟩, ⟨f z₂, hz₂'⟩], simp only [submodule.coe_mk, lie_hom.map_lie], },
end

lemma map_comap_bracket_eq {J₁ J₂ : lie_ideal R L'} (h : f.is_ideal_morphism) :
  map f ⁅comap f J₁, comap f J₂⁆ = ⁅f.ideal_range ⊓ J₁, f.ideal_range ⊓ J₂⁆ :=
by { rw [← map_sup_ker_eq_map, ← comap_bracket_eq h, map_comap_eq h, inf_eq_right],
     exact le_trans (lie_submodule.lie_le_left _ _) inf_le_left, }

lemma comap_bracket_incl {I₁ I₂ : lie_ideal R L} :
  ⁅comap I.incl I₁, comap I.incl I₂⁆ = comap I.incl ⁅I ⊓ I₁, I ⊓ I₂⁆ :=
begin
  conv_rhs { congr, skip, rw ← I.incl_ideal_range, }, rw comap_bracket_eq,
  simp only [ker_incl, sup_bot_eq], exact I.incl_is_ideal_morphism,
end

/-- This is a very useful result; it allows us to use the fact that inclusion distributes over the
Lie bracket operation on ideals, subject to the conditions shown. -/
lemma comap_bracket_incl_of_le {I₁ I₂ : lie_ideal R L} (h₁ : I₁ ≤ I) (h₂ : I₂ ≤ I) :
  ⁅comap I.incl I₁, comap I.incl I₂⁆ = comap I.incl ⁅I₁, I₂⁆ :=
by { rw comap_bracket_incl, rw ← inf_eq_right at h₁ h₂, rw [h₁, h₂], }

end lie_ideal


<|start_filename|>src/algebra/category/Module/products.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.category.Module.epi_mono
import linear_algebra.pi

/-!
# The concrete products in the category of modules are products in the categorical sense.
-/

open category_theory
open category_theory.limits

universes u v w

namespace Module
variables {R : Type u} [ring R]

variables {ι : Type v} (Z : ι → Module.{max v w} R)

/-- The product cone induced by the concrete product. -/
def product_cone : fan Z :=
fan.mk (Module.of R (Π i : ι, Z i)) (λ i, (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i))

/-- The concrete product cone is limiting. -/
def product_cone_is_limit : is_limit (product_cone Z) :=
{ lift := λ s, (linear_map.pi (λ j, s.π.app ⟨j⟩) : s.X →ₗ[R] (Π i : ι, Z i)),
  fac' := λ s j, by { cases j, tidy, },
  uniq' := λ s m w, by { ext x i, exact linear_map.congr_fun (w ⟨i⟩) x, }, }

-- While we could use this to construct a `has_products (Module R)` instance,
-- we already have `has_limits (Module R)` in `algebra.category.Module.limits`.

variables [has_product Z]

/--
The categorical product of a family of objects in `Module`
agrees with the usual module-theoretical product.
-/
noncomputable def pi_iso_pi :
  ∏ Z ≅ Module.of R (Π i, Z i) :=
limit.iso_limit_cone ⟨_, product_cone_is_limit Z⟩

-- We now show this isomorphism commutes with the inclusion of the kernel into the source.

@[simp, elementwise] lemma pi_iso_pi_inv_kernel_ι (i : ι) :
  (pi_iso_pi Z).inv ≫ pi.π Z i = (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i) :=
limit.iso_limit_cone_inv_π _ _

@[simp, elementwise] lemma pi_iso_pi_hom_ker_subtype (i : ι) :
  (pi_iso_pi Z).hom ≫ (linear_map.proj i : (Π i : ι, Z i) →ₗ[R] Z i) = pi.π Z i :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ (limit.is_limit _) (discrete.mk i)

end Module


<|start_filename|>src/combinatorics/simple_graph/inc_matrix.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import combinatorics.simple_graph.basic
import data.matrix.basic

/-!
# Incidence matrix of a simple graph

This file defines the unoriented incidence matrix of a simple graph.

## Main definitions

* `simple_graph.inc_matrix`: `G.inc_matrix R` is the incidence matrix of `G` over the ring `R`.

## Main results

* `simple_graph.inc_matrix_mul_transpose_diag`: The diagonal entries of the product of
  `G.inc_matrix R` and its transpose are the degrees of the vertices.
* `simple_graph.inc_matrix_mul_transpose`: Gives a complete description of the product of
  `G.inc_matrix R` and its transpose; the diagonal is the degrees of each vertex, and the
  off-diagonals are 1 or 0 depending on whether or not the vertices are adjacent.
* `simple_graph.inc_matrix_transpose_mul_diag`: The diagonal entries of the product of the
  transpose of `G.inc_matrix R` and `G.inc_matrix R` are `2` or `0` depending on whether or
  not the unordered pair is an edge of `G`.

## Implementation notes

The usual definition of an incidence matrix has one row per vertex and one column per edge.
However, this definition has columns indexed by all of `sym2 α`, where `α` is the vertex type.
This appears not to change the theory, and for simple graphs it has the nice effect that every
incidence matrix for each `simple_graph α` has the same type.

## TODO

* Define the oriented incidence matrices for oriented graphs.
* Define the graph Laplacian of a simple graph using the oriented incidence matrix from an
  arbitrary orientation of a simple graph.
-/

open finset matrix simple_graph sym2
open_locale big_operators matrix

namespace simple_graph
variables (R : Type*) {α : Type*} (G : simple_graph α)

/-- `G.inc_matrix R` is the `α × sym2 α` matrix whose `(a, e)`-entry is `1` if `e` is incident to
`a` and `0` otherwise. -/
noncomputable def inc_matrix [has_zero R] [has_one R] : matrix α (sym2 α) R :=
λ a, (G.incidence_set a).indicator 1

variables {R}

lemma inc_matrix_apply [has_zero R] [has_one R] {a : α} {e : sym2 α} :
  G.inc_matrix R a e = (G.incidence_set a).indicator 1 e := rfl

/-- Entries of the incidence matrix can be computed given additional decidable instances. -/
lemma inc_matrix_apply' [has_zero R] [has_one R] [decidable_eq α] [decidable_rel G.adj]
  {a : α} {e : sym2 α} :
  G.inc_matrix R a e = if e ∈ G.incidence_set a then 1 else 0 :=
by convert rfl

section mul_zero_one_class
variables [mul_zero_one_class R] {a b : α} {e : sym2 α}

lemma inc_matrix_apply_mul_inc_matrix_apply :
  G.inc_matrix R a e * G.inc_matrix R b e = (G.incidence_set a ∩ G.incidence_set b).indicator 1 e :=
begin
  classical,
  simp only [inc_matrix, set.indicator_apply, ←ite_and_mul_zero,
    pi.one_apply, mul_one, set.mem_inter_eq],
end

lemma inc_matrix_apply_mul_inc_matrix_apply_of_not_adj (hab : a ≠ b) (h : ¬ G.adj a b) :
  G.inc_matrix R a e * G.inc_matrix R b e = 0 :=
begin
  rw [inc_matrix_apply_mul_inc_matrix_apply, set.indicator_of_not_mem],
  rw [G.incidence_set_inter_incidence_set_of_not_adj h hab],
  exact set.not_mem_empty e,
end

lemma inc_matrix_of_not_mem_incidence_set (h : e ∉ G.incidence_set a) :
  G.inc_matrix R a e = 0 :=
by rw [inc_matrix_apply, set.indicator_of_not_mem h]

lemma inc_matrix_of_mem_incidence_set (h : e ∈ G.incidence_set a) : G.inc_matrix R a e = 1 :=
by rw [inc_matrix_apply, set.indicator_of_mem h, pi.one_apply]

variables [nontrivial R]

lemma inc_matrix_apply_eq_zero_iff : G.inc_matrix R a e = 0 ↔ e ∉ G.incidence_set a :=
begin
  simp only [inc_matrix_apply, set.indicator_apply_eq_zero, pi.one_apply, one_ne_zero],
  exact iff.rfl,
end

lemma inc_matrix_apply_eq_one_iff : G.inc_matrix R a e = 1 ↔ e ∈ G.incidence_set a :=
by { convert one_ne_zero.ite_eq_left_iff, assumption }

end mul_zero_one_class

section non_assoc_semiring
variables [fintype α] [non_assoc_semiring R] {a b : α} {e : sym2 α}

lemma sum_inc_matrix_apply [decidable_eq α] [decidable_rel G.adj] :
  ∑ e, G.inc_matrix R a e = G.degree a :=
by simp [inc_matrix_apply', sum_boole, set.filter_mem_univ_eq_to_finset]

lemma inc_matrix_mul_transpose_diag [decidable_eq α] [decidable_rel G.adj] :
  (G.inc_matrix R ⬝ (G.inc_matrix R)ᵀ) a a = G.degree a :=
begin
  rw ←sum_inc_matrix_apply,
  simp [matrix.mul_apply, inc_matrix_apply', ←ite_and_mul_zero],
end

lemma sum_inc_matrix_apply_of_mem_edge_set : e ∈ G.edge_set → ∑ a, G.inc_matrix R a e = 2 :=
begin
  classical,
  refine e.ind _,
  intros a b h,
  rw mem_edge_set at h,
  rw [←nat.cast_two, ←card_doubleton h.ne],
  simp only [inc_matrix_apply', sum_boole, mk_mem_incidence_set_iff, h, true_and],
  congr' 2,
  ext e,
  simp only [mem_filter, mem_univ, true_and, mem_insert, mem_singleton],
end

lemma sum_inc_matrix_apply_of_not_mem_edge_set (h : e ∉ G.edge_set) : ∑ a, G.inc_matrix R a e = 0 :=
sum_eq_zero $ λ a _, G.inc_matrix_of_not_mem_incidence_set $ λ he, h he.1

lemma inc_matrix_transpose_mul_diag [decidable_rel G.adj] :
  ((G.inc_matrix R)ᵀ ⬝ G.inc_matrix R) e e = if e ∈ G.edge_set then 2 else 0 :=
begin
  classical,
  simp only [matrix.mul_apply, inc_matrix_apply', transpose_apply, ←ite_and_mul_zero,
    one_mul, sum_boole, and_self],
  split_ifs with h,
  { revert h,
    refine e.ind _,
    intros v w h,
    rw [←nat.cast_two, ←card_doubleton (G.ne_of_adj h)],
    simp [mk_mem_incidence_set_iff, G.mem_edge_set.mp h],
    congr' 2,
    ext u,
    simp, },
  { revert h,
    refine e.ind _,
    intros v w h,
    simp [mk_mem_incidence_set_iff, G.mem_edge_set.not.mp h], },
end

end non_assoc_semiring

section semiring
variables [fintype (sym2 α)] [semiring R] {a b : α} {e : sym2 α}

lemma inc_matrix_mul_transpose_apply_of_adj (h : G.adj a b) :
  (G.inc_matrix R ⬝ (G.inc_matrix R)ᵀ) a b = (1 : R) :=
begin
  classical,
  simp_rw [matrix.mul_apply, matrix.transpose_apply, inc_matrix_apply_mul_inc_matrix_apply,
    set.indicator_apply, pi.one_apply, sum_boole],
  convert nat.cast_one,
  convert card_singleton ⟦(a, b)⟧,
  rw [←coe_eq_singleton, coe_filter_univ],
  exact G.incidence_set_inter_incidence_set_of_adj h,
end

lemma inc_matrix_mul_transpose [fintype α] [decidable_eq α] [decidable_rel G.adj] :
  G.inc_matrix R ⬝ (G.inc_matrix R)ᵀ = λ a b,
    if a = b then G.degree a else if G.adj a b then 1 else 0 :=
begin
  ext a b,
  split_ifs with h h',
  { subst b,
    convert G.inc_matrix_mul_transpose_diag },
  { exact G.inc_matrix_mul_transpose_apply_of_adj h' },
  { simp only [matrix.mul_apply, matrix.transpose_apply,
    G.inc_matrix_apply_mul_inc_matrix_apply_of_not_adj h h', sum_const_zero] }
end

end semiring
end simple_graph


<|start_filename|>src/linear_algebra/tensor_product_basis.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import linear_algebra.direct_sum.finsupp
import linear_algebra.finsupp_vector_space

/-!
# Bases and dimensionality of tensor products of modules

These can not go into `linear_algebra.tensor_product` since they depend on
`linear_algebra.finsupp_vector_space` which in turn imports `linear_algebra.tensor_product`.

-/
noncomputable theory
open set linear_map submodule

section comm_ring
variables {R : Type*} {M : Type*} {N : Type*} {ι : Type*} {κ : Type*}
variables [comm_ring R] [add_comm_group M] [module R M] [add_comm_group N] [module R N]

/-- If b : ι → M and c : κ → N are bases then so is λ i, b i.1 ⊗ₜ c i.2 : ι × κ → M ⊗ N. -/
def basis.tensor_product (b : basis ι R M) (c : basis κ R N) :
  basis (ι × κ) R (tensor_product R M N) :=
finsupp.basis_single_one.map
  ((tensor_product.congr b.repr c.repr).trans $
    (finsupp_tensor_finsupp R _ _ _ _).trans $
    finsupp.lcongr (equiv.refl _) (tensor_product.lid R R)).symm

@[simp]
lemma basis.tensor_product_apply (b : basis ι R M) (c : basis κ R N) (i : ι) (j : κ) :
  basis.tensor_product b c (i, j) = b i ⊗ₜ c j :=
by simp [basis.tensor_product]

lemma basis.tensor_product_apply' (b : basis ι R M) (c : basis κ R N) (i : ι × κ) :
  basis.tensor_product b c i = b i.1 ⊗ₜ c i.2 :=
by simp [basis.tensor_product]

end comm_ring


<|start_filename|>src/linear_algebra/trace.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>
-/
import linear_algebra.matrix.to_lin
import linear_algebra.matrix.trace
import linear_algebra.contraction
import linear_algebra.tensor_product_basis
import linear_algebra.free_module.strong_rank_condition
import linear_algebra.projection

/-!
# Trace of a linear map

This file defines the trace of a linear map.

See also `linear_algebra/matrix/trace.lean` for the trace of a matrix.

## Tags

linear_map, trace, diagonal

-/

noncomputable theory

universes u v w

namespace linear_map

open_locale big_operators
open_locale matrix
open finite_dimensional

open_locale tensor_product

section
variables (R : Type u) [comm_semiring R] {M : Type v} [add_comm_monoid M] [module R M]
variables {ι : Type w} [decidable_eq ι] [fintype ι]
variables {κ : Type*} [decidable_eq κ] [fintype κ]
variables (b : basis ι R M) (c : basis κ R M)

/-- The trace of an endomorphism given a basis. -/
def trace_aux :
  (M →ₗ[R] M) →ₗ[R] R :=
(matrix.trace_linear_map ι R R) ∘ₗ ↑(linear_map.to_matrix b b)

-- Can't be `simp` because it would cause a loop.
lemma trace_aux_def (b : basis ι R M) (f : M →ₗ[R] M) :
  trace_aux R b f = matrix.trace (linear_map.to_matrix b b f) :=
rfl

theorem trace_aux_eq : trace_aux R b = trace_aux R c :=
linear_map.ext $ λ f,
calc  matrix.trace (linear_map.to_matrix b b f)
    = matrix.trace (linear_map.to_matrix b b ((linear_map.id.comp f).comp linear_map.id)) :
  by rw [linear_map.id_comp, linear_map.comp_id]
... = matrix.trace (linear_map.to_matrix c b linear_map.id ⬝
        linear_map.to_matrix c c f ⬝
        linear_map.to_matrix b c linear_map.id) :
  by rw [linear_map.to_matrix_comp _ c, linear_map.to_matrix_comp _ c]
... = matrix.trace (linear_map.to_matrix c c f ⬝
        linear_map.to_matrix b c linear_map.id ⬝
        linear_map.to_matrix c b linear_map.id) :
  by rw [matrix.mul_assoc, matrix.trace_mul_comm]
... = matrix.trace (linear_map.to_matrix c c ((f.comp linear_map.id).comp linear_map.id)) :
  by rw [linear_map.to_matrix_comp _ b, linear_map.to_matrix_comp _ c]
... = matrix.trace (linear_map.to_matrix c c f) :
  by rw [linear_map.comp_id, linear_map.comp_id]

open_locale classical

variables (R) (M)

/-- Trace of an endomorphism independent of basis. -/
def trace : (M →ₗ[R] M) →ₗ[R] R :=
if H : ∃ (s : finset M), nonempty (basis s R M)
then trace_aux R H.some_spec.some
else 0

variables (R) {M}

/-- Auxiliary lemma for `trace_eq_matrix_trace`. -/
theorem trace_eq_matrix_trace_of_finset {s : finset M} (b : basis s R M)
  (f : M →ₗ[R] M) :
  trace R M f = matrix.trace (linear_map.to_matrix b b f) :=
have ∃ (s : finset M), nonempty (basis s R M),
from ⟨s, ⟨b⟩⟩,
by { rw [trace, dif_pos this, ← trace_aux_def], congr' 1, apply trace_aux_eq }

theorem trace_eq_matrix_trace (f : M →ₗ[R] M) :
  trace R M f = matrix.trace (linear_map.to_matrix b b f) :=
by rw [trace_eq_matrix_trace_of_finset R b.reindex_finset_range,
    ← trace_aux_def, ← trace_aux_def, trace_aux_eq R b]

theorem trace_mul_comm (f g : M →ₗ[R] M) :
  trace R M (f * g) = trace R M (g * f) :=
if H : ∃ (s : finset M), nonempty (basis s R M) then let ⟨s, ⟨b⟩⟩ := H in
by { simp_rw [trace_eq_matrix_trace R b, linear_map.to_matrix_mul], apply matrix.trace_mul_comm }
else by rw [trace, dif_neg H, linear_map.zero_apply, linear_map.zero_apply]

/-- The trace of an endomorphism is invariant under conjugation -/
@[simp]
theorem trace_conj (g : M →ₗ[R] M) (f : (M →ₗ[R] M)ˣ) :
  trace R M (↑f * g * ↑f⁻¹) = trace R M g :=
by { rw trace_mul_comm, simp }

end

section

variables {R : Type*} [comm_ring R] {M : Type*} [add_comm_group M] [module R M]
variables (N : Type*) [add_comm_group N] [module R N]
variables {ι : Type*} [fintype ι]

/-- The trace of a linear map correspond to the contraction pairing under the isomorphism
 `End(M) ≃ M* ⊗ M`-/
lemma trace_eq_contract_of_basis (b : basis ι R M) :
  (linear_map.trace R M) ∘ₗ (dual_tensor_hom R M M) = contract_left R M :=
begin
  classical,
  apply basis.ext (basis.tensor_product (basis.dual_basis b) b),
  rintros ⟨i, j⟩,
  simp only [function.comp_app, basis.tensor_product_apply, basis.coe_dual_basis, coe_comp],
  rw [trace_eq_matrix_trace R b, to_matrix_dual_tensor_hom],
  by_cases hij : i = j,
  { rw [hij], simp },
  rw matrix.std_basis_matrix.trace_zero j i (1:R) hij,
  simp [finsupp.single_eq_pi_single, hij],
end

/-- The trace of a linear map correspond to the contraction pairing under the isomorphism
 `End(M) ≃ M* ⊗ M`-/
lemma trace_eq_contract_of_basis' [decidable_eq ι] (b : basis ι R M) :
  (linear_map.trace R M) =
  (contract_left R M) ∘ₗ (dual_tensor_hom_equiv_of_basis b).symm.to_linear_map :=
by simp [linear_equiv.eq_comp_to_linear_map_symm, trace_eq_contract_of_basis b]

variables (R M N)
variables [module.free R M] [module.finite R M] [module.free R N] [module.finite R N] [nontrivial R]

/-- When `M` is finite free, the trace of a linear map correspond to the contraction pairing under
the isomorphism `End(M) ≃ M* ⊗ M`-/
@[simp] theorem trace_eq_contract :
  (linear_map.trace R M) ∘ₗ (dual_tensor_hom R M M) = contract_left R M :=
trace_eq_contract_of_basis (module.free.choose_basis R M)

@[simp] theorem trace_eq_contract_apply (x : module.dual R M ⊗[R] M) :
  (linear_map.trace R M) ((dual_tensor_hom R M M) x) = contract_left R M x :=
by rw [←comp_apply, trace_eq_contract]

open_locale classical

/-- When `M` is finite free, the trace of a linear map correspond to the contraction pairing under
the isomorphism `End(M) ≃ M* ⊗ M`-/
theorem trace_eq_contract' :
  (linear_map.trace R M) =
  (contract_left R M) ∘ₗ (dual_tensor_hom_equiv R M M).symm.to_linear_map :=
trace_eq_contract_of_basis' (module.free.choose_basis R M)

/-- The trace of the identity endomorphism is the dimension of the free module -/
@[simp] theorem trace_one : trace R M 1 = (finrank R M : R) :=
begin
  have b := module.free.choose_basis R M,
  rw [trace_eq_matrix_trace R b, to_matrix_one, module.free.finrank_eq_card_choose_basis_index],
  simp,
end

/-- The trace of the identity endomorphism is the dimension of the free module -/
@[simp] theorem trace_id : trace R M id = (finrank R M : R) :=
by rw [←one_eq_id, trace_one]

@[simp] theorem trace_transpose : trace R (module.dual R M) ∘ₗ module.dual.transpose = trace R M :=
begin
  let e := dual_tensor_hom_equiv R M M,
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext f m, simp [e],
end

theorem trace_prod_map :
  trace R (M × N) ∘ₗ prod_map_linear R M N M N R =
  (coprod id id : R × R →ₗ[R] R) ∘ₗ prod_map (trace R M) (trace R N) :=
begin
  let e := ((dual_tensor_hom_equiv R M M).prod (dual_tensor_hom_equiv R N N)),
  have h : function.surjective e.to_linear_map := e.surjective,
  refine (cancel_right h).1 _,
  ext,
  { simp only [dual_tensor_hom_equiv, tensor_product.algebra_tensor_module.curry_apply,
  to_fun_eq_coe, tensor_product.curry_apply, coe_restrict_scalars_eq_coe, coe_comp,
  linear_equiv.coe_to_linear_map, coe_inl, function.comp_app, linear_equiv.prod_apply,
  dual_tensor_hom_equiv_of_basis_apply, map_zero, prod_map_apply, coprod_apply, id_coe, id.def,
  add_zero, prod_map_linear_apply, dual_tensor_hom_prod_map_zero, trace_eq_contract_apply,
  contract_left_apply, fst_apply] },
  { simp only [dual_tensor_hom_equiv, tensor_product.algebra_tensor_module.curry_apply,
  to_fun_eq_coe, tensor_product.curry_apply, coe_restrict_scalars_eq_coe, coe_comp,
  linear_equiv.coe_to_linear_map, coe_inr, function.comp_app, linear_equiv.prod_apply,
  dual_tensor_hom_equiv_of_basis_apply, map_zero, prod_map_apply, coprod_apply, id_coe, id.def,
  zero_add, prod_map_linear_apply, zero_prod_map_dual_tensor_hom, trace_eq_contract_apply,
  contract_left_apply, snd_apply], },
end

variables {R M N}

theorem trace_prod_map' (f : M →ₗ[R] M) (g : N →ₗ[R] N) :
  trace R (M × N) (prod_map f g) = trace R M f + trace R N g :=
begin
  have h := ext_iff.1 (trace_prod_map R M N) (f, g),
  simp only [coe_comp, function.comp_app, prod_map_apply, coprod_apply, id_coe, id.def,
  prod_map_linear_apply] at h, exact h,
end

variables (R M N)

open tensor_product function

theorem trace_tensor_product :
  compr₂ (map_bilinear R M N M N) (trace R (M ⊗ N)) =
  compl₁₂ (lsmul R R : R →ₗ[R] R →ₗ[R] R) (trace R M) (trace R N) :=
begin
  apply (compl₁₂_inj
    (show surjective (dual_tensor_hom R M M), from (dual_tensor_hom_equiv R M M).surjective)
    (show surjective (dual_tensor_hom R N N), from (dual_tensor_hom_equiv R N N).surjective)).1,
  ext f m g n,
  simp only [algebra_tensor_module.curry_apply, to_fun_eq_coe, tensor_product.curry_apply,
  coe_restrict_scalars_eq_coe, compl₁₂_apply, compr₂_apply, map_bilinear_apply,
  trace_eq_contract_apply, contract_left_apply, lsmul_apply, algebra.id.smul_eq_mul,
  map_dual_tensor_hom, dual_distrib_apply],
end

theorem trace_comp_comm :
  compr₂ (llcomp R M N M) (trace R M) = compr₂ (llcomp R N M N).flip (trace R N) :=
begin
  apply (compl₁₂_inj
    (show surjective (dual_tensor_hom R N M), from (dual_tensor_hom_equiv R N M).surjective)
    (show surjective (dual_tensor_hom R M N), from (dual_tensor_hom_equiv R M N).surjective)).1,
  ext g m f n,
  simp only [tensor_product.algebra_tensor_module.curry_apply, to_fun_eq_coe,
      linear_equiv.coe_to_linear_map, tensor_product.curry_apply, coe_restrict_scalars_eq_coe,
      compl₁₂_apply, compr₂_apply, flip_apply, llcomp_apply', comp_dual_tensor_hom, map_smul,
      trace_eq_contract_apply, contract_left_apply, smul_eq_mul, mul_comm],
end

variables {R M N}

@[simp]
theorem trace_transpose' (f : M →ₗ[R] M) : trace R _ (module.dual.transpose f) = trace R M f :=
by { rw [←comp_apply, trace_transpose] }

theorem trace_tensor_product' (f : M →ₗ[R] M) (g : N →ₗ[R] N) :
  trace R (M ⊗ N) (map f g) = trace R M f * trace R N g :=
begin
  have h := ext_iff.1 (ext_iff.1 (trace_tensor_product R M N) f) g,
  simp only [compr₂_apply, map_bilinear_apply, compl₁₂_apply, lsmul_apply,
    algebra.id.smul_eq_mul] at h, exact h,
end

theorem trace_comp_comm' (f : M →ₗ[R] N) (g : N →ₗ[R] M) :
  trace R M (g ∘ₗ f) = trace R N (f ∘ₗ g) :=
begin
  have h := ext_iff.1 (ext_iff.1 (trace_comp_comm R M N) g) f,
  simp only [llcomp_apply', compr₂_apply, flip_apply] at h,
  exact h,
end

@[simp] theorem trace_conj' (f : M →ₗ[R] M) (e : M ≃ₗ[R] N) : trace R N (e.conj f) = trace R M f :=
by rw [e.conj_apply, trace_comp_comm', ←comp_assoc, linear_equiv.comp_coe,
  linear_equiv.self_trans_symm, linear_equiv.refl_to_linear_map, id_comp]

theorem is_proj.trace {p : submodule R M} {f : M →ₗ[R] M} (h : is_proj p f)
  [module.free R p] [module.finite R p] [module.free R f.ker] [module.finite R f.ker] :
  trace R M f = (finrank R p : R) :=
by rw [h.eq_conj_prod_map, trace_conj', trace_prod_map', trace_id, map_zero, add_zero]

end

end linear_map


<|start_filename|>src/topology/algebra/order/floor.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.order.floor
import topology.algebra.order.basic

/-!
# Topological facts about `int.floor`, `int.ceil` and `int.fract`

This file proves statements about limits and continuity of functions involving `floor`, `ceil` and
`fract`.

## Main declarations

* `tendsto_floor_at_top`, `tendsto_floor_at_bot`, `tendsto_ceil_at_top`, `tendsto_ceil_at_bot`:
  `int.floor` and `int.ceil` tend to +-∞ in +-∞.
* `continuous_on_floor`: `int.floor` is continuous on `Ico n (n + 1)`, because constant.
* `continuous_on_ceil`: `int.ceil` is continuous on `Ioc n (n + 1)`, because constant.
* `continuous_on_fract`: `int.fract` is continuous on `Ico n (n + 1)`.
* `continuous_on.comp_fract`: Precomposing a continuous function satisfying `f 0 = f 1` with
  `int.fract` yields another continuous function.
-/

open filter function int set
open_locale topological_space

variables {α β γ : Type*} [linear_ordered_ring α] [floor_ring α]

lemma tendsto_floor_at_top : tendsto (floor : α → ℤ) at_top at_top :=
floor_mono.tendsto_at_top_at_top $ λ b, ⟨(b + 1 : ℤ), by { rw floor_coe, exact (lt_add_one _).le }⟩

lemma tendsto_floor_at_bot : tendsto (floor : α → ℤ) at_bot at_bot :=
floor_mono.tendsto_at_bot_at_bot $ λ b, ⟨b, (floor_coe _).le⟩

lemma tendsto_ceil_at_top : tendsto (ceil : α → ℤ) at_top at_top :=
ceil_mono.tendsto_at_top_at_top $ λ b, ⟨b, (ceil_coe _).ge⟩

lemma tendsto_ceil_at_bot : tendsto (ceil : α → ℤ) at_bot at_bot :=
ceil_mono.tendsto_at_bot_at_bot $ λ b, ⟨(b - 1 : ℤ), by { rw ceil_coe, exact (sub_one_lt _).le }⟩

variables [topological_space α]

lemma continuous_on_floor (n : ℤ) : continuous_on (λ x, floor x : α → α) (Ico n (n+1) : set α) :=
(continuous_on_congr $ floor_eq_on_Ico' n).mpr continuous_on_const

lemma continuous_on_ceil (n : ℤ) : continuous_on (λ x, ceil x : α → α) (Ioc (n-1) n : set α) :=
(continuous_on_congr $ ceil_eq_on_Ioc' n).mpr continuous_on_const

lemma tendsto_floor_right' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[≥] n) (𝓝 n) :=
begin
  rw ← nhds_within_Ico_eq_nhds_within_Ici (lt_add_one (n : α)),
  simpa only [floor_coe] using
    (continuous_on_floor n _ (left_mem_Ico.mpr $ lt_add_one (_ : α))).tendsto
end

lemma tendsto_ceil_left' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[≤] n) (𝓝 n) :=
begin
  rw ← nhds_within_Ioc_eq_nhds_within_Iic (sub_one_lt (n : α)),
  simpa only [ceil_coe] using
    (continuous_on_ceil _ _ (right_mem_Ioc.mpr $ sub_one_lt (_ : α))).tendsto
end

lemma tendsto_floor_right [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[≥] n) (𝓝[≥] n) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ (tendsto_floor_right' _)
begin
  refine (eventually_nhds_within_of_forall $ λ x (hx : (n : α) ≤ x), _),
  change _ ≤ _,
  norm_cast,
  convert ← floor_mono hx,
  rw floor_eq_iff,
  exact ⟨le_rfl, lt_add_one _⟩
end

lemma tendsto_ceil_left [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[≤] n) (𝓝[≤] n) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ (tendsto_ceil_left' _)
begin
  refine (eventually_nhds_within_of_forall $ λ x (hx : x ≤ (n : α)), _),
  change _ ≤ _,
  norm_cast,
  convert ← ceil_mono hx,
  rw ceil_eq_iff,
  exact ⟨sub_one_lt _, le_rfl⟩
end

lemma tendsto_floor_left [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[<] n) (𝓝[≤] (n-1)) :=
begin
  rw ← nhds_within_Ico_eq_nhds_within_Iio (sub_one_lt (n : α)),
  convert (tendsto_nhds_within_congr $ (λ x hx, (floor_eq_on_Ico' (n-1) x hx).symm))
    (tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ tendsto_const_nhds
      (eventually_of_forall (λ _, mem_Iic.mpr $ le_rfl)));
  norm_cast <|> apply_instance,
  ring
end

lemma tendsto_ceil_right [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[>] n) (𝓝[≥] (n+1)) :=
begin
  rw ← nhds_within_Ioc_eq_nhds_within_Ioi (lt_add_one (n : α)),
  convert (tendsto_nhds_within_congr $ (λ x hx, (ceil_eq_on_Ioc' (n+1) x hx).symm))
    (tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _ tendsto_const_nhds
      (eventually_of_forall (λ _, mem_Ici.mpr $ le_rfl)));
  norm_cast <|> apply_instance,
  ring
end

lemma tendsto_floor_left' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, floor x : α → α) (𝓝[<] n) (𝓝 (n-1)) :=
begin
  rw ← nhds_within_univ,
  exact tendsto_nhds_within_mono_right (subset_univ _) (tendsto_floor_left n),
end

lemma tendsto_ceil_right' [order_closed_topology α] (n : ℤ) :
  tendsto (λ x, ceil x : α → α) (𝓝[>] n) (𝓝 (n+1)) :=
begin
  rw ← nhds_within_univ,
  exact tendsto_nhds_within_mono_right (subset_univ _) (tendsto_ceil_right n),
end

lemma continuous_on_fract [topological_add_group α] (n : ℤ) :
  continuous_on (fract : α → α) (Ico n (n+1) : set α) :=
continuous_on_id.sub (continuous_on_floor n)

lemma tendsto_fract_left' [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[<] n) (𝓝 1) :=
begin
  convert (tendsto_nhds_within_of_tendsto_nhds tendsto_id).sub (tendsto_floor_left' n);
  [{norm_cast, ring}, apply_instance, apply_instance]
end

lemma tendsto_fract_left [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[<] n) (𝓝[<] 1) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  (tendsto_fract_left' _) (eventually_of_forall fract_lt_one)

lemma tendsto_fract_right' [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[≥] n) (𝓝 0) :=
begin
  convert (tendsto_nhds_within_of_tendsto_nhds tendsto_id).sub (tendsto_floor_right' n);
  [exact (sub_self _).symm, apply_instance, apply_instance]
end

lemma tendsto_fract_right [order_closed_topology α] [topological_add_group α]
  (n : ℤ) : tendsto (fract : α → α) (𝓝[≥] n) (𝓝[≥] 0) :=
tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
  (tendsto_fract_right' _) (eventually_of_forall fract_nonneg)

local notation `I` := (Icc 0 1 : set α)

variables [order_topology α] [topological_add_group α] [topological_space β] [topological_space γ]

/-- Do not use this, use `continuous_on.comp_fract` instead. -/
lemma continuous_on.comp_fract' {f : β → α → γ}
  (h : continuous_on (uncurry f) $ (univ : set β) ×ˢ I) (hf : ∀ s, f s 0 = f s 1) :
  continuous (λ st : β × α, f st.1 $ fract st.2) :=
begin
  change continuous ((uncurry f) ∘ (prod.map id (fract))),
  rw continuous_iff_continuous_at,
  rintro ⟨s, t⟩,
  by_cases ht : t = floor t,
  { rw ht,
    rw ← continuous_within_at_univ,
    have : (univ : set (β × α)) ⊆ ((univ : set β) ×ˢ Iio ↑⌊t⌋) ∪ ((univ : set β) ×ˢ Ici ↑⌊t⌋),
    { rintros p -,
      rw ← prod_union,
      exact ⟨trivial, lt_or_le p.2 _⟩ },
    refine continuous_within_at.mono _ this,
    refine continuous_within_at.union _ _,
    { simp only [continuous_within_at, fract_coe, nhds_within_prod_eq,
                  nhds_within_univ, id.def, comp_app, prod.map_mk],
      have : (uncurry f) (s, 0) = (uncurry f) (s, (1 : α)),
        by simp [uncurry, hf],
      rw this,
      refine (h _ ⟨⟨⟩, by exact_mod_cast right_mem_Icc.2 (zero_le_one' α)⟩).tendsto.comp _,
      rw [nhds_within_prod_eq, nhds_within_univ],
      rw nhds_within_Icc_eq_nhds_within_Iic (@zero_lt_one α _ _),
      exact tendsto_id.prod_map
        (tendsto_nhds_within_mono_right Iio_subset_Iic_self $ tendsto_fract_left _) },
    { simp only [continuous_within_at, fract_coe, nhds_within_prod_eq,
                  nhds_within_univ, id.def, comp_app, prod.map_mk],
      refine (h _ ⟨⟨⟩, by exact_mod_cast left_mem_Icc.2 (zero_le_one' α)⟩).tendsto.comp _,
      rw [nhds_within_prod_eq, nhds_within_univ,
        nhds_within_Icc_eq_nhds_within_Ici (@zero_lt_one α _ _)],
      exact tendsto_id.prod_map (tendsto_fract_right _) } },
  { have : t ∈ Ioo (floor t : α) ((floor t : α) + 1),
      from ⟨lt_of_le_of_ne (floor_le t) (ne.symm ht), lt_floor_add_one _⟩,
    apply (h ((prod.map _ fract) _) ⟨trivial, ⟨fract_nonneg _, (fract_lt_one _).le⟩⟩).tendsto.comp,
    simp only [nhds_prod_eq, nhds_within_prod_eq, nhds_within_univ, id.def, prod.map_mk],
    exact continuous_at_id.tendsto.prod_map
            (tendsto_nhds_within_of_tendsto_nhds_of_eventually_within _
              (((continuous_on_fract _ _ (Ioo_subset_Ico_self this)).mono
                  Ioo_subset_Ico_self).continuous_at (Ioo_mem_nhds this.1 this.2))
              (eventually_of_forall (λ x, ⟨fract_nonneg _, (fract_lt_one _).le⟩)) ) }
end

lemma continuous_on.comp_fract
  {s : β → α}
  {f : β → α → γ}
  (h : continuous_on (uncurry f) $ (univ : set β) ×ˢ (Icc 0 1 : set α))
  (hs : continuous s)
  (hf : ∀ s, f s 0 = f s 1) :
  continuous (λ x : β, f x $ int.fract (s x)) :=
(h.comp_fract' hf).comp (continuous_id.prod_mk hs)

/-- A special case of `continuous_on.comp_fract`. -/
lemma continuous_on.comp_fract'' {f : α → β} (h : continuous_on f I) (hf : f 0 = f 1) :
  continuous (f ∘ fract) :=
continuous_on.comp_fract (h.comp continuous_on_snd $ λ x hx, (mem_prod.mp hx).2)
  continuous_id (λ _, hf)


<|start_filename|>src/measure_theory/card_measurable_space.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import measure_theory.measurable_space_def
import set_theory.cardinal.cofinality
import set_theory.cardinal.continuum

/-!
# Cardinal of sigma-algebras

If a sigma-algebra is generated by a set of sets `s`, then the cardinality of the sigma-algebra is
bounded by `(max (#s) 2) ^ ℵ₀`. This is stated in `measurable_space.cardinal_generate_measurable_le`
and `measurable_space.cardinal_measurable_set_le`.

In particular, if `#s ≤ 𝔠`, then the generated sigma-algebra has cardinality at most `𝔠`, see
`measurable_space.cardinal_measurable_set_le_continuum`.

For the proof, we rely on an explicit inductive construction of the sigma-algebra generated by
`s` (instead of the inductive predicate `generate_measurable`). This transfinite inductive
construction is parameterized by an ordinal `< ω₁`, and the cardinality bound is preserved along
each step of the construction. We show in `measurable_space.generate_measurable_eq_rec` that this
indeed generates this sigma-algebra.
-/

universe u
variables {α : Type u}

open_locale cardinal
open cardinal set

local notation `ω₁` := (aleph 1 : cardinal.{u}).ord.out.α

namespace measurable_space

/-- Transfinite induction construction of the sigma-algebra generated by a set of sets `s`. At each
step, we add all elements of `s`, the empty set, the complements of already constructed sets, and
countable unions of already constructed sets. We index this construction by an ordinal `< ω₁`, as
this will be enough to generate all sets in the sigma-algebra.

This construction is very similar to that of the Borel hierarchy. -/
def generate_measurable_rec (s : set (set α)) : ω₁ → set (set α)
| i := let S := ⋃ j : {j // j < i}, generate_measurable_rec j.1 in
    s ∪ {∅} ∪ compl '' S ∪ set.range (λ (f : ℕ → S), ⋃ n, (f n).1)
using_well_founded {dec_tac := `[exact j.2]}

theorem self_subset_generate_measurable_rec (s : set (set α)) (i : ω₁) :
  s ⊆ generate_measurable_rec s i :=
begin
  unfold generate_measurable_rec,
  apply_rules [subset_union_of_subset_left],
  exact subset_rfl
end

theorem empty_mem_generate_measurable_rec (s : set (set α)) (i : ω₁) :
  ∅ ∈ generate_measurable_rec s i :=
begin
  unfold generate_measurable_rec,
  exact mem_union_left _ (mem_union_left _ (mem_union_right _ (mem_singleton ∅)))
end

theorem compl_mem_generate_measurable_rec {s : set (set α)} {i j : ω₁} (h : j < i) {t : set α}
  (ht : t ∈ generate_measurable_rec s j) : tᶜ ∈ generate_measurable_rec s i :=
begin
  unfold generate_measurable_rec,
  exact mem_union_left _ (mem_union_right _ ⟨t, mem_Union.2 ⟨⟨j, h⟩, ht⟩, rfl⟩)
end

theorem Union_mem_generate_measurable_rec {s : set (set α)} {i : ω₁}
  {f : ℕ → set α} (hf : ∀ n, ∃ j < i, f n ∈ generate_measurable_rec s j) :
  (⋃ n, f n) ∈ generate_measurable_rec s i :=
begin
  unfold generate_measurable_rec,
  exact mem_union_right _ ⟨λ n, ⟨f n, let ⟨j, hj, hf⟩ := hf n in mem_Union.2 ⟨⟨j, hj⟩, hf⟩⟩, rfl⟩
end

theorem generate_measurable_rec_subset (s : set (set α)) {i j : ω₁} (h : i ≤ j) :
  generate_measurable_rec s i ⊆ generate_measurable_rec s j :=
λ x hx, begin
  rcases eq_or_lt_of_le h with rfl | h,
  { exact hx },
  { convert Union_mem_generate_measurable_rec (λ n, ⟨i, h, hx⟩),
    exact (Union_const x).symm }
end

/-- At each step of the inductive construction, the cardinality bound `≤ (max (#s) 2) ^ ℵ₀` holds.
-/
lemma cardinal_generate_measurable_rec_le (s : set (set α)) (i : ω₁) :
  #(generate_measurable_rec s i) ≤ (max (#s) 2) ^ aleph_0.{u} :=
begin
  apply (aleph 1).ord.out.wo.wf.induction i,
  assume i IH,
  have A := aleph_0_le_aleph 1,
  have B : aleph 1 ≤ (max (#s) 2) ^ aleph_0.{u} :=
    aleph_one_le_continuum.trans (power_le_power_right (le_max_right _ _)),
  have C : ℵ₀ ≤ (max (#s) 2) ^ aleph_0.{u} := A.trans B,
  have J : #(⋃ (j : {j // j < i}), generate_measurable_rec s j.1) ≤ (max (#s) 2) ^ aleph_0.{u},
  { apply (mk_Union_le _).trans,
    have D : cardinal.sup.{u u} (λ (j : {j // j < i}), #(generate_measurable_rec s j.1)) ≤ _ :=
      cardinal.sup_le (λ ⟨j, hj⟩, IH j hj),
    apply (mul_le_mul' ((mk_subtype_le _).trans (aleph 1).mk_ord_out.le) D).trans,
    rw mul_eq_max A C,
    exact max_le B le_rfl },
  rw [generate_measurable_rec],
  apply_rules [(mk_union_le _ _).trans, add_le_of_le C, mk_image_le.trans],
  { exact (le_max_left _ _).trans (self_le_power _ one_lt_aleph_0.le) },
  { rw [mk_singleton],
    exact one_lt_aleph_0.le.trans C },
  { apply mk_range_le.trans,
    simp only [mk_pi, subtype.val_eq_coe, prod_const, lift_uzero, mk_denumerable, lift_aleph_0],
    have := @power_le_power_right _ _ ℵ₀ J,
    rwa [← power_mul, aleph_0_mul_aleph_0] at this }
end

/-- `generate_measurable_rec s` generates precisely the smallest sigma-algebra containing `s`. -/
theorem generate_measurable_eq_rec (s : set (set α)) :
  {t | generate_measurable s t} = ⋃ i, generate_measurable_rec s i :=
begin
  ext t, refine ⟨λ ht, _, λ ht, _⟩,
  { inhabit ω₁,
    induction ht with u hu u hu IH f hf IH,
    { exact mem_Union.2 ⟨default, self_subset_generate_measurable_rec s _ hu⟩ },
    { exact mem_Union.2 ⟨default, empty_mem_generate_measurable_rec s _⟩ },
    { rcases mem_Union.1 IH with ⟨i, hi⟩,
      obtain ⟨j, hj⟩ := exists_gt i,
      exact mem_Union.2 ⟨j, compl_mem_generate_measurable_rec hj hi⟩ },
    { have : ∀ n, ∃ i, f n ∈ generate_measurable_rec s i := λ n, by simpa using IH n,
      choose I hI using this,
      refine mem_Union.2 ⟨ordinal.enum (<) (ordinal.lsub (λ n, ordinal.typein.{u} (<) (I n))) _,
        Union_mem_generate_measurable_rec (λ n, ⟨I n, _, hI n⟩)⟩,
      { rw ordinal.type_lt,
        refine ordinal.lsub_lt_ord_lift _ (λ i, ordinal.typein_lt_self _),
        rw [mk_denumerable, lift_aleph_0, is_regular_aleph_one.cof_eq],
        exact aleph_0_lt_aleph_one },
      { rw [←ordinal.typein_lt_typein (<), ordinal.typein_enum],
        apply ordinal.lt_lsub (λ n : ℕ, _) } } },
  { rcases ht with ⟨t, ⟨i, rfl⟩, hx⟩,
    revert t,
    apply (aleph 1).ord.out.wo.wf.induction i,
    intros j H t ht,
    unfold generate_measurable_rec at ht,
    rcases ht with (((h | h) | ⟨u, ⟨-, ⟨⟨k, hk⟩, rfl⟩, hu⟩, rfl⟩) | ⟨f, rfl⟩),
    { exact generate_measurable.basic t h },
    { convert generate_measurable.empty },
    { exact generate_measurable.compl u (H k hk u hu) },
    { apply generate_measurable.union _ (λ n, _),
      obtain ⟨-, ⟨⟨k, hk⟩, rfl⟩, hf⟩ := (f n).prop,
      exact H k hk _ hf } }
end

/-- If a sigma-algebra is generated by a set of sets `s`, then the sigma-algebra has cardinality at
most `(max (#s) 2) ^ ℵ₀`. -/
theorem cardinal_generate_measurable_le (s : set (set α)) :
  #{t | generate_measurable s t} ≤ (max (#s) 2) ^ aleph_0.{u} :=
begin
  rw generate_measurable_eq_rec,
  apply (mk_Union_le _).trans,
  rw (aleph 1).mk_ord_out,
  refine le_trans (mul_le_mul' aleph_one_le_continuum
    (cardinal.sup_le (λ i, cardinal_generate_measurable_rec_le s i))) _,
  have := power_le_power_right (le_max_right (#s) 2),
  rw mul_eq_max aleph_0_le_continuum (aleph_0_le_continuum.trans this),
  exact max_le this le_rfl
end

/-- If a sigma-algebra is generated by a set of sets `s`, then the sigma
algebra has cardinality at most `(max (#s) 2) ^ ℵ₀`. -/
theorem cardinal_measurable_set_le (s : set (set α)) :
  #{t | @measurable_set α (generate_from s) t} ≤ (max (#s) 2) ^ aleph_0.{u} :=
cardinal_generate_measurable_le s

/-- If a sigma-algebra is generated by a set of sets `s` with cardinality at most the continuum,
then the sigma algebra has the same cardinality bound. -/
theorem cardinal_generate_measurable_le_continuum {s : set (set α)} (hs : #s ≤ 𝔠) :
  #{t | generate_measurable s t} ≤ 𝔠 :=
(cardinal_generate_measurable_le s).trans begin
  rw ←continuum_power_aleph_0,
  exact_mod_cast power_le_power_right (max_le hs (nat_lt_continuum 2).le)
end

/-- If a sigma-algebra is generated by a set of sets `s` with cardinality at most the continuum,
then the sigma algebra has the same cardinality bound. -/
theorem cardinal_measurable_set_le_continuum {s : set (set α)} :
  #s ≤ 𝔠 → #{t | @measurable_set α (generate_from s) t} ≤ 𝔠 :=
cardinal_generate_measurable_le_continuum

end measurable_space


<|start_filename|>src/set_theory/game/ordinal.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import set_theory.game.pgame
import set_theory.ordinal.basic

/-!
# Ordinals as games

We define the canonical map `ordinal → pgame`, where every ordinal is mapped to the game whose left
set consists of all previous ordinals.

The map to surreals is defined in `ordinal.to_surreal`.

# Main declarations

- `ordinal.to_pgame`: The canonical map between ordinals and pre-games.
- `ordinal.to_pgame_embedding`: The order embedding version of the previous map.
-/

universe u

open pgame

local infix ` ≈ ` := equiv
local infix ` ⧏ `:50 := lf

namespace ordinal

/-- Converts an ordinal into the corresponding pre-game. -/
noncomputable! def to_pgame : Π o : ordinal.{u}, pgame.{u}
| o := ⟨o.out.α, pempty, λ x, let hwf := ordinal.typein_lt_self x in
        (typein (<) x).to_pgame, pempty.elim⟩
using_well_founded { dec_tac := tactic.assumption }

theorem to_pgame_def (o : ordinal) :
  o.to_pgame = ⟨o.out.α, pempty, λ x, (typein (<) x).to_pgame, pempty.elim⟩ :=
by rw to_pgame

@[simp] theorem to_pgame_left_moves (o : ordinal) : o.to_pgame.left_moves = o.out.α :=
by rw [to_pgame, left_moves]

@[simp] theorem to_pgame_right_moves (o : ordinal) : o.to_pgame.right_moves = pempty :=
by rw [to_pgame, right_moves]

instance : is_empty (to_pgame 0).left_moves :=
by { rw to_pgame_left_moves, apply_instance }

instance (o : ordinal) : is_empty o.to_pgame.right_moves :=
by { rw to_pgame_right_moves, apply_instance }

/-- Converts an ordinal less than `o` into a move for the `pgame` corresponding to `o`, and vice
versa. -/
noncomputable def to_left_moves_to_pgame {o : ordinal} : set.Iio o ≃ o.to_pgame.left_moves :=
(enum_iso_out o).to_equiv.trans (equiv.cast (to_pgame_left_moves o).symm)

@[simp] theorem to_left_moves_to_pgame_symm_lt {o : ordinal} (i : o.to_pgame.left_moves) :
  ↑(to_left_moves_to_pgame.symm i) < o :=
(to_left_moves_to_pgame.symm i).prop

theorem to_pgame_move_left_heq {o : ordinal} :
  o.to_pgame.move_left == λ x : o.out.α, (typein (<) x).to_pgame :=
by { rw to_pgame, refl }

@[simp] theorem to_pgame_move_left' {o : ordinal} (i) :
  o.to_pgame.move_left i = (to_left_moves_to_pgame.symm i).val.to_pgame :=
(congr_heq to_pgame_move_left_heq.symm (cast_heq _ i)).symm

theorem to_pgame_move_left {o : ordinal} (i) :
  o.to_pgame.move_left (to_left_moves_to_pgame i) = i.val.to_pgame :=
by simp

theorem to_pgame_lf {a b : ordinal} (h : a < b) : a.to_pgame ⧏ b.to_pgame :=
by { convert move_left_lf (to_left_moves_to_pgame ⟨a, h⟩), rw to_pgame_move_left }

theorem to_pgame_le {a b : ordinal} (h : a ≤ b) : a.to_pgame ≤ b.to_pgame :=
begin
  refine le_iff_forall_lf.2 ⟨λ i, _, is_empty_elim⟩,
  rw to_pgame_move_left',
  exact to_pgame_lf ((to_left_moves_to_pgame_symm_lt i).trans_le h)
end

theorem to_pgame_lt {a b : ordinal} (h : a < b) : a.to_pgame < b.to_pgame :=
lt_of_le_of_lf (to_pgame_le h.le) (to_pgame_lf h)

@[simp] theorem to_pgame_lf_iff {a b : ordinal} : a.to_pgame ⧏ b.to_pgame ↔ a < b :=
⟨by { contrapose, rw [not_lt, not_lf], exact to_pgame_le }, to_pgame_lf⟩

@[simp] theorem to_pgame_le_iff {a b : ordinal} : a.to_pgame ≤ b.to_pgame ↔ a ≤ b :=
⟨by { contrapose, rw [not_le, pgame.not_le], exact to_pgame_lf }, to_pgame_le⟩

@[simp] theorem to_pgame_lt_iff {a b : ordinal} : a.to_pgame < b.to_pgame ↔ a < b :=
⟨by { contrapose, rw not_lt, exact λ h, not_lt_of_le (to_pgame_le h) }, to_pgame_lt⟩

@[simp] theorem to_pgame_equiv_iff {a b : ordinal} : a.to_pgame ≈ b.to_pgame ↔ a = b :=
by rw [pgame.equiv, le_antisymm_iff, to_pgame_le_iff, to_pgame_le_iff]

theorem to_pgame_injective : function.injective ordinal.to_pgame :=
λ a b h, to_pgame_equiv_iff.1 $ equiv_of_eq h

@[simp] theorem to_pgame_eq_iff {a b : ordinal} : a.to_pgame = b.to_pgame ↔ a = b :=
to_pgame_injective.eq_iff

/-- The order embedding version of `to_pgame`. -/
@[simps] noncomputable def to_pgame_embedding : ordinal.{u} ↪o pgame.{u} :=
{ to_fun := ordinal.to_pgame,
  inj' := to_pgame_injective,
  map_rel_iff' := @to_pgame_le_iff }

end ordinal


<|start_filename|>src/category_theory/elementwise.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import tactic.elementwise

/-!
# Use the `elementwise` attribute to create applied versions of lemmas.

Usually we would use `@[elementwise]` at the point of definition,
however some early parts of the category theory library are imported by `tactic.elementwise`,
so we need to add the attribute after the fact.
-/

/-! We now add some `elementwise` attributes to lemmas that were proved earlier. -/
open category_theory

-- This list is incomplete, and it would probably be useful to add more.
attribute [elementwise] iso.hom_inv_id iso.inv_hom_id is_iso.hom_inv_id is_iso.inv_hom_id


<|start_filename|>src/data/fin/tuple/nat_antidiagonal.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.big_operators.fin
import data.finset.nat_antidiagonal
import data.fin.vec_notation
import logic.equiv.fin

/-!
# Collections of tuples of naturals with the same sum

This file generalizes `list.nat.antidiagonal n`, `multiset.nat.antidiagonal n`, and
`finset.nat.antidiagonal n` from the pair of elements `x : ℕ × ℕ` such that `n = x.1 + x.2`, to
the sequence of elements `x : fin k → ℕ` such that `n = ∑ i, x i`.

## Main definitions

* `list.nat.antidiagonal_tuple`
* `multiset.nat.antidiagonal_tuple`
* `finset.nat.antidiagonal_tuple`

## Main results

* `antidiagonal_tuple 2 n` is analogous to `antidiagonal n`:

  * `list.nat.antidiagonal_tuple_two`
  * `multiset.nat.antidiagonal_tuple_two`
  * `finset.nat.antidiagonal_tuple_two`

## Implementation notes

While we could implement this by filtering `(fintype.pi_finset $ λ _, range (n + 1))` or similar,
this implementation would be much slower.

In the future, we could consider generalizing `finset.nat.antidiagonal_tuple` further to
support finitely-supported functions, as is done with `cut` in
`archive/100-theorems-list/45_partition.lean`.
-/

open_locale big_operators

/-! ### Lists -/

namespace list.nat

/-- `list.antidiagonal_tuple k n` is a list of all `k`-tuples which sum to `n`.

This list contains no duplicates (`list.nat.nodup_antidiagonal_tuple`), and is sorted
lexicographically (`list.nat.antidiagonal_tuple_pairwise_pi_lex`), starting with `![0, ..., n]`
and ending with `![n, ..., 0]`.

```
#eval antidiagonal_tuple 3 2
-- [![0, 0, 2], ![0, 1, 1], ![0, 2, 0], ![1, 0, 1], ![1, 1, 0], ![2, 0, 0]]
```
-/
def antidiagonal_tuple : Π k, ℕ → list (fin k → ℕ)
| 0 0 := [![]]
| 0 (n + 1) := []
| (k + 1) n := (list.nat.antidiagonal n).bind $ λ ni,
  (antidiagonal_tuple k ni.2).map $ λ x, fin.cons (ni.1) x

@[simp] lemma antidiagonal_tuple_zero_zero : antidiagonal_tuple 0 0 = [![]] := rfl
@[simp] lemma antidiagonal_tuple_zero_succ (n : ℕ) : antidiagonal_tuple 0 n.succ = [] := rfl

lemma mem_antidiagonal_tuple {n : ℕ} {k : ℕ} {x : fin k → ℕ} :
  x ∈ antidiagonal_tuple k n ↔ ∑ i, x i = n :=
begin
  induction k with k ih generalizing n,
  { cases n,
    { simp },
    { simp [eq_comm] }, },
  { refine fin.cons_induction (λ x₀ x, _) x,
    simp_rw [fin.sum_cons, antidiagonal_tuple, list.mem_bind, list.mem_map,
      list.nat.mem_antidiagonal, fin.cons_eq_cons, exists_eq_right_right, ih, prod.exists],
    split,
    { rintros ⟨a, b, rfl, rfl, rfl⟩, refl },
    { rintro rfl, exact ⟨_, _, rfl, rfl, rfl⟩, } },
end

/-- The antidiagonal of `n` does not contain duplicate entries. -/
lemma nodup_antidiagonal_tuple (k n : ℕ) : list.nodup (antidiagonal_tuple k n) :=
begin
  induction k with k ih generalizing n,
  { cases n,
    { simp },
    { simp [eq_comm] }, },
  simp_rw [antidiagonal_tuple, list.nodup_bind],
  split,
  { intros i hi,
    exact (ih i.snd).map (fin.cons_right_injective (i.fst : (λ _, ℕ) 0)), },
  induction n,
  { exact list.pairwise_singleton _ _ },
  { rw list.nat.antidiagonal_succ,
    refine list.pairwise.cons (λ a ha x hx₁ hx₂, _) (n_ih.map _ (λ a b h x hx₁ hx₂, _)),
    { rw list.mem_map at hx₁ hx₂ ha,
      obtain ⟨⟨a, -, rfl⟩, ⟨x₁, -, rfl⟩, ⟨x₂, -, h⟩⟩ := ⟨ha, hx₁, hx₂⟩,
      rw fin.cons_eq_cons at h,
      injection h.1, },
    { rw list.mem_map at hx₁ hx₂,
      obtain ⟨⟨x₁, hx₁, rfl⟩, ⟨x₂, hx₂, h₁₂⟩⟩ := ⟨hx₁, hx₂⟩,
      dsimp at h₁₂,
      rw [fin.cons_eq_cons, nat.succ_inj'] at h₁₂,
      obtain ⟨h₁₂, rfl⟩ := h₁₂,
      rw h₁₂ at h,
      exact h (list.mem_map_of_mem _ hx₁) (list.mem_map_of_mem _ hx₂) }, },
end

lemma antidiagonal_tuple_zero_right : ∀ k, antidiagonal_tuple k 0 = [0]
| 0 := congr_arg (λ x, [x]) $ subsingleton.elim _ _
| (k + 1) := begin
  rw [antidiagonal_tuple, antidiagonal_zero, list.bind_singleton, antidiagonal_tuple_zero_right k,
    list.map_singleton],
  exact congr_arg (λ x, [x]) matrix.cons_zero_zero
end

@[simp] lemma antidiagonal_tuple_one (n : ℕ) : antidiagonal_tuple 1 n = [![n]] :=
begin
  simp_rw [antidiagonal_tuple, antidiagonal, list.range_succ, list.map_append, list.map_singleton,
    tsub_self, list.bind_append, list.bind_singleton, antidiagonal_tuple_zero_zero,
    list.map_singleton, list.map_bind],
  conv_rhs { rw ← list.nil_append [![n]]},
  congr' 1,
  simp_rw [list.bind_eq_nil, list.mem_range, list.map_eq_nil],
  intros x hx,
  obtain ⟨m, rfl⟩ := nat.exists_eq_add_of_lt hx,
  rw [add_assoc, add_tsub_cancel_left, antidiagonal_tuple_zero_succ],
end

lemma antidiagonal_tuple_two (n : ℕ) :
  antidiagonal_tuple 2 n = (antidiagonal n).map (λ i, ![i.1, i.2]) :=
begin
  rw antidiagonal_tuple,
  simp_rw [antidiagonal_tuple_one, list.map_singleton],
  rw [list.map_eq_bind],
  refl,
end

lemma antidiagonal_tuple_pairwise_pi_lex : ∀ k n,
  (antidiagonal_tuple k n).pairwise (pi.lex (<) (λ _, (<)))
| 0 0 := list.pairwise_singleton _ _
| 0 (n + 1) := list.pairwise.nil
| (k + 1) n := begin
  simp_rw [antidiagonal_tuple, list.pairwise_bind, list.pairwise_map, list.mem_map,
    forall_exists_index, and_imp, forall_apply_eq_imp_iff₂],
  simp only [mem_antidiagonal, prod.forall, and_imp, forall_apply_eq_imp_iff₂],
  simp only [fin.pi_lex_lt_cons_cons, eq_self_iff_true, true_and, lt_self_iff_false, false_or],
  refine ⟨λ _ _ _, antidiagonal_tuple_pairwise_pi_lex k _, _⟩,
  induction n,
  { rw [antidiagonal_zero],
    exact list.pairwise_singleton _ _ },
  { rw [antidiagonal_succ, list.pairwise_cons, list.pairwise_map],
    refine ⟨λ p hp x hx y hy, _, _⟩,
    { rw [list.mem_map, prod.exists] at hp,
      obtain ⟨a, b, hab, (rfl : (nat.succ a, b) = p)⟩ := hp,
      exact or.inl (nat.zero_lt_succ _), },
    dsimp,
    simp_rw [nat.succ_inj', nat.succ_lt_succ_iff],
    exact n_ih },
end

end list.nat

/-! ### Multisets -/
namespace multiset.nat

/-- `multiset.antidiagonal_tuple k n` is a multiset of `k`-tuples summing to `n` -/
def antidiagonal_tuple (k n : ℕ) : multiset (fin k → ℕ) :=
list.nat.antidiagonal_tuple k n

@[simp] lemma antidiagonal_tuple_zero_zero : antidiagonal_tuple 0 0 = { ![]} := rfl
@[simp] lemma antidiagonal_tuple_zero_succ (n : ℕ) : antidiagonal_tuple 0 n.succ = 0 := rfl

lemma mem_antidiagonal_tuple {n : ℕ} {k : ℕ} {x : fin k → ℕ} :
  x ∈ antidiagonal_tuple k n ↔ ∑ i, x i = n :=
list.nat.mem_antidiagonal_tuple

lemma nodup_antidiagonal_tuple (k n : ℕ) : (antidiagonal_tuple k n).nodup :=
list.nat.nodup_antidiagonal_tuple _ _

lemma antidiagonal_tuple_zero_right (k : ℕ) : antidiagonal_tuple k 0 = {0} :=
congr_arg _ (list.nat.antidiagonal_tuple_zero_right k)

@[simp] lemma antidiagonal_tuple_one (n : ℕ) : antidiagonal_tuple 1 n = { ![n]} :=
congr_arg _ (list.nat.antidiagonal_tuple_one n)

lemma antidiagonal_tuple_two (n : ℕ) :
  antidiagonal_tuple 2 n = (antidiagonal n).map (λ i, ![i.1, i.2]) :=
congr_arg _ (list.nat.antidiagonal_tuple_two n)

end multiset.nat

/-! ### Finsets -/
namespace finset.nat

/-- `finset.antidiagonal_tuple k n` is a finset of `k`-tuples summing to `n` -/
def antidiagonal_tuple (k n : ℕ) : finset (fin k → ℕ) :=
⟨multiset.nat.antidiagonal_tuple k n, multiset.nat.nodup_antidiagonal_tuple k n⟩

@[simp] lemma antidiagonal_tuple_zero_zero : antidiagonal_tuple 0 0 = { ![]} := rfl
@[simp] lemma antidiagonal_tuple_zero_succ (n : ℕ) : antidiagonal_tuple 0 n.succ = ∅ := rfl

lemma mem_antidiagonal_tuple {n : ℕ} {k : ℕ} {x : fin k → ℕ} :
  x ∈ antidiagonal_tuple k n ↔ ∑ i, x i = n :=
list.nat.mem_antidiagonal_tuple

lemma antidiagonal_tuple_zero_right (k : ℕ) : antidiagonal_tuple k 0 = {0} :=
finset.eq_of_veq (multiset.nat.antidiagonal_tuple_zero_right k)

@[simp] lemma antidiagonal_tuple_one (n : ℕ) : antidiagonal_tuple 1 n = { ![n]} :=
finset.eq_of_veq (multiset.nat.antidiagonal_tuple_one n)

lemma antidiagonal_tuple_two (n : ℕ) :
  antidiagonal_tuple 2 n = (antidiagonal n).map (pi_fin_two_equiv (λ _, ℕ)).symm.to_embedding :=
finset.eq_of_veq (multiset.nat.antidiagonal_tuple_two n)

section equiv_prod

/-- The disjoint union of antidiagonal tuples `Σ n, antidiagonal_tuple k n` is equivalent to the
`k`-tuple `fin k → ℕ`. This is such an equivalence, obtained by mapping `(n, x)` to `x`.

This is the tuple version of `finset.nat.sigma_antidiagonal_equiv_prod`. -/
@[simps] def sigma_antidiagonal_tuple_equiv_tuple (k : ℕ) :
  (Σ n, antidiagonal_tuple k n) ≃ (fin k → ℕ) :=
{ to_fun := λ x, x.2,
  inv_fun := λ x, ⟨∑ i, x i, x, mem_antidiagonal_tuple.mpr rfl⟩,
  left_inv := λ ⟨n, t, h⟩, sigma.subtype_ext (mem_antidiagonal_tuple.mp h) rfl,
  right_inv := λ x, rfl }

end equiv_prod

end finset.nat


<|start_filename|>src/set_theory/ordinal/cantor_normal_form.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import set_theory.ordinal.arithmetic

/-!
# Cantor Normal Form

The Cantor normal form of an ordinal is generally defined as its base `ω` expansion, with its
non-zero exponents in decreasing order. Here, we more generally define a base `b` expansion
`ordinal.CNF` in this manner, for any `b ≥ 2`.

# Todo

- Add API for the coefficients of the Cantor normal form.
- Prove the basic results relating the CNF to the arithmetic operations on ordinals.
-/

noncomputable theory

universe u

open order

namespace ordinal

/-- Proving properties of ordinals by induction over their Cantor normal form. -/
@[elab_as_eliminator] noncomputable def CNF_rec {b : ordinal} (b0 : b ≠ 0)
  {C : ordinal → Sort*} (H0 : C 0) (H : ∀ o, o ≠ 0 → C (o % b ^ log b o) → C o) : ∀ o, C o
| o :=
  if o0 : o = 0 then by rwa o0 else
  have _, from mod_opow_log_lt_self b0 o0,
  H o o0 (CNF_rec (o % b ^ log b o))
using_well_founded {dec_tac := `[assumption]}

@[simp] theorem CNF_rec_zero {b} (b0) {C H0 H} : @CNF_rec b b0 C H0 H 0 = H0 :=
by rw [CNF_rec, dif_pos rfl]; refl

@[simp] theorem CNF_rec_ne_zero {b} (b0) {C H0 H o} (o0) :
  @CNF_rec b b0 C H0 H o = H o o0 (@CNF_rec b b0 C H0 H _) :=
by rw [CNF_rec, dif_neg o0]

/-- The Cantor normal form of an ordinal `o` is the list of coefficients and exponents in the
    base-`b` expansion of `o`.

    `CNF b (b ^ u₁ * v₁ + b ^ u₂ * v₂) = [(u₁, v₁), (u₂, v₂)]` -/
def CNF (b o : ordinal) : list (ordinal × ordinal) :=
if b0 : b = 0 then [] else
CNF_rec b0 [] (λ o o0 IH, (log b o, o / b ^ log b o) :: IH) o

@[simp] theorem zero_CNF (o) : CNF 0 o = [] :=
dif_pos rfl

@[simp] theorem CNF_zero (b) : CNF b 0 = [] :=
if b0 : b = 0 then dif_pos b0 else (dif_neg b0).trans $ CNF_rec_zero _

theorem CNF_ne_zero {b o : ordinal} (b0 : b ≠ 0) (o0 : o ≠ 0) :
  CNF b o = (log b o, o / b ^ log b o) :: CNF b (o % b ^ log b o) :=
by unfold CNF; rw [dif_neg b0, dif_neg b0, CNF_rec_ne_zero b0 o0]

@[simp] theorem one_CNF {o : ordinal} (o0 : o ≠ 0) : CNF 1 o = [(0, o)] :=
by rw [CNF_ne_zero ordinal.one_ne_zero o0, log_of_not_one_lt_left (irrefl _), opow_zero, mod_one,
       CNF_zero, div_one]

theorem CNF_foldr {b : ordinal} (b0 : b ≠ 0) (o) :
  (CNF b o).foldr (λ p r, b ^ p.1 * p.2 + r) 0 = o :=
CNF_rec b0 (by rw CNF_zero; refl)
  (λ o o0 IH, by rw [CNF_ne_zero b0 o0, list.foldr_cons, IH, div_add_mod]) o

/-- This theorem exists to factor out commonalities between the proofs of `ordinal.CNF_pairwise` and
`ordinal.CNF_fst_le_log`. -/
private theorem CNF_pairwise_aux (b o : ordinal.{u}) :
  (∀ p : ordinal × ordinal, p ∈ CNF b o → p.1 ≤ log b o) ∧ (CNF b o).pairwise (λ p q, q.1 < p.1) :=
begin
  by_cases b0 : b = 0,
  { simp only [b0, zero_CNF, list.pairwise.nil, and_true], exact λ _, false.elim },
  cases lt_or_eq_of_le (one_le_iff_ne_zero.2 b0) with b1 b1,
  { refine CNF_rec b0 _ _ o,
    { simp only [CNF_zero, list.pairwise.nil, and_true], exact λ _, false.elim },
    intros o o0 IH, cases IH with IH₁ IH₂,
    simp only [CNF_ne_zero b0 o0, list.forall_mem_cons, list.pairwise_cons, IH₂, and_true],
    refine ⟨⟨le_rfl, λ p m, _⟩, λ p m, _⟩,
    { exact (IH₁ p m).trans (log_mono_right _ $ le_of_lt $ mod_opow_log_lt_self b0 o0) },
    { refine (IH₁ p m).trans_lt ((lt_opow_iff_log_lt b1 _).1 _),
      { rw ordinal.pos_iff_ne_zero, intro e,
        rw e at m, simpa only [CNF_zero] using m },
      { exact mod_lt _ (opow_ne_zero _ b0) } } },
  { by_cases o0 : o = 0,
    { simp only [o0, CNF_zero, list.pairwise.nil, and_true], exact λ _, false.elim },
    rw [← b1, one_CNF o0],
    simp only [list.mem_singleton, log_one_left, forall_eq, le_refl, true_and,
      list.pairwise_singleton] }
end

theorem CNF_pairwise (b o : ordinal.{u}) :
  (CNF b o).pairwise (λ p q : ordinal × ordinal, q.1 < p.1) :=
(CNF_pairwise_aux _ _).2

theorem CNF_fst_le_log {b o : ordinal.{u}} :
  ∀ {p : ordinal × ordinal}, p ∈ CNF b o → p.1 ≤ log b o :=
(CNF_pairwise_aux _ _).1

theorem CNF_fst_le {b o : ordinal.{u}} {p : ordinal × ordinal} (hp : p ∈ CNF b o) : p.1 ≤ o :=
(CNF_fst_le_log hp).trans (log_le_self _ _)

/-- This theorem exists to factor out commonalities between the proofs of `ordinal.CNF_snd_lt` and
`ordinal.CNF_lt_snd`. -/
private theorem CNF_snd_lt_aux {b o : ordinal.{u}} (b1 : 1 < b) :
  ∀ {p : ordinal × ordinal}, p ∈ CNF b o → p.2 < b ∧ 0 < p.2 :=
begin
  have b0 := (zero_lt_one.trans b1).ne',
  refine CNF_rec b0 (λ _, by { rw CNF_zero, exact false.elim }) (λ o o0 IH, _) o,
  simp only [CNF_ne_zero b0 o0, list.mem_cons_iff, forall_eq_or_imp, iff_true_intro @IH, and_true],
  nth_rewrite 1 ←@succ_le_iff,
  rw [div_lt (opow_ne_zero _ b0), ←opow_succ, le_div (opow_ne_zero _ b0), succ_zero, mul_one],
  refine ⟨lt_opow_succ_log_self b1 _, opow_log_le_self _ _⟩,
  rwa ordinal.pos_iff_ne_zero
end

theorem CNF_snd_lt {b o : ordinal.{u}} (b1 : 1 < b) {p : ordinal × ordinal} (hp : p ∈ CNF b o) :
  p.2 < b :=
(CNF_snd_lt_aux b1 hp).1

theorem CNF_lt_snd {b o : ordinal.{u}} (b1 : 1 < b) {p : ordinal × ordinal} (hp : p ∈ CNF b o) :
  0 < p.2 :=
(CNF_snd_lt_aux b1 hp).2

theorem CNF_sorted (b o : ordinal) : ((CNF b o).map prod.fst).sorted (>) :=
by { rw [list.sorted, list.pairwise_map], exact CNF_pairwise b o }

end ordinal


<|start_filename|>src/topology/algebra/order/liminf_limsup.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import order.liminf_limsup
import topology.algebra.order.basic

/-!
# Lemmas about liminf and limsup in an order topology.
-/

open filter
open_locale topological_space classical

universes u v
variables {α : Type u} {β : Type v}

section liminf_limsup

section order_closed_topology
variables [semilattice_sup α] [topological_space α] [order_topology α]

lemma is_bounded_le_nhds (a : α) : (𝓝 a).is_bounded (≤) :=
(is_top_or_exists_gt a).elim (λ h, ⟨a, eventually_of_forall h⟩) (λ ⟨b, hb⟩, ⟨b, ge_mem_nhds hb⟩)

lemma filter.tendsto.is_bounded_under_le {f : filter β} {u : β → α} {a : α}
  (h : tendsto u f (𝓝 a)) : f.is_bounded_under (≤) u :=
(is_bounded_le_nhds a).mono h

lemma filter.tendsto.bdd_above_range_of_cofinite {u : β → α} {a : α}
  (h : tendsto u cofinite (𝓝 a)) : bdd_above (set.range u) :=
h.is_bounded_under_le.bdd_above_range_of_cofinite

lemma filter.tendsto.bdd_above_range {u : ℕ → α} {a : α}
  (h : tendsto u at_top (𝓝 a)) : bdd_above (set.range u) :=
h.is_bounded_under_le.bdd_above_range

lemma is_cobounded_ge_nhds (a : α) : (𝓝 a).is_cobounded (≥) :=
(is_bounded_le_nhds a).is_cobounded_flip

lemma filter.tendsto.is_cobounded_under_ge {f : filter β} {u : β → α} {a : α}
  [ne_bot f] (h : tendsto u f (𝓝 a)) : f.is_cobounded_under (≥) u :=
h.is_bounded_under_le.is_cobounded_flip

end order_closed_topology

section order_closed_topology
variables [semilattice_inf α] [topological_space α] [order_topology α]

lemma is_bounded_ge_nhds (a : α) : (𝓝 a).is_bounded (≥) := @is_bounded_le_nhds αᵒᵈ _ _ _ a

lemma filter.tendsto.is_bounded_under_ge {f : filter β} {u : β → α} {a : α}
  (h : tendsto u f (𝓝 a)) : f.is_bounded_under (≥) u :=
(is_bounded_ge_nhds a).mono h

lemma filter.tendsto.bdd_below_range_of_cofinite {u : β → α} {a : α}
  (h : tendsto u cofinite (𝓝 a)) : bdd_below (set.range u) :=
h.is_bounded_under_ge.bdd_below_range_of_cofinite

lemma filter.tendsto.bdd_below_range {u : ℕ → α} {a : α}
  (h : tendsto u at_top (𝓝 a)) : bdd_below (set.range u) :=
h.is_bounded_under_ge.bdd_below_range

lemma is_cobounded_le_nhds (a : α) : (𝓝 a).is_cobounded (≤) :=
(is_bounded_ge_nhds a).is_cobounded_flip

lemma filter.tendsto.is_cobounded_under_le {f : filter β} {u : β → α} {a : α}
  [ne_bot f] (h : tendsto u f (𝓝 a)) : f.is_cobounded_under (≤) u :=
h.is_bounded_under_ge.is_cobounded_flip

end order_closed_topology

section conditionally_complete_linear_order
variables [conditionally_complete_linear_order α]

theorem lt_mem_sets_of_Limsup_lt {f : filter α} {b} (h : f.is_bounded (≤)) (l : f.Limsup < b) :
  ∀ᶠ a in f, a < b :=
let ⟨c, (h : ∀ᶠ a in f, a ≤ c), hcb⟩ := exists_lt_of_cInf_lt h l in
mem_of_superset h $ assume a hac, lt_of_le_of_lt hac hcb

theorem gt_mem_sets_of_Liminf_gt : ∀ {f : filter α} {b}, f.is_bounded (≥) → b < f.Liminf →
  ∀ᶠ a in f, b < a :=
@lt_mem_sets_of_Limsup_lt αᵒᵈ _

variables [topological_space α] [order_topology α]

/-- If the liminf and the limsup of a filter coincide, then this filter converges to
their common value, at least if the filter is eventually bounded above and below. -/
theorem le_nhds_of_Limsup_eq_Liminf {f : filter α} {a : α}
  (hl : f.is_bounded (≤)) (hg : f.is_bounded (≥)) (hs : f.Limsup = a) (hi : f.Liminf = a) :
  f ≤ 𝓝 a :=
tendsto_order.2 $ and.intro
  (assume b hb, gt_mem_sets_of_Liminf_gt hg $ hi.symm ▸ hb)
  (assume b hb, lt_mem_sets_of_Limsup_lt hl $ hs.symm ▸ hb)

theorem Limsup_nhds (a : α) : Limsup (𝓝 a) = a :=
cInf_eq_of_forall_ge_of_forall_gt_exists_lt (is_bounded_le_nhds a)
  (assume a' (h : {n : α | n ≤ a'} ∈ 𝓝 a), show a ≤ a', from @mem_of_mem_nhds α _ a _ h)
  (assume b (hba : a < b), show ∃c (h : {n : α | n ≤ c} ∈ 𝓝 a), c < b, from
    match dense_or_discrete a b with
    | or.inl ⟨c, hac, hcb⟩ := ⟨c, ge_mem_nhds hac, hcb⟩
    | or.inr ⟨_, h⟩        := ⟨a, (𝓝 a).sets_of_superset (gt_mem_nhds hba) h, hba⟩
    end)

theorem Liminf_nhds : ∀ (a : α), Liminf (𝓝 a) = a := @Limsup_nhds αᵒᵈ _ _ _

/-- If a filter is converging, its limsup coincides with its limit. -/
theorem Liminf_eq_of_le_nhds {f : filter α} {a : α} [ne_bot f] (h : f ≤ 𝓝 a) : f.Liminf = a :=
have hb_ge : is_bounded (≥) f, from (is_bounded_ge_nhds a).mono h,
have hb_le : is_bounded (≤) f, from (is_bounded_le_nhds a).mono h,
le_antisymm
  (calc f.Liminf ≤ f.Limsup : Liminf_le_Limsup hb_le hb_ge
    ... ≤ (𝓝 a).Limsup :
      Limsup_le_Limsup_of_le h hb_ge.is_cobounded_flip (is_bounded_le_nhds a)
    ... = a : Limsup_nhds a)
  (calc a = (𝓝 a).Liminf : (Liminf_nhds a).symm
    ... ≤ f.Liminf :
      Liminf_le_Liminf_of_le h (is_bounded_ge_nhds a) hb_le.is_cobounded_flip)

/-- If a filter is converging, its liminf coincides with its limit. -/
theorem Limsup_eq_of_le_nhds : ∀ {f : filter α} {a : α} [ne_bot f], f ≤ 𝓝 a → f.Limsup = a :=
@Liminf_eq_of_le_nhds αᵒᵈ _ _ _

/-- If a function has a limit, then its limsup coincides with its limit. -/
theorem filter.tendsto.limsup_eq {f : filter β} {u : β → α} {a : α} [ne_bot f]
  (h : tendsto u f (𝓝 a)) : limsup f u = a :=
Limsup_eq_of_le_nhds h

/-- If a function has a limit, then its liminf coincides with its limit. -/
theorem filter.tendsto.liminf_eq {f : filter β} {u : β → α} {a : α} [ne_bot f]
  (h : tendsto u f (𝓝 a)) : liminf f u = a :=
Liminf_eq_of_le_nhds h

/-- If the liminf and the limsup of a function coincide, then the limit of the function
exists and has the same value -/
theorem tendsto_of_liminf_eq_limsup {f : filter β} {u : β → α} {a : α}
  (hinf : liminf f u = a) (hsup : limsup f u = a)
  (h : f.is_bounded_under (≤) u . is_bounded_default)
  (h' : f.is_bounded_under (≥) u . is_bounded_default) :
  tendsto u f (𝓝 a) :=
le_nhds_of_Limsup_eq_Liminf h h' hsup hinf

/-- If a number `a` is less than or equal to the `liminf` of a function `f` at some filter
and is greater than or equal to the `limsup` of `f`, then `f` tends to `a` along this filter. -/
theorem tendsto_of_le_liminf_of_limsup_le {f : filter β} {u : β → α} {a : α}
  (hinf : a ≤ liminf f u) (hsup : limsup f u ≤ a)
  (h : f.is_bounded_under (≤) u . is_bounded_default)
  (h' : f.is_bounded_under (≥) u . is_bounded_default) :
  tendsto u f (𝓝 a) :=
if hf : f = ⊥ then hf.symm ▸ tendsto_bot
else by haveI : ne_bot f := ⟨hf⟩; exact tendsto_of_liminf_eq_limsup
  (le_antisymm (le_trans (liminf_le_limsup h h') hsup) hinf)
  (le_antisymm hsup (le_trans hinf (liminf_le_limsup h h'))) h h'

/-- Assume that, for any `a < b`, a sequence can not be infinitely many times below `a` and
above `b`. If it is also ultimately bounded above and below, then it has to converge. This even
works if `a` and `b` are restricted to a dense subset.
-/
lemma tendsto_of_no_upcrossings [densely_ordered α]
  {f : filter β} {u : β → α} {s : set α} (hs : dense s)
  (H : ∀ (a ∈ s) (b ∈ s), a < b → ¬((∃ᶠ n in f, u n < a) ∧ (∃ᶠ n in f, b < u n)))
  (h : f.is_bounded_under (≤) u . is_bounded_default)
  (h' : f.is_bounded_under (≥) u . is_bounded_default) :
  ∃ (c : α), tendsto u f (𝓝 c) :=
begin
  by_cases hbot : f = ⊥, { rw hbot, exact ⟨Inf ∅, tendsto_bot⟩ },
  haveI : ne_bot f := ⟨hbot⟩,
  refine ⟨limsup f u, _⟩,
  apply tendsto_of_le_liminf_of_limsup_le _ le_rfl h h',
  by_contra' hlt,
  obtain ⟨a, ⟨⟨la, au⟩, as⟩⟩ : ∃ a, (f.liminf u < a ∧ a < f.limsup u) ∧ a ∈ s :=
    dense_iff_inter_open.1 hs (set.Ioo (f.liminf u) (f.limsup u)) is_open_Ioo
    (set.nonempty_Ioo.2 hlt),
  obtain ⟨b, ⟨⟨ab, bu⟩, bs⟩⟩ : ∃ b, (a < b ∧ b < f.limsup u) ∧ b ∈ s :=
    dense_iff_inter_open.1 hs (set.Ioo a (f.limsup u)) is_open_Ioo
    (set.nonempty_Ioo.2 au),
  have A : ∃ᶠ n in f, u n < a :=
    frequently_lt_of_liminf_lt (is_bounded.is_cobounded_ge h) la,
  have B : ∃ᶠ n in f, b < u n :=
    frequently_lt_of_lt_limsup (is_bounded.is_cobounded_le h') bu,
  exact H a as b bs ab ⟨A, B⟩,
end

end conditionally_complete_linear_order

end liminf_limsup


<|start_filename|>src/measure_theory/group/measure.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import dynamics.ergodic.measure_preserving
import measure_theory.measure.regular
import measure_theory.group.measurable_equiv
import measure_theory.measure.open_pos

/-!
# Measures on Groups

We develop some properties of measures on (topological) groups

* We define properties on measures: measures that are left or right invariant w.r.t. multiplication.
* We define the measure `μ.inv : A ↦ μ(A⁻¹)` and show that it is right invariant iff
  `μ` is left invariant.
* We define a class `is_haar_measure μ`, requiring that the measure `μ` is left-invariant, finite
  on compact sets, and positive on open sets.

We also give analogues of all these notions in the additive world.
-/

noncomputable theory

open_locale ennreal pointwise big_operators
open has_inv set function measure_theory.measure

variables {G : Type*} [measurable_space G]

namespace measure_theory
namespace measure

/-- A measure `μ` on a measurable additive group is left invariant
  if the measure of left translations of a set are equal to the measure of the set itself. -/
class is_add_left_invariant [has_add G] (μ : measure G) : Prop :=
(map_add_left_eq_self : ∀ g : G, map ((+) g) μ = μ)

/-- A measure `μ` on a measurable group is left invariant
  if the measure of left translations of a set are equal to the measure of the set itself. -/
@[to_additive] class is_mul_left_invariant [has_mul G] (μ : measure G) : Prop :=
(map_mul_left_eq_self : ∀ g : G, map ((*) g) μ = μ)

/-- A measure `μ` on a measurable additive group is right invariant
  if the measure of right translations of a set are equal to the measure of the set itself. -/
class is_add_right_invariant [has_add G] (μ : measure G) : Prop :=
(map_add_right_eq_self : ∀ g : G, map (+ g) μ = μ)

/-- A measure `μ` on a measurable group is right invariant
  if the measure of right translations of a set are equal to the measure of the set itself. -/
@[to_additive] class is_mul_right_invariant [has_mul G] (μ : measure G) : Prop :=
(map_mul_right_eq_self : ∀ g : G, map (* g) μ = μ)

end measure
open measure

section mul

variables [has_mul G] {μ : measure G}

@[to_additive]
lemma map_mul_left_eq_self (μ : measure G) [is_mul_left_invariant μ] (g : G) : map ((*) g) μ = μ :=
is_mul_left_invariant.map_mul_left_eq_self g

@[to_additive]
lemma map_mul_right_eq_self (μ : measure G) [is_mul_right_invariant μ] (g : G) : map (* g) μ = μ :=
is_mul_right_invariant.map_mul_right_eq_self g

@[to_additive]
instance [is_mul_left_invariant μ] (c : ℝ≥0∞) : is_mul_left_invariant (c • μ) :=
⟨λ g, by rw [measure.map_smul, map_mul_left_eq_self]⟩

@[to_additive]
instance [is_mul_right_invariant μ] (c : ℝ≥0∞) : is_mul_right_invariant (c • μ) :=
⟨λ g, by rw [measure.map_smul, map_mul_right_eq_self]⟩

section has_measurable_mul

variables [has_measurable_mul G]

@[to_additive]
lemma measure_preserving_mul_left (μ : measure G) [is_mul_left_invariant μ] (g : G) :
  measure_preserving ((*) g) μ μ :=
⟨measurable_const_mul g, map_mul_left_eq_self μ g⟩

@[to_additive]
lemma measure_preserving_mul_right (μ : measure G) [is_mul_right_invariant μ] (g : G) :
  measure_preserving (* g) μ μ :=
⟨measurable_mul_const g, map_mul_right_eq_self μ g⟩

/-- An alternative way to prove that `μ` is left invariant under multiplication. -/
@[to_additive /-" An alternative way to prove that `μ` is left invariant under addition. "-/]
lemma forall_measure_preimage_mul_iff (μ : measure G) :
  (∀ (g : G) (A : set G), measurable_set A → μ ((λ h, g * h) ⁻¹' A) = μ A) ↔
  is_mul_left_invariant μ :=
begin
  transitivity ∀ g, map ((*) g) μ = μ,
  { simp_rw [measure.ext_iff],
    refine forall_congr (λ g, forall_congr $ λ A, forall_congr $ λ hA, _),
    rw [map_apply (measurable_const_mul g) hA] },
  exact ⟨λ h, ⟨h⟩, λ h, h.1⟩
end

/-- An alternative way to prove that `μ` is right invariant under multiplication. -/
@[to_additive /-" An alternative way to prove that `μ` is right invariant under addition. "-/]
lemma forall_measure_preimage_mul_right_iff (μ : measure G) :
  (∀ (g : G) (A : set G), measurable_set A → μ ((λ h, h * g) ⁻¹' A) = μ A) ↔
  is_mul_right_invariant μ :=
begin
  transitivity ∀ g, map (* g) μ = μ,
  { simp_rw [measure.ext_iff],
    refine forall_congr (λ g, forall_congr $ λ A, forall_congr $ λ hA, _),
    rw [map_apply (measurable_mul_const g) hA] },
  exact ⟨λ h, ⟨h⟩, λ h, h.1⟩
end

end has_measurable_mul

end mul

section group

variables [group G]

@[to_additive]
lemma map_div_right_eq_self (μ : measure G) [is_mul_right_invariant μ] (g : G) :
  map (/ g) μ = μ :=
by simp_rw [div_eq_mul_inv, map_mul_right_eq_self μ g⁻¹]


variables [has_measurable_mul G]

/-- We shorten this from `measure_preimage_mul_left`, since left invariant is the preferred option
  for measures in this formalization. -/
@[simp, to_additive "We shorten this from `measure_preimage_add_left`, since left invariant is the
preferred option for measures in this formalization."]
lemma measure_preimage_mul (μ : measure G) [is_mul_left_invariant μ] (g : G) (A : set G) :
  μ ((λ h, g * h) ⁻¹' A) = μ A :=
calc μ ((λ h, g * h) ⁻¹' A) = map (λ h, g * h) μ A :
  ((measurable_equiv.mul_left g).map_apply A).symm
... = μ A : by rw map_mul_left_eq_self μ g

@[simp, to_additive]
lemma measure_preimage_mul_right (μ : measure G) [is_mul_right_invariant μ] (g : G) (A : set G) :
  μ ((λ h, h * g) ⁻¹' A) = μ A :=
calc μ ((λ h, h * g) ⁻¹' A) = map (λ h, h * g) μ A :
  ((measurable_equiv.mul_right g).map_apply A).symm
... = μ A : by rw map_mul_right_eq_self μ g

@[to_additive]
lemma map_mul_left_ae (μ : measure G) [is_mul_left_invariant μ] (x : G) :
  filter.map (λ h, x * h) μ.ae = μ.ae :=
((measurable_equiv.mul_left x).map_ae μ).trans $ congr_arg ae $ map_mul_left_eq_self μ x

@[to_additive]
lemma map_mul_right_ae (μ : measure G) [is_mul_right_invariant μ] (x : G) :
  filter.map (λ h, h * x) μ.ae = μ.ae :=
((measurable_equiv.mul_right x).map_ae μ).trans $ congr_arg ae $ map_mul_right_eq_self μ x

@[to_additive]
lemma map_div_right_ae (μ : measure G) [is_mul_right_invariant μ] (x : G) :
  filter.map (λ t, t / x) μ.ae = μ.ae :=
((measurable_equiv.div_right x).map_ae μ).trans $ congr_arg ae $ map_div_right_eq_self μ x

end group

namespace measure

/-- The measure `A ↦ μ (A⁻¹)`, where `A⁻¹` is the pointwise inverse of `A`. -/
@[to_additive "The measure `A ↦ μ (- A)`, where `- A` is the pointwise negation of `A`."]
protected def inv [has_inv G] (μ : measure G) : measure G :=
measure.map inv μ

/-- A measure is invariant under negation if `- μ = μ`. Equivalently, this means that for all
measurable `A` we have `μ (- A) = μ A`, where `- A` is the pointwise negation of `A`. -/
class is_neg_invariant [has_neg G] (μ : measure G) : Prop :=
(neg_eq_self : μ.neg = μ)

/-- A measure is invariant under inversion if `μ⁻¹ = μ`. Equivalently, this means that for all
measurable `A` we have `μ (A⁻¹) = μ A`, where `A⁻¹` is the pointwise inverse of `A`. -/
@[to_additive] class is_inv_invariant [has_inv G] (μ : measure G) : Prop :=
(inv_eq_self : μ.inv = μ)

section inv

variables [has_inv G]

@[simp, to_additive]
lemma inv_eq_self (μ : measure G) [is_inv_invariant μ] : μ.inv = μ :=
is_inv_invariant.inv_eq_self

@[simp, to_additive]
lemma map_inv_eq_self (μ : measure G) [is_inv_invariant μ] : map has_inv.inv μ = μ :=
is_inv_invariant.inv_eq_self

end inv

section has_involutive_inv

variables [has_involutive_inv G] [has_measurable_inv G]

@[simp, to_additive]
lemma inv_apply (μ : measure G) (s : set G) : μ.inv s = μ s⁻¹ :=
(measurable_equiv.inv G).map_apply s

@[simp, to_additive]
protected lemma inv_inv (μ : measure G) : μ.inv.inv = μ :=
(measurable_equiv.inv G).map_symm_map

@[simp, to_additive]
lemma measure_inv (μ : measure G) [is_inv_invariant μ] (A : set G) : μ A⁻¹ = μ A :=
by rw [← inv_apply, inv_eq_self]

@[to_additive]
lemma measure_preimage_inv (μ : measure G) [is_inv_invariant μ] (A : set G) :
  μ (has_inv.inv ⁻¹' A) = μ A :=
μ.measure_inv A

@[to_additive]
instance (μ : measure G) [sigma_finite μ] : sigma_finite μ.inv :=
(measurable_equiv.inv G).sigma_finite_map ‹_›

end has_involutive_inv

section mul_inv
variables [group G] [has_measurable_mul G] [has_measurable_inv G] {μ : measure G}

@[to_additive]
instance [is_mul_left_invariant μ] : is_mul_right_invariant μ.inv :=
begin
  constructor,
  intro g,
  conv_rhs { rw [← map_mul_left_eq_self μ g⁻¹] },
  simp_rw [measure.inv, map_map (measurable_mul_const g) measurable_inv,
    map_map measurable_inv (measurable_const_mul g⁻¹), function.comp, mul_inv_rev, inv_inv]
end

@[to_additive]
instance [is_mul_right_invariant μ] : is_mul_left_invariant μ.inv :=
begin
  constructor,
  intro g,
  conv_rhs { rw [← map_mul_right_eq_self μ g⁻¹] },
  simp_rw [measure.inv, map_map (measurable_const_mul g) measurable_inv,
    map_map measurable_inv (measurable_mul_const g⁻¹), function.comp, mul_inv_rev, inv_inv]
end

@[to_additive]
lemma map_div_left_eq_self (μ : measure G) [is_inv_invariant μ] [is_mul_left_invariant μ] (g : G) :
  map (λ t, g / t) μ = μ :=
begin
  simp_rw [div_eq_mul_inv],
  conv_rhs { rw [← map_mul_left_eq_self μ g, ← map_inv_eq_self μ] },
  exact (map_map (measurable_const_mul g) measurable_inv).symm
end

@[to_additive]
lemma map_mul_right_inv_eq_self (μ : measure G) [is_inv_invariant μ] [is_mul_left_invariant μ]
  (g : G) : map (λ t, (g * t)⁻¹) μ = μ :=
begin
  conv_rhs { rw [← map_inv_eq_self μ, ← map_mul_left_eq_self μ g] },
  exact (map_map measurable_inv (measurable_const_mul g)).symm
end

@[to_additive]
lemma map_div_left_ae (μ : measure G) [is_mul_left_invariant μ] [is_inv_invariant μ] (x : G) :
  filter.map (λ t, x / t) μ.ae = μ.ae :=
((measurable_equiv.div_left x).map_ae μ).trans $ congr_arg ae $ map_div_left_eq_self μ x

end mul_inv

end measure

section topological_group

variables [topological_space G] [borel_space G] {μ : measure G}
variables [group G] [topological_group G]

@[to_additive]
instance measure.regular.inv [t2_space G] [regular μ] : regular μ.inv :=
regular.map (homeomorph.inv G)

@[to_additive]
lemma regular_inv_iff [t2_space G] : μ.inv.regular ↔ μ.regular :=
begin
  split,
  { introI h, rw ← μ.inv_inv, exact measure.regular.inv },
  { introI h, exact measure.regular.inv }
end

variables [is_mul_left_invariant μ]

/-- If a left-invariant measure gives positive mass to a compact set, then it gives positive mass to
any open set. -/
@[to_additive "If a left-invariant measure gives positive mass to a compact set, then it gives
positive mass to any open set."]
lemma is_open_pos_measure_of_mul_left_invariant_of_compact
  (K : set G) (hK : is_compact K) (h : μ K ≠ 0) :
  is_open_pos_measure μ :=
begin
  refine ⟨λ U hU hne, _⟩,
  contrapose! h,
  rw ← nonpos_iff_eq_zero,
  rw ← hU.interior_eq at hne,
  obtain ⟨t, hKt⟩ : ∃ (t : finset G), K ⊆ ⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U :=
    compact_covered_by_mul_left_translates hK hne,
  calc μ K ≤ μ (⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U) : measure_mono hKt
  ... ≤ ∑ g in t, μ ((λ (h : G), g * h) ⁻¹' U) : measure_bUnion_finset_le _ _
  ... = 0 : by simp [measure_preimage_mul, h]
end

/-- A nonzero left-invariant regular measure gives positive mass to any open set. -/
@[to_additive "A nonzero left-invariant regular measure gives positive mass to any open set."]
lemma is_open_pos_measure_of_mul_left_invariant_of_regular [regular μ] (h₀ : μ ≠ 0) :
  is_open_pos_measure μ :=
let ⟨K, hK, h2K⟩ := regular.exists_compact_not_null.mpr h₀
in is_open_pos_measure_of_mul_left_invariant_of_compact K hK h2K

@[to_additive]
lemma null_iff_of_is_mul_left_invariant [regular μ]
  {s : set G} (hs : is_open s) :
  μ s = 0 ↔ s = ∅ ∨ μ = 0 :=
begin
  by_cases h3μ : μ = 0, { simp [h3μ] },
  { haveI := is_open_pos_measure_of_mul_left_invariant_of_regular h3μ,
    simp only [h3μ, or_false, hs.measure_eq_zero_iff μ] },
end

@[to_additive]
lemma measure_ne_zero_iff_nonempty_of_is_mul_left_invariant [regular μ]
  (hμ : μ ≠ 0) {s : set G} (hs : is_open s) :
  μ s ≠ 0 ↔ s.nonempty :=
by simpa [null_iff_of_is_mul_left_invariant hs, hμ] using ne_empty_iff_nonempty

@[to_additive]
lemma measure_pos_iff_nonempty_of_is_mul_left_invariant [regular μ]
  (h3μ : μ ≠ 0) {s : set G} (hs : is_open s) :
  0 < μ s ↔ s.nonempty :=
pos_iff_ne_zero.trans $ measure_ne_zero_iff_nonempty_of_is_mul_left_invariant h3μ hs

/-- If a left-invariant measure gives finite mass to a nonempty open set, then it gives finite mass
to any compact set. -/
@[to_additive "If a left-invariant measure gives finite mass to a nonempty open set, then it gives
finite mass to any compact set."]
lemma measure_lt_top_of_is_compact_of_is_mul_left_invariant
  (U : set G) (hU : is_open U) (h'U : U.nonempty) (h : μ U ≠ ∞) {K : set G} (hK : is_compact K) :
  μ K < ∞ :=
begin
  rw ← hU.interior_eq at h'U,
  obtain ⟨t, hKt⟩ : ∃ (t : finset G), K ⊆ ⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U :=
    compact_covered_by_mul_left_translates hK h'U,
  calc μ K ≤ μ (⋃ (g : G) (H : g ∈ t), (λ (h : G), g * h) ⁻¹' U) : measure_mono hKt
  ... ≤ ∑ g in t, μ ((λ (h : G), g * h) ⁻¹' U) : measure_bUnion_finset_le _ _
  ... = finset.card t * μ U : by simp only [measure_preimage_mul, finset.sum_const, nsmul_eq_mul]
  ... < ∞ : ennreal.mul_lt_top ennreal.coe_nat_ne_top h
end

/-- If a left-invariant measure gives finite mass to a set with nonempty interior, then
it gives finite mass to any compact set. -/
@[to_additive "If a left-invariant measure gives finite mass to a set with nonempty interior, then
it gives finite mass to any compact set."]
lemma measure_lt_top_of_is_compact_of_is_mul_left_invariant'
  {U : set G} (hU : (interior U).nonempty) (h : μ U ≠ ∞) {K : set G} (hK : is_compact K) :
  μ K < ∞ :=
measure_lt_top_of_is_compact_of_is_mul_left_invariant (interior U) is_open_interior hU
  ((measure_mono (interior_subset)).trans_lt (lt_top_iff_ne_top.2 h)).ne hK

end topological_group

section comm_group

variables [comm_group G]

/-- In an abelian group every left invariant measure is also right-invariant.
  We don't declare the converse as an instance, since that would loop type-class inference, and
  we use `is_mul_left_invariant` as default hypotheses in abelian groups. -/
@[priority 100, to_additive "In an abelian additive group every left invariant measure is also
right-invariant. We don't declare the converse as an instance, since that would loop type-class
inference, and we use `is_add_left_invariant` as default hypotheses in abelian groups."]
instance is_mul_left_invariant.is_mul_right_invariant {μ : measure G} [is_mul_left_invariant μ] :
  is_mul_right_invariant μ :=
⟨λ g, by simp_rw [mul_comm, map_mul_left_eq_self]⟩


end comm_group

section haar

namespace measure

/-- A measure on an additive group is an additive Haar measure if it is left-invariant, and gives
finite mass to compact sets and positive mass to open sets. -/
class is_add_haar_measure {G : Type*} [add_group G] [topological_space G] [measurable_space G]
  (μ : measure G)
  extends is_finite_measure_on_compacts μ, is_add_left_invariant μ, is_open_pos_measure μ : Prop

/-- A measure on a group is a Haar measure if it is left-invariant, and gives finite mass to compact
sets and positive mass to open sets. -/
@[to_additive]
class is_haar_measure {G : Type*} [group G] [topological_space G] [measurable_space G]
  (μ : measure G)
  extends is_finite_measure_on_compacts μ, is_mul_left_invariant μ, is_open_pos_measure μ : Prop

/-- Record that a Haar measure on a locally compact space is locally finite. This is needed as the
fact that a measure which is finite on compacts is locally finite is not registered as an instance,
to avoid an instance loop.

See Note [lower instance priority]. -/

@[priority 100, to_additive "Record that an additive Haar measure on a locally compact space is
locally finite. This is needed as the fact that a measure which is finite on compacts is locally
finite is not registered as an instance, to avoid an instance loop.

See Note [lower instance priority]"]
instance is_locally_finite_measure_of_is_haar_measure {G : Type*}
  [group G] [measurable_space G] [topological_space G] [locally_compact_space G]
  (μ : measure G) [is_haar_measure μ] :
  is_locally_finite_measure μ :=
is_locally_finite_measure_of_is_finite_measure_on_compacts

section

variables [group G] [topological_space G] (μ : measure G) [is_haar_measure μ]

@[simp, to_additive]
lemma haar_singleton [topological_group G] [borel_space G] (g : G) :
  μ {g} = μ {(1 : G)} :=
begin
  convert measure_preimage_mul μ (g⁻¹) _,
  simp only [mul_one, preimage_mul_left_singleton, inv_inv],
end

@[to_additive measure_theory.measure.is_add_haar_measure.smul]
lemma is_haar_measure.smul {c : ℝ≥0∞} (cpos : c ≠ 0) (ctop : c ≠ ∞) :
  is_haar_measure (c • μ) :=
{ lt_top_of_is_compact := λ K hK, ennreal.mul_lt_top ctop hK.measure_lt_top.ne,
  to_is_open_pos_measure := is_open_pos_measure_smul μ cpos }

/-- If a left-invariant measure gives positive mass to some compact set with nonempty interior, then
it is a Haar measure. -/
@[to_additive "If a left-invariant measure gives positive mass to some compact set with nonempty
interior, then it is an additive Haar measure."]
lemma is_haar_measure_of_is_compact_nonempty_interior [topological_group G] [borel_space G]
  (μ : measure G) [is_mul_left_invariant μ]
  (K : set G) (hK : is_compact K) (h'K : (interior K).nonempty) (h : μ K ≠ 0) (h' : μ K ≠ ∞) :
  is_haar_measure μ :=
{ lt_top_of_is_compact :=
    λ L hL, measure_lt_top_of_is_compact_of_is_mul_left_invariant' h'K h' hL,
  to_is_open_pos_measure := is_open_pos_measure_of_mul_left_invariant_of_compact K hK h }

/-- The image of a Haar measure under a group homomorphism which is also a homeomorphism is again
a Haar measure. -/
@[to_additive "The image of an additive Haar measure under an additive group homomorphism which is
also a homeomorphism is again an additive Haar measure."]
lemma is_haar_measure_map [borel_space G] [topological_group G] {H : Type*} [group H]
  [topological_space H] [measurable_space H] [borel_space H] [t2_space H] [topological_group H]
  (f : G ≃* H) (hf : continuous f) (hfsymm : continuous f.symm) :
  is_haar_measure (measure.map f μ) :=
{ to_is_mul_left_invariant := begin
    constructor,
    assume h,
    rw map_map (continuous_mul_left h).measurable hf.measurable,
    conv_rhs { rw ← map_mul_left_eq_self μ (f.symm h) },
    rw map_map hf.measurable (continuous_mul_left _).measurable,
    congr' 2,
    ext y,
    simp only [mul_equiv.apply_symm_apply, comp_app, mul_equiv.map_mul],
  end,
  lt_top_of_is_compact := begin
    assume K hK,
    rw map_apply hf.measurable hK.measurable_set,
    have : f.symm '' K = f ⁻¹' K := equiv.image_eq_preimage _ _,
    rw ← this,
    exact is_compact.measure_lt_top (hK.image hfsymm)
  end,
  to_is_open_pos_measure := hf.is_open_pos_measure_map f.surjective }

/-- A Haar measure on a σ-compact space is σ-finite.

See Note [lower instance priority] -/
@[priority 100, to_additive "A Haar measure on a σ-compact space is σ-finite.

See Note [lower instance priority]"]
instance is_haar_measure.sigma_finite [sigma_compact_space G] : sigma_finite μ :=
⟨⟨{ set := compact_covering G,
  set_mem := λ n, mem_univ _,
  finite := λ n, is_compact.measure_lt_top $ is_compact_compact_covering G n,
  spanning := Union_compact_covering G }⟩⟩

open_locale topological_space
open filter

/-- If the neutral element of a group is not isolated, then a Haar measure on this group has
no atoms.

The additive version of this instance applies in particular to show that an additive Haar measure on
a nontrivial finite-dimensional real vector space has no atom. -/
@[priority 100, to_additive "If the zero element of an additive group is not isolated, then an
additive Haar measure on this group has no atoms.

This applies in particular to show that an additive Haar measure on a nontrivial finite-dimensional
real vector space has no atom."]
instance is_haar_measure.has_no_atoms [topological_group G] [borel_space G]
  [t1_space G] [locally_compact_space G] [(𝓝[≠] (1 : G)).ne_bot]
  (μ : measure G) [μ.is_haar_measure] :
  has_no_atoms μ :=
begin
  suffices H : μ {(1 : G)} ≤ 0, by { constructor, simp [le_bot_iff.1 H] },
  obtain ⟨K, K_compact, K_int⟩ : ∃ (K : set G), is_compact K ∧ (1 : G) ∈ interior K,
  { rcases exists_compact_subset is_open_univ (mem_univ (1 : G)) with ⟨K, hK⟩,
    exact ⟨K, hK.1, hK.2.1⟩ },
  have K_inf : set.infinite K := infinite_of_mem_nhds (1 : G) (mem_interior_iff_mem_nhds.1 K_int),
  have μKlt : μ K ≠ ∞ := K_compact.measure_lt_top.ne,
  have I : ∀ (n : ℕ), μ {(1 : G)} ≤ μ K / n,
  { assume n,
    obtain ⟨t, tK, tn⟩ : ∃ (t : finset G), ↑t ⊆ K ∧ t.card = n := K_inf.exists_subset_card_eq n,
    have A : μ t ≤ μ K := measure_mono tK,
    have B : μ t = n * μ {(1 : G)},
    { rw ← bUnion_of_singleton ↑t,
      change μ (⋃ (x ∈ t), {x}) = n * μ {1},
      rw @measure_bUnion_finset G G _ μ t (λ i, {i}),
      { simp only [tn, finset.sum_const, nsmul_eq_mul, haar_singleton] },
      { assume x hx y hy xy,
        simp only [on_fun, xy.symm, mem_singleton_iff, not_false_iff, disjoint_singleton_right] },
      { assume b hb, exact measurable_set_singleton b } },
    rw B at A,
    rwa [ennreal.le_div_iff_mul_le _ (or.inr μKlt), mul_comm],
    right,
    apply (measure_pos_of_nonempty_interior μ ⟨_, K_int⟩).ne' },
  have J : tendsto (λ (n : ℕ),  μ K / n) at_top (𝓝 (μ K / ∞)) :=
    ennreal.tendsto.const_div ennreal.tendsto_nat_nhds_top (or.inr μKlt),
  simp only [ennreal.div_top] at J,
  exact ge_of_tendsto' J I,
end

/- The above instance applies in particular to show that an additive Haar measure on a nontrivial
finite-dimensional real vector space has no atom. -/
example {E : Type*} [normed_group E] [normed_space ℝ E] [nontrivial E] [finite_dimensional ℝ E]
  [measurable_space E] [borel_space E] (μ : measure E) [is_add_haar_measure μ] :
  has_no_atoms μ := by apply_instance

end

end measure
end haar

end measure_theory


<|start_filename|>src/set_theory/cardinal/finite.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import set_theory.cardinal.basic

/-!
# Finite Cardinality Functions

## Main Definitions

* `nat.card α` is the cardinality of `α` as a natural number.
  If `α` is infinite, `nat.card α = 0`.
* `enat.card α` is the cardinality of `α` as an extended natural number.
  If `α` is infinite, `enat.card α = ⊤`.

-/

open cardinal
noncomputable theory

variables {α β : Type*}

namespace nat

/-- `nat.card α` is the cardinality of `α` as a natural number.
  If `α` is infinite, `nat.card α = 0`. -/
protected def card (α : Type*) : ℕ := (mk α).to_nat

@[simp]
lemma card_eq_fintype_card [fintype α] : nat.card α = fintype.card α := mk_to_nat_eq_card

@[simp]
lemma card_eq_zero_of_infinite [infinite α] : nat.card α = 0 := mk_to_nat_of_infinite

lemma card_congr (f : α ≃ β) : nat.card α = nat.card β :=
cardinal.to_nat_congr f

lemma card_eq_of_bijective (f : α → β) (hf : function.bijective f) : nat.card α = nat.card β :=
card_congr (equiv.of_bijective f hf)

lemma card_eq_of_equiv_fin {α : Type*} {n : ℕ}
  (f : α ≃ fin n) : nat.card α = n :=
by simpa using card_congr f

/-- If the cardinality is positive, that means it is a finite type, so there is
an equivalence between `α` and `fin (nat.card α)`. See also `finite.equiv_fin`. -/
def equiv_fin_of_card_pos {α : Type*} (h : nat.card α ≠ 0) :
  α ≃ fin (nat.card α) :=
begin
  casesI fintype_or_infinite α,
  { simpa using fintype.equiv_fin α },
  { simpa using h },
end

lemma card_of_subsingleton (a : α) [subsingleton α] : nat.card α = 1 :=
begin
  rw [card_eq_fintype_card],
  convert fintype.card_of_subsingleton a,
end

@[simp] lemma card_unique [unique α] : nat.card α = 1 :=
card_of_subsingleton default

lemma card_eq_one_iff_unique : nat.card α = 1 ↔ subsingleton α ∧ nonempty α :=
cardinal.to_nat_eq_one_iff_unique

theorem card_of_is_empty [is_empty α] : nat.card α = 0 := by simp

@[simp] lemma card_prod (α β : Type*) : nat.card (α × β) = nat.card α * nat.card β :=
by simp only [nat.card, mk_prod, to_nat_mul, to_nat_lift]

@[simp] lemma card_ulift (α : Type*) : nat.card (ulift α) = nat.card α :=
card_congr equiv.ulift

@[simp] lemma card_plift (α : Type*) : nat.card (plift α) = nat.card α :=
card_congr equiv.plift

end nat

namespace enat

/-- `enat.card α` is the cardinality of `α` as an extended natural number.
  If `α` is infinite, `enat.card α = ⊤`. -/
def card (α : Type*) : enat := (mk α).to_enat

@[simp]
lemma card_eq_coe_fintype_card [fintype α] : card α = fintype.card α := mk_to_enat_eq_coe_card

@[simp]
lemma card_eq_top_of_infinite [infinite α] : card α = ⊤ := mk_to_enat_of_infinite

end enat


<|start_filename|>src/analysis/convex/krein_milman.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.convex.exposed
import analysis.normed_space.hahn_banach.separation

/-!
# The Krein-Milman theorem

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

## The lemma

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

## The theorem

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

## Related theorems

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

## References

See chapter 8 of [<NAME>, *Convexity*][simon2011]

## TODO

* Both theorems are currently stated for normed `ℝ`-spaces due to our version of geometric
  Hahn-Banach. They are more generally true in a LCTVS without changes to the proofs.
-/

open set
open_locale classical

variables {E : Type*} [normed_group E] [normed_space ℝ E] {s : set E}

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

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


<|start_filename|>src/data/mv_polynomial/cardinal.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.W.cardinal
import data.mv_polynomial.basic
/-!
# Cardinality of Polynomial Ring

The main result in this file is `mv_polynomial.cardinal_mk_le_max`, which says that
the cardinality of `mv_polynomial σ R` is bounded above by the maximum of `#R`, `#σ`
and `ℵ₀`.

-/
universes u
/-
The definitions `mv_polynomial_fun` and `arity` are motivated by defining the following
inductive type as a `W_type` in order to be able to use theorems about the cardinality
of `W_type`.

inductive mv_polynomial_term (σ R : Type u) : Type u
| of_ring : R → mv_polynomial_term
| X : σ → mv_polynomial_term
| add : mv_polynomial_term → mv_polynomial_term → mv_polynomial_term
| mul : mv_polynomial_term → mv_polynomial_term → mv_polynomial_term

`W_type (arity σ R)` is isomorphic to the above type.
-/
open cardinal
open_locale cardinal

/-- A type used to prove theorems about the cardinality of `mv_polynomial σ R`. The
`W_type (arity σ R)` has a constant for every element of `R` and `σ` and two binary functions. -/
private def mv_polynomial_fun (σ R : Type u) : Type u :=
R ⊕ σ ⊕ ulift.{u} bool

variables (σ R : Type u)
/-- A function used to prove theorems about the cardinality of `mv_polynomial σ R`.
  The type ``W_type (arity σ R)` has a constant for every element of `R` and `σ` and two binary
  functions. -/
private def arity : mv_polynomial_fun σ R → Type u
| (sum.inl _)              := pempty
| (sum.inr (sum.inl _))    := pempty
| (sum.inr (sum.inr ⟨ff⟩)) := ulift bool
| (sum.inr (sum.inr ⟨tt⟩)) := ulift bool

private def arity_fintype (x : mv_polynomial_fun σ R) : fintype (arity σ R x) :=
by rcases x with x | x | ⟨_ | _⟩; dsimp [arity]; apply_instance

local attribute [instance] arity_fintype

variables {σ R}

variables [comm_semiring R]

/-- The surjection from `W_type (arity σ R)` into `mv_polynomial σ R`. -/
private noncomputable def to_mv_polynomial :
  W_type (arity σ R) → mv_polynomial σ R
| ⟨sum.inl r, _⟩              := mv_polynomial.C r
| ⟨sum.inr (sum.inl i), _⟩    := mv_polynomial.X i
| ⟨sum.inr (sum.inr ⟨ff⟩), f⟩ :=
  to_mv_polynomial (f (ulift.up tt)) * to_mv_polynomial (f (ulift.up ff))
| ⟨sum.inr (sum.inr ⟨tt⟩), f⟩ :=
  to_mv_polynomial (f (ulift.up tt)) + to_mv_polynomial (f (ulift.up ff))

private lemma to_mv_polynomial_surjective : function.surjective (@to_mv_polynomial σ R _) :=
begin
  intro p,
  induction p using mv_polynomial.induction_on with x p₁ p₂ ih₁ ih₂ p i ih,
  { exact ⟨W_type.mk (sum.inl x) pempty.elim, rfl⟩ },
  { rcases ih₁ with ⟨w₁, rfl⟩,
    rcases ih₂ with ⟨w₂, rfl⟩,
    exact ⟨W_type.mk (sum.inr (sum.inr ⟨tt⟩)) (λ x, cond x.down w₁ w₂),
      by simp [to_mv_polynomial]⟩ },
  { rcases ih with ⟨w, rfl⟩,
    exact ⟨W_type.mk (sum.inr (sum.inr ⟨ff⟩)) (λ x, cond x.down w (W_type.mk
      (sum.inr (sum.inl i)) pempty.elim)), by simp [to_mv_polynomial]⟩ }
end

private lemma cardinal_mv_polynomial_fun_le : #(mv_polynomial_fun σ R) ≤ max (max (#R) (#σ)) ℵ₀ :=
calc #(mv_polynomial_fun σ R) = #R + #σ + #(ulift bool) :
  by dsimp [mv_polynomial_fun]; simp only [← add_def, add_assoc, cardinal.mk_ulift]
... ≤ max (max (#R + #σ) (#(ulift bool))) ℵ₀ : add_le_max _ _
... ≤ max (max (max (max (#R) (#σ)) ℵ₀) (#(ulift bool))) ℵ₀ :
  max_le_max (max_le_max (add_le_max _ _) le_rfl) le_rfl
... ≤ _ : by simp only [max_comm ℵ₀, max_assoc, max_left_comm ℵ₀, max_self,
            max_eq_left (lt_aleph_0_of_fintype (ulift.{u} bool)).le]

namespace mv_polynomial

/-- The cardinality of the multivariate polynomial ring, `mv_polynomial σ R` is at most the maximum
of `#R`, `#σ` and `ℵ₀` -/
lemma cardinal_mk_le_max {σ R : Type u} [comm_semiring R] :
  #(mv_polynomial σ R) ≤ max (max (#R) (#σ)) ℵ₀ :=
calc #(mv_polynomial σ R) ≤ #(W_type (arity σ R)) :
  cardinal.mk_le_of_surjective to_mv_polynomial_surjective
... ≤ max (#(mv_polynomial_fun σ R)) ℵ₀ : W_type.cardinal_mk_le_max_aleph_0_of_fintype
... ≤ _ : max_le_max cardinal_mv_polynomial_fun_le le_rfl
... ≤ _ : by simp only [max_assoc, max_self]

end mv_polynomial


<|start_filename|>src/linear_algebra/std_basis.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.matrix.basis
import linear_algebra.basis
import linear_algebra.pi

/-!
# The standard basis

This file defines the standard basis `pi.basis (s : ∀ j, basis (ι j) R (M j))`,
which is the `Σ j, ι j`-indexed basis of Π j, M j`. The basis vectors are given by
`pi.basis s ⟨j, i⟩ j' = linear_map.std_basis R M j' (s j) i = if j = j' then s i else 0`.

The standard basis on `R^η`, i.e. `η → R` is called `pi.basis_fun`.

To give a concrete example, `linear_map.std_basis R (λ (i : fin 3), R) i 1`
gives the `i`th unit basis vector in `R³`, and `pi.basis_fun R (fin 3)` proves
this is a basis over `fin 3 → R`.

## Main definitions

 - `linear_map.std_basis R M`: if `x` is a basis vector of `M i`, then
   `linear_map.std_basis R M i x` is the `i`th standard basis vector of `Π i, M i`.
 - `pi.basis s`: given a basis `s i` for each `M i`, the standard basis on `Π i, M i`
 - `pi.basis_fun R η`: the standard basis on `R^η`, i.e. `η → R`, given by
   `pi.basis_fun R η i j = if i = j then 1 else 0`.
 - `matrix.std_basis R n m`: the standard basis on `matrix n m R`, given by
   `matrix.std_basis R n m (i, j) i' j' = if (i, j) = (i', j') then 1 else 0`.

-/

open function submodule
open_locale big_operators
open_locale big_operators

namespace linear_map

variables (R : Type*) {ι : Type*} [semiring R] (φ : ι → Type*)
  [Π i, add_comm_monoid (φ i)] [Π i, module R (φ i)] [decidable_eq ι]

/-- The standard basis of the product of `φ`. -/
def std_basis : Π (i : ι), φ i →ₗ[R] (Πi, φ i) := single

lemma std_basis_apply (i : ι) (b : φ i) : std_basis R φ i b = update 0 i b :=
rfl

lemma coe_std_basis (i : ι) : ⇑(std_basis R φ i) = pi.single i :=
rfl

@[simp] lemma std_basis_same (i : ι) (b : φ i) : std_basis R φ i b i = b :=
pi.single_eq_same i b

lemma std_basis_ne (i j : ι) (h : j ≠ i) (b : φ i) : std_basis R φ i b j = 0 :=
pi.single_eq_of_ne h b

lemma std_basis_eq_pi_diag (i : ι) : std_basis R φ i = pi (diag i) :=
begin
  ext x j,
  convert (update_apply 0 x i j _).symm,
  refl,
end

lemma ker_std_basis (i : ι) : ker (std_basis R φ i) = ⊥ :=
ker_eq_bot_of_injective $ pi.single_injective _ _

lemma proj_comp_std_basis (i j : ι) : (proj i).comp (std_basis R φ j) = diag j i :=
by rw [std_basis_eq_pi_diag, proj_pi]

lemma proj_std_basis_same (i : ι) : (proj i).comp (std_basis R φ i) = id :=
linear_map.ext $ std_basis_same R φ i

lemma proj_std_basis_ne (i j : ι) (h : i ≠ j) : (proj i).comp (std_basis R φ j) = 0 :=
linear_map.ext $ std_basis_ne R φ _ _ h

lemma supr_range_std_basis_le_infi_ker_proj (I J : set ι) (h : disjoint I J) :
  (⨆i∈I, range (std_basis R φ i)) ≤ (⨅i∈J, ker (proj i)) :=
begin
  refine (supr_le $ λ i, supr_le $ λ hi, range_le_iff_comap.2 _),
  simp only [(ker_comp _ _).symm, eq_top_iff, set_like.le_def, mem_ker, comap_infi, mem_infi],
  rintro b - j hj,
  rw [proj_std_basis_ne R φ j i, zero_apply],
  rintro rfl,
  exact h ⟨hi, hj⟩
end

lemma infi_ker_proj_le_supr_range_std_basis {I : finset ι} {J : set ι} (hu : set.univ ⊆ ↑I ∪ J) :
  (⨅ i∈J, ker (proj i)) ≤ (⨆i∈I, range (std_basis R φ i)) :=
set_like.le_def.2
begin
  assume b hb,
  simp only [mem_infi, mem_ker, proj_apply] at hb,
  rw ← show ∑ i in I, std_basis R φ i (b i) = b,
  { ext i,
    rw [finset.sum_apply, ← std_basis_same R φ i (b i)],
    refine finset.sum_eq_single i (assume j hjI ne, std_basis_ne _ _ _ _ ne.symm _) _,
    assume hiI,
    rw [std_basis_same],
    exact hb _ ((hu trivial).resolve_left hiI) },
  exact sum_mem_bsupr (λ i hi, (std_basis R φ i).mem_range_self (b i))
end

lemma supr_range_std_basis_eq_infi_ker_proj {I J : set ι}
  (hd : disjoint I J) (hu : set.univ ⊆ I ∪ J) (hI : set.finite I) :
  (⨆i∈I, range (std_basis R φ i)) = (⨅i∈J, ker (proj i)) :=
begin
  refine le_antisymm (supr_range_std_basis_le_infi_ker_proj _ _ _ _ hd) _,
  have : set.univ ⊆ ↑hI.to_finset ∪ J, { rwa [hI.coe_to_finset] },
  refine le_trans (infi_ker_proj_le_supr_range_std_basis R φ this) (supr_mono $ assume i, _),
  rw [set.finite.mem_to_finset],
  exact le_rfl
end

lemma supr_range_std_basis [fintype ι] : (⨆i:ι, range (std_basis R φ i)) = ⊤ :=
have (set.univ : set ι) ⊆ ↑(finset.univ : finset ι) ∪ ∅ := by rw [finset.coe_univ, set.union_empty],
begin
  apply top_unique,
  convert (infi_ker_proj_le_supr_range_std_basis R φ this),
  exact infi_emptyset.symm,
  exact (funext $ λi, (@supr_pos _ _ _ (λh, range (std_basis R φ i)) $ finset.mem_univ i).symm)
end

lemma disjoint_std_basis_std_basis (I J : set ι) (h : disjoint I J) :
  disjoint (⨆i∈I, range (std_basis R φ i)) (⨆i∈J, range (std_basis R φ i)) :=
begin
  refine disjoint.mono
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right)
    (supr_range_std_basis_le_infi_ker_proj _ _ _ _ $ disjoint_compl_right) _,
  simp only [disjoint, set_like.le_def, mem_infi, mem_inf, mem_ker, mem_bot, proj_apply,
    funext_iff],
  rintros b ⟨hI, hJ⟩ i,
  classical,
  by_cases hiI : i ∈ I,
  { by_cases hiJ : i ∈ J,
    { exact (h ⟨hiI, hiJ⟩).elim },
    { exact hJ i hiJ } },
  { exact hI i hiI }
end

lemma std_basis_eq_single {a : R} :
  (λ (i : ι), (std_basis R (λ _ : ι, R) i) a) = λ (i : ι), (finsupp.single i a) :=
funext $ λ i, (finsupp.single_eq_pi_single i a).symm

end linear_map

namespace pi
open linear_map
open set

variables {R : Type*}

section module
variables {η : Type*} {ιs : η → Type*} {Ms : η → Type*}

lemma linear_independent_std_basis [ring R] [∀i, add_comm_group (Ms i)] [∀i, module R (Ms i)]
  [decidable_eq η] (v : Πj, ιs j → (Ms j)) (hs : ∀i, linear_independent R (v i)) :
  linear_independent R (λ (ji : Σ j, ιs j), std_basis R Ms ji.1 (v ji.1 ji.2)) :=
begin
  have hs' : ∀j : η, linear_independent R (λ i : ιs j, std_basis R Ms j (v j i)),
  { intro j,
    exact (hs j).map' _ (ker_std_basis _ _ _) },
  apply linear_independent_Union_finite hs',
  { assume j J _ hiJ,
    simp [(set.Union.equations._eqn_1 _).symm, submodule.span_image, submodule.span_Union],
    have h₀ : ∀ j, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ range (std_basis R Ms j),
    { intro j,
      rw [span_le, linear_map.range_coe],
      apply range_comp_subset_range },
    have h₁ : span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))
        ≤ ⨆ i ∈ {j}, range (std_basis R Ms i),
    { rw @supr_singleton _ _ _ (λ i, linear_map.range (std_basis R (λ (j : η), Ms j) i)),
      apply h₀ },
    have h₂ : (⨆ j ∈ J, span R (range (λ (i : ιs j), std_basis R Ms j (v j i)))) ≤
               ⨆ j ∈ J, range (std_basis R (λ (j : η), Ms j) j) :=
      supr₂_mono (λ i _, h₀ i),
    have h₃ : disjoint (λ (i : η), i ∈ {j}) J,
    { convert set.disjoint_singleton_left.2 hiJ using 0 },
    exact (disjoint_std_basis_std_basis _ _ _ _ h₃).mono h₁ h₂ }
end

variables [semiring R] [∀i, add_comm_monoid (Ms i)] [∀i, module R (Ms i)]

variable [fintype η]

section

open linear_equiv

/-- `pi.basis (s : ∀ j, basis (ιs j) R (Ms j))` is the `Σ j, ιs j`-indexed basis on `Π j, Ms j`
given by `s j` on each component. -/
protected noncomputable def basis (s : ∀ j, basis (ιs j) R (Ms j)) :
  basis (Σ j, ιs j) R (Π j, Ms j) :=
-- The `add_comm_monoid (Π j, Ms j)` instance was hard to find.
-- Defining this in tactic mode seems to shake up instance search enough that it works by itself.
by { refine basis.of_repr (_ ≪≫ₗ (finsupp.sigma_finsupp_lequiv_pi_finsupp R).symm),
     exact linear_equiv.Pi_congr_right (λ j, (s j).repr) }

@[simp] lemma basis_repr_std_basis [decidable_eq η] (s : ∀ j, basis (ιs j) R (Ms j)) (j i) :
  (pi.basis s).repr (std_basis R _ j (s j i)) = finsupp.single ⟨j, i⟩ 1 :=
begin
  ext ⟨j', i'⟩,
  by_cases hj : j = j',
  { subst hj,
    simp only [pi.basis, linear_equiv.trans_apply, basis.repr_self, std_basis_same,
        linear_equiv.Pi_congr_right_apply, finsupp.sigma_finsupp_lequiv_pi_finsupp_symm_apply],
    symmetry,
    exact basis.finsupp.single_apply_left
      (λ i i' (h : (⟨j, i⟩ : Σ j, ιs j) = ⟨j, i'⟩), eq_of_heq (sigma.mk.inj h).2) _ _ _ },
  simp only [pi.basis, linear_equiv.trans_apply, finsupp.sigma_finsupp_lequiv_pi_finsupp_symm_apply,
      linear_equiv.Pi_congr_right_apply],
  dsimp,
  rw [std_basis_ne _ _ _ _ (ne.symm hj), linear_equiv.map_zero, finsupp.zero_apply,
      finsupp.single_eq_of_ne],
  rintros ⟨⟩,
  contradiction
end

@[simp] lemma basis_apply [decidable_eq η] (s : ∀ j, basis (ιs j) R (Ms j)) (ji) :
  pi.basis s ji = std_basis R _ ji.1 (s ji.1 ji.2) :=
basis.apply_eq_iff.mpr (by simp)

@[simp] lemma basis_repr (s : ∀ j, basis (ιs j) R (Ms j)) (x) (ji) :
  (pi.basis s).repr x ji = (s ji.1).repr (x ji.1) ji.2 :=
rfl

end

section
variables (R η)

/-- The basis on `η → R` where the `i`th basis vector is `function.update 0 i 1`. -/
noncomputable def basis_fun : basis η R (Π (j : η), R) :=
basis.of_equiv_fun (linear_equiv.refl _ _)

@[simp] lemma basis_fun_apply [decidable_eq η] (i) :
  basis_fun R η i = std_basis R (λ (i : η), R) i 1 :=
by { simp only [basis_fun, basis.coe_of_equiv_fun, linear_equiv.refl_symm,
                linear_equiv.refl_apply, std_basis_apply],
     congr /- Get rid of a `decidable_eq` mismatch. -/ }

@[simp] lemma basis_fun_repr (x : η → R) (i : η) :
  (pi.basis_fun R η).repr x i = x i :=
by simp [basis_fun]

end

end module

end pi

namespace matrix

variables (R : Type*) (m n : Type*) [fintype m] [fintype n] [semiring R]

/-- The standard basis of `matrix m n R`. -/
noncomputable def std_basis : basis (m × n) R (matrix m n R) :=
basis.reindex (pi.basis (λ (i : m), pi.basis_fun R n)) (equiv.sigma_equiv_prod _ _)

variables {n m}

lemma std_basis_eq_std_basis_matrix (i : n) (j : m) [decidable_eq n] [decidable_eq m] :
  std_basis R n m (i, j) = std_basis_matrix i j (1 : R) :=
begin
  ext a b,
  by_cases hi : i = a; by_cases hj : j = b,
  { simp [std_basis, hi, hj] },
  { simp [std_basis, hi, hj, ne.symm hj, linear_map.std_basis_ne] },
  { simp [std_basis, hi, hj, ne.symm hi, linear_map.std_basis_ne] },
  { simp [std_basis, hi, hj, ne.symm hj, ne.symm hi, linear_map.std_basis_ne] }
end

end matrix


<|start_filename|>src/analysis/normed_space/exponential.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import analysis.specific_limits.basic
import analysis.analytic.basic
import analysis.complex.basic
import data.nat.choose.cast
import data.finset.noncomm_prod

/-!
# Exponential in a Banach algebra

In this file, we define `exp 𝕂 : 𝔸 → 𝔸`, the exponential map in a topological algebra `𝔸` over a
field `𝕂`.

While for most interesting results we need `𝔸` to be normed algebra, we do not require this in the
definition in order to make `exp` independent of a particular choice of norm. The definition also
does not require that `𝔸` be complete, but we need to assume it for most results.

We then prove some basic results, but we avoid importing derivatives here to minimize dependencies.
Results involving derivatives and comparisons with `real.exp` and `complex.exp` can be found in
`analysis/special_functions/exponential`.

## Main results

We prove most result for an arbitrary field `𝕂`, and then specialize to `𝕂 = ℝ` or `𝕂 = ℂ`.

### General case

- `exp_add_of_commute_of_mem_ball` : if `𝕂` has characteristic zero, then given two commuting
  elements `x` and `y` in the disk of convergence, we have
  `exp 𝕂 (x+y) = (exp 𝕂 x) * (exp 𝕂 y)`
- `exp_add_of_mem_ball` : if `𝕂` has characteristic zero and `𝔸` is commutative, then given two
  elements `x` and `y` in the disk of convergence, we have
  `exp 𝕂 (x+y) = (exp 𝕂 x) * (exp 𝕂 y)`
- `exp_neg_of_mem_ball` : if `𝕂` has characteristic zero and `𝔸` is a division ring, then given an
  element `x` in the disk of convergence, we have `exp 𝕂 (-x) = (exp 𝕂 x)⁻¹`.

### `𝕂 = ℝ` or `𝕂 = ℂ`

- `exp_series_radius_eq_top` : the `formal_multilinear_series` defining `exp 𝕂` has infinite
  radius of convergence
- `exp_add_of_commute` : given two commuting elements `x` and `y`, we have
  `exp 𝕂 (x+y) = (exp 𝕂 x) * (exp 𝕂 y)`
- `exp_add` : if `𝔸` is commutative, then we have `exp 𝕂 (x+y) = (exp 𝕂 x) * (exp 𝕂 y)`
  for any `x` and `y`
- `exp_neg` : if `𝔸` is a division ring, then we have `exp 𝕂 (-x) = (exp 𝕂 x)⁻¹`.
- `exp_sum_of_commute` : the analogous result to `exp_add_of_commute` for `finset.sum`.
- `exp_sum` : the analogous result to `exp_add` for `finset.sum`.
- `exp_nsmul` : repeated addition in the domain corresponds to repeated multiplication in the
  codomain.
- `exp_zsmul` : repeated addition in the domain corresponds to repeated multiplication in the
  codomain.

### Other useful compatibility results

- `exp_eq_exp` : if `𝔸` is a normed algebra over two fields `𝕂` and `𝕂'`, then `exp 𝕂 = exp 𝕂' 𝔸`

-/

open filter is_R_or_C continuous_multilinear_map normed_field asymptotics
open_locale nat topological_space big_operators ennreal

section topological_algebra

variables (𝕂 𝔸 : Type*) [field 𝕂] [ring 𝔸] [algebra 𝕂 𝔸] [topological_space 𝔸]
  [topological_ring 𝔸]

/-- `exp_series 𝕂 𝔸` is the `formal_multilinear_series` whose `n`-th term is the map
`(xᵢ) : 𝔸ⁿ ↦ (1/n! : 𝕂) • ∏ xᵢ`. Its sum is the exponential map `exp 𝕂 : 𝔸 → 𝔸`. -/
def exp_series : formal_multilinear_series 𝕂 𝔸 𝔸 :=
λ n, (n!⁻¹ : 𝕂) • continuous_multilinear_map.mk_pi_algebra_fin 𝕂 n 𝔸

variables {𝔸}

/-- `exp 𝕂 : 𝔸 → 𝔸` is the exponential map determined by the action of `𝕂` on `𝔸`.
It is defined as the sum of the `formal_multilinear_series` `exp_series 𝕂 𝔸`.

Note that when `𝔸 = matrix n n 𝕂`, this is the **Matrix Exponential**; see
[`analysis.normed_space.matrix_exponential`](../matrix_exponential) for lemmas specific to that
case. -/
noncomputable def exp (x : 𝔸) : 𝔸 := (exp_series 𝕂 𝔸).sum x

variables {𝕂}

lemma exp_series_apply_eq (x : 𝔸) (n : ℕ) : exp_series 𝕂 𝔸 n (λ _, x) = (n!⁻¹ : 𝕂) • x^n :=
by simp [exp_series]

lemma exp_series_apply_eq' (x : 𝔸) :
  (λ n, exp_series 𝕂 𝔸 n (λ _, x)) = (λ n, (n!⁻¹ : 𝕂) • x^n) :=
funext (exp_series_apply_eq x)

lemma exp_series_sum_eq (x : 𝔸) : (exp_series 𝕂 𝔸).sum x = ∑' (n : ℕ), (n!⁻¹ : 𝕂) • x^n :=
tsum_congr (λ n, exp_series_apply_eq x n)

lemma exp_eq_tsum : exp 𝕂 = (λ x : 𝔸, ∑' (n : ℕ), (n!⁻¹ : 𝕂) • x^n) :=
funext exp_series_sum_eq

@[simp] lemma exp_zero [t2_space 𝔸] : exp 𝕂 (0 : 𝔸) = 1 :=
begin
  suffices : (λ x : 𝔸, ∑' (n : ℕ), (n!⁻¹ : 𝕂) • x^n) 0 = ∑' (n : ℕ), if n = 0 then 1 else 0,
  { have key : ∀ n ∉ ({0} : finset ℕ), (if n = 0 then (1 : 𝔸) else 0) = 0,
      from λ n hn, if_neg (finset.not_mem_singleton.mp hn),
    rw [exp_eq_tsum, this, tsum_eq_sum key, finset.sum_singleton],
    simp },
  refine tsum_congr (λ n, _),
  split_ifs with h h;
  simp [h]
end

@[simp] lemma exp_op [t2_space 𝔸] (x : 𝔸) :
  exp 𝕂 (mul_opposite.op x) = mul_opposite.op (exp 𝕂 x) :=
by simp_rw [exp, exp_series_sum_eq, ←mul_opposite.op_pow, ←mul_opposite.op_smul, tsum_op]

@[simp] lemma exp_unop [t2_space 𝔸] (x : 𝔸ᵐᵒᵖ) :
  exp 𝕂 (mul_opposite.unop x) = mul_opposite.unop (exp 𝕂 x) :=
by simp_rw [exp, exp_series_sum_eq, ←mul_opposite.unop_pow, ←mul_opposite.unop_smul, tsum_unop]

lemma star_exp [t2_space 𝔸] [star_ring 𝔸] [has_continuous_star 𝔸] (x : 𝔸) :
  star (exp 𝕂 x) = exp 𝕂 (star x) :=
by simp_rw [exp_eq_tsum, ←star_pow, ←star_inv_nat_cast_smul, ←tsum_star]

variables (𝕂)

lemma commute.exp_right [t2_space 𝔸] {x y : 𝔸} (h : commute x y) : commute x (exp 𝕂 y) :=
begin
  rw exp_eq_tsum,
  exact commute.tsum_right x (λ n, (h.pow_right n).smul_right _),
end

lemma commute.exp_left [t2_space 𝔸] {x y : 𝔸} (h : commute x y) : commute (exp 𝕂 x) y :=
(h.symm.exp_right 𝕂).symm

lemma commute.exp [t2_space 𝔸] {x y : 𝔸} (h : commute x y) : commute (exp 𝕂 x) (exp 𝕂 y) :=
(h.exp_left _).exp_right _

end topological_algebra

section topological_division_algebra
variables {𝕂 𝔸 : Type*} [field 𝕂] [division_ring 𝔸] [algebra 𝕂 𝔸] [topological_space 𝔸]
  [topological_ring 𝔸]

lemma exp_series_apply_eq_div (x : 𝔸) (n : ℕ) : exp_series 𝕂 𝔸 n (λ _, x) = x^n / n! :=
by rw [div_eq_mul_inv, ←(nat.cast_commute n! (x ^ n)).inv_left₀.eq, ←smul_eq_mul,
    exp_series_apply_eq, inv_nat_cast_smul_eq _ _ _ _]

lemma exp_series_apply_eq_div' (x : 𝔸) : (λ n, exp_series 𝕂 𝔸 n (λ _, x)) = (λ n, x^n / n!) :=
funext (exp_series_apply_eq_div x)

lemma exp_series_sum_eq_div (x : 𝔸) : (exp_series 𝕂 𝔸).sum x = ∑' (n : ℕ), x^n / n! :=
tsum_congr (exp_series_apply_eq_div x)

lemma exp_eq_tsum_div : exp 𝕂 = (λ x : 𝔸, ∑' (n : ℕ), x^n / n!) :=
funext exp_series_sum_eq_div

end topological_division_algebra

section normed

section any_field_any_algebra

variables {𝕂 𝔸 𝔹 : Type*} [nondiscrete_normed_field 𝕂]
variables [normed_ring 𝔸] [normed_ring 𝔹] [normed_algebra 𝕂 𝔸] [normed_algebra 𝕂 𝔹]

lemma norm_exp_series_summable_of_mem_ball (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  summable (λ n, ∥exp_series 𝕂 𝔸 n (λ _, x)∥) :=
(exp_series 𝕂 𝔸).summable_norm_apply hx

lemma norm_exp_series_summable_of_mem_ball' (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  summable (λ n, ∥(n!⁻¹ : 𝕂) • x^n∥) :=
begin
  change summable (norm ∘ _),
  rw ← exp_series_apply_eq',
  exact norm_exp_series_summable_of_mem_ball x hx
end

section complete_algebra

variables [complete_space 𝔸]

lemma exp_series_summable_of_mem_ball (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  summable (λ n, exp_series 𝕂 𝔸 n (λ _, x)) :=
summable_of_summable_norm (norm_exp_series_summable_of_mem_ball x hx)

lemma exp_series_summable_of_mem_ball' (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  summable (λ n, (n!⁻¹ : 𝕂) • x^n) :=
summable_of_summable_norm (norm_exp_series_summable_of_mem_ball' x hx)

lemma exp_series_has_sum_exp_of_mem_ball (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  has_sum (λ n, exp_series 𝕂 𝔸 n (λ _, x)) (exp 𝕂 x) :=
formal_multilinear_series.has_sum (exp_series 𝕂 𝔸) hx

lemma exp_series_has_sum_exp_of_mem_ball' (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  has_sum (λ n, (n!⁻¹ : 𝕂) • x^n) (exp 𝕂 x):=
begin
  rw ← exp_series_apply_eq',
  exact exp_series_has_sum_exp_of_mem_ball x hx
end

lemma has_fpower_series_on_ball_exp_of_radius_pos (h : 0 < (exp_series 𝕂 𝔸).radius) :
  has_fpower_series_on_ball (exp 𝕂) (exp_series 𝕂 𝔸) 0 (exp_series 𝕂 𝔸).radius :=
(exp_series 𝕂 𝔸).has_fpower_series_on_ball h

lemma has_fpower_series_at_exp_zero_of_radius_pos (h : 0 < (exp_series 𝕂 𝔸).radius) :
  has_fpower_series_at (exp 𝕂) (exp_series 𝕂 𝔸) 0 :=
(has_fpower_series_on_ball_exp_of_radius_pos h).has_fpower_series_at

lemma continuous_on_exp :
  continuous_on (exp 𝕂 : 𝔸 → 𝔸) (emetric.ball 0 (exp_series 𝕂 𝔸).radius) :=
formal_multilinear_series.continuous_on

lemma analytic_at_exp_of_mem_ball (x : 𝔸) (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  analytic_at 𝕂 (exp 𝕂) x:=
begin
  by_cases h : (exp_series 𝕂 𝔸).radius = 0,
  { rw h at hx, exact (ennreal.not_lt_zero hx).elim },
  { have h := pos_iff_ne_zero.mpr h,
    exact (has_fpower_series_on_ball_exp_of_radius_pos h).analytic_at_of_mem hx }
end

/-- In a Banach-algebra `𝔸` over a normed field `𝕂` of characteristic zero, if `x` and `y` are
in the disk of convergence and commute, then `exp 𝕂 (x + y) = (exp 𝕂 x) * (exp 𝕂 y)`. -/
lemma exp_add_of_commute_of_mem_ball [char_zero 𝕂]
  {x y : 𝔸} (hxy : commute x y) (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius)
  (hy : y ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  exp 𝕂 (x + y) = (exp 𝕂 x) * (exp 𝕂 y) :=
begin
  rw [exp_eq_tsum, tsum_mul_tsum_eq_tsum_sum_antidiagonal_of_summable_norm
        (norm_exp_series_summable_of_mem_ball' x hx) (norm_exp_series_summable_of_mem_ball' y hy)],
  dsimp only,
  conv_lhs {congr, funext, rw [hxy.add_pow' _, finset.smul_sum]},
  refine tsum_congr (λ n, finset.sum_congr rfl $ λ kl hkl, _),
  rw [nsmul_eq_smul_cast 𝕂, smul_smul, smul_mul_smul, ← (finset.nat.mem_antidiagonal.mp hkl),
      nat.cast_add_choose, (finset.nat.mem_antidiagonal.mp hkl)],
  congr' 1,
  have : (n! : 𝕂) ≠ 0 := nat.cast_ne_zero.mpr n.factorial_ne_zero,
  field_simp [this]
end

/-- `exp 𝕂 x` has explicit two-sided inverse `exp 𝕂 (-x)`. -/
noncomputable def invertible_exp_of_mem_ball [char_zero 𝕂] {x : 𝔸}
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) : invertible (exp 𝕂 x) :=
{ inv_of := exp 𝕂 (-x),
  inv_of_mul_self := begin
    have hnx : -x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius,
    { rw [emetric.mem_ball, ←neg_zero, edist_neg_neg],
      exact hx },
    rw [←exp_add_of_commute_of_mem_ball (commute.neg_left $ commute.refl x) hnx hx, neg_add_self,
      exp_zero],
  end,
  mul_inv_of_self := begin
    have hnx : -x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius,
    { rw [emetric.mem_ball, ←neg_zero, edist_neg_neg],
      exact hx },
    rw [←exp_add_of_commute_of_mem_ball (commute.neg_right $ commute.refl x) hx hnx, add_neg_self,
      exp_zero],
  end }

lemma is_unit_exp_of_mem_ball [char_zero 𝕂] {x : 𝔸}
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) : is_unit (exp 𝕂 x) :=
@is_unit_of_invertible _ _ _ (invertible_exp_of_mem_ball hx)

lemma inv_of_exp_of_mem_ball [char_zero 𝕂] {x : 𝔸}
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) [invertible (exp 𝕂 x)] :
  ⅟(exp 𝕂 x) = exp 𝕂 (-x) :=
by { letI := invertible_exp_of_mem_ball hx, convert (rfl : ⅟(exp 𝕂 x) = _) }

/-- Any continuous ring homomorphism commutes with `exp`. -/
lemma map_exp_of_mem_ball {F} [ring_hom_class F 𝔸 𝔹] (f : F) (hf : continuous f) (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  f (exp 𝕂 x) = exp 𝕂 (f x) :=
begin
  rw [exp_eq_tsum, exp_eq_tsum],
  refine ((exp_series_summable_of_mem_ball' _ hx).has_sum.map f hf).tsum_eq.symm.trans _,
  dsimp only [function.comp],
  simp_rw [one_div, map_inv_nat_cast_smul f 𝕂 𝕂, map_pow],
end

end complete_algebra

lemma algebra_map_exp_comm_of_mem_ball [complete_space 𝕂] (x : 𝕂)
  (hx : x ∈ emetric.ball (0 : 𝕂) (exp_series 𝕂 𝕂).radius) :
  algebra_map 𝕂 𝔸 (exp 𝕂 x) = exp 𝕂 (algebra_map 𝕂 𝔸 x) :=
map_exp_of_mem_ball _ (algebra_map_clm _ _).continuous _ hx

end any_field_any_algebra

section any_field_division_algebra

variables {𝕂 𝔸 : Type*} [nondiscrete_normed_field 𝕂] [normed_division_ring 𝔸] [normed_algebra 𝕂 𝔸]

variables (𝕂)

lemma norm_exp_series_div_summable_of_mem_ball (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  summable (λ n, ∥x^n / n!∥) :=
begin
  change summable (norm ∘ _),
  rw ← exp_series_apply_eq_div' x,
  exact norm_exp_series_summable_of_mem_ball x hx
end

lemma exp_series_div_summable_of_mem_ball [complete_space 𝔸] (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) : summable (λ n, x^n / n!) :=
summable_of_summable_norm (norm_exp_series_div_summable_of_mem_ball 𝕂 x hx)

lemma exp_series_div_has_sum_exp_of_mem_ball [complete_space 𝔸] (x : 𝔸)
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) : has_sum (λ n, x^n / n!) (exp 𝕂 x) :=
begin
  rw ← exp_series_apply_eq_div' x,
  exact exp_series_has_sum_exp_of_mem_ball x hx
end

variables {𝕂}

lemma exp_neg_of_mem_ball [char_zero 𝕂] [complete_space 𝔸] {x : 𝔸}
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  exp 𝕂 (-x) = (exp 𝕂 x)⁻¹ :=
begin
  letI := invertible_exp_of_mem_ball hx,
  exact inv_of_eq_inv (exp 𝕂 x),
end

end any_field_division_algebra


section any_field_comm_algebra

variables {𝕂 𝔸 : Type*} [nondiscrete_normed_field 𝕂] [normed_comm_ring 𝔸] [normed_algebra 𝕂 𝔸]
  [complete_space 𝔸]

/-- In a commutative Banach-algebra `𝔸` over a normed field `𝕂` of characteristic zero,
`exp 𝕂 (x+y) = (exp 𝕂 x) * (exp 𝕂 y)` for all `x`, `y` in the disk of convergence. -/
lemma exp_add_of_mem_ball [char_zero 𝕂] {x y : 𝔸}
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius)
  (hy : y ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  exp 𝕂 (x + y) = (exp 𝕂 x) * (exp 𝕂 y) :=
exp_add_of_commute_of_mem_ball (commute.all x y) hx hy

end any_field_comm_algebra

section is_R_or_C

section any_algebra

variables (𝕂 𝔸 𝔹 : Type*) [is_R_or_C 𝕂] [normed_ring 𝔸] [normed_algebra 𝕂 𝔸]
variables [normed_ring 𝔹] [normed_algebra 𝕂 𝔹]

/-- In a normed algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ`, the series defining the exponential map
has an infinite radius of convergence. -/
lemma exp_series_radius_eq_top : (exp_series 𝕂 𝔸).radius = ∞ :=
begin
  refine (exp_series 𝕂 𝔸).radius_eq_top_of_summable_norm (λ r, _),
  refine summable_of_norm_bounded_eventually _ (real.summable_pow_div_factorial r) _,
  filter_upwards [eventually_cofinite_ne 0] with n hn,
  rw [norm_mul, norm_norm (exp_series 𝕂 𝔸 n), exp_series, norm_smul, norm_inv, norm_pow,
      nnreal.norm_eq, norm_eq_abs, abs_cast_nat, mul_comm, ←mul_assoc, ←div_eq_mul_inv],
  have : ∥continuous_multilinear_map.mk_pi_algebra_fin 𝕂 n 𝔸∥ ≤ 1 :=
    norm_mk_pi_algebra_fin_le_of_pos (nat.pos_of_ne_zero hn),
  exact mul_le_of_le_one_right (div_nonneg (pow_nonneg r.coe_nonneg n) n!.cast_nonneg) this
end

lemma exp_series_radius_pos : 0 < (exp_series 𝕂 𝔸).radius :=
begin
  rw exp_series_radius_eq_top,
  exact with_top.zero_lt_top
end

variables {𝕂 𝔸 𝔹}

lemma norm_exp_series_summable (x : 𝔸) : summable (λ n, ∥exp_series 𝕂 𝔸 n (λ _, x)∥) :=
norm_exp_series_summable_of_mem_ball x ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

lemma norm_exp_series_summable' (x : 𝔸) : summable (λ n, ∥(n!⁻¹ : 𝕂) • x^n∥) :=
norm_exp_series_summable_of_mem_ball' x ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

section complete_algebra

variables [complete_space 𝔸]

lemma exp_series_summable (x : 𝔸) : summable (λ n, exp_series 𝕂 𝔸 n (λ _, x)) :=
summable_of_summable_norm (norm_exp_series_summable x)

lemma exp_series_summable' (x : 𝔸) : summable (λ n, (n!⁻¹ : 𝕂) • x^n) :=
summable_of_summable_norm (norm_exp_series_summable' x)

lemma exp_series_has_sum_exp (x : 𝔸) : has_sum (λ n, exp_series 𝕂 𝔸 n (λ _, x)) (exp 𝕂 x) :=
exp_series_has_sum_exp_of_mem_ball x ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

lemma exp_series_has_sum_exp' (x : 𝔸) : has_sum (λ n, (n!⁻¹ : 𝕂) • x^n) (exp 𝕂 x):=
exp_series_has_sum_exp_of_mem_ball' x ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

lemma exp_has_fpower_series_on_ball :
  has_fpower_series_on_ball (exp 𝕂) (exp_series 𝕂 𝔸) 0 ∞ :=
exp_series_radius_eq_top 𝕂 𝔸 ▸
  has_fpower_series_on_ball_exp_of_radius_pos (exp_series_radius_pos _ _)

lemma exp_has_fpower_series_at_zero :
  has_fpower_series_at (exp 𝕂) (exp_series 𝕂 𝔸) 0 :=
exp_has_fpower_series_on_ball.has_fpower_series_at

lemma exp_continuous : continuous (exp 𝕂 : 𝔸 → 𝔸) :=
begin
  rw [continuous_iff_continuous_on_univ, ← metric.eball_top_eq_univ (0 : 𝔸),
      ← exp_series_radius_eq_top 𝕂 𝔸],
  exact continuous_on_exp
end

lemma exp_analytic (x : 𝔸) :
  analytic_at 𝕂 (exp 𝕂) x :=
analytic_at_exp_of_mem_ball x ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

/-- In a Banach-algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ`, if `x` and `y` commute, then
`exp 𝕂 (x+y) = (exp 𝕂 x) * (exp 𝕂 y)`. -/
lemma exp_add_of_commute
  {x y : 𝔸} (hxy : commute x y) :
  exp 𝕂 (x + y) = (exp 𝕂 x) * (exp 𝕂 y) :=
exp_add_of_commute_of_mem_ball hxy ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)
  ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

section
variables (𝕂)

/-- `exp 𝕂 x` has explicit two-sided inverse `exp 𝕂 (-x)`. -/
noncomputable def invertible_exp (x : 𝔸) : invertible (exp 𝕂 x) :=
invertible_exp_of_mem_ball $ (exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _

lemma is_unit_exp (x : 𝔸) : is_unit (exp 𝕂 x) :=
is_unit_exp_of_mem_ball $ (exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _

lemma inv_of_exp (x : 𝔸) [invertible (exp 𝕂 x)] :
  ⅟(exp 𝕂 x) = exp 𝕂 (-x) :=
inv_of_exp_of_mem_ball $ (exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _

lemma ring.inverse_exp (x : 𝔸) : ring.inverse (exp 𝕂 x) = exp 𝕂 (-x) :=
begin
  letI := invertible_exp 𝕂 x,
  exact ring.inverse_invertible _,
end

end

/-- In a Banach-algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ`, if a family of elements `f i` mutually
commute then `exp 𝕂 (∑ i, f i) = ∏ i, exp 𝕂 (f i)`. -/
lemma exp_sum_of_commute {ι} (s : finset ι) (f : ι → 𝔸)
  (h : ∀ (i ∈ s) (j ∈ s), commute (f i) (f j)) :
  exp 𝕂 (∑ i in s, f i) = s.noncomm_prod (λ i, exp 𝕂 (f i))
    (λ i hi j hj, (h i hi j hj).exp 𝕂) :=
begin
  classical,
  induction s using finset.induction_on with a s ha ih,
  { simp },
  rw [finset.noncomm_prod_insert_of_not_mem _ _ _ _ ha, finset.sum_insert ha,
      exp_add_of_commute, ih],
  refine commute.sum_right _ _ _ _,
  intros i hi,
  exact h _ (finset.mem_insert_self _ _) _ (finset.mem_insert_of_mem hi),
end

lemma exp_nsmul (n : ℕ) (x : 𝔸) :
  exp 𝕂 (n • x) = exp 𝕂 x ^ n :=
begin
  induction n with n ih,
  { rw [zero_smul, pow_zero, exp_zero], },
  { rw [succ_nsmul, pow_succ, exp_add_of_commute ((commute.refl x).smul_right n), ih] }
end

variables (𝕂)

/-- Any continuous ring homomorphism commutes with `exp`. -/
lemma map_exp {F} [ring_hom_class F 𝔸 𝔹] (f : F) (hf : continuous f) (x : 𝔸) :
  f (exp 𝕂 x) = exp 𝕂 (f x) :=
map_exp_of_mem_ball f hf x $ (exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _

lemma exp_smul {G} [monoid G] [mul_semiring_action G 𝔸] [has_continuous_const_smul G 𝔸]
  (g : G) (x : 𝔸) :
  exp 𝕂 (g • x) = g • exp 𝕂 x :=
(map_exp 𝕂 (mul_semiring_action.to_ring_hom G 𝔸 g) (continuous_const_smul _) x).symm

lemma exp_units_conj (y : 𝔸ˣ) (x : 𝔸)  :
  exp 𝕂 (y * x * ↑(y⁻¹) : 𝔸) = y * exp 𝕂 x * ↑(y⁻¹) :=
exp_smul _ (conj_act.to_conj_act y) x

lemma exp_units_conj' (y : 𝔸ˣ) (x : 𝔸)  :
  exp 𝕂 (↑(y⁻¹) * x * y) = ↑(y⁻¹) * exp 𝕂 x * y :=
exp_units_conj _ _ _

@[simp] lemma prod.fst_exp [complete_space 𝔹] (x : 𝔸 × 𝔹) : (exp 𝕂 x).fst = exp 𝕂 x.fst :=
map_exp _ (ring_hom.fst 𝔸 𝔹) continuous_fst x

@[simp] lemma prod.snd_exp [complete_space 𝔹] (x : 𝔸 × 𝔹) : (exp 𝕂 x).snd = exp 𝕂 x.snd :=
map_exp _ (ring_hom.snd 𝔸 𝔹) continuous_snd x

@[simp] lemma pi.exp_apply {ι : Type*} {𝔸 : ι → Type*} [fintype ι]
  [Π i, normed_ring (𝔸 i)] [Π i, normed_algebra 𝕂 (𝔸 i)] [Π i, complete_space (𝔸 i)]
  (x : Π i, 𝔸 i) (i : ι) :
  exp 𝕂 x i = exp 𝕂 (x i) :=
begin
  -- Lean struggles to infer this instance due to it wanting `[Π i, semi_normed_ring (𝔸 i)]`
  letI : normed_algebra 𝕂 (Π i, 𝔸 i) := pi.normed_algebra _,
  exact map_exp _ (pi.eval_ring_hom 𝔸 i) (continuous_apply _) x
end

lemma pi.exp_def {ι : Type*} {𝔸 : ι → Type*} [fintype ι]
  [Π i, normed_ring (𝔸 i)] [Π i, normed_algebra 𝕂 (𝔸 i)] [Π i, complete_space (𝔸 i)]
  (x : Π i, 𝔸 i) :
  exp 𝕂 x = λ i, exp 𝕂 (x i) :=
funext $ pi.exp_apply 𝕂 x

lemma function.update_exp {ι : Type*} {𝔸 : ι → Type*} [fintype ι] [decidable_eq ι]
  [Π i, normed_ring (𝔸 i)] [Π i, normed_algebra 𝕂 (𝔸 i)] [Π i, complete_space (𝔸 i)]
  (x : Π i, 𝔸 i) (j : ι) (xj : 𝔸 j) :
  function.update (exp 𝕂 x) j (exp 𝕂 xj) = exp 𝕂 (function.update x j xj) :=
begin
  ext i,
  simp_rw [pi.exp_def],
  exact (function.apply_update (λ i, exp 𝕂) x j xj i).symm,
end

end complete_algebra

lemma algebra_map_exp_comm (x : 𝕂) :
  algebra_map 𝕂 𝔸 (exp 𝕂 x) = exp 𝕂 (algebra_map 𝕂 𝔸 x) :=
algebra_map_exp_comm_of_mem_ball x $
  (exp_series_radius_eq_top 𝕂 𝕂).symm ▸ edist_lt_top _ _

end any_algebra

section division_algebra

variables {𝕂 𝔸 : Type*} [is_R_or_C 𝕂] [normed_division_ring 𝔸] [normed_algebra 𝕂 𝔸]

variables (𝕂)

lemma norm_exp_series_div_summable (x : 𝔸) : summable (λ n, ∥x^n / n!∥) :=
norm_exp_series_div_summable_of_mem_ball 𝕂 x
  ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

variables [complete_space 𝔸]

lemma exp_series_div_summable (x : 𝔸) : summable (λ n, x^n / n!) :=
summable_of_summable_norm (norm_exp_series_div_summable 𝕂 x)

lemma exp_series_div_has_sum_exp (x : 𝔸) : has_sum (λ n, x^n / n!) (exp 𝕂 x):=
exp_series_div_has_sum_exp_of_mem_ball 𝕂 x
  ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

variables {𝕂}

lemma exp_neg (x : 𝔸) : exp 𝕂 (-x) = (exp 𝕂 x)⁻¹ :=
exp_neg_of_mem_ball $ (exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _

lemma exp_zsmul (z : ℤ) (x : 𝔸) : exp 𝕂 (z • x) = (exp 𝕂 x) ^ z :=
begin
  obtain ⟨n, rfl | rfl⟩ := z.eq_coe_or_neg,
  { rw [zpow_coe_nat, coe_nat_zsmul, exp_nsmul] },
  { rw [zpow_neg, zpow_coe_nat, neg_smul, exp_neg, coe_nat_zsmul, exp_nsmul] },
end

lemma exp_conj (y : 𝔸) (x : 𝔸) (hy : y ≠ 0) :
  exp 𝕂 (y * x * y⁻¹) = y * exp 𝕂 x * y⁻¹ :=
exp_units_conj _ (units.mk0 y hy) x

lemma exp_conj' (y : 𝔸) (x : 𝔸)  (hy : y ≠ 0) :
  exp 𝕂 (y⁻¹ * x * y) = y⁻¹ * exp 𝕂 x * y :=
exp_units_conj' _ (units.mk0 y hy) x

end division_algebra

section comm_algebra

variables {𝕂 𝔸 : Type*} [is_R_or_C 𝕂] [normed_comm_ring 𝔸] [normed_algebra 𝕂 𝔸] [complete_space 𝔸]

/-- In a commutative Banach-algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ`,
`exp 𝕂 (x+y) = (exp 𝕂 x) * (exp 𝕂 y)`. -/
lemma exp_add {x y : 𝔸} : exp 𝕂 (x + y) = (exp 𝕂 x) * (exp 𝕂 y) :=
exp_add_of_mem_ball ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)
  ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

/-- A version of `exp_sum_of_commute` for a commutative Banach-algebra. -/
lemma exp_sum {ι} (s : finset ι) (f : ι → 𝔸) :
  exp 𝕂 (∑ i in s, f i) = ∏ i in s, exp 𝕂 (f i) :=
begin
  rw [exp_sum_of_commute, finset.noncomm_prod_eq_prod],
  exact λ i hi j hj, commute.all _ _,
end

end comm_algebra

end is_R_or_C

end normed

section scalar_tower

variables (𝕂 𝕂' 𝔸 : Type*) [field 𝕂] [field 𝕂'] [ring 𝔸] [algebra 𝕂 𝔸] [algebra 𝕂' 𝔸]
  [topological_space 𝔸] [topological_ring 𝔸]

/-- If a normed ring `𝔸` is a normed algebra over two fields, then they define the same
`exp_series` on `𝔸`. -/
lemma exp_series_eq_exp_series (n : ℕ) (x : 𝔸) :
  (exp_series 𝕂 𝔸 n (λ _, x)) = (exp_series 𝕂' 𝔸 n (λ _, x)) :=
by rw [exp_series_apply_eq, exp_series_apply_eq, inv_nat_cast_smul_eq 𝕂 𝕂']

/-- If a normed ring `𝔸` is a normed algebra over two fields, then they define the same
exponential function on `𝔸`. -/
lemma exp_eq_exp : (exp 𝕂 : 𝔸 → 𝔸) = exp 𝕂' :=
begin
  ext,
  rw [exp, exp],
  refine tsum_congr (λ n, _),
  rw exp_series_eq_exp_series 𝕂 𝕂' 𝔸 n x
end

lemma exp_ℝ_ℂ_eq_exp_ℂ_ℂ : (exp ℝ : ℂ → ℂ) = exp ℂ :=
exp_eq_exp ℝ ℂ ℂ

end scalar_tower


<|start_filename|>src/combinatorics/simple_graph/connectivity.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import combinatorics.simple_graph.basic
import combinatorics.simple_graph.subgraph
import data.list
/-!

# Graph connectivity

In a simple graph,

* A *walk* is a finite sequence of adjacent vertices, and can be
  thought of equally well as a sequence of directed edges.

* A *trail* is a walk whose edges each appear no more than once.

* A *path* is a trail whose vertices appear no more than once.

* A *cycle* is a nonempty trail whose first and last vertices are the
  same and whose vertices except for the first appear no more than once.

**Warning:** graph theorists mean something different by "path" than
do homotopy theorists.  A "walk" in graph theory is a "path" in
homotopy theory.  Another warning: some graph theorists use "path" and
"simple path" for "walk" and "path."

Some definitions and theorems have inspiration from multigraph
counterparts in [Chou1994].

## Main definitions

* `simple_graph.walk` (with accompanying pattern definitions
  `simple_graph.walk.nil'` and `simple_graph.walk.cons'`)

* `simple_graph.walk.is_trail`, `simple_graph.walk.is_path`, and `simple_graph.walk.is_cycle`.

* `simple_graph.path`

* `simple_graph.walk.map` and `simple_graph.path.map` for the induced map on walks,
  given an (injective) graph homomorphism.

* `simple_graph.reachable` for the relation of whether there exists
  a walk between a given pair of vertices

* `simple_graph.preconnected` and `simple_graph.connected` are predicates
  on simple graphs for whether every vertex can be reached from every other,
  and in the latter case, whether the vertex type is nonempty.

* `simple_graph.subgraph.connected` gives subgraphs the connectivity
  predicate via `simple_graph.subgraph.coe`.

* `simple_graph.connected_component` is the type of connected components of
  a given graph.

## Tags
walks, trails, paths, circuits, cycles

-/

universes u v

namespace simple_graph
variables {V : Type u} {V' : Type v} (G : simple_graph V) (G' : simple_graph V')

/-- A walk is a sequence of adjacent vertices.  For vertices `u v : V`,
the type `walk u v` consists of all walks starting at `u` and ending at `v`.

We say that a walk *visits* the vertices it contains.  The set of vertices a
walk visits is `simple_graph.walk.support`.

See `simple_graph.walk.nil'` and `simple_graph.walk.cons'` for patterns that
can be useful in definitions since they make the vertices explicit. -/
@[derive decidable_eq]
inductive walk : V → V → Type u
| nil {u : V} : walk u u
| cons {u v w: V} (h : G.adj u v) (p : walk v w) : walk u w

attribute [refl] walk.nil

instance walk.inhabited (v : V) : inhabited (G.walk v v) := ⟨by refl⟩

namespace walk
variables {G}

/-- Pattern to get `walk.nil` with the vertex as an explicit argument. -/
@[pattern] abbreviation nil' (u : V) : G.walk u u := walk.nil

/-- Pattern to get `walk.cons` with the vertices as explicit arguments. -/
@[pattern] abbreviation cons' (u v w : V) (h : G.adj u v) (p : G.walk v w) : G.walk u w :=
walk.cons h p

lemma exists_eq_cons_of_ne : Π {u v : V} (hne : u ≠ v) (p : G.walk u v),
  ∃ (w : V) (h : G.adj u w) (p' : G.walk w v), p = cons h p'
| _ _ hne nil := (hne rfl).elim
| _ _ _ (cons h p') := ⟨_, h, p', rfl⟩

/-- The length of a walk is the number of edges/darts along it. -/
def length : Π {u v : V}, G.walk u v → ℕ
| _ _ nil := 0
| _ _ (cons _ q) := q.length.succ

/-- The concatenation of two compatible walks. -/
@[trans]
def append : Π {u v w : V}, G.walk u v → G.walk v w → G.walk u w
| _ _ _ nil q := q
| _ _ _ (cons h p) q := cons h (p.append q)

/-- The concatenation of the reverse of the first walk with the second walk. -/
protected def reverse_aux : Π {u v w : V}, G.walk u v → G.walk u w → G.walk v w
| _ _ _ nil q := q
| _ _ _ (cons h p) q := reverse_aux p (cons (G.symm h) q)

/-- The walk in reverse. -/
@[symm]
def reverse {u v : V} (w : G.walk u v) : G.walk v u := w.reverse_aux nil

/-- Get the `n`th vertex from a walk, where `n` is generally expected to be
between `0` and `p.length`, inclusive.
If `n` is greater than or equal to `p.length`, the result is the path's endpoint. -/
def get_vert : Π {u v : V} (p : G.walk u v) (n : ℕ), V
| u v nil _ := u
| u v (cons _ _) 0 := u
| u v (cons _ q) (n+1) := q.get_vert n

@[simp] lemma get_vert_zero {u v} (w : G.walk u v) : w.get_vert 0 = u :=
by { cases w; refl }

lemma get_vert_of_length_le {u v} (w : G.walk u v) {i : ℕ} (hi : w.length ≤ i) :
  w.get_vert i = v :=
begin
  induction w with _ x y z hxy wyz IH generalizing i,
  { refl },
  { cases i,
    { cases hi, },
    { exact IH (nat.succ_le_succ_iff.1 hi) } }
end

@[simp] lemma get_vert_length {u v} (w : G.walk u v) : w.get_vert w.length = v :=
w.get_vert_of_length_le rfl.le

lemma adj_get_vert_succ {u v} (w : G.walk u v) {i : ℕ} (hi : i < w.length) :
  G.adj (w.get_vert i) (w.get_vert (i+1)) :=
begin
  induction w with _ x y z hxy wyz IH generalizing i,
  { cases hi, },
  { cases i,
    { simp [get_vert, hxy] },
    { exact IH (nat.succ_lt_succ_iff.1 hi) } },
end

@[simp] lemma cons_append {u v w x : V} (h : G.adj u v) (p : G.walk v w) (q : G.walk w x) :
  (cons h p).append q = cons h (p.append q) := rfl

@[simp] lemma cons_nil_append {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h nil).append p = cons h p := rfl

@[simp] lemma append_nil : Π {u v : V} (p : G.walk u v), p.append nil = p
| _ _ nil := rfl
| _ _ (cons h p) := by rw [cons_append, append_nil]

@[simp] lemma nil_append {u v : V} (p : G.walk u v) : nil.append p = p := rfl

lemma append_assoc : Π {u v w x : V} (p : G.walk u v) (q : G.walk v w) (r : G.walk w x),
  p.append (q.append r) = (p.append q).append r
| _ _ _ _ nil _ _ := rfl
| _ _ _ _ (cons h p') q r := by { dunfold append, rw append_assoc, }

@[simp] lemma reverse_nil {u : V} : (nil : G.walk u u).reverse = nil := rfl

lemma reverse_singleton {u v : V} (h : G.adj u v) :
  (cons h nil).reverse = cons (G.symm h) nil := rfl

@[simp] lemma cons_reverse_aux {u v w x : V} (p : G.walk u v) (q : G.walk w x) (h : G.adj w u) :
  (cons h p).reverse_aux q = p.reverse_aux (cons (G.symm h) q) := rfl

@[simp] protected lemma append_reverse_aux : Π {u v w x : V}
  (p : G.walk u v) (q : G.walk v w) (r : G.walk u x),
  (p.append q).reverse_aux r = q.reverse_aux (p.reverse_aux r)
| _ _ _ _ nil _ _ := rfl
| _ _ _ _ (cons h p') q r := append_reverse_aux p' q (cons (G.symm h) r)

@[simp] protected lemma reverse_aux_append : Π {u v w x : V}
  (p : G.walk u v) (q : G.walk u w) (r : G.walk w x),
  (p.reverse_aux q).append r = p.reverse_aux (q.append r)
| _ _ _ _ nil _ _ := rfl
| _ _ _ _ (cons h p') q r := by simp [reverse_aux_append p' (cons (G.symm h) q) r]

protected lemma reverse_aux_eq_reverse_append {u v w : V} (p : G.walk u v) (q : G.walk u w) :
  p.reverse_aux q = p.reverse.append q :=
by simp [reverse]

@[simp] lemma reverse_cons {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h p).reverse = p.reverse.append (cons (G.symm h) nil) :=
by simp [reverse]

@[simp] lemma reverse_append {u v w : V} (p : G.walk u v) (q : G.walk v w) :
  (p.append q).reverse = q.reverse.append p.reverse :=
by simp [reverse]

@[simp] lemma reverse_reverse : Π {u v : V} (p : G.walk u v), p.reverse.reverse = p
| _ _ nil := rfl
| _ _ (cons h p) := by simp [reverse_reverse]

@[simp] lemma length_nil {u : V} : (nil : G.walk u u).length = 0 := rfl

@[simp] lemma length_cons {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h p).length = p.length + 1 := rfl

@[simp] lemma length_append : Π {u v w : V} (p : G.walk u v) (q : G.walk v w),
  (p.append q).length = p.length + q.length
| _ _ _ nil _ := by simp
| _ _ _ (cons _ _) _ := by simp [length_append, add_left_comm, add_comm]

@[simp] protected lemma length_reverse_aux : Π {u v w : V} (p : G.walk u v) (q : G.walk u w),
  (p.reverse_aux q).length = p.length + q.length
| _ _ _ nil _ := by simp!
| _ _ _ (cons _ _) _ := by simp [length_reverse_aux, nat.add_succ, nat.succ_add]

@[simp] lemma length_reverse {u v : V} (p : G.walk u v) : p.reverse.length = p.length :=
by simp [reverse]

lemma eq_of_length_eq_zero : Π {u v : V} {p : G.walk u v}, p.length = 0 → u = v
| _ _ nil _ := rfl

@[simp] lemma exists_length_eq_zero_iff {u v : V} : (∃ (p : G.walk u v), p.length = 0) ↔ u = v :=
begin
  split,
  { rintro ⟨p, hp⟩,
    exact eq_of_length_eq_zero hp, },
  { rintro rfl,
    exact ⟨nil, rfl⟩, },
end

@[simp] lemma length_eq_zero_iff {u : V} {p : G.walk u u} : p.length = 0 ↔ p = nil :=
by cases p; simp

/-- The `support` of a walk is the list of vertices it visits in order. -/
def support : Π {u v : V}, G.walk u v → list V
| u v nil := [u]
| u v (cons h p) := u :: p.support

/-- The `darts` of a walk is the list of darts it visits in order. -/
def darts : Π {u v : V}, G.walk u v → list G.dart
| u v nil := []
| u v (cons h p) := ⟨(u, _), h⟩ :: p.darts

/-- The `edges` of a walk is the list of edges it visits in order.
This is defined to be the list of edges underlying `simple_graph.walk.darts`. -/
def edges {u v : V} (p : G.walk u v) : list (sym2 V) := p.darts.map dart.edge

@[simp] lemma support_nil {u : V} : (nil : G.walk u u).support = [u] := rfl

@[simp] lemma support_cons {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h p).support = u :: p.support := rfl

lemma support_append {u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  (p.append p').support = p.support ++ p'.support.tail :=
by induction p; cases p'; simp [*]

@[simp]
lemma support_reverse {u v : V} (p : G.walk u v) : p.reverse.support = p.support.reverse :=
by induction p; simp [support_append, *]

lemma support_ne_nil {u v : V} (p : G.walk u v) : p.support ≠ [] :=
by cases p; simp

lemma tail_support_append {u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  (p.append p').support.tail = p.support.tail ++ p'.support.tail :=
by rw [support_append, list.tail_append_of_ne_nil _ _ (support_ne_nil _)]

lemma support_eq_cons {u v : V} (p : G.walk u v) : p.support = u :: p.support.tail :=
by cases p; simp

@[simp] lemma start_mem_support {u v : V} (p : G.walk u v) : u ∈ p.support :=
by cases p; simp

@[simp] lemma end_mem_support {u v : V} (p : G.walk u v) : v ∈ p.support :=
by induction p; simp [*]

lemma mem_support_iff {u v w : V} (p : G.walk u v) :
  w ∈ p.support ↔ w = u ∨ w ∈ p.support.tail :=
by cases p; simp

lemma mem_support_nil_iff {u v : V} : u ∈ (nil : G.walk v v).support ↔ u = v := by simp

@[simp]
lemma mem_tail_support_append_iff {t u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  t ∈ (p.append p').support.tail ↔ t ∈ p.support.tail ∨ t ∈ p'.support.tail :=
by rw [tail_support_append, list.mem_append]

@[simp] lemma end_mem_tail_support_of_ne {u v : V} (h : u ≠ v) (p : G.walk u v) :
  v ∈ p.support.tail :=
by { obtain ⟨_, _, _, rfl⟩ := exists_eq_cons_of_ne h p, simp }

@[simp]
lemma mem_support_append_iff {t u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  t ∈ (p.append p').support ↔ t ∈ p.support ∨ t ∈ p'.support :=
begin
  simp only [mem_support_iff, mem_tail_support_append_iff],
  by_cases h : t = v; by_cases h' : t = u;
  subst_vars;
  try { have := ne.symm h' };
  simp [*],
end

lemma coe_support {u v : V} (p : G.walk u v) :
  (p.support : multiset V) = {u} + p.support.tail :=
by cases p; refl

lemma coe_support_append {u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  ((p.append p').support : multiset V) = {u} + p.support.tail + p'.support.tail :=
by rw [support_append, ←multiset.coe_add, coe_support]

lemma coe_support_append' [decidable_eq V] {u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  ((p.append p').support : multiset V) = p.support + p'.support - {v} :=
begin
  rw [support_append, ←multiset.coe_add],
  simp only [coe_support],
  rw add_comm {v},
  simp only [← add_assoc, add_tsub_cancel_right],
end

lemma chain_adj_support : Π {u v w : V} (h : G.adj u v) (p : G.walk v w),
  list.chain G.adj u p.support
| _ _ _ h nil := list.chain.cons h list.chain.nil
| _ _ _ h (cons h' p) := list.chain.cons h (chain_adj_support h' p)

lemma chain'_adj_support : Π {u v : V} (p : G.walk u v), list.chain' G.adj p.support
| _ _ nil := list.chain.nil
| _ _ (cons h p) := chain_adj_support h p

lemma chain_dart_adj_darts : Π {d : G.dart} {v w : V} (h : d.snd = v) (p : G.walk v w),
  list.chain G.dart_adj d p.darts
| _ _ _ h nil := list.chain.nil
| _ _ _ h (cons h' p) := list.chain.cons h (chain_dart_adj_darts (by exact rfl) p)

lemma chain'_dart_adj_darts : Π {u v : V} (p : G.walk u v), list.chain' G.dart_adj p.darts
| _ _ nil := trivial
| _ _ (cons h p) := chain_dart_adj_darts rfl p

/-- Every edge in a walk's edge list is an edge of the graph.
It is written in this form (rather than using `⊆`) to avoid unsightly coercions. -/
lemma edges_subset_edge_set : Π {u v : V} (p : G.walk u v) ⦃e : sym2 V⦄
  (h : e ∈ p.edges), e ∈ G.edge_set
| _ _ (cons h' p') e h := by rcases h with ⟨rfl, h⟩; solve_by_elim

@[simp] lemma darts_nil {u : V} : (nil : G.walk u u).darts = [] := rfl

@[simp] lemma darts_cons {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h p).darts = ⟨(u, v), h⟩ :: p.darts := rfl

@[simp] lemma darts_append {u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  (p.append p').darts = p.darts ++ p'.darts :=
by induction p; simp [*]

@[simp] lemma darts_reverse {u v : V} (p : G.walk u v) :
  p.reverse.darts = (p.darts.map dart.symm).reverse :=
by induction p; simp [*, sym2.eq_swap]

lemma cons_map_snd_darts {u v : V} (p : G.walk u v) :
  u :: p.darts.map dart.snd = p.support :=
by induction p; simp! [*]

lemma map_snd_darts {u v : V} (p : G.walk u v) :
  p.darts.map dart.snd = p.support.tail :=
by simpa using congr_arg list.tail (cons_map_snd_darts p)

lemma map_fst_darts_append {u v : V} (p : G.walk u v) :
  p.darts.map dart.fst ++ [v] = p.support :=
by induction p; simp! [*]

lemma map_fst_darts {u v : V} (p : G.walk u v) :
  p.darts.map dart.fst = p.support.init :=
by simpa! using congr_arg list.init (map_fst_darts_append p)

@[simp] lemma edges_nil {u : V} : (nil : G.walk u u).edges = [] := rfl

@[simp] lemma edges_cons {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h p).edges = ⟦(u, v)⟧ :: p.edges := rfl

@[simp] lemma edges_append {u v w : V} (p : G.walk u v) (p' : G.walk v w) :
  (p.append p').edges = p.edges ++ p'.edges :=
by simp [edges]

@[simp] lemma edges_reverse {u v : V} (p : G.walk u v) : p.reverse.edges = p.edges.reverse :=
by simp [edges]

@[simp] lemma length_support {u v : V} (p : G.walk u v) : p.support.length = p.length + 1 :=
by induction p; simp *

@[simp] lemma length_darts {u v : V} (p : G.walk u v) : p.darts.length = p.length :=
by induction p; simp *

@[simp] lemma length_edges {u v : V} (p : G.walk u v) : p.edges.length = p.length :=
by simp [edges]

lemma dart_fst_mem_support_of_mem_darts :
  Π {u v : V} (p : G.walk u v) {d : G.dart}, d ∈ p.darts → d.fst ∈ p.support
| u v (cons h p') d hd := begin
  simp only [support_cons, darts_cons, list.mem_cons_iff] at hd ⊢,
  rcases hd with (rfl|hd),
  { exact or.inl rfl, },
  { exact or.inr (dart_fst_mem_support_of_mem_darts _ hd), },
end

lemma dart_snd_mem_support_of_mem_darts :
  Π {u v : V} (p : G.walk u v) {d : G.dart}, d ∈ p.darts → d.snd ∈ p.support
| u v (cons h p') d hd := begin
  simp only [support_cons, darts_cons, list.mem_cons_iff] at hd ⊢,
  rcases hd with (rfl|hd),
  { simp },
  { exact or.inr (dart_snd_mem_support_of_mem_darts _ hd), },
end

lemma mem_support_of_mem_edges {t u v w : V} (p : G.walk v w) (he : ⟦(t, u)⟧ ∈ p.edges) :
  t ∈ p.support :=
begin
  obtain ⟨d, hd, he⟩ := list.mem_map.mp he,
  rw dart_edge_eq_mk_iff' at he,
  rcases he with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩,
  { exact dart_fst_mem_support_of_mem_darts _ hd, },
  { exact dart_snd_mem_support_of_mem_darts _ hd, },
end

lemma darts_nodup_of_support_nodup {u v : V} {p : G.walk u v} (h : p.support.nodup) :
  p.darts.nodup :=
begin
  induction p,
  { simp, },
  { simp only [darts_cons, support_cons, list.nodup_cons] at h ⊢,
    refine ⟨λ h', h.1 (dart_fst_mem_support_of_mem_darts p_p h'), p_ih h.2⟩, }
end

lemma edges_nodup_of_support_nodup {u v : V} {p : G.walk u v} (h : p.support.nodup) :
  p.edges.nodup :=
begin
  induction p,
  { simp, },
  { simp only [edges_cons, support_cons, list.nodup_cons] at h ⊢,
    exact ⟨λ h', h.1 (mem_support_of_mem_edges p_p h'), p_ih h.2⟩, }
end

/-! ### Trails, paths, circuits, cycles -/

/-- A *trail* is a walk with no repeating edges. -/
structure is_trail {u v : V} (p : G.walk u v) : Prop :=
(edges_nodup : p.edges.nodup)

/-- A *path* is a walk with no repeating vertices.
Use `simple_graph.walk.is_path.mk'` for a simpler constructor. -/
structure is_path {u v : V} (p : G.walk u v) extends to_trail : is_trail p : Prop :=
(support_nodup : p.support.nodup)

/-- A *circuit* at `u : V` is a nonempty trail beginning and ending at `u`. -/
structure is_circuit {u : V} (p : G.walk u u) extends to_trail : is_trail p : Prop :=
(ne_nil : p ≠ nil)

/-- A *cycle* at `u : V` is a circuit at `u` whose only repeating vertex
is `u` (which appears exactly twice). -/
structure is_cycle {u : V} (p : G.walk u u)
  extends to_circuit : is_circuit p : Prop :=
(support_nodup : p.support.tail.nodup)

lemma is_trail_def {u v : V} (p : G.walk u v) : p.is_trail ↔ p.edges.nodup :=
⟨is_trail.edges_nodup, λ h, ⟨h⟩⟩

lemma is_path.mk' {u v : V} {p : G.walk u v} (h : p.support.nodup) : is_path p :=
⟨⟨edges_nodup_of_support_nodup h⟩, h⟩

lemma is_path_def {u v : V} (p : G.walk u v) : p.is_path ↔ p.support.nodup :=
⟨is_path.support_nodup, is_path.mk'⟩

lemma is_cycle_def {u : V} (p : G.walk u u) :
  p.is_cycle ↔ is_trail p ∧ p ≠ nil ∧ p.support.tail.nodup :=
iff.intro (λ h, ⟨h.1.1, h.1.2, h.2⟩) (λ h, ⟨⟨h.1, h.2.1⟩, h.2.2⟩)

@[simp] lemma is_trail.nil {u : V} : (nil : G.walk u u).is_trail :=
⟨by simp [edges]⟩

lemma is_trail.of_cons {u v w : V} {h : G.adj u v} {p : G.walk v w} :
  (cons h p).is_trail → p.is_trail :=
by simp [is_trail_def]

@[simp] lemma cons_is_trail_iff {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h p).is_trail ↔ p.is_trail ∧ ⟦(u, v)⟧ ∉ p.edges :=
by simp [is_trail_def, and_comm]

lemma is_trail.reverse {u v : V} (p : G.walk u v) (h : p.is_trail) : p.reverse.is_trail :=
by simpa [is_trail_def] using h

@[simp] lemma reverse_is_trail_iff {u v : V} (p : G.walk u v) : p.reverse.is_trail ↔ p.is_trail :=
by split; { intro h, convert h.reverse _, try { rw reverse_reverse } }

lemma is_trail.of_append_left {u v w : V} {p : G.walk u v} {q : G.walk v w}
  (h : (p.append q).is_trail) : p.is_trail :=
by { rw [is_trail_def, edges_append, list.nodup_append] at h, exact ⟨h.1⟩ }

lemma is_trail.of_append_right {u v w : V} {p : G.walk u v} {q : G.walk v w}
  (h : (p.append q).is_trail) : q.is_trail :=
by { rw [is_trail_def, edges_append, list.nodup_append] at h, exact ⟨h.2.1⟩ }

lemma is_trail.count_edges_le_one [decidable_eq V] {u v : V}
  {p : G.walk u v} (h : p.is_trail) (e : sym2 V) : p.edges.count e ≤ 1 :=
list.nodup_iff_count_le_one.mp h.edges_nodup e

lemma is_trail.count_edges_eq_one [decidable_eq V] {u v : V}
  {p : G.walk u v} (h : p.is_trail) {e : sym2 V} (he : e ∈ p.edges) :
  p.edges.count e = 1 :=
list.count_eq_one_of_mem h.edges_nodup he

@[simp] lemma is_path.nil {u : V} : (nil : G.walk u u).is_path :=
by { fsplit; simp }

lemma is_path.of_cons {u v w : V} {h : G.adj u v} {p : G.walk v w} :
  (cons h p).is_path → p.is_path :=
by simp [is_path_def]

@[simp] lemma cons_is_path_iff {u v w : V} (h : G.adj u v) (p : G.walk v w) :
  (cons h p).is_path ↔ p.is_path ∧ u ∉ p.support :=
by split; simp [is_path_def] { contextual := tt }

lemma is_path.reverse {u v : V} {p : G.walk u v} (h : p.is_path) : p.reverse.is_path :=
by simpa [is_path_def] using h

@[simp] lemma is_path_reverse_iff {u v : V} (p : G.walk u v) : p.reverse.is_path ↔ p.is_path :=
by split; intro h; convert h.reverse; simp

lemma is_path.of_append_left {u v w : V} {p : G.walk u v} {q : G.walk v w} :
  (p.append q).is_path → p.is_path :=
by { simp only [is_path_def, support_append], exact list.nodup.of_append_left }

lemma is_path.of_append_right {u v w : V} {p : G.walk u v} {q : G.walk v w}
  (h : (p.append q).is_path) : q.is_path :=
begin
  rw ←is_path_reverse_iff at h ⊢,
  rw reverse_append at h,
  apply h.of_append_left,
end

/-! ### Walk decompositions -/

section walk_decomp
variables [decidable_eq V]

/-- Given a vertex in the support of a path, give the path up until (and including) that vertex. -/
def take_until : Π {v w : V} (p : G.walk v w) (u : V) (h : u ∈ p.support), G.walk v u
| v w nil u h := by rw mem_support_nil_iff.mp h
| v w (cons r p) u h :=
  if hx : v = u
  then by subst u
  else cons r (take_until p _ $ h.cases_on (λ h', (hx h'.symm).elim) id)

/-- Given a vertex in the support of a path, give the path from (and including) that vertex to
the end. In other words, drop vertices from the front of a path until (and not including)
that vertex. -/
def drop_until : Π {v w : V} (p : G.walk v w) (u : V) (h : u ∈ p.support), G.walk u w
| v w nil u h := by rw mem_support_nil_iff.mp h
| v w (cons r p) u h :=
  if hx : v = u
  then by { subst u, exact cons r p }
  else drop_until p _ $ h.cases_on (λ h', (hx h'.symm).elim) id

/-- The `take_until` and `drop_until` functions split a walk into two pieces.
The lemma `count_support_take_until_eq_one` specifies where this split occurs. -/
@[simp]
lemma take_spec {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.take_until u h).append (p.drop_until u h) = p :=
begin
  induction p,
  { rw mem_support_nil_iff at h,
    subst u,
    refl, },
  { obtain (rfl|h) := h,
    { simp! },
    { simp! only,
      split_ifs with h'; subst_vars; simp [*], } },
end

@[simp]
lemma count_support_take_until_eq_one {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.take_until u h).support.count u = 1 :=
begin
  induction p,
  { rw mem_support_nil_iff at h,
    subst u,
    simp!, },
  { obtain (rfl|h) := h,
    { simp! },
    { simp! only,
      split_ifs with h'; rw eq_comm at h'; subst_vars; simp! [*, list.count_cons], } },
end

lemma count_edges_take_until_le_one {u v w : V} (p : G.walk v w) (h : u ∈ p.support) (x : V) :
  (p.take_until u h).edges.count ⟦(u, x)⟧ ≤ 1 :=
begin
  induction p with u' u' v' w' ha p' ih,
  { rw mem_support_nil_iff at h,
    subst u,
    simp!, },
  { obtain (rfl|h) := h,
    { simp!, },
    { simp! only,
      split_ifs with h',
      { subst h',
        simp, },
      { rw [edges_cons, list.count_cons],
        split_ifs with h'',
        { rw sym2.eq_iff at h'',
          obtain (⟨rfl,rfl⟩|⟨rfl,rfl⟩) := h'',
          { exact (h' rfl).elim },
          { cases p'; simp! } },
        { apply ih, } } } },
end

lemma support_take_until_subset {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.take_until u h).support ⊆ p.support :=
λ x hx, by { rw [← take_spec p h, mem_support_append_iff], exact or.inl hx }

lemma support_drop_until_subset {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.drop_until u h).support ⊆ p.support :=
λ x hx, by { rw [← take_spec p h, mem_support_append_iff], exact or.inr hx }

lemma darts_take_until_subset {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.take_until u h).darts ⊆ p.darts :=
λ x hx, by { rw [← take_spec p h, darts_append, list.mem_append], exact or.inl hx }

lemma darts_drop_until_subset {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.drop_until u h).darts ⊆ p.darts :=
λ x hx, by { rw [← take_spec p h, darts_append, list.mem_append], exact or.inr hx }

lemma edges_take_until_subset {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.take_until u h).edges ⊆ p.edges :=
list.map_subset _ (p.darts_take_until_subset h)

lemma edges_drop_until_subset {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.drop_until u h).edges ⊆ p.edges :=
list.map_subset _ (p.darts_drop_until_subset h)

lemma length_take_until_le {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.take_until u h).length ≤ p.length :=
begin
  have := congr_arg walk.length (p.take_spec h),
  rw [length_append] at this,
  exact nat.le.intro this,
end

lemma length_drop_until_le {u v w : V} (p : G.walk v w) (h : u ∈ p.support) :
  (p.drop_until u h).length ≤ p.length :=
begin
  have := congr_arg walk.length (p.take_spec h),
  rw [length_append, add_comm] at this,
  exact nat.le.intro this,
end

protected
lemma is_trail.take_until {u v w : V} {p : G.walk v w} (hc : p.is_trail) (h : u ∈ p.support) :
  (p.take_until u h).is_trail :=
is_trail.of_append_left (by rwa ← take_spec _ h at hc)

protected
lemma is_trail.drop_until {u v w : V} {p : G.walk v w} (hc : p.is_trail) (h : u ∈ p.support) :
  (p.drop_until u h).is_trail :=
is_trail.of_append_right (by rwa ← take_spec _ h at hc)

protected
lemma is_path.take_until {u v w : V} {p : G.walk v w} (hc : p.is_path) (h : u ∈ p.support) :
  (p.take_until u h).is_path :=
is_path.of_append_left (by rwa ← take_spec _ h at hc)

protected
lemma is_path.drop_until {u v w : V} (p : G.walk v w) (hc : p.is_path) (h : u ∈ p.support) :
  (p.drop_until u h).is_path :=
is_path.of_append_right (by rwa ← take_spec _ h at hc)

/-- Rotate a loop walk such that it is centered at the given vertex. -/
def rotate {u v : V} (c : G.walk v v) (h : u ∈ c.support) : G.walk u u :=
(c.drop_until u h).append (c.take_until u h)

@[simp]
lemma support_rotate {u v : V} (c : G.walk v v) (h : u ∈ c.support) :
  (c.rotate h).support.tail ~r c.support.tail :=
begin
  simp only [rotate, tail_support_append],
  apply list.is_rotated.trans list.is_rotated_append,
  rw [←tail_support_append, take_spec],
end

lemma rotate_darts {u v : V} (c : G.walk v v) (h : u ∈ c.support) :
  (c.rotate h).darts ~r c.darts :=
begin
  simp only [rotate, darts_append],
  apply list.is_rotated.trans list.is_rotated_append,
  rw [←darts_append, take_spec],
end

lemma rotate_edges {u v : V} (c : G.walk v v) (h : u ∈ c.support) :
  (c.rotate h).edges ~r c.edges :=
(rotate_darts c h).map _

protected
lemma is_trail.rotate {u v : V} {c : G.walk v v} (hc : c.is_trail) (h : u ∈ c.support) :
  (c.rotate h).is_trail :=
begin
  rw [is_trail_def, (c.rotate_edges h).perm.nodup_iff],
  exact hc.edges_nodup,
end

protected
lemma is_circuit.rotate {u v : V} {c : G.walk v v} (hc : c.is_circuit) (h : u ∈ c.support) :
  (c.rotate h).is_circuit :=
begin
  refine ⟨hc.to_trail.rotate _, _⟩,
  cases c,
  { exact (hc.ne_nil rfl).elim, },
  { intro hn,
    have hn' := congr_arg length hn,
    rw [rotate, length_append, add_comm, ← length_append, take_spec] at hn',
    simpa using hn', },
end

protected
lemma is_cycle.rotate {u v : V} {c : G.walk v v} (hc : c.is_cycle) (h : u ∈ c.support) :
  (c.rotate h).is_cycle :=
begin
  refine ⟨hc.to_circuit.rotate _, _⟩,
  rw list.is_rotated.nodup_iff (support_rotate _ _),
  exact hc.support_nodup,
end

end walk_decomp

end walk

/-! ### Walks to paths -/

/-- The type for paths between two vertices. -/
abbreviation path (u v : V) := {p : G.walk u v // p.is_path}

namespace walk
variables {G} [decidable_eq V]

/-- Given a walk, produces a walk from it by bypassing subwalks between repeated vertices.
The result is a path, as shown in `simple_graph.walk.bypass_is_path`.
This is packaged up in `simple_graph.walk.to_path`. -/
def bypass : Π {u v : V}, G.walk u v → G.walk u v
| u v nil := nil
| u v (cons ha p) :=
  let p' := p.bypass
  in if hs : u ∈ p'.support
     then p'.drop_until u hs
     else cons ha p'

lemma bypass_is_path {u v : V} (p : G.walk u v) : p.bypass.is_path :=
begin
  induction p,
  { simp!, },
  { simp only [bypass],
    split_ifs,
    { apply is_path.drop_until,
      assumption, },
    { simp [*, cons_is_path_iff], } },
end

lemma length_bypass_le {u v : V} (p : G.walk u v) : p.bypass.length ≤ p.length :=
begin
  induction p,
  { refl },
  { simp only [bypass],
    split_ifs,
    { transitivity,
      apply length_drop_until_le,
      rw [length_cons],
      exact le_add_right p_ih, },
    { rw [length_cons, length_cons],
      exact add_le_add_right p_ih 1, } },
end

/-- Given a walk, produces a path with the same endpoints using `simple_graph.walk.bypass`. -/
def to_path {u v : V} (p : G.walk u v) : G.path u v := ⟨p.bypass, p.bypass_is_path⟩

lemma support_bypass_subset {u v : V} (p : G.walk u v) : p.bypass.support ⊆ p.support :=
begin
  induction p,
  { simp!, },
  { simp! only,
    split_ifs,
    { apply list.subset.trans (support_drop_until_subset _ _),
      apply list.subset_cons_of_subset,
      assumption, },
    { rw support_cons,
      apply list.cons_subset_cons,
      assumption, }, },
end

lemma support_to_path_subset {u v : V} (p : G.walk u v) :
  (p.to_path : G.walk u v).support ⊆ p.support :=
support_bypass_subset _

lemma darts_bypass_subset {u v : V} (p : G.walk u v) : p.bypass.darts ⊆ p.darts :=
begin
  induction p,
  { simp!, },
  { simp! only,
    split_ifs,
    { apply list.subset.trans (darts_drop_until_subset _ _),
      apply list.subset_cons_of_subset _ p_ih, },
    { rw darts_cons,
      exact list.cons_subset_cons _ p_ih, }, },
end

lemma edges_bypass_subset {u v : V} (p : G.walk u v) : p.bypass.edges ⊆ p.edges :=
list.map_subset _ p.darts_bypass_subset

lemma darts_to_path_subset {u v : V} (p : G.walk u v) :
  (p.to_path : G.walk u v).darts ⊆ p.darts :=
darts_bypass_subset _

lemma edges_to_path_subset {u v : V} (p : G.walk u v) :
  (p.to_path : G.walk u v).edges ⊆ p.edges :=
edges_bypass_subset _

end walk

/-! ## Mapping paths -/

namespace walk
variables {G G'}

/-- Given a graph homomorphism, map walks to walks. -/
protected def map (f : G →g G') : Π {u v : V}, G.walk u v → G'.walk (f u) (f v)
| _ _ nil := nil
| _ _ (cons h p) := cons (f.map_adj h) (map p)

variables (f : G →g G') {u v : V} (p : G.walk u v)

@[simp] lemma map_nil : (nil : G.walk u u).map f = nil := rfl

@[simp] lemma map_cons {w : V} (h : G.adj w u) :
  (cons h p).map f = cons (f.map_adj h) (p.map f) := rfl

@[simp] lemma length_map : (p.map f).length = p.length :=
by induction p; simp [*]

lemma map_append {u v w : V} (p : G.walk u v) (q : G.walk v w) :
  (p.append q).map f = (p.map f).append (q.map f) :=
by induction p; simp [*]

@[simp] lemma reverse_map : (p.map f).reverse = p.reverse.map f :=
by induction p; simp [map_append, *]

@[simp] lemma support_map : (p.map f).support = p.support.map f :=
by induction p; simp [*]

@[simp] lemma darts_map : (p.map f).darts = p.darts.map f.map_dart :=
by induction p; simp [*]

@[simp] lemma edges_map : (p.map f).edges = p.edges.map (sym2.map f) :=
by induction p; simp [*]

variables {p f}

lemma map_is_path_of_injective (hinj : function.injective f) (hp : p.is_path) :
  (p.map f).is_path :=
begin
  induction p with w u v w huv hvw ih,
  { simp, },
  { rw walk.cons_is_path_iff at hp,
    simp [ih hp.1],
    intros x hx hf,
    cases hinj hf,
    exact hp.2 hx, },
end

protected lemma is_path.of_map {f : G →g G'} (hp : (p.map f).is_path) : p.is_path :=
begin
  induction p with w u v w huv hvw ih,
  { simp },
  { rw [map_cons, walk.cons_is_path_iff, support_map] at hp,
    rw walk.cons_is_path_iff,
    cases hp with hp1 hp2,
    refine ⟨ih hp1, _⟩,
    contrapose! hp2,
    exact list.mem_map_of_mem f hp2, }
end

lemma map_is_path_iff_of_injective (hinj : function.injective f) :
  (p.map f).is_path ↔ p.is_path :=
⟨is_path.of_map, map_is_path_of_injective hinj⟩

variables (p f)

lemma map_injective_of_injective {f : G →g G'} (hinj : function.injective f) (u v : V) :
  function.injective (walk.map f : G.walk u v → G'.walk (f u) (f v)) :=
begin
  intros p p' h,
  induction p with _ _ _ _ _ _ ih generalizing p',
  { cases p',
    { refl },
    simpa using h, },
  { induction p',
    { simpa using h, },
    { simp only [map_cons] at h,
      cases hinj h.1,
      simp only [eq_self_iff_true, heq_iff_eq, true_and],
      apply ih,
      simpa using h.2, } },
end

end walk

namespace path
variables {G G'}

/-- Given an injective graph homomorphism, map paths to paths. -/
@[simps] protected def map (f : G →g G') (hinj : function.injective f) {u v : V} (p : G.path u v) :
  G'.path (f u) (f v) :=
⟨walk.map f p, walk.map_is_path_of_injective hinj p.2⟩

lemma map_injective {f : G →g G'} (hinj : function.injective f) (u v : V) :
  function.injective (path.map f hinj : G.path u v → G'.path (f u) (f v)) :=
begin
  rintros ⟨p, hp⟩ ⟨p', hp'⟩ h,
  simp only [path.map, subtype.coe_mk] at h,
  simp [walk.map_injective_of_injective hinj u v h],
end

/-- Given a graph embedding, map paths to paths. -/
@[simps] protected def map_embedding (f : G ↪g G') {u v : V} (p : G.path u v) :
  G'.path (f u) (f v) :=
path.map f.to_hom f.injective p

lemma map_embedding_injective (f : G ↪g G') (u v : V) :
  function.injective (path.map_embedding f : G.path u v → G'.path (f u) (f v)) :=
map_injective f.injective u v

end path

/-! ## Deleting edges -/

namespace walk
variables {G}

/-- Given a walk that avoids a set of edges, produce a walk in the graph
with those edges deleted. -/
@[simp]
def to_delete_edges (s : set (sym2 V)) :
  Π {v w : V} (p : G.walk v w) (hp : ∀ e, e ∈ p.edges → ¬ e ∈ s), (G.delete_edges s).walk v w
| _ _ nil _ := nil
| _ _ (cons' u v w huv p) hp := cons ((G.delete_edges_adj _ _ _).mpr ⟨huv, hp ⟦(u, v)⟧ (by simp)⟩)
                                (p.to_delete_edges (λ e he, hp e (by simp [he])))

/-- Given a walk that avoids an edge, create a walk in the subgraph with that edge deleted.
This is an abbreviation for `simple_graph.walk.to_delete_edges`. -/
abbreviation to_delete_edge {v w : V} (e : sym2 V) (p : G.walk v w) (hp : e ∉ p.edges) :
  (G.delete_edges {e}).walk v w :=
p.to_delete_edges {e} (λ e', by { contrapose!, simp [hp] { contextual := tt } })

@[simp]
lemma map_to_delete_edges_eq (s : set (sym2 V)) {v w : V} {p : G.walk v w} (hp) :
  walk.map (hom.map_spanning_subgraphs (G.delete_edges_le s)) (p.to_delete_edges s hp) = p :=
by induction p; simp [*]

lemma is_path.to_delete_edges (s : set (sym2 V))
  {v w : V} {p : G.walk v w} (h : p.is_path) (hp) :
  (p.to_delete_edges s hp).is_path :=
by { rw ← map_to_delete_edges_eq s hp at h, exact h.of_map }

end walk

/-! ## `reachable` and `connected` -/

/-- Two vertices are *reachable* if there is a walk between them.
This is equivalent to `relation.refl_trans_gen` of `G.adj`.
See `simple_graph.reachable_iff_refl_trans_gen`. -/
def reachable (u v : V) : Prop := nonempty (G.walk u v)

variables {G}

lemma reachable_iff_nonempty_univ {u v : V} :
  G.reachable u v ↔ (set.univ : set (G.walk u v)).nonempty :=
set.nonempty_iff_univ_nonempty

protected lemma reachable.elim {p : Prop} {u v : V}
  (h : G.reachable u v) (hp : G.walk u v → p) : p :=
nonempty.elim h hp

protected lemma reachable.elim_path {p : Prop} {u v : V}
  (h : G.reachable u v) (hp : G.path u v → p) : p :=
begin
  classical,
  exact h.elim (λ q, hp q.to_path),
end

@[refl] protected lemma reachable.refl (u : V) : G.reachable u u := by { fsplit, refl }
protected lemma reachable.rfl {u : V} : G.reachable u u := reachable.refl _

@[symm] protected lemma reachable.symm {u v : V} (huv : G.reachable u v) : G.reachable v u :=
huv.elim (λ p, ⟨p.reverse⟩)

@[trans] protected lemma reachable.trans {u v w : V}
  (huv : G.reachable u v) (hvw : G.reachable v w) :
  G.reachable u w :=
huv.elim (λ puv, hvw.elim (λ pvw, ⟨puv.append pvw⟩))

lemma reachable_iff_refl_trans_gen (u v : V) :
  G.reachable u v ↔ relation.refl_trans_gen G.adj u v :=
begin
  split,
  { rintro ⟨h⟩,
    induction h,
    { refl, },
    { exact (relation.refl_trans_gen.single h_h).trans h_ih, }, },
  { intro h,
    induction h with _ _ _ ha hr,
    { refl, },
    { exact reachable.trans hr ⟨walk.cons ha walk.nil⟩, }, },
end

variables (G)

lemma reachable_is_equivalence : equivalence G.reachable :=
mk_equivalence _ (@reachable.refl _ G) (@reachable.symm _ G) (@reachable.trans _ G)

/-- The equivalence relation on vertices given by `simple_graph.reachable`. -/
def reachable_setoid : setoid V := setoid.mk _ G.reachable_is_equivalence

/-- A graph is preconnected if every pair of vertices is reachable from one another. -/
def preconnected : Prop := ∀ (u v : V), G.reachable u v

/-- A graph is connected if it's preconnected and contains at least one vertex.
This follows the convention observed by mathlib that something is connected iff it has
exactly one connected component.

There is a `has_coe_to_fun` instance so that `h u v` can be used instead
of `h.preconnected u v`. -/
@[protect_proj]
structure connected : Prop :=
(preconnected : G.preconnected)
[nonempty : nonempty V]

instance : has_coe_to_fun G.connected (λ _, Π (u v : V), G.reachable u v) :=
⟨λ h, h.preconnected⟩

/-- The quotient of `V` by the `simple_graph.reachable` relation gives the connected
components of a graph. -/
def connected_component := quot G.reachable

/-- Gives the connected component containing a particular vertex. -/
def connected_component_mk (v : V) : G.connected_component := quot.mk G.reachable v

instance connected_component.inhabited [inhabited V] : inhabited G.connected_component :=
⟨G.connected_component_mk default⟩

section connected_component
variables {G}

@[elab_as_eliminator]
protected lemma connected_component.ind {β : G.connected_component → Prop}
  (h : ∀ (v : V), β (G.connected_component_mk v)) (c : G.connected_component) : β c :=
quot.ind h c

@[elab_as_eliminator]
protected lemma connected_component.ind₂ {β : G.connected_component → G.connected_component → Prop}
  (h : ∀ (v w : V), β (G.connected_component_mk v) (G.connected_component_mk w))
  (c d : G.connected_component) : β c d :=
quot.induction_on₂ c d h

protected lemma connected_component.sound {v w : V} :
  G.reachable v w → G.connected_component_mk v = G.connected_component_mk w := quot.sound

protected lemma connected_component.exact {v w : V} :
  G.connected_component_mk v = G.connected_component_mk w → G.reachable v w :=
@quotient.exact _ G.reachable_setoid _ _

@[simp] protected lemma connected_component.eq {v w : V} :
  G.connected_component_mk v = G.connected_component_mk w ↔ G.reachable v w :=
@quotient.eq _ G.reachable_setoid _ _

/-- The `connected_component` specialization of `quot.lift`. Provides the stronger
assumption that the vertices are connected by a path. -/
protected def connected_component.lift {β : Sort*} (f : V → β)
  (h : ∀ (v w : V) (p : G.walk v w), p.is_path → f v = f w) : G.connected_component → β :=
quot.lift f (λ v w (h' : G.reachable v w), h'.elim_path (λ hp, h v w hp hp.2))

@[simp] protected lemma connected_component.lift_mk {β : Sort*} {f : V → β}
  {h : ∀ (v w : V) (p : G.walk v w), p.is_path → f v = f w} {v : V} :
  connected_component.lift f h (G.connected_component_mk v) = f v := rfl

protected lemma connected_component.«exists» {p : G.connected_component → Prop} :
  (∃ (c : G.connected_component), p c) ↔ ∃ v, p (G.connected_component_mk v) :=
(surjective_quot_mk G.reachable).exists

protected lemma connected_component.«forall» {p : G.connected_component → Prop} :
  (∀ (c : G.connected_component), p c) ↔ ∀ v, p (G.connected_component_mk v) :=
(surjective_quot_mk G.reachable).forall

lemma preconnected.subsingleton_connected_component (h : G.preconnected) :
  subsingleton G.connected_component :=
⟨connected_component.ind₂ (λ v w, connected_component.sound (h v w))⟩

end connected_component

variables {G}

/-- A subgraph is connected if it is connected as a simple graph. -/
abbreviation subgraph.connected (H : G.subgraph) : Prop := H.coe.connected

lemma preconnected.set_univ_walk_nonempty (hconn : G.preconnected) (u v : V) :
  (set.univ : set (G.walk u v)).nonempty :=
by { rw ← set.nonempty_iff_univ_nonempty, exact hconn u v }

lemma connected.set_univ_walk_nonempty (hconn : G.connected) (u v : V) :
  (set.univ : set (G.walk u v)).nonempty := hconn.preconnected.set_univ_walk_nonempty u v

/-! ### Walks of a given length -/

section walk_counting

lemma set_walk_self_length_zero_eq (u : V) :
  {p : G.walk u u | p.length = 0} = {walk.nil} :=
by { ext p, simp }

lemma set_walk_length_zero_eq_of_ne {u v : V} (h : u ≠ v) :
  {p : G.walk u v | p.length = 0} = ∅ :=
begin
  ext p,
  simp only [set.mem_set_of_eq, set.mem_empty_eq, iff_false],
  exact λ h', absurd (walk.eq_of_length_eq_zero h') h,
end

lemma set_walk_length_succ_eq (u v : V) (n : ℕ) :
  {p : G.walk u v | p.length = n.succ} =
    ⋃ (w : V) (h : G.adj u w), walk.cons h '' {p' : G.walk w v | p'.length = n} :=
begin
  ext p,
  cases p with _ _ w _ huw pwv,
  { simp [eq_comm], },
  { simp only [nat.succ_eq_add_one, set.mem_set_of_eq, walk.length_cons, add_left_inj,
      set.mem_Union, set.mem_image, exists_prop],
    split,
    { rintro rfl,
      exact ⟨w, huw, pwv, rfl, rfl, heq.rfl⟩, },
    { rintro ⟨w, huw, pwv, rfl, rfl, rfl⟩,
      refl, } },
end

variables (G) [fintype V] [decidable_rel G.adj] [decidable_eq V]

/-- The `finset` of length-`n` walks from `u` to `v`.
This is used to give `{p : G.walk u v | p.length = n}` a `fintype` instance, and it
can also be useful as a recursive description of this set when `V` is finite.

See `simple_graph.coe_finset_walk_length_eq` for the relationship between this `finset` and
the set of length-`n` walks. -/
def finset_walk_length : Π (n : ℕ) (u v : V), finset (G.walk u v)
| 0 u v := if h : u = v
           then by { subst u, exact {walk.nil} }
           else ∅
| (n+1) u v := finset.univ.bUnion (λ (w : V),
                 if h : G.adj u w
                 then (finset_walk_length n w v).map ⟨λ p, walk.cons h p, λ p q, by simp⟩
                 else ∅)

lemma coe_finset_walk_length_eq (n : ℕ) (u v : V) :
  (G.finset_walk_length n u v : set (G.walk u v)) = {p : G.walk u v | p.length = n} :=
begin
  induction n with n ih generalizing u v,
  { obtain rfl | huv := eq_or_ne u v;
    simp [finset_walk_length, set_walk_length_zero_eq_of_ne, *], },
  { simp only [finset_walk_length, set_walk_length_succ_eq,
      finset.coe_bUnion, finset.mem_coe, finset.mem_univ, set.Union_true],
    ext p,
    simp only [set.mem_Union, finset.mem_coe, set.mem_image, set.mem_set_of_eq],
    congr' 2,
    ext w,
    simp only [set.ext_iff, finset.mem_coe, set.mem_set_of_eq] at ih,
    split_ifs with huw; simp [huw, ih], },
end

variables {G}

lemma walk.length_eq_of_mem_finset_walk_length {n : ℕ} {u v : V} (p : G.walk u v) :
  p ∈ G.finset_walk_length n u v → p.length = n :=
(set.ext_iff.mp (G.coe_finset_walk_length_eq n u v) p).mp

variables (G)

instance fintype_set_walk_length (u v : V) (n : ℕ) : fintype {p : G.walk u v | p.length = n} :=
fintype.subtype (G.finset_walk_length n u v) $ λ p,
by rw [←finset.mem_coe, coe_finset_walk_length_eq]

lemma set_walk_length_to_finset_eq (n : ℕ) (u v : V) :
  {p : G.walk u v | p.length = n}.to_finset = G.finset_walk_length n u v :=
by { ext p, simp [←coe_finset_walk_length_eq] }

/- See `simple_graph.adj_matrix_pow_apply_eq_card_walk` for the cardinality in terms of the `n`th
power of the adjacency matrix. -/
lemma card_set_walk_length_eq (u v : V) (n : ℕ) :
  fintype.card {p : G.walk u v | p.length = n} = (G.finset_walk_length n u v).card :=
fintype.card_of_subtype (G.finset_walk_length n u v) $ λ p,
by rw [←finset.mem_coe, coe_finset_walk_length_eq]

end walk_counting

end simple_graph


<|start_filename|>src/analysis/special_functions/exp_deriv.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>
-/
import analysis.calculus.inverse
import analysis.complex.real_deriv
import analysis.special_functions.exp

/-!
# Complex and real exponential

In this file we prove that `complex.exp` and `real.exp` are infinitely smooth functions.

## Tags

exp, derivative
-/

noncomputable theory

open filter asymptotics set function
open_locale classical topological_space

namespace complex
variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜] [normed_algebra 𝕜 ℂ]

/-- The complex exponential is everywhere differentiable, with the derivative `exp x`. -/
lemma has_deriv_at_exp (x : ℂ) : has_deriv_at exp (exp x) x :=
begin
  rw has_deriv_at_iff_is_o_nhds_zero,
  have : (1 : ℕ) < 2 := by norm_num,
  refine (is_O.of_bound (∥exp x∥) _).trans_is_o (is_o_pow_id this),
  filter_upwards [metric.ball_mem_nhds (0 : ℂ) zero_lt_one],
  simp only [metric.mem_ball, dist_zero_right, norm_pow],
  exact λ z hz, exp_bound_sq x z hz.le,
end

lemma differentiable_exp : differentiable 𝕜 exp :=
λ x, (has_deriv_at_exp x).differentiable_at.restrict_scalars 𝕜

lemma differentiable_at_exp {x : ℂ} : differentiable_at 𝕜 exp x :=
differentiable_exp x

@[simp] lemma deriv_exp : deriv exp = exp :=
funext $ λ x, (has_deriv_at_exp x).deriv

@[simp] lemma iter_deriv_exp : ∀ n : ℕ, (deriv^[n] exp) = exp
| 0 := rfl
| (n+1) := by rw [iterate_succ_apply, deriv_exp, iter_deriv_exp n]

lemma cont_diff_exp : ∀ {n}, cont_diff 𝕜 n exp :=
begin
  refine cont_diff_all_iff_nat.2 (λ n, _),
  have : cont_diff ℂ ↑n exp,
  { induction n with n ihn,
    { exact cont_diff_zero.2 continuous_exp },
    { rw cont_diff_succ_iff_deriv,
      use differentiable_exp,
      rwa deriv_exp }, },
  exact this.restrict_scalars 𝕜
end

lemma has_strict_deriv_at_exp (x : ℂ) : has_strict_deriv_at exp (exp x) x :=
cont_diff_exp.cont_diff_at.has_strict_deriv_at' (has_deriv_at_exp x) le_rfl

lemma has_strict_fderiv_at_exp_real (x : ℂ) :
  has_strict_fderiv_at exp (exp x • (1 : ℂ →L[ℝ] ℂ)) x :=
(has_strict_deriv_at_exp x).complex_to_real_fderiv

lemma is_open_map_exp : is_open_map exp :=
open_map_of_strict_deriv has_strict_deriv_at_exp exp_ne_zero

end complex

section
variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜] [normed_algebra 𝕜 ℂ]
  {f : 𝕜 → ℂ} {f' : ℂ} {x : 𝕜} {s : set 𝕜}

lemma has_strict_deriv_at.cexp (hf : has_strict_deriv_at f f' x) :
  has_strict_deriv_at (λ x, complex.exp (f x)) (complex.exp (f x) * f') x :=
(complex.has_strict_deriv_at_exp (f x)).comp x hf

lemma has_deriv_at.cexp (hf : has_deriv_at f f' x) :
  has_deriv_at (λ x, complex.exp (f x)) (complex.exp (f x) * f') x :=
(complex.has_deriv_at_exp (f x)).comp x hf

lemma has_deriv_within_at.cexp (hf : has_deriv_within_at f f' s x) :
  has_deriv_within_at (λ x, complex.exp (f x)) (complex.exp (f x) * f') s x :=
(complex.has_deriv_at_exp (f x)).comp_has_deriv_within_at x hf

lemma deriv_within_cexp (hf : differentiable_within_at 𝕜 f s x)
  (hxs : unique_diff_within_at 𝕜 s x) :
  deriv_within (λ x, complex.exp (f x)) s x = complex.exp (f x) * deriv_within f s x :=
hf.has_deriv_within_at.cexp.deriv_within hxs

@[simp] lemma deriv_cexp (hc : differentiable_at 𝕜 f x) :
  deriv (λ x, complex.exp (f x)) x = complex.exp (f x) * deriv f x :=
hc.has_deriv_at.cexp.deriv

end

section
variables {𝕜 : Type*} [nondiscrete_normed_field 𝕜] [normed_algebra 𝕜 ℂ]
  {E : Type*} [normed_group E] [normed_space 𝕜 E] {f : E → ℂ} {f' : E →L[𝕜] ℂ}
  {x : E} {s : set E}

lemma has_strict_fderiv_at.cexp (hf : has_strict_fderiv_at f f' x) :
  has_strict_fderiv_at (λ x, complex.exp (f x)) (complex.exp (f x) • f') x :=
(complex.has_strict_deriv_at_exp (f x)).comp_has_strict_fderiv_at x hf

lemma has_fderiv_within_at.cexp (hf : has_fderiv_within_at f f' s x) :
  has_fderiv_within_at (λ x, complex.exp (f x)) (complex.exp (f x) • f') s x :=
(complex.has_deriv_at_exp (f x)).comp_has_fderiv_within_at x hf

lemma has_fderiv_at.cexp (hf : has_fderiv_at f f' x) :
  has_fderiv_at (λ x, complex.exp (f x)) (complex.exp (f x) • f') x :=
has_fderiv_within_at_univ.1 $ hf.has_fderiv_within_at.cexp

lemma differentiable_within_at.cexp (hf : differentiable_within_at 𝕜 f s x) :
  differentiable_within_at 𝕜 (λ x, complex.exp (f x)) s x :=
hf.has_fderiv_within_at.cexp.differentiable_within_at

@[simp] lemma differentiable_at.cexp (hc : differentiable_at 𝕜 f x) :
  differentiable_at 𝕜 (λ x, complex.exp (f x)) x :=
hc.has_fderiv_at.cexp.differentiable_at

lemma differentiable_on.cexp (hc : differentiable_on 𝕜 f s) :
  differentiable_on 𝕜 (λ x, complex.exp (f x)) s :=
λ x h, (hc x h).cexp

@[simp] lemma differentiable.cexp (hc : differentiable 𝕜 f) :
  differentiable 𝕜 (λ x, complex.exp (f x)) :=
λ x, (hc x).cexp

lemma cont_diff.cexp {n} (h : cont_diff 𝕜 n f) :
  cont_diff 𝕜 n (λ x, complex.exp (f x)) :=
complex.cont_diff_exp.comp h

lemma cont_diff_at.cexp {n} (hf : cont_diff_at 𝕜 n f x) :
  cont_diff_at 𝕜 n (λ x, complex.exp (f x)) x :=
complex.cont_diff_exp.cont_diff_at.comp x hf

lemma cont_diff_on.cexp {n} (hf : cont_diff_on 𝕜 n f s) :
  cont_diff_on 𝕜 n (λ x, complex.exp (f x)) s :=
complex.cont_diff_exp.comp_cont_diff_on hf

lemma cont_diff_within_at.cexp {n} (hf : cont_diff_within_at 𝕜 n f s x) :
  cont_diff_within_at 𝕜 n (λ x, complex.exp (f x)) s x :=
complex.cont_diff_exp.cont_diff_at.comp_cont_diff_within_at x hf

end

namespace real

variables {x y z : ℝ}

lemma has_strict_deriv_at_exp (x : ℝ) : has_strict_deriv_at exp (exp x) x :=
(complex.has_strict_deriv_at_exp x).real_of_complex

lemma has_deriv_at_exp (x : ℝ) : has_deriv_at exp (exp x) x :=
(complex.has_deriv_at_exp x).real_of_complex

lemma cont_diff_exp {n} : cont_diff ℝ n exp :=
complex.cont_diff_exp.real_of_complex

lemma differentiable_exp : differentiable ℝ exp :=
λx, (has_deriv_at_exp x).differentiable_at

lemma differentiable_at_exp : differentiable_at ℝ exp x :=
differentiable_exp x

@[simp] lemma deriv_exp : deriv exp = exp :=
funext $ λ x, (has_deriv_at_exp x).deriv

@[simp] lemma iter_deriv_exp : ∀ n : ℕ, (deriv^[n] exp) = exp
| 0 := rfl
| (n+1) := by rw [iterate_succ_apply, deriv_exp, iter_deriv_exp n]

end real


section
/-! Register lemmas for the derivatives of the composition of `real.exp` with a differentiable
function, for standalone use and use with `simp`. -/

variables {f : ℝ → ℝ} {f' x : ℝ} {s : set ℝ}

lemma has_strict_deriv_at.exp (hf : has_strict_deriv_at f f' x) :
  has_strict_deriv_at (λ x, real.exp (f x)) (real.exp (f x) * f') x :=
(real.has_strict_deriv_at_exp (f x)).comp x hf

lemma has_deriv_at.exp (hf : has_deriv_at f f' x) :
  has_deriv_at (λ x, real.exp (f x)) (real.exp (f x) * f') x :=
(real.has_deriv_at_exp (f x)).comp x hf

lemma has_deriv_within_at.exp (hf : has_deriv_within_at f f' s x) :
  has_deriv_within_at (λ x, real.exp (f x)) (real.exp (f x) * f') s x :=
(real.has_deriv_at_exp (f x)).comp_has_deriv_within_at x hf

lemma deriv_within_exp (hf : differentiable_within_at ℝ f s x)
  (hxs : unique_diff_within_at ℝ s x) :
  deriv_within (λx, real.exp (f x)) s x = real.exp (f x) * (deriv_within f s x) :=
hf.has_deriv_within_at.exp.deriv_within hxs

@[simp] lemma deriv_exp (hc : differentiable_at ℝ f x) :
  deriv (λx, real.exp (f x)) x = real.exp (f x) * (deriv f x) :=
hc.has_deriv_at.exp.deriv

end

section
/-! Register lemmas for the derivatives of the composition of `real.exp` with a differentiable
function, for standalone use and use with `simp`. -/

variables {E : Type*} [normed_group E] [normed_space ℝ E] {f : E → ℝ} {f' : E →L[ℝ] ℝ}
  {x : E} {s : set E}

lemma cont_diff.exp {n} (hf : cont_diff ℝ n f) :
  cont_diff ℝ n (λ x, real.exp (f x)) :=
real.cont_diff_exp.comp hf

lemma cont_diff_at.exp {n} (hf : cont_diff_at ℝ n f x) :
  cont_diff_at ℝ n (λ x, real.exp (f x)) x :=
real.cont_diff_exp.cont_diff_at.comp x hf

lemma cont_diff_on.exp {n} (hf : cont_diff_on ℝ n f s) :
  cont_diff_on ℝ n (λ x, real.exp (f x)) s :=
real.cont_diff_exp.comp_cont_diff_on  hf

lemma cont_diff_within_at.exp {n} (hf : cont_diff_within_at ℝ n f s x) :
  cont_diff_within_at ℝ n (λ x, real.exp (f x)) s x :=
real.cont_diff_exp.cont_diff_at.comp_cont_diff_within_at x hf

lemma has_fderiv_within_at.exp (hf : has_fderiv_within_at f f' s x) :
  has_fderiv_within_at (λ x, real.exp (f x)) (real.exp (f x) • f') s x :=
(real.has_deriv_at_exp (f x)).comp_has_fderiv_within_at x hf

lemma has_fderiv_at.exp (hf : has_fderiv_at f f' x) :
  has_fderiv_at (λ x, real.exp (f x)) (real.exp (f x) • f') x :=
(real.has_deriv_at_exp (f x)).comp_has_fderiv_at x hf

lemma has_strict_fderiv_at.exp (hf : has_strict_fderiv_at f f' x) :
  has_strict_fderiv_at (λ x, real.exp (f x)) (real.exp (f x) • f') x :=
(real.has_strict_deriv_at_exp (f x)).comp_has_strict_fderiv_at x hf

lemma differentiable_within_at.exp (hf : differentiable_within_at ℝ f s x) :
  differentiable_within_at ℝ (λ x, real.exp (f x)) s x :=
hf.has_fderiv_within_at.exp.differentiable_within_at

@[simp] lemma differentiable_at.exp (hc : differentiable_at ℝ f x) :
  differentiable_at ℝ (λx, real.exp (f x)) x :=
hc.has_fderiv_at.exp.differentiable_at

lemma differentiable_on.exp (hc : differentiable_on ℝ f s) :
  differentiable_on ℝ (λx, real.exp (f x)) s :=
λ x h, (hc x h).exp

@[simp] lemma differentiable.exp (hc : differentiable ℝ f) :
  differentiable ℝ (λx, real.exp (f x)) :=
λ x, (hc x).exp

lemma fderiv_within_exp (hf : differentiable_within_at ℝ f s x)
  (hxs : unique_diff_within_at ℝ s x) :
  fderiv_within ℝ (λx, real.exp (f x)) s x = real.exp (f x) • (fderiv_within ℝ f s x) :=
hf.has_fderiv_within_at.exp.fderiv_within hxs

@[simp] lemma fderiv_exp (hc : differentiable_at ℝ f x) :
  fderiv ℝ (λx, real.exp (f x)) x = real.exp (f x) • (fderiv ℝ f x) :=
hc.has_fderiv_at.exp.fderiv

end


<|start_filename|>src/data/list/min_max.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import data.list.basic
/-!
# Minimum and maximum of lists

## Main definitions

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

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

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

namespace list

variables {α β : Type*}

section arg_aux
variables (r : α → α → Prop) [decidable_rel r] {l : list α} {o : option α} {a m : α}

/-- Auxiliary definition for `argmax` and `argmin`. -/
def arg_aux (a : option α) (b : α) : option α :=
option.cases_on a (some b) $ λ c, if r b c then some b else some c

@[simp] lemma foldl_arg_aux_eq_none :
  l.foldl (arg_aux r) o = none ↔ l = [] ∧ o = none :=
list.reverse_rec_on l (by simp) $
  (assume tl hd, by simp [arg_aux];
    cases foldl (arg_aux r) o tl; simp; try {split_ifs}; simp)

private lemma foldl_arg_aux_mem (l) : Π (a m : α),
  m ∈ foldl (arg_aux r) (some a) l → m ∈ a :: l :=
list.reverse_rec_on l (by simp [eq_comm])
  begin
    assume tl hd ih a m,
    simp only [foldl_append, foldl_cons, foldl_nil, arg_aux],
    cases hf : foldl (arg_aux r) (some a) tl,
    { simp {contextual := tt} },
    { dsimp only, split_ifs,
      { simp {contextual := tt} },
      { -- `finish [ih _ _ hf]` closes this goal
        rcases ih _ _ hf with rfl | H,
        { simp only [mem_cons_iff, mem_append, mem_singleton, option.mem_def], tauto },
        { apply λ hm, or.inr (list.mem_append.mpr $ or.inl _),
          exact (option.mem_some_iff.mp hm ▸ H)} } }
  end

@[simp] lemma arg_aux_self (hr₀ : irreflexive r) (a : α) : arg_aux r (some a) a = a :=
if_neg $ hr₀ _

lemma not_of_mem_foldl_arg_aux (hr₀ : irreflexive r) (hr₁ : transitive r) :
  Π {a m : α} {o : option α}, a ∈ l → m ∈ foldl (arg_aux r) o l → ¬ r a m :=
begin
  induction l using list.reverse_rec_on with tl a ih,
  { exact λ _ _ _ h, absurd h $ not_mem_nil _ },
  intros b m o hb ho,
  rw [foldl_append, foldl_cons, foldl_nil, arg_aux] at ho,
  cases hf : foldl (arg_aux r) o tl with c,
  { rw [hf] at ho,
    rw [foldl_arg_aux_eq_none] at hf,
    simp [hf.1, hf.2, *, hr₀ _] at * },
  rw [hf, option.mem_def] at ho,
  dsimp only at ho,
  split_ifs at ho with hac hac; cases mem_append.1 hb with h h; subst ho,
  { exact λ hba, ih h hf (hr₁ hba hac) },
  { simp [*, hr₀ _] at * },
  { exact ih h hf },
  { simp * at * }
end

end arg_aux

section preorder
variables [preorder β] [@decidable_rel β (<)] {f : α → β} {l : list α} {o : option α} {a m : α}

/-- `argmax f l` returns `some a`, where `f a` is maximal among the elements of `l`, in the sense
that there is no `b ∈ l` with `f a < f b`. If `a`, `b` are such that `f a = f b`, it returns
whichever of `a` or `b` comes first in the list. `argmax f []` = none`. -/
def argmax (f : α → β) (l : list α) : option α := l.foldl (arg_aux $ λ b c, f c < f b) none

/-- `argmin f l` returns `some a`, where `f a` is minimal among the elements of `l`, in the sense
that there is no `b ∈ l` with `f b < f a`. If `a`, `b` are such that `f a = f b`, it returns
whichever of `a` or `b` comes first in the list. `argmin f []` = none`. -/
def argmin (f : α → β) (l : list α) := l.foldl (arg_aux $ λ b c, f b < f c) none

@[simp] lemma argmax_nil (f : α → β) : argmax f [] = none := rfl
@[simp] lemma argmin_nil (f : α → β) : argmin f [] = none := rfl

@[simp] lemma argmax_singleton {f : α → β} {a : α} : argmax f [a] = a := rfl
@[simp] lemma argmin_singleton {f : α → β} {a : α} : argmin f [a] = a := rfl

lemma not_lt_of_mem_argmax : a ∈ l → m ∈ argmax f l → ¬ f m < f a :=
not_of_mem_foldl_arg_aux _ (λ _ , lt_irrefl _) $ λ _ _ _, gt_trans

lemma not_lt_of_mem_argmin : a ∈ l → m ∈ argmin f l → ¬ f a < f m :=
not_of_mem_foldl_arg_aux _ (λ _ , lt_irrefl _) $ λ _ _ _, lt_trans

theorem argmax_concat (f : α → β) (a : α) (l : list α) : argmax f (l ++ [a]) =
  option.cases_on (argmax f l) (some a) (λ c, if f c < f a then some a else some c) :=
by rw [argmax, argmax]; simp [arg_aux]

theorem argmin_concat (f : α → β) (a : α) (l : list α) : argmin f (l ++ [a]) =
  option.cases_on (argmin f l) (some a) (λ c, if f a < f c then some a else some c) :=
@argmax_concat _ βᵒᵈ _ _ _ _ _

theorem argmax_mem : Π {l : list α} {m : α}, m ∈ argmax f l → m ∈ l
| [] m       := by simp
| (hd::tl) m := by simpa [argmax, arg_aux] using foldl_arg_aux_mem _ tl hd m

theorem argmin_mem : Π {l : list α} {m : α}, m ∈ argmin f l → m ∈ l := @argmax_mem _ βᵒᵈ _ _ _

@[simp] theorem argmax_eq_none : l.argmax f = none ↔ l = [] := by simp [argmax]
@[simp] theorem argmin_eq_none : l.argmin f = none ↔ l = [] := @argmax_eq_none _ βᵒᵈ _ _ _ _

end preorder

section linear_order
variables [linear_order β] {f : α → β} {l : list α} {o : option α} {a m : α}

theorem le_of_mem_argmax : a ∈ l → m ∈ argmax f l → f a ≤ f m :=
λ ha hm, le_of_not_lt $ not_lt_of_mem_argmax ha hm

theorem le_of_mem_argmin : a ∈ l → m ∈ argmin f l → f m ≤ f a := @le_of_mem_argmax _ βᵒᵈ _ _ _ _ _

theorem argmax_cons (f : α → β) (a : α) (l : list α) : argmax f (a :: l) =
  option.cases_on (argmax f l) (some a) (λ c, if f a < f c then some c else some a) :=
list.reverse_rec_on l rfl $ λ hd tl ih, begin
    rw [← cons_append, argmax_concat, ih, argmax_concat],
    cases h : argmax f hd with m,
    { simp [h] },
    dsimp,
    rw [←apply_ite, ←apply_ite],
    dsimp,
    split_ifs; try { refl },
    { exact absurd (lt_trans ‹f a < f m› ‹_›) ‹_› },
    { cases (‹f a < f tl›.lt_or_lt _).elim ‹_› ‹_› }
  end

theorem argmin_cons (f : α → β) (a : α) (l : list α) : argmin f (a :: l) =
  option.cases_on (argmin f l) (some a) (λ c, if f c < f a then some c else some a) :=
by convert @argmax_cons _ βᵒᵈ _ _ _ _

variables [decidable_eq α]

theorem index_of_argmax : Π {l : list α} {m : α}, m ∈ argmax f l →
  ∀ {a}, a ∈ l → f m ≤ f a → l.index_of m ≤ l.index_of a
| []       m _  _ _  _   := by simp
| (hd::tl) m hm a ha ham := begin
  simp only [index_of_cons, argmax_cons, option.mem_def] at ⊢ hm,
  cases h : argmax f tl,
  { rw h at hm,
    simp * at * },
  rw h at hm,
  dsimp only at hm,
  obtain rfl | ha := ha; split_ifs at hm; subst hm,
  { cases not_le_of_lt ‹_› ‹_› },
  { rw [if_neg, if_neg],
    exact nat.succ_le_succ (index_of_argmax h ha ham),
    { exact ne_of_apply_ne f (lt_of_lt_of_le ‹_› ‹_›).ne' },
    { exact ne_of_apply_ne _ ‹f hd < f val›.ne' } },
  { rw if_pos rfl,
    exact bot_le }
end

theorem index_of_argmin : Π {l : list α} {m : α}, m ∈ argmin f l →
  ∀ {a}, a ∈ l → f a ≤ f m → l.index_of m ≤ l.index_of a :=
@index_of_argmax _ βᵒᵈ _ _ _

theorem mem_argmax_iff :
  m ∈ argmax f l ↔ m ∈ l ∧ (∀ a ∈ l, f a ≤ f m) ∧
    ∀ a ∈ l, f m ≤ f a → l.index_of m ≤ l.index_of a :=
⟨λ hm, ⟨argmax_mem hm, λ a ha, le_of_mem_argmax ha hm, λ _, index_of_argmax hm⟩,
  begin
    rintros ⟨hml, ham, hma⟩,
    cases harg : argmax f l with n,
    { simp * at * },
    { have := le_antisymm (hma n (argmax_mem harg) (le_of_mem_argmax hml harg))
        (index_of_argmax harg hml (ham _ (argmax_mem harg))),
      rw [(index_of_inj hml (argmax_mem harg)).1 this, option.mem_def] }
  end⟩

theorem argmax_eq_some_iff :
  argmax f l = some m ↔ m ∈ l ∧ (∀ a ∈ l, f a ≤ f m) ∧
    ∀ a ∈ l, f m ≤ f a → l.index_of m ≤ l.index_of a := mem_argmax_iff

theorem mem_argmin_iff :
  m ∈ argmin f l ↔ m ∈ l ∧ (∀ a ∈ l, f m ≤ f a) ∧
    ∀ a ∈ l, f a ≤ f m → l.index_of m ≤ l.index_of a :=
@mem_argmax_iff _ βᵒᵈ _ _ _ _ _

theorem argmin_eq_some_iff :
  argmin f l = some m ↔ m ∈ l ∧ (∀ a ∈ l, f m ≤ f a) ∧
    ∀ a ∈ l, f a ≤ f m → l.index_of m ≤ l.index_of a := mem_argmin_iff

end linear_order

section maximum_minimum
section preorder
variables [preorder α] [@decidable_rel α (<)] {l : list α} {a m : α}

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

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

@[simp] lemma maximum_nil : maximum ([] : list α) = ⊥ := rfl

@[simp] lemma minimum_nil : minimum ([] : list α) = ⊤ := rfl

@[simp] lemma maximum_singleton (a : α) : maximum [a] = a := rfl

@[simp] lemma minimum_singleton (a : α) : minimum [a] = a := rfl

theorem maximum_mem {l : list α} {m : α} : (maximum l : with_top α) = m → m ∈ l := argmax_mem

theorem minimum_mem {l : list α} {m : α} : (minimum l : with_bot α) = m → m ∈ l := argmin_mem

@[simp] theorem maximum_eq_none {l : list α} : l.maximum = none ↔ l = [] := argmax_eq_none

@[simp] theorem minimum_eq_none {l : list α} : l.minimum = none ↔ l = [] := argmin_eq_none

lemma not_lt_maximum_of_mem : a ∈ l → (maximum l : with_bot α) = m → ¬ m < a := not_lt_of_mem_argmax
lemma minimum_not_lt_of_mem : a ∈ l → (minimum l : with_top α) = m → ¬ a < m := not_lt_of_mem_argmin

theorem not_lt_maximum_of_mem' (ha : a ∈ l) : ¬ maximum l < (a : with_bot α) :=
begin
  cases h : l.maximum,
  { simp * at * },
  { simp_rw [with_bot.some_eq_coe, with_bot.coe_lt_coe, not_lt_maximum_of_mem ha h, not_false_iff] }
end

theorem not_lt_minimum_of_mem' (ha : a ∈ l) : ¬ (a : with_top α) < minimum l :=
@not_lt_maximum_of_mem' αᵒᵈ _ _ _ _ ha

end preorder

section linear_order
variables [linear_order α] {l : list α} {a m : α}

theorem maximum_concat (a : α) (l : list α) : maximum (l ++ [a]) = max (maximum l) a :=
begin
  simp only [maximum, argmax_concat, id],
  cases h : argmax id l,
  { exact (max_eq_right bot_le).symm },
  { simp [option.coe_def, max_def, ←not_lt] }
end

lemma le_maximum_of_mem : a ∈ l → (maximum l : with_bot α) = m → a ≤ m := le_of_mem_argmax
lemma minimum_le_of_mem : a ∈ l → (minimum l : with_top α) = m → m ≤ a := le_of_mem_argmin

lemma le_maximum_of_mem' (ha : a ∈ l) : (a : with_bot α) ≤ maximum l :=
le_of_not_lt $ not_lt_maximum_of_mem' ha

lemma le_minimum_of_mem' (ha : a ∈ l) : minimum l ≤ (a : with_top α) :=
@le_maximum_of_mem' αᵒᵈ _ _ _ ha

theorem minimum_concat (a : α) (l : list α) : minimum (l ++ [a]) = min (minimum l) a :=
@maximum_concat αᵒᵈ _ _ _

theorem maximum_cons (a : α) (l : list α) : maximum (a :: l) = max a (maximum l) :=
list.reverse_rec_on l (by simp [@max_eq_left (with_bot α) _ _ _ bot_le])
  (λ tl hd ih, by rw [← cons_append, maximum_concat, ih, maximum_concat, max_assoc])

theorem minimum_cons (a : α) (l : list α) : minimum (a :: l) = min a (minimum l) :=
@maximum_cons αᵒᵈ _ _ _

lemma maximum_eq_coe_iff : maximum l = m ↔ m ∈ l ∧ ∀ a ∈ l, a ≤ m :=
begin
  unfold_coes,
  simp only [maximum, argmax_eq_some_iff, id],
  split,
  { simp only [true_and, forall_true_iff] {contextual := tt} },
  { simp only [true_and, forall_true_iff] {contextual := tt},
    intros h a hal hma,
    rw [le_antisymm hma (h.2 a hal)] }
end

lemma minimum_eq_coe_iff : minimum l = m ↔ m ∈ l ∧ ∀ a ∈ l, m ≤ a :=
@maximum_eq_coe_iff αᵒᵈ _ _ _

end linear_order
end maximum_minimum

section fold
variables [linear_order α]

section order_bot
variables [order_bot α] {l : list α}

@[simp] lemma foldr_max_of_ne_nil (h : l ≠ []) : ↑(l.foldr max ⊥) = l.maximum :=
begin
  induction l with hd tl IH,
  { contradiction },
  { rw [maximum_cons, foldr, with_bot.coe_max],
    by_cases h : tl = [],
    { simp [h, -with_top.coe_zero] },
    { simp [IH h] } }
end

lemma max_le_of_forall_le (l : list α) (a : α) (h : ∀ x ∈ l, x ≤ a) : l.foldr max ⊥ ≤ a :=
begin
  induction l with y l IH,
  { simp },
  { simpa [h y (mem_cons_self _ _)] using IH (λ x hx, h x $ mem_cons_of_mem _ hx) }
end

lemma le_max_of_le {l : list α} {a x : α} (hx : x ∈ l) (h : a ≤ x) :
  a ≤ l.foldr max ⊥ :=
begin
  induction l with y l IH,
  { exact absurd hx (not_mem_nil _), },
  { obtain rfl | hl := hx,
    simp only [foldr, foldr_cons],
    { exact le_max_of_le_left h, },
    { exact le_max_of_le_right (IH hl) }}
end

end order_bot

section order_top
variables [order_top α] {l : list α}

@[simp] lemma foldr_min_of_ne_nil (h : l ≠ []) : ↑(l.foldr min ⊤) = l.minimum :=
@foldr_max_of_ne_nil αᵒᵈ _ _ _ h

lemma le_min_of_forall_le (l : list α) (a : α) (h : ∀ x ∈ l, a ≤ x) : a ≤ l.foldr min ⊤ :=
@max_le_of_forall_le αᵒᵈ _ _ _ _ h

lemma min_le_of_le (l : list α) (a : α) {x : α} (hx : x ∈ l) (h : x ≤ a) :
  l.foldr min ⊤ ≤ a :=
@le_max_of_le αᵒᵈ _ _ _ _ _ hx h

end order_top
end fold
end list


<|start_filename|>src/model_theory/encoding.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import computability.encoding
import model_theory.syntax
import set_theory.cardinal.ordinal

/-! # Encodings and Cardinality of First-Order Syntax

## Main Definitions
* `first_order.language.term.encoding` encodes terms as lists.
* `first_order.language.bounded_formula.encoding` encodes bounded formulas as lists.

## Main Results
* `first_order.language.term.card_le` shows that the number of terms in `L.term α` is at most
`max ℵ₀ # (α ⊕ Σ i, L.functions i)`.
* `first_order.language.bounded_formula.card_le` shows that the number of bounded formulas in
`Σ n, L.bounded_formula α n` is at most
`max ℵ₀ (cardinal.lift.{max u v} (#α) + cardinal.lift.{u'} L.card)`.

## TODO
* `primcodable` instances for terms and formulas, based on the `encoding`s
* Computability facts about term and formula operations, to set up a computability approach to
incompleteness

-/

universes u v w u' v'

namespace first_order
namespace language

variables {L : language.{u v}}
variables {M : Type w} {N P : Type*} [L.Structure M] [L.Structure N] [L.Structure P]
variables {α : Type u'} {β : Type v'}
open_locale first_order cardinal
open computability list Structure cardinal fin

namespace term

/-- Encodes a term as a list of variables and function symbols. -/
def list_encode : L.term α → list (α ⊕ Σ i, L.functions i)
| (var i) := [sum.inl i]
| (func f ts) := ((sum.inr (⟨_, f⟩ : Σ i, L.functions i)) ::
    ((list.fin_range _).bind (λ i, (ts i).list_encode)))

/-- Decodes a list of variables and function symbols as a list of terms. -/
def list_decode :
  list (α ⊕ Σ i, L.functions i) → list (option (L.term α))
| [] := []
| ((sum.inl a) :: l) := some (var a) :: list_decode l
| ((sum.inr ⟨n, f⟩) :: l) :=
  if h : ∀ (i : fin n), ((list_decode l).nth i).join.is_some
  then func f (λ i, option.get (h i)) :: ((list_decode l).drop n)
  else [none]

theorem list_decode_encode_list (l : list (L.term α)) :
  list_decode (l.bind list_encode) = l.map option.some :=
begin
  suffices h : ∀ (t : L.term α) (l : list (α ⊕ Σ i, L.functions i)),
    list_decode (t.list_encode ++ l) = some t :: list_decode l,
  { induction l with t l lih,
    { refl },
    { rw [cons_bind, h t (l.bind list_encode), lih, list.map] } },
  { intro t,
    induction t with a n f ts ih; intro l,
    { rw [list_encode, singleton_append, list_decode] },
    { rw [list_encode, cons_append, list_decode],
      have h : list_decode ((fin_range n).bind (λ (i : fin n), (ts i).list_encode) ++ l) =
        (fin_range n).map (option.some ∘ ts) ++ list_decode l,
      { induction (fin_range n) with i l' l'ih,
        { refl },
        { rw [cons_bind, append_assoc, ih, map_cons, l'ih, cons_append] } },
      have h' : ∀ i, (list_decode ((fin_range n).bind (λ (i : fin n), (ts i).list_encode) ++ l)).nth
        ↑i = some (some (ts i)),
      { intro i,
        rw [h, nth_append, nth_map],
        { simp only [option.map_eq_some', function.comp_app, nth_eq_some],
          refine ⟨i, ⟨lt_of_lt_of_le i.2 (ge_of_eq (length_fin_range _)), _⟩, rfl⟩,
          rw [nth_le_fin_range, fin.eta] },
        { refine lt_of_lt_of_le i.2 _,
          simp } },
      refine (dif_pos (λ i, option.is_some_iff_exists.2 ⟨ts i, _⟩)).trans _,
      { rw [option.join_eq_some, h'] },
      refine congr (congr rfl (congr rfl (congr rfl (funext (λ i, option.get_of_mem _ _))))) _,
      { simp [h'] },
      { rw [h, drop_left'],
        rw [length_map, length_fin_range] } } }
end

/-- An encoding of terms as lists. -/
@[simps] protected def encoding : encoding (L.term α) :=
{ Γ := α ⊕ Σ i, L.functions i,
  encode := list_encode,
  decode := λ l, (list_decode l).head'.join,
  decode_encode := λ t, begin
    have h := list_decode_encode_list [t],
    rw [bind_singleton] at h,
    simp only [h, option.join, head', list.map, option.some_bind, id.def],
  end }

lemma list_encode_injective :
  function.injective (list_encode : L.term α → list (α ⊕ Σ i, L.functions i)) :=
term.encoding.encode_injective

theorem card_le : # (L.term α) ≤ max ℵ₀ (# (α ⊕ Σ i, L.functions i)) :=
lift_le.1 (trans term.encoding.card_le_card_list (lift_le.2 (mk_list_le_max _)))

theorem card_sigma : # (Σ n, (L.term (α ⊕ fin n))) = max ℵ₀ (# (α ⊕ Σ i, L.functions i)) :=
begin
  refine le_antisymm _ _,
  { rw mk_sigma,
    refine (sum_le_sup_lift _).trans _,
    rw [mk_nat, lift_aleph_0, mul_eq_max_of_aleph_0_le_left le_rfl, max_le_iff,
      cardinal.sup_le_iff],
    { refine ⟨le_max_left _ _, λ i, card_le.trans _⟩,
      rw max_le_iff,
      refine ⟨le_max_left _ _, _⟩,
      rw [← add_eq_max le_rfl, mk_sum, mk_sum, mk_sum, add_comm (cardinal.lift (#α)), lift_add,
        add_assoc, lift_lift, lift_lift],
      refine add_le_add_right _ _,
      rw [lift_le_aleph_0, ← encodable_iff],
      exact ⟨infer_instance⟩ },
    { rw [← one_le_iff_ne_zero],
      refine trans _ (le_sup _ 1),
      rw [one_le_iff_ne_zero, mk_ne_zero_iff],
      exact ⟨var (sum.inr 0)⟩ } },
  { rw [max_le_iff, ← infinite_iff],
    refine ⟨infinite.of_injective (λ i, ⟨i + 1, var (sum.inr i)⟩) (λ i j ij, _), _⟩,
    { cases ij,
      refl },
    { rw [cardinal.le_def],
      refine ⟨⟨sum.elim (λ i, ⟨0, var (sum.inl i)⟩)
        (λ F, ⟨1, func F.2 (λ _, var (sum.inr 0))⟩), _⟩⟩,
      { rintros (a | a) (b | b) h,
        { simp only [sum.elim_inl, eq_self_iff_true, heq_iff_eq, true_and] at h,
          rw h },
        { simp only [sum.elim_inl, sum.elim_inr, nat.zero_ne_one, false_and] at h,
          exact h.elim },
        { simp only [sum.elim_inr, sum.elim_inl, nat.one_ne_zero, false_and] at h,
          exact h.elim },
        { simp only [sum.elim_inr, eq_self_iff_true, heq_iff_eq, true_and] at h,
          rw sigma.ext_iff.2 ⟨h.1, h.2.1⟩, } } } }
end

instance [encodable α] [encodable ((Σ i, L.functions i))] :
  encodable (L.term α) :=
encodable.of_left_injection list_encode (λ l, (list_decode l).head'.join)
  (λ t, begin
    rw [← bind_singleton list_encode, list_decode_encode_list],
    simp only [option.join, head', list.map, option.some_bind, id.def],
  end)

lemma card_le_aleph_0 [h1 : nonempty (encodable α)] [h2 : L.countable_functions] :
  # (L.term α) ≤ ℵ₀ :=
begin
  refine (card_le.trans _),
  rw [max_le_iff],
  simp only [le_refl, mk_sum, add_le_aleph_0, lift_le_aleph_0, true_and],
  exact ⟨encodable_iff.1 h1, L.card_functions_le_aleph_0⟩,
end

instance small [small.{u} α] :
  small.{u} (L.term α) :=
small_of_injective list_encode_injective

end term

namespace bounded_formula

/-- Encodes a bounded formula as a list of symbols. -/
def list_encode : ∀ {n : ℕ}, L.bounded_formula α n →
  list ((Σ k, L.term (α ⊕ fin k)) ⊕ (Σ n, L.relations n) ⊕ ℕ)
| n falsum := [sum.inr (sum.inr (n + 2))]
| n (equal t₁ t₂) := [sum.inl ⟨_, t₁⟩, sum.inl ⟨_, t₂⟩]
| n (rel R ts) := [sum.inr (sum.inl ⟨_, R⟩), sum.inr (sum.inr n)] ++
  ((list.fin_range _).map (λ i, sum.inl ⟨n, (ts i)⟩))
| n (imp φ₁ φ₂) := (sum.inr (sum.inr 0)) :: φ₁.list_encode ++ φ₂.list_encode
| n (all φ) := (sum.inr (sum.inr 1)) :: φ.list_encode

/-- Applies the `forall` quantifier to an element of `(Σ n, L.bounded_formula α n)`,
or returns `default` if not possible. -/
def sigma_all : (Σ n, L.bounded_formula α n) → Σ n, L.bounded_formula α n
| ⟨(n + 1), φ⟩ := ⟨n, φ.all⟩
| _ := default

/-- Applies `imp` to two elements of `(Σ n, L.bounded_formula α n)`,
or returns `default` if not possible. -/
def sigma_imp :
  (Σ n, L.bounded_formula α n) → (Σ n, L.bounded_formula α n) → (Σ n, L.bounded_formula α n)
| ⟨m, φ⟩ ⟨n, ψ⟩ := if h : m = n then ⟨m, φ.imp (eq.mp (by rw h) ψ)⟩ else default

/-- Decodes a list of symbols as a list of formulas. -/
@[simp] def list_decode :
  Π (l : list ((Σ k, L.term (α ⊕ fin k)) ⊕ (Σ n, L.relations n) ⊕ ℕ)),
    (Σ n, L.bounded_formula α n) ×
    { l' : list ((Σ k, L.term (α ⊕ fin k)) ⊕ (Σ n, L.relations n) ⊕ ℕ)
    // l'.sizeof ≤ max 1 l.sizeof }
| ((sum.inr (sum.inr (n + 2))) :: l) := ⟨⟨n, falsum⟩, l, le_max_of_le_right le_add_self⟩
| ((sum.inl ⟨n₁, t₁⟩) :: sum.inl ⟨n₂, t₂⟩ :: l) :=
    ⟨if h : n₁ = n₂ then ⟨n₁, equal t₁ (eq.mp (by rw h) t₂)⟩ else default, l, begin
      simp only [list.sizeof, ← add_assoc],
      exact le_max_of_le_right le_add_self,
    end⟩
| (sum.inr (sum.inl ⟨n, R⟩) :: (sum.inr (sum.inr k)) :: l) := ⟨
    if h : ∀ (i : fin n), ((l.map sum.get_left).nth i).join.is_some
    then if h' : ∀ i, (option.get (h i)).1 = k
      then ⟨k, bounded_formula.rel R (λ i, eq.mp (by rw h' i) (option.get (h i)).2)⟩
      else default
    else default,
    l.drop n, le_max_of_le_right (le_add_left (le_add_left (list.drop_sizeof_le _ _)))⟩
| ((sum.inr (sum.inr 0)) :: l) :=
  have (↑((list_decode l).2) : list ((Σ k, L.term (α ⊕ fin k)) ⊕ (Σ n, L.relations n) ⊕ ℕ)).sizeof
    < 1 + (1 + 1) + l.sizeof, from begin
      refine lt_of_le_of_lt (list_decode l).2.2 (max_lt _ (nat.lt_add_of_pos_left dec_trivial)),
      rw [add_assoc, add_comm, nat.lt_succ_iff, add_assoc],
      exact le_self_add,
    end,
  ⟨sigma_imp (list_decode l).1 (list_decode (list_decode l).2).1,
    (list_decode (list_decode l).2).2, le_max_of_le_right (trans (list_decode _).2.2 (max_le
      (le_add_right le_self_add) (trans (list_decode _).2.2
      (max_le (le_add_right le_self_add) le_add_self))))⟩
| ((sum.inr (sum.inr 1)) :: l) := ⟨sigma_all (list_decode l).1, (list_decode l).2,
  (list_decode l).2.2.trans (max_le_max le_rfl le_add_self)⟩
| _ := ⟨default, [], le_max_left _ _⟩

@[simp] theorem list_decode_encode_list (l : list (Σ n, L.bounded_formula α n)) :
  (list_decode (l.bind (λ φ, φ.2.list_encode))).1 = l.head :=
begin
  suffices h : ∀ (φ : (Σ n, L.bounded_formula α n)) l,
    (list_decode (list_encode φ.2 ++ l)).1 = φ ∧ (list_decode (list_encode φ.2 ++ l)).2.1 = l,
  { induction l with φ l lih,
    { rw [list.nil_bind],
      simp [list_decode], },
    { rw [cons_bind, (h φ _).1, head_cons] } },
  { rintro ⟨n, φ⟩,
    induction φ with _ _ _ _ _ _ _ ts _ _ _ ih1 ih2 _ _ ih; intro l,
    { rw [list_encode, singleton_append, list_decode],
      simp only [eq_self_iff_true, heq_iff_eq, and_self], },
    { rw [list_encode, cons_append, cons_append, list_decode, dif_pos],
      { simp only [eq_mp_eq_cast, cast_eq, eq_self_iff_true, heq_iff_eq, and_self, nil_append], },
      { simp only [eq_self_iff_true, heq_iff_eq, and_self], } },
    { rw [list_encode, cons_append, cons_append, singleton_append, cons_append, list_decode],
      { have h : ∀ (i : fin φ_l), ((list.map sum.get_left (list.map (λ (i : fin φ_l),
          sum.inl (⟨(⟨φ_n, rel φ_R ts⟩ : Σ n, L.bounded_formula α n).fst, ts i⟩ :
            Σ n, L.term (α ⊕ fin n))) (fin_range φ_l) ++ l)).nth ↑i).join = some ⟨_, ts i⟩,
        { intro i,
          simp only [option.join, map_append, map_map, option.bind_eq_some, id.def, exists_eq_right,
            nth_eq_some, length_append, length_map, length_fin_range],
          refine ⟨lt_of_lt_of_le i.2 le_self_add, _⟩,
          rw [nth_le_append, nth_le_map],
          { simp only [sum.get_left, nth_le_fin_range, fin.eta, function.comp_app, eq_self_iff_true,
            heq_iff_eq, and_self] },
          { exact lt_of_lt_of_le i.is_lt (ge_of_eq (length_fin_range _)) },
          { rw [length_map, length_fin_range],
            exact i.2 } },
        rw dif_pos, swap,
        { exact λ i, option.is_some_iff_exists.2 ⟨⟨_, ts i⟩, h i⟩ },
        rw dif_pos, swap,
        { intro i,
          obtain ⟨h1, h2⟩ := option.eq_some_iff_get_eq.1 (h i),
          rw h2 },
        simp only [eq_self_iff_true, heq_iff_eq, true_and],
        refine ⟨funext (λ i, _), _⟩,
        { obtain ⟨h1, h2⟩ := option.eq_some_iff_get_eq.1 (h i),
          rw [eq_mp_eq_cast, cast_eq_iff_heq],
          exact (sigma.ext_iff.1 ((sigma.eta (option.get h1)).trans h2)).2 },
        rw [list.drop_append_eq_append_drop, length_map, length_fin_range, nat.sub_self, drop,
          drop_eq_nil_of_le, nil_append],
        rw [length_map, length_fin_range], }, },
    { rw [list_encode, append_assoc, cons_append, list_decode],
      simp only [subtype.val_eq_coe] at *,
      rw [(ih1 _).1, (ih1 _).2, (ih2 _).1, (ih2 _).2, sigma_imp, dif_pos rfl],
      exact ⟨rfl, rfl⟩, },
    { rw [list_encode, cons_append, list_decode],
      simp only,
      simp only [subtype.val_eq_coe] at *,
      rw [(ih _).1, (ih _).2, sigma_all],
      exact ⟨rfl, rfl⟩ } }
end

/-- An encoding of bounded formulas as lists. -/
@[simps] protected def encoding : encoding (Σ n, L.bounded_formula α n) :=
{ Γ := (Σ k, L.term (α ⊕ fin k)) ⊕ (Σ n, L.relations n) ⊕ ℕ,
  encode := λ φ, φ.2.list_encode,
  decode := λ l, (list_decode l).1,
  decode_encode := λ φ, begin
    have h := list_decode_encode_list [φ],
    rw [bind_singleton] at h,
    rw h,
    refl,
  end }

lemma list_encode_sigma_injective :
  function.injective (λ (φ : Σ n, L.bounded_formula α n), φ.2.list_encode) :=
bounded_formula.encoding.encode_injective

theorem card_le : # (Σ n, L.bounded_formula α n) ≤
  max ℵ₀ (cardinal.lift.{max u v} (#α) + cardinal.lift.{u'} L.card) :=
begin
  refine lift_le.1 ((bounded_formula.encoding.card_le_card_list).trans _),
  rw [encoding_Γ, mk_list_eq_max_mk_aleph_0, lift_max, lift_aleph_0, lift_max, lift_aleph_0,
    max_le_iff],
  refine ⟨_, le_max_left _ _⟩,
  rw [mk_sum, term.card_sigma, mk_sum, ← add_eq_max le_rfl, mk_sum, mk_nat],
  simp only [lift_add, lift_lift, lift_aleph_0],
  rw [← add_assoc, add_comm, ← add_assoc, ← add_assoc, aleph_0_add_aleph_0, add_assoc,
    add_eq_max le_rfl, add_assoc, card, symbols, mk_sum, lift_add, lift_lift, lift_lift],
end

end bounded_formula

end language
end first_order


<|start_filename|>src/algebra/hom/freiman.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.big_operators.multiset
import data.fun_like.basic

/-!
# Freiman homomorphisms

In this file, we define Freiman homomorphisms. A `n`-Freiman homomorphism on `A` is a function
`f : α → β` such that `f (x₁) * ... * f (xₙ) = f (y₁) * ... * f (yₙ)` for all
`x₁, ..., xₙ, y₁, ..., yₙ ∈ A` such that `x₁ * ... * xₙ = y₁ * ... * yₙ`. In particular, any
`mul_hom` is a Freiman homomorphism.

They are of interest in additive combinatorics.

## Main declaration

* `freiman_hom`: Freiman homomorphism.
* `add_freiman_hom`: Additive Freiman homomorphism.

## Notation

* `A →*[n] β`: Multiplicative `n`-Freiman homomorphism on `A`
* `A →+[n] β`: Additive `n`-Freiman homomorphism on `A`

## Implementation notes

In the context of combinatorics, we are interested in Freiman homomorphisms over sets which are not
necessarily closed under addition/multiplication. This means we must parametrize them with a set in
an `add_monoid`/`monoid` instead of the `add_monoid`/`monoid` itself.

## References

[<NAME>, *18.225: Graph Theory and Additive Combinatorics*](https://yufeizhao.com/gtac/)

## TODO

`monoid_hom.to_freiman_hom` could be relaxed to `mul_hom.to_freiman_hom` by proving
`(s.map f).prod = (t.map f).prod` directly by induction instead of going through `f s.prod`.

Define `n`-Freiman isomorphisms.

Affine maps induce Freiman homs. Concretely, provide the `add_freiman_hom_class (α →ₐ[𝕜] β) A β n`
instance.
-/

open multiset

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

/-- An additive `n`-Freiman homomorphism is a map which preserves sums of `n` elements. -/
structure add_freiman_hom (A : set α) (β : Type*) [add_comm_monoid α] [add_comm_monoid β] (n : ℕ) :=
(to_fun : α → β)
(map_sum_eq_map_sum' {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A)
  (hs : s.card = n) (ht : t.card = n) (h : s.sum = t.sum) :
  (s.map to_fun).sum = (t.map to_fun).sum)

/-- A `n`-Freiman homomorphism on a set `A` is a map which preserves products of `n` elements. -/
@[to_additive add_freiman_hom]
structure freiman_hom (A : set α) (β : Type*) [comm_monoid α] [comm_monoid β] (n : ℕ) :=
(to_fun : α → β)
(map_prod_eq_map_prod' {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A)
  (hs : s.card = n) (ht : t.card = n) (h : s.prod = t.prod) :
  (s.map to_fun).prod = (t.map to_fun).prod)

notation A ` →+[`:25 n:25 `] `:0 β:0 := add_freiman_hom A β n
notation A ` →*[`:25 n:25 `] `:0 β:0 := freiman_hom A β n

/-- `add_freiman_hom_class F s β n` states that `F` is a type of `n`-ary sums-preserving morphisms.
You should extend this class when you extend `add_freiman_hom`. -/
class add_freiman_hom_class (F : Type*) (A : out_param $ set α) (β : out_param $ Type*)
  [add_comm_monoid α] [add_comm_monoid β] (n : ℕ) [fun_like F α (λ _, β)] :=
(map_sum_eq_map_sum' (f : F) {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A)
  (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : s.card = n) (ht : t.card = n) (h : s.sum = t.sum) :
  (s.map f).sum = (t.map f).sum)

/-- `freiman_hom_class F A β n` states that `F` is a type of `n`-ary products-preserving morphisms.
You should extend this class when you extend `freiman_hom`. -/
@[to_additive add_freiman_hom_class
"`add_freiman_hom_class F A β n` states that `F` is a type of `n`-ary sums-preserving morphisms.
You should extend this class when you extend `add_freiman_hom`."]
class freiman_hom_class (F : Type*) (A : out_param $ set α) (β : out_param $ Type*) [comm_monoid α]
  [comm_monoid β] (n : ℕ) [fun_like F α (λ _, β)] :=
(map_prod_eq_map_prod' (f : F) {s t : multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A)
  (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : s.card = n) (ht : t.card = n) (h : s.prod = t.prod) :
  (s.map f).prod = (t.map f).prod)

variables [fun_like F α (λ _, β)]

section comm_monoid
variables [comm_monoid α] [comm_monoid β] [comm_monoid γ] [comm_monoid δ] [comm_group G] {A : set α}
  {B : set β} {C : set γ} {n : ℕ} {a b c d : α}

@[to_additive]
lemma map_prod_eq_map_prod [freiman_hom_class F A β n] (f : F) {s t : multiset α}
  (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : s.card = n) (ht : t.card = n)
  (h : s.prod = t.prod) :
  (s.map f).prod = (t.map f).prod :=
freiman_hom_class.map_prod_eq_map_prod' f hsA htA hs ht h

@[to_additive]
lemma map_mul_map_eq_map_mul_map [freiman_hom_class F A β 2] (f : F) (ha : a ∈ A) (hb : b ∈ A)
  (hc : c ∈ A) (hd : d ∈ A) (h : a * b = c * d) :
  f a * f b = f c * f d :=
begin
  simp_rw ←prod_pair at ⊢ h,
  refine map_prod_eq_map_prod f _ _ (card_pair _ _) (card_pair _ _) h; simp [ha, hb, hc, hd],
end

namespace freiman_hom

@[to_additive]
instance fun_like : fun_like (A →*[n] β) α (λ _, β) :=
{ coe := to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr' }

@[to_additive]
instance freiman_hom_class : freiman_hom_class (A →*[n] β) A β n :=
{ map_prod_eq_map_prod' := map_prod_eq_map_prod' }

/-- Helper instance for when there's too many metavariables to apply
`fun_like.has_coe_to_fun` directly. -/
@[to_additive]
instance : has_coe_to_fun (A →*[n] β) (λ _, α → β) := ⟨to_fun⟩

initialize_simps_projections freiman_hom (to_fun → apply)

@[simp, to_additive]
lemma to_fun_eq_coe (f : A →*[n] β) : f.to_fun = f := rfl

@[ext, to_additive]
lemma ext ⦃f g : A →*[n] β⦄ (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

@[simp, to_additive]
lemma coe_mk (f : α → β) (h : ∀ s t : multiset α, (∀ ⦃x⦄, x ∈ s → x ∈ A) → (∀ ⦃x⦄, x ∈ t → x ∈ A) →
  s.card = n → t.card = n → s.prod = t.prod → (s.map f).prod = (t.map f).prod) :
  ⇑(mk f h) = f := rfl

@[simp, to_additive] lemma mk_coe (f : A →*[n] β) (h) : mk f h = f := ext $ λ _, rfl

/-- The identity map from a commutative monoid to itself. -/
@[to_additive "The identity map from an additive commutative monoid to itself.", simps]
protected def id (A : set α) (n : ℕ) : A →*[n] α  :=
{ to_fun := λ x, x, map_prod_eq_map_prod' := λ s t _ _ _ _ h, by rw [map_id', map_id', h] }

/-- Composition of Freiman homomorphisms as a Freiman homomorphism. -/
@[to_additive "Composition of additive Freiman homomorphisms as an additive Freiman homomorphism."]
protected def comp (f : B →*[n] γ) (g : A →*[n] β) (hAB : A.maps_to g B) : A →*[n] γ :=
{ to_fun := f ∘ g,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h, begin
    rw [←map_map,
    map_prod_eq_map_prod f _ _ ((s.card_map _).trans hs) ((t.card_map _).trans ht)
      (map_prod_eq_map_prod g hsA htA hs ht h), map_map],
    { simpa using (λ a h, hAB (hsA h)) },
    { simpa using (λ a h, hAB (htA h)) }
  end }

@[simp, to_additive]
lemma coe_comp (f : B →*[n] γ) (g : A →*[n] β) {hfg} : ⇑(f.comp g hfg) = f ∘ g := rfl

@[to_additive]
lemma comp_apply (f : B →*[n] γ) (g : A →*[n] β) {hfg} (x : α) : f.comp g hfg x = f (g x) := rfl

@[to_additive]
lemma comp_assoc (f : A →*[n] β) (g : B →*[n] γ) (h : C →*[n] δ) {hf hhg hgf}
  {hh : A.maps_to (g.comp f hgf) C} :
  (h.comp g hhg).comp f hf = h.comp (g.comp f hgf) hh := rfl

@[to_additive]
lemma cancel_right {g₁ g₂ : B →*[n] γ} {f : A →*[n] β} (hf : function.surjective f) {hg₁ hg₂} :
  g₁.comp f hg₁ = g₂.comp f hg₂ ↔ g₁ = g₂ :=
⟨λ h, ext $ hf.forall.2 $ fun_like.ext_iff.1 h, λ h, h ▸ rfl⟩

@[to_additive]
lemma cancel_right_on {g₁ g₂ : B →*[n] γ} {f : A →*[n] β} (hf : A.surj_on f B) {hf'} :
  A.eq_on (g₁.comp f hf') (g₂.comp f hf') ↔ B.eq_on g₁ g₂ :=
hf.cancel_right hf'

@[to_additive]
lemma cancel_left_on {g : B →*[n] γ} {f₁ f₂ : A →*[n] β} (hg : B.inj_on g) {hf₁ hf₂} :
  A.eq_on (g.comp f₁ hf₁) (g.comp f₂ hf₂) ↔ A.eq_on f₁ f₂ :=
hg.cancel_left hf₁ hf₂

@[simp, to_additive] lemma comp_id (f : A →*[n] β) {hf} : f.comp (freiman_hom.id A n) hf = f :=
ext $ λ x, rfl

@[simp, to_additive] lemma id_comp (f : A →*[n] β) {hf} : (freiman_hom.id B n).comp f hf = f :=
ext $ λ x, rfl

/-- `freiman_hom.const A n b` is the Freiman homomorphism sending everything to `b`. -/
@[to_additive "`add_freiman_hom.const n b` is the Freiman homomorphism sending everything to `b`."]
def const (A : set α) (n : ℕ) (b : β) : A →*[n] β :=
{ to_fun := λ _, b,
  map_prod_eq_map_prod' := λ s t _ _ hs ht _,
    by rw [multiset.map_const, multiset.map_const, prod_repeat, prod_repeat, hs, ht] }

@[simp, to_additive] lemma const_apply (n : ℕ) (b : β) (x : α) : const A n b x = b := rfl

@[simp, to_additive]
lemma const_comp (n : ℕ) (c : γ) (f : A →*[n] β) {hf} : (const B n c).comp f hf = const A n c := rfl

/-- `1` is the Freiman homomorphism sending everything to `1`. -/
@[to_additive "`0` is the Freiman homomorphism sending everything to `0`."]
instance : has_one (A →*[n] β) := ⟨const A n 1⟩

@[simp, to_additive] lemma one_apply (x : α) : (1 : A →*[n] β) x = 1 := rfl

@[simp, to_additive] lemma one_comp (f : A →*[n] β) {hf} : (1 : B →*[n] γ).comp f hf = 1 := rfl

@[to_additive] instance : inhabited (A →*[n] β) := ⟨1⟩

/-- `f * g` is the Freiman homomorphism  sends `x` to `f x * g x`. -/
@[to_additive "`f + g` is the Freiman homomorphism sending `x` to `f x + g x`."]
instance : has_mul (A →*[n] β) :=
⟨λ f g, { to_fun := λ x, f x * g x,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
    by rw [prod_map_mul, prod_map_mul, map_prod_eq_map_prod f hsA htA hs ht h,
           map_prod_eq_map_prod g hsA htA hs ht h] }⟩

@[simp, to_additive] lemma mul_apply (f g : A →*[n] β) (x : α) : (f * g) x = f x * g x := rfl

@[to_additive] lemma mul_comp (g₁ g₂ : B →*[n] γ) (f : A →*[n] β) {hg hg₁ hg₂} :
  (g₁ * g₂).comp f hg = g₁.comp f hg₁ * g₂.comp f hg₂ := rfl

/-- If `f` is a Freiman homomorphism to a commutative group, then `f⁻¹` is the Freiman homomorphism
sending `x` to `(f x)⁻¹`. -/
@[to_additive "If `f` is a Freiman homomorphism to an additive commutative group, then `-f` is the
Freiman homomorphism sending `x` to `-f x`."]
instance : has_inv (A →*[n] G) :=
⟨λ f, { to_fun := λ x, (f x)⁻¹,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
    by rw [prod_map_inv, prod_map_inv, map_prod_eq_map_prod f hsA htA hs ht h] }⟩

@[simp, to_additive] lemma inv_apply (f : A →*[n] G) (x : α) : f⁻¹ x = (f x)⁻¹ := rfl

@[simp, to_additive] lemma inv_comp (f : B →*[n] G) (g : A →*[n] β) {hf hf'} :
  f⁻¹.comp g hf = (f.comp g hf')⁻¹ :=
ext $ λ x, rfl

/-- If `f` and `g` are Freiman homomorphisms to a commutative group, then `f / g` is the Freiman
homomorphism sending `x` to `f x / g x`. -/
@[to_additive "If `f` and `g` are additive Freiman homomorphisms to an additive commutative group,
then `f - g` is the additive Freiman homomorphism sending `x` to `f x - g x`"]
instance : has_div (A →*[n] G) :=
⟨λ f g, { to_fun := λ x, f x / g x,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
    by rw [prod_map_div, prod_map_div, map_prod_eq_map_prod f hsA htA hs ht h,
           map_prod_eq_map_prod g hsA htA hs ht h] }⟩

@[simp, to_additive] lemma div_apply (f g : A →*[n] G) (x : α) : (f / g) x = f x / g x := rfl

@[simp, to_additive] lemma div_comp (f₁ f₂ : B →*[n] G) (g : A →*[n] β) {hf hf₁ hf₂} :
  (f₁ / f₂).comp g hf = f₁.comp g hf₁ / f₂.comp g hf₂ :=
ext $ λ x, rfl

/-! ### Instances -/

/-- `A →*[n] β` is a `comm_monoid`. -/
@[to_additive "`α →+[n] β` is an `add_comm_monoid`."]
instance : comm_monoid (A →*[n] β) :=
{ mul := (*),
  mul_assoc := λ a b c, by { ext, apply mul_assoc },
  one := 1,
  one_mul := λ a, by { ext, apply one_mul },
  mul_one := λ a, by { ext, apply mul_one },
  mul_comm :=  λ a b, by { ext, apply mul_comm },
  npow := λ m f,
  { to_fun := λ x, f x ^ m,
    map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
      by rw [prod_map_pow, prod_map_pow, map_prod_eq_map_prod f hsA htA hs ht h] },
  npow_zero' := λ f, by { ext x, exact pow_zero _ },
  npow_succ' := λ n f, by { ext x, exact pow_succ _ _ } }

/-- If `β` is a commutative group, then `A →*[n] β` is a commutative group too. -/
@[to_additive "If `β` is an additive commutative group, then `A →*[n] β` is an additive commutative
group too."]
instance {β} [comm_group β] : comm_group (A →*[n] β) :=
{ inv := has_inv.inv,
  div := has_div.div,
  div_eq_mul_inv := by { intros, ext, apply div_eq_mul_inv },
  mul_left_inv := by { intros, ext, apply mul_left_inv },
  zpow := λ n f, { to_fun := λ x, (f x) ^ n,
    map_prod_eq_map_prod' := λ s t hsA htA hs ht h,
      by rw [prod_map_zpow, prod_map_zpow, map_prod_eq_map_prod f hsA htA hs ht h] },
  zpow_zero' := λ f, by { ext x, exact zpow_zero _ },
  zpow_succ' := λ n f, by { ext x, simp_rw [zpow_of_nat, pow_succ, mul_apply, coe_mk] },
  zpow_neg'  := λ n f, by { ext x, simp_rw [zpow_neg_succ_of_nat, zpow_coe_nat], refl },
  ..freiman_hom.comm_monoid }

end freiman_hom

/-! ### Hom hierarchy -/

--TODO: change to `monoid_hom_class F A β → freiman_hom_class F A β n` once `map_multiset_prod` is
-- generalized
/-- A monoid homomorphism is naturally a `freiman_hom` on its entire domain.

We can't leave the domain `A : set α` of the `freiman_hom` a free variable, since it wouldn't be
inferrable. -/
@[to_additive " An additive monoid homomorphism is naturally an `add_freiman_hom` on its entire
domain.

We can't leave the domain `A : set α` of the `freiman_hom` a free variable, since it wouldn't be
inferrable."]
instance monoid_hom.freiman_hom_class : freiman_hom_class (α →* β) set.univ β n :=
{ map_prod_eq_map_prod' := λ f s t _ _ _ _ h, by rw [←f.map_multiset_prod, h, f.map_multiset_prod] }

/-- A `monoid_hom` is naturally a `freiman_hom`. -/
@[to_additive add_monoid_hom.to_add_freiman_hom "An `add_monoid_hom` is naturally an
`add_freiman_hom`"]
def monoid_hom.to_freiman_hom (A : set α) (n : ℕ) (f : α →* β) : A →*[n] β :=
{ to_fun := f,
  map_prod_eq_map_prod' := λ s t hsA htA, map_prod_eq_map_prod f
    (λ _ _, set.mem_univ _) (λ _ _, set.mem_univ _) }

@[simp, to_additive]
lemma monoid_hom.to_freiman_hom_coe (f : α →* β) : (f.to_freiman_hom A n : α → β) = f := rfl

@[to_additive]
lemma monoid_hom.to_freiman_hom_injective :
  function.injective (monoid_hom.to_freiman_hom A n : (α →* β) → A →*[n] β) :=
λ f g h, monoid_hom.ext $ show _, from fun_like.ext_iff.mp h

end comm_monoid

section cancel_comm_monoid
variables [comm_monoid α] [cancel_comm_monoid β] {A : set α} {m n : ℕ}

@[to_additive]
lemma map_prod_eq_map_prod_of_le [freiman_hom_class F A β n] (f : F) {s t : multiset α}
  (hsA : ∀ x ∈ s, x ∈ A) (htA : ∀ x ∈ t, x ∈ A) (hs : s.card = m)
  (ht : t.card = m) (hst : s.prod = t.prod) (h : m ≤ n) :
  (s.map f).prod = (t.map f).prod :=
begin
  obtain rfl | hm := m.eq_zero_or_pos,
  { rw card_eq_zero at hs ht,
    rw [hs, ht] },
  rw [←hs, card_pos_iff_exists_mem] at hm,
  obtain ⟨a, ha⟩ := hm,
  suffices : ((s + repeat a (n - m)).map f).prod = ((t + repeat a (n - m)).map f).prod,
  { simp_rw [multiset.map_add, prod_add] at this,
    exact mul_right_cancel this },
  replace ha := hsA _ ha,
  refine map_prod_eq_map_prod f (λ x hx, _) (λ x hx, _) _ _ _,
  rotate 2, assumption, -- Can't infer `A` and `n` from the context, so do it manually.
  { rw mem_add at hx,
    refine hx.elim (hsA _) (λ h, _),
    rwa eq_of_mem_repeat h },
  { rw mem_add at hx,
    refine hx.elim (htA _) (λ h, _),
    rwa eq_of_mem_repeat h },
  { rw [card_add, hs, card_repeat, add_tsub_cancel_of_le h] },
  { rw [card_add, ht, card_repeat, add_tsub_cancel_of_le h] },
  { rw [prod_add, prod_add, hst] }
end

/-- `α →*[n] β` is naturally included in  `A →*[m] β` for any `m ≤ n`. -/
@[to_additive add_freiman_hom.to_add_freiman_hom "`α →+[n] β` is naturally included in  `α →+[m] β`
for any `m ≤ n`"]
def freiman_hom.to_freiman_hom (h : m ≤ n) (f : A →*[n] β) : A →*[m] β :=
{ to_fun := f,
  map_prod_eq_map_prod' := λ s t hsA htA hs ht hst,
    map_prod_eq_map_prod_of_le f hsA htA hs ht hst h }

/-- A `n`-Freiman homomorphism is also a `m`-Freiman homomorphism for any `m ≤ n`. -/
@[to_additive add_freiman_hom.add_freiman_hom_class_of_le "An additive `n`-Freiman homomorphism is
also an additive `m`-Freiman homomorphism for any `m ≤ n`."]
def freiman_hom.freiman_hom_class_of_le [freiman_hom_class F A β n] (h : m ≤ n) :
  freiman_hom_class F A β m :=
{ map_prod_eq_map_prod' := λ f s t hsA htA hs ht hst,
    map_prod_eq_map_prod_of_le f hsA htA hs ht hst h }

@[simp, to_additive add_freiman_hom.to_add_freiman_hom_coe]
lemma freiman_hom.to_freiman_hom_coe (h : m ≤ n) (f : A →*[n] β) :
  (f.to_freiman_hom h : α → β) = f := rfl

@[to_additive]
lemma freiman_hom.to_freiman_hom_injective (h : m ≤ n) :
  function.injective (freiman_hom.to_freiman_hom h : (A →*[n] β) → A →*[m] β) :=
λ f g hfg, freiman_hom.ext $ by convert fun_like.ext_iff.1 hfg

end cancel_comm_monoid


<|start_filename|>src/category_theory/limits/shapes/products.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import category_theory.limits.has_limits
import category_theory.discrete_category

/-!
# Categorical (co)products

This file defines (co)products as special cases of (co)limits.

A product is the categorical generalization of the object `Π i, f i` where `f : ι → C`. It is a
limit cone over the diagram formed by `f`, implemented by converting `f` into a functor
`discrete ι ⥤ C`.

A coproduct is the dual concept.

## Main definitions

* a `fan` is a cone over a discrete category
* `fan.mk` constructs a fan from an indexed collection of maps
* a `pi` is a `limit (discrete.functor f)`

Each of these has a dual.

## Implementation notes
As with the other special shapes in the limits library, all the definitions here are given as
`abbreviation`s of the general statements for limits, so all the `simp` lemmas and theorems about
general limits can be used.
-/

noncomputable theory

universes w v u u₂

open category_theory

namespace category_theory.limits

variables {β : Type w}
variables {C : Type u} [category.{v} C]

-- We don't need an analogue of `pair` (for binary products), `parallel_pair` (for equalizers),
-- or `(co)span`, since we already have `discrete.functor`.

local attribute [tidy] tactic.discrete_cases

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
abbreviation fan (f : β → C) := cone (discrete.functor f)
/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
abbreviation cofan (f : β → C) := cocone (discrete.functor f)

/-- A fan over `f : β → C` consists of a collection of maps from an object `P` to every `f b`. -/
@[simps]
def fan.mk {f : β → C} (P : C) (p : Π b, P ⟶ f b) : fan f :=
{ X := P,
  π := { app := λ X, p X.as } }

/-- A cofan over `f : β → C` consists of a collection of maps from every `f b` to an object `P`. -/
@[simps]
def cofan.mk {f : β → C} (P : C) (p : Π b, f b ⟶ P) : cofan f :=
{ X := P,
  ι := { app := λ X, p X.as } }

-- FIXME dualize as needed below (and rename?)

/-- Get the `j`th map in the fan -/
def fan.proj  {f : β → C} (p : fan f) (j : β) : p.X ⟶ f j := p.π.app (discrete.mk j)
@[simp] lemma fan_mk_proj {f : β → C} (P : C) (p : Π b, P ⟶ f b) (j : β) :
  (fan.mk P p).proj j = p j := rfl

/-- An abbreviation for `has_limit (discrete.functor f)`. -/
abbreviation has_product (f : β → C) := has_limit (discrete.functor f)

/-- An abbreviation for `has_colimit (discrete.functor f)`. -/
abbreviation has_coproduct (f : β → C) := has_colimit (discrete.functor f)

/-- Make a fan `f` into a limit fan by providing `lift`, `fac`, and `uniq` --
  just a convenience lemma to avoid having to go through `discrete` -/
@[simps] def mk_fan_limit {f : β → C} (t : fan f)
  (lift : Π s : fan f, s.X ⟶ t.X)
  (fac : ∀ (s : fan f) (j : β), lift s ≫ (t.proj j) = s.proj j)
  (uniq : ∀ (s : fan f) (m : s.X ⟶ t.X) (w : ∀ j : β, m ≫ t.proj j = s.proj j), m = lift s) :
  is_limit t :=
{ lift := lift,
  fac' := λ s j, by convert fac s j.as; simp,
  uniq' := λ s m w, uniq s m (λ j, w (discrete.mk j)), }


section
variables (C)

/-- An abbreviation for `has_limits_of_shape (discrete f)`. -/
abbreviation has_products_of_shape (β : Type v) := has_limits_of_shape.{v} (discrete β)
/-- An abbreviation for `has_colimits_of_shape (discrete f)`. -/
abbreviation has_coproducts_of_shape (β : Type v) := has_colimits_of_shape.{v} (discrete β)
end

/-- `pi_obj f` computes the product of a family of elements `f`.
(It is defined as an abbreviation for `limit (discrete.functor f)`,
so for most facts about `pi_obj f`, you will just use general facts about limits.) -/
abbreviation pi_obj (f : β → C) [has_product f] := limit (discrete.functor f)
/-- `sigma_obj f` computes the coproduct of a family of elements `f`.
(It is defined as an abbreviation for `colimit (discrete.functor f)`,
so for most facts about `sigma_obj f`, you will just use general facts about colimits.) -/
abbreviation sigma_obj (f : β → C) [has_coproduct f] := colimit (discrete.functor f)

notation `∏ ` f:20 := pi_obj f
notation `∐ ` f:20 := sigma_obj f

/-- The `b`-th projection from the pi object over `f` has the form `∏ f ⟶ f b`. -/
abbreviation pi.π (f : β → C) [has_product f] (b : β) : ∏ f ⟶ f b :=
limit.π (discrete.functor f) (discrete.mk b)
/-- The `b`-th inclusion into the sigma object over `f` has the form `f b ⟶ ∐ f`. -/
abbreviation sigma.ι (f : β → C) [has_coproduct f] (b : β) : f b ⟶ ∐ f :=
colimit.ι (discrete.functor f) (discrete.mk b)

/-- The fan constructed of the projections from the product is limiting. -/
def product_is_product (f : β → C) [has_product f] :
  is_limit (fan.mk _ (pi.π f)) :=
is_limit.of_iso_limit (limit.is_limit (discrete.functor f)) (cones.ext (iso.refl _) (by tidy))

/-- The cofan constructed of the inclusions from the coproduct is colimiting. -/
def coproduct_is_coproduct (f : β → C) [has_coproduct f] :
  is_colimit (cofan.mk _ (sigma.ι f)) :=
is_colimit.of_iso_colimit (colimit.is_colimit (discrete.functor f)) (cocones.ext (iso.refl _)
  (by tidy))

/-- A collection of morphisms `P ⟶ f b` induces a morphism `P ⟶ ∏ f`. -/
abbreviation pi.lift {f : β → C} [has_product f] {P : C} (p : Π b, P ⟶ f b) : P ⟶ ∏ f :=
limit.lift _ (fan.mk P p)
/-- A collection of morphisms `f b ⟶ P` induces a morphism `∐ f ⟶ P`. -/
abbreviation sigma.desc {f : β → C} [has_coproduct f] {P : C} (p : Π b, f b ⟶ P) : ∐ f ⟶ P :=
colimit.desc _ (cofan.mk P p)

/--
Construct a morphism between categorical products (indexed by the same type)
from a family of morphisms between the factors.
-/
abbreviation pi.map {f g : β → C} [has_product f] [has_product g]
  (p : Π b, f b ⟶ g b) : ∏ f ⟶ ∏ g :=
lim_map (discrete.nat_trans (λ X, p X.as))
/--
Construct an isomorphism between categorical products (indexed by the same type)
from a family of isomorphisms between the factors.
-/
abbreviation pi.map_iso {f g : β → C} [has_products_of_shape β C]
  (p : Π b, f b ≅ g b) : ∏ f ≅ ∏ g :=
lim.map_iso (discrete.nat_iso (λ X, p X.as))
/--
Construct a morphism between categorical coproducts (indexed by the same type)
from a family of morphisms between the factors.
-/
abbreviation sigma.map {f g : β → C} [has_coproduct f] [has_coproduct g]
  (p : Π b, f b ⟶ g b) : ∐ f ⟶ ∐ g :=
colim_map (discrete.nat_trans (λ X, p X.as))
/--
Construct an isomorphism between categorical coproducts (indexed by the same type)
from a family of isomorphisms between the factors.
-/
abbreviation sigma.map_iso {f g : β → C} [has_coproducts_of_shape β C]
  (p : Π b, f b ≅ g b) : ∐ f ≅ ∐ g :=
colim.map_iso (discrete.nat_iso (λ X, p X.as))

section comparison

variables {D : Type u₂} [category.{v} D] (G : C ⥤ D)
variables (f : β → C)

/-- The comparison morphism for the product of `f`. This is an iso iff `G` preserves the product
of `f`, see `preserves_product.of_iso_comparison`. -/
def pi_comparison [has_product f] [has_product (λ b, G.obj (f b))] :
  G.obj (∏ f) ⟶ ∏ (λ b, G.obj (f b)) :=
pi.lift (λ b, G.map (pi.π f b))

@[simp, reassoc]
lemma pi_comparison_comp_π [has_product f] [has_product (λ b, G.obj (f b))] (b : β) :
  pi_comparison G f ≫ pi.π _ b = G.map (pi.π f b) :=
limit.lift_π _ (discrete.mk b)

@[simp, reassoc]
lemma map_lift_pi_comparison [has_product f] [has_product (λ b, G.obj (f b))]
  (P : C) (g : Π j, P ⟶ f j) :
  G.map (pi.lift g) ≫ pi_comparison G f = pi.lift (λ j, G.map (g j)) :=
by { ext, discrete_cases, simp [← G.map_comp] }

/-- The comparison morphism for the coproduct of `f`. This is an iso iff `G` preserves the coproduct
of `f`, see `preserves_coproduct.of_iso_comparison`. -/
def sigma_comparison [has_coproduct f] [has_coproduct (λ b, G.obj (f b))] :
  ∐ (λ b, G.obj (f b)) ⟶ G.obj (∐ f) :=
sigma.desc (λ b, G.map (sigma.ι f b))

@[simp, reassoc]
lemma ι_comp_sigma_comparison [has_coproduct f] [has_coproduct (λ b, G.obj (f b))] (b : β) :
  sigma.ι _ b ≫ sigma_comparison G f = G.map (sigma.ι f b) :=
colimit.ι_desc _ (discrete.mk b)

@[simp, reassoc]
lemma sigma_comparison_map_desc [has_coproduct f] [has_coproduct (λ b, G.obj (f b))]
  (P : C) (g : Π j, f j ⟶ P) :
  sigma_comparison G f ≫ G.map (sigma.desc g) = sigma.desc (λ j, G.map (g j)) :=
by { ext, discrete_cases, simp [← G.map_comp] }

end comparison

variables (C)

/-- An abbreviation for `Π J, has_limits_of_shape (discrete J) C` -/
abbreviation has_products := Π (J : Type v), has_limits_of_shape (discrete J) C
/-- An abbreviation for `Π J, has_colimits_of_shape (discrete J) C` -/
abbreviation has_coproducts := Π (J : Type v), has_colimits_of_shape (discrete J) C

variable {C}

lemma has_products_of_limit_fans (lf : ∀ {J : Type v} (f : J → C), fan f)
  (lf_is_limit : ∀ {J : Type v} (f : J → C), is_limit (lf f)) : has_products C :=
λ J, { has_limit := λ F, has_limit.mk
  ⟨(cones.postcompose discrete.nat_iso_functor.inv).obj (lf (λ j, F.obj (discrete.mk j))),
    (is_limit.postcompose_inv_equiv _ _).symm (lf_is_limit _)⟩ }

/-!
(Co)products over a type with a unique term.
-/
section unique
variables {C} [unique β] (f : β → C)

/-- The limit cone for the product over an index type with exactly one term. -/
@[simps]
def limit_cone_of_unique : limit_cone (discrete.functor f) :=
{ cone :=
  { X := f default,
    π := { app := λ j, eq_to_hom (by { dsimp, congr, }), }, },
  is_limit :=
  { lift := λ s, s.π.app default,
    fac' := λ s j, begin
      have w := (s.π.naturality (eq_to_hom (unique.default_eq _))).symm,
      dsimp at w,
      simpa [eq_to_hom_map] using w,
    end,
    uniq' := λ s m w, begin
      specialize w default,
      dsimp at w,
      simpa using w,
    end, }, }

@[priority 100] instance has_product_unique : has_product f :=
has_limit.mk (limit_cone_of_unique f)

/-- A product over a index type with exactly one term is just the object over that term. -/
@[simps]
def product_unique_iso : ∏ f ≅ f default :=
is_limit.cone_point_unique_up_to_iso (limit.is_limit _) (limit_cone_of_unique f).is_limit

/-- The colimit cocone for the coproduct over an index type with exactly one term. -/
@[simps]
def colimit_cocone_of_unique : colimit_cocone (discrete.functor f) :=
{ cocone :=
  { X := f default,
    ι := { app := λ j, eq_to_hom (by { discrete_cases, dsimp, congr, }), }, },
  is_colimit :=
  { desc := λ s, s.ι.app default,
    fac' := λ s j, begin
      have w := (s.ι.naturality (eq_to_hom (unique.eq_default _))),
      dsimp at w,
      simpa [eq_to_hom_map] using w,
    end,
    uniq' := λ s m w, begin
      specialize w default,
      dsimp at w,
      simpa using w,
    end, }, }

@[priority 100] instance has_coproduct_unique : has_coproduct f :=
has_colimit.mk (colimit_cocone_of_unique f)

/-- A coproduct over a index type with exactly one term is just the object over that term. -/
@[simps]
def coproduct_unique_iso : ∐ f ≅ f default :=
is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit _)
  (colimit_cocone_of_unique f).is_colimit

end unique

section reindex
variables {C} {γ : Type v} (ε : β ≃ γ) (f : γ → C)

section
variables [has_product f] [has_product (f ∘ ε)]

/-- Reindex a categorical product via an equivalence of the index types. -/
def pi.reindex : pi_obj (f ∘ ε) ≅ pi_obj f :=
has_limit.iso_of_equivalence (discrete.equivalence ε) (discrete.nat_iso (λ i, iso.refl _))

@[simp, reassoc]
lemma pi.reindex_hom_π (b : β) : (pi.reindex ε f).hom ≫ pi.π f (ε b) = pi.π (f ∘ ε) b :=
begin
  dsimp [pi.reindex],
  simp only [has_limit.iso_of_equivalence_hom_π, discrete.nat_iso_inv_app,
    equivalence.equivalence_mk'_counit, discrete.equivalence_counit_iso, discrete.nat_iso_hom_app,
    eq_to_iso.hom, eq_to_hom_map],
  dsimp,
  simpa [eq_to_hom_map] using
    limit.w (discrete.functor (f ∘ ε)) (discrete.eq_to_hom' (ε.symm_apply_apply b)),
end

@[simp, reassoc]
lemma pi.reindex_inv_π (b : β) : (pi.reindex ε f).inv ≫ pi.π (f ∘ ε) b = pi.π f (ε b) :=
by simp [iso.inv_comp_eq]

end

section
variables [has_coproduct f] [has_coproduct (f ∘ ε)]

/-- Reindex a categorical coproduct via an equivalence of the index types. -/
def sigma.reindex : sigma_obj (f ∘ ε) ≅ sigma_obj f :=
has_colimit.iso_of_equivalence (discrete.equivalence ε) (discrete.nat_iso (λ i, iso.refl _))

@[simp, reassoc]
lemma sigma.ι_reindex_hom (b : β) : sigma.ι (f ∘ ε) b ≫ (sigma.reindex ε f).hom = sigma.ι f (ε b) :=
begin
  dsimp [sigma.reindex],
  simp only [has_colimit.iso_of_equivalence_hom_π, equivalence.equivalence_mk'_unit,
    discrete.equivalence_unit_iso, discrete.nat_iso_hom_app, eq_to_iso.hom, eq_to_hom_map,
    discrete.nat_iso_inv_app],
  dsimp,
  simp [eq_to_hom_map,
    ←colimit.w (discrete.functor f) (discrete.eq_to_hom' (ε.apply_symm_apply (ε b)))],
end

@[simp, reassoc]
lemma sigma.ι_reindex_inv (b : β) : sigma.ι f (ε b) ≫ (sigma.reindex ε f).inv = sigma.ι (f ∘ ε) b :=
by simp [iso.comp_inv_eq]

end

end reindex

end category_theory.limits


<|start_filename|>src/analysis/special_functions/integrals.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.integral.interval_integral
import analysis.special_functions.trigonometric.arctan_deriv

/-!
# Integration of specific interval integrals

This file contains proofs of the integrals of various specific functions. This includes:
* Integrals of simple functions, such as `id`, `pow`, `inv`, `exp`, `log`
* Integrals of some trigonometric functions, such as `sin`, `cos`, `1 / (1 + x^2)`
* The integral of `cos x ^ 2 - sin x ^ 2`
* Reduction formulae for the integrals of `sin x ^ n` and `cos x ^ n` for `n ≥ 2`
* The computation of `∫ x in 0..π, sin x ^ n` as a product for even and odd `n` (used in proving the
  Wallis product for pi)
* Integrals of the form `sin x ^ m * cos x ^ n`

With these lemmas, many simple integrals can be computed by `simp` or `norm_num`.
See `test/integration.lean` for specific examples.

This file also contains some facts about the interval integrability of specific functions.

This file is still being developed.

## Tags

integrate, integration, integrable, integrability
-/

open real nat set finset
open_locale real big_operators interval
variables {a b : ℝ} (n : ℕ)

namespace interval_integral
open measure_theory
variables {f : ℝ → ℝ} {μ ν : measure ℝ} [is_locally_finite_measure μ] (c d : ℝ)

/-! ### Interval integrability -/

@[simp]
lemma interval_integrable_pow : interval_integrable (λ x, x^n) μ a b :=
(continuous_pow n).interval_integrable a b

lemma interval_integrable_zpow {n : ℤ} (h : 0 ≤ n ∨ (0 : ℝ) ∉ [a, b]) :
  interval_integrable (λ x, x ^ n) μ a b :=
(continuous_on_id.zpow₀ n $ λ x hx, h.symm.imp (ne_of_mem_of_not_mem hx) id).interval_integrable

lemma interval_integrable_rpow {r : ℝ} (h : 0 ≤ r ∨ (0 : ℝ) ∉ [a, b]) :
  interval_integrable (λ x, x ^ r) μ a b :=
(continuous_on_id.rpow_const $ λ x hx, h.symm.imp (ne_of_mem_of_not_mem hx) id).interval_integrable

/-- Alternative version with a weaker hypothesis on `r`, but assuming the measure is volume. -/
lemma interval_integrable_rpow' {r : ℝ} (h : -1 < r) :
  interval_integrable (λ x, x ^ r) volume a b :=
begin
  suffices : ∀ (c : ℝ), interval_integrable (λ x, x ^ r) volume 0 c,
  { exact interval_integrable.trans (this a).symm (this b) },
  have : ∀ (c : ℝ), (0 ≤ c) → interval_integrable (λ x, x ^ r) volume 0 c,
  { intros c hc,
    rw [interval_integrable_iff, interval_oc_of_le hc],
    have hderiv : ∀ x ∈ Ioo 0 c, has_deriv_at (λ x : ℝ, x ^ (r + 1) / (r + 1)) (x ^ r) x,
    { intros x hx, convert (real.has_deriv_at_rpow_const (or.inl hx.1.ne')).div_const (r + 1),
      field_simp [(by linarith : r + 1 ≠ 0)], ring, },
    apply integrable_on_deriv_of_nonneg hc _ hderiv,
    { intros x hx, apply rpow_nonneg_of_nonneg hx.1.le, },
    { refine (continuous_on_id.rpow_const _).div_const, intros x hx, right, linarith } },
  intro c, rcases le_total 0 c with hc|hc,
  { exact this c hc },
  { rw [interval_integrable.iff_comp_neg, neg_zero],
    have m := (this (-c) (by linarith)).smul (cos (r * π)),
    rw interval_integrable_iff at m ⊢,
    refine m.congr_fun _ measurable_set_Ioc, intros x hx,
    rw interval_oc_of_le (by linarith : 0 ≤ -c) at hx,
    simp only [pi.smul_apply, algebra.id.smul_eq_mul, log_neg_eq_log, mul_comm,
      rpow_def_of_pos hx.1, rpow_def_of_neg (by linarith [hx.1] : -x < 0)], }
end

@[simp]
lemma interval_integrable_id : interval_integrable (λ x, x) μ a b :=
continuous_id.interval_integrable a b

@[simp]
lemma interval_integrable_const : interval_integrable (λ x, c) μ a b :=
continuous_const.interval_integrable a b

@[simp]
lemma interval_integrable.const_mul (h : interval_integrable f ν a b) :
  interval_integrable (λ x, c * f x) ν a b :=
by convert h.smul c

@[simp]
lemma interval_integrable.mul_const (h : interval_integrable f ν a b) :
  interval_integrable (λ x, f x * c) ν a b :=
by simp only [mul_comm, interval_integrable.const_mul c h]

@[simp]
lemma interval_integrable.div (h : interval_integrable f ν a b) :
  interval_integrable (λ x, f x / c) ν a b :=
interval_integrable.mul_const c⁻¹ h

lemma interval_integrable_one_div (h : ∀ x : ℝ, x ∈ [a, b] → f x ≠ 0)
  (hf : continuous_on f [a, b]) :
  interval_integrable (λ x, 1 / f x) μ a b :=
(continuous_on_const.div hf h).interval_integrable

@[simp]
lemma interval_integrable_inv (h : ∀ x : ℝ, x ∈ [a, b] → f x ≠ 0)
  (hf : continuous_on f [a, b]) :
  interval_integrable (λ x, (f x)⁻¹) μ a b :=
by simpa only [one_div] using interval_integrable_one_div h hf

@[simp]
lemma interval_integrable_exp : interval_integrable exp μ a b :=
continuous_exp.interval_integrable a b

@[simp]
lemma interval_integrable.log
  (hf : continuous_on f [a, b]) (h : ∀ x : ℝ, x ∈ [a, b] → f x ≠ 0) :
  interval_integrable (λ x, log (f x)) μ a b :=
(continuous_on.log hf h).interval_integrable

@[simp]
lemma interval_integrable_log (h : (0:ℝ) ∉ [a, b]) :
  interval_integrable log μ a b :=
interval_integrable.log continuous_on_id $ λ x hx, ne_of_mem_of_not_mem hx h

@[simp]
lemma interval_integrable_sin : interval_integrable sin μ a b :=
continuous_sin.interval_integrable a b

@[simp]
lemma interval_integrable_cos : interval_integrable cos μ a b :=
continuous_cos.interval_integrable a b

lemma interval_integrable_one_div_one_add_sq : interval_integrable (λ x : ℝ, 1 / (1 + x^2)) μ a b :=
begin
  refine (continuous_const.div _ (λ x, _)).interval_integrable a b,
  { continuity },
  { nlinarith },
end

@[simp]
lemma interval_integrable_inv_one_add_sq : interval_integrable (λ x : ℝ, (1 + x^2)⁻¹) μ a b :=
by simpa only [one_div] using interval_integrable_one_div_one_add_sq

/-! ### Integrals of the form `c * ∫ x in a..b, f (c * x + d)` -/

@[simp]
lemma mul_integral_comp_mul_right : c * ∫ x in a..b, f (x * c) = ∫ x in a*c..b*c, f x :=
smul_integral_comp_mul_right f c

@[simp]
lemma mul_integral_comp_mul_left : c * ∫ x in a..b, f (c * x) = ∫ x in c*a..c*b, f x :=
smul_integral_comp_mul_left f c

@[simp]
lemma inv_mul_integral_comp_div : c⁻¹ * ∫ x in a..b, f (x / c) = ∫ x in a/c..b/c, f x :=
inv_smul_integral_comp_div f c

@[simp]
lemma mul_integral_comp_mul_add : c * ∫ x in a..b, f (c * x + d) = ∫ x in c*a+d..c*b+d, f x :=
smul_integral_comp_mul_add f c d

@[simp]
lemma mul_integral_comp_add_mul : c * ∫ x in a..b, f (d + c * x) = ∫ x in d+c*a..d+c*b, f x :=
smul_integral_comp_add_mul f c d

@[simp]
lemma inv_mul_integral_comp_div_add : c⁻¹ * ∫ x in a..b, f (x / c + d) = ∫ x in a/c+d..b/c+d, f x :=
inv_smul_integral_comp_div_add f c d

@[simp]
lemma inv_mul_integral_comp_add_div : c⁻¹ * ∫ x in a..b, f (d + x / c) = ∫ x in d+a/c..d+b/c, f x :=
inv_smul_integral_comp_add_div f c d

@[simp]
lemma mul_integral_comp_mul_sub : c * ∫ x in a..b, f (c * x - d) = ∫ x in c*a-d..c*b-d, f x :=
smul_integral_comp_mul_sub f c d

@[simp]
lemma mul_integral_comp_sub_mul : c * ∫ x in a..b, f (d - c * x) = ∫ x in d-c*b..d-c*a, f x :=
smul_integral_comp_sub_mul f c d

@[simp]
lemma inv_mul_integral_comp_div_sub : c⁻¹ * ∫ x in a..b, f (x / c - d) = ∫ x in a/c-d..b/c-d, f x :=
inv_smul_integral_comp_div_sub f c d

@[simp]
lemma inv_mul_integral_comp_sub_div : c⁻¹ * ∫ x in a..b, f (d - x / c) = ∫ x in d-b/c..d-a/c, f x :=
inv_smul_integral_comp_sub_div f c d

end interval_integral

open interval_integral

/-! ### Integrals of simple functions -/

lemma integral_rpow {r : ℝ} (h : -1 < r ∨ (r ≠ -1 ∧ (0 : ℝ) ∉ [a, b])) :
  ∫ x in a..b, x ^ r = (b ^ (r + 1) - a ^ (r + 1)) / (r + 1) :=
begin
  rw sub_div,
  have hderiv : ∀ (x : ℝ), x ≠ 0 → has_deriv_at (λ x : ℝ, x ^ (r + 1) / (r + 1)) (x ^ r) x,
  { intros x hx,
    convert (real.has_deriv_at_rpow_const (or.inl hx)).div_const (r + 1),
    rw [add_sub_cancel, mul_div_cancel_left],
    contrapose! h, rw ←eq_neg_iff_add_eq_zero at h, rw h, tauto, },
  cases h,
  { suffices : ∀ (c : ℝ), ∫ x in 0..c, x ^ r = c ^ (r + 1) / (r + 1),
    { rw [←integral_add_adjacent_intervals
        (interval_integrable_rpow' h) (interval_integrable_rpow' h), this b],
      have t := this a, rw integral_symm at t, apply_fun (λ x, -x) at t, rw neg_neg at t,
      rw t, ring },
    intro c, rcases le_total 0 c with hc|hc,
    { convert integral_eq_sub_of_has_deriv_at_of_le hc _ (λ x hx, hderiv x hx.1.ne') _,
      { rw zero_rpow, ring, linarith,},
      { apply continuous_at.continuous_on, intros x hx,
        refine (continuous_at_id.rpow_const _).div_const, right, linarith,},
      apply interval_integrable_rpow' h },
    { rw integral_symm, symmetry, rw eq_neg_iff_eq_neg,
      convert integral_eq_sub_of_has_deriv_at_of_le hc _ (λ x hx, hderiv x hx.2.ne) _,
      { rw zero_rpow, ring, linarith },
      { apply continuous_at.continuous_on, intros x hx,
        refine (continuous_at_id.rpow_const _).div_const, right, linarith },
      apply interval_integrable_rpow' h, } },
  { have hderiv' : ∀ (x : ℝ), x ∈ [a, b] → has_deriv_at (λ x : ℝ, x ^ (r + 1) / (r + 1)) (x ^ r) x,
    { intros x hx, apply hderiv x, exact ne_of_mem_of_not_mem hx h.2 },
    exact integral_eq_sub_of_has_deriv_at hderiv' (interval_integrable_rpow (or.inr h.2)) },
end

lemma integral_zpow {n : ℤ} (h : 0 ≤ n ∨ n ≠ -1 ∧ (0 : ℝ) ∉ [a, b]) :
  ∫ x in a..b, x ^ n = (b ^ (n + 1) - a ^ (n + 1)) / (n + 1) :=
begin
  replace h : -1 < (n : ℝ) ∨ (n : ℝ) ≠ -1 ∧ (0 : ℝ) ∉ [a, b], by exact_mod_cast h,
  exact_mod_cast integral_rpow h,
end

@[simp] lemma integral_pow : ∫ x in a..b, x ^ n = (b ^ (n + 1) - a ^ (n + 1)) / (n + 1) :=
by simpa using integral_zpow (or.inl (int.coe_nat_nonneg n))

/-- Integral of `|x - a| ^ n` over `Ι a b`. This integral appears in the proof of the
Picard-Lindelöf/Cauchy-Lipschitz theorem. -/
lemma integral_pow_abs_sub_interval_oc :
  ∫ x in Ι a b, |x - a| ^ n = |b - a| ^ (n + 1) / (n + 1) :=
begin
  cases le_or_lt a b with hab hab,
  { calc ∫ x in Ι a b, |x - a| ^ n = ∫ x in a..b, |x - a| ^ n :
      by rw [interval_oc_of_le hab, ← integral_of_le hab]
    ... = ∫ x in 0..(b - a), x ^ n :
      begin
        simp only [integral_comp_sub_right (λ x, |x| ^ n), sub_self],
        refine integral_congr (λ x hx, congr_arg2 has_pow.pow (abs_of_nonneg $ _) rfl),
        rw interval_of_le (sub_nonneg.2 hab) at hx,
        exact hx.1
      end
    ... = |b - a| ^ (n + 1) / (n + 1) : by simp [abs_of_nonneg (sub_nonneg.2 hab)] },
  { calc ∫ x in Ι a b, |x - a| ^ n = ∫ x in b..a, |x - a| ^ n :
      by rw [interval_oc_of_lt hab, ← integral_of_le hab.le]
    ... = ∫ x in b - a..0, (-x) ^ n :
      begin
        simp only [integral_comp_sub_right (λ x, |x| ^ n), sub_self],
        refine integral_congr (λ x hx, congr_arg2 has_pow.pow (abs_of_nonpos $ _) rfl),
        rw interval_of_le (sub_nonpos.2 hab.le) at hx,
        exact hx.2
      end
    ... = |b - a| ^ (n + 1) / (n + 1) :
      by simp [integral_comp_neg (λ x, x ^ n), abs_of_neg (sub_neg.2 hab)] }
end

@[simp]
lemma integral_id : ∫ x in a..b, x = (b ^ 2 - a ^ 2) / 2 :=
by simpa using integral_pow 1

@[simp]
lemma integral_one : ∫ x in a..b, (1 : ℝ) = b - a :=
by simp only [mul_one, smul_eq_mul, integral_const]

lemma integral_const_on_unit_interval : ∫ x in a..(a + 1), b = b :=
by simp

@[simp]
lemma integral_inv (h : (0:ℝ) ∉ [a, b]) : ∫ x in a..b, x⁻¹ = log (b / a) :=
begin
  have h' := λ x hx, ne_of_mem_of_not_mem hx h,
  rw [integral_deriv_eq_sub' _ deriv_log' (λ x hx, differentiable_at_log (h' x hx))
        (continuous_on_inv₀.mono $ subset_compl_singleton_iff.mpr h),
      log_div (h' b right_mem_interval) (h' a left_mem_interval)],
end

@[simp]
lemma integral_inv_of_pos (ha : 0 < a) (hb : 0 < b) : ∫ x in a..b, x⁻¹ = log (b / a) :=
integral_inv $ not_mem_interval_of_lt ha hb

@[simp]
lemma integral_inv_of_neg (ha : a < 0) (hb : b < 0) : ∫ x in a..b, x⁻¹ = log (b / a) :=
integral_inv $ not_mem_interval_of_gt ha hb

lemma integral_one_div (h : (0:ℝ) ∉ [a, b]) : ∫ x : ℝ in a..b, 1/x = log (b / a) :=
by simp only [one_div, integral_inv h]

lemma integral_one_div_of_pos (ha : 0 < a) (hb : 0 < b) : ∫ x : ℝ in a..b, 1/x = log (b / a) :=
by simp only [one_div, integral_inv_of_pos ha hb]

lemma integral_one_div_of_neg (ha : a < 0) (hb : b < 0) : ∫ x : ℝ in a..b, 1/x = log (b / a) :=
by simp only [one_div, integral_inv_of_neg ha hb]

@[simp]
lemma integral_exp : ∫ x in a..b, exp x = exp b - exp a :=
by rw integral_deriv_eq_sub'; norm_num [continuous_on_exp]

lemma integral_exp_mul_complex {c : ℂ} (hc : c ≠ 0) :
  ∫ x in a..b, complex.exp (c * x) = (complex.exp (c * b) - complex.exp (c * a)) / c :=
begin
  have D : ∀ (x : ℝ), has_deriv_at (λ (y : ℝ), complex.exp (c * y) / c) (complex.exp (c * x)) x,
  { intro x,
    conv { congr, skip, rw ←mul_div_cancel (complex.exp (c * x)) hc, },
    convert ((complex.has_deriv_at_exp _).comp x _).div_const c using 1,
    simpa only [complex.of_real_clm_apply, complex.of_real_one, one_mul, mul_one, mul_comm] using
      complex.of_real_clm.has_deriv_at.mul_const c },
  rw integral_deriv_eq_sub' _ (funext (λ x, (D x).deriv)) (λ x hx, (D x).differentiable_at),
  { ring_nf },
  { apply continuous.continuous_on, continuity,}
end

@[simp]
lemma integral_log (h : (0:ℝ) ∉ [a, b]) :
  ∫ x in a..b, log x = b * log b - a * log a - b + a :=
begin
  obtain ⟨h', heq⟩ := ⟨λ x hx, ne_of_mem_of_not_mem hx h, λ x hx, mul_inv_cancel (h' x hx)⟩,
  convert integral_mul_deriv_eq_deriv_mul (λ x hx, has_deriv_at_log (h' x hx))
      (λ x hx, has_deriv_at_id x)
      (continuous_on_inv₀.mono $ subset_compl_singleton_iff.mpr h).interval_integrable
      continuous_on_const.interval_integrable using 1;
    simp [integral_congr heq, mul_comm, ← sub_add],
end

@[simp]
lemma integral_log_of_pos (ha : 0 < a) (hb : 0 < b) :
  ∫ x in a..b, log x = b * log b - a * log a - b + a :=
integral_log $ not_mem_interval_of_lt ha hb

@[simp]
lemma integral_log_of_neg (ha : a < 0) (hb : b < 0) :
  ∫ x in a..b, log x = b * log b - a * log a - b + a :=
integral_log $ not_mem_interval_of_gt ha hb

@[simp]
lemma integral_sin : ∫ x in a..b, sin x = cos a - cos b :=
by rw integral_deriv_eq_sub' (λ x, -cos x); norm_num [continuous_on_sin]

@[simp]
lemma integral_cos : ∫ x in a..b, cos x = sin b - sin a :=
by rw integral_deriv_eq_sub'; norm_num [continuous_on_cos]

lemma integral_cos_sq_sub_sin_sq :
  ∫ x in a..b, cos x ^ 2 - sin x ^ 2 = sin b * cos b - sin a * cos a :=
by simpa only [sq, sub_eq_add_neg, neg_mul_eq_mul_neg] using integral_deriv_mul_eq_sub
  (λ x hx, has_deriv_at_sin x) (λ x hx, has_deriv_at_cos x) continuous_on_cos.interval_integrable
  continuous_on_sin.neg.interval_integrable

@[simp]
lemma integral_inv_one_add_sq : ∫ x : ℝ in a..b, (1 + x^2)⁻¹ = arctan b - arctan a :=
begin
  simp only [← one_div],
  refine integral_deriv_eq_sub' _ _ _ (continuous_const.div _ (λ x, _)).continuous_on,
  { norm_num },
  { norm_num },
  { continuity },
  { nlinarith },
end

lemma integral_one_div_one_add_sq : ∫ x : ℝ in a..b, 1 / (1 + x^2) = arctan b - arctan a :=
by simp only [one_div, integral_inv_one_add_sq]

/-! ### Integral of `sin x ^ n` -/

lemma integral_sin_pow_aux :
  ∫ x in a..b, sin x ^ (n + 2) = sin a ^ (n + 1) * cos a - sin b ^ (n + 1) * cos b
    + (n + 1) * (∫ x in a..b, sin x ^ n) - (n + 1) * ∫ x in a..b, sin x ^ (n + 2) :=
begin
  let C := sin a ^ (n + 1) * cos a - sin b ^ (n + 1) * cos b,
  have h : ∀ α β γ : ℝ, α * (β * α * γ) = β * (α * α * γ) := λ α β γ, by ring,
  have hu : ∀ x ∈ _, has_deriv_at (λ y, sin y ^ (n + 1)) ((n + 1) * cos x * sin x ^ n) x :=
    λ x hx, by simpa only [mul_right_comm] using (has_deriv_at_sin x).pow,
  have hv : ∀ x ∈ [a, b], has_deriv_at (-cos) (sin x) x :=
    λ x hx, by simpa only [neg_neg] using (has_deriv_at_cos x).neg,
  have H := integral_mul_deriv_eq_deriv_mul hu hv _ _,
  calc  ∫ x in a..b, sin x ^ (n + 2)
      = ∫ x in a..b, sin x ^ (n + 1) * sin x                   : by simp only [pow_succ']
  ... = C + (n + 1) * ∫ x in a..b, cos x ^ 2 * sin x ^ n       : by simp [H, h, sq]
  ... = C + (n + 1) * ∫ x in a..b, sin x ^ n - sin x ^ (n + 2) : by simp [cos_sq', sub_mul,
                                                                          ← pow_add, add_comm]
  ... = C + (n + 1) * (∫ x in a..b, sin x ^ n) - (n + 1) * ∫ x in a..b, sin x ^ (n + 2) :
    by rw [integral_sub, mul_sub, add_sub_assoc]; apply continuous.interval_integrable; continuity,
  all_goals { apply continuous.interval_integrable, continuity },
end

/-- The reduction formula for the integral of `sin x ^ n` for any natural `n ≥ 2`. -/
lemma integral_sin_pow :
  ∫ x in a..b, sin x ^ (n + 2) = (sin a ^ (n + 1) * cos a - sin b ^ (n + 1) * cos b) / (n + 2)
    + (n + 1) / (n + 2) * ∫ x in a..b, sin x ^ n :=
begin
  have : (n : ℝ) + 2 ≠ 0 := by exact_mod_cast succ_ne_zero n.succ,
  field_simp,
  convert eq_sub_iff_add_eq.mp (integral_sin_pow_aux n),
  ring,
end

@[simp]
lemma integral_sin_sq : ∫ x in a..b, sin x ^ 2 = (sin a * cos a - sin b * cos b + b - a) / 2 :=
by field_simp [integral_sin_pow, add_sub_assoc]

theorem integral_sin_pow_odd :
  ∫ x in 0..π, sin x ^ (2 * n + 1) = 2 * ∏ i in range n, (2 * i + 2) / (2 * i + 3) :=
begin
  induction n with k ih, { norm_num },
  rw [prod_range_succ_comm, mul_left_comm, ← ih, mul_succ, integral_sin_pow],
  norm_cast,
  simp [-cast_add] with field_simps,
end

theorem integral_sin_pow_even :
  ∫ x in 0..π, sin x ^ (2 * n) = π * ∏ i in range n, (2 * i + 1) / (2 * i + 2) :=
begin
  induction n with k ih, { simp },
  rw [prod_range_succ_comm, mul_left_comm, ← ih, mul_succ, integral_sin_pow],
  norm_cast,
  simp [-cast_add] with field_simps,
end

lemma integral_sin_pow_pos : 0 < ∫ x in 0..π, sin x ^ n :=
begin
  rcases even_or_odd' n with ⟨k, (rfl | rfl)⟩;
  simp only [integral_sin_pow_even, integral_sin_pow_odd];
  refine mul_pos (by norm_num [pi_pos]) (prod_pos (λ n hn, div_pos _ _));
  norm_cast;
  linarith,
end

lemma integral_sin_pow_succ_le : ∫ x in 0..π, sin x ^ (n + 1) ≤ ∫ x in 0..π, sin x ^ n :=
let H := λ x h, pow_le_pow_of_le_one (sin_nonneg_of_mem_Icc h) (sin_le_one x) (n.le_add_right 1) in
by refine integral_mono_on pi_pos.le _ _ H; exact (continuous_sin.pow _).interval_integrable 0 π

lemma integral_sin_pow_antitone : antitone (λ n : ℕ, ∫ x in 0..π, sin x ^ n) :=
antitone_nat_of_succ_le integral_sin_pow_succ_le

/-! ### Integral of `cos x ^ n` -/

lemma integral_cos_pow_aux :
  ∫ x in a..b, cos x ^ (n + 2) = cos b ^ (n + 1) * sin b - cos a ^ (n + 1) * sin a
    + (n + 1) * (∫ x in a..b, cos x ^ n) - (n + 1) * ∫ x in a..b, cos x ^ (n + 2) :=
begin
  let C := cos b ^ (n + 1) * sin b - cos a ^ (n + 1) * sin a,
  have h : ∀ α β γ : ℝ, α * (β * α * γ) = β * (α * α * γ) := λ α β γ, by ring,
  have hu : ∀ x ∈ _, has_deriv_at (λ y, cos y ^ (n + 1)) (-(n + 1) * sin x * cos x ^ n) x :=
    λ x hx, by simpa only [mul_right_comm, neg_mul, mul_neg]
      using (has_deriv_at_cos x).pow,
  have hv : ∀ x ∈ [a, b], has_deriv_at sin (cos x) x := λ x hx, has_deriv_at_sin x,
  have H := integral_mul_deriv_eq_deriv_mul hu hv _ _,
  calc  ∫ x in a..b, cos x ^ (n + 2)
      = ∫ x in a..b, cos x ^ (n + 1) * cos x                   : by simp only [pow_succ']
  ... = C + (n + 1) * ∫ x in a..b, sin x ^ 2 * cos x ^ n       : by simp [H, h, sq, -neg_add_rev]
  ... = C + (n + 1) * ∫ x in a..b, cos x ^ n - cos x ^ (n + 2) : by simp [sin_sq, sub_mul,
                                                                          ← pow_add, add_comm]
  ... = C + (n + 1) * (∫ x in a..b, cos x ^ n) - (n + 1) * ∫ x in a..b, cos x ^ (n + 2) :
    by rw [integral_sub, mul_sub, add_sub_assoc]; apply continuous.interval_integrable; continuity,
  all_goals { apply continuous.interval_integrable, continuity },
end

/-- The reduction formula for the integral of `cos x ^ n` for any natural `n ≥ 2`. -/
lemma integral_cos_pow :
  ∫ x in a..b, cos x ^ (n + 2) = (cos b ^ (n + 1) * sin b - cos a ^ (n + 1) * sin a) / (n + 2)
    + (n + 1) / (n + 2) * ∫ x in a..b, cos x ^ n :=
begin
  have : (n : ℝ) + 2 ≠ 0 := by exact_mod_cast succ_ne_zero n.succ,
  field_simp,
  convert eq_sub_iff_add_eq.mp (integral_cos_pow_aux n),
  ring,
end

@[simp]
lemma integral_cos_sq : ∫ x in a..b, cos x ^ 2 = (cos b * sin b - cos a * sin a + b - a) / 2 :=
by field_simp [integral_cos_pow, add_sub_assoc]

/-! ### Integral of `sin x ^ m * cos x ^ n` -/

/-- Simplification of the integral of `sin x ^ m * cos x ^ n`, case `n` is odd. -/
lemma integral_sin_pow_mul_cos_pow_odd (m n : ℕ) :
  ∫ x in a..b, sin x ^ m * cos x ^ (2 * n + 1) = ∫ u in sin a..sin b, u ^ m * (1 - u ^ 2) ^ n :=
have hc : continuous (λ u : ℝ, u ^ m * (1 - u ^ 2) ^ n), by continuity,
calc  ∫ x in a..b, sin x ^ m * cos x ^ (2 * n + 1)
    = ∫ x in a..b, sin x ^ m * (1 - sin x ^ 2) ^ n * cos x : by simp only [pow_succ', ← mul_assoc,
                                                                           pow_mul, cos_sq']
... = ∫ u in sin a..sin b, u ^ m * (1 - u ^ 2) ^ n         : integral_comp_mul_deriv
                                                              (λ x hx, has_deriv_at_sin x)
                                                                continuous_on_cos hc

/-- The integral of `sin x * cos x`, given in terms of sin².
  See `integral_sin_mul_cos₂` below for the integral given in terms of cos². -/
@[simp]
lemma integral_sin_mul_cos₁ :
  ∫ x in a..b, sin x * cos x = (sin b ^ 2 - sin a ^ 2) / 2 :=
by simpa using integral_sin_pow_mul_cos_pow_odd 1 0

@[simp]
lemma integral_sin_sq_mul_cos :
  ∫ x in a..b, sin x ^ 2 * cos x = (sin b ^ 3 - sin a ^ 3) / 3 :=
by simpa using integral_sin_pow_mul_cos_pow_odd 2 0

@[simp]
lemma integral_cos_pow_three :
  ∫ x in a..b, cos x ^ 3 = sin b - sin a - (sin b ^ 3 - sin a ^ 3) / 3 :=
by simpa using integral_sin_pow_mul_cos_pow_odd 0 1

/-- Simplification of the integral of `sin x ^ m * cos x ^ n`, case `m` is odd. -/
lemma integral_sin_pow_odd_mul_cos_pow (m n : ℕ) :
  ∫ x in a..b, sin x ^ (2 * m + 1) * cos x ^ n = ∫ u in cos b..cos a, u ^ n * (1 - u ^ 2) ^ m :=
have hc : continuous (λ u : ℝ, u ^ n * (1 - u ^ 2) ^ m), by continuity,
calc   ∫ x in a..b, sin x ^ (2 * m + 1) * cos x ^ n
    = -∫ x in b..a, sin x ^ (2 * m + 1) * cos x ^ n          : by rw integral_symm
... =  ∫ x in b..a, (1 - cos x ^ 2) ^ m * -sin x * cos x ^ n : by simp [pow_succ', pow_mul, sin_sq]
... =  ∫ x in b..a, cos x ^ n * (1 - cos x ^ 2) ^ m * -sin x : by { congr, ext, ring }
... =  ∫ u in cos b..cos a, u ^ n * (1 - u ^ 2) ^ m          : integral_comp_mul_deriv
                                                                (λ x hx, has_deriv_at_cos x)
                                                                  continuous_on_sin.neg hc

/-- The integral of `sin x * cos x`, given in terms of cos².
See `integral_sin_mul_cos₁` above for the integral given in terms of sin². -/
lemma integral_sin_mul_cos₂  :
  ∫ x in a..b, sin x * cos x = (cos a ^ 2 - cos b ^ 2) / 2 :=
by simpa using integral_sin_pow_odd_mul_cos_pow 0 1

@[simp]
lemma integral_sin_mul_cos_sq :
  ∫ x in a..b, sin x * cos x ^ 2 = (cos a ^ 3 - cos b ^ 3) / 3 :=
by simpa using integral_sin_pow_odd_mul_cos_pow 0 2

@[simp]
lemma integral_sin_pow_three :
  ∫ x in a..b, sin x ^ 3 = cos a - cos b - (cos a ^ 3 - cos b ^ 3) / 3 :=
by simpa using integral_sin_pow_odd_mul_cos_pow 1 0

/-- Simplification of the integral of `sin x ^ m * cos x ^ n`, case `m` and `n` are both even. -/
lemma integral_sin_pow_even_mul_cos_pow_even (m n : ℕ) :
    ∫ x in a..b, sin x ^ (2 * m) * cos x ^ (2 * n)
  = ∫ x in a..b, ((1 - cos (2 * x)) / 2) ^ m * ((1 + cos (2 * x)) / 2) ^ n :=
by field_simp [pow_mul, sin_sq, cos_sq, ← sub_sub, (by ring : (2:ℝ) - 1 = 1)]

@[simp]
lemma integral_sin_sq_mul_cos_sq :
  ∫ x in a..b, sin x ^ 2 * cos x ^ 2 = (b - a) / 8 - (sin (4 * b) - sin (4 * a)) / 32 :=
begin
  convert integral_sin_pow_even_mul_cos_pow_even 1 1 using 1,
  have h1 : ∀ c : ℝ, (1 - c) / 2 * ((1 + c) / 2) = (1 - c ^ 2) / 4 := λ c, by ring,
  have h2 : continuous (λ x, cos (2 * x) ^ 2) := by continuity,
  have h3 : ∀ x, cos x * sin x = sin (2 * x) / 2, { intro, rw sin_two_mul, ring },
  have h4 : ∀ d : ℝ, 2 * (2 * d) = 4 * d := λ d, by ring,
  simp [h1, h2.interval_integrable, integral_comp_mul_left (λ x, cos x ^ 2), h3, h4],
  ring,
end


<|start_filename|>src/analysis/locally_convex/with_seminorms.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import analysis.seminorm
import analysis.locally_convex.bounded

/-!
# Topology induced by a family of seminorms

## Main definitions

* `seminorm_family.basis_sets`: The set of open seminorm balls for a family of seminorms.
* `seminorm_family.module_filter_basis`: A module filter basis formed by the open balls.
* `seminorm.is_bounded`: A linear map `f : E →ₗ[𝕜] F` is bounded iff every seminorm in `F` can be
bounded by a finite number of seminorms in `E`.

## Main statements

* `continuous_from_bounded`: A bounded linear map `f : E →ₗ[𝕜] F` is continuous.
* `seminorm_family.to_locally_convex_space`: A space equipped with a family of seminorms is locally
convex.

## TODO

Show that for any locally convex space there exist seminorms that induce the topology.

## Tags

seminorm, locally convex
-/

open normed_field set seminorm topological_space
open_locale big_operators nnreal pointwise topological_space

variables {𝕜 E F G ι ι' : Type*}

section filter_basis

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

variables (𝕜 E ι)

/-- An abbreviation for indexed families of seminorms. This is mainly to allow for dot-notation. -/
abbreviation seminorm_family := ι → seminorm 𝕜 E

variables {𝕜 E ι}

namespace seminorm_family

/-- The sets of a filter basis for the neighborhood filter of 0. -/
def basis_sets (p : seminorm_family 𝕜 E ι) : set (set E) :=
⋃ (s : finset ι) r (hr : 0 < r), singleton $ ball (s.sup p) (0 : E) r

variables (p : seminorm_family 𝕜 E ι)

lemma basis_sets_iff {U : set E} :
  U ∈ p.basis_sets ↔ ∃ (i : finset ι) r (hr : 0 < r), U = ball (i.sup p) 0 r :=
by simp only [basis_sets, mem_Union, mem_singleton_iff]

lemma basis_sets_mem (i : finset ι) {r : ℝ} (hr : 0 < r) :
  (i.sup p).ball 0 r ∈ p.basis_sets :=
(basis_sets_iff _).mpr ⟨i,_,hr,rfl⟩

lemma basis_sets_singleton_mem (i : ι) {r : ℝ} (hr : 0 < r) :
  (p i).ball 0 r ∈ p.basis_sets :=
(basis_sets_iff _).mpr ⟨{i},_,hr, by rw finset.sup_singleton⟩

lemma basis_sets_nonempty [nonempty ι] : p.basis_sets.nonempty :=
begin
  let i := classical.arbitrary ι,
  refine set.nonempty_def.mpr ⟨(p i).ball 0 1, _⟩,
  exact p.basis_sets_singleton_mem i zero_lt_one,
end

lemma basis_sets_intersect
  (U V : set E) (hU : U ∈ p.basis_sets) (hV : V ∈ p.basis_sets) :
  ∃ (z : set E) (H : z ∈ p.basis_sets), z ⊆ U ∩ V :=
begin
  classical,
  rcases p.basis_sets_iff.mp hU with ⟨s, r₁, hr₁, hU⟩,
  rcases p.basis_sets_iff.mp hV with ⟨t, r₂, hr₂, hV⟩,
  use ((s ∪ t).sup p).ball 0 (min r₁ r₂),
  refine ⟨p.basis_sets_mem (s ∪ t) (lt_min_iff.mpr ⟨hr₁, hr₂⟩), _⟩,
  rw [hU, hV, ball_finset_sup_eq_Inter _ _ _ (lt_min_iff.mpr ⟨hr₁, hr₂⟩),
    ball_finset_sup_eq_Inter _ _ _ hr₁, ball_finset_sup_eq_Inter _ _ _ hr₂],
  exact set.subset_inter
    (set.Inter₂_mono' $ λ i hi, ⟨i, finset.subset_union_left _ _ hi, ball_mono $ min_le_left _ _⟩)
    (set.Inter₂_mono' $ λ i hi, ⟨i, finset.subset_union_right _ _ hi, ball_mono $
    min_le_right _ _⟩),
end

lemma basis_sets_zero (U) (hU : U ∈ p.basis_sets) :
  (0 : E) ∈ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨ι', r, hr, hU⟩,
  rw [hU, mem_ball_zero, map_zero],
  exact hr,
end

lemma basis_sets_add (U) (hU : U ∈ p.basis_sets) :
  ∃ (V : set E) (H : V ∈ p.basis_sets), V + V ⊆ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  use (s.sup p).ball 0 (r/2),
  refine ⟨p.basis_sets_mem s (div_pos hr zero_lt_two), _⟩,
  refine set.subset.trans (ball_add_ball_subset (s.sup p) (r/2) (r/2) 0 0) _,
  rw [hU, add_zero, add_halves'],
end

lemma basis_sets_neg (U) (hU' : U ∈ p.basis_sets) :
  ∃ (V : set E) (H : V ∈ p.basis_sets), V ⊆ (λ (x : E), -x) ⁻¹' U :=
begin
  rcases p.basis_sets_iff.mp hU' with ⟨s, r, hr, hU⟩,
  rw [hU, neg_preimage, neg_ball (s.sup p), neg_zero],
  exact ⟨U, hU', eq.subset hU⟩,
end

/-- The `add_group_filter_basis` induced by the filter basis `seminorm_basis_zero`. -/
protected def add_group_filter_basis [nonempty ι] : add_group_filter_basis E :=
add_group_filter_basis_of_comm p.basis_sets p.basis_sets_nonempty
  p.basis_sets_intersect p.basis_sets_zero p.basis_sets_add p.basis_sets_neg

lemma basis_sets_smul_right (v : E) (U : set E)
  (hU : U ∈ p.basis_sets) : ∀ᶠ (x : 𝕜) in 𝓝 0, x • v ∈ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  rw [hU, filter.eventually_iff],
  simp_rw [(s.sup p).mem_ball_zero, (s.sup p).smul],
  by_cases h : 0 < (s.sup p) v,
  { simp_rw (lt_div_iff h).symm,
    rw ←_root_.ball_zero_eq,
    exact metric.ball_mem_nhds 0 (div_pos hr h) },
  simp_rw [le_antisymm (not_lt.mp h) ((s.sup p).nonneg v), mul_zero, hr],
  exact is_open.mem_nhds is_open_univ (mem_univ 0),
end

variables [nonempty ι]

lemma basis_sets_smul (U) (hU : U ∈ p.basis_sets) :
  ∃ (V : set 𝕜) (H : V ∈ 𝓝 (0 : 𝕜)) (W : set E)
  (H : W ∈ p.add_group_filter_basis.sets), V • W ⊆ U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  refine ⟨metric.ball 0 r.sqrt, metric.ball_mem_nhds 0 (real.sqrt_pos.mpr hr), _⟩,
  refine ⟨(s.sup p).ball 0 r.sqrt, p.basis_sets_mem s (real.sqrt_pos.mpr hr), _⟩,
  refine set.subset.trans (ball_smul_ball (s.sup p) r.sqrt r.sqrt) _,
  rw [hU, real.mul_self_sqrt (le_of_lt hr)],
end

lemma basis_sets_smul_left (x : 𝕜) (U : set E)
  (hU : U ∈ p.basis_sets) : ∃ (V : set E)
  (H : V ∈ p.add_group_filter_basis.sets), V ⊆ (λ (y : E), x • y) ⁻¹' U :=
begin
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  rw hU,
  by_cases h : x ≠ 0,
  { rw [(s.sup p).smul_ball_preimage 0 r x h, smul_zero],
    use (s.sup p).ball 0 (r / ∥x∥),
    exact ⟨p.basis_sets_mem s (div_pos hr (norm_pos_iff.mpr h)), subset.rfl⟩ },
  refine ⟨(s.sup p).ball 0 r, p.basis_sets_mem s hr, _⟩,
  simp only [not_ne_iff.mp h, subset_def, mem_ball_zero, hr, mem_univ, map_zero,
    implies_true_iff, preimage_const_of_mem, zero_smul],
end

/-- The `module_filter_basis` induced by the filter basis `seminorm_basis_zero`. -/
protected def module_filter_basis : module_filter_basis 𝕜 E :=
{ to_add_group_filter_basis := p.add_group_filter_basis,
  smul' := p.basis_sets_smul,
  smul_left' := p.basis_sets_smul_left,
  smul_right' := p.basis_sets_smul_right }

lemma filter_eq_infi (p : seminorm_family 𝕜 E ι) :
  p.module_filter_basis.to_filter_basis.filter = ⨅ i, (𝓝 0).comap (p i) :=
begin
  refine le_antisymm (le_infi $ λ i, _) _,
  { rw p.module_filter_basis.to_filter_basis.has_basis.le_basis_iff
      (metric.nhds_basis_ball.comap _),
    intros ε hε,
    refine ⟨(p i).ball 0 ε, _, _⟩,
    { rw ← (finset.sup_singleton : _ = p i),
      exact p.basis_sets_mem {i} hε, },
    { rw [id, (p i).ball_zero_eq_preimage_ball] } },
  { rw p.module_filter_basis.to_filter_basis.has_basis.ge_iff,
    rintros U (hU : U ∈ p.basis_sets),
    rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, rfl⟩,
    rw [id, seminorm.ball_finset_sup_eq_Inter _ _ _ hr, s.Inter_mem_sets],
    exact λ i hi, filter.mem_infi_of_mem i ⟨metric.ball 0 r, metric.ball_mem_nhds 0 hr,
      eq.subset ((p i).ball_zero_eq_preimage_ball).symm⟩, },
end

end seminorm_family

end filter_basis

section bounded

namespace seminorm

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [add_comm_group F] [module 𝕜 F]

-- Todo: This should be phrased entirely in terms of the von Neumann bornology.

/-- The proposition that a linear map is bounded between spaces with families of seminorms. -/
def is_bounded (p : ι → seminorm 𝕜 E) (q : ι' → seminorm 𝕜 F) (f : E →ₗ[𝕜] F) : Prop :=
  ∀ i, ∃ s : finset ι, ∃ C : ℝ≥0, C ≠ 0 ∧ (q i).comp f ≤ C • s.sup p

lemma is_bounded_const (ι' : Type*) [nonempty ι']
  {p : ι → seminorm 𝕜 E} {q : seminorm 𝕜 F} (f : E →ₗ[𝕜] F) :
  is_bounded p (λ _ : ι', q) f ↔ ∃ (s : finset ι) C : ℝ≥0, C ≠ 0 ∧ q.comp f ≤ C • s.sup p :=
by simp only [is_bounded, forall_const]

lemma const_is_bounded (ι : Type*) [nonempty ι]
  {p : seminorm 𝕜 E} {q : ι' → seminorm 𝕜 F} (f : E →ₗ[𝕜] F) :
  is_bounded (λ _ : ι, p) q f ↔ ∀ i, ∃ C : ℝ≥0, C ≠ 0 ∧ (q i).comp f ≤ C • p :=
begin
  split; intros h i,
  { rcases h i with ⟨s, C, hC, h⟩,
    exact ⟨C, hC, le_trans h (smul_le_smul (finset.sup_le (λ _ _, le_rfl)) le_rfl)⟩ },
  use [{classical.arbitrary ι}],
  simp only [h, finset.sup_singleton],
end

lemma is_bounded_sup {p : ι → seminorm 𝕜 E} {q : ι' → seminorm 𝕜 F}
  {f : E →ₗ[𝕜] F} (hf : is_bounded p q f) (s' : finset ι') :
  ∃ (C : ℝ≥0) (s : finset ι), 0 < C ∧ (s'.sup q).comp f ≤ C • (s.sup p) :=
begin
  classical,
  by_cases hs' : ¬s'.nonempty,
  { refine ⟨1, ∅, zero_lt_one, _⟩,
    rw [finset.not_nonempty_iff_eq_empty.mp hs', finset.sup_empty, seminorm.bot_eq_zero, zero_comp],
    exact seminorm.nonneg _ },
  rw not_not at hs',
  choose fₛ fC hf using hf,
  use [s'.card • s'.sup fC, finset.bUnion s' fₛ],
  split,
  { refine nsmul_pos _ (ne_of_gt (finset.nonempty.card_pos hs')),
    cases finset.nonempty.bex hs' with j hj,
    exact lt_of_lt_of_le (zero_lt_iff.mpr (and.elim_left (hf j))) (finset.le_sup hj) },
  have hs : ∀ i : ι', i ∈ s' → (q i).comp f ≤ s'.sup fC • ((finset.bUnion s' fₛ).sup p) :=
  begin
    intros i hi,
    refine le_trans (and.elim_right (hf i)) (smul_le_smul _ (finset.le_sup hi)),
    exact finset.sup_mono (finset.subset_bUnion_of_mem fₛ hi),
  end,
  refine le_trans (comp_mono f (finset_sup_le_sum q s')) _,
  simp_rw [←pullback_apply, add_monoid_hom.map_sum, pullback_apply],
  refine le_trans (finset.sum_le_sum hs) _,
  rw [finset.sum_const, smul_assoc],
  exact le_rfl,
end

end seminorm

end bounded

section topology

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [nonempty ι]

/-- The proposition that the topology of `E` is induced by a family of seminorms `p`. -/
class with_seminorms (p : seminorm_family 𝕜 E ι) [t : topological_space E] : Prop :=
(topology_eq_with_seminorms : t = p.module_filter_basis.topology)

lemma seminorm_family.with_seminorms_eq (p : seminorm_family 𝕜 E ι) [t : topological_space E]
  [with_seminorms p] : t = p.module_filter_basis.topology :=
with_seminorms.topology_eq_with_seminorms

variables [topological_space E]
variables (p : seminorm_family 𝕜 E ι) [with_seminorms p]

lemma seminorm_family.has_basis : (𝓝 (0 : E)).has_basis
  (λ (s : set E), s ∈ p.basis_sets) id :=
begin
  rw (congr_fun (congr_arg (@nhds E) p.with_seminorms_eq) 0),
  exact add_group_filter_basis.nhds_zero_has_basis _,
end
end topology

section topological_add_group

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E]
variables [topological_space E] [topological_add_group E]
variables [nonempty ι]

lemma seminorm_family.with_seminorms_of_nhds (p : seminorm_family 𝕜 E ι)
  (h : 𝓝 (0 : E) = p.module_filter_basis.to_filter_basis.filter) :
  with_seminorms p :=
begin
  refine ⟨topological_add_group.ext (by apply_instance)
    (p.add_group_filter_basis.is_topological_add_group) _⟩,
  rw add_group_filter_basis.nhds_zero_eq,
  exact h,
end

lemma seminorm_family.with_seminorms_of_has_basis (p : seminorm_family 𝕜 E ι)
  (h : (𝓝 (0 : E)).has_basis (λ (s : set E), s ∈ p.basis_sets) id) :
  with_seminorms p :=
p.with_seminorms_of_nhds $ filter.has_basis.eq_of_same_basis h
  p.add_group_filter_basis.to_filter_basis.has_basis

lemma seminorm_family.with_seminorms_iff_nhds_eq_infi (p : seminorm_family 𝕜 E ι) :
  with_seminorms p ↔ (𝓝 0 : filter E) = ⨅ i, (𝓝 0).comap (p i) :=
begin
  rw ← p.filter_eq_infi,
  refine ⟨λ h, _, p.with_seminorms_of_nhds⟩,
  rw h.topology_eq_with_seminorms,
  exact add_group_filter_basis.nhds_zero_eq _,
end

end topological_add_group

section normed_space

/-- The topology of a `normed_space 𝕜 E` is induced by the seminorm `norm_seminorm 𝕜 E`. -/
instance norm_with_seminorms (𝕜 E) [normed_field 𝕜] [semi_normed_group E] [normed_space 𝕜 E] :
  with_seminorms (λ (_ : fin 1), norm_seminorm 𝕜 E) :=
begin
  let p : seminorm_family 𝕜 E (fin 1) := λ _, norm_seminorm 𝕜 E,
  refine ⟨topological_add_group.ext normed_top_group
    (p.add_group_filter_basis.is_topological_add_group) _⟩,
  refine filter.has_basis.eq_of_same_basis metric.nhds_basis_ball _,
  rw ←ball_norm_seminorm 𝕜 E,
  refine filter.has_basis.to_has_basis p.add_group_filter_basis.nhds_zero_has_basis _
    (λ r hr, ⟨(norm_seminorm 𝕜 E).ball 0 r, p.basis_sets_singleton_mem 0 hr, rfl.subset⟩),
  rintros U (hU : U ∈ p.basis_sets),
  rcases p.basis_sets_iff.mp hU with ⟨s, r, hr, hU⟩,
  use [r, hr],
  rw [hU, id.def],
  by_cases h : s.nonempty,
  { rw finset.sup_const h },
  rw [finset.not_nonempty_iff_eq_empty.mp h, finset.sup_empty, ball_bot _ hr],
  exact set.subset_univ _,
end

end normed_space

section nondiscrete_normed_field

variables [nondiscrete_normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [nonempty ι]
variables (p : seminorm_family 𝕜 E ι)
variables [topological_space E] [with_seminorms p]

lemma bornology.is_vonN_bounded_iff_finset_seminorm_bounded {s : set E} :
  bornology.is_vonN_bounded 𝕜 s ↔ ∀ I : finset ι, ∃ r (hr : 0 < r), ∀ (x ∈ s), I.sup p x < r :=
begin
  rw (p.has_basis).is_vonN_bounded_basis_iff,
  split,
  { intros h I,
    simp only [id.def] at h,
    specialize h ((I.sup p).ball 0 1) (p.basis_sets_mem I zero_lt_one),
    rcases h with ⟨r, hr, h⟩,
    cases normed_field.exists_lt_norm 𝕜 r with a ha,
    specialize h a (le_of_lt ha),
    rw [seminorm.smul_ball_zero (lt_trans hr ha), mul_one] at h,
    refine ⟨∥a∥, lt_trans hr ha, _⟩,
    intros x hx,
    specialize h hx,
    exact (finset.sup I p).mem_ball_zero.mp h },
  intros h s' hs',
  rcases p.basis_sets_iff.mp hs' with ⟨I, r, hr, hs'⟩,
  rw [id.def, hs'],
  rcases h I with ⟨r', hr', h'⟩,
  simp_rw ←(I.sup p).mem_ball_zero at h',
  refine absorbs.mono_right _ h',
  exact (finset.sup I p).ball_zero_absorbs_ball_zero hr,
end

lemma bornology.is_vonN_bounded_iff_seminorm_bounded {s : set E} :
  bornology.is_vonN_bounded 𝕜 s ↔ ∀ i : ι, ∃ r (hr : 0 < r), ∀ (x ∈ s), p i x < r :=
begin
  rw bornology.is_vonN_bounded_iff_finset_seminorm_bounded p,
  split,
  { intros hI i,
    convert hI {i},
    rw [finset.sup_singleton] },
  intros hi I,
  by_cases hI : I.nonempty,
  { choose r hr h using hi,
    have h' : 0 < I.sup' hI r :=
    by { rcases hI.bex with ⟨i, hi⟩, exact lt_of_lt_of_le (hr i) (finset.le_sup' r hi) },
    refine ⟨I.sup' hI r, h', λ x hx, finset_sup_apply_lt h' (λ i hi, _)⟩,
    refine lt_of_lt_of_le (h i x hx) _,
    simp only [finset.le_sup'_iff, exists_prop],
    exact ⟨i, hi, (eq.refl _).le⟩ },
  simp only [finset.not_nonempty_iff_eq_empty.mp hI, finset.sup_empty, coe_bot, pi.zero_apply,
    exists_prop],
  exact ⟨1, zero_lt_one, λ _ _, zero_lt_one⟩,
end

end nondiscrete_normed_field
section continuous_bounded

namespace seminorm

variables [normed_field 𝕜] [add_comm_group E] [module 𝕜 E] [add_comm_group F] [module 𝕜 F]
variables [nonempty ι] [nonempty ι']

lemma continuous_from_bounded (p : seminorm_family 𝕜 E ι) (q : seminorm_family 𝕜 F ι')
  [uniform_space E] [uniform_add_group E] [with_seminorms p]
  [uniform_space F] [uniform_add_group F] [with_seminorms q]
  (f : E →ₗ[𝕜] F) (hf : seminorm.is_bounded p q f) : continuous f :=
begin
  refine continuous_of_continuous_at_zero f _,
  rw [continuous_at_def, f.map_zero, p.with_seminorms_eq],
  intros U hU,
  rw [q.with_seminorms_eq, add_group_filter_basis.nhds_zero_eq, filter_basis.mem_filter_iff] at hU,
  rcases hU with ⟨V, hV : V ∈ q.basis_sets, hU⟩,
  rcases q.basis_sets_iff.mp hV with ⟨s₂, r, hr, hV⟩,
  rw hV at hU,
  rw [p.add_group_filter_basis.nhds_zero_eq, filter_basis.mem_filter_iff],
  rcases (seminorm.is_bounded_sup hf s₂) with ⟨C, s₁, hC, hf⟩,
  refine ⟨(s₁.sup p).ball 0 (r/C), p.basis_sets_mem _ (div_pos hr (nnreal.coe_pos.mpr hC)), _⟩,
  refine subset.trans _ (preimage_mono hU),
  simp_rw [←linear_map.map_zero f, ←ball_comp],
  refine subset.trans _ (ball_antitone hf),
  rw ball_smul (s₁.sup p) hC,
end

lemma cont_with_seminorms_normed_space (F) [semi_normed_group F] [normed_space 𝕜 F]
  [uniform_space E] [uniform_add_group E]
  (p : ι → seminorm 𝕜 E) [with_seminorms p] (f : E →ₗ[𝕜] F)
  (hf : ∃ (s : finset ι) C : ℝ≥0, C ≠ 0 ∧ (norm_seminorm 𝕜 F).comp f ≤ C • s.sup p) :
  continuous f :=
begin
  rw ←seminorm.is_bounded_const (fin 1) at hf,
  exact continuous_from_bounded p (λ _ : fin 1, norm_seminorm 𝕜 F) f hf,
end

lemma cont_normed_space_to_with_seminorms (E) [semi_normed_group E] [normed_space 𝕜 E]
  [uniform_space F] [uniform_add_group F]
  (q : ι → seminorm 𝕜 F) [with_seminorms q] (f : E →ₗ[𝕜] F)
  (hf : ∀ i : ι, ∃ C : ℝ≥0, C ≠ 0 ∧ (q i).comp f ≤ C • (norm_seminorm 𝕜 E)) : continuous f :=
begin
  rw ←seminorm.const_is_bounded (fin 1) at hf,
  exact continuous_from_bounded (λ _ : fin 1, norm_seminorm 𝕜 E) q f hf,
end

end seminorm

end continuous_bounded

section locally_convex_space

open locally_convex_space

variables [nonempty ι] [normed_field 𝕜] [normed_space ℝ 𝕜]
  [add_comm_group E] [module 𝕜 E] [module ℝ E] [is_scalar_tower ℝ 𝕜 E] [topological_space E]
  [topological_add_group E]

lemma seminorm_family.to_locally_convex_space (p : seminorm_family 𝕜 E ι) [with_seminorms p] :
  locally_convex_space ℝ E :=
begin
  apply of_basis_zero ℝ E id (λ s, s ∈ p.basis_sets),
  { rw [p.with_seminorms_eq, add_group_filter_basis.nhds_eq _, add_group_filter_basis.N_zero],
    exact filter_basis.has_basis _ },
  { intros s hs,
    change s ∈ set.Union _ at hs,
    simp_rw [set.mem_Union, set.mem_singleton_iff] at hs,
    rcases hs with ⟨I, r, hr, rfl⟩,
    exact convex_ball _ _ _ }
end

end locally_convex_space

section normed_space

variables (𝕜) [normed_field 𝕜] [normed_space ℝ 𝕜] [semi_normed_group E]

/-- Not an instance since `𝕜` can't be inferred. See `normed_space.to_locally_convex_space` for a
slightly weaker instance version. -/
lemma normed_space.to_locally_convex_space' [normed_space 𝕜 E] [module ℝ E]
  [is_scalar_tower ℝ 𝕜 E] : locally_convex_space ℝ E :=
seminorm_family.to_locally_convex_space (λ _ : fin 1, norm_seminorm 𝕜 E)

/-- See `normed_space.to_locally_convex_space'` for a slightly stronger version which is not an
instance. -/
instance normed_space.to_locally_convex_space [normed_space ℝ E] :
  locally_convex_space ℝ E :=
normed_space.to_locally_convex_space' ℝ

end normed_space

section topological_constructions

variables [normed_field 𝕜] [add_comm_group F] [module 𝕜 F] [add_comm_group E] [module 𝕜 E]

/-- The family of seminorms obtained by composing each seminorm by a linear map. -/
def seminorm_family.comp (q : seminorm_family 𝕜 F ι) (f : E →ₗ[𝕜] F) :
  seminorm_family 𝕜 E ι :=
λ i, (q i).comp f

lemma seminorm_family.comp_apply (q : seminorm_family 𝕜 F ι) (i : ι) (f : E →ₗ[𝕜] F) :
  q.comp f i = (q i).comp f :=
rfl

lemma seminorm_family.finset_sup_comp (q : seminorm_family 𝕜 F ι) (s : finset ι)
  (f : E →ₗ[𝕜] F) : (s.sup q).comp f = s.sup (q.comp f) :=
begin
  ext x,
  rw [seminorm.comp_apply, seminorm.finset_sup_apply, seminorm.finset_sup_apply],
  refl
end

variables [topological_space F] [topological_add_group F]

lemma linear_map.with_seminorms_induced [hι : nonempty ι] {q : seminorm_family 𝕜 F ι}
  [hq : with_seminorms q] (f : E →ₗ[𝕜] F) :
  @with_seminorms 𝕜 E ι _ _ _ _ (q.comp f) (induced f infer_instance) :=
begin
  letI : topological_space E := induced f infer_instance,
  letI : topological_add_group E := topological_add_group_induced f,
  rw [(q.comp f).with_seminorms_iff_nhds_eq_infi, nhds_induced, map_zero,
      q.with_seminorms_iff_nhds_eq_infi.mp hq, filter.comap_infi],
  refine infi_congr (λ i, _),
  exact filter.comap_comap
end

lemma inducing.with_seminorms [hι : nonempty ι] {q : seminorm_family 𝕜 F ι}
  [hq : with_seminorms q] [topological_space E] {f : E →ₗ[𝕜] F} (hf : inducing f) :
  with_seminorms (q.comp f) :=
begin
  rw hf.induced,
  exact f.with_seminorms_induced
end

end topological_constructions


<|start_filename|>src/data/nat/choose/factorization.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/

import data.nat.choose.central
import number_theory.padics.padic_norm
import data.nat.multiplicity

/-!
# Factorization of Binomial Coefficients

This file contains a few results on the multiplicity of prime factors within certain size
bounds in binomial coefficients. These include:

* `nat.factorization_choose_le_log`: a logarithmic upper bound on the multiplicity of a prime in
  a binomial coefficient.
* `nat.factorization_choose_le_one`: Primes above `sqrt n` appear at most once
  in the factorization of `n` choose `k`.
* `nat.factorization_central_binom_of_two_mul_self_lt_three_mul`: Primes from `2 * n / 3` to `n`
do not appear in the factorization of the `n`th central binomial coefficient.
* `nat.factorization_choose_eq_zero_of_lt`: Primes greater than `n` do not
  appear in the factorization of `n` choose `k`.

These results appear in the [Erdős proof of Bertrand's postulate](aigner1999proofs).
-/

namespace nat

variables {p n k : ℕ}

/--
A logarithmic upper bound on the multiplicity of a prime in a binomial coefficient.
-/
lemma factorization_choose_le_log : (choose n k).factorization p ≤ log p n :=
begin
  by_cases h : (choose n k).factorization p = 0, { simp [h] },
  have hp : p.prime := not.imp_symm (choose n k).factorization_eq_zero_of_non_prime h,
  have hkn : k ≤ n, { refine le_of_not_lt (λ hnk, h _), simp [choose_eq_zero_of_lt hnk] },
  rw [←@padic_val_nat_eq_factorization p _ ⟨hp⟩, @padic_val_nat_def _ ⟨hp⟩ _ (choose_pos hkn)],
  simp only [hp.multiplicity_choose hkn (lt_add_one _), enat.get_coe],
  refine (finset.card_filter_le _ _).trans (le_of_eq (nat.card_Ico _ _)),
end

/--
A `pow` form of `nat.factorization_choose_le`
-/
lemma pow_factorization_choose_le (hn : 0 < n) : p ^ (choose n k).factorization p ≤ n :=
begin
  cases le_or_lt p 1,
  { exact (pow_le_pow_of_le h).trans ((le_of_eq (one_pow _)).trans hn) },
  { exact (pow_le_iff_le_log h hn).mpr factorization_choose_le_log },
end

/--
Primes greater than about `sqrt n` appear only to multiplicity 0 or 1 in the binomial coefficient.
-/
lemma factorization_choose_le_one (p_large : n < p ^ 2) : (choose n k).factorization p ≤ 1 :=
begin
  apply factorization_choose_le_log.trans,
  rcases n.eq_zero_or_pos with rfl | hn0, { simp },
  refine lt_succ_iff.1 ((lt_pow_iff_log_lt _ hn0).1 p_large),
  contrapose! hn0,
  exact lt_succ_iff.1 (lt_of_lt_of_le p_large (pow_le_one' hn0 2)),
end

lemma factorization_choose_of_lt_three_mul
  (hp' : p ≠ 2) (hk : p ≤ k) (hk' : p ≤ n - k) (hn : n < 3 * p) :
  (choose n k).factorization p = 0 :=
begin
  cases em' p.prime with hp hp,
  { exact factorization_eq_zero_of_non_prime (choose n k) hp },
  cases lt_or_le n k with hnk hkn,
  { simp [choose_eq_zero_of_lt hnk] },
  rw [←@padic_val_nat_eq_factorization p _ ⟨hp⟩, @padic_val_nat_def _ ⟨hp⟩ _ (choose_pos hkn)],
  simp only [hp.multiplicity_choose hkn (lt_add_one _), enat.get_coe,
    finset.card_eq_zero, finset.filter_eq_empty_iff, not_le],
  intros i hi,
  rcases eq_or_lt_of_le (finset.mem_Ico.mp hi).1 with rfl | hi,
  { rw [pow_one, ←add_lt_add_iff_left (2 * p), ←succ_mul, two_mul, add_add_add_comm],
    exact lt_of_le_of_lt (add_le_add
      (add_le_add_right (le_mul_of_one_le_right' ((one_le_div_iff hp.pos).mpr hk)) (k % p))
      (add_le_add_right (le_mul_of_one_le_right' ((one_le_div_iff hp.pos).mpr hk')) ((n - k) % p)))
      (by rwa [div_add_mod, div_add_mod, add_tsub_cancel_of_le hkn]) },
  { replace hn : n < p ^ i,
    { calc n < 3 * p : hn
      ... ≤ p * p : mul_le_mul_right' (lt_of_le_of_ne hp.two_le hp'.symm) p
      ... = p ^ 2 : (sq p).symm
      ... ≤ p ^ i : pow_le_pow hp.one_lt.le hi },
    rwa [mod_eq_of_lt (lt_of_le_of_lt hkn hn), mod_eq_of_lt (lt_of_le_of_lt tsub_le_self hn),
      add_tsub_cancel_of_le hkn] },
end

/--
Primes greater than about `2 * n / 3` and less than `n` do not appear in the factorization of
`central_binom n`.
-/
lemma factorization_central_binom_of_two_mul_self_lt_three_mul
  (n_big : 2 < n) (p_le_n : p ≤ n) (big : 2 * n < 3 * p) :
  (central_binom n).factorization p = 0 :=
begin
  refine factorization_choose_of_lt_three_mul _ p_le_n (p_le_n.trans _) big,
  { rintro rfl, linarith },
  { rw [two_mul, add_tsub_cancel_left] },
end

lemma factorization_factorial_eq_zero_of_lt (h : n < p) :
  (factorial n).factorization p = 0 :=
begin
  induction n with n hn, { simp },
  rw [factorial_succ, factorization_mul n.succ_ne_zero n.factorial_ne_zero, finsupp.coe_add,
      pi.add_apply, hn (lt_of_succ_lt h), add_zero, factorization_eq_zero_of_lt h],
end

lemma factorization_choose_eq_zero_of_lt (h : n < p) :
  (choose n k).factorization p = 0 :=
begin
  by_cases hnk : n < k, { simp [choose_eq_zero_of_lt hnk] },
  rw [choose_eq_factorial_div_factorial (le_of_not_lt hnk),
      factorization_div (factorial_mul_factorial_dvd_factorial (le_of_not_lt hnk)),
      finsupp.coe_tsub, pi.sub_apply, factorization_factorial_eq_zero_of_lt h, zero_tsub],
end

/--
If a prime `p` has positive multiplicity in the `n`th central binomial coefficient,
`p` is no more than `2 * n`
-/
lemma factorization_central_binom_eq_zero_of_two_mul_lt (h : 2 * n < p) :
  (central_binom n).factorization p = 0 :=
factorization_choose_eq_zero_of_lt h

/--
Contrapositive form of `nat.factorization_central_binom_eq_zero_of_two_mul_lt`
-/
lemma le_two_mul_of_factorization_central_binom_pos
  (h_pos : 0 < (central_binom n).factorization p) : p ≤ 2 * n :=
le_of_not_lt (pos_iff_ne_zero.mp h_pos ∘ factorization_central_binom_eq_zero_of_two_mul_lt)

end nat


<|start_filename|>src/data/finset/lattice.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.finset.fold
import data.finset.option
import data.finset.prod
import data.multiset.lattice
import order.complete_lattice

/-!
# Lattice operations on finsets
-/

variables {α β γ ι : Type*}

namespace finset
open multiset order_dual

/-! ### sup -/
section sup
-- TODO: define with just `[has_bot α]` where some lemmas hold without requiring `[order_bot α]`
variables [semilattice_sup α] [order_bot α]

/-- Supremum of a finite set: `sup {a, b, c} f = f a ⊔ f b ⊔ f c` -/
def sup (s : finset β) (f : β → α) : α := s.fold (⊔) ⊥ f

variables {s s₁ s₂ : finset β} {f g : β → α}

lemma sup_def : s.sup f = (s.1.map f).sup := rfl

@[simp] lemma sup_empty : (∅ : finset β).sup f = ⊥ :=
fold_empty

@[simp] lemma sup_cons {b : β} (h : b ∉ s) : (cons b s h).sup f = f b ⊔ s.sup f :=
fold_cons h

@[simp] lemma sup_insert [decidable_eq β] {b : β} : (insert b s : finset β).sup f = f b ⊔ s.sup f :=
fold_insert_idem

lemma sup_image [decidable_eq β] (s : finset γ) (f : γ → β) (g : β → α) :
  (s.image f).sup g = s.sup (g ∘ f) :=
fold_image_idem

@[simp] lemma sup_map (s : finset γ) (f : γ ↪ β) (g : β → α) :
  (s.map f).sup g = s.sup (g ∘ f) :=
fold_map

@[simp] lemma sup_singleton {b : β} : ({b} : finset β).sup f = f b :=
sup_singleton

lemma sup_union [decidable_eq β] : (s₁ ∪ s₂).sup f = s₁.sup f ⊔ s₂.sup f :=
finset.induction_on s₁ (by rw [empty_union, sup_empty, bot_sup_eq]) $ λ a s has ih,
by rw [insert_union, sup_insert, sup_insert, ih, sup_assoc]

lemma sup_sup : s.sup (f ⊔ g) = s.sup f ⊔ s.sup g :=
begin
  refine finset.cons_induction_on s _ (λ b t _ h, _),
  { rw [sup_empty, sup_empty, sup_empty, bot_sup_eq] },
  { rw [sup_cons, sup_cons, sup_cons, h],
    exact sup_sup_sup_comm _ _ _ _ }
end

theorem sup_congr {f g : β → α} (hs : s₁ = s₂) (hfg : ∀a∈s₂, f a = g a) : s₁.sup f = s₂.sup g :=
by subst hs; exact finset.fold_congr hfg

@[simp] protected lemma sup_le_iff {a : α} : s.sup f ≤ a ↔ (∀b ∈ s, f b ≤ a) :=
begin
  apply iff.trans multiset.sup_le,
  simp only [multiset.mem_map, and_imp, exists_imp_distrib],
  exact ⟨λ k b hb, k _ _ hb rfl, λ k a' b hb h, h ▸ k _ hb⟩,
end

@[simp] lemma sup_bUnion [decidable_eq β] (s : finset γ) (t : γ → finset β) :
  (s.bUnion t).sup f = s.sup (λ x, (t x).sup f) :=
eq_of_forall_ge_iff $ λ c, by simp [@forall_swap _ β]

lemma sup_const {s : finset β} (h : s.nonempty) (c : α) : s.sup (λ _, c) = c :=
eq_of_forall_ge_iff $ λ b, finset.sup_le_iff.trans h.forall_const

@[simp] lemma sup_bot (s : finset β) : s.sup (λ _, ⊥) = (⊥ : α) :=
begin
  obtain rfl | hs := s.eq_empty_or_nonempty,
  { exact sup_empty },
  { exact sup_const hs _ }
end

lemma sup_ite (p : β → Prop) [decidable_pred p] :
  s.sup (λ i, ite (p i) (f i) (g i)) =
    (s.filter p).sup f ⊔ (s.filter (λ i, ¬ p i)).sup g :=
fold_ite _

lemma sup_le {a : α} : (∀b ∈ s, f b ≤ a) → s.sup f ≤ a :=
finset.sup_le_iff.2

lemma le_sup {b : β} (hb : b ∈ s) : f b ≤ s.sup f :=
finset.sup_le_iff.1 le_rfl _ hb

lemma sup_mono_fun {g : β → α} (h : ∀b∈s, f b ≤ g b) : s.sup f ≤ s.sup g :=
sup_le (λ b hb, le_trans (h b hb) (le_sup hb))

lemma sup_mono (h : s₁ ⊆ s₂) : s₁.sup f ≤ s₂.sup f :=
sup_le $ assume b hb, le_sup (h hb)

lemma sup_comm (s : finset β) (t : finset γ) (f : β → γ → α) :
  s.sup (λ b, t.sup (f b)) = t.sup (λ c, s.sup (λ b, f b c)) :=
begin
  refine eq_of_forall_ge_iff (λ a, _),
  simp_rw finset.sup_le_iff,
  exact ⟨λ h c hc b hb, h b hb c hc, λ h b hb c hc, h c hc b hb⟩,
end

@[simp] lemma sup_attach (s : finset β) (f : β → α) : s.attach.sup (λ x, f x) = s.sup f :=
(s.attach.sup_map (function.embedding.subtype _) f).symm.trans $ congr_arg _ attach_map_val

/-- See also `finset.product_bUnion`. -/
lemma sup_product_left (s : finset β) (t : finset γ) (f : β × γ → α) :
  (s.product t).sup f = s.sup (λ i, t.sup $ λ i', f ⟨i, i'⟩) :=
begin
  refine le_antisymm _ (sup_le (λ i hi, sup_le $ λ i' hi', le_sup $ mem_product.2 ⟨hi, hi'⟩)),
  refine sup_le _,
  rintro ⟨i, i'⟩ hi,
  rw mem_product at hi,
  refine le_trans _ (le_sup hi.1),
  convert le_sup hi.2,
end

lemma sup_product_right (s : finset β) (t : finset γ) (f : β × γ → α) :
  (s.product t).sup f = t.sup (λ i', s.sup $ λ i, f ⟨i, i'⟩) :=
by rw [sup_product_left, sup_comm]

@[simp] lemma sup_erase_bot [decidable_eq α] (s : finset α) : (s.erase ⊥).sup id = s.sup id :=
begin
  refine (sup_mono (s.erase_subset _)).antisymm (finset.sup_le_iff.2 $ λ a ha, _),
  obtain rfl | ha' := eq_or_ne a ⊥,
  { exact bot_le },
  { exact le_sup (mem_erase.2 ⟨ha', ha⟩) }
end

lemma sup_sdiff_right {α β : Type*} [generalized_boolean_algebra α] (s : finset β) (f : β → α)
  (a : α) :
  s.sup (λ b, f b \ a) = s.sup f \ a :=
begin
  refine finset.cons_induction_on s _ (λ b t _ h, _),
  { rw [sup_empty, sup_empty, bot_sdiff] },
  { rw [sup_cons, sup_cons, h, sup_sdiff] }
end

lemma comp_sup_eq_sup_comp [semilattice_sup γ] [order_bot γ] {s : finset β}
  {f : β → α} (g : α → γ) (g_sup : ∀ x y, g (x ⊔ y) = g x ⊔ g y) (bot : g ⊥ = ⊥) :
  g (s.sup f) = s.sup (g ∘ f) :=
finset.cons_induction_on s bot (λ c t hc ih, by rw [sup_cons, sup_cons, g_sup, ih])

/-- Computing `sup` in a subtype (closed under `sup`) is the same as computing it in `α`. -/
lemma sup_coe {P : α → Prop}
  {Pbot : P ⊥} {Psup : ∀{{x y}}, P x → P y → P (x ⊔ y)}
  (t : finset β) (f : β → {x : α // P x}) :
  (@sup _ _ (subtype.semilattice_sup Psup) (subtype.order_bot Pbot) t f : α) = t.sup (λ x, f x) :=
by { rw [comp_sup_eq_sup_comp coe]; intros; refl }

@[simp] lemma sup_to_finset {α β} [decidable_eq β]
  (s : finset α) (f : α → multiset β) :
  (s.sup f).to_finset = s.sup (λ x, (f x).to_finset) :=
comp_sup_eq_sup_comp multiset.to_finset to_finset_union rfl

theorem subset_range_sup_succ (s : finset ℕ) : s ⊆ range (s.sup id).succ :=
λ n hn, mem_range.2 $ nat.lt_succ_of_le $ le_sup hn

theorem exists_nat_subset_range (s : finset ℕ) : ∃n : ℕ, s ⊆ range n :=
⟨_, s.subset_range_sup_succ⟩

lemma sup_induction {p : α → Prop} (hb : p ⊥) (hp : ∀ a₁, p a₁ → ∀ a₂, p a₂ → p (a₁ ⊔ a₂))
  (hs : ∀ b ∈ s, p (f b)) : p (s.sup f) :=
begin
  induction s using finset.cons_induction with c s hc ih,
  { exact hb, },
  { rw sup_cons,
    apply hp,
    { exact hs c (mem_cons.2 (or.inl rfl)), },
    { exact ih (λ b h, hs b (mem_cons.2 (or.inr h))), }, },
end

lemma sup_le_of_le_directed {α : Type*} [semilattice_sup α] [order_bot α] (s : set α)
  (hs : s.nonempty) (hdir : directed_on (≤) s) (t : finset α) :
  (∀ x ∈ t, ∃ y ∈ s, x ≤ y) → ∃ x, x ∈ s ∧ t.sup id ≤ x :=
begin
  classical,
  apply finset.induction_on t,
  { simpa only [forall_prop_of_true, and_true, forall_prop_of_false, bot_le, not_false_iff,
      sup_empty, forall_true_iff, not_mem_empty], },
  { intros a r har ih h,
    have incs : ↑r ⊆ ↑(insert a r), by { rw finset.coe_subset, apply finset.subset_insert, },
    -- x ∈ s is above the sup of r
    obtain ⟨x, ⟨hxs, hsx_sup⟩⟩ := ih (λ x hx, h x $ incs hx),
    -- y ∈ s is above a
    obtain ⟨y, hys, hay⟩ := h a (finset.mem_insert_self a r),
    -- z ∈ s is above x and y
    obtain ⟨z, hzs, ⟨hxz, hyz⟩⟩ := hdir x hxs y hys,
    use [z, hzs],
    rw [sup_insert, id.def, sup_le_iff],
    exact ⟨le_trans hay hyz, le_trans hsx_sup hxz⟩, },
end

-- If we acquire sublattices
-- the hypotheses should be reformulated as `s : subsemilattice_sup_bot`
lemma sup_mem
  (s : set α) (w₁ : ⊥ ∈ s) (w₂ : ∀ x y ∈ s, x ⊔ y ∈ s)
  {ι : Type*} (t : finset ι) (p : ι → α) (h : ∀ i ∈ t, p i ∈ s) :
  t.sup p ∈ s :=
@sup_induction _ _ _ _ _ _ (∈ s) w₁ w₂ h

@[simp]
lemma sup_eq_bot_iff (f : β → α)
  (S : finset β) : S.sup f = ⊥ ↔ ∀ s ∈ S, f s = ⊥ :=
begin
  classical,
  induction S using finset.induction with a S haS hi;
  simp [*],
end

end sup

lemma sup_eq_supr [complete_lattice β] (s : finset α) (f : α → β) : s.sup f = (⨆a∈s, f a) :=
le_antisymm
  (finset.sup_le $ assume a ha, le_supr_of_le a $ le_supr _ ha)
  (supr_le $ assume a, supr_le $ assume ha, le_sup ha)

lemma sup_id_eq_Sup [complete_lattice α] (s : finset α) : s.sup id = Sup s :=
by simp [Sup_eq_supr, sup_eq_supr]

lemma sup_id_set_eq_sUnion (s : finset (set α)) : s.sup id = ⋃₀(↑s) :=
sup_id_eq_Sup _

@[simp] lemma sup_set_eq_bUnion (s : finset α) (f : α → set β) : s.sup f = ⋃ x ∈ s, f x :=
sup_eq_supr _ _

lemma sup_eq_Sup_image [complete_lattice β] (s : finset α) (f : α → β) : s.sup f = Sup (f '' s) :=
begin
  classical,
  rw [←finset.coe_image, ←sup_id_eq_Sup, sup_image, function.comp.left_id],
end

/-! ### inf -/
section inf
-- TODO: define with just `[has_top α]` where some lemmas hold without requiring `[order_top α]`
variables [semilattice_inf α] [order_top α]

/-- Infimum of a finite set: `inf {a, b, c} f = f a ⊓ f b ⊓ f c` -/
def inf (s : finset β) (f : β → α) : α := s.fold (⊓) ⊤ f

variables {s s₁ s₂ : finset β} {f g : β → α}

lemma inf_def : s.inf f = (s.1.map f).inf := rfl

@[simp] lemma inf_empty : (∅ : finset β).inf f = ⊤ :=
fold_empty

@[simp] lemma inf_cons {b : β} (h : b ∉ s) : (cons b s h).inf f = f b ⊓ s.inf f :=
@sup_cons αᵒᵈ _ _ _ _ _ _ h

@[simp] lemma inf_insert [decidable_eq β] {b : β} : (insert b s : finset β).inf f = f b ⊓ s.inf f :=
fold_insert_idem

lemma inf_image [decidable_eq β] (s : finset γ) (f : γ → β) (g : β → α) :
  (s.image f).inf g = s.inf (g ∘ f) :=
fold_image_idem

@[simp] lemma inf_map (s : finset γ) (f : γ ↪ β) (g : β → α) :
  (s.map f).inf g = s.inf (g ∘ f) :=
fold_map

@[simp] lemma inf_singleton {b : β} : ({b} : finset β).inf f = f b :=
inf_singleton

lemma inf_union [decidable_eq β] : (s₁ ∪ s₂).inf f = s₁.inf f ⊓ s₂.inf f :=
@sup_union αᵒᵈ _ _ _ _ _ _ _

lemma inf_inf : s.inf (f ⊓ g) = s.inf f ⊓ s.inf g :=
@sup_sup αᵒᵈ _ _ _ _ _ _

theorem inf_congr {f g : β → α} (hs : s₁ = s₂) (hfg : ∀a∈s₂, f a = g a) : s₁.inf f = s₂.inf g :=
by subst hs; exact finset.fold_congr hfg

@[simp] lemma inf_bUnion [decidable_eq β] (s : finset γ) (t : γ → finset β) :
  (s.bUnion t).inf f = s.inf (λ x, (t x).inf f) :=
@sup_bUnion αᵒᵈ _ _ _ _ _ _ _ _

lemma inf_const {s : finset β} (h : s.nonempty) (c : α) : s.inf (λ _, c) = c :=
@sup_const αᵒᵈ _ _ _ _ h _

@[simp] lemma inf_top (s : finset β) : s.inf (λ _, ⊤) = (⊤ : α) := @sup_bot αᵒᵈ _ _ _ _

lemma le_inf_iff {a : α} : a ≤ s.inf f ↔ ∀ b ∈ s, a ≤ f b :=
@finset.sup_le_iff αᵒᵈ _ _ _ _ _ _

lemma inf_le {b : β} (hb : b ∈ s) : s.inf f ≤ f b :=
le_inf_iff.1 le_rfl _ hb

lemma le_inf {a : α} : (∀b ∈ s, a ≤ f b) → a ≤ s.inf f :=
le_inf_iff.2

lemma inf_mono_fun {g : β → α} (h : ∀b∈s, f b ≤ g b) : s.inf f ≤ s.inf g :=
le_inf (λ b hb, le_trans (inf_le hb) (h b hb))

lemma inf_mono (h : s₁ ⊆ s₂) : s₂.inf f ≤ s₁.inf f :=
le_inf $ assume b hb, inf_le (h hb)

lemma inf_attach (s : finset β) (f : β → α) : s.attach.inf (λ x, f x) = s.inf f :=
@sup_attach αᵒᵈ _ _ _ _ _

lemma inf_comm (s : finset β) (t : finset γ) (f : β → γ → α) :
  s.inf (λ b, t.inf (f b)) = t.inf (λ c, s.inf (λ b, f b c)) :=
@sup_comm αᵒᵈ _ _ _ _ _ _ _

lemma inf_product_left (s : finset β) (t : finset γ) (f : β × γ → α) :
  (s.product t).inf f = s.inf (λ i, t.inf $ λ i', f ⟨i, i'⟩) :=
@sup_product_left αᵒᵈ _ _ _ _ _ _ _

lemma inf_product_right (s : finset β) (t : finset γ) (f : β × γ → α) :
  (s.product t).inf f = t.inf (λ i', s.inf $ λ i, f ⟨i, i'⟩) :=
@sup_product_right αᵒᵈ _ _ _ _ _ _ _

@[simp] lemma inf_erase_top [decidable_eq α] (s : finset α) : (s.erase ⊤).inf id = s.inf id :=
@sup_erase_bot αᵒᵈ _ _ _ _

lemma sup_sdiff_left {α β : Type*} [boolean_algebra α] (s : finset β) (f : β → α) (a : α) :
  s.sup (λ b, a \ f b) = a \ s.inf f :=
begin
  refine finset.cons_induction_on s _ (λ b t _ h, _),
  { rw [sup_empty, inf_empty, sdiff_top] },
  { rw [sup_cons, inf_cons, h, sdiff_inf] }
end

lemma inf_sdiff_left {α β : Type*} [boolean_algebra α] {s : finset β} (hs : s.nonempty) (f : β → α)
  (a : α) :
  s.inf (λ b, a \ f b) = a \ s.sup f :=
begin
  induction hs using finset.nonempty.cons_induction with b b t _ _ h,
  { rw [sup_singleton, inf_singleton] },
  { rw [sup_cons, inf_cons, h, sdiff_sup] }
end

lemma inf_sdiff_right {α β : Type*} [boolean_algebra α] {s : finset β} (hs : s.nonempty) (f : β → α)
  (a : α) :
  s.inf (λ b, f b \ a) = s.inf f \ a :=
begin
  induction hs using finset.nonempty.cons_induction with b b t _ _ h,
  { rw [inf_singleton, inf_singleton] },
  { rw [inf_cons, inf_cons, h, inf_sdiff] }
end

lemma comp_inf_eq_inf_comp [semilattice_inf γ] [order_top γ] {s : finset β}
  {f : β → α} (g : α → γ) (g_inf : ∀ x y, g (x ⊓ y) = g x ⊓ g y) (top : g ⊤ = ⊤) :
  g (s.inf f) = s.inf (g ∘ f) :=
@comp_sup_eq_sup_comp αᵒᵈ _ γᵒᵈ _ _ _ _ _ _ _ g_inf top

/-- Computing `inf` in a subtype (closed under `inf`) is the same as computing it in `α`. -/
lemma inf_coe {P : α → Prop}
  {Ptop : P ⊤} {Pinf : ∀{{x y}}, P x → P y → P (x ⊓ y)}
  (t : finset β) (f : β → {x : α // P x}) :
  (@inf _ _ (subtype.semilattice_inf Pinf) (subtype.order_top Ptop) t f : α) = t.inf (λ x, f x) :=
@sup_coe αᵒᵈ _ _ _ _ Ptop Pinf t f

lemma inf_induction {p : α → Prop} (ht : p ⊤) (hp : ∀ a₁, p a₁ → ∀ a₂, p a₂ → p (a₁ ⊓ a₂))
  (hs : ∀ b ∈ s, p (f b)) : p (s.inf f) :=
@sup_induction αᵒᵈ _ _ _ _ _ _ ht hp hs

lemma inf_mem
  (s : set α) (w₁ : ⊤ ∈ s) (w₂ : ∀ x y ∈ s, x ⊓ y ∈ s)
  {ι : Type*} (t : finset ι) (p : ι → α) (h : ∀ i ∈ t, p i ∈ s) :
  t.inf p ∈ s :=
@inf_induction _ _ _ _ _ _ (∈ s) w₁ w₂ h

@[simp]
lemma inf_eq_top_iff (f : β → α)
  (S : finset β) : S.inf f = ⊤ ↔ ∀ s ∈ S, f s = ⊤ :=
@finset.sup_eq_bot_iff αᵒᵈ _ _ _ _ _

end inf

@[simp] lemma to_dual_sup [semilattice_sup α] [order_bot α] (s : finset β) (f : β → α) :
  to_dual (s.sup f) = s.inf (to_dual ∘ f) := rfl
@[simp] lemma to_dual_inf [semilattice_inf α] [order_top α] (s : finset β) (f : β → α) :
  to_dual (s.inf f) = s.sup (to_dual ∘ f) := rfl
@[simp] lemma of_dual_sup [semilattice_inf α] [order_top α] (s : finset β) (f : β → αᵒᵈ) :
  of_dual (s.sup f) = s.inf (of_dual ∘ f) := rfl
@[simp] lemma of_dual_inf [semilattice_sup α] [order_bot α] (s : finset β) (f : β → αᵒᵈ) :
  of_dual (s.inf f) = s.sup (of_dual ∘ f) := rfl

section distrib_lattice
variables [distrib_lattice α]

section order_bot
variables [order_bot α] {s : finset β} {f : β → α} {a : α}

lemma sup_inf_distrib_left (s : finset ι) (f : ι → α) (a : α) :
  a ⊓ s.sup f = s.sup (λ i, a ⊓ f i) :=
begin
  induction s using finset.cons_induction with i s hi h,
  { simp_rw [finset.sup_empty, inf_bot_eq] },
  { rw [sup_cons, sup_cons, inf_sup_left, h] }
end

lemma sup_inf_distrib_right (s : finset ι) (f : ι → α) (a : α) :
  s.sup f ⊓ a = s.sup (λ i, f i ⊓ a) :=
by { rw [_root_.inf_comm, s.sup_inf_distrib_left], simp_rw _root_.inf_comm }

lemma disjoint_sup_right : disjoint a (s.sup f) ↔ ∀ i ∈ s, disjoint a (f i) :=
by simp only [disjoint_iff, sup_inf_distrib_left, sup_eq_bot_iff]

lemma disjoint_sup_left : disjoint (s.sup f) a ↔ ∀ i ∈ s, disjoint (f i) a :=
by simp only [disjoint_iff, sup_inf_distrib_right, sup_eq_bot_iff]

end order_bot

section order_top
variables [order_top α]

lemma inf_sup_distrib_left (s : finset ι) (f : ι → α) (a : α) :
  a ⊔ s.inf f = s.inf (λ i, a ⊔ f i) :=
@sup_inf_distrib_left αᵒᵈ _ _ _ _ _ _

lemma inf_sup_distrib_right (s : finset ι) (f : ι → α) (a : α) :
  s.inf f ⊔ a = s.inf (λ i, f i ⊔ a) :=
@sup_inf_distrib_right αᵒᵈ _ _ _ _ _ _

end order_top
end distrib_lattice

section linear_order
variables [linear_order α]

section order_bot
variables [order_bot α] {s : finset ι} {f : ι → α} {a : α}

lemma comp_sup_eq_sup_comp_of_is_total [semilattice_sup β] [order_bot β] (g : α → β)
  (mono_g : monotone g) (bot : g ⊥ = ⊥) : g (s.sup f) = s.sup (g ∘ f) :=
comp_sup_eq_sup_comp g mono_g.map_sup bot

@[simp] protected lemma le_sup_iff (ha : ⊥ < a) : a ≤ s.sup f ↔ ∃ b ∈ s, a ≤ f b :=
⟨finset.cons_induction_on s (λ h, absurd h (not_le_of_lt ha))
  (λ c t hc ih, by simpa using @or.rec _ _ (∃ b, (b = c ∨ b ∈ t) ∧ a ≤ f b)
    (λ h, ⟨c, or.inl rfl, h⟩) (λ h, let ⟨b, hb, hle⟩ := ih h in ⟨b, or.inr hb, hle⟩)),
(λ ⟨b, hb, hle⟩, trans hle (le_sup hb))⟩

@[simp] protected lemma lt_sup_iff : a < s.sup f ↔ ∃ b ∈ s, a < f b :=
⟨finset.cons_induction_on s (λ h, absurd h not_lt_bot)
  (λ c t hc ih, by simpa using @or.rec _ _ (∃ b, (b = c ∨ b ∈ t) ∧ a < f b)
    (λ h, ⟨c, or.inl rfl, h⟩) (λ h, let ⟨b, hb, hlt⟩ := ih h in ⟨b, or.inr hb, hlt⟩)),
(λ ⟨b, hb, hlt⟩, lt_of_lt_of_le hlt (le_sup hb))⟩

@[simp] protected lemma sup_lt_iff (ha : ⊥ < a) : s.sup f < a ↔ ∀ b ∈ s, f b < a :=
⟨(λ hs b hb, lt_of_le_of_lt (le_sup hb) hs), finset.cons_induction_on s (λ _, ha)
  (λ c t hc, by simpa only [sup_cons, sup_lt_iff, mem_cons, forall_eq_or_imp] using and.imp_right)⟩

end order_bot

section order_top
variables [order_top α] {s : finset ι} {f : ι → α} {a : α}

lemma comp_inf_eq_inf_comp_of_is_total [semilattice_inf β] [order_top β] (g : α → β)
  (mono_g : monotone g) (top : g ⊤ = ⊤) : g (s.inf f) = s.inf (g ∘ f) :=
comp_inf_eq_inf_comp g mono_g.map_inf top

@[simp] protected lemma inf_le_iff (ha : a < ⊤) : s.inf f ≤ a ↔ ∃ b ∈ s, f b ≤ a :=
@finset.le_sup_iff αᵒᵈ _ _ _ _ _ _ ha

@[simp] protected lemma inf_lt_iff : s.inf f < a ↔ ∃ b ∈ s, f b < a :=
@finset.lt_sup_iff αᵒᵈ _ _ _ _ _ _

@[simp] protected lemma lt_inf_iff (ha : a < ⊤) : a < s.inf f ↔ ∀ b ∈ s, a < f b :=
@finset.sup_lt_iff αᵒᵈ _ _ _ _ _ _ ha

end order_top
end linear_order

lemma inf_eq_infi [complete_lattice β] (s : finset α) (f : α → β) : s.inf f = ⨅ a ∈ s, f a :=
@sup_eq_supr _ βᵒᵈ _ _ _

lemma inf_id_eq_Inf [complete_lattice α] (s : finset α) : s.inf id = Inf s := @sup_id_eq_Sup αᵒᵈ _ _

lemma inf_id_set_eq_sInter (s : finset (set α)) : s.inf id = ⋂₀(↑s) :=
inf_id_eq_Inf _

@[simp] lemma inf_set_eq_bInter (s : finset α) (f : α → set β) : s.inf f = ⋂ x ∈ s, f x :=
inf_eq_infi _ _

lemma inf_eq_Inf_image [complete_lattice β] (s : finset α) (f : α → β) : s.inf f = Inf (f '' s) :=
@sup_eq_Sup_image _ βᵒᵈ _ _ _

section sup'
variables [semilattice_sup α]

lemma sup_of_mem {s : finset β} (f : β → α) {b : β} (h : b ∈ s) :
  ∃ (a : α), s.sup (coe ∘ f : β → with_bot α) = ↑a :=
Exists.imp (λ a, Exists.fst) (@le_sup (with_bot α) _ _ _ _ _ _ h (f b) rfl)

/-- Given nonempty finset `s` then `s.sup' H f` is the supremum of its image under `f` in (possibly
unbounded) join-semilattice `α`, where `H` is a proof of nonemptiness. If `α` has a bottom element
you may instead use `finset.sup` which does not require `s` nonempty. -/
def sup' (s : finset β) (H : s.nonempty) (f : β → α) : α :=
option.get $ let ⟨b, hb⟩ := H in option.is_some_iff_exists.2 (sup_of_mem f hb)

variables {s : finset β} (H : s.nonempty) (f : β → α)

@[simp] lemma coe_sup' : ((s.sup' H f : α) : with_bot α) = s.sup (coe ∘ f) :=
by rw [sup', ←with_bot.some_eq_coe, option.some_get]

@[simp] lemma sup'_cons {b : β} {hb : b ∉ s} {h : (cons b s hb).nonempty} :
  (cons b s hb).sup' h f = f b ⊔ s.sup' H f :=
by { rw ←with_bot.coe_eq_coe, simp only [coe_sup', sup_cons, with_bot.coe_sup], }

@[simp] lemma sup'_insert [decidable_eq β] {b : β} {h : (insert b s).nonempty} :
  (insert b s).sup' h f = f b ⊔ s.sup' H f :=
by { rw ←with_bot.coe_eq_coe, simp only [coe_sup', sup_insert, with_bot.coe_sup], }

@[simp] lemma sup'_singleton {b : β} {h : ({b} : finset β).nonempty} :
  ({b} : finset β).sup' h f = f b := rfl

lemma sup'_le {a : α} (hs : ∀ b ∈ s, f b ≤ a) : s.sup' H f ≤ a :=
by { rw [←with_bot.coe_le_coe, coe_sup'], exact sup_le (λ b h, with_bot.coe_le_coe.2 $ hs b h), }

lemma le_sup' {b : β} (h : b ∈ s) : f b ≤ s.sup' ⟨b, h⟩ f :=
by { rw [←with_bot.coe_le_coe, coe_sup'], exact le_sup h, }

@[simp] lemma sup'_const (a : α) : s.sup' H (λ b, a) = a :=
begin
  apply le_antisymm,
  { apply sup'_le, intros, exact le_rfl, },
  { apply le_sup' (λ b, a) H.some_spec, }
end

@[simp] lemma sup'_le_iff {a : α} : s.sup' H f ≤ a ↔ ∀ b ∈ s, f b ≤ a :=
iff.intro (λ h b hb, trans (le_sup' f hb) h) (sup'_le H f)

lemma sup'_bUnion [decidable_eq β] {s : finset γ} (Hs : s.nonempty) {t : γ → finset β}
  (Ht : ∀ b, (t b).nonempty) :
  (s.bUnion t).sup' (Hs.bUnion (λ b _, Ht b)) f = s.sup' Hs (λ b, (t b).sup' (Ht b) f) :=
eq_of_forall_ge_iff $ λ c, by simp [@forall_swap _ β]

lemma comp_sup'_eq_sup'_comp [semilattice_sup γ] {s : finset β} (H : s.nonempty)
  {f : β → α} (g : α → γ) (g_sup : ∀ x y, g (x ⊔ y) = g x ⊔ g y) :
  g (s.sup' H f) = s.sup' H (g ∘ f) :=
begin
  rw [←with_bot.coe_eq_coe, coe_sup'],
  let g' : with_bot α → with_bot γ := with_bot.rec_bot_coe ⊥ (λ x, ↑(g x)),
  show g' ↑(s.sup' H f) = s.sup (λ a, g' ↑(f a)),
  rw coe_sup',
  refine comp_sup_eq_sup_comp g' _ rfl,
  intros f₁ f₂,
  cases f₁,
  { rw [with_bot.none_eq_bot, bot_sup_eq], exact bot_sup_eq.symm, },
  { cases f₂, refl,
    exact congr_arg coe (g_sup f₁ f₂), },
end

lemma sup'_induction {p : α → Prop} (hp : ∀ a₁, p a₁ → ∀ a₂, p a₂ → p (a₁ ⊔ a₂))
  (hs : ∀ b ∈ s, p (f b)) : p (s.sup' H f) :=
begin
  show @with_bot.rec_bot_coe α (λ _, Prop) true p ↑(s.sup' H f),
  rw coe_sup',
  refine sup_induction trivial _ hs,
  rintro (_|a₁) h₁ a₂ h₂,
  { rw [with_bot.none_eq_bot, bot_sup_eq], exact h₂ },
  cases a₂,
  exacts [h₁, hp a₁ h₁ a₂ h₂]
end

lemma sup'_mem
  (s : set α) (w : ∀ x y ∈ s, x ⊔ y ∈ s)
  {ι : Type*} (t : finset ι) (H : t.nonempty) (p : ι → α) (h : ∀ i ∈ t, p i ∈ s) :
  t.sup' H p ∈ s := sup'_induction H p w h

@[congr] lemma sup'_congr {t : finset β} {f g : β → α} (h₁ : s = t) (h₂ : ∀ x ∈ s, f x = g x) :
  s.sup' H f = t.sup' (h₁ ▸ H) g :=
begin
  subst s,
  refine eq_of_forall_ge_iff (λ c, _),
  simp only [sup'_le_iff, h₂] { contextual := tt }
end

end sup'

section inf'
variables [semilattice_inf α]

lemma inf_of_mem {s : finset β} (f : β → α) {b : β} (h : b ∈ s) :
  ∃ (a : α), s.inf (coe ∘ f : β → with_top α) = ↑a :=
@sup_of_mem αᵒᵈ _ _ _ f _ h

/-- Given nonempty finset `s` then `s.inf' H f` is the infimum of its image under `f` in (possibly
unbounded) meet-semilattice `α`, where `H` is a proof of nonemptiness. If `α` has a top element you
may instead use `finset.inf` which does not require `s` nonempty. -/
def inf' (s : finset β) (H : s.nonempty) (f : β → α) : α :=
@sup' αᵒᵈ _ _ s H f

variables {s : finset β} (H : s.nonempty) (f : β → α) {a : α} {b : β}

@[simp] lemma coe_inf' : ((s.inf' H f : α) : with_top α) = s.inf (coe ∘ f) :=
@coe_sup' αᵒᵈ _ _ _ H f

@[simp] lemma inf'_cons {b : β} {hb : b ∉ s} {h : (cons b s hb).nonempty} :
  (cons b s hb).inf' h f = f b ⊓ s.inf' H f :=
@sup'_cons αᵒᵈ _ _ _ H f _ _ _

@[simp] lemma inf'_insert [decidable_eq β] {b : β} {h : (insert b s).nonempty} :
  (insert b s).inf' h f = f b ⊓ s.inf' H f :=
@sup'_insert αᵒᵈ _ _ _ H f _ _ _

@[simp] lemma inf'_singleton {b : β} {h : ({b} : finset β).nonempty} :
  ({b} : finset β).inf' h f = f b := rfl

lemma le_inf' (hs : ∀ b ∈ s, a ≤ f b) : a ≤ s.inf' H f := @sup'_le αᵒᵈ _ _ _ H f _ hs
lemma inf'_le (h : b ∈ s) : s.inf' ⟨b, h⟩ f ≤ f b := @le_sup' αᵒᵈ _ _ _ f _ h

@[simp] lemma inf'_const (a : α) : s.inf' H (λ b, a) = a := @sup'_const αᵒᵈ _ _ _ _ _

@[simp] lemma le_inf'_iff : a ≤ s.inf' H f ↔ ∀ b ∈ s, a ≤ f b := @sup'_le_iff αᵒᵈ _ _ _ H f _

lemma inf'_bUnion [decidable_eq β] {s : finset γ} (Hs : s.nonempty) {t : γ → finset β}
  (Ht : ∀ b, (t b).nonempty) :
  (s.bUnion t).inf' (Hs.bUnion (λ b _, Ht b)) f = s.inf' Hs (λ b, (t b).inf' (Ht b) f) :=
@sup'_bUnion αᵒᵈ _ _ _ _ _ _ Hs _ Ht

lemma comp_inf'_eq_inf'_comp [semilattice_inf γ] {s : finset β} (H : s.nonempty)
  {f : β → α} (g : α → γ) (g_inf : ∀ x y, g (x ⊓ y) = g x ⊓ g y) :
  g (s.inf' H f) = s.inf' H (g ∘ f) :=
@comp_sup'_eq_sup'_comp αᵒᵈ _ γᵒᵈ _ _ _ H f g g_inf

lemma inf'_induction {p : α → Prop} (hp : ∀ a₁, p a₁ → ∀ a₂, p a₂ → p (a₁ ⊓ a₂))
  (hs : ∀ b ∈ s, p (f b)) : p (s.inf' H f) :=
@sup'_induction αᵒᵈ _ _ _ H f _ hp hs

lemma inf'_mem (s : set α) (w : ∀ x y ∈ s, x ⊓ y ∈ s)
  {ι : Type*} (t : finset ι) (H : t.nonempty) (p : ι → α) (h : ∀ i ∈ t, p i ∈ s) :
  t.inf' H p ∈ s := inf'_induction H p w h

@[congr] lemma inf'_congr {t : finset β} {f g : β → α} (h₁ : s = t) (h₂ : ∀ x ∈ s, f x = g x) :
  s.inf' H f = t.inf' (h₁ ▸ H) g :=
@sup'_congr αᵒᵈ _ _ _ H _ _ _ h₁ h₂

end inf'

section sup
variables [semilattice_sup α] [order_bot α]

lemma sup'_eq_sup {s : finset β} (H : s.nonempty) (f : β → α) : s.sup' H f = s.sup f :=
le_antisymm (sup'_le H f (λ b, le_sup)) (sup_le (λ b, le_sup' f))

lemma sup_closed_of_sup_closed {s : set α} (t : finset α) (htne : t.nonempty) (h_subset : ↑t ⊆ s)
  (h : ∀ a b ∈ s, a ⊔ b ∈ s) : t.sup id ∈ s :=
sup'_eq_sup htne id ▸ sup'_induction _ _ h h_subset

lemma coe_sup_of_nonempty {s : finset β} (h : s.nonempty) (f : β → α) :
  (↑(s.sup f) : with_bot α) = s.sup (coe ∘ f) :=
by simp only [←sup'_eq_sup h, coe_sup' h]

end sup

section inf
variables [semilattice_inf α] [order_top α]

lemma inf'_eq_inf {s : finset β} (H : s.nonempty) (f : β → α) : s.inf' H f = s.inf f :=
@sup'_eq_sup αᵒᵈ _ _ _ _ H f

lemma inf_closed_of_inf_closed {s : set α} (t : finset α) (htne : t.nonempty) (h_subset : ↑t ⊆ s)
  (h : ∀ a b ∈ s, a ⊓ b ∈ s) : t.inf id ∈ s :=
@sup_closed_of_sup_closed αᵒᵈ _ _ _ t htne h_subset h

lemma coe_inf_of_nonempty {s : finset β} (h : s.nonempty) (f : β → α):
  (↑(s.inf f) : with_top α) = s.inf (λ i, f i) :=
@coe_sup_of_nonempty αᵒᵈ _ _ _ _ h f

end inf

section sup
variables {C : β → Type*} [Π (b : β), semilattice_sup (C b)] [Π (b : β), order_bot (C b)]

@[simp]
protected lemma sup_apply (s : finset α) (f : α → Π (b : β), C b) (b : β) :
  s.sup f b = s.sup (λ a, f a b) :=
comp_sup_eq_sup_comp (λ x : Π b : β, C b, x b) (λ i j, rfl) rfl

end sup

section inf
variables {C : β → Type*} [Π (b : β), semilattice_inf (C b)] [Π (b : β), order_top (C b)]

@[simp]
protected lemma inf_apply (s : finset α) (f : α → Π (b : β), C b) (b : β) :
  s.inf f b = s.inf (λ a, f a b) :=
@finset.sup_apply _ _ (λ b, (C b)ᵒᵈ) _ _ s f b

end inf

section sup'
variables {C : β → Type*} [Π (b : β), semilattice_sup (C b)]

@[simp]
protected lemma sup'_apply {s : finset α} (H : s.nonempty) (f : α → Π (b : β), C b) (b : β) :
  s.sup' H f b = s.sup' H (λ a, f a b) :=
comp_sup'_eq_sup'_comp H (λ x : Π b : β, C b, x b) (λ i j, rfl)

end sup'

section inf'
variables {C : β → Type*} [Π (b : β), semilattice_inf (C b)]

@[simp]
protected lemma inf'_apply {s : finset α} (H : s.nonempty) (f : α → Π (b : β), C b) (b : β) :
  s.inf' H f b = s.inf' H (λ a, f a b) :=
@finset.sup'_apply _ _ (λ b, (C b)ᵒᵈ) _ _ H f b

end inf'

@[simp] lemma to_dual_sup' [semilattice_sup α] {s : finset ι} (hs : s.nonempty) (f : ι → α) :
  to_dual (s.sup' hs f) = s.inf' hs (to_dual ∘ f) := rfl
@[simp] lemma to_dual_inf' [semilattice_inf α] {s : finset ι} (hs : s.nonempty) (f : ι → α) :
  to_dual (s.inf' hs f) = s.sup' hs (to_dual ∘ f) := rfl
@[simp] lemma of_dual_sup' [semilattice_inf α] {s : finset ι} (hs : s.nonempty) (f : ι → αᵒᵈ) :
  of_dual (s.sup' hs f) = s.inf' hs (of_dual ∘ f) := rfl
@[simp] lemma of_dual_inf' [semilattice_sup α] {s : finset ι} (hs : s.nonempty) (f : ι → αᵒᵈ) :
  of_dual (s.inf' hs f) = s.sup' hs (of_dual ∘ f) := rfl

section linear_order
variables [linear_order α] {s : finset ι} (H : s.nonempty) {f : ι → α} {a : α}

@[simp] lemma le_sup'_iff : a ≤ s.sup' H f ↔ ∃ b ∈ s, a ≤ f b :=
begin
  rw [←with_bot.coe_le_coe, coe_sup', finset.le_sup_iff (with_bot.bot_lt_coe a)],
  exact bex_congr (λ b hb, with_bot.coe_le_coe),
end

@[simp] lemma lt_sup'_iff : a < s.sup' H f ↔ ∃ b ∈ s, a < f b :=
begin
  rw [←with_bot.coe_lt_coe, coe_sup', finset.lt_sup_iff],
  exact bex_congr (λ b hb, with_bot.coe_lt_coe),
end

@[simp] lemma sup'_lt_iff : s.sup' H f < a ↔ ∀ i ∈ s, f i < a :=
begin
  rw [←with_bot.coe_lt_coe, coe_sup', finset.sup_lt_iff (with_bot.bot_lt_coe a)],
  exact ball_congr (λ b hb, with_bot.coe_lt_coe),
end

@[simp] lemma inf'_le_iff : s.inf' H f ≤ a ↔ ∃ i ∈ s, f i ≤ a := @le_sup'_iff αᵒᵈ _ _ _ H f _
@[simp] lemma inf'_lt_iff : s.inf' H f < a ↔ ∃ i ∈ s, f i < a := @lt_sup'_iff αᵒᵈ _ _ _ H f _
@[simp] lemma lt_inf'_iff : a < s.inf' H f ↔ ∀ i ∈ s, a < f i := @sup'_lt_iff αᵒᵈ _ _ _ H f _

lemma exists_mem_eq_sup' (f : ι → α) : ∃ i, i ∈ s ∧ s.sup' H f = f i :=
begin
  refine H.cons_induction (λ c, _) (λ c s hc hs ih, _),
  { exact ⟨c, mem_singleton_self c, rfl⟩, },
  { rcases ih with ⟨b, hb, h'⟩,
    rw [sup'_cons hs, h'],
    cases total_of (≤) (f b) (f c) with h h,
    { exact ⟨c, mem_cons.2 (or.inl rfl), sup_eq_left.2 h⟩, },
    { exact ⟨b, mem_cons.2 (or.inr hb), sup_eq_right.2 h⟩, }, },
end

lemma exists_mem_eq_inf' (f : ι → α) : ∃ i, i ∈ s ∧ s.inf' H f = f i :=
@exists_mem_eq_sup' αᵒᵈ _ _ _ H f

lemma exists_mem_eq_sup [order_bot α] (s : finset ι) (h : s.nonempty) (f : ι → α) :
  ∃ i, i ∈ s ∧ s.sup f = f i :=
sup'_eq_sup h f ▸ exists_mem_eq_sup' h f

lemma exists_mem_eq_inf [order_top α] (s : finset ι) (h : s.nonempty) (f : ι → α) :
  ∃ i, i ∈ s ∧ s.inf f = f i :=
@exists_mem_eq_sup αᵒᵈ _ _ _ _ h f

end linear_order

/-! ### max and min of finite sets -/
section max_min
variables [linear_order α]

/-- Let `s` be a finset in a linear order. Then `s.max` is the maximum of `s` if `s` is not empty,
and `none` otherwise. It belongs to `option α`. If you want to get an element of `α`, see
`s.max'`. -/
protected def max : finset α → option α :=
fold (option.lift_or_get max) none some

theorem max_eq_sup_with_bot (s : finset α) :
  s.max = @sup (with_bot α) α _ _ s some := rfl

@[simp] theorem max_empty : (∅ : finset α).max = none := rfl

@[simp] theorem max_insert {a : α} {s : finset α} :
  (insert a s).max = option.lift_or_get max (some a) s.max := fold_insert_idem

@[simp] theorem max_singleton {a : α} : finset.max {a} = some a :=
by { rw [← insert_emptyc_eq], exact max_insert }

theorem max_of_mem {s : finset α} {a : α} (h : a ∈ s) : ∃ b, b ∈ s.max :=
(@le_sup (with_bot α) _ _ _ _ _ _ h _ rfl).imp $ λ b, Exists.fst

theorem max_of_nonempty {s : finset α} (h : s.nonempty) : ∃ a, a ∈ s.max :=
let ⟨a, ha⟩ := h in max_of_mem ha

theorem max_eq_none {s : finset α} : s.max = none ↔ s = ∅ :=
⟨λ h, s.eq_empty_or_nonempty.elim id
  (λ H, let ⟨a, ha⟩ := max_of_nonempty H in by rw h at ha; cases ha),
  λ h, h.symm ▸ max_empty⟩

theorem mem_of_max {s : finset α} : ∀ {a : α}, a ∈ s.max → a ∈ s :=
finset.induction_on s (λ _ H, by cases H)
  (λ b s _ (ih : ∀ {a}, a ∈ s.max → a ∈ s) a (h : a ∈ (insert b s).max),
  begin
    by_cases p : b = a,
    { induction p, exact mem_insert_self b s },
    { cases option.lift_or_get_choice max_choice (some b) s.max with q q;
      rw [max_insert, q] at h,
      { cases h, cases p rfl },
      { exact mem_insert_of_mem (ih h) } }
  end)

theorem le_max_of_mem {s : finset α} {a b : α} (h₁ : a ∈ s) (h₂ : b ∈ s.max) : a ≤ b :=
by rcases @le_sup (with_bot α) _ _ _ _ _ _ h₁ _ rfl with ⟨b', hb, ab⟩;
   cases h₂.symm.trans hb; assumption

/-- Let `s` be a finset in a linear order. Then `s.min` is the minimum of `s` if `s` is not empty,
and `none` otherwise. It belongs to `option α`. If you want to get an element of `α`, see
`s.min'`. -/
protected def min : finset α → option α :=
fold (option.lift_or_get min) none some

theorem min_eq_inf_with_top (s : finset α) :
  s.min = @inf (with_top α) α _ _ s some := rfl

@[simp] theorem min_empty : (∅ : finset α).min = none := rfl

@[simp] theorem min_insert {a : α} {s : finset α} :
  (insert a s).min = option.lift_or_get min (some a) s.min :=
fold_insert_idem

@[simp] theorem min_singleton {a : α} : finset.min {a} = some a :=
by { rw ← insert_emptyc_eq, exact min_insert }

theorem min_of_mem {s : finset α} {a : α} (h : a ∈ s) : ∃ b, b ∈ s.min :=
(@inf_le (with_top α) _ _ _ _ _ _ h _ rfl).imp $ λ b, Exists.fst

theorem min_of_nonempty {s : finset α} (h : s.nonempty) : ∃ a, a ∈ s.min :=
let ⟨a, ha⟩ := h in min_of_mem ha

theorem min_eq_none {s : finset α} : s.min = none ↔ s = ∅ :=
⟨λ h, s.eq_empty_or_nonempty.elim id
  (λ H, let ⟨a, ha⟩ := min_of_nonempty H in by rw h at ha; cases ha),
  λ h, h.symm ▸ min_empty⟩

theorem mem_of_min {s : finset α} : ∀ {a : α}, a ∈ s.min → a ∈ s := @mem_of_max αᵒᵈ _ s

theorem min_le_of_mem {s : finset α} {a b : α} (h₁ : b ∈ s) (h₂ : a ∈ s.min) : a ≤ b :=
by rcases @inf_le (with_top α) _ _ _ _ _ _ h₁ _ rfl with ⟨b', hb, ab⟩;
   cases h₂.symm.trans hb; assumption

/-- Given a nonempty finset `s` in a linear order `α `, then `s.min' h` is its minimum, as an
element of `α`, where `h` is a proof of nonemptiness. Without this assumption, use instead `s.min`,
taking values in `option α`. -/
def min' (s : finset α) (H : s.nonempty) : α :=
@option.get _ s.min $
  let ⟨k, hk⟩ := H in
  let ⟨b, hb⟩ := min_of_mem hk in by simp at hb; simp [hb]

/-- Given a nonempty finset `s` in a linear order `α `, then `s.max' h` is its maximum, as an
element of `α`, where `h` is a proof of nonemptiness. Without this assumption, use instead `s.max`,
taking values in `option α`. -/
def max' (s : finset α) (H : s.nonempty) : α :=
@option.get _ s.max $
  let ⟨k, hk⟩ := H in
  let ⟨b, hb⟩ := max_of_mem hk in by simp at hb; simp [hb]

variables (s : finset α) (H : s.nonempty) {x : α}

theorem min'_mem : s.min' H ∈ s := mem_of_min $ by simp [min']

theorem min'_le (x) (H2 : x ∈ s) : s.min' ⟨x, H2⟩ ≤ x := min_le_of_mem H2 $ option.get_mem _

theorem le_min' (x) (H2 : ∀ y ∈ s, x ≤ y) : x ≤ s.min' H := H2 _ $ min'_mem _ _

theorem is_least_min' : is_least ↑s (s.min' H) := ⟨min'_mem _ _, min'_le _⟩

@[simp] lemma le_min'_iff {x} : x ≤ s.min' H ↔ ∀ y ∈ s, x ≤ y :=
le_is_glb_iff (is_least_min' s H).is_glb

/-- `{a}.min' _` is `a`. -/
@[simp] lemma min'_singleton (a : α) :
  ({a} : finset α).min' (singleton_nonempty _) = a :=
by simp [min']

theorem max'_mem : s.max' H ∈ s := mem_of_max $ by simp [max']

theorem le_max' (x) (H2 : x ∈ s) : x ≤ s.max' ⟨x, H2⟩ := le_max_of_mem H2 $ option.get_mem _

theorem max'_le (x) (H2 : ∀ y ∈ s, y ≤ x) : s.max' H ≤ x := H2 _ $ max'_mem _ _

theorem is_greatest_max' : is_greatest ↑s (s.max' H) := ⟨max'_mem _ _, le_max' _⟩

@[simp] lemma max'_le_iff {x} : s.max' H ≤ x ↔ ∀ y ∈ s, y ≤ x :=
is_lub_le_iff (is_greatest_max' s H).is_lub

@[simp] lemma max'_lt_iff {x} : s.max' H < x ↔ ∀ y ∈ s, y < x :=
⟨λ Hlt y hy, (s.le_max' y hy).trans_lt Hlt, λ H, H _ $ s.max'_mem _⟩

@[simp] lemma lt_min'_iff : x < s.min' H ↔ ∀ y ∈ s, x < y := @max'_lt_iff αᵒᵈ _ _ H _

lemma max'_eq_sup' : s.max' H = s.sup' H id :=
eq_of_forall_ge_iff $ λ a, (max'_le_iff _ _).trans (sup'_le_iff _ _).symm

lemma min'_eq_inf' : s.min' H = s.inf' H id := @max'_eq_sup' αᵒᵈ _ s H

/-- `{a}.max' _` is `a`. -/
@[simp] lemma max'_singleton (a : α) :
  ({a} : finset α).max' (singleton_nonempty _) = a :=
by simp [max']

theorem min'_lt_max' {i j} (H1 : i ∈ s) (H2 : j ∈ s) (H3 : i ≠ j) :
  s.min' ⟨i, H1⟩ < s.max' ⟨i, H1⟩ :=
is_glb_lt_is_lub_of_ne (s.is_least_min' _).is_glb (s.is_greatest_max' _).is_lub H1 H2 H3

/--
If there's more than 1 element, the min' is less than the max'. An alternate version of
`min'_lt_max'` which is sometimes more convenient.
-/
lemma min'_lt_max'_of_card (h₂ : 1 < card s) :
  s.min' (finset.card_pos.mp $ lt_trans zero_lt_one h₂) <
  s.max' (finset.card_pos.mp $ lt_trans zero_lt_one h₂) :=
begin
  rcases one_lt_card.1 h₂ with ⟨a, ha, b, hb, hab⟩,
  exact s.min'_lt_max' ha hb hab
end

lemma map_of_dual_min (s : finset αᵒᵈ) : s.min.map of_dual = (s.image of_dual).max :=
by { rw [max_eq_sup_with_bot, sup_image], exact congr_fun option.map_id _ }

lemma map_of_dual_max (s : finset αᵒᵈ) : s.max.map of_dual = (s.image of_dual).min :=
by { rw [min_eq_inf_with_top, inf_image], exact congr_fun option.map_id _ }

lemma map_to_dual_min (s : finset α) : s.min.map to_dual  = (s.image to_dual).max :=
by { rw [max_eq_sup_with_bot, sup_image], exact congr_fun option.map_id _ }

lemma map_to_dual_max (s : finset α) : s.max.map to_dual  = (s.image to_dual).min :=
by { rw [min_eq_inf_with_top, inf_image], exact congr_fun option.map_id _ }

lemma of_dual_min' {s : finset αᵒᵈ} (hs : s.nonempty) :
  of_dual (min' s hs) = max' (s.image of_dual) (hs.image _) :=
by { convert rfl, exact image_id }

lemma of_dual_max' {s : finset αᵒᵈ} (hs : s.nonempty) :
  of_dual (max' s hs) = min' (s.image of_dual) (hs.image _) :=
by { convert rfl, exact image_id }

lemma to_dual_min' {s : finset α} (hs : s.nonempty) :
  to_dual (min' s hs) = max' (s.image to_dual) (hs.image _) :=
by { convert rfl, exact image_id }

lemma to_dual_max' {s : finset α} (hs : s.nonempty) :
  to_dual (max' s hs) = min' (s.image to_dual) (hs.image _) :=
by { convert rfl, exact image_id }

lemma max'_subset {s t : finset α} (H : s.nonempty) (hst : s ⊆ t) :
  s.max' H ≤ t.max' (H.mono hst) :=
le_max' _ _ (hst (s.max'_mem H))

lemma min'_subset {s t : finset α} (H : s.nonempty) (hst : s ⊆ t) :
  t.min' (H.mono hst) ≤ s.min' H :=
min'_le _ _ (hst (s.min'_mem H))

lemma max'_insert (a : α) (s : finset α) (H : s.nonempty) :
  (insert a s).max' (s.insert_nonempty a) = max (s.max' H) a :=
(is_greatest_max' _ _).unique $
  by { rw [coe_insert, max_comm], exact (is_greatest_max' _ _).insert _ }

lemma min'_insert (a : α) (s : finset α) (H : s.nonempty) :
  (insert a s).min' (s.insert_nonempty a) = min (s.min' H) a :=
(is_least_min' _ _).unique $
  by { rw [coe_insert, min_comm], exact (is_least_min' _ _).insert _ }

lemma lt_max'_of_mem_erase_max' [decidable_eq α] {a : α} (ha : a ∈ s.erase (s.max' H)) :
  a < s.max' H :=
lt_of_le_of_ne (le_max' _ _ (mem_of_mem_erase ha)) $ ne_of_mem_of_not_mem ha $ not_mem_erase _ _

lemma min'_lt_of_mem_erase_min' [decidable_eq α] {a : α} (ha : a ∈ s.erase (s.min' H)) :
  s.min' H < a :=
@lt_max'_of_mem_erase_max' αᵒᵈ _ s H _ a ha

@[simp] lemma max'_image [linear_order β]
  {f : α → β} (hf : monotone f) (s : finset α) (h : (s.image f).nonempty) :
  (s.image f).max' h = f (s.max' ((nonempty.image_iff f).mp h)) :=
begin
  refine le_antisymm (max'_le _ _ _ (λ y hy, _))
    (le_max' _ _ (mem_image.mpr ⟨_, max'_mem _ _, rfl⟩)),
  obtain ⟨x, hx, rfl⟩ := mem_image.mp hy,
  exact hf (le_max' _ _ hx)
end

@[simp] lemma min'_image [linear_order β]
  {f : α → β} (hf : monotone f) (s : finset α) (h : (s.image f).nonempty) :
  (s.image f).min' h = f (s.min' ((nonempty.image_iff f).mp h)) :=
begin
  refine le_antisymm (min'_le _ _ (mem_image.mpr ⟨_, min'_mem _ _, rfl⟩))
    (le_min' _ _ _ (λ y hy, _)),
  obtain ⟨x, hx, rfl⟩ := mem_image.mp hy,
  exact hf (min'_le _ _ hx)
end

/-- Induction principle for `finset`s in a linearly ordered type: a predicate is true on all
`s : finset α` provided that:

* it is true on the empty `finset`,
* for every `s : finset α` and an element `a` strictly greater than all elements of `s`, `p s`
  implies `p (insert a s)`. -/
@[elab_as_eliminator]
lemma induction_on_max [decidable_eq α] {p : finset α → Prop} (s : finset α) (h0 : p ∅)
  (step : ∀ a s, (∀ x ∈ s, x < a) → p s → p (insert a s)) : p s :=
begin
  induction s using finset.strong_induction_on with s ihs,
  rcases s.eq_empty_or_nonempty with rfl|hne,
  { exact h0 },
  { have H : s.max' hne ∈ s, from max'_mem s hne,
    rw ← insert_erase H,
    exact step _ _ (λ x, s.lt_max'_of_mem_erase_max' hne) (ihs _ $ erase_ssubset H) }
end

/-- Induction principle for `finset`s in a linearly ordered type: a predicate is true on all
`s : finset α` provided that:

* it is true on the empty `finset`,
* for every `s : finset α` and an element `a` strictly less than all elements of `s`, `p s`
  implies `p (insert a s)`. -/
@[elab_as_eliminator]
lemma induction_on_min [decidable_eq α] {p : finset α → Prop} (s : finset α) (h0 : p ∅)
  (step : ∀ a s, (∀ x ∈ s, a < x) → p s → p (insert a s)) : p s :=
@induction_on_max αᵒᵈ _ _ _ s h0 step

end max_min

section max_min_induction_value

variables [linear_order α] [linear_order β]

/-- Induction principle for `finset`s in any type from which a given function `f` maps to a linearly
ordered type : a predicate is true on all `s : finset α` provided that:

* it is true on the empty `finset`,
* for every `s : finset α` and an element `a` such that for elements of `s` denoted by `x` we have
  `f x ≤ f a`, `p s` implies `p (insert a s)`. -/
@[elab_as_eliminator]
lemma induction_on_max_value [decidable_eq ι] (f : ι → α)
  {p : finset ι → Prop} (s : finset ι) (h0 : p ∅)
  (step : ∀ a s, a ∉ s → (∀ x ∈ s, f x ≤ f a) → p s → p (insert a s)) : p s :=
begin
  induction s using finset.strong_induction_on with s ihs,
  rcases (s.image f).eq_empty_or_nonempty with hne|hne,
  { simp only [image_eq_empty] at hne,
    simp only [hne, h0] },
  { have H : (s.image f).max' hne ∈ (s.image f), from max'_mem (s.image f) hne,
    simp only [mem_image, exists_prop] at H,
    rcases H with ⟨a, has, hfa⟩,
    rw ← insert_erase has,
    refine step _ _ (not_mem_erase a s) (λ x hx, _) (ihs _ $ erase_ssubset has),
    rw hfa,
    exact le_max' _ _ (mem_image_of_mem _ $ mem_of_mem_erase hx) }
end

/-- Induction principle for `finset`s in any type from which a given function `f` maps to a linearly
ordered type : a predicate is true on all `s : finset α` provided that:

* it is true on the empty `finset`,
* for every `s : finset α` and an element `a` such that for elements of `s` denoted by `x` we have
  `f a ≤ f x`, `p s` implies `p (insert a s)`. -/
@[elab_as_eliminator]
lemma induction_on_min_value [decidable_eq ι] (f : ι → α)
  {p : finset ι → Prop} (s : finset ι) (h0 : p ∅)
  (step : ∀ a s, a ∉ s → (∀ x ∈ s, f a ≤ f x) → p s → p (insert a s)) : p s :=
@induction_on_max_value αᵒᵈ ι _ _ _ _ s h0 step

end max_min_induction_value

section exists_max_min

variables [linear_order α]
lemma exists_max_image (s : finset β) (f : β → α) (h : s.nonempty) :
  ∃ x ∈ s, ∀ x' ∈ s, f x' ≤ f x :=
begin
  cases max_of_nonempty (h.image f) with y hy,
  rcases mem_image.mp (mem_of_max hy) with ⟨x, hx, rfl⟩,
  exact ⟨x, hx, λ x' hx', le_max_of_mem (mem_image_of_mem f hx') hy⟩,
end

lemma exists_min_image (s : finset β) (f : β → α) (h : s.nonempty) :
  ∃ x ∈ s, ∀ x' ∈ s, f x ≤ f x' :=
@exists_max_image αᵒᵈ β _ s f h

end exists_max_min
end finset

namespace multiset

lemma map_finset_sup [decidable_eq α] [decidable_eq β]
  (s : finset γ) (f : γ → multiset β) (g : β → α) (hg : function.injective g) :
  map g (s.sup f) = s.sup (map g ∘ f) :=
finset.comp_sup_eq_sup_comp _ (λ _ _, map_union hg) (map_zero _)

lemma count_finset_sup [decidable_eq β] (s : finset α) (f : α → multiset β) (b : β) :
  count b (s.sup f) = s.sup (λa, count b (f a)) :=
begin
  letI := classical.dec_eq α,
  refine s.induction _ _,
  { exact count_zero _ },
  { assume i s his ih,
    rw [finset.sup_insert, sup_eq_union, count_union, finset.sup_insert, ih],
    refl }
end

lemma mem_sup {α β} [decidable_eq β] {s : finset α} {f : α → multiset β}
  {x : β} : x ∈ s.sup f ↔ ∃ v ∈ s, x ∈ f v :=
begin
  classical,
  apply s.induction_on,
  { simp },
  { intros a s has hxs,
    rw [finset.sup_insert, multiset.sup_eq_union, multiset.mem_union],
    split,
    { intro hxi,
      cases hxi with hf hf,
      { refine ⟨a, _, hf⟩,
        simp only [true_or, eq_self_iff_true, finset.mem_insert] },
      { rcases hxs.mp hf with ⟨v, hv, hfv⟩,
        refine ⟨v, _, hfv⟩,
        simp only [hv, or_true, finset.mem_insert] } },
    { rintros ⟨v, hv, hfv⟩,
      rw [finset.mem_insert] at hv,
      rcases hv with rfl | hv,
      { exact or.inl hfv },
      { refine or.inr (hxs.mpr ⟨v, hv, hfv⟩) } } },
end

end multiset

namespace finset

lemma mem_sup {α β} [decidable_eq β] {s : finset α} {f : α → finset β}
  {x : β} : x ∈ s.sup f ↔ ∃ v ∈ s, x ∈ f v :=
begin
  change _ ↔ ∃ v ∈ s, x ∈ (f v).val,
  rw [←multiset.mem_sup, ←multiset.mem_to_finset, sup_to_finset],
  simp_rw [val_to_finset],
end

lemma sup_eq_bUnion {α β} [decidable_eq β] (s : finset α) (t : α → finset β) :
  s.sup t = s.bUnion t :=
by { ext, rw [mem_sup, mem_bUnion], }

@[simp] lemma sup_singleton'' [decidable_eq α] (s : finset β) (f : β → α) :
  s.sup (λ b, {f b}) = s.image f :=
by { ext a, rw [mem_sup, mem_image], simp only [mem_singleton, eq_comm] }

@[simp] lemma sup_singleton' [decidable_eq α] (s : finset α) : s.sup singleton = s :=
(s.sup_singleton'' _).trans image_id

end finset

section lattice
variables {ι' : Sort*} [complete_lattice α]

/-- Supremum of `s i`, `i : ι`, is equal to the supremum over `t : finset ι` of suprema
`⨆ i ∈ t, s i`. This version assumes `ι` is a `Type*`. See `supr_eq_supr_finset'` for a version
that works for `ι : Sort*`. -/
lemma supr_eq_supr_finset (s : ι → α) :
  (⨆i, s i) = (⨆t:finset ι, ⨆i∈t, s i) :=
begin
  classical,
  exact le_antisymm
    (supr_le $ assume b, le_supr_of_le {b} $ le_supr_of_le b $ le_supr_of_le
      (by simp) $ le_rfl)
    (supr_le $ assume t, supr_le $ assume b, supr_le $ assume hb, le_supr _ _)
end

/-- Supremum of `s i`, `i : ι`, is equal to the supremum over `t : finset ι` of suprema
`⨆ i ∈ t, s i`. This version works for `ι : Sort*`. See `supr_eq_supr_finset` for a version
that assumes `ι : Type*` but has no `plift`s. -/
lemma supr_eq_supr_finset' (s : ι' → α) :
  (⨆i, s i) = (⨆t:finset (plift ι'), ⨆i∈t, s (plift.down i)) :=
by rw [← supr_eq_supr_finset, ← equiv.plift.surjective.supr_comp]; refl

/-- Infimum of `s i`, `i : ι`, is equal to the infimum over `t : finset ι` of infima
`⨅ i ∈ t, s i`. This version assumes `ι` is a `Type*`. See `infi_eq_infi_finset'` for a version
that works for `ι : Sort*`. -/
lemma infi_eq_infi_finset (s : ι → α) : (⨅ i, s i) = ⨅ (t : finset ι) (i ∈ t), s i :=
@supr_eq_supr_finset αᵒᵈ _ _ _

/-- Infimum of `s i`, `i : ι`, is equal to the infimum over `t : finset ι` of infima
`⨅ i ∈ t, s i`. This version works for `ι : Sort*`. See `infi_eq_infi_finset` for a version
that assumes `ι : Type*` but has no `plift`s. -/
lemma infi_eq_infi_finset' (s : ι' → α) :
  (⨅i, s i) = (⨅t:finset (plift ι'), ⨅i∈t, s (plift.down i)) :=
@supr_eq_supr_finset' αᵒᵈ _ _ _

end lattice

namespace set
variables {ι' : Sort*}

/-- Union of an indexed family of sets `s : ι → set α` is equal to the union of the unions
of finite subfamilies. This version assumes `ι : Type*`. See also `Union_eq_Union_finset'` for
a version that works for `ι : Sort*`. -/
lemma Union_eq_Union_finset (s : ι → set α) :
  (⋃i, s i) = (⋃t:finset ι, ⋃i∈t, s i) :=
supr_eq_supr_finset s

/-- Union of an indexed family of sets `s : ι → set α` is equal to the union of the unions
of finite subfamilies. This version works for `ι : Sort*`. See also `Union_eq_Union_finset` for
a version that assumes `ι : Type*` but avoids `plift`s in the right hand side. -/
lemma Union_eq_Union_finset' (s : ι' → set α) :
  (⋃i, s i) = (⋃t:finset (plift ι'), ⋃i∈t, s (plift.down i)) :=
supr_eq_supr_finset' s

/-- Intersection of an indexed family of sets `s : ι → set α` is equal to the intersection of the
intersections of finite subfamilies. This version assumes `ι : Type*`. See also
`Inter_eq_Inter_finset'` for a version that works for `ι : Sort*`. -/
lemma Inter_eq_Inter_finset (s : ι → set α) :
  (⋂i, s i) = (⋂t:finset ι, ⋂i∈t, s i) :=
infi_eq_infi_finset s

/-- Intersection of an indexed family of sets `s : ι → set α` is equal to the intersection of the
intersections of finite subfamilies. This version works for `ι : Sort*`. See also
`Inter_eq_Inter_finset` for a version that assumes `ι : Type*` but avoids `plift`s in the right
hand side. -/
lemma Inter_eq_Inter_finset' (s : ι' → set α) :
  (⋂i, s i) = (⋂t:finset (plift ι'), ⋂i∈t, s (plift.down i)) :=
infi_eq_infi_finset' s

end set

namespace finset

/-! ### Interaction with ordered algebra structures -/

lemma sup_mul_le_mul_sup_of_nonneg [linear_ordered_semiring α] [order_bot α]
  {a b : ι → α} (s : finset ι) (ha : ∀ i ∈ s, 0 ≤ a i) (hb : ∀ i ∈ s, 0 ≤ b i)  :
  s.sup (a * b) ≤ s.sup a * s.sup b :=
finset.sup_le $ λ i hi, mul_le_mul (le_sup hi) (le_sup hi) (hb _ hi) ((ha _ hi).trans $ le_sup hi)

lemma mul_inf_le_inf_mul_of_nonneg [linear_ordered_semiring α] [order_top α]
  {a b : ι → α} (s : finset ι) (ha : ∀ i ∈ s, 0 ≤ a i) (hb : ∀ i ∈ s, 0 ≤ b i) :
  s.inf a * s.inf b ≤ s.inf (a * b) :=
finset.le_inf $ λ i hi, mul_le_mul (inf_le hi) (inf_le hi) (finset.le_inf hb) (ha i hi)

lemma sup'_mul_le_mul_sup'_of_nonneg [linear_ordered_semiring α]
  {a b : ι → α} (s : finset ι) (H : s.nonempty) (ha : ∀ i ∈ s, 0 ≤ a i) (hb : ∀ i ∈ s, 0 ≤ b i)  :
  s.sup' H (a * b) ≤ s.sup' H a * s.sup' H b :=
sup'_le _ _ $ λ i hi,
  mul_le_mul (le_sup' _ hi) (le_sup' _ hi) (hb _ hi) ((ha _ hi).trans $ le_sup' _ hi)

lemma inf'_mul_le_mul_inf'_of_nonneg [linear_ordered_semiring α]
  {a b : ι → α} (s : finset ι) (H : s.nonempty) (ha : ∀ i ∈ s, 0 ≤ a i) (hb : ∀ i ∈ s, 0 ≤ b i)  :
  s.inf' H a * s.inf' H b ≤ s.inf' H (a * b) :=
le_inf' _ _ $ λ i hi, mul_le_mul (inf'_le _ hi) (inf'_le _ hi) (le_inf' _ _ hb) (ha _ hi)

open function

/-! ### Interaction with big lattice/set operations -/

section lattice

lemma supr_coe [has_Sup β] (f : α → β) (s : finset α) :
  (⨆ x ∈ (↑s : set α), f x) = ⨆ x ∈ s, f x :=
rfl

lemma infi_coe [has_Inf β] (f : α → β) (s : finset α) :
  (⨅ x ∈ (↑s : set α), f x) = ⨅ x ∈ s, f x :=
rfl

variables [complete_lattice β]

theorem supr_singleton (a : α) (s : α → β) : (⨆ x ∈ ({a} : finset α), s x) = s a :=
by simp

theorem infi_singleton (a : α) (s : α → β) : (⨅ x ∈ ({a} : finset α), s x) = s a :=
by simp

lemma supr_option_to_finset (o : option α) (f : α → β) :
  (⨆ x ∈ o.to_finset, f x) = ⨆ x ∈ o, f x :=
by simp

lemma infi_option_to_finset (o : option α) (f : α → β) : (⨅ x ∈ o.to_finset, f x) = ⨅ x ∈ o, f x :=
@supr_option_to_finset _ βᵒᵈ _ _ _

variables [decidable_eq α]

theorem supr_union {f : α → β} {s t : finset α} :
  (⨆ x ∈ s ∪ t, f x) = (⨆x∈s, f x) ⊔ (⨆x∈t, f x) :=
by simp [supr_or, supr_sup_eq]

theorem infi_union {f : α → β} {s t : finset α} :
  (⨅ x ∈ s ∪ t, f x) = (⨅ x ∈ s, f x) ⊓ (⨅ x ∈ t, f x) :=
@supr_union α βᵒᵈ _ _ _ _ _

lemma supr_insert (a : α) (s : finset α) (t : α → β) :
  (⨆ x ∈ insert a s, t x) = t a ⊔ (⨆ x ∈ s, t x) :=
by { rw insert_eq, simp only [supr_union, finset.supr_singleton] }

lemma infi_insert (a : α) (s : finset α) (t : α → β) :
  (⨅ x ∈ insert a s, t x) = t a ⊓ (⨅ x ∈ s, t x) :=
@supr_insert α βᵒᵈ  _ _ _ _ _

lemma supr_finset_image {f : γ → α} {g : α → β} {s : finset γ} :
  (⨆ x ∈ s.image f, g x) = (⨆ y ∈ s, g (f y)) :=
by rw [← supr_coe, coe_image, supr_image, supr_coe]

lemma sup_finset_image {β γ : Type*} [semilattice_sup β] [order_bot β]
  (f : γ → α) (g : α → β) (s : finset γ) :
  (s.image f).sup g = s.sup (g ∘ f) :=
begin
  classical,
  induction s using finset.induction_on with a s' ha ih; simp *
end

lemma infi_finset_image {f : γ → α} {g : α → β} {s : finset γ} :
  (⨅ x ∈ s.image f, g x) = (⨅ y ∈ s, g (f y)) :=
by rw [← infi_coe, coe_image, infi_image, infi_coe]

lemma supr_insert_update {x : α} {t : finset α} (f : α → β) {s : β} (hx : x ∉ t) :
  (⨆ (i ∈ insert x t), function.update f x s i) = (s ⊔ ⨆ (i ∈ t), f i) :=
begin
  simp only [finset.supr_insert, update_same],
  rcongr i hi, apply update_noteq, rintro rfl, exact hx hi
end

lemma infi_insert_update {x : α} {t : finset α} (f : α → β) {s : β} (hx : x ∉ t) :
  (⨅ (i ∈ insert x t), update f x s i) = (s ⊓ ⨅ (i ∈ t), f i) :=
@supr_insert_update α βᵒᵈ _ _ _ _ f _ hx

lemma supr_bUnion (s : finset γ) (t : γ → finset α) (f : α → β) :
  (⨆ y ∈ s.bUnion t, f y) = ⨆ (x ∈ s) (y ∈ t x), f y :=
by simp [@supr_comm _ α, supr_and]

lemma infi_bUnion (s : finset γ) (t : γ → finset α) (f : α → β) :
  (⨅ y ∈ s.bUnion t, f y) = ⨅ (x ∈ s) (y ∈ t x), f y :=
@supr_bUnion _ βᵒᵈ _ _ _ _ _ _

end lattice

theorem set_bUnion_coe (s : finset α) (t : α → set β) :
  (⋃ x ∈ (↑s : set α), t x) = ⋃ x ∈ s, t x :=
rfl

theorem set_bInter_coe (s : finset α) (t : α → set β) :
  (⋂ x ∈ (↑s : set α), t x) = ⋂ x ∈ s, t x :=
rfl

theorem set_bUnion_singleton (a : α) (s : α → set β) :
  (⋃ x ∈ ({a} : finset α), s x) = s a :=
supr_singleton a s

theorem set_bInter_singleton (a : α) (s : α → set β) :
  (⋂ x ∈ ({a} : finset α), s x) = s a :=
infi_singleton a s

@[simp] lemma set_bUnion_preimage_singleton (f : α → β) (s : finset β) :
  (⋃ y ∈ s, f ⁻¹' {y}) = f ⁻¹' s :=
set.bUnion_preimage_singleton f s

lemma set_bUnion_option_to_finset (o : option α) (f : α → set β) :
  (⋃ x ∈ o.to_finset, f x) = ⋃ x ∈ o, f x :=
supr_option_to_finset o f

lemma set_bInter_option_to_finset (o : option α) (f : α → set β) :
  (⋂ x ∈ o.to_finset, f x) = ⋂ x ∈ o, f x :=
infi_option_to_finset o f

lemma subset_set_bUnion_of_mem {s : finset α} {f : α → set β} {x : α} (h : x ∈ s) :
  f x ⊆ ⋃ (y ∈ s), f y :=
show f x ≤ (⨆ y ∈ s, f y), from le_supr_of_le x $ le_supr _ h

variables [decidable_eq α]

lemma set_bUnion_union (s t : finset α) (u : α → set β) :
  (⋃ x ∈ s ∪ t, u x) = (⋃ x ∈ s, u x) ∪ (⋃ x ∈ t, u x) :=
supr_union

lemma set_bInter_inter (s t : finset α) (u : α → set β) :
  (⋂ x ∈ s ∪ t, u x) = (⋂ x ∈ s, u x) ∩ (⋂ x ∈ t, u x) :=
infi_union

lemma set_bUnion_insert (a : α) (s : finset α) (t : α → set β) :
  (⋃ x ∈ insert a s, t x) = t a ∪ (⋃ x ∈ s, t x) :=
supr_insert a s t

lemma set_bInter_insert (a : α) (s : finset α) (t : α → set β) :
  (⋂ x ∈ insert a s, t x) = t a ∩ (⋂ x ∈ s, t x) :=
infi_insert a s t

lemma set_bUnion_finset_image {f : γ → α} {g : α → set β} {s : finset γ} :
  (⋃x ∈ s.image f, g x) = (⋃y ∈ s, g (f y)) :=
supr_finset_image

lemma set_bInter_finset_image {f : γ → α} {g : α → set β} {s : finset γ} :
  (⋂ x ∈ s.image f, g x) = (⋂ y ∈ s, g (f y)) :=
infi_finset_image

lemma set_bUnion_insert_update {x : α} {t : finset α} (f : α → set β) {s : set β} (hx : x ∉ t) :
  (⋃ (i ∈ insert x t), @update _ _ _ f x s i) = (s ∪ ⋃ (i ∈ t), f i) :=
supr_insert_update f hx

lemma set_bInter_insert_update {x : α} {t : finset α} (f : α → set β) {s : set β} (hx : x ∉ t) :
  (⋂ (i ∈ insert x t), @update _ _ _ f x s i) = (s ∩ ⋂ (i ∈ t), f i) :=
infi_insert_update f hx

lemma set_bUnion_bUnion (s : finset γ) (t : γ → finset α) (f : α → set β) :
  (⋃ y ∈ s.bUnion t, f y) = ⋃ (x ∈ s) (y ∈ t x), f y :=
supr_bUnion s t f

lemma set_bInter_bUnion (s : finset γ) (t : γ → finset α) (f : α → set β) :
  (⋂ y ∈ s.bUnion t, f y) = ⋂ (x ∈ s) (y ∈ t x), f y :=
infi_bUnion s t f

end finset


<|start_filename|>src/algebra/is_prime_pow.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.associated
import number_theory.divisors

/-!
# Prime powers

This file deals with prime powers: numbers which are positive integer powers of a single prime.
-/

variables {R : Type*} [comm_monoid_with_zero R] (n p : R) (k : ℕ)

/-- `n` is a prime power if there is a prime `p` and a positive natural `k` such that `n` can be
written as `p^k`. -/
def is_prime_pow : Prop :=
∃ (p : R) (k : ℕ), prime p ∧ 0 < k ∧ p ^ k = n

lemma is_prime_pow_def :
  is_prime_pow n ↔ ∃ (p : R) (k : ℕ), prime p ∧ 0 < k ∧ p ^ k = n := iff.rfl

/-- An equivalent definition for prime powers: `n` is a prime power iff there is a prime `p` and a
natural `k` such that `n` can be written as `p^(k+1)`. -/
lemma is_prime_pow_iff_pow_succ :
  is_prime_pow n ↔ ∃ (p : R) (k : ℕ), prime p ∧ p ^ (k + 1) = n :=
(is_prime_pow_def _).trans
⟨λ ⟨p, k, hp, hk, hn⟩, ⟨_, _, hp, by rwa [nat.sub_add_cancel hk]⟩,
  λ ⟨p, k, hp, hn⟩, ⟨_, _, hp, nat.succ_pos', hn⟩⟩

lemma not_is_prime_pow_zero [no_zero_divisors R] :
  ¬ is_prime_pow (0 : R) :=
begin
  simp only [is_prime_pow_def, not_exists, not_and', and_imp],
  intros x n hn hx,
  rw pow_eq_zero hx,
  simp,
end

lemma not_is_prime_pow_one : ¬ is_prime_pow (1 : R) :=
begin
  simp only [is_prime_pow_def, not_exists, not_and', and_imp],
  intros x n hn hx ht,
  exact ht.not_unit (is_unit_of_pow_eq_one x n hx hn),
end

lemma prime.is_prime_pow {p : R} (hp : prime p) : is_prime_pow p :=
⟨p, 1, hp, zero_lt_one, by simp⟩

lemma is_prime_pow.pow {n : R} (hn : is_prime_pow n)
  {k : ℕ} (hk : k ≠ 0) : is_prime_pow (n ^ k) :=
let ⟨p, k', hp, hk', hn⟩ := hn in ⟨p, k * k', hp, mul_pos hk.bot_lt hk', by rw [pow_mul', hn]⟩

theorem is_prime_pow.ne_zero [no_zero_divisors R] {n : R} (h : is_prime_pow n) : n ≠ 0 :=
λ t, eq.rec not_is_prime_pow_zero t.symm h

lemma is_prime_pow.ne_one {n : R} (h : is_prime_pow n) : n ≠ 1 :=
λ t, eq.rec not_is_prime_pow_one t.symm h

section unique_units

lemma eq_of_prime_pow_eq {R : Type*} [cancel_comm_monoid_with_zero R] [unique Rˣ] {p₁ p₂ : R}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₁ : 0 < k₁) (h : p₁ ^ k₁ = p₂ ^ k₂) :
  p₁ = p₂ :=
by { rw [←associated_iff_eq] at h ⊢, apply h.of_pow_associated_of_prime hp₁ hp₂ hk₁ }

lemma eq_of_prime_pow_eq' {R : Type*} [cancel_comm_monoid_with_zero R] [unique Rˣ] {p₁ p₂ : R}
  {k₁ k₂ : ℕ} (hp₁ : prime p₁) (hp₂ : prime p₂) (hk₁ : 0 < k₂) (h : p₁ ^ k₁ = p₂ ^ k₂) :
  p₁ = p₂ :=
by { rw [←associated_iff_eq] at h ⊢, apply h.of_pow_associated_of_prime' hp₁ hp₂ hk₁ }

end unique_units

section nat

lemma is_prime_pow_nat_iff (n : ℕ) :
  is_prime_pow n ↔ ∃ (p k : ℕ), nat.prime p ∧ 0 < k ∧ p ^ k = n :=
by simp only [is_prime_pow_def, nat.prime_iff]

lemma nat.prime.is_prime_pow {p : ℕ} (hp : p.prime) : is_prime_pow p :=
(nat.prime_iff.mp hp).is_prime_pow

lemma is_prime_pow_nat_iff_bounded (n : ℕ) :
  is_prime_pow n ↔ ∃ (p : ℕ), p ≤ n ∧ ∃ (k : ℕ), k ≤ n ∧ p.prime ∧ 0 < k ∧ p ^ k = n :=
begin
  rw is_prime_pow_nat_iff,
  refine iff.symm ⟨λ ⟨p, _, k, _, hp, hk, hn⟩, ⟨p, k, hp, hk, hn⟩, _⟩,
  rintro ⟨p, k, hp, hk, rfl⟩,
  refine ⟨p, _, k, (nat.lt_pow_self hp.one_lt _).le, hp, hk, rfl⟩,
  simpa using nat.pow_le_pow_of_le_right hp.pos hk,
end

instance {n : ℕ} : decidable (is_prime_pow n) :=
decidable_of_iff' _ (is_prime_pow_nat_iff_bounded n)

lemma is_prime_pow.dvd {n m : ℕ} (hn : is_prime_pow n) (hm : m ∣ n) (hm₁ : m ≠ 1) :
  is_prime_pow m :=
begin
  rw is_prime_pow_nat_iff at hn ⊢,
  rcases hn with ⟨p, k, hp, hk, rfl⟩,
  obtain ⟨i, hik, rfl⟩ := (nat.dvd_prime_pow hp).1 hm,
  refine ⟨p, i, hp, _, rfl⟩,
  apply nat.pos_of_ne_zero,
  rintro rfl,
  simpa using hm₁,
end

lemma nat.disjoint_divisors_filter_prime_pow {a b : ℕ} (hab : a.coprime b) :
  disjoint (a.divisors.filter is_prime_pow) (b.divisors.filter is_prime_pow) :=
begin
  simp only [finset.disjoint_left, finset.mem_filter, and_imp, nat.mem_divisors, not_and],
  rintro n han ha hn hbn hb -,
  exact hn.ne_one (nat.eq_one_of_dvd_coprimes hab han hbn),
end

lemma is_prime_pow.two_le : ∀ {n : ℕ}, is_prime_pow n → 2 ≤ n
| 0 h := (not_is_prime_pow_zero h).elim
| 1 h := (not_is_prime_pow_one h).elim
| (n+2) _ := le_add_self

theorem is_prime_pow.pos {n : ℕ} (hn : is_prime_pow n) : 0 < n := pos_of_gt hn.two_le

theorem is_prime_pow.one_lt {n : ℕ} (h : is_prime_pow n) : 1 < n := h.two_le

end nat


<|start_filename|>src/algebra/group/conj.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import algebra.group.semiconj
import algebra.group_with_zero.basic
import algebra.hom.aut
import algebra.hom.group
import data.fintype.basic

/-!
# Conjugacy of group elements

See also `mul_aut.conj` and `quandle.conj`.
-/

universes u v
variables {α : Type u} {β : Type v}

section monoid

variables [monoid α] [monoid β]

/-- We say that `a` is conjugate to `b` if for some unit `c` we have `c * a * c⁻¹ = b`. -/
def is_conj (a b : α) := ∃ c : αˣ, semiconj_by ↑c a b

@[refl] lemma is_conj.refl (a : α) : is_conj a a :=
⟨1, semiconj_by.one_left a⟩

@[symm] lemma is_conj.symm {a b : α} : is_conj a b → is_conj b a
| ⟨c, hc⟩ := ⟨c⁻¹, hc.units_inv_symm_left⟩

lemma is_conj_comm {g h : α} : is_conj g h ↔ is_conj h g :=
⟨is_conj.symm, is_conj.symm⟩

@[trans] lemma is_conj.trans {a b c : α} : is_conj a b → is_conj b c → is_conj a c
| ⟨c₁, hc₁⟩ ⟨c₂, hc₂⟩ := ⟨c₂ * c₁, hc₂.mul_left hc₁⟩

@[simp] lemma is_conj_iff_eq {α : Type*} [comm_monoid α] {a b : α} : is_conj a b ↔ a = b :=
⟨λ ⟨c, hc⟩, begin
  rw [semiconj_by, mul_comm, ← units.mul_inv_eq_iff_eq_mul, mul_assoc, c.mul_inv, mul_one] at hc,
  exact hc,
end, λ h, by rw h⟩

protected lemma monoid_hom.map_is_conj (f : α →* β) {a b : α} : is_conj a b → is_conj (f a) (f b)
| ⟨c, hc⟩ := ⟨units.map f c, by rw [units.coe_map, semiconj_by, ← f.map_mul, hc.eq, f.map_mul]⟩

end monoid

section cancel_monoid

variables [cancel_monoid α]
-- These lemmas hold for `right_cancel_monoid` with the current proofs, but for the sake of
-- not duplicating code (these lemmas also hold for `left_cancel_monoids`) we leave these
-- not generalised.

@[simp] lemma is_conj_one_right {a : α} : is_conj 1 a  ↔ a = 1 :=
⟨λ ⟨c, hc⟩, mul_right_cancel (hc.symm.trans ((mul_one _).trans (one_mul _).symm)), λ h, by rw [h]⟩

@[simp] lemma is_conj_one_left {a : α} : is_conj a 1 ↔ a = 1 :=
calc is_conj a 1 ↔ is_conj 1 a : ⟨is_conj.symm, is_conj.symm⟩
... ↔ a = 1 : is_conj_one_right

end cancel_monoid

section group

variables [group α]

@[simp] lemma is_conj_iff {a b : α} :
  is_conj a b ↔ ∃ c : α, c * a * c⁻¹ = b :=
⟨λ ⟨c, hc⟩, ⟨c, mul_inv_eq_iff_eq_mul.2 hc⟩, λ ⟨c, hc⟩,
  ⟨⟨c, c⁻¹, mul_inv_self c, inv_mul_self c⟩, mul_inv_eq_iff_eq_mul.1 hc⟩⟩

@[simp] lemma conj_inv {a b : α} : (b * a * b⁻¹)⁻¹ = b * a⁻¹ * b⁻¹ :=
((mul_aut.conj b).map_inv a).symm

@[simp] lemma conj_mul {a b c : α} : (b * a * b⁻¹) * (b * c * b⁻¹) = b * (a * c) * b⁻¹ :=
((mul_aut.conj b).map_mul a c).symm

@[simp] lemma conj_pow {i : ℕ} {a b : α} : (a * b * a⁻¹) ^ i = a * (b ^ i) * a⁻¹ :=
begin
  induction i with i hi,
  { simp },
  { simp [pow_succ, hi] }
end

@[simp] lemma conj_zpow {i : ℤ} {a b : α} : (a * b * a⁻¹) ^ i = a * (b ^ i) * a⁻¹ :=
begin
  induction i,
  { simp },
  { simp [zpow_neg_succ_of_nat, conj_pow] }
end

lemma conj_injective {x : α} : function.injective (λ (g : α), x * g * x⁻¹) :=
(mul_aut.conj x).injective

end group

@[simp] lemma is_conj_iff₀ [group_with_zero α] {a b : α} :
  is_conj a b ↔ ∃ c : α, c ≠ 0 ∧ c * a * c⁻¹ = b :=
⟨λ ⟨c, hc⟩, ⟨c, begin
    rw [← units.coe_inv', units.mul_inv_eq_iff_eq_mul],
    exact ⟨c.ne_zero, hc⟩,
  end⟩, λ ⟨c, c0, hc⟩,
  ⟨units.mk0 c c0, begin
    rw [semiconj_by, ← units.mul_inv_eq_iff_eq_mul, units.coe_inv', units.coe_mk0],
    exact hc
  end⟩⟩

namespace is_conj
/- This small quotient API is largely copied from the API of `associates`;
where possible, try to keep them in sync -/

/-- The setoid of the relation `is_conj` iff there is a unit `u` such that `u * x = y * u` -/
protected def setoid (α : Type*) [monoid α] : setoid α :=
{ r := is_conj, iseqv := ⟨is_conj.refl, λa b, is_conj.symm, λa b c, is_conj.trans⟩ }

end is_conj

local attribute [instance, priority 100] is_conj.setoid

/-- The quotient type of conjugacy classes of a group. -/
def conj_classes (α : Type*) [monoid α] : Type* :=
quotient (is_conj.setoid α)

namespace conj_classes

section monoid
variables [monoid α] [monoid β]

/-- The canonical quotient map from a monoid `α` into the `conj_classes` of `α` -/
protected def mk {α : Type*} [monoid α] (a : α) : conj_classes α :=
⟦a⟧

instance : inhabited (conj_classes α) := ⟨⟦1⟧⟩

theorem mk_eq_mk_iff_is_conj {a b : α} :
  conj_classes.mk a = conj_classes.mk b ↔ is_conj a b :=
iff.intro quotient.exact quot.sound

theorem quotient_mk_eq_mk (a : α) : ⟦ a ⟧ = conj_classes.mk a := rfl

theorem quot_mk_eq_mk (a : α) : quot.mk setoid.r a = conj_classes.mk a := rfl

theorem forall_is_conj {p : conj_classes α → Prop} :
  (∀a, p a) ↔ (∀a, p (conj_classes.mk a)) :=
iff.intro
  (assume h a, h _)
  (assume h a, quotient.induction_on a h)

theorem mk_surjective : function.surjective (@conj_classes.mk α _) :=
forall_is_conj.2 (λ a, ⟨a, rfl⟩)

instance : has_one (conj_classes α) := ⟨⟦ 1 ⟧⟩

theorem one_eq_mk_one : (1 : conj_classes α) = conj_classes.mk 1 := rfl

lemma exists_rep (a : conj_classes α) : ∃ a0 : α, conj_classes.mk a0 = a :=
quot.exists_rep a

/-- A `monoid_hom` maps conjugacy classes of one group to conjugacy classes of another. -/
def map (f : α →* β) : conj_classes α → conj_classes β :=
quotient.lift (conj_classes.mk ∘ f) (λ a b ab, mk_eq_mk_iff_is_conj.2 (f.map_is_conj ab))

lemma map_surjective {f : α →* β} (hf : function.surjective f) :
  function.surjective (conj_classes.map f) :=
begin
  intros b,
  obtain ⟨b, rfl⟩ := conj_classes.mk_surjective b,
  obtain ⟨a, rfl⟩ := hf b,
  exact ⟨conj_classes.mk a, rfl⟩,
end

instance [fintype α] [decidable_rel (is_conj : α → α → Prop)] :
  fintype (conj_classes α) :=
quotient.fintype (is_conj.setoid α)

/--
Certain instances trigger further searches when they are considered as candidate instances;
these instances should be assigned a priority lower than the default of 1000 (for example, 900).

The conditions for this rule are as follows:
 * a class `C` has instances `instT : C T` and `instT' : C T'`
 * types `T` and `T'` are both specializations of another type `S`
 * the parameters supplied to `S` to produce `T` are not (fully) determined by `instT`,
   instead they have to be found by instance search
If those conditions hold, the instance `instT` should be assigned lower priority.

For example, suppose the search for an instance of `decidable_eq (multiset α)` tries the
candidate instance `con.quotient.decidable_eq (c : con M) : decidable_eq c.quotient`.
Since `multiset` and `con.quotient` are both quotient types, unification will check
that the relations `list.perm` and `c.to_setoid.r` unify. However, `c.to_setoid` depends on 
a `has_mul M` instance, so this unification triggers a search for `has_mul (list α)`;
this will traverse all subclasses of `has_mul` before failing.
On the other hand, the search for an instance of `decidable_eq (con.quotient c)` for `c : con M`
can quickly reject the candidate instance `multiset.has_decidable_eq` because the type of
`list.perm : list ?m_1 → list ?m_1 → Prop` does not unify with `M → M → Prop`.
Therefore, we should assign `con.quotient.decidable_eq` a lower priority because it fails slowly.
(In terms of the rules above, `C := decidable_eq`, `T := con.quotient`,
`instT := con.quotient.decidable_eq`, `T' := multiset`, `instT' := multiset.has_decidable_eq`,
and `S := quot`.)

If the type involved is a free variable (rather than an instantiation of some type `S`),
the instance priority should be even lower, see Note [lower instance priority].
-/
library_note "slow-failing instance priority"

@[priority 900] -- see Note [slow-failing instance priority]
instance [decidable_rel (is_conj : α → α → Prop)] : decidable_eq (conj_classes α) :=
quotient.decidable_eq

instance [decidable_eq α] [fintype α] : decidable_rel (is_conj : α → α → Prop) :=
λ a b, by { delta is_conj semiconj_by, apply_instance }

end monoid

section comm_monoid
variable [comm_monoid α]

lemma mk_injective : function.injective (@conj_classes.mk α _) :=
λ _ _, (mk_eq_mk_iff_is_conj.trans is_conj_iff_eq).1

lemma mk_bijective : function.bijective (@conj_classes.mk α _) :=
⟨mk_injective, mk_surjective⟩

/-- The bijection between a `comm_group` and its `conj_classes`. -/
def mk_equiv : α ≃ conj_classes α :=
⟨conj_classes.mk, quotient.lift id (λ (a : α) b, is_conj_iff_eq.1), quotient.lift_mk _ _,
  begin
    rw [function.right_inverse, function.left_inverse, forall_is_conj],
    intro x,
    rw [← quotient_mk_eq_mk, ← quotient_mk_eq_mk, quotient.lift_mk, id.def],
  end⟩

end comm_monoid
end conj_classes

section monoid

variables [monoid α]

/-- Given an element `a`, `conjugates a` is the set of conjugates. -/
def conjugates_of (a : α) : set α := {b | is_conj a b}

lemma mem_conjugates_of_self {a : α} : a ∈ conjugates_of a := is_conj.refl _

lemma is_conj.conjugates_of_eq {a b : α} (ab : is_conj a b) :
  conjugates_of a = conjugates_of b :=
set.ext (λ g, ⟨λ ag, (ab.symm).trans ag, λ bg, ab.trans bg⟩)

lemma is_conj_iff_conjugates_of_eq {a b : α} :
  is_conj a b ↔ conjugates_of a = conjugates_of b :=
⟨is_conj.conjugates_of_eq, λ h, begin
  have ha := mem_conjugates_of_self,
  rwa ← h at ha,
end⟩

instance [fintype α] [decidable_rel (is_conj : α → α → Prop)] {a : α} : fintype (conjugates_of a) :=
@subtype.fintype _ _ (‹decidable_rel is_conj› a) _

end monoid

namespace conj_classes

variables [monoid α]

local attribute [instance] is_conj.setoid

/-- Given a conjugacy class `a`, `carrier a` is the set it represents. -/
def carrier : conj_classes α → set α :=
quotient.lift conjugates_of (λ (a : α) b ab, is_conj.conjugates_of_eq ab)

lemma mem_carrier_mk {a : α} : a ∈ carrier (conj_classes.mk a) := is_conj.refl _

lemma mem_carrier_iff_mk_eq {a : α} {b : conj_classes α} :
  a ∈ carrier b ↔ conj_classes.mk a = b :=
begin
  revert b,
  rw forall_is_conj,
  intro b,
  rw [carrier, eq_comm, mk_eq_mk_iff_is_conj, ← quotient_mk_eq_mk, quotient.lift_mk],
  refl,
end

lemma carrier_eq_preimage_mk {a : conj_classes α} :
  a.carrier = conj_classes.mk ⁻¹' {a} :=
set.ext (λ x, mem_carrier_iff_mk_eq)

section fintype

variables [fintype α] [decidable_rel (is_conj : α → α → Prop)]

instance {x : conj_classes α} : fintype (carrier x) :=
quotient.rec_on_subsingleton x $ λ a, conjugates_of.fintype

end fintype

end conj_classes


<|start_filename|>src/category_theory/concrete_category/elementwise.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import tactic.elementwise
import category_theory.limits.has_limits
import category_theory.limits.shapes.kernels

/-!
In this file we provide various simp lemmas in its elementwise form via `tactic.elementwise`.
-/

open category_theory category_theory.limits

attribute [elementwise]
  cone.w limit.lift_π limit.w cocone.w colimit.ι_desc colimit.w
  kernel.lift_ι cokernel.π_desc
  kernel.condition cokernel.condition


<|start_filename|>src/ring_theory/algebraic_independent.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import ring_theory.adjoin.basic
import linear_algebra.linear_independent
import ring_theory.mv_polynomial.basic
import data.mv_polynomial.supported
import ring_theory.algebraic
import data.mv_polynomial.equiv
/-!
# Algebraic Independence

This file defines algebraic independence of a family of element of an `R` algebra

## Main definitions

* `algebraic_independent` - `algebraic_independent R x` states the family of elements `x`
  is algebraically independent over `R`, meaning that the canonical map out of the multivariable
  polynomial ring is injective.

* `algebraic_independent.repr` - The canonical map from the subalgebra generated by an
  algebraic independent family into the polynomial ring.

## References

* [Stacks: Transcendence](https://stacks.math.columbia.edu/tag/030D)

## TODO
Prove that a ring is an algebraic extension of the subalgebra generated by a transcendence basis.

## Tags
transcendence basis, transcendence degree, transcendence

-/
noncomputable theory

open function set subalgebra mv_polynomial algebra
open_locale classical big_operators

universes x u v w

variables {ι : Type*} {ι' : Type*} (R : Type*) {K : Type*}
variables {A : Type*} {A' A'' : Type*} {V : Type u} {V' : Type*}
variables (x : ι → A)
variables [comm_ring R] [comm_ring A] [comm_ring A'] [comm_ring A'']
variables [algebra R A] [algebra R A'] [algebra R A'']
variables {a b : R}

/-- `algebraic_independent R x` states the family of elements `x`
  is algebraically independent over `R`, meaning that the canonical
  map out of the multivariable polynomial ring is injective. -/
def algebraic_independent : Prop :=
injective (mv_polynomial.aeval x : mv_polynomial ι R →ₐ[R] A)

variables {R} {x}

theorem algebraic_independent_iff_ker_eq_bot : algebraic_independent R x ↔
  (mv_polynomial.aeval x : mv_polynomial ι R →ₐ[R] A).to_ring_hom.ker = ⊥ :=
ring_hom.injective_iff_ker_eq_bot _

theorem algebraic_independent_iff : algebraic_independent R x ↔
  ∀p : mv_polynomial ι R, mv_polynomial.aeval (x : ι → A) p = 0 → p = 0 :=
injective_iff_map_eq_zero _

theorem algebraic_independent.eq_zero_of_aeval_eq_zero (h : algebraic_independent R x) :
  ∀p : mv_polynomial ι R, mv_polynomial.aeval (x : ι → A) p = 0 → p = 0 :=
algebraic_independent_iff.1 h

theorem algebraic_independent_iff_injective_aeval :
  algebraic_independent R x ↔ injective (mv_polynomial.aeval x : mv_polynomial ι R →ₐ[R] A) :=
iff.rfl

@[simp] lemma algebraic_independent_empty_type_iff [is_empty ι] :
  algebraic_independent R x ↔ injective (algebra_map R A) :=
have aeval x = (algebra.of_id R A).comp (@is_empty_alg_equiv R ι _ _).to_alg_hom,
  by { ext i, exact is_empty.elim' ‹is_empty ι› i },
begin
  rw [algebraic_independent, this,
    ← injective.of_comp_iff' _ (@is_empty_alg_equiv R ι _ _).bijective],
  refl
end

namespace algebraic_independent

variables (hx : algebraic_independent R x)

include hx

lemma algebra_map_injective : injective (algebra_map R A) :=
by simpa [← mv_polynomial.algebra_map_eq, function.comp] using
    (injective.of_comp_iff
      (algebraic_independent_iff_injective_aeval.1 hx) (mv_polynomial.C)).2
    (mv_polynomial.C_injective _ _)

lemma linear_independent : linear_independent R x :=
begin
  rw [linear_independent_iff_injective_total],
  have : finsupp.total ι A R x =
    (mv_polynomial.aeval x).to_linear_map.comp (finsupp.total ι _ R X),
  { ext, simp },
  rw this,
  refine hx.comp _,
  rw [← linear_independent_iff_injective_total],
  exact linear_independent_X _ _
end

protected lemma injective [nontrivial R] : injective x :=
hx.linear_independent.injective

lemma ne_zero [nontrivial R] (i : ι) : x i ≠ 0 :=
hx.linear_independent.ne_zero i

lemma comp (f : ι' → ι) (hf : function.injective f) : algebraic_independent R (x ∘ f) :=
λ p q, by simpa [aeval_rename, (rename_injective f hf).eq_iff] using @hx (rename f p) (rename f q)

lemma coe_range : algebraic_independent R (coe : range x → A) :=
by simpa using hx.comp _ (range_splitting_injective x)

lemma map {f : A →ₐ[R] A'} (hf_inj : set.inj_on f (adjoin R (range x))) :
  algebraic_independent R (f ∘ x) :=
have aeval (f ∘ x) = f.comp (aeval x), by ext; simp,
have h : ∀ p : mv_polynomial ι R, aeval x p ∈ (@aeval R _ _ _ _ _ (coe : range x → A)).range,
  { intro p,
    rw [alg_hom.mem_range],
    refine ⟨mv_polynomial.rename (cod_restrict x (range x) (mem_range_self)) p, _⟩,
    simp [function.comp, aeval_rename] },
begin
  intros x y hxy,
  rw [this] at hxy,
  rw [adjoin_eq_range] at hf_inj,
  exact hx (hf_inj (h x) (h y) hxy)
end

lemma map' {f : A →ₐ[R] A'} (hf_inj : injective f) : algebraic_independent R (f ∘ x) :=
hx.map (inj_on_of_injective hf_inj _)

omit hx

lemma of_comp (f : A →ₐ[R] A') (hfv : algebraic_independent R (f ∘ x)) :
  algebraic_independent R x :=
have aeval (f ∘ x) = f.comp (aeval x), by ext; simp,
by rw [algebraic_independent, this] at hfv; exact hfv.of_comp

end algebraic_independent

open algebraic_independent

lemma alg_hom.algebraic_independent_iff (f : A →ₐ[R] A') (hf : injective f) :
  algebraic_independent R (f ∘ x) ↔ algebraic_independent R x :=
⟨λ h, h.of_comp f, λ h, h.map (inj_on_of_injective hf _)⟩

@[nontriviality]
lemma algebraic_independent_of_subsingleton [subsingleton R] : algebraic_independent R x :=
by haveI := @mv_polynomial.unique R ι;
  exact algebraic_independent_iff.2 (λ l hl, subsingleton.elim _ _)

theorem algebraic_independent_equiv (e : ι ≃ ι') {f : ι' → A} :
  algebraic_independent R (f ∘ e) ↔ algebraic_independent R f :=
⟨λ h, function.comp.right_id f ▸ e.self_comp_symm ▸ h.comp _ e.symm.injective,
λ h, h.comp _ e.injective⟩

theorem algebraic_independent_equiv' (e : ι ≃ ι') {f : ι' → A} {g : ι → A} (h : f ∘ e = g) :
  algebraic_independent R g ↔ algebraic_independent R f :=
h ▸ algebraic_independent_equiv e

theorem algebraic_independent_subtype_range {ι} {f : ι → A} (hf : injective f) :
  algebraic_independent R (coe : range f → A) ↔ algebraic_independent R f :=
iff.symm $ algebraic_independent_equiv' (equiv.of_injective f hf) rfl

alias algebraic_independent_subtype_range ↔ algebraic_independent.of_subtype_range _

theorem algebraic_independent_image {ι} {s : set ι} {f : ι → A} (hf : set.inj_on f s) :
  algebraic_independent R (λ x : s, f x) ↔ algebraic_independent R (λ x : f '' s, (x : A)) :=
algebraic_independent_equiv' (equiv.set.image_of_inj_on _ _ hf) rfl

lemma algebraic_independent_adjoin (hs : algebraic_independent R x) :
  @algebraic_independent ι R (adjoin R (range x))
      (λ i : ι, ⟨x i, subset_adjoin (mem_range_self i)⟩) _ _ _ :=
algebraic_independent.of_comp (adjoin R (range x)).val hs

/-- A set of algebraically independent elements in an algebra `A` over a ring `K` is also
algebraically independent over a subring `R` of `K`. -/
lemma algebraic_independent.restrict_scalars {K : Type*} [comm_ring K] [algebra R K]
   [algebra K A] [is_scalar_tower R K A]
  (hinj : function.injective (algebra_map R K)) (ai : algebraic_independent K x) :
  algebraic_independent R x :=
have (aeval x : mv_polynomial ι K →ₐ[K] A).to_ring_hom.comp
    (mv_polynomial.map (algebra_map R K)) =
    (aeval x : mv_polynomial ι R →ₐ[R] A).to_ring_hom,
  by { ext; simp [algebra_map_eq_smul_one] },
begin
  show injective (aeval x).to_ring_hom,
  rw [← this],
  exact injective.comp ai (mv_polynomial.map_injective _ hinj)
end

/-- Every finite subset of an algebraically independent set is algebraically independent. -/
lemma algebraic_independent_finset_map_embedding_subtype
  (s : set A) (li : algebraic_independent R (coe : s → A)) (t : finset s) :
  algebraic_independent R (coe : (finset.map (embedding.subtype s) t) → A) :=
begin
  let f : t.map (embedding.subtype s) → s := λ x, ⟨x.1, begin
    obtain ⟨x, h⟩ := x,
    rw [finset.mem_map] at h,
    obtain ⟨a, ha, rfl⟩ := h,
    simp only [subtype.coe_prop, embedding.coe_subtype],
  end⟩,
  convert algebraic_independent.comp li f _,
  rintros ⟨x, hx⟩ ⟨y, hy⟩,
  rw [finset.mem_map] at hx hy,
  obtain ⟨a, ha, rfl⟩ := hx,
  obtain ⟨b, hb, rfl⟩ := hy,
  simp only [imp_self, subtype.mk_eq_mk],
end

/--
If every finite set of algebraically independent element has cardinality at most `n`,
then the same is true for arbitrary sets of algebraically independent elements.
-/
lemma algebraic_independent_bounded_of_finset_algebraic_independent_bounded {n : ℕ}
  (H : ∀ s : finset A, algebraic_independent R (λ i : s, (i : A)) → s.card ≤ n) :
  ∀ s : set A, algebraic_independent R (coe : s → A) → cardinal.mk s ≤ n :=
begin
  intros s li,
  apply cardinal.card_le_of,
  intro t,
  rw ← finset.card_map (embedding.subtype s),
  apply H,
  apply algebraic_independent_finset_map_embedding_subtype _ li,
end

section subtype

lemma algebraic_independent.restrict_of_comp_subtype {s : set ι}
  (hs : algebraic_independent R (x ∘ coe : s → A)) :
  algebraic_independent R (s.restrict x) :=
hs

variables (R A)
lemma algebraic_independent_empty_iff : algebraic_independent R (λ x, x : (∅ : set A) → A) ↔
  injective (algebra_map R A) :=
by simp
variables {R A}

lemma algebraic_independent.mono {t s : set A} (h : t ⊆ s)
  (hx : algebraic_independent R (λ x, x : s → A)) : algebraic_independent R (λ x, x : t → A) :=
by simpa [function.comp] using hx.comp (inclusion h) (inclusion_injective h)

end subtype

theorem algebraic_independent.to_subtype_range {ι} {f : ι → A} (hf : algebraic_independent R f) :
  algebraic_independent R (coe : range f → A) :=
begin
  nontriviality R,
  { rwa algebraic_independent_subtype_range hf.injective }
end

theorem algebraic_independent.to_subtype_range' {ι} {f : ι → A} (hf : algebraic_independent R f)
  {t} (ht : range f = t) :
  algebraic_independent R (coe : t → A) :=
ht ▸ hf.to_subtype_range

theorem algebraic_independent_comp_subtype {s : set ι} :
  algebraic_independent R (x ∘ coe : s → A) ↔
  ∀ p ∈ (mv_polynomial.supported R s), aeval x p = 0 → p = 0 :=
have (aeval (x ∘ coe : s → A) : _ →ₐ[R] _) =
  (aeval x).comp (rename coe), by ext; simp,
have ∀ p : mv_polynomial s R, rename (coe : s → ι) p = 0 ↔ p = 0,
  from (injective_iff_map_eq_zero' (rename (coe : s → ι) : mv_polynomial s R →ₐ[R] _).to_ring_hom).1
    (rename_injective _ subtype.val_injective),
by simp [algebraic_independent_iff, supported_eq_range_rename, *]

theorem algebraic_independent_subtype {s : set A} :
  algebraic_independent R (λ x, x : s → A) ↔
  ∀ (p : mv_polynomial A R), p ∈ mv_polynomial.supported R s → aeval id p = 0 → p = 0 :=
by apply @algebraic_independent_comp_subtype _ _ _ id

lemma algebraic_independent_of_finite (s : set A)
  (H : ∀ t ⊆ s, t.finite → algebraic_independent R (λ x, x : t → A)) :
  algebraic_independent R (λ x, x : s → A) :=
algebraic_independent_subtype.2 $
  λ p hp, algebraic_independent_subtype.1 (H _ (mem_supported.1 hp) (finset.finite_to_set _)) _
    (by simp)

theorem algebraic_independent.image_of_comp {ι ι'} (s : set ι) (f : ι → ι') (g : ι' → A)
  (hs : algebraic_independent R (λ x : s, g (f x))) :
  algebraic_independent R (λ x : f '' s, g x) :=
begin
  nontriviality R,
  have : inj_on f s, from inj_on_iff_injective.2 hs.injective.of_comp,
  exact (algebraic_independent_equiv' (equiv.set.image_of_inj_on f s this) rfl).1 hs
end

theorem algebraic_independent.image {ι} {s : set ι} {f : ι → A}
  (hs : algebraic_independent R (λ x : s, f x)) : algebraic_independent R (λ x : f '' s, (x : A)) :=
by convert algebraic_independent.image_of_comp s f id hs

lemma algebraic_independent_Union_of_directed {η : Type*} [nonempty η]
  {s : η → set A} (hs : directed (⊆) s)
  (h : ∀ i, algebraic_independent R (λ x, x : s i → A)) :
  algebraic_independent R (λ x, x : (⋃ i, s i) → A) :=
begin
  refine algebraic_independent_of_finite (⋃ i, s i) (λ t ht ft, _),
  rcases finite_subset_Union ft ht with ⟨I, fi, hI⟩,
  rcases hs.finset_le fi.to_finset with ⟨i, hi⟩,
  exact (h i).mono (subset.trans hI $ Union₂_subset $
    λ j hj, hi j (fi.mem_to_finset.2 hj))
end

lemma algebraic_independent_sUnion_of_directed {s : set (set A)}
  (hsn : s.nonempty)
  (hs : directed_on (⊆) s)
  (h : ∀ a ∈ s, algebraic_independent R (λ x, x : (a : set A) → A)) :
  algebraic_independent R (λ x, x : (⋃₀ s) → A) :=
by letI : nonempty s := nonempty.to_subtype hsn;
rw sUnion_eq_Union; exact
algebraic_independent_Union_of_directed hs.directed_coe (by simpa using h)

lemma exists_maximal_algebraic_independent
  (s t : set A) (hst : s ⊆ t)
  (hs : algebraic_independent R (coe : s → A)) :
  ∃ u : set A, algebraic_independent R (coe : u → A) ∧ s ⊆ u ∧ u ⊆ t ∧
    ∀ x : set A, algebraic_independent R (coe : x → A) →
      u ⊆ x → x ⊆ t → x = u :=
begin
  rcases zorn_subset_nonempty
      { u : set A | algebraic_independent R (coe : u → A) ∧ s ⊆ u ∧ u ⊆ t }
    (λ c hc chainc hcn, ⟨⋃₀ c, begin
      refine ⟨⟨algebraic_independent_sUnion_of_directed hcn
        chainc.directed_on
        (λ a ha, (hc ha).1), _, _⟩, _⟩,
      { cases hcn with x hx,
        exact subset_sUnion_of_subset _ x (hc hx).2.1 hx },
      { exact sUnion_subset (λ x hx, (hc hx).2.2) },
      { intros s,
        exact subset_sUnion_of_mem }
    end⟩)
  s ⟨hs, set.subset.refl s, hst⟩ with ⟨u, ⟨huai, hsu, hut⟩, hsu, hx⟩,
  use [u, huai, hsu, hut],
  intros x hxai huv hxt,
  exact hx _ ⟨hxai, trans hsu huv, hxt⟩ huv,
end

section repr
variables (hx : algebraic_independent R x)

/-- Canonical isomorphism between polynomials and the subalgebra generated by
  algebraically independent elements. -/
@[simps] def algebraic_independent.aeval_equiv (hx : algebraic_independent R x) :
  (mv_polynomial ι R) ≃ₐ[R] algebra.adjoin R (range x) :=
begin
  apply alg_equiv.of_bijective
    (alg_hom.cod_restrict (@aeval R A ι _ _ _ x) (algebra.adjoin R (range x)) _),
  swap,
  { intros x,
    rw [adjoin_range_eq_range_aeval],
    exact alg_hom.mem_range_self _ _ },
  { split,
    { exact (alg_hom.injective_cod_restrict _ _ _).2 hx },
    { rintros ⟨x, hx⟩,
      rw [adjoin_range_eq_range_aeval] at hx,
      rcases hx with ⟨y, rfl⟩,
      use y,
      ext,
      simp } }
end

@[simp] lemma algebraic_independent.algebra_map_aeval_equiv (hx : algebraic_independent R x)
  (p : mv_polynomial ι R) : algebra_map (algebra.adjoin R (range x)) A (hx.aeval_equiv p) =
  aeval x p := rfl

/-- The canonical map from the subalgebra generated by an algebraic independent family
  into the polynomial ring.  -/
def algebraic_independent.repr (hx : algebraic_independent R x) :
  algebra.adjoin R (range x) →ₐ[R] mv_polynomial ι R := hx.aeval_equiv.symm

@[simp] lemma algebraic_independent.aeval_repr (p) : aeval x (hx.repr p) = p :=
subtype.ext_iff.1 (alg_equiv.apply_symm_apply hx.aeval_equiv p)

lemma algebraic_independent.aeval_comp_repr :
  (aeval x).comp hx.repr = subalgebra.val _ :=
alg_hom.ext $ hx.aeval_repr

lemma algebraic_independent.repr_ker :
  (hx.repr : adjoin R (range x) →+* mv_polynomial ι R).ker = ⊥ :=
(ring_hom.injective_iff_ker_eq_bot _).1 (alg_equiv.injective _)

end repr

-- TODO - make this an `alg_equiv`
/-- The isomorphism between `mv_polynomial (option ι) R` and the polynomial ring over
the algebra generated by an algebraically independent family.  -/
def algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin
  (hx : algebraic_independent R x) :
  mv_polynomial (option ι) R ≃+* polynomial (adjoin R (set.range x)) :=
(mv_polynomial.option_equiv_left _ _).to_ring_equiv.trans
  (polynomial.map_equiv hx.aeval_equiv.to_ring_equiv)

@[simp]
lemma algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin_apply
  (hx : algebraic_independent R x) (y) :
  hx.mv_polynomial_option_equiv_polynomial_adjoin y =
    polynomial.map (hx.aeval_equiv : mv_polynomial ι R →+* adjoin R (range x))
      (aeval (λ (o : option ι), o.elim polynomial.X (λ (s : ι), polynomial.C (X s))) y) :=
rfl

@[simp]
lemma algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin_C
  (hx : algebraic_independent R x) (r) :
  hx.mv_polynomial_option_equiv_polynomial_adjoin (C r) =
    polynomial.C (algebra_map _ _ r) :=
begin
  -- TODO: this instance is slow to infer
  have h : is_scalar_tower R (mv_polynomial ι R) (polynomial (mv_polynomial ι R)) :=
    @polynomial.is_scalar_tower (mv_polynomial ι R) _ R _ _ _ _ _ _ _,
  rw [algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin_apply, aeval_C,
    @is_scalar_tower.algebra_map_apply _ _ _ _ _ _ _ _ _ h, ← polynomial.C_eq_algebra_map,
    polynomial.map_C, ring_hom.coe_coe, alg_equiv.commutes]
end

@[simp]
lemma algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin_X_none
  (hx : algebraic_independent R x) :
  hx.mv_polynomial_option_equiv_polynomial_adjoin (X none) = polynomial.X :=
by rw [algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin_apply, aeval_X,
      option.elim, polynomial.map_X]

@[simp]
lemma algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin_X_some
  (hx : algebraic_independent R x) (i) :
  hx.mv_polynomial_option_equiv_polynomial_adjoin (X (some i)) =
    polynomial.C (hx.aeval_equiv (X i)) :=
by rw [algebraic_independent.mv_polynomial_option_equiv_polynomial_adjoin_apply, aeval_X,
      option.elim, polynomial.map_C, ring_hom.coe_coe]

lemma algebraic_independent.aeval_comp_mv_polynomial_option_equiv_polynomial_adjoin
  (hx : algebraic_independent R x) (a : A) :
  (ring_hom.comp (↑(polynomial.aeval a : polynomial (adjoin R (set.range x)) →ₐ[_] A) :
      polynomial (adjoin R (set.range x)) →+* A)
    hx.mv_polynomial_option_equiv_polynomial_adjoin.to_ring_hom) =
    ↑((mv_polynomial.aeval (λ o : option ι, o.elim a x)) :
      mv_polynomial (option ι) R →ₐ[R] A) :=
begin
  refine mv_polynomial.ring_hom_ext _ _;
    simp only [ring_hom.comp_apply, ring_equiv.to_ring_hom_eq_coe, ring_equiv.coe_to_ring_hom,
        alg_hom.coe_to_ring_hom, alg_hom.coe_to_ring_hom],
  { intro r,
    rw [hx.mv_polynomial_option_equiv_polynomial_adjoin_C,
        aeval_C, polynomial.aeval_C, is_scalar_tower.algebra_map_apply R (adjoin R (range x)) A] },
  { rintro (⟨⟩|⟨i⟩),
    { rw [hx.mv_polynomial_option_equiv_polynomial_adjoin_X_none,
          aeval_X, polynomial.aeval_X, option.elim] },
    { rw [hx.mv_polynomial_option_equiv_polynomial_adjoin_X_some, polynomial.aeval_C,
          hx.algebra_map_aeval_equiv, aeval_X, aeval_X, option.elim] } },
end

theorem algebraic_independent.option_iff (hx : algebraic_independent R x) (a : A) :
  (algebraic_independent R (λ o : option ι, o.elim a x)) ↔
    ¬ is_algebraic (adjoin R (set.range x)) a :=
by erw [algebraic_independent_iff_injective_aeval, is_algebraic_iff_not_injective, not_not,
    ← alg_hom.coe_to_ring_hom,
    ← hx.aeval_comp_mv_polynomial_option_equiv_polynomial_adjoin,
    ring_hom.coe_comp, injective.of_comp_iff' _ (ring_equiv.bijective _), alg_hom.coe_to_ring_hom]

variable (R)
/--
  A family is a transcendence basis if it is a maximal algebraically independent subset.
-/
def is_transcendence_basis (x : ι → A) : Prop :=
algebraic_independent R x ∧
  ∀ (s : set A) (i' : algebraic_independent R (coe : s → A)) (h : range x ≤ s), range x = s

lemma exists_is_transcendence_basis (h : injective (algebra_map R A)) :
  ∃ s : set A, is_transcendence_basis R (coe : s → A) :=
begin
  cases exists_maximal_algebraic_independent (∅ : set A) set.univ
    (set.subset_univ _) ((algebraic_independent_empty_iff R A).2 h) with s hs,
  use [s, hs.1],
  intros t ht hr,
  simp only [subtype.range_coe_subtype, set_of_mem_eq] at *,
  exact eq.symm (hs.2.2.2 t ht hr (set.subset_univ _))
end

variable {R}
lemma algebraic_independent.is_transcendence_basis_iff
  {ι : Type w} {R : Type u} [comm_ring R] [nontrivial R]
  {A : Type v} [comm_ring A] [algebra R A] {x : ι → A} (i : algebraic_independent R x) :
  is_transcendence_basis R x ↔ ∀ (κ : Type v) (w : κ → A) (i' : algebraic_independent R w)
    (j : ι → κ) (h : w ∘ j = x), surjective j :=
begin
  fsplit,
  { rintros p κ w i' j rfl,
    have p := p.2 (range w) i'.coe_range (range_comp_subset_range _ _),
    rw [range_comp, ←@image_univ _ _ w] at p,
    exact range_iff_surjective.mp (image_injective.mpr i'.injective p) },
  { intros p,
    use i,
    intros w i' h,
    specialize p w (coe : w → A) i'
      (λ i, ⟨x i, range_subset_iff.mp h i⟩)
      (by { ext, simp, }),
    have q := congr_arg (λ s, (coe : w → A) '' s) p.range_eq,
    dsimp at q,
    rw [←image_univ, image_image] at q,
    simpa using q, },
end

lemma is_transcendence_basis.is_algebraic [nontrivial R]
  (hx : is_transcendence_basis R x) : is_algebraic (adjoin R (range x)) A :=
begin
  intro a,
  rw [← not_iff_comm.1 (hx.1.option_iff _).symm],
  intro ai,
  have h₁ : range x ⊆ range (λ o : option ι, o.elim a x),
  { rintros x ⟨y, rfl⟩, exact ⟨some y, rfl⟩ },
  have h₂ : range x ≠ range (λ o : option ι, o.elim a x),
  { intro h,
    have : a ∈ range x, { rw h, exact ⟨none, rfl⟩ },
    rcases this with ⟨b, rfl⟩,
    have : some b = none := ai.injective rfl,
    simpa },
  exact h₂ (hx.2 (set.range (λ o : option ι, o.elim a x))
    ((algebraic_independent_subtype_range ai.injective).2 ai) h₁)
end

section field
variables [field K] [algebra K A]

@[simp] lemma algebraic_independent_empty_type [is_empty ι] [nontrivial A] :
  algebraic_independent K x :=
begin
  rw [algebraic_independent_empty_type_iff],
  exact ring_hom.injective _,
end

lemma algebraic_independent_empty [nontrivial A] :
  algebraic_independent K (coe : ((∅ : set A) → A)) :=
algebraic_independent_empty_type

end field


<|start_filename|>src/category_theory/limits/constructions/limits_of_products_and_equalizers.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.finite_products
import category_theory.limits.preserves.shapes.products
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.finite

/-!
# Constructing limits from products and equalizers.

If a category has all products, and all equalizers, then it has all limits.
Similarly, if it has all finite products, and all equalizers, then it has all finite limits.

If a functor preserves all products and equalizers, then it preserves all limits.
Similarly, if it preserves all finite products and equalizers, then it preserves all finite limits.

# TODO

Provide the dual results.
Show the analogous results for functors which reflect or create (co)limits.
-/

open category_theory
open opposite

namespace category_theory.limits

universes v u u₂
variables {C : Type u} [category.{v} C]

variables {J : Type v} [small_category J]

-- We hide the "implementation details" inside a namespace
namespace has_limit_of_has_products_of_has_equalizers

variables {F : J ⥤ C}
          {c₁ : fan F.obj}
          {c₂ : fan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2)}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), s ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.1⟩ ≫ F.map f.2)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), t ≫ c₂.π.app ⟨f⟩ = c₁.π.app ⟨f.1.2⟩)
          (i : fork s t)

include hs ht
/--
(Implementation) Given the appropriate product and equalizer cones, build the cone for `F` which is
limiting if the given cones are also.
-/
@[simps]
def build_limit : cone F :=
{ X := i.X,
  π :=
  { app := λ j, i.ι ≫ c₁.π.app ⟨_⟩,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.id_comp, category.assoc, ← hs ⟨⟨_, _⟩, f⟩, i.condition_assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cone constructed in `build_limit` is limiting, provided the cones used in
its construction are.
-/
def build_is_limit (t₁ : is_limit c₁) (t₂ : is_limit c₂) (hi : is_limit i) :
  is_limit (build_limit s t hs ht i) :=
{ lift := λ q,
  begin
    refine hi.lift (fork.of_ι _ _),
    { refine t₁.lift (fan.mk _ (λ j, _)),
      apply q.π.app j },
    { apply t₂.hom_ext,
      intro j, discrete_cases,
      simp [hs, ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.equalizer_ext (t₁.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_limit_of_has_products_of_has_equalizers

open has_limit_of_has_products_of_has_equalizers

/--
Given the existence of the appropriate (possibly finite) products and equalizers,
we can construct a limit cone for `F`.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
noncomputable
def limit_cone_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : limit_cone F :=
{ cone := _,
  is_limit :=
    build_is_limit
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨_⟩ ≫ F.map f.2))
      (pi.lift (λ f, limit.π (discrete.functor F.obj) ⟨f.1.2⟩))
      (by simp)
      (by simp)
      (limit.is_limit _)
      (limit.is_limit _)
      (limit.is_limit _) }

/--
Given the existence of the appropriate (possibly finite) products and equalizers, we know a limit of
`F` exists.
(This assumes the existence of all equalizers, which is technically stronger than needed.)
-/
lemma has_limit_of_equalizer_and_product (F : J ⥤ C)
  [has_limit (discrete.functor F.obj)]
  [has_limit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.2))]
  [has_equalizers C] : has_limit F :=
has_limit.mk (limit_cone_of_equalizer_and_product F)

/-- A limit can be realised as a subobject of a product. -/
noncomputable
def limit_subobject_product [has_limits C] (F : J ⥤ C) :
  limit F ⟶ ∏ (λ j, F.obj j) :=
(limit.iso_limit_cone (limit_cone_of_equalizer_and_product F)).hom ≫ equalizer.ι _ _

instance limit_subobject_product_mono [has_limits C] (F : J ⥤ C) :
  mono (limit_subobject_product F) :=
mono_comp _ _

/--
Any category with products and equalizers has all limits.

See <https://stacks.math.columbia.edu/tag/002N>.
-/
lemma limits_from_equalizers_and_products
  [has_products C] [has_equalizers C] : has_limits C :=
{ has_limits_of_shape := λ J 𝒥,
  { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F } }

/--
Any category with finite products and equalizers has all finite limits.

See <https://stacks.math.columbia.edu/tag/002O>.
-/
lemma finite_limits_from_equalizers_and_finite_products
  [has_finite_products C] [has_equalizers C] : has_finite_limits C :=
⟨λ J _ _, { has_limit := λ F, by exactI has_limit_of_equalizer_and_product F }⟩

variables {D : Type u₂} [category.{v} D]
noncomputable theory

section

variables [has_limits_of_shape (discrete.{v} J) C]
          [has_limits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_equalizers C]
variables (G : C ⥤ D)
          [preserves_limits_of_shape walking_parallel_pair.{v} G]
          [preserves_limits_of_shape (discrete.{v} J) G]
          [preserves_limits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves equalizers and the appropriate products, it preserves limits. -/
def preserves_limit_of_preserves_equalizers_and_product :
  preserves_limits_of_shape J G :=
{ preserves_limit := λ K,
  begin
    let P := ∏ K.obj,
    let Q := ∏ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.2),
    let s : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨_⟩ ≫ K.map f.2),
    let t : P ⟶ Q := pi.lift (λ f, limit.π (discrete.functor K.obj) ⟨f.1.2⟩),
    let I := equalizer s t,
    let i : I ⟶ P := equalizer.ι s t,
    apply preserves_limit_of_preserves_limit_cone
      (build_is_limit s t (by simp) (by simp)
        (limit.is_limit _)
        (limit.is_limit _)
        (limit.is_limit _)),
    refine is_limit.of_iso_limit (build_is_limit _ _ _ _ _ _ _) _,
    { exact fan.mk _ (λ j, G.map (pi.π _ j)) },
    { exact fan.mk (G.obj Q) (λ f, G.map (pi.π _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, limit.lift_π, fan.mk_π_app] },
    { apply fork.of_ι (G.map i) _,
      simp only [← G.map_comp, equalizer.condition] },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_of_has_product_of_preserves_limit },
    { apply is_limit_fork_map_of_is_limit,
      apply equalizer_is_equalizer },
    refine cones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves equalizers and finite products, it preserves finite limits. -/
def preserves_finite_limits_of_preserves_equalizers_and_finite_products
  [has_equalizers C] [has_finite_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair.{v} G]
  [∀ J [fintype J], preserves_limits_of_shape (discrete.{v} J) G] :
  preserves_finite_limits G :=
⟨λ _ _ _, by exactI preserves_limit_of_preserves_equalizers_and_product G⟩

/-- If G preserves equalizers and products, it preserves all limits. -/
def preserves_limits_of_preserves_equalizers_and_products
  [has_equalizers C] [has_products C]
  (G : C ⥤ D) [preserves_limits_of_shape walking_parallel_pair.{v} G]
  [∀ J, preserves_limits_of_shape (discrete.{v} J) G] :
preserves_limits G :=
{ preserves_limits_of_shape := λ J 𝒥,
  by exactI preserves_limit_of_preserves_equalizers_and_product G }

/-!
We now dualize the above constructions, resorting to copy-paste.
-/

-- We hide the "implementation details" inside a namespace
namespace has_colimit_of_has_coproducts_of_has_coequalizers

variables {F : J ⥤ C}
          {c₁ : cofan (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1)}
          {c₂ : cofan F.obj}
          (s t : c₁.X ⟶ c₂.X)
          (hs : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ s = F.map f.2 ≫ c₂.ι.app ⟨f.1.2⟩)
          (ht : ∀ (f : Σ p : J × J, p.1 ⟶ p.2), c₁.ι.app ⟨f⟩ ≫ t = c₂.ι.app ⟨f.1.1⟩)
          (i : cofork s t)

include hs ht
/--
(Implementation) Given the appropriate coproduct and coequalizer cocones,
build the cocone for `F` which is colimiting if the given cocones are also.
-/
@[simps]
def build_colimit : cocone F :=
{ X := i.X,
  ι :=
  { app := λ j, c₂.ι.app ⟨_⟩ ≫ i.π,
    naturality' := λ j₁ j₂ f, begin
      dsimp,
      rw [category.comp_id, ←reassoc_of (hs ⟨⟨_, _⟩, f⟩), i.condition, ←category.assoc, ht],
    end} }

variable {i}
/--
(Implementation) Show the cocone constructed in `build_colimit` is colimiting,
provided the cocones used in its construction are.
-/
def build_is_colimit (t₁ : is_colimit c₁) (t₂ : is_colimit c₂) (hi : is_colimit i) :
  is_colimit (build_colimit s t hs ht i) :=
{ desc := λ q,
  begin
    refine hi.desc (cofork.of_π _ _),
    { refine t₂.desc (cofan.mk _ (λ j, _)),
      apply q.ι.app j },
    { apply t₁.hom_ext,
      intro j, discrete_cases,
      simp [reassoc_of hs, reassoc_of ht] },
  end,
  uniq' := λ q m w, hi.hom_ext (i.coequalizer_ext (t₂.hom_ext
    (λ j, by { cases j, simpa using w j }))) }

end has_colimit_of_has_coproducts_of_has_coequalizers

open has_colimit_of_has_coproducts_of_has_coequalizers

/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we can construct a colimit cocone for `F`.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
noncomputable
def colimit_cocone_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : colimit_cocone F :=
{ cocone := _,
  is_colimit :=
    build_is_colimit
      (sigma.desc (λ f, F.map f.2 ≫ colimit.ι (discrete.functor F.obj) ⟨f.1.2⟩))
      (sigma.desc (λ f, colimit.ι (discrete.functor F.obj) ⟨f.1.1⟩))
      (by simp)
      (by simp)
      (colimit.is_colimit _)
      (colimit.is_colimit _)
      (colimit.is_colimit _) }


/--
Given the existence of the appropriate (possibly finite) coproducts and coequalizers,
we know a colimit of `F` exists.
(This assumes the existence of all coequalizers, which is technically stronger than needed.)
-/
lemma has_colimit_of_coequalizer_and_coproduct (F : J ⥤ C)
  [has_colimit (discrete.functor F.obj)]
  [has_colimit (discrete.functor (λ f : (Σ p : J × J, p.1 ⟶ p.2), F.obj f.1.1))]
  [has_coequalizers C] : has_colimit F :=
has_colimit.mk (colimit_cocone_of_coequalizer_and_coproduct F)

/-- A colimit can be realised as a quotient of a coproduct. -/
noncomputable
def colimit_quotient_coproduct [has_colimits C] (F : J ⥤ C) :
  ∐ (λ j, F.obj j) ⟶ colimit F :=
coequalizer.π _ _ ≫ (colimit.iso_colimit_cocone (colimit_cocone_of_coequalizer_and_coproduct F)).inv

instance colimit_quotient_coproduct_epi [has_colimits C] (F : J ⥤ C) :
  epi (colimit_quotient_coproduct F) :=
epi_comp _ _

/--
Any category with coproducts and coequalizers has all colimits.

See <https://stacks.math.columbia.edu/tag/002P>.
-/
lemma colimits_from_coequalizers_and_coproducts
  [has_coproducts C] [has_coequalizers C] : has_colimits C :=
{ has_colimits_of_shape := λ J 𝒥,
  { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F } }

/--
Any category with finite coproducts and coequalizers has all finite colimits.

See <https://stacks.math.columbia.edu/tag/002Q>.
-/
lemma finite_colimits_from_coequalizers_and_finite_coproducts
  [has_finite_coproducts C] [has_coequalizers C] : has_finite_colimits C :=
⟨λ J _ _, { has_colimit := λ F, by exactI has_colimit_of_coequalizer_and_coproduct F }⟩

noncomputable theory

section

variables [has_colimits_of_shape (discrete.{v} J) C]
          [has_colimits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) C]
          [has_coequalizers C]
variables (G : C ⥤ D)
          [preserves_colimits_of_shape walking_parallel_pair.{v} G]
          [preserves_colimits_of_shape (discrete.{v} J) G]
          [preserves_colimits_of_shape (discrete.{v} (Σ p : J × J, p.1 ⟶ p.2)) G]

/-- If a functor preserves coequalizers and the appropriate coproducts, it preserves colimits. -/
def preserves_colimit_of_preserves_coequalizers_and_coproduct :
  preserves_colimits_of_shape J G :=
{ preserves_colimit := λ K,
  begin
    let P := ∐ K.obj,
    let Q := ∐ (λ (f : (Σ (p : J × J), p.fst ⟶ p.snd)), K.obj f.1.1),
    let s : Q ⟶ P := sigma.desc (λ f, K.map f.2 ≫ colimit.ι (discrete.functor K.obj) ⟨_⟩),
    let t : Q ⟶ P := sigma.desc (λ f, colimit.ι (discrete.functor K.obj) ⟨f.1.1⟩),
    let I := coequalizer s t,
    let i : P ⟶ I := coequalizer.π s t,
    apply preserves_colimit_of_preserves_colimit_cocone
      (build_is_colimit s t (by simp) (by simp)
        (colimit.is_colimit _)
        (colimit.is_colimit _)
        (colimit.is_colimit _)),
    refine is_colimit.of_iso_colimit (build_is_colimit _ _ _ _ _ _ _) _,
    { exact cofan.mk (G.obj Q) (λ j, G.map (sigma.ι _ j)) },
    { exact cofan.mk _ (λ f, G.map (sigma.ι _ f)) },
    { apply G.map s },
    { apply G.map t },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { intro f,
      dsimp,
      simp only [←G.map_comp, colimit.ι_desc, cofan.mk_ι_app] },
    { apply cofork.of_π (G.map i) _,
      simp only [← G.map_comp, coequalizer.condition] },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_of_has_coproduct_of_preserves_colimit },
    { apply is_colimit_cofork_map_of_is_colimit,
      apply coequalizer_is_coequalizer },
    refine cocones.ext (iso.refl _) _,
    intro j,
    dsimp,
    simp, -- See note [dsimp, simp].
  end }
end

/-- If G preserves coequalizers and finite coproducts, it preserves finite colimits. -/
def preserves_finite_colimits_of_preserves_coequalizers_and_finite_coproducts
  [has_coequalizers C] [has_finite_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair.{v} G]
  [∀ J [fintype J], preserves_colimits_of_shape (discrete.{v} J) G] :
  preserves_finite_colimits G :=
⟨λ _ _ _, by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G⟩

/-- If G preserves coequalizers and coproducts, it preserves all colimits. -/
def preserves_colimits_of_preserves_coequalizers_and_coproducts
  [has_coequalizers C] [has_coproducts C]
  (G : C ⥤ D) [preserves_colimits_of_shape walking_parallel_pair.{v} G]
  [∀ J, preserves_colimits_of_shape (discrete.{v} J) G] :
preserves_colimits G :=
{ preserves_colimits_of_shape := λ J 𝒥,
  by exactI preserves_colimit_of_preserves_coequalizers_and_coproduct G }

end category_theory.limits


<|start_filename|>src/field_theory/finite/polynomial.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import linear_algebra.finite_dimensional
import linear_algebra.basic
import ring_theory.mv_polynomial.basic
import data.mv_polynomial.expand
import field_theory.finite.basic

/-!
## Polynomials over finite fields
-/

namespace mv_polynomial
variables {σ : Type*}

/-- A polynomial over the integers is divisible by `n : ℕ`
if and only if it is zero over `zmod n`. -/
lemma C_dvd_iff_zmod (n : ℕ) (φ : mv_polynomial σ ℤ) :
  C (n:ℤ) ∣ φ ↔ map (int.cast_ring_hom (zmod n)) φ = 0 :=
C_dvd_iff_map_hom_eq_zero _ _ (char_p.int_cast_eq_zero_iff (zmod n) n) _

section frobenius

variables {p : ℕ} [fact p.prime]

lemma frobenius_zmod (f : mv_polynomial σ (zmod p)) : frobenius _ p f = expand p f :=
begin
  apply induction_on f,
  { intro a, rw [expand_C, frobenius_def, ← C_pow, zmod.pow_card], },
  { simp only [alg_hom.map_add, ring_hom.map_add], intros _ _ hf hg, rw [hf, hg] },
  { simp only [expand_X, ring_hom.map_mul, alg_hom.map_mul],
    intros _ _ hf, rw [hf, frobenius_def], },
end

lemma expand_zmod (f : mv_polynomial σ (zmod p)) : expand p f = f ^ p :=
(frobenius_zmod _).symm

end frobenius

end mv_polynomial

namespace mv_polynomial

noncomputable theory
open_locale big_operators classical
open set linear_map submodule

variables {K : Type*} {σ : Type*}

section indicator

variables [fintype K] [fintype σ]

/-- Over a field, this is the indicator function as an `mv_polynomial`. -/
def indicator [comm_ring K] (a : σ → K) : mv_polynomial σ K :=
∏ n, (1 - (X n - C (a n)) ^ (fintype.card K - 1))

section comm_ring

variables [comm_ring K]

lemma eval_indicator_apply_eq_one (a : σ → K) :
  eval a (indicator a) = 1 :=
begin
  nontriviality,
  have : 0 < fintype.card K - 1 := tsub_pos_of_lt fintype.one_lt_card,
  simp only [indicator, map_prod, map_sub, map_one, map_pow, eval_X, eval_C,
             sub_self, zero_pow this, sub_zero, finset.prod_const_one]
end

lemma degrees_indicator (c : σ → K) :
  degrees (indicator c) ≤ ∑ s : σ, (fintype.card K - 1) • {s} :=
begin
  rw [indicator],
  refine le_trans (degrees_prod _ _) (finset.sum_le_sum $ assume s hs, _),
  refine le_trans (degrees_sub _ _) _,
  rw [degrees_one, ← bot_eq_zero, bot_sup_eq],
  refine le_trans (degrees_pow _ _) (nsmul_le_nsmul_of_le_right _ _),
  refine le_trans (degrees_sub _ _) _,
  rw [degrees_C, ← bot_eq_zero, sup_bot_eq],
  exact degrees_X' _
end

lemma indicator_mem_restrict_degree (c : σ → K) :
  indicator c ∈ restrict_degree σ K (fintype.card K - 1) :=
begin
  rw [mem_restrict_degree_iff_sup, indicator],
  assume n,
  refine le_trans (multiset.count_le_of_le _ $ degrees_indicator _) (le_of_eq _),
  simp_rw [ ← multiset.coe_count_add_monoid_hom, (multiset.count_add_monoid_hom n).map_sum,
    add_monoid_hom.map_nsmul, multiset.coe_count_add_monoid_hom, nsmul_eq_mul, nat.cast_id],
  transitivity,
  refine finset.sum_eq_single n _ _,
  { assume b hb ne, rw [multiset.count_singleton, if_neg ne.symm, mul_zero] },
  { assume h, exact (h $ finset.mem_univ _).elim },
  { rw [multiset.count_singleton_self, mul_one] }
end

end comm_ring

variables [field K]

lemma eval_indicator_apply_eq_zero (a b : σ → K) (h : a ≠ b) :
  eval a (indicator b) = 0 :=
begin
  obtain ⟨i, hi⟩ : ∃ i, a i ≠ b i := by rwa [(≠), function.funext_iff, not_forall] at h,
  simp only [indicator, map_prod, map_sub, map_one, map_pow, eval_X, eval_C,
             sub_self, finset.prod_eq_zero_iff],
  refine ⟨i, finset.mem_univ _, _⟩,
  rw [finite_field.pow_card_sub_one_eq_one, sub_self],
  rwa [(≠), sub_eq_zero],
end

end indicator

section
variables (K σ)

/-- `mv_polynomial.eval` as a `K`-linear map. -/
@[simps] def evalₗ [comm_semiring K] : mv_polynomial σ K →ₗ[K] (σ → K) → K :=
{ to_fun := λ p e, eval e p,
  map_add' := λ p q, by { ext x, rw ring_hom.map_add, refl, },
  map_smul' := λ a p, by { ext e, rw [smul_eq_C_mul, ring_hom.map_mul, eval_C], refl } }
end

variables [field K] [fintype K] [fintype σ]

lemma map_restrict_dom_evalₗ : (restrict_degree σ K (fintype.card K - 1)).map (evalₗ K σ) = ⊤ :=
begin
  refine top_unique (set_like.le_def.2 $ assume e _, mem_map.2 _),
  refine ⟨∑ n : σ → K, e n • indicator n, _, _⟩,
  { exact sum_mem (assume c _, smul_mem _ _ (indicator_mem_restrict_degree _)) },
  { ext n,
    simp only [linear_map.map_sum, @finset.sum_apply (σ → K) (λ_, K) _ _ _ _ _,
      pi.smul_apply, linear_map.map_smul],
    simp only [evalₗ_apply],
    transitivity,
    refine finset.sum_eq_single n (λ b _ h, _) _,
    { rw [eval_indicator_apply_eq_zero _ _ h.symm, smul_zero] },
    { exact λ h, (h $ finset.mem_univ n).elim },
    { rw [eval_indicator_apply_eq_one, smul_eq_mul, mul_one] } }
end

end mv_polynomial

namespace mv_polynomial

open_locale classical cardinal
open linear_map submodule

universe u
variables (σ : Type u) (K : Type u) [fintype K]

/-- The submodule of multivariate polynomials whose degree of each variable is strictly less
than the cardinality of K. -/
@[derive [add_comm_group, module K, inhabited]]
def R [comm_ring K] : Type u := restrict_degree σ K (fintype.card K - 1)

/-- Evaluation in the `mv_polynomial.R` subtype. -/
def evalᵢ [comm_ring K] : R σ K →ₗ[K] (σ → K) → K :=
((evalₗ K σ).comp (restrict_degree σ K (fintype.card K - 1)).subtype)

section comm_ring

variables [comm_ring K]

noncomputable instance decidable_restrict_degree (m : ℕ) :
  decidable_pred (∈ {n : σ →₀ ℕ | ∀i, n i ≤ m }) :=
by simp only [set.mem_set_of_eq]; apply_instance

end comm_ring

variables [field K]

lemma dim_R [fintype σ] : module.rank K (R σ K) = fintype.card (σ → K) :=
calc module.rank K (R σ K) =
  module.rank K (↥{s : σ →₀ ℕ | ∀ (n : σ), s n ≤ fintype.card K - 1} →₀ K) :
    linear_equiv.dim_eq
      (finsupp.supported_equiv_finsupp {s : σ →₀ ℕ | ∀n:σ, s n ≤ fintype.card K - 1 })
  ... = #{s : σ →₀ ℕ | ∀ (n : σ), s n ≤ fintype.card K - 1} :
    by rw [finsupp.dim_eq, dim_self, mul_one]
  ... = #{s : σ → ℕ | ∀ (n : σ), s n < fintype.card K } :
  begin
    refine quotient.sound ⟨equiv.subtype_equiv finsupp.equiv_fun_on_fintype $ assume f, _⟩,
    refine forall_congr (assume n, le_tsub_iff_right _),
    exact fintype.card_pos_iff.2 ⟨0⟩
  end
  ... = #(σ → {n // n < fintype.card K}) :
    (@equiv.subtype_pi_equiv_pi σ (λ_, ℕ) (λs n, n < fintype.card K)).cardinal_eq
  ... = #(σ → fin (fintype.card K)) :
    (equiv.arrow_congr (equiv.refl σ) (equiv.refl _)).cardinal_eq
  ... = #(σ → K) :
    (equiv.arrow_congr (equiv.refl σ) (fintype.equiv_fin K).symm).cardinal_eq
  ... = fintype.card (σ → K) : cardinal.mk_fintype _

instance [fintype σ] : finite_dimensional K (R σ K) :=
is_noetherian.iff_fg.1 $ is_noetherian.iff_dim_lt_aleph_0.mpr
  (by simpa only [dim_R] using cardinal.nat_lt_aleph_0 (fintype.card (σ → K)))

lemma finrank_R [fintype σ] : finite_dimensional.finrank K (R σ K) = fintype.card (σ → K) :=
finite_dimensional.finrank_eq_of_dim_eq (dim_R σ K)

lemma range_evalᵢ [fintype σ] : (evalᵢ σ K).range = ⊤ :=
begin
  rw [evalᵢ, linear_map.range_comp, range_subtype],
  exact map_restrict_dom_evalₗ
end

lemma ker_evalₗ [fintype σ] : (evalᵢ σ K).ker = ⊥ :=
begin
  refine (ker_eq_bot_iff_range_eq_top_of_finrank_eq_finrank _).mpr (range_evalᵢ _ _),
  rw [finite_dimensional.finrank_fintype_fun_eq_card, finrank_R]
end

lemma eq_zero_of_eval_eq_zero  [fintype σ] (p : mv_polynomial σ K)
  (h : ∀v:σ → K, eval v p = 0) (hp : p ∈ restrict_degree σ K (fintype.card K - 1)) :
  p = 0 :=
let p' : R σ K := ⟨p, hp⟩ in
have p' ∈ (evalᵢ σ K).ker := funext h,
show p'.1 = (0 : R σ K).1, from congr_arg _ $ by rwa [ker_evalₗ, mem_bot] at this

end mv_polynomial


<|start_filename|>src/data/complex/cardinality.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

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

/-!
# The cardinality of the complex numbers

This file shows that the complex numbers have cardinality continuum, i.e. `#ℂ = 𝔠`.
-/

open cardinal set

open_locale cardinal

/-- The cardinality of the complex numbers, as a type. -/
@[simp] theorem mk_complex : #ℂ = 𝔠 :=
by rw [mk_congr complex.equiv_real_prod, mk_prod, lift_id, mk_real, continuum_mul_self]

/-- The cardinality of the complex numbers, as a set. -/
@[simp] lemma mk_univ_complex : #(set.univ : set ℂ) = 𝔠 :=
by rw [mk_univ, mk_complex]

/-- The complex numbers are not countable. -/
lemma not_countable_complex : ¬ countable (set.univ : set ℂ) :=
by { rw [← mk_set_le_aleph_0, not_le, mk_univ_complex], apply cantor }


<|start_filename|>src/algebra/squarefree.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import ring_theory.unique_factorization_domain

/-!
# Squarefree elements of monoids
An element of a monoid is squarefree when it is not divisible by any squares
except the squares of units.

Results about squarefree natural numbers are proved in `data/nat/squarefree`.

## Main Definitions
 - `squarefree r` indicates that `r` is only divisible by `x * x` if `x` is a unit.

## Main Results
 - `multiplicity.squarefree_iff_multiplicity_le_one`: `x` is `squarefree` iff for every `y`, either
  `multiplicity y x ≤ 1` or `is_unit y`.
 - `unique_factorization_monoid.squarefree_iff_nodup_factors`: A nonzero element `x` of a unique
 factorization monoid is squarefree iff `factors x` has no duplicate factors.

## Tags
squarefree, multiplicity

-/

variables {R : Type*}

/-- An element of a monoid is squarefree if the only squares that
  divide it are the squares of units. -/
def squarefree [monoid R] (r : R) : Prop := ∀ x : R, x * x ∣ r → is_unit x

@[simp]
lemma is_unit.squarefree [comm_monoid R] {x : R} (h : is_unit x) :
  squarefree x :=
λ y hdvd, is_unit_of_mul_is_unit_left (is_unit_of_dvd_unit hdvd h)

@[simp]
lemma squarefree_one [comm_monoid R] : squarefree (1 : R) :=
is_unit_one.squarefree

@[simp]
lemma not_squarefree_zero [monoid_with_zero R] [nontrivial R] : ¬ squarefree (0 : R) :=
begin
  erw [not_forall],
  exact ⟨0, by simp⟩,
end

lemma squarefree.ne_zero [monoid_with_zero R] [nontrivial R] {m : R}
  (hm : squarefree (m : R)) : m ≠ 0 :=
begin
  rintro rfl,
  exact not_squarefree_zero hm,
end

@[simp]
lemma irreducible.squarefree [comm_monoid R] {x : R} (h : irreducible x) :
  squarefree x :=
begin
  rintros y ⟨z, hz⟩,
  rw mul_assoc at hz,
  rcases h.is_unit_or_is_unit hz with hu | hu,
  { exact hu },
  { apply is_unit_of_mul_is_unit_left hu },
end

@[simp]
lemma prime.squarefree [cancel_comm_monoid_with_zero R] {x : R} (h : prime x) :
  squarefree x :=
h.irreducible.squarefree

lemma squarefree.of_mul_left [comm_monoid R] {m n : R} (hmn : squarefree (m * n)) : squarefree m :=
(λ p hp, hmn p (dvd_mul_of_dvd_left hp n))

lemma squarefree.of_mul_right [comm_monoid R] {m n : R} (hmn : squarefree (m * n)) : squarefree n :=
(λ p hp, hmn p (dvd_mul_of_dvd_right hp m))

lemma squarefree_of_dvd_of_squarefree [comm_monoid R]
  {x y : R} (hdvd : x ∣ y) (hsq : squarefree y) :
  squarefree x :=
λ a h, hsq _ (h.trans hdvd)

namespace multiplicity

section comm_monoid

variables [comm_monoid R] [decidable_rel (has_dvd.dvd : R → R → Prop)]

lemma squarefree_iff_multiplicity_le_one (r : R) :
  squarefree r ↔ ∀ x : R, multiplicity x r ≤ 1 ∨ is_unit x :=
begin
  refine forall_congr (λ a, _),
  rw [← sq, pow_dvd_iff_le_multiplicity, or_iff_not_imp_left, not_le, imp_congr],
  swap, { refl },
  convert enat.add_one_le_iff_lt (enat.coe_ne_top 1),
  norm_cast,
end

end comm_monoid

section cancel_comm_monoid_with_zero

variables [cancel_comm_monoid_with_zero R] [wf_dvd_monoid R]

lemma finite_prime_left {a b : R} (ha : prime a) (hb : b ≠ 0) :
  multiplicity.finite a b :=
begin
  classical,
  revert hb,
  refine wf_dvd_monoid.induction_on_irreducible b (by contradiction) (λ u hu hu', _)
    (λ b p hb hp ih hpb, _),
  { rw [multiplicity.finite_iff_dom, multiplicity.is_unit_right ha.not_unit hu],
    exact enat.dom_coe 0, },
  { refine multiplicity.finite_mul ha
      (multiplicity.finite_iff_dom.mpr (enat.dom_of_le_coe (show multiplicity a p ≤ ↑1, from _)))
      (ih hb),
    norm_cast,
    exact (((multiplicity.squarefree_iff_multiplicity_le_one p).mp hp.squarefree a)
      .resolve_right ha.not_unit) }
end

end cancel_comm_monoid_with_zero

end multiplicity

section irreducible
variables [comm_monoid_with_zero R] [wf_dvd_monoid R]

lemma irreducible_sq_not_dvd_iff_eq_zero_and_no_irreducibles_or_squarefree (r : R) :
  (∀ x : R, irreducible x → ¬ x * x ∣ r) ↔ ((r = 0 ∧ ∀ x : R, ¬irreducible x) ∨ squarefree r) :=
begin
  symmetry,
  split,
  { rintro (⟨rfl, h⟩ | h),
    { simpa using h },
    intros x hx t,
    exact hx.not_unit (h x t) },
  intro h,
  rcases eq_or_ne r 0 with rfl | hr,
  { exact or.inl (by simpa using h) },
  right,
  intros x hx,
  by_contra i,
  have : x ≠ 0,
  { rintro rfl,
    apply hr,
    simpa only [zero_dvd_iff, mul_zero] using hx},
  obtain ⟨j, hj₁, hj₂⟩ := wf_dvd_monoid.exists_irreducible_factor i this,
  exact h _ hj₁ ((mul_dvd_mul hj₂ hj₂).trans hx),
end

lemma squarefree_iff_irreducible_sq_not_dvd_of_ne_zero {r : R} (hr : r ≠ 0) :
  squarefree r ↔ ∀ x : R, irreducible x → ¬ x * x ∣ r :=
by simpa [hr] using (irreducible_sq_not_dvd_iff_eq_zero_and_no_irreducibles_or_squarefree r).symm

lemma squarefree_iff_irreducible_sq_not_dvd_of_exists_irreducible
  {r : R} (hr : ∃ (x : R), irreducible x) :
  squarefree r ↔ ∀ x : R, irreducible x → ¬ x * x ∣ r :=
begin
  rw [irreducible_sq_not_dvd_iff_eq_zero_and_no_irreducibles_or_squarefree, ←not_exists],
  simp only [hr, not_true, false_or, and_false],
end

end irreducible

namespace unique_factorization_monoid
variables [cancel_comm_monoid_with_zero R] [nontrivial R] [unique_factorization_monoid R]
variables [normalization_monoid R]

lemma squarefree_iff_nodup_normalized_factors [decidable_eq R] {x : R} (x0 : x ≠ 0) :
  squarefree x ↔ multiset.nodup (normalized_factors x) :=
begin
  have drel : decidable_rel (has_dvd.dvd : R → R → Prop),
  { classical,
    apply_instance, },
  haveI := drel,
  rw [multiplicity.squarefree_iff_multiplicity_le_one, multiset.nodup_iff_count_le_one],
  split; intros h a,
  { by_cases hmem : a ∈ normalized_factors x,
    { have ha := irreducible_of_normalized_factor _ hmem,
      rcases h a with h | h,
      { rw ← normalize_normalized_factor _ hmem,
        rw [multiplicity_eq_count_normalized_factors ha x0] at h,
        assumption_mod_cast },
      { have := ha.1, contradiction, } },
    { simp [multiset.count_eq_zero_of_not_mem hmem] } },
  { rw or_iff_not_imp_right, intro hu,
    by_cases h0 : a = 0,
    { simp [h0, x0] },
    rcases wf_dvd_monoid.exists_irreducible_factor hu h0 with ⟨b, hib, hdvd⟩,
    apply le_trans (multiplicity.multiplicity_le_multiplicity_of_dvd_left hdvd),
    rw [multiplicity_eq_count_normalized_factors hib x0],
    specialize h (normalize b),
    assumption_mod_cast }
end

lemma dvd_pow_iff_dvd_of_squarefree {x y : R} {n : ℕ} (hsq : squarefree x) (h0 : n ≠ 0) :
  x ∣ y ^ n ↔ x ∣ y :=
begin
  classical,
  by_cases hx : x = 0,
  { simp [hx, pow_eq_zero_iff (nat.pos_of_ne_zero h0)] },
  by_cases hy : y = 0,
  { simp [hy, zero_pow (nat.pos_of_ne_zero h0)] },
  refine ⟨λ h, _, λ h, h.pow h0⟩,
  rw [dvd_iff_normalized_factors_le_normalized_factors hx (pow_ne_zero n hy),
    normalized_factors_pow,
    ((squarefree_iff_nodup_normalized_factors hx).1 hsq).le_nsmul_iff_le h0] at h,
  rwa dvd_iff_normalized_factors_le_normalized_factors hx hy,
end

end unique_factorization_monoid


<|start_filename|>src/measure_theory/function/simple_func_dense.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import measure_theory.integral.mean_inequalities
import topology.continuous_function.compact
import topology.metric_space.metrizable

/-!
# Density of simple functions

Show that each Borel measurable function can be approximated pointwise
by a sequence of simple functions.

## Main definitions

* `measure_theory.simple_func.nearest_pt (e : ℕ → α) (N : ℕ) : α →ₛ ℕ`: the `simple_func` sending
  each `x : α` to the point `e k` which is the nearest to `x` among `e 0`, ..., `e N`.
* `measure_theory.simple_func.approx_on (f : β → α) (hf : measurable f) (s : set α) (y₀ : α)
  (h₀ : y₀ ∈ s) [separable_space s] (n : ℕ) : β →ₛ α` : a simple function that takes values in `s`
  and approximates `f`.

## Main results

* `tendsto_approx_on` (pointwise convergence): If `f x ∈ s`, then the sequence of simple
  approximations `measure_theory.simple_func.approx_on f hf s y₀ h₀ n`, evaluated at `x`,
  tends to `f x` as `n` tends to `∞`.

## Notations

* `α →ₛ β` (local notation): the type of simple functions `α → β`.
-/

open set function filter topological_space ennreal emetric finset
open_locale classical topological_space ennreal measure_theory big_operators
variables {α β ι E F 𝕜 : Type*}

noncomputable theory

namespace measure_theory

local infixr ` →ₛ `:25 := simple_func

namespace simple_func

/-! ### Pointwise approximation by simple functions -/

variables [measurable_space α] [pseudo_emetric_space α] [opens_measurable_space α]

/-- `nearest_pt_ind e N x` is the index `k` such that `e k` is the nearest point to `x` among the
points `e 0`, ..., `e N`. If more than one point are at the same distance from `x`, then
`nearest_pt_ind e N x` returns the least of their indexes. -/
noncomputable def nearest_pt_ind (e : ℕ → α) : ℕ → α →ₛ ℕ
| 0 := const α 0
| (N + 1) := piecewise (⋂ k ≤ N, {x | edist (e (N + 1)) x < edist (e k) x})
    (measurable_set.Inter $ λ k, measurable_set.Inter_Prop $ λ hk,
      measurable_set_lt measurable_edist_right measurable_edist_right)
    (const α $ N + 1) (nearest_pt_ind N)

/-- `nearest_pt e N x` is the nearest point to `x` among the points `e 0`, ..., `e N`. If more than
one point are at the same distance from `x`, then `nearest_pt e N x` returns the point with the
least possible index. -/
noncomputable def nearest_pt (e : ℕ → α) (N : ℕ) : α →ₛ α :=
(nearest_pt_ind e N).map e

@[simp] lemma nearest_pt_ind_zero (e : ℕ → α) : nearest_pt_ind e 0 = const α 0 := rfl

@[simp] lemma nearest_pt_zero (e : ℕ → α) : nearest_pt e 0 = const α (e 0) := rfl

lemma nearest_pt_ind_succ (e : ℕ → α) (N : ℕ) (x : α) :
  nearest_pt_ind e (N + 1) x =
    if ∀ k ≤ N, edist (e (N + 1)) x < edist (e k) x
    then N + 1 else nearest_pt_ind e N x :=
by { simp only [nearest_pt_ind, coe_piecewise, set.piecewise], congr, simp }

lemma nearest_pt_ind_le (e : ℕ → α) (N : ℕ) (x : α) : nearest_pt_ind e N x ≤ N :=
begin
  induction N with N ihN, { simp },
  simp only [nearest_pt_ind_succ],
  split_ifs,
  exacts [le_rfl, ihN.trans N.le_succ]
end

lemma edist_nearest_pt_le (e : ℕ → α) (x : α) {k N : ℕ} (hk : k ≤ N) :
  edist (nearest_pt e N x) x ≤ edist (e k) x :=
begin
  induction N with N ihN generalizing k,
  { simp [nonpos_iff_eq_zero.1 hk, le_refl] },
  { simp only [nearest_pt, nearest_pt_ind_succ, map_apply],
    split_ifs,
    { rcases hk.eq_or_lt with rfl|hk,
      exacts [le_rfl, (h k (nat.lt_succ_iff.1 hk)).le] },
    { push_neg at h,
      rcases h with ⟨l, hlN, hxl⟩,
      rcases hk.eq_or_lt with rfl|hk,
      exacts [(ihN hlN).trans hxl, ihN (nat.lt_succ_iff.1 hk)] } }
end

lemma tendsto_nearest_pt {e : ℕ → α} {x : α} (hx : x ∈ closure (range e)) :
  tendsto (λ N, nearest_pt e N x) at_top (𝓝 x) :=
begin
  refine (at_top_basis.tendsto_iff nhds_basis_eball).2 (λ ε hε, _),
  rcases emetric.mem_closure_iff.1 hx ε hε with ⟨_, ⟨N, rfl⟩, hN⟩,
  rw [edist_comm] at hN,
  exact ⟨N, trivial, λ n hn, (edist_nearest_pt_le e x hn).trans_lt hN⟩
end

variables [measurable_space β] {f : β → α}

/-- Approximate a measurable function by a sequence of simple functions `F n` such that
`F n x ∈ s`. -/
noncomputable def approx_on (f : β → α) (hf : measurable f) (s : set α) (y₀ : α) (h₀ : y₀ ∈ s)
  [separable_space s] (n : ℕ) :
  β →ₛ α :=
by haveI : nonempty s := ⟨⟨y₀, h₀⟩⟩;
  exact comp (nearest_pt (λ k, nat.cases_on k y₀ (coe ∘ dense_seq s) : ℕ → α) n) f hf

@[simp] lemma approx_on_zero {f : β → α} (hf : measurable f) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s)
  [separable_space s] (x : β) :
  approx_on f hf s y₀ h₀ 0 x = y₀ :=
rfl

lemma approx_on_mem {f : β → α} (hf : measurable f) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s)
  [separable_space s] (n : ℕ) (x : β) :
  approx_on f hf s y₀ h₀ n x ∈ s :=
begin
  haveI : nonempty s := ⟨⟨y₀, h₀⟩⟩,
  suffices : ∀ n, (nat.cases_on n y₀ (coe ∘ dense_seq s) : α) ∈ s, { apply this },
  rintro (_|n),
  exacts [h₀, subtype.mem _]
end

@[simp] lemma approx_on_comp {γ : Type*} [measurable_space γ] {f : β → α} (hf : measurable f)
  {g : γ → β} (hg : measurable g) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s) [separable_space s] (n : ℕ) :
  approx_on (f ∘ g) (hf.comp hg) s y₀ h₀ n = (approx_on f hf s y₀ h₀ n).comp g hg :=
rfl

lemma tendsto_approx_on {f : β → α} (hf : measurable f) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s)
  [separable_space s] {x : β} (hx : f x ∈ closure s) :
  tendsto (λ n, approx_on f hf s y₀ h₀ n x) at_top (𝓝 $ f x) :=
begin
  haveI : nonempty s := ⟨⟨y₀, h₀⟩⟩,
  rw [← @subtype.range_coe _ s, ← image_univ, ← (dense_range_dense_seq s).closure_eq] at hx,
  simp only [approx_on, coe_comp],
  refine tendsto_nearest_pt (closure_minimal _ is_closed_closure hx),
  simp only [nat.range_cases_on, closure_union, range_comp coe],
  exact subset.trans (image_closure_subset_closure_image continuous_subtype_coe)
    (subset_union_right _ _)
end

lemma edist_approx_on_mono {f : β → α} (hf : measurable f) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s)
  [separable_space s] (x : β) {m n : ℕ} (h : m ≤ n) :
  edist (approx_on f hf s y₀ h₀ n x) (f x) ≤ edist (approx_on f hf s y₀ h₀ m x) (f x) :=
begin
  dsimp only [approx_on, coe_comp, (∘)],
  exact edist_nearest_pt_le _ _ ((nearest_pt_ind_le _ _ _).trans h)
end

lemma edist_approx_on_le {f : β → α} (hf : measurable f) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s)
  [separable_space s] (x : β) (n : ℕ) :
  edist (approx_on f hf s y₀ h₀ n x) (f x) ≤ edist y₀ (f x) :=
edist_approx_on_mono hf h₀ x (zero_le n)

lemma edist_approx_on_y0_le {f : β → α} (hf : measurable f) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s)
  [separable_space s] (x : β) (n : ℕ) :
  edist y₀ (approx_on f hf s y₀ h₀ n x) ≤ edist y₀ (f x) + edist y₀ (f x) :=
calc edist y₀ (approx_on f hf s y₀ h₀ n x) ≤
  edist y₀ (f x) + edist (approx_on f hf s y₀ h₀ n x) (f x) : edist_triangle_right _ _ _
... ≤ edist y₀ (f x) + edist y₀ (f x) : add_le_add_left (edist_approx_on_le hf h₀ x n) _

end simple_func

end measure_theory


<|start_filename|>src/linear_algebra/matrix/charpoly/minpoly.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>, <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import linear_algebra.matrix.charpoly.coeff
import linear_algebra.matrix.to_lin
import ring_theory.power_basis

/-!
# The minimal polynomial divides the characteristic polynomial of a matrix.
-/

noncomputable theory

universes u v

open polynomial matrix

variables {R : Type u} [comm_ring R]
variables {n : Type v} [decidable_eq n] [fintype n]

open finset

variable {M : matrix n n R}

namespace matrix

theorem is_integral : is_integral R M := ⟨M.charpoly, ⟨charpoly_monic M, aeval_self_charpoly M⟩⟩

theorem minpoly_dvd_charpoly {K : Type*} [field K] (M : matrix n n K) :
  (minpoly K M) ∣ M.charpoly :=
minpoly.dvd _ _ (aeval_self_charpoly M)

end matrix

section power_basis

open algebra

/-- The characteristic polynomial of the map `λ x, a * x` is the minimal polynomial of `a`.

In combination with `det_eq_sign_charpoly_coeff` or `trace_eq_neg_charpoly_coeff`
and a bit of rewriting, this will allow us to conclude the
field norm resp. trace of `x` is the product resp. sum of `x`'s conjugates.
-/
lemma charpoly_left_mul_matrix {K S : Type*} [field K] [comm_ring S] [algebra K S]
  (h : power_basis K S) :
  (left_mul_matrix h.basis h.gen).charpoly = minpoly K h.gen :=
begin
  apply minpoly.unique,
  { apply matrix.charpoly_monic },
  { apply (injective_iff_map_eq_zero (left_mul_matrix _)).mp (left_mul_matrix_injective h.basis),
    rw [← polynomial.aeval_alg_hom_apply, aeval_self_charpoly] },
  { intros q q_monic root_q,
    rw [matrix.charpoly_degree_eq_dim, fintype.card_fin, degree_eq_nat_degree q_monic.ne_zero],
    apply with_bot.some_le_some.mpr,
    exact h.dim_le_nat_degree_of_root q_monic.ne_zero root_q }
end

end power_basis


<|start_filename|>src/data/set/pointwise.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.module.basic
import data.set.finite
import group_theory.submonoid.basic

/-!
# Pointwise operations of sets

This file defines pointwise algebraic operations on sets.

## Main declarations

For sets `s` and `t` and scalar `a`:
* `s * t`: Multiplication, set of all `x * y` where `x ∈ s` and `y ∈ t`.
* `s + t`: Addition, set of all `x + y` where `x ∈ s` and `y ∈ t`.
* `s⁻¹`: Inversion, set of all `x⁻¹` where `x ∈ s`.
* `-s`: Negation, set of all `-x` where `x ∈ s`.
* `s / t`: Division, set of all `x / y` where `x ∈ s` and `y ∈ t`.
* `s - t`: Subtraction, set of all `x - y` where `x ∈ s` and `y ∈ t`.
* `s • t`: Scalar multiplication, set of all `x • y` where `x ∈ s` and `y ∈ t`.
* `s +ᵥ t`: Scalar addition, set of all `x +ᵥ y` where `x ∈ s` and `y ∈ t`.
* `s -ᵥ t`: Scalar subtraction, set of all `x -ᵥ y` where `x ∈ s` and `y ∈ t`.
* `a • s`: Scaling, set of all `a • x` where `x ∈ s`.
* `a +ᵥ s`: Translation, set of all `a +ᵥ x` where `x ∈ s`.

For `α` a semigroup/monoid, `set α` is a semigroup/monoid.
As an unfortunate side effect, this means that `n • s`, where `n : ℕ`, is ambiguous between
pointwise scaling and repeated pointwise addition; the former has `(2 : ℕ) • {1, 2} = {2, 4}`, while
the latter has `(2 : ℕ) • {1, 2} = {2, 3, 4}`. See note [pointwise nat action].

Appropriate definitions and results are also transported to the additive theory via `to_additive`.

## Implementation notes

* The following expressions are considered in simp-normal form in a group:
  `(λ h, h * g) ⁻¹' s`, `(λ h, g * h) ⁻¹' s`, `(λ h, h * g⁻¹) ⁻¹' s`, `(λ h, g⁻¹ * h) ⁻¹' s`,
  `s * t`, `s⁻¹`, `(1 : set _)` (and similarly for additive variants).
  Expressions equal to one of these will be simplified.
* We put all instances in the locale `pointwise`, so that these instances are not available by
  default. Note that we do not mark them as reducible (as argued by note [reducible non-instances])
  since we expect the locale to be open whenever the instances are actually used (and making the
  instances reducible changes the behavior of `simp`.

## Tags

set multiplication, set addition, pointwise addition, pointwise multiplication,
pointwise subtraction
-/

/--
Pointwise monoids (`set`, `finset`, `filter`) have derived pointwise actions of the form
`has_scalar α β → has_scalar α (set β)`. When `α` is `ℕ` or `ℤ`, this action conflicts with the
nat or int action coming from `set β` being a `monoid` or `div_inv_monoid`. For example,
`2 • {a, b}` can both be `{2 • a, 2 • b}` (pointwise action, pointwise repeated addition,
`set.has_scalar_set`) and `{a + a, a + b, b + a, b + b}` (nat or int action, repeated pointwise
addition, `set.has_nsmul`).

Because the pointwise action can easily be spelled out in such cases, we give higher priority to the
nat and int actions.
-/
library_note "pointwise nat action"

open function

variables {F α β γ : Type*}

namespace set

/-! ### `0`/`1` as sets -/

section one
variables [has_one α] {s : set α} {a : α}

/-- The set `1 : set α` is defined as `{1}` in locale `pointwise`. -/
@[to_additive "The set `0 : set α` is defined as `{0}` in locale `pointwise`."]
protected def has_one : has_one (set α) := ⟨{1}⟩

localized "attribute [instance] set.has_one set.has_zero" in pointwise

@[to_additive] lemma singleton_one : ({1} : set α) = 1 := rfl
@[simp, to_additive] lemma mem_one : a ∈ (1 : set α) ↔ a = 1 := iff.rfl
@[to_additive] lemma one_mem_one : (1 : α) ∈ (1 : set α) := eq.refl _
@[simp, to_additive] lemma one_subset : 1 ⊆ s ↔ (1 : α) ∈ s := singleton_subset_iff
@[to_additive] lemma one_nonempty : (1 : set α).nonempty := ⟨1, rfl⟩
@[simp, to_additive] lemma image_one {f : α → β} : f '' 1 = {f 1} := image_singleton
@[to_additive] lemma subset_one_iff_eq : s ⊆ 1 ↔ s = ∅ ∨ s = 1 := subset_singleton_iff_eq
@[to_additive] lemma nonempty.subset_one_iff (h : s.nonempty) : s ⊆ 1 ↔ s = 1 :=
h.subset_singleton_iff

/-- The singleton operation as a `one_hom`. -/
@[to_additive "The singleton operation as a `zero_hom`."]
def singleton_one_hom : one_hom α (set α) := ⟨singleton, singleton_one⟩

@[simp, to_additive] lemma coe_singleton_one_hom : (singleton_one_hom : α → set α) = singleton :=
rfl

end one

/-! ### Set negation/inversion -/

section inv

/-- The pointwise inversion of set `s⁻¹` is defined as `{x | x⁻¹ ∈ s}` in locale `pointwise`. It i
equal to `{x⁻¹ | x ∈ s}`, see `set.image_inv`. -/
@[to_additive "The pointwise negation of set `-s` is defined as `{x | -x ∈ s}` in locale
`pointwise`. It is equal to `{-x | x ∈ s}`, see `set.image_neg`."]
protected def has_inv [has_inv α] : has_inv (set α) := ⟨preimage has_inv.inv⟩

localized "attribute [instance] set.has_inv set.has_neg" in pointwise

section has_inv
variables {ι : Sort*} [has_inv α] {s t : set α} {a : α}

@[simp, to_additive] lemma mem_inv : a ∈ s⁻¹ ↔ a⁻¹ ∈ s := iff.rfl
@[simp, to_additive] lemma inv_preimage : has_inv.inv ⁻¹' s = s⁻¹ := rfl
@[simp, to_additive] lemma inv_empty : (∅ : set α)⁻¹ = ∅ := rfl
@[simp, to_additive] lemma inv_univ : (univ : set α)⁻¹ = univ := rfl
@[simp, to_additive] lemma inter_inv : (s ∩ t)⁻¹ = s⁻¹ ∩ t⁻¹ := preimage_inter
@[simp, to_additive] lemma union_inv : (s ∪ t)⁻¹ = s⁻¹ ∪ t⁻¹ := preimage_union
@[simp, to_additive] lemma Inter_inv (s : ι → set α) : (⋂ i, s i)⁻¹ = ⋂ i, (s i)⁻¹ := preimage_Inter
@[simp, to_additive] lemma Union_inv (s : ι → set α) : (⋃ i, s i)⁻¹ = ⋃ i, (s i)⁻¹ := preimage_Union
@[simp, to_additive] lemma compl_inv : (sᶜ)⁻¹ = (s⁻¹)ᶜ := preimage_compl

end has_inv

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

@[to_additive] lemma inv_mem_inv : a⁻¹ ∈ s⁻¹ ↔ a ∈ s := by simp only [mem_inv, inv_inv]

@[simp, to_additive] lemma nonempty_inv : s⁻¹.nonempty ↔ s.nonempty :=
inv_involutive.surjective.nonempty_preimage

@[to_additive] lemma nonempty.inv (h : s.nonempty) : s⁻¹.nonempty := nonempty_inv.2 h

@[to_additive] lemma finite.inv (hs : s.finite) : s⁻¹.finite :=
hs.preimage $ inv_injective.inj_on _

@[simp, to_additive]
lemma image_inv : has_inv.inv '' s = s⁻¹ :=
congr_fun (image_eq_preimage_of_inverse inv_involutive.left_inverse inv_involutive.right_inverse) _

@[simp, to_additive]
instance : has_involutive_inv (set α) :=
{ inv := has_inv.inv,
  inv_inv := λ s, by { simp only [← inv_preimage, preimage_preimage, inv_inv, preimage_id'] } }

@[simp, to_additive]
lemma inv_subset_inv : s⁻¹ ⊆ t⁻¹ ↔ s ⊆ t :=
(equiv.inv α).surjective.preimage_subset_preimage_iff

@[to_additive] lemma inv_subset : s⁻¹ ⊆ t ↔ s ⊆ t⁻¹ := by { rw [← inv_subset_inv, inv_inv] }

@[simp, to_additive] lemma inv_singleton (a : α) : ({a} : set α)⁻¹ = {a⁻¹} :=
by rw [←image_inv, image_singleton]

@[to_additive] lemma inv_range {ι : Sort*} {f : ι → α} : (range f)⁻¹ = range (λ i, (f i)⁻¹) :=
by { rw ←image_inv, exact (range_comp _ _).symm }

open mul_opposite

@[to_additive]
lemma image_op_inv : op '' s⁻¹ = (op '' s)⁻¹ := by simp_rw [←image_inv, image_comm op_inv]

end has_involutive_inv
end inv

open_locale pointwise

/-! ### Set addition/multiplication -/

section has_mul
variables {ι : Sort*} {κ : ι → Sort*} [has_mul α] {s s₁ s₂ t t₁ t₂ u : set α} {a b : α}

/-- The pointwise multiplication of sets `s * t` and `t` is defined as `{x * y | x ∈ s, y ∈ t}` in
locale `pointwise`. -/
@[to_additive "The pointwise addition of sets `s + t` is defined as `{x + y | x ∈ s, y ∈ t}` in
locale `pointwise`."]
protected def has_mul : has_mul (set α) := ⟨image2 (*)⟩

localized "attribute [instance] set.has_mul set.has_add" in pointwise

@[simp, to_additive]
lemma image2_mul : image2 has_mul.mul s t = s * t := rfl

@[to_additive]
lemma mem_mul : a ∈ s * t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x * y = a := iff.rfl

@[to_additive] lemma mul_mem_mul : a ∈ s → b ∈ t → a * b ∈ s * t := mem_image2_of_mem

@[to_additive add_image_prod]
lemma image_mul_prod : (λ x : α × α, x.fst * x.snd) '' s ×ˢ t = s * t := image_prod _

@[simp, to_additive] lemma empty_mul : ∅ * s = ∅ := image2_empty_left
@[simp, to_additive] lemma mul_empty : s * ∅ = ∅ := image2_empty_right
@[simp, to_additive] lemma mul_eq_empty : s * t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp, to_additive] lemma mul_nonempty : (s * t).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
@[to_additive] lemma nonempty.mul : s.nonempty → t.nonempty → (s * t).nonempty := nonempty.image2
@[to_additive] lemma nonempty.of_mul_left : (s * t).nonempty → s.nonempty := nonempty.of_image2_left
@[to_additive] lemma nonempty.of_mul_right : (s * t).nonempty → t.nonempty :=
nonempty.of_image2_right
@[simp, to_additive] lemma mul_singleton : s * {b} = (* b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_mul : {a} * t = ((*) a) '' t := image2_singleton_left
@[simp, to_additive] lemma singleton_mul_singleton : ({a} : set α) * {b} = {a * b} :=
image2_singleton

@[to_additive, mono] lemma mul_subset_mul : s₁ ⊆ t₁ → s₂ ⊆ t₂ → s₁ * s₂ ⊆ t₁ * t₂ := image2_subset
@[to_additive] lemma mul_subset_mul_left : t₁ ⊆ t₂ → s * t₁ ⊆ s * t₂ := image2_subset_left
@[to_additive] lemma mul_subset_mul_right : s₁ ⊆ s₂ → s₁ * t ⊆ s₂ * t := image2_subset_right
@[to_additive] lemma mul_subset_iff : s * t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), x * y ∈ u := image2_subset_iff

attribute [mono] add_subset_add

@[to_additive] lemma union_mul : (s₁ ∪ s₂) * t = s₁ * t ∪ s₂ * t := image2_union_left
@[to_additive] lemma mul_union : s * (t₁ ∪ t₂) = s * t₁ ∪ s * t₂ := image2_union_right
@[to_additive] lemma inter_mul_subset : (s₁ ∩ s₂) * t ⊆ s₁ * t ∩ (s₂ * t) :=
image2_inter_subset_left
@[to_additive] lemma mul_inter_subset : s * (t₁ ∩ t₂) ⊆ s * t₁ ∩ (s * t₂) :=
image2_inter_subset_right

@[to_additive] lemma Union_mul_left_image : (⋃ a ∈ s, ((*) a) '' t) = s * t := Union_image_left _
@[to_additive] lemma Union_mul_right_image : (⋃ a ∈ t, (* a) '' s) = s * t := Union_image_right _

@[to_additive] lemma Union_mul (s : ι → set α) (t : set α) : (⋃ i, s i) * t = ⋃ i, s i * t :=
image2_Union_left _ _ _
@[to_additive] lemma mul_Union (s : set α) (t : ι → set α) : s * (⋃ i, t i) = ⋃ i, s * t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_mul (s : Π i, κ i → set α) (t : set α) : (⋃ i j, s i j) * t = ⋃ i j, s i j * t :=
image2_Union₂_left _ _ _

@[to_additive]
lemma mul_Union₂ (s : set α) (t : Π i, κ i → set α) : s * (⋃ i j, t i j) = ⋃ i j, s * t i j :=
image2_Union₂_right _ _ _

@[to_additive]
lemma Inter_mul_subset (s : ι → set α) (t : set α) : (⋂ i, s i) * t ⊆ ⋂ i, s i * t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma mul_Inter_subset (s : set α) (t : ι → set α) : s * (⋂ i, t i) ⊆ ⋂ i, s * t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_mul_subset (s : Π i, κ i → set α) (t : set α) :
  (⋂ i j, s i j) * t ⊆ ⋂ i j, s i j * t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma mul_Inter₂_subset (s : set α) (t : Π i, κ i → set α) :
  s * (⋂ i j, t i j) ⊆ ⋂ i j, s * t i j :=
image2_Inter₂_subset_right _ _ _

@[to_additive] lemma finite.mul : s.finite → t.finite → (s * t).finite := finite.image2 _

/-- Multiplication preserves finiteness. -/
@[to_additive "Addition preserves finiteness."]
def fintype_mul [decidable_eq α] (s t : set α) [fintype s] [fintype t] : fintype (s * t : set α) :=
set.fintype_image2 _ _ _

/-- The singleton operation as a `mul_hom`. -/
@[to_additive "The singleton operation as an `add_hom`."]
def singleton_mul_hom : α →ₙ* set α := ⟨singleton, λ a b, singleton_mul_singleton.symm⟩

@[simp, to_additive] lemma coe_singleton_mul_hom : (singleton_mul_hom : α → set α) = singleton :=
rfl
@[simp, to_additive] lemma singleton_mul_hom_apply (a : α) : singleton_mul_hom a = {a} := rfl

open mul_opposite

@[simp, to_additive]
lemma image_op_mul : op '' (s * t) = op '' t * op '' s := image_image2_antidistrib op_mul

end has_mul

/-! ### Set subtraction/division -/

section has_div
variables {ι : Sort*} {κ : ι → Sort*} [has_div α] {s s₁ s₂ t t₁ t₂ u : set α} {a b : α}

/-- The pointwise division of sets `s / t` is defined as `{x / y | x ∈ s, y ∈ t}` in locale
`pointwise`. -/
@[to_additive "The pointwise subtraction of sets `s - t` is defined as `{x - y | x ∈ s, y ∈ t}` in
locale `pointwise`."]
protected def has_div : has_div (set α) := ⟨image2 (/)⟩

localized "attribute [instance] set.has_div set.has_sub" in pointwise

@[simp, to_additive]
lemma image2_div : image2 has_div.div s t = s / t := rfl

@[to_additive]
lemma mem_div : a ∈ s / t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x / y = a := iff.rfl

@[to_additive] lemma div_mem_div : a ∈ s → b ∈ t → a / b ∈ s / t := mem_image2_of_mem

@[to_additive add_image_prod]
lemma image_div_prod : (λ x : α × α, x.fst / x.snd) '' s ×ˢ t = s / t := image_prod _

@[simp, to_additive] lemma empty_div : ∅ / s = ∅ := image2_empty_left
@[simp, to_additive] lemma div_empty : s / ∅ = ∅ := image2_empty_right
@[simp, to_additive] lemma div_eq_empty : s / t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp, to_additive] lemma div_nonempty : (s / t).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
@[to_additive] lemma nonempty.div : s.nonempty → t.nonempty → (s / t).nonempty := nonempty.image2
@[to_additive] lemma nonempty.of_div_left : (s / t).nonempty → s.nonempty := nonempty.of_image2_left
@[to_additive] lemma nonempty.of_div_right : (s / t).nonempty → t.nonempty :=
nonempty.of_image2_right
@[simp, to_additive] lemma div_singleton : s / {b} = (/ b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_div : {a} / t = ((/) a) '' t := image2_singleton_left
@[simp, to_additive] lemma singleton_div_singleton : ({a} : set α) / {b} = {a / b} :=
image2_singleton

@[to_additive, mono] lemma div_subset_div : s₁ ⊆ t₁ → s₂ ⊆ t₂ → s₁ / s₂ ⊆ t₁ / t₂ := image2_subset
@[to_additive] lemma div_subset_div_left : t₁ ⊆ t₂ → s / t₁ ⊆ s / t₂ := image2_subset_left
@[to_additive] lemma div_subset_div_right : s₁ ⊆ s₂ → s₁ / t ⊆ s₂ / t := image2_subset_right
@[to_additive] lemma div_subset_iff : s / t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), x / y ∈ u := image2_subset_iff

attribute [mono] sub_subset_sub

@[to_additive] lemma union_div : (s₁ ∪ s₂) / t = s₁ / t ∪ s₂ / t := image2_union_left
@[to_additive] lemma div_union : s / (t₁ ∪ t₂) = s / t₁ ∪ s / t₂ := image2_union_right
@[to_additive] lemma inter_div_subset : (s₁ ∩ s₂) / t ⊆ s₁ / t ∩ (s₂ / t) :=
image2_inter_subset_left
@[to_additive] lemma div_inter_subset : s / (t₁ ∩ t₂) ⊆ s / t₁ ∩ (s / t₂) :=
image2_inter_subset_right

@[to_additive] lemma Union_div_left_image : (⋃ a ∈ s, ((/) a) '' t) = s / t := Union_image_left _
@[to_additive] lemma Union_div_right_image : (⋃ a ∈ t, (/ a) '' s) = s / t := Union_image_right _

@[to_additive] lemma Union_div (s : ι → set α) (t : set α) : (⋃ i, s i) / t = ⋃ i, s i / t :=
image2_Union_left _ _ _
@[to_additive] lemma div_Union (s : set α) (t : ι → set α) : s / (⋃ i, t i) = ⋃ i, s / t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_div (s : Π i, κ i → set α) (t : set α) : (⋃ i j, s i j) / t = ⋃ i j, s i j / t :=
image2_Union₂_left _ _ _

@[to_additive]
lemma div_Union₂ (s : set α) (t : Π i, κ i → set α) : s / (⋃ i j, t i j) = ⋃ i j, s / t i j :=
image2_Union₂_right _ _ _

@[to_additive]
lemma Inter_div_subset (s : ι → set α) (t : set α) : (⋂ i, s i) / t ⊆ ⋂ i, s i / t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma div_Inter_subset (s : set α) (t : ι → set α) : s / (⋂ i, t i) ⊆ ⋂ i, s / t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_div_subset (s : Π i, κ i → set α) (t : set α) :
  (⋂ i j, s i j) / t ⊆ ⋂ i j, s i j / t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma div_Inter₂_subset (s : set α) (t : Π i, κ i → set α) :
  s / (⋂ i j, t i j) ⊆ ⋂ i j, s / t i j :=
image2_Inter₂_subset_right _ _ _

end has_div

open_locale pointwise

/-- Repeated pointwise addition (not the same as pointwise repeated addition!) of a `finset`. See
note [pointwise nat action].-/
protected def has_nsmul [has_zero α] [has_add α] : has_scalar ℕ (set α) := ⟨nsmul_rec⟩

/-- Repeated pointwise multiplication (not the same as pointwise repeated multiplication!) of a
`set`. See note [pointwise nat action]. -/
@[to_additive]
protected def has_npow [has_one α] [has_mul α] : has_pow (set α) ℕ := ⟨λ s n, npow_rec n s⟩

/-- Repeated pointwise addition/subtraction (not the same as pointwise repeated
addition/subtraction!) of a `set`. See note [pointwise nat action]. -/
protected def has_zsmul [has_zero α] [has_add α] [has_neg α] : has_scalar ℤ (set α) := ⟨zsmul_rec⟩

/-- Repeated pointwise multiplication/division (not the same as pointwise repeated
multiplication/division!) of a `set`. See note [pointwise nat action]. -/
@[to_additive] protected def has_zpow [has_one α] [has_mul α] [has_inv α] : has_pow (set α) ℤ :=
⟨λ s n, zpow_rec n s⟩

localized "attribute [instance] set.has_nsmul set.has_npow set.has_zsmul set.has_zpow" in pointwise

/-- `set α` is a `semigroup` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_semigroup` under pointwise operations if `α` is."]
protected def semigroup [semigroup α] : semigroup (set α) :=
{ mul_assoc := λ _ _ _, image2_assoc mul_assoc,
  ..set.has_mul }

/-- `set α` is a `comm_semigroup` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_comm_semigroup` under pointwise operations if `α` is."]
protected def comm_semigroup [comm_semigroup α] : comm_semigroup (set α) :=
{ mul_comm := λ s t, image2_comm mul_comm
  ..set.semigroup }

section mul_one_class
variables [mul_one_class α]

/-- `set α` is a `mul_one_class` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_zero_class` under pointwise operations if `α` is."]
protected def mul_one_class : mul_one_class (set α) :=
{ mul_one := λ s, by { simp only [← singleton_one, mul_singleton, mul_one, image_id'] },
  one_mul := λ s, by { simp only [← singleton_one, singleton_mul, one_mul, image_id'] },
  ..set.has_one, ..set.has_mul }

localized "attribute [instance] set.mul_one_class set.add_zero_class set.semigroup set.add_semigroup
  set.comm_semigroup set.add_comm_semigroup" in pointwise

@[to_additive] lemma subset_mul_left (s : set α) {t : set α} (ht : (1 : α) ∈ t) : s ⊆ s * t :=
λ x hx, ⟨x, 1, hx, ht, mul_one _⟩

@[to_additive] lemma subset_mul_right {s : set α} (t : set α) (hs : (1 : α) ∈ s) : t ⊆ s * t :=
λ x hx, ⟨1, x, hs, hx, one_mul _⟩

/-- The singleton operation as a `monoid_hom`. -/
@[to_additive "The singleton operation as an `add_monoid_hom`."]
def singleton_monoid_hom : α →* set α := { ..singleton_mul_hom, ..singleton_one_hom }

@[simp, to_additive] lemma coe_singleton_monoid_hom :
  (singleton_monoid_hom : α → set α) = singleton := rfl
@[simp, to_additive] lemma singleton_monoid_hom_apply (a : α) : singleton_monoid_hom a = {a} := rfl

end mul_one_class

section monoid
variables [monoid α] {s t : set α} {a : α} {m n : ℕ}

/-- `set α` is a `monoid` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_monoid` under pointwise operations if `α` is."]
protected def monoid : monoid (set α) := { ..set.semigroup, ..set.mul_one_class, ..set.has_npow }

localized "attribute [instance] set.monoid set.add_monoid" in pointwise

@[to_additive]
instance decidable_mem_mul [fintype α] [decidable_eq α] [decidable_pred (∈ s)]
  [decidable_pred (∈ t)] :
  decidable_pred (∈ s * t) :=
λ _, decidable_of_iff _ mem_mul.symm

@[to_additive]
instance decidable_mem_pow [fintype α] [decidable_eq α] [decidable_pred (∈ s)] (n : ℕ) :
  decidable_pred (∈ (s ^ n)) :=
begin
  induction n with n ih,
  { simp_rw [pow_zero, mem_one], apply_instance },
  { letI := ih, rw pow_succ, apply_instance }
end

@[to_additive] lemma pow_mem_pow (ha : a ∈ s) : ∀ n : ℕ, a ^ n ∈ s ^ n
| 0 := by { rw pow_zero, exact one_mem_one }
| (n + 1) := by { rw pow_succ, exact mul_mem_mul ha (pow_mem_pow _) }

@[to_additive] lemma pow_subset_pow (hst : s ⊆ t) : ∀ n : ℕ, s ^ n ⊆ t ^ n
| 0 := by { rw pow_zero, exact subset.rfl }
| (n + 1) := by { rw pow_succ, exact mul_subset_mul hst (pow_subset_pow _) }

@[to_additive] lemma pow_subset_pow_of_one_mem (hs : (1 : α) ∈ s) : m ≤ n → s ^ m ⊆ s ^ n :=
begin
  refine nat.le_induction _ (λ n h ih, _) _,
  { exact subset.rfl },
  { rw pow_succ,
    exact ih.trans (subset_mul_right _ hs) }
end

@[simp, to_additive] lemma empty_pow {n : ℕ} (hn : n ≠ 0) : (∅ : set α) ^ n = ∅ :=
by rw [← tsub_add_cancel_of_le (nat.succ_le_of_lt $ nat.pos_of_ne_zero hn), pow_succ, empty_mul]

@[to_additive] lemma mul_univ_of_one_mem (hs : (1 : α) ∈ s) : s * univ = univ :=
eq_univ_iff_forall.2 $ λ a, mem_mul.2 ⟨_, _, hs, mem_univ _, one_mul _⟩

@[to_additive] lemma univ_mul_of_one_mem (ht : (1 : α) ∈ t) : univ * t = univ :=
eq_univ_iff_forall.2 $ λ a, mem_mul.2 ⟨_, _, mem_univ _, ht, mul_one _⟩

@[simp, to_additive] lemma univ_mul_univ : (univ : set α) * univ = univ :=
mul_univ_of_one_mem $ mem_univ _

--TODO: `to_additive` trips up on the `1 : ℕ` used in the pattern-matching.
@[simp] lemma nsmul_univ {α : Type*} [add_monoid α] : ∀ {n : ℕ}, n ≠ 0 → n • (univ : set α) = univ
| 0 := λ h, (h rfl).elim
| 1 := λ _, one_nsmul _
| (n + 2) := λ _, by { rw [succ_nsmul, nsmul_univ n.succ_ne_zero, univ_add_univ] }

@[simp, to_additive nsmul_univ] lemma univ_pow : ∀ {n : ℕ}, n ≠ 0 → (univ : set α) ^ n = univ
| 0 := λ h, (h rfl).elim
| 1 := λ _, pow_one _
| (n + 2) := λ _, by { rw [pow_succ, univ_pow n.succ_ne_zero, univ_mul_univ] }

@[to_additive] protected lemma _root_.is_unit.set : is_unit a → is_unit ({a} : set α) :=
is_unit.map (singleton_monoid_hom : α →* set α)

end monoid

/-- `set α` is a `comm_monoid` under pointwise operations if `α` is. -/
@[to_additive "`set α` is an `add_comm_monoid` under pointwise operations if `α` is."]
protected def comm_monoid [comm_monoid α] : comm_monoid (set α) :=
{ ..set.monoid, ..set.comm_semigroup }

localized "attribute [instance] set.comm_monoid set.add_comm_monoid" in pointwise

open_locale pointwise

section division_monoid
variables [division_monoid α] {s t : set α}

@[to_additive] protected lemma mul_eq_one_iff : s * t = 1 ↔ ∃ a b, s = {a} ∧ t = {b} ∧ a * b = 1 :=
begin
  refine ⟨λ h, _, _⟩,
  { have hst : (s * t).nonempty := h.symm.subst one_nonempty,
    obtain ⟨a, ha⟩ := hst.of_image2_left,
    obtain ⟨b, hb⟩ := hst.of_image2_right,
    have H : ∀ {a b}, a ∈ s → b ∈ t → a * b = (1 : α) :=
      λ a b ha hb, (h.subset $ mem_image2_of_mem ha hb),
    refine ⟨a, b, _, _, H ha hb⟩; refine eq_singleton_iff_unique_mem.2 ⟨‹_›, λ x hx, _⟩,
    { exact (eq_inv_of_mul_eq_one_left $ H hx hb).trans (inv_eq_of_mul_eq_one_left $ H ha hb) },
    { exact (eq_inv_of_mul_eq_one_right $ H ha hx).trans (inv_eq_of_mul_eq_one_right $ H ha hb) } },
  { rintro ⟨b, c, rfl, rfl, h⟩,
    rw [singleton_mul_singleton, h, singleton_one] }
end

/-- `set α` is a division monoid under pointwise operations if `α` is. -/
@[to_additive subtraction_monoid "`set α` is a subtraction monoid under pointwise operations if `α`
is."]
protected def division_monoid : division_monoid (set α) :=
{ mul_inv_rev := λ s t, by { simp_rw ←image_inv, exact image_image2_antidistrib mul_inv_rev },
  inv_eq_of_mul := λ s t h, begin
    obtain ⟨a, b, rfl, rfl, hab⟩ := set.mul_eq_one_iff.1 h,
    rw [inv_singleton, inv_eq_of_mul_eq_one_right hab],
  end,
  div_eq_mul_inv := λ s t,
    by { rw [←image_id (s / t), ←image_inv], exact image_image2_distrib_right div_eq_mul_inv },
  ..set.monoid, ..set.has_involutive_inv, ..set.has_div, ..set.has_zpow }

@[simp, to_additive] lemma is_unit_iff : is_unit s ↔ ∃ a, s = {a} ∧ is_unit a :=
begin
  split,
  { rintro ⟨u, rfl⟩,
    obtain ⟨a, b, ha, hb, h⟩ := set.mul_eq_one_iff.1 u.mul_inv,
    refine ⟨a, ha, ⟨a, b, h, singleton_injective _⟩, rfl⟩,
    rw [←singleton_mul_singleton, ←ha, ←hb],
    exact u.inv_mul },
  { rintro ⟨a, rfl, ha⟩,
    exact ha.set }
end

end division_monoid

/-- `set α` is a commutative division monoid under pointwise operations if `α` is. -/
@[to_additive subtraction_comm_monoid "`set α` is a commutative subtraction monoid under pointwise
operations if `α` is."]
protected def division_comm_monoid [division_comm_monoid α] : division_comm_monoid (set α) :=
{ ..set.division_monoid, ..set.comm_semigroup }

/-- `set α` has distributive negation if `α` has. -/
protected def has_distrib_neg [has_mul α] [has_distrib_neg α] : has_distrib_neg (set α) :=
{ neg_mul := λ _ _, by { simp_rw ←image_neg, exact image2_image_left_comm neg_mul },
  mul_neg := λ _ _, by { simp_rw ←image_neg, exact image_image2_right_comm mul_neg },
  ..set.has_involutive_neg }

localized "attribute [instance] set.division_monoid set.subtraction_monoid set.division_comm_monoid
  set.subtraction_comm_monoid set.has_distrib_neg" in pointwise

section distrib
variables [distrib α] (s t u : set α)

/-!
Note that `set α` is not a `distrib` because `s * t + s * u` has cross terms that `s * (t + u)`
lacks.
-/

lemma mul_add_subset : s * (t + u) ⊆ s * t + s * u := image2_distrib_subset_left mul_add
lemma add_mul_subset : (s + t) * u ⊆ s * u + t * u := image2_distrib_subset_right add_mul

end distrib

section mul_zero_class
variables [mul_zero_class α] {s t : set α}

/-! Note that `set` is not a `mul_zero_class` because `0 * ∅ ≠ 0`. -/

lemma mul_zero_subset (s : set α) : s * 0 ⊆ 0 := by simp [subset_def, mem_mul]
lemma zero_mul_subset (s : set α) : 0 * s ⊆ 0 := by simp [subset_def, mem_mul]

lemma nonempty.mul_zero (hs : s.nonempty) : s * 0 = 0 :=
s.mul_zero_subset.antisymm $ by simpa [mem_mul] using hs

lemma nonempty.zero_mul (hs : s.nonempty) : 0 * s = 0 :=
s.zero_mul_subset.antisymm $ by simpa [mem_mul] using hs

end mul_zero_class

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

/-! Note that `set` is not a `group` because `s / s ≠ 1` in general. -/

@[simp, to_additive] lemma one_mem_div_iff : (1 : α) ∈ s / t ↔ ¬ disjoint s t :=
by simp [not_disjoint_iff_nonempty_inter, mem_div, div_eq_one, set.nonempty]

@[to_additive] lemma not_one_mem_div_iff : (1 : α) ∉ s / t ↔ disjoint s t :=
one_mem_div_iff.not_left

alias not_one_mem_div_iff ↔ _ disjoint.one_not_mem_div_set

attribute [to_additive] disjoint.one_not_mem_div_set

@[to_additive] lemma nonempty.one_mem_div (h : s.nonempty) : (1 : α) ∈ s / s :=
let ⟨a, ha⟩ := h in mem_div.2 ⟨a, a, ha, ha, div_self' _⟩

@[to_additive] lemma is_unit_singleton (a : α) : is_unit ({a} : set α) := (group.is_unit a).set

@[simp, to_additive] lemma is_unit_iff_singleton : is_unit s ↔ ∃ a, s = {a} :=
by simp only [is_unit_iff, group.is_unit, and_true]

@[simp, to_additive] lemma image_mul_left : ((*) a) '' t = ((*) a⁻¹) ⁻¹' t :=
by { rw image_eq_preimage_of_inverse; intro c; simp }

@[simp, to_additive] lemma image_mul_right : (* b) '' t = (* b⁻¹) ⁻¹' t :=
by { rw image_eq_preimage_of_inverse; intro c; simp }

@[to_additive] lemma image_mul_left' : (λ b, a⁻¹ * b) '' t = (λ b, a * b) ⁻¹' t := by simp
@[to_additive] lemma image_mul_right' : (* b⁻¹) '' t = (* b) ⁻¹' t := by simp

@[simp, to_additive] lemma preimage_mul_left_singleton : ((*) a) ⁻¹' {b} = {a⁻¹ * b} :=
by rw [← image_mul_left', image_singleton]

@[simp, to_additive] lemma preimage_mul_right_singleton : (* a) ⁻¹' {b} = {b * a⁻¹} :=
by rw [← image_mul_right', image_singleton]

@[simp, to_additive] lemma preimage_mul_left_one : ((*) a) ⁻¹' 1 = {a⁻¹} :=
by rw [← image_mul_left', image_one, mul_one]

@[simp, to_additive] lemma preimage_mul_right_one : (* b) ⁻¹' 1 = {b⁻¹} :=
by rw [← image_mul_right', image_one, one_mul]

@[to_additive] lemma preimage_mul_left_one' : (λ b, a⁻¹ * b) ⁻¹' 1 = {a} := by simp
@[to_additive] lemma preimage_mul_right_one' : (* b⁻¹) ⁻¹' 1 = {b} := by simp

@[simp, to_additive] lemma mul_univ (hs : s.nonempty) : s * (univ : set α) = univ :=
let ⟨a, ha⟩ := hs in eq_univ_of_forall $ λ b, ⟨a, a⁻¹ * b, ha, trivial, mul_inv_cancel_left _ _⟩

@[simp, to_additive] lemma univ_mul (ht : t.nonempty) : (univ : set α) * t = univ :=
let ⟨a, ha⟩ := ht in eq_univ_of_forall $ λ b, ⟨b * a⁻¹, a, trivial, ha, inv_mul_cancel_right _ _⟩

end group

section group_with_zero
variables [group_with_zero α] {s t : set α}

lemma div_zero_subset (s : set α) : s / 0 ⊆ 0 := by simp [subset_def, mem_div]
lemma zero_div_subset (s : set α) : 0 / s ⊆ 0 := by simp [subset_def, mem_div]

lemma nonempty.div_zero (hs : s.nonempty) : s / 0 = 0 :=
s.div_zero_subset.antisymm $ by simpa [mem_div] using hs

lemma nonempty.zero_div (hs : s.nonempty) : 0 / s = 0 :=
s.zero_div_subset.antisymm $ by simpa [mem_div] using hs

end group_with_zero

section has_mul
variables [has_mul α] [has_mul β] [mul_hom_class F α β] (m : F) {s t : set α}
include α β

@[to_additive] lemma image_mul : m '' (s * t) = m '' s * m '' t := image_image2_distrib $ map_mul m

@[to_additive]
lemma preimage_mul_preimage_subset {s t : set β} : m ⁻¹' s * m ⁻¹' t ⊆ m ⁻¹' (s * t) :=
by { rintro _ ⟨_, _, _, _, rfl⟩, exact ⟨_, _, ‹_›, ‹_›, (map_mul m _ _).symm ⟩ }

end has_mul

section group
variables [group α] [division_monoid β] [monoid_hom_class F α β] (m : F) {s t : set α}
include α β

@[to_additive] lemma image_div : m '' (s / t) = m '' s / m '' t := image_image2_distrib $ map_div m

@[to_additive]
lemma preimage_div_preimage_subset {s t : set β} : m ⁻¹' s / m ⁻¹' t ⊆ m ⁻¹' (s / t) :=
by { rintro _ ⟨_, _, _, _, rfl⟩, exact ⟨_, _, ‹_›, ‹_›, (map_div m _ _).symm ⟩ }

end group

@[to_additive]
lemma bdd_above_mul [ordered_comm_monoid α] {A B : set α} :
  bdd_above A → bdd_above B → bdd_above (A * B) :=
begin
  rintro ⟨bA, hbA⟩ ⟨bB, hbB⟩,
  use bA * bB,
  rintro x ⟨xa, xb, hxa, hxb, rfl⟩,
  exact mul_le_mul' (hbA hxa) (hbB hxb),
end

open_locale pointwise

section big_operators
open_locale big_operators

variables {ι : Type*} [comm_monoid α]

/-- The n-ary version of `set.mem_mul`. -/
@[to_additive /-" The n-ary version of `set.mem_add`. "-/]
lemma mem_finset_prod (t : finset ι) (f : ι → set α) (a : α) :
  a ∈ ∏ i in t, f i ↔ ∃ (g : ι → α) (hg : ∀ {i}, i ∈ t → g i ∈ f i), ∏ i in t, g i = a :=
begin
  classical,
  induction t using finset.induction_on with i is hi ih generalizing a,
  { simp_rw [finset.prod_empty, set.mem_one],
    exact ⟨λ h, ⟨λ i, a, λ i, false.elim, h.symm⟩, λ ⟨f, _, hf⟩, hf.symm⟩ },
  rw [finset.prod_insert hi, set.mem_mul],
  simp_rw [finset.prod_insert hi],
  simp_rw ih,
  split,
  { rintro ⟨x, y, hx, ⟨g, hg, rfl⟩, rfl⟩,
    refine ⟨function.update g i x, λ j hj, _, _⟩,
    obtain rfl | hj := finset.mem_insert.mp hj,
    { rw function.update_same, exact hx },
    { rw update_noteq (ne_of_mem_of_not_mem hj hi), exact hg hj, },
    rw [finset.prod_update_of_not_mem hi, function.update_same], },
  { rintro ⟨g, hg, rfl⟩,
    exact ⟨g i, is.prod g, hg (is.mem_insert_self _),
      ⟨g, λ i hi, hg (finset.mem_insert_of_mem hi), rfl⟩, rfl⟩ },
end

/-- A version of `set.mem_finset_prod` with a simpler RHS for products over a fintype. -/
@[to_additive /-" A version of `set.mem_finset_sum` with a simpler RHS for sums over a fintype. "-/]
lemma mem_fintype_prod [fintype ι] (f : ι → set α) (a : α) :
  a ∈ ∏ i, f i ↔ ∃ (g : ι → α) (hg : ∀ i, g i ∈ f i), ∏ i, g i = a :=
by { rw mem_finset_prod, simp }

/-- The n-ary version of `set.mul_mem_mul`. -/
@[to_additive /-" The n-ary version of `set.add_mem_add`. "-/]
lemma finset_prod_mem_finset_prod (t : finset ι) (f : ι → set α)
  (g : ι → α) (hg : ∀ i ∈ t, g i ∈ f i) :
  ∏ i in t, g i ∈ ∏ i in t, f i :=
by { rw mem_finset_prod, exact ⟨g, hg, rfl⟩ }

/-- The n-ary version of `set.mul_subset_mul`. -/
@[to_additive /-" The n-ary version of `set.add_subset_add`. "-/]
lemma finset_prod_subset_finset_prod (t : finset ι) (f₁ f₂ : ι → set α)
  (hf : ∀ {i}, i ∈ t → f₁ i ⊆ f₂ i) :
  ∏ i in t, f₁ i ⊆ ∏ i in t, f₂ i :=
begin
  intro a,
  rw [mem_finset_prod, mem_finset_prod],
  rintro ⟨g, hg, rfl⟩,
  exact ⟨g, λ i hi, hf hi $ hg hi, rfl⟩
end

@[to_additive]
lemma finset_prod_singleton {M ι : Type*} [comm_monoid M] (s : finset ι) (I : ι → M) :
  ∏ (i : ι) in s, ({I i} : set M) = {∏ (i : ι) in s, I i} :=
(map_prod (singleton_monoid_hom : M →* set M) _ _).symm

/-! TODO: define `decidable_mem_finset_prod` and `decidable_mem_finset_sum`. -/

end big_operators

/-! ### Translation/scaling of sets -/

section smul

/-- The dilation of set `x • s` is defined as `{x • y | y ∈ s}` in locale `pointwise`. -/
@[to_additive has_vadd_set "The translation of set `x +ᵥ s` is defined as `{x +ᵥ y | y ∈ s}` in
locale `pointwise`."]
protected def has_scalar_set [has_scalar α β] : has_scalar α (set β) :=
⟨λ a, image (has_scalar.smul a)⟩

/-- The pointwise scalar multiplication of sets `s • t` is defined as `{x • y | x ∈ s, y ∈ t}` in
locale `pointwise`. -/
@[to_additive has_vadd "The pointwise scalar addition of sets `s +ᵥ t` is defined as
`{x +ᵥ y | x ∈ s, y ∈ t}` in locale `pointwise`."]
protected def has_scalar [has_scalar α β] : has_scalar (set α) (set β) :=
⟨image2 has_scalar.smul⟩

localized "attribute [instance] set.has_scalar_set set.has_scalar" in pointwise
localized "attribute [instance] set.has_vadd_set set.has_vadd" in pointwise

section has_scalar
variables {ι : Sort*} {κ : ι → Sort*} [has_scalar α β] {s s₁ s₂ : set α} {t t₁ t₂ u : set β} {a : α}
  {b : β}

@[simp, to_additive]
lemma image2_smul : image2 has_scalar.smul s t = s • t := rfl

@[to_additive add_image_prod]
lemma image_smul_prod : (λ x : α × β, x.fst • x.snd) '' s ×ˢ t = s • t := image_prod _

@[to_additive]
lemma mem_smul : b ∈ s • t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x • y = b := iff.rfl

@[to_additive] lemma smul_mem_smul : a ∈ s → b ∈ t → a • b ∈ s • t := mem_image2_of_mem

@[simp, to_additive] lemma empty_smul : (∅ : set α) • t = ∅ := image2_empty_left
@[simp, to_additive] lemma smul_empty : s • (∅ : set β) = ∅ := image2_empty_right
@[simp, to_additive] lemma smul_eq_empty : s • t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp, to_additive] lemma smul_nonempty : (s • t).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
@[to_additive] lemma nonempty.smul : s.nonempty → t.nonempty → (s • t).nonempty := nonempty.image2
@[to_additive] lemma nonempty.of_smul_left : (s • t).nonempty → s.nonempty :=
nonempty.of_image2_left
@[to_additive] lemma nonempty.of_smul_right : (s • t).nonempty → t.nonempty :=
nonempty.of_image2_right
@[simp, to_additive] lemma smul_singleton : s • {b} = (• b) '' s := image2_singleton_right
@[simp, to_additive] lemma singleton_smul : ({a} : set α) • t = a • t := image2_singleton_left
@[simp, to_additive] lemma singleton_smul_singleton : ({a} : set α) • ({b} : set β) = {a • b} :=
image2_singleton

@[to_additive, mono] lemma smul_subset_smul : s₁ ⊆ s₂ → t₁ ⊆ t₂ → s₁ • t₁ ⊆ s₂ • t₂ := image2_subset
@[to_additive] lemma smul_subset_smul_left : t₁ ⊆ t₂ → s • t₁ ⊆ s • t₂ := image2_subset_left
@[to_additive] lemma smul_subset_smul_right : s₁ ⊆ s₂ → s₁ • t ⊆ s₂ • t := image2_subset_right
@[to_additive] lemma smul_subset_iff : s • t ⊆ u ↔ ∀ (a ∈ s) (b ∈ t), a • b ∈ u := image2_subset_iff

attribute [mono] vadd_subset_vadd

@[to_additive] lemma union_smul : (s₁ ∪ s₂) • t = s₁ • t ∪ s₂ • t := image2_union_left
@[to_additive] lemma smul_union : s • (t₁ ∪ t₂) = s • t₁ ∪ s • t₂ := image2_union_right
@[to_additive] lemma inter_smul_subset : (s₁ ∩ s₂) • t ⊆ s₁ • t ∩ s₂ • t := image2_inter_subset_left
@[to_additive] lemma smul_inter_subset : s • (t₁ ∩ t₂) ⊆ s • t₁ ∩ s • t₂ :=
image2_inter_subset_right

@[to_additive] lemma Union_smul_left_image : (⋃ a ∈ s, a • t) = s • t := Union_image_left _
@[to_additive] lemma Union_smul_right_image : (⋃ a ∈ t, (• a) '' s) = s • t := Union_image_right _

@[to_additive] lemma Union_smul (s : ι → set α) (t : set β) : (⋃ i, s i) • t = ⋃ i, s i • t :=
image2_Union_left _ _ _
@[to_additive] lemma smul_Union (s : set α) (t : ι → set β) : s • (⋃ i, t i) = ⋃ i, s • t i :=
image2_Union_right _ _ _

@[to_additive]
lemma Union₂_smul (s : Π i, κ i → set α) (t : set β) : (⋃ i j, s i j) • t = ⋃ i j, s i j • t :=
image2_Union₂_left _ _ _

@[to_additive]
lemma smul_Union₂ (s : set α) (t : Π i, κ i → set β) : s • (⋃ i j, t i j) = ⋃ i j, s • t i j :=
image2_Union₂_right _ _ _

@[to_additive]
lemma Inter_smul_subset (s : ι → set α) (t : set β) : (⋂ i, s i) • t ⊆ ⋂ i, s i • t :=
image2_Inter_subset_left _ _ _

@[to_additive]
lemma smul_Inter_subset (s : set α) (t : ι → set β) : s • (⋂ i, t i) ⊆ ⋂ i, s • t i :=
image2_Inter_subset_right _ _ _

@[to_additive]
lemma Inter₂_smul_subset (s : Π i, κ i → set α) (t : set β) :
  (⋂ i j, s i j) • t ⊆ ⋂ i j, s i j • t :=
image2_Inter₂_subset_left _ _ _

@[to_additive]
lemma smul_Inter₂_subset (s : set α) (t : Π i, κ i → set β) :
  s • (⋂ i j, t i j) ⊆ ⋂ i j, s • t i j :=
image2_Inter₂_subset_right _ _ _

@[to_additive] lemma finite.smul : s.finite → t.finite → (s • t).finite := finite.image2 _

end has_scalar

section has_scalar_set
variables {ι : Sort*} {κ : ι → Sort*} [has_scalar α β] {s t t₁ t₂ : set β} {a : α} {b : β} {x y : β}

@[simp, to_additive] lemma image_smul : (λ x, a • x) '' t = a • t := rfl

@[to_additive] lemma mem_smul_set : x ∈ a • t ↔ ∃ y, y ∈ t ∧ a • y = x := iff.rfl

@[to_additive] lemma smul_mem_smul_set : b ∈ s → a • b ∈ a • s := mem_image_of_mem _

@[simp, to_additive] lemma smul_set_empty : a • (∅ : set β) = ∅ := image_empty _
@[simp, to_additive] lemma smul_set_eq_empty : a • s = ∅ ↔ s = ∅ := image_eq_empty
@[simp, to_additive] lemma smul_set_nonempty : (a • s).nonempty ↔ s.nonempty := nonempty_image_iff

@[simp, to_additive] lemma smul_set_singleton : a • ({b} : set β) = {a • b} := image_singleton

@[to_additive] lemma smul_set_mono (h : s ⊆ t) : a • s ⊆ a • t := image_subset _ h

@[to_additive] lemma smul_set_union : a • (t₁ ∪ t₂) = a • t₁ ∪ a • t₂ := image_union _ _ _

@[to_additive]
lemma smul_set_inter_subset : a • (t₁ ∩ t₂) ⊆ a • t₁ ∩ (a • t₂) := image_inter_subset _ _ _

@[to_additive]
lemma smul_set_Union (a : α) (s : ι → set β) : a • (⋃ i, s i) = ⋃ i, a • s i := image_Union

@[to_additive]
lemma smul_set_Union₂ (a : α) (s : Π i, κ i → set β) : a • (⋃ i j, s i j) = ⋃ i j, a • s i j :=
image_Union₂ _ _

@[to_additive]
lemma smul_set_Inter_subset (a : α) (t : ι → set β) : a • (⋂ i, t i) ⊆ ⋂ i, a • t i :=
image_Inter_subset _ _

@[to_additive]
lemma smul_set_Inter₂_subset (a : α) (t : Π i, κ i → set β) :
  a • (⋂ i j, t i j) ⊆ ⋂ i j, a • t i j :=
image_Inter₂_subset _ _

@[to_additive] lemma nonempty.smul_set : s.nonempty → (a • s).nonempty := nonempty.image _
@[to_additive] lemma finite.smul_set : s.finite → (a • s).finite := finite.image _

end has_scalar_set

variables {s s₁ s₂ : set α} {t t₁ t₂ : set β} {a : α} {b : β}

@[to_additive]
lemma smul_set_inter [group α] [mul_action α β] {s t : set β} :
  a • (s ∩ t) = a • s ∩ a • t :=
(image_inter $ mul_action.injective a).symm

lemma smul_set_inter₀ [group_with_zero α] [mul_action α β] {s t : set β} (ha : a ≠ 0) :
  a • (s ∩ t) = a • s ∩ a • t :=
show units.mk0 a ha • _ = _, from smul_set_inter

@[simp, to_additive]
lemma smul_set_univ [group α] [mul_action α β] {a : α} : a • (univ : set β) = univ :=
eq_univ_of_forall $ λ b, ⟨a⁻¹ • b, trivial, smul_inv_smul _ _⟩

@[simp, to_additive]
lemma smul_univ [group α] [mul_action α β] {s : set α} (hs : s.nonempty) :
  s • (univ : set β) = univ :=
let ⟨a, ha⟩ := hs in eq_univ_of_forall $ λ b, ⟨a, a⁻¹ • b, ha, trivial, smul_inv_smul _ _⟩

@[to_additive]
theorem range_smul_range {ι κ : Type*} [has_scalar α β] (b : ι → α) (c : κ → β) :
  range b • range c = range (λ p : ι × κ, b p.1 • c p.2) :=
ext $ λ x, ⟨λ hx, let ⟨p, q, ⟨i, hi⟩, ⟨j, hj⟩, hpq⟩ := set.mem_smul.1 hx in
  ⟨(i, j), hpq ▸ hi ▸ hj ▸ rfl⟩,
λ ⟨⟨i, j⟩, h⟩, set.mem_smul.2 ⟨b i, c j, ⟨i, rfl⟩, ⟨j, rfl⟩, h⟩⟩

@[to_additive] lemma smul_set_range [has_scalar α β] {ι : Sort*} {f : ι → β} :
  a • range f = range (λ i, a • f i) := (range_comp _ _).symm

@[to_additive]
instance smul_comm_class_set [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class α (set β) (set γ) :=
⟨λ _ _ _, image_image2_distrib_right $ smul_comm _⟩

@[to_additive]
instance smul_comm_class_set' [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class (set α) β (set γ) :=
by haveI := smul_comm_class.symm α β γ; exact smul_comm_class.symm _ _ _

@[to_additive]
instance smul_comm_class [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class (set α) (set β) (set γ) :=
⟨λ _ _ _, image2_left_comm smul_comm⟩

instance is_scalar_tower [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α β (set γ) :=
{ smul_assoc := λ a b T, by simp only [←image_smul, image_image, smul_assoc] }

instance is_scalar_tower' [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α (set β) (set γ) :=
⟨λ _ _ _, image2_image_left_comm $ smul_assoc _⟩

instance is_scalar_tower'' [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower (set α) (set β) (set γ) :=
{ smul_assoc := λ T T' T'', image2_assoc smul_assoc }

instance is_central_scalar [has_scalar α β] [has_scalar αᵐᵒᵖ β] [is_central_scalar α β] :
  is_central_scalar α (set β) :=
⟨λ a S, congr_arg (λ f, f '' S) $ by exact funext (λ _, op_smul_eq_smul _ _)⟩

/-- A multiplicative action of a monoid `α` on a type `β` gives a multiplicative action of `set α`
on `set β`. -/
@[to_additive "An additive action of an additive monoid `α` on a type `β` gives an additive action
of `set α` on `set β`"]
protected def mul_action [monoid α] [mul_action α β] : mul_action (set α) (set β) :=
{ mul_smul := λ _ _ _, image2_assoc mul_smul,
  one_smul := λ s, image2_singleton_left.trans $ by simp_rw [one_smul, image_id'] }

/-- A multiplicative action of a monoid on a type `β` gives a multiplicative action on `set β`. -/
@[to_additive "An additive action of an additive monoid on a type `β` gives an additive action
on `set β`."]
protected def mul_action_set [monoid α] [mul_action α β] : mul_action α (set β) :=
{ mul_smul := by { intros, simp only [← image_smul, image_image, ← mul_smul] },
  one_smul := by { intros, simp only [← image_smul, one_smul, image_id'] } }

localized "attribute [instance] set.mul_action_set set.add_action_set
  set.mul_action set.add_action" in pointwise

/-- A distributive multiplicative action of a monoid on an additive monoid `β` gives a distributive
multiplicative action on `set β`. -/
protected def distrib_mul_action_set [monoid α] [add_monoid β] [distrib_mul_action α β] :
  distrib_mul_action α (set β) :=
{ smul_add := λ _ _ _, image_image2_distrib $ smul_add _,
  smul_zero := λ _, image_singleton.trans $ by rw [smul_zero, singleton_zero] }

/-- A multiplicative action of a monoid on a monoid `β` gives a multiplicative action on `set β`. -/
protected def mul_distrib_mul_action_set [monoid α] [monoid β] [mul_distrib_mul_action α β] :
  mul_distrib_mul_action α (set β) :=
{ smul_mul := λ _ _ _, image_image2_distrib $ smul_mul' _,
  smul_one := λ _, image_singleton.trans $ by rw [smul_one, singleton_one] }

localized "attribute [instance] set.distrib_mul_action_set set.mul_distrib_mul_action_set"
  in pointwise

end smul

section vsub
variables {ι : Sort*} {κ : ι → Sort*} [has_vsub α β] {s s₁ s₂ t t₁ t₂ : set β} {u : set α} {a : α}
  {b c : β}
include α

instance has_vsub : has_vsub (set α) (set β) := ⟨image2 (-ᵥ)⟩

@[simp] lemma image2_vsub : (image2 has_vsub.vsub s t : set α) = s -ᵥ t := rfl

lemma image_vsub_prod : (λ x : β × β, x.fst -ᵥ x.snd) '' s ×ˢ t = s -ᵥ t := image_prod _

lemma mem_vsub : a ∈ s -ᵥ t ↔ ∃ x y, x ∈ s ∧ y ∈ t ∧ x -ᵥ y = a := iff.rfl

lemma vsub_mem_vsub (hb : b ∈ s) (hc : c ∈ t) : b -ᵥ c ∈ s -ᵥ t := mem_image2_of_mem hb hc

@[simp] lemma empty_vsub (t : set β) : ∅ -ᵥ t = ∅ := image2_empty_left
@[simp] lemma vsub_empty (s : set β) : s -ᵥ ∅ = ∅ := image2_empty_right
@[simp] lemma vsub_eq_empty : s -ᵥ t = ∅ ↔ s = ∅ ∨ t = ∅ := image2_eq_empty_iff
@[simp] lemma vsub_nonempty : (s -ᵥ t : set α).nonempty ↔ s.nonempty ∧ t.nonempty :=
image2_nonempty_iff
lemma nonempty.vsub : s.nonempty → t.nonempty → (s -ᵥ t : set α).nonempty := nonempty.image2
lemma nonempty.of_vsub_left : (s -ᵥ t :set α).nonempty → s.nonempty := nonempty.of_image2_left
lemma nonempty.of_vsub_right : (s -ᵥ t : set α).nonempty → t.nonempty := nonempty.of_image2_right
@[simp] lemma vsub_singleton (s : set β) (b : β) : s -ᵥ {b} = (-ᵥ b) '' s := image2_singleton_right
@[simp] lemma singleton_vsub (t : set β) (b : β) : {b} -ᵥ t = ((-ᵥ) b) '' t := image2_singleton_left
@[simp] lemma singleton_vsub_singleton : ({b} : set β) -ᵥ {c} = {b -ᵥ c} := image2_singleton

@[mono] lemma vsub_subset_vsub : s₁ ⊆ s₂ → t₁ ⊆ t₂ → s₁ -ᵥ t₁ ⊆ s₂ -ᵥ t₂ := image2_subset
lemma vsub_subset_vsub_left : t₁ ⊆ t₂ → s -ᵥ t₁ ⊆ s -ᵥ t₂ := image2_subset_left
lemma vsub_subset_vsub_right : s₁ ⊆ s₂ → s₁ -ᵥ t ⊆ s₂ -ᵥ t := image2_subset_right
lemma vsub_subset_iff : s -ᵥ t ⊆ u ↔ ∀ (x ∈ s) (y ∈ t), x -ᵥ y ∈ u := image2_subset_iff
lemma vsub_self_mono (h : s ⊆ t) : s -ᵥ s ⊆ t -ᵥ t := vsub_subset_vsub h h

lemma union_vsub : (s₁ ∪ s₂) -ᵥ t = s₁ -ᵥ t ∪ (s₂ -ᵥ t) := image2_union_left
lemma vsub_union : s -ᵥ (t₁ ∪ t₂) = s -ᵥ t₁ ∪ (s -ᵥ t₂) := image2_union_right
lemma inter_vsub_subset : s₁ ∩ s₂ -ᵥ t ⊆ (s₁ -ᵥ t) ∩ (s₂ -ᵥ t) := image2_inter_subset_left
lemma vsub_inter_subset : s -ᵥ t₁ ∩ t₂ ⊆ (s -ᵥ t₁) ∩ (s -ᵥ t₂) := image2_inter_subset_right

lemma Union_vsub_left_image : (⋃ a ∈ s, ((-ᵥ) a) '' t) = s -ᵥ t := Union_image_left _
lemma Union_vsub_right_image : (⋃ a ∈ t, (-ᵥ a) '' s) = s -ᵥ t := Union_image_right _

lemma Union_vsub (s : ι → set β) (t : set β) : (⋃ i, s i) -ᵥ t = ⋃ i, s i -ᵥ t :=
image2_Union_left _ _ _
lemma vsub_Union (s : set β) (t : ι → set β) : s -ᵥ (⋃ i, t i) = ⋃ i, s -ᵥ t i :=
image2_Union_right _ _ _

lemma Union₂_vsub (s : Π i, κ i → set β) (t : set β) : (⋃ i j, s i j) -ᵥ t = ⋃ i j, s i j -ᵥ t :=
image2_Union₂_left _ _ _

lemma vsub_Union₂ (s : set β) (t : Π i, κ i → set β) : s -ᵥ (⋃ i j, t i j) = ⋃ i j, s -ᵥ t i j :=
image2_Union₂_right _ _ _

lemma Inter_vsub_subset (s : ι → set β) (t : set β) : (⋂ i, s i) -ᵥ t ⊆ ⋂ i, s i -ᵥ t :=
image2_Inter_subset_left _ _ _

lemma vsub_Inter_subset (s : set β) (t : ι → set β) : s -ᵥ (⋂ i, t i) ⊆ ⋂ i, s -ᵥ t i :=
image2_Inter_subset_right _ _ _

lemma Inter₂_vsub_subset (s : Π i, κ i → set β) (t : set β) :
  (⋂ i j, s i j) -ᵥ t ⊆ ⋂ i j, s i j -ᵥ t :=
image2_Inter₂_subset_left _ _ _

lemma vsub_Inter₂_subset (s : set β) (t : Π i, κ i → set β) :
  s -ᵥ (⋂ i j, t i j) ⊆ ⋂ i j, s -ᵥ t i j :=
image2_Inter₂_subset_right _ _ _

lemma finite.vsub (hs : s.finite) (ht : t.finite) : set.finite (s -ᵥ t) := hs.image2 _ ht

end vsub

open_locale pointwise

section ring
variables [ring α] [add_comm_group β] [module α β] {s : set α} {t : set β} {a : α}

@[simp] lemma neg_smul_set : -a • t = -(a • t) :=
by simp_rw [←image_smul, ←image_neg, image_image, neg_smul]

@[simp] lemma smul_set_neg : a • -t = -(a • t) :=
by simp_rw [←image_smul, ←image_neg, image_image, smul_neg]

@[simp] protected lemma neg_smul : -s • t = -(s • t) :=
by { simp_rw ←image_neg, exact image2_image_left_comm neg_smul }

@[simp] protected lemma smul_neg : s • -t = -(s • t) :=
by { simp_rw ←image_neg, exact image_image2_right_comm smul_neg }

end ring

section smul_with_zero
variables [has_zero α] [has_zero β] [smul_with_zero α β] {s : set α} {t : set β}

/-!
Note that we have neither `smul_with_zero α (set β)` nor `smul_with_zero (set α) (set β)`
because `0 * ∅ ≠ 0`.
-/

lemma smul_zero_subset (s : set α) : s • (0 : set β) ⊆ 0 := by simp [subset_def, mem_smul]
lemma zero_smul_subset (t : set β) : (0 : set α) • t ⊆ 0 := by simp [subset_def, mem_smul]

lemma nonempty.smul_zero (hs : s.nonempty) : s • (0 : set β) = 0 :=
s.smul_zero_subset.antisymm $ by simpa [mem_smul] using hs

lemma nonempty.zero_smul (ht : t.nonempty) : (0 : set α) • t = 0 :=
t.zero_smul_subset.antisymm $ by simpa [mem_smul] using ht

/-- A nonempty set is scaled by zero to the singleton set containing 0. -/
lemma zero_smul_set {s : set β} (h : s.nonempty) : (0 : α) • s = (0 : set β) :=
by simp only [← image_smul, image_eta, zero_smul, h.image_const, singleton_zero]

lemma zero_smul_set_subset (s : set β) : (0 : α) • s ⊆ 0 :=
image_subset_iff.2 $ λ x _, zero_smul α x

lemma subsingleton_zero_smul_set (s : set β) : ((0 : α) • s).subsingleton :=
subsingleton_singleton.mono $ zero_smul_set_subset s

lemma zero_mem_smul_set {t : set β} {a : α} (h : (0 : β) ∈ t) : (0 : β) ∈ a • t :=
⟨0, h, smul_zero' _ _⟩

variables [no_zero_smul_divisors α β] {a : α}

lemma zero_mem_smul_iff : (0 : β) ∈ s • t ↔ (0 : α) ∈ s ∧ t.nonempty ∨ (0 : β) ∈ t ∧ s.nonempty :=
begin
  split,
  { rintro ⟨a, b, ha, hb, h⟩,
    obtain rfl | rfl := eq_zero_or_eq_zero_of_smul_eq_zero h,
    { exact or.inl ⟨ha, b, hb⟩ },
    { exact or.inr ⟨hb, a, ha⟩ } },
  { rintro (⟨hs, b, hb⟩ | ⟨ht, a, ha⟩),
    { exact ⟨0, b, hs, hb, zero_smul _ _⟩ },
    { exact ⟨a, 0, ha, ht, smul_zero' _ _⟩ } }
end

lemma zero_mem_smul_set_iff (ha : a ≠ 0) : (0 : β) ∈ a • t ↔ (0 : β) ∈ t :=
begin
  refine ⟨_, zero_mem_smul_set⟩,
  rintro ⟨b, hb, h⟩,
  rwa (eq_zero_or_eq_zero_of_smul_eq_zero h).resolve_left ha at hb,
end

end smul_with_zero

section group
variables [group α] [mul_action α β] {s t A B : set β} {a : α} {x : β}

@[simp, to_additive]
lemma smul_mem_smul_set_iff : a • x ∈ a • s ↔ x ∈ s := (mul_action.injective _).mem_set_image

@[to_additive]
lemma mem_smul_set_iff_inv_smul_mem : x ∈ a • A ↔ a⁻¹ • x ∈ A :=
show x ∈ mul_action.to_perm a '' A ↔ _, from mem_image_equiv

@[to_additive]
lemma mem_inv_smul_set_iff : x ∈ a⁻¹ • A ↔ a • x ∈ A :=
by simp only [← image_smul, mem_image, inv_smul_eq_iff, exists_eq_right]

@[to_additive]
lemma preimage_smul (a : α) (t : set β) : (λ x, a • x) ⁻¹' t = a⁻¹ • t :=
((mul_action.to_perm a).symm.image_eq_preimage _).symm

@[to_additive]
lemma preimage_smul_inv (a : α) (t : set β) : (λ x, a⁻¹ • x) ⁻¹' t = a • t :=
preimage_smul (to_units a)⁻¹ t

@[simp, to_additive]
lemma set_smul_subset_set_smul_iff : a • A ⊆ a • B ↔ A ⊆ B :=
image_subset_image_iff $ mul_action.injective _

@[to_additive]
lemma set_smul_subset_iff : a • A ⊆ B ↔ A ⊆ a⁻¹ • B :=
(image_subset_iff).trans $ iff_of_eq $ congr_arg _ $
  preimage_equiv_eq_image_symm _ $ mul_action.to_perm _

@[to_additive]
lemma subset_set_smul_iff : A ⊆ a • B ↔ a⁻¹ • A ⊆ B :=
iff.symm $ (image_subset_iff).trans $ iff.symm $ iff_of_eq $ congr_arg _ $
  image_equiv_eq_preimage_symm _ $ mul_action.to_perm _

end group

section group_with_zero
variables [group_with_zero α] [mul_action α β] {s : set α} {a : α}

@[simp] lemma smul_mem_smul_set_iff₀ (ha : a ≠ 0) (A : set β)
  (x : β) : a • x ∈ a • A ↔ x ∈ A :=
show units.mk0 a ha • _ ∈ _ ↔ _, from smul_mem_smul_set_iff

lemma mem_smul_set_iff_inv_smul_mem₀ (ha : a ≠ 0) (A : set β) (x : β) :
  x ∈ a • A ↔ a⁻¹ • x ∈ A :=
show _ ∈ units.mk0 a ha • _ ↔ _, from mem_smul_set_iff_inv_smul_mem

lemma mem_inv_smul_set_iff₀ (ha : a ≠ 0) (A : set β) (x : β) : x ∈ a⁻¹ • A ↔ a • x ∈ A :=
show _ ∈ (units.mk0 a ha)⁻¹ • _ ↔ _, from mem_inv_smul_set_iff

lemma preimage_smul₀ (ha : a ≠ 0) (t : set β) : (λ x, a • x) ⁻¹' t = a⁻¹ • t :=
preimage_smul (units.mk0 a ha) t

lemma preimage_smul_inv₀ (ha : a ≠ 0) (t : set β) :
  (λ x, a⁻¹ • x) ⁻¹' t = a • t :=
preimage_smul ((units.mk0 a ha)⁻¹) t

@[simp] lemma set_smul_subset_set_smul_iff₀ (ha : a ≠ 0) {A B : set β} :
  a • A ⊆ a • B ↔ A ⊆ B :=
show units.mk0 a ha • _ ⊆ _ ↔ _, from set_smul_subset_set_smul_iff

lemma set_smul_subset_iff₀ (ha : a ≠ 0) {A B : set β} : a • A ⊆ B ↔ A ⊆ a⁻¹ • B :=
show units.mk0 a ha • _ ⊆ _ ↔ _, from set_smul_subset_iff

lemma subset_set_smul_iff₀ (ha : a ≠ 0) {A B : set β} : A ⊆ a • B ↔ a⁻¹ • A ⊆ B :=
show _ ⊆ units.mk0 a ha • _ ↔ _, from subset_set_smul_iff

lemma smul_univ₀ (hs : ¬ s ⊆ 0) : s • (univ : set β) = univ :=
let ⟨a, ha, ha₀⟩ := not_subset.1 hs in eq_univ_of_forall $ λ b,
  ⟨a, a⁻¹ • b, ha, trivial, smul_inv_smul₀ ha₀ _⟩

lemma smul_set_univ₀ (ha : a ≠ 0) : a • (univ : set β) = univ :=
eq_univ_of_forall $ λ b, ⟨a⁻¹ • b, trivial, smul_inv_smul₀ ha _⟩

end group_with_zero

end set

/-! ### Miscellaneous -/

open set
open_locale pointwise

/-! Some lemmas about pointwise multiplication and submonoids. Ideally we put these in
  `group_theory.submonoid.basic`, but currently we cannot because that file is imported by this. -/
namespace submonoid

variables {M : Type*} [monoid M] {s t u : set M}

@[to_additive]
lemma mul_subset {S : submonoid M} (hs : s ⊆ S) (ht : t ⊆ S) : s * t ⊆ S :=
by { rintro _ ⟨p, q, hp, hq, rfl⟩, exact submonoid.mul_mem _ (hs hp) (ht hq) }

@[to_additive]
lemma mul_subset_closure (hs : s ⊆ u) (ht : t ⊆ u) : s * t ⊆ submonoid.closure u :=
mul_subset (subset.trans hs submonoid.subset_closure) (subset.trans ht submonoid.subset_closure)

@[to_additive]
lemma coe_mul_self_eq (s : submonoid M) : (s : set M) * s = s :=
begin
  ext x,
  refine ⟨_, λ h, ⟨x, 1, h, s.one_mem, mul_one x⟩⟩,
  rintro ⟨a, b, ha, hb, rfl⟩,
  exact s.mul_mem ha hb
end

@[to_additive]
lemma closure_mul_le (S T : set M) : closure (S * T) ≤ closure S ⊔ closure T :=
Inf_le $ λ x ⟨s, t, hs, ht, hx⟩, hx ▸ (closure S ⊔ closure T).mul_mem
    (set_like.le_def.mp le_sup_left $ subset_closure hs)
    (set_like.le_def.mp le_sup_right $ subset_closure ht)

@[to_additive]
lemma sup_eq_closure (H K : submonoid M) : H ⊔ K = closure (H * K) :=
le_antisymm
  (sup_le
    (λ h hh, subset_closure ⟨h, 1, hh, K.one_mem, mul_one h⟩)
    (λ k hk, subset_closure ⟨1, k, H.one_mem, hk, one_mul k⟩))
  (by conv_rhs { rw [← closure_eq H, ← closure_eq K] }; apply closure_mul_le)

lemma pow_smul_mem_closure_smul {N : Type*} [comm_monoid N] [mul_action M N]
  [is_scalar_tower M N N] (r : M) (s : set N) {x : N} (hx : x ∈ closure s) :
  ∃ n : ℕ, r ^ n • x ∈ closure (r • s) :=
begin
  apply @closure_induction N _ s
    (λ (x : N), ∃ n : ℕ, r ^ n • x ∈ closure (r • s)) _ hx,
  { intros x hx,
    exact ⟨1, subset_closure ⟨_, hx, by rw pow_one⟩⟩ },
  { exact ⟨0, by simpa using one_mem _⟩ },
  { rintro x y ⟨nx, hx⟩ ⟨ny, hy⟩,
    use nx + ny,
    convert mul_mem hx hy,
    rw [pow_add, smul_mul_assoc, mul_smul, mul_comm, ← smul_mul_assoc, mul_comm] }
end

end submonoid

namespace group

lemma card_pow_eq_card_pow_card_univ_aux {f : ℕ → ℕ} (h1 : monotone f)
  {B : ℕ} (h2 : ∀ n, f n ≤ B) (h3 : ∀ n, f n = f (n + 1) → f (n + 1) = f (n + 2)) :
  ∀ k, B ≤ k → f k = f B :=
begin
  have key : ∃ n : ℕ, n ≤ B ∧ f n = f (n + 1),
  { contrapose! h2,
    suffices : ∀ n : ℕ, n ≤ B + 1 → n ≤ f n,
    { exact ⟨B + 1, this (B + 1) (le_refl (B + 1))⟩ },
    exact λ n, nat.rec (λ h, nat.zero_le (f 0)) (λ n ih h, lt_of_le_of_lt (ih (n.le_succ.trans h))
      (lt_of_le_of_ne (h1 n.le_succ) (h2 n (nat.succ_le_succ_iff.mp h)))) n },
  { obtain ⟨n, hn1, hn2⟩ := key,
    replace key : ∀ k : ℕ, f (n + k) = f (n + k + 1) ∧ f (n + k) = f n :=
    λ k, nat.rec ⟨hn2, rfl⟩ (λ k ih, ⟨h3 _ ih.1, ih.1.symm.trans ih.2⟩) k,
    replace key : ∀ k : ℕ, n ≤ k → f k = f n :=
    λ k hk, (congr_arg f (add_tsub_cancel_of_le hk)).symm.trans (key (k - n)).2,
    exact λ k hk, (key k (hn1.trans hk)).trans (key B hn1).symm },
end

variables {G : Type*} [group G] [fintype G] (S : set G)

@[to_additive]
lemma card_pow_eq_card_pow_card_univ [∀ (k : ℕ), decidable_pred (∈ (S ^ k))] :
  ∀ k, fintype.card G ≤ k → fintype.card ↥(S ^ k) = fintype.card ↥(S ^ (fintype.card G)) :=
begin
  have hG : 0 < fintype.card G := fintype.card_pos_iff.mpr ⟨1⟩,
  by_cases hS : S = ∅,
  { refine λ k hk, fintype.card_congr _,
    rw [hS, empty_pow (ne_of_gt (lt_of_lt_of_le hG hk)), empty_pow (ne_of_gt hG)] },
  obtain ⟨a, ha⟩ := set.ne_empty_iff_nonempty.mp hS,
  classical!,
  have key : ∀ a (s t : set G), (∀ b : G, b ∈ s → a * b ∈ t) → fintype.card s ≤ fintype.card t,
  { refine λ a s t h, fintype.card_le_of_injective (λ ⟨b, hb⟩, ⟨a * b, h b hb⟩) _,
    rintro ⟨b, hb⟩ ⟨c, hc⟩ hbc,
    exact subtype.ext (mul_left_cancel (subtype.ext_iff.mp hbc)) },
  have mono : monotone (λ n, fintype.card ↥(S ^ n) : ℕ → ℕ) :=
  monotone_nat_of_le_succ (λ n, key a _ _ (λ b hb, set.mul_mem_mul ha hb)),
  convert card_pow_eq_card_pow_card_univ_aux mono (λ n, set_fintype_card_le_univ (S ^ n))
    (λ n h, le_antisymm (mono (n + 1).le_succ) (key a⁻¹ _ _ _)),
  { simp only [finset.filter_congr_decidable, fintype.card_of_finset] },
  replace h : {a} * S ^ n = S ^ (n + 1),
  { refine set.eq_of_subset_of_card_le _ (le_trans (ge_of_eq h) _),
    { exact mul_subset_mul (set.singleton_subset_iff.mpr ha) set.subset.rfl },
    { convert key a (S ^ n) ({a} * S ^ n) (λ b hb, set.mul_mem_mul (set.mem_singleton a) hb) } },
  rw [pow_succ', ←h, mul_assoc, ←pow_succ', h],
  rintro _ ⟨b, c, hb, hc, rfl⟩,
  rwa [set.mem_singleton_iff.mp hb, inv_mul_cancel_left],
end

end group


<|start_filename|>src/topology/algebra/order/archimedean.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import topology.algebra.order.basic
import algebra.order.archimedean

/-!
# Rational numbers are dense in a linear ordered archimedean field

In this file we prove that coercion from `ℚ` to a linear ordered archimedean field has dense range.
This lemma is in a separate file because `topology.algebra.order.basic` does not import
`algebra.order.archimedean`.
-/

variables {𝕜 : Type*} [linear_ordered_field 𝕜] [topological_space 𝕜] [order_topology 𝕜]
  [archimedean 𝕜]

/-- Rational numbers are dense in a linear ordered archimedean field. -/
lemma rat.dense_range_cast : dense_range (coe : ℚ → 𝕜) :=
dense_of_exists_between $ λ a b h, set.exists_range_iff.2 $ exists_rat_btwn h


<|start_filename|>src/category_theory/limits/shapes/comm_sq.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.limits.preserves.shapes.pullbacks
import category_theory.limits.shapes.zero_morphisms
import category_theory.limits.constructions.binary_products

/-!
# Pullback and pushout squares

We provide another API for pullbacks and pushouts.

`is_pullback fst snd f g` is the proposition that
```
  P --fst--> X
  |          |
 snd         f
  |          |
  v          v
  Y ---g---> Z

```
is a pullback square.

(And similarly for `is_pushout`.)

We provide the glue to go back and forth to the usual `is_limit` API for pullbacks, and prove
`is_pullback (pullback.fst : pullback f g ⟶ X) (pullback.snd : pullback f g ⟶ Y) f g`
for the usual `pullback f g` provided by the `has_limit` API.

We don't attempt to restate everything we know about pullbacks in this language,
but do restate the pasting lemmas.

## Future work
Bicartesian squares, and
show that the pullback and pushout squares for a biproduct are bicartesian.
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v₁ v₂ u₁ u₂

namespace category_theory

variables {C : Type u₁} [category.{v₁} C]

/-- The proposition that a square
```
  W ---f---> X
  |          |
  g          h
  |          |
  v          v
  Y ---i---> Z

```
is a commuting square.
-/
structure comm_sq {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (i : Y ⟶ Z) : Prop :=
(w : f ≫ h = g ≫ i)

attribute [reassoc] comm_sq.w

namespace comm_sq

variables {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

lemma flip (p : comm_sq f g h i) : comm_sq g f i h := ⟨p.w.symm⟩

lemma of_arrow {f g : arrow C} (h : f ⟶ g) : comm_sq f.hom h.left h.right g.hom := ⟨h.w.symm⟩

/--
The (not necessarily limiting) `pullback_cone h i` implicit in the statement
that we have `comm_sq f g h i`.
-/
def cone (s : comm_sq f g h i) : pullback_cone h i := pullback_cone.mk _ _ s.w

/--
The (not necessarily limiting) `pushout_cocone f g` implicit in the statement
that we have `comm_sq f g h i`.
-/
def cocone (s : comm_sq f g h i) : pushout_cocone f g := pushout_cocone.mk _ _ s.w

end comm_sq

/-- The proposition that a square
```
  P --fst--> X
  |          |
 snd         f
  |          |
  v          v
  Y ---g---> Z

```
is a pullback square.
-/
structure is_pullback
  {P X Y Z : C} (fst : P ⟶ X) (snd : P ⟶ Y) (f : X ⟶ Z) (g : Y ⟶ Z)
  extends comm_sq fst snd f g : Prop :=
(is_limit' : nonempty (is_limit (pullback_cone.mk _ _ w)))

/-- The proposition that a square
```
  Z ---f---> X
  |          |
  g         inl
  |          |
  v          v
  Y --inr--> P

```
is a pushout square.
-/
structure is_pushout
  {Z X Y P : C} (f : Z ⟶ X) (g : Z ⟶ Y) (inl : X ⟶ P) (inr : Y ⟶ P)
  extends comm_sq f g inl inr : Prop :=
(is_colimit' : nonempty (is_colimit (pushout_cocone.mk _ _ w)))

/-!
We begin by providing some glue between `is_pullback` and the `is_limit` and `has_limit` APIs.
(And similarly for `is_pushout`.)
-/

namespace is_pullback

variables {P X Y Z : C} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z}

/--
The (limiting) `pullback_cone f g` implicit in the statement
that we have a `is_pullback fst snd f g`.
-/
def cone (h : is_pullback fst snd f g) : pullback_cone f g := h.to_comm_sq.cone

/--
The cone obtained from `is_pullback fst snd f g` is a limit cone.
-/
noncomputable def is_limit (h : is_pullback fst snd f g) : is_limit h.cone :=
h.is_limit'.some

/-- If `c` is a limiting pullback cone, then we have a `is_pullback c.fst c.snd f g`. -/
lemma of_is_limit {c : pullback_cone f g} (h : limits.is_limit c) :
  is_pullback c.fst c.snd f g :=
{ w := c.condition,
  is_limit' := ⟨is_limit.of_iso_limit h
    (limits.pullback_cone.ext (iso.refl _) (by tidy) (by tidy))⟩, }

/-- A variant of `of_is_limit` that is more useful with `apply`. -/
lemma of_is_limit' (w : comm_sq fst snd f g) (h : limits.is_limit w.cone) :
  is_pullback fst snd f g :=
of_is_limit h

/-- The pullback provided by `has_pullback f g` fits into a `is_pullback`. -/
lemma of_has_pullback (f : X ⟶ Z) (g : Y ⟶ Z) [has_pullback f g] :
  is_pullback (pullback.fst : pullback f g ⟶ X) (pullback.snd : pullback f g ⟶ Y) f g :=
of_is_limit (limit.is_limit (cospan f g))

/-- If `c` is a limiting binary product cone, and we have a terminal object,
then we have `is_pullback c.fst c.snd 0 0`
(where each `0` is the unique morphism to the terminal object). -/
lemma of_is_product {c : binary_fan X Y} (h : limits.is_limit c) (t : is_terminal Z) :
  is_pullback c.fst c.snd (t.from _) (t.from _) :=
of_is_limit (is_pullback_of_is_terminal_is_product _ _ _ _ t
  (is_limit.of_iso_limit h (limits.cones.ext (iso.refl c.X) (by rintro ⟨⟨⟩⟩; { dsimp, simp, }))))

variables (X Y)

lemma of_has_binary_product' [has_binary_product X Y] [has_terminal C] :
  is_pullback limits.prod.fst limits.prod.snd (terminal.from X) (terminal.from Y) :=
of_is_product (limit.is_limit _) terminal_is_terminal

open_locale zero_object

lemma of_has_binary_product [has_binary_product X Y] [has_zero_object C] [has_zero_morphisms C] :
  is_pullback limits.prod.fst limits.prod.snd (0 : X ⟶ 0) (0 : Y ⟶ 0) :=
by convert of_is_product (limit.is_limit _) has_zero_object.zero_is_terminal

variables {X Y}

/-- Any object at the top left of a pullback square is
isomorphic to the pullback provided by the `has_limit` API. -/
noncomputable
def iso_pullback (h : is_pullback fst snd f g) [has_pullback f g] : P ≅ pullback f g :=
(limit.iso_limit_cone ⟨_, h.is_limit⟩).symm

@[simp] lemma iso_pullback_hom_fst (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.hom ≫ pullback.fst = fst :=
by { dsimp [iso_pullback, cone, comm_sq.cone], simp, }
@[simp] lemma iso_pullback_hom_snd (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.hom ≫ pullback.snd = snd :=
by { dsimp [iso_pullback, cone, comm_sq.cone], simp, }
@[simp] lemma iso_pullback_inv_fst (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.inv ≫ fst = pullback.fst :=
by simp [iso.inv_comp_eq]
@[simp] lemma iso_pullback_inv_snd (h : is_pullback fst snd f g) [has_pullback f g] :
  h.iso_pullback.inv ≫ snd = pullback.snd :=
by simp [iso.inv_comp_eq]

lemma of_iso_pullback (h : comm_sq fst snd f g) [has_pullback f g] (i : P ≅ pullback f g)
  (w₁ : i.hom ≫ pullback.fst = fst) (w₂ : i.hom ≫ pullback.snd = snd) : is_pullback fst snd f g :=
of_is_limit' h (limits.is_limit.of_iso_limit (limit.is_limit _)
  (@pullback_cone.ext _ _ _ _ _ _ _ (pullback_cone.mk _ _ _) _ i w₁.symm w₂.symm).symm)

end is_pullback

namespace is_pushout

variables {Z X Y P : C} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}

/--
The (colimiting) `pushout_cocone f g` implicit in the statement
that we have a `is_pushout f g inl inr`.
-/
def cocone (h : is_pushout f g inl inr) : pushout_cocone f g := h.to_comm_sq.cocone

/--
The cocone obtained from `is_pushout f g inl inr` is a colimit cocone.
-/
noncomputable def is_colimit (h : is_pushout f g inl inr) : is_colimit h.cocone :=
h.is_colimit'.some

/-- If `c` is a colimiting pushout cocone, then we have a `is_pushout f g c.inl c.inr`. -/
lemma of_is_colimit {c : pushout_cocone f g} (h : limits.is_colimit c) :
  is_pushout f g c.inl c.inr :=
{ w := c.condition,
  is_colimit' := ⟨is_colimit.of_iso_colimit h
    (limits.pushout_cocone.ext (iso.refl _) (by tidy) (by tidy))⟩, }

/-- A variant of `of_is_colimit` that is more useful with `apply`. -/
lemma of_is_colimit' (w : comm_sq f g inl inr) (h : limits.is_colimit w.cocone) :
  is_pushout f g inl inr :=
of_is_colimit h

/-- The pushout provided by `has_pushout f g` fits into a `is_pushout`. -/
lemma of_has_pushout (f : Z ⟶ X) (g : Z ⟶ Y) [has_pushout f g] :
  is_pushout f g (pushout.inl : X ⟶ pushout f g) (pushout.inr : Y ⟶ pushout f g) :=
of_is_colimit (colimit.is_colimit (span f g))

/-- If `c` is a colimiting binary coproduct cocone, and we have an initial object,
then we have `is_pushout 0 0 c.inl c.inr`
(where each `0` is the unique morphism from the initial object). -/
lemma of_is_coproduct {c : binary_cofan X Y} (h : limits.is_colimit c) (t : is_initial Z) :
  is_pushout (t.to _) (t.to _) c.inl c.inr :=
of_is_colimit (is_pushout_of_is_initial_is_coproduct _ _ _ _ t
  (is_colimit.of_iso_colimit h
    (limits.cocones.ext (iso.refl c.X) (by rintro ⟨⟨⟩⟩; { dsimp, simp, }))))

variables (X Y)

lemma of_has_binary_coproduct' [has_binary_coproduct X Y] [has_initial C] :
  is_pushout (initial.to _) (initial.to _) (coprod.inl : X ⟶ _) (coprod.inr : Y ⟶ _)  :=
of_is_coproduct (colimit.is_colimit _) initial_is_initial

open_locale zero_object

lemma of_has_binary_coproduct
  [has_binary_coproduct X Y] [has_zero_object C] [has_zero_morphisms C] :
  is_pushout (0 : 0 ⟶ X) (0 : 0 ⟶ Y) coprod.inl coprod.inr :=
by convert of_is_coproduct (colimit.is_colimit _) has_zero_object.zero_is_initial

variables {X Y}

/-- Any object at the top left of a pullback square is
isomorphic to the pullback provided by the `has_limit` API. -/
noncomputable
def iso_pushout (h : is_pushout f g inl inr) [has_pushout f g] : P ≅ pushout f g :=
(colimit.iso_colimit_cocone ⟨_, h.is_colimit⟩).symm

@[simp] lemma inl_iso_pushout_inv (h : is_pushout f g inl inr) [has_pushout f g] :
  pushout.inl ≫ h.iso_pushout.inv = inl :=
by { dsimp [iso_pushout, cocone, comm_sq.cocone], simp, }
@[simp] lemma inr_iso_pushout_inv (h : is_pushout f g inl inr) [has_pushout f g] :
  pushout.inr ≫ h.iso_pushout.inv = inr :=
by { dsimp [iso_pushout, cocone, comm_sq.cocone], simp, }
@[simp] lemma inl_iso_pushout_hom (h : is_pushout f g inl inr) [has_pushout f g] :
  inl ≫ h.iso_pushout.hom = pushout.inl :=
by simp [←iso.eq_comp_inv]
@[simp] lemma inr_iso_pushout_hom (h : is_pushout f g inl inr) [has_pushout f g] :
  inr ≫ h.iso_pushout.hom = pushout.inr :=
by simp [←iso.eq_comp_inv]

lemma of_iso_pushout (h : comm_sq f g inl inr) [has_pushout f g] (i : P ≅ pushout f g)
  (w₁ : inl ≫ i.hom = pushout.inl) (w₂ : inr ≫ i.hom = pushout.inr) : is_pushout f g inl inr :=
of_is_colimit' h (limits.is_colimit.of_iso_colimit (colimit.is_colimit _)
  (@pushout_cocone.ext _ _ _ _ _ _ _ (pushout_cocone.mk _ _ _) _ i w₁ w₂).symm)

end is_pushout

namespace is_pullback

variables {P X Y Z : C} {fst : P ⟶ X} {snd : P ⟶ Y} {f : X ⟶ Z} {g : Y ⟶ Z}

lemma flip (h : is_pullback fst snd f g) : is_pullback snd fst g f :=
of_is_limit (@pullback_cone.flip_is_limit _ _ _ _ _ _ _ _ _ _ h.w.symm h.is_limit)

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

/-- The square with `0 : 0 ⟶ 0` on the left and `𝟙 X` on the right is a pullback square. -/
lemma zero_left (X : C) : is_pullback (0 : 0 ⟶ X) (0 : 0 ⟶ 0) (𝟙 X) (0 : 0 ⟶ X) :=
{ w := by simp,
  is_limit' :=
  ⟨{ lift := λ s, 0,
     fac' := λ s, by simpa using @pullback_cone.equalizer_ext _ _ _ _ _ _ _ s _ 0 (𝟙 _)
       (by simpa using (pullback_cone.condition s).symm), }⟩ }

/-- The square with `0 : 0 ⟶ 0` on the top and `𝟙 X` on the bottom is a pullback square. -/
lemma zero_top (X : C) : is_pullback (0 : 0 ⟶ 0) (0 : 0 ⟶ X) (0 : 0 ⟶ X) (𝟙 X) :=
(zero_left X).flip

end

/-- Paste two pullback squares "vertically" to obtain another pullback square. -/
-- Objects here are arranged in a 3x2 grid, and indexed by their xy coordinates.
-- Morphisms are named `hᵢⱼ` for a horizontal morphism starting at `(i,j)`,
-- and `vᵢⱼ` for a vertical morphism starting at `(i,j)`.
lemma paste_vert {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pullback h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pullback h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pullback h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ :=
(of_is_limit
  (big_square_is_pullback _ _ _ _ _ _ _ s.w t.w t.is_limit s.is_limit))

/-- Paste two pullback squares "horizontally" to obtain another pullback square. -/
lemma paste_horiz {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pullback h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pullback h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pullback (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) :=
(paste_vert s.flip t.flip).flip

/-- Given a pullback square assembled from a commuting square on the top and
a pullback square on the bottom, the top square is a pullback square. -/
lemma of_bot {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pullback h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁) (p : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁)
  (t : is_pullback h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
of_is_limit (left_square_is_pullback _ _ _ _ _ _ _ p _ t.is_limit s.is_limit)

/-- Given a pullback square assembled from a commuting square on the left and
a pullback square on the right, the left square is a pullback square. -/
lemma of_right {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pullback (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂)) (p : h₁₁ ≫ v₁₂ = v₁₁ ≫ h₂₁)
  (t : is_pullback h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pullback h₁₁ v₁₁ v₁₂ h₂₁ :=
(of_bot s.flip p.symm t.flip).flip

end is_pullback

namespace is_pushout

variables {Z X Y P : C} {f : Z ⟶ X} {g : Z ⟶ Y} {inl : X ⟶ P} {inr : Y ⟶ P}

lemma flip (h : is_pushout f g inl inr) : is_pushout g f inr inl :=
of_is_colimit (@pushout_cocone.flip_is_colimit _ _ _ _ _ _ _ _ _ _ h.w.symm h.is_colimit)

section

variables [has_zero_object C] [has_zero_morphisms C]
open_locale zero_object

/-- The square with `0 : 0 ⟶ 0` on the right and `𝟙 X` on the left is a pushout square. -/
lemma zero_right (X : C) : is_pushout (0 : X ⟶ 0) (𝟙 X) (0 : 0 ⟶ 0) (0 : X ⟶ 0) :=
{ w := by simp,
  is_colimit' :=
  ⟨{ desc := λ s, 0,
     fac' := λ s, begin
       have c := @pushout_cocone.coequalizer_ext _ _ _ _ _ _ _ s _ 0 (𝟙 _) (by simp)
         (by simpa using (pushout_cocone.condition s)),
      dsimp at c,
      simpa using c,
     end }⟩ }

/-- The square with `0 : 0 ⟶ 0` on the bottom and `𝟙 X` on the top is a pushout square. -/
lemma zero_bot (X : C) : is_pushout (𝟙 X) (0 : X ⟶ 0) (0 : X ⟶ 0) (0 : 0 ⟶ 0) :=
(zero_right X).flip

end

/-- Paste two pushout squares "vertically" to obtain another pushout square. -/
-- Objects here are arranged in a 3x2 grid, and indexed by their xy coordinates.
-- Morphisms are named `hᵢⱼ` for a horizontal morphism starting at `(i,j)`,
-- and `vᵢⱼ` for a vertical morphism starting at `(i,j)`.
lemma paste_vert {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pushout h₂₁ v₂₁ v₂₂ h₃₁) :
  is_pushout h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁ :=
(of_is_colimit
  (big_square_is_pushout _ _ _ _ _ _ _ s.w t.w t.is_colimit s.is_colimit))

/-- Paste two pushout squares "horizontally" to obtain another pushout square. -/
lemma paste_horiz {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) (t : is_pushout h₁₂ v₁₂ v₁₃ h₂₂) :
  is_pushout (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂) :=
(paste_vert s.flip t.flip).flip

/-- Given a pushout square assembled from a pushout square on the top and
a commuting square on the bottom, the bottom square is a pushout square. -/
lemma of_bot {X₁₁ X₁₂ X₂₁ X₂₂ X₃₁ X₃₂ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₂₁ : X₂₁ ⟶ X₂₂} {h₃₁ : X₃₁ ⟶ X₃₂}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₂₁ : X₂₁ ⟶ X₃₁} {v₂₂ : X₂₂ ⟶ X₃₂}
  (s : is_pushout h₁₁ (v₁₁ ≫ v₂₁) (v₁₂ ≫ v₂₂) h₃₁) (p : h₂₁ ≫ v₂₂ = v₂₁ ≫ h₃₁)
  (t : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) :
  is_pushout h₂₁ v₂₁ v₂₂ h₃₁ :=
of_is_colimit (right_square_is_pushout _ _ _ _ _ _ _ _ p t.is_colimit s.is_colimit)

/-- Given a pushout square assembled from a pushout square on the left and
a commuting square on the right, the right square is a pushout square. -/
lemma of_right {X₁₁ X₁₂ X₁₃ X₂₁ X₂₂ X₂₃ : C}
  {h₁₁ : X₁₁ ⟶ X₁₂} {h₁₂ : X₁₂ ⟶ X₁₃} {h₂₁ : X₂₁ ⟶ X₂₂} {h₂₂ : X₂₂ ⟶ X₂₃}
  {v₁₁ : X₁₁ ⟶ X₂₁} {v₁₂ : X₁₂ ⟶ X₂₂} {v₁₃ : X₁₃ ⟶ X₂₃}
  (s : is_pushout (h₁₁ ≫ h₁₂) v₁₁ v₁₃ (h₂₁ ≫ h₂₂)) (p : h₁₂ ≫ v₁₃ = v₁₂ ≫ h₂₂)
  (t : is_pushout h₁₁ v₁₁ v₁₂ h₂₁) :
  is_pushout h₁₂ v₁₂ v₁₃ h₂₂ :=
(of_bot s.flip p.symm t.flip).flip

end is_pushout

namespace functor

variables {D : Type u₂} [category.{v₂} D]
variables (F : C ⥤ D) {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {i : Y ⟶ Z}

lemma map_comm_sq (s : comm_sq f g h i) : comm_sq (F.map f) (F.map g) (F.map h) (F.map i) :=
⟨by simpa using congr_arg (λ k : W ⟶ Z, F.map k) s.w⟩

lemma map_is_pullback [preserves_limit (cospan h i) F] (s : is_pullback f g h i) :
  is_pullback (F.map f) (F.map g) (F.map h) (F.map i) :=
-- This is made slightly awkward because `C` and `D` have different universes,
-- and so the relevant `walking_cospan` diagrams live in different universes too!
begin
  refine is_pullback.of_is_limit' (F.map_comm_sq s.to_comm_sq)
    (is_limit.of_whisker_equivalence walking_cospan_equiv
      (is_limit.equiv_of_nat_iso_of_iso (cospan_comp_iso F h i) _ _ (walking_cospan.ext _ _ _)
        (is_limit_of_preserves F s.is_limit))),
  { refl, },
  { dsimp, simp, refl, },
  { dsimp, simp, refl, },
end

lemma map_is_pushout [preserves_colimit (span f g) F] (s : is_pushout f g h i) :
  is_pushout (F.map f) (F.map g) (F.map h) (F.map i) :=
begin
  refine is_pushout.of_is_colimit' (F.map_comm_sq s.to_comm_sq)
    (is_colimit.of_whisker_equivalence walking_span_equiv
      (is_colimit.equiv_of_nat_iso_of_iso (span_comp_iso F f g) _ _ (walking_span.ext _ _ _)
        (is_colimit_of_preserves F s.is_colimit))),
  { refl, },
  { dsimp, simp, refl, },
  { dsimp, simp, refl, },
end

end functor

alias functor.map_comm_sq ← comm_sq.map
alias functor.map_is_pullback ← is_pullback.map
alias functor.map_is_pushout ← is_pushout.map

end category_theory


<|start_filename|>src/analysis/convolution.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.group.integration
import measure_theory.group.prod
import measure_theory.function.locally_integrable
import analysis.calculus.specific_functions
import analysis.calculus.parametric_integral

/-!
# Convolution of functions

This file defines the convolution on two functions, i.e. `x ↦ ∫ f(t)g(x - t) ∂t`.
In the general case, these functions can be vector-valued, and have an arbitrary (additive)
group as domain. We use a continuous bilinear operation `L` on these function values as
"multiplication". The domain must be equipped with a Haar measure `μ`
(though many individual results have weaker conditions on `μ`).

For many applications we can take `L = lsmul ℝ ℝ` or `L = lmul ℝ ℝ`.

We also define `convolution_exists` and `convolution_exists_at` to state that the convolution is
well-defined (everywhere or at a single point). These conditions are needed for pointwise
computations (e.g. `convolution_exists_at.distrib_add`), but are generally not stong enough for any
local (or global) properties of the convolution. For this we need stronger assumptions on `f`
and/or `g`, and generally if we impose stronger conditions on one of the functions, we can impose
weaker conditions on the other.
We have proven many of the properties of the convolution assuming one of these functions
has compact support (in which case the other function only needs to be locally integrable).
We still need to prove the properties for other pairs of conditions (e.g. both functions are
rapidly decreasing)

# Design Decisions

We use a bilinear map `L` to "multiply" the two functions in the integrand.
This generality has several advantages

* This allows us to compute the total derivative of the convolution, in case the functions are
  multivariate. The total derivative is again a convolution, but where the codomains of the
  functions can be higher-dimensional. See `has_compact_support.has_fderiv_at_convolution_right`.
* This allows us to use `@[to_additive]` everywhere (which would not be possible if we would use
  `mul`/`smul` in the integral, since `@[to_additive]` will incorrectly also try to additivize
  those definitions).
* We need to support the case where at least one of the functions is vector-valued, but if we use
  `smul` to multiply the functions, that would be an asymmetric definition.

# Main Definitions
* `convolution f g L μ x = (f ⋆[L, μ] g) x = ∫ t, L (f t) (g (x - t)) ∂μ` is the convolution of
  `f` and `g` w.r.t. the continuous bilinear map `L` and measure `μ`.
* `convolution_exists_at f g x L μ` states that the convolution `(f ⋆[L, μ] g) x` is well-defined
  (i.e. the integral exists).
* `convolution_exists f g L μ` states that the convolution `f ⋆[L, μ] g` is well-defined at each
  point.

# Main Results
* `has_compact_support.has_fderiv_at_convolution_right` and
  `has_compact_support.has_fderiv_at_convolution_left`: we can compute the total derivative
  of the convolution as a convolution with the total derivative of the right (left) function.
* `has_compact_support.cont_diff_convolution_right` and
  `has_compact_support.cont_diff_convolution_left`: the convolution is `𝒞ⁿ` if one of the functions
  is `𝒞ⁿ` with compact support and the other function in locally integrable.
* `convolution_tendsto_right`: Given a sequence of nonnegative normalized functions whose support
  tends to a small neighborhood around `0`, the convolution tends to the right argument.
  This is specialized to bump functions in `cont_diff_bump_of_inner.convolution_tendsto_right`.

# Notation
The following notations are localized in the locale `convolution`:
* `f ⋆[L, μ] g` for the convolution. Note: you have to use parentheses to apply the convolution
  to an argument: `(f ⋆[L, μ] g) x`.
* `f ⋆[L] g := f ⋆[L, volume] g`
* `f ⋆ g := f ⋆[lsmul ℝ ℝ] g`

# To do
* Prove properties about the convolution if both functions are rapidly decreasing.
* Use `@[to_additive]` everywhere
-/

open set function filter measure_theory measure_theory.measure topological_space
open continuous_linear_map metric
open_locale pointwise topological_space nnreal

variables {𝕜 G E E' E'' F F' F'' : Type*}
variables [normed_group E] [normed_group E'] [normed_group E''] [normed_group F]
variables {f f' : G → E} {g g' : G → E'} {x x' : G} {y y' : E}

section nondiscrete_normed_field

variables [nondiscrete_normed_field 𝕜]
variables [normed_space 𝕜 E] [normed_space 𝕜 E'] [normed_space 𝕜 E''] [normed_space 𝕜 F]
variables (L : E →L[𝕜] E' →L[𝕜] F)

section no_measurability

variables [add_group G] [topological_space G]

lemma has_compact_support.convolution_integrand_bound_right (hcg : has_compact_support g)
  (hg : continuous g) {x t : G} {s : set G} (hx : x ∈ s) :
  ∥L (f t) (g (x - t))∥ ≤ (- tsupport g + s).indicator (λ t, ∥L∥ * ∥f t∥ * (⨆ i, ∥g i∥)) t :=
begin
  refine le_indicator (λ t ht, _) (λ t ht, _) t,
  { refine (L.le_op_norm₂ _ _).trans _,
    exact mul_le_mul_of_nonneg_left
        (le_csupr (hg.norm.bdd_above_range_of_has_compact_support hcg.norm) $ x - t)
        (mul_nonneg (norm_nonneg _) (norm_nonneg _)) },
  { have : x - t ∉ support g,
    { refine mt (λ hxt, _) ht, refine ⟨_, _, set.neg_mem_neg.mpr (subset_closure hxt), hx, _⟩,
      rw [neg_sub, sub_add_cancel] },
    rw [nmem_support.mp this, (L _).map_zero, norm_zero] }
end

lemma continuous.convolution_integrand_fst [has_continuous_sub G] (hg : continuous g) (t : G) :
  continuous (λ x, L (f t) (g (x - t))) :=
L.continuous₂.comp₂ continuous_const $ hg.comp $ continuous_id.sub continuous_const

lemma has_compact_support.convolution_integrand_bound_left (hcf : has_compact_support f)
  (hf : continuous f) {x t : G} {s : set G} (hx : x ∈ s) :
  ∥L (f (x - t)) (g t)∥ ≤ (- tsupport f + s).indicator (λ t, ∥L∥ * (⨆ i, ∥f i∥) * ∥g t∥) t :=
by { convert hcf.convolution_integrand_bound_right L.flip hf hx,
  simp_rw [L.op_norm_flip, mul_right_comm] }

end no_measurability

section measurability

variables [measurable_space G] {μ : measure G}

/-- The convolution of `f` and `g` exists at `x` when the function `t ↦ L (f t) (g (x - t))` is
integrable. There are various conditions on `f` and `g` to prove this. -/
def convolution_exists_at [has_sub G] (f : G → E) (g : G → E') (x : G) (L : E →L[𝕜] E' →L[𝕜] F)
  (μ : measure G . volume_tac) : Prop :=
integrable (λ t, L (f t) (g (x - t))) μ

/-- The convolution of `f` and `g` exists when the function `t ↦ L (f t) (g (x - t))` is integrable
for all `x : G`. There are various conditions on `f` and `g` to prove this. -/
def convolution_exists [has_sub G] (f : G → E) (g : G → E') (L : E →L[𝕜] E' →L[𝕜] F)
  (μ : measure G . volume_tac) : Prop :=
∀ x : G, convolution_exists_at f g x L μ

section convolution_exists

variables {L}
lemma convolution_exists_at.integrable [has_sub G] {x : G} (h : convolution_exists_at f g x L μ) :
  integrable (λ t, L (f t) (g (x - t))) μ :=
h

variables (L)

section group

variables [add_group G]
variables [has_measurable_add₂ G] [has_measurable_neg G]

lemma measure_theory.ae_strongly_measurable.convolution_integrand' [sigma_finite μ]
  (hf : ae_strongly_measurable f μ)
  (hg : ae_strongly_measurable g $ map (λ (p : G × G), p.1 - p.2) (μ.prod μ)) :
  ae_strongly_measurable (λ p : G × G, L (f p.2) (g (p.1 - p.2))) (μ.prod μ) :=
L.ae_strongly_measurable_comp₂ hf.snd $ hg.comp_measurable $ measurable_fst.sub measurable_snd

lemma measure_theory.ae_strongly_measurable.convolution_integrand_snd'
  (hf : ae_strongly_measurable f μ) {x : G}
  (hg : ae_strongly_measurable g $ map (λ t, x - t) μ) :
  ae_strongly_measurable (λ t, L (f t) (g (x - t))) μ :=
L.ae_strongly_measurable_comp₂ hf $ hg.comp_measurable $ measurable_id.const_sub x

lemma measure_theory.ae_strongly_measurable.convolution_integrand_swap_snd'
  {x : G} (hf : ae_strongly_measurable f $ map (λ t, x - t) μ)
  (hg : ae_strongly_measurable g μ) : ae_strongly_measurable (λ t, L (f (x - t)) (g t)) μ :=
L.ae_strongly_measurable_comp₂ (hf.comp_measurable $ measurable_id.const_sub x) hg

/-- A sufficient condition to prove that `f ⋆[L, μ] g` exists.
We assume that the integrand has compact support and `g` is bounded on this support (note that
both properties hold if `g` is continuous with compact support). We also require that `f` is
integrable on the support of the integrand, and that both functions are strongly measurable.

Note: we could weaken the measurability condition to hold only for `μ.restrict s`. -/
lemma bdd_above.convolution_exists_at' {x₀ : G}
  {s : set G} (hbg : bdd_above ((λ i, ∥g i∥) '' ((λ t, - t + x₀) ⁻¹' s)))
  (hs : measurable_set s) (h2s : support (λ t, L (f t) (g (x₀ - t))) ⊆ s)
  (hf : integrable_on f s μ)
  (hmf : ae_strongly_measurable f μ)
  (hmg : ae_strongly_measurable g $ map (λ t, x₀ - t) μ) :
    convolution_exists_at f g x₀ L μ :=
begin
  set s' := (λ t, - t + x₀) ⁻¹' s,
  have : ∀ᵐ (t : G) ∂μ,
    ∥L (f t) (g (x₀ - t))∥ ≤ s.indicator (λ t, ∥L∥ * ∥f t∥ * ⨆ i : s', ∥g i∥) t,
  { refine eventually_of_forall _,
    refine le_indicator (λ t ht, _) (λ t ht, _),
    { refine (L.le_op_norm₂ _ _).trans _,
      refine mul_le_mul_of_nonneg_left
        (le_csupr_set hbg $ mem_preimage.mpr _)
        (mul_nonneg (norm_nonneg _) (norm_nonneg _)),
      rwa [neg_sub, sub_add_cancel] },
    { have : t ∉ support (λ t, L (f t) (g (x₀ - t))) := mt (λ h, h2s h) ht,
      rw [nmem_support.mp this, norm_zero] } },
  refine integrable.mono' _ _ this,
  { rw [integrable_indicator_iff hs], exact (hf.norm.const_mul _).mul_const _ },
  { exact hmf.convolution_integrand_snd' L hmg }
end

section left
variables [sigma_finite μ] [is_add_left_invariant μ]

lemma measure_theory.ae_strongly_measurable.convolution_integrand_snd
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ)
  (x : G) : ae_strongly_measurable (λ t, L (f t) (g (x - t))) μ :=
hf.convolution_integrand_snd' L $ hg.mono' $ map_sub_left_absolutely_continuous μ x

lemma measure_theory.ae_strongly_measurable.convolution_integrand_swap_snd
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ)
  (x : G) : ae_strongly_measurable (λ t, L (f (x - t)) (g t)) μ :=
(hf.mono' (map_sub_left_absolutely_continuous μ x)).convolution_integrand_swap_snd' L hg

end left

section right

variables [sigma_finite μ] [is_add_right_invariant μ]

lemma measure_theory.ae_strongly_measurable.convolution_integrand
  (hf : ae_strongly_measurable f μ) (hg : ae_strongly_measurable g μ) :
  ae_strongly_measurable (λ p : G × G, L (f p.2) (g (p.1 - p.2))) (μ.prod μ) :=
hf.convolution_integrand' L $ hg.mono' (quasi_measure_preserving_sub μ).absolutely_continuous

lemma measure_theory.integrable.convolution_integrand (hf : integrable f μ) (hg : integrable g μ) :
  integrable (λ p : G × G, L (f p.2) (g (p.1 - p.2))) (μ.prod μ) :=
begin
  have h_meas : ae_strongly_measurable (λ (p : G × G), L (f p.2) (g (p.1 - p.2))) (μ.prod μ) :=
    hf.ae_strongly_measurable.convolution_integrand L hg.ae_strongly_measurable,
  have h2_meas : ae_strongly_measurable (λ (y : G), ∫ (x : G), ∥L (f y) (g (x - y))∥ ∂μ) μ :=
    h_meas.prod_swap.norm.integral_prod_right',
  simp_rw [integrable_prod_iff' h_meas],
  refine ⟨eventually_of_forall (λ t, (L (f t)).integrable_comp (hg.comp_sub_right t)), _⟩,
  refine integrable.mono' _ h2_meas (eventually_of_forall $
    λ t, (_ : _ ≤ ∥L∥ * ∥f t∥ * ∫ x, ∥g (x - t)∥ ∂μ)),
  { simp_rw [integral_sub_right_eq_self (λ t, ∥ g t ∥)],
    exact (hf.norm.const_mul _).mul_const _ },
  { simp_rw [← integral_mul_left],
    rw [real.norm_of_nonneg],
    { exact integral_mono_of_nonneg (eventually_of_forall $ λ t, norm_nonneg _)
        ((hg.comp_sub_right t).norm.const_mul _) (eventually_of_forall $ λ t, L.le_op_norm₂ _ _) },
    exact integral_nonneg (λ x, norm_nonneg _) }
end

lemma measure_theory.integrable.ae_convolution_exists (hf : integrable f μ) (hg : integrable g μ) :
  ∀ᵐ x ∂μ, convolution_exists_at f g x L μ :=
((integrable_prod_iff $ hf.ae_strongly_measurable.convolution_integrand L
  hg.ae_strongly_measurable).mp $ hf.convolution_integrand L hg).1

end right

variables [topological_space G] [topological_add_group G] [borel_space G]
  [second_countable_topology G] [sigma_compact_space G]

lemma has_compact_support.convolution_exists_at {x₀ : G}
  (h : has_compact_support (λ t, L (f t) (g (x₀ - t)))) (hf : locally_integrable f μ)
  (hg : continuous g) : convolution_exists_at f g x₀ L μ :=
((((homeomorph.neg G).trans $ homeomorph.add_right x₀).compact_preimage.mpr h).bdd_above_image
  hg.norm.continuous_on).convolution_exists_at' L is_closed_closure.measurable_set subset_closure
  (hf h) hf.ae_strongly_measurable hg.ae_strongly_measurable

lemma has_compact_support.convolution_exists_right
  (hcg : has_compact_support g) (hf : locally_integrable f μ) (hg : continuous g) :
  convolution_exists f g L μ :=
begin
  intro x₀,
  refine has_compact_support.convolution_exists_at L _ hf hg,
  refine (hcg.comp_homeomorph (homeomorph.sub_left x₀)).mono _,
  refine λ t, mt (λ ht : g (x₀ - t) = 0, _),
  simp_rw [ht, (L _).map_zero]
end

lemma has_compact_support.convolution_exists_left_of_continuous_right
  (hcf : has_compact_support f) (hf : locally_integrable f μ) (hg : continuous g) :
  convolution_exists f g L μ :=
begin
  intro x₀,
  refine has_compact_support.convolution_exists_at L _ hf hg,
  refine hcf.mono _,
  refine λ t, mt (λ ht : f t = 0, _),
  simp_rw [ht, L.map_zero₂]
end

end group

section comm_group

variables [add_comm_group G]

section measurable_group

variables [has_measurable_add₂ G] [has_measurable_neg G] [is_add_left_invariant μ]

/-- A sufficient condition to prove that `f ⋆[L, μ] g` exists.
We assume that the integrand has compact support and `g` is bounded on this support (note that
both properties hold if `g` is continuous with compact support). We also require that `f` is
integrable on the support of the integrand, and that both functions are strongly measurable.

This is a variant of `bdd_above.convolution_exists_at'` in an abelian group with a left-invariant
measure. This allows us to state the boundedness and measurability of `g` in a more natural way. -/
lemma bdd_above.convolution_exists_at [sigma_finite μ] {x₀ : G}
  {s : set G} (hbg : bdd_above ((λ i, ∥g i∥) '' ((λ t, x₀ - t) ⁻¹' s)))
  (hs : measurable_set s) (h2s : support (λ t, L (f t) (g (x₀ - t))) ⊆ s)
  (hf : integrable_on f s μ)
  (hmf : ae_strongly_measurable f μ)
  (hmg : ae_strongly_measurable g μ) :
    convolution_exists_at f g x₀ L μ :=
begin
  refine bdd_above.convolution_exists_at' L _ hs h2s hf hmf _,
  { simp_rw [← sub_eq_neg_add, hbg] },
  { exact hmg.mono' (map_sub_left_absolutely_continuous μ x₀) }
end

variables {L} [is_neg_invariant μ]

lemma convolution_exists_at_flip :
  convolution_exists_at g f x L.flip μ ↔ convolution_exists_at f g x L μ :=
by simp_rw [convolution_exists_at, ← integrable_comp_sub_left (λ t, L (f t) (g (x - t))) x,
  sub_sub_cancel, flip_apply]

lemma convolution_exists_at.integrable_swap (h : convolution_exists_at f g x L μ) :
  integrable (λ t, L (f (x - t)) (g t)) μ :=
by { convert h.comp_sub_left x, simp_rw [sub_sub_self] }

lemma convolution_exists_at_iff_integrable_swap :
  convolution_exists_at f g x L μ ↔ integrable (λ t, L (f (x - t)) (g t)) μ :=
convolution_exists_at_flip.symm

end measurable_group

variables [topological_space G] [topological_add_group G] [borel_space G]
  [second_countable_topology G] [is_add_left_invariant μ] [is_neg_invariant μ]
  [sigma_compact_space G]

lemma has_compact_support.convolution_exists_left
  (hcf : has_compact_support f) (hf : continuous f) (hg : locally_integrable g μ) :
  convolution_exists f g L μ :=
λ x₀, convolution_exists_at_flip.mp $ hcf.convolution_exists_right L.flip hg hf x₀

lemma has_compact_support.convolution_exists_right_of_continuous_left
  (hcg : has_compact_support g) (hf : continuous f) (hg : locally_integrable g μ) :
  convolution_exists f g L μ :=
λ x₀, convolution_exists_at_flip.mp $
  hcg.convolution_exists_left_of_continuous_right L.flip hg hf x₀

end comm_group

end convolution_exists

variables [normed_space ℝ F] [complete_space F]

/-- The convolution of two functions `f` and `g` with respect to a continuous bilinear map `L` and
measure `μ`. It is defined to be `(f ⋆[L, μ] g) x = ∫ t, L (f t) (g (x - t)) ∂μ`. -/
noncomputable def convolution [has_sub G] (f : G → E) (g : G → E') (L : E →L[𝕜] E' →L[𝕜] F)
  (μ : measure G . volume_tac) : G → F :=
λ x, ∫ t, L (f t) (g (x - t)) ∂μ

localized "notation f ` ⋆[`:67 L:67 `, ` μ:67 `] `:0 g:66 := convolution f g L μ" in convolution
localized "notation f ` ⋆[`:67 L:67 `]`:0 g:66 := convolution f g L
  measure_theory.measure_space.volume" in convolution
localized "notation f ` ⋆ `:67 g:66 := convolution f g (continuous_linear_map.lsmul ℝ ℝ)
  measure_theory.measure_space.volume" in convolution

lemma convolution_def [has_sub G] : (f ⋆[L, μ] g) x = ∫ t, L (f t) (g (x - t)) ∂μ := rfl

/-- The definition of convolution where the bilinear operator is scalar multiplication.
Note: it often helps the elaborator to give the type of the convolution explicitly. -/
lemma convolution_lsmul [has_sub G] {f : G → 𝕜} {g : G → F} :
  (f ⋆[lsmul 𝕜 𝕜, μ] g : G → F) x = ∫ t, f t • g (x - t) ∂μ := rfl

/-- The definition of convolution where the bilinear operator is multiplication. -/
lemma convolution_lmul [has_sub G] [normed_space ℝ 𝕜] [complete_space 𝕜] {f : G → 𝕜} {g : G → 𝕜} :
  (f ⋆[lmul 𝕜 𝕜, μ] g) x = ∫ t, f t * g (x - t) ∂μ := rfl

section group

variables {L} [add_group G]

lemma smul_convolution [smul_comm_class ℝ 𝕜 F]
  {y : 𝕜} : (y • f) ⋆[L, μ] g = y • (f ⋆[L, μ] g) :=
by { ext, simp only [pi.smul_apply, convolution_def, ← integral_smul, L.map_smul₂] }

lemma convolution_smul [smul_comm_class ℝ 𝕜 F]
  {y : 𝕜} : f ⋆[L, μ] (y • g) = y • (f ⋆[L, μ] g) :=
by { ext, simp only [pi.smul_apply, convolution_def, ← integral_smul, (L _).map_smul] }

lemma zero_convolution : 0 ⋆[L, μ] g = 0 :=
by { ext, simp_rw [convolution_def, pi.zero_apply, L.map_zero₂, integral_zero] }

lemma convolution_zero : f ⋆[L, μ] 0 = 0 :=
by { ext, simp_rw [convolution_def, pi.zero_apply, (L _).map_zero, integral_zero] }

lemma convolution_exists_at.distrib_add {x : G} (hfg : convolution_exists_at f g x L μ)
  (hfg' : convolution_exists_at f g' x L μ) :
  (f ⋆[L, μ] (g + g')) x = (f ⋆[L, μ] g) x + (f ⋆[L, μ] g') x :=
by simp only [convolution_def, (L _).map_add, pi.add_apply, integral_add hfg hfg']

lemma convolution_exists.distrib_add (hfg : convolution_exists f g L μ)
  (hfg' : convolution_exists f g' L μ) : f ⋆[L, μ] (g + g') = f ⋆[L, μ] g + f ⋆[L, μ] g' :=
by { ext, exact (hfg x).distrib_add (hfg' x) }

lemma convolution_exists_at.add_distrib {x : G} (hfg : convolution_exists_at f g x L μ)
  (hfg' : convolution_exists_at f' g x L μ) :
  ((f + f') ⋆[L, μ] g) x = (f ⋆[L, μ] g) x + (f' ⋆[L, μ] g) x :=
by simp only [convolution_def, L.map_add₂, pi.add_apply, integral_add hfg hfg']

lemma convolution_exists.add_distrib (hfg : convolution_exists f g L μ)
  (hfg' : convolution_exists f' g L μ) : (f + f') ⋆[L, μ] g = f ⋆[L, μ] g + f' ⋆[L, μ] g :=
by { ext, exact (hfg x).add_distrib (hfg' x) }

variables (L)

lemma convolution_congr [has_measurable_add G] [has_measurable_neg G] [is_add_left_invariant μ]
  [is_neg_invariant μ] (h1 : f =ᵐ[μ] f') (h2 : g =ᵐ[μ] g') :
  f ⋆[L, μ] g = f' ⋆[L, μ] g' :=
begin
  ext x,
  apply integral_congr_ae,
  exact (h1.prod_mk $ h2.comp_tendsto (map_sub_left_ae μ x).le).fun_comp ↿(λ x y, L x y)
end

lemma support_convolution_subset_swap : support (f ⋆[L, μ] g) ⊆ support g + support f :=
begin
  intros x h2x,
  by_contra hx,
  apply h2x,
  simp_rw [set.mem_add, not_exists, not_and_distrib, nmem_support] at hx,
  rw [convolution_def],
  convert integral_zero G F,
  ext t,
  rcases hx (x - t) t with h|h|h,
  { rw [h, (L _).map_zero] },
  { rw [h, L.map_zero₂] },
  { exact (h $ sub_add_cancel x t).elim }
end

variables [topological_space G]
variables [topological_add_group G]

lemma has_compact_support.convolution [t2_space G] (hcf : has_compact_support f)
  (hcg : has_compact_support g) : has_compact_support (f ⋆[L, μ] g) :=
compact_of_is_closed_subset (hcg.is_compact.add hcf) is_closed_closure $ closure_minimal
  ((support_convolution_subset_swap L).trans $ add_subset_add subset_closure subset_closure)
  (hcg.is_compact.add hcf).is_closed

variables [borel_space G] [second_countable_topology G]

/-- The convolution is continuous if one function is locally integrable and the other has compact
support and is continuous. -/
lemma has_compact_support.continuous_convolution_right [locally_compact_space G] [t2_space G]
  (hcg : has_compact_support g) (hf : locally_integrable f μ)
  (hg : continuous g) : continuous (f ⋆[L, μ] g) :=
begin
  refine continuous_iff_continuous_at.mpr (λ x₀, _),
  obtain ⟨K, hK, h2K⟩ := exists_compact_mem_nhds x₀,
  let K' := - tsupport g + K,
  have hK' : is_compact K' := hcg.neg.add hK,
  have : ∀ᶠ x in 𝓝 x₀, ∀ᵐ (t : G) ∂μ,
    ∥L (f t) (g (x - t))∥ ≤ K'.indicator (λ t, ∥L∥ * ∥f t∥ * (⨆ i, ∥g i∥)) t :=
  eventually_of_mem h2K (λ x hx, eventually_of_forall $
    λ t, hcg.convolution_integrand_bound_right L hg hx),
  refine continuous_at_of_dominated _ this _ _,
  { exact eventually_of_forall
      (λ x, hf.ae_strongly_measurable.convolution_integrand_snd' L hg.ae_strongly_measurable) },
  { rw [integrable_indicator_iff hK'.measurable_set],
    exact ((hf hK').norm.const_mul _).mul_const _ },
  { exact eventually_of_forall (λ t, (L.continuous₂.comp₂ continuous_const $
      hg.comp $ continuous_id.sub $ by apply continuous_const).continuous_at) }
end

/-- The convolution is continuous if one function is integrable and the other is bounded and
continuous. -/
lemma bdd_above.continuous_convolution_right_of_integrable
  (hbg : bdd_above (range (λ x, ∥g x∥))) (hf : integrable f μ) (hg : continuous g) :
    continuous (f ⋆[L, μ] g) :=
begin
  refine continuous_iff_continuous_at.mpr (λ x₀, _),
  have : ∀ᶠ x in 𝓝 x₀, ∀ᵐ (t : G) ∂μ,
    ∥L (f t) (g (x - t))∥ ≤ ∥L∥ * ∥f t∥ * (⨆ i, ∥g i∥),
  { refine eventually_of_forall (λ x, eventually_of_forall $ λ t, _),
    refine (L.le_op_norm₂ _ _).trans _,
    exact mul_le_mul_of_nonneg_left (le_csupr hbg $ x - t)
      (mul_nonneg (norm_nonneg _) (norm_nonneg _)) },
  refine continuous_at_of_dominated _ this _ _,
  { exact eventually_of_forall
      (λ x, hf.ae_strongly_measurable.convolution_integrand_snd' L hg.ae_strongly_measurable) },
  { exact (hf.norm.const_mul _).mul_const _ },
  { exact eventually_of_forall (λ t, (L.continuous₂.comp₂ continuous_const $
      hg.comp $ continuous_id.sub $ by apply continuous_const).continuous_at) }
end

/-- A version of `has_compact_support.continuous_convolution_right` that works if `G` is
not locally compact but requires that `g` is integrable. -/
lemma has_compact_support.continuous_convolution_right_of_integrable
  (hcg : has_compact_support g) (hf : integrable f μ) (hg : continuous g) :
    continuous (f ⋆[L, μ] g) :=
(hg.norm.bdd_above_range_of_has_compact_support hcg.norm).continuous_convolution_right_of_integrable
  L hf hg

variables [sigma_finite μ] [is_add_right_invariant μ]

lemma measure_theory.integrable.integrable_convolution (hf : integrable f μ) (hg : integrable g μ) :
  integrable (f ⋆[L, μ] g) μ :=
(hf.convolution_integrand L hg).integral_prod_left

end group

section comm_group

variables [add_comm_group G]

lemma support_convolution_subset : support (f ⋆[L, μ] g) ⊆ support f + support g :=
(support_convolution_subset_swap L).trans (add_comm _ _).subset

variables [topological_space G]
variables [topological_add_group G]
variables [borel_space G]
variables [is_add_left_invariant μ]  [is_neg_invariant μ]

variable (L)
/-- Commutativity of convolution -/
lemma convolution_flip : g ⋆[L.flip, μ] f = f ⋆[L, μ] g :=
begin
  ext1 x,
  simp_rw [convolution_def],
  rw [← integral_sub_left_eq_self _ μ x],
  simp_rw [sub_sub_self, flip_apply]
end

/-- The symmetric definition of convolution. -/
lemma convolution_eq_swap : (f ⋆[L, μ] g) x = ∫ t, L (f (x - t)) (g t) ∂μ :=
by { rw [← convolution_flip], refl }

/-- The symmetric definition of convolution where the bilinear operator is scalar multiplication. -/
lemma convolution_lsmul_swap {f : G → 𝕜} {g : G → F}:
  (f ⋆[lsmul 𝕜 𝕜, μ] g : G → F) x = ∫ t, f (x - t) • g t ∂μ :=
convolution_eq_swap _

/-- The symmetric definition of convolution where the bilinear operator is multiplication. -/
lemma convolution_lmul_swap [normed_space ℝ 𝕜] [complete_space 𝕜] {f : G → 𝕜} {g : G → 𝕜} :
  (f ⋆[lmul 𝕜 𝕜, μ] g) x = ∫ t, f (x - t) * g t ∂μ :=
convolution_eq_swap _

variables [second_countable_topology G]

lemma has_compact_support.continuous_convolution_left [locally_compact_space G] [t2_space G]
  (hcf : has_compact_support f) (hf : continuous f) (hg : locally_integrable g μ) :
    continuous (f ⋆[L, μ] g) :=
by { rw [← convolution_flip], exact hcf.continuous_convolution_right L.flip hg hf }

lemma bdd_above.continuous_convolution_left_of_integrable
  (hbf : bdd_above (range (λ x, ∥f x∥))) (hf : continuous f) (hg : integrable g μ) :
    continuous (f ⋆[L, μ] g) :=
by { rw [← convolution_flip], exact hbf.continuous_convolution_right_of_integrable L.flip hg hf }

/-- A version of `has_compact_support.continuous_convolution_left` that works if `G` is
not locally compact but requires that `g` is integrable. -/
lemma has_compact_support.continuous_convolution_left_of_integrable
  (hcf : has_compact_support f) (hf : continuous f) (hg : integrable g μ) :
    continuous (f ⋆[L, μ] g) :=
by { rw [← convolution_flip], exact hcf.continuous_convolution_right_of_integrable L.flip hg hf }

end comm_group

section normed_group

variables [semi_normed_group G]

/-- Compute `(f ⋆ g) x₀` if the support of the `f` is within `metric.ball 0 R`, and `g` is constant
on `metric.ball x₀ R`.

We can simplify the RHS further if we assume `f` is integrable, but also if `L = (•)` or more
generally if `L` has a `antilipschitz_with`-condition. -/
lemma convolution_eq_right' {x₀ : G} {R : ℝ}
  (hf : support f ⊆ ball (0 : G) R)
  (hg : ∀ x ∈ ball x₀ R, g x = g x₀) : (f ⋆[L, μ] g) x₀ = ∫ t, L (f t) (g x₀) ∂μ :=
begin
  have h2 : ∀ t, L (f t) (g (x₀ - t)) = L (f t) (g x₀),
  { intro t, by_cases ht : t ∈ support f,
    { have h2t := hf ht,
      rw [mem_ball_zero_iff] at h2t,
      specialize hg (x₀ - t),
      rw [sub_eq_add_neg, add_mem_ball_iff_norm, norm_neg, ← sub_eq_add_neg] at hg,
      rw [hg h2t] },
    { rw [nmem_support] at ht,
      simp_rw [ht, L.map_zero₂] } },
  simp_rw [convolution_def, h2],
end

variables [borel_space G] [second_countable_topology G]
variables [is_add_left_invariant μ] [sigma_finite μ]

/-- Approximate `(f ⋆ g) x₀` if the support of the `f` is bounded within a ball, and `g` is near
`g x₀` on a ball with the same radius around `x₀`. See `dist_convolution_le` for a special case.

We can simplify the second argument of `dist` further if we assume `f` is integrable, but also if
`L = (•)` or more generally if `L` has a `antilipschitz_with`-condition. -/
lemma dist_convolution_le' {x₀ : G} {R ε : ℝ}
  (hε : 0 ≤ ε)
  (hif : integrable f μ)
  (hf : support f ⊆ ball (0 : G) R)
  (hmg : ae_strongly_measurable g μ)
  (hg : ∀ x ∈ ball x₀ R, dist (g x) (g x₀) ≤ ε) :
  dist ((f ⋆[L, μ] g : G → F) x₀) (∫ t, L (f t) (g x₀) ∂μ) ≤ ∥L∥ * ∫ x, ∥f x∥ ∂μ * ε :=
begin
  have hfg : convolution_exists_at f g x₀ L μ,
  { refine bdd_above.convolution_exists_at L _ metric.is_open_ball.measurable_set
    (subset_trans _ hf) hif.integrable_on hif.ae_strongly_measurable hmg,
    swap, { refine λ t, mt (λ ht : f t = 0, _), simp_rw [ht, L.map_zero₂] },
    rw [bdd_above_def],
    refine ⟨∥g x₀∥ + ε, _⟩,
    rintro _ ⟨x, hx, rfl⟩,
    refine norm_le_norm_add_const_of_dist_le (hg x _),
    rwa [mem_ball_iff_norm, norm_sub_rev, ← mem_ball_zero_iff] },
  have h2 : ∀ t, dist (L (f t) (g (x₀ - t))) (L (f t) (g x₀)) ≤ ∥L (f t)∥ * ε,
  { intro t, by_cases ht : t ∈ support f,
    { have h2t := hf ht,
      rw [mem_ball_zero_iff] at h2t,
      specialize hg (x₀ - t),
      rw [sub_eq_add_neg, add_mem_ball_iff_norm, norm_neg, ← sub_eq_add_neg] at hg,
      refine ((L (f t)).dist_le_op_norm _ _).trans _,
      exact mul_le_mul_of_nonneg_left (hg h2t) (norm_nonneg _) },
    { rw [nmem_support] at ht,
      simp_rw [ht, L.map_zero₂, L.map_zero, norm_zero, zero_mul, dist_self] } },
  simp_rw [convolution_def],
  simp_rw [dist_eq_norm] at h2 ⊢,
  rw [← integral_sub hfg.integrable], swap, { exact (L.flip (g x₀)).integrable_comp hif },
  refine (norm_integral_le_of_norm_le ((L.integrable_comp hif).norm.mul_const ε)
    (eventually_of_forall h2)).trans _,
  rw [integral_mul_right],
  refine mul_le_mul_of_nonneg_right _ hε,
  have h3 : ∀ t, ∥L (f t)∥ ≤ ∥L∥ * ∥f t∥ := λ t, L.le_op_norm (f t),
  refine (integral_mono (L.integrable_comp hif).norm (hif.norm.const_mul _) h3).trans_eq _,
  rw [integral_mul_left]
end

variables [normed_space ℝ E] [normed_space ℝ E'] [complete_space E']

/-- Approximate `f ⋆ g` if the support of the `f` is bounded within a ball, and `g` is near `g x₀`
on a ball with the same radius around `x₀`.

This is a special case of `dist_convolution_le'` where `L` is `(•)`, `f` has integral 1 and `f` is
nonnegative. -/
lemma dist_convolution_le {f : G → ℝ} {x₀ : G} {R ε : ℝ}
  (hε : 0 ≤ ε)
  (hf : support f ⊆ ball (0 : G) R)
  (hnf : ∀ x, 0 ≤ f x)
  (hintf : ∫ x, f x ∂μ = 1)
  (hmg : ae_strongly_measurable g μ)
  (hg : ∀ x ∈ ball x₀ R, dist (g x) (g x₀) ≤ ε) :
  dist ((f ⋆[lsmul ℝ ℝ, μ] g : G → E') x₀) (g x₀) ≤ ε :=
begin
  have hif : integrable f μ,
  { by_contra hif, exact zero_ne_one ((integral_undef hif).symm.trans hintf) },
  convert (dist_convolution_le' _ hε hif hf hmg hg).trans _,
  { simp_rw [lsmul_apply, integral_smul_const, hintf, one_smul] },
  { simp_rw [real.norm_of_nonneg (hnf _), hintf, mul_one],
    exact (mul_le_mul_of_nonneg_right op_norm_lsmul_le hε).trans_eq (one_mul ε) }
end

/-- `(φ i ⋆ g) x₀` tends to `g x₀` if `φ` is a sequence of nonnegative functions with integral 1
whose support tends to small neighborhoods around `(0 : G)` and `g` is continuous at `x₀`.

See also `cont_diff_bump_of_inner.convolution_tendsto_right'`. -/
lemma convolution_tendsto_right {ι} {l : filter ι} {φ : ι → G → ℝ}
  (hnφ : ∀ i x, 0 ≤ φ i x)
  (hiφ : ∀ i, ∫ s, φ i s ∂μ = 1)
  (hφ : tendsto (λ n, support (φ n)) l (𝓝 0).small_sets)
  (hmg : ae_strongly_measurable g μ) {x₀ : G} (hcg : continuous_at g x₀) :
  tendsto (λ i, (φ i ⋆[lsmul ℝ ℝ, μ] g : G → E') x₀) l (𝓝 (g x₀)) :=
begin
  simp_rw [tendsto_small_sets_iff] at hφ,
  rw [metric.continuous_at_iff] at hcg,
  rw [metric.tendsto_nhds],
  intros ε hε,
  rcases hcg (ε / 2) (half_pos hε) with ⟨δ, hδ, hgδ⟩,
  refine (hφ (ball (0 : G) δ) $ ball_mem_nhds _ hδ).mono (λ i hi, _),
  exact (dist_convolution_le (half_pos hε).le hi (hnφ i) (hiφ i) hmg (λ x hx, (hgδ hx.out).le))
    .trans_lt (half_lt_self hε)
end

end normed_group

namespace cont_diff_bump_of_inner

variables {n : with_top ℕ}
variables [normed_space ℝ E']
variables [inner_product_space ℝ G]
variables [complete_space E']
variables {a : G} {φ : cont_diff_bump_of_inner (0 : G)}

/-- If `φ` is a bump function, compute `(φ ⋆ g) x₀` if `g` is constant on `metric.ball x₀ φ.R`. -/
lemma convolution_eq_right {x₀ : G}
  (hg : ∀ x ∈ ball x₀ φ.R, g x = g x₀) : (φ ⋆[lsmul ℝ ℝ, μ] g : G → E') x₀ = integral μ φ • g x₀ :=
by simp_rw [convolution_eq_right' _ φ.support_eq.subset hg, lsmul_apply, integral_smul_const]

variables [borel_space G]
variables [is_locally_finite_measure μ] [is_open_pos_measure μ]
variables [finite_dimensional ℝ G]

/-- If `φ` is a normed bump function, compute `φ ⋆ g` if `g` is constant on `metric.ball x₀ φ.R`. -/
lemma normed_convolution_eq_right {x₀ : G}
  (hg : ∀ x ∈ ball x₀ φ.R, g x = g x₀) : (φ.normed μ ⋆[lsmul ℝ ℝ, μ] g : G → E') x₀ = g x₀ :=
by { simp_rw [convolution_eq_right' _ φ.support_normed_eq.subset hg, lsmul_apply],
  exact integral_normed_smul φ μ (g x₀) }

variables [is_add_left_invariant μ]

/-- If `φ` is a normed bump function, approximate `(φ ⋆ g) x₀` if `g` is near `g x₀` on a ball with
radius `φ.R` around `x₀`. -/
lemma dist_normed_convolution_le {x₀ : G} {ε : ℝ}
  (hmg : ae_strongly_measurable g μ)
  (hg : ∀ x ∈ ball x₀ φ.R, dist (g x) (g x₀) ≤ ε) :
  dist ((φ.normed μ ⋆[lsmul ℝ ℝ, μ] g : G → E') x₀) (g x₀) ≤ ε :=
dist_convolution_le (by simp_rw [← dist_self (g x₀), hg x₀ (mem_ball_self φ.R_pos)])
  φ.support_normed_eq.subset φ.nonneg_normed φ.integral_normed hmg hg

/-- If `φ i` is a sequence of normed bump function, `(φ i ⋆ g) x₀` tends to `g x₀` if `(φ i).R`
tends to `0` and `g` is continuous at `x₀`. -/
lemma convolution_tendsto_right' {ι} {φ : ι → cont_diff_bump_of_inner (0 : G)}
  {l : filter ι} (hφ : tendsto (λ i, (φ i).R) l (𝓝 0))
  (hmg : ae_strongly_measurable g μ) {x₀ : G} (hcg : continuous_at g x₀) :
  tendsto (λ i, ((λ x, (φ i).normed μ x) ⋆[lsmul ℝ ℝ, μ] g : G → E') x₀) l (𝓝 (g x₀)) :=
begin
  refine convolution_tendsto_right (λ i, (φ i).nonneg_normed) (λ i, (φ i).integral_normed)
    _ hmg hcg,
  rw [normed_group.tendsto_nhds_zero] at hφ,
  rw [tendsto_small_sets_iff],
  intros t ht,
  rcases metric.mem_nhds_iff.mp ht with ⟨ε, hε, ht⟩,
  refine (hφ ε hε).mono (λ i hi, subset_trans _ ht),
  simp_rw [(φ i).support_normed_eq],
  rw [real.norm_eq_abs, abs_eq_self.mpr (φ i).R_pos.le] at hi,
  exact ball_subset_ball hi.le
end

/-- Special case of `cont_diff_bump_of_inner.convolution_tendsto_right'` where `g` is continuous. -/
lemma convolution_tendsto_right {ι} {φ : ι → cont_diff_bump_of_inner (0 : G)}
  {l : filter ι} (hφ : tendsto (λ i, (φ i).R) l (𝓝 0))
  (hg : continuous g) (x₀ : G) :
  tendsto (λ i, ((λ x, (φ i).normed μ x) ⋆[lsmul ℝ ℝ, μ] g : G → E') x₀) l (𝓝 (g x₀)) :=
convolution_tendsto_right' hφ hg.ae_strongly_measurable hg.continuous_at

end cont_diff_bump_of_inner

end measurability

end nondiscrete_normed_field

open_locale convolution


section is_R_or_C

variables [is_R_or_C 𝕜]
variables [normed_space 𝕜 E]
variables [normed_space 𝕜 E']
variables [normed_space 𝕜 E'']
variables [normed_space ℝ F] [normed_space 𝕜 F]
variables {n : with_top ℕ}
variables [complete_space F]
variables [measurable_space G] {μ : measure G}
variables (L : E →L[𝕜] E' →L[𝕜] F)

section assoc
variables [normed_group F'] [normed_space ℝ F'] [normed_space 𝕜 F'] [complete_space F']
variables [normed_group F''] [normed_space ℝ F''] [normed_space 𝕜 F''] [complete_space F'']
variables {k : G → E''}
variables (L₂ : F →L[𝕜] E'' →L[𝕜] F')
variables (L₃ : E →L[𝕜] F'' →L[𝕜] F')
variables (L₄ : E' →L[𝕜] E'' →L[𝕜] F'')
variables [add_group G] [has_measurable_add G]
variables [sigma_finite μ]
variables {ν : measure G} [sigma_finite ν] [is_add_right_invariant ν]

/-- Convolution is associative.
To do: prove that `hi` follows from simpler conditions. -/
lemma convolution_assoc (hL : ∀ (x : E) (y : E') (z : E''), L₂ (L x y) z = L₃ x (L₄ y z))
  {x₀ : G}
  (h₄ : convolution_exists g k L₄ ν)
  (h₁ : convolution_exists f g L μ)
  (hi : integrable (uncurry (λ x y, (L₃ (f y)) ((L₄ (g (x - y))) (k (x₀ - x))))) (ν.prod μ)) :
  ((f ⋆[L, μ] g) ⋆[L₂, ν] k) x₀ = (f ⋆[L₃, μ] (g ⋆[L₄, ν] k)) x₀ :=
begin
  have h1 := λ t, (L₂.flip (k (x₀ - t))).integral_comp_comm (h₁ t),
  dsimp only [flip_apply] at h1,
  simp_rw [convolution_def, ← (L₃ (f _)).integral_comp_comm (h₄ (x₀ - _)), ← h1, hL],
  rw [integral_integral_swap hi],
  congr', ext t,
  rw [eq_comm, ← integral_sub_right_eq_self _ t],
  { simp_rw [sub_sub_sub_cancel_right] },
  { apply_instance },
end

end assoc

variables [normed_group G] [borel_space G]
variables [second_countable_topology G] [sigma_compact_space G]

lemma convolution_precompR_apply {g : G → E'' →L[𝕜] E'}
  (hf : locally_integrable f μ) (hcg : has_compact_support g) (hg : continuous g)
  (x₀ : G) (x : E'') : (f ⋆[L.precompR E'', μ] g) x₀ x = (f ⋆[L, μ] (λ a, g a x)) x₀  :=
begin
  have := hcg.convolution_exists_right (L.precompR E'') hf hg x₀,
  simp_rw [convolution_def, continuous_linear_map.integral_apply this],
  refl,
end

variables [sigma_finite μ] [is_add_left_invariant μ]
variables [normed_space 𝕜 G] [proper_space G]

/-- Compute the total derivative of `f ⋆ g` if `g` is `C^1` with compact support and `f` is locally
integrable. To write down the total derivative as a convolution, we use
`continuous_linear_map.precompR`. -/
lemma has_compact_support.has_fderiv_at_convolution_right
  (hcg : has_compact_support g) (hf : locally_integrable f μ) (hg : cont_diff 𝕜 1 g) (x₀ : G) :
  has_fderiv_at (f ⋆[L, μ] g) ((f ⋆[L.precompR G, μ] fderiv 𝕜 g) x₀) x₀ :=
begin
  set L' := L.precompR G,
  have h1 : ∀ᶠ x in 𝓝 x₀, ae_strongly_measurable (λ t, L (f t) (g (x - t))) μ :=
  eventually_of_forall
    (hf.ae_strongly_measurable.convolution_integrand_snd L hg.continuous.ae_strongly_measurable),
  have h2 : ∀ x, ae_strongly_measurable (λ t, L' (f t) (fderiv 𝕜 g (x - t))) μ,
  { exact hf.ae_strongly_measurable.convolution_integrand_snd L'
      (hg.continuous_fderiv le_rfl).ae_strongly_measurable },
  have h3 : ∀ x t, has_fderiv_at (λ x, g (x - t)) (fderiv 𝕜 g (x - t)) x,
  { intros x t,
    simpa using (hg.differentiable le_rfl).differentiable_at.has_fderiv_at.comp x
      ((has_fderiv_at_id x).sub (has_fderiv_at_const t x)) },
  let K' := - tsupport (fderiv 𝕜 g) + closed_ball x₀ 1,
  have hK' : is_compact K' := (hcg.fderiv 𝕜).neg.add (is_compact_closed_ball x₀ 1),
  refine has_fderiv_at_integral_of_dominated_of_fderiv_le
    zero_lt_one h1 _ (h2 x₀) _ _ _,
  { exact K'.indicator (λ t, ∥L'∥ * ∥f t∥ * (⨆ x, ∥fderiv 𝕜 g x∥)) },
  { exact hcg.convolution_exists_right L hf hg.continuous x₀ },
  { refine eventually_of_forall (λ t x hx, _),
    exact (hcg.fderiv 𝕜).convolution_integrand_bound_right L'
      (hg.continuous_fderiv le_rfl) (ball_subset_closed_ball hx) },
  { rw [integrable_indicator_iff hK'.measurable_set],
    exact ((hf hK').norm.const_mul _).mul_const _ },
  { exact eventually_of_forall (λ t x hx, (L _).has_fderiv_at.comp x (h3 x t)) },
end

lemma has_compact_support.has_fderiv_at_convolution_left [is_neg_invariant μ]
  (hcf : has_compact_support f) (hf : cont_diff 𝕜 1 f) (hg : locally_integrable g μ) (x₀ : G) :
  has_fderiv_at (f ⋆[L, μ] g) ((fderiv 𝕜 f ⋆[L.precompL G, μ] g) x₀) x₀ :=
begin
  simp only [← convolution_flip] {single_pass := tt},
  exact hcf.has_fderiv_at_convolution_right L.flip hg hf x₀,
end

lemma has_compact_support.cont_diff_convolution_right [finite_dimensional 𝕜 G]
  (hcg : has_compact_support g) (hf : locally_integrable f μ) (hg : cont_diff 𝕜 n g) :
  cont_diff 𝕜 n (f ⋆[L, μ] g) :=
begin
  induction n using with_top.nat_induction with n ih ih generalizing g,
  { rw [cont_diff_zero] at hg ⊢,
    exact hcg.continuous_convolution_right L hf hg },
  { have h : ∀ x, has_fderiv_at (f ⋆[L, μ] g) ((f ⋆[L.precompR G, μ] fderiv 𝕜 g) x) x :=
      hcg.has_fderiv_at_convolution_right L hf hg.one_of_succ,
    rw cont_diff_succ_iff_fderiv_apply,
    split,
    { exact λ x₀, ⟨_, h x₀⟩ },
    { simp_rw [fderiv_eq h, convolution_precompR_apply L hf (hcg.fderiv 𝕜)
        (hg.one_of_succ.continuous_fderiv le_rfl)],
      intro x,
      refine ih _ _,
      { refine @has_compact_support.comp_left _ _ _ _ _ _ (λ (G : _ →L[𝕜] _), G x) _
          (hcg.fderiv 𝕜) (continuous_linear_map.zero_apply x) },
      { revert x, rw [← cont_diff_clm_apply],
        exact (cont_diff_succ_iff_fderiv.mp hg).2 } } },
  { rw [cont_diff_top] at hg ⊢, exact λ n, ih n hcg (hg n) }
end

lemma has_compact_support.cont_diff_convolution_left [finite_dimensional 𝕜 G] [is_neg_invariant μ]
  (hcf : has_compact_support f) (hf : cont_diff 𝕜 n f) (hg : locally_integrable g μ) :
  cont_diff 𝕜 n (f ⋆[L, μ] g) :=
by { rw [← convolution_flip], exact hcf.cont_diff_convolution_right L.flip hg hf }

end is_R_or_C

section real
/-! The one-variable case -/

variables [is_R_or_C 𝕜]
variables [normed_space 𝕜 E]
variables [normed_space 𝕜 E']
variables [normed_space ℝ F] [normed_space 𝕜 F]
variables {f₀ : 𝕜 → E} {g₀ : 𝕜 → E'}
variables {n : with_top ℕ}
variables (L : E →L[𝕜] E' →L[𝕜] F)
variables [complete_space F]
variables {μ : measure 𝕜}
variables [is_add_left_invariant μ] [sigma_finite μ]

lemma has_compact_support.has_deriv_at_convolution_right
  (hf : locally_integrable f₀ μ) (hcg : has_compact_support g₀) (hg : cont_diff 𝕜 1 g₀)
  (x₀ : 𝕜) :
  has_deriv_at (f₀ ⋆[L, μ] g₀) ((f₀ ⋆[L, μ] deriv g₀) x₀) x₀ :=
begin
  convert (hcg.has_fderiv_at_convolution_right L hf hg x₀).has_deriv_at,
  rw [convolution_precompR_apply L hf (hcg.fderiv 𝕜) (hg.continuous_fderiv le_rfl)],
  refl,
end

lemma has_compact_support.has_deriv_at_convolution_left [is_neg_invariant μ]
  (hcf : has_compact_support f₀) (hf : cont_diff 𝕜 1 f₀)
  (hg : locally_integrable g₀ μ) (x₀ : 𝕜) :
  has_deriv_at (f₀ ⋆[L, μ] g₀) ((deriv f₀ ⋆[L, μ] g₀) x₀) x₀ :=
begin
  simp only [← convolution_flip] {single_pass := tt},
  exact hcf.has_deriv_at_convolution_right L.flip hg hf x₀,
end

end real


<|start_filename|>src/topology/algebra/uniform_group.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import topology.uniform_space.uniform_convergence
import topology.uniform_space.uniform_embedding
import topology.uniform_space.complete_separated
import topology.algebra.group
import tactic.abel

/-!
# Uniform structure on topological groups

This file defines uniform groups and its additive counterpart. These typeclasses should be
preferred over using `[topological_space α] [topological_group α]` since every topological
group naturally induces a uniform structure.

## Main declarations
* `uniform_group` and `uniform_add_group`: Multiplicative and additive uniform groups, that
  i.e., groups with uniformly continuous `(*)` and `(⁻¹)` / `(+)` and `(-)`.

## Main results

* `topological_add_group.to_uniform_space` and `topological_add_group_is_uniform` can be used to
  construct a canonical uniformity for a topological add group.

* extension of ℤ-bilinear maps to complete groups (useful for ring completions)
-/

noncomputable theory
open_locale classical uniformity topological_space filter pointwise

section uniform_group
open filter set

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

/-- A uniform group is a group in which multiplication and inversion are uniformly continuous. -/
class uniform_group (α : Type*) [uniform_space α] [group α] : Prop :=
(uniform_continuous_div : uniform_continuous (λp:α×α, p.1 / p.2))

/-- A uniform additive group is an additive group in which addition
  and negation are uniformly continuous.-/
class uniform_add_group (α : Type*) [uniform_space α] [add_group α] : Prop :=
(uniform_continuous_sub : uniform_continuous (λp:α×α, p.1 - p.2))

attribute [to_additive] uniform_group

@[to_additive] theorem uniform_group.mk' {α} [uniform_space α] [group α]
  (h₁ : uniform_continuous (λp:α×α, p.1 * p.2))
  (h₂ : uniform_continuous (λp:α, p⁻¹)) : uniform_group α :=
⟨by simpa only [div_eq_mul_inv] using
  h₁.comp (uniform_continuous_fst.prod_mk (h₂.comp uniform_continuous_snd))⟩

variables [uniform_space α] [group α] [uniform_group α]

@[to_additive] lemma uniform_continuous_div : uniform_continuous (λp:α×α, p.1 / p.2) :=
uniform_group.uniform_continuous_div

@[to_additive] lemma uniform_continuous.div [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x / g x) :=
uniform_continuous_div.comp (hf.prod_mk hg)

@[to_additive] lemma uniform_continuous.inv [uniform_space β] {f : β → α}
  (hf : uniform_continuous f) : uniform_continuous (λx, (f x)⁻¹) :=
have uniform_continuous (λx, 1 / f x),
  from uniform_continuous_const.div hf,
by simp * at *

@[to_additive] lemma uniform_continuous_inv : uniform_continuous (λx:α, x⁻¹) :=
uniform_continuous_id.inv

@[to_additive] lemma uniform_continuous.mul [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x * g x) :=
have uniform_continuous (λx, f x / (g x)⁻¹), from hf.div hg.inv,
by simp * at *

@[to_additive] lemma uniform_continuous_mul : uniform_continuous (λp:α×α, p.1 * p.2) :=
uniform_continuous_fst.mul uniform_continuous_snd

@[priority 10, to_additive]
instance uniform_group.to_topological_group : topological_group α :=
{ continuous_mul := uniform_continuous_mul.continuous,
  continuous_inv := uniform_continuous_inv.continuous }

@[to_additive] instance [uniform_space β] [group β] [uniform_group β] : uniform_group (α × β) :=
⟨((uniform_continuous_fst.comp uniform_continuous_fst).div
  (uniform_continuous_fst.comp uniform_continuous_snd)).prod_mk
 ((uniform_continuous_snd.comp uniform_continuous_fst).div
  (uniform_continuous_snd.comp uniform_continuous_snd))⟩

@[to_additive] lemma uniformity_translate_mul (a : α) :
  (𝓤 α).map (λx:α×α, (x.1 * a, x.2 * a)) = 𝓤 α :=
le_antisymm
  (uniform_continuous_id.mul uniform_continuous_const)
  (calc 𝓤 α =
    ((𝓤 α).map (λx:α×α, (x.1 * a⁻¹, x.2 * a⁻¹))).map (λx:α×α, (x.1 * a, x.2 * a)) :
      by simp [filter.map_map, (∘)]; exact filter.map_id.symm
    ... ≤ (𝓤 α).map (λx:α×α, (x.1 * a, x.2 * a)) :
      filter.map_mono (uniform_continuous_id.mul uniform_continuous_const))

@[to_additive] lemma uniform_embedding_translate_mul (a : α) : uniform_embedding (λx:α, x * a) :=
{ comap_uniformity := begin
    rw [← uniformity_translate_mul a, comap_map] {occs := occurrences.pos [1]},
    rintros ⟨p₁, p₂⟩ ⟨q₁, q₂⟩,
    simp [prod.eq_iff_fst_eq_snd_eq] {contextual := tt}
  end,
  inj := mul_left_injective a }


namespace mul_opposite

@[to_additive] instance : uniform_group αᵐᵒᵖ :=
⟨uniform_continuous_op.comp ((uniform_continuous_unop.comp uniform_continuous_snd).inv.mul $
  uniform_continuous_unop.comp uniform_continuous_fst)⟩

end mul_opposite

namespace subgroup

@[to_additive] instance (S : subgroup α) : uniform_group S :=
⟨uniform_continuous_comap' (uniform_continuous_div.comp $
  uniform_continuous_subtype_val.prod_map uniform_continuous_subtype_val)⟩

end subgroup

section
variables (α)

@[to_additive] lemma uniformity_eq_comap_nhds_one : 𝓤 α = comap (λx:α×α, x.2 / x.1) (𝓝 (1:α)) :=
begin
  rw [nhds_eq_comap_uniformity, filter.comap_comap],
  refine le_antisymm (filter.map_le_iff_le_comap.1 _) _,
  { assume s hs,
    rcases mem_uniformity_of_uniform_continuous_invariant uniform_continuous_div hs
      with ⟨t, ht, hts⟩,
    refine mem_map.2 (mem_of_superset ht _),
    rintros ⟨a, b⟩,
    simpa [subset_def] using hts a b a },
  { assume s hs,
    rcases mem_uniformity_of_uniform_continuous_invariant uniform_continuous_mul hs
      with ⟨t, ht, hts⟩,
    refine ⟨_, ht, _⟩,
    rintros ⟨a, b⟩, simpa [subset_def] using hts 1 (b / a) a }
end

@[to_additive] lemma uniformity_eq_comap_nhds_one_swapped :
  𝓤 α = comap (λx:α×α, x.1 / x.2) (𝓝 (1:α)) :=
by { rw [← comap_swap_uniformity, uniformity_eq_comap_nhds_one, comap_comap, (∘)], refl }

open mul_opposite

@[to_additive]
lemma uniformity_eq_comap_inv_mul_nhds_one : 𝓤 α = comap (λx:α×α, x.1⁻¹ * x.2) (𝓝 (1:α)) :=
begin
  rw [← comap_uniformity_mul_opposite, uniformity_eq_comap_nhds_one, ← op_one, ← comap_unop_nhds,
    comap_comap, comap_comap],
  simp [(∘)]
end

@[to_additive] lemma uniformity_eq_comap_inv_mul_nhds_one_swapped :
  𝓤 α = comap (λx:α×α, x.2⁻¹ * x.1) (𝓝 (1:α)) :=
by { rw [← comap_swap_uniformity, uniformity_eq_comap_inv_mul_nhds_one, comap_comap, (∘)], refl }

end

@[to_additive] lemma filter.has_basis.uniformity_of_nhds_one {ι} {p : ι → Prop} {U : ι → set α}
  (h : (𝓝 (1 : α)).has_basis p U) :
  (𝓤 α).has_basis p (λ i, {x : α × α | x.2 / x.1 ∈ U i}) :=
by { rw uniformity_eq_comap_nhds_one, exact h.comap _ }

@[to_additive] lemma filter.has_basis.uniformity_of_nhds_one_inv_mul
  {ι} {p : ι → Prop} {U : ι → set α} (h : (𝓝 (1 : α)).has_basis p U) :
  (𝓤 α).has_basis p (λ i, {x : α × α | x.1⁻¹ * x.2 ∈ U i}) :=
by { rw uniformity_eq_comap_inv_mul_nhds_one, exact h.comap _ }

@[to_additive] lemma filter.has_basis.uniformity_of_nhds_one_swapped
  {ι} {p : ι → Prop} {U : ι → set α} (h : (𝓝 (1 : α)).has_basis p U) :
  (𝓤 α).has_basis p (λ i, {x : α × α | x.1 / x.2 ∈ U i}) :=
by { rw uniformity_eq_comap_nhds_one_swapped, exact h.comap _ }

@[to_additive] lemma filter.has_basis.uniformity_of_nhds_one_inv_mul_swapped
  {ι} {p : ι → Prop} {U : ι → set α} (h : (𝓝 (1 : α)).has_basis p U) :
  (𝓤 α).has_basis p (λ i, {x : α × α | x.2⁻¹ * x.1 ∈ U i}) :=
by { rw uniformity_eq_comap_inv_mul_nhds_one_swapped, exact h.comap _ }

@[to_additive] lemma group_separation_rel (x y : α) :
  (x, y) ∈ separation_rel α ↔ x / y ∈ closure ({1} : set α) :=
have embedding (λa, a * (y / x)), from (uniform_embedding_translate_mul (y / x)).embedding,
show (x, y) ∈ ⋂₀ (𝓤 α).sets ↔ x / y ∈ closure ({1} : set α),
begin
  rw [this.closure_eq_preimage_closure_image, uniformity_eq_comap_nhds_one α, sInter_comap_sets],
  simp [mem_closure_iff_nhds, inter_singleton_nonempty, sub_eq_add_neg, add_assoc]
end

@[to_additive] lemma uniform_continuous_of_tendsto_one {hom : Type*} [uniform_space β] [group β]
  [uniform_group β] [monoid_hom_class hom α β] {f : hom} (h : tendsto f (𝓝 1) (𝓝 1)) :
  uniform_continuous f :=
begin
  have : ((λx:β×β, x.2 / x.1) ∘ (λx:α×α, (f x.1, f x.2))) = (λx:α×α, f (x.2 / x.1)),
  { simp only [map_div] },
  rw [uniform_continuous, uniformity_eq_comap_nhds_one α, uniformity_eq_comap_nhds_one β,
    tendsto_comap_iff, this],
  exact tendsto.comp h tendsto_comap
end

/-- A group homomorphism (a bundled morphism of a type that implements `monoid_hom_class`) between
two uniform groups is uniformly continuous provided that it is continuous at one. See also
`continuous_of_continuous_at_one`. -/
@[to_additive "An additive group homomorphism (a bundled morphism of a type that implements
`add_monoid_hom_class`) between two uniform additive groups is uniformly continuous provided that it
is continuous at zero. See also `continuous_of_continuous_at_zero`."]
lemma uniform_continuous_of_continuous_at_one {hom : Type*}
  [uniform_space β] [group β] [uniform_group β] [monoid_hom_class hom α β]
  (f : hom) (hf : continuous_at f 1) :
  uniform_continuous f :=
uniform_continuous_of_tendsto_one (by simpa using hf.tendsto)

@[to_additive] lemma monoid_hom.uniform_continuous_of_continuous_at_one
  [uniform_space β] [group β] [uniform_group β]
  (f : α →* β) (hf : continuous_at f 1) :
  uniform_continuous f :=
uniform_continuous_of_continuous_at_one f hf

/-- A homomorphism from a uniform group to a discrete uniform group is continuous if and only if
its kernel is open. -/
@[to_additive "A homomorphism from a uniform additive group to a discrete uniform additive group is
continuous if and only if its kernel is open."]
lemma uniform_group.uniform_continuous_iff_open_ker {hom : Type*} [uniform_space β]
  [discrete_topology β] [group β] [uniform_group β] [monoid_hom_class hom α β] {f : hom} :
  uniform_continuous f ↔ is_open ((f : α →* β).ker : set α) :=
begin
  refine ⟨λ hf, _, λ hf, _⟩,
  { apply (is_open_discrete ({1} : set β)).preimage (uniform_continuous.continuous hf) },
  { apply uniform_continuous_of_continuous_at_one,
    rw [continuous_at, nhds_discrete β, map_one, tendsto_pure],
    exact hf.mem_nhds (map_one f) }
end

@[to_additive] lemma uniform_continuous_monoid_hom_of_continuous {hom : Type*} [uniform_space β]
  [group β] [uniform_group β] [monoid_hom_class hom α β] {f : hom} (h : continuous f) :
  uniform_continuous f :=
uniform_continuous_of_tendsto_one $
  suffices tendsto f (𝓝 1) (𝓝 (f 1)), by rwa map_one at this,
  h.tendsto 1

@[to_additive] lemma cauchy_seq.mul {ι : Type*} [semilattice_sup ι] {u v : ι → α}
  (hu : cauchy_seq u) (hv : cauchy_seq v) : cauchy_seq (u * v) :=
uniform_continuous_mul.comp_cauchy_seq (hu.prod hv)

@[to_additive] lemma cauchy_seq.mul_const {ι : Type*} [semilattice_sup ι]
  {u : ι → α} {x : α} (hu : cauchy_seq u) : cauchy_seq (λ n, u n * x) :=
(uniform_continuous_id.mul uniform_continuous_const).comp_cauchy_seq hu

@[to_additive] lemma cauchy_seq.const_mul {ι : Type*} [semilattice_sup ι]
  {u : ι → α} {x : α} (hu : cauchy_seq u) : cauchy_seq (λ n, x * u n) :=
(uniform_continuous_const.mul uniform_continuous_id).comp_cauchy_seq hu

@[to_additive] lemma cauchy_seq.inv {ι : Type*} [semilattice_sup ι]
  {u : ι → α} (h : cauchy_seq u) : cauchy_seq (u⁻¹) :=
uniform_continuous_inv.comp_cauchy_seq h

@[to_additive] lemma totally_bounded_iff_subset_finite_Union_nhds_one {s : set α} :
  totally_bounded s ↔ ∀ U ∈ 𝓝 (1 : α), ∃ (t : set α), t.finite ∧ s ⊆ ⋃ y ∈ t, y • U :=
(𝓝 (1 : α)).basis_sets.uniformity_of_nhds_one_inv_mul_swapped.totally_bounded_iff.trans $
  by simp [← preimage_smul_inv, preimage]

end uniform_group

section topological_comm_group
open filter
variables (G : Type*) [comm_group G] [topological_space G] [topological_group G]

/-- The right uniformity on a topological group. -/
@[to_additive "The right uniformity on a topological group"]
def topological_group.to_uniform_space : uniform_space G :=
{ uniformity          := comap (λp:G×G, p.2 / p.1) (𝓝 1),
  refl                :=
    by refine map_le_iff_le_comap.1 (le_trans _ (pure_le_nhds 1));
      simp [set.subset_def] {contextual := tt},
  symm                :=
  begin
    suffices : tendsto (λp:G×G, (p.2 / p.1)⁻¹) (comap (λp:G×G, p.2 / p.1) (𝓝 1)) (𝓝 1⁻¹),
    { simpa [tendsto_comap_iff], },
    exact tendsto.comp (tendsto.inv tendsto_id) tendsto_comap
  end,
  comp                :=
  begin
    intros D H,
    rw mem_lift'_sets,
    { rcases H with ⟨U, U_nhds, U_sub⟩,
      rcases exists_nhds_one_split U_nhds with ⟨V, ⟨V_nhds, V_sum⟩⟩,
      existsi ((λp:G×G, p.2 / p.1) ⁻¹' V),
      have H : (λp:G×G, p.2 / p.1) ⁻¹' V ∈ comap (λp:G×G, p.2 / p.1) (𝓝 (1 : G)),
        by existsi [V, V_nhds] ; refl,
      existsi H,
      have comp_rel_sub :
        comp_rel ((λp:G×G, p.2 / p.1) ⁻¹' V) ((λp, p.2 / p.1) ⁻¹' V) ⊆ (λp:G×G, p.2 / p.1) ⁻¹' U,
      begin
        intros p p_comp_rel,
        rcases p_comp_rel with ⟨z, ⟨Hz1, Hz2⟩⟩,
        simpa [sub_eq_add_neg, add_comm, add_left_comm] using V_sum _ Hz1 _ Hz2
      end,
      exact set.subset.trans comp_rel_sub U_sub },
    { exact monotone_comp_rel monotone_id monotone_id }
  end,
  is_open_uniformity  :=
  begin
    intro S,
    let S' := λ x, {p : G × G | p.1 = x → p.2 ∈ S},
    show is_open S ↔ ∀ (x : G), x ∈ S → S' x ∈ comap (λp:G×G, p.2 / p.1) (𝓝 (1 : G)),
    rw [is_open_iff_mem_nhds],
    refine forall₂_congr (λ a ha, _),
    rw [← nhds_translation_div, mem_comap, mem_comap],
    refine exists₂_congr (λ t ht, _),
    show (λ (y : G), y / a) ⁻¹' t ⊆ S ↔ (λ (p : G × G), p.snd / p.fst) ⁻¹' t ⊆ S' a,
    split,
    { rintros h ⟨x, y⟩ hx rfl, exact h hx },
    { rintros h x hx, exact @h (a, x) hx rfl }
  end }

variables {G}

@[to_additive] lemma topological_group.tendsto_uniformly_iff
  {ι α : Type*} (F : ι → α → G) (f : α → G) (p : filter ι) :
  @tendsto_uniformly α G ι (topological_group.to_uniform_space G) F f p
    ↔ ∀ u ∈ 𝓝 (1 : G), ∀ᶠ i in p, ∀ a, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩,
  mem_of_superset (h u hu) (λ i hi a, hv (by exact hi a))⟩

@[to_additive] lemma topological_group.tendsto_uniformly_on_iff
  {ι α : Type*} (F : ι → α → G) (f : α → G) (p : filter ι) (s : set α) :
  @tendsto_uniformly_on α G ι (topological_group.to_uniform_space G) F f p s
    ↔ ∀ u ∈ 𝓝 (1 : G), ∀ᶠ i in p, ∀ a ∈ s, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩,
  mem_of_superset (h u hu) (λ i hi a ha, hv (by exact hi a ha))⟩

@[to_additive] lemma topological_group.tendsto_locally_uniformly_iff
  {ι α : Type*} [topological_space α] (F : ι → α → G) (f : α → G) (p : filter ι) :
  @tendsto_locally_uniformly α G ι (topological_group.to_uniform_space G) _ F f p
    ↔ ∀ (u ∈ 𝓝 (1 : G)) (x : α), ∃ (t ∈ 𝓝 x), ∀ᶠ i in p, ∀ a ∈ t, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩ x, exists_imp_exists (by exact λ a,
  exists_imp_exists (λ ha hp, mem_of_superset hp (λ i hi a ha, hv (by exact hi a ha)))) (h u hu x)⟩

@[to_additive] lemma topological_group.tendsto_locally_uniformly_on_iff
  {ι α : Type*} [topological_space α] (F : ι → α → G) (f : α → G) (p : filter ι) (s : set α) :
  @tendsto_locally_uniformly_on α G ι (topological_group.to_uniform_space G) _ F f p s
    ↔ ∀ (u ∈ 𝓝 (1 : G)) (x ∈ s), ∃ (t ∈ 𝓝[s] x), ∀ᶠ i in p, ∀ a ∈ t, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩ x, exists_imp_exists (by exact λ a,
  exists_imp_exists (λ ha hp, mem_of_superset hp (λ i hi a ha, hv (by exact hi a ha)))) ∘ h u hu x⟩

end topological_comm_group

section topological_comm_group
universes u v w x
open filter

variables (G : Type*) [comm_group G] [topological_space G] [topological_group G]

section
local attribute [instance] topological_group.to_uniform_space

@[to_additive] lemma uniformity_eq_comap_nhds_one' :
  𝓤 G = comap (λp:G×G, p.2 / p.1) (𝓝 (1 : G)) := rfl

variable {G}
@[to_additive] lemma topological_group_is_uniform : uniform_group G :=
have tendsto
    ((λp:(G×G), p.1 / p.2) ∘ (λp:(G×G)×(G×G), (p.1.2 / p.1.1, p.2.2 / p.2.1)))
    (comap (λp:(G×G)×(G×G), (p.1.2 / p.1.1, p.2.2 / p.2.1)) ((𝓝 1).prod (𝓝 1)))
    (𝓝 (1 / 1)) :=
  (tendsto_fst.div' tendsto_snd).comp tendsto_comap,
begin
  constructor,
  rw [uniform_continuous, uniformity_prod_eq_prod, tendsto_map'_iff,
    uniformity_eq_comap_nhds_one' G, tendsto_comap_iff, prod_comap_comap_eq],
  simpa [(∘), div_eq_mul_inv, mul_comm, mul_left_comm] using this
end

open set

@[to_additive] lemma topological_group.t2_space_iff_one_closed :
  t2_space G ↔ is_closed ({1} : set G) :=
begin
  haveI : uniform_group G := topological_group_is_uniform,
  rw [← separated_iff_t2, separated_space_iff, ← closure_eq_iff_is_closed],
  split; intro h,
  { apply subset.antisymm,
    { intros x x_in,
      have := group_separation_rel x 1,
      rw div_one at this,
      rw [← this, h] at x_in,
      change x = 1 at x_in,
      simp [x_in] },
    { exact subset_closure } },
  { ext p,
    cases p with x y,
    rw [group_separation_rel x, h, mem_singleton_iff, div_eq_one],
    refl }
end

@[to_additive] lemma topological_group.t2_space_of_one_sep
  (H : ∀ x : G, x ≠ 1 → ∃ U ∈ nhds (1 : G), x ∉ U) : t2_space G :=
begin
  rw [topological_group.t2_space_iff_one_closed, ← is_open_compl_iff, is_open_iff_mem_nhds],
  intros x x_not,
  have : x ≠ 1, from mem_compl_singleton_iff.mp x_not,
  rcases H x this with ⟨U, U_in, xU⟩,
  rw ← nhds_one_symm G at U_in,
  rcases U_in with ⟨W, W_in, UW⟩,
  rw ← nhds_translation_mul_inv,
  use [W, W_in],
  rw subset_compl_comm,
  suffices : x⁻¹ ∉ W, by simpa,
  exact λ h, xU (UW h)
end

end

@[to_additive] lemma uniform_group.to_uniform_space_eq {G : Type*} [u : uniform_space G]
  [comm_group G] [uniform_group G] : topological_group.to_uniform_space G = u :=
begin
  ext : 1,
  show @uniformity G (topological_group.to_uniform_space G) = 𝓤 G,
  rw [uniformity_eq_comap_nhds_one' G, uniformity_eq_comap_nhds_one G]
end

end topological_comm_group

open comm_group filter set function

section
variables {α : Type*} {β : Type*} {hom : Type*}
variables [topological_space α] [comm_group α] [topological_group α]

-- β is a dense subgroup of α, inclusion is denoted by e
variables [topological_space β] [comm_group β]
variables [monoid_hom_class hom β α] {e : hom} (de : dense_inducing e)
include de

@[to_additive] lemma tendsto_div_comap_self (x₀ : α) :
  tendsto (λt:β×β, t.2 / t.1) (comap (λp:β×β, (e p.1, e p.2)) $ 𝓝 (x₀, x₀)) (𝓝 1) :=
begin
  have comm : (λx:α×α, x.2/x.1) ∘ (λt:β×β, (e t.1, e t.2)) = e ∘ (λt:β×β, t.2 / t.1),
  { ext t,
    change e t.2 / e t.1 = e (t.2 / t.1),
    rwa ← map_div e t.2 t.1 },
  have lim : tendsto (λ x : α × α, x.2/x.1) (𝓝 (x₀, x₀)) (𝓝 (e 1)),
  { simpa using (continuous_div'.comp (@continuous_swap α α _ _)).tendsto (x₀, x₀) },
  simpa using de.tendsto_comap_nhds_nhds lim comm
end
end

namespace dense_inducing
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
variables {G : Type*}

-- β is a dense subgroup of α, inclusion is denoted by e
-- δ is a dense subgroup of γ, inclusion is denoted by f
variables [topological_space α] [add_comm_group α] [topological_add_group α]
variables [topological_space β] [add_comm_group β] [topological_add_group β]
variables [topological_space γ] [add_comm_group γ] [topological_add_group γ]
variables [topological_space δ] [add_comm_group δ] [topological_add_group δ]
variables [uniform_space G] [add_comm_group G] [uniform_add_group G] [separated_space G]
  [complete_space G]
variables {e : β →+ α} (de : dense_inducing e)
variables {f : δ →+ γ} (df : dense_inducing f)

variables {φ : β →+ δ →+ G}
local notation `Φ` := λ p : β × δ, φ p.1 p.2

variables  (hφ : continuous Φ)

include de df hφ

variables {W' : set G} (W'_nhd : W' ∈ 𝓝 (0 : G))
include W'_nhd

private lemma extend_Z_bilin_aux (x₀ : α) (y₁ : δ) :
  ∃ U₂ ∈ comap e (𝓝 x₀), ∀ x x' ∈ U₂, Φ (x' - x, y₁) ∈ W' :=
begin
  let Nx := 𝓝 x₀,
  let ee := λ u : β × β, (e u.1, e u.2),

  have lim1 : tendsto (λ a : β × β, (a.2 - a.1, y₁)) (comap e Nx ×ᶠ comap e Nx) (𝓝 (0, y₁)),
  { have := tendsto.prod_mk (tendsto_sub_comap_self de x₀)
      (tendsto_const_nhds : tendsto (λ (p : β × β), y₁) (comap ee $ 𝓝 (x₀, x₀)) (𝓝 y₁)),
    rw [nhds_prod_eq, prod_comap_comap_eq, ←nhds_prod_eq],
    exact (this : _) },
  have lim2 : tendsto Φ (𝓝 (0, y₁)) (𝓝 0), by simpa using hφ.tendsto (0, y₁),
  have lim := lim2.comp lim1,
  rw tendsto_prod_self_iff at lim,
  simp_rw ball_mem_comm,
  exact lim W' W'_nhd
end

private lemma extend_Z_bilin_key (x₀ : α) (y₀ : γ) :
  ∃ U ∈ comap e (𝓝 x₀), ∃ V ∈ comap f (𝓝 y₀),
    ∀ x x' ∈ U, ∀ y y' ∈ V, Φ (x', y') - Φ (x, y) ∈ W' :=
begin
  let Nx := 𝓝 x₀,
  let Ny := 𝓝 y₀,
  let dp := dense_inducing.prod de df,
  let ee := λ u : β × β, (e u.1, e u.2),
  let ff := λ u : δ × δ, (f u.1, f u.2),

  have lim_φ : filter.tendsto Φ (𝓝 (0, 0)) (𝓝 0),
  { simpa using hφ.tendsto (0, 0) },

  have lim_φ_sub_sub : tendsto (λ (p : (β × β) × (δ × δ)), Φ (p.1.2 - p.1.1, p.2.2 - p.2.1))
    ((comap ee $ 𝓝 (x₀, x₀)) ×ᶠ (comap ff $ 𝓝 (y₀, y₀))) (𝓝 0),
  { have lim_sub_sub :  tendsto (λ (p : (β × β) × δ × δ), (p.1.2 - p.1.1, p.2.2 - p.2.1))
      ((comap ee (𝓝 (x₀, x₀))) ×ᶠ (comap ff (𝓝 (y₀, y₀)))) (𝓝 0 ×ᶠ 𝓝 0),
    { have := filter.prod_mono (tendsto_sub_comap_self de x₀) (tendsto_sub_comap_self df y₀),
      rwa prod_map_map_eq at this },
    rw ← nhds_prod_eq at lim_sub_sub,
    exact tendsto.comp lim_φ lim_sub_sub },

  rcases exists_nhds_zero_quarter W'_nhd with ⟨W, W_nhd, W4⟩,

  have : ∃ U₁ ∈ comap e (𝓝 x₀), ∃ V₁ ∈ comap f (𝓝 y₀),
    ∀ x x' ∈ U₁, ∀ y y' ∈ V₁,  Φ (x'-x, y'-y) ∈ W,
  { have := tendsto_prod_iff.1 lim_φ_sub_sub W W_nhd,
    repeat { rw [nhds_prod_eq, ←prod_comap_comap_eq] at this },
    rcases this with ⟨U, U_in, V, V_in, H⟩,
    rw [mem_prod_same_iff] at U_in V_in,
    rcases U_in with ⟨U₁, U₁_in, HU₁⟩,
    rcases V_in with ⟨V₁, V₁_in, HV₁⟩,
    existsi [U₁, U₁_in, V₁, V₁_in],
    intros x x_in x' x'_in y y_in y' y'_in,
    exact H _ _ (HU₁ (mk_mem_prod x_in x'_in)) (HV₁ (mk_mem_prod y_in y'_in)) },
  rcases this with ⟨U₁, U₁_nhd, V₁, V₁_nhd, H⟩,

  obtain ⟨x₁, x₁_in⟩ : U₁.nonempty :=
    ((de.comap_nhds_ne_bot _).nonempty_of_mem U₁_nhd),
  obtain ⟨y₁, y₁_in⟩ : V₁.nonempty :=
    ((df.comap_nhds_ne_bot _).nonempty_of_mem V₁_nhd),

  have cont_flip : continuous (λ p : δ × β, φ.flip p.1 p.2),
  { show continuous (Φ ∘ prod.swap), from hφ.comp continuous_swap },
  rcases (extend_Z_bilin_aux de df hφ W_nhd x₀ y₁) with ⟨U₂, U₂_nhd, HU⟩,
  rcases (extend_Z_bilin_aux df de cont_flip W_nhd y₀ x₁) with ⟨V₂, V₂_nhd, HV⟩,

  existsi [U₁ ∩ U₂, inter_mem U₁_nhd U₂_nhd,
            V₁ ∩ V₂, inter_mem V₁_nhd V₂_nhd],

  rintros x ⟨xU₁, xU₂⟩ x' ⟨x'U₁, x'U₂⟩ y ⟨yV₁, yV₂⟩ y' ⟨y'V₁, y'V₂⟩,
  have key_formula : φ x' y' - φ x y =
    φ(x' - x) y₁ + φ (x' - x) (y' - y₁) + φ x₁ (y' - y) + φ (x - x₁) (y' - y),
  { simp, abel },
  rw key_formula,
  have h₁ := HU x xU₂ x' x'U₂,
  have h₂ := H x xU₁ x' x'U₁ y₁ y₁_in y' y'V₁,
  have h₃ := HV y yV₂ y' y'V₂,
  have h₄ := H x₁ x₁_in x xU₁ y yV₁ y' y'V₁,
  exact W4 h₁ h₂ h₃ h₄
end

omit W'_nhd

open dense_inducing

/-- Bourbaki GT III.6.5 Theorem I:
ℤ-bilinear continuous maps from dense images into a complete Hausdorff group extend by continuity.
Note: Bourbaki assumes that α and β are also complete Hausdorff, but this is not necessary. -/
theorem extend_Z_bilin  : continuous (extend (de.prod df) Φ) :=
begin
  refine continuous_extend_of_cauchy _ _,
  rintro ⟨x₀, y₀⟩,
  split,
  { apply ne_bot.map,
    apply comap_ne_bot,

    intros U h,
    rcases mem_closure_iff_nhds.1 ((de.prod df).dense (x₀, y₀)) U h with ⟨x, x_in, ⟨z, z_x⟩⟩,
    existsi z,
    cc },
  { suffices : map (λ (p : (β × δ) × (β × δ)), Φ p.2 - Φ p.1)
      (comap (λ (p : (β × δ) × β × δ), ((e p.1.1, f p.1.2), (e p.2.1, f p.2.2)))
         (𝓝 (x₀, y₀) ×ᶠ 𝓝 (x₀, y₀))) ≤ 𝓝 0,
    by rwa [uniformity_eq_comap_nhds_zero G, prod_map_map_eq, ←map_le_iff_le_comap, filter.map_map,
        prod_comap_comap_eq],

    intros W' W'_nhd,

    have key := extend_Z_bilin_key de df hφ W'_nhd x₀ y₀,
    rcases key with ⟨U, U_nhd, V, V_nhd, h⟩,
    rw mem_comap at U_nhd,
    rcases U_nhd with ⟨U', U'_nhd, U'_sub⟩,
    rw mem_comap at V_nhd,
    rcases V_nhd with ⟨V', V'_nhd, V'_sub⟩,

    rw [mem_map, mem_comap, nhds_prod_eq],
    existsi (U' ×ˢ V') ×ˢ (U' ×ˢ V'),
    rw mem_prod_same_iff,

    simp only [exists_prop],
    split,
    { change U' ∈ 𝓝 x₀ at U'_nhd,
      change V' ∈ 𝓝 y₀ at V'_nhd,
      have := prod_mem_prod U'_nhd V'_nhd,
      tauto },
    { intros p h',
      simp only [set.mem_preimage, set.prod_mk_mem_set_prod_eq] at h',
      rcases p with ⟨⟨x, y⟩, ⟨x', y'⟩⟩,
      apply h ; tauto } }
end
end dense_inducing


<|start_filename|>src/topology/algebra/star.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.star.pi
import algebra.star.prod
import topology.algebra.group

/-!
# Continuity of `star`

This file defines the `has_continuous_star` typeclass, along with instances on `pi`, `prod`,
`mul_opposite`, and `units`.
-/


open_locale filter topological_space
open filter

universes u

variables {ι α R S : Type*}

/-- Basic hypothesis to talk about a topological space with a continuous `star` operator. -/
class has_continuous_star (R : Type u) [topological_space R] [has_star R] : Prop :=
(continuous_star : continuous (star : R → R))

export has_continuous_star (continuous_star)

section continuity

variables [topological_space R] [has_star R] [has_continuous_star R]

lemma continuous_on_star {s : set R} : continuous_on star s :=
continuous_star.continuous_on

lemma continuous_within_at_star {s : set R} {x : R} : continuous_within_at star s x :=
continuous_star.continuous_within_at

lemma continuous_at_star {x : R} : continuous_at star x :=
continuous_star.continuous_at

lemma tendsto_star (a : R) : tendsto star (𝓝 a) (𝓝 (star a)) :=
continuous_at_star

lemma filter.tendsto.star {f : α → R} {l : filter α} {y : R} (h : tendsto f l (𝓝 y)) :
  tendsto (λ x, star (f x)) l (𝓝 (star y)) :=
(continuous_star.tendsto y).comp h

variables [topological_space α] {f : α → R} {s : set α} {x : α}

@[continuity]
lemma continuous.star (hf : continuous f) : continuous (λ x, star (f x)) :=
continuous_star.comp hf

lemma continuous_at.star (hf : continuous_at f x) : continuous_at (λ x, star (f x)) x :=
continuous_at_star.comp hf

lemma continuous_on.star (hf : continuous_on f s) : continuous_on (λ x, star (f x)) s :=
continuous_star.comp_continuous_on hf

lemma continuous_within_at.star (hf : continuous_within_at f s x) :
  continuous_within_at (λ x, star (f x)) s x :=
hf.star

/-- The star operation bundled as a continuous map. -/
@[simps] def star_continuous_map : C(R, R) := ⟨star, continuous_star⟩

end continuity

section instances

instance [has_star R] [has_star S] [topological_space R] [topological_space S]
  [has_continuous_star R] [has_continuous_star S] : has_continuous_star (R × S) :=
⟨(continuous_star.comp continuous_fst).prod_mk (continuous_star.comp continuous_snd)⟩

instance {C : ι → Type*} [∀ i, topological_space (C i)]
  [∀ i, has_star (C i)] [∀ i, has_continuous_star (C i)] : has_continuous_star (Π i, C i) :=
{ continuous_star := continuous_pi (λ i, continuous.star (continuous_apply i)) }

instance [has_star R] [topological_space R] [has_continuous_star R] : has_continuous_star Rᵐᵒᵖ :=
⟨mul_opposite.continuous_op.comp $ mul_opposite.continuous_unop.star⟩

instance [monoid R] [star_semigroup R] [topological_space R] [has_continuous_star R] :
  has_continuous_star Rˣ :=
⟨continuous_induced_rng units.continuous_embed_product.star⟩

end instances


<|start_filename|>src/logic/is_empty.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import logic.function.basic
import tactic.protected
/-!
# Types that are empty

In this file we define a typeclass `is_empty`, which expresses that a type has no elements.

## Main declaration

* `is_empty`: a typeclass that expresses that a type is empty.
-/

variables {α β γ : Sort*}

/-- `is_empty α` expresses that `α` is empty. -/
@[protect_proj]
class is_empty (α : Sort*) : Prop :=
(false : α → false)

instance : is_empty empty   := ⟨empty.elim⟩
instance : is_empty pempty  := ⟨pempty.elim⟩
instance : is_empty false   := ⟨id⟩
instance : is_empty (fin 0) := ⟨λ n, nat.not_lt_zero n.1 n.2⟩

protected lemma function.is_empty [is_empty β] (f : α → β) : is_empty α :=
⟨λ x, is_empty.false (f x)⟩

instance {p : α → Sort*} [h : nonempty α] [∀ x, is_empty (p x)] : is_empty (Π x, p x) :=
h.elim $ λ x, function.is_empty $ function.eval x
instance pprod.is_empty_left [is_empty α] : is_empty (pprod α β) :=
function.is_empty pprod.fst
instance pprod.is_empty_right [is_empty β] : is_empty (pprod α β) :=
function.is_empty pprod.snd
instance prod.is_empty_left {α β} [is_empty α] : is_empty (α × β) :=
function.is_empty prod.fst
instance prod.is_empty_right {α β} [is_empty β] : is_empty (α × β) :=
function.is_empty prod.snd
instance [is_empty α] [is_empty β] : is_empty (psum α β) :=
⟨λ x, psum.rec is_empty.false is_empty.false x⟩
instance {α β} [is_empty α] [is_empty β] : is_empty (α ⊕ β) :=
⟨λ x, sum.rec is_empty.false is_empty.false x⟩
/-- subtypes of an empty type are empty -/
instance [is_empty α] (p : α → Prop) : is_empty (subtype p) :=
⟨λ x, is_empty.false x.1⟩
/-- subtypes by an all-false predicate are false. -/
lemma subtype.is_empty_of_false {p : α → Prop} (hp : ∀ a, ¬(p a)) : is_empty (subtype p) :=
⟨λ x, hp _ x.2⟩
/-- subtypes by false are false. -/
instance subtype.is_empty_false : is_empty {a : α // false} :=
subtype.is_empty_of_false (λ a, id)

instance sigma.is_empty_left {α} [is_empty α] {E : α → Type*} : is_empty (sigma E) :=
function.is_empty sigma.fst

/- Test that `pi.is_empty` finds this instance. -/
example [h : nonempty α] [is_empty β] : is_empty (α → β) := by apply_instance

/-- Eliminate out of a type that `is_empty` (without using projection notation). -/
@[elab_as_eliminator]
def is_empty_elim [is_empty α] {p : α → Sort*} (a : α) : p a :=
(is_empty.false a).elim

lemma is_empty_iff : is_empty α ↔ α → false :=
⟨@is_empty.false α, is_empty.mk⟩

namespace is_empty
open function
/-- Eliminate out of a type that `is_empty` (using projection notation). -/
protected def elim (h : is_empty α) {p : α → Sort*} (a : α) : p a :=
is_empty_elim a

/-- Non-dependent version of `is_empty.elim`. Helpful if the elaborator cannot elaborate `h.elim a`
  correctly. -/
protected def elim' {β : Sort*} (h : is_empty α) (a : α) : β :=
h.elim a

protected lemma prop_iff {p : Prop} : is_empty p ↔ ¬ p :=
is_empty_iff

variables [is_empty α]

lemma forall_iff {p : α → Prop} : (∀ a, p a) ↔ true :=
iff_true_intro is_empty_elim

lemma exists_iff {p : α → Prop} : (∃ a, p a) ↔ false :=
iff_false_intro $ λ ⟨x, hx⟩, is_empty.false x

@[priority 100] -- see Note [lower instance priority]
instance : subsingleton α := ⟨is_empty_elim⟩

end is_empty

@[simp] lemma not_nonempty_iff : ¬ nonempty α ↔ is_empty α :=
⟨λ h, ⟨λ x, h ⟨x⟩⟩, λ h1 h2, h2.elim h1.elim⟩

@[simp] lemma not_is_empty_iff : ¬ is_empty α ↔ nonempty α :=
not_iff_comm.mp not_nonempty_iff

@[simp] lemma is_empty_pi {π : α → Sort*} : is_empty (Π a, π a) ↔ ∃ a, is_empty (π a) :=
by simp only [← not_nonempty_iff, classical.nonempty_pi, not_forall]

@[simp] lemma is_empty_prod {α β : Type*} : is_empty (α × β) ↔ is_empty α ∨ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_prod, not_and_distrib]

@[simp] lemma is_empty_pprod : is_empty (pprod α β) ↔ is_empty α ∨ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_pprod, not_and_distrib]

@[simp] lemma is_empty_sum {α β} : is_empty (α ⊕ β) ↔ is_empty α ∧ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_sum, not_or_distrib]

@[simp] lemma is_empty_psum {α β} : is_empty (psum α β) ↔ is_empty α ∧ is_empty β :=
by simp only [← not_nonempty_iff, nonempty_psum, not_or_distrib]

lemma well_founded_of_empty {α} [is_empty α] (r : α → α → Prop) : well_founded r :=
⟨is_empty_elim⟩ 

variables (α)

lemma is_empty_or_nonempty : is_empty α ∨ nonempty α :=
(em $ is_empty α).elim or.inl $ or.inr ∘ not_is_empty_iff.mp

@[simp] lemma not_is_empty_of_nonempty [h : nonempty α] : ¬ is_empty α :=
not_is_empty_iff.mpr h

variable {α}

lemma function.extend_of_empty [is_empty α] (f : α → β) (g : α → γ) (h : β → γ) :
  function.extend f g h = h :=
funext $ λ x, function.extend_apply' _ _ _ $ λ ⟨a, h⟩, is_empty_elim a


<|start_filename|>src/data/nat/choose/central.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import data.nat.choose.basic
import data.nat.choose.sum

/-!
# Central binomial coefficients

This file proves properties of the central binomial coefficients (that is, `nat.choose (2 * n) n`).

## Main definition and results

* `nat.central_binom`: the central binomial coefficient, `(2 * n).choose n`.
* `nat.succ_mul_central_binom_succ`: the inductive relationship between successive central binomial
  coefficients.
* `nat.four_pow_lt_mul_central_binom`: an exponential lower bound on the central binomial
  coefficient.
-/

namespace nat

/--
The central binomial coefficient, `nat.choose (2 * n) n`.
-/
def central_binom (n : ℕ) := (2 * n).choose n

lemma central_binom_eq_two_mul_choose (n : ℕ) : central_binom n = (2 * n).choose n := rfl

lemma central_binom_pos (n : ℕ) : 0 < central_binom n :=
choose_pos (nat.le_mul_of_pos_left zero_lt_two)

lemma central_binom_ne_zero (n : ℕ) : central_binom n ≠ 0 :=
(central_binom_pos n).ne'

@[simp] lemma central_binom_zero : central_binom 0 = 1 :=
choose_zero_right _

/--
The central binomial coefficient is the largest binomial coefficient.
-/
lemma choose_le_central_binom (r n : ℕ) : choose (2 * n) r ≤ central_binom n :=
calc (2 * n).choose r ≤ (2 * n).choose (2 * n / 2) : choose_le_middle r (2 * n)
... = (2 * n).choose n : by rw nat.mul_div_cancel_left n zero_lt_two

lemma two_le_central_binom (n : ℕ) (n_pos : 0 < n) : 2 ≤ central_binom n :=
calc 2 ≤ 2 * n : le_mul_of_pos_right n_pos
... = (2 * n).choose 1 : (choose_one_right (2 * n)).symm
... ≤ central_binom n : choose_le_central_binom 1 n

/--
An inductive property of the central binomial coefficient.
-/
lemma succ_mul_central_binom_succ (n : ℕ) :
  (n + 1) * central_binom (n + 1) = 2 * (2 * n + 1) * central_binom n :=
calc (n + 1) * (2 * (n + 1)).choose (n + 1) = (2 * n + 2).choose (n + 1) * (n + 1) : mul_comm _ _
... = (2 * n + 1).choose n * (2 * n + 2) : by rw [choose_succ_right_eq, choose_mul_succ_eq]
... = 2 * ((2 * n + 1).choose n * (n + 1)) : by ring
... = 2 * ((2 * n + 1).choose n * ((2 * n + 1) - n)) :
  by rw [two_mul n, add_assoc, nat.add_sub_cancel_left]
... = 2 * ((2 * n).choose n * (2 * n + 1)) : by rw choose_mul_succ_eq
... = (2 * (2 * n + 1)) * (2 * n).choose n : by rw [mul_assoc, mul_comm (2 * n + 1)]

/--
An exponential lower bound on the central binomial coefficient.
This bound is of interest because it appears in
[Tochiori's refinement of Erdős's proof of Bertrand's postulate](tochiori_bertrand).
-/
lemma four_pow_lt_mul_central_binom (n : ℕ) (n_big : 4 ≤ n) : 4 ^ n < n * central_binom n :=
begin
  induction n using nat.strong_induction_on with n IH,
  rcases lt_trichotomy n 4 with (hn|rfl|hn),
  { clear IH, dec_trivial! },
  { norm_num [central_binom, choose] },
  obtain ⟨n, rfl⟩ : ∃ m, n = m + 1 := nat.exists_eq_succ_of_ne_zero (zero_lt_four.trans hn).ne',
  calc 4 ^ (n + 1) < 4 * (n * central_binom n) :
      (mul_lt_mul_left zero_lt_four).mpr (IH n n.lt_succ_self (nat.le_of_lt_succ hn))
  ... ≤ 2 * (2 * n + 1) * central_binom n : by { rw ← mul_assoc, linarith }
  ... = (n + 1) * central_binom (n + 1) : (succ_mul_central_binom_succ n).symm,
end

/--
An exponential lower bound on the central binomial coefficient.
This bound is weaker than `four_pow_n_lt_n_mul_central_binom`, but it is of historical interest
because it appears in Erdős's proof of Bertrand's postulate.
-/
lemma four_pow_le_two_mul_self_mul_central_binom : ∀ (n : ℕ) (n_pos : 0 < n),
  4 ^ n ≤ (2 * n) * central_binom n
| 0 pr := (nat.not_lt_zero _ pr).elim
| 1 pr := by norm_num [central_binom, choose]
| 2 pr := by norm_num [central_binom, choose]
| 3 pr := by norm_num [central_binom, choose]
| n@(m + 4) _ :=
calc 4 ^ n ≤ n * central_binom n : (four_pow_lt_mul_central_binom _ le_add_self).le
... ≤ 2 * n * central_binom n    : by { rw [mul_assoc], refine le_mul_of_pos_left zero_lt_two }

end nat


<|start_filename|>src/analysis/asymptotics/superpolynomial_decay.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.asymptotics.asymptotics
import analysis.normed_space.ordered
import data.polynomial.eval
import topology.algebra.order.liminf_limsup

/-!
# Super-Polynomial Function Decay

This file defines a predicate `asymptotics.superpolynomial_decay f` for a function satisfying
  one of following equivalent definitions (The definition is in terms of the first condition):

* `x ^ n * f` tends to `𝓝 0` for all (or sufficiently large) naturals `n`
* `|x ^ n * f|` tends to `𝓝 0` for all naturals `n` (`superpolynomial_decay_iff_abs_tendsto_zero`)
* `|x ^ n * f|` is bounded for all naturals `n` (`superpolynomial_decay_iff_abs_is_bounded_under`)
* `f` is `o(x ^ c)` for all integers `c` (`superpolynomial_decay_iff_is_o`)
* `f` is `O(x ^ c)` for all integers `c` (`superpolynomial_decay_iff_is_O`)

These conditions are all equivalent to conditions in terms of polynomials, replacing `x ^ c` with
  `p(x)` or `p(x)⁻¹` as appropriate, since asymptotically `p(x)` behaves like `X ^ p.nat_degree`.
These further equivalences are not proven in mathlib but would be good future projects.

The definition of superpolynomial decay for `f : α → β` is relative to a parameter `k : α → β`.
Super-polynomial decay then means `f x` decays faster than `(k x) ^ c` for all integers `c`.
Equivalently `f x` decays faster than `p.eval (k x)` for all polynomials `p : polynomial β`.
The definition is also relative to a filter `l : filter α` where the decay rate is compared.

When the map `k` is given by `n ↦ ↑n : ℕ → ℝ` this defines negligible functions:
https://en.wikipedia.org/wiki/Negligible_function

When the map `k` is given by `(r₁,...,rₙ) ↦ r₁*...*rₙ : ℝⁿ → ℝ` this is equivalent
  to the definition of rapidly decreasing functions given here:
https://ncatlab.org/nlab/show/rapidly+decreasing+function

# Main Theorems

* `superpolynomial_decay.polynomial_mul` says that if `f(x)` is negligible,
    then so is `p(x) * f(x)` for any polynomial `p`.
* `superpolynomial_decay_iff_zpow_tendsto_zero` gives an equivalence between definitions in terms
    of decaying faster than `k(x) ^ n` for all naturals `n` or `k(x) ^ c` for all integer `c`.
-/

namespace asymptotics

open_locale topological_space
open filter

/-- `f` has superpolynomial decay in parameter `k` along filter `l` if
  `k ^ n * f` tends to zero at `l` for all naturals `n` -/
def superpolynomial_decay {α β : Type*} [topological_space β] [comm_semiring β]
  (l : filter α) (k : α → β) (f : α → β) :=
∀ (n : ℕ), tendsto (λ (a : α), (k a) ^ n * f a) l (𝓝 0)

variables {α β : Type*} {l : filter α} {k : α → β} {f g g' : α → β}

section comm_semiring

variables [topological_space β] [comm_semiring β]

lemma superpolynomial_decay.congr' (hf : superpolynomial_decay l k f)
  (hfg : f =ᶠ[l] g) : superpolynomial_decay l k g :=
λ z, (hf z).congr' (eventually_eq.mul (eventually_eq.refl l _) hfg)

lemma superpolynomial_decay.congr (hf : superpolynomial_decay l k f)
  (hfg : ∀ x, f x = g x) : superpolynomial_decay l k g :=
λ z, (hf z).congr (λ x, congr_arg (λ a, k x ^ z * a) $ hfg x)

@[simp]
lemma superpolynomial_decay_zero (l : filter α) (k : α → β) :
  superpolynomial_decay l k 0 :=
λ z, by simpa only [pi.zero_apply, mul_zero] using tendsto_const_nhds

lemma superpolynomial_decay.add [has_continuous_add β] (hf : superpolynomial_decay l k f)
  (hg : superpolynomial_decay l k g) : superpolynomial_decay l k (f + g) :=
λ z, by simpa only [mul_add, add_zero, pi.add_apply] using (hf z).add (hg z)

lemma superpolynomial_decay.mul [has_continuous_mul β] (hf : superpolynomial_decay l k f)
  (hg : superpolynomial_decay l k g) : superpolynomial_decay l k (f * g) :=
λ z, by simpa only [mul_assoc, one_mul, mul_zero, pow_zero] using (hf z).mul (hg 0)

lemma superpolynomial_decay.mul_const [has_continuous_mul β] (hf : superpolynomial_decay l k f)
  (c : β) : superpolynomial_decay l k (λ n, f n * c) :=
λ z, by simpa only [←mul_assoc, zero_mul] using tendsto.mul_const c (hf z)

lemma superpolynomial_decay.const_mul [has_continuous_mul β] (hf : superpolynomial_decay l k f)
  (c : β) : superpolynomial_decay l k (λ n, c * f n) :=
(hf.mul_const c).congr (λ _, mul_comm _ _)

lemma superpolynomial_decay.param_mul (hf : superpolynomial_decay l k f) :
  superpolynomial_decay l k (k * f) :=
λ z, tendsto_nhds.2 (λ s hs hs0, l.sets_of_superset ((tendsto_nhds.1 (hf $ z + 1)) s hs hs0)
  (λ x hx, by simpa only [set.mem_preimage, pi.mul_apply, ← mul_assoc, ← pow_succ'] using hx))

lemma superpolynomial_decay.mul_param (hf : superpolynomial_decay l k f) :
  superpolynomial_decay l k (f * k) :=
(hf.param_mul).congr (λ _, mul_comm _ _)

lemma superpolynomial_decay.param_pow_mul (hf : superpolynomial_decay l k f)
  (n : ℕ) : superpolynomial_decay l k (k ^ n * f) :=
begin
  induction n with n hn,
  { simpa only [one_mul, pow_zero] using hf },
  { simpa only [pow_succ, mul_assoc] using hn.param_mul }
end

lemma superpolynomial_decay.mul_param_pow (hf : superpolynomial_decay l k f)
  (n : ℕ) : superpolynomial_decay l k (f * k ^ n) :=
(hf.param_pow_mul n).congr (λ _, mul_comm _ _)

lemma superpolynomial_decay.polynomial_mul [has_continuous_add β] [has_continuous_mul β]
  (hf : superpolynomial_decay l k f) (p : polynomial β) :
  superpolynomial_decay l k (λ x, (p.eval $ k x) * f x) :=
polynomial.induction_on' p (λ p q hp hq, by simpa [add_mul] using hp.add hq)
  (λ n c, by simpa [mul_assoc] using (hf.param_pow_mul n).const_mul c)

lemma superpolynomial_decay.mul_polynomial [has_continuous_add β] [has_continuous_mul β]
  (hf : superpolynomial_decay l k f) (p : polynomial β) :
  superpolynomial_decay l k (λ x, f x * (p.eval $ k x)) :=
(hf.polynomial_mul p).congr (λ _, mul_comm _ _)

end comm_semiring

section ordered_comm_semiring

variables [topological_space β] [ordered_comm_semiring β] [order_topology β]

lemma superpolynomial_decay.trans_eventually_le (hk : 0 ≤ᶠ[l] k)
  (hg : superpolynomial_decay l k g) (hg' : superpolynomial_decay l k g')
  (hfg : g ≤ᶠ[l] f) (hfg' : f ≤ᶠ[l] g') : superpolynomial_decay l k f :=
λ z, tendsto_of_tendsto_of_tendsto_of_le_of_le' (hg z) (hg' z)
  (hfg.mp (hk.mono $ λ x hx hx', mul_le_mul_of_nonneg_left hx' (pow_nonneg hx z)))
  (hfg'.mp (hk.mono $ λ x hx hx', mul_le_mul_of_nonneg_left hx' (pow_nonneg hx z)))

end ordered_comm_semiring

section linear_ordered_comm_ring

variables [topological_space β] [linear_ordered_comm_ring β] [order_topology β]

variables (l k f)

lemma superpolynomial_decay_iff_abs_tendsto_zero :
  superpolynomial_decay l k f ↔ ∀ (n : ℕ), tendsto (λ (a : α), |(k a) ^ n * f a|) l (𝓝 0) :=
⟨λ h z, (tendsto_zero_iff_abs_tendsto_zero _).1 (h z),
  λ h z, (tendsto_zero_iff_abs_tendsto_zero _).2 (h z)⟩

lemma superpolynomial_decay_iff_superpolynomial_decay_abs :
  superpolynomial_decay l k f ↔ superpolynomial_decay l (λ a, |k a|) (λ a, |f a|) :=
(superpolynomial_decay_iff_abs_tendsto_zero l k f).trans
  (by simp_rw [superpolynomial_decay, abs_mul, abs_pow])

variables {l k f}

lemma superpolynomial_decay.trans_eventually_abs_le (hf : superpolynomial_decay l k f)
  (hfg : abs ∘ g ≤ᶠ[l] abs ∘ f) : superpolynomial_decay l k g :=
begin
  rw superpolynomial_decay_iff_abs_tendsto_zero at hf ⊢,
  refine λ z, tendsto_of_tendsto_of_tendsto_of_le_of_le' (tendsto_const_nhds) (hf z)
    (eventually_of_forall $ λ x, abs_nonneg _) (hfg.mono $ λ x hx, _),
  calc |k x ^ z * g x| = |k x ^ z| * |g x| : abs_mul (k x ^ z) (g x)
    ... ≤ |k x ^ z| * |f x| : mul_le_mul le_rfl hx (abs_nonneg _) (abs_nonneg _)
    ... = |k x ^ z * f x| : (abs_mul (k x ^ z) (f x)).symm,
end

lemma superpolynomial_decay.trans_abs_le (hf : superpolynomial_decay l k f)
  (hfg : ∀ x, |g x| ≤ |f x|) : superpolynomial_decay l k g :=
hf.trans_eventually_abs_le (eventually_of_forall hfg)

end linear_ordered_comm_ring

section field

variables [topological_space β] [field β] (l k f)

lemma superpolynomial_decay_mul_const_iff [has_continuous_mul β] {c : β} (hc0 : c ≠ 0) :
  superpolynomial_decay l k (λ n, f n * c) ↔ superpolynomial_decay l k f :=
⟨λ h, (h.mul_const c⁻¹).congr (λ x, by simp [mul_assoc, mul_inv_cancel hc0]), λ h, h.mul_const c⟩

lemma superpolynomial_decay_const_mul_iff [has_continuous_mul β] {c : β} (hc0 : c ≠ 0) :
  superpolynomial_decay l k (λ n, c * f n) ↔ superpolynomial_decay l k f :=
⟨λ h, (h.const_mul c⁻¹).congr (λ x, by simp [← mul_assoc, inv_mul_cancel hc0]), λ h, h.const_mul c⟩

variables {l k f}

end field

section linear_ordered_field

variables [topological_space β] [linear_ordered_field β] [order_topology β]

variable (f)

lemma superpolynomial_decay_iff_abs_is_bounded_under (hk : tendsto k l at_top) :
  superpolynomial_decay l k f ↔ ∀ (z : ℕ), is_bounded_under (≤) l (λ (a : α), |(k a) ^ z * f a|) :=
begin
  refine ⟨λ h z, tendsto.is_bounded_under_le (tendsto.abs (h z)),
    λ h, (superpolynomial_decay_iff_abs_tendsto_zero l k f).2 (λ z, _)⟩,
  obtain ⟨m, hm⟩ := h (z + 1),
  have h1 : tendsto (λ (a : α), (0 : β)) l (𝓝 0) := tendsto_const_nhds,
  have h2 : tendsto (λ (a : α), |(k a)⁻¹| * m) l (𝓝 0) := (zero_mul m) ▸ tendsto.mul_const m
    ((tendsto_zero_iff_abs_tendsto_zero _).1 hk.inv_tendsto_at_top),
  refine tendsto_of_tendsto_of_tendsto_of_le_of_le' h1 h2
    (eventually_of_forall (λ x, abs_nonneg _)) ((eventually_map.1 hm).mp _),
  refine ((hk.eventually_ne_at_top 0).mono $ λ x hk0 hx, _),
  refine eq.trans_le _ (mul_le_mul_of_nonneg_left hx $ abs_nonneg (k x)⁻¹),
  rw [← abs_mul, ← mul_assoc, pow_succ, ← mul_assoc, inv_mul_cancel hk0, one_mul],
end

lemma superpolynomial_decay_iff_zpow_tendsto_zero (hk : tendsto k l at_top) :
  superpolynomial_decay l k f ↔ ∀ (z : ℤ), tendsto (λ (a : α), (k a) ^ z * f a) l (𝓝 0) :=
begin
  refine ⟨λ h z, _, λ h n, by simpa only [zpow_coe_nat] using h (n : ℤ)⟩,
  by_cases hz : 0 ≤ z,
  { lift z to ℕ using hz,
    simpa using h z },
  { have : tendsto (λ a, (k a) ^ z) l (𝓝 0) :=
      tendsto.comp (tendsto_zpow_at_top_zero (not_le.1 hz)) hk,
    have h : tendsto f l (𝓝 0) := by simpa using h 0,
    exact (zero_mul (0 : β)) ▸ this.mul h },
end

variable {f}

lemma superpolynomial_decay.param_zpow_mul (hk : tendsto k l at_top)
  (hf : superpolynomial_decay l k f) (z : ℤ) : superpolynomial_decay l k (λ a, k a ^ z * f a) :=
begin
  rw superpolynomial_decay_iff_zpow_tendsto_zero _ hk at hf ⊢,
  refine λ z', (hf $ z' + z).congr' ((hk.eventually_ne_at_top 0).mono (λ x hx, _)),
  simp [zpow_add₀ hx, mul_assoc, pi.mul_apply],
end

lemma superpolynomial_decay.mul_param_zpow (hk : tendsto k l at_top)
  (hf : superpolynomial_decay l k f) (z : ℤ) : superpolynomial_decay l k (λ a, f a * k a ^ z) :=
(hf.param_zpow_mul hk z).congr (λ _, mul_comm _ _)

lemma superpolynomial_decay.inv_param_mul (hk : tendsto k l at_top)
  (hf : superpolynomial_decay l k f) : superpolynomial_decay l k (k⁻¹ * f) :=
by simpa using (hf.param_zpow_mul hk (-1))

lemma superpolynomial_decay.param_inv_mul (hk : tendsto k l at_top)
  (hf : superpolynomial_decay l k f) : superpolynomial_decay l k (f * k⁻¹) :=
(hf.inv_param_mul hk).congr (λ _, mul_comm _ _)

variable (f)

lemma superpolynomial_decay_param_mul_iff (hk : tendsto k l at_top) :
  superpolynomial_decay l k (k * f) ↔ superpolynomial_decay l k f :=
⟨λ h, (h.inv_param_mul hk).congr' ((hk.eventually_ne_at_top 0).mono
  (λ x hx, by simp [← mul_assoc, inv_mul_cancel hx])), λ h, h.param_mul⟩

lemma superpolynomial_decay_mul_param_iff (hk : tendsto k l at_top) :
  superpolynomial_decay l k (f * k) ↔ superpolynomial_decay l k f :=
by simpa [mul_comm k] using superpolynomial_decay_param_mul_iff f hk

lemma superpolynomial_decay_param_pow_mul_iff (hk : tendsto k l at_top) (n : ℕ) :
  superpolynomial_decay l k (k ^ n * f) ↔ superpolynomial_decay l k f :=
begin
  induction n with n hn,
  { simp },
  { simpa [pow_succ, ← mul_comm k, mul_assoc,
      superpolynomial_decay_param_mul_iff (k ^ n * f) hk] using hn }
end

lemma superpolynomial_decay_mul_param_pow_iff (hk : tendsto k l at_top) (n : ℕ) :
  superpolynomial_decay l k (f * k ^ n) ↔ superpolynomial_decay l k f :=
by simpa [mul_comm f] using superpolynomial_decay_param_pow_mul_iff f hk n

variable {f}

end linear_ordered_field

section normed_linear_ordered_field

variable [normed_linear_ordered_field β]

variables (l k f)

lemma superpolynomial_decay_iff_norm_tendsto_zero :
  superpolynomial_decay l k f ↔ ∀ (n : ℕ), tendsto (λ (a : α), ∥(k a) ^ n * f a∥) l (𝓝 0) :=
⟨λ h z, tendsto_zero_iff_norm_tendsto_zero.1 (h z),
  λ h z, tendsto_zero_iff_norm_tendsto_zero.2 (h z)⟩

lemma superpolynomial_decay_iff_superpolynomial_decay_norm :
  superpolynomial_decay l k f ↔ superpolynomial_decay l (λ a, ∥k a∥) (λ a, ∥f a∥) :=
(superpolynomial_decay_iff_norm_tendsto_zero l k f).trans (by simp [superpolynomial_decay])

variables {l k}

variable [order_topology β]

lemma superpolynomial_decay_iff_is_O (hk : tendsto k l at_top) :
  superpolynomial_decay l k f ↔ ∀ (z : ℤ), f =O[l] (λ (a : α), (k a) ^ z) :=
begin
  refine (superpolynomial_decay_iff_zpow_tendsto_zero f hk).trans _,
  have hk0 : ∀ᶠ x in l, k x ≠ 0 := hk.eventually_ne_at_top 0,
  refine ⟨λ h z, _, λ h z, _⟩,
  { refine is_O_of_div_tendsto_nhds (hk0.mono (λ x hx hxz, absurd (zpow_eq_zero hxz) hx)) 0 _,
    have : (λ (a : α), k a ^ z)⁻¹ = (λ (a : α), k a ^ (- z)) := funext (λ x, by simp),
    rw [div_eq_mul_inv, mul_comm f, this],
    exact h (-z) },
  { suffices : (λ (a : α), k a ^ z * f a) =O[l] (λ (a : α), (k a)⁻¹),
      from is_O.trans_tendsto this hk.inv_tendsto_at_top,
    refine ((is_O_refl (λ a, (k a) ^ z) l).mul (h (- (z + 1)))).trans
      (is_O.of_bound 1 $ hk0.mono (λ a ha0, _)),
    simp only [one_mul, neg_add z 1, zpow_add₀ ha0, ← mul_assoc, zpow_neg,
      mul_inv_cancel (zpow_ne_zero z ha0), zpow_one] }
end

lemma superpolynomial_decay_iff_is_o (hk : tendsto k l at_top) :
  superpolynomial_decay l k f ↔ ∀ (z : ℤ), f =o[l] (λ (a : α), (k a) ^ z) :=
begin
  refine ⟨λ h z, _, λ h, (superpolynomial_decay_iff_is_O f hk).2 (λ z, (h z).is_O)⟩,
  have hk0 : ∀ᶠ x in l, k x ≠ 0 := hk.eventually_ne_at_top 0,
  have : (λ (x : α), (1 : β)) =o[l] k := is_o_of_tendsto'
    (hk0.mono (λ x hkx hkx', absurd hkx' hkx)) (by simpa using hk.inv_tendsto_at_top),
  have : f =o[l] (λ (x : α), k x * k x ^ (z - 1)),
    by simpa using this.mul_is_O (((superpolynomial_decay_iff_is_O f hk).1 h) $ z - 1),
  refine this.trans_is_O (is_O.of_bound 1 (hk0.mono $ λ x hkx, le_of_eq _)),
  rw [one_mul, zpow_sub_one₀ hkx, mul_comm (k x), mul_assoc, inv_mul_cancel hkx, mul_one],
end

end normed_linear_ordered_field

end asymptotics


<|start_filename|>src/order/succ_pred/interval_succ.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import order.succ_pred.basic
import data.set.lattice

/-!
# Intervals `Ixx (f x) (f (order.succ x))`

In this file we prove

* `monotone.bUnion_Ico_Ioc_map_succ`: if `α` is a linear archimedean succ order and `β` is a linear
  order, then for any monotone function `f` and `m n : α`, the union of intervals
  `set.Ioc (f i) (f (order.succ i))`, `m ≤ i < n`, is equal to `set.Ioc (f m) (f n)`;

* `monotone.pairwise_disjoint_on_Ioc_succ`: if `α` is a linear succ order, `β` is a preorder, and
  `f : α → β` is a monotone function, then the intervals `set.Ioc (f n) (f (order.succ n))` are
  pairwise disjoint.

For the latter lemma, we also prove various order dual versions.
-/

open set order

variables {α β : Type*} [linear_order α]

namespace monotone

/-- If `α` is a linear archimedean succ order and `β` is a linear order, then for any monotone
function `f` and `m n : α`, the union of intervals `set.Ioc (f i) (f (order.succ i))`, `m ≤ i < n`,
is equal to `set.Ioc (f m) (f n)` -/
lemma bUnion_Ico_Ioc_map_succ [succ_order α] [is_succ_archimedean α]
  [linear_order β] {f : α → β} (hf : monotone f) (m n : α) :
  (⋃ i ∈ Ico m n, Ioc (f i) (f (succ i))) = Ioc (f m) (f n) :=
begin
  cases le_total n m with hnm hmn,
  { rw [Ico_eq_empty_of_le hnm, Ioc_eq_empty_of_le (hf hnm), bUnion_empty] },
  { refine succ.rec _ _ hmn,
    { simp only [Ioc_self, Ico_self, bUnion_empty] },
    { intros k hmk ihk,
      rw [← Ioc_union_Ioc_eq_Ioc (hf hmk) (hf $ le_succ _), union_comm, ← ihk],
      by_cases hk : is_max k,
      { rw [hk.succ_eq, Ioc_self, empty_union] },
      { rw [Ico_succ_right_eq_insert_of_not_is_max hmk hk, bUnion_insert] } } }
end

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioc (f n) (f (order.succ n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioc_succ [succ_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ioc (f n) (f (succ n)))) :=
(pairwise_disjoint_on _).2 $ λ m n hmn x ⟨⟨_, h₁⟩, ⟨h₂, _⟩⟩, h₂.not_le $
  h₁.trans $ hf $ succ_le_of_lt hmn

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ico (f n) (f (order.succ n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_succ [succ_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ico (f n) (f (succ n)))) :=
(pairwise_disjoint_on _).2 $ λ m n hmn x ⟨⟨_, h₁⟩, ⟨h₂, _⟩⟩, h₁.not_le $
  (hf $ succ_le_of_lt hmn).trans h₂

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioo (f n) (f (order.succ n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_succ [succ_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ioo (f n) (f (succ n)))) :=
hf.pairwise_disjoint_on_Ico_succ.mono $ λ i j h, h.mono Ioo_subset_Ico_self Ioo_subset_Ico_self

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioc (f order.pred n) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioc_pred [pred_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ioc (f (pred n)) (f n))) :=
by simpa only [(∘), dual_Ico] using hf.dual.pairwise_disjoint_on_Ico_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ico (f order.pred n) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_pred [pred_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ico (f (pred n)) (f n))) :=
by simpa only [(∘), dual_Ioc] using hf.dual.pairwise_disjoint_on_Ioc_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is a monotone function, then
the intervals `set.Ioo (f order.pred n) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_pred [pred_order α] [preorder β] {f : α → β} (hf : monotone f) :
  pairwise (disjoint on (λ n, Ioo (f (pred n)) (f n))) :=
by simpa only [(∘), dual_Ioo] using hf.dual.pairwise_disjoint_on_Ioo_succ

end monotone

namespace antitone

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioc (f (order.succ n)) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioc_succ [succ_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioc (f (succ n)) (f n))) :=
hf.dual_left.pairwise_disjoint_on_Ioc_pred

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ico (f (order.succ n)) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_succ [succ_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ico (f (succ n)) (f n))) :=
hf.dual_left.pairwise_disjoint_on_Ico_pred

/-- If `α` is a linear succ order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioo (f (order.succ n)) (f n)` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_succ [succ_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioo (f (succ n)) (f n))) :=
hf.dual_left.pairwise_disjoint_on_Ioo_pred

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioc (f n) (f (order.pred n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioc_pred [pred_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioc (f n) (f (pred n)))) :=
hf.dual_left.pairwise_disjoint_on_Ioc_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ico (f n) (f (order.pred n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ico_pred [pred_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ico (f n) (f (pred n)))) :=
hf.dual_left.pairwise_disjoint_on_Ico_succ

/-- If `α` is a linear pred order, `β` is a preorder, and `f : α → β` is an antitone function, then
the intervals `set.Ioo (f n) (f (order.pred n))` are pairwise disjoint. -/
lemma pairwise_disjoint_on_Ioo_pred [pred_order α] [preorder β] {f : α → β} (hf : antitone f) :
  pairwise (disjoint on (λ n, Ioo (f n) (f (pred n)))) :=
hf.dual_left.pairwise_disjoint_on_Ioo_succ

end antitone


<|start_filename|>src/analysis/special_functions/gamma.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.integral.exp_decay
import analysis.calculus.parametric_integral

/-!
# The Gamma function

This file defines the `Γ` function (of a real or complex variable `s`). We define this by Euler's
integral `Γ(s) = ∫ x in Ioi 0, exp (-x) * x ^ (s - 1)` in the range where this integral converges
(i.e., for `0 < s` in the real case, and `0 < re s` in the complex case).

We show that this integral satisfies `Γ(1) = 1` and `Γ(s + 1) = s * Γ(s)`; hence we can define
`Γ(s)` for all `s` as the unique function satisfying this recurrence and agreeing with Euler's
integral in the convergence range. In the complex case we also prove that the resulting function is
holomorphic on `ℂ` away from the points `{-n : n ∈ ℤ}`.

## Tags

Gamma
-/

noncomputable theory
open filter interval_integral set real measure_theory asymptotics
open_locale topological_space

lemma integral_exp_neg_Ioi : ∫ (x : ℝ) in Ioi 0, exp (-x) = 1 :=
begin
  refine tendsto_nhds_unique (interval_integral_tendsto_integral_Ioi _ _ tendsto_id) _,
  { simpa only [neg_mul, one_mul] using exp_neg_integrable_on_Ioi 0 zero_lt_one, },
  { simpa using tendsto_exp_neg_at_top_nhds_0.const_sub 1, },
end

namespace real

/-- Asymptotic bound for the `Γ` function integrand. -/
lemma Gamma_integrand_is_o (s : ℝ) :
  (λ x:ℝ, exp (-x) * x ^ s) =o[at_top] (λ x:ℝ, exp (-(1/2) * x)) :=
begin
  refine is_o_of_tendsto (λ x hx, _) _,
  { exfalso, exact (exp_pos (-(1 / 2) * x)).ne' hx },
  have : (λ (x:ℝ), exp (-x) * x ^ s / exp (-(1 / 2) * x)) = (λ (x:ℝ), exp ((1 / 2) * x) / x ^ s )⁻¹,
  { ext1 x,
    field_simp [exp_ne_zero, exp_neg, ← real.exp_add],
    left,
    ring },
  rw this,
  exact (tendsto_exp_mul_div_rpow_at_top s (1 / 2) one_half_pos).inv_tendsto_at_top,
end

/-- Euler's integral for the `Γ` function (of a real variable `s`), defined as
`∫ x in Ioi 0, exp (-x) * x ^ (s - 1)`.

See `Gamma_integral_convergent` for a proof of the convergence of the integral for `0 < s`. -/
def Gamma_integral (s : ℝ) : ℝ := ∫ x in Ioi (0:ℝ), exp (-x) * x ^ (s - 1)

/-- The integral defining the `Γ` function converges for positive real `s`. -/
lemma Gamma_integral_convergent {s : ℝ} (h : 0 < s) :
  integrable_on (λ x:ℝ, exp (-x) * x ^ (s - 1)) (Ioi 0) :=
begin
  rw [←Ioc_union_Ioi_eq_Ioi (@zero_le_one ℝ _ _ _ _), integrable_on_union],
  split,
  { rw ←integrable_on_Icc_iff_integrable_on_Ioc,
    refine integrable_on.continuous_on_mul continuous_on_id.neg.exp _ is_compact_Icc,
    refine (interval_integrable_iff_integrable_Icc_of_le zero_le_one).mp _,
    exact interval_integrable_rpow' (by linarith), },
  { refine integrable_of_is_O_exp_neg one_half_pos _ (Gamma_integrand_is_o _ ).is_O,
    refine continuous_on_id.neg.exp.mul (continuous_on_id.rpow_const _),
    intros x hx,
    exact or.inl ((zero_lt_one : (0 : ℝ) < 1).trans_le hx).ne' }
end

lemma Gamma_integral_one : Gamma_integral 1 = 1 :=
by simpa only [Gamma_integral, sub_self, rpow_zero, mul_one] using integral_exp_neg_Ioi

end real

namespace complex
/- Technical note: In defining the Gamma integrand exp (-x) * x ^ (s - 1) for s complex, we have to
make a choice between ↑(real.exp (-x)), complex.exp (↑(-x)), and complex.exp (-↑x), all of which are
equal but not definitionally so. We use the first of these throughout. -/


/-- The integral defining the `Γ` function converges for complex `s` with `0 < re s`.

This is proved by reduction to the real case. -/
lemma Gamma_integral_convergent {s : ℂ} (hs : 0 < s.re) :
  integrable_on (λ x, (-x).exp * x ^ (s - 1) : ℝ → ℂ) (Ioi 0) :=
begin
  split,
  { refine continuous_on.ae_strongly_measurable _ measurable_set_Ioi,
    apply (continuous_of_real.comp continuous_neg.exp).continuous_on.mul,
    apply continuous_at.continuous_on,
    intros x hx,
    have : continuous_at (λ x:ℂ, x ^ (s - 1)) ↑x,
    { apply continuous_at_cpow_const, rw of_real_re, exact or.inl hx, },
    exact continuous_at.comp this continuous_of_real.continuous_at },
  { rw ←has_finite_integral_norm_iff,
    refine has_finite_integral.congr (real.Gamma_integral_convergent hs).2 _,
    refine (ae_restrict_iff' measurable_set_Ioi).mpr (ae_of_all _ (λ x hx, _)),
    dsimp only,
    rw [norm_eq_abs, abs_mul, abs_of_nonneg $ le_of_lt $ exp_pos $ -x,
      abs_cpow_eq_rpow_re_of_pos hx _],
    simp }
end

/-- Euler's integral for the `Γ` function (of a complex variable `s`), defined as
`∫ x in Ioi 0, exp (-x) * x ^ (s - 1)`.

See `complex.Gamma_integral_convergent` for a proof of the convergence of the integral for
`0 < re s`. -/
def Gamma_integral (s : ℂ) : ℂ := ∫ x in Ioi (0:ℝ), ↑(-x).exp * ↑x ^ (s - 1)

lemma Gamma_integral_of_real (s : ℝ) :
  Gamma_integral ↑s = ↑(s.Gamma_integral) :=
begin
  rw [real.Gamma_integral, ←integral_of_real],
  refine set_integral_congr measurable_set_Ioi _,
  intros x hx, dsimp only,
  rw [of_real_mul, of_real_cpow (mem_Ioi.mp hx).le],
  simp,
end

lemma Gamma_integral_one : Gamma_integral 1 = 1 :=
begin
  rw [←of_real_one, Gamma_integral_of_real, of_real_inj],
  exact real.Gamma_integral_one,
end

end complex

/-! Now we establish the recurrence relation `Γ(s + 1) = s * Γ(s)` using integration by parts. -/

namespace complex

section Gamma_recurrence

/-- The indefinite version of the `Γ` function, `Γ(s, X) = ∫ x ∈ 0..X, exp(-x) x ^ (s - 1)`. -/
def partial_Gamma (s : ℂ) (X : ℝ) : ℂ := ∫ x in 0..X, (-x).exp * x ^ (s - 1)

lemma tendsto_partial_Gamma {s : ℂ} (hs: 0 < s.re) :
  tendsto (λ X:ℝ, partial_Gamma s X) at_top (𝓝 $ Gamma_integral s) :=
interval_integral_tendsto_integral_Ioi 0 (Gamma_integral_convergent hs) tendsto_id

private lemma Gamma_integrand_interval_integrable (s : ℂ) {X : ℝ} (hs : 0 < s.re) (hX : 0 ≤ X):
  interval_integrable (λ x, (-x).exp * x ^ (s - 1) : ℝ → ℂ) volume 0 X :=
begin
  rw interval_integrable_iff_integrable_Ioc_of_le hX,
  exact integrable_on.mono_set (Gamma_integral_convergent hs) Ioc_subset_Ioi_self
end

private lemma Gamma_integrand_deriv_integrable_A {s : ℂ} (hs : 0 < s.re) {X : ℝ} (hX : 0 ≤ X):
 interval_integrable (λ x, -((-x).exp * x ^ s) : ℝ → ℂ) volume 0 X :=
begin
  convert (Gamma_integrand_interval_integrable (s+1) _ hX).neg,
  { ext1, simp only [add_sub_cancel, pi.neg_apply] },
  { simp only [add_re, one_re], linarith,},
end

private lemma Gamma_integrand_deriv_integrable_B {s : ℂ} (hs : 0 < s.re) {Y : ℝ} (hY : 0 ≤ Y) :
  interval_integrable (λ (x : ℝ), (-x).exp * (s * x ^ (s - 1)) : ℝ → ℂ) volume 0 Y :=
begin
  have : (λ x, (-x).exp * (s * x ^ (s - 1)) : ℝ → ℂ) =
    (λ x, s * ((-x).exp * x ^ (s - 1)) : ℝ → ℂ),
  { ext1, ring, },
  rw [this, interval_integrable_iff_integrable_Ioc_of_le hY],
  split,
  { refine (continuous_on_const.mul _).ae_strongly_measurable measurable_set_Ioc,
    apply (continuous_of_real.comp continuous_neg.exp).continuous_on.mul,
    apply continuous_at.continuous_on,
    intros x hx,
    refine (_ : continuous_at (λ x:ℂ, x ^ (s - 1)) _).comp continuous_of_real.continuous_at,
    apply continuous_at_cpow_const, rw of_real_re, exact or.inl hx.1, },
  rw ←has_finite_integral_norm_iff,
  simp_rw [norm_eq_abs, complex.abs_mul],
  refine (((real.Gamma_integral_convergent hs).mono_set
    Ioc_subset_Ioi_self).has_finite_integral.congr _).const_mul _,
  rw [eventually_eq, ae_restrict_iff'],
  { apply ae_of_all, intros x hx,
    rw [abs_of_nonneg (exp_pos _).le,abs_cpow_eq_rpow_re_of_pos hx.1],
    simp },
  { exact measurable_set_Ioc},
end

/-- The recurrence relation for the indefinite version of the `Γ` function. -/
lemma partial_Gamma_add_one {s : ℂ} (hs: 0 < s.re) {X : ℝ} (hX : 0 ≤ X) :
  partial_Gamma (s + 1) X = s * partial_Gamma s X - (-X).exp * X ^ s :=
begin
  rw [partial_Gamma, partial_Gamma, add_sub_cancel],
  have F_der_I: (∀ (x:ℝ), (x ∈ Ioo 0 X) → has_deriv_at (λ x, (-x).exp * x ^ s : ℝ → ℂ)
    ( -((-x).exp * x ^ s) + (-x).exp * (s * x ^ (s - 1))) x),
  { intros x hx,
    have d1 : has_deriv_at (λ (y: ℝ), (-y).exp) (-(-x).exp) x,
    { simpa using (has_deriv_at_neg x).exp },
    have d1b : has_deriv_at (λ y, ↑(-y).exp : ℝ → ℂ) (↑-(-x).exp) x,
    { convert has_deriv_at.scomp x of_real_clm.has_deriv_at d1, simp, },
    have d2: has_deriv_at (λ (y : ℝ), ↑y ^ s) (s * x ^ (s - 1)) x,
    { have t := @has_deriv_at.cpow_const _ _ _ s (has_deriv_at_id ↑x),
      simp only [id.def, of_real_re, of_real_im,
        ne.def, eq_self_iff_true, not_true, or_false, mul_one] at t,
      simpa using has_deriv_at.comp x (t hx.left) of_real_clm.has_deriv_at, },
    simpa only [of_real_neg, neg_mul] using d1b.mul d2 },
  have cont := (continuous_of_real.comp continuous_neg.exp).mul
    (continuous_of_real_cpow_const hs),
  have der_ible := (Gamma_integrand_deriv_integrable_A hs hX).add
    (Gamma_integrand_deriv_integrable_B hs hX),
  have int_eval := integral_eq_sub_of_has_deriv_at_of_le hX cont.continuous_on F_der_I der_ible,
  -- We are basically done here but manipulating the output into the right form is fiddly.
  apply_fun (λ x:ℂ, -x) at int_eval,
  rw [interval_integral.integral_add (Gamma_integrand_deriv_integrable_A hs hX)
    (Gamma_integrand_deriv_integrable_B hs hX), interval_integral.integral_neg, neg_add, neg_neg]
    at int_eval,
  replace int_eval := eq_sub_of_add_eq int_eval,
  rw [int_eval, sub_neg_eq_add, neg_sub, add_comm, add_sub],
  simp only [sub_left_inj, add_left_inj],
  have : (λ x, (-x).exp * (s * x ^ (s - 1)) : ℝ → ℂ) = (λ x, s * (-x).exp * x ^ (s - 1) : ℝ → ℂ),
  { ext1, ring,},
  rw this,
  have t := @integral_const_mul (0:ℝ) X volume _ _ s (λ x:ℝ, (-x).exp * x ^ (s - 1)),
  dsimp at t, rw [←t, of_real_zero, zero_cpow],
  { rw [mul_zero, add_zero], congr', ext1, ring },
  { contrapose! hs, rw [hs, zero_re] }
end

/-- The recurrence relation for the `Γ` integral. -/
theorem Gamma_integral_add_one {s : ℂ} (hs: 0 < s.re) :
  Gamma_integral (s + 1) = s * Gamma_integral s :=
begin
  suffices : tendsto (s+1).partial_Gamma at_top (𝓝 $ s * Gamma_integral s),
  { refine tendsto_nhds_unique _ this,
    apply tendsto_partial_Gamma, rw [add_re, one_re], linarith, },
  have : (λ X:ℝ, s * partial_Gamma s X - X ^ s * (-X).exp) =ᶠ[at_top] (s+1).partial_Gamma,
  { apply eventually_eq_of_mem (Ici_mem_at_top (0:ℝ)),
    intros X hX,
    rw partial_Gamma_add_one hs (mem_Ici.mp hX),
    ring_nf, },
  refine tendsto.congr' this _,
  suffices : tendsto (λ X, -X ^ s * (-X).exp : ℝ → ℂ) at_top (𝓝 0),
  { simpa using tendsto.add (tendsto.const_mul s (tendsto_partial_Gamma hs)) this },
  rw tendsto_zero_iff_norm_tendsto_zero,
  have : (λ (e : ℝ), ∥-(e:ℂ) ^ s * (-e).exp∥ ) =ᶠ[at_top] (λ (e : ℝ), e ^ s.re * (-1 * e).exp ),
  { refine eventually_eq_of_mem (Ioi_mem_at_top 0) _,
    intros x hx, dsimp only,
    rw [norm_eq_abs, abs_mul, abs_neg, abs_cpow_eq_rpow_re_of_pos hx,
      abs_of_nonneg (exp_pos(-x)).le, neg_mul, one_mul],},
  exact (tendsto_congr' this).mpr (tendsto_rpow_mul_exp_neg_mul_at_top_nhds_0 _ _ zero_lt_one),
end

end Gamma_recurrence

/-! Now we define `Γ(s)` on the whole complex plane, by recursion. -/

section Gamma_def

/-- The `n`th function in this family is `Γ(s)` if `-n < s.re`, and junk otherwise. -/
noncomputable def Gamma_aux : ℕ → (ℂ → ℂ)
| 0      := Gamma_integral
| (n+1)  := λ s:ℂ, (Gamma_aux n (s+1)) / s

lemma Gamma_aux_recurrence1 (s : ℂ) (n : ℕ) (h1 : -s.re < ↑n) :
  Gamma_aux n s = Gamma_aux n (s+1) / s :=
begin
  induction n with n hn generalizing s,
  { simp only [nat.cast_zero, neg_lt_zero] at h1,
    dsimp only [Gamma_aux], rw Gamma_integral_add_one h1,
    rw [mul_comm, mul_div_cancel], contrapose! h1, rw h1,
    simp },
  { dsimp only [Gamma_aux],
    have hh1 : -(s+1).re < n,
    { rw [nat.succ_eq_add_one, nat.cast_add, nat.cast_one] at h1,
      rw [add_re, one_re], linarith, },
    rw ←(hn (s+1) hh1) }
end

lemma Gamma_aux_recurrence2 (s : ℂ) (n : ℕ) (h1 : -s.re < ↑n) :
  Gamma_aux n s = Gamma_aux (n+1) s :=
begin
  cases n,
  { simp only [nat.cast_zero, neg_lt_zero] at h1,
    dsimp only [Gamma_aux],
    rw [Gamma_integral_add_one h1, mul_div_cancel_left],
    rintro rfl,
    rw [zero_re] at h1,
    exact h1.false },
  { dsimp only [Gamma_aux],
    have : (Gamma_aux n (s + 1 + 1)) / (s+1) = Gamma_aux n (s + 1),
    { have hh1 : -(s+1).re < n,
      { rw [nat.succ_eq_add_one, nat.cast_add, nat.cast_one] at h1,
        rw [add_re, one_re], linarith, },
      rw Gamma_aux_recurrence1 (s+1) n hh1, },
    rw this },
end


/-- The `Γ` function (of a complex variable `s`). -/
def Gamma (s : ℂ) : ℂ := Gamma_aux ⌊1 - s.re⌋₊ s

lemma Gamma_eq_Gamma_aux (s : ℂ) (n : ℕ) (h1 : -s.re < ↑n) : Gamma s = Gamma_aux n s :=
begin
  have u : ∀ (k : ℕ), Gamma_aux (⌊1 - s.re⌋₊ + k) s = Gamma s,
  { intro k, induction k with k hk,
    { simp [Gamma],},
    { rw [←hk, nat.succ_eq_add_one, ←add_assoc],
      refine (Gamma_aux_recurrence2 s (⌊1 - s.re⌋₊ + k) _).symm,
      rw nat.cast_add,
      have i0 := nat.sub_one_lt_floor (1 - s.re),
      simp only [sub_sub_cancel_left] at i0,
      refine lt_add_of_lt_of_nonneg i0 _,
      rw [←nat.cast_zero, nat.cast_le], exact nat.zero_le k, } },
  convert (u $ n - ⌊1 - s.re⌋₊).symm, rw nat.add_sub_of_le,
  by_cases (0 ≤ 1 - s.re),
  { apply nat.le_of_lt_succ,
    exact_mod_cast lt_of_le_of_lt (nat.floor_le h) (by linarith : 1 - s.re < n + 1) },
  { rw nat.floor_of_nonpos, linarith, linarith },
end

/-- The recurrence relation for the `Γ` function. -/
theorem Gamma_add_one (s : ℂ) (h2 : s ≠ 0) : Gamma (s+1) = s * Gamma s :=
begin
  let n := ⌊1 - s.re⌋₊,
  have t1 : -s.re < n,
  { simpa only [sub_sub_cancel_left] using nat.sub_one_lt_floor (1 - s.re) },
  have t2 : -(s+1).re < n,
  { rw [add_re, one_re], linarith, },
  rw [Gamma_eq_Gamma_aux s n t1, Gamma_eq_Gamma_aux (s+1) n t2, Gamma_aux_recurrence1 s n t1],
  field_simp, ring,
end

theorem Gamma_eq_integral (s : ℂ) (hs : 0 < s.re) : Gamma s = Gamma_integral s :=
begin
  refine Gamma_eq_Gamma_aux s 0 (_ : _ < 0), linarith,
end

theorem Gamma_nat_eq_factorial (n : ℕ) : Gamma (n+1) = nat.factorial n :=
begin
  induction n with n hn,
  { rw [nat.cast_zero, zero_add], rw Gamma_eq_integral,
    simpa using Gamma_integral_one, simp,},
  rw (Gamma_add_one n.succ $ nat.cast_ne_zero.mpr $ nat.succ_ne_zero n),
  { simp only [nat.cast_succ, nat.factorial_succ, nat.cast_mul], congr, exact hn },
end

end Gamma_def

end complex

/-! Now check that the `Γ` function is differentiable, wherever this makes sense. -/

section Gamma_has_deriv

/-- Integrand for the derivative of the `Γ` function -/
def dGamma_integrand (s : ℂ) (x : ℝ) : ℂ := exp (-x) * log x * x ^ (s - 1)

/-- Integrand for the absolute value of the derivative of the `Γ` function -/
def dGamma_integrand_real (s x : ℝ) : ℝ := |exp (-x) * log x * x ^ (s - 1)|

lemma dGamma_integrand_is_o_at_top (s : ℝ) :
  (λ x : ℝ, exp (-x) * log x * x ^ (s - 1)) =o[at_top] (λ x, exp (-(1/2) * x)) :=
begin
  refine is_o_of_tendsto (λ x hx, _) _,
  { exfalso, exact (-(1/2) * x).exp_pos.ne' hx, },
  have : eventually_eq at_top (λ (x : ℝ), exp (-x) * log x * x ^ (s - 1) / exp (-(1 / 2) * x))
    (λ (x : ℝ),  (λ z:ℝ, exp (1 / 2 * z) / z ^ s) x * (λ z:ℝ, z / log z) x)⁻¹,
  { refine eventually_of_mem (Ioi_mem_at_top 1) _,
    intros x hx, dsimp,
    replace hx := lt_trans zero_lt_one (mem_Ioi.mp hx),
    rw [real.exp_neg, neg_mul, real.exp_neg, rpow_sub hx],
    have : exp x = exp(x/2) * exp(x/2),
    { rw [←real.exp_add, add_halves], },
    rw this, field_simp [hx.ne', exp_ne_zero (x/2)], ring, },
  refine tendsto.congr' this.symm (tendsto.inv_tendsto_at_top _),
  apply tendsto.at_top_mul_at_top (tendsto_exp_mul_div_rpow_at_top s (1/2) one_half_pos),
  refine tendsto.congr' _ ((tendsto_exp_div_pow_at_top 1).comp tendsto_log_at_top),
  apply eventually_eq_of_mem (Ioi_mem_at_top (0:ℝ)),
  intros x hx, simp [exp_log hx],
end

/-- Absolute convergence of the integral which will give the derivative of the `Γ` function on
`1 < re s`. -/
lemma dGamma_integral_abs_convergent (s : ℝ) (hs : 1 < s) :
  integrable_on (λ x:ℝ, ∥exp (-x) * log x * x ^ (s-1)∥) (Ioi 0) :=
begin
  rw [←Ioc_union_Ioi_eq_Ioi (@zero_le_one ℝ _ _ _ _), integrable_on_union],
  refine ⟨⟨_, _⟩, _⟩,
  { refine continuous_on.ae_strongly_measurable (continuous_on.mul _ _).norm measurable_set_Ioc,
    { refine (continuous_exp.comp continuous_neg).continuous_on.mul (continuous_on_log.mono _),
      simp, },
    { apply continuous_on_id.rpow_const, intros x hx, right, linarith }, },
  { apply has_finite_integral_of_bounded,
    swap, { exact 1 / (s - 1), },
    refine (ae_restrict_iff' measurable_set_Ioc).mpr (ae_of_all _ (λ x hx, _)),
    rw [norm_norm, norm_eq_abs, mul_assoc, abs_mul, ←one_mul (1 / (s - 1))],
    refine mul_le_mul _ _ (abs_nonneg _) zero_le_one,
    { rw [abs_of_pos (exp_pos(-x)), exp_le_one_iff, neg_le, neg_zero], exact hx.1.le },
    { exact (abs_log_mul_self_rpow_lt x (s-1) hx.1 hx.2 (sub_pos.mpr hs)).le }, },
  { have := (dGamma_integrand_is_o_at_top s).is_O.norm_left,
    refine integrable_of_is_O_exp_neg one_half_pos (continuous_on.mul _ _).norm this,
    { refine (continuous_exp.comp continuous_neg).continuous_on.mul (continuous_on_log.mono _),
      simp, },
    { apply continuous_at.continuous_on (λ x hx, _),
      apply continuous_at_id.rpow continuous_at_const,
      dsimp, right, linarith, }, }
end

/-- A uniform bound for the `s`-derivative of the `Γ` integrand for `s` in vertical strips. -/
lemma loc_unif_bound_dGamma_integrand {t : ℂ} {s1 s2 x : ℝ} (ht1 : s1 ≤ t.re)
  (ht2: t.re ≤ s2) (hx : 0 < x) :
  ∥dGamma_integrand t x∥ ≤ dGamma_integrand_real s1 x + dGamma_integrand_real s2 x :=
begin
  rcases le_or_lt 1 x with h|h,
  { -- case 1 ≤ x
    refine le_add_of_nonneg_of_le (abs_nonneg _) _,
    rw [dGamma_integrand, dGamma_integrand_real, complex.norm_eq_abs, complex.abs_mul, abs_mul,
      ←complex.of_real_mul, complex.abs_of_real],
    refine mul_le_mul_of_nonneg_left _ (abs_nonneg _),
    rw complex.abs_cpow_eq_rpow_re_of_pos hx,
    refine le_trans _ (le_abs_self _),
    apply rpow_le_rpow_of_exponent_le h,
    rw [complex.sub_re, complex.one_re], linarith, },
  { refine le_add_of_le_of_nonneg _ (abs_nonneg _),
    rw [dGamma_integrand, dGamma_integrand_real, complex.norm_eq_abs, complex.abs_mul, abs_mul,
      ←complex.of_real_mul, complex.abs_of_real],
    refine mul_le_mul_of_nonneg_left _ (abs_nonneg _),
    rw complex.abs_cpow_eq_rpow_re_of_pos hx,
    refine le_trans _ (le_abs_self _),
    apply rpow_le_rpow_of_exponent_ge hx h.le,
    rw [complex.sub_re, complex.one_re], linarith, },
end

namespace complex

/-- The derivative of the `Γ` integral, at any `s ∈ ℂ` with `1 < re s`, is given by the integral
of `exp (-x) * log x * x ^ (s - 1)` over `[0, ∞)`. -/
theorem has_deriv_at_Gamma_integral {s : ℂ} (hs : 1 < s.re) :
  (integrable_on (λ x, real.exp (-x) * real.log x * x ^ (s - 1) : ℝ → ℂ) (Ioi 0) volume) ∧
  (has_deriv_at Gamma_integral (∫ x:ℝ in Ioi 0, real.exp (-x) * real.log x * x ^ (s - 1)) s) :=
begin
  let ε := (s.re - 1) / 2,
  let μ := volume.restrict (Ioi (0:ℝ)),
  let bound := (λ x:ℝ, dGamma_integrand_real (s.re - ε) x + dGamma_integrand_real (s.re + ε) x),
  have cont : ∀ (t : ℂ), continuous_on (λ x, real.exp (-x) * x ^ (t - 1) : ℝ → ℂ) (Ioi 0),
  { intro t, apply (continuous_of_real.comp continuous_neg.exp).continuous_on.mul,
    apply continuous_at.continuous_on, intros x hx,
    refine (continuous_at_cpow_const _).comp continuous_of_real.continuous_at,
    exact or.inl hx, },
  have eps_pos: 0 < ε := div_pos (sub_pos.mpr hs) zero_lt_two,
  have hF_meas : ∀ᶠ (t : ℂ) in 𝓝 s,
    ae_strongly_measurable (λ x, real.exp(-x) * x ^ (t - 1) : ℝ → ℂ) μ,
  { apply eventually_of_forall, intro t,
    exact (cont t).ae_strongly_measurable measurable_set_Ioi, },
  have hF'_meas : ae_strongly_measurable (dGamma_integrand s) μ,
  { refine continuous_on.ae_strongly_measurable _ measurable_set_Ioi,
    have : dGamma_integrand s = (λ x, real.exp (-x) * x ^ (s - 1) * real.log x : ℝ → ℂ),
    { ext1, simp only [dGamma_integrand], ring },
    rw this,
    refine continuous_on.mul (cont s) (continuous_at.continuous_on _),
    exact λ x hx, continuous_of_real.continuous_at.comp (continuous_at_log (mem_Ioi.mp hx).ne'), },
  have h_bound : ∀ᵐ (x : ℝ) ∂μ, ∀ (t : ℂ), t ∈ metric.ball s ε → ∥ dGamma_integrand t x ∥ ≤ bound x,
  { refine (ae_restrict_iff' measurable_set_Ioi).mpr (ae_of_all _ (λ x hx, _)),
    intros t ht,
    rw [metric.mem_ball, complex.dist_eq] at ht,
    replace ht := lt_of_le_of_lt (complex.abs_re_le_abs $ t - s ) ht,
    rw [complex.sub_re, @abs_sub_lt_iff ℝ _ t.re s.re ((s.re - 1) / 2) ] at ht,
    refine loc_unif_bound_dGamma_integrand _ _ hx,
    all_goals { simp only [ε], linarith } },
  have bound_integrable : integrable bound μ,
  { apply integrable.add,
    { refine dGamma_integral_abs_convergent (s.re - ε) _,
      field_simp, rw one_lt_div,
      { linarith }, { exact zero_lt_two }, },
    { refine dGamma_integral_abs_convergent (s.re + ε) _, linarith, }, },
  have h_diff : ∀ᵐ (x : ℝ) ∂μ, ∀ (t : ℂ), t ∈ metric.ball s ε
    → has_deriv_at (λ u, real.exp (-x) * x ^ (u - 1) : ℂ → ℂ) (dGamma_integrand t x) t,
  { refine (ae_restrict_iff' measurable_set_Ioi).mpr (ae_of_all _ (λ x hx, _)),
    intros t ht, rw mem_Ioi at hx,
    simp only [dGamma_integrand],
    rw mul_assoc,
    apply has_deriv_at.const_mul,
    rw [of_real_log hx.le, mul_comm],
    have := ((has_deriv_at_id t).sub_const 1).const_cpow (or.inl (of_real_ne_zero.mpr hx.ne')),
    rwa mul_one at this },
  exact (has_deriv_at_integral_of_dominated_loc_of_deriv_le eps_pos hF_meas
    (Gamma_integral_convergent (zero_lt_one.trans hs)) hF'_meas h_bound bound_integrable h_diff),
end

lemma differentiable_at_Gamma_aux (s : ℂ) (n : ℕ) (h1 : (1 - s.re) < n ) (h2 : ∀ m:ℕ, s + m ≠ 0) :
  differentiable_at ℂ (Gamma_aux n) s :=
begin
  induction n with n hn generalizing s,
  { refine (has_deriv_at_Gamma_integral _).2.differentiable_at,
    rw nat.cast_zero at h1, linarith },
  { dsimp only [Gamma_aux],
    specialize hn (s + 1),
    have a : 1 - (s + 1).re < ↑n,
    { rw nat.cast_succ at h1, rw [complex.add_re, complex.one_re], linarith },
    have b : ∀ m:ℕ, s + 1 + m ≠ 0,
    { intro m, have := h2 (1 + m), rwa [nat.cast_add, nat.cast_one, ←add_assoc] at this },
    refine differentiable_at.div (differentiable_at.comp _ (hn a b) _) _ _,
    simp, simp, simpa using h2 0 }
end

theorem differentiable_at_Gamma (s : ℂ) (hs : ∀ m:ℕ, s + m ≠ 0) : differentiable_at ℂ Gamma s :=
begin
  let n := ⌊1 - s.re⌋₊ + 1,
  have hn : 1 - s.re < n := nat.lt_floor_add_one (1 - s.re),
  apply (differentiable_at_Gamma_aux s n hn hs).congr_of_eventually_eq,
  let S := { t : ℂ | 1 - t.re < n },
  have : S ∈ 𝓝 s,
  { rw mem_nhds_iff, use S,
    refine ⟨subset.rfl, _, hn⟩,
    have : S = re⁻¹' Ioi (1 - n : ℝ),
    { ext, rw [preimage,Ioi, mem_set_of_eq, mem_set_of_eq, mem_set_of_eq], exact sub_lt },
    rw this,
    refine continuous.is_open_preimage continuous_re _ is_open_Ioi, },
  apply eventually_eq_of_mem this,
  intros t ht, rw mem_set_of_eq at ht,
  apply Gamma_eq_Gamma_aux, linarith,
end

end complex

end Gamma_has_deriv


<|start_filename|>src/topology/vector_bundle/pullback.lean<|end_filename|>
/-
Copyright © 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>
-/

import topology.vector_bundle.basic

/-!
# Pullbacks of topological vector bundles

We construct the pullback bundle for a map `f : B' → B` whose fiber map is given simply by
`f *ᵖ E = E ∘ f` (the type synonym is there for typeclass instance problems).
-/

noncomputable theory

open bundle set topological_space topological_vector_bundle
open_locale classical

variables (R 𝕜 : Type*) {B : Type*} (F : Type*) (E E' : B → Type*)
variables {B' : Type*} (f : B' → B)

instance [∀ (x : B), topological_space (E' x)] : ∀ (x : B'), topological_space ((f *ᵖ E') x) :=
by delta_instance bundle.pullback
instance [∀ (x : B), add_comm_monoid (E' x)] : ∀ (x : B'), add_comm_monoid ((f *ᵖ E') x) :=
by delta_instance bundle.pullback
instance [semiring R] [∀ (x : B), add_comm_monoid (E' x)] [∀ x, module R (E' x)] :
  ∀ (x : B'), module R ((f *ᵖ E') x) :=
by delta_instance bundle.pullback

variables [topological_space B'] [topological_space (total_space E)]

/-- Definition of `pullback.total_space.topological_space`, which we make irreducible. -/
@[irreducible] def pullback_topology : topological_space (total_space (f *ᵖ E)) :=
induced total_space.proj ‹topological_space B'› ⊓
induced (pullback.lift f) ‹topological_space (total_space E)›

/-- The topology on the total space of a pullback bundle is the coarsest topology for which both
the projections to the base and the map to the original bundle are continuous. -/
instance pullback.total_space.topological_space :
  topological_space (total_space (f *ᵖ E)) :=
pullback_topology E f

lemma pullback.continuous_proj (f : B' → B) :
  continuous (@total_space.proj _ (f *ᵖ E)) :=
begin
  rw [continuous_iff_le_induced, pullback.total_space.topological_space, pullback_topology],
  exact inf_le_left,
end

lemma pullback.continuous_lift (f : B' → B) :
  continuous (@pullback.lift B E B' f) :=
begin
  rw [continuous_iff_le_induced, pullback.total_space.topological_space, pullback_topology],
  exact inf_le_right,
end

lemma inducing_pullback_total_space_embedding (f : B' → B) :
  inducing (@pullback_total_space_embedding B E B' f) :=
begin
  constructor,
  simp_rw [prod.topological_space, induced_inf, induced_compose,
    pullback.total_space.topological_space, pullback_topology],
  refl
end

variables (F) [nondiscrete_normed_field 𝕜]
  [normed_group F] [normed_space 𝕜 F] [topological_space B]
  [∀ x, add_comm_monoid (E x)] [∀ x, module 𝕜 (E x)]

lemma pullback.continuous_total_space_mk [∀ x, topological_space (E x)]
  [topological_vector_bundle 𝕜 F E] {f : B' → B} {x : B'} :
  continuous (@total_space_mk _ (f *ᵖ E) x) :=
begin
  simp only [continuous_iff_le_induced, pullback.total_space.topological_space, induced_compose,
    induced_inf, function.comp, total_space_mk, total_space.proj, induced_const, top_inf_eq,
    pullback_topology],
  exact le_of_eq (topological_vector_bundle.total_space_mk_inducing 𝕜 F E (f x)).induced,
end

variables {E 𝕜 F} {K : Type*} [continuous_map_class K B' B]

/-- A vector bundle trivialization can be pulled back to a trivialization on the pullback bundle. -/
def topological_vector_bundle.trivialization.pullback (e : trivialization 𝕜 F E) (f : K) :
  trivialization 𝕜 F ((f : B' → B) *ᵖ E) :=
{ to_fun := λ z, (z.proj, (e (pullback.lift f z)).2),
  inv_fun := λ y, @total_space_mk _ (f *ᵖ E) y.1 (e.symm (f y.1) y.2),
  source := pullback.lift f ⁻¹' e.source,
  base_set := f ⁻¹' e.base_set,
  target := (f ⁻¹' e.base_set) ×ˢ (univ : set F),
  map_source' := λ x h, by { simp_rw [e.source_eq, mem_preimage, pullback.proj_lift] at h,
    simp_rw [prod_mk_mem_set_prod_eq, mem_univ, and_true, mem_preimage, h] },
  map_target' := λ y h, by { rw [mem_prod, mem_preimage] at h,
    simp_rw [e.source_eq, mem_preimage, pullback.proj_lift, h.1] },
  left_inv' := λ x h, by { simp_rw [mem_preimage, e.mem_source, pullback.proj_lift] at h,
    simp_rw [pullback.lift, e.symm_apply_apply_mk h, total_space.eta] },
  right_inv' := λ x h, by { simp_rw [mem_prod, mem_preimage, mem_univ, and_true] at h,
    simp_rw [total_space.proj_mk, pullback.lift_mk, e.apply_mk_symm h, prod.mk.eta] },
  open_source := by { simp_rw [e.source_eq, ← preimage_comp], exact ((map_continuous f).comp $
    pullback.continuous_proj E f).is_open_preimage _ e.open_base_set },
  open_target := ((map_continuous f).is_open_preimage _ e.open_base_set).prod is_open_univ,
  open_base_set := (map_continuous f).is_open_preimage _ e.open_base_set,
  continuous_to_fun := (pullback.continuous_proj E f).continuous_on.prod
    (continuous_snd.comp_continuous_on $
    e.continuous_on.comp (pullback.continuous_lift E f).continuous_on subset.rfl),
  continuous_inv_fun := begin
    dsimp only,
    simp_rw [(inducing_pullback_total_space_embedding E f).continuous_on_iff, function.comp,
      pullback_total_space_embedding, total_space.proj_mk],
    dsimp only [total_space.proj_mk],
    refine continuous_on_fst.prod (e.continuous_on_symm.comp
      ((map_continuous f).prod_map continuous_id).continuous_on subset.rfl)
  end,
  source_eq := by { dsimp only, rw e.source_eq, refl, },
  target_eq := rfl,
  proj_to_fun := λ y h, rfl,
  linear' := λ x h, e.linear h }

instance topological_vector_bundle.pullback [∀ x, topological_space (E x)]
  [topological_vector_bundle 𝕜 F E] (f : K) : topological_vector_bundle 𝕜 F ((f : B' → B) *ᵖ E) :=
{ total_space_mk_inducing := λ x, inducing_of_inducing_compose
    (pullback.continuous_total_space_mk 𝕜 F E) (pullback.continuous_lift E f)
    (total_space_mk_inducing 𝕜 F E (f x)),
  trivialization_atlas := (λ e : trivialization 𝕜 F E, e.pullback f) '' trivialization_atlas 𝕜 F E,
  trivialization_at := λ x, (trivialization_at 𝕜 F E (f x)).pullback f,
  mem_base_set_trivialization_at := λ x, mem_base_set_trivialization_at 𝕜 F E (f x),
  trivialization_mem_atlas := λ x, mem_image_of_mem _ (trivialization_mem_atlas 𝕜 F E (f x)),
  continuous_on_coord_change := begin
    rintro _ ⟨e, he, rfl⟩ _ ⟨e', he', rfl⟩,
    refine ((continuous_on_coord_change e he e' he').comp (map_continuous f).continuous_on
      (λ b hb, hb)).congr _,
    rintro b (hb : f b ∈ e.base_set ∩ e'.base_set), ext v,
    show ((e.pullback f).coord_change (e'.pullback f) b) v = (e.coord_change e' (f b)) v,
    rw [e.coord_change_apply e' hb, (e.pullback f).coord_change_apply' _],
    exacts [rfl, hb]
  end }


<|start_filename|>src/category_theory/grothendieck.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.category.Cat
import category_theory.elements

/-!
# The Grothendieck construction

Given a functor `F : C ⥤ Cat`, the objects of `grothendieck F`
consist of dependent pairs `(b, f)`, where `b : C` and `f : F.obj c`,
and a morphism `(b, f) ⟶ (b', f')` is a pair `β : b ⟶ b'` in `C`, and
`φ : (F.map β).obj f ⟶ f'`

Categories such as `PresheafedSpace` are in fact examples of this construction,
and it may be interesting to try to generalize some of the development there.

## Implementation notes

Really we should treat `Cat` as a 2-category, and allow `F` to be a 2-functor.

There is also a closely related construction starting with `G : Cᵒᵖ ⥤ Cat`,
where morphisms consists again of `β : b ⟶ b'` and `φ : f ⟶ (F.map (op β)).obj f'`.

## References

See also `category_theory.functor.elements` for the category of elements of functor `F : C ⥤ Type`.

* https://stacks.math.columbia.edu/tag/02XV
* https://ncatlab.org/nlab/show/Grothendieck+construction

-/

universe u

namespace category_theory

variables {C D : Type*} [category C] [category D]
variables (F : C ⥤ Cat)

/--
The Grothendieck construction (often written as `∫ F` in mathematics) for a functor `F : C ⥤ Cat`
gives a category whose
* objects `X` consist of `X.base : C` and `X.fiber : F.obj base`
* morphisms `f : X ⟶ Y` consist of
  `base : X.base ⟶ Y.base` and
  `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`
-/
@[nolint has_inhabited_instance]
structure grothendieck :=
(base : C)
(fiber : F.obj base)

namespace grothendieck

variables {F}

/--
A morphism in the Grothendieck category `F : C ⥤ Cat` consists of
`base : X.base ⟶ Y.base` and `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`.
-/
structure hom (X Y : grothendieck F) :=
(base : X.base ⟶ Y.base)
(fiber : (F.map base).obj X.fiber ⟶ Y.fiber)

@[ext] lemma ext {X Y : grothendieck F} (f g : hom X Y)
  (w_base : f.base = g.base) (w_fiber : eq_to_hom (by rw w_base) ≫ f.fiber = g.fiber) : f = g :=
begin
  cases f; cases g,
  congr,
  dsimp at w_base,
  induction w_base,
  refl,
  dsimp at w_base,
  induction w_base,
  simpa using w_fiber,
end

/--
The identity morphism in the Grothendieck category.
-/
@[simps]
def id (X : grothendieck F) : hom X X :=
{ base := 𝟙 X.base,
  fiber := eq_to_hom (by erw [category_theory.functor.map_id, functor.id_obj X.fiber]), }

instance (X : grothendieck F) : inhabited (hom X X) := ⟨id X⟩

/--
Composition of morphisms in the Grothendieck category.
-/
@[simps]
def comp {X Y Z : grothendieck F} (f : hom X Y) (g : hom Y Z) : hom X Z :=
{ base := f.base ≫ g.base,
  fiber :=
  eq_to_hom (by erw [functor.map_comp, functor.comp_obj]) ≫
    (F.map g.base).map f.fiber ≫ g.fiber, }

local attribute [simp] eq_to_hom_map

instance : category (grothendieck F) :=
{ hom := λ X Y, grothendieck.hom X Y,
  id := λ X, grothendieck.id X,
  comp := λ X Y Z f g, grothendieck.comp f g,
  comp_id' := λ X Y f,
  begin
    ext,
    { dsimp,
      -- We need to turn `F.map_id` (which is an equation between functors)
      -- into a natural isomorphism.
      rw ← nat_iso.naturality_2 (eq_to_iso (F.map_id Y.base)) f.fiber,
      simp, },
    { simp, },
  end,
  id_comp' := λ X Y f, by ext; simp,
  assoc' := λ W X Y Z f g h,
  begin
    ext, swap,
    { simp, },
    { dsimp,
      rw ← nat_iso.naturality_2 (eq_to_iso (F.map_comp _ _)) f.fiber,
      simp,
      refl, },
  end, }

@[simp] lemma id_fiber' (X : grothendieck F) :
  hom.fiber (𝟙 X) = eq_to_hom (by erw [category_theory.functor.map_id, functor.id_obj X.fiber]) :=
id_fiber X

lemma congr {X Y : grothendieck F} {f g : X ⟶ Y} (h : f = g) :
  f.fiber = eq_to_hom (by subst h) ≫ g.fiber :=
by { subst h, dsimp, simp, }

section
variables (F)

/-- The forgetful functor from `grothendieck F` to the source category. -/
@[simps]
def forget : grothendieck F ⥤ C :=
{ obj := λ X, X.1,
  map := λ X Y f, f.1, }

end

universe w
variables (G : C ⥤ Type w)

/-- Auxiliary definition for `grothendieck_Type_to_Cat`, to speed up elaboration. -/
@[simps]
def grothendieck_Type_to_Cat_functor : grothendieck (G ⋙ Type_to_Cat) ⥤ G.elements :=
{ obj := λ X, ⟨X.1, X.2.as⟩,
  map := λ X Y f, ⟨f.1, f.2.1.1⟩ }

/-- Auxiliary definition for `grothendieck_Type_to_Cat`, to speed up elaboration. -/
@[simps]
def grothendieck_Type_to_Cat_inverse : G.elements ⥤ grothendieck (G ⋙ Type_to_Cat) :=
{ obj := λ X, ⟨X.1, ⟨X.2⟩⟩,
  map := λ X Y f, ⟨f.1, ⟨⟨f.2⟩⟩⟩ }

/--
The Grothendieck construction applied to a functor to `Type`
(thought of as a functor to `Cat` by realising a type as a discrete category)
is the same as the 'category of elements' construction.
-/
@[simps]
def grothendieck_Type_to_Cat : grothendieck (G ⋙ Type_to_Cat) ≌ G.elements :=
{ functor := grothendieck_Type_to_Cat_functor G,
  inverse := grothendieck_Type_to_Cat_inverse G,
  unit_iso := nat_iso.of_components (λ X, by { rcases X with ⟨_, ⟨⟩⟩, exact iso.refl _, })
    (by { rintro ⟨_, ⟨⟩⟩ ⟨_, ⟨⟩⟩ ⟨base, ⟨⟨f⟩⟩⟩, dsimp at *, subst f, ext, simp, }),
  counit_iso := nat_iso.of_components (λ X, by { cases X, exact iso.refl _, })
    (by { rintro ⟨⟩ ⟨⟩ ⟨f, e⟩, dsimp at *, subst e, ext, simp }),
  functor_unit_iso_comp' := by { rintro ⟨_, ⟨⟩⟩, dsimp, simp, refl, } }

end grothendieck

end category_theory


<|start_filename|>src/algebra/field_power.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.group_with_zero.power
import algebra.ring.equiv
import tactic.linarith

/-!
# Integer power operation on fields and division rings

This file collects basic facts about the operation of raising an element of a `division_ring` to an
integer power. More specialised results are provided in the case of a linearly ordered field.
-/

universe u

@[simp] lemma ring_hom.map_zpow {K L : Type*} [division_ring K] [division_ring L] (f : K →+* L) :
  ∀ (a : K) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_monoid_with_zero_hom.map_zpow

@[simp] lemma ring_equiv.map_zpow {K L : Type*} [division_ring K] [division_ring L] (f : K ≃+* L) :
  ∀ (a : K) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_ring_hom.map_zpow

@[simp] lemma zpow_bit1_neg {K : Type*} [division_ring K] (x : K) (n : ℤ) :
  (-x) ^ (bit1 n) = - x ^ bit1 n :=
by rw [zpow_bit1', zpow_bit1', neg_mul_neg, neg_mul_eq_mul_neg]

section ordered_field_power
open int

variables {K : Type u} [linear_ordered_field K] {a : K} {n : ℤ}

lemma zpow_nonneg {a : K} (ha : 0 ≤ a) : ∀ (z : ℤ), 0 ≤ a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_nonneg ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_nonneg.2 (pow_nonneg ha _) }

lemma zpow_pos_of_pos {a : K} (ha : 0 < a) : ∀ (z : ℤ), 0 < a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_pos ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_pos.2 (pow_pos ha _) }

lemma zpow_le_of_le {x : K} (hx : 1 ≤ x) {a b : ℤ} (h : a ≤ b) : x ^ a ≤ x ^ b :=
begin
  induction a with a a; induction b with b b,
  { simp only [of_nat_eq_coe, zpow_coe_nat],
    apply pow_le_pow hx,
    apply le_of_coe_nat_le_coe_nat h },
  { apply absurd h,
    apply not_le_of_gt,
    exact lt_of_lt_of_le (neg_succ_lt_zero _) (of_nat_nonneg _) },
  { simp only [zpow_neg_succ_of_nat, one_div, of_nat_eq_coe, zpow_coe_nat],
    apply le_trans (inv_le_one _); apply one_le_pow_of_one_le hx },
  { simp only [zpow_neg_succ_of_nat],
    apply (inv_le_inv _ _).2,
    { apply pow_le_pow hx,
      have : -(↑(a+1) : ℤ) ≤ -(↑(b+1) : ℤ), from h,
      have h' := le_of_neg_le_neg this,
      apply le_of_coe_nat_le_coe_nat h' },
    repeat { apply pow_pos (lt_of_lt_of_le zero_lt_one hx) } }
end

lemma pow_le_max_of_min_le {x : K} (hx : 1 ≤ x) {a b c : ℤ} (h : min a b ≤ c) :
      x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) :=
begin
  wlog hle : a ≤ b,
  have hnle : -b ≤ -a, from neg_le_neg hle,
  have hfle : x ^ (-b) ≤ x ^ (-a), from zpow_le_of_le hx hnle,
  have : x ^ (-c) ≤ x ^ (-a),
  { apply zpow_le_of_le hx,
    simpa only [min_eq_left hle, neg_le_neg_iff] using h },
  simpa only [max_eq_left hfle]
end

lemma zpow_le_one_of_nonpos {p : K} (hp : 1 ≤ p) {z : ℤ} (hz : z ≤ 0) : p ^ z ≤ 1 :=
calc p ^ z ≤ p ^ 0 : zpow_le_of_le hp hz
          ... = 1        : by simp

lemma one_le_zpow_of_nonneg {p : K} (hp : 1 ≤ p) {z : ℤ} (hz : 0 ≤ z) : 1 ≤ p ^ z :=
calc p ^ z ≥ p ^ 0 : zpow_le_of_le hp hz
          ... = 1        : by simp

theorem zpow_bit0_nonneg (a : K) (n : ℤ) : 0 ≤ a ^ bit0 n :=
by { rw zpow_bit0, exact mul_self_nonneg _ }

theorem zpow_two_nonneg (a : K) : 0 ≤ a ^ (2 : ℤ) :=
zpow_bit0_nonneg a 1

theorem zpow_bit0_pos {a : K} (h : a ≠ 0) (n : ℤ) : 0 < a ^ bit0 n :=
(zpow_bit0_nonneg a n).lt_of_ne (zpow_ne_zero _ h).symm

theorem zpow_two_pos_of_ne_zero (a : K) (h : a ≠ 0) : 0 < a ^ (2 : ℤ) :=
zpow_bit0_pos h 1

@[simp] theorem zpow_bit1_neg_iff : a ^ bit1 n < 0 ↔ a < 0 :=
⟨λ h, not_le.1 $ λ h', not_le.2 h $ zpow_nonneg h' _,
 λ h, by rw [bit1, zpow_add_one₀ h.ne]; exact mul_neg_of_pos_of_neg (zpow_bit0_pos h.ne _) h⟩

@[simp] theorem zpow_bit1_nonneg_iff : 0 ≤ a ^ bit1 n ↔ 0 ≤ a :=
le_iff_le_iff_lt_iff_lt.2 zpow_bit1_neg_iff

@[simp] theorem zpow_bit1_nonpos_iff : a ^ bit1 n ≤ 0 ↔ a ≤ 0 :=
begin
  rw [le_iff_lt_or_eq, zpow_bit1_neg_iff],
  split,
  { rintro (h | h),
    { exact h.le },
    { exact (zpow_eq_zero h).le } },
  { intro h,
    rcases eq_or_lt_of_le h with rfl|h,
    { exact or.inr (zero_zpow _ (bit1_ne_zero n)) },
    { exact or.inl h } }
end

@[simp] theorem zpow_bit1_pos_iff : 0 < a ^ bit1 n ↔ 0 < a :=
lt_iff_lt_of_le_iff_le zpow_bit1_nonpos_iff

end ordered_field_power

lemma one_lt_zpow {K} [linear_ordered_field K] {p : K} (hp : 1 < p) :
  ∀ z : ℤ, 0 < z → 1 < p ^ z
| (n : ℕ) h := (zpow_coe_nat p n).symm.subst (one_lt_pow hp $ int.coe_nat_ne_zero.mp h.ne')
| -[1+ n] h := ((int.neg_succ_not_pos _).mp h).elim

section ordered
variables  {K : Type*} [linear_ordered_field K]

lemma nat.zpow_pos_of_pos {p : ℕ} (h : 0 < p) (n:ℤ) : 0 < (p:K)^n :=
by { apply zpow_pos_of_pos, exact_mod_cast h }

lemma nat.zpow_ne_zero_of_pos {p : ℕ} (h : 0 < p) (n:ℤ) : (p:K)^n ≠ 0 :=
ne_of_gt (nat.zpow_pos_of_pos h n)

lemma zpow_strict_mono {x : K} (hx : 1 < x) :
  strict_mono (λ n:ℤ, x ^ n) :=
strict_mono_int_of_lt_succ $ λ n,
have xpos : 0 < x, from zero_lt_one.trans hx,
calc x ^ n < x ^ n * x : lt_mul_of_one_lt_right (zpow_pos_of_pos xpos _) hx
... = x ^ (n + 1) : (zpow_add_one₀ xpos.ne' _).symm

lemma zpow_strict_anti {x : K} (h₀ : 0 < x) (h₁ : x < 1) : strict_anti (λ n : ℤ, x ^ n) :=
strict_anti_int_of_succ_lt $ λ n,
calc x ^ (n + 1) = x ^ n * x : zpow_add_one₀ h₀.ne' _
... < x ^ n * 1 : (mul_lt_mul_left $ zpow_pos_of_pos h₀ _).2 h₁
... = x ^ n : mul_one _

@[simp] lemma zpow_lt_iff_lt {x : K} (hx : 1 < x) {m n : ℤ} :
  x ^ m < x ^ n ↔ m < n :=
(zpow_strict_mono hx).lt_iff_lt

@[simp] lemma zpow_le_iff_le {x : K} (hx : 1 < x) {m n : ℤ} :
  x ^ m ≤ x ^ n ↔ m ≤ n :=
(zpow_strict_mono hx).le_iff_le

lemma min_le_of_zpow_le_max {x : K} (hx : 1 < x) {a b c : ℤ}
  (h_max : x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) ) : min a b ≤ c :=
begin
  rw min_le_iff,
  refine or.imp (λ h, _) (λ h, _) (le_max_iff.mp h_max);
  rwa [zpow_le_iff_le hx, neg_le_neg_iff] at h
end

@[simp] lemma pos_div_pow_pos {a b : K} (ha : 0 < a) (hb : 0 < b) (k : ℕ) : 0 < a/b^k :=
div_pos ha (pow_pos hb k)

@[simp] lemma div_pow_le {a b : K} (ha : 0 < a) (hb : 1 ≤ b) (k : ℕ) : a/b^k ≤ a :=
(div_le_iff $ pow_pos (lt_of_lt_of_le zero_lt_one hb) k).mpr
(calc a = a * 1 : (mul_one a).symm
   ...  ≤ a*b^k : (mul_le_mul_left ha).mpr $ one_le_pow_of_one_le hb _)

lemma zpow_injective {x : K} (h₀ : 0 < x) (h₁ : x ≠ 1) :
  function.injective ((^) x : ℤ → K) :=
begin
  intros m n h,
  rcases h₁.lt_or_lt with H|H,
  { apply (zpow_strict_mono (one_lt_inv h₀ H)).injective,
    show x⁻¹ ^ m = x⁻¹ ^ n,
    rw [← zpow_neg_one, ← zpow_mul, ← zpow_mul, mul_comm _ m, mul_comm _ n, zpow_mul, zpow_mul,
      h], },
  { exact (zpow_strict_mono H).injective h, },
end

@[simp] lemma zpow_inj {x : K} (h₀ : 0 < x) (h₁ : x ≠ 1) {m n : ℤ} :
  x ^ m = x ^ n ↔ m = n :=
(zpow_injective h₀ h₁).eq_iff

end ordered

section
variables {K : Type*} [division_ring K]

@[simp, norm_cast] theorem rat.cast_zpow [char_zero K] (q : ℚ) (n : ℤ) :
  ((q ^ n : ℚ) : K) = q ^ n :=
(rat.cast_hom K).map_zpow q n

end


<|start_filename|>src/algebra/parity.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import algebra.ring.basic
import algebra.algebra.basic
import algebra.group_power.basic
import algebra.field_power
import algebra.opposites

/-!  # Squares, even and odd elements

This file proves some general facts about squares, even and odd elements of semirings.

In the implementation, we define `is_square` and we let `even` be the notion transported by
`to_additive`.  The definition are therefore as follows:
```lean
is_square a ↔ ∃ r, a = r * r
even a ↔ ∃ r, a = r + r
```

Odd elements are not unified with a multiplicative notion.

## Future work

* TODO: Try to generalize further the typeclass assumptions on `is_square/even`.
  For instance, in some cases, there are `semiring` assumptions that I (DT) am not convinced are
  necessary.
* TODO: Consider moving the definition and lemmas about `odd` to a separate file.
* TODO: The "old" definition of `even a` asked for the existence of an element `c` such that
  `a = 2 * c`.  For this reason, several fixes introduce an extra `two_mul` or `← two_mul`.
  It might be the case that by making a careful choice of `simp` lemma, this can be avoided.
 -/

open mul_opposite
variables {F α β R : Type*}

section has_mul
variables [has_mul α]

/--  An element `a` of a type `α` with multiplication satisfies `square a` if `a = r * r`,
for some `r : α`. -/
@[to_additive
"An element `a` of a type `α` with addition satisfies `even a` if `a = r + r`,
for some `r : α`."]
def is_square (a : α) : Prop := ∃ r, a = r * r

@[simp, to_additive] lemma is_square_mul_self (m : α) : is_square (m * m) := ⟨m, rfl⟩

@[to_additive] lemma is_square_op_iff (a : α) : is_square (op a) ↔ is_square a :=
⟨λ ⟨c, hc⟩, ⟨unop c, by rw [← unop_mul, ← hc, unop_op]⟩, λ ⟨c, hc⟩, by simp [hc]⟩

/-- Create a decidability instance for `is_square` on `fintype`s. -/
instance is_square_decidable [fintype α] [decidable_eq α] : decidable_pred (is_square : α → Prop) :=
λ a, fintype.decidable_exists_fintype

end has_mul

@[simp, to_additive]
lemma is_square_one [mul_one_class α] : is_square (1 : α) := ⟨1, (mul_one _).symm⟩

@[to_additive]
lemma is_square.map [mul_one_class α] [mul_one_class β] [monoid_hom_class F α β] {m : α} (f : F) :
  is_square m → is_square (f m) :=
by { rintro ⟨m, rfl⟩, exact ⟨f m, by simp⟩ }

section monoid
variables [monoid α]

@[to_additive even_iff_exists_two_nsmul]
lemma is_square_iff_exists_sq (m : α) : is_square m ↔ ∃ c, m = c ^ 2 :=
by simp [is_square, pow_two]

alias is_square_iff_exists_sq ↔ is_square.exists_sq is_square_of_exists_sq

attribute [to_additive even.exists_two_nsmul "Alias of the forwards direction of
`even_iff_exists_two_nsmul`."] is_square.exists_sq

attribute [to_additive even_of_exists_two_nsmul "Alias of the backwards direction of
`even_iff_exists_two_nsmul`."] is_square_of_exists_sq

@[simp, to_additive even_two_nsmul]
lemma is_square_sq (a : α) : is_square (a ^ 2) := ⟨a, pow_two _⟩

variables [has_distrib_neg α] {n : ℕ}

lemma even.neg_pow : even n → ∀ a : α, (-a) ^ n = a ^ n :=
by { rintro ⟨c, rfl⟩ a, simp_rw [←two_mul, pow_mul, neg_sq] }

lemma even.neg_one_pow (h : even n) : (-1 : α) ^ n = 1 := by rw [h.neg_pow, one_pow]

end monoid

/-- `0` is always a square (in a monoid with zero). -/
lemma is_square_zero (M : Type*) [monoid_with_zero M] : is_square (0 : M) :=
by { use 0, simp only [mul_zero] }

@[to_additive] lemma is_square.mul [comm_semigroup α] {a b : α} :
  is_square a → is_square b → is_square (a * b) :=
by { rintro ⟨a, rfl⟩ ⟨b, rfl⟩, exact ⟨a * b, mul_mul_mul_comm _ _ _ _⟩ }

section division_monoid
variables [division_monoid α] {a : α}

@[simp, to_additive] lemma is_square_inv : is_square a⁻¹ ↔ is_square a :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  { rw [← is_square_op_iff, ← inv_inv a],
    exact h.map (mul_equiv.inv' α) },
  { exact ((is_square_op_iff a).mpr h).map (mul_equiv.inv' α).symm }
end

alias is_square_inv ↔ _ is_square.inv

attribute [to_additive] is_square.inv

variables [has_distrib_neg α] {n : ℤ}

lemma even.neg_zpow : even n → ∀ a : α, (-a) ^ n = a ^ n :=
by { rintro ⟨c, rfl⟩ a, exact zpow_bit0_neg _ _ }

lemma even.neg_one_zpow (h : even n) : (-1 : α) ^ n = 1 := by rw [h.neg_zpow, one_zpow]

end division_monoid

lemma even_abs [subtraction_monoid α] [linear_order α] {a : α} : even (|a|) ↔ even a :=
by cases abs_choice a; simp only [h, even_neg]

@[to_additive]
lemma is_square.div [division_comm_monoid α] {a b : α} (ha : is_square a) (hb : is_square b) :
  is_square (a / b) :=
by { rw div_eq_mul_inv, exact ha.mul hb.inv }

-- `odd.tsub` requires `canonically_linear_ordered_semiring`, which we don't have
lemma even.tsub [canonically_linear_ordered_add_monoid α] [has_sub α] [has_ordered_sub α]
  [contravariant_class α α (+) (≤)] {m n : α} (hm : even m) (hn : even n) : even (m - n) :=
begin
  obtain ⟨a, rfl⟩ := hm,
  obtain ⟨b, rfl⟩ := hn,
  refine ⟨a - b, _⟩,
  obtain h | h := le_total a b,
  { rw [tsub_eq_zero_of_le h, tsub_eq_zero_of_le (add_le_add h h), add_zero] },
  { exact (tsub_add_tsub_comm h h).symm }
end

lemma even_iff_exists_bit0 [has_add α] {a : α} : even a ↔ ∃ b, a = bit0 b := iff.rfl

alias even_iff_exists_bit0 ↔ even.exists_bit0 _

section semiring
variables [semiring α] [semiring β] {m n : α}

lemma even_iff_exists_two_mul (m : α) : even m ↔ ∃ c, m = 2 * c :=
by simp [even_iff_exists_two_nsmul]

lemma even_iff_two_dvd {a : α} : even a ↔ 2 ∣ a := by simp [even, has_dvd.dvd, two_mul]

@[simp] lemma range_two_mul (α : Type*) [semiring α] :
  set.range (λ x : α, 2 * x) = {a | even a} :=
by { ext x, simp [eq_comm, two_mul, even] }

@[simp] lemma even_bit0 (a : α) : even (bit0 a) :=
⟨a, rfl⟩

@[simp] lemma even_two : even (2 : α) := ⟨1, rfl⟩

@[simp] lemma even.mul_left (hm : even m) (n) : even (n * m) :=
hm.map (add_monoid_hom.mul_left n)

@[simp] lemma even.mul_right (hm : even m) (n) : even (m * n) :=
hm.map (add_monoid_hom.mul_right n)

lemma even_two_mul (m : α) : even (2 * m) := ⟨m, two_mul _⟩

lemma even.pow_of_ne_zero (hm : even m) : ∀ {a : ℕ}, a ≠ 0 → even (m ^ a)
| 0       a0 := (a0 rfl).elim
| (a + 1) _  := by { rw pow_succ, exact hm.mul_right _ }

section with_odd

/-- An element `a` of a semiring is odd if there exists `k` such `a = 2*k + 1`. -/
def odd (a : α) : Prop := ∃ k, a = 2*k + 1

lemma odd_iff_exists_bit1 {a : α} : odd a ↔ ∃ b, a = bit1 b :=
exists_congr $ λ b, by { rw two_mul, refl }

alias odd_iff_exists_bit1 ↔ odd.exists_bit1 _

@[simp] lemma odd_bit1 (a : α) : odd (bit1 a) := odd_iff_exists_bit1.2 ⟨a, rfl⟩

@[simp] lemma range_two_mul_add_one (α : Type*) [semiring α] :
  set.range (λ x : α, 2 * x + 1) = {a | odd a} :=
by { ext x, simp [odd, eq_comm] }

lemma even.add_odd : even m → odd n → odd (m + n) :=
by { rintro ⟨m, rfl⟩ ⟨n, rfl⟩, exact ⟨m + n, by rw [mul_add, ← two_mul, add_assoc]⟩ }

lemma odd.add_even (hm : odd m) (hn : even n) : odd (m + n) :=
by { rw add_comm, exact hn.add_odd hm }

lemma odd.add_odd : odd m → odd n → even (m + n) :=
begin
  rintro ⟨m, rfl⟩ ⟨n, rfl⟩,
  refine ⟨n + m + 1, _⟩,
  rw [← two_mul, ←add_assoc, add_comm _ (2 * n), ←add_assoc, ←mul_add, add_assoc, mul_add _ (n + m),
    mul_one],
  refl
end

@[simp] lemma odd_one : odd (1 : α) :=
⟨0, (zero_add _).symm.trans (congr_arg (+ (1 : α)) (mul_zero _).symm)⟩

@[simp] lemma odd_two_mul_add_one (m : α) : odd (2 * m + 1) := ⟨m, rfl⟩

lemma odd.map [ring_hom_class F α β] (f : F) : odd m → odd (f m) :=
by { rintro ⟨m, rfl⟩, exact ⟨f m, by simp [two_mul]⟩ }

@[simp] lemma odd.mul : odd m → odd n → odd (m * n) :=
begin
  rintro ⟨m, rfl⟩ ⟨n, rfl⟩,
  refine ⟨2 * m * n + n + m, _⟩,
  rw [mul_add, add_mul, mul_one, ← add_assoc, one_mul, mul_assoc, ← mul_add, ← mul_add, ← mul_assoc,
    ← nat.cast_two, ← nat.cast_comm],
end

lemma odd.pow (hm : odd m) : ∀ {a : ℕ}, odd (m ^ a)
| 0       := by { rw pow_zero, exact odd_one }
| (a + 1) := by { rw pow_succ, exact hm.mul odd.pow }

end with_odd
end semiring

section monoid
variables [monoid α] [has_distrib_neg α] {a : α} {n : ℕ}

lemma odd.neg_pow : odd n → ∀ a : α, (-a) ^ n = - a ^ n :=
by { rintro ⟨c, rfl⟩ a, simp_rw [pow_add, pow_mul, neg_sq, pow_one, mul_neg] }
lemma odd.neg_one_pow (h : odd n) : (-1 : α) ^ n = -1 := by rw [h.neg_pow, one_pow]

end monoid

section ring
variables [ring α] {a b : α} {n : ℕ}

@[simp] lemma even_neg_two : even (- 2 : α) := by simp only [even_neg, even_two]

lemma odd.neg (hp : odd a) : odd (-a) :=
begin
  obtain ⟨k, hk⟩ := hp,
  use -(k + 1),
  rw [mul_neg, mul_add, neg_add, add_assoc, two_mul (1 : α), neg_add,
    neg_add_cancel_right, ←neg_add, hk],
end

@[simp] lemma odd_neg : odd (-a) ↔ odd a := ⟨λ h, neg_neg a ▸ h.neg, odd.neg⟩

@[simp] lemma odd_neg_one : odd (- 1 : α) := by simp

lemma odd.sub_even (ha : odd a) (hb : even b) : odd (a - b) :=
by { rw sub_eq_add_neg, exact ha.add_even hb.neg }

lemma even.sub_odd (ha : even a) (hb : odd b) : odd (a - b) :=
by { rw sub_eq_add_neg, exact ha.add_odd hb.neg }

lemma odd.sub_odd (ha : odd a) (hb : odd b) : even (a - b) :=
by { rw sub_eq_add_neg, exact ha.add_odd hb.neg }

lemma odd_abs [linear_order α] : odd (abs a) ↔ odd a :=
by cases abs_choice a with h h; simp only [h, odd_neg]

end ring

section powers
variables [linear_ordered_ring R] {a : R} {n : ℕ}

lemma even.pow_nonneg (hn : even n) (a : R) : 0 ≤ a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using pow_bit0_nonneg a k

lemma even.pow_pos (hn : even n) (ha : a ≠ 0) : 0 < a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using pow_bit0_pos ha k

lemma odd.pow_nonpos (hn : odd n) (ha : a ≤ 0) : a ^ n ≤ 0:=
by cases hn with k hk; simpa only [hk, two_mul] using pow_bit1_nonpos_iff.mpr ha

lemma odd.pow_neg (hn : odd n) (ha : a < 0) : a ^ n < 0:=
by cases hn with k hk; simpa only [hk, two_mul] using pow_bit1_neg_iff.mpr ha

lemma odd.pow_nonneg_iff (hn : odd n) : 0 ≤ a ^ n ↔ 0 ≤ a :=
⟨λ h, le_of_not_lt (λ ha, h.not_lt $ hn.pow_neg ha), λ ha, pow_nonneg ha n⟩

lemma odd.pow_nonpos_iff (hn : odd n) : a ^ n ≤ 0 ↔ a ≤ 0 :=
⟨λ h, le_of_not_lt (λ ha, h.not_lt $ pow_pos ha _), hn.pow_nonpos⟩

lemma odd.pow_pos_iff (hn : odd n) : 0 < a ^ n ↔ 0 < a :=
⟨λ h, lt_of_not_le (λ ha, h.not_le $ hn.pow_nonpos ha), λ ha, pow_pos ha n⟩

lemma odd.pow_neg_iff (hn : odd n) : a ^ n < 0 ↔ a < 0 :=
⟨λ h, lt_of_not_le (λ ha, h.not_le $ pow_nonneg ha _), hn.pow_neg⟩

lemma even.pow_pos_iff (hn : even n) (h₀ : 0 < n) : 0 < a ^ n ↔ a ≠ 0 :=
⟨λ h ha, by { rw [ha, zero_pow h₀] at h, exact lt_irrefl 0 h }, hn.pow_pos⟩

lemma even.pow_abs {p : ℕ} (hp : even p) (a : R) : |a| ^ p = a ^ p :=
begin
  rw [←abs_pow, abs_eq_self],
  exact hp.pow_nonneg _
end

@[simp] lemma pow_bit0_abs (a : R) (p : ℕ) : |a| ^ bit0 p = a ^ bit0 p := (even_bit0 _).pow_abs _

lemma odd.strict_mono_pow (hn : odd n) : strict_mono (λ a : R, a ^ n) :=
by cases hn with k hk; simpa only [hk, two_mul] using strict_mono_pow_bit1 _

end powers

/-- The cardinality of `fin (bit0 k)` is even, `fact` version.
This `fact` is needed as an instance by `matrix.special_linear_group.has_neg`. -/
lemma fintype.card_fin_even {k : ℕ} : fact (even (fintype.card (fin (bit0 k)))) :=
⟨by { rw [fintype.card_fin], exact even_bit0 k }⟩

section field_power
variable {K : Type*}

section division_ring
variables [division_ring K] {n : ℤ}

lemma odd.neg_zpow (h : odd n) (a : K) : (-a) ^ n = - a ^ n :=
by { obtain ⟨k, rfl⟩ := h.exists_bit1, exact zpow_bit1_neg _ _ }

lemma odd.neg_one_zpow (h : odd n) : (-1 : K) ^ n = -1 := by rw [h.neg_zpow, one_zpow]

end division_ring

variables [linear_ordered_field K] {n : ℤ} {a : K}

protected lemma even.zpow_nonneg (hn : even n) (a : K) : 0 ≤ a ^ n :=
begin
  cases le_or_lt 0 a with h h,
  { exact zpow_nonneg h _ },
  { exact (hn.neg_zpow a).subst (zpow_nonneg (neg_nonneg_of_nonpos h.le) _) }
end

theorem even.zpow_pos (hn : even n) (ha : a ≠ 0) : 0 < a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit0_pos ha k

protected lemma odd.zpow_nonneg (hn : odd n) (ha : 0 ≤ a) : 0 ≤ a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_nonneg_iff.mpr ha

theorem odd.zpow_pos (hn : odd n) (ha : 0 < a) : 0 < a ^ n :=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_pos_iff.mpr ha

theorem odd.zpow_nonpos (hn : odd n) (ha : a ≤ 0) : a ^ n ≤ 0:=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_nonpos_iff.mpr ha

theorem odd.zpow_neg (hn : odd n) (ha : a < 0) : a ^ n < 0:=
by cases hn with k hk; simpa only [hk, two_mul] using zpow_bit1_neg_iff.mpr ha

lemma even.zpow_abs {p : ℤ} (hp : even p) (a : K) : |a| ^ p = a ^ p :=
begin
  cases abs_choice a with h h;
  simp only [h, hp.neg_zpow _],
end

@[simp] lemma zpow_bit0_abs (a : K) (p : ℤ) : |a| ^ bit0 p = a ^ bit0 p :=
(even_bit0 _).zpow_abs _

lemma even.abs_zpow {p : ℤ} (hp : even p) (a : K) : |a ^ p| = a ^ p :=
begin
  rw [abs_eq_self],
  exact hp.zpow_nonneg _
end

@[simp] lemma abs_zpow_bit0 (a : K) (p : ℤ) :
  |a ^ bit0 p| = a ^ bit0 p :=
(even_bit0 _).abs_zpow _

end field_power


<|start_filename|>src/topology/uniform_space/separation.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import tactic.apply_fun
import data.set.pairwise
import topology.uniform_space.basic
import topology.separation

/-!
# Hausdorff properties of uniform spaces. Separation quotient.

This file studies uniform spaces whose underlying topological spaces are separated
(also known as Hausdorff or T₂).
This turns out to be equivalent to asking that the intersection of all entourages
is the diagonal only. This condition actually implies the stronger separation property
that the space is regular (T₃), hence those conditions are equivalent for topologies coming from
a uniform structure.

More generally, the intersection `𝓢 X` of all entourages of `X`, which has type `set (X × X)` is an
equivalence relation on `X`. Points which are equivalent under the relation are basically
undistinguishable from the point of view of the uniform structure. For instance any uniformly
continuous function will send equivalent points to the same value.

The quotient `separation_quotient X` of `X` by `𝓢 X` has a natural uniform structure which is
separated, and satisfies a universal property: every uniformly continuous function
from `X` to a separated uniform space uniquely factors through `separation_quotient X`.
As usual, this allows to turn `separation_quotient` into a functor (but we don't use the
category theory library in this file).

These notions admit relative versions, one can ask that `s : set X` is separated, this
is equivalent to asking that the uniform structure induced on `s` is separated.

## Main definitions

* `separation_relation X : set (X × X)`: the separation relation
* `separated_space X`: a predicate class asserting that `X` is separated
* `is_separated s`: a predicate asserting that `s : set X` is separated
* `separation_quotient X`: the maximal separated quotient of `X`.
* `separation_quotient.lift f`: factors a map `f : X → Y` through the separation quotient of `X`.
* `separation_quotient.map f`: turns a map `f : X → Y` into a map between the separation quotients
  of `X` and `Y`.

## Main results

* `separated_iff_t2`: the equivalence between being separated and being Hausdorff for uniform
  spaces.
* `separation_quotient.uniform_continuous_lift`: factoring a uniformly continuous map through the
  separation quotient gives a uniformly continuous map.
* `separation_quotient.uniform_continuous_map`: maps induced between separation quotients are
  uniformly continuous.

## Notations

Localized in `uniformity`, we have the notation `𝓢 X` for the separation relation
on a uniform space `X`,

## Implementation notes

The separation setoid `separation_setoid` is not declared as a global instance.
It is made a local instance while building the theory of `separation_quotient`.
The factored map `separation_quotient.lift f` is defined without imposing any condition on
`f`, but returns junk if `f` is not uniformly continuous (constant junk hence it is always
uniformly continuous).

-/

open filter topological_space set classical function uniform_space
open_locale classical topological_space uniformity filter
noncomputable theory
set_option eqn_compiler.zeta true

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}
variables [uniform_space α] [uniform_space β] [uniform_space γ]


/-!
### Separated uniform spaces
-/

/-- The separation relation is the intersection of all entourages.
  Two points which are related by the separation relation are "indistinguishable"
  according to the uniform structure. -/
protected def separation_rel (α : Type u) [u : uniform_space α] :=
⋂₀ (𝓤 α).sets

localized "notation `𝓢` := separation_rel" in uniformity

lemma separated_equiv : equivalence (λx y, (x, y) ∈ 𝓢 α) :=
⟨assume x, assume s, refl_mem_uniformity,
  assume x y, assume h (s : set (α×α)) hs,
    have preimage prod.swap s ∈ 𝓤 α,
      from symm_le_uniformity hs,
    h _ this,
  assume x y z (hxy : (x, y) ∈ 𝓢 α) (hyz : (y, z) ∈ 𝓢 α)
      s (hs : s ∈ 𝓤 α),
    let ⟨t, ht, (h_ts : comp_rel t t ⊆ s)⟩ := comp_mem_uniformity_sets hs in
    h_ts $ show (x, z) ∈ comp_rel t t,
      from ⟨y, hxy t ht, hyz t ht⟩⟩

lemma filter.has_basis.mem_separation_rel {ι : Sort*} {p : ι → Prop} {s : ι → set (α × α)}
  (h : (𝓤 α).has_basis p s) {a : α × α} :
  a ∈ 𝓢 α ↔ ∀ i, p i → a ∈ s i :=
h.forall_mem_mem

/-- A uniform space is separated if its separation relation is trivial (each point
is related only to itself). -/
class separated_space (α : Type u) [uniform_space α] : Prop := (out : 𝓢 α = id_rel)

theorem separated_space_iff {α : Type u} [uniform_space α] :
  separated_space α ↔ 𝓢 α = id_rel :=
⟨λ h, h.1, λ h, ⟨h⟩⟩

theorem separated_def {α : Type u} [uniform_space α] :
  separated_space α ↔ ∀ x y, (∀ r ∈ 𝓤 α, (x, y) ∈ r) → x = y :=
by simp [separated_space_iff, id_rel_subset.2 separated_equiv.1, subset.antisymm_iff];
   simp [subset_def, separation_rel]

theorem separated_def' {α : Type u} [uniform_space α] :
  separated_space α ↔ ∀ x y, x ≠ y → ∃ r ∈ 𝓤 α, (x, y) ∉ r :=
separated_def.trans $ forall₂_congr $ λ x y, by rw ← not_imp_not; simp [not_forall]

lemma eq_of_uniformity {α : Type*} [uniform_space α] [separated_space α] {x y : α}
  (h : ∀ {V}, V ∈ 𝓤 α → (x, y) ∈ V) : x = y :=
separated_def.mp ‹separated_space α› x y (λ _, h)

lemma eq_of_uniformity_basis {α : Type*} [uniform_space α] [separated_space α] {ι : Type*}
  {p : ι → Prop} {s : ι → set (α × α)} (hs : (𝓤 α).has_basis p s) {x y : α}
  (h : ∀ {i}, p i → (x, y) ∈ s i) : x = y :=
eq_of_uniformity (λ V V_in, let ⟨i, hi, H⟩ := hs.mem_iff.mp V_in in H (h hi))

lemma eq_of_forall_symmetric {α : Type*} [uniform_space α] [separated_space α] {x y : α}
  (h : ∀ {V}, V ∈ 𝓤 α → symmetric_rel V → (x, y) ∈ V) : x = y :=
eq_of_uniformity_basis has_basis_symmetric (by simpa [and_imp] using λ _, h)

lemma id_rel_sub_separation_relation (α : Type*) [uniform_space α] : id_rel ⊆ 𝓢 α :=
begin
  unfold separation_rel,
  rw id_rel_subset,
  intros x,
  suffices : ∀ t ∈ 𝓤 α, (x, x) ∈ t, by simpa only [refl_mem_uniformity],
  exact λ t, refl_mem_uniformity,
end

lemma separation_rel_comap  {f : α → β}
  (h : ‹uniform_space α› = uniform_space.comap f ‹uniform_space β›) :
  𝓢 α = (prod.map f f) ⁻¹' 𝓢 β :=
begin
  dsimp [separation_rel],
  simp_rw [uniformity_comap h, (filter.comap_has_basis (prod.map f f) (𝓤 β)).sInter_sets,
      ← preimage_Inter, sInter_eq_bInter],
  refl,
end

protected lemma filter.has_basis.separation_rel {ι : Sort*} {p : ι → Prop} {s : ι → set (α × α)}
  (h : has_basis (𝓤 α) p s) :
  𝓢 α = ⋂ i (hi : p i), s i :=
by { unfold separation_rel, rw h.sInter_sets }

lemma separation_rel_eq_inter_closure : 𝓢 α = ⋂₀ (closure '' (𝓤 α).sets) :=
by simp [uniformity_has_basis_closure.separation_rel]

lemma is_closed_separation_rel : is_closed (𝓢 α) :=
begin
  rw separation_rel_eq_inter_closure,
  apply is_closed_sInter,
  rintros _ ⟨t, t_in, rfl⟩,
  exact is_closed_closure,
end

lemma separated_iff_t2 : separated_space α ↔ t2_space α :=
begin
  classical,
  split ; introI h,
  { rw [t2_iff_is_closed_diagonal, ← show 𝓢 α = diagonal α, from h.1],
    exact is_closed_separation_rel },
  { rw separated_def',
    intros x y hxy,
    rcases t2_separation hxy with ⟨u, v, uo, vo, hx, hy, h⟩,
    rcases is_open_iff_ball_subset.1 uo x hx with ⟨r, hrU, hr⟩,
    exact ⟨r, hrU, λ H, disjoint_iff.2 h ⟨hr H, hy⟩⟩ }
end

@[priority 100] -- see Note [lower instance priority]
instance separated_regular [separated_space α] : regular_space α :=
{ t0 := by { haveI := separated_iff_t2.mp ‹_›, exact t1_space.t0_space.t0 },
  regular := λs a hs ha,
    have sᶜ ∈ 𝓝 a,
      from is_open.mem_nhds hs.is_open_compl ha,
    have {p : α × α | p.1 = a → p.2 ∈ sᶜ} ∈ 𝓤 α,
      from mem_nhds_uniformity_iff_right.mp this,
    let ⟨d, hd, h⟩ := comp_mem_uniformity_sets this in
    let e := {y:α| (a, y) ∈ d} in
    have hae : a ∈ closure e, from subset_closure $ refl_mem_uniformity hd,
    have closure e ×ˢ closure e ⊆ comp_rel d (comp_rel (e ×ˢ e) d),
    begin
      rw [←closure_prod_eq, closure_eq_inter_uniformity],
      change (⨅d' ∈ 𝓤 α, _) ≤ comp_rel d (comp_rel _ d),
      exact (infi_le_of_le d $ infi_le_of_le hd $ le_rfl)
    end,
    have e_subset : closure e ⊆ sᶜ,
      from assume a' ha',
        let ⟨x, (hx : (a, x) ∈ d), y, ⟨hx₁, hx₂⟩, (hy : (y, _) ∈ d)⟩ := @this ⟨a, a'⟩ ⟨hae, ha'⟩ in
        have (a, a') ∈ comp_rel d d, from ⟨y, hx₂, hy⟩,
        h this rfl,
    have closure e ∈ 𝓝 a, from (𝓝 a).sets_of_superset (mem_nhds_left a hd) subset_closure,
    have 𝓝 a ⊓ 𝓟 (closure e)ᶜ = ⊥,
      from (is_compl_principal (closure e)).inf_right_eq_bot_iff.2 (le_principal_iff.2 this),
    ⟨(closure e)ᶜ, is_closed_closure.is_open_compl, assume x h₁ h₂, @e_subset x h₂ h₁, this⟩,
    ..@t2_space.t1_space _ _ (separated_iff_t2.mp ‹_›) }

lemma is_closed_of_spaced_out [separated_space α] {V₀ : set (α × α)} (V₀_in : V₀ ∈ 𝓤 α)
  {s : set α} (hs : s.pairwise (λ x y, (x, y) ∉ V₀)) : is_closed s :=
begin
  rcases comp_symm_mem_uniformity_sets V₀_in with ⟨V₁, V₁_in, V₁_symm, h_comp⟩,
  apply is_closed_of_closure_subset,
  intros x hx,
  rw mem_closure_iff_ball at hx,
  rcases hx V₁_in with ⟨y, hy, hy'⟩,
  suffices : x = y, by rwa this,
  apply eq_of_forall_symmetric,
  intros V V_in V_symm,
  rcases hx (inter_mem V₁_in V_in) with ⟨z, hz, hz'⟩,
  obtain rfl : z = y,
  { by_contra hzy,
    exact hs hz' hy' hzy (h_comp $ mem_comp_of_mem_ball V₁_symm (ball_inter_left x _ _ hz) hy) },
  exact ball_inter_right x _ _ hz
end

lemma is_closed_range_of_spaced_out {ι} [separated_space α] {V₀ : set (α × α)} (V₀_in : V₀ ∈ 𝓤 α)
  {f : ι → α} (hf : pairwise (λ x y, (f x, f y) ∉ V₀)) : is_closed (range f) :=
is_closed_of_spaced_out V₀_in $
  by { rintro _ ⟨x, rfl⟩ _ ⟨y, rfl⟩ h, exact hf x y (ne_of_apply_ne f h) }

/-!
### Separated sets
-/

/-- A set `s` in a uniform space `α` is separated if the separation relation `𝓢 α`
induces the trivial relation on `s`. -/
def is_separated (s : set α) : Prop := ∀ x y ∈ s, (x, y) ∈ 𝓢 α → x = y

lemma is_separated_def (s : set α) : is_separated s ↔ ∀ x y ∈ s, (x, y) ∈ 𝓢 α → x = y :=
iff.rfl

lemma is_separated_def' (s : set α) : is_separated s ↔ (s ×ˢ s) ∩ 𝓢 α ⊆ id_rel :=
begin
  rw is_separated_def,
  split,
  { rintros h ⟨x, y⟩ ⟨⟨x_in, y_in⟩, H⟩,
    simp [h x x_in y y_in H] },
  { intros h x x_in y y_in xy_in,
    rw ← mem_id_rel,
    exact h ⟨mk_mem_prod x_in y_in, xy_in⟩ }
end

lemma is_separated.mono {s t : set α} (hs : is_separated s) (hts : t ⊆ s) : is_separated t :=
λ x hx y hy, hs x (hts hx) y (hts hy)

lemma univ_separated_iff : is_separated (univ : set α) ↔ separated_space α :=
begin
  simp only [is_separated, mem_univ, true_implies_iff, separated_space_iff],
  split,
  { intro h,
    exact subset.antisymm (λ ⟨x, y⟩ xy_in, h x y xy_in) (id_rel_sub_separation_relation α), },
  { intros h x y xy_in,
    rwa h at xy_in },
end

lemma is_separated_of_separated_space [separated_space α] (s : set α) : is_separated s :=
begin
  rw [is_separated, separated_space.out],
  tauto,
end

lemma is_separated_iff_induced {s : set α} : is_separated s ↔ separated_space s :=
begin
  rw separated_space_iff,
  change _ ↔ 𝓢 {x // x ∈ s} = _,
  rw [separation_rel_comap rfl, is_separated_def'],
  split; intro h,
  { ext ⟨⟨x, x_in⟩, ⟨y, y_in⟩⟩,
    suffices : (x, y) ∈ 𝓢 α ↔ x = y, by simpa only [mem_id_rel],
    refine ⟨λ H, h ⟨mk_mem_prod x_in y_in, H⟩, _⟩,
    rintro rfl,
    exact id_rel_sub_separation_relation α rfl },
  { rintros ⟨x, y⟩ ⟨⟨x_in, y_in⟩, hS⟩,
    have A : (⟨⟨x, x_in⟩, ⟨y, y_in⟩⟩ : ↥s × ↥s) ∈ prod.map (coe : s → α) (coe : s → α) ⁻¹' 𝓢 α,
      from hS,
    simpa using h.subset A }
end

lemma eq_of_uniformity_inf_nhds_of_is_separated {s : set α} (hs : is_separated s) :
  ∀ {x y : α}, x ∈ s → y ∈ s → cluster_pt (x, y) (𝓤 α) → x = y :=
begin
  intros x y x_in y_in H,
  have : ∀ V ∈ 𝓤 α, (x, y) ∈ closure V,
  { intros V V_in,
    rw mem_closure_iff_cluster_pt,
    have : 𝓤 α ≤ 𝓟 V, by rwa le_principal_iff,
    exact H.mono this },
  apply hs x x_in y y_in,
  simpa [separation_rel_eq_inter_closure],
end

lemma eq_of_uniformity_inf_nhds [separated_space α] :
  ∀ {x y : α}, cluster_pt (x, y) (𝓤 α) → x = y :=
begin
  have : is_separated (univ : set α),
  { rw univ_separated_iff,
    assumption },
  introv,
  simpa using eq_of_uniformity_inf_nhds_of_is_separated this,
end

/-!
### Separation quotient
-/
namespace uniform_space

/-- The separation relation of a uniform space seen as a setoid. -/
def separation_setoid (α : Type u) [uniform_space α] : setoid α :=
⟨λx y, (x, y) ∈ 𝓢 α, separated_equiv⟩

local attribute [instance] separation_setoid

instance separation_setoid.uniform_space {α : Type u} [u : uniform_space α] :
  uniform_space (quotient (separation_setoid α)) :=
{ to_topological_space := u.to_topological_space.coinduced (λx, ⟦x⟧),
  uniformity := map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)) u.uniformity,
  refl := le_trans (by simp [quotient.exists_rep]) (filter.map_mono refl_le_uniformity),
  symm := tendsto_map' $
    by simp [prod.swap, (∘)]; exact tendsto_map.comp tendsto_swap_uniformity,
  comp := calc (map (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) u.uniformity).lift' (λs, comp_rel s s) =
          u.uniformity.lift' ((λs, comp_rel s s) ∘ image (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧))) :
      map_lift'_eq2 $ monotone_comp_rel monotone_id monotone_id
    ... ≤ u.uniformity.lift' (image (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) ∘
            (λs:set (α×α), comp_rel s (comp_rel s s))) :
      lift'_mono' $ assume s hs ⟨a, b⟩ ⟨c, ⟨⟨a₁, a₂⟩, ha, a_eq⟩, ⟨⟨b₁, b₂⟩, hb, b_eq⟩⟩,
      begin
        simp at a_eq,
        simp at b_eq,
        have h : ⟦a₂⟧ = ⟦b₁⟧, { rw [a_eq.right, b_eq.left] },
        have h : (a₂, b₁) ∈ 𝓢 α := quotient.exact h,
        simp [function.comp, set.image, comp_rel, and.comm, and.left_comm, and.assoc],
        exact ⟨a₁, a_eq.left, b₂, b_eq.right, a₂, ha, b₁, h s hs, hb⟩
      end
    ... = map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧))
            (u.uniformity.lift' (λs:set (α×α), comp_rel s (comp_rel s s))) :
      by rw [map_lift'_eq];
        exact monotone_comp_rel monotone_id (monotone_comp_rel monotone_id monotone_id)
    ... ≤ map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)) u.uniformity :
      map_mono comp_le_uniformity3,
  is_open_uniformity := assume s,
    have ∀a, ⟦a⟧ ∈ s →
        ({p:α×α | p.1 = a → ⟦p.2⟧ ∈ s} ∈ 𝓤 α ↔
          {p:α×α | p.1 ≈ a → ⟦p.2⟧ ∈ s} ∈ 𝓤 α),
      from assume a ha,
      ⟨assume h,
        let ⟨t, ht, hts⟩ := comp_mem_uniformity_sets h in
        have hts : ∀{a₁ a₂}, (a, a₁) ∈ t → (a₁, a₂) ∈ t → ⟦a₂⟧ ∈ s,
          from assume a₁ a₂ ha₁ ha₂, @hts (a, a₂) ⟨a₁, ha₁, ha₂⟩ rfl,
        have ht' : ∀{a₁ a₂}, a₁ ≈ a₂ → (a₁, a₂) ∈ t,
          from assume a₁ a₂ h, sInter_subset_of_mem ht h,
        u.uniformity.sets_of_superset ht $ assume ⟨a₁, a₂⟩ h₁ h₂, hts (ht' $ setoid.symm h₂) h₁,
        assume h, u.uniformity.sets_of_superset h $ by simp {contextual := tt}⟩,
    begin
      simp [topological_space.coinduced, u.is_open_uniformity, uniformity, forall_quotient_iff],
      exact ⟨λh a ha, (this a ha).mp $ h a ha, λh a ha, (this a ha).mpr $ h a ha⟩
    end }

lemma uniformity_quotient :
  𝓤 (quotient (separation_setoid α)) = (𝓤 α).map (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)) :=
rfl

lemma uniform_continuous_quotient_mk :
  uniform_continuous (quotient.mk : α → quotient (separation_setoid α)) :=
le_rfl

lemma uniform_continuous_quotient {f : quotient (separation_setoid α) → β}
  (hf : uniform_continuous (λx, f ⟦x⟧)) : uniform_continuous f :=
hf

lemma uniform_continuous_quotient_lift
  {f : α → β} {h : ∀a b, (a, b) ∈ 𝓢 α → f a = f b}
  (hf : uniform_continuous f) : uniform_continuous (λa, quotient.lift f h a) :=
uniform_continuous_quotient hf

lemma uniform_continuous_quotient_lift₂
  {f : α → β → γ} {h : ∀a c b d, (a, b) ∈ 𝓢 α → (c, d) ∈ 𝓢 β → f a c = f b d}
  (hf : uniform_continuous (λp:α×β, f p.1 p.2)) :
  uniform_continuous (λp:_×_, quotient.lift₂ f h p.1 p.2) :=
begin
  rw [uniform_continuous, uniformity_prod_eq_prod, uniformity_quotient, uniformity_quotient,
    filter.prod_map_map_eq, filter.tendsto_map'_iff, filter.tendsto_map'_iff],
  rwa [uniform_continuous, uniformity_prod_eq_prod, filter.tendsto_map'_iff] at hf
end

lemma comap_quotient_le_uniformity :
  (𝓤 $ quotient $ separation_setoid α).comap (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) ≤ (𝓤 α) :=
assume t' ht',
let ⟨t, ht, tt_t'⟩ := comp_mem_uniformity_sets ht' in
let ⟨s, hs, ss_t⟩ := comp_mem_uniformity_sets ht in
⟨(λp:α×α, (⟦p.1⟧, ⟦p.2⟧)) '' s,
  (𝓤 α).sets_of_superset hs $ assume x hx, ⟨x, hx, rfl⟩,
  assume ⟨a₁, a₂⟩ ⟨⟨b₁, b₂⟩, hb, ab_eq⟩,
  have ⟦b₁⟧ = ⟦a₁⟧ ∧ ⟦b₂⟧ = ⟦a₂⟧, from prod.mk.inj ab_eq,
  have b₁ ≈ a₁ ∧ b₂ ≈ a₂, from and.imp quotient.exact quotient.exact this,
  have ab₁ : (a₁, b₁) ∈ t, from (setoid.symm this.left) t ht,
  have ba₂ : (b₂, a₂) ∈ s, from this.right s hs,
  tt_t' ⟨b₁, show ((a₁, a₂).1, b₁) ∈ t, from ab₁,
    ss_t ⟨b₂, show ((b₁, a₂).1, b₂) ∈ s, from hb, ba₂⟩⟩⟩

lemma comap_quotient_eq_uniformity :
  (𝓤 $ quotient $ separation_setoid α).comap (λ (p : α × α), (⟦p.fst⟧, ⟦p.snd⟧)) = 𝓤 α :=
le_antisymm comap_quotient_le_uniformity le_comap_map


instance separated_separation : separated_space (quotient (separation_setoid α)) :=
⟨set.ext $ assume ⟨a, b⟩, quotient.induction_on₂ a b $ assume a b,
  ⟨assume h,
    have a ≈ b, from assume s hs,
      have s ∈ (𝓤 $ quotient $ separation_setoid α).comap (λp:(α×α), (⟦p.1⟧, ⟦p.2⟧)),
        from comap_quotient_le_uniformity hs,
      let ⟨t, ht, hts⟩ := this in
      hts begin dsimp [preimage], exact h t ht end,
    show ⟦a⟧ = ⟦b⟧, from quotient.sound this,

  assume heq : ⟦a⟧ = ⟦b⟧, assume h hs,
  heq ▸ refl_mem_uniformity hs⟩⟩

lemma separated_of_uniform_continuous {f : α → β} {x y : α}
  (H : uniform_continuous f) (h : x ≈ y) : f x ≈ f y :=
assume _ h', h _ (H h')

lemma eq_of_separated_of_uniform_continuous [separated_space β] {f : α → β} {x y : α}
  (H : uniform_continuous f) (h : x ≈ y) : f x = f y :=
separated_def.1 (by apply_instance) _ _ $ separated_of_uniform_continuous H h

lemma _root_.is_separated.eq_of_uniform_continuous {f : α → β} {x y : α} {s : set β}
  (hs : is_separated s) (hxs : f x ∈ s) (hys : f y ∈ s) (H : uniform_continuous f) (h : x ≈ y) :
  f x = f y :=
(is_separated_def _).mp hs _ hxs _ hys $ λ _ h', h _ (H h')

/-- The maximal separated quotient of a uniform space `α`. -/
def separation_quotient (α : Type*) [uniform_space α] := quotient (separation_setoid α)

namespace separation_quotient
instance : uniform_space (separation_quotient α) := separation_setoid.uniform_space
instance : separated_space (separation_quotient α) := uniform_space.separated_separation
instance [inhabited α] : inhabited (separation_quotient α) :=
quotient.inhabited (separation_setoid α)

/-- Factoring functions to a separated space through the separation quotient. -/
def lift [separated_space β] (f : α → β) : (separation_quotient α → β) :=
if h : uniform_continuous f then
  quotient.lift f (λ x y, eq_of_separated_of_uniform_continuous h)
else
  λ x, f (nonempty.some ⟨x.out⟩)

lemma lift_mk [separated_space β] {f : α → β} (h : uniform_continuous f) (a : α) :
  lift f ⟦a⟧ = f a :=
by rw [lift, dif_pos h]; refl

lemma uniform_continuous_lift [separated_space β] (f : α → β) : uniform_continuous (lift f) :=
begin
  by_cases hf : uniform_continuous f,
  { rw [lift, dif_pos hf], exact uniform_continuous_quotient_lift hf },
  { rw [lift, dif_neg hf], exact uniform_continuous_of_const (assume a b, rfl) }
end

/-- The separation quotient functor acting on functions. -/
def map (f : α → β) : separation_quotient α → separation_quotient β :=
lift (quotient.mk ∘ f)

lemma map_mk {f : α → β} (h : uniform_continuous f) (a : α) : map f ⟦a⟧ = ⟦f a⟧ :=
by rw [map, lift_mk (uniform_continuous_quotient_mk.comp h)]

lemma uniform_continuous_map (f : α → β) : uniform_continuous (map f) :=
uniform_continuous_lift (quotient.mk ∘ f)

lemma map_unique {f : α → β} (hf : uniform_continuous f)
  {g : separation_quotient α → separation_quotient β}
  (comm : quotient.mk ∘ f = g ∘ quotient.mk) : map f = g :=
by ext ⟨a⟩;
calc map f ⟦a⟧ = ⟦f a⟧ : map_mk hf a
  ... = g ⟦a⟧ : congr_fun comm a

lemma map_id : map (@id α) = id :=
map_unique uniform_continuous_id rfl

lemma map_comp {f : α → β} {g : β → γ} (hf : uniform_continuous f) (hg : uniform_continuous g) :
  map g ∘ map f = map (g ∘ f) :=
(map_unique (hg.comp hf) $ by simp only [(∘), map_mk, hf, hg]).symm

end separation_quotient

lemma separation_prod {a₁ a₂ : α} {b₁ b₂ : β} : (a₁, b₁) ≈ (a₂, b₂) ↔ a₁ ≈ a₂ ∧ b₁ ≈ b₂ :=
begin
  split,
  { assume h,
    exact ⟨separated_of_uniform_continuous uniform_continuous_fst h,
           separated_of_uniform_continuous uniform_continuous_snd h⟩ },
  { rintros ⟨eqv_α, eqv_β⟩ r r_in,
    rw uniformity_prod at r_in,
    rcases r_in with ⟨t_α, ⟨r_α, r_α_in, h_α⟩, t_β, ⟨r_β, r_β_in, h_β⟩, rfl⟩,
    let p_α := λ(p : (α × β) × (α × β)), (p.1.1, p.2.1),
    let p_β := λ(p : (α × β) × (α × β)), (p.1.2, p.2.2),
    have key_α : p_α ((a₁, b₁), (a₂, b₂)) ∈ r_α, { simp [p_α, eqv_α r_α r_α_in] },
    have key_β : p_β ((a₁, b₁), (a₂, b₂)) ∈ r_β, { simp [p_β, eqv_β r_β r_β_in] },
    exact ⟨h_α key_α, h_β key_β⟩ },
end

instance separated.prod [separated_space α] [separated_space β] : separated_space (α × β) :=
separated_def.2 $ assume x y H, prod.ext
  (eq_of_separated_of_uniform_continuous uniform_continuous_fst H)
  (eq_of_separated_of_uniform_continuous uniform_continuous_snd H)

lemma _root_.is_separated.prod {s : set α} {t : set β} (hs : is_separated s) (ht : is_separated t) :
  is_separated (s ×ˢ t) :=
(is_separated_def _).mpr $ λ x hx y hy H, prod.ext
  (hs.eq_of_uniform_continuous hx.1 hy.1 uniform_continuous_fst H)
  (ht.eq_of_uniform_continuous hx.2 hy.2 uniform_continuous_snd H)

end uniform_space


<|start_filename|>src/order/filter/pointwise.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import data.set.pointwise
import order.filter.n_ary
import order.filter.ultrafilter

/-!
# Pointwise operations on filters

This file defines pointwise operations on filters. This is useful because usual algebraic operations
distribute over pointwise operations. For example,
* `(f₁ * f₂).map m  = f₁.map m * f₂.map m`
* `𝓝 (x * y) = 𝓝 x * 𝓝 y`

## Main declarations

* `0` (`filter.has_zero`): Pure filter at `0 : α`, or alternatively principal filter at `0 : set α`.
* `1` (`filter.has_one`): Pure filter at `1 : α`, or alternatively principal filter at `1 : set α`.
* `f + g` (`filter.has_add`): Addition, filter generated by all `s + t` where `s ∈ f` and `t ∈ g`.
* `f * g` (`filter.has_mul`): Multiplication, filter generated by all `s * t` where `s ∈ f` and
  `t ∈ g`.
* `-f` (`filter.has_neg`): Negation, filter of all `-s` where `s ∈ f`.
* `f⁻¹` (`filter.has_inv`): Inversion, filter of all `s⁻¹` where `s ∈ f`.
* `f - g` (`filter.has_sub`): Subtraction, filter generated by all `s - t` where `s ∈ f` and
  `t ∈ g`.
* `f / g` (`filter.has_div`): Division, filter generated by all `s / t` where `s ∈ f` and `t ∈ g`.
* `f +ᵥ g` (`filter.has_vadd`): Scalar addition, filter generated by all `s +ᵥ t` where `s ∈ f` and
  `t ∈ g`.
* `f -ᵥ g` (`filter.has_vsub`): Scalar subtraction, filter generated by all `s -ᵥ t` where `s ∈ f`
  and `t ∈ g`.
* `f • g` (`filter.has_scalar`): Scalar multiplication, filter generated by all `s • t` where
  `s ∈ f` and `t ∈ g`.
* `a +ᵥ f` (`filter.has_vadd_filter`): Translation, filter of all `a +ᵥ s` where `s ∈ f`.
* `a • f` (`filter.has_scalar_filter`): Scaling, filter of all `a • s` where `s ∈ f`.

For `α` a semigroup/monoid, `filter α` is a semigroup/monoid.
As an unfortunate side effect, this means that `n • f`, where `n : ℕ`, is ambiguous between
pointwise scaling and repeated pointwise addition. See note [pointwise nat action].

## Implementation notes

We put all instances in the locale `pointwise`, so that these instances are not available by
default. Note that we do not mark them as reducible (as argued by note [reducible non-instances])
since we expect the locale to be open whenever the instances are actually used (and making the
instances reducible changes the behavior of `simp`.

## Tags

filter multiplication, filter addition, pointwise addition, pointwise multiplication,
-/

open function set
open_locale filter pointwise

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

namespace filter

/-! ### `0`/`1` as filters -/

section has_one
variables [has_one α] {f : filter α} {s : set α}

/-- `1 : filter α` is defined as the filter of sets containing `1 : α` in locale `pointwise`. -/
@[to_additive "`0 : filter α` is defined as the filter of sets containing `0 : α` in locale
`pointwise`."]
protected def has_one : has_one (filter α) := ⟨pure 1⟩

localized "attribute [instance] filter.has_one filter.has_zero" in pointwise

@[simp, to_additive] lemma mem_one : s ∈ (1 : filter α) ↔ (1 : α) ∈ s := mem_pure
@[to_additive] lemma one_mem_one : (1 : set α) ∈ (1 : filter α) := mem_pure.2 one_mem_one
@[simp, to_additive] lemma pure_one : pure 1 = (1 : filter α) := rfl
@[simp, to_additive] lemma principal_one : 𝓟 1 = (1 : filter α) := principal_singleton _
@[to_additive] lemma one_ne_bot : (1 : filter α).ne_bot := filter.pure_ne_bot
@[simp, to_additive] protected lemma map_one' (f : α → β) : (1 : filter α).map f = pure (f 1) := rfl
@[simp, to_additive] lemma le_one_iff : f ≤ 1 ↔ (1 : set α) ∈ f := le_pure_iff
@[to_additive] protected lemma ne_bot.le_one_iff (h : f.ne_bot) : f ≤ 1 ↔ f = 1 := h.le_pure_iff
@[simp, to_additive] lemma eventually_one {p : α → Prop} : (∀ᶠ x in 1, p x) ↔ p 1 := eventually_pure
@[simp, to_additive] lemma tendsto_one {a : filter β} {f : β → α} :
   tendsto f a 1 ↔ ∀ᶠ x in a, f x = 1 :=
tendsto_pure

/-- `pure` as a `one_hom`. -/
@[to_additive "`pure` as a `zero_hom`."]
def pure_one_hom : one_hom α (filter α) := ⟨pure, pure_one⟩

@[simp, to_additive] lemma coe_pure_one_hom : (pure_one_hom : α → filter α) = pure := rfl
@[simp, to_additive] lemma pure_one_hom_apply (a : α) : pure_one_hom a = pure a := rfl

variables [has_one β]

@[simp, to_additive]
protected lemma map_one [one_hom_class F α β] (φ : F) : map φ 1 = 1 :=
by rw [filter.map_one', map_one, pure_one]

end has_one

/-! ### Filter negation/inversion -/

section has_inv
variables [has_inv α] {f g : filter α} {s : set α} {a : α}

/-- The inverse of a filter is the pointwise preimage under `⁻¹` of its sets. -/
@[to_additive "The negation of a filter is the pointwise preimage under `-` of its sets."]
instance : has_inv (filter α) := ⟨map has_inv.inv⟩

@[simp, to_additive] protected lemma map_inv : f.map has_inv.inv = f⁻¹ := rfl
@[to_additive] lemma mem_inv : s ∈ f⁻¹ ↔ has_inv.inv ⁻¹' s ∈ f := iff.rfl
@[to_additive] protected lemma inv_le_inv (hf : f ≤ g) : f⁻¹ ≤ g⁻¹ := map_mono hf
@[simp, to_additive] lemma inv_pure : (pure a : filter α)⁻¹ = pure a⁻¹ := rfl
@[simp, to_additive] lemma inv_eq_bot_iff : f⁻¹ = ⊥ ↔ f = ⊥  := map_eq_bot_iff
@[simp, to_additive] lemma ne_bot_inv_iff : f⁻¹.ne_bot ↔ ne_bot f := map_ne_bot_iff _
@[to_additive] lemma ne_bot.inv : f.ne_bot → f⁻¹.ne_bot := λ h, h.map _

end has_inv

section has_involutive_inv
variables [has_involutive_inv α] {f : filter α} {s : set α}

@[to_additive] lemma inv_mem_inv (hs : s ∈ f) : s⁻¹ ∈ f⁻¹ := by rwa [mem_inv, inv_preimage, inv_inv]

/-- Inversion is involutive on `filter α` if it is on `α`. -/
@[to_additive "Negation is involutive on `filter α` if it is on `α`."]
protected def has_involutive_inv : has_involutive_inv (filter α) :=
{ inv_inv := λ f, map_map.trans $ by rw [inv_involutive.comp_self, map_id],
  ..filter.has_inv }

end has_involutive_inv

/-! ### Filter addition/multiplication -/

section has_mul
variables [has_mul α] [has_mul β] {f f₁ f₂ g g₁ g₂ h : filter α} {s t : set α} {a b : α}

/-- The filter `f * g` is generated by `{s * t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
@[to_additive "The filter `f + g` is generated by `{s + t | s ∈ f, t ∈ g}` in locale `pointwise`."]
protected def has_mul : has_mul (filter α) :=
/- This is defeq to `map₂ (*) f g`, but the hypothesis unfolds to `t₁ * t₂ ⊆ s` rather than all the
way to `set.image2 (*) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂ ⊆ s}, ..map₂ (*) f g }⟩

localized "attribute [instance] filter.has_mul filter.has_add" in pointwise

@[simp, to_additive] lemma map₂_mul : map₂ (*) f g = f * g := rfl
@[to_additive] lemma mem_mul : s ∈ f * g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ * t₂ ⊆ s := iff.rfl
@[to_additive] lemma mul_mem_mul : s ∈ f → t ∈ g → s * t ∈ f * g := image2_mem_map₂
@[simp, to_additive] lemma bot_mul : ⊥ * g = ⊥ := map₂_bot_left
@[simp, to_additive] lemma mul_bot : f * ⊥ = ⊥ := map₂_bot_right
@[simp, to_additive] lemma mul_eq_bot_iff : f * g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp, to_additive] lemma mul_ne_bot_iff : (f * g).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
@[to_additive] lemma ne_bot.mul : ne_bot f → ne_bot g → ne_bot (f * g) := ne_bot.map₂
@[to_additive] lemma ne_bot.of_mul_left : (f * g).ne_bot → f.ne_bot := ne_bot.of_map₂_left
@[to_additive] lemma ne_bot.of_mul_right : (f * g).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp, to_additive] lemma pure_mul : pure a * g = g.map ((*) a)  := map₂_pure_left
@[simp, to_additive] lemma mul_pure : f * pure b = f.map (* b)  := map₂_pure_right
@[simp, to_additive] lemma pure_mul_pure : (pure a : filter α) * pure b = pure (a * b) := map₂_pure
@[simp, to_additive] lemma le_mul_iff : h ≤ f * g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s * t ∈ h :=
le_map₂_iff

@[to_additive] instance covariant_mul : covariant_class (filter α) (filter α) (*) (≤) :=
⟨λ f g h, map₂_mono_left⟩

@[to_additive] instance covariant_swap_mul : covariant_class (filter α) (filter α) (swap (*)) (≤) :=
⟨λ f g h, map₂_mono_right⟩

@[to_additive]
protected lemma map_mul [mul_hom_class F α β] (m : F) : (f₁ * f₂).map m = f₁.map m * f₂.map m :=
map_map₂_distrib $ map_mul m

/-- `pure` operation as a `mul_hom`. -/
@[to_additive "The singleton operation as an `add_hom`."]
def pure_mul_hom : α →ₙ* filter α := ⟨pure, λ a b, pure_mul_pure.symm⟩

@[simp, to_additive] lemma coe_pure_mul_hom : (pure_mul_hom : α → filter α) = pure := rfl
@[simp, to_additive] lemma pure_mul_hom_apply (a : α) : pure_mul_hom a = pure a := rfl

end has_mul

/-! ### Filter subtraction/division -/

section div
variables [has_div α] {f f₁ f₂ g g₁ g₂ h : filter α} {s t : set α} {a b : α}

/-- The filter `f / g` is generated by `{s / t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
@[to_additive "The filter `f - g` is generated by `{s - t | s ∈ f, t ∈ g}` in locale `pointwise`."]
protected def has_div : has_div (filter α) :=
/- This is defeq to `map₂ (/) f g`, but the hypothesis unfolds to `t₁ / t₂ ⊆ s` rather than all the
way to `set.image2 (/) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ / t₂ ⊆ s}, ..map₂ (/) f g }⟩

localized "attribute [instance] filter.has_div filter.has_sub" in pointwise

@[simp, to_additive] lemma map₂_div : map₂ (/) f g = f / g := rfl
@[to_additive] lemma mem_div : s ∈ f / g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ / t₂ ⊆ s := iff.rfl
@[to_additive] lemma div_mem_div : s ∈ f → t ∈ g → s / t ∈ f / g := image2_mem_map₂
@[simp, to_additive] lemma bot_div : ⊥ / g = ⊥ := map₂_bot_left
@[simp, to_additive] lemma div_bot : f / ⊥ = ⊥ := map₂_bot_right
@[simp, to_additive] lemma div_eq_bot_iff : f / g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp, to_additive] lemma div_ne_bot_iff : (f / g).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
@[to_additive] lemma ne_bot.div : ne_bot f → ne_bot g → ne_bot (f / g) := ne_bot.map₂
@[to_additive] lemma ne_bot.of_div_left : (f / g).ne_bot → f.ne_bot := ne_bot.of_map₂_left
@[to_additive] lemma ne_bot.of_div_right : (f / g).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp, to_additive] lemma pure_div : pure a / g = g.map ((/) a)  := map₂_pure_left
@[simp, to_additive] lemma div_pure : f / pure b = f.map (/ b)  := map₂_pure_right
@[simp, to_additive] lemma pure_div_pure : (pure a : filter α) / pure b = pure (a / b) := map₂_pure
@[to_additive] protected lemma div_le_div : f₁ ≤ f₂ → g₁ ≤ g₂ → f₁ / g₁ ≤ f₂ / g₂ := map₂_mono
@[to_additive] protected lemma div_le_div_left : g₁ ≤ g₂ → f / g₁ ≤ f / g₂ := map₂_mono_left
@[to_additive] protected lemma div_le_div_right : f₁ ≤ f₂ → f₁ / g ≤ f₂ / g := map₂_mono_right
@[simp, to_additive] protected lemma le_div_iff :
  h ≤ f / g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s / t ∈ h :=
le_map₂_iff

@[to_additive] instance covariant_div : covariant_class (filter α) (filter α) (/) (≤) :=
⟨λ f g h, map₂_mono_left⟩

@[to_additive] instance covariant_swap_div : covariant_class (filter α) (filter α) (swap (/)) (≤) :=
⟨λ f g h, map₂_mono_right⟩

end div

open_locale pointwise

/-- Repeated pointwise addition (not the same as pointwise repeated addition!) of a `filter`. See
Note [pointwise nat action].-/
protected def has_nsmul [has_zero α] [has_add α] : has_scalar ℕ (filter α) := ⟨nsmul_rec⟩

/-- Repeated pointwise multiplication (not the same as pointwise repeated multiplication!) of a
`filter`. See Note [pointwise nat action]. -/
@[to_additive]
protected def has_npow [has_one α] [has_mul α] : has_pow (filter α) ℕ := ⟨λ s n, npow_rec n s⟩

/-- Repeated pointwise addition/subtraction (not the same as pointwise repeated
addition/subtraction!) of a `filter`. See Note [pointwise nat action]. -/
protected def has_zsmul [has_zero α] [has_add α] [has_neg α] : has_scalar ℤ (filter α) :=
⟨zsmul_rec⟩

/-- Repeated pointwise multiplication/division (not the same as pointwise repeated
multiplication/division!) of a `filter`. See Note [pointwise nat action]. -/
@[to_additive] protected def has_zpow [has_one α] [has_mul α] [has_inv α] : has_pow (filter α) ℤ :=
⟨λ s n, zpow_rec n s⟩

localized "attribute [instance] filter.has_nsmul filter.has_npow filter.has_zsmul filter.has_zpow"
  in pointwise

/-- `filter α` is a `semigroup` under pointwise operations if `α` is.-/
@[to_additive "`filter α` is an `add_semigroup` under pointwise operations if `α` is."]
protected def semigroup [semigroup α] : semigroup (filter α) :=
{ mul := (*),
  mul_assoc := λ f g h, map₂_assoc mul_assoc }

/-- `filter α` is a `comm_semigroup` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_comm_semigroup` under pointwise operations if `α` is."]
protected def comm_semigroup [comm_semigroup α] : comm_semigroup (filter α) :=
{ mul_comm := λ f g, map₂_comm mul_comm,
  ..filter.semigroup }

section mul_one_class
variables [mul_one_class α] [mul_one_class β]

/-- `filter α` is a `mul_one_class` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_zero_class` under pointwise operations if `α` is."]
protected def mul_one_class : mul_one_class (filter α) :=
{ one := 1,
  mul := (*),
  one_mul := λ f, by simp only [←pure_one, ←map₂_mul, map₂_pure_left, one_mul, map_id'],
  mul_one := λ f, by simp only [←pure_one, ←map₂_mul, map₂_pure_right, mul_one, map_id'] }

localized "attribute [instance] filter.semigroup filter.add_semigroup filter.comm_semigroup
  filter.add_comm_semigroup filter.mul_one_class filter.add_zero_class" in pointwise

/-- If `φ : α →* β` then `map_monoid_hom φ` is the monoid homomorphism
`filter α →* filter β` induced by `map φ`. -/
@[to_additive "If `φ : α →+ β` then `map_add_monoid_hom φ` is the monoid homomorphism
`filter α →+ filter β` induced by `map φ`."]
def map_monoid_hom [monoid_hom_class F α β] (φ : F) : filter α →* filter β :=
{ to_fun := map φ,
  map_one' := filter.map_one φ,
  map_mul' := λ _ _, filter.map_mul φ }

-- The other direction does not hold in general
@[to_additive]
lemma comap_mul_comap_le [mul_hom_class F α β] (m : F) {f g : filter β} :
  f.comap m * g.comap m ≤ (f * g).comap m  :=
λ s ⟨t, ⟨t₁, t₂, ht₁, ht₂, t₁t₂⟩, mt⟩,
  ⟨m ⁻¹' t₁, m ⁻¹' t₂, ⟨t₁, ht₁, subset.rfl⟩, ⟨t₂, ht₂, subset.rfl⟩,
    (preimage_mul_preimage_subset _).trans $ (preimage_mono t₁t₂).trans mt⟩

@[to_additive]
lemma tendsto.mul_mul [mul_hom_class F α β] (m : F) {f₁ g₁ : filter α} {f₂ g₂ : filter β} :
  tendsto m f₁ f₂ → tendsto m g₁ g₂ → tendsto m (f₁ * g₁) (f₂ * g₂) :=
λ hf hg, (filter.map_mul m).trans_le $ mul_le_mul' hf hg

/-- `pure` as a `monoid_hom`. -/
@[to_additive "`pure` as an `add_monoid_hom`."]
def pure_monoid_hom : α →* filter α := { ..pure_mul_hom, ..pure_one_hom }

@[simp, to_additive] lemma coe_pure_monoid_hom : (pure_monoid_hom : α → filter α) = pure := rfl
@[simp, to_additive] lemma pure_monoid_hom_apply (a : α) : pure_monoid_hom a = pure a := rfl

end mul_one_class

section monoid
variables [monoid α] {f g : filter α} {s : set α} {a : α} {m n : ℕ}

/-- `filter α` is a `monoid` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_monoid` under pointwise operations if `α` is."]
protected def monoid : monoid (filter α) :=
{ ..filter.mul_one_class, ..filter.semigroup, ..filter.has_npow }

localized "attribute [instance] filter.monoid filter.add_monoid" in pointwise

@[to_additive] lemma pow_mem_pow (hs : s ∈ f) : ∀ n : ℕ, s ^ n ∈ f ^ n
| 0 := by { rw pow_zero, exact one_mem_one }
| (n + 1) := by { rw pow_succ, exact mul_mem_mul hs (pow_mem_pow _) }

@[simp, to_additive nsmul_bot] lemma bot_pow {n : ℕ} (hn : n ≠ 0) : (⊥  : filter α) ^ n = ⊥ :=
by rw [←tsub_add_cancel_of_le (nat.succ_le_of_lt $ nat.pos_of_ne_zero hn), pow_succ, bot_mul]

@[to_additive] lemma mul_top_of_one_le (hf : 1 ≤ f) : f * ⊤ = ⊤ :=
begin
  refine top_le_iff.1 (λ s, _),
  simp only [mem_mul, mem_top, exists_and_distrib_left, exists_eq_left],
  rintro ⟨t, ht, hs⟩,
  rwa [mul_univ_of_one_mem (mem_one.1 $ hf ht), univ_subset_iff] at hs,
end

@[to_additive] lemma top_mul_of_one_le (hf : 1 ≤ f) : ⊤ * f = ⊤ :=
begin
  refine top_le_iff.1 (λ s, _),
  simp only [mem_mul, mem_top, exists_and_distrib_left, exists_eq_left],
  rintro ⟨t, ht, hs⟩,
  rwa [univ_mul_of_one_mem (mem_one.1 $ hf ht), univ_subset_iff] at hs,
end

@[simp, to_additive] lemma top_mul_top : (⊤ : filter α) * ⊤ = ⊤ := mul_top_of_one_le le_top

--TODO: `to_additive` trips up on the `1 : ℕ` used in the pattern-matching.
lemma nsmul_top {α : Type*} [add_monoid α] : ∀ {n : ℕ}, n ≠ 0 → n • (⊤ : filter α) = ⊤
| 0 := λ h, (h rfl).elim
| 1 := λ _, one_nsmul _
| (n + 2) := λ _, by { rw [succ_nsmul, nsmul_top n.succ_ne_zero, top_add_top] }

@[to_additive nsmul_top] lemma top_pow : ∀ {n : ℕ}, n ≠ 0 → (⊤ : filter α) ^ n = ⊤
| 0 := λ h, (h rfl).elim
| 1 := λ _, pow_one _
| (n + 2) := λ _, by { rw [pow_succ, top_pow n.succ_ne_zero, top_mul_top] }

@[to_additive] protected lemma _root_.is_unit.filter : is_unit a → is_unit (pure a : filter α) :=
is_unit.map (pure_monoid_hom : α →* filter α)

end monoid

/-- `filter α` is a `comm_monoid` under pointwise operations if `α` is. -/
@[to_additive "`filter α` is an `add_comm_monoid` under pointwise operations if `α` is."]
protected def comm_monoid [comm_monoid α] : comm_monoid (filter α) :=
{ ..filter.mul_one_class, ..filter.comm_semigroup }

open_locale pointwise

section division_monoid
variables [division_monoid α] {f g : filter α}

@[to_additive]
protected lemma mul_eq_one_iff : f * g = 1 ↔ ∃ a b, f = pure a ∧ g = pure b ∧ a * b = 1 :=
begin
  refine ⟨λ hfg, _, _⟩,
  { obtain ⟨t₁, t₂, h₁, h₂, h⟩ : (1 : set α) ∈ f * g := hfg.symm.subst one_mem_one,
    have hfg : (f * g).ne_bot := hfg.symm.subst one_ne_bot,
    rw [(hfg.nonempty_of_mem $ mul_mem_mul h₁ h₂).subset_one_iff, set.mul_eq_one_iff] at h,
    obtain ⟨a, b, rfl, rfl, h⟩ := h,
    refine ⟨a, b, _, _, h⟩,
    { rwa [←hfg.of_mul_left.le_pure_iff, le_pure_iff] },
    { rwa [←hfg.of_mul_right.le_pure_iff, le_pure_iff] } },
  { rintro ⟨a, b, rfl, rfl, h⟩,
    rw [pure_mul_pure, h, pure_one] }
end

/-- `filter α` is a division monoid under pointwise operations if `α` is. -/
@[to_additive subtraction_monoid "`filter α` is a subtraction monoid under pointwise
operations if `α` is."]
protected def division_monoid : division_monoid (filter α) :=
{ mul_inv_rev := λ s t, map_map₂_antidistrib mul_inv_rev,
  inv_eq_of_mul := λ s t h, begin
    obtain ⟨a, b, rfl, rfl, hab⟩ := filter.mul_eq_one_iff.1 h,
    rw [inv_pure, inv_eq_of_mul_eq_one_right hab],
  end,
  div_eq_mul_inv := λ f g, map_map₂_distrib_right div_eq_mul_inv,
  ..filter.monoid, ..filter.has_involutive_inv, ..filter.has_div, ..filter.has_zpow }

@[to_additive] lemma is_unit_iff : is_unit f ↔ ∃ a, f = pure a ∧ is_unit a :=
begin
  split,
  { rintro ⟨u, rfl⟩,
    obtain ⟨a, b, ha, hb, h⟩ := filter.mul_eq_one_iff.1 u.mul_inv,
    refine ⟨a, ha, ⟨a, b, h, pure_injective _⟩, rfl⟩,
    rw [←pure_mul_pure, ←ha, ←hb],
    exact u.inv_mul },
  { rintro ⟨a, rfl, ha⟩,
    exact ha.filter }
end

end division_monoid

/-- `filter α` is a commutative division monoid under pointwise operations if `α` is. -/
@[to_additive subtraction_comm_monoid "`filter α` is a commutative subtraction monoid under
pointwise operations if `α` is."]
protected def division_comm_monoid [division_comm_monoid α] : division_comm_monoid (filter α) :=
{ ..filter.division_monoid, ..filter.comm_semigroup }

/-- `filter α` has distributive negation if `α` has. -/
protected def has_distrib_neg [has_mul α] [has_distrib_neg α] : has_distrib_neg (filter α) :=
{ neg_mul := λ _ _, map₂_map_left_comm neg_mul,
  mul_neg := λ _ _, map_map₂_right_comm mul_neg,
  ..filter.has_involutive_neg }

localized "attribute [instance] filter.comm_monoid filter.add_comm_monoid filter.division_monoid
  filter.subtraction_monoid filter.division_comm_monoid filter.subtraction_comm_monoid
  filter.has_distrib_neg" in pointwise

section distrib
variables [distrib α] {f g h : filter α}

/-!
Note that `filter α` is not a `distrib` because `f * g + f * h` has cross terms that `f * (g + h)`
lacks.
-/

lemma mul_add_subset : f * (g + h) ≤ f * g + f * h := map₂_distrib_le_left mul_add
lemma add_mul_subset : (f + g) * h ≤ f * h + g * h := map₂_distrib_le_right add_mul

end distrib

section mul_zero_class
variables [mul_zero_class α] {f g : filter α}

/-! Note that `filter` is not a `mul_zero_class` because `0 * ⊥ ≠ 0`. -/

lemma ne_bot.mul_zero_nonneg (hf : f.ne_bot) : 0 ≤ f * 0 :=
le_mul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨a, ha⟩ := hf.nonempty_of_mem h₁ in ⟨_, _, ha, h₂, mul_zero _⟩

lemma ne_bot.zero_mul_nonneg (hg : g.ne_bot) : 0 ≤ 0 * g :=
le_mul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨b, hb⟩ := hg.nonempty_of_mem h₂ in ⟨_, _, h₁, hb, zero_mul _⟩

end mul_zero_class

section group
variables [group α] [division_monoid β] [monoid_hom_class F α β] (m : F) {f g f₁ g₁ : filter α}
  {f₂ g₂ : filter β}

/-! Note that `filter α` is not a group because `f / f ≠ 1` in general -/

@[simp, to_additive] protected lemma one_le_div_iff : 1 ≤ f / g ↔ ¬ disjoint f g :=
begin
  refine ⟨λ h hfg, _, _⟩,
  { obtain ⟨s, hs, t, ht, hst⟩ := hfg (mem_bot : ∅ ∈ ⊥),
    exact set.one_mem_div_iff.1 (h $ div_mem_div hs ht) (disjoint_iff.2 hst.symm) },
  { rintro h s ⟨t₁, t₂, h₁, h₂, hs⟩,
    exact hs (set.one_mem_div_iff.2 $ λ ht, h $ disjoint_of_disjoint_of_mem ht h₁ h₂) }
end

@[to_additive] lemma not_one_le_div_iff : ¬ 1 ≤ f / g ↔ disjoint f g :=
filter.one_le_div_iff.not_left

@[to_additive] lemma ne_bot.one_le_div (h : f.ne_bot) : 1 ≤ f / f :=
begin
  rintro s ⟨t₁, t₂, h₁, h₂, hs⟩,
  obtain ⟨a, ha₁, ha₂⟩ := set.not_disjoint_iff.1 (h.not_disjoint h₁ h₂),
  rw [mem_one, ←div_self' a],
  exact hs (set.div_mem_div ha₁ ha₂),
end

@[to_additive] lemma is_unit_pure (a : α) : is_unit (pure a : filter α) := (group.is_unit a).filter

@[simp] lemma is_unit_iff_singleton : is_unit f ↔ ∃ a, f = pure a :=
by simp only [is_unit_iff, group.is_unit, and_true]

include β

@[to_additive] lemma map_inv' : f⁻¹.map m = (f.map m)⁻¹ := map_comm (funext $ map_inv m) _

@[to_additive] lemma tendsto.inv_inv : tendsto m f₁ f₂ → tendsto m f₁⁻¹ f₂⁻¹ :=
λ hf, (filter.map_inv' m).trans_le $ filter.inv_le_inv hf

@[to_additive] protected lemma map_div : (f / g).map m = f.map m / g.map m :=
map_map₂_distrib $ map_div m

@[to_additive]
lemma tendsto.div_div : tendsto m f₁ f₂ → tendsto m g₁ g₂ → tendsto m (f₁ / g₁) (f₂ / g₂) :=
λ hf hg, (filter.map_div m).trans_le $ filter.div_le_div hf hg

end group

open_locale pointwise

section group_with_zero
variables [group_with_zero α] {f g : filter α}

lemma ne_bot.div_zero_nonneg (hf : f.ne_bot) : 0 ≤ f / 0 :=
filter.le_div_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨a, ha⟩ := hf.nonempty_of_mem h₁ in
  ⟨_, _, ha, h₂, div_zero _⟩

lemma ne_bot.zero_div_nonneg (hg : g.ne_bot) : 0 ≤ 0 / g :=
filter.le_div_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨b, hb⟩ := hg.nonempty_of_mem h₂ in
  ⟨_, _, h₁, hb, zero_div _⟩

end group_with_zero

/-! ### Scalar addition/multiplication of filters -/

section smul
variables [has_scalar α β] {f f₁ f₂ : filter α} {g g₁ g₂ h : filter β} {s : set α} {t : set β}
  {a : α} {b : β}

/-- The filter `f • g` is generated by `{s • t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
@[to_additive filter.has_vadd
"The filter `f +ᵥ g` is generated by `{s +ᵥ t | s ∈ f, t ∈ g}` in locale `pointwise`."]
protected def has_scalar : has_scalar (filter α) (filter β) :=
/- This is defeq to `map₂ (•) f g`, but the hypothesis unfolds to `t₁ • t₂ ⊆ s` rather than all the
way to `set.image2 (•) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ • t₂ ⊆ s}, ..map₂ (•) f g }⟩

localized "attribute [instance] filter.has_scalar filter.has_vadd" in pointwise

@[simp, to_additive] lemma map₂_smul : map₂ (•) f g = f • g := rfl
@[to_additive] lemma mem_smul : t ∈ f • g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ • t₂ ⊆ t := iff.rfl
@[to_additive] lemma smul_mem_smul : s ∈ f → t ∈ g → s • t ∈ f • g :=  image2_mem_map₂
@[simp, to_additive] lemma bot_smul : (⊥ : filter α) • g = ⊥ := map₂_bot_left
@[simp, to_additive] lemma smul_bot : f • (⊥ : filter β) = ⊥ := map₂_bot_right
@[simp, to_additive] lemma smul_eq_bot_iff : f • g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp, to_additive] lemma smul_ne_bot_iff : (f • g).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
@[to_additive] lemma ne_bot.smul : ne_bot f → ne_bot g → ne_bot (f • g) := ne_bot.map₂
@[to_additive] lemma ne_bot.of_smul_left : (f • g).ne_bot → f.ne_bot := ne_bot.of_map₂_left
@[to_additive] lemma ne_bot.of_smul_right : (f • g).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp, to_additive] lemma pure_smul : (pure a : filter α) • g = g.map ((•) a)  := map₂_pure_left
@[simp, to_additive] lemma smul_pure : f • pure b = f.map (• b)  := map₂_pure_right
@[simp, to_additive] lemma pure_smul_pure :
  (pure a : filter α) • (pure b : filter β) = pure (a • b) := map₂_pure
@[to_additive] lemma smul_le_smul : f₁ ≤ f₂ → g₁ ≤ g₂ → f₁ • g₁ ≤ f₂ • g₂ := map₂_mono
@[to_additive] lemma smul_le_smul_left : g₁ ≤ g₂ → f • g₁ ≤ f • g₂ := map₂_mono_left
@[to_additive] lemma smul_le_smul_right : f₁ ≤ f₂ → f₁ • g ≤ f₂ • g := map₂_mono_right
@[simp, to_additive] lemma le_smul_iff : h ≤ f • g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s • t ∈ h :=
le_map₂_iff

@[to_additive] instance covariant_smul : covariant_class (filter α) (filter β) (•) (≤) :=
⟨λ f g h, map₂_mono_left⟩

end smul

/-! ### Scalar subtraction of filters -/

section vsub
variables [has_vsub α β] {f f₁ f₂ g g₁ g₂ : filter β} {h : filter α} {s t : set β} {a b : β}
include α

/-- The filter `f -ᵥ g` is generated by `{s -ᵥ t | s ∈ f, t ∈ g}` in locale `pointwise`. -/
protected def has_vsub : has_vsub (filter α) (filter β) :=
/- This is defeq to `map₂ (-ᵥ) f g`, but the hypothesis unfolds to `t₁ -ᵥ t₂ ⊆ s` rather than all
the way to `set.image2 (-ᵥ) t₁ t₂ ⊆ s`. -/
⟨λ f g, { sets := {s | ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ -ᵥ t₂ ⊆ s}, ..map₂ (-ᵥ) f g }⟩

localized "attribute [instance] filter.has_vsub" in pointwise

@[simp] lemma map₂_vsub : map₂ (-ᵥ) f g = f -ᵥ g := rfl
lemma mem_vsub {s : set α} : s ∈ f -ᵥ g ↔ ∃ t₁ t₂, t₁ ∈ f ∧ t₂ ∈ g ∧ t₁ -ᵥ t₂ ⊆ s := iff.rfl
lemma vsub_mem_vsub : s ∈ f → t ∈ g → s -ᵥ t ∈ f -ᵥ g :=  image2_mem_map₂
@[simp] lemma bot_vsub : (⊥ : filter β) -ᵥ g = ⊥ := map₂_bot_left
@[simp] lemma vsub_bot : f -ᵥ (⊥ : filter β) = ⊥ := map₂_bot_right
@[simp] lemma vsub_eq_bot_iff : f -ᵥ g = ⊥ ↔ f = ⊥ ∨ g = ⊥ := map₂_eq_bot_iff
@[simp] lemma vsub_ne_bot_iff : (f -ᵥ g : filter α).ne_bot ↔ f.ne_bot ∧ g.ne_bot := map₂_ne_bot_iff
lemma ne_bot.vsub : ne_bot f → ne_bot g → ne_bot (f -ᵥ g) := ne_bot.map₂
lemma ne_bot.of_vsub_left : (f -ᵥ g : filter α).ne_bot → f.ne_bot := ne_bot.of_map₂_left
lemma ne_bot.of_vsub_right : (f -ᵥ g : filter α).ne_bot → g.ne_bot := ne_bot.of_map₂_right
@[simp] lemma pure_vsub : (pure a : filter β) -ᵥ g = g.map ((-ᵥ) a)  := map₂_pure_left
@[simp] lemma vsub_pure : f -ᵥ pure b = f.map (-ᵥ b)  := map₂_pure_right
@[simp] lemma pure_vsub_pure : (pure a : filter β) -ᵥ pure b = (pure (a -ᵥ b) : filter α) :=
map₂_pure
lemma vsub_le_vsub : f₁ ≤ f₂ → g₁ ≤ g₂ → f₁ -ᵥ g₁ ≤ f₂ -ᵥ g₂ := map₂_mono
lemma vsub_le_vsub_left : g₁ ≤ g₂ → f -ᵥ g₁ ≤ f -ᵥ g₂ := map₂_mono_left
lemma vsub_le_vsub_right : f₁ ≤ f₂ → f₁ -ᵥ g ≤ f₂ -ᵥ g := map₂_mono_right
@[simp] lemma le_vsub_iff : h ≤ f -ᵥ g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → s -ᵥ t ∈ h := le_map₂_iff

end vsub

/-! ### Translation/scaling of filters -/

section smul
variables [has_scalar α β] {f f₁ f₂ : filter β} {s : set β} {a : α}

/-- `a • f` is the map of `f` under `a •` in locale `pointwise`. -/
@[to_additive filter.has_vadd_filter
"`a +ᵥ f` is the map of `f` under `a +ᵥ` in locale `pointwise`."]
protected def has_scalar_filter : has_scalar α (filter β) := ⟨λ a, map ((•) a)⟩

localized "attribute [instance] filter.has_scalar_filter filter.has_vadd_filter" in pointwise

@[simp, to_additive] lemma map_smul : map (λ b, a • b) f = a • f := rfl
@[to_additive] lemma mem_smul_filter : s ∈ a • f ↔ (•) a ⁻¹' s ∈ f := iff.rfl

@[to_additive] lemma smul_set_mem_smul_filter : s ∈ f → a • s ∈ a • f := image_mem_map
@[simp, to_additive] lemma smul_filter_bot : a • (⊥ : filter β) = ⊥ := map_bot
@[simp, to_additive] lemma smul_filter_eq_bot_iff : a • f = ⊥ ↔ f = ⊥ := map_eq_bot_iff
@[simp, to_additive] lemma smul_filter_ne_bot_iff : (a • f).ne_bot ↔ f.ne_bot := map_ne_bot_iff _
@[to_additive] lemma ne_bot.smul_filter : f.ne_bot → (a • f).ne_bot := λ h, h.map _
@[to_additive] lemma ne_bot.of_smul_filter : (a • f).ne_bot → f.ne_bot := ne_bot.of_map
@[to_additive] lemma smul_filter_le_smul_filter (hf : f₁ ≤ f₂) : a • f₁ ≤ a • f₂ :=
map_mono hf

@[to_additive] instance covariant_smul_filter : covariant_class α (filter β) (•) (≤) :=
⟨λ f, map_mono⟩

end smul

open_locale pointwise

@[to_additive]
instance smul_comm_class_filter [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class α (filter β) (filter γ) :=
⟨λ a f g, map_map₂_distrib_right $ smul_comm a⟩

@[to_additive]
instance smul_comm_class_filter' [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class (filter α) β (filter γ) :=
by haveI := smul_comm_class.symm α β γ; exact smul_comm_class.symm _ _ _

@[to_additive]
instance smul_comm_class [has_scalar α γ] [has_scalar β γ] [smul_comm_class α β γ] :
  smul_comm_class (filter α) (filter β) (filter γ) :=
⟨λ f g h, map₂_left_comm smul_comm⟩

instance is_scalar_tower [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α β (filter γ) :=
⟨λ a b f, by simp only [←map_smul, map_map, smul_assoc]⟩

instance is_scalar_tower' [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower α (filter β) (filter γ) :=
⟨λ a f g, by { refine (map_map₂_distrib_left $ λ _ _, _).symm, exact (smul_assoc a _ _).symm }⟩

instance is_scalar_tower'' [has_scalar α β] [has_scalar α γ] [has_scalar β γ]
  [is_scalar_tower α β γ] :
  is_scalar_tower (filter α) (filter β) (filter γ) :=
⟨λ f g h, map₂_assoc smul_assoc⟩

instance is_central_scalar [has_scalar α β] [has_scalar αᵐᵒᵖ β] [is_central_scalar α β] :
  is_central_scalar α (filter β) :=
⟨λ a f, congr_arg (λ m, map m f) $ by exact funext (λ _, op_smul_eq_smul _ _)⟩

/-- A multiplicative action of a monoid `α` on a type `β` gives a multiplicative action of
`filter α` on `filter β`. -/
@[to_additive "An additive action of an additive monoid `α` on a type `β` gives an additive action
of `filter α` on `filter β`"]
protected def mul_action [monoid α] [mul_action α β] : mul_action (filter α) (filter β) :=
{ one_smul := λ f, map₂_pure_left.trans $ by simp_rw [one_smul, map_id'],
  mul_smul := λ f g h, map₂_assoc mul_smul }

/-- A multiplicative action of a monoid on a type `β` gives a multiplicative action on `filter β`.
-/
@[to_additive "An additive action of an additive monoid on a type `β` gives an additive action on
`filter β`."]
protected def mul_action_filter [monoid α] [mul_action α β] : mul_action α (filter β) :=
{ mul_smul := λ a b f, by simp only [←map_smul, map_map, function.comp, ←mul_smul],
  one_smul := λ f, by simp only [←map_smul, one_smul, map_id'] }

localized "attribute [instance] filter.mul_action filter.add_action filter.mul_action_filter
  filter.add_action_filter" in pointwise

/-- A distributive multiplicative action of a monoid on an additive monoid `β` gives a distributive
multiplicative action on `filter β`. -/
protected def distrib_mul_action_filter [monoid α] [add_monoid β] [distrib_mul_action α β] :
  distrib_mul_action α (filter β) :=
{ smul_add := λ _ _ _, map_map₂_distrib $ smul_add _,
  smul_zero := λ _, (map_pure _ _).trans $ by rw [smul_zero, pure_zero] }

/-- A multiplicative action of a monoid on a monoid `β` gives a multiplicative action on `set β`. -/
protected def mul_distrib_mul_action_filter [monoid α] [monoid β] [mul_distrib_mul_action α β] :
  mul_distrib_mul_action α (set β) :=
{ smul_mul := λ _ _ _, image_image2_distrib $ smul_mul' _,
  smul_one := λ _, image_singleton.trans $ by rw [smul_one, singleton_one] }

localized "attribute [instance] filter.distrib_mul_action_filter
  filter.mul_distrib_mul_action_filter" in pointwise

section smul_with_zero
variables [has_zero α] [has_zero β] [smul_with_zero α β] {f : filter α} {g : filter β}

/-!
Note that we have neither `smul_with_zero α (filter β)` nor `smul_with_zero (filter α) (filter β)`
because `0 * ⊥ ≠ 0`.
-/

lemma ne_bot.smul_zero_nonneg (hf : f.ne_bot) : 0 ≤ f • (0 : filter β) :=
le_smul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨a, ha⟩ := hf.nonempty_of_mem h₁ in
  ⟨_, _, ha, h₂, smul_zero' _ _⟩

lemma ne_bot.zero_smul_nonneg (hg : g.ne_bot) : 0 ≤ (0 : filter α) • g :=
le_smul_iff.2 $ λ t₁ h₁ t₂ h₂, let ⟨b, hb⟩ := hg.nonempty_of_mem h₂ in ⟨_, _, h₁, hb, zero_smul _ _⟩

lemma zero_smul_filter_nonpos : (0 : α) • g ≤ 0 :=
begin
  refine λ s hs, mem_smul_filter.2 _,
  convert univ_mem,
  refine eq_univ_iff_forall.2 (λ a, _),
  rwa [mem_preimage, zero_smul],
end

lemma zero_smul_filter (hg : g.ne_bot) : (0 : α) • g = 0 :=
zero_smul_filter_nonpos.antisymm $ le_map_iff.2 $ λ s hs, begin
  simp_rw [set.image_eta, zero_smul, (hg.nonempty_of_mem hs).image_const],
  exact zero_mem_zero,
end

end smul_with_zero

end filter


<|start_filename|>src/data/array/lemmas.lean<|end_filename|>
/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import control.traversable.equiv
import data.vector.basic

universes u v w

namespace d_array
variables {n : ℕ} {α : fin n → Type u}

instance [∀ i, inhabited (α i)] : inhabited (d_array n α) :=
⟨⟨default⟩⟩

end d_array

namespace array

instance {n α} [inhabited α] : inhabited (array n α) :=
d_array.inhabited

theorem to_list_of_heq {n₁ n₂ α} {a₁ : array n₁ α} {a₂ : array n₂ α}
  (hn : n₁ = n₂) (ha : a₁ == a₂) : a₁.to_list = a₂.to_list :=
by congr; assumption

/- rev_list -/

section rev_list
variables {n : ℕ} {α : Type u} {a : array n α}

theorem rev_list_reverse_aux : ∀ i (h : i ≤ n) (t : list α),
  (a.iterate_aux (λ _, (::)) i h []).reverse_core t = a.rev_iterate_aux (λ _, (::)) i h t
| 0     h t := rfl
| (i+1) h t := rev_list_reverse_aux i _ _

@[simp] theorem rev_list_reverse : a.rev_list.reverse = a.to_list :=
rev_list_reverse_aux _ _ _

@[simp] theorem to_list_reverse : a.to_list.reverse = a.rev_list :=
by rw [←rev_list_reverse, list.reverse_reverse]

end rev_list

/- mem -/

section mem
variables {n : ℕ} {α : Type u} {v : α} {a : array n α}

theorem mem.def : v ∈ a ↔ ∃ i, a.read i = v :=
iff.rfl

theorem mem_rev_list_aux : ∀ {i} (h : i ≤ n),
  (∃ (j : fin n), (j : ℕ) < i ∧ read a j = v) ↔ v ∈ a.iterate_aux (λ _, (::)) i h []
| 0     _ := ⟨λ ⟨i, n, _⟩, absurd n i.val.not_lt_zero, false.elim⟩
| (i+1) h := let IH := mem_rev_list_aux (le_of_lt h) in
  ⟨λ ⟨j, ji1, e⟩, or.elim (lt_or_eq_of_le $ nat.le_of_succ_le_succ ji1)
    (λ ji, list.mem_cons_of_mem _ $ IH.1 ⟨j, ji, e⟩)
    (λ je, by simp [d_array.iterate_aux]; apply or.inl; unfold read at e;
          have H : j = ⟨i, h⟩ := fin.eq_of_veq je; rwa [←H, e]),
  λ m, begin
    simp [d_array.iterate_aux, list.mem] at m,
    cases m with e m',
    exact ⟨⟨i, h⟩, nat.lt_succ_self _, eq.symm e⟩,
    exact let ⟨j, ji, e⟩ := IH.2 m' in
    ⟨j, nat.le_succ_of_le ji, e⟩
  end⟩

@[simp] theorem mem_rev_list : v ∈ a.rev_list ↔ v ∈ a :=
iff.symm $ iff.trans
  (exists_congr $ λ j, iff.symm $
    show j.1 < n ∧ read a j = v ↔ read a j = v,
    from and_iff_right j.2)
  (mem_rev_list_aux _)

@[simp] theorem mem_to_list : v ∈ a.to_list ↔ v ∈ a :=
by rw ←rev_list_reverse; exact list.mem_reverse.trans mem_rev_list

end mem

/- foldr -/

section foldr
variables {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : α → β → β} {a : array n α}

theorem rev_list_foldr_aux : ∀ {i} (h : i ≤ n),
  (d_array.iterate_aux a (λ _, (::)) i h []).foldr f b = d_array.iterate_aux a (λ _, f) i h b
| 0     h := rfl
| (j+1) h := congr_arg (f (read a ⟨j, h⟩)) (rev_list_foldr_aux _)

theorem rev_list_foldr : a.rev_list.foldr f b = a.foldl b f :=
rev_list_foldr_aux _

end foldr

/- foldl -/

section foldl
variables {n : ℕ} {α : Type u} {β : Type w} {b : β} {f : β → α → β} {a : array n α}

theorem to_list_foldl : a.to_list.foldl f b = a.foldl b (function.swap f) :=
by rw [←rev_list_reverse, list.foldl_reverse, rev_list_foldr]

end foldl

/- length -/

section length
variables {n : ℕ} {α : Type u}

theorem rev_list_length_aux (a : array n α) (i h) :
  (a.iterate_aux (λ _, (::)) i h []).length = i :=
by induction i; simp [*, d_array.iterate_aux]

@[simp] theorem rev_list_length (a : array n α) : a.rev_list.length = n :=
rev_list_length_aux a _ _

@[simp] theorem to_list_length (a : array n α) : a.to_list.length = n :=
by rw[←rev_list_reverse, list.length_reverse, rev_list_length]

end length

/- nth -/

section nth
variables {n : ℕ} {α : Type u} {a : array n α}

theorem to_list_nth_le_aux (i : ℕ) (ih : i < n) : ∀ j {jh t h'},
  (∀ k tl, j + k = i → list.nth_le t k tl = a.read ⟨i, ih⟩) →
  (a.rev_iterate_aux (λ _, (::)) j jh t).nth_le i h' = a.read ⟨i, ih⟩
| 0     _  _ _  al := al i _ $ zero_add _
| (j+1) jh t h' al := to_list_nth_le_aux j $ λ k tl hjk,
  show list.nth_le (a.read ⟨j, jh⟩ :: t) k tl = a.read ⟨i, ih⟩, from
  match k, hjk, tl with
  | 0,    e, tl := match i, e, ih with ._, rfl, _ := rfl end
  | k'+1, _, tl := by simp[list.nth_le]; exact al _ _ (by simp [add_comm, add_assoc, *]; cc)
  end

theorem to_list_nth_le (i : ℕ) (h h') : list.nth_le a.to_list i h' = a.read ⟨i, h⟩ :=
to_list_nth_le_aux _ _ _ (λ k tl, absurd tl k.not_lt_zero)

@[simp] theorem to_list_nth_le' (a : array n α) (i : fin n) (h') :
  list.nth_le a.to_list i h' = a.read i :=
by cases i; apply to_list_nth_le

theorem to_list_nth {i v} : list.nth a.to_list i = some v ↔ ∃ h, a.read ⟨i, h⟩ = v :=
begin
  rw list.nth_eq_some,
  have ll := to_list_length a,
  split; intro h; cases h with h e; subst v,
  { exact ⟨ll ▸ h, (to_list_nth_le _ _ _).symm⟩ },
  { exact ⟨ll.symm ▸ h, to_list_nth_le _ _ _⟩ }
end

theorem write_to_list {i v} : (a.write i v).to_list = a.to_list.update_nth i v :=
list.ext_le (by simp) $ λ j h₁ h₂, begin
  have h₃ : j < n, {simpa using h₁},
  rw [to_list_nth_le _ h₃],
  refine let ⟨_, e⟩ := list.nth_eq_some.1 _ in e.symm,
  by_cases ij : (i : ℕ) = j,
  { subst j, rw [show (⟨(i : ℕ), h₃⟩ : fin _) = i, from fin.eq_of_veq rfl,
      array.read_write, list.nth_update_nth_of_lt],
    simp [h₃] },
  { rw [list.nth_update_nth_ne _ _ ij, a.read_write_of_ne,
        to_list_nth.2 ⟨h₃, rfl⟩],
    exact fin.ne_of_vne ij }
end

end nth

/- enum -/

section enum
variables {n : ℕ} {α : Type u} {a : array n α}

theorem mem_to_list_enum {i v} : (i, v) ∈ a.to_list.enum ↔ ∃ h, a.read ⟨i, h⟩ = v :=
by simp [list.mem_iff_nth, to_list_nth, and.comm, and.assoc, and.left_comm]

end enum

/- to_array -/

section to_array
variables {n : ℕ} {α : Type u}

@[simp] theorem to_list_to_array (a : array n α) : a.to_list.to_array == a :=
heq_of_heq_of_eq
  (@@eq.drec_on (λ m (e : a.to_list.length = m), (d_array.mk (λ v, a.to_list.nth_le v.1 v.2)) ==
    (@d_array.mk m (λ _, α) $ λ v, a.to_list.nth_le v.1 $ e.symm ▸ v.2)) a.to_list_length heq.rfl) $
  d_array.ext $ λ ⟨i, h⟩, to_list_nth_le i h _

@[simp] theorem to_array_to_list (l : list α) : l.to_array.to_list = l :=
list.ext_le (to_list_length _) $ λ n h1 h2, to_list_nth_le _ h2 _

end to_array

/- push_back -/

section push_back
variables {n : ℕ} {α : Type u} {v : α} {a : array n α}

lemma push_back_rev_list_aux : ∀ i h h',
  d_array.iterate_aux (a.push_back v) (λ _, (::)) i h [] = d_array.iterate_aux a (λ _, (::)) i h' []
| 0 h h' := rfl
| (i+1) h h' := begin
  simp [d_array.iterate_aux],
  refine ⟨_, push_back_rev_list_aux _ _ _⟩,
  dsimp [read, d_array.read, push_back],
  rw [dif_neg], refl,
  exact ne_of_lt h',
end

@[simp] theorem push_back_rev_list : (a.push_back v).rev_list = v :: a.rev_list :=
begin
  unfold push_back rev_list foldl iterate d_array.iterate,
  dsimp [d_array.iterate_aux, read, d_array.read, push_back],
  rw [dif_pos (eq.refl n)],
  apply congr_arg,
  apply push_back_rev_list_aux
end

@[simp] theorem push_back_to_list : (a.push_back v).to_list = a.to_list ++ [v] :=
by rw [←rev_list_reverse, ←rev_list_reverse, push_back_rev_list, list.reverse_cons]

@[simp] lemma read_push_back_left (i : fin n) : (a.push_back v).read i.cast_succ = a.read i :=
begin
  cases i with i hi,
  have : ¬ i = n := ne_of_lt hi,
  simp [push_back, this, fin.cast_succ, fin.cast_add, fin.cast_le, fin.cast_lt, read, d_array.read]
end

@[simp] lemma read_push_back_right : (a.push_back v).read (fin.last _) = v :=
begin
  cases hn : fin.last n with k hk,
  have : k = n := by simpa [fin.eq_iff_veq ] using hn.symm,
  simp [push_back, this, fin.cast_succ, fin.cast_add, fin.cast_le, fin.cast_lt, read, d_array.read]
end

end push_back

/- foreach -/

section foreach
variables {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : fin n → α → β} {a : array n α}

@[simp] theorem read_foreach : (foreach a f).read i = f i (a.read i) :=
rfl

end foreach

/- map -/

section map
variables {n : ℕ} {α : Type u} {β : Type v} {i : fin n} {f : α → β} {a : array n α}

theorem read_map : (a.map f).read i = f (a.read i) :=
read_foreach

end map

/- map₂ -/

section map₂
variables {n : ℕ} {α : Type u} {i : fin n} {f : α → α → α} {a₁ a₂ : array n α}

@[simp] theorem read_map₂ : (map₂ f a₁ a₂).read i = f (a₁.read i) (a₂.read i) :=
read_foreach

end map₂

end array

namespace equiv

/-- The natural equivalence between length-`n` heterogeneous arrays
and dependent functions from `fin n`. -/
def d_array_equiv_fin {n : ℕ} (α : fin n → Type*) : d_array n α ≃ (Π i, α i) :=
⟨d_array.read, d_array.mk, λ ⟨f⟩, rfl, λ f, rfl⟩

/-- The natural equivalence between length-`n` arrays and functions from `fin n`. -/
def array_equiv_fin (n : ℕ) (α : Type*) : array n α ≃ (fin n → α) :=
d_array_equiv_fin _

/-- The natural equivalence between length-`n` vectors and length-`n` arrays. -/
def vector_equiv_array (α : Type*) (n : ℕ) : vector α n ≃ array n α :=
(vector_equiv_fin _ _).trans (array_equiv_fin _ _).symm

end equiv

namespace array
open function
variable {n : ℕ}

instance : traversable (array n) :=
@equiv.traversable (flip vector n) _ (λ α, equiv.vector_equiv_array α n) _

instance : is_lawful_traversable (array n) :=
@equiv.is_lawful_traversable (flip vector n) _ (λ α, equiv.vector_equiv_array α n) _ _

end array


<|start_filename|>src/category_theory/monoidal/braided.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.monoidal.coherence_lemmas
import category_theory.monoidal.natural_transformation
import category_theory.monoidal.discrete

/-!
# Braided and symmetric monoidal categories

The basic definitions of braided monoidal categories, and symmetric monoidal categories,
as well as braided functors.

## Implementation note

We make `braided_monoidal_category` another typeclass, but then have `symmetric_monoidal_category`
extend this. The rationale is that we are not carrying any additional data,
just requiring a property.

## Future work

* Construct the Drinfeld center of a monoidal category as a braided monoidal category.
* Say something about pseudo-natural transformations.

-/

open category_theory

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

namespace category_theory

/--
A braided monoidal category is a monoidal category equipped with a braiding isomorphism
`β_ X Y : X ⊗ Y ≅ Y ⊗ X`
which is natural in both arguments,
and also satisfies the two hexagon identities.
-/
class braided_category (C : Type u) [category.{v} C] [monoidal_category.{v} C] :=
-- braiding natural iso:
(braiding             : Π X Y : C, X ⊗ Y ≅ Y ⊗ X)
(braiding_naturality' : ∀ {X X' Y Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y'),
  (f ⊗ g) ≫ (braiding Y Y').hom = (braiding X X').hom ≫ (g ⊗ f) . obviously)
-- hexagon identities:
(hexagon_forward'     : Π X Y Z : C,
    (α_ X Y Z).hom ≫ (braiding X (Y ⊗ Z)).hom ≫ (α_ Y Z X).hom
  = ((braiding X Y).hom ⊗ (𝟙 Z)) ≫ (α_ Y X Z).hom ≫ ((𝟙 Y) ⊗ (braiding X Z).hom)
  . obviously)
(hexagon_reverse'     : Π X Y Z : C,
    (α_ X Y Z).inv ≫ (braiding (X ⊗ Y) Z).hom ≫ (α_ Z X Y).inv
  = ((𝟙 X) ⊗ (braiding Y Z).hom) ≫ (α_ X Z Y).inv ≫ ((braiding X Z).hom ⊗ (𝟙 Y))
  . obviously)

restate_axiom braided_category.braiding_naturality'
attribute [simp,reassoc] braided_category.braiding_naturality
restate_axiom braided_category.hexagon_forward'
restate_axiom braided_category.hexagon_reverse'
attribute [reassoc] braided_category.hexagon_forward braided_category.hexagon_reverse

open category
open monoidal_category
open braided_category

notation `β_` := braiding

/--
Verifying the axioms for a braiding by checking that the candidate braiding is sent to a braiding
by a faithful monoidal functor.
-/
def braided_category_of_faithful {C D : Type*} [category C] [category D]
  [monoidal_category C] [monoidal_category D] (F : monoidal_functor C D) [faithful F.to_functor]
  [braided_category D] (β : Π X Y : C, X ⊗ Y ≅ Y ⊗ X)
  (w : ∀ X Y, F.μ _ _ ≫ F.map (β X Y).hom = (β_ _ _).hom ≫ F.μ _ _) : braided_category C :=
{ braiding := β,
  braiding_naturality' := begin
    intros,
    apply F.to_functor.map_injective,
    refine (cancel_epi (F.μ _ _)).1 _,
    rw [functor.map_comp, ←lax_monoidal_functor.μ_natural_assoc, w, functor.map_comp, reassoc_of w,
      braiding_naturality_assoc, lax_monoidal_functor.μ_natural],
  end,
  hexagon_forward' := begin
    intros,
    apply F.to_functor.map_injective,
    refine (cancel_epi (F.μ _ _)).1 _,
    refine (cancel_epi (F.μ _ _ ⊗ 𝟙 _)).1 _,
    rw [functor.map_comp, functor.map_comp, functor.map_comp, functor.map_comp,
      ←lax_monoidal_functor.μ_natural_assoc, functor.map_id, ←comp_tensor_id_assoc, w,
      comp_tensor_id, category.assoc, lax_monoidal_functor.associativity_assoc,
      lax_monoidal_functor.associativity_assoc, ←lax_monoidal_functor.μ_natural, functor.map_id,
      ←id_tensor_comp_assoc, w, id_tensor_comp_assoc, reassoc_of w, braiding_naturality_assoc,
      lax_monoidal_functor.associativity, hexagon_forward_assoc],
  end,
  hexagon_reverse' := begin
    intros,
    apply F.to_functor.map_injective,
    refine (cancel_epi (F.μ _ _)).1 _,
    refine (cancel_epi (𝟙 _ ⊗ F.μ _ _)).1 _,
    rw [functor.map_comp, functor.map_comp, functor.map_comp, functor.map_comp,
      ←lax_monoidal_functor.μ_natural_assoc, functor.map_id, ←id_tensor_comp_assoc, w,
      id_tensor_comp_assoc, lax_monoidal_functor.associativity_inv_assoc,
      lax_monoidal_functor.associativity_inv_assoc, ←lax_monoidal_functor.μ_natural, functor.map_id,
      ←comp_tensor_id_assoc, w, comp_tensor_id_assoc, reassoc_of w, braiding_naturality_assoc,
      lax_monoidal_functor.associativity_inv, hexagon_reverse_assoc],
  end, }

/-- Pull back a braiding along a fully faithful monoidal functor. -/
noncomputable
def braided_category_of_fully_faithful {C D : Type*} [category C] [category D]
  [monoidal_category C] [monoidal_category D] (F : monoidal_functor C D)
  [full F.to_functor] [faithful F.to_functor]
  [braided_category D] : braided_category C :=
braided_category_of_faithful F (λ X Y, F.to_functor.preimage_iso
  ((as_iso (F.μ _ _)).symm ≪≫ β_ (F.obj X) (F.obj Y) ≪≫ (as_iso (F.μ _ _))))
  (by tidy)

section
/-!
We now establish how the braiding interacts with the unitors.

I couldn't find a detailed proof in print, but this is discussed in:

* Proposition 1 of <NAME> and Ross Street,
  "Braided monoidal categories", Macquarie Math Reports 860081 (1986).
* Proposition 2.1 of <NAME> and Ross Street,
  "Braided tensor categories" , Adv. Math. 102 (1993), 20–78.
* Exercise 8.1.6 of Etingof, Gelaki, Nikshych, Ostrik,
  "Tensor categories", vol 25, Mathematical Surveys and Monographs (2015), AMS.
-/

variables (C : Type u₁) [category.{v₁} C] [monoidal_category C] [braided_category C]

lemma braiding_left_unitor_aux₁ (X : C) :
  (α_ (𝟙_ C) (𝟙_ C) X).hom ≫ (𝟙 (𝟙_ C) ⊗ (β_ X (𝟙_ C)).inv) ≫ (α_ _ X _).inv ≫ ((λ_ X).hom ⊗ 𝟙 _) =
  ((λ_ _).hom ⊗ 𝟙 X) ≫ (β_ X (𝟙_ C)).inv :=
by { rw [←left_unitor_tensor, left_unitor_naturality], simp, }

lemma braiding_left_unitor_aux₂ (X : C) :
  ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C))) = (ρ_ X).hom ⊗ (𝟙 (𝟙_ C)) :=
calc ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
    = ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ (α_ _ _ _).hom ≫ (α_ _ _ _).inv ≫
        ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by coherence
... = ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (β_ X _).hom) ≫
        (𝟙 _ ⊗ (β_ X _).inv) ≫ (α_ _ _ _).inv ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by { slice_rhs 3 4 { rw [←id_tensor_comp, iso.hom_inv_id, tensor_id], }, rw [id_comp], }
... = (α_ _ _ _).hom ≫ (β_ _ _).hom ≫
        (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (β_ X _).inv) ≫ (α_ _ _ _).inv ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by { slice_lhs 1 3 { rw ←hexagon_forward }, simp only [assoc], }
... = (α_ _ _ _).hom ≫ (β_ _ _).hom ≫ ((λ_ _).hom ⊗ 𝟙 X) ≫ (β_ X _).inv
         : by rw braiding_left_unitor_aux₁
... = (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (λ_ _).hom) ≫ (β_ _ _).hom ≫ (β_ X _).inv
         : by { slice_lhs 2 3 { rw [←braiding_naturality] }, simp only [assoc], }
... = (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (λ_ _).hom)
         : by rw [iso.hom_inv_id, comp_id]
... = (ρ_ X).hom ⊗ (𝟙 (𝟙_ C))
         : by rw triangle

@[simp]
lemma braiding_left_unitor (X : C) : (β_ X (𝟙_ C)).hom ≫ (λ_ X).hom = (ρ_ X).hom :=
by rw [←tensor_right_iff, comp_tensor_id, braiding_left_unitor_aux₂]

lemma braiding_right_unitor_aux₁ (X : C) :
  (α_ X (𝟙_ C) (𝟙_ C)).inv ≫ ((β_ (𝟙_ C) X).inv ⊗ 𝟙 (𝟙_ C)) ≫ (α_ _ X _).hom ≫ (𝟙 _ ⊗ (ρ_ X).hom) =
  (𝟙 X ⊗ (ρ_ _).hom) ≫ (β_ (𝟙_ C) X).inv :=
by { rw [←right_unitor_tensor, right_unitor_naturality], simp, }

lemma braiding_right_unitor_aux₂ (X : C) :
  ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom) = (𝟙 (𝟙_ C)) ⊗ (λ_ X).hom :=
calc ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
    = ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ (α_ _ _ _).inv ≫ (α_ _ _ _).hom ≫
        ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by coherence
... = ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ (α_ _ _ _).inv ≫ ((β_ _ X).hom ⊗ 𝟙 _) ≫
        ((β_ _ X).inv ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by { slice_rhs 3 4 { rw [←comp_tensor_id, iso.hom_inv_id, tensor_id], }, rw [id_comp], }
... = (α_ _ _ _).inv ≫ (β_ _ _).hom ≫
        (α_ _ _ _).inv ≫ ((β_ _ X).inv ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by { slice_lhs 1 3 { rw ←hexagon_reverse }, simp only [assoc], }
... = (α_ _ _ _).inv ≫ (β_ _ _).hom ≫ (𝟙 X ⊗ (ρ_ _).hom) ≫ (β_ _ X).inv
         : by rw braiding_right_unitor_aux₁
... = (α_ _ _ _).inv ≫ ((ρ_ _).hom ⊗ 𝟙 _) ≫ (β_ _ X).hom ≫ (β_ _ _).inv
         : by { slice_lhs 2 3 { rw [←braiding_naturality] }, simp only [assoc], }
... = (α_ _ _ _).inv ≫ ((ρ_ _).hom ⊗ 𝟙 _)
         : by rw [iso.hom_inv_id, comp_id]
... = (𝟙 (𝟙_ C)) ⊗ (λ_ X).hom
         : by rw [triangle_assoc_comp_right]

@[simp]
lemma braiding_right_unitor (X : C) : (β_ (𝟙_ C) X).hom ≫ (ρ_ X).hom = (λ_ X).hom :=
by rw [←tensor_left_iff, id_tensor_comp, braiding_right_unitor_aux₂]

@[simp]
lemma left_unitor_inv_braiding (X : C) : (λ_ X).inv ≫ (β_ (𝟙_ C) X).hom = (ρ_ X).inv :=
begin
  apply (cancel_mono (ρ_ X).hom).1,
  simp only [assoc, braiding_right_unitor, iso.inv_hom_id],
end

@[simp]
lemma right_unitor_inv_braiding (X : C) : (ρ_ X).inv ≫ (β_ X (𝟙_ C)).hom = (λ_ X).inv :=
begin
  apply (cancel_mono (λ_ X).hom).1,
  simp only [assoc, braiding_left_unitor, iso.inv_hom_id],
end

end

/--
A symmetric monoidal category is a braided monoidal category for which the braiding is symmetric.

See <https://stacks.math.columbia.edu/tag/0FFW>.
-/
class symmetric_category (C : Type u) [category.{v} C] [monoidal_category.{v} C]
   extends braided_category.{v} C :=
-- braiding symmetric:
(symmetry' : ∀ X Y : C, (β_ X Y).hom ≫ (β_ Y X).hom = 𝟙 (X ⊗ Y) . obviously)

restate_axiom symmetric_category.symmetry'
attribute [simp,reassoc] symmetric_category.symmetry

variables (C : Type u₁) [category.{v₁} C] [monoidal_category C] [braided_category C]
variables (D : Type u₂) [category.{v₂} D] [monoidal_category D] [braided_category D]
variables (E : Type u₃) [category.{v₃} E] [monoidal_category E] [braided_category E]

/--
A lax braided functor between braided monoidal categories is a lax monoidal functor
which preserves the braiding.
-/
structure lax_braided_functor extends lax_monoidal_functor C D :=
(braided' : ∀ X Y : C, μ X Y ≫ map (β_ X Y).hom = (β_ (obj X) (obj Y)).hom ≫ μ Y X . obviously)

restate_axiom lax_braided_functor.braided'

namespace lax_braided_functor

/-- The identity lax braided monoidal functor. -/
@[simps] def id : lax_braided_functor C C :=
{ .. monoidal_functor.id C }

instance : inhabited (lax_braided_functor C C) := ⟨id C⟩

variables {C D E}

/-- The composition of lax braided monoidal functors. -/
@[simps]
def comp (F : lax_braided_functor C D) (G : lax_braided_functor D E) : lax_braided_functor C E :=
{ braided' := λ X Y,
  begin
    dsimp,
    slice_lhs 2 3 { rw [←category_theory.functor.map_comp, F.braided,
      category_theory.functor.map_comp], },
    slice_lhs 1 2 { rw [G.braided], },
    simp only [category.assoc],
  end,
  ..(lax_monoidal_functor.comp F.to_lax_monoidal_functor G.to_lax_monoidal_functor) }

instance category_lax_braided_functor : category (lax_braided_functor C D) :=
induced_category.category lax_braided_functor.to_lax_monoidal_functor

@[simp] lemma comp_to_nat_trans {F G H : lax_braided_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

/--
Interpret a natural isomorphism of the underlyling lax monoidal functors as an
isomorphism of the lax braided monoidal functors.
-/
@[simps]
def mk_iso {F G : lax_braided_functor C D}
  (i : F.to_lax_monoidal_functor ≅ G.to_lax_monoidal_functor) : F ≅ G :=
{ ..i }

end lax_braided_functor

/--
A braided functor between braided monoidal categories is a monoidal functor
which preserves the braiding.
-/
structure braided_functor extends monoidal_functor C D :=
-- Note this is stated differently than for `lax_braided_functor`.
-- We move the `μ X Y` to the right hand side,
-- so that this makes a good `@[simp]` lemma.
(braided' :
  ∀ X Y : C, map (β_ X Y).hom = inv (μ X Y) ≫ (β_ (obj X) (obj Y)).hom ≫ μ Y X . obviously)

restate_axiom braided_functor.braided'
attribute [simp] braided_functor.braided

/-- A braided category with a braided functor to a symmetric category is itself symmetric. -/
def symmetric_category_of_faithful {C D : Type*} [category C] [category D]
  [monoidal_category C] [monoidal_category D] [braided_category C] [symmetric_category D]
  (F : braided_functor C D) [faithful F.to_functor] : symmetric_category C :=
{ symmetry' := λ X Y, F.to_functor.map_injective (by simp), }

namespace braided_functor

/-- Turn a braided functor into a lax braided functor. -/
@[simps]
def to_lax_braided_functor (F : braided_functor C D) : lax_braided_functor C D :=
{ braided' := λ X Y, by { rw F.braided, simp, }
  .. F }

/-- The identity braided monoidal functor. -/
@[simps] def id : braided_functor C C :=
{ .. monoidal_functor.id C }

instance : inhabited (braided_functor C C) := ⟨id C⟩

variables {C D E}

/-- The composition of braided monoidal functors. -/
@[simps]
def comp (F : braided_functor C D) (G : braided_functor D E) : braided_functor C E :=
{ ..(monoidal_functor.comp F.to_monoidal_functor G.to_monoidal_functor) }

instance category_braided_functor : category (braided_functor C D) :=
induced_category.category braided_functor.to_monoidal_functor

@[simp] lemma comp_to_nat_trans {F G H : braided_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

/--
Interpret a natural isomorphism of the underlyling monoidal functors as an
isomorphism of the braided monoidal functors.
-/
@[simps]
def mk_iso {F G : braided_functor C D}
  (i : F.to_monoidal_functor ≅ G.to_monoidal_functor) : F ≅ G :=
{ ..i }


end braided_functor

section comm_monoid

variables (M : Type u) [comm_monoid M]

instance : braided_category (discrete M) :=
{ braiding := λ X Y, discrete.eq_to_iso (mul_comm X.as Y.as), }

variables {M} {N : Type u} [comm_monoid N]

/--
A multiplicative morphism between commutative monoids gives a braided functor between
the corresponding discrete braided monoidal categories.
-/
@[simps]
def discrete.braided_functor (F : M →* N) : braided_functor (discrete M) (discrete N) :=
{ ..discrete.monoidal_functor F }

end comm_monoid

section tensor

/-- The strength of the tensor product functor from `C × C` to `C`. -/
def tensor_μ (X Y : C × C) : (tensor C).obj X ⊗ (tensor C).obj Y ⟶ (tensor C).obj (X ⊗ Y) :=
(α_ X.1 X.2 (Y.1 ⊗ Y.2)).hom ≫ (𝟙 X.1 ⊗ (α_ X.2 Y.1 Y.2).inv) ≫
  (𝟙 X.1 ⊗ ((β_ X.2 Y.1).hom ⊗ 𝟙 Y.2)) ≫
  (𝟙 X.1 ⊗ (α_ Y.1 X.2 Y.2).hom) ≫ (α_ X.1 Y.1 (X.2 ⊗ Y.2)).inv

lemma tensor_μ_def₁ (X₁ X₂ Y₁ Y₂ : C) :
    tensor_μ C (X₁, X₂) (Y₁, Y₂) ≫ (α_ X₁ Y₁ (X₂ ⊗ Y₂)).hom ≫ (𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).inv)
  = (α_ X₁ X₂ (Y₁ ⊗ Y₂)).hom ≫ (𝟙 X₁ ⊗ (α_ X₂ Y₁ Y₂).inv) ≫ (𝟙 X₁ ⊗ ((β_ X₂ Y₁).hom ⊗ 𝟙 Y₂)) :=
by { dsimp [tensor_μ], simp }

lemma tensor_μ_def₂ (X₁ X₂ Y₁ Y₂ : C) :
    (𝟙 X₁ ⊗ (α_ X₂ Y₁ Y₂).hom) ≫ (α_ X₁ X₂ (Y₁ ⊗ Y₂)).inv ≫ tensor_μ C (X₁, X₂) (Y₁, Y₂)
  = (𝟙 X₁ ⊗ ((β_ X₂ Y₁).hom ⊗ 𝟙 Y₂)) ≫ (𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).hom) ≫ (α_ X₁ Y₁ (X₂ ⊗ Y₂)).inv :=
by { dsimp [tensor_μ], simp }

lemma tensor_μ_natural {X₁ X₂ Y₁ Y₂ U₁ U₂ V₁ V₂ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : U₁ ⟶ V₁) (g₂ : U₂ ⟶ V₂) :
  ((f₁ ⊗ f₂) ⊗ (g₁ ⊗ g₂)) ≫ tensor_μ C (Y₁, Y₂) (V₁, V₂) =
    tensor_μ C (X₁, X₂) (U₁, U₂) ≫ ((f₁ ⊗ g₁) ⊗ (f₂ ⊗ g₂)) :=
begin
  dsimp [tensor_μ],
  slice_lhs 1 2 { rw [associator_naturality] },
  slice_lhs 2 3 { rw [←tensor_comp,
                      comp_id f₁, ←id_comp f₁,
                      associator_inv_naturality,
                      tensor_comp] },
  slice_lhs 3 4 { rw [←tensor_comp, ←tensor_comp,
                      comp_id f₁, ←id_comp f₁,
                      comp_id g₂, ←id_comp g₂,
                      braiding_naturality,
                      tensor_comp, tensor_comp] },
  slice_lhs 4 5 { rw [←tensor_comp,
                      comp_id f₁, ←id_comp f₁,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 5 6 { rw [associator_inv_naturality] },
  simp only [assoc],
end

lemma tensor_left_unitality (X₁ X₂ : C) :
    (λ_ (X₁ ⊗ X₂)).hom
  = ((λ_ (𝟙_ C)).inv ⊗ 𝟙 (X₁ ⊗ X₂)) ≫
    tensor_μ C (𝟙_ C, 𝟙_ C) (X₁, X₂) ≫
    ((λ_ X₁).hom ⊗ (λ_ X₂).hom) :=
begin
  dsimp [tensor_μ],
  have :
      ((λ_ (𝟙_ C)).inv ⊗ 𝟙 (X₁ ⊗ X₂)) ≫
      (α_ (𝟙_ C) (𝟙_ C) (X₁ ⊗ X₂)).hom ≫
      (𝟙 (𝟙_ C) ⊗ (α_ (𝟙_ C) X₁ X₂).inv)
    = 𝟙 (𝟙_ C) ⊗ ((λ_ X₁).inv ⊗ 𝟙 X₂) := by pure_coherence,
  slice_rhs 1 3 { rw this }, clear this,
  slice_rhs 1 2 { rw [←tensor_comp, ←tensor_comp,
                      comp_id, comp_id,
                      left_unitor_inv_braiding] },
  simp only [assoc],
  coherence,
end

lemma tensor_right_unitality (X₁ X₂ : C) :
    (ρ_ (X₁ ⊗ X₂)).hom
  = (𝟙 (X₁ ⊗ X₂) ⊗ (λ_ (𝟙_ C)).inv) ≫
    tensor_μ C (X₁, X₂) (𝟙_ C, 𝟙_ C) ≫
    ((ρ_ X₁).hom ⊗ (ρ_ X₂).hom) :=
begin
  dsimp [tensor_μ],
  have :
      (𝟙 (X₁ ⊗ X₂) ⊗ (λ_ (𝟙_ C)).inv) ≫
      (α_ X₁ X₂ (𝟙_ C ⊗ 𝟙_ C)).hom ≫
      (𝟙 X₁ ⊗ (α_ X₂ (𝟙_ C) (𝟙_ C)).inv)
    = (α_ X₁ X₂ (𝟙_ C)).hom ≫
      (𝟙 X₁ ⊗ ((ρ_ X₂).inv ⊗ 𝟙 (𝟙_ C))) := by pure_coherence,
  slice_rhs 1 3 { rw this }, clear this,
  slice_rhs 2 3 { rw [←tensor_comp, ←tensor_comp,
                      comp_id, comp_id,
                      right_unitor_inv_braiding] },
  simp only [assoc],
  coherence,
end

/-
Diagram B6 from Proposition 1 of [Joyal and Street, *Braided monoidal categories*][Joyal_Street].
-/
lemma tensor_associativity_aux (W X Y Z : C) :
    ((β_ W X).hom ⊗ 𝟙 (Y ⊗ Z)) ≫
    (α_ X W (Y ⊗ Z)).hom ≫
    (𝟙 X ⊗ (α_ W Y Z).inv) ≫
    (𝟙 X ⊗ (β_ (W ⊗ Y) Z).hom) ≫
    (𝟙 X ⊗ (α_ Z W Y).inv)
  = (𝟙 (W ⊗ X) ⊗ (β_ Y Z).hom) ≫
    (α_ (W ⊗ X) Z Y).inv ≫
    ((α_ W X Z).hom ⊗ 𝟙 Y) ≫
    ((β_ W (X ⊗ Z)).hom ⊗ 𝟙 Y) ≫
    ((α_ X Z W).hom ⊗ 𝟙 Y) ≫
    (α_ X (Z ⊗ W) Y).hom :=
begin
  slice_rhs 3 5 { rw [←tensor_comp, ←tensor_comp,
                      hexagon_forward,
                      tensor_comp, tensor_comp] },
  slice_rhs 5 6 { rw [associator_naturality] },
  slice_rhs 2 3 { rw [←associator_inv_naturality] },
  slice_rhs 3 5 { rw [←pentagon_hom_inv] },
  slice_rhs 1 2 { rw [tensor_id,
                      id_tensor_comp_tensor_id,
                      ←tensor_id_comp_id_tensor] },
  slice_rhs 2 3 { rw [← tensor_id, associator_naturality] },
  slice_rhs 3 5 { rw [←tensor_comp, ←tensor_comp,
                      ←hexagon_reverse,
                      tensor_comp, tensor_comp] },
end

lemma tensor_associativity (X₁ X₂ Y₁ Y₂ Z₁ Z₂ : C) :
    (tensor_μ C (X₁, X₂) (Y₁, Y₂) ⊗ 𝟙 (Z₁ ⊗ Z₂)) ≫
    tensor_μ C (X₁ ⊗ Y₁, X₂ ⊗ Y₂) (Z₁, Z₂) ≫
    ((α_ X₁ Y₁ Z₁).hom ⊗ (α_ X₂ Y₂ Z₂).hom)
  = (α_ (X₁ ⊗ X₂) (Y₁ ⊗ Y₂) (Z₁ ⊗ Z₂)).hom ≫
    (𝟙 (X₁ ⊗ X₂) ⊗ tensor_μ C (Y₁, Y₂) (Z₁, Z₂)) ≫
    tensor_μ C (X₁, X₂) (Y₁ ⊗ Z₁, Y₂ ⊗ Z₂) :=
begin
  have :
      ((α_ X₁ Y₁ Z₁).hom ⊗ (α_ X₂ Y₂ Z₂).hom)
    = (α_ (X₁ ⊗ Y₁) Z₁ ((X₂ ⊗ Y₂) ⊗ Z₂)).hom ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ Z₁ (X₂ ⊗ Y₂) Z₂).inv) ≫
      (α_ X₁ Y₁ ((Z₁ ⊗ (X₂ ⊗ Y₂)) ⊗ Z₂)).hom ≫
      (𝟙 X₁ ⊗ (α_ Y₁ (Z₁ ⊗ (X₂ ⊗ Y₂)) Z₂).inv) ≫
      (α_ X₁ (Y₁ ⊗ (Z₁ ⊗ (X₂ ⊗ Y₂))) Z₂).inv ≫
      ((𝟙 X₁ ⊗ (𝟙 Y₁ ⊗ (α_ Z₁ X₂ Y₂).inv)) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ (Z₁ ⊗ X₂) Y₂).inv) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ ((α_ Y₁ Z₁ X₂).inv ⊗ 𝟙 Y₂)) ⊗ 𝟙 Z₂) ≫
      (α_ X₁ (((Y₁ ⊗ Z₁) ⊗ X₂) ⊗ Y₂) Z₂).hom ≫
      (𝟙 X₁ ⊗ (α_ ((Y₁ ⊗ Z₁) ⊗ X₂) Y₂ Z₂).hom) ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ Z₁) X₂ (Y₂ ⊗ Z₂)).hom) ≫
      (α_ X₁ (Y₁ ⊗ Z₁) (X₂ ⊗ (Y₂ ⊗ Z₂))).inv := by pure_coherence,
  rw this, clear this,
  slice_lhs 2 4 { rw [tensor_μ_def₁] },
  slice_lhs 4 5 { rw [←tensor_id, associator_naturality] },
  slice_lhs 5 6 { rw [←tensor_comp,
                      associator_inv_naturality,
                      tensor_comp] },
  slice_lhs 6 7 { rw [associator_inv_naturality] },
  have :
      (α_ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) (Z₁ ⊗ Z₂)).hom ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ (X₂ ⊗ Y₂) Z₁ Z₂).inv) ≫
      (α_ X₁ Y₁ (((X₂ ⊗ Y₂) ⊗ Z₁) ⊗ Z₂)).hom ≫
      (𝟙 X₁ ⊗ (α_ Y₁ ((X₂ ⊗ Y₂) ⊗ Z₁) Z₂).inv) ≫
      (α_ X₁ (Y₁ ⊗ ((X₂ ⊗ Y₂) ⊗ Z₁)) Z₂).inv
    = ((α_ X₁ Y₁ (X₂ ⊗ Y₂)).hom ⊗ 𝟙 (Z₁ ⊗ Z₂)) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).inv) ⊗ 𝟙 (Z₁ ⊗ Z₂)) ≫
      (α_ (X₁ ⊗ ((Y₁ ⊗ X₂) ⊗ Y₂)) Z₁ Z₂).inv ≫
      ((α_ X₁ ((Y₁ ⊗ X₂) ⊗ Y₂) Z₁).hom ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) Y₂ Z₁).hom) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ X₂ (Y₂ ⊗ Z₁)).hom) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (𝟙 Y₁ ⊗ (α_ X₂ Y₂ Z₁).inv)) ⊗ 𝟙 Z₂) := by pure_coherence,
  slice_lhs 2 6 { rw this }, clear this,
  slice_lhs 1 3 { rw [←tensor_comp, ←tensor_comp,
                      tensor_μ_def₁,
                      tensor_comp, tensor_comp] },
  slice_lhs 3 4 { rw [←tensor_id,
                      associator_inv_naturality] },
  slice_lhs 4 5 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 5 6 { rw [←tensor_comp, ←tensor_comp,
                      associator_naturality,
                      tensor_comp, tensor_comp] },
  slice_lhs 6 10 { rw [←tensor_comp, ←tensor_comp, ←tensor_comp, ←tensor_comp,
                       ←tensor_comp, ←tensor_comp, ←tensor_comp, ←tensor_comp,
                       tensor_id,
                       tensor_associativity_aux,
                       ←tensor_id,
                       ←id_comp (𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁),
                       ←id_comp (𝟙 Z₂ ≫ 𝟙 Z₂ ≫ 𝟙 Z₂ ≫ 𝟙 Z₂ ≫ 𝟙 Z₂),
                       tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp,
                       tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp] },
  slice_lhs 11 12 { rw [←tensor_comp, ←tensor_comp,
                        iso.hom_inv_id],
                    simp },
  simp only [assoc, id_comp],
  slice_lhs 10 11 { rw [←tensor_comp, ←tensor_comp, ←tensor_comp,
                        iso.hom_inv_id],
                    simp },
  simp only [assoc, id_comp],
  slice_lhs 9 10 { rw [associator_naturality] },
  slice_lhs 10 11 { rw [←tensor_comp,
                        associator_naturality,
                        tensor_comp] },
  slice_lhs 11 13 { rw [tensor_id, ←tensor_μ_def₂] },
  have :
      ((𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁) Z₁ Y₂).inv) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ X₂ Y₁ Z₁).hom ⊗ 𝟙 Y₂) ⊗ 𝟙 Z₂) ≫
      (α_ X₁ ((X₂ ⊗ Y₁ ⊗ Z₁) ⊗ Y₂) Z₂).hom ≫
      (𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁ ⊗ Z₁) Y₂ Z₂).hom) ≫
      (𝟙 X₁ ⊗ (α_ X₂ (Y₁ ⊗ Z₁) (Y₂ ⊗ Z₂)).hom) ≫
      (α_ X₁ X₂ ((Y₁ ⊗ Z₁) ⊗ Y₂ ⊗ Z₂)).inv
    = (α_ X₁ ((X₂ ⊗ Y₁) ⊗ (Z₁ ⊗ Y₂)) Z₂).hom ≫
      (𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁) (Z₁ ⊗ Y₂) Z₂).hom) ≫
      (𝟙 X₁ ⊗ (α_ X₂ Y₁ ((Z₁ ⊗ Y₂) ⊗ Z₂)).hom) ≫
      (α_ X₁ X₂ (Y₁ ⊗ ((Z₁ ⊗ Y₂) ⊗ Z₂))).inv ≫
      (𝟙 (X₁ ⊗ X₂) ⊗ (𝟙 Y₁ ⊗ (α_ Z₁ Y₂ Z₂).hom)) ≫
      (𝟙 (X₁ ⊗ X₂) ⊗ (α_ Y₁ Z₁ (Y₂ ⊗ Z₂)).inv) := by pure_coherence,
  slice_lhs 7 12 { rw this }, clear this,
  slice_lhs 6 7 { rw [associator_naturality] },
  slice_lhs 7 8 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 8 9 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 9 10 { rw [associator_inv_naturality] },
  slice_lhs 10 12 { rw [←tensor_comp, ←tensor_comp,
                        ←tensor_μ_def₂,
                        tensor_comp, tensor_comp] },
  dsimp,
  coherence,
end

/-- The tensor product functor from `C × C` to `C` as a monoidal functor. -/
@[simps]
def tensor_monoidal : monoidal_functor (C × C) C :=
{ ε := (λ_ (𝟙_ C)).inv,
  μ := λ X Y, tensor_μ C X Y,
  μ_natural' := λ X Y X' Y' f g, tensor_μ_natural C f.1 f.2 g.1 g.2,
  associativity' := λ X Y Z, tensor_associativity C X.1 X.2 Y.1 Y.2 Z.1 Z.2,
  left_unitality' := λ ⟨X₁, X₂⟩, tensor_left_unitality C X₁ X₂,
  right_unitality' := λ ⟨X₁, X₂⟩, tensor_right_unitality C X₁ X₂,
  μ_is_iso := by { dsimp [tensor_μ], apply_instance },
  .. tensor C }

lemma left_unitor_monoidal (X₁ X₂ : C) :
    (λ_ X₁).hom ⊗ (λ_ X₂).hom
  = tensor_μ C (𝟙_ C, X₁) (𝟙_ C, X₂) ≫
    ((λ_ (𝟙_ C)).hom ⊗ 𝟙 (X₁ ⊗ X₂)) ≫
    (λ_ (X₁ ⊗ X₂)).hom :=
begin
  dsimp [tensor_μ],
  have :
      (λ_ X₁).hom ⊗ (λ_ X₂).hom
    = (α_ (𝟙_ C) X₁ (𝟙_ C ⊗ X₂)).hom ≫
      (𝟙 (𝟙_ C) ⊗ (α_ X₁ (𝟙_ C) X₂).inv) ≫
      (λ_ ((X₁ ⊗ (𝟙_ C)) ⊗ X₂)).hom ≫
      ((ρ_ X₁).hom ⊗ (𝟙 X₂)) := by pure_coherence,
  rw this, clear this,
  rw ←braiding_left_unitor,
  slice_lhs 3 4 { rw [←id_comp (𝟙 X₂), tensor_comp] },
  slice_lhs 3 4 { rw [←left_unitor_naturality] },
  coherence,
end

lemma right_unitor_monoidal (X₁ X₂ : C) :
    (ρ_ X₁).hom ⊗ (ρ_ X₂).hom
  = tensor_μ C (X₁, 𝟙_ C) (X₂, 𝟙_ C) ≫
    (𝟙 (X₁ ⊗ X₂) ⊗ (λ_ (𝟙_ C)).hom) ≫
    (ρ_ (X₁ ⊗ X₂)).hom :=
begin
  dsimp [tensor_μ],
  have :
      (ρ_ X₁).hom ⊗ (ρ_ X₂).hom
    = (α_ X₁ (𝟙_ C) (X₂ ⊗ (𝟙_ C))).hom ≫
      (𝟙 X₁ ⊗ (α_ (𝟙_ C) X₂ (𝟙_ C)).inv) ≫
      (𝟙 X₁ ⊗ (ρ_ (𝟙_ C ⊗ X₂)).hom) ≫
      (𝟙 X₁ ⊗ (λ_ X₂).hom) := by pure_coherence,
  rw this, clear this,
  rw ←braiding_right_unitor,
  slice_lhs 3 4 { rw [←id_comp (𝟙 X₁), tensor_comp, id_comp] },
  slice_lhs 3 4 { rw [←tensor_comp,
                      ←right_unitor_naturality,
                      tensor_comp] },
  coherence,
end

lemma associator_monoidal_aux (W X Y Z : C) :
    (𝟙 W ⊗ (β_ X (Y ⊗ Z)).hom) ≫
    (𝟙 W ⊗ (α_ Y Z X).hom) ≫
    (α_ W Y (Z ⊗ X)).inv ≫
    ((β_ W Y).hom ⊗ 𝟙 (Z ⊗ X))
  = (α_ W X (Y ⊗ Z)).inv ≫
    (α_ (W ⊗ X) Y Z).inv ≫
    ((β_ (W ⊗ X) Y).hom ⊗ 𝟙 Z) ≫
    ((α_ Y W X).inv ⊗ 𝟙 Z) ≫
    (α_ (Y ⊗ W) X Z).hom ≫
    (𝟙 (Y ⊗ W) ⊗ (β_ X Z).hom) :=
begin
  slice_rhs 1 2 { rw ←pentagon_inv },
  slice_rhs 3 5 { rw [←tensor_comp, ←tensor_comp,
                      hexagon_reverse,
                      tensor_comp, tensor_comp] },
  slice_rhs 5 6 { rw associator_naturality },
  slice_rhs 6 7 { rw [tensor_id,
                      tensor_id_comp_id_tensor,
                      ←id_tensor_comp_tensor_id] },
  slice_rhs 2 3 { rw ←associator_inv_naturality },
  slice_rhs 3 5 { rw pentagon_inv_inv_hom },
  slice_rhs 4 5 { rw [←tensor_id,
                      ←associator_inv_naturality] },
  slice_rhs 2 4 { rw [←tensor_comp, ←tensor_comp,
                      ←hexagon_forward,
                      tensor_comp, tensor_comp] },
  simp,
end

lemma associator_monoidal (X₁ X₂ X₃ Y₁ Y₂ Y₃ : C) :
    tensor_μ C (X₁ ⊗ X₂, X₃) (Y₁ ⊗ Y₂, Y₃) ≫
    (tensor_μ C (X₁, X₂) (Y₁, Y₂) ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
    (α_ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) (X₃ ⊗ Y₃)).hom
  = ((α_ X₁ X₂ X₃).hom ⊗ (α_ Y₁ Y₂ Y₃).hom) ≫
    tensor_μ C (X₁, X₂ ⊗ X₃) (Y₁, Y₂ ⊗ Y₃) ≫
    (𝟙 (X₁ ⊗ Y₁) ⊗ tensor_μ C (X₂, X₃) (Y₂, Y₃)) :=
begin
  have :
      (α_ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) (X₃ ⊗ Y₃)).hom
    = ((α_ X₁ Y₁ (X₂ ⊗ Y₂)).hom ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).inv) ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      (α_ (X₁ ⊗ ((Y₁ ⊗ X₂) ⊗ Y₂)) X₃ Y₃).inv ≫
      ((α_ X₁ ((Y₁ ⊗ X₂) ⊗ Y₂) X₃).hom ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) Y₂ X₃).hom) ⊗ 𝟙 Y₃) ≫
      (α_ X₁ ((Y₁ ⊗ X₂) ⊗ (Y₂ ⊗ X₃)) Y₃).hom ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) (Y₂ ⊗ X₃) Y₃).hom) ≫
      (𝟙 X₁ ⊗ (α_ Y₁ X₂ ((Y₂ ⊗ X₃) ⊗ Y₃)).hom) ≫
      (α_ X₁ Y₁ (X₂ ⊗ ((Y₂ ⊗ X₃) ⊗ Y₃))).inv ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (𝟙 X₂ ⊗ (α_ Y₂ X₃ Y₃).hom)) ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ X₂ Y₂ (X₃ ⊗ Y₃)).inv) := by pure_coherence,
  rw this, clear this,
  slice_lhs 2 4 { rw [←tensor_comp, ←tensor_comp,
                      tensor_μ_def₁,
                      tensor_comp, tensor_comp] },
  slice_lhs 4 5 { rw [←tensor_id,
                      associator_inv_naturality] },
  slice_lhs 5 6 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 6 7 { rw [←tensor_comp, ←tensor_comp,
                      associator_naturality,
                      tensor_comp, tensor_comp] },
  have :
      ((α_ X₁ X₂ (Y₁ ⊗ Y₂)).hom ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      ((𝟙 X₁ ⊗ (α_ X₂ Y₁ Y₂).inv) ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      (α_ (X₁ ⊗ ((X₂ ⊗ Y₁) ⊗ Y₂)) X₃ Y₃).inv ≫
      ((α_ X₁ ((X₂ ⊗ Y₁) ⊗ Y₂) X₃).hom ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁) Y₂ X₃).hom) ⊗ 𝟙 Y₃)
    = (α_ (X₁ ⊗ X₂) (Y₁ ⊗ Y₂) (X₃ ⊗ Y₃)).hom ≫
      (𝟙 (X₁ ⊗ X₂) ⊗ (α_ (Y₁ ⊗ Y₂) X₃ Y₃).inv) ≫
      (α_ X₁ X₂ (((Y₁ ⊗ Y₂) ⊗ X₃) ⊗ Y₃)).hom ≫
      (𝟙 X₁ ⊗ (α_ X₂ ((Y₁ ⊗ Y₂) ⊗ X₃) Y₃).inv) ≫
      (α_ X₁ (X₂ ⊗ ((Y₁ ⊗ Y₂) ⊗ X₃)) Y₃).inv ≫
      ((𝟙 X₁ ⊗ (𝟙 X₂ ⊗ (α_ Y₁ Y₂ X₃).hom)) ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ X₂ Y₁ (Y₂ ⊗ X₃)).inv) ⊗ 𝟙 Y₃) := by pure_coherence,
  slice_lhs 2 6 { rw this }, clear this,
  slice_lhs 1 3 { rw tensor_μ_def₁ },
  slice_lhs 3 4 { rw [←tensor_id,
                      associator_naturality] },
  slice_lhs 4 5 { rw [←tensor_comp,
                      associator_inv_naturality,
                      tensor_comp] },
  slice_lhs 5 6 { rw associator_inv_naturality },
  slice_lhs 6 9 { rw [←tensor_comp, ←tensor_comp, ←tensor_comp,
                      ←tensor_comp, ←tensor_comp, ←tensor_comp,
                      tensor_id,
                      associator_monoidal_aux,
                      ←id_comp (𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁),
                      ←id_comp (𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁),
                      ←id_comp (𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃),
                      ←id_comp (𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃),
                      tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp,
                      tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp] },
  slice_lhs 11 12 { rw associator_naturality },
  slice_lhs 12 13 { rw [←tensor_comp,
                        associator_naturality,
                        tensor_comp] },
  slice_lhs 13 14 { rw [←tensor_comp, ←tensor_id,
                        associator_naturality,
                        tensor_comp] },
  slice_lhs 14 15 { rw associator_inv_naturality },
  slice_lhs 15 17 { rw [tensor_id, ←tensor_comp, ←tensor_comp,
                        ←tensor_μ_def₂,
                        tensor_comp, tensor_comp] },
  have :
      ((𝟙 X₁ ⊗ ((α_ Y₁ X₂ X₃).inv ⊗ 𝟙 Y₂)) ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) X₃ Y₂).hom) ⊗ 𝟙 Y₃) ≫
      (α_ X₁ ((Y₁ ⊗ X₂) ⊗ (X₃ ⊗ Y₂)) Y₃).hom ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) (X₃ ⊗ Y₂) Y₃).hom) ≫
      (𝟙 X₁ ⊗ (α_ Y₁ X₂ ((X₃ ⊗ Y₂) ⊗ Y₃)).hom) ≫
      (α_ X₁ Y₁ (X₂ ⊗ ((X₃ ⊗ Y₂) ⊗ Y₃))).inv ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (𝟙 X₂ ⊗ (α_ X₃ Y₂ Y₃).hom)) ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ X₂ X₃ (Y₂ ⊗ Y₃)).inv)
    = (α_ X₁ ((Y₁ ⊗ (X₂ ⊗ X₃)) ⊗ Y₂) Y₃).hom ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ (X₂ ⊗ X₃)) Y₂ Y₃).hom) ≫
      (𝟙 X₁ ⊗ (α_ Y₁ (X₂ ⊗ X₃) (Y₂ ⊗ Y₃)).hom) ≫
      (α_ X₁ Y₁ ((X₂ ⊗ X₃) ⊗ (Y₂ ⊗ Y₃))).inv := by pure_coherence,
  slice_lhs 9 16 { rw this }, clear this,
  slice_lhs 8 9 { rw associator_naturality },
  slice_lhs 9 10 { rw [←tensor_comp,
                       associator_naturality,
                       tensor_comp] },
  slice_lhs 10 12 { rw [tensor_id,
                        ←tensor_μ_def₂] },
  dsimp,
  coherence,
end

end tensor

end category_theory


<|start_filename|>src/set_theory/game/winner.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import set_theory.game.pgame

/-!
# Basic definitions about who has a winning stratergy

We define `G.first_loses`, `G.first_wins`, `G.left_wins` and `G.right_wins` for a pgame `G`, which
means the second, first, left and right players have a winning strategy respectively.
These are defined by inequalities which can be unfolded with `pgame.lt_def` and `pgame.le_def`.
-/

namespace pgame

local infix ` ≈ ` := equiv
local infix ` ⧏ `:50 := lf
local infix ` ∥ `:50 := fuzzy

/-- The player who goes first loses -/
def first_loses (G : pgame) : Prop := G ≈ 0

/-- The player who goes first wins -/
def first_wins (G : pgame) : Prop := G ∥ 0

/-- The left player can always win -/
def left_wins (G : pgame) : Prop := 0 < G

/-- The right player can always win -/
def right_wins (G : pgame) : Prop := G < 0

theorem zero_first_loses : first_loses 0 := equiv_rfl
theorem one_left_wins : left_wins 1 := zero_lt_one

theorem star_first_wins : first_wins star := star_fuzzy_zero

lemma winner_cases (G : pgame) : G.right_wins ∨ G.first_loses ∨ G.left_wins ∨ G.first_wins :=
lt_or_equiv_or_gt_or_fuzzy G 0

lemma first_loses_is_zero {G : pgame} : G.first_loses ↔ G ≈ 0 := by refl

lemma first_loses_of_equiv {G H : pgame} (h : G ≈ H) : G.first_loses → H.first_loses :=
h.symm.trans
lemma first_wins_of_equiv {G H : pgame} (h : G ≈ H) : G.first_wins → H.first_wins :=
(fuzzy_congr_left h).1
lemma left_wins_of_equiv {G H : pgame} (h : G ≈ H) : G.left_wins → H.left_wins :=
(lt_congr_right h).1
lemma right_wins_of_equiv {G H : pgame} (h : G ≈ H) : G.right_wins → H.right_wins :=
(lt_congr_left h).1

lemma first_loses_of_equiv_iff {G H : pgame} (h : G ≈ H) : G.first_loses ↔ H.first_loses :=
⟨first_loses_of_equiv h, h.trans⟩
lemma first_wins_of_equiv_iff {G H : pgame} : G ≈ H → (G.first_wins ↔ H.first_wins) :=
fuzzy_congr_left
lemma left_wins_of_equiv_iff {G H : pgame} : G ≈ H → (G.left_wins ↔ H.left_wins) :=
lt_congr_right
lemma right_wins_of_equiv_iff {G H : pgame} : G ≈ H → (G.right_wins ↔ H.right_wins) :=
lt_congr_left

lemma not_first_wins_of_first_loses {G : pgame} : G.first_loses → ¬G.first_wins :=
equiv.not_fuzzy

lemma not_first_loses_of_first_wins {G : pgame} : G.first_wins → ¬G.first_loses :=
fuzzy.not_equiv

end pgame


<|start_filename|>src/topology/vector_bundle/prod.lean<|end_filename|>
/-
Copyright © 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import topology.vector_bundle.basic

/-!
# Direct sum of two vector bundles

If `E₁ : B → Type*` and `E₂ : B → Type*` define two topological vector bundles over `R` with fiber
models `F₁` and `F₂`, we define the bundle of direct sums `E₁ ×ᵇ E₂ := λ x, E₁ x × E₂ x`.
We can endow `E₁ ×ᵇ E₂` with a topological vector bundle structure:
`bundle.prod.topological_vector_bundle`.

A similar construction (which is yet to be formalized) can be done for the vector bundle of
continuous linear maps from `E₁ x` to `E₂ x` with fiber a type synonym
`vector_bundle_continuous_linear_map R F₁ E₁ F₂ E₂ x := (E₁ x →L[R] E₂ x)` (and with the
topology inherited from the norm-topology on `F₁ →L[R] F₂`, without the need to define the strong
topology on continuous linear maps between general topological vector spaces).  Likewise for tensor
products of topological vector bundles, exterior algebras, and so on, where the topology can be
defined using a norm on the fiber model if this helps.

## Tags
Vector bundle
-/

noncomputable theory

open bundle set
open_locale classical

variables (R 𝕜 : Type*) {B : Type*} (F : Type*) (E : B → Type*)

namespace topological_vector_bundle

section defs
variables (E₁ : B → Type*) (E₂ : B → Type*)
variables [topological_space (total_space E₁)] [topological_space (total_space E₂)]

/-- Equip the total space of the fibrewise product of two topological vector bundles `E₁`, `E₂` with
the induced topology from the diagonal embedding into `total_space E₁ × total_space E₂`. -/
instance prod.topological_space :
  topological_space (total_space (E₁ ×ᵇ E₂)) :=
topological_space.induced
  (λ p, ((⟨p.1, p.2.1⟩ : total_space E₁), (⟨p.1, p.2.2⟩ : total_space E₂)))
  (by apply_instance : topological_space (total_space E₁ × total_space E₂))

/-- The diagonal map from the total space of the fibrewise product of two topological vector bundles
`E₁`, `E₂` into `total_space E₁ × total_space E₂` is `inducing`. -/
lemma prod.inducing_diag : inducing
  (λ p, (⟨p.1, p.2.1⟩, ⟨p.1, p.2.2⟩) :
    total_space (E₁ ×ᵇ E₂) → total_space E₁ × total_space E₂) :=
⟨rfl⟩

end defs

variables [nondiscrete_normed_field R] [topological_space B]

variables (F₁ : Type*) [normed_group F₁] [normed_space R F₁]
  (E₁ : B → Type*) [topological_space (total_space E₁)]
  [Π x, add_comm_monoid (E₁ x)] [Π x, module R (E₁ x)]

variables (F₂ : Type*) [normed_group F₂] [normed_space R F₂]
  (E₂ : B → Type*) [topological_space (total_space E₂)]
  [Π x, add_comm_monoid (E₂ x)] [Π x, module R (E₂ x)]

namespace trivialization
variables (e₁ : trivialization R F₁ E₁) (e₂ : trivialization R F₂ E₂)
include e₁ e₂
variables {R F₁ E₁ F₂ E₂}

/-- Given trivializations `e₁`, `e₂` for vector bundles `E₁`, `E₂` over a base `B`, the forward
function for the construction `topological_vector_bundle.trivialization.prod`, the induced
trivialization for the direct sum of `E₁` and `E₂`. -/
def prod.to_fun' : total_space (E₁ ×ᵇ E₂) → B × (F₁ × F₂) :=
λ p, ⟨p.1, (e₁ ⟨p.1, p.2.1⟩).2, (e₂ ⟨p.1, p.2.2⟩).2⟩

variables {e₁ e₂}

lemma prod.continuous_to_fun : continuous_on (prod.to_fun' e₁ e₂)
  (@total_space.proj B (E₁ ×ᵇ E₂) ⁻¹' (e₁.base_set ∩ e₂.base_set)) :=
begin
  let f₁ : total_space (E₁ ×ᵇ E₂) → total_space E₁ × total_space E₂ :=
    λ p, ((⟨p.1, p.2.1⟩ : total_space E₁), (⟨p.1, p.2.2⟩ : total_space E₂)),
  let f₂ : total_space E₁ × total_space E₂ → (B × F₁) × (B × F₂) := λ p, ⟨e₁ p.1, e₂ p.2⟩,
  let f₃ : (B × F₁) × (B × F₂) → B × F₁ × F₂ := λ p, ⟨p.1.1, p.1.2, p.2.2⟩,
  have hf₁ : continuous f₁ := (prod.inducing_diag E₁ E₂).continuous,
  have hf₂ : continuous_on f₂ (e₁.source ×ˢ e₂.source) :=
    e₁.to_local_homeomorph.continuous_on.prod_map e₂.to_local_homeomorph.continuous_on,
  have hf₃ : continuous f₃ :=
    (continuous_fst.comp continuous_fst).prod_mk (continuous_snd.prod_map continuous_snd),
  refine ((hf₃.comp_continuous_on hf₂).comp hf₁.continuous_on _).congr _,
  { rw [e₁.source_eq, e₂.source_eq],
    exact maps_to_preimage _ _ },
  rintros ⟨b, v₁, v₂⟩ ⟨hb₁, hb₂⟩,
  simp only [prod.to_fun', prod.mk.inj_iff, eq_self_iff_true, and_true],
  rw e₁.coe_fst,
  rw [e₁.source_eq, mem_preimage],
  exact hb₁,
end

variables (e₁ e₂)

/-- Given trivializations `e₁`, `e₂` for vector bundles `E₁`, `E₂` over a base `B`, the inverse
function for the construction `topological_vector_bundle.trivialization.prod`, the induced
trivialization for the direct sum of `E₁` and `E₂`. -/
def prod.inv_fun' (p : B × (F₁ × F₂)) : total_space (E₁ ×ᵇ E₂) :=
⟨p.1, e₁.symm p.1 p.2.1, e₂.symm p.1 p.2.2⟩

variables {e₁ e₂}

lemma prod.left_inv {x : total_space (E₁ ×ᵇ E₂)}
  (h : x ∈ @total_space.proj B (E₁ ×ᵇ E₂) ⁻¹' (e₁.base_set ∩ e₂.base_set)) :
  prod.inv_fun' e₁ e₂ (prod.to_fun' e₁ e₂ x) = x :=
begin
  obtain ⟨x, v₁, v₂⟩ := x,
  obtain ⟨h₁ : x ∈ e₁.base_set, h₂ : x ∈ e₂.base_set⟩ := h,
  simp only [prod.to_fun', prod.inv_fun', symm_apply_apply_mk, h₁, h₂]
end

lemma prod.right_inv {x : B × F₁ × F₂}
  (h : x ∈ (e₁.base_set ∩ e₂.base_set) ×ˢ (univ : set (F₁ × F₂))) :
  prod.to_fun' e₁ e₂ (prod.inv_fun' e₁ e₂ x) = x :=
begin
  obtain ⟨x, w₁, w₂⟩ := x,
  obtain ⟨⟨h₁ : x ∈ e₁.base_set, h₂ : x ∈ e₂.base_set⟩, -⟩ := h,
  simp only [prod.to_fun', prod.inv_fun', apply_mk_symm, h₁, h₂]
end

lemma prod.continuous_inv_fun :
  continuous_on (prod.inv_fun' e₁ e₂) ((e₁.base_set ∩ e₂.base_set) ×ˢ (univ : set (F₁ × F₂))) :=
begin
  rw (prod.inducing_diag E₁ E₂).continuous_on_iff,
  have H₁ : continuous (λ p : B × F₁ × F₂, ((p.1, p.2.1), (p.1, p.2.2))) :=
    (continuous_id.prod_map continuous_fst).prod_mk (continuous_id.prod_map continuous_snd),
  refine (e₁.continuous_on_symm.prod_map e₂.continuous_on_symm).comp H₁.continuous_on _,
  exact λ x h, ⟨⟨h.1.1, mem_univ _⟩, ⟨h.1.2, mem_univ _⟩⟩
end

variables (e₁ e₂)
variables [Π x : B, topological_space (E₁ x)] [Π x : B, topological_space (E₂ x)]
  [topological_vector_bundle R F₁ E₁] [topological_vector_bundle R F₂ E₂]

/-- Given trivializations `e₁`, `e₂` for vector bundles `E₁`, `E₂` over a base `B`, the induced
trivialization for the direct sum of `E₁` and `E₂`, whose base set is `e₁.base_set ∩ e₂.base_set`.
-/
@[nolint unused_arguments]
def prod : trivialization R (F₁ × F₂) (E₁ ×ᵇ E₂) :=
{ to_fun := prod.to_fun' e₁ e₂,
  inv_fun := prod.inv_fun' e₁ e₂,
  source := (@total_space.proj B (E₁ ×ᵇ E₂)) ⁻¹' (e₁.base_set ∩ e₂.base_set),
  target := (e₁.base_set ∩ e₂.base_set) ×ˢ (set.univ : set (F₁ × F₂)),
  map_source' := λ x h, ⟨h, set.mem_univ _⟩,
  map_target' := λ x h, h.1,
  left_inv' := λ x, prod.left_inv,
  right_inv' := λ x, prod.right_inv,
  open_source := begin
    refine (e₁.open_base_set.inter e₂.open_base_set).preimage _,
    have : continuous (@total_space.proj B E₁) := continuous_proj R B F₁,
    exact this.comp (prod.inducing_diag E₁ E₂).continuous.fst,
  end,
  open_target := (e₁.open_base_set.inter e₂.open_base_set).prod is_open_univ,
  continuous_to_fun := prod.continuous_to_fun,
  continuous_inv_fun := prod.continuous_inv_fun,
  base_set := e₁.base_set ∩ e₂.base_set,
  open_base_set := e₁.open_base_set.inter e₂.open_base_set,
  source_eq := rfl,
  target_eq := rfl,
  proj_to_fun := λ x h, rfl,
  linear' := λ x ⟨h₁, h₂⟩, (((e₁.linear h₁).mk' _).prod_map ((e₂.linear h₂).mk' _)).is_linear }

@[simp] lemma base_set_prod : (prod e₁ e₂).base_set = e₁.base_set ∩ e₂.base_set :=
rfl

variables {e₁ e₂}

lemma prod_apply {x : B} (hx₁ : x ∈ e₁.base_set) (hx₂ : x ∈ e₂.base_set) (v₁ : E₁ x)
  (v₂ : E₂ x) :
  prod e₁ e₂ ⟨x, (v₁, v₂)⟩
  = ⟨x, e₁.continuous_linear_equiv_at x hx₁ v₁, e₂.continuous_linear_equiv_at x hx₂ v₂⟩ :=
rfl

lemma prod_symm_apply (x : B) (w₁ : F₁) (w₂ : F₂) : (prod e₁ e₂).to_local_equiv.symm (x, w₁, w₂)
  = ⟨x, e₁.symm x w₁, e₂.symm x w₂⟩ :=
rfl

end trivialization

open trivialization

variables [Π x : B, topological_space (E₁ x)] [Π x : B, topological_space (E₂ x)]
  [topological_vector_bundle R F₁ E₁] [topological_vector_bundle R F₂ E₂]

/-- The product of two vector bundles is a vector bundle. -/
instance _root_.bundle.prod.topological_vector_bundle :
  topological_vector_bundle R (F₁ × F₂) (E₁ ×ᵇ E₂) :=
{ total_space_mk_inducing := λ b,
  begin
    rw (prod.inducing_diag E₁ E₂).inducing_iff,
    exact (total_space_mk_inducing R F₁ E₁ b).prod_mk (total_space_mk_inducing R F₂ E₂ b),
  end,
  trivialization_atlas := (λ (p : trivialization R F₁ E₁ × trivialization R F₂ E₂), p.1.prod p.2) ''
    (trivialization_atlas R F₁ E₁ ×ˢ trivialization_atlas R F₂ E₂),
  trivialization_at := λ b, (trivialization_at R F₁ E₁ b).prod (trivialization_at R F₂ E₂ b),
  mem_base_set_trivialization_at :=
    λ b, ⟨mem_base_set_trivialization_at R F₁ E₁ b, mem_base_set_trivialization_at R F₂ E₂ b⟩,
  trivialization_mem_atlas := λ b,
    ⟨(_, _), ⟨trivialization_mem_atlas R F₁ E₁ b, trivialization_mem_atlas R F₂ E₂ b⟩, rfl⟩,
  continuous_on_coord_change := begin
    rintros _ ⟨⟨e₁, e₂⟩, ⟨he₁, he₂⟩, rfl⟩ _ ⟨⟨e₁', e₂'⟩, ⟨he₁', he₂'⟩, rfl⟩,
    have := continuous_on_coord_change e₁ he₁ e₁' he₁',
    have := continuous_on_coord_change e₂ he₂ e₂' he₂',
    refine (((continuous_on_coord_change e₁ he₁ e₁' he₁').mono _).prod_mapL R
      ((continuous_on_coord_change e₂ he₂ e₂' he₂').mono _)).congr _;
    dsimp only [base_set_prod] with mfld_simps,
    { mfld_set_tac },
    { mfld_set_tac },
    { rintro b hb,
      rw [continuous_linear_map.ext_iff],
      rintro ⟨v₁, v₂⟩,
      show (e₁.prod e₂).coord_change (e₁'.prod e₂') b (v₁, v₂) =
        (e₁.coord_change e₁' b v₁, e₂.coord_change e₂' b v₂),
      rw [e₁.coord_change_apply e₁', e₂.coord_change_apply e₂', (e₁.prod e₂).coord_change_apply'],
      exacts [rfl, hb, ⟨hb.1.2, hb.2.2⟩, ⟨hb.1.1, hb.2.1⟩] }
  end }

variables {R F₁ E₁ F₂ E₂}

@[simp] lemma trivialization.continuous_linear_equiv_at_prod {e₁ : trivialization R F₁ E₁}
  {e₂ : trivialization R F₂ E₂} {x : B} (hx₁ : x ∈ e₁.base_set) (hx₂ : x ∈ e₂.base_set) :
  (e₁.prod e₂).continuous_linear_equiv_at x ⟨hx₁, hx₂⟩
  = (e₁.continuous_linear_equiv_at x hx₁).prod (e₂.continuous_linear_equiv_at x hx₂) :=
begin
  ext1,
  funext v,
  obtain ⟨v₁, v₂⟩ := v,
  rw [(e₁.prod e₂).continuous_linear_equiv_at_apply, trivialization.prod],
  exact (congr_arg prod.snd (prod_apply hx₁ hx₂ v₁ v₂) : _)
end

end topological_vector_bundle


<|start_filename|>src/analysis/sum_integral_comparisons.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import measure_theory.integral.interval_integral
import algebra.order.floor
import data.set.function
import analysis.special_functions.integrals

/-!
# Comparing sums and integrals

## Summary

It is often the case that error terms in analysis can be computed by comparing
an infinite sum to the improper integral of an antitone function. This file will eventually enable
that.

At the moment it contains four lemmas in this direction: `antitone_on.integral_le_sum`,
`antitone_on.sum_le_integral` and versions for monotone functions, which can all be paired
with a `filter.tendsto` to estimate some errors.

`TODO`: Add more lemmas to the API to directly address limiting issues

## Main Results

* `antitone_on.integral_le_sum`: The integral of an antitone function is at most the sum of its
  values at integer steps aligning with the left-hand side of the interval
* `antitone_on.sum_le_integral`: The sum of an antitone function along integer steps aligning with
  the right-hand side of the interval is at most the integral of the function along that interval
* `monotone_on.integral_le_sum`: The integral of a monotone function is at most the sum of its
  values at integer steps aligning with the right-hand side of the interval
* `monotone_on.sum_le_integral`: The sum of a monotone function along integer steps aligning with
  the left-hand side of the interval is at most the integral of the function along that interval

## Tags

analysis, comparison, asymptotics
-/

open set measure_theory.measure_space
open_locale big_operators

variables {x₀ : ℝ} {a b : ℕ} {f : ℝ → ℝ}

lemma antitone_on.integral_le_sum (hf : antitone_on f (Icc x₀ (x₀ + a))) :
  ∫ x in x₀..(x₀ + a), f x ≤ ∑ i in finset.range a, f (x₀ + i) :=
begin
  have hint : ∀ (k : ℕ), k < a → interval_integrable f volume (x₀+k) (x₀ + (k + 1 : ℕ)),
  { assume k hk,
    refine (hf.mono _).interval_integrable,
    rw interval_of_le,
    { apply Icc_subset_Icc,
      { simp only [le_add_iff_nonneg_right, nat.cast_nonneg] },
      { simp only [add_le_add_iff_left, nat.cast_le, nat.succ_le_of_lt hk] } },
    { simp only [add_le_add_iff_left, nat.cast_le, nat.le_succ] } },
  calc
  ∫ x in x₀..(x₀ + a), f x = ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1 : ℕ)), f x :
    begin
      convert (interval_integral.sum_integral_adjacent_intervals hint).symm,
      simp only [nat.cast_zero, add_zero],
    end
  ... ≤ ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1)), f (x₀ + i) :
    begin
      apply finset.sum_le_sum (λ i hi, _),
      have ia : i < a := finset.mem_range.1 hi,
      refine interval_integral.integral_mono_on (by simp) (hint _ ia) (by simp) (λ x hx, _),
      apply hf _ _ hx.1,
      { simp only [ia.le, mem_Icc, le_add_iff_nonneg_right, nat.cast_nonneg, add_le_add_iff_left,
          nat.cast_le, and_self] },
      { refine mem_Icc.2 ⟨le_trans (by simp) hx.1, le_trans hx.2 _⟩,
        simp only [add_le_add_iff_left, nat.cast_le, nat.succ_le_of_lt ia] },
    end
  ... = ∑ i in finset.range a, f (x₀ + i) : by simp
end

lemma antitone_on.integral_le_sum_Ico (hab : a ≤ b) (hf : antitone_on f (set.Icc a b)) :
  ∫ x in a..b, f x ≤ ∑ x in finset.Ico a b, f x :=
begin
  rw [(nat.sub_add_cancel hab).symm, nat.cast_add],
  conv { congr, congr, skip, skip, rw add_comm, skip, skip, congr, congr, rw ←zero_add a, },
  rw [← finset.sum_Ico_add, nat.Ico_zero_eq_range],
  conv { to_rhs, congr, skip, funext, rw nat.cast_add, },
  apply antitone_on.integral_le_sum,
  simp only [hf, hab, nat.cast_sub, add_sub_cancel'_right],
end

lemma antitone_on.sum_le_integral (hf : antitone_on f (Icc x₀ (x₀ + a))) :
  ∑ i in finset.range a, f (x₀ + (i + 1 : ℕ)) ≤ ∫ x in x₀..(x₀ + a), f x :=
begin
  have hint : ∀ (k : ℕ), k < a → interval_integrable f volume (x₀+k) (x₀ + (k + 1 : ℕ)),
  { assume k hk,
    refine (hf.mono _).interval_integrable,
    rw interval_of_le,
    { apply Icc_subset_Icc,
      { simp only [le_add_iff_nonneg_right, nat.cast_nonneg] },
      { simp only [add_le_add_iff_left, nat.cast_le, nat.succ_le_of_lt hk] } },
    { simp only [add_le_add_iff_left, nat.cast_le, nat.le_succ] } },
  calc ∑ i in finset.range a, f (x₀ + (i + 1 : ℕ))
      = ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1:ℕ)), f (x₀ + (i + 1 : ℕ)) : by simp
  ... ≤ ∑ i in finset.range a, ∫ x in (x₀+i)..(x₀+(i+1:ℕ)), f x :
    begin
      apply finset.sum_le_sum (λ i hi, _),
      have ia : i + 1 ≤ a := finset.mem_range.1 hi,
      refine interval_integral.integral_mono_on (by simp) (by simp) (hint _ ia) (λ x hx, _),
      apply hf _ _ hx.2,
      { refine mem_Icc.2 ⟨le_trans ((le_add_iff_nonneg_right _).2 (nat.cast_nonneg _)) hx.1,
          le_trans hx.2 _⟩,
        simp only [nat.cast_le, add_le_add_iff_left, ia] },
      { refine mem_Icc.2 ⟨(le_add_iff_nonneg_right _).2 (nat.cast_nonneg _), _⟩,
        simp only [add_le_add_iff_left, nat.cast_le, ia] },
    end
  ... = ∫ x in x₀..(x₀ + a), f x :
    begin
      convert interval_integral.sum_integral_adjacent_intervals hint,
      simp only [nat.cast_zero, add_zero],
    end
end

lemma antitone_on.sum_le_integral_Ico (hab : a ≤ b) (hf : antitone_on f (set.Icc a b)) :
  ∑ i in finset.Ico a b, f (i + 1 : ℕ) ≤ ∫ x in a..b, f x :=
begin
  rw [(nat.sub_add_cancel hab).symm, nat.cast_add],
  conv { congr, congr, congr, rw ← zero_add a, skip, skip, skip, rw add_comm, },
  rw [← finset.sum_Ico_add, nat.Ico_zero_eq_range],
  conv { to_lhs, congr, congr, skip, funext, rw [add_assoc, nat.cast_add], },
  apply antitone_on.sum_le_integral,
  simp only [hf, hab, nat.cast_sub, add_sub_cancel'_right],
end

lemma monotone_on.sum_le_integral (hf : monotone_on f (Icc x₀ (x₀ + a))) :
  ∑ i in finset.range a, f (x₀ + i) ≤ ∫ x in x₀..(x₀ + a), f x :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.integral_le_sum,
end

lemma monotone_on.sum_le_integral_Ico (hab : a ≤ b) (hf : monotone_on f (set.Icc a b)) :
  ∑ x in finset.Ico a b, f x ≤ ∫ x in a..b, f x :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.integral_le_sum_Ico hab,
end

lemma monotone_on.integral_le_sum (hf : monotone_on f (Icc x₀ (x₀ + a))) :
  ∫ x in x₀..(x₀ + a), f x ≤ ∑ i in finset.range a, f (x₀ + (i + 1 : ℕ)) :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.sum_le_integral,
end

lemma monotone_on.integral_le_sum_Ico (hab : a ≤ b) (hf : monotone_on f (set.Icc a b)) :
  ∫ x in a..b, f x ≤ ∑ i in finset.Ico a b, f (i + 1 : ℕ) :=
begin
  rw [← neg_le_neg_iff, ← finset.sum_neg_distrib, ← interval_integral.integral_neg],
  exact hf.neg.sum_le_integral_Ico hab,
end


<|start_filename|>src/algebra/group_power/lemmas.lean<|end_filename|>
/-
Copyright (c) 2015 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.invertible
import data.int.cast

/-!
# Lemmas about power operations on monoids and groups

This file contains lemmas about `monoid.pow`, `group.pow`, `nsmul`, `zsmul`
which require additional imports besides those available in `algebra.group_power.basic`.
-/

open function int nat

universes u v w x y z u₁ u₂

variables {α : Type*} {M : Type u} {N : Type v} {G : Type w} {H : Type x} {A : Type y} {B : Type z}
  {R : Type u₁} {S : Type u₂}

/-!
### (Additive) monoid
-/
section monoid
variables [monoid M] [monoid N] [add_monoid A] [add_monoid B]

@[simp] theorem nsmul_one [has_one A] : ∀ n : ℕ, n • (1 : A) = n :=
begin
  refine eq_nat_cast' (⟨_, _, _⟩ : ℕ →+ A) _,
  { simp [zero_nsmul] },
  { simp [add_nsmul] },
  { simp }
end

instance invertible_pow (m : M) [invertible m] (n : ℕ) : invertible (m ^ n) :=
{ inv_of := ⅟ m ^ n,
  inv_of_mul_self := by rw [← (commute_inv_of m).symm.mul_pow, inv_of_mul_self, one_pow],
  mul_inv_of_self := by rw [← (commute_inv_of m).mul_pow, mul_inv_of_self, one_pow] }

lemma inv_of_pow (m : M) [invertible m] (n : ℕ) [invertible (m ^ n)] :
  ⅟(m ^ n) = ⅟m ^ n :=
@invertible_unique M _ (m ^ n) (m ^ n) _ (invertible_pow m n) rfl

lemma is_unit.pow {m : M} (n : ℕ) : is_unit m → is_unit (m ^ n) :=
λ ⟨u, hu⟩, ⟨u ^ n, by simp *⟩

@[simp] lemma is_unit_pow_succ_iff {m : M} {n : ℕ} :
  is_unit (m ^ (n + 1)) ↔ is_unit m :=
begin
  refine ⟨_, λ h, h.pow _⟩,
  rw [pow_succ, ((commute.refl _).pow_right _).is_unit_mul_iff],
  exact and.left
end

lemma is_unit_pos_pow_iff {m : M} :
  ∀ {n : ℕ} (h : 0 < n), is_unit (m ^ n) ↔ is_unit m
| (n + 1) _ := is_unit_pow_succ_iff

/-- If `x ^ n.succ = 1` then `x` has an inverse, `x^n`. -/
def invertible_of_pow_succ_eq_one (x : M) (n : ℕ) (hx : x ^ n.succ = 1) :
  invertible x :=
⟨x ^ n, (pow_succ' x n).symm.trans hx, (pow_succ x n).symm.trans hx⟩

/-- If `x ^ n = 1` then `x` has an inverse, `x^(n - 1)`. -/
def invertible_of_pow_eq_one (x : M) (n : ℕ) (hx : x ^ n = 1) (hn : 0 < n) :
  invertible x :=
begin
  apply invertible_of_pow_succ_eq_one x (n - 1),
  convert hx,
  exact tsub_add_cancel_of_le (nat.succ_le_of_lt hn),
end

lemma is_unit_of_pow_eq_one (x : M) (n : ℕ) (hx : x ^ n = 1) (hn : 0 < n) :
  is_unit x :=
begin
  haveI := invertible_of_pow_eq_one x n hx hn,
  exact is_unit_of_invertible x
end

lemma smul_pow [mul_action M N] [is_scalar_tower M N N] [smul_comm_class M N N]
  (k : M) (x : N) (p : ℕ) :
  (k • x) ^ p = k ^ p • x ^ p :=
begin
  induction p with p IH,
  { simp },
  { rw [pow_succ', IH, smul_mul_smul, ←pow_succ', ←pow_succ'] }
end

@[simp] lemma smul_pow' [mul_distrib_mul_action M N] (x : M) (m : N) (n : ℕ) :
  x • m ^ n = (x • m) ^ n :=
begin
  induction n with n ih,
  { rw [pow_zero, pow_zero], exact smul_one x },
  { rw [pow_succ, pow_succ], exact (smul_mul' x m (m ^ n)).trans (congr_arg _ ih) }
end

end monoid

section sub_neg_monoid
variables [sub_neg_monoid A]

lemma zsmul_one [has_one A] (n : ℤ) : n • (1 : A) = n := by cases n; simp

end sub_neg_monoid

section division_monoid
variables [division_monoid α]

-- Note that `mul_zsmul` and `zpow_mul` have the primes swapped since their argument order,
-- and therefore the more "natural" choice of lemma, is reversed.
@[to_additive mul_zsmul'] lemma zpow_mul (a : α) : ∀ m n : ℤ, a ^ (m * n) = (a ^ m) ^ n
| (m : ℕ) (n : ℕ) := by { rw [zpow_coe_nat, zpow_coe_nat, ← pow_mul, ← zpow_coe_nat], refl }
| (m : ℕ) -[1+ n] := by { rw [zpow_coe_nat, zpow_neg_succ_of_nat, ← pow_mul, coe_nat_mul_neg_succ,
    zpow_neg, inv_inj, ← zpow_coe_nat], refl }
| -[1+ m] (n : ℕ) := by { rw [zpow_coe_nat, zpow_neg_succ_of_nat, ← inv_pow, ← pow_mul,
    neg_succ_mul_coe_nat, zpow_neg, inv_pow, inv_inj, ← zpow_coe_nat], refl }
| -[1+ m] -[1+ n] := by { rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat, neg_succ_mul_neg_succ,
    inv_pow, inv_inv, ← pow_mul, ← zpow_coe_nat], refl }

@[to_additive mul_zsmul] lemma zpow_mul' (a : α) (m n : ℤ) : a ^ (m * n) = (a ^ n) ^ m :=
by rw [mul_comm, zpow_mul]

@[to_additive bit0_zsmul] lemma zpow_bit0 (a : α) : ∀ n : ℤ, a ^ bit0 n = a ^ n * a ^ n
| (n : ℕ) := by simp only [zpow_coe_nat, ←int.coe_nat_bit0, pow_bit0]
| -[1+n]  := by { simp [←mul_inv_rev, ←pow_bit0], rw [neg_succ_of_nat_eq, bit0_neg, zpow_neg],
  norm_cast }

@[to_additive bit0_zsmul'] lemma zpow_bit0' (a : α) (n : ℤ) : a ^ bit0 n = (a * a) ^ n :=
(zpow_bit0 a n).trans ((commute.refl a).mul_zpow n).symm

@[simp] lemma zpow_bit0_neg [has_distrib_neg α] (x : α) (n : ℤ) : (-x) ^ (bit0 n) = x ^ bit0 n :=
by rw [zpow_bit0', zpow_bit0', neg_mul_neg]

end division_monoid

section group
variables [group G]

@[to_additive add_one_zsmul]
lemma zpow_add_one (a : G) : ∀ n : ℤ, a ^ (n + 1) = a ^ n * a
| (of_nat n) := by simp [← int.coe_nat_succ, pow_succ']
| -[1+n] := by rw [int.neg_succ_of_nat_eq, zpow_neg, neg_add, neg_add_cancel_right, zpow_neg,
  ← int.coe_nat_succ, zpow_coe_nat, zpow_coe_nat, pow_succ _ n, mul_inv_rev,
  inv_mul_cancel_right]

@[to_additive zsmul_sub_one]
lemma zpow_sub_one (a : G) (n : ℤ) : a ^ (n - 1) = a ^ n * a⁻¹ :=
calc a ^ (n - 1) = a ^ (n - 1) * a * a⁻¹ : (mul_inv_cancel_right _ _).symm
             ... = a^n * a⁻¹             : by rw [← zpow_add_one, sub_add_cancel]

@[to_additive add_zsmul]
lemma zpow_add (a : G) (m n : ℤ) : a ^ (m + n) = a ^ m * a ^ n :=
begin
  induction n using int.induction_on with n ihn n ihn,
  case hz : { simp },
  { simp only [← add_assoc, zpow_add_one, ihn, mul_assoc] },
  { rw [zpow_sub_one, ← mul_assoc, ← ihn, ← zpow_sub_one, add_sub_assoc] }
end

@[to_additive add_zsmul_self]
lemma mul_self_zpow (b : G) (m : ℤ) : b*b^m = b^(m+1) :=
by { conv_lhs {congr, rw ← zpow_one b }, rw [← zpow_add, add_comm] }

@[to_additive add_self_zsmul]
lemma mul_zpow_self (b : G) (m : ℤ) : b^m*b = b^(m+1) :=
by { conv_lhs {congr, skip, rw ← zpow_one b }, rw [← zpow_add, add_comm] }

@[to_additive sub_zsmul]
lemma zpow_sub (a : G) (m n : ℤ) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
by rw [sub_eq_add_neg, zpow_add, zpow_neg]

@[to_additive one_add_zsmul]
theorem zpow_one_add (a : G) (i : ℤ) : a ^ (1 + i) = a * a ^ i :=
by rw [zpow_add, zpow_one]

@[to_additive] lemma zpow_mul_comm (a : G) (i j : ℤ) : a ^ i * a ^ j = a ^ j * a ^ i :=
(commute.refl _).zpow_zpow _ _

@[to_additive bit1_zsmul]
theorem zpow_bit1 (a : G) (n : ℤ) : a ^ bit1 n = a ^ n * a ^ n * a :=
by rw [bit1, zpow_add, zpow_bit0, zpow_one]

end group

/-!
### `zpow`/`zsmul` and an order

Those lemmas are placed here (rather than in `algebra.group_power.order` with their friends) because
they require facts from `data.int.basic`.
-/

section ordered_add_comm_group
variables [ordered_comm_group α] {m n : ℤ} {a b : α}

@[to_additive zsmul_pos]
lemma one_lt_zpow' (ha : 1 < a) {k : ℤ} (hk : (0:ℤ) < k) : 1 < a^k :=
begin
  lift k to ℕ using int.le_of_lt hk,
  rw zpow_coe_nat,
  exact one_lt_pow' ha (coe_nat_pos.mp hk).ne',
end

@[to_additive zsmul_strict_mono_left]
lemma zpow_strict_mono_right (ha : 1 < a) : strict_mono (λ n : ℤ, a ^ n) :=
λ m n h,
  calc a ^ m = a ^ m * 1 : (mul_one _).symm
    ... < a ^ m * a ^ (n - m) : mul_lt_mul_left' (one_lt_zpow' ha $ sub_pos_of_lt h) _
    ... = a ^ n : by { rw ←zpow_add, simp }

@[to_additive zsmul_mono_left]
lemma zpow_mono_right (ha : 1 ≤ a) : monotone (λ n : ℤ, a ^ n) :=
λ m n h,
  calc a ^ m = a ^ m * 1 : (mul_one _).symm
    ... ≤ a ^ m * a ^ (n - m) : mul_le_mul_left' (one_le_zpow ha $ sub_nonneg_of_le h) _
    ... = a ^ n : by { rw ←zpow_add, simp }

@[to_additive]
lemma zpow_le_zpow (ha : 1 ≤ a) (h : m ≤ n) : a ^ m ≤ a ^ n := zpow_mono_right ha h

@[to_additive]
lemma zpow_lt_zpow (ha : 1 < a) (h : m < n) : a ^ m < a ^ n := zpow_strict_mono_right ha h

@[to_additive]
lemma zpow_le_zpow_iff (ha : 1 < a) : a ^ m ≤ a ^ n ↔ m ≤ n := (zpow_strict_mono_right ha).le_iff_le

@[to_additive]
lemma zpow_lt_zpow_iff (ha : 1 < a) : a ^ m < a ^ n ↔ m < n := (zpow_strict_mono_right ha).lt_iff_lt

variables (α)

@[to_additive zsmul_strict_mono_right]
lemma zpow_strict_mono_left (hn : 0 < n) : strict_mono ((^ n) : α → α) :=
λ a b hab, by { rw [←one_lt_div', ←div_zpow], exact one_lt_zpow' (one_lt_div'.2 hab) hn }

@[to_additive zsmul_mono_right]
lemma zpow_mono_left (hn : 0 ≤ n) : monotone ((^ n) : α → α) :=
λ a b hab, by { rw [←one_le_div', ←div_zpow], exact one_le_zpow (one_le_div'.2 hab) hn }

variables {α}

@[to_additive]
lemma zpow_le_zpow' (hn : 0 ≤ n) (h : a ≤ b) : a ^ n ≤ b ^ n := zpow_mono_left α hn h

@[to_additive]
lemma zpow_lt_zpow' (hn : 0 < n) (h : a < b) : a ^ n < b ^ n := zpow_strict_mono_left α hn h

end ordered_add_comm_group

section linear_ordered_comm_group
variables [linear_ordered_comm_group α] {n : ℤ} {a b : α}

@[to_additive]
lemma zpow_le_zpow_iff' (hn : 0 < n) {a b : α} : a ^ n ≤ b ^ n ↔ a ≤ b :=
(zpow_strict_mono_left α hn).le_iff_le

@[to_additive]
lemma zpow_lt_zpow_iff' (hn : 0 < n) {a b : α} : a ^ n < b ^ n ↔ a < b :=
(zpow_strict_mono_left α hn).lt_iff_lt

@[nolint to_additive_doc, to_additive zsmul_right_injective
"See also `smul_right_injective`. TODO: provide a `no_zero_smul_divisors` instance. We can't do that
here because importing that definition would create import cycles."]
lemma zpow_left_injective (hn : n ≠ 0) : function.injective ((^ n) : α → α) :=
begin
  cases hn.symm.lt_or_lt,
  { exact (zpow_strict_mono_left α h).injective },
  { refine λ a b (hab : a ^ n = b ^ n), (zpow_strict_mono_left α (neg_pos.mpr h)).injective _,
    rw [zpow_neg, zpow_neg, hab] }
end

@[to_additive zsmul_right_inj]
lemma zpow_left_inj (hn : n ≠ 0) : a ^ n = b ^ n ↔ a = b := (zpow_left_injective hn).eq_iff

/-- Alias of `zsmul_right_inj`, for ease of discovery alongside `zsmul_le_zsmul_iff'` and
`zsmul_lt_zsmul_iff'`. -/
@[to_additive "Alias of `zsmul_right_inj`, for ease of discovery alongside `zsmul_le_zsmul_iff'` and
`zsmul_lt_zsmul_iff'`."]
lemma zpow_eq_zpow_iff' (hn : n ≠ 0) : a ^ n = b ^ n ↔ a = b := zpow_left_inj hn

end linear_ordered_comm_group

section linear_ordered_add_comm_group
variables [linear_ordered_add_comm_group α] {a b : α}

lemma abs_nsmul (n : ℕ) (a : α) : |n • a| = n • |a| :=
begin
  cases le_total a 0 with hneg hpos,
  { rw [abs_of_nonpos hneg, ← abs_neg, ← neg_nsmul, abs_of_nonneg],
    exact nsmul_nonneg (neg_nonneg.mpr hneg) n },
  { rw [abs_of_nonneg hpos, abs_of_nonneg],
    exact nsmul_nonneg hpos n }
end

lemma abs_zsmul (n : ℤ) (a : α) : |n • a| = |n| • |a| :=
begin
  obtain n0 | n0 := le_total 0 n,
  { lift n to ℕ using n0,
    simp only [abs_nsmul, coe_nat_abs, coe_nat_zsmul] },
  { lift (- n) to ℕ using neg_nonneg.2 n0 with m h,
    rw [← abs_neg (n • a), ← neg_zsmul, ← abs_neg n, ← h, coe_nat_zsmul, coe_nat_abs,
      coe_nat_zsmul],
    exact abs_nsmul m _ },
end

lemma abs_add_eq_add_abs_le (hle : a ≤ b) : |a + b| = |a| + |b| ↔ 0 ≤ a ∧ 0 ≤ b ∨ a ≤ 0 ∧ b ≤ 0 :=
begin
  obtain a0 | a0 := le_or_lt 0 a; obtain b0 | b0 := le_or_lt 0 b,
  { simp [a0, b0, abs_of_nonneg, add_nonneg a0 b0] },
  { exact (lt_irrefl (0 : α) $ a0.trans_lt $ hle.trans_lt b0).elim },
  any_goals { simp [a0.le, b0.le, abs_of_nonpos, add_nonpos, add_comm] },
  have : (|a + b| = -a + b ↔ b ≤ 0) ↔ (|a + b| =
    |a| + |b| ↔ 0 ≤ a ∧ 0 ≤ b ∨ a ≤ 0 ∧ b ≤ 0),
  { simp [a0, a0.le, a0.not_le, b0, abs_of_neg, abs_of_nonneg] },
  refine this.mp ⟨λ h, _, λ h, by simp only [le_antisymm h b0, abs_of_neg a0, add_zero]⟩,
  obtain ab | ab := le_or_lt (a + b) 0,
  { refine le_of_eq (eq_zero_of_neg_eq _),
    rwa [abs_of_nonpos ab, neg_add_rev, add_comm, add_right_inj] at h },
  { refine (lt_irrefl (0 : α) _).elim,
    rw [abs_of_pos ab, add_left_inj] at h,
    rwa eq_zero_of_neg_eq h.symm at a0 }
end

lemma abs_add_eq_add_abs_iff (a b : α) : |a + b| = |a| + |b| ↔ 0 ≤ a ∧ 0 ≤ b ∨ a ≤ 0 ∧ b ≤ 0 :=
begin
  obtain ab | ab := le_total a b,
  { exact abs_add_eq_add_abs_le ab },
  { rw [add_comm a, add_comm (abs _), abs_add_eq_add_abs_le ab, and.comm, @and.comm (b ≤ 0)] }
end

end linear_ordered_add_comm_group

@[simp] lemma with_bot.coe_nsmul [add_monoid A] (a : A) (n : ℕ) :
  ((n • a : A) : with_bot A) = n • a :=
add_monoid_hom.map_nsmul ⟨(coe : A → with_bot A), with_bot.coe_zero, with_bot.coe_add⟩ a n

theorem nsmul_eq_mul' [non_assoc_semiring R] (a : R) (n : ℕ) : n • a = a * n :=
by induction n with n ih; [rw [zero_nsmul, nat.cast_zero, mul_zero],
  rw [succ_nsmul', ih, nat.cast_succ, mul_add, mul_one]]

@[simp] theorem nsmul_eq_mul [non_assoc_semiring R] (n : ℕ) (a : R) : n • a = n * a :=
by rw [nsmul_eq_mul', (n.cast_commute a).eq]

/-- Note that `add_comm_monoid.nat_smul_comm_class` requires stronger assumptions on `R`. -/
instance non_unital_non_assoc_semiring.nat_smul_comm_class [non_unital_non_assoc_semiring R] :
  smul_comm_class ℕ R R :=
⟨λ n x y, match n with
  | 0 := by simp_rw [zero_nsmul, smul_eq_mul, mul_zero]
  | (n + 1) := by simp_rw [succ_nsmul, smul_eq_mul, mul_add, ←smul_eq_mul, _match n]
  end⟩

/-- Note that `add_comm_monoid.nat_is_scalar_tower` requires stronger assumptions on `R`. -/
instance non_unital_non_assoc_semiring.nat_is_scalar_tower [non_unital_non_assoc_semiring R] :
  is_scalar_tower ℕ R R :=
⟨λ n x y, match n with
  | 0 := by simp_rw [zero_nsmul, smul_eq_mul, zero_mul]
  | (n + 1) := by simp_rw [succ_nsmul, ←_match n, smul_eq_mul, add_mul]
  end⟩

@[simp, norm_cast] theorem nat.cast_pow [semiring R] (n m : ℕ) : (↑(n ^ m) : R) = ↑n ^ m :=
begin
  induction m with m ih,
  { rw [pow_zero, pow_zero], exact nat.cast_one },
  { rw [pow_succ', pow_succ', nat.cast_mul, ih] }
end

@[simp, norm_cast] theorem int.coe_nat_pow (n m : ℕ) : ((n ^ m : ℕ) : ℤ) = n ^ m :=
by induction m with m ih; [exact int.coe_nat_one, rw [pow_succ', pow_succ', int.coe_nat_mul, ih]]

theorem int.nat_abs_pow (n : ℤ) (k : ℕ) : int.nat_abs (n ^ k) = (int.nat_abs n) ^ k :=
by induction k with k ih; [refl, rw [pow_succ', int.nat_abs_mul, pow_succ', ih]]

-- The next four lemmas allow us to replace multiplication by a numeral with a `zsmul` expression.
-- They are used by the `noncomm_ring` tactic, to normalise expressions before passing to `abel`.

lemma bit0_mul [non_unital_non_assoc_ring R] {n r : R} : bit0 n * r = (2 : ℤ) • (n * r) :=
by { dsimp [bit0], rw [add_mul, add_zsmul, one_zsmul], }

lemma mul_bit0 [non_unital_non_assoc_ring R] {n r : R} : r * bit0 n = (2 : ℤ) • (r * n) :=
by { dsimp [bit0], rw [mul_add, add_zsmul, one_zsmul], }

lemma bit1_mul [non_assoc_ring R] {n r : R} : bit1 n * r = (2 : ℤ) • (n * r) + r :=
by { dsimp [bit1], rw [add_mul, bit0_mul, one_mul], }

lemma mul_bit1 [non_assoc_ring R] {n r : R} : r * bit1 n = (2 : ℤ) • (r * n) + r :=
by { dsimp [bit1], rw [mul_add, mul_bit0, mul_one], }

@[simp] theorem zsmul_eq_mul [non_assoc_ring R] (a : R) : ∀ (n : ℤ), n • a = n * a
| (n : ℕ) := by { rw [coe_nat_zsmul, nsmul_eq_mul], refl }
| -[1+ n] := by simp [nat.cast_succ, neg_add_rev, int.cast_neg_succ_of_nat, add_mul]

theorem zsmul_eq_mul' [ring R] (a : R) (n : ℤ) : n • a = a * n :=
by rw [zsmul_eq_mul, (n.cast_commute a).eq]

/-- Note that `add_comm_group.int_smul_comm_class` requires stronger assumptions on `R`. -/
instance non_unital_non_assoc_ring.int_smul_comm_class [non_unital_non_assoc_ring R] :
  smul_comm_class ℤ R R :=
⟨λ n x y, match n with
  | (n : ℕ) := by simp_rw [coe_nat_zsmul, smul_comm]
  | -[1+n]  := by simp_rw [zsmul_neg_succ_of_nat, smul_eq_mul, mul_neg, mul_smul_comm]
  end⟩

/-- Note that `add_comm_group.int_is_scalar_tower` requires stronger assumptions on `R`. -/
instance non_unital_non_assoc_ring.int_is_scalar_tower [non_unital_non_assoc_ring R] :
  is_scalar_tower ℤ R R :=
⟨λ n x y, match n with
  | (n : ℕ) := by simp_rw [coe_nat_zsmul, smul_assoc]
  | -[1+n]  := by simp_rw [zsmul_neg_succ_of_nat, smul_eq_mul, neg_mul, smul_mul_assoc]
  end⟩

lemma zsmul_int_int (a b : ℤ) : a • b = a * b := by simp

lemma zsmul_int_one (n : ℤ) : n • 1 = n := by simp

@[simp, norm_cast] theorem int.cast_pow [ring R] (n : ℤ) (m : ℕ) : (↑(n ^ m) : R) = ↑n ^ m :=
begin
  induction m with m ih,
  { rw [pow_zero, pow_zero, int.cast_one] },
  { rw [pow_succ, pow_succ, int.cast_mul, ih] }
end

lemma neg_one_pow_eq_pow_mod_two [ring R] {n : ℕ} : (-1 : R) ^ n = (-1) ^ (n % 2) :=
by rw [← nat.mod_add_div n 2, pow_add, pow_mul]; simp [sq]

section ordered_semiring
variables [ordered_semiring R] {a : R}

/-- Bernoulli's inequality. This version works for semirings but requires
additional hypotheses `0 ≤ a * a` and `0 ≤ (1 + a) * (1 + a)`. -/
theorem one_add_mul_le_pow' (Hsq : 0 ≤ a * a) (Hsq' : 0 ≤ (1 + a) * (1 + a))
  (H : 0 ≤ 2 + a) :
  ∀ (n : ℕ), 1 + (n : R) * a ≤ (1 + a) ^ n
| 0     := by simp
| 1     := by simp
| (n+2) :=
have 0 ≤ (n : R) * (a * a * (2 + a)) + a * a,
  from add_nonneg (mul_nonneg n.cast_nonneg (mul_nonneg Hsq H)) Hsq,
calc 1 + (↑(n + 2) : R) * a ≤ 1 + ↑(n + 2) * a + (n * (a * a * (2 + a)) + a * a) :
  (le_add_iff_nonneg_right _).2 this
... = (1 + a) * (1 + a) * (1 + n * a) :
  by { simp [add_mul, mul_add, bit0, mul_assoc, (n.cast_commute (_ : R)).left_comm],
       ac_refl }
... ≤ (1 + a) * (1 + a) * (1 + a)^n :
  mul_le_mul_of_nonneg_left (one_add_mul_le_pow' n) Hsq'
... = (1 + a)^(n + 2) : by simp only [pow_succ, mul_assoc]

private lemma pow_le_pow_of_le_one_aux (h : 0 ≤ a) (ha : a ≤ 1) (i : ℕ) :
  ∀ k : ℕ, a ^ (i + k) ≤ a ^ i
| 0 := by simp
| (k+1) := by { rw [←add_assoc, ←one_mul (a^i), pow_succ],
                exact mul_le_mul ha (pow_le_pow_of_le_one_aux _) (pow_nonneg h _) zero_le_one }

lemma pow_le_pow_of_le_one (h : 0 ≤ a) (ha : a ≤ 1) {i j : ℕ} (hij : i ≤ j) :
  a ^ j ≤ a ^ i :=
let ⟨k, hk⟩ := nat.exists_eq_add_of_le hij in
by rw hk; exact pow_le_pow_of_le_one_aux h ha _ _

lemma pow_le_of_le_one (h₀ : 0 ≤ a) (h₁ : a ≤ 1) {n : ℕ} (hn : n ≠ 0) : a ^ n ≤ a :=
(pow_one a).subst (pow_le_pow_of_le_one h₀ h₁ (nat.pos_of_ne_zero hn))

lemma sq_le (h₀ : 0 ≤ a) (h₁ : a ≤ 1) : a ^ 2 ≤ a := pow_le_of_le_one h₀ h₁ two_ne_zero

end ordered_semiring

section linear_ordered_semiring

variables [linear_ordered_semiring R]

lemma sign_cases_of_C_mul_pow_nonneg {C r : R} (h : ∀ n : ℕ, 0 ≤ C * r ^ n) :
  C = 0 ∨ (0 < C ∧ 0 ≤ r) :=
begin
  have : 0 ≤ C, by simpa only [pow_zero, mul_one] using h 0,
  refine this.eq_or_lt.elim (λ h, or.inl h.symm) (λ hC, or.inr ⟨hC, _⟩),
  refine nonneg_of_mul_nonneg_left _ hC,
  simpa only [pow_one] using h 1
end

end linear_ordered_semiring

section linear_ordered_ring

variables [linear_ordered_ring R] {a : R} {n : ℕ}

@[simp] lemma abs_pow (a : R) (n : ℕ) : |a ^ n| = |a| ^ n :=
(pow_abs a n).symm

@[simp] theorem pow_bit1_neg_iff : a ^ bit1 n < 0 ↔ a < 0 :=
⟨λ h, not_le.1 $ λ h', not_le.2 h $ pow_nonneg h' _, λ ha, pow_bit1_neg ha n⟩

@[simp] theorem pow_bit1_nonneg_iff : 0 ≤ a ^ bit1 n ↔ 0 ≤ a :=
le_iff_le_iff_lt_iff_lt.2 pow_bit1_neg_iff

@[simp] theorem pow_bit1_nonpos_iff : a ^ bit1 n ≤ 0 ↔ a ≤ 0 :=
by simp only [le_iff_lt_or_eq, pow_bit1_neg_iff, pow_eq_zero_iff (bit1_pos (zero_le n))]

@[simp] theorem pow_bit1_pos_iff : 0 < a ^ bit1 n ↔ 0 < a :=
lt_iff_lt_of_le_iff_le pow_bit1_nonpos_iff

lemma strict_mono_pow_bit1 (n : ℕ) : strict_mono (λ a : R, a ^ bit1 n) :=
begin
  intros a b hab,
  cases le_total a 0 with ha ha,
  { cases le_or_lt b 0 with hb hb,
    { rw [← neg_lt_neg_iff, ← neg_pow_bit1, ← neg_pow_bit1],
      exact pow_lt_pow_of_lt_left (neg_lt_neg hab) (neg_nonneg.2 hb) (bit1_pos (zero_le n)) },
    { exact (pow_bit1_nonpos_iff.2 ha).trans_lt (pow_bit1_pos_iff.2 hb) } },
  { exact pow_lt_pow_of_lt_left hab ha (bit1_pos (zero_le n)) }
end

/-- Bernoulli's inequality for `n : ℕ`, `-2 ≤ a`. -/
theorem one_add_mul_le_pow (H : -2 ≤ a) (n : ℕ) : 1 + (n : R) * a ≤ (1 + a) ^ n :=
one_add_mul_le_pow' (mul_self_nonneg _) (mul_self_nonneg _) (neg_le_iff_add_nonneg'.1 H) _

/-- Bernoulli's inequality reformulated to estimate `a^n`. -/
theorem one_add_mul_sub_le_pow (H : -1 ≤ a) (n : ℕ) : 1 + (n : R) * (a - 1) ≤ a ^ n :=
have -2 ≤ a - 1, by rwa [bit0, neg_add, ← sub_eq_add_neg, sub_le_sub_iff_right],
by simpa only [add_sub_cancel'_right] using one_add_mul_le_pow this n

end linear_ordered_ring

/-- Bernoulli's inequality reformulated to estimate `(n : K)`. -/
theorem nat.cast_le_pow_sub_div_sub {K : Type*} [linear_ordered_field K] {a : K} (H : 1 < a)
  (n : ℕ) :
  (n : K) ≤ (a ^ n - 1) / (a - 1) :=
(le_div_iff (sub_pos.2 H)).2 $ le_sub_left_of_add_le $
  one_add_mul_sub_le_pow ((neg_le_self zero_le_one).trans H.le) _

/-- For any `a > 1` and a natural `n` we have `n ≤ a ^ n / (a - 1)`. See also
`nat.cast_le_pow_sub_div_sub` for a stronger inequality with `a ^ n - 1` in the numerator. -/
theorem nat.cast_le_pow_div_sub {K : Type*} [linear_ordered_field K] {a : K} (H : 1 < a) (n : ℕ) :
  (n : K) ≤ a ^ n / (a - 1) :=
(n.cast_le_pow_sub_div_sub H).trans $ div_le_div_of_le (sub_nonneg.2 H.le)
  (sub_le_self _ zero_le_one)

namespace int

alias int.units_sq ← int.units_pow_two

lemma units_pow_eq_pow_mod_two (u : ℤˣ) (n : ℕ) : u ^ n = u ^ (n % 2) :=
by conv {to_lhs, rw ← nat.mod_add_div n 2}; rw [pow_add, pow_mul, units_sq, one_pow, mul_one]

@[simp] lemma nat_abs_sq (x : ℤ) : (x.nat_abs ^ 2 : ℤ) = x ^ 2 :=
by rw [sq, int.nat_abs_mul_self', sq]

alias int.nat_abs_sq ← int.nat_abs_pow_two

lemma abs_le_self_sq (a : ℤ) : (int.nat_abs a : ℤ) ≤ a ^ 2 :=
by { rw [← int.nat_abs_sq a, sq], norm_cast, apply nat.le_mul_self }

alias int.abs_le_self_sq ← int.abs_le_self_pow_two

lemma le_self_sq (b : ℤ) : b ≤ b ^ 2 := le_trans (le_nat_abs) (abs_le_self_sq _)

alias int.le_self_sq ← int.le_self_pow_two

lemma pow_right_injective {x : ℤ} (h : 1 < x.nat_abs) : function.injective ((^) x : ℕ → ℤ) :=
begin
  suffices : function.injective (nat_abs ∘ ((^) x : ℕ → ℤ)),
  { exact function.injective.of_comp this },
  convert nat.pow_right_injective h,
  ext n,
  rw [function.comp_app, nat_abs_pow]
end

end int

variables (M G A)

/-- Monoid homomorphisms from `multiplicative ℕ` are defined by the image
of `multiplicative.of_add 1`. -/
def powers_hom [monoid M] : M ≃ (multiplicative ℕ →* M) :=
{ to_fun := λ x, ⟨λ n, x ^ n.to_add, by { convert pow_zero x, exact to_add_one },
    λ m n, pow_add x m n⟩,
  inv_fun := λ f, f (multiplicative.of_add 1),
  left_inv := pow_one,
  right_inv := λ f, monoid_hom.ext $ λ n, by { simp [← f.map_pow, ← of_add_nsmul] } }

/-- Monoid homomorphisms from `multiplicative ℤ` are defined by the image
of `multiplicative.of_add 1`. -/
def zpowers_hom [group G] : G ≃ (multiplicative ℤ →* G) :=
{ to_fun := λ x, ⟨λ n, x ^ n.to_add, zpow_zero x, λ m n, zpow_add x m n⟩,
  inv_fun := λ f, f (multiplicative.of_add 1),
  left_inv := zpow_one,
  right_inv := λ f, monoid_hom.ext $ λ n, by { simp [← f.map_zpow, ← of_add_zsmul ] } }

/-- Additive homomorphisms from `ℕ` are defined by the image of `1`. -/
def multiples_hom [add_monoid A] : A ≃ (ℕ →+ A) :=
{ to_fun := λ x, ⟨λ n, n • x, zero_nsmul x, λ m n, add_nsmul _ _ _⟩,
  inv_fun := λ f, f 1,
  left_inv := one_nsmul,
  right_inv := λ f, add_monoid_hom.ext_nat $ one_nsmul (f 1) }

/-- Additive homomorphisms from `ℤ` are defined by the image of `1`. -/
def zmultiples_hom [add_group A] : A ≃ (ℤ →+ A) :=
{ to_fun := λ x, ⟨λ n, n • x, zero_zsmul x, λ m n, add_zsmul _ _ _⟩,
  inv_fun := λ f, f 1,
  left_inv := one_zsmul,
  right_inv := λ f, add_monoid_hom.ext_int $ one_zsmul (f 1) }

attribute [to_additive multiples_hom] powers_hom
attribute [to_additive zmultiples_hom] zpowers_hom

variables {M G A}

@[simp] lemma powers_hom_apply [monoid M] (x : M) (n : multiplicative ℕ) :
  powers_hom M x n = x ^ n.to_add := rfl

@[simp] lemma powers_hom_symm_apply [monoid M] (f : multiplicative ℕ →* M) :
  (powers_hom M).symm f = f (multiplicative.of_add 1) := rfl

@[simp] lemma zpowers_hom_apply [group G] (x : G) (n : multiplicative ℤ) :
  zpowers_hom G x n = x ^ n.to_add := rfl

@[simp] lemma zpowers_hom_symm_apply [group G] (f : multiplicative ℤ →* G) :
  (zpowers_hom G).symm f = f (multiplicative.of_add 1) := rfl

@[simp] lemma multiples_hom_apply [add_monoid A] (x : A) (n : ℕ) :
  multiples_hom A x n = n • x := rfl

attribute [to_additive multiples_hom_apply] powers_hom_apply

@[simp] lemma multiples_hom_symm_apply [add_monoid A] (f : ℕ →+ A) :
  (multiples_hom A).symm f = f 1 := rfl

attribute [to_additive multiples_hom_symm_apply] powers_hom_symm_apply

@[simp] lemma zmultiples_hom_apply [add_group A] (x : A) (n : ℤ) :
  zmultiples_hom A x n = n • x := rfl

attribute [to_additive zmultiples_hom_apply] zpowers_hom_apply

@[simp] lemma zmultiples_hom_symm_apply [add_group A] (f : ℤ →+ A) :
  (zmultiples_hom A).symm f = f 1 := rfl

attribute [to_additive zmultiples_hom_symm_apply] zpowers_hom_symm_apply

-- TODO use to_additive in the rest of this file

lemma monoid_hom.apply_mnat [monoid M] (f : multiplicative ℕ →* M) (n : multiplicative ℕ) :
  f n = (f (multiplicative.of_add 1)) ^ n.to_add :=
by rw [← powers_hom_symm_apply, ← powers_hom_apply, equiv.apply_symm_apply]

@[ext] lemma monoid_hom.ext_mnat [monoid M] ⦃f g : multiplicative ℕ →* M⦄
  (h : f (multiplicative.of_add 1) = g (multiplicative.of_add 1)) : f = g :=
monoid_hom.ext $ λ n, by rw [f.apply_mnat, g.apply_mnat, h]

lemma monoid_hom.apply_mint [group M] (f : multiplicative ℤ →* M) (n : multiplicative ℤ) :
  f n = (f (multiplicative.of_add 1)) ^ n.to_add :=
by rw [← zpowers_hom_symm_apply, ← zpowers_hom_apply, equiv.apply_symm_apply]

/-! `monoid_hom.ext_mint` is defined in `data.int.cast` -/

lemma add_monoid_hom.apply_nat [add_monoid M] (f : ℕ →+ M) (n : ℕ) :
  f n = n • (f 1) :=
by rw [← multiples_hom_symm_apply, ← multiples_hom_apply, equiv.apply_symm_apply]

/-! `add_monoid_hom.ext_nat` is defined in `data.nat.cast` -/

lemma add_monoid_hom.apply_int [add_group M] (f : ℤ →+ M) (n : ℤ) :
  f n = n • (f 1) :=
by rw [← zmultiples_hom_symm_apply, ← zmultiples_hom_apply, equiv.apply_symm_apply]

/-! `add_monoid_hom.ext_int` is defined in `data.int.cast` -/

variables (M G A)

/-- If `M` is commutative, `powers_hom` is a multiplicative equivalence. -/
def powers_mul_hom [comm_monoid M] : M ≃* (multiplicative ℕ →* M) :=
{ map_mul' := λ a b, monoid_hom.ext $ by simp [mul_pow],
  ..powers_hom M}

/-- If `M` is commutative, `zpowers_hom` is a multiplicative equivalence. -/
def zpowers_mul_hom [comm_group G] : G ≃* (multiplicative ℤ →* G) :=
{ map_mul' := λ a b, monoid_hom.ext $ by simp [mul_zpow],
  ..zpowers_hom G}

/-- If `M` is commutative, `multiples_hom` is an additive equivalence. -/
def multiples_add_hom [add_comm_monoid A] : A ≃+ (ℕ →+ A) :=
{ map_add' := λ a b, add_monoid_hom.ext $ by simp [nsmul_add],
  ..multiples_hom A}

/-- If `M` is commutative, `zmultiples_hom` is an additive equivalence. -/
def zmultiples_add_hom [add_comm_group A] : A ≃+ (ℤ →+ A) :=
{ map_add' := λ a b, add_monoid_hom.ext $ by simp [zsmul_add],
  ..zmultiples_hom A}

variables {M G A}

@[simp] lemma powers_mul_hom_apply [comm_monoid M] (x : M) (n : multiplicative ℕ) :
  powers_mul_hom M x n = x ^ n.to_add := rfl

@[simp] lemma powers_mul_hom_symm_apply [comm_monoid M] (f : multiplicative ℕ →* M) :
  (powers_mul_hom M).symm f = f (multiplicative.of_add 1) := rfl

@[simp] lemma zpowers_mul_hom_apply [comm_group G] (x : G) (n : multiplicative ℤ) :
  zpowers_mul_hom G x n = x ^ n.to_add := rfl

@[simp] lemma zpowers_mul_hom_symm_apply [comm_group G] (f : multiplicative ℤ →* G) :
  (zpowers_mul_hom G).symm f = f (multiplicative.of_add 1) := rfl

@[simp] lemma multiples_add_hom_apply [add_comm_monoid A] (x : A) (n : ℕ) :
  multiples_add_hom A x n = n • x := rfl

@[simp] lemma multiples_add_hom_symm_apply [add_comm_monoid A] (f : ℕ →+ A) :
  (multiples_add_hom A).symm f = f 1 := rfl

@[simp] lemma zmultiples_add_hom_apply [add_comm_group A] (x : A) (n : ℤ) :
  zmultiples_add_hom A x n = n • x := rfl

@[simp] lemma zmultiples_add_hom_symm_apply [add_comm_group A] (f : ℤ →+ A) :
  (zmultiples_add_hom A).symm f = f 1 := rfl

/-!
### Commutativity (again)

Facts about `semiconj_by` and `commute` that require `zpow` or `zsmul`, or the fact that integer
multiplication equals semiring multiplication.
-/

namespace semiconj_by

section

variables [semiring R] {a x y : R}

@[simp] lemma cast_nat_mul_right (h : semiconj_by a x y) (n : ℕ) :
  semiconj_by a ((n : R) * x) (n * y) :=
semiconj_by.mul_right (nat.commute_cast _ _) h

@[simp] lemma cast_nat_mul_left (h : semiconj_by a x y) (n : ℕ) : semiconj_by ((n : R) * a) x y :=
semiconj_by.mul_left (nat.cast_commute _ _) h

@[simp] lemma cast_nat_mul_cast_nat_mul (h : semiconj_by a x y) (m n : ℕ) :
  semiconj_by ((m : R) * a) (n * x) (n * y) :=
(h.cast_nat_mul_left m).cast_nat_mul_right n

end

variables [monoid M] [group G] [ring R]

@[simp, to_additive] lemma units_zpow_right {a : M} {x y : Mˣ} (h : semiconj_by a x y) :
  ∀ m : ℤ, semiconj_by a (↑(x^m)) (↑(y^m))
| (n : ℕ) := by simp only [zpow_coe_nat, units.coe_pow, h, pow_right]
| -[1+n] := by simp only [zpow_neg_succ_of_nat, units.coe_pow, units_inv_right, h, pow_right]

variables {a b x y x' y' : R}

@[simp] lemma cast_int_mul_right (h : semiconj_by a x y) (m : ℤ) :
  semiconj_by a ((m : ℤ) * x) (m * y) :=
semiconj_by.mul_right (int.commute_cast _ _) h

@[simp] lemma cast_int_mul_left (h : semiconj_by a x y) (m : ℤ) : semiconj_by ((m : R) * a) x y :=
semiconj_by.mul_left (int.cast_commute _ _) h

@[simp] lemma cast_int_mul_cast_int_mul (h : semiconj_by a x y) (m n : ℤ) :
  semiconj_by ((m : R) * a) (n * x) (n * y) :=
(h.cast_int_mul_left m).cast_int_mul_right n

end semiconj_by

namespace commute

section

variables [semiring R] {a b : R}

@[simp] theorem cast_nat_mul_right (h : commute a b) (n : ℕ) : commute a ((n : R) * b) :=
h.cast_nat_mul_right n

@[simp] theorem cast_nat_mul_left (h : commute a b) (n : ℕ) : commute ((n : R) * a) b :=
h.cast_nat_mul_left n

@[simp] theorem cast_nat_mul_cast_nat_mul (h : commute a b) (m n : ℕ) :
  commute (m * a : R) (n * b : R) :=
h.cast_nat_mul_cast_nat_mul m n

@[simp] theorem self_cast_nat_mul (n : ℕ) : commute a (n * a : R) :=
(commute.refl a).cast_nat_mul_right n

@[simp] theorem cast_nat_mul_self (n : ℕ) : commute ((n : R) * a) a :=
(commute.refl a).cast_nat_mul_left n

@[simp] theorem self_cast_nat_mul_cast_nat_mul (m n : ℕ) : commute (m * a : R) (n * a : R) :=
(commute.refl a).cast_nat_mul_cast_nat_mul m n

end

variables [monoid M] [group G] [ring R]

@[simp, to_additive] lemma units_zpow_right {a : M} {u : Mˣ} (h : commute a u) (m : ℤ) :
  commute a (↑(u^m)) :=
h.units_zpow_right m

@[simp, to_additive] lemma units_zpow_left {u : Mˣ} {a : M} (h : commute ↑u a) (m : ℤ) :
  commute (↑(u^m)) a :=
(h.symm.units_zpow_right m).symm

variables {a b : R}

@[simp] lemma cast_int_mul_right (h : commute a b) (m : ℤ) : commute a (m * b : R) :=
h.cast_int_mul_right m

@[simp] lemma cast_int_mul_left (h : commute a b) (m : ℤ) : commute ((m : R) * a) b :=
h.cast_int_mul_left m

lemma cast_int_mul_cast_int_mul (h : commute a b) (m n : ℤ) : commute (m * a : R) (n * b : R) :=
h.cast_int_mul_cast_int_mul m n

variables (a) (m n : ℤ)

@[simp] lemma cast_int_left : commute (m : R) a :=
by { rw [← mul_one (m : R)], exact (one_left a).cast_int_mul_left m }

@[simp] lemma cast_int_right : commute a m :=
by { rw [← mul_one (m : R)], exact (one_right a).cast_int_mul_right m }

@[simp] theorem self_cast_int_mul : commute a (n * a : R) := (commute.refl a).cast_int_mul_right n

@[simp] theorem cast_int_mul_self : commute ((n : R) * a) a := (commute.refl a).cast_int_mul_left n

theorem self_cast_int_mul_cast_int_mul : commute (m * a : R) (n * a : R) :=
(commute.refl a).cast_int_mul_cast_int_mul m n

end commute

section multiplicative

open multiplicative

@[simp] lemma nat.to_add_pow (a : multiplicative ℕ) (b : ℕ) : to_add (a ^ b) = to_add a * b :=
begin
  induction b with b ih,
  { erw [pow_zero, to_add_one, mul_zero] },
  { simp [*, pow_succ, add_comm, nat.mul_succ] }
end

@[simp] lemma nat.of_add_mul (a b : ℕ) : of_add (a * b) = of_add a ^ b :=
(nat.to_add_pow _ _).symm

@[simp] lemma int.to_add_pow (a : multiplicative ℤ) (b : ℕ) : to_add (a ^ b) = to_add a * b :=
by induction b; simp [*, mul_add, pow_succ, add_comm]

@[simp] lemma int.to_add_zpow (a : multiplicative ℤ) (b : ℤ) : to_add (a ^ b) = to_add a * b :=
int.induction_on b (by simp)
  (by simp [zpow_add, mul_add] {contextual := tt})
  (by simp [zpow_add, mul_add, sub_eq_add_neg, -int.add_neg_one] {contextual := tt})

@[simp] lemma int.of_add_mul (a b : ℤ) : of_add (a * b) = of_add a ^ b :=
(int.to_add_zpow _ _).symm

end multiplicative

namespace units

variables [monoid M]

lemma conj_pow (u : Mˣ) (x : M) (n : ℕ) : (↑u * x * ↑(u⁻¹))^n = u * x^n * ↑(u⁻¹) :=
(divp_eq_iff_mul_eq.2 ((u.mk_semiconj_by x).pow_right n).eq.symm).symm

lemma conj_pow' (u : Mˣ) (x : M) (n : ℕ) : (↑(u⁻¹) * x * u)^n = ↑(u⁻¹) * x^n * u:=
(u⁻¹).conj_pow x n

end units

namespace mul_opposite

/-- Moving to the opposite monoid commutes with taking powers. -/
@[simp] lemma op_pow [monoid M] (x : M) (n : ℕ) : op (x ^ n) = (op x) ^ n := rfl
@[simp] lemma unop_pow [monoid M] (x : Mᵐᵒᵖ) (n : ℕ) : unop (x ^ n) = (unop x) ^ n := rfl

/-- Moving to the opposite group or group_with_zero commutes with taking powers. -/
@[simp] lemma op_zpow [div_inv_monoid M] (x : M) (z : ℤ) : op (x ^ z) = (op x) ^ z := rfl
@[simp] lemma unop_zpow [div_inv_monoid M] (x : Mᵐᵒᵖ) (z : ℤ) : unop (x ^ z) = (unop x) ^ z := rfl

end mul_opposite


<|start_filename|>src/number_theory/padics/padic_val.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.order.absolute_value
import algebra.field_power
import ring_theory.int.basic
import tactic.basic
import tactic.ring_exp
import number_theory.divisors
import data.nat.factorization.basic

/-!
# p-adic Valuation

This file defines the p-adic valuation on ℕ, ℤ, and ℚ.

The p-adic valuation on ℚ is the difference of the multiplicities of `p` in the numerator and
denominator of `q`. This function obeys the standard properties of a valuation, with the appropriate
assumptions on p. The p-adic valuations on ℕ and ℤ agree with that on ℚ.

The valuation induces a norm on ℚ. This norm is defined in padic_norm.lean.

## Notations

This file uses the local notation `/.` for `rat.mk`.

## Implementation notes

Much, but not all, of this file assumes that `p` is prime. This assumption is inferred automatically
by taking `[fact (prime p)]` as a type class argument.

## References

* [<NAME>, *p-adic numbers*][gouvea1997]
* [<NAME>, *A formal proof of Hensel's lemma over the p-adic integers*][lewis2019]
* <https://en.wikipedia.org/wiki/P-adic_number>

## Tags

p-adic, p adic, padic, norm, valuation
-/

universe u

open nat

open_locale rat

open multiplicity

/--
For `p ≠ 1`, the p-adic valuation of a natural `n ≠ 0` is the largest natural number `k` such that
p^k divides z.
If `n = 0` or `p = 1`, then `padic_val_nat p q` defaults to 0.
-/
def padic_val_nat (p : ℕ) (n : ℕ) : ℕ :=
if h : p ≠ 1 ∧ 0 < n
then (multiplicity p n).get (multiplicity.finite_nat_iff.2 h)
else 0

namespace padic_val_nat
open multiplicity
variables {p : ℕ}

/-- `padic_val_nat p 0` is 0 for any `p`. -/
@[simp] protected lemma zero : padic_val_nat p 0 = 0 :=
by simp [padic_val_nat]

/-- `padic_val_nat p 1` is 0 for any `p`. -/
@[simp] protected lemma one : padic_val_nat p 1 = 0 :=
by unfold padic_val_nat; split_ifs; simp *

/-- For `p ≠ 0, p ≠ 1, `padic_val_rat p p` is 1. -/
@[simp] lemma self (hp : 1 < p) : padic_val_nat p p = 1 :=
begin
  have neq_one : (¬ p = 1) ↔ true,
  { exact iff_of_true ((ne_of_lt hp).symm) trivial, },
  have eq_zero_false : (p = 0) ↔ false,
  { exact iff_false_intro ((ne_of_lt (trans zero_lt_one hp)).symm) },
  simp [padic_val_nat, neq_one, eq_zero_false],
end

lemma eq_zero_of_not_dvd {n : ℕ} (h : ¬ p ∣ n) : padic_val_nat p n = 0 :=
begin
  rw padic_val_nat,
  split_ifs,
  { simp [multiplicity_eq_zero_of_not_dvd h], },
  refl,
end

end padic_val_nat

/--
For `p ≠ 1`, the p-adic valuation of an integer `z ≠ 0` is the largest natural number `k` such that
p^k divides z.
If `x = 0` or `p = 1`, then `padic_val_int p q` defaults to 0.
-/
def padic_val_int (p : ℕ) (z : ℤ) : ℕ :=
padic_val_nat p (z.nat_abs)

namespace padic_val_int
open multiplicity
variables {p : ℕ}

lemma of_ne_one_ne_zero {z : ℤ} (hp : p ≠ 1) (hz : z ≠ 0) : padic_val_int p z =
  (multiplicity (p : ℤ) z).get (by {apply multiplicity.finite_int_iff.2, simp [hp, hz]}) :=
begin
  rw [padic_val_int, padic_val_nat, dif_pos (and.intro hp (int.nat_abs_pos_of_ne_zero hz))],
  simp_rw multiplicity.int.nat_abs p z,
  refl,
end

/-- `padic_val_int p 0` is 0 for any `p`. -/
@[simp] protected lemma zero : padic_val_int p 0 = 0 :=
by simp [padic_val_int]

/-- `padic_val_int p 1` is 0 for any `p`. -/
@[simp] protected lemma one : padic_val_int p 1 = 0 :=
by simp [padic_val_int]

/-- The p-adic value of an natural is its p-adic_value as an integer -/
@[simp] lemma of_nat {n : ℕ} : padic_val_int p (n : ℤ) = padic_val_nat p n :=
by simp [padic_val_int]

/-- For `p ≠ 0, p ≠ 1, `padic_val_int p p` is 1. -/
lemma self (hp : 1 < p) : padic_val_int p p = 1 :=
by simp [padic_val_nat.self hp]

lemma eq_zero_of_not_dvd {z : ℤ} (h : ¬ (p : ℤ) ∣ z) : padic_val_int p z = 0 :=
begin
  rw [padic_val_int, padic_val_nat],
  split_ifs,
  { simp_rw multiplicity.int.nat_abs,
    simp [multiplicity_eq_zero_of_not_dvd h], },
  refl,
end

end padic_val_int

/--
`padic_val_rat` defines the valuation of a rational `q` to be the valuation of `q.num` minus the
valuation of `q.denom`.
If `q = 0` or `p = 1`, then `padic_val_rat p q` defaults to 0.
-/
def padic_val_rat (p : ℕ) (q : ℚ) : ℤ :=
padic_val_int p q.num - padic_val_nat p q.denom

namespace padic_val_rat
open multiplicity
variables {p : ℕ}

/-- `padic_val_rat p q` is symmetric in `q`. -/
@[simp] protected lemma neg (q : ℚ) : padic_val_rat p (-q) = padic_val_rat p q :=
by simp [padic_val_rat, padic_val_int]

/-- `padic_val_rat p 0` is 0 for any `p`. -/
@[simp]
protected lemma zero (m : nat) : padic_val_rat m 0 = 0 := by simp [padic_val_rat, padic_val_int]

/-- `padic_val_rat p 1` is 0 for any `p`. -/
@[simp] protected lemma one : padic_val_rat p 1 = 0 := by simp [padic_val_rat, padic_val_int]

/-- The p-adic value of an integer `z ≠ 0` is its p-adic_value as a rational -/
@[simp] lemma of_int {z : ℤ} : padic_val_rat p (z : ℚ) = padic_val_int p z :=
by simp [padic_val_rat]

/-- The p-adic value of an integer `z ≠ 0` is the multiplicity of `p` in `z`. -/
lemma of_int_multiplicity (z : ℤ) (hp : p ≠ 1) (hz : z ≠ 0) :
  padic_val_rat p (z : ℚ) = (multiplicity (p : ℤ) z).get
    (finite_int_iff.2 ⟨hp, hz⟩) :=
by rw [of_int, padic_val_int.of_ne_one_ne_zero hp hz]

lemma multiplicity_sub_multiplicity {q : ℚ} (hp : p ≠ 1) (hq : q ≠ 0) :
  padic_val_rat p q =
  (multiplicity (p : ℤ) q.num).get (finite_int_iff.2 ⟨hp, rat.num_ne_zero_of_ne_zero hq⟩) -
  (multiplicity p q.denom).get
    (by { rw [←finite_iff_dom, finite_nat_iff, and_iff_right hp], exact q.pos }) :=
begin
  rw [padic_val_rat, padic_val_int.of_ne_one_ne_zero hp, padic_val_nat, dif_pos],
  { refl },
  { exact ⟨hp, q.pos⟩ },
  { exact rat.num_ne_zero_of_ne_zero hq },
end

/-- The p-adic value of an integer `z ≠ 0` is its p-adic_value as a rational -/
@[simp] lemma of_nat {n : ℕ} : padic_val_rat p (n : ℚ) = padic_val_nat p n :=
by simp [padic_val_rat, padic_val_int]

/-- For `p ≠ 0, p ≠ 1, `padic_val_rat p p` is 1. -/
lemma self (hp : 1 < p) : padic_val_rat p p = 1 := by simp [of_nat, hp]

end padic_val_rat

section padic_val_nat

lemma zero_le_padic_val_rat_of_nat (p n : ℕ) : 0 ≤ padic_val_rat p n := by simp

-- /-- `padic_val_rat` coincides with `padic_val_nat`. -/
@[norm_cast] lemma padic_val_rat_of_nat (p n : ℕ) :
  ↑(padic_val_nat p n) = padic_val_rat p n :=
by simp [padic_val_rat, padic_val_int]

/--
A simplification of `padic_val_nat` when one input is prime, by analogy with `padic_val_rat_def`.
-/
lemma padic_val_nat_def {p : ℕ} [hp : fact p.prime] {n : ℕ} (hn : 0 < n) :
  padic_val_nat p n =
  (multiplicity p n).get
    (multiplicity.finite_nat_iff.2 ⟨nat.prime.ne_one hp.1, hn⟩) :=
begin
  simp [padic_val_nat],
  split_ifs,
  { refl, },
  { exfalso,
    apply h ⟨(hp.out).ne_one, hn⟩, }
end

lemma padic_val_nat_def' {n p : ℕ} (hp : p ≠ 1) (hn : 0 < n) :
  ↑(padic_val_nat p n) = multiplicity p n :=
by simp [padic_val_nat, hp, hn]

@[simp] lemma padic_val_nat_self (p : ℕ) [fact p.prime] : padic_val_nat p p = 1 :=
by simp [padic_val_nat_def (fact.out p.prime).pos]

lemma one_le_padic_val_nat_of_dvd
  {n p : nat} [prime : fact p.prime] (n_pos : 0 < n) (div : p ∣ n) :
  1 ≤ padic_val_nat p n :=
begin
  rw @padic_val_nat_def _ prime _ n_pos,
  let one_le_mul : _ ≤ multiplicity p n :=
    @multiplicity.le_multiplicity_of_pow_dvd _ _ _ p n 1 (begin norm_num, exact div end),
  simp only [nat.cast_one] at one_le_mul,
  rcases one_le_mul with ⟨_, q⟩,
  dsimp at q,
  solve_by_elim,
end

end padic_val_nat

namespace padic_val_rat
open multiplicity
variables (p : ℕ) [p_prime : fact p.prime]
include p_prime

/-- The multiplicity of `p : ℕ` in `a : ℤ` is finite exactly when `a ≠ 0`. -/
lemma finite_int_prime_iff {p : ℕ} [p_prime : fact p.prime] {a : ℤ} : finite (p : ℤ) a ↔ a ≠ 0 :=
by simp [finite_int_iff, ne.symm (ne_of_lt (p_prime.1.one_lt))]

/-- A rewrite lemma for `padic_val_rat p q` when `q` is expressed in terms of `rat.mk`. -/
protected lemma defn {q : ℚ} {n d : ℤ} (hqz : q ≠ 0) (qdf : q = n /. d) :
  padic_val_rat p q = (multiplicity (p : ℤ) n).get (finite_int_iff.2
    ⟨ne.symm $ ne_of_lt p_prime.1.one_lt, λ hn, by simp * at *⟩) -
  (multiplicity (p : ℤ) d).get (finite_int_iff.2 ⟨ne.symm $ ne_of_lt p_prime.1.one_lt,
    λ hd, by simp * at *⟩) :=
have hd : d ≠ 0, from rat.mk_denom_ne_zero_of_ne_zero hqz qdf,
let ⟨c, hc1, hc2⟩ := rat.num_denom_mk hd qdf in
begin
  rw [padic_val_rat.multiplicity_sub_multiplicity];
  simp [hc1, hc2, multiplicity.mul' (nat.prime_iff_prime_int.1 p_prime.1),
    (ne.symm (ne_of_lt p_prime.1.one_lt)), hqz, pos_iff_ne_zero],
  simp_rw [int.coe_nat_multiplicity p q.denom],
end

/-- A rewrite lemma for `padic_val_rat p (q * r)` with conditions `q ≠ 0`, `r ≠ 0`. -/
protected lemma mul {q r : ℚ} (hq : q ≠ 0) (hr : r ≠ 0) :
  padic_val_rat p (q * r) = padic_val_rat p q + padic_val_rat p r :=
have q*r = (q.num * r.num) /. (↑q.denom * ↑r.denom), by rw_mod_cast rat.mul_num_denom,
have hq' : q.num /. q.denom ≠ 0, by rw rat.num_denom; exact hq,
have hr' : r.num /. r.denom ≠ 0, by rw rat.num_denom; exact hr,
have hp' : _root_.prime (p : ℤ), from nat.prime_iff_prime_int.1 p_prime.1,
begin
  rw [padic_val_rat.defn p (mul_ne_zero hq hr) this],
  conv_rhs { rw [←(@rat.num_denom q), padic_val_rat.defn p hq',
    ←(@rat.num_denom r), padic_val_rat.defn p hr'] },
  rw [multiplicity.mul' hp', multiplicity.mul' hp']; simp [add_comm, add_left_comm, sub_eq_add_neg]
end

/-- A rewrite lemma for `padic_val_rat p (q^k)` with condition `q ≠ 0`. -/
protected lemma pow {q : ℚ} (hq : q ≠ 0) {k : ℕ} :
    padic_val_rat p (q ^ k) = k * padic_val_rat p q :=
by induction k; simp [*, padic_val_rat.mul _ hq (pow_ne_zero _ hq),
  pow_succ, add_mul, add_comm]

/--
A rewrite lemma for `padic_val_rat p (q⁻¹)` with condition `q ≠ 0`.
-/
protected lemma inv (q : ℚ) :
  padic_val_rat p (q⁻¹) = -padic_val_rat p q :=
begin
  by_cases hq : q = 0,
  { simp [hq], },
  { rw [eq_neg_iff_add_eq_zero, ← padic_val_rat.mul p (inv_ne_zero hq) hq,
      inv_mul_cancel hq, padic_val_rat.one] },
end

/-- A rewrite lemma for `padic_val_rat p (q / r)` with conditions `q ≠ 0`, `r ≠ 0`. -/
protected lemma div {q r : ℚ} (hq : q ≠ 0) (hr : r ≠ 0) :
  padic_val_rat p (q / r) = padic_val_rat p q - padic_val_rat p r :=
by rw [div_eq_mul_inv, padic_val_rat.mul p hq (inv_ne_zero hr),
    padic_val_rat.inv p r, sub_eq_add_neg]

/--
A condition for `padic_val_rat p (n₁ / d₁) ≤ padic_val_rat p (n₂ / d₂),
in terms of divisibility by `p^n`.
-/
lemma padic_val_rat_le_padic_val_rat_iff {n₁ n₂ d₁ d₂ : ℤ}
  (hn₁ : n₁ ≠ 0) (hn₂ : n₂ ≠ 0) (hd₁ : d₁ ≠ 0) (hd₂ : d₂ ≠ 0) :
  padic_val_rat p (n₁ /. d₁) ≤ padic_val_rat p (n₂ /. d₂) ↔
  ∀ (n : ℕ), ↑p ^ n ∣ n₁ * d₂ → ↑p ^ n ∣ n₂ * d₁ :=
have hf1 : finite (p : ℤ) (n₁ * d₂),
  from finite_int_prime_iff.2 (mul_ne_zero hn₁ hd₂),
have hf2 : finite (p : ℤ) (n₂ * d₁),
  from finite_int_prime_iff.2 (mul_ne_zero hn₂ hd₁),
  by conv
  { to_lhs,
    rw [padic_val_rat.defn p (rat.mk_ne_zero_of_ne_zero hn₁ hd₁) rfl,
      padic_val_rat.defn p (rat.mk_ne_zero_of_ne_zero hn₂ hd₂) rfl,
      sub_le_iff_le_add',
      ← add_sub_assoc,
      le_sub_iff_add_le],
    norm_cast,
    rw [← multiplicity.mul' (nat.prime_iff_prime_int.1 p_prime.1) hf1, add_comm,
      ← multiplicity.mul' (nat.prime_iff_prime_int.1 p_prime.1) hf2,
      enat.get_le_get, multiplicity_le_multiplicity_iff] }

/--
Sufficient conditions to show that the p-adic valuation of `q` is less than or equal to the
p-adic vlauation of `q + r`.
-/
theorem le_padic_val_rat_add_of_le {q r : ℚ}
  (hqr : q + r ≠ 0)
  (h : padic_val_rat p q ≤ padic_val_rat p r) :
  padic_val_rat p q ≤ padic_val_rat p (q + r) :=
if hq : q = 0 then by simpa [hq] using h else
if hr : r = 0 then by simp [hr] else
have hqn : q.num ≠ 0, from rat.num_ne_zero_of_ne_zero hq,
have hqd : (q.denom : ℤ) ≠ 0, by exact_mod_cast rat.denom_ne_zero _,
have hrn : r.num ≠ 0, from rat.num_ne_zero_of_ne_zero hr,
have hrd : (r.denom : ℤ) ≠ 0, by exact_mod_cast rat.denom_ne_zero _,
have hqreq : q + r = (((q.num * r.denom + q.denom * r.num : ℤ)) /. (↑q.denom * ↑r.denom : ℤ)),
  from rat.add_num_denom _ _,
have hqrd : q.num * ↑(r.denom) + ↑(q.denom) * r.num ≠ 0,
  from rat.mk_num_ne_zero_of_ne_zero hqr hqreq,
begin
  conv_lhs { rw ←(@rat.num_denom q) },
  rw [hqreq, padic_val_rat_le_padic_val_rat_iff p hqn hqrd hqd (mul_ne_zero hqd hrd),
    ← multiplicity_le_multiplicity_iff, mul_left_comm,
    multiplicity.mul (nat.prime_iff_prime_int.1 p_prime.1), add_mul],
  rw [←(@rat.num_denom q), ←(@rat.num_denom r),
    padic_val_rat_le_padic_val_rat_iff p hqn hrn hqd hrd, ← multiplicity_le_multiplicity_iff] at h,
  calc _ ≤ min (multiplicity ↑p (q.num * ↑(r.denom) * ↑(q.denom)))
    (multiplicity ↑p (↑(q.denom) * r.num * ↑(q.denom))) : (le_min
    (by rw [@multiplicity.mul _ _ _ _ (_ * _) _ (nat.prime_iff_prime_int.1 p_prime.1), add_comm])
    (by rw [mul_assoc, @multiplicity.mul _ _ _ _ (q.denom : ℤ)
        (_ * _) (nat.prime_iff_prime_int.1 p_prime.1)];
      exact add_le_add_left h _))
    ... ≤ _ : min_le_multiplicity_add
end

/--
The minimum of the valuations of `q` and `r` is less than or equal to the valuation of `q + r`.
-/
theorem min_le_padic_val_rat_add {q r : ℚ} (hqr : q + r ≠ 0) :
  min (padic_val_rat p q) (padic_val_rat p r) ≤ padic_val_rat p (q + r) :=
(le_total (padic_val_rat p q) (padic_val_rat p r)).elim
  (λ h, by rw [min_eq_left h]; exact le_padic_val_rat_add_of_le _ hqr h)
  (λ h, by rw [min_eq_right h, add_comm]; exact le_padic_val_rat_add_of_le _
    (by rwa add_comm) h)

open_locale big_operators

/-- A finite sum of rationals with positive p-adic valuation has positive p-adic valuation
  (if the sum is non-zero). -/
theorem sum_pos_of_pos {n : ℕ} {F : ℕ → ℚ}
  (hF : ∀ i, i < n → 0 < padic_val_rat p (F i)) (hn0 : ∑ i in finset.range n, F i ≠ 0) :
  0 < padic_val_rat p (∑ i in finset.range n, F i) :=
begin
  induction n with d hd,
  { exact false.elim (hn0 rfl) },
  { rw finset.sum_range_succ at hn0 ⊢,
    by_cases h : ∑ (x : ℕ) in finset.range d, F x = 0,
    { rw [h, zero_add],
      exact hF d (lt_add_one _) },
    { refine lt_of_lt_of_le _ (min_le_padic_val_rat_add p hn0),
      { refine lt_min (hd (λ i hi, _) h) (hF d (lt_add_one _)),
        exact hF _ (lt_trans hi (lt_add_one _)) }, } }
end

end padic_val_rat

namespace padic_val_nat

/-- A rewrite lemma for `padic_val_nat p (q * r)` with conditions `q ≠ 0`, `r ≠ 0`. -/
protected lemma mul (p : ℕ) [p_prime : fact p.prime] {q r : ℕ} (hq : q ≠ 0) (hr : r ≠ 0) :
  padic_val_nat p (q * r) = padic_val_nat p q + padic_val_nat p r :=
begin
  apply int.coe_nat_inj,
  simp only [padic_val_rat_of_nat, nat.cast_mul],
  rw padic_val_rat.mul,
  norm_cast,
  exact cast_ne_zero.mpr hq,
  exact cast_ne_zero.mpr hr,
end

protected lemma div_of_dvd (p : ℕ) [hp : fact p.prime] {a b : ℕ} (h : b ∣ a) :
  padic_val_nat p (a / b) = padic_val_nat p a - padic_val_nat p b :=
begin
  rcases eq_or_ne a 0 with rfl | ha,
  { simp },
  obtain ⟨k, rfl⟩ := h,
  obtain ⟨hb, hk⟩ := mul_ne_zero_iff.mp ha,
  rw [mul_comm, k.mul_div_cancel hb.bot_lt, padic_val_nat.mul p hk hb, nat.add_sub_cancel]
end

/-- Dividing out by a prime factor reduces the padic_val_nat by 1. -/
protected lemma div {p : ℕ} [p_prime : fact p.prime] {b : ℕ} (dvd : p ∣ b) :
  (padic_val_nat p (b / p)) = (padic_val_nat p b) - 1 :=
begin
  convert padic_val_nat.div_of_dvd p dvd,
  rw padic_val_nat_self p
end

/-- A version of `padic_val_rat.pow` for `padic_val_nat` -/
protected lemma pow (p q n : ℕ) [fact p.prime] (hq : q ≠ 0) :
  padic_val_nat p (q ^ n) = n * padic_val_nat p q :=
begin
  apply @nat.cast_injective ℤ,
  push_cast,
  exact padic_val_rat.pow _ (cast_ne_zero.mpr hq),
end

@[simp] protected lemma prime_pow (p n : ℕ) [fact p.prime] : padic_val_nat p (p ^ n) = n :=
by rw [padic_val_nat.pow p _ _ (fact.out p.prime).ne_zero, padic_val_nat_self p, mul_one]

protected lemma div_pow {p : ℕ} [p_prime : fact p.prime] {b k : ℕ} (dvd : p ^ k ∣ b) :
  (padic_val_nat p (b / p ^ k)) = (padic_val_nat p b) - k :=
begin
  convert padic_val_nat.div_of_dvd p dvd,
  rw padic_val_nat.prime_pow
end

end padic_val_nat

section padic_val_nat

lemma dvd_of_one_le_padic_val_nat {n p : nat} (hp : 1 ≤ padic_val_nat p n) :
  p ∣ n :=
begin
  by_contra h,
  rw padic_val_nat.eq_zero_of_not_dvd h at hp,
  exact lt_irrefl 0 (lt_of_lt_of_le zero_lt_one hp),
end

lemma pow_padic_val_nat_dvd {p n : ℕ} : p ^ (padic_val_nat p n) ∣ n :=
begin
  rcases n.eq_zero_or_pos with rfl | hn, { simp },
  rcases eq_or_ne p 1 with rfl | hp, { simp },
  rw [multiplicity.pow_dvd_iff_le_multiplicity, padic_val_nat_def']; assumption,
end

lemma pow_succ_padic_val_nat_not_dvd {p n : ℕ} [hp : fact (nat.prime p)] (hn : 0 < n) :
  ¬ p ^ (padic_val_nat p n + 1) ∣ n :=
begin
  rw multiplicity.pow_dvd_iff_le_multiplicity,
  rw padic_val_nat_def hn,
  { rw [nat.cast_add, enat.coe_get],
    simp only [nat.cast_one, not_le],
    exact enat.lt_add_one (ne_top_iff_finite.mpr
      (finite_nat_iff.mpr ⟨(fact.elim hp).ne_one, hn⟩)), },
  { apply_instance }
end

lemma padic_val_nat_dvd_iff (p : ℕ) [hp :fact p.prime] (n : ℕ) (a : ℕ) :
  p^n ∣ a ↔ a = 0 ∨ n ≤ padic_val_nat p a :=
begin
  split,
  { rw [pow_dvd_iff_le_multiplicity, padic_val_nat],
    split_ifs,
    { rw enat.coe_le_iff,
      exact λ hn, or.inr (hn _) },
    { simp only [true_and, not_lt, ne.def, not_false_iff, nat.le_zero_iff, hp.out.ne_one] at h,
      exact λ hn, or.inl h } },
  { rintro (rfl|h),
    { exact dvd_zero (p ^ n) },
    { exact dvd_trans (pow_dvd_pow p h) pow_padic_val_nat_dvd } },
end

lemma padic_val_nat_primes {p q : ℕ} [p_prime : fact p.prime] [q_prime : fact q.prime]
  (neq : p ≠ q) : padic_val_nat p q = 0 :=
@padic_val_nat.eq_zero_of_not_dvd p q $
(not_congr (iff.symm (prime_dvd_prime_iff_eq p_prime.1 q_prime.1))).mp neq

protected lemma padic_val_nat.div' {p : ℕ} [p_prime : fact p.prime] :
  ∀ {m : ℕ} (cpm : coprime p m) {b : ℕ} (dvd : m ∣ b), padic_val_nat p (b / m) = padic_val_nat p b
| 0 := λ cpm b dvd, by { rw zero_dvd_iff at dvd, rw [dvd, nat.zero_div], }
| (n + 1) :=
  λ cpm b dvd,
  begin
    rcases dvd with ⟨c, rfl⟩,
    rw [mul_div_right c (nat.succ_pos _)],by_cases hc : c = 0,
    { rw [hc, mul_zero] },
    { rw padic_val_nat.mul,
      { suffices : ¬ p ∣ (n+1),
        { rw [padic_val_nat.eq_zero_of_not_dvd this, zero_add] },
        contrapose! cpm,
        exact p_prime.1.dvd_iff_not_coprime.mp cpm },
      { exact nat.succ_ne_zero _ },
      { exact hc } },
  end

lemma padic_val_nat_eq_factorization (p n : ℕ) [hp : fact p.prime] :
  padic_val_nat p n = n.factorization p :=
begin
  by_cases hn : n = 0, { subst hn, simp },
  rw @padic_val_nat_def p _ n (nat.pos_of_ne_zero hn),
  simp [@multiplicity_eq_factorization n p hp.elim hn],
end

open_locale big_operators

lemma prod_pow_prime_padic_val_nat (n : nat) (hn : n ≠ 0) (m : nat) (pr : n < m) :
  ∏ p in finset.filter nat.prime (finset.range m), p ^ (padic_val_nat p n) = n :=
begin
  nth_rewrite_rhs 0 ←factorization_prod_pow_eq_self hn,
  rw eq_comm,
  apply finset.prod_subset_one_on_sdiff,
  { exact λ p hp, finset.mem_filter.mpr
      ⟨finset.mem_range.mpr (gt_of_gt_of_ge pr (le_of_mem_factorization hp)),
       prime_of_mem_factorization hp⟩ },
  { intros p hp,
    cases finset.mem_sdiff.mp hp with hp1 hp2,
    haveI := fact_iff.mpr (finset.mem_filter.mp hp1).2,
    rw padic_val_nat_eq_factorization p n,
    simp [finsupp.not_mem_support_iff.mp hp2] },
  { intros p hp,
    haveI := fact_iff.mpr (prime_of_mem_factorization hp),
    simp [padic_val_nat_eq_factorization] }
end

lemma range_pow_padic_val_nat_subset_divisors {n : ℕ} (p : ℕ) (hn : n ≠ 0) :
  (finset.range (padic_val_nat p n + 1)).image (pow p) ⊆ n.divisors :=
begin
  intros t ht,
  simp only [exists_prop, finset.mem_image, finset.mem_range] at ht,
  obtain ⟨k, hk, rfl⟩ := ht,
  rw nat.mem_divisors,
  exact ⟨(pow_dvd_pow p $ by linarith).trans pow_padic_val_nat_dvd, hn⟩
end

lemma range_pow_padic_val_nat_subset_divisors' {n : ℕ} (p : ℕ) [h : fact p.prime] :
  (finset.range (padic_val_nat p n)).image (λ t, p ^ (t + 1)) ⊆ (n.divisors \ {1}) :=
begin
  rcases eq_or_ne n 0 with rfl | hn,
  { simp },
  intros t ht,
  simp only [exists_prop, finset.mem_image, finset.mem_range] at ht,
  obtain ⟨k, hk, rfl⟩ := ht,
  rw [finset.mem_sdiff, nat.mem_divisors],
  refine ⟨⟨(pow_dvd_pow p $ by linarith).trans pow_padic_val_nat_dvd, hn⟩, _⟩,
  rw [finset.mem_singleton],
  nth_rewrite 1 ←one_pow (k + 1),
  exact (nat.pow_lt_pow_of_lt_left h.1.one_lt $ nat.succ_pos k).ne',
end

end padic_val_nat

section padic_val_int
variables (p : ℕ) [p_prime : fact p.prime]

lemma padic_val_int_dvd_iff (p : ℕ) [fact p.prime] (n : ℕ) (a : ℤ) :
  ↑p^n ∣ a ↔ a = 0 ∨ n ≤ padic_val_int p a :=
by rw [padic_val_int, ←int.nat_abs_eq_zero, ←padic_val_nat_dvd_iff, ←int.coe_nat_dvd_left,
       int.coe_nat_pow]

lemma padic_val_int_dvd (p : ℕ) [fact p.prime] (a : ℤ) : ↑p^(padic_val_int p a) ∣ a :=
begin
  rw padic_val_int_dvd_iff,
  exact or.inr le_rfl,
end

lemma padic_val_int_self (p : ℕ) [pp : fact p.prime] : padic_val_int p p = 1 :=
padic_val_int.self pp.out.one_lt

lemma padic_val_int.mul (p : ℕ) [fact p.prime] {a b : ℤ} (ha : a ≠ 0) (hb : b ≠ 0) :
  padic_val_int p (a*b) = padic_val_int p a + padic_val_int p b :=
begin
  simp_rw padic_val_int,
  rw [int.nat_abs_mul, padic_val_nat.mul];
  rwa int.nat_abs_ne_zero,
end

lemma padic_val_int_mul_eq_succ (p : ℕ) [pp : fact p.prime] (a : ℤ) (ha : a ≠ 0) :
  padic_val_int p (a * p) = (padic_val_int p a) + 1 :=
begin
  rw padic_val_int.mul p ha (int.coe_nat_ne_zero.mpr (pp.out).ne_zero),
  simp only [eq_self_iff_true, padic_val_int.of_nat, padic_val_nat_self],
end

end padic_val_int


<|start_filename|>src/ring_theory/valuation/integers.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import ring_theory.valuation.basic

/-!
# Ring of integers under a given valuation

The elements with valuation less than or equal to 1.

TODO: Define characteristic predicate.
-/

universes u v w

namespace valuation

section ring

variables {R : Type u} {Γ₀ : Type v} [ring R] [linear_ordered_comm_group_with_zero Γ₀]
variables (v : valuation R Γ₀)

/-- The ring of integers under a given valuation is the subring of elements with valuation ≤ 1. -/
def integer : subring R :=
{ carrier := { x | v x ≤ 1 },
  one_mem' := le_of_eq v.map_one,
  mul_mem' := λ x y hx hy, trans_rel_right (≤) (v.map_mul x y) (mul_le_one' hx hy),
  zero_mem' := trans_rel_right (≤) v.map_zero zero_le_one,
  add_mem' := λ x y hx hy, le_trans (v.map_add x y) (max_le hx hy),
  neg_mem' := λ x hx, trans_rel_right (≤) (v.map_neg x) hx }

end ring

section comm_ring

variables {R : Type u} {Γ₀ : Type v} [comm_ring R] [linear_ordered_comm_group_with_zero Γ₀]
variables (v : valuation R Γ₀)
variables (O : Type w) [comm_ring O] [algebra O R]

/-- Given a valuation v : R → Γ₀ and a ring homomorphism O →+* R, we say that O is the integers of v
if f is injective, and its range is exactly `v.integer`. -/
structure integers : Prop :=
(hom_inj : function.injective (algebra_map O R))
(map_le_one : ∀ x, v (algebra_map O R x) ≤ 1)
(exists_of_le_one : ∀ ⦃r⦄, v r ≤ 1 → ∃ x, algebra_map O R x = r)

-- typeclass shortcut
instance : algebra v.integer R :=
algebra.of_subring v.integer

theorem integer.integers : v.integers v.integer :=
{ hom_inj := subtype.coe_injective,
  map_le_one := λ r, r.2,
  exists_of_le_one := λ r hr, ⟨⟨r, hr⟩, rfl⟩ }

namespace integers

variables {v O} (hv : integers v O)
include hv

lemma one_of_is_unit {x : O} (hx : is_unit x) : v (algebra_map O R x) = 1 :=
let ⟨u, hu⟩ := hx in le_antisymm (hv.2 _) $
by { rw [← v.map_one, ← (algebra_map O R).map_one, ← u.mul_inv, ← mul_one (v (algebra_map O R x)),
  hu, (algebra_map O R).map_mul, v.map_mul], exact mul_le_mul_left' (hv.2 (u⁻¹ : units O)) _ }

lemma is_unit_of_one {x : O} (hx : is_unit (algebra_map O R x)) (hvx : v (algebra_map O R x) = 1) :
  is_unit x :=
let ⟨u, hu⟩ := hx in
have h1 : v u ≤ 1, from hu.symm ▸ hv.2 x,
have h2 : v (u⁻¹ : Rˣ) ≤ 1,
  by rw [← one_mul (v _), ← hvx, ← v.map_mul, ← hu, u.mul_inv, hu, hvx, v.map_one],
let ⟨r1, hr1⟩ := hv.3 h1, ⟨r2, hr2⟩ := hv.3 h2 in
⟨⟨r1, r2, hv.1 $ by rw [ring_hom.map_mul, ring_hom.map_one, hr1, hr2, units.mul_inv],
  hv.1 $ by rw [ring_hom.map_mul, ring_hom.map_one, hr1, hr2, units.inv_mul]⟩,
hv.1 $ hr1.trans hu⟩

lemma le_of_dvd {x y : O} (h : x ∣ y) : v (algebra_map O R y) ≤ v (algebra_map O R x) :=
let ⟨z, hz⟩ := h in by { rw [← mul_one (v (algebra_map O R x)), hz, ring_hom.map_mul, v.map_mul],
  exact mul_le_mul_left' (hv.2 z) _ }

end integers

end comm_ring

section field

variables {F : Type u} {Γ₀ : Type v} [field F] [linear_ordered_comm_group_with_zero Γ₀]
variables {v : valuation F Γ₀} {O : Type w} [comm_ring O] [algebra O F] (hv : integers v O)
include hv

namespace integers

lemma dvd_of_le {x y : O} (h : v (algebra_map O F x) ≤ v (algebra_map O F y)) : y ∣ x :=
classical.by_cases (λ hy : algebra_map O F y = 0, have hx : x = 0,
    from hv.1 $ (algebra_map O F).map_zero.symm ▸
      (v.zero_iff.1 $ le_zero_iff.1 (v.map_zero ▸ hy ▸ h)),
  hx.symm ▸ dvd_zero y) $
λ hy : algebra_map O F y ≠ 0,
have v ((algebra_map O F y)⁻¹ * algebra_map O F x) ≤ 1,
  by { rw [← v.map_one, ← inv_mul_cancel hy, v.map_mul, v.map_mul], exact mul_le_mul_left' h _ },
let ⟨z, hz⟩ := hv.3 this in
⟨z, hv.1 $ ((algebra_map O F).map_mul y z).symm ▸ hz.symm ▸ (mul_inv_cancel_left₀ hy _).symm⟩

lemma dvd_iff_le {x y : O} : x ∣ y ↔ v (algebra_map O F y) ≤ v (algebra_map O F x) :=
⟨hv.le_of_dvd, hv.dvd_of_le⟩

lemma le_iff_dvd {x y : O} : v (algebra_map O F x) ≤ v (algebra_map O F y) ↔ y ∣ x :=
⟨hv.dvd_of_le, hv.le_of_dvd⟩

end integers

end field

end valuation


<|start_filename|>src/algebra/star/pi.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.star.basic
import algebra.ring.pi
import algebra.module.pi

/-!
# `star` on pi types

We put a `has_star` structure on pi types that operates elementwise, such that it describes the
complex conjugation of vectors.
-/

universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances

namespace pi

instance [Π i, has_star (f i)] : has_star (Π i, f i) :=
{ star := λ x i, star (x i) }

@[simp] lemma star_apply [Π i, has_star (f i)] (x : Π i, f i) (i : I) : star x i = star (x i) := rfl

lemma star_def [Π i, has_star (f i)] (x : Π i, f i) : star x = λ i, star (x i) := rfl

instance [Π i, has_involutive_star (f i)] : has_involutive_star (Π i, f i) :=
{ star_involutive := λ _, funext $ λ _, star_star _ }

instance [Π i, semigroup (f i)] [Π i, star_semigroup (f i)] : star_semigroup (Π i, f i) :=
{ star_mul := λ _ _, funext $ λ _, star_mul _ _ }

instance [Π i, add_monoid (f i)] [Π i, star_add_monoid (f i)] : star_add_monoid (Π i, f i) :=
{ star_add := λ _ _, funext $ λ _, star_add _ _ }

instance [Π i, non_unital_semiring (f i)] [Π i, star_ring (f i)] : star_ring (Π i, f i) :=
{ ..pi.star_add_monoid, ..(pi.star_semigroup : star_semigroup (Π i, f i)) }

instance {R : Type w}
  [Π i, has_scalar R (f i)] [has_star R] [Π i, has_star (f i)] [Π i, star_module R (f i)] :
  star_module R (Π i, f i) :=
{ star_smul := λ r x, funext $ λ i, star_smul r (x i) }

lemma single_star [Π i, add_monoid (f i)] [Π i, star_add_monoid (f i)] [decidable_eq I]
  (i : I) (a : f i) :
  pi.single i (star a) = star (pi.single i a) :=
single_op (λ i, @star (f i) _) (λ i, star_zero _) i a

end pi

namespace function

lemma update_star [Π i, has_star (f i)] [decidable_eq I]
  (h : Π (i : I), f i) (i : I) (a : f i) :
  function.update (star h) i (star a) = star (function.update h i a) :=
funext $ λ j, (apply_update (λ i, star) h i a j).symm

end function


<|start_filename|>src/algebraic_geometry/presheafed_space/gluing.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import topology.gluing
import algebraic_geometry.open_immersion
import algebraic_geometry.locally_ringed_space.has_colimits

/-!
# Gluing Structured spaces

Given a family of gluing data of structured spaces (presheafed spaces, sheafed spaces, or locally
ringed spaces), we may glue them together.

The construction should be "sealed" and considered as a black box, while only using the API
provided.

## Main definitions

* `algebraic_geometry.PresheafedSpace.glue_data`: A structure containing the family of gluing data.
* `category_theory.glue_data.glued`: The glued presheafed space.
    This is defined as the multicoequalizer of `∐ V i j ⇉ ∐ U i`, so that the general colimit API
    can be used.
* `category_theory.glue_data.ι`: The immersion `ι i : U i ⟶ glued` for each `i : J`.

## Main results

* `algebraic_geometry.PresheafedSpace.glue_data.ι_is_open_immersion`: The map `ι i : U i ⟶ glued`
  is an open immersion for each `i : J`.
* `algebraic_geometry.PresheafedSpace.glue_data.ι_jointly_surjective` : The underlying maps of
  `ι i : U i ⟶ glued` are jointly surjective.
* `algebraic_geometry.PresheafedSpace.glue_data.V_pullback_cone_is_limit` : `V i j` is the pullback
  (intersection) of `U i` and `U j` over the glued space.

Analogous results are also provided for `SheafedSpace` and `LocallyRingedSpace`.

## Implementation details

Almost the whole file is dedicated to showing tht `ι i` is an open immersion. The fact that
this is an open embedding of topological spaces follows from `topology.gluing.lean`, and it remains
to construct `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_X, ι i '' U)` for each `U ⊆ U i`.
Since `Γ(𝒪_X, ι i '' U)` is the the limit of `diagram_over_open`, the components of the structure
sheafs of the spaces in the gluing diagram, we need to construct a map
`ι_inv_app_π_app : Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_V, U_V)` for each `V` in the gluing diagram.

We will refer to ![this diagram](https://i.imgur.com/P0phrwr.png) in the following doc strings.
The `X` is the glued space, and the dotted arrow is a partial inverse guaranteed by the fact
that it is an open immersion. The map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_{U_j}, _)` is given by the composition
of the red arrows, and the map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_{V_{jk}}, _)` is given by the composition of the
blue arrows. To lift this into a map from `Γ(𝒪_X, ι i '' U)`, we also need to show that these
commute with the maps in the diagram (the green arrows), which is just a lengthy diagram-chasing.

-/

noncomputable theory

open topological_space category_theory opposite
open category_theory.limits algebraic_geometry.PresheafedSpace
open category_theory.glue_data

namespace algebraic_geometry

universes v u

variables (C : Type u) [category.{v} C]

namespace PresheafedSpace


/--
A family of gluing data consists of
1. An index type `J`
2. A presheafed space `U i` for each `i : J`.
3. A presheafed space `V i j` for each `i j : J`.
  (Note that this is `J × J → PresheafedSpace C` rather than `J → J → PresheafedSpace C` to
  connect to the limits library easier.)
4. An open immersion `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the spaces `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subspaces of the glued space.
-/
@[nolint has_inhabited_instance]
structure glue_data extends glue_data (PresheafedSpace C) :=
(f_open : ∀ i j, is_open_immersion (f i j))

attribute [instance] glue_data.f_open

namespace glue_data

variables {C} (D : glue_data C)

local notation `𝖣` := D.to_glue_data
local notation `π₁` i `,` j `,` k := @pullback.fst _ _ _ _ _ (D.f i j) (D.f i k) _
local notation `π₂` i `,` j `,` k := @pullback.snd _ _ _ _ _ (D.f i j) (D.f i k) _
local notation `π₁⁻¹` i `,` j `,` k :=
(PresheafedSpace.is_open_immersion.pullback_fst_of_right (D.f i j) (D.f i k)).inv_app
local notation `π₂⁻¹` i `,` j `,` k :=
(PresheafedSpace.is_open_immersion.pullback_snd_of_left (D.f i j) (D.f i k)).inv_app

/-- The glue data of topological spaces associated to a family of glue data of PresheafedSpaces. -/
abbreviation to_Top_glue_data : Top.glue_data :=
{ f_open := λ i j, (D.f_open i j).base_open,
  to_glue_data := 𝖣 .map_glue_data (forget C) }

lemma ι_open_embedding [has_limits C] (i : D.J) : open_embedding (𝖣 .ι i).base :=
begin
  rw ← (show _ = (𝖣 .ι i).base, from 𝖣 .ι_glued_iso_inv (PresheafedSpace.forget _) _),
  exact open_embedding.comp (Top.homeo_of_iso
    (𝖣 .glued_iso (PresheafedSpace.forget _)).symm).open_embedding
    (D.to_Top_glue_data.ι_open_embedding i)
end

lemma pullback_base (i j k : D.J)  (S : set (D.V (i, j)).carrier) :
  (π₂ i, j, k) '' ((π₁ i, j, k) ⁻¹' S) = D.f i k ⁻¹' (D.f i j '' S) :=
begin
  have eq₁ : _ = (π₁ i, j, k).base := preserves_pullback.iso_hom_fst (forget C) _ _,
  have eq₂ : _ = (π₂ i, j, k).base := preserves_pullback.iso_hom_snd (forget C) _ _,
  rw [coe_to_fun_eq, coe_to_fun_eq, ← eq₁, ← eq₂, coe_comp, set.image_comp, coe_comp,
    set.preimage_comp, set.image_preimage_eq, Top.pullback_snd_image_fst_preimage],
  refl,
  rw ← Top.epi_iff_surjective,
  apply_instance
end

/-- The red and the blue arrows in ![this diagram](https://i.imgur.com/0GiBUh6.png) commute. -/
@[simp, reassoc]
lemma f_inv_app_f_app (i j k : D.J)  (U : (opens (D.V (i, j)).carrier)) :
  (D.f_open i j).inv_app U ≫ (D.f i k).c.app _ =
    (π₁ i, j, k).c.app (op U) ≫ (π₂⁻¹ i, j, k) (unop _) ≫ (D.V _).presheaf.map (eq_to_hom
      (begin
        delta is_open_immersion.open_functor,
        dsimp only [functor.op, is_open_map.functor, opens.map, unop_op],
        congr,
        apply pullback_base,
      end)) :=
begin
  have := PresheafedSpace.congr_app (@pullback.condition _ _ _ _ _ (D.f i j) (D.f i k) _),
  dsimp only [comp_c_app] at this,
  rw [← cancel_epi (inv ((D.f_open i j).inv_app U)), is_iso.inv_hom_id_assoc,
    is_open_immersion.inv_inv_app],
  simp_rw category.assoc,
  erw [(π₁ i, j, k).c.naturality_assoc,
    reassoc_of this, ← functor.map_comp_assoc, is_open_immersion.inv_naturality_assoc,
    is_open_immersion.app_inv_app_assoc, ← (D.V (i, k)).presheaf.map_comp,
    ← (D.V (i, k)).presheaf.map_comp],
  convert (category.comp_id _).symm,
  erw (D.V (i, k)).presheaf.map_id,
  refl
end

/--
We can prove the `eq` along with the lemma. Thus this is bundled together here, and the
lemma itself is separated below.
-/
lemma snd_inv_app_t_app' (i j k : D.J) (U : opens (pullback (D.f i j) (D.f i k)).carrier) :
  ∃ eq, (π₂⁻¹ i, j, k) U ≫ (D.t k i).c.app _ ≫ (D.V (k, i)).presheaf.map (eq_to_hom eq) =
    (D.t' k i j).c.app _ ≫ (π₁⁻¹ k, j, i) (unop _) :=
begin
  split,
  rw [← is_iso.eq_inv_comp, is_open_immersion.inv_inv_app, category.assoc,
    (D.t' k i j).c.naturality_assoc],
  simp_rw ← category.assoc,
  erw ← comp_c_app,
  rw [congr_app (D.t_fac k i j), comp_c_app],
  simp_rw category.assoc,
  erw [is_open_immersion.inv_naturality, is_open_immersion.inv_naturality_assoc,
    is_open_immersion.app_inv_app'_assoc],
  simp_rw [← (𝖣 .V (k, i)).presheaf.map_comp,
    eq_to_hom_map (functor.op _), eq_to_hom_op, eq_to_hom_trans],
  rintros x ⟨y, hy, eq⟩,
  replace eq := concrete_category.congr_arg ((𝖣 .t i k).base) eq,
  change ((π₂ i, j, k) ≫ D.t i k).base y = (D.t k i ≫ D.t i k).base x at eq,
  rw [𝖣 .t_inv, id_base, Top.id_app] at eq,
  subst eq,
  use (inv (D.t' k i j)).base y,
  change ((inv (D.t' k i j)) ≫ (π₁ k, i, j)).base y = _,
  congr' 2,
  rw [is_iso.inv_comp_eq, 𝖣 .t_fac_assoc, 𝖣 .t_inv, category.comp_id]
end

/-- The red and the blue arrows in ![this diagram](https://i.imgur.com/q6X1GJ9.png) commute. -/
@[simp, reassoc]
lemma snd_inv_app_t_app (i j k : D.J) (U : opens (pullback (D.f i j) (D.f i k)).carrier) :
  (π₂⁻¹ i, j, k) U ≫ (D.t k i).c.app _ = (D.t' k i j).c.app _ ≫ (π₁⁻¹ k, j, i) (unop _) ≫
    (D.V (k, i)).presheaf.map (eq_to_hom (D.snd_inv_app_t_app' i j k U).some.symm) :=
begin
  have e := (D.snd_inv_app_t_app' i j k U).some_spec,
  reassoc! e,
  rw ← e,
  simp [eq_to_hom_map],
end

variable [has_limits C]

lemma ι_image_preimage_eq (i j : D.J) (U : opens (D.U i).carrier) :
  (opens.map (𝖣 .ι j).base).obj ((D.ι_open_embedding i).is_open_map.functor.obj U) =
  (D.f_open j i).open_functor.obj ((opens.map (𝖣 .t j i).base).obj
    ((opens.map (𝖣 .f i j).base).obj U)) :=
begin
  dsimp only [opens.map, is_open_map.functor],
  congr' 1,
  rw [← (show _ = (𝖣 .ι i).base, from 𝖣 .ι_glued_iso_inv (PresheafedSpace.forget _) i),
    ← (show _ = (𝖣 .ι j).base, from 𝖣 .ι_glued_iso_inv (PresheafedSpace.forget _) j),
    coe_comp, coe_comp, set.image_comp, set.preimage_comp, set.preimage_image_eq],
  refine eq.trans (D.to_Top_glue_data.preimage_image_eq_image' _ _ _) _,
  rw [coe_comp, set.image_comp],
  congr' 1,
  erw set.eq_preimage_iff_image_eq,
  rw ← set.image_comp,
  change (D.t i j ≫ D.t j i).base '' _ = _,
  rw 𝖣 .t_inv,
  { simp },
  { change function.bijective (Top.homeo_of_iso (as_iso _)),
    exact homeomorph.bijective _,
    apply_instance },
  { rw ← Top.mono_iff_injective,
    apply_instance }
end

/-- (Implementation). The map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_{U_j}, 𝖣.ι j ⁻¹' (𝖣.ι i '' U))` -/
def opens_image_preimage_map (i j : D.J) (U : opens (D.U i).carrier) :
  (D.U i).presheaf.obj (op U) ⟶ (D.U j).presheaf.obj _ :=
(D.f i j).c.app (op U) ≫ (D.t j i).c.app _ ≫ (D.f_open j i).inv_app (unop _) ≫
  (𝖣 .U j).presheaf.map (eq_to_hom (D.ι_image_preimage_eq i j U)).op

lemma opens_image_preimage_map_app' (i j k : D.J) (U : opens (D.U i).carrier) :
  ∃ eq, D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ =
    ((π₁ j, i, k) ≫ D.t j i ≫ D.f i j).c.app (op U) ≫ (π₂⁻¹ j, i, k) (unop _) ≫
      (D.V (j, k)).presheaf.map (eq_to_hom eq) :=
begin
  split,
  delta opens_image_preimage_map,
  simp_rw category.assoc,
  rw [(D.f j k).c.naturality, f_inv_app_f_app_assoc],
  erw ← (D.V (j, k)).presheaf.map_comp,
  simp_rw ← category.assoc,
  erw [← comp_c_app, ← comp_c_app],
  simp_rw category.assoc,
  dsimp only [functor.op, unop_op, quiver.hom.unop_op],
  rw [eq_to_hom_map (opens.map _), eq_to_hom_op, eq_to_hom_trans],
  congr
end

/-- The red and the blue arrows in ![this diagram](https://i.imgur.com/mBzV1Rx.png) commute. -/
lemma opens_image_preimage_map_app (i j k : D.J) (U : opens (D.U i).carrier) :
  D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ =
  ((π₁ j, i, k) ≫ D.t j i ≫ D.f i j).c.app (op U) ≫ (π₂⁻¹ j, i, k) (unop _) ≫
    (D.V (j, k)).presheaf.map (eq_to_hom ((opens_image_preimage_map_app' D i j k U).some)) :=
(opens_image_preimage_map_app' D i j k U).some_spec

-- This is proved separately since `reassoc` somehow timeouts.
lemma opens_image_preimage_map_app_assoc (i j k : D.J) (U : opens (D.U i).carrier)
  {X' : C} (f' : _ ⟶ X') :
  D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ ≫ f' =
    ((π₁ j, i, k) ≫ D.t j i ≫ D.f i j).c.app (op U) ≫ (π₂⁻¹ j, i, k) (unop _) ≫
    (D.V (j, k)).presheaf.map (eq_to_hom ((opens_image_preimage_map_app' D i j k U).some)) ≫ f' :=
by simpa only [category.assoc]
  using congr_arg (λ g, g ≫ f') (opens_image_preimage_map_app D i j k U)

/-- (Implementation) Given an open subset of one of the spaces `U ⊆ Uᵢ`, the sheaf component of
the image `ι '' U` in the glued space is the limit of this diagram. -/
abbreviation diagram_over_open {i : D.J} (U : opens (D.U i).carrier) :
  (walking_multispan _ _)ᵒᵖ ⥤ C :=
componentwise_diagram 𝖣 .diagram.multispan ((D.ι_open_embedding i).is_open_map.functor.obj U)

/-- (Implementation)
The projection from the limit of `diagram_over_open` to a component of `D.U j`. -/
abbreviation diagram_over_open_π {i : D.J} (U : opens (D.U i).carrier) (j : D.J) :=
limit.π (D.diagram_over_open U) (op (walking_multispan.right j))

/-- (Implementation) We construct the map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_V, U_V)` for each `V` in the gluing
diagram. We will lift these maps into `ι_inv_app`. -/
def ι_inv_app_π_app {i : D.J} (U : opens (D.U i).carrier) (j) :
  (𝖣 .U i).presheaf.obj (op U) ⟶ (D.diagram_over_open U).obj (op j) :=
begin
  rcases j with (⟨j, k⟩|j),
  { refine D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ ≫
      (D.V (j, k)).presheaf.map (eq_to_hom _),
    dsimp only [functor.op, opens.map, unop_op],
    congr' 2,
    rw set.preimage_preimage,
    change (D.f j k ≫ 𝖣 .ι j).base ⁻¹' _ = _,
    congr' 3,
    exact colimit.w 𝖣 .diagram.multispan (walking_multispan.hom.fst (j, k)) },
  { exact D.opens_image_preimage_map i j U }
end

/-- (Implementation) The natural map `Γ(𝒪_{U_i}, U) ⟶ Γ(𝒪_X, 𝖣.ι i '' U)`.
This forms the inverse of `(𝖣.ι i).c.app (op U)`. -/
def ι_inv_app {i : D.J} (U : opens (D.U i).carrier) :
  (D.U i).presheaf.obj (op U) ⟶ limit (D.diagram_over_open U) :=
limit.lift (D.diagram_over_open U)
{ X := (D.U i).presheaf.obj (op U),
  π := { app := λ j, D.ι_inv_app_π_app U (unop j),
  naturality' := λ X Y f', begin
    induction X using opposite.rec,
    induction Y using opposite.rec,
    let f : Y ⟶ X := f'.unop, have : f' = f.op := rfl, clear_value f, subst this,
    rcases f with (_|⟨j,k⟩|⟨j,k⟩),
    { erw [category.id_comp, category_theory.functor.map_id],
      rw category.comp_id },
    { erw category.id_comp, congr' 1 },
    erw category.id_comp,
    -- It remains to show that the blue is equal to red + green in the original diagram.
    -- The proof strategy is illustrated in ![this diagram](https://i.imgur.com/mBzV1Rx.png)
    -- where we prove red = pink = light-blue = green = blue.
    change D.opens_image_preimage_map i j U ≫ (D.f j k).c.app _ ≫
      (D.V (j, k)).presheaf.map (eq_to_hom _) = D.opens_image_preimage_map _ _ _ ≫
      ((D.f k j).c.app _ ≫ (D.t j k).c.app _) ≫ (D.V (j, k)).presheaf.map (eq_to_hom _),
    erw opens_image_preimage_map_app_assoc,
    simp_rw category.assoc,
    erw [opens_image_preimage_map_app_assoc, (D.t j k).c.naturality_assoc],
    rw snd_inv_app_t_app_assoc,
    erw ← PresheafedSpace.comp_c_app_assoc,
    -- light-blue = green is relatively easy since the part that differs does not involve
    -- partial inverses.
    have : D.t' j k i ≫ (π₁ k, i, j) ≫ D.t k i ≫ 𝖣 .f i k =
      (pullback_symmetry _ _).hom ≫ (π₁ j, i, k) ≫ D.t j i ≫ D.f i j,
    { rw [← 𝖣 .t_fac_assoc, 𝖣 .t'_comp_eq_pullback_symmetry_assoc,
        pullback_symmetry_hom_comp_snd_assoc, pullback.condition, 𝖣 .t_fac_assoc] },
    rw congr_app this,
    erw PresheafedSpace.comp_c_app_assoc (pullback_symmetry _ _).hom,
    simp_rw category.assoc,
    congr' 1,
    rw ← is_iso.eq_inv_comp,
    erw is_open_immersion.inv_inv_app,
    simp_rw category.assoc,
    erw [nat_trans.naturality_assoc, ← PresheafedSpace.comp_c_app_assoc,
      congr_app (pullback_symmetry_hom_comp_snd _ _)],
    simp_rw category.assoc,
    erw [is_open_immersion.inv_naturality_assoc, is_open_immersion.inv_naturality_assoc,
      is_open_immersion.inv_naturality_assoc, is_open_immersion.app_inv_app_assoc],
    repeat { erw ← (D.V (j, k)).presheaf.map_comp },
    congr,
  end } }

/-- `ι_inv_app` is the left inverse of `D.ι i` on `U`. -/
lemma ι_inv_app_π {i : D.J} (U : opens (D.U i).carrier) :
  ∃ eq, D.ι_inv_app U ≫ D.diagram_over_open_π U i = (D.U i).presheaf.map (eq_to_hom eq) :=
begin
  split,
  delta ι_inv_app,
  rw limit.lift_π,
  change D.opens_image_preimage_map i i U = _,
  dsimp [opens_image_preimage_map],
  rw [congr_app (D.t_id _), id_c_app, ← functor.map_comp],
  erw [is_open_immersion.inv_naturality_assoc, is_open_immersion.app_inv_app'_assoc],
  simp only [eq_to_hom_op, eq_to_hom_trans, eq_to_hom_map (functor.op _), ← functor.map_comp],
  rw set.range_iff_surjective.mpr _,
  { simp },
  { rw ← Top.epi_iff_surjective,
    apply_instance }
end

/-- The `eq_to_hom` given by `ι_inv_app_π`. -/
abbreviation ι_inv_app_π_eq_map {i : D.J} (U : opens (D.U i).carrier) :=
(D.U i).presheaf.map (eq_to_iso (D.ι_inv_app_π U).some).inv

/-- `ι_inv_app` is the right inverse of `D.ι i` on `U`. -/
lemma π_ι_inv_app_π (i j : D.J) (U : opens (D.U i).carrier) :
  D.diagram_over_open_π U i ≫ D.ι_inv_app_π_eq_map U ≫ D.ι_inv_app U ≫
    D.diagram_over_open_π U j = D.diagram_over_open_π U j :=
begin
  rw ← cancel_mono ((componentwise_diagram 𝖣 .diagram.multispan _).map
    (quiver.hom.op (walking_multispan.hom.snd (i, j))) ≫ (𝟙 _)),
  simp_rw category.assoc,
  rw limit.w_assoc,
  erw limit.lift_π_assoc,
  rw [category.comp_id, category.comp_id],
  change _ ≫ _ ≫ (_ ≫ _) ≫ _ = _,
  rw [congr_app (D.t_id _), id_c_app],
  simp_rw category.assoc,
  rw [← functor.map_comp_assoc, is_open_immersion.inv_naturality_assoc],
  erw is_open_immersion.app_inv_app_assoc,
  iterate 3 { rw ← functor.map_comp_assoc },
  rw nat_trans.naturality_assoc,
  erw ← (D.V (i, j)).presheaf.map_comp,
  convert limit.w (componentwise_diagram 𝖣 .diagram.multispan _)
    (quiver.hom.op (walking_multispan.hom.fst (i, j))),
  { rw category.comp_id,
    apply_with mono_comp { instances := ff },
    change mono ((_ ≫ D.f j i).c.app _),
    rw comp_c_app,
    apply_with mono_comp { instances := ff },
    erw D.ι_image_preimage_eq i j U,
    all_goals { apply_instance } },
end

/-- `ι_inv_app` is the inverse of `D.ι i` on `U`. -/
lemma π_ι_inv_app_eq_id (i : D.J) (U : opens (D.U i).carrier) :
  D.diagram_over_open_π U i ≫ D.ι_inv_app_π_eq_map U ≫ D.ι_inv_app U = 𝟙 _ :=
begin
  ext j,
  induction j using opposite.rec,
  rcases j with (⟨j, k⟩|⟨j⟩),
  { rw [← limit.w (componentwise_diagram 𝖣 .diagram.multispan _)
      (quiver.hom.op (walking_multispan.hom.fst (j, k))), ← category.assoc, category.id_comp],
    congr' 1,
    simp_rw category.assoc,
    apply π_ι_inv_app_π },
  { simp_rw category.assoc,
    rw category.id_comp,
    apply π_ι_inv_app_π }
end

instance componentwise_diagram_π_is_iso (i : D.J) (U : opens (D.U i).carrier) :
  is_iso (D.diagram_over_open_π U i) :=
begin
  use D.ι_inv_app_π_eq_map U ≫ D.ι_inv_app U,
  split,
  { apply π_ι_inv_app_eq_id },
  { rw [category.assoc, (D.ι_inv_app_π _).some_spec],
    exact iso.inv_hom_id ((D.to_glue_data.U i).presheaf.map_iso (eq_to_iso _)) }
end

instance ι_is_open_immersion (i : D.J) :
  is_open_immersion (𝖣 .ι i) :=
{ base_open := D.ι_open_embedding i,
  c_iso := λ U, by { erw ← colimit_presheaf_obj_iso_componentwise_limit_hom_π, apply_instance } }

/-- The following diagram is a pullback, i.e. `Vᵢⱼ` is the intersection of `Uᵢ` and `Uⱼ` in `X`.

Vᵢⱼ ⟶ Uᵢ
 |      |
 ↓      ↓
 Uⱼ ⟶ X
-/
def V_pullback_cone_is_limit (i j : D.J) : is_limit (𝖣 .V_pullback_cone i j) :=
pullback_cone.is_limit_aux' _ $ λ s,
begin
  refine ⟨_, _, _, _⟩,
  { refine PresheafedSpace.is_open_immersion.lift (D.f i j) s.fst _,
    erw ← D.to_Top_glue_data.preimage_range j i,
    have : s.fst.base ≫ D.to_Top_glue_data.to_glue_data.ι i =
      s.snd.base ≫ D.to_Top_glue_data.to_glue_data.ι j,
    { rw [← 𝖣 .ι_glued_iso_hom (PresheafedSpace.forget _) _,
        ← 𝖣 .ι_glued_iso_hom (PresheafedSpace.forget _) _],
      have := congr_arg PresheafedSpace.hom.base s.condition,
      rw [comp_base, comp_base] at this,
      reassoc! this,
      exact this _ },
    rw [← set.image_subset_iff, ← set.image_univ, ← set.image_comp, set.image_univ,
      ← coe_comp, this, coe_comp, ← set.image_univ, set.image_comp],
    exact set.image_subset_range _ _ },
  { apply is_open_immersion.lift_fac },
  { rw [← cancel_mono (𝖣 .ι j), category.assoc, ← (𝖣 .V_pullback_cone i j).condition],
    conv_rhs { rw ← s.condition },
    erw is_open_immersion.lift_fac_assoc },
  { intros m e₁ e₂, rw ← cancel_mono (D.f i j), erw e₁, rw is_open_immersion.lift_fac }
end

lemma ι_jointly_surjective (x : 𝖣 .glued) :
  ∃ (i : D.J) (y : D.U i), (𝖣 .ι i).base y = x :=
𝖣 .ι_jointly_surjective (PresheafedSpace.forget _ ⋙ category_theory.forget Top) x

end glue_data

end PresheafedSpace

namespace SheafedSpace

variables (C) [has_products C]

/--
A family of gluing data consists of
1. An index type `J`
2. A sheafed space `U i` for each `i : J`.
3. A sheafed space `V i j` for each `i j : J`.
  (Note that this is `J × J → SheafedSpace C` rather than `J → J → SheafedSpace C` to
  connect to the limits library easier.)
4. An open immersion `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the spaces `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subspaces of the glued space.
-/
@[nolint has_inhabited_instance]
structure glue_data extends glue_data (SheafedSpace C) :=
(f_open : ∀ i j, SheafedSpace.is_open_immersion (f i j))

attribute [instance] glue_data.f_open

namespace glue_data

variables {C} (D : glue_data C)

local notation `𝖣` := D.to_glue_data

/-- The glue data of presheafed spaces associated to a family of glue data of sheafed spaces. -/
abbreviation to_PresheafedSpace_glue_data : PresheafedSpace.glue_data C :=
{ f_open := D.f_open,
  to_glue_data := 𝖣 .map_glue_data forget_to_PresheafedSpace }

variable [has_limits C]

/-- The gluing as sheafed spaces is isomorphic to the gluing as presheafed spaces. -/
abbreviation iso_PresheafedSpace : 𝖣 .glued.to_PresheafedSpace ≅
  D.to_PresheafedSpace_glue_data.to_glue_data.glued :=
𝖣 .glued_iso forget_to_PresheafedSpace

lemma ι_iso_PresheafedSpace_inv (i : D.J) :
  D.to_PresheafedSpace_glue_data.to_glue_data.ι i ≫ D.iso_PresheafedSpace.inv = 𝖣 .ι i :=
𝖣 .ι_glued_iso_inv _ _

instance ι_is_open_immersion (i : D.J) :
  is_open_immersion (𝖣 .ι i) :=
by { rw ← D.ι_iso_PresheafedSpace_inv, apply_instance }

lemma ι_jointly_surjective (x : 𝖣 .glued) :
  ∃ (i : D.J) (y : D.U i), (𝖣 .ι i).base y = x :=
𝖣 .ι_jointly_surjective (SheafedSpace.forget _ ⋙ category_theory.forget Top) x

/-- The following diagram is a pullback, i.e. `Vᵢⱼ` is the intersection of `Uᵢ` and `Uⱼ` in `X`.

Vᵢⱼ ⟶ Uᵢ
 |      |
 ↓      ↓
 Uⱼ ⟶ X
-/
def V_pullback_cone_is_limit (i j : D.J) : is_limit (𝖣 .V_pullback_cone i j) :=
𝖣 .V_pullback_cone_is_limit_of_map forget_to_PresheafedSpace i j
  (D.to_PresheafedSpace_glue_data.V_pullback_cone_is_limit _ _)

end glue_data

end SheafedSpace

namespace LocallyRingedSpace

/--
A family of gluing data consists of
1. An index type `J`
2. A locally ringed space `U i` for each `i : J`.
3. A locally ringed space `V i j` for each `i j : J`.
  (Note that this is `J × J → LocallyRingedSpace` rather than `J → J → LocallyRingedSpace` to
  connect to the limits library easier.)
4. An open immersion `f i j : V i j ⟶ U i` for each `i j : ι`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : ι`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
9. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.

We can then glue the spaces `U i` together by identifying `V i j` with `V j i`, such
that the `U i`'s are open subspaces of the glued space.
-/
@[nolint has_inhabited_instance]
structure glue_data extends glue_data LocallyRingedSpace :=
(f_open : ∀ i j, LocallyRingedSpace.is_open_immersion (f i j))

attribute [instance] glue_data.f_open

namespace glue_data

variables (D : glue_data)

local notation `𝖣` := D.to_glue_data

/-- The glue data of ringed spaces associated to a family of glue data of locally ringed spaces. -/
abbreviation to_SheafedSpace_glue_data : SheafedSpace.glue_data CommRing :=
{ f_open := D.f_open,
  to_glue_data := 𝖣 .map_glue_data forget_to_SheafedSpace }

/-- The gluing as locally ringed spaces is isomorphic to the gluing as ringed spaces. -/
abbreviation iso_SheafedSpace : 𝖣 .glued.to_SheafedSpace ≅
  D.to_SheafedSpace_glue_data.to_glue_data.glued :=
𝖣 .glued_iso forget_to_SheafedSpace

lemma ι_iso_SheafedSpace_inv (i : D.J) :
  D.to_SheafedSpace_glue_data.to_glue_data.ι i ≫ D.iso_SheafedSpace.inv = (𝖣 .ι i).1 :=
𝖣 .ι_glued_iso_inv forget_to_SheafedSpace i

instance ι_is_open_immersion (i : D.J) :
  is_open_immersion (𝖣 .ι i) :=
by { delta is_open_immersion, rw ← D.ι_iso_SheafedSpace_inv,
  apply PresheafedSpace.is_open_immersion.comp }

instance (i j k : D.J) :
  preserves_limit (cospan (𝖣 .f i j) (𝖣 .f i k)) forget_to_SheafedSpace :=
infer_instance

lemma ι_jointly_surjective (x : 𝖣 .glued) :
  ∃ (i : D.J) (y : D.U i), (𝖣 .ι i).1.base y = x :=
𝖣 .ι_jointly_surjective ((LocallyRingedSpace.forget_to_SheafedSpace ⋙
  SheafedSpace.forget _) ⋙ forget Top) x

/-- The following diagram is a pullback, i.e. `Vᵢⱼ` is the intersection of `Uᵢ` and `Uⱼ` in `X`.

Vᵢⱼ ⟶ Uᵢ
 |      |
 ↓      ↓
 Uⱼ ⟶ X
-/
def V_pullback_cone_is_limit (i j : D.J) : is_limit (𝖣 .V_pullback_cone i j) :=
𝖣 .V_pullback_cone_is_limit_of_map forget_to_SheafedSpace i j
  (D.to_SheafedSpace_glue_data.V_pullback_cone_is_limit _ _)

end glue_data

end LocallyRingedSpace

end algebraic_geometry


<|start_filename|>src/category_theory/monoidal/Mon_.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.monoidal.braided
import category_theory.monoidal.discrete
import category_theory.monoidal.coherence_lemmas
import category_theory.limits.shapes.terminal
import algebra.punit_instances

/-!
# The category of monoids in a monoidal category.

We define monoids in a monoidal category `C` and show that the category of monoids is equivalent to
the category of lax monoidal functors from the unit monoidal category to `C`.  We also show that if
`C` is braided, then the category of monoids is naturally monoidal.

-/

universes v₁ v₂ u₁ u₂ u

open category_theory
open category_theory.monoidal_category

variables (C : Type u₁) [category.{v₁} C] [monoidal_category.{v₁} C]

/--
A monoid object internal to a monoidal category.

When the monoidal category is preadditive, this is also sometimes called an "algebra object".
-/
structure Mon_ :=
(X : C)
(one : 𝟙_ C ⟶ X)
(mul : X ⊗ X ⟶ X)
(one_mul' : (one ⊗ 𝟙 X) ≫ mul = (λ_ X).hom . obviously)
(mul_one' : (𝟙 X ⊗ one) ≫ mul = (ρ_ X).hom . obviously)
-- Obviously there is some flexibility stating this axiom.
-- This one has left- and right-hand sides matching the statement of `monoid.mul_assoc`,
-- and chooses to place the associator on the right-hand side.
-- The heuristic is that unitors and associators "don't have much weight".
(mul_assoc' : (mul ⊗ 𝟙 X) ≫ mul = (α_ X X X).hom ≫ (𝟙 X ⊗ mul) ≫ mul . obviously)

restate_axiom Mon_.one_mul'
restate_axiom Mon_.mul_one'
restate_axiom Mon_.mul_assoc'
attribute [reassoc] Mon_.one_mul Mon_.mul_one -- We prove a more general `@[simp]` lemma below.
attribute [simp, reassoc] Mon_.mul_assoc

namespace Mon_

/--
The trivial monoid object. We later show this is initial in `Mon_ C`.
-/
@[simps]
def trivial : Mon_ C :=
{ X := 𝟙_ C,
  one := 𝟙 _,
  mul := (λ_ _).hom,
  mul_assoc' := by coherence,
  mul_one' := by coherence }

instance : inhabited (Mon_ C) := ⟨trivial C⟩

variables {C} {M : Mon_ C}

@[simp] lemma one_mul_hom {Z : C} (f : Z ⟶ M.X) : (M.one ⊗ f) ≫ M.mul = (λ_ Z).hom ≫ f :=
by rw [←id_tensor_comp_tensor_id, category.assoc, M.one_mul, left_unitor_naturality]

@[simp] lemma mul_one_hom {Z : C} (f : Z ⟶ M.X) : (f ⊗ M.one) ≫ M.mul = (ρ_ Z).hom ≫ f :=
by rw [←tensor_id_comp_id_tensor, category.assoc, M.mul_one, right_unitor_naturality]

lemma assoc_flip : (𝟙 M.X ⊗ M.mul) ≫ M.mul = (α_ M.X M.X M.X).inv ≫ (M.mul ⊗ 𝟙 M.X) ≫ M.mul :=
by simp

/-- A morphism of monoid objects. -/
@[ext]
structure hom (M N : Mon_ C) :=
(hom : M.X ⟶ N.X)
(one_hom' : M.one ≫ hom = N.one . obviously)
(mul_hom' : M.mul ≫ hom = (hom ⊗ hom) ≫ N.mul . obviously)

restate_axiom hom.one_hom'
restate_axiom hom.mul_hom'
attribute [simp, reassoc] hom.one_hom hom.mul_hom

/-- The identity morphism on a monoid object. -/
@[simps]
def id (M : Mon_ C) : hom M M :=
{ hom := 𝟙 M.X, }

instance hom_inhabited (M : Mon_ C) : inhabited (hom M M) := ⟨id M⟩

/-- Composition of morphisms of monoid objects. -/
@[simps]
def comp {M N O : Mon_ C} (f : hom M N) (g : hom N O) : hom M O :=
{ hom := f.hom ≫ g.hom, }

instance : category (Mon_ C) :=
{ hom := λ M N, hom M N,
  id := id,
  comp := λ M N O f g, comp f g, }

@[simp] lemma id_hom' (M : Mon_ C) : (𝟙 M : hom M M).hom = 𝟙 M.X := rfl
@[simp] lemma comp_hom' {M N K : Mon_ C} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g : hom M K).hom = f.hom ≫ g.hom := rfl

section
variables (C)

/-- The forgetful functor from monoid objects to the ambient category. -/
@[simps]
def forget : Mon_ C ⥤ C :=
{ obj := λ A, A.X,
  map := λ A B f, f.hom, }

end

instance forget_faithful : faithful (@forget C _ _) := { }

instance {A B : Mon_ C} (f : A ⟶ B) [e : is_iso ((forget C).map f)] : is_iso f.hom := e

/-- The forgetful functor from monoid objects to the ambient category reflects isomorphisms. -/
instance : reflects_isomorphisms (forget C) :=
{ reflects := λ X Y f e, by exactI ⟨⟨
{ hom := inv f.hom,
  mul_hom' :=
  begin
    simp only [is_iso.comp_inv_eq, hom.mul_hom, category.assoc, ←tensor_comp_assoc,
      is_iso.inv_hom_id, tensor_id, category.id_comp],
  end }, by tidy⟩⟩ }

/--
Construct an isomorphism of monoids by giving an isomorphism between the underlying objects
and checking compatibility with unit and multiplication only in the forward direction.
-/
def iso_of_iso {M N : Mon_ C}
  (f : M.X ≅ N.X)
  (one_f : M.one ≫ f.hom = N.one)
  (mul_f : M.mul ≫ f.hom = (f.hom ⊗ f.hom) ≫ N.mul) :
  M ≅ N :=
{ hom := { hom := f.hom, one_hom' := one_f, mul_hom' := mul_f },
  inv :=
  { hom := f.inv,
    one_hom' := by { rw ←one_f, simp },
    mul_hom' :=
    begin
      rw ←(cancel_mono f.hom),
      slice_rhs 2 3 { rw mul_f },
      simp,
    end } }

instance unique_hom_from_trivial (A : Mon_ C) : unique (trivial C ⟶ A) :=
{ default :=
  { hom := A.one,
    one_hom' := by { dsimp, simp, },
    mul_hom' := by { dsimp, simp [A.one_mul, unitors_equal], } },
  uniq := λ f,
  begin
    ext, simp,
    rw [←category.id_comp f.hom],
    erw f.one_hom,
  end }

open category_theory.limits

instance : has_initial (Mon_ C) :=
has_initial_of_unique (trivial C)

end Mon_

namespace category_theory.lax_monoidal_functor

variables {C} {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D]

/--
A lax monoidal functor takes monoid objects to monoid objects.

That is, a lax monoidal functor `F : C ⥤ D` induces a functor `Mon_ C ⥤ Mon_ D`.
-/
-- TODO: map_Mod F A : Mod A ⥤ Mod (F.map_Mon A)
@[simps]
def map_Mon (F : lax_monoidal_functor C D) : Mon_ C ⥤ Mon_ D :=
{ obj := λ A,
  { X := F.obj A.X,
    one := F.ε ≫ F.map A.one,
    mul := F.μ _ _ ≫ F.map A.mul,
    one_mul' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.one_mul], },
      rw [F.to_functor.map_id],
      rw [F.left_unitality],
    end,
    mul_one' :=
    begin
      conv_lhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_one], },
      rw [F.to_functor.map_id],
      rw [F.right_unitality],
    end,
    mul_assoc' :=
    begin
      conv_lhs { rw [comp_tensor_id, ←F.to_functor.map_id], },
      slice_lhs 2 3 { rw [F.μ_natural], },
      slice_lhs 3 4 { rw [←F.to_functor.map_comp, A.mul_assoc], },
      conv_lhs { rw [F.to_functor.map_id] },
      conv_lhs { rw [F.to_functor.map_comp, F.to_functor.map_comp] },
      conv_rhs { rw [id_tensor_comp, ←F.to_functor.map_id], },
      slice_rhs 3 4 { rw [F.μ_natural], },
      conv_rhs { rw [F.to_functor.map_id] },
      slice_rhs 1 3 { rw [←F.associativity], },
      simp only [category.assoc],
    end, },
  map := λ A B f,
  { hom := F.map f.hom,
    one_hom' := by { dsimp, rw [category.assoc, ←F.to_functor.map_comp, f.one_hom], },
    mul_hom' :=
    begin
      dsimp,
      rw [category.assoc, F.μ_natural_assoc, ←F.to_functor.map_comp, ←F.to_functor.map_comp,
        f.mul_hom],
    end },
  map_id' := λ A, by { ext, simp, },
  map_comp' := λ A B C f g, by { ext, simp, }, }

variables (C D)

/-- `map_Mon` is functorial in the lax monoidal functor. -/
def map_Mon_functor : (lax_monoidal_functor C D) ⥤ (Mon_ C ⥤ Mon_ D) :=
{ obj := map_Mon,
  map := λ F G α,
  { app := λ A,
    { hom := α.app A.X, } } }

end category_theory.lax_monoidal_functor

namespace Mon_

open category_theory.lax_monoidal_functor

namespace equiv_lax_monoidal_functor_punit

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def lax_monoidal_to_Mon : lax_monoidal_functor (discrete punit.{u+1}) C ⥤ Mon_ C :=
{ obj := λ F, (F.map_Mon : Mon_ _ ⥤ Mon_ C).obj (trivial (discrete punit)),
  map := λ F G α, ((map_Mon_functor (discrete punit) C).map α).app _ }

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def Mon_to_lax_monoidal : Mon_ C ⥤ lax_monoidal_functor (discrete punit.{u+1}) C :=
{ obj := λ A,
  { obj := λ _, A.X,
    map := λ _ _ _, 𝟙 _,
    ε := A.one,
    μ := λ _ _, A.mul,
    map_id' := λ _, rfl,
    map_comp' := λ _ _ _ _ _, (category.id_comp (𝟙 A.X)).symm, },
  map := λ A B f,
  { app := λ _, f.hom,
    naturality' := λ _ _ _, by { dsimp, rw [category.id_comp, category.comp_id], },
    unit' := f.one_hom,
    tensor' := λ _ _, f.mul_hom, }, }

local attribute [tidy] tactic.discrete_cases
local attribute [simp] eq_to_iso_map

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def unit_iso :
  𝟭 (lax_monoidal_functor (discrete punit.{u+1}) C) ≅
    lax_monoidal_to_Mon C ⋙ Mon_to_lax_monoidal C :=
nat_iso.of_components (λ F,
  monoidal_nat_iso.of_components
    (λ _, F.to_functor.map_iso (eq_to_iso (by ext)))
    (by tidy) (by tidy) (by tidy))
  (by tidy)

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simps]
def counit_iso : Mon_to_lax_monoidal C ⋙ lax_monoidal_to_Mon C ≅ 𝟭 (Mon_ C) :=
nat_iso.of_components (λ F, { hom := { hom := 𝟙 _, }, inv := { hom := 𝟙 _, } })
  (by tidy)

end equiv_lax_monoidal_functor_punit

open equiv_lax_monoidal_functor_punit

local attribute [simp] eq_to_iso_map

/--
Monoid objects in `C` are "just" lax monoidal functors from the trivial monoidal category to `C`.
-/
@[simps]
def equiv_lax_monoidal_functor_punit : lax_monoidal_functor (discrete punit.{u+1}) C ≌ Mon_ C :=
{ functor := lax_monoidal_to_Mon C,
  inverse := Mon_to_lax_monoidal C,
  unit_iso := unit_iso C,
  counit_iso := counit_iso C, }

end Mon_

namespace Mon_

/-!
In this section, we prove that the category of monoids in a braided monoidal category is monoidal.

Given two monoids `M` and `N` in a braided monoidal category `C`, the multiplication on the tensor
product `M.X ⊗ N.X` is defined in the obvious way: it is the tensor product of the multiplications
on `M` and `N`, except that the tensor factors in the source come in the wrong order, which we fix
by pre-composing with a permutation isomorphism constructed from the braiding.

A more conceptual way of understanding this definition is the following: The braiding on `C` gives
rise to a monoidal structure on the tensor product functor from `C × C` to `C`.  A pair of monoids
in `C` gives rise to a monoid in `C × C`, which the tensor product functor by being monoidal takes
to a monoid in `C`.  The permutation isomorphism appearing in the definition of the multiplication
on the tensor product of two monoids is an instance of a more general family of isomorphisms which
together form a strength that equips the tensor product functor with a monoidal structure, and the
monoid axioms for the tensor product follow from the monoid axioms for the tensor factors plus the
properties of the strength (i.e., monoidal functor axioms).  The strength `tensor_μ` of the tensor
product functor has been defined in `category_theory.monoidal.braided`.  Its properties, stated as
independent lemmas in that module, are used extensively in the proofs below.  Notice that we could
have followed the above plan not only conceptually but also as a possible implementation and could
have constructed the tensor product of monoids via `map_Mon`, but we chose to give a more explicit
definition directly in terms of `tensor_μ`.

To complete the definition of the monoidal category structure on the category of monoids, we need
to provide definitions of associator and unitors.  The obvious candidates are the associator and
unitors from `C`, but we need to prove that they are monoid morphisms, i.e., compatible with unit
and multiplication.  These properties translate to the monoidality of the associator and unitors
(with respect to the monoidal structures on the functors they relate), which have also been proved
in `category_theory.monoidal.braided`.

-/

variable {C}

-- The proofs that associators and unitors preserve monoid units don't require braiding.

lemma one_associator {M N P : Mon_ C} :
    ((λ_ (𝟙_ C)).inv ≫ ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ P.one)) ≫ (α_ M.X N.X P.X).hom
  = (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ (λ_ (𝟙_ C)).inv ≫ (N.one ⊗ P.one)) :=
begin
  simp,
  slice_lhs 1 3 { rw [←category.id_comp P.one, tensor_comp] },
  slice_lhs 2 3 { rw associator_naturality },
  slice_rhs 1 2 { rw [←category.id_comp M.one, tensor_comp] },
  slice_lhs 1 2 { rw [←left_unitor_tensor_inv] },
  rw ←(cancel_epi (λ_ (𝟙_ C)).inv),
  slice_lhs 1 2 { rw [left_unitor_inv_naturality] },
  simp only [category.assoc],
end

lemma one_left_unitor {M : Mon_ C} :
  ((λ_ (𝟙_ C)).inv ≫ (𝟙 (𝟙_ C) ⊗ M.one)) ≫ (λ_ M.X).hom = M.one :=
by { slice_lhs 2 3 { rw left_unitor_naturality }, simp }

lemma one_right_unitor {M : Mon_ C} :
  ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ 𝟙 (𝟙_ C))) ≫ (ρ_ M.X).hom = M.one :=
by { slice_lhs 2 3 { rw [right_unitor_naturality, ←unitors_equal] }, simp }

variable [braided_category C]

lemma Mon_tensor_one_mul (M N : Mon_ C) :
    ((λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one) ⊗ 𝟙 (M.X ⊗ N.X)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)
  = (λ_ (M.X ⊗ N.X)).hom :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, one_mul M, one_mul N] },
  symmetry,
  exact tensor_left_unitality C M.X N.X,
end

lemma Mon_tensor_mul_one (M N : Mon_ C) :
    (𝟙 (M.X ⊗ N.X) ⊗ (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)
  = (ρ_ (M.X ⊗ N.X)).hom :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, mul_one M, mul_one N] },
  symmetry,
  exact tensor_right_unitality C M.X N.X,
end

lemma Mon_tensor_mul_assoc (M N : Mon_ C) :
    (tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul) ⊗ 𝟙 (M.X ⊗ N.X)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫
    (M.mul ⊗ N.mul)
  = (α_ (M.X ⊗ N.X) (M.X ⊗ N.X) (M.X ⊗ N.X)).hom ≫
    (𝟙 (M.X ⊗ N.X) ⊗ tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul)) ≫
    tensor_μ C (M.X, N.X) (M.X, N.X) ≫
    (M.mul ⊗ N.mul) :=
begin
  rw [←category.id_comp (𝟙 (M.X ⊗ N.X)), tensor_comp],
  slice_lhs 2 3 { rw [←tensor_id, tensor_μ_natural] },
  slice_lhs 3 4 { rw [←tensor_comp, mul_assoc M, mul_assoc N, tensor_comp, tensor_comp] },
  slice_lhs 1 3 { rw [tensor_associativity] },
  slice_lhs 3 4 { rw [←tensor_μ_natural] },
  slice_lhs 2 3 { rw [←tensor_comp, tensor_id] },
  simp only [category.assoc],
end

lemma mul_associator {M N P : Mon_ C} :
    (tensor_μ C (M.X ⊗ N.X, P.X) (M.X ⊗ N.X, P.X) ≫
      (tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul) ⊗ P.mul)) ≫
    (α_ M.X N.X P.X).hom
  = ((α_ M.X N.X P.X).hom ⊗ (α_ M.X N.X P.X).hom) ≫
    tensor_μ C (M.X, N.X ⊗ P.X) (M.X, N.X ⊗ P.X) ≫
    (M.mul ⊗ tensor_μ C (N.X, P.X) (N.X, P.X) ≫ (N.mul ⊗ P.mul)) :=
begin
  simp,
  slice_lhs 2 3 { rw [←category.id_comp P.mul, tensor_comp] },
  slice_lhs 3 4 { rw [associator_naturality] },
  slice_rhs 3 4 { rw [←category.id_comp M.mul, tensor_comp] },
  slice_lhs 1 3 { rw associator_monoidal },
  simp only [category.assoc],
end

lemma mul_left_unitor {M : Mon_ C}:
    (tensor_μ C (𝟙_ C, M.X) (𝟙_ C, M.X) ≫ ((λ_ (𝟙_ C)).hom ⊗ M.mul)) ≫ (λ_ M.X).hom
  = ((λ_ M.X).hom ⊗ (λ_ M.X).hom) ≫ M.mul :=
begin
  rw [←(category.comp_id (λ_ (𝟙_ C)).hom), ←(category.id_comp M.mul), tensor_comp],
  slice_lhs 3 4 { rw left_unitor_naturality },
  slice_lhs 1 3 { rw ←left_unitor_monoidal },
  simp only [category.assoc, category.id_comp],
end

lemma mul_right_unitor {M : Mon_ C} :
    (tensor_μ C (M.X, 𝟙_ C) (M.X, 𝟙_ C) ≫ (M.mul ⊗ (λ_ (𝟙_ C)).hom)) ≫ (ρ_ M.X).hom
  = ((ρ_ M.X).hom ⊗ (ρ_ M.X).hom) ≫ M.mul :=
begin
  rw [←(category.id_comp M.mul), ←(category.comp_id (λ_ (𝟙_ C)).hom), tensor_comp],
  slice_lhs 3 4 { rw right_unitor_naturality },
  slice_lhs 1 3 { rw ←right_unitor_monoidal },
  simp only [category.assoc, category.id_comp],
end

instance Mon_monoidal : monoidal_category (Mon_ C) :=
{ tensor_obj := λ M N,
  { X := M.X ⊗ N.X,
    one := (λ_ (𝟙_ C)).inv ≫ (M.one ⊗ N.one),
    mul := tensor_μ C (M.X, N.X) (M.X, N.X) ≫ (M.mul ⊗ N.mul),
    one_mul' := Mon_tensor_one_mul M N,
    mul_one' := Mon_tensor_mul_one M N,
    mul_assoc' := Mon_tensor_mul_assoc M N },
  tensor_hom := λ M N P Q f g,
  { hom := f.hom ⊗ g.hom,
    one_hom' :=
    begin
      dsimp,
      slice_lhs 2 3 { rw [←tensor_comp, hom.one_hom f, hom.one_hom g] },
    end,
    mul_hom' :=
    begin
      dsimp,
      slice_rhs 1 2 { rw [tensor_μ_natural] },
      slice_lhs 2 3 { rw [←tensor_comp, hom.mul_hom f, hom.mul_hom g, tensor_comp] },
      simp only [category.assoc],
    end },
  tensor_id' := by { intros, ext, apply tensor_id },
  tensor_comp' := by { intros, ext, apply tensor_comp },
  tensor_unit := trivial C,
  associator := λ M N P, iso_of_iso (α_ M.X N.X P.X) one_associator mul_associator,
  associator_naturality' := by { intros, ext, dsimp, apply associator_naturality },
  left_unitor := λ M, iso_of_iso (λ_ M.X) one_left_unitor mul_left_unitor,
  left_unitor_naturality' := by { intros, ext, dsimp, apply left_unitor_naturality },
  right_unitor := λ M, iso_of_iso (ρ_ M.X) one_right_unitor mul_right_unitor,
  right_unitor_naturality' := by { intros, ext, dsimp, apply right_unitor_naturality },
  pentagon' := by { intros, ext, dsimp, apply pentagon },
  triangle' := by { intros, ext, dsimp, apply triangle } }

end Mon_

/-!
Projects:
* Check that `Mon_ Mon ≌ CommMon`, via the Eckmann-Hilton argument.
  (You'll have to hook up the cartesian monoidal structure on `Mon` first, available in #3463)
* Check that `Mon_ Top ≌ [bundled topological monoids]`.
* Check that `Mon_ AddCommGroup ≌ Ring`.
  (We've already got `Mon_ (Module R) ≌ Algebra R`, in `category_theory.monoidal.internal.Module`.)
* Can you transport this monoidal structure to `Ring` or `Algebra R`?
  How does it compare to the "native" one?
* Show that when `C` is braided, the forgetful functor `Mon_ C ⥤ C` is monoidal.
* Show that when `F` is a lax braided functor `C ⥤ D`, the functor `map_Mon F : Mon_ C ⥤ Mon_ D`
  is lax monoidal.
-/


<|start_filename|>src/ring_theory/nilpotent.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.nat.choose.sum
import algebra.algebra.bilinear
import ring_theory.ideal.operations

/-!
# Nilpotent elements

## Main definitions

  * `is_nilpotent`
  * `is_nilpotent_neg_iff`
  * `commute.is_nilpotent_add`
  * `commute.is_nilpotent_mul_left`
  * `commute.is_nilpotent_mul_right`
  * `commute.is_nilpotent_sub`

-/

universes u v

variables {R S : Type u} {x y : R}

/-- An element is said to be nilpotent if some natural-number-power of it equals zero.

Note that we require only the bare minimum assumptions for the definition to make sense. Even
`monoid_with_zero` is too strong since nilpotency is important in the study of rings that are only
power-associative. -/
def is_nilpotent [has_zero R] [has_pow R ℕ] (x : R) : Prop := ∃ (n : ℕ), x^n = 0

lemma is_nilpotent.mk [has_zero R] [has_pow R ℕ] (x : R) (n : ℕ)
  (e : x ^ n = 0) : is_nilpotent x := ⟨n, e⟩

lemma is_nilpotent.zero [monoid_with_zero R] : is_nilpotent (0 : R) := ⟨1, pow_one 0⟩

lemma is_nilpotent.neg [ring R] (h : is_nilpotent x) : is_nilpotent (-x) :=
begin
  obtain ⟨n, hn⟩ := h,
  use n,
  rw [neg_pow, hn, mul_zero],
end

@[simp] lemma is_nilpotent_neg_iff [ring R] : is_nilpotent (-x) ↔ is_nilpotent x :=
⟨λ h, neg_neg x ▸ h.neg, λ h, h.neg⟩

lemma is_nilpotent.map [monoid_with_zero R] [monoid_with_zero S] {r : R}
  {F : Type*} [monoid_with_zero_hom_class F R S] (hr : is_nilpotent r) (f : F) :
    is_nilpotent (f r) :=
by { use hr.some, rw [← map_pow, hr.some_spec, map_zero] }

/-- A structure that has zero and pow is reduced if it has no nonzero nilpotent elements. -/
class is_reduced (R : Type*) [has_zero R] [has_pow R ℕ] : Prop :=
(eq_zero : ∀ (x : R), is_nilpotent x → x = 0)

@[priority 900]
instance is_reduced_of_no_zero_divisors [monoid_with_zero R] [no_zero_divisors R] : is_reduced R :=
⟨λ _ ⟨_, hn⟩, pow_eq_zero hn⟩

@[priority 900]
instance is_reduced_of_subsingleton [has_zero R] [has_pow R ℕ] [subsingleton R] :
  is_reduced R := ⟨λ _ _, subsingleton.elim _ _⟩

lemma is_nilpotent.eq_zero [has_zero R] [has_pow R ℕ] [is_reduced R]
  (h : is_nilpotent x) : x = 0 :=
is_reduced.eq_zero x h

@[simp] lemma is_nilpotent_iff_eq_zero [monoid_with_zero R] [is_reduced R] :
  is_nilpotent x ↔ x = 0 :=
⟨λ h, h.eq_zero, λ h, h.symm ▸ is_nilpotent.zero⟩

lemma is_reduced_of_injective [monoid_with_zero R] [monoid_with_zero S]
  {F : Type*} [monoid_with_zero_hom_class F R S] (f : F)
  (hf : function.injective f) [_root_.is_reduced S] : _root_.is_reduced R :=
begin
  constructor,
  intros x hx,
  apply hf,
  rw map_zero,
  exact (hx.map f).eq_zero,
end

namespace commute

section semiring

variables [semiring R] (h_comm : commute x y)

include h_comm

lemma is_nilpotent_add (hx : is_nilpotent x) (hy : is_nilpotent y) : is_nilpotent (x + y) :=
begin
  obtain ⟨n, hn⟩ := hx,
  obtain ⟨m, hm⟩ := hy,
  use n + m - 1,
  rw h_comm.add_pow',
  apply finset.sum_eq_zero,
  rintros ⟨i, j⟩ hij,
  suffices : x^i * y^j = 0, { simp only [this, nsmul_eq_mul, mul_zero], },
  cases nat.le_or_le_of_add_eq_add_pred (finset.nat.mem_antidiagonal.mp hij) with hi hj,
  { rw [pow_eq_zero_of_le hi hn, zero_mul], },
  { rw [pow_eq_zero_of_le hj hm, mul_zero], },
end

lemma is_nilpotent_mul_left (h : is_nilpotent x) : is_nilpotent (x * y) :=
begin
  obtain ⟨n, hn⟩ := h,
  use n,
  rw [h_comm.mul_pow, hn, zero_mul],
end

lemma is_nilpotent_mul_right (h : is_nilpotent y) : is_nilpotent (x * y) :=
by { rw h_comm.eq, exact h_comm.symm.is_nilpotent_mul_left h, }

end semiring

section ring

variables [ring R] (h_comm : commute x y)

include h_comm

lemma is_nilpotent_sub (hx : is_nilpotent x) (hy : is_nilpotent y) : is_nilpotent (x - y) :=
begin
  rw ← neg_right_iff at h_comm,
  rw ← is_nilpotent_neg_iff at hy,
  rw sub_eq_add_neg,
  exact h_comm.is_nilpotent_add hx hy,
end

end ring

end commute

section comm_semiring

variable [comm_semiring R]

/-- The nilradical of a commutative semiring is the ideal of nilpotent elements. -/
def nilradical (R : Type*) [comm_semiring R] : ideal R := (0 : ideal R).radical

lemma mem_nilradical : x ∈ nilradical R ↔ is_nilpotent x := iff.rfl

lemma nilradical_eq_Inf (R : Type*) [comm_semiring R] :
  nilradical R = Inf { J : ideal R | J.is_prime } :=
(ideal.radical_eq_Inf ⊥).trans $ by simp_rw and_iff_right bot_le

lemma nilpotent_iff_mem_prime : is_nilpotent x ↔ ∀ (J : ideal R), J.is_prime → x ∈ J :=
by { rw [← mem_nilradical, nilradical_eq_Inf, submodule.mem_Inf], refl }

lemma nilradical_le_prime (J : ideal R) [H : J.is_prime] : nilradical R ≤ J :=
(nilradical_eq_Inf R).symm ▸ Inf_le H

@[simp] lemma nilradical_eq_zero (R : Type*) [comm_semiring R] [is_reduced R] : nilradical R = 0 :=
ideal.ext $ λ _, is_nilpotent_iff_eq_zero

end comm_semiring

namespace algebra

variables (R) {A : Type v} [comm_semiring R] [semiring A] [algebra R A]

@[simp] lemma is_nilpotent_lmul_left_iff (a : A) :
  is_nilpotent (lmul_left R a) ↔ is_nilpotent a :=
begin
  split; rintros ⟨n, hn⟩; use n;
  simp only [lmul_left_eq_zero_iff, pow_lmul_left] at ⊢ hn;
  exact hn,
end

@[simp] lemma is_nilpotent_lmul_right_iff (a : A) :
  is_nilpotent (lmul_right R a) ↔ is_nilpotent a :=
begin
  split; rintros ⟨n, hn⟩; use n;
  simp only [lmul_right_eq_zero_iff, pow_lmul_right] at ⊢ hn;
  exact hn,
end

end algebra

namespace module.End

variables {M : Type v} [ring R] [add_comm_group M] [module R M]
variables {f : module.End R M} {p : submodule R M} (hp : p ≤ p.comap f)

lemma is_nilpotent.mapq (hnp : is_nilpotent f) : is_nilpotent (p.mapq p f hp) :=
begin
  obtain ⟨k, hk⟩ := hnp,
  use k,
  simp [← p.mapq_pow, hk],
end

end module.End


<|start_filename|>src/topology/algebra/module/finite_dimension.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import analysis.locally_convex.balanced_core_hull

/-!
# Finite dimensional topological vector spaces over complete fields

Let `𝕜` be a nondiscrete and complete normed field, and `E` a topological vector space (TVS) over
`𝕜` (i.e we have `[add_comm_group E] [module 𝕜 E] [topological_space E] [topological_add_group E]`
and `[has_continuous_smul 𝕜 E]`).

If `E` is finite dimensional and Hausdorff, then all linear maps from `E` to any other TVS are
continuous.

When `E` is a normed space, this gets us the equivalence of norms in finite dimension.

## Main results :

* `linear_map.continuous_iff_is_closed_ker` : a linear form is continuous if and only if its kernel
  is closed.
* `linear_map.continuous_of_finite_dimensional` : a linear map on a finite-dimensional Hausdorff
  space over a complete field is continuous.

## TODO

Generalize more of `analysis/normed_space/finite_dimension` to general TVSs.

## Implementation detail

The main result from which everything follows is the fact that, if `ξ : ι → E` is a finite basis,
then `ξ.equiv_fun : E →ₗ (ι → 𝕜)` is continuous. However, for technical reasons, it is easier to
prove this when `ι` and `E` live ine the same universe. So we start by doing that as a private
lemma, then we deduce `linear_map.continuous_of_finite_dimensional` from it, and then the general
result follows as `continuous_equiv_fun_basis`.

-/

universes u v w x

noncomputable theory

open set finite_dimensional topological_space filter
open_locale big_operators

section semiring

variables {ι 𝕜 F : Type*} [fintype ι] [semiring 𝕜] [topological_space 𝕜]
  [add_comm_monoid F] [module 𝕜 F] [topological_space F]
  [has_continuous_add F] [has_continuous_smul 𝕜 F]

/-- A linear map on `ι → 𝕜` (where `ι` is a fintype) is continuous -/
lemma linear_map.continuous_on_pi (f : (ι → 𝕜) →ₗ[𝕜] F) : continuous f :=
begin
  classical,
  -- for the proof, write `f` in the standard basis, and use that each coordinate is a continuous
  -- function.
  have : (f : (ι → 𝕜) → F) =
         (λx, ∑ i : ι, x i • (f (λ j, if i = j then 1 else 0))),
    by { ext x, exact f.pi_apply_eq_sum_univ x },
  rw this,
  refine continuous_finset_sum _ (λi hi, _),
  exact (continuous_apply i).smul continuous_const
end

end semiring

section field

variables {ι 𝕜 E F : Type*} [fintype ι] [field 𝕜] [topological_space 𝕜]
  [add_comm_group E] [module 𝕜 E] [topological_space E]
  [add_comm_group F] [module 𝕜 F] [topological_space F]
  [topological_add_group F] [has_continuous_smul 𝕜 F]

/-- The space of continuous linear maps between finite-dimensional spaces is finite-dimensional. -/
instance [finite_dimensional 𝕜 E] [finite_dimensional 𝕜 F] :
  finite_dimensional 𝕜 (E →L[𝕜] F) :=
finite_dimensional.of_injective
  (continuous_linear_map.coe_lm 𝕜 : (E →L[𝕜] F) →ₗ[𝕜] (E →ₗ[𝕜] F))
  continuous_linear_map.coe_injective

end field

section normed_field

variables {𝕜 : Type u} [hnorm : nondiscrete_normed_field 𝕜]
  {E : Type v} [add_comm_group E] [module 𝕜 E] [topological_space E]
  [topological_add_group E] [has_continuous_smul 𝕜 E]
  {F : Type w} [add_comm_group F] [module 𝕜 F] [topological_space F]
  [topological_add_group F] [has_continuous_smul 𝕜 F]
  {F' : Type x} [add_comm_group F'] [module 𝕜 F'] [topological_space F']
  [topological_add_group F'] [has_continuous_smul 𝕜 F']

include hnorm

/-- If `𝕜` is a nondiscrete normed field, any T2 topology on `𝕜` which makes it a topological vector
    space over itself (with the norm topology) is *equal* to the norm topology. -/
lemma unique_topology_of_t2 {t : topological_space 𝕜}
  (h₁ : @topological_add_group 𝕜 t _)
  (h₂ : @has_continuous_smul 𝕜 𝕜 _ hnorm.to_uniform_space.to_topological_space t)
  (h₃ : @t2_space 𝕜 t) :
  t = hnorm.to_uniform_space.to_topological_space :=
begin
  -- Let `𝓣₀` denote the topology on `𝕜` induced by the norm, and `𝓣` be any T2 vector
  -- topology on `𝕜`. To show that `𝓣₀ = 𝓣`, it suffices to show that they have the same
  -- neighborhoods of 0.
  refine topological_add_group.ext h₁ infer_instance (le_antisymm _ _),
  { -- To show `𝓣 ≤ 𝓣₀`, we have to show that closed balls are `𝓣`-neighborhoods of 0.
    rw metric.nhds_basis_closed_ball.ge_iff,
    -- Let `ε > 0`. Since `𝕜` is nondiscrete, we have `0 < ∥ξ₀∥ < ε` for some `ξ₀ : 𝕜`.
    intros ε hε,
    rcases normed_field.exists_norm_lt 𝕜 hε with ⟨ξ₀, hξ₀, hξ₀ε⟩,
    -- Since `ξ₀ ≠ 0` and `𝓣` is T2, we know that `{ξ₀}ᶜ` is a `𝓣`-neighborhood of 0.
    have : {ξ₀}ᶜ ∈ @nhds 𝕜 t 0 :=
      is_open.mem_nhds is_open_compl_singleton (ne.symm $ norm_ne_zero_iff.mp hξ₀.ne.symm),
    -- Thus, its balanced core `𝓑` is too. Let's show that the closed ball of radius `ε` contains
    -- `𝓑`, which will imply that the closed ball is indeed a `𝓣`-neighborhood of 0.
    have : balanced_core 𝕜 {ξ₀}ᶜ ∈ @nhds 𝕜 t 0 := balanced_core_mem_nhds_zero this,
    refine mem_of_superset this (λ ξ hξ, _),
    -- Let `ξ ∈ 𝓑`. We want to show `∥ξ∥ < ε`. If `ξ = 0`, this is trivial.
    by_cases hξ0 : ξ = 0,
    { rw hξ0,
      exact metric.mem_closed_ball_self hε.le },
    { rw [mem_closed_ball_zero_iff],
      -- Now suppose `ξ ≠ 0`. By contradiction, let's assume `ε < ∥ξ∥`, and show that
      -- `ξ₀ ∈ 𝓑 ⊆ {ξ₀}ᶜ`, which is a contradiction.
      by_contra' h,
      suffices : (ξ₀ * ξ⁻¹) • ξ ∈ balanced_core 𝕜 {ξ₀}ᶜ,
      { rw [smul_eq_mul 𝕜, mul_assoc, inv_mul_cancel hξ0, mul_one] at this,
        exact not_mem_compl_iff.mpr (mem_singleton ξ₀) ((balanced_core_subset _) this) },
      -- For that, we use that `𝓑` is balanced : since `∥ξ₀∥ < ε < ∥ξ∥`, we have `∥ξ₀ / ξ∥ ≤ 1`,
      -- hence `ξ₀ = (ξ₀ / ξ) • ξ ∈ 𝓑` because `ξ ∈ 𝓑`.
      refine balanced_mem (balanced_core_balanced _) hξ _,
      rw [norm_mul, norm_inv, mul_inv_le_iff (norm_pos_iff.mpr hξ0), mul_one],
      exact (hξ₀ε.trans h).le } },
  { -- Finally, to show `𝓣₀ ≤ 𝓣`, we simply argue that `id = (λ x, x • 1)` is continuous from
    -- `(𝕜, 𝓣₀)` to `(𝕜, 𝓣)` because `(•) : (𝕜, 𝓣₀) × (𝕜, 𝓣) → (𝕜, 𝓣)` is continuous.
    calc (@nhds 𝕜 hnorm.to_uniform_space.to_topological_space 0)
        = map id (@nhds 𝕜 hnorm.to_uniform_space.to_topological_space 0) : map_id.symm
    ... = map (λ x, id x • 1) (@nhds 𝕜 hnorm.to_uniform_space.to_topological_space 0) :
        by conv_rhs {congr, funext, rw [smul_eq_mul, mul_one]}; refl
    ... ≤ (@nhds 𝕜 t ((0 : 𝕜) • 1)) :
        @tendsto.smul_const _ _ _ hnorm.to_uniform_space.to_topological_space t _ _ _ _ _
          tendsto_id (1 : 𝕜)
    ... = (@nhds 𝕜 t 0) : by rw zero_smul }
end

/-- Any linear form on a topological vector space over a nondiscrete normed field is continuous if
    its kernel is closed. -/
lemma linear_map.continuous_of_is_closed_ker (l : E →ₗ[𝕜] 𝕜) (hl : is_closed (l.ker : set E)) :
  continuous l :=
begin
  -- `l` is either constant or surjective. If it is constant, the result is trivial.
  by_cases H : finrank 𝕜 l.range = 0,
  { rw [finrank_eq_zero, linear_map.range_eq_bot] at H,
    rw H,
    exact continuous_zero },
  { -- In the case where `l` is surjective, we factor it as `φ : (E ⧸ l.ker) ≃ₗ[𝕜] 𝕜`. Note that
    -- `E ⧸ l.ker` is T2 since `l.ker` is closed.
    have : finrank 𝕜 l.range = 1,
      from le_antisymm (finrank_self 𝕜 ▸ l.range.finrank_le) (zero_lt_iff.mpr H),
    have hi : function.injective (l.ker.liftq l (le_refl _)),
    { rw [← linear_map.ker_eq_bot],
      exact submodule.ker_liftq_eq_bot _ _ _ (le_refl _) },
    have hs : function.surjective (l.ker.liftq l (le_refl _)),
    { rw [← linear_map.range_eq_top, submodule.range_liftq],
      exact eq_top_of_finrank_eq ((finrank_self 𝕜).symm ▸ this) },
    let φ : (E ⧸ l.ker) ≃ₗ[𝕜] 𝕜 := linear_equiv.of_bijective (l.ker.liftq l (le_refl _)) hi hs,
    have hlφ : (l : E → 𝕜) = φ ∘ l.ker.mkq,
      by ext; refl,
    -- Since the quotient map `E →ₗ[𝕜] (E ⧸ l.ker)` is continuous, the continuity of `l` will follow
    -- form the continuity of `φ`.
    suffices : continuous φ.to_equiv,
    { rw hlφ,
      exact this.comp continuous_quot_mk },
    -- The pullback by `φ.symm` of the quotient topology is a T2 topology on `𝕜`, because `φ.symm`
    -- is injective. Since `φ.symm` is linear, it is also a vector space topology.
    -- Hence, we know that it is equal to the topology induced by the norm.
    have : induced φ.to_equiv.symm infer_instance = hnorm.to_uniform_space.to_topological_space,
    { refine unique_topology_of_t2 (topological_add_group_induced φ.symm.to_linear_map)
        (has_continuous_smul_induced φ.symm.to_linear_map) _,
      rw t2_space_iff,
      exact λ x y hxy, @separated_by_continuous _ _ (induced _ _) _ _ _
        continuous_induced_dom _ _ (φ.to_equiv.symm.injective.ne hxy) },
    -- Finally, the pullback by `φ.symm` is exactly the pushforward by `φ`, so we have to prove
    -- that `φ` is continuous when `𝕜` is endowed with the pushforward by `φ` of the quotient
    -- topology, which is trivial by definition of the pushforward.
    rw [this.symm, equiv.induced_symm],
    exact continuous_coinduced_rng }
end

/-- Any linear form on a topological vector space over a nondiscrete normed field is continuous if
    and only if its kernel is closed. -/
lemma linear_map.continuous_iff_is_closed_ker (l : E →ₗ[𝕜] 𝕜) :
  continuous l ↔ is_closed (l.ker : set E) :=
⟨λ h, is_closed_singleton.preimage h, l.continuous_of_is_closed_ker⟩

variables [complete_space 𝕜]

/-- This version imposes `ι` and `E` to live in the same universe, so you should instead use
`continuous_equiv_fun_basis` which gives the same result without universe restrictions. -/
private lemma continuous_equiv_fun_basis_aux [ht2 : t2_space E] {ι : Type v} [fintype ι]
  (ξ : basis ι 𝕜 E) : continuous ξ.equiv_fun :=
begin
  letI : uniform_space E := topological_add_group.to_uniform_space E,
  letI : uniform_add_group E := topological_add_group_is_uniform,
  letI : separated_space E := separated_iff_t2.mpr ht2,
  unfreezingI { induction hn : fintype.card ι with n IH generalizing ι E },
  { rw fintype.card_eq_zero_iff at hn,
    exact continuous_of_const (λ x y, funext hn.elim) },
  { haveI : finite_dimensional 𝕜 E := of_fintype_basis ξ,
    -- first step: thanks to the induction hypothesis, any n-dimensional subspace is equivalent
    -- to a standard space of dimension n, hence it is complete and therefore closed.
    have H₁ : ∀s : submodule 𝕜 E, finrank 𝕜 s = n → is_closed (s : set E),
    { assume s s_dim,
      letI : uniform_add_group s := s.to_add_subgroup.uniform_add_group,
      let b := basis.of_vector_space 𝕜 s,
      have U : uniform_embedding b.equiv_fun.symm.to_equiv,
      { have : fintype.card (basis.of_vector_space_index 𝕜 s) = n,
          by { rw ← s_dim, exact (finrank_eq_card_basis b).symm },
        have : continuous b.equiv_fun := IH b this,
        exact b.equiv_fun.symm.uniform_embedding b.equiv_fun.symm.to_linear_map.continuous_on_pi
          this },
      have : is_complete (s : set E),
        from complete_space_coe_iff_is_complete.1 ((complete_space_congr U).1 (by apply_instance)),
      exact this.is_closed },
    -- second step: any linear form is continuous, as its kernel is closed by the first step
    have H₂ : ∀f : E →ₗ[𝕜] 𝕜, continuous f,
    { assume f,
      by_cases H : finrank 𝕜 f.range = 0,
      { rw [finrank_eq_zero, linear_map.range_eq_bot] at H,
        rw H,
        exact continuous_zero },
      { have : finrank 𝕜 f.ker = n,
        { have Z := f.finrank_range_add_finrank_ker,
          rw [finrank_eq_card_basis ξ, hn] at Z,
          have : finrank 𝕜 f.range = 1,
            from le_antisymm (finrank_self 𝕜 ▸ f.range.finrank_le) (zero_lt_iff.mpr H),
          rw [this, add_comm, nat.add_one] at Z,
          exact nat.succ.inj Z },
        have : is_closed (f.ker : set E),
          from H₁ _ this,
        exact linear_map.continuous_of_is_closed_ker f this } },
    rw continuous_pi_iff,
    intros i,
    change continuous (ξ.coord i),
    exact H₂ (ξ.coord i) },
end

/-- Any linear map on a finite dimensional space over a complete field is continuous. -/
theorem linear_map.continuous_of_finite_dimensional [t2_space E] [finite_dimensional 𝕜 E]
  (f : E →ₗ[𝕜] F') :
  continuous f :=
begin
  -- for the proof, go to a model vector space `b → 𝕜` thanks to `continuous_equiv_fun_basis`, and
  -- argue that all linear maps there are continuous.
  let b := basis.of_vector_space 𝕜 E,
  have A : continuous b.equiv_fun :=
    continuous_equiv_fun_basis_aux b,
  have B : continuous (f.comp (b.equiv_fun.symm : (basis.of_vector_space_index 𝕜 E → 𝕜) →ₗ[𝕜] E)) :=
    linear_map.continuous_on_pi _,
  have : continuous ((f.comp (b.equiv_fun.symm : (basis.of_vector_space_index 𝕜 E → 𝕜) →ₗ[𝕜] E))
                      ∘ b.equiv_fun) := B.comp A,
  convert this,
  ext x,
  dsimp,
  rw [basis.equiv_fun_symm_apply, basis.sum_repr]
end

/-- In finite dimensions over a non-discrete complete normed field, the canonical identification
(in terms of a basis) with `𝕜^n` (endowed with the product topology) is continuous.
This is the key fact wich makes all linear maps from a T2 finite dimensional TVS over such a field
continuous (see `linear_map.continuous_of_finite_dimensional`), which in turn implies that all
norms are equivalent in finite dimensions. -/
theorem continuous_equiv_fun_basis [t2_space E] {ι : Type*} [fintype ι] (ξ : basis ι 𝕜 E) :
  continuous ξ.equiv_fun :=
begin
  haveI : finite_dimensional 𝕜 E := of_fintype_basis ξ,
  exact ξ.equiv_fun.to_linear_map.continuous_of_finite_dimensional
end

namespace linear_map

variables [t2_space E] [finite_dimensional 𝕜 E]

/-- The continuous linear map induced by a linear map on a finite dimensional space -/
def to_continuous_linear_map : (E →ₗ[𝕜] F') ≃ₗ[𝕜] E →L[𝕜] F' :=
{ to_fun := λ f, ⟨f, f.continuous_of_finite_dimensional⟩,
  inv_fun := coe,
  map_add' := λ f g, rfl,
  map_smul' := λ c f, rfl,
  left_inv := λ f, rfl,
  right_inv := λ f, continuous_linear_map.coe_injective rfl }

@[simp] lemma coe_to_continuous_linear_map' (f : E →ₗ[𝕜] F') :
  ⇑f.to_continuous_linear_map = f := rfl

@[simp] lemma coe_to_continuous_linear_map (f : E →ₗ[𝕜] F') :
  (f.to_continuous_linear_map : E →ₗ[𝕜] F') = f := rfl

@[simp] lemma coe_to_continuous_linear_map_symm :
  ⇑(to_continuous_linear_map : (E →ₗ[𝕜] F') ≃ₗ[𝕜] E →L[𝕜] F').symm = coe := rfl

end linear_map

namespace linear_equiv

variables [t2_space E] [t2_space F] [finite_dimensional 𝕜 E]

/-- The continuous linear equivalence induced by a linear equivalence on a finite dimensional
space. -/
def to_continuous_linear_equiv (e : E ≃ₗ[𝕜] F) : E ≃L[𝕜] F :=
{ continuous_to_fun := e.to_linear_map.continuous_of_finite_dimensional,
  continuous_inv_fun := begin
    haveI : finite_dimensional 𝕜 F := e.finite_dimensional,
    exact e.symm.to_linear_map.continuous_of_finite_dimensional
  end,
  ..e }

@[simp] lemma coe_to_continuous_linear_equiv (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv : E →ₗ[𝕜] F) = e := rfl

@[simp] lemma coe_to_continuous_linear_equiv' (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv : E → F) = e := rfl

@[simp] lemma coe_to_continuous_linear_equiv_symm (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv.symm : F →ₗ[𝕜] E) = e.symm := rfl

@[simp] lemma coe_to_continuous_linear_equiv_symm' (e : E ≃ₗ[𝕜] F) :
  (e.to_continuous_linear_equiv.symm : F → E) = e.symm := rfl

@[simp] lemma to_linear_equiv_to_continuous_linear_equiv (e : E ≃ₗ[𝕜] F) :
  e.to_continuous_linear_equiv.to_linear_equiv = e :=
by { ext x, refl }

@[simp] lemma to_linear_equiv_to_continuous_linear_equiv_symm (e : E ≃ₗ[𝕜] F) :
  e.to_continuous_linear_equiv.symm.to_linear_equiv = e.symm :=
by { ext x, refl }

end linear_equiv

namespace continuous_linear_map

variables [t2_space E] [finite_dimensional 𝕜 E]

/-- Builds a continuous linear equivalence from a continuous linear map on a finite-dimensional
vector space whose determinant is nonzero. -/
def to_continuous_linear_equiv_of_det_ne_zero
  (f : E →L[𝕜] E) (hf : f.det ≠ 0) : E ≃L[𝕜] E :=
((f : E →ₗ[𝕜] E).equiv_of_det_ne_zero hf).to_continuous_linear_equiv

@[simp] lemma coe_to_continuous_linear_equiv_of_det_ne_zero (f : E →L[𝕜] E) (hf : f.det ≠ 0) :
  (f.to_continuous_linear_equiv_of_det_ne_zero hf : E →L[𝕜] E) = f :=
by { ext x, refl }

@[simp] lemma to_continuous_linear_equiv_of_det_ne_zero_apply
  (f : E →L[𝕜] E) (hf : f.det ≠ 0) (x : E) :
  f.to_continuous_linear_equiv_of_det_ne_zero hf x = f x :=
rfl

end continuous_linear_map

end normed_field


<|start_filename|>src/analysis/convex/uniform.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.convex.strict_convex_space

/-!
# Uniformly convex spaces

This file defines uniformly convex spaces, which are real normed vector spaces in which for all
strictly positive `ε`, there exists some strictly positive `δ` such that `ε ≤ ∥x - y∥` implies
`∥x + y∥ ≤ 2 - δ` for all `x` and `y` of norm at most than `1`. This means that the triangle
inequality is strict with a uniform bound, as opposed to strictly convex spaces where the triangle
inequality is strict but not necessarily uniformly (`∥x + y∥ < ∥x∥ + ∥y∥` for all `x` and `y` not in
the same ray).

## Main declarations

`uniform_convex_space E` means that `E` is a uniformly convex space.

## TODO

* Milman-Pettis
* Hanner's inequalities

## Tags

convex, uniformly convex
-/

open set metric
open_locale convex pointwise

/-- A *uniformly convex space* is a real normed space where .

See also `uniform_convex_space.of_uniform_convex_closed_unit_ball`. -/
class uniform_convex_space (E : Type*) [semi_normed_group E] : Prop :=
(uniform_convex : ∀ ⦃ε : ℝ⦄, 0 < ε → ∃ δ, 0 < δ ∧
  ∀ ⦃x : E⦄, ∥x∥ = 1 → ∀ ⦃y⦄, ∥y∥ = 1 → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 - δ)

variables {E : Type*}

section semi_normed_group
variables (E) [semi_normed_group E] [uniform_convex_space E] {ε : ℝ}

lemma exists_forall_sphere_dist_add_le_two_sub (hε : 0 < ε) :
  ∃ δ, 0 < δ ∧ ∀ ⦃x : E⦄, ∥x∥ = 1 → ∀ ⦃y⦄, ∥y∥ = 1 → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 - δ :=
uniform_convex_space.uniform_convex hε

variables [normed_space ℝ E]

lemma exists_forall_closed_ball_dist_add_le_two_sub (hε : 0 < ε) :
  ∃ δ, 0 < δ ∧ ∀ ⦃x : E⦄, ∥x∥ ≤ 1 → ∀ ⦃y⦄, ∥y∥ ≤ 1 → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 - δ :=
begin
  have hε' : 0 < ε / 3 := div_pos hε zero_lt_three,
  obtain ⟨δ, hδ, h⟩ := exists_forall_sphere_dist_add_le_two_sub E hε',
  set δ' := min (1/2) (min (ε/3) $ δ/3),
  refine ⟨δ', lt_min one_half_pos $ lt_min hε' (div_pos hδ zero_lt_three), λ x hx y hy hxy, _⟩,
  obtain hx' | hx' := le_or_lt (∥x∥) (1 - δ'),
  { exact (norm_add_le_of_le hx' hy).trans (sub_add_eq_add_sub _ _ _).le },
  obtain hy' | hy' := le_or_lt (∥y∥) (1 - δ'),
  { exact (norm_add_le_of_le hx hy').trans (add_sub_assoc _ _ _).ge },
  have hδ' : 0 < 1 - δ' := sub_pos_of_lt  (min_lt_of_left_lt one_half_lt_one),
  have h₁ : ∀ z : E, 1 - δ' < ∥z∥ → ∥∥z∥⁻¹ • z∥ = 1,
  { rintro z hz,
    rw [norm_smul_of_nonneg (inv_nonneg.2 $ norm_nonneg _), inv_mul_cancel (hδ'.trans hz).ne'] },
  have h₂ : ∀ z : E, ∥z∥ ≤ 1 → 1 - δ' ≤ ∥z∥ → ∥∥z∥⁻¹ • z - z∥ ≤ δ',
  { rintro z hz hδz,
    nth_rewrite 2 ←one_smul ℝ z,
    rwa [←sub_smul, norm_smul_of_nonneg (sub_nonneg_of_le $ one_le_inv (hδ'.trans_le hδz) hz),
      sub_mul, inv_mul_cancel (hδ'.trans_le hδz).ne', one_mul, sub_le] },
  set x' := ∥x∥⁻¹ • x,
  set y' := ∥y∥⁻¹ • y,
  have hxy' : ε/3 ≤ ∥x' - y'∥ :=
  calc ε/3 = ε - (ε/3 + ε/3) : by ring
    ... ≤ ∥x - y∥ - (∥x' - x∥ + ∥y' - y∥) : sub_le_sub hxy (add_le_add
          ((h₂ _ hx hx'.le).trans $ min_le_of_right_le $ min_le_left _ _) $
          (h₂ _ hy hy'.le).trans $ min_le_of_right_le $ min_le_left _ _)
    ... ≤ _ : begin
        have : ∀ x' y', x - y = x' - y' + (x - x') + (y' - y) := λ _ _, by abel,
        rw [sub_le_iff_le_add, norm_sub_rev _ x, ←add_assoc, this],
        exact norm_add₃_le _ _ _,
      end,
  calc ∥x + y∥ ≤ ∥x' + y'∥ + ∥x' - x∥ + ∥y' - y∥ : begin
        have : ∀ x' y', x + y = x' + y' + (x - x') + (y - y') := λ _ _, by abel,
        rw [norm_sub_rev, norm_sub_rev y', this],
        exact norm_add₃_le _ _ _,
      end
    ... ≤ 2 - δ + δ' + δ'
        : add_le_add_three (h (h₁ _ hx') (h₁ _ hy') hxy') (h₂ _ hx hx'.le) (h₂ _ hy hy'.le)
    ... ≤ 2 - δ' : begin
        rw [←le_sub_iff_add_le, ←le_sub_iff_add_le, sub_sub, sub_sub],
        refine sub_le_sub_left _ _,
        ring_nf,
        rw ←mul_div_cancel' δ three_ne_zero,
        exact mul_le_mul_of_nonneg_left (min_le_of_right_le $ min_le_right _ _) three_pos.le,
      end,
end

lemma exists_forall_closed_ball_dist_add_le_two_mul_sub (hε : 0 < ε) (r : ℝ) :
  ∃ δ, 0 < δ ∧ ∀ ⦃x : E⦄, ∥x∥ ≤ r → ∀ ⦃y⦄, ∥y∥ ≤ r → ε ≤ ∥x - y∥ → ∥x + y∥ ≤ 2 * r - δ :=
begin
  obtain hr | hr := le_or_lt r 0,
  { exact ⟨1, one_pos, λ x hx y hy h, (hε.not_le $ h.trans $ (norm_sub_le _ _).trans $
     add_nonpos (hx.trans hr) (hy.trans hr)).elim⟩ },
  obtain ⟨δ, hδ, h⟩ := exists_forall_closed_ball_dist_add_le_two_sub E (div_pos hε hr),
  refine ⟨δ * r, mul_pos hδ hr, λ x hx y hy hxy, _⟩,
  rw [←div_le_one hr, div_eq_inv_mul, ←norm_smul_of_nonneg (inv_nonneg.2 hr.le)] at hx hy;
    try { apply_instance },
  have := h hx hy,
  simp_rw [←smul_add, ←smul_sub, norm_smul_of_nonneg (inv_nonneg.2 hr.le), ←div_eq_inv_mul,
    div_le_div_right hr, div_le_iff hr, sub_mul] at this,
  exact this hxy,
end

end semi_normed_group

variables [normed_group E] [normed_space ℝ E] [uniform_convex_space E]

@[priority 100] -- See note [lower instance priority]
instance uniform_convex_space.to_strict_convex_space : strict_convex_space ℝ E :=
strict_convex_space.of_norm_add_lt one_half_pos one_half_pos (add_halves _) $ λ x y hx hy hxy, begin
  obtain ⟨δ, hδ, h⟩ := exists_forall_closed_ball_dist_add_le_two_sub E (norm_sub_pos_iff.2 hxy),
  rw [←smul_add, norm_smul_of_nonneg one_half_pos.le, ←lt_div_iff' one_half_pos, one_div_one_div],
  exact (h hx hy le_rfl).trans_lt (sub_lt_self _ hδ),
end


<|start_filename|>src/algebra/ring/idempotents.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.ring.basic
import algebra.group_power.basic
import tactic.nth_rewrite.default

/-!
# Idempotents

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] [group_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)),
  lift p to G₀ˣ using is_unit.mk0 _ hp,
  exact_mod_cast iff_eq_one.mp (by exact_mod_cast h.eq),
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


<|start_filename|>src/algebra/big_operators/fin.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>, <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.big_operators.basic
import data.fintype.fin
import data.fintype.card
import logic.equiv.fin
/-!
# Big operators and `fin`

Some results about products and sums over the type `fin`.

The most important results are the induction formulas `fin.prod_univ_cast_succ`
and `fin.prod_univ_succ`, and the formula `fin.prod_const` for the product of a
constant function. These results have variants for sums instead of products.

-/

open_locale big_operators

open finset

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

namespace finset

@[to_additive]
theorem prod_range [comm_monoid β] {n : ℕ} (f : ℕ → β) :
  ∏ i in finset.range n, f i = ∏ i : fin n, f i :=
prod_bij'
  (λ k w, ⟨k, mem_range.mp w⟩)
  (λ a ha, mem_univ _)
  (λ a ha, congr_arg _ (fin.coe_mk _).symm)
  (λ a m, a)
  (λ a m, mem_range.mpr a.prop)
  (λ a ha, fin.coe_mk _)
  (λ a ha, fin.eta _ _)

end finset

namespace fin

@[to_additive]
theorem prod_univ_def [comm_monoid β] {n : ℕ} (f : fin n → β) :
  ∏ i, f i = ((list.fin_range n).map f).prod :=
by simp [univ_def, finset.fin_range]

@[to_additive]
theorem prod_of_fn [comm_monoid β] {n : ℕ} (f : fin n → β) :
  (list.of_fn f).prod = ∏ i, f i :=
by rw [list.of_fn_eq_map, prod_univ_def]

/-- A product of a function `f : fin 0 → β` is `1` because `fin 0` is empty -/
@[to_additive "A sum of a function `f : fin 0 → β` is `0` because `fin 0` is empty"]
theorem prod_univ_zero [comm_monoid β] (f : fin 0 → β) : ∏ i, f i = 1 := rfl

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f x`, for some `x : fin (n + 1)` times the remaining product -/
@[to_additive
/- A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the sum of `f x`, for some `x : fin (n + 1)` plus the remaining product -/]
theorem prod_univ_succ_above [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β) (x : fin (n + 1)) :
  ∏ i, f i = f x * ∏ i : fin n, f (x.succ_above i) :=
by rw [univ_succ_above, prod_cons, finset.prod_map, rel_embedding.coe_fn_to_embedding]

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f 0` plus the remaining product -/
@[to_additive
/- A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the sum of `f 0` plus the remaining product -/]
theorem prod_univ_succ [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β) :
  ∏ i, f i = f 0 * ∏ i : fin n, f i.succ :=
prod_univ_succ_above f 0

/-- A product of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the product of `f (fin.last n)` plus the remaining product -/
@[to_additive
/- A sum of a function `f : fin (n + 1) → β` over all `fin (n + 1)`
is the sum of `f (fin.last n)` plus the remaining sum -/]
theorem prod_univ_cast_succ [comm_monoid β] {n : ℕ} (f : fin (n + 1) → β) :
  ∏ i, f i = (∏ i : fin n, f i.cast_succ) * f (last n) :=
by simpa [mul_comm] using prod_univ_succ_above f (last n)

@[to_additive] lemma prod_cons [comm_monoid β] {n : ℕ} (x : β) (f : fin n → β) :
  ∏ i : fin n.succ, (cons x f : fin n.succ → β) i = x * ∏ i : fin n, f i :=
by simp_rw [prod_univ_succ, cons_zero, cons_succ]

@[to_additive sum_univ_one] theorem prod_univ_one [comm_monoid β] (f : fin 1 → β) :
  ∏ i, f i = f 0 :=
by simp

@[to_additive] theorem prod_univ_two [comm_monoid β] (f : fin 2 → β) :
  ∏ i, f i = f 0 * f 1 :=
by simp [prod_univ_succ]

lemma sum_pow_mul_eq_add_pow {n : ℕ} {R : Type*} [comm_semiring R] (a b : R) :
  ∑ s : finset (fin n), a ^ s.card * b ^ (n - s.card) = (a + b) ^ n :=
by simpa using fintype.sum_pow_mul_eq_add_pow (fin n) a b

lemma prod_const [comm_monoid α] (n : ℕ) (x : α) : ∏ i : fin n, x = x ^ n := by simp

lemma sum_const [add_comm_monoid α] (n : ℕ) (x : α) : ∑ i : fin n, x = n • x := by simp

@[to_additive]
lemma prod_filter_zero_lt {M : Type*} [comm_monoid M] {n : ℕ} {v : fin n.succ → M} :
  ∏ i in univ.filter (λ (i : fin n.succ), 0 < i), v i = ∏ (j : fin n), v j.succ :=
by rw [univ_filter_zero_lt, finset.prod_map, rel_embedding.coe_fn_to_embedding, coe_succ_embedding]

@[to_additive]
lemma prod_filter_succ_lt {M : Type*} [comm_monoid M] {n : ℕ} (j : fin n) (v : fin n.succ → M) :
  ∏ i in univ.filter (λ i, j.succ < i), v i =
    ∏ j in univ.filter (λ i, j < i), v j.succ :=
by rw [univ_filter_succ_lt, finset.prod_map, rel_embedding.coe_fn_to_embedding, coe_succ_embedding]

@[to_additive]
lemma prod_congr' {M : Type*} [comm_monoid M] {a b : ℕ} (f : fin b → M) (h : a = b) :
  ∏ (i : fin a), f (cast h i) = ∏ (i : fin b), f i :=
by { subst h, congr, ext, congr, ext, rw coe_cast, }

@[to_additive]
lemma prod_univ_add {M : Type*} [comm_monoid M] {a b : ℕ} (f : fin (a+b) → M) :
  ∏ (i : fin (a+b)), f i =
  (∏ (i : fin a), f (cast_add b i)) * ∏ (i : fin b), f (nat_add a i) :=
begin
  rw fintype.prod_equiv fin_sum_fin_equiv.symm f (λ i, f (fin_sum_fin_equiv.to_fun i)), swap,
  { intro x,
    simp only [equiv.to_fun_as_coe, equiv.apply_symm_apply], },
  apply prod_on_sum,
end

@[to_additive]
lemma prod_trunc {M : Type*} [comm_monoid M] {a b : ℕ} (f : fin (a+b) → M)
  (hf : ∀ (j : fin b), f (nat_add a j) = 1) :
  ∏ (i : fin (a+b)), f i =
  ∏ (i : fin a), f (cast_le (nat.le.intro rfl) i) :=
by simpa only [prod_univ_add, fintype.prod_eq_one _ hf, mul_one]

end fin

namespace list

@[to_additive]
lemma prod_take_of_fn [comm_monoid α] {n : ℕ} (f : fin n → α) (i : ℕ) :
  ((of_fn f).take i).prod = ∏ j in finset.univ.filter (λ (j : fin n), j.val < i), f j :=
begin
  have A : ∀ (j : fin n), ¬ ((j : ℕ) < 0) := λ j, not_lt_bot,
  induction i with i IH, { simp [A] },
  by_cases h : i < n,
  { have : i < length (of_fn f), by rwa [length_of_fn f],
    rw prod_take_succ _ _ this,
    have A : ((finset.univ : finset (fin n)).filter (λ j, j.val < i + 1))
      = ((finset.univ : finset (fin n)).filter (λ j, j.val < i)) ∪ {(⟨i, h⟩ : fin n)},
        by { ext j, simp [nat.lt_succ_iff_lt_or_eq, fin.ext_iff, - add_comm] },
    have B : _root_.disjoint (finset.filter (λ (j : fin n), j.val < i) finset.univ)
      (singleton (⟨i, h⟩ : fin n)), by simp,
    rw [A, finset.prod_union B, IH],
    simp },
  { have A : (of_fn f).take i = (of_fn f).take i.succ,
    { rw ← length_of_fn f at h,
      have : length (of_fn f) ≤ i := not_lt.mp h,
      rw [take_all_of_le this, take_all_of_le (le_trans this (nat.le_succ _))] },
    have B : ∀ (j : fin n), ((j : ℕ) < i.succ) = ((j : ℕ) < i),
    { assume j,
      have : (j : ℕ) < i := lt_of_lt_of_le j.2 (not_lt.mp h),
      simp [this, lt_trans this (nat.lt_succ_self _)] },
    simp [← A, B, IH] }
end

@[to_additive]
lemma prod_of_fn [comm_monoid α] {n : ℕ} {f : fin n → α} :
  (of_fn f).prod = ∏ i, f i :=
begin
  convert prod_take_of_fn f n,
  { rw [take_all_of_le (le_of_eq (length_of_fn f))] },
  { have : ∀ (j : fin n), (j : ℕ) < n := λ j, j.is_lt,
    simp [this] }
end

lemma alternating_sum_eq_finset_sum {G : Type*} [add_comm_group G] :
  ∀ (L : list G), alternating_sum L = ∑ i : fin L.length, (-1 : ℤ) ^ (i : ℕ) • L.nth_le i i.is_lt
| [] := by { rw [alternating_sum, finset.sum_eq_zero], rintro ⟨i, ⟨⟩⟩ }
| (g :: []) := by simp
| (g :: h :: L) :=
calc g + -h + L.alternating_sum
    = g + -h + ∑ i : fin L.length, (-1 : ℤ) ^ (i : ℕ) • L.nth_le i i.2 :
      congr_arg _ (alternating_sum_eq_finset_sum _)
... = ∑ i : fin (L.length + 2), (-1 : ℤ) ^ (i : ℕ) • list.nth_le (g :: h :: L) i _ :
begin
  rw [fin.sum_univ_succ, fin.sum_univ_succ, add_assoc],
  unfold_coes,
  simp [nat.succ_eq_add_one, pow_add],
  refl,
end

@[to_additive]
lemma alternating_prod_eq_finset_prod {G : Type*} [comm_group G] :
  ∀ (L : list G), alternating_prod L = ∏ i : fin L.length, (L.nth_le i i.2) ^ ((-1 : ℤ) ^ (i : ℕ))
| [] := by { rw [alternating_prod, finset.prod_eq_one], rintro ⟨i, ⟨⟩⟩ }
| (g :: []) :=
begin
  show g = ∏ i : fin 1, [g].nth_le i i.2 ^ (-1 : ℤ) ^ (i : ℕ),
  rw [fin.prod_univ_succ], simp,
end
| (g :: h :: L) :=
calc g * h⁻¹ * L.alternating_prod
    = g * h⁻¹ * ∏ i : fin L.length, L.nth_le i i.2 ^ (-1 : ℤ) ^ (i : ℕ) :
      congr_arg _ (alternating_prod_eq_finset_prod _)
... = ∏ i : fin (L.length + 2), list.nth_le (g :: h :: L) i _ ^ (-1 : ℤ) ^ (i : ℕ) :
begin
  rw [fin.prod_univ_succ, fin.prod_univ_succ, mul_assoc],
  unfold_coes,
  simp [nat.succ_eq_add_one, pow_add],
  refl,
end

end list


<|start_filename|>src/linear_algebra/matrix/spectrum.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.inner_product_space.spectrum
import linear_algebra.matrix.hermitian

/-! # Spectral theory of hermitian matrices

This file proves the spectral theorem for matrices. The proof of the spectral theorem is based on
the spectral theorem for linear maps (`diagonalization_basis_apply_self_apply`).

## Tags

spectral theorem, diagonalization theorem

-/

namespace matrix

variables {𝕜 : Type*} [is_R_or_C 𝕜] [decidable_eq 𝕜] {n : Type*} [fintype n] [decidable_eq n]
variables {A : matrix n n 𝕜}

open_locale matrix

namespace is_hermitian

variables (hA : A.is_hermitian)

/-- The eigenvalues of a hermitian matrix, indexed by `fin (fintype.card n)` where `n` is the index
type of the matrix. -/
noncomputable def eigenvalues₀ : fin (fintype.card n) → ℝ :=
@inner_product_space.is_self_adjoint.eigenvalues 𝕜 _ _ (pi_Lp 2 (λ (_ : n), 𝕜)) _ A.to_lin'
  (is_hermitian_iff_is_self_adjoint.1 hA) _ (fintype.card n) finrank_euclidean_space

/-- The eigenvalues of a hermitian matrix, reusing the index `n` of the matrix entries. -/
noncomputable def eigenvalues : n → ℝ :=
λ i, hA.eigenvalues₀ $ (fintype.equiv_of_card_eq (fintype.card_fin _)).symm i

/-- A choice of an orthonormal basis of eigenvectors of a hermitian matrix. -/
noncomputable def eigenvector_basis : basis n 𝕜 (n → 𝕜) :=
(@inner_product_space.is_self_adjoint.eigenvector_basis 𝕜 _ _
    (pi_Lp 2 (λ (_ : n), 𝕜)) _ A.to_lin' (is_hermitian_iff_is_self_adjoint.1 hA) _
    (fintype.card n) finrank_euclidean_space).reindex
  (fintype.equiv_of_card_eq (fintype.card_fin _))

/-- A matrix whose columns are an orthonormal basis of eigenvectors of a hermitian matrix. -/
noncomputable def eigenvector_matrix : matrix n n 𝕜 :=
(pi.basis_fun 𝕜 n).to_matrix (eigenvector_basis hA)

/-- The inverse of `eigenvector_matrix` -/
noncomputable def eigenvector_matrix_inv : matrix n n 𝕜 :=
(eigenvector_basis hA).to_matrix (pi.basis_fun 𝕜 n)

lemma eigenvector_matrix_mul_inv :
  hA.eigenvector_matrix ⬝ hA.eigenvector_matrix_inv = 1 :=
by apply basis.to_matrix_mul_to_matrix_flip

/-- *Diagonalization theorem*, *spectral theorem* for matrices; A hermitian matrix can be
diagonalized by a change of basis.

For the spectral theorem on linear maps, see `diagonalization_basis_apply_self_apply`. -/
theorem spectral_theorem :
  hA.eigenvector_matrix_inv ⬝ A =
    diagonal (coe ∘ hA.eigenvalues) ⬝ hA.eigenvector_matrix_inv :=
begin
  rw [eigenvector_matrix_inv, basis_to_matrix_basis_fun_mul],
  ext i j,
  convert @inner_product_space.is_self_adjoint.diagonalization_basis_apply_self_apply 𝕜 _ _
    (pi_Lp 2 (λ (_ : n), 𝕜)) _ A.to_lin' (is_hermitian_iff_is_self_adjoint.1 hA) _ (fintype.card n)
    finrank_euclidean_space (euclidean_space.single j 1)
    ((fintype.equiv_of_card_eq (fintype.card_fin _)).symm i),
  { rw [eigenvector_basis, inner_product_space.is_self_adjoint.diagonalization_basis,
      to_lin'_apply],
    simp only [basis.to_matrix, basis.coe_to_orthonormal_basis_repr, basis.equiv_fun_apply],
    simp_rw [basis.reindex_repr, euclidean_space.single, pi_Lp.equiv_symm_apply', mul_vec_single,
      mul_one],
    refl },
  { simp only [diagonal_mul, (∘), eigenvalues, eigenvector_basis,
      inner_product_space.is_self_adjoint.diagonalization_basis],
    rw [basis.to_matrix_apply, basis.coe_to_orthonormal_basis_repr, basis.reindex_repr,
      basis.equiv_fun_apply, pi.basis_fun_apply, eigenvalues₀, linear_map.coe_std_basis,
      euclidean_space.single, pi_Lp.equiv_symm_apply'] }
end

end is_hermitian

end matrix


<|start_filename|>src/algebraic_geometry/stalks.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebraic_geometry.presheafed_space
import category_theory.limits.final
import topology.sheaves.stalks

/-!
# Stalks for presheaved spaces

This file lifts constructions of stalks and pushforwards of stalks to work with
the category of presheafed spaces. Additionally, we prove that restriction of
presheafed spaces does not change the stalks.
-/

noncomputable theory

universes v u v' u'

open category_theory
open category_theory.limits category_theory.category category_theory.functor
open algebraic_geometry
open topological_space
open opposite

variables {C : Type u} [category.{v} C] [has_colimits C]

local attribute [tidy] tactic.op_induction'

open Top.presheaf

namespace algebraic_geometry.PresheafedSpace

/--
The stalk at `x` of a `PresheafedSpace`.
-/
abbreviation stalk (X : PresheafedSpace C) (x : X) : C := X.presheaf.stalk x

/--
A morphism of presheafed spaces induces a morphism of stalks.
-/
def stalk_map {X Y : PresheafedSpace C} (α : X ⟶ Y) (x : X) : Y.stalk (α.base x) ⟶ X.stalk x :=
(stalk_functor C (α.base x)).map (α.c) ≫ X.presheaf.stalk_pushforward C α.base x

@[simp, elementwise, reassoc]
lemma stalk_map_germ {X Y : PresheafedSpace C} (α : X ⟶ Y) (U : opens Y.carrier)
  (x : (opens.map α.base).obj U) :
  Y.presheaf.germ ⟨α.base x, x.2⟩ ≫ stalk_map α ↑x = α.c.app (op U) ≫ X.presheaf.germ x :=
by rw [stalk_map, stalk_functor_map_germ_assoc, stalk_pushforward_germ]

section restrict

/--
For an open embedding `f : U ⟶ X` and a point `x : U`, we get an isomorphism between the stalk
of `X` at `f x` and the stalk of the restriction of `X` along `f` at t `x`.
-/
def restrict_stalk_iso {U : Top} (X : PresheafedSpace C)
  {f : U ⟶ (X : Top.{v})} (h : open_embedding f) (x : U) :
  (X.restrict h).stalk x ≅ X.stalk (f x) :=
begin
  -- As a left adjoint, the functor `h.is_open_map.functor_nhds x` is initial.
  haveI := initial_of_adjunction (h.is_open_map.adjunction_nhds x),
  -- Typeclass resolution knows that the opposite of an initial functor is final. The result
  -- follows from the general fact that postcomposing with a final functor doesn't change colimits.
  exact final.colimit_iso (h.is_open_map.functor_nhds x).op
    ((open_nhds.inclusion (f x)).op ⋙ X.presheaf),
end

@[simp, elementwise, reassoc]
lemma restrict_stalk_iso_hom_eq_germ {U : Top} (X : PresheafedSpace C) {f : U ⟶ (X : Top.{v})}
  (h : open_embedding f) (V : opens U) (x : U) (hx : x ∈ V) :
  (X.restrict h).presheaf.germ ⟨x, hx⟩ ≫ (restrict_stalk_iso X h x).hom =
  X.presheaf.germ ⟨f x, show f x ∈ h.is_open_map.functor.obj V, from ⟨x, hx, rfl⟩⟩ :=
colimit.ι_pre ((open_nhds.inclusion (f x)).op ⋙ X.presheaf)
  (h.is_open_map.functor_nhds x).op (op ⟨V, hx⟩)

@[simp, elementwise, reassoc]
lemma restrict_stalk_iso_inv_eq_germ {U : Top} (X : PresheafedSpace C) {f : U ⟶ (X : Top.{v})}
  (h : open_embedding f) (V : opens U) (x : U) (hx : x ∈ V) :
  X.presheaf.germ ⟨f x, show f x ∈ h.is_open_map.functor.obj V, from ⟨x, hx, rfl⟩⟩ ≫
  (restrict_stalk_iso X h x).inv = (X.restrict h).presheaf.germ ⟨x, hx⟩ :=
by rw [← restrict_stalk_iso_hom_eq_germ, category.assoc, iso.hom_inv_id, category.comp_id]

lemma restrict_stalk_iso_inv_eq_of_restrict {U : Top} (X : PresheafedSpace C)
  {f : U ⟶ (X : Top.{v})} (h : open_embedding f) (x : U) :
    (X.restrict_stalk_iso h x).inv = stalk_map (X.of_restrict h) x :=
begin
  ext V,
  induction V using opposite.rec,
  let i : (h.is_open_map.functor_nhds x).obj ((open_nhds.map f x).obj V) ⟶ V :=
    hom_of_le (set.image_preimage_subset f _),
  erw [iso.comp_inv_eq, colimit.ι_map_assoc, colimit.ι_map_assoc, colimit.ι_pre],
  simp_rw category.assoc,
  erw colimit.ι_pre ((open_nhds.inclusion (f x)).op ⋙ X.presheaf)
    (h.is_open_map.functor_nhds x).op,
  erw ← X.presheaf.map_comp_assoc,
  exact (colimit.w ((open_nhds.inclusion (f x)).op ⋙ X.presheaf) i.op).symm,
end

instance of_restrict_stalk_map_is_iso {U : Top} (X : PresheafedSpace C)
  {f : U ⟶ (X : Top.{v})} (h : open_embedding f) (x : U) :
  is_iso (stalk_map (X.of_restrict h) x) :=
by { rw ← restrict_stalk_iso_inv_eq_of_restrict, apply_instance }

end restrict

namespace stalk_map

@[simp] lemma id (X : PresheafedSpace C) (x : X) : stalk_map (𝟙 X) x = 𝟙 (X.stalk x) :=
begin
  dsimp [stalk_map],
  simp only [stalk_pushforward.id],
  rw [←map_comp],
  convert (stalk_functor C x).map_id X.presheaf,
  tidy,
end

-- TODO understand why this proof is still gross (i.e. requires using `erw`)
@[simp] lemma comp {X Y Z : PresheafedSpace C} (α : X ⟶ Y) (β : Y ⟶ Z) (x : X) :
  stalk_map (α ≫ β) x =
    (stalk_map β (α.base x) : Z.stalk (β.base (α.base x)) ⟶ Y.stalk (α.base x)) ≫
    (stalk_map α x : Y.stalk (α.base x) ⟶ X.stalk x) :=
begin
  dsimp [stalk_map, stalk_functor, stalk_pushforward],
  ext U,
  induction U using opposite.rec,
  cases U,
  simp only [colimit.ι_map_assoc, colimit.ι_pre_assoc, colimit.ι_pre,
    whisker_left_app, whisker_right_app,
    assoc, id_comp, map_id, map_comp],
  dsimp,
  simp only [map_id, assoc, pushforward.comp_inv_app],
  -- FIXME Why doesn't simp do this:
  erw [category_theory.functor.map_id],
  erw [category_theory.functor.map_id],
  erw [id_comp, id_comp],
end

/--
If `α = β` and `x = x'`, we would like to say that `stalk_map α x = stalk_map β x'`.
Unfortunately, this equality is not well-formed, as their types are not _definitionally_ the same.
To get a proper congruence lemma, we therefore have to introduce these `eq_to_hom` arrows on
either side of the equality.
-/
lemma congr {X Y : PresheafedSpace C} (α β : X ⟶ Y) (h₁ : α = β) (x x': X) (h₂ : x = x') :
  stalk_map α x ≫ eq_to_hom (show X.stalk x = X.stalk x', by rw h₂) =
  eq_to_hom (show Y.stalk (α.base x) = Y.stalk (β.base x'), by rw [h₁, h₂]) ≫ stalk_map β x' :=
stalk_hom_ext _ $ λ U hx, by { subst h₁, subst h₂, simp }

lemma congr_hom {X Y : PresheafedSpace C} (α β : X ⟶ Y) (h : α = β) (x : X) :
  stalk_map α x =
  eq_to_hom (show Y.stalk (α.base x) = Y.stalk (β.base x), by rw h) ≫ stalk_map β x :=
by rw [← stalk_map.congr α β h x x rfl, eq_to_hom_refl, category.comp_id]

lemma congr_point {X Y : PresheafedSpace C} (α : X ⟶ Y) (x x' : X) (h : x = x') :
  stalk_map α x ≫ eq_to_hom (show X.stalk x = X.stalk x', by rw h) =
  eq_to_hom (show Y.stalk (α.base x) = Y.stalk (α.base x'), by rw h) ≫ stalk_map α x' :=
by rw stalk_map.congr α α rfl x x' h

instance is_iso {X Y : PresheafedSpace C} (α : X ⟶ Y) [is_iso α] (x : X) :
  is_iso (stalk_map α x) :=
{ out := begin
  let β : Y ⟶ X := category_theory.inv α,
  have h_eq : (α ≫ β).base x = x,
  { rw [is_iso.hom_inv_id α, id_base, Top.id_app] },
  -- Intuitively, the inverse of the stalk map of `α` at `x` should just be the stalk map of `β`
  -- at `α x`. Unfortunately, we have a problem with dependent type theory here: Because `x`
  -- is not *definitionally* equal to `β (α x)`, the map `stalk_map β (α x)` has not the correct
  -- type for an inverse.
  -- To get a proper inverse, we need to compose with the `eq_to_hom` arrow
  -- `X.stalk x ⟶ X.stalk ((α ≫ β).base x)`.
  refine ⟨eq_to_hom (show X.stalk x = X.stalk ((α ≫ β).base x), by rw h_eq) ≫
    (stalk_map β (α.base x) : _), _, _⟩,
  { rw [← category.assoc, congr_point α x ((α ≫ β).base x) h_eq.symm, category.assoc],
    erw ← stalk_map.comp β α (α.base x),
    rw [congr_hom _ _ (is_iso.inv_hom_id α), stalk_map.id, eq_to_hom_trans_assoc,
      eq_to_hom_refl, category.id_comp] },
  { rw [category.assoc, ← stalk_map.comp, congr_hom _ _ (is_iso.hom_inv_id α),
    stalk_map.id, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp] },
end }

/--
An isomorphism between presheafed spaces induces an isomorphism of stalks.
-/
def stalk_iso {X Y : PresheafedSpace C} (α : X ≅ Y) (x : X) :
  Y.stalk (α.hom.base x) ≅ X.stalk x :=
as_iso (stalk_map α.hom x)

@[simp, reassoc, elementwise]
lemma stalk_specializes_stalk_map {X Y : PresheafedSpace C} (f : X ⟶ Y) {x y : X} (h : x ⤳ y) :
  Y.presheaf.stalk_specializes (f.base.map_specializes h) ≫ stalk_map f x =
    stalk_map f y ≫ X.presheaf.stalk_specializes h :=
by { delta PresheafedSpace.stalk_map, simp [stalk_map] }

end stalk_map

end algebraic_geometry.PresheafedSpace


<|start_filename|>src/category_theory/linear/linear_functor.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.preadditive.additive_functor
import category_theory.linear

/-!
# Linear Functors

An additive functor between two `R`-linear categories is called *linear*
if the induced map on hom types is a morphism of `R`-modules.

# Implementation details

`functor.linear` is a `Prop`-valued class, defined by saying that
for every two objects `X` and `Y`, the map
`F.map : (X ⟶ Y) → (F.obj X ⟶ F.obj Y)` is a morphism of `R`-modules.

-/

namespace category_theory

variables (R : Type*) [semiring R]

/-- An additive functor `F` is `R`-linear provided `F.map` is an `R`-module morphism. -/
class functor.linear {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] [linear R C] [linear R D] (F : C ⥤ D) [F.additive] : Prop :=
(map_smul' : Π {X Y : C} {f : X ⟶ Y} {r : R}, F.map (r • f) = r • F.map f . obviously)

section linear

namespace functor

section
variables {R} {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D] [category_theory.linear R C] [category_theory.linear R D]
  (F : C ⥤ D) [additive F] [linear R F]

@[simp]
lemma map_smul {X Y : C} (r : R) (f : X ⟶ Y) : F.map (r • f) = r • F.map f :=
functor.linear.map_smul'

instance : linear R (𝟭 C) :=
{}

instance {E : Type*} [category E] [preadditive E] [category_theory.linear R E]
  (G : D ⥤ E) [additive G] [linear R G]:
  linear R (F ⋙ G) :=
{}

variables (R)

/-- `F.map_linear_map` is an `R`-linear map whose underlying function is `F.map`. -/
@[simps]
def map_linear_map {X Y : C} : (X ⟶ Y) →ₗ[R] (F.obj X ⟶ F.obj Y) :=
{ map_smul' := λ r f, F.map_smul r f,
  ..F.map_add_hom }

lemma coe_map_linear_map {X Y : C} : ⇑(F.map_linear_map R : (X ⟶ Y) →ₗ[R] _) = @map C _ D _ F X Y :=
rfl

end

section induced_category
variables {C : Type*} {D : Type*} [category D] [preadditive D] [category_theory.linear R D]
   (F : C → D)

instance induced_functor_linear : functor.linear R (induced_functor F) := {}

end induced_category

section

variables {R} {C D : Type*} [category C] [category D]
  [preadditive C] [preadditive D]
  (F : C ⥤ D) [additive F]

instance nat_linear : F.linear ℕ :=
{ map_smul' := λ X Y f r, F.map_add_hom.map_nsmul f r, }

instance int_linear : F.linear ℤ :=
{ map_smul' := λ X Y f r, (F.map_add_hom : (X ⟶ Y) →+ (F.obj X ⟶ F.obj Y)).map_zsmul f r, }

variables [category_theory.linear ℚ C] [category_theory.linear ℚ D]

instance rat_linear : F.linear ℚ :=
{ map_smul' := λ X Y f r, F.map_add_hom.to_rat_linear_map.map_smul r f, }

end

end functor

namespace equivalence

variables {C D : Type*} [category C] [category D]
  [preadditive C] [linear R C] [preadditive D] [linear R D]

instance inverse_linear (e : C ≌ D) [e.functor.additive] [e.functor.linear R] :
  e.inverse.linear R :=
{ map_smul' := λ X Y r f, by { apply e.functor.map_injective, simp, }, }

end equivalence

end linear

end category_theory


<|start_filename|>src/set_theory/cardinal/schroeder_bernstein.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import order.fixed_points
import order.zorn

/-!
# Schröder-Bernstein theorem, well-ordering of cardinals

This file proves the Schröder-Bernstein theorem (see `schroeder_bernstein`), the well-ordering of
cardinals (see `min_injective`) and the totality of their order (see `total`).

## Notes

Cardinals are naturally ordered by `α ≤ β ↔ ∃ f : a → β, injective f`:
* `schroeder_bernstein` states that, given injections `α → β` and `β → α`, one can get a
  bijection `α → β`. This corresponds to the antisymmetry of the order.
* The order is also well-founded: any nonempty set of cardinals has a minimal element.
  `min_injective` states that by saying that there exists an element of the set that injects into
  all others.

Cardinals are defined and further developed in the file `set_theory.cardinal`.
-/

open set function
open_locale classical

universes u v

namespace function
namespace embedding

section antisymm
variables {α : Type u} {β : Type v}

/-- **The Schröder-Bernstein Theorem**:
Given injections `α → β` and `β → α`, we can get a bijection `α → β`. -/
theorem schroeder_bernstein {f : α → β} {g : β → α}
  (hf : function.injective f) (hg : function.injective g) : ∃ h : α → β, bijective h :=
begin
  casesI is_empty_or_nonempty β with hβ hβ,
  { haveI : is_empty α, from function.is_empty f,
    exact ⟨_, ((equiv.equiv_empty α).trans (equiv.equiv_empty β).symm).bijective⟩ },
  set F : set α →o set α :=
  { to_fun := λ s, (g '' (f '' s)ᶜ)ᶜ,
    monotone' := λ s t hst, compl_subset_compl.mpr $ image_subset _ $
     compl_subset_compl.mpr $ image_subset _ hst },
  set s : set α := F.lfp,
  have hs : (g '' (f '' s)ᶜ)ᶜ = s, from F.map_lfp,
  have hns : g '' (f '' s)ᶜ = sᶜ, from compl_injective (by simp [hs]),
  set g' := inv_fun g,
  have g'g : left_inverse g' g, from left_inverse_inv_fun hg,
  have hg'ns : g' '' sᶜ = (f '' s)ᶜ, by rw [← hns, g'g.image_image],
  set h : α → β := s.piecewise f g',
  have : surjective h, by rw [← range_iff_surjective, range_piecewise, hg'ns, union_compl_self],
  have : injective h,
  { refine (injective_piecewise_iff _).2 ⟨hf.inj_on _, _, _⟩,
    { intros x hx y hy hxy,
      obtain ⟨x', hx', rfl⟩ : x ∈ g '' (f '' s)ᶜ, by rwa hns,
      obtain ⟨y', hy', rfl⟩ : y ∈ g '' (f '' s)ᶜ, by rwa hns,
      rw [g'g _, g'g _] at hxy, rw hxy },
    { intros x hx y hy hxy,
      obtain ⟨y', hy', rfl⟩ : y ∈ g '' (f '' s)ᶜ, by rwa hns,
      rw [g'g _] at hxy,
      exact hy' ⟨x, hx, hxy⟩ } },
  exact ⟨h, ‹injective h›, ‹surjective h›⟩
end

/-- **The Schröder-Bernstein Theorem**: Given embeddings `α ↪ β` and `β ↪ α`, there exists an
equivalence `α ≃ β`. -/
theorem antisymm : (α ↪ β) → (β ↪ α) → nonempty (α ≃ β)
| ⟨e₁, h₁⟩ ⟨e₂, h₂⟩ :=
  let ⟨f, hf⟩ := schroeder_bernstein h₁ h₂ in
  ⟨equiv.of_bijective f hf⟩

end antisymm

section wo
parameters {ι : Type u} (β : ι → Type v)

@[reducible] private def sets := {s : set (∀ i, β i) |
  ∀ (x ∈ s) (y ∈ s) i, (x : ∀ i, β i) i = y i → x = y}

/-- The cardinals are well-ordered. We express it here by the fact that in any set of cardinals
there is an element that injects into the others. See `cardinal.linear_order` for (one of) the
lattice instances. -/
theorem min_injective [I : nonempty ι] : ∃ i, nonempty (∀ j, β i ↪ β j) :=
let ⟨s, hs, ms⟩ := show ∃ s ∈ sets, ∀ a ∈ sets, s ⊆ a → a = s, from
  zorn_subset sets (λ c hc hcc, ⟨⋃₀ c,
    λ x ⟨p, hpc, hxp⟩ y ⟨q, hqc, hyq⟩ i hi, (hcc.total hpc hqc).elim
      (λ h, hc hqc x (h hxp) y hyq i hi) (λ h, hc hpc x hxp y (h hyq) i hi),
  λ _, subset_sUnion_of_mem⟩) in
let ⟨i, e⟩ := show ∃ i, ∀ y, ∃ x ∈ s, (x : ∀ i, β i) i = y, from
  classical.by_contradiction $ λ h,
  have h : ∀ i, ∃ y, ∀ x ∈ s, (x : ∀ i, β i) i ≠ y,
    by simpa only [not_exists, not_forall] using h,
  let ⟨f, hf⟩ := classical.axiom_of_choice h in
  have f ∈ s, from
    have insert f s ∈ sets := λ x hx y hy, begin
      cases hx; cases hy, {simp [hx, hy]},
      { subst x, exact λ i e, (hf i y hy e.symm).elim },
      { subst y, exact λ i e, (hf i x hx e).elim },
      { exact hs x hx y hy }
    end, ms _ this (subset_insert f s) ▸ mem_insert _ _,
  let ⟨i⟩ := I in hf i f this rfl in
let ⟨f, hf⟩ := classical.axiom_of_choice e in
⟨i, ⟨λ j, ⟨λ a, f a j, λ a b e',
  let ⟨sa, ea⟩ := hf a, ⟨sb, eb⟩ := hf b in
  by rw [← ea, ← eb, hs _ sa _ sb _ e']⟩⟩⟩

end wo

/-- The cardinals are totally ordered. See `cardinal.linear_order` for (one of) the lattice
instance. -/
theorem total (α : Type u) (β : Type v) : nonempty (α ↪ β) ∨ nonempty (β ↪ α) :=
match @min_injective bool (λ b, cond b (ulift α) (ulift.{(max u v) v} β)) ⟨tt⟩ with
| ⟨tt, ⟨h⟩⟩ := let ⟨f, hf⟩ := h ff in or.inl ⟨embedding.congr equiv.ulift equiv.ulift ⟨f, hf⟩⟩
| ⟨ff, ⟨h⟩⟩ := let ⟨f, hf⟩ := h tt in or.inr ⟨embedding.congr equiv.ulift equiv.ulift ⟨f, hf⟩⟩
end

end embedding
end function


<|start_filename|>src/linear_algebra/multilinear/finite_dimensional.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import linear_algebra.multilinear.basic
import linear_algebra.free_module.finite.basic

/-! # Multilinear maps over finite dimensional spaces

The main results are that multilinear maps over finitely-generated, free modules are
finitely-generated and free.

* `module.finite.multilinear_map`
* `module.free.multilinear_map`

We do not put this in `linear_algebra/multilinear_map/basic` to avoid making the imports too large
there.
-/

namespace multilinear_map

variables {ι R M₂ : Type*} {M₁ : ι → Type*}
variables [decidable_eq ι]
variables [fintype ι] [comm_ring R] [add_comm_group M₂] [module R M₂]
variables [Π i, add_comm_group (M₁ i)] [Π i, module R (M₁ i)]
variables [module.finite R M₂] [module.free R M₂]
variables [∀ i, module.finite R (M₁ i)] [∀ i, module.free R (M₁ i)]

-- the induction requires us to show both at once
private lemma free_and_finite :
  module.free R (multilinear_map R M₁ M₂) ∧ module.finite R (multilinear_map R M₁ M₂) :=
begin
  -- the `fin n` case is sufficient
  suffices : ∀ n (N : fin n → Type*) [Π i, add_comm_group (N i)],
    by exactI ∀ [Π i, module R (N i)],
    by exactI ∀ [∀ i, module.finite R (N i)] [∀ i, module.free R (N i)],
      module.free R (multilinear_map R N M₂) ∧ module.finite R (multilinear_map R N M₂),
  { casesI this _ (M₁ ∘ (fintype.equiv_fin ι).symm),
    have e := dom_dom_congr_linear_equiv' R M₁ M₂ (fintype.equiv_fin ι),
    exact ⟨module.free.of_equiv e.symm, module.finite.equiv e.symm⟩, },
  introsI n N _ _ _ _,
  unfreezingI { induction n with n ih },
  { exact ⟨module.free.of_equiv (const_linear_equiv_of_is_empty R N M₂),
           module.finite.equiv (const_linear_equiv_of_is_empty R N M₂)⟩ },
  { suffices :
      module.free R (N 0 →ₗ[R] multilinear_map R (λ (i : fin n), N i.succ) M₂) ∧
      module.finite R (N 0 →ₗ[R] multilinear_map R (λ (i : fin n), N i.succ) M₂),
    { casesI this,
      exact ⟨module.free.of_equiv (multilinear_curry_left_equiv R N M₂),
            module.finite.equiv (multilinear_curry_left_equiv R N M₂)⟩ },
    casesI ih (λ i, N i.succ),
    exact ⟨module.free.linear_map _ _ _, module.finite.linear_map _ _⟩ },
end

instance _root_.module.finite.multilinear_map : module.finite R (multilinear_map R M₁ M₂) :=
free_and_finite.2

instance _root_.module.free.multilinear_map : module.free R (multilinear_map R M₁ M₂) :=
free_and_finite.1

end multilinear_map


<|start_filename|>src/probability/strong_law.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import probability.ident_distrib
import measure_theory.function.l2_space
import measure_theory.integral.interval_integral
import analysis.specific_limits.floor_pow
import analysis.p_series
import analysis.asymptotics.specific_asymptotics

/-!
# The strong law of large numbers

We prove the strong law of large numbers, in `probability_theory.strong_law_ae`:
If `X n` is a sequence of independent identically distributed integrable real-valued random
variables, then `∑ i in range n, X i / n` converges almost surely to `𝔼[X 0]`.
We give here the strong version, due to Etemadi, that only requires pairwise independence.

## Implementation

We follow the proof by Etemadi
[Etemadi, *An elementary proof of the strong law of large numbers*][etemadi_strong_law],
which goes as follows.

It suffices to prove the result for nonnegative `X`, as one can prove the general result by
splitting a general `X` into its positive part and negative part.
Consider `Xₙ` a sequence of nonnegative integrable identically distributed pairwise independent
random variables. Let `Yₙ` be the truncation of `Xₙ` up to `n`. We claim that
* Almost surely, `Xₙ = Yₙ` for all but finitely many indices. Indeed, `∑ ℙ (Xₙ ≠ Yₙ)` is bounded by
  `1 + 𝔼[X]` (see `sum_prob_mem_Ioc_le` and `tsum_prob_mem_Ioi_lt_top`).
* Let `c > 1`. Along the sequence `n = c ^ k`, then `(∑_{i=0}^{n-1} Yᵢ - 𝔼[Yᵢ])/n` converges almost
  surely to `0`. This follows from a variance control, as
```
  ∑_k ℙ (|∑_{i=0}^{c^k - 1} Yᵢ - 𝔼[Yᵢ]| > c^k ε)
    ≤ ∑_k (c^k ε)^{-2} ∑_{i=0}^{c^k - 1} Var[Yᵢ]    (by Markov inequality)
    ≤ ∑_i (C/i^2) Var[Yᵢ]                           (as ∑_{c^k > i} 1/(c^k)^2 ≤ C/i^2)
    ≤ ∑_i (C/i^2) 𝔼[Yᵢ^2]
    ≤ 2C 𝔼[X^2]                                     (see `sum_variance_truncation_le`)
```
* As `𝔼[Yᵢ]` converges to `𝔼[X]`, it follows from the two previous items and Cesaro that, along
  the sequence `n = c^k`, one has `(∑_{i=0}^{n-1} Xᵢ) / n → 𝔼[X]` almost surely.
* To generalize it to all indices, we use the fact that `∑_{i=0}^{n-1} Xᵢ` is nondecreasing and
  that, if `c` is close enough to `1`, the gap between `c^k` and `c^(k+1)` is small.
-/

noncomputable theory

open measure_theory filter finset asymptotics
open set (indicator)

open_locale topological_space big_operators measure_theory probability_theory ennreal nnreal

namespace probability_theory

/-! ### Prerequisites on truncations -/

section truncation

variables {α : Type*}

/-- Truncating a real-valued function to the interval `(-A, A]`. -/
def truncation (f : α → ℝ) (A : ℝ) :=
(indicator (set.Ioc (-A) A) id) ∘ f

variables {m : measurable_space α} {μ : measure α} {f : α → ℝ}

lemma _root_.measure_theory.ae_strongly_measurable.truncation
  (hf : ae_strongly_measurable f μ) {A : ℝ} :
  ae_strongly_measurable (truncation f A) μ :=
begin
  apply ae_strongly_measurable.comp_ae_measurable _ hf.ae_measurable,
  exact (strongly_measurable_id.indicator measurable_set_Ioc).ae_strongly_measurable,
end

lemma abs_truncation_le_bound (f : α → ℝ) (A : ℝ) (x : α) :
  |truncation f A x| ≤ |A| :=
begin
  simp only [truncation, set.indicator, set.mem_Icc, id.def, function.comp_app],
  split_ifs,
  { exact abs_le_abs h.2 (neg_le.2 h.1.le) },
  { simp [abs_nonneg] }
end

@[simp] lemma truncation_zero (f : α → ℝ) :
  truncation f 0 = 0 :=
by simp [truncation]

lemma abs_truncation_le_abs_self (f : α → ℝ) (A : ℝ) (x : α) :
  |truncation f A x| ≤ |f x| :=
begin
  simp only [truncation, indicator, set.mem_Icc, id.def, function.comp_app],
  split_ifs,
  { exact le_rfl },
  { simp [abs_nonneg] },
end

lemma truncation_eq_self {f : α → ℝ} {A : ℝ} {x : α} (h : |f x| < A) :
  truncation f A x = f x :=
begin
  simp only [truncation, indicator, set.mem_Icc, id.def, function.comp_app, ite_eq_left_iff],
  assume H,
  apply H.elim,
  simp [(abs_lt.1 h).1, (abs_lt.1 h).2.le],
end

lemma truncation_eq_of_nonneg {f : α → ℝ} {A : ℝ} (h : ∀ x, 0 ≤ f x) :
  truncation f A = (indicator (set.Ioc 0 A) id) ∘ f :=
begin
  ext x,
  rcases (h x).lt_or_eq with hx|hx,
  { simp only [truncation, indicator, hx, set.mem_Ioc, id.def, function.comp_app, true_and],
    by_cases h'x : f x ≤ A,
    { have : - A < f x, by linarith [h x],
      simp only [this, true_and] },
    { simp only [h'x, and_false] } },
  { simp only [truncation, indicator, hx, id.def, function.comp_app, if_t_t]},
end

lemma truncation_nonneg {f : α → ℝ} (A : ℝ) {x : α} (h : 0 ≤ f x) : 0 ≤ truncation f A x :=
set.indicator_apply_nonneg $ λ _, h

lemma _root_.measure_theory.ae_strongly_measurable.mem_ℒp_truncation [is_finite_measure μ]
  (hf : ae_strongly_measurable f μ) {A : ℝ} {p : ℝ≥0∞} :
  mem_ℒp (truncation f A) p μ :=
mem_ℒp.of_bound hf.truncation (|A|) (eventually_of_forall (λ x, abs_truncation_le_bound _ _ _))

lemma _root_.measure_theory.ae_strongly_measurable.integrable_truncation [is_finite_measure μ]
  (hf : ae_strongly_measurable f μ) {A : ℝ} :
  integrable (truncation f A) μ :=
by { rw ← mem_ℒp_one_iff_integrable, exact hf.mem_ℒp_truncation }

lemma moment_truncation_eq_interval_integral (hf : ae_strongly_measurable f μ) {A : ℝ}
  (hA : 0 ≤ A) {n : ℕ} (hn : n ≠ 0) :
  ∫ x, (truncation f A x) ^ n ∂μ = ∫ y in (-A)..A, y ^ n ∂(measure.map f μ) :=
begin
  have M : measurable_set (set.Ioc (-A) A) := measurable_set_Ioc,
  change ∫ x, (λ z, (indicator (set.Ioc (-A) A) id z) ^ n) (f x) ∂μ = _,
  rw [← integral_map hf.ae_measurable, interval_integral.integral_of_le, ← integral_indicator M],
  { simp only [indicator, zero_pow' _ hn, id.def, ite_pow] },
  { linarith },
  { exact ((measurable_id.indicator M).pow_const n).ae_strongly_measurable }
end

lemma moment_truncation_eq_interval_integral_of_nonneg (hf : ae_strongly_measurable f μ) {A : ℝ}
  {n : ℕ} (hn : n ≠ 0) (h'f : 0 ≤ f) :
  ∫ x, (truncation f A x) ^ n ∂μ = ∫ y in 0..A, y ^ n ∂(measure.map f μ) :=
begin
  have M : measurable_set (set.Ioc 0 A) := measurable_set_Ioc,
  have M' : measurable_set (set.Ioc A 0) := measurable_set_Ioc,
  rw truncation_eq_of_nonneg h'f,
  change ∫ x, (λ z, (indicator (set.Ioc 0 A) id z) ^ n) (f x) ∂μ = _,
  rcases le_or_lt 0 A with hA | hA,
  { rw [← integral_map hf.ae_measurable, interval_integral.integral_of_le hA,
        ← integral_indicator M],
    { simp only [indicator, zero_pow' _ hn, id.def, ite_pow] },
    { exact ((measurable_id.indicator M).pow_const n).ae_strongly_measurable } },
  { rw [← integral_map hf.ae_measurable, interval_integral.integral_of_ge hA.le,
        ← integral_indicator M'],
    { simp only [set.Ioc_eq_empty_of_le hA.le, zero_pow' _ hn, set.indicator_empty, integral_zero,
        zero_eq_neg],
      apply integral_eq_zero_of_ae,
      have : ∀ᵐ x ∂(measure.map f μ), (0 : ℝ) ≤ x :=
        (ae_map_iff hf.ae_measurable measurable_set_Ici).2 (eventually_of_forall h'f),
      filter_upwards [this] with x hx,
      simp only [indicator, set.mem_Ioc, pi.zero_apply, ite_eq_right_iff, and_imp],
      assume h'x h''x,
      have : x = 0, by linarith,
      simp [this, zero_pow' _ hn] },
    { exact ((measurable_id.indicator M).pow_const n).ae_strongly_measurable } }
end

lemma integral_truncation_eq_interval_integral (hf : ae_strongly_measurable f μ) {A : ℝ}
  (hA : 0 ≤ A) :
  ∫ x, truncation f A x ∂μ = ∫ y in (-A)..A, y ∂(measure.map f μ) :=
by simpa using moment_truncation_eq_interval_integral hf hA one_ne_zero

lemma integral_truncation_eq_interval_integral_of_nonneg (hf : ae_strongly_measurable f μ) {A : ℝ}
  (h'f : 0 ≤ f) :
  ∫ x, truncation f A x ∂μ = ∫ y in 0..A, y ∂(measure.map f μ) :=
by simpa using moment_truncation_eq_interval_integral_of_nonneg hf one_ne_zero h'f

lemma integral_truncation_le_integral_of_nonneg
  (hf : integrable f μ) (h'f : 0 ≤ f) {A : ℝ} :
  ∫ x, truncation f A x ∂μ ≤ ∫ x, f x ∂μ :=
begin
  apply integral_mono_of_nonneg (eventually_of_forall (λ x, _)) hf (eventually_of_forall (λ x, _)),
  { exact truncation_nonneg _ (h'f x) },
  { calc truncation f A x ≤ |truncation f A x| : le_abs_self _
                      ... ≤ |f x|              : abs_truncation_le_abs_self _ _ _
                      ... = f x                : abs_of_nonneg (h'f x) }
end

/-- If a function is integrable, then the integral of its truncated versions converges to the
integral of the whole function. -/
lemma tendsto_integral_truncation {f : α → ℝ} (hf : integrable f μ) :
  tendsto (λ A, ∫ x, truncation f A x ∂μ) at_top (𝓝 (∫ x, f x ∂μ)) :=
begin
  refine tendsto_integral_filter_of_dominated_convergence (λ x, abs (f x)) _ _ _ _,
  { exact eventually_of_forall (λ A, hf.ae_strongly_measurable.truncation) },
  { apply eventually_of_forall (λ A, _),
    apply eventually_of_forall (λ x, _),
    rw real.norm_eq_abs,
    exact abs_truncation_le_abs_self _ _ _ },
  { apply hf.abs },
  { apply eventually_of_forall (λ x, _),
    apply tendsto_const_nhds.congr' _,
    filter_upwards [Ioi_mem_at_top (abs (f x))] with A hA,
    exact (truncation_eq_self hA).symm },
end

lemma ident_distrib.truncation {β : Type*} [measurable_space β] {ν : measure β}
  {f : α → ℝ} {g : β → ℝ} (h : ident_distrib f g μ ν) {A : ℝ} :
  ident_distrib (truncation f A) (truncation g A) μ ν :=
h.comp (measurable_id.indicator measurable_set_Ioc)

end truncation

section strong_law_ae

variables {Ω : Type*} [measure_space Ω] [is_probability_measure (ℙ : measure Ω)]

section moment_estimates

lemma sum_prob_mem_Ioc_le
  {X : Ω → ℝ} (hint : integrable X) (hnonneg : 0 ≤ X) {K : ℕ} {N : ℕ} (hKN : K ≤ N) :
  ∑ j in range K, ℙ {ω | X ω ∈ set.Ioc (j : ℝ) N} ≤ ennreal.of_real (𝔼[X] + 1) :=
begin
  let ρ : measure ℝ := measure.map X ℙ,
  haveI : is_probability_measure ρ := is_probability_measure_map hint.ae_measurable,
  have A : ∑ j in range K, ∫ x in j..N, (1 : ℝ) ∂ρ ≤ 𝔼[X] + 1, from calc
  ∑ j in range K, ∫ x in j..N, (1 : ℝ) ∂ρ
      = ∑ j in range K, ∑ i in Ico j N, ∫ x in i..(i+1 : ℕ), (1 : ℝ) ∂ρ :
    begin
      apply sum_congr rfl (λ j hj, _),
      rw interval_integral.sum_integral_adjacent_intervals_Ico ((mem_range.1 hj).le.trans hKN),
      assume k hk,
      exact continuous_const.interval_integrable _ _,
    end
  ... = ∑ i in range N, ∑ j in range (min (i+1) K), ∫ x in i..(i+1 : ℕ), (1 : ℝ) ∂ρ :
    begin
      simp_rw [sum_sigma'],
      refine sum_bij' (λ (p : (Σ (i : ℕ), ℕ)) hp, (⟨p.2, p.1⟩ : (Σ (i : ℕ), ℕ))) _ (λ a ha, rfl)
        (λ (p : (Σ (i : ℕ), ℕ)) hp, (⟨p.2, p.1⟩ : (Σ (i : ℕ), ℕ))) _ _ _,
      { rintros ⟨i, j⟩ hij,
        simp only [mem_sigma, mem_range, mem_Ico] at hij,
        simp only [hij, nat.lt_succ_iff.2 hij.2.1, mem_sigma, mem_range, lt_min_iff, and_self] },
      { rintros ⟨i, j⟩ hij,
        simp only [mem_sigma, mem_range, lt_min_iff] at hij,
        simp only [hij, nat.lt_succ_iff.1 hij.2.1, mem_sigma, mem_range, mem_Ico, and_self] },
      { rintros ⟨i, j⟩ hij, refl },
      { rintros ⟨i, j⟩ hij, refl },
    end
  ... ≤ ∑ i in range N, (i + 1) * ∫ x in i..(i+1 : ℕ), (1 : ℝ) ∂ρ :
    begin
      apply sum_le_sum (λ i hi, _),
      simp only [nat.cast_add, nat.cast_one, sum_const, card_range, nsmul_eq_mul, nat.cast_min],
      refine mul_le_mul_of_nonneg_right (min_le_left _ _) _,
      apply interval_integral.integral_nonneg,
      { simp only [le_add_iff_nonneg_right, zero_le_one] },
      { simp only [zero_le_one, implies_true_iff], }
    end
  ... ≤ ∑ i in range N, ∫ x in i..(i+1 : ℕ), (x + 1) ∂ρ :
    begin
      apply sum_le_sum (λ i hi, _),
      have I : (i : ℝ) ≤ (i + 1 : ℕ),
        by simp only [nat.cast_add, nat.cast_one, le_add_iff_nonneg_right, zero_le_one],
      simp_rw [interval_integral.integral_of_le I, ← integral_mul_left],
      apply set_integral_mono_on,
      { exact continuous_const.integrable_on_Ioc },
      { exact (continuous_id.add continuous_const).integrable_on_Ioc },
      { exact measurable_set_Ioc },
      { assume x hx,
        simp only [nat.cast_add, nat.cast_one, set.mem_Ioc] at hx,
        simp [hx.1.le] }
    end
  ... = ∫ x in 0..N, x + 1 ∂ρ :
    begin
      rw interval_integral.sum_integral_adjacent_intervals (λ k hk, _),
      { refl },
      { exact (continuous_id.add continuous_const).interval_integrable _ _ }
    end
  ... = ∫ x in 0..N, x ∂ρ + ∫ x in 0..N, 1 ∂ρ :
    begin
      rw interval_integral.integral_add,
      { exact continuous_id.interval_integrable _ _ },
      { exact continuous_const.interval_integrable _ _ },
    end
  ... = 𝔼[truncation X N] + ∫ x in 0..N, 1 ∂ρ :
    by rw integral_truncation_eq_interval_integral_of_nonneg hint.1 hnonneg
  ... ≤ 𝔼[X] + ∫ x in 0..N, 1 ∂ρ :
    add_le_add_right (integral_truncation_le_integral_of_nonneg hint hnonneg) _
  ... ≤ 𝔼[X] + 1 :
    begin
      refine add_le_add le_rfl _,
      rw interval_integral.integral_of_le (nat.cast_nonneg _),
      simp only [integral_const, measure.restrict_apply', measurable_set_Ioc, set.univ_inter,
        algebra.id.smul_eq_mul, mul_one],
      rw ← ennreal.one_to_real,
      exact ennreal.to_real_mono ennreal.one_ne_top prob_le_one,
    end,
  have B : ∀ a b, ℙ {ω | X ω ∈ set.Ioc a b} = ennreal.of_real (∫ x in set.Ioc a b, (1 : ℝ) ∂ρ),
  { assume a b,
    rw [of_real_set_integral_one ρ _,
        measure.map_apply_of_ae_measurable hint.ae_measurable measurable_set_Ioc],
    refl },
  calc ∑ j in range K, ℙ {ω | X ω ∈ set.Ioc (j : ℝ) N}
      = ∑ j in range K, ennreal.of_real (∫ x in set.Ioc (j : ℝ) N, (1 : ℝ) ∂ρ) :
    by simp_rw B
  ... = ennreal.of_real (∑ j in range K, ∫ x in set.Ioc (j : ℝ) N, (1 : ℝ) ∂ρ) :
    begin
      rw ennreal.of_real_sum_of_nonneg,
      simp only [integral_const, algebra.id.smul_eq_mul, mul_one, ennreal.to_real_nonneg,
        implies_true_iff],
    end
  ... = ennreal.of_real (∑ j in range K, ∫ x in (j : ℝ)..N, (1 : ℝ) ∂ρ) :
    begin
      congr' 1,
      refine sum_congr rfl (λ j hj, _),
      rw interval_integral.integral_of_le (nat.cast_le.2 ((mem_range.1 hj).le.trans hKN)),
    end
  ... ≤ ennreal.of_real (𝔼[X] + 1) : ennreal.of_real_le_of_real A
end

lemma tsum_prob_mem_Ioi_lt_top
  {X : Ω → ℝ} (hint : integrable X) (hnonneg : 0 ≤ X) :
  ∑' (j : ℕ), ℙ {ω | X ω ∈ set.Ioi (j : ℝ)} < ∞ :=
begin
  suffices : ∀ (K : ℕ), ∑ j in range K, ℙ {ω | X ω ∈ set.Ioi (j : ℝ)} ≤ ennreal.of_real (𝔼[X] + 1),
    from (le_of_tendsto_of_tendsto (ennreal.tendsto_nat_tsum _) tendsto_const_nhds
      (eventually_of_forall this)).trans_lt ennreal.of_real_lt_top,
  assume K,
  have A : tendsto (λ (N : ℕ), ∑ j in range K, ℙ {ω | X ω ∈ set.Ioc (j : ℝ) N})
    at_top (𝓝 (∑ j in range K, ℙ {ω | X ω ∈ set.Ioi (j : ℝ)})),
  { refine tendsto_finset_sum _ (λ i hi, _),
    have : {ω | X ω ∈ set.Ioi (i : ℝ)} = ⋃ (N : ℕ), {ω | X ω ∈ set.Ioc (i : ℝ) N},
    { apply set.subset.antisymm _ _,
      { assume ω hω,
        obtain ⟨N, hN⟩ : ∃ (N : ℕ), X ω ≤ N := exists_nat_ge (X ω),
        exact set.mem_Union.2 ⟨N, hω, hN⟩ },
      { simp only [set.mem_Ioc, set.mem_Ioi, set.Union_subset_iff, set.set_of_subset_set_of,
          implies_true_iff] {contextual := tt} } },
    rw this,
    apply tendsto_measure_Union,
    assume m n hmn x hx,
    exact ⟨hx.1, hx.2.trans (nat.cast_le.2 hmn)⟩ },
  apply le_of_tendsto_of_tendsto A tendsto_const_nhds,
  filter_upwards [Ici_mem_at_top K] with N hN,
  exact sum_prob_mem_Ioc_le hint hnonneg hN
end

lemma sum_variance_truncation_le
  {X : Ω → ℝ} (hint : integrable X) (hnonneg : 0 ≤ X) (K : ℕ) :
  ∑ j in range K, ((j : ℝ) ^ 2) ⁻¹ * 𝔼[(truncation X j) ^ 2] ≤ 2 * 𝔼[X] :=
begin
  set Y := λ (n : ℕ), truncation X n,
  let ρ : measure ℝ := measure.map X ℙ,
  have Y2 : ∀ n, 𝔼[Y n ^ 2] = ∫ x in 0..n, x ^ 2 ∂ρ,
  { assume n,
    change 𝔼[λ x, (Y n x)^2] = _,
    rw [moment_truncation_eq_interval_integral_of_nonneg hint.1 two_ne_zero hnonneg] },
  calc ∑ j in range K, ((j : ℝ) ^ 2) ⁻¹ * 𝔼[Y j ^ 2]
      = ∑ j in range K, ((j : ℝ) ^ 2) ⁻¹ * ∫ x in 0..j, x ^ 2 ∂ρ :
    by simp_rw [Y2]
  ... = ∑ j in range K, ((j : ℝ) ^ 2) ⁻¹ * ∑ k in range j, ∫ x in k..(k+1 : ℕ), x ^ 2 ∂ρ :
    begin
      congr' 1 with j,
      congr' 1,
      rw interval_integral.sum_integral_adjacent_intervals,
      { refl },
      assume k hk,
      exact (continuous_id.pow _).interval_integrable _ _,
    end
  ... = ∑ k in range K, (∑ j in Ioo k K, ((j : ℝ) ^ 2) ⁻¹) * ∫ x in k..(k+1 : ℕ), x ^ 2 ∂ρ :
    begin
      simp_rw [mul_sum, sum_mul, sum_sigma'],
      refine sum_bij' (λ (p : (Σ (i : ℕ), ℕ)) hp, (⟨p.2, p.1⟩ : (Σ (i : ℕ), ℕ))) _ (λ a ha, rfl)
        (λ (p : (Σ (i : ℕ), ℕ)) hp, (⟨p.2, p.1⟩ : (Σ (i : ℕ), ℕ))) _ _ _,
      { rintros ⟨i, j⟩ hij,
        simp only [mem_sigma, mem_range, mem_filter] at hij,
        simp [hij, mem_sigma, mem_range, and_self, hij.2.trans hij.1], },
      { rintros ⟨i, j⟩ hij,
        simp only [mem_sigma, mem_range, mem_Ioo] at hij,
        simp only [hij, mem_sigma, mem_range, and_self], },
      { rintros ⟨i, j⟩ hij, refl },
      { rintros ⟨i, j⟩ hij, refl },
    end
  ... ≤ ∑ k in range K, (2/ (k+1)) * ∫ x in k..(k+1 : ℕ), x ^ 2 ∂ρ :
    begin
      apply sum_le_sum (λ k hk, _),
      refine mul_le_mul_of_nonneg_right (sum_Ioo_inv_sq_le _ _) _,
      refine interval_integral.integral_nonneg_of_forall _ (λ u, sq_nonneg _),
      simp only [nat.cast_add, nat.cast_one, le_add_iff_nonneg_right, zero_le_one],
    end
  ... ≤ ∑ k in range K, ∫ x in k..(k+1 : ℕ), 2 * x ∂ρ :
    begin
      apply sum_le_sum (λ k hk, _),
      have Ik : (k : ℝ) ≤ (k + 1 : ℕ), by simp,
      rw [← interval_integral.integral_const_mul, interval_integral.integral_of_le Ik,
        interval_integral.integral_of_le Ik],
      refine set_integral_mono_on _ _ measurable_set_Ioc (λ x hx, _),
      { apply continuous.integrable_on_Ioc,
        exact continuous_const.mul (continuous_pow 2) },
      { apply continuous.integrable_on_Ioc,
        exact continuous_const.mul continuous_id' },
      { calc 2 / (↑k + 1) * x ^ 2 = (x / (k+1)) * (2 * x) : by ring_exp
        ... ≤ 1 * (2 * x) :
          mul_le_mul_of_nonneg_right begin
            apply (div_le_one _).2 hx.2,
            simp only [nat.cast_add, nat.cast_one],
            linarith only [show (0 : ℝ) ≤ k, from  nat.cast_nonneg k],
          end (mul_nonneg zero_le_two ((nat.cast_nonneg k).trans hx.1.le))
        ... = 2 * x : by rw one_mul }
    end
  ... = 2 * ∫ x in (0 : ℝ)..K, x ∂ρ :
    begin
      rw interval_integral.sum_integral_adjacent_intervals (λ k hk, _),
      swap, { exact (continuous_const.mul continuous_id').interval_integrable _ _ },
      rw interval_integral.integral_const_mul,
      refl
    end
  ... ≤ 2 * 𝔼[X] :
    mul_le_mul_of_nonneg_left begin
      rw ← integral_truncation_eq_interval_integral_of_nonneg hint.1 hnonneg,
      exact integral_truncation_le_integral_of_nonneg hint hnonneg,
    end zero_le_two
end

end moment_estimates

section strong_law_nonneg

/- This paragraph proves the strong law of large numbers (almost sure version, assuming only
pairwise independence) for nonnegative random variables, following Etemadi's proof. -/

variables (X : ℕ → Ω → ℝ) (hint : integrable (X 0))
  (hindep : pairwise (λ i j, indep_fun (X i) (X j)))
  (hident : ∀ i, ident_distrib (X i) (X 0))
  (hnonneg : ∀ i ω, 0 ≤ X i ω)

include X hint hindep hident hnonneg

/- The truncation of `Xᵢ` up to `i` satisfies the strong law of large numbers (with respect to
the truncated expectation) along the sequence `c^n`, for any `c > 1`, up to a given `ε > 0`.
This follows from a variance control. -/
lemma strong_law_aux1 {c : ℝ} (c_one : 1 < c) {ε : ℝ} (εpos : 0 < ε) :
  ∀ᵐ ω, ∀ᶠ (n : ℕ) in at_top,
    |∑ i in range ⌊c^n⌋₊, truncation (X i) i ω - 𝔼[∑ i in range ⌊c^n⌋₊, truncation (X i) i]|
      < ε * ⌊c^n⌋₊ :=
begin
  /- Let `S n = ∑ i in range n, Y i` where `Y i = truncation (X i) i`. We should show that
  `|S k - 𝔼[S k]| / k ≤ ε` along the sequence of powers of `c`. For this, we apply Borel-Cantelli:
  it suffices to show that the converse probabilites are summable. From Chebyshev inequality, this
  will follow from a variance control `∑' Var[S (c^i)] / (c^i)^2 < ∞`. This is checked in `I2` using
  pairwise independence to expand the variance of the sum as the sum of the variances, and then
  a straightforward but tedious computation (essentially boiling down to the fact that the sum of
  `1/(c ^ i)^2` beyong a threshold `j` is comparable to `1/j^2`).
  Note that we have written `c^i` in the above proof sketch, but rigorously one should put integer
  parts everywhere, making things more painful. We write `u i = ⌊c^i⌋₊` for brevity. -/
  have c_pos : 0 < c := zero_lt_one.trans c_one,
  let ρ : measure ℝ := measure.map (X 0) ℙ,
  have hX : ∀ i, ae_strongly_measurable (X i) ℙ :=
    λ i, (hident i).symm.ae_strongly_measurable_snd hint.1,
  have A : ∀ i, strongly_measurable (indicator (set.Ioc (-i : ℝ) i) id) :=
    λ i, strongly_measurable_id.indicator measurable_set_Ioc,
  set Y := λ (n : ℕ), truncation (X n) n with hY,
  set S := λ n, ∑ i in range n, Y i with hS,
  let u : ℕ → ℕ := λ n, ⌊c ^ n⌋₊,
  have u_mono : monotone u := λ i j hij, nat.floor_mono (pow_le_pow c_one.le hij),
  have I1 : ∀ K, ∑ j in range K, ((j : ℝ) ^ 2) ⁻¹ * Var[Y j] ≤ 2 * 𝔼[X 0],
  { assume K,
    calc ∑ j in range K, ((j : ℝ) ^ 2) ⁻¹ * Var[Y j] ≤
      ∑ j in range K, ((j : ℝ) ^ 2) ⁻¹ * 𝔼[(truncation (X 0) j)^2] :
      begin
        apply sum_le_sum (λ j hj, _),
        refine mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (sq_nonneg _)),
        rw (hident j).truncation.variance_eq,
        exact variance_le_expectation_sq,
      end
      ... ≤ 2 * 𝔼[X 0] : sum_variance_truncation_le hint (hnonneg 0) K },
  let C := (c ^ 5 * (c - 1) ⁻¹ ^ 3) * (2 * 𝔼[X 0]),
  have I2 : ∀ N, ∑ i in range N, ((u i : ℝ) ^ 2) ⁻¹ * Var[S (u i)] ≤ C,
  { assume N,
    calc
    ∑ i in range N, ((u i : ℝ) ^ 2) ⁻¹ * Var[S (u i)]
        = ∑ i in range N, ((u i : ℝ) ^ 2) ⁻¹ * (∑ j in range (u i), Var[Y j]) :
      begin
        congr' 1 with i,
        congr' 1,
        rw [hS, indep_fun.variance_sum],
        { assume j hj,
          exact (hident j).ae_strongly_measurable_fst.mem_ℒp_truncation },
        { assume k hk l hl hkl,
          exact (hindep k l hkl).comp (A k).measurable (A l).measurable }
      end
    ... = ∑ j in range (u (N - 1)),
            (∑ i in (range N).filter (λ i, j < u i), ((u i : ℝ) ^ 2) ⁻¹) * Var[Y j] :
      begin
        simp_rw [mul_sum, sum_mul, sum_sigma'],
        refine sum_bij' (λ (p : (Σ (i : ℕ), ℕ)) hp, (⟨p.2, p.1⟩ : (Σ (i : ℕ), ℕ))) _ (λ a ha, rfl)
          (λ (p : (Σ (i : ℕ), ℕ)) hp, (⟨p.2, p.1⟩ : (Σ (i : ℕ), ℕ))) _ _ _,
        { rintros ⟨i, j⟩ hij,
          simp only [mem_sigma, mem_range] at hij,
          simp only [hij.1, hij.2, mem_sigma, mem_range, mem_filter, and_true],
          exact hij.2.trans_le (u_mono (nat.le_pred_of_lt hij.1)) },
        { rintros ⟨i, j⟩ hij,
          simp only [mem_sigma, mem_range, mem_filter] at hij,
          simp only [hij.2.1, hij.2.2, mem_sigma, mem_range, and_self] },
        { rintros ⟨i, j⟩ hij, refl },
        { rintros ⟨i, j⟩ hij, refl },
      end
    ... ≤ ∑ j in range (u (N - 1)), (c ^ 5 * (c - 1) ⁻¹ ^ 3 / j ^ 2) * Var[Y j] :
      begin
        apply sum_le_sum (λ j hj, _),
        rcases @eq_zero_or_pos _ _ j with rfl|hj,
        { simp only [Y, nat.cast_zero, zero_pow', ne.def, bit0_eq_zero, nat.one_ne_zero,
            not_false_iff, div_zero, zero_mul],
          simp only [nat.cast_zero, truncation_zero, variance_zero, mul_zero] },
        apply mul_le_mul_of_nonneg_right _ (variance_nonneg _ _),
        convert sum_div_nat_floor_pow_sq_le_div_sq N (nat.cast_pos.2 hj) c_one,
        { simp only [nat.cast_lt] },
        { simp only [one_div] }
      end
    ... = (c ^ 5 * (c - 1) ⁻¹ ^ 3) * ∑ j in range (u (N - 1)), ((j : ℝ) ^ 2) ⁻¹ * Var[Y j] :
      by { simp_rw [mul_sum, div_eq_mul_inv], ring_nf }
    ... ≤ (c ^ 5 * (c - 1) ⁻¹ ^ 3) * (2 * 𝔼[X 0]) :
      begin
        apply mul_le_mul_of_nonneg_left (I1 _),
        apply mul_nonneg (pow_nonneg c_pos.le _),
        exact pow_nonneg (inv_nonneg.2 (sub_nonneg.2 c_one.le)) _
      end },
  have I3 : ∀ N, ∑ i in range N,
    ℙ {ω | (u i * ε : ℝ) ≤ |S (u i) ω - 𝔼[S (u i)]|} ≤ ennreal.of_real (ε ⁻¹ ^ 2 * C),
  { assume N,
    calc ∑ i in range N, ℙ {ω | (u i * ε : ℝ) ≤ |S (u i) ω - 𝔼[S (u i)]|}
        ≤ ∑ i in range N, ennreal.of_real (Var[S (u i)] / (u i * ε) ^ 2) :
      begin
        refine sum_le_sum (λ i hi, _),
        apply meas_ge_le_variance_div_sq,
        { exact mem_ℒp_finset_sum' _
            (λ j hj, (hident j).ae_strongly_measurable_fst.mem_ℒp_truncation) },
        { apply mul_pos (nat.cast_pos.2 _) εpos,
          refine zero_lt_one.trans_le _,
          apply nat.le_floor,
          rw nat.cast_one,
          apply one_le_pow_of_one_le c_one.le }
      end
    ... = ennreal.of_real (∑ i in range N, Var[S (u i)] / (u i * ε) ^ 2) :
      begin
        rw ennreal.of_real_sum_of_nonneg (λ i hi, _),
        exact div_nonneg (variance_nonneg _ _) (sq_nonneg _),
      end
    ... ≤ ennreal.of_real (ε ⁻¹ ^ 2 * C) :
      begin
        apply ennreal.of_real_le_of_real,
        simp_rw [div_eq_inv_mul, ← inv_pow, mul_inv, mul_comm _ (ε⁻¹), mul_pow, mul_assoc,
          ← mul_sum],
        refine mul_le_mul_of_nonneg_left _ (sq_nonneg _),
        simp_rw [inv_pow],
        exact I2 N
      end },
  have I4 : ∑' i, ℙ {ω | (u i * ε : ℝ) ≤ |S (u i) ω - 𝔼[S (u i)]|} < ∞ :=
    (le_of_tendsto_of_tendsto' (ennreal.tendsto_nat_tsum _) tendsto_const_nhds I3).trans_lt
      ennreal.of_real_lt_top,
  filter_upwards [ae_eventually_not_mem I4.ne] with ω hω,
  simp_rw [not_le, mul_comm, S, sum_apply] at hω,
  exact hω,
end

/- The truncation of `Xᵢ` up to `i` satisfies the strong law of large numbers
(with respect to the truncated expectation) along the sequence
`c^n`, for any `c > 1`. This follows from `strong_law_aux1` by varying `ε`. -/
lemma strong_law_aux2 {c : ℝ} (c_one : 1 < c) :
  ∀ᵐ ω, (λ (n : ℕ), ∑ i in range ⌊c^n⌋₊, truncation (X i) i ω
    - 𝔼[∑ i in range ⌊c^n⌋₊, truncation (X i) i]) =o[at_top] (λ (n : ℕ), (⌊c^n⌋₊ : ℝ)) :=
begin
  obtain ⟨v, -, v_pos, v_lim⟩ :
    ∃ (v : ℕ → ℝ), strict_anti v ∧ (∀ (n : ℕ), 0 < v n) ∧ tendsto v at_top (𝓝 0) :=
      exists_seq_strict_anti_tendsto (0 : ℝ),
  have := λ i, strong_law_aux1 X hint hindep hident hnonneg c_one (v_pos i),
  filter_upwards [ae_all_iff.2 this] with ω hω,
  apply asymptotics.is_o_iff.2 (λ ε εpos, _),
  obtain ⟨i, hi⟩ : ∃ i, v i < ε := ((tendsto_order.1 v_lim).2 ε εpos).exists,
  filter_upwards [hω i] with n hn,
  simp only [real.norm_eq_abs, lattice_ordered_comm_group.abs_abs, nat.abs_cast],
  exact hn.le.trans (mul_le_mul_of_nonneg_right hi.le (nat.cast_nonneg _)),
end

omit hindep hnonneg
/-- The expectation of the truncated version of `Xᵢ` behaves asymptotically like the whole
expectation. This follows from convergence and Cesaro averaging. -/
lemma strong_law_aux3 :
  (λ n, 𝔼[∑ i in range n, truncation (X i) i] - n * 𝔼[X 0]) =o[at_top] (coe : ℕ → ℝ) :=
begin
  have A : tendsto (λ i, 𝔼[truncation (X i) i]) at_top (𝓝 (𝔼[X 0])),
  { convert (tendsto_integral_truncation hint).comp tendsto_coe_nat_at_top_at_top,
    ext i,
    exact (hident i).truncation.integral_eq },
  convert asymptotics.is_o_sum_range_of_tendsto_zero (tendsto_sub_nhds_zero_iff.2 A),
  ext1 n,
  simp only [sum_sub_distrib, sum_const, card_range, nsmul_eq_mul, sum_apply, sub_left_inj],
  rw integral_finset_sum _ (λ i hi, _),
  exact ((hident i).symm.integrable_snd hint).1.integrable_truncation,
end
include hindep hnonneg

/- The truncation of `Xᵢ` up to `i` satisfies the strong law of large numbers
(with respect to the original expectation) along the sequence
`c^n`, for any `c > 1`. This follows from the version from the truncated expectation, and the
fact that the truncated and the original expectations have the same asymptotic behavior. -/
lemma strong_law_aux4 {c : ℝ} (c_one : 1 < c) :
  ∀ᵐ ω, (λ (n : ℕ), ∑ i in range ⌊c^n⌋₊, truncation (X i) i ω - ⌊c^n⌋₊ * 𝔼[X 0]) =o[at_top]
    (λ (n : ℕ), (⌊c^n⌋₊ : ℝ)) :=
begin
  filter_upwards [strong_law_aux2 X hint hindep hident hnonneg c_one] with ω hω,
  have A : tendsto (λ (n : ℕ), ⌊c ^ n⌋₊) at_top at_top :=
    tendsto_nat_floor_at_top.comp (tendsto_pow_at_top_at_top_of_one_lt c_one),
  convert hω.add ((strong_law_aux3 X hint hident).comp_tendsto A),
  ext1 n,
  simp,
end

omit hindep
/-- The truncated and non-truncated versions of `Xᵢ` have the same asymptotic behavior, as they
almost surely coincide at all but finitely many steps. This follows from a probability computation
and Borel-Cantelli. -/
lemma strong_law_aux5 :
  ∀ᵐ ω, (λ (n : ℕ), ∑ i in range n, truncation (X i) i ω - ∑ i in range n, X i ω) =o[at_top]
    (λ (n : ℕ), (n : ℝ)) :=
begin
  have A : ∑' (j : ℕ), ℙ {ω | X j ω ∈ set.Ioi (j : ℝ)} < ∞,
  { convert tsum_prob_mem_Ioi_lt_top hint (hnonneg 0),
    ext1 j,
    exact (hident j).measure_mem_eq measurable_set_Ioi },
  have B : ∀ᵐ ω, tendsto (λ (n : ℕ), truncation (X n) n ω - X n ω) at_top (𝓝 0),
  { filter_upwards [ae_eventually_not_mem A.ne] with ω hω,
    apply tendsto_const_nhds.congr' _,
    filter_upwards [hω, Ioi_mem_at_top 0] with n hn npos,
    simp only [truncation, indicator, set.mem_Ioc, id.def, function.comp_app],
    split_ifs,
    { exact (sub_self _).symm },
    { have : - (n : ℝ) < X n ω,
      { apply lt_of_lt_of_le _ (hnonneg n ω),
        simpa only [right.neg_neg_iff, nat.cast_pos] using npos },
      simp only [this, true_and, not_le] at h,
      exact (hn h).elim } },
  filter_upwards [B] with ω hω,
  convert is_o_sum_range_of_tendsto_zero hω,
  ext n,
  rw sum_sub_distrib,
end
include hindep

/- `Xᵢ` satisfies the strong law of large numbers along the sequence
`c^n`, for any `c > 1`. This follows from the version for the truncated `Xᵢ`, and the fact that
`Xᵢ` and its truncated version have the same asymptotic behavior. -/
lemma strong_law_aux6 {c : ℝ} (c_one : 1 < c) :
  ∀ᵐ ω, tendsto (λ (n : ℕ), (∑ i in range ⌊c^n⌋₊, X i ω) / ⌊c^n⌋₊) at_top (𝓝 (𝔼[X 0])) :=
begin
   have H : ∀ (n : ℕ), (0 : ℝ) < ⌊c ^ n⌋₊,
  { assume n,
    refine zero_lt_one.trans_le _,
    simp only [nat.one_le_cast, nat.one_le_floor_iff, one_le_pow_of_one_le c_one.le n] },
  filter_upwards [strong_law_aux4 X hint hindep hident hnonneg c_one,
    strong_law_aux5 X hint hident hnonneg] with ω hω h'ω,
  rw [← tendsto_sub_nhds_zero_iff, ← asymptotics.is_o_one_iff ℝ],
  have L : (λ n : ℕ, ∑ i in range ⌊c^n⌋₊, X i ω - ⌊c^n⌋₊ * 𝔼[X 0]) =o[at_top] (λ n, (⌊c^n⌋₊ : ℝ)),
  { have A : tendsto (λ (n : ℕ), ⌊c ^ n⌋₊) at_top at_top :=
      tendsto_nat_floor_at_top.comp (tendsto_pow_at_top_at_top_of_one_lt c_one),
    convert hω.sub (h'ω.comp_tendsto A),
    ext1 n,
    simp only [sub_sub_sub_cancel_left] },
  convert L.mul_is_O (is_O_refl (λ (n : ℕ), (⌊c ^ n⌋₊ : ℝ) ⁻¹) at_top);
  { ext1 n,
    field_simp [(H n).ne'] },
end

/-- `Xᵢ` satisfies the strong law of large numbers along all integers. This follows from the
corresponding fact along the sequences `c^n`, and the fact that any integer can be sandwiched
between `c^n` and `c^(n+1)` with comparably small error if `c` is close enough to `1`
(which is formalized in `tendsto_div_of_monotone_of_tendsto_div_floor_pow`). -/
lemma strong_law_aux7 :
  ∀ᵐ ω, tendsto (λ (n : ℕ), (∑ i in range n, X i ω) / n) at_top (𝓝 (𝔼[X 0])) :=
begin
  obtain ⟨c, -, cone, clim⟩ :
    ∃ (c : ℕ → ℝ), strict_anti c ∧ (∀ (n : ℕ), 1 < c n) ∧ tendsto c at_top (𝓝 1) :=
      exists_seq_strict_anti_tendsto (1 : ℝ),
  have : ∀ k, ∀ᵐ ω, tendsto (λ (n : ℕ), (∑ i in range ⌊c k ^ n⌋₊, X i ω) / ⌊c k ^ n⌋₊)
    at_top (𝓝 (𝔼[X 0])) := λ k, strong_law_aux6 X hint hindep hident hnonneg (cone k),
  filter_upwards [ae_all_iff.2 this] with ω hω,
  apply tendsto_div_of_monotone_of_tendsto_div_floor_pow _ _ _ c cone clim _,
  { assume m n hmn,
    exact sum_le_sum_of_subset_of_nonneg (range_mono hmn) (λ i hi h'i, hnonneg i ω) },
  { exact hω }
end

end strong_law_nonneg

/-- *Strong law of large numbers*, almost sure version: if `X n` is a sequence of independent
identically distributed integrable real-valued random variables, then `∑ i in range n, X i / n`
converges almost surely to `𝔼[X 0]`. We give here the strong version, due to Etemadi, that only
requires pairwise independence. -/
theorem strong_law_ae
  (X : ℕ → Ω → ℝ) (hint : integrable (X 0))
  (hindep : pairwise (λ i j, indep_fun (X i) (X j)))
  (hident : ∀ i, ident_distrib (X i) (X 0)) :
  ∀ᵐ ω, tendsto (λ (n : ℕ), (∑ i in range n, X i ω) / n) at_top (𝓝 (𝔼[X 0])) :=
begin
  let pos : ℝ → ℝ := (λ x, max x 0),
  let neg : ℝ → ℝ := (λ x, max (-x) 0),
  have posm : measurable pos := measurable_id'.max measurable_const,
  have negm : measurable neg := measurable_id'.neg.max measurable_const,
  have A : ∀ᵐ ω, tendsto (λ (n : ℕ), (∑ i in range n, (pos ∘ (X i)) ω) / n)
    at_top (𝓝 (𝔼[pos ∘ (X 0)])) :=
      strong_law_aux7 _ hint.pos_part (λ i j hij, (hindep i j hij).comp posm posm)
        (λ i, (hident i).comp posm) (λ i ω, le_max_right _ _),
  have B : ∀ᵐ ω, tendsto (λ (n : ℕ), (∑ i in range n, (neg ∘ (X i)) ω) / n)
    at_top (𝓝 (𝔼[neg ∘ (X 0)])) :=
      strong_law_aux7 _ hint.neg_part (λ i j hij, (hindep i j hij).comp negm negm)
        (λ i, (hident i).comp negm) (λ i ω, le_max_right _ _),
  filter_upwards [A, B] with ω hωpos hωneg,
  convert hωpos.sub hωneg,
  { simp only [← sub_div, ← sum_sub_distrib, max_zero_sub_max_neg_zero_eq_self] },
  { simp only [←integral_sub hint.pos_part hint.neg_part, max_zero_sub_max_neg_zero_eq_self] }
end

end strong_law_ae

end probability_theory


<|start_filename|>src/analysis/box_integral/partition/tagged.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.box_integral.partition.basic

/-!
# Tagged partitions

A tagged (pre)partition is a (pre)partition `π` enriched with a tagged point for each box of
‵π`. For simplicity we require that the function `box_integral.tagged_prepartition.tag` is defined
on all boxes `J : box ι` but use its values only on boxes of the partition. Given `π :
box_integral.tagged_partition I`, we require that each `box_integral.tagged_partition π J` belongs
to `box_integral.box.Icc I`. If for every `J ∈ π`, `π.tag J` belongs to `J.Icc`, then `π` is called
a *Henstock* partition. We do not include this assumption into the definition of a tagged
(pre)partition because McShane integral is defined as a limit along tagged partitions without this
requirement.

### Tags

rectangular box, box partition
-/

noncomputable theory
open_locale classical ennreal nnreal
open set function

namespace box_integral

variables {ι : Type*}

/-- A tagged prepartition is a prepartition enriched with a tagged point for each box of the
prepartition. For simiplicity we require that `tag` is defined for all boxes in `ι → ℝ` but
we will use onle the values of `tag` on the boxes of the partition. -/
structure tagged_prepartition (I : box ι) extends prepartition I :=
(tag : box ι → ι → ℝ)
(tag_mem_Icc : ∀ J, tag J ∈ I.Icc)

namespace tagged_prepartition

variables {I J J₁ J₂ : box ι} (π : tagged_prepartition I) {x : ι → ℝ}

instance : has_mem (box ι) (tagged_prepartition I) := ⟨λ J π, J ∈ π.boxes⟩

@[simp] lemma mem_to_prepartition {π : tagged_prepartition I} :
  J ∈ π.to_prepartition ↔ J ∈ π := iff.rfl

@[simp] lemma mem_mk (π : prepartition I) (f h) :
  J ∈ mk π f h ↔ J ∈ π := iff.rfl

/-- Union of all boxes of a tagged prepartition. -/
def Union : set (ι → ℝ) := π.to_prepartition.Union

lemma Union_def : π.Union = ⋃ J ∈ π, ↑J := rfl

@[simp] lemma Union_mk (π : prepartition I) (f h) : (mk π f h).Union = π.Union := rfl

@[simp] lemma Union_to_prepartition : π.to_prepartition.Union = π.Union := rfl

@[simp] lemma mem_Union : x ∈ π.Union ↔ ∃ J ∈ π, x ∈ J := set.mem_Union₂

lemma subset_Union (h : J ∈ π) : ↑J ⊆ π.Union := subset_bUnion_of_mem h

lemma Union_subset : π.Union ⊆ I := Union₂_subset π.le_of_mem'

/-- A tagged prepartition is a partition if it covers the whole box. -/
def is_partition := π.to_prepartition.is_partition

lemma is_partition_iff_Union_eq : is_partition π ↔ π.Union = I :=
prepartition.is_partition_iff_Union_eq

/-- The tagged partition made of boxes of `π` that satisfy predicate `p`. -/
@[simps { fully_applied := ff }] def filter (p : box ι → Prop) : tagged_prepartition I :=
⟨π.1.filter p, π.2, π.3⟩

@[simp] lemma mem_filter {p : box ι → Prop} : J ∈ π.filter p ↔ J ∈ π ∧ p J :=
finset.mem_filter

@[simp] lemma Union_filter_not (π : tagged_prepartition I) (p : box ι → Prop) :
  (π.filter (λ J, ¬p J)).Union = π.Union \ (π.filter p).Union :=
π.to_prepartition.Union_filter_not p

end tagged_prepartition

namespace prepartition

variables {I J : box ι}

/-- Given a partition `π` of `I : box_integral.box ι` and a collection of tagged partitions
`πi J` of all boxes `J ∈ π`, returns the tagged partition of `I` into all the boxes of `πi J`
with tags coming from `(πi J).tag`. -/
def bUnion_tagged (π : prepartition I) (πi : Π J, tagged_prepartition J) :
  tagged_prepartition I :=
{ to_prepartition := π.bUnion (λ J, (πi J).to_prepartition),
  tag := λ J, (πi (π.bUnion_index (λ J, (πi J).to_prepartition) J)).tag J,
  tag_mem_Icc := λ J, box.le_iff_Icc.1 (π.bUnion_index_le _ _) ((πi _).tag_mem_Icc _) }

@[simp] lemma mem_bUnion_tagged (π : prepartition I) {πi : Π J, tagged_prepartition J} :
  J ∈ π.bUnion_tagged πi ↔ ∃ J' ∈ π, J ∈ πi J' :=
π.mem_bUnion

lemma tag_bUnion_tagged (π : prepartition I) {πi : Π J, tagged_prepartition J} (hJ : J ∈ π) {J'}
  (hJ' : J' ∈ πi J) :
  (π.bUnion_tagged πi).tag J' = (πi J).tag J' :=
begin
  have : J' ∈ π.bUnion_tagged πi, from π.mem_bUnion.2 ⟨J, hJ, hJ'⟩,
  obtain rfl := π.bUnion_index_of_mem hJ hJ',
  refl
end

@[simp] lemma Union_bUnion_tagged (π : prepartition I) (πi : Π J, tagged_prepartition J) :
  (π.bUnion_tagged πi).Union = ⋃ J ∈ π, (πi J).Union :=
Union_bUnion _ _

lemma forall_bUnion_tagged (p : (ι → ℝ) → box ι → Prop) (π : prepartition I)
  (πi : Π J, tagged_prepartition J) :
  (∀ J ∈ π.bUnion_tagged πi, p ((π.bUnion_tagged πi).tag J) J) ↔
    ∀ (J ∈ π) (J' ∈ πi J), p ((πi J).tag J') J' :=
begin
  simp only [bex_imp_distrib, mem_bUnion_tagged],
  refine ⟨λ H J hJ J' hJ', _, λ H J' J hJ hJ', _⟩,
  { rw ← π.tag_bUnion_tagged hJ hJ', exact H J' J hJ hJ' },
  { rw π.tag_bUnion_tagged hJ hJ', exact H J hJ J' hJ' }
end

lemma is_partition.bUnion_tagged {π : prepartition I} (h : is_partition π)
  {πi : Π J, tagged_prepartition J} (hi : ∀ J ∈ π, (πi J).is_partition) :
  (π.bUnion_tagged πi).is_partition :=
h.bUnion hi

end prepartition

namespace tagged_prepartition

variables {I J : box ι} {π π₁ π₂ : tagged_prepartition I} {x : ι → ℝ}

/-- Given a tagged partition `π` of `I` and a (not tagged) partition `πi J hJ` of each `J ∈ π`,
returns the tagged partition of `I` into all the boxes of all `πi J hJ`. The tag of a box `J`
is defined to be the `π.tag` of the box of the partition `π` that includes `J`.

Note that usually the result is not a Henstock partition. -/
@[simps tag { fully_applied := ff }]
def bUnion_prepartition (π : tagged_prepartition I) (πi : Π J, prepartition J) :
  tagged_prepartition I :=
{ to_prepartition := π.to_prepartition.bUnion πi,
  tag := λ J, π.tag (π.to_prepartition.bUnion_index πi J),
  tag_mem_Icc := λ J, π.tag_mem_Icc _ }

lemma is_partition.bUnion_prepartition {π : tagged_prepartition I} (h : is_partition π)
  {πi : Π J, prepartition J} (hi : ∀ J ∈ π, (πi J).is_partition) :
  (π.bUnion_prepartition πi).is_partition :=
h.bUnion hi

/-- Given two partitions `π₁` and `π₁`, one of them tagged and the other is not, returns the tagged
partition with `to_partition = π₁.to_partition ⊓ π₂` and tags coming from `π₁`.

Note that usually the result is not a Henstock partition. -/
def inf_prepartition (π : tagged_prepartition I) (π' : prepartition I) :
  tagged_prepartition I :=
π.bUnion_prepartition $ λ J, π'.restrict J

@[simp] lemma inf_prepartition_to_prepartition (π : tagged_prepartition I) (π' : prepartition I) :
  (π.inf_prepartition π').to_prepartition = π.to_prepartition ⊓ π' := rfl

lemma mem_inf_prepartition_comm :
  J ∈ π₁.inf_prepartition π₂.to_prepartition ↔ J ∈ π₂.inf_prepartition π₁.to_prepartition :=
by simp only [← mem_to_prepartition, inf_prepartition_to_prepartition, inf_comm]

lemma is_partition.inf_prepartition (h₁ : π₁.is_partition) {π₂ : prepartition I}
  (h₂ : π₂.is_partition) :
  (π₁.inf_prepartition π₂).is_partition :=
h₁.inf h₂

open metric

/-- A tagged partition is said to be a Henstock partition if for each `J ∈ π`, the tag of `J`
belongs to `J.Icc`. -/
def is_Henstock (π : tagged_prepartition I) : Prop := ∀ J ∈ π, π.tag J ∈ J.Icc

@[simp] lemma is_Henstock_bUnion_tagged
  {π : prepartition I} {πi : Π J, tagged_prepartition J} :
  is_Henstock (π.bUnion_tagged πi) ↔ ∀ J ∈ π, (πi J).is_Henstock :=
π.forall_bUnion_tagged (λ x J, x ∈ J.Icc) πi

/-- In a Henstock prepartition, there are at most `2 ^ fintype.card ι` boxes with a given tag. -/
lemma is_Henstock.card_filter_tag_eq_le [fintype ι] (h : π.is_Henstock) (x : ι → ℝ) :
  (π.boxes.filter (λ J, π.tag J = x)).card ≤ 2 ^ fintype.card ι :=
calc (π.boxes.filter (λ J, π.tag J = x)).card ≤ (π.boxes.filter (λ J : box ι, x ∈ J.Icc)).card :
  begin
    refine finset.card_le_of_subset (λ J hJ, _),
    rw finset.mem_filter at hJ ⊢, rcases hJ with ⟨hJ, rfl⟩,
    exact ⟨hJ, h J hJ⟩
  end
... ≤ 2 ^ fintype.card ι : π.to_prepartition.card_filter_mem_Icc_le x

/-- A tagged partition `π` is subordinate to `r : (ι → ℝ) → ℝ` if each box `J ∈ π` is included in
the closed ball with center `π.tag J` and radius `r (π.tag J)`. -/
def is_subordinate [fintype ι] (π : tagged_prepartition I) (r : (ι → ℝ) → Ioi (0 : ℝ)) : Prop :=
∀ J ∈ π, (J : _).Icc ⊆ closed_ball (π.tag J) (r $ π.tag J)

variables {r r₁ r₂ : (ι → ℝ) → Ioi (0 : ℝ)}

@[simp] lemma is_subordinate_bUnion_tagged [fintype ι]
  {π : prepartition I} {πi : Π J, tagged_prepartition J} :
  is_subordinate (π.bUnion_tagged πi) r ↔ ∀ J ∈ π, (πi J).is_subordinate r :=
π.forall_bUnion_tagged (λ x J, J.Icc ⊆ closed_ball x (r x)) πi

lemma is_subordinate.bUnion_prepartition [fintype ι] (h : is_subordinate π r)
  (πi : Π J, prepartition J) :
  is_subordinate (π.bUnion_prepartition πi) r :=
λ J hJ, subset.trans (box.le_iff_Icc.1 $ π.to_prepartition.le_bUnion_index hJ) $
  h _ $ π.to_prepartition.bUnion_index_mem hJ

lemma is_subordinate.inf_prepartition [fintype ι] (h : is_subordinate π r) (π' : prepartition I) :
  is_subordinate (π.inf_prepartition π') r :=
h.bUnion_prepartition _

lemma is_subordinate.mono' [fintype ι] {π : tagged_prepartition I}
  (hr₁ : π.is_subordinate r₁) (h : ∀ J ∈ π, r₁ (π.tag J) ≤ r₂ (π.tag J)) :
  π.is_subordinate r₂ :=
λ J hJ x hx, closed_ball_subset_closed_ball (h _ hJ) (hr₁ _ hJ hx)

lemma is_subordinate.mono [fintype ι] {π : tagged_prepartition I}
  (hr₁ : π.is_subordinate r₁) (h : ∀ x ∈ I.Icc, r₁ x ≤ r₂ x) :
  π.is_subordinate r₂ :=
hr₁.mono' $ λ J _, h _ $ π.tag_mem_Icc J

lemma is_subordinate.diam_le [fintype ι] {π : tagged_prepartition I}
  (h : π.is_subordinate r) (hJ : J ∈ π.boxes) :
  diam J.Icc ≤ 2 * r (π.tag J) :=
calc diam J.Icc ≤ diam (closed_ball (π.tag J) (r $ π.tag J)) :
  diam_mono (h J hJ) bounded_closed_ball
            ... ≤ 2 * r (π.tag J) : diam_closed_ball (le_of_lt (r _).2)

/-- Tagged prepartition with single box and prescribed tag. -/
@[simps { fully_applied := ff }]
def single (I J : box ι) (hJ : J ≤ I) (x : ι → ℝ) (h : x ∈ I.Icc) : tagged_prepartition I :=
⟨prepartition.single I J hJ, λ J, x, λ J, h⟩

@[simp] lemma mem_single {J'} (hJ : J ≤ I) (h : x ∈ I.Icc) : J' ∈ single I J hJ x h ↔ J' = J :=
finset.mem_singleton

instance (I : box ι) : inhabited (tagged_prepartition I) :=
⟨single I I le_rfl I.upper I.upper_mem_Icc⟩

lemma is_partition_single_iff (hJ : J ≤ I) (h : x ∈ I.Icc) :
  (single I J hJ x h).is_partition ↔ J = I :=
prepartition.is_partition_single_iff hJ

lemma is_partition_single (h : x ∈ I.Icc) : (single I I le_rfl x h).is_partition :=
prepartition.is_partition_top I

lemma forall_mem_single (p : (ι → ℝ) → (box ι) → Prop) (hJ : J ≤ I) (h : x ∈ I.Icc) :
  (∀ J' ∈ single I J hJ x h, p ((single I J hJ x h).tag J') J') ↔ p x J :=
by simp

@[simp] lemma is_Henstock_single_iff (hJ : J ≤ I) (h : x ∈ I.Icc) :
  is_Henstock (single I J hJ x h) ↔ x ∈ J.Icc :=
forall_mem_single (λ x J, x ∈ J.Icc) hJ h

@[simp] lemma is_Henstock_single (h : x ∈ I.Icc) : is_Henstock (single I I le_rfl x h) :=
(is_Henstock_single_iff (le_refl I) h).2 h

@[simp] lemma is_subordinate_single [fintype ι] (hJ : J ≤ I) (h : x ∈ I.Icc) :
  is_subordinate (single I J hJ x h) r ↔ J.Icc ⊆ closed_ball x (r x) :=
forall_mem_single (λ x J, J.Icc ⊆ closed_ball x (r x)) hJ h

@[simp] lemma Union_single (hJ : J ≤ I) (h : x ∈ I.Icc) :
  (single I J hJ x h).Union = J :=
prepartition.Union_single hJ

/-- Union of two tagged prepartitions with disjoint unions of boxes. -/
def disj_union (π₁ π₂ : tagged_prepartition I) (h : disjoint π₁.Union π₂.Union) :
  tagged_prepartition I :=
{ to_prepartition := π₁.to_prepartition.disj_union π₂.to_prepartition h,
  tag := π₁.boxes.piecewise π₁.tag π₂.tag,
  tag_mem_Icc := λ J, by { dunfold finset.piecewise, split_ifs,
    exacts [π₁.tag_mem_Icc J, π₂.tag_mem_Icc J]  } }

@[simp] lemma disj_union_boxes (h : disjoint π₁.Union π₂.Union) :
  (π₁.disj_union π₂ h).boxes = π₁.boxes ∪ π₂.boxes := rfl

@[simp] lemma mem_disj_union (h : disjoint π₁.Union π₂.Union) :
  J ∈ π₁.disj_union π₂ h ↔ J ∈ π₁ ∨ J ∈ π₂ :=
finset.mem_union

@[simp] lemma Union_disj_union (h : disjoint π₁.Union π₂.Union) :
  (π₁.disj_union π₂ h).Union = π₁.Union ∪ π₂.Union :=
prepartition.Union_disj_union _

lemma disj_union_tag_of_mem_left (h : disjoint π₁.Union π₂.Union) (hJ : J ∈ π₁) :
  (π₁.disj_union π₂ h).tag J = π₁.tag J :=
dif_pos hJ

lemma disj_union_tag_of_mem_right (h : disjoint π₁.Union π₂.Union) (hJ : J ∈ π₂) :
  (π₁.disj_union π₂ h).tag J = π₂.tag J :=
dif_neg $ λ h₁, h ⟨π₁.subset_Union h₁ J.upper_mem, π₂.subset_Union hJ J.upper_mem⟩

lemma is_subordinate.disj_union [fintype ι] (h₁ : is_subordinate π₁ r)
  (h₂ : is_subordinate π₂ r) (h : disjoint π₁.Union π₂.Union) :
  is_subordinate (π₁.disj_union π₂ h) r :=
begin
  refine λ J hJ, (finset.mem_union.1 hJ).elim (λ hJ, _) (λ hJ, _),
  { rw disj_union_tag_of_mem_left _ hJ, exact h₁ _ hJ },
  { rw disj_union_tag_of_mem_right _ hJ, exact h₂ _ hJ }
end

lemma is_Henstock.disj_union (h₁ : is_Henstock π₁) (h₂ : is_Henstock π₂)
  (h : disjoint π₁.Union π₂.Union) :
  is_Henstock (π₁.disj_union π₂ h) :=
begin
  refine λ J hJ, (finset.mem_union.1 hJ).elim (λ hJ, _) (λ hJ, _),
  { rw disj_union_tag_of_mem_left _ hJ, exact h₁ _ hJ },
  { rw disj_union_tag_of_mem_right _ hJ, exact h₂ _ hJ }
end

/-- If `I ≤ J`, then every tagged prepartition of `I` is a tagged prepartition of `J`. -/
def embed_box (I J : box ι) (h : I ≤ J) :
  tagged_prepartition I ↪ tagged_prepartition J :=
{ to_fun := λ π,
  { le_of_mem' := λ J' hJ', (π.le_of_mem' J' hJ').trans h,
    tag_mem_Icc := λ J, box.le_iff_Icc.1 h (π.tag_mem_Icc J),
    .. π },
  inj' := by { rintro ⟨⟨b₁, h₁le, h₁d⟩, t₁, ht₁⟩ ⟨⟨b₂, h₂le, h₂d⟩, t₂, ht₂⟩ H, simpa using H } }

section distortion

variables [fintype ι] (π)
open finset

/-- The distortion of a tagged prepartition is the maximum of distortions of its boxes. -/
def distortion : ℝ≥0 := π.to_prepartition.distortion

lemma distortion_le_of_mem (h : J ∈ π) : J.distortion ≤ π.distortion :=
le_sup h

lemma distortion_le_iff {c : ℝ≥0} : π.distortion ≤ c ↔ ∀ J ∈ π, box.distortion J ≤ c :=
finset.sup_le_iff

@[simp] lemma _root_.box_integral.prepartition.distortion_bUnion_tagged (π : prepartition I)
  (πi : Π J, tagged_prepartition J) :
  (π.bUnion_tagged πi).distortion = π.boxes.sup (λ J, (πi J).distortion) :=
sup_bUnion _ _

@[simp] lemma distortion_bUnion_prepartition (π : tagged_prepartition I)
  (πi : Π J, prepartition J) :
  (π.bUnion_prepartition πi).distortion = π.boxes.sup (λ J, (πi J).distortion) :=
sup_bUnion _ _

@[simp] lemma distortion_disj_union (h : disjoint π₁.Union π₂.Union) :
  (π₁.disj_union π₂ h).distortion = max π₁.distortion π₂.distortion :=
sup_union

lemma distortion_of_const {c} (h₁ : π.boxes.nonempty) (h₂ : ∀ J ∈ π, box.distortion J = c) :
  π.distortion = c :=
(sup_congr rfl h₂).trans (sup_const h₁ _)

@[simp] lemma distortion_single (hJ : J ≤ I) (h : x ∈ I.Icc) :
  distortion (single I J hJ x h) = J.distortion :=
sup_singleton

lemma distortion_filter_le (p : box ι → Prop) : (π.filter p).distortion ≤ π.distortion :=
sup_mono (filter_subset _ _)

end distortion

end tagged_prepartition

end box_integral


<|start_filename|>src/analysis/specific_limits/normed.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>
-/
import analysis.asymptotics.asymptotics
import analysis.specific_limits.basic

/-!
# A collection of specific limit computations

This file contains important specific limit computations in (semi-)normed groups/rings/spaces, as
as well as such computations in `ℝ` when the natural proof passes through a fact about normed
spaces.

-/

noncomputable theory
open classical set function filter finset metric asymptotics

open_locale classical topological_space nat big_operators uniformity nnreal ennreal

variables {α : Type*} {β : Type*} {ι : Type*}

lemma tendsto_norm_at_top_at_top : tendsto (norm : ℝ → ℝ) at_top at_top :=
tendsto_abs_at_top_at_top

lemma summable_of_absolute_convergence_real {f : ℕ → ℝ} :
  (∃r, tendsto (λn, (∑ i in range n, |f i|)) at_top (𝓝 r)) → summable f
| ⟨r, hr⟩ :=
  begin
    refine summable_of_summable_norm ⟨r, (has_sum_iff_tendsto_nat_of_nonneg _ _).2 _⟩,
    exact assume i, norm_nonneg _,
    simpa only using hr
  end

/-! ### Powers -/

lemma tendsto_norm_zero' {𝕜 : Type*} [normed_group 𝕜] :
  tendsto (norm : 𝕜 → ℝ) (𝓝[≠] 0) (𝓝[>] 0) :=
tendsto_norm_zero.inf $ tendsto_principal_principal.2 $ λ x hx, norm_pos_iff.2 hx

namespace normed_field

lemma tendsto_norm_inverse_nhds_within_0_at_top {𝕜 : Type*} [normed_field 𝕜] :
  tendsto (λ x:𝕜, ∥x⁻¹∥) (𝓝[≠] 0) at_top :=
(tendsto_inv_zero_at_top.comp tendsto_norm_zero').congr $ λ x, (norm_inv x).symm

lemma tendsto_norm_zpow_nhds_within_0_at_top {𝕜 : Type*} [normed_field 𝕜] {m : ℤ}
  (hm : m < 0) :
  tendsto (λ x : 𝕜, ∥x ^ m∥) (𝓝[≠] 0) at_top :=
begin
  rcases neg_surjective m with ⟨m, rfl⟩,
  rw neg_lt_zero at hm, lift m to ℕ using hm.le, rw int.coe_nat_pos at hm,
  simp only [norm_pow, zpow_neg, zpow_coe_nat, ← inv_pow],
  exact (tendsto_pow_at_top hm).comp normed_field.tendsto_norm_inverse_nhds_within_0_at_top
end

/-- The (scalar) product of a sequence that tends to zero with a bounded one also tends to zero. -/
lemma tendsto_zero_smul_of_tendsto_zero_of_bounded {ι 𝕜 𝔸 : Type*} [normed_field 𝕜]
  [normed_group 𝔸] [normed_space 𝕜 𝔸] {l : filter ι} {ε : ι → 𝕜} {f : ι → 𝔸}
  (hε : tendsto ε l (𝓝 0)) (hf : filter.is_bounded_under (≤) l (norm ∘ f)) :
  tendsto (ε • f) l (𝓝 0) :=
begin
  rw ← is_o_one_iff 𝕜 at hε ⊢,
  simpa using is_o.smul_is_O hε (hf.is_O_const (one_ne_zero : (1 : 𝕜) ≠ 0))
end

@[simp] lemma continuous_at_zpow {𝕜 : Type*} [nondiscrete_normed_field 𝕜] {m : ℤ} {x : 𝕜} :
  continuous_at (λ x, x ^ m) x ↔ x ≠ 0 ∨ 0 ≤ m :=
begin
  refine ⟨_, continuous_at_zpow₀ _ _⟩,
  contrapose!, rintro ⟨rfl, hm⟩ hc,
  exact not_tendsto_at_top_of_tendsto_nhds (hc.tendsto.mono_left nhds_within_le_nhds).norm
      (tendsto_norm_zpow_nhds_within_0_at_top hm)
end

@[simp] lemma continuous_at_inv {𝕜 : Type*} [nondiscrete_normed_field 𝕜] {x : 𝕜} :
  continuous_at has_inv.inv x ↔ x ≠ 0 :=
by simpa [(@zero_lt_one ℤ _ _).not_le] using @continuous_at_zpow _ _ (-1) x

end normed_field

lemma is_o_pow_pow_of_lt_left {r₁ r₂ : ℝ} (h₁ : 0 ≤ r₁) (h₂ : r₁ < r₂) :
  (λ n : ℕ, r₁ ^ n) =o[at_top] (λ n, r₂ ^ n) :=
have H : 0 < r₂ := h₁.trans_lt h₂,
is_o_of_tendsto (λ n hn, false.elim $ H.ne' $ pow_eq_zero hn) $
  (tendsto_pow_at_top_nhds_0_of_lt_1 (div_nonneg h₁ (h₁.trans h₂.le)) ((div_lt_one H).2 h₂)).congr
    (λ n, div_pow _ _ _)

lemma is_O_pow_pow_of_le_left {r₁ r₂ : ℝ} (h₁ : 0 ≤ r₁) (h₂ : r₁ ≤ r₂) :
  (λ n : ℕ, r₁ ^ n) =O[at_top] (λ n, r₂ ^ n) :=
h₂.eq_or_lt.elim (λ h, h ▸ is_O_refl _ _) (λ h, (is_o_pow_pow_of_lt_left h₁ h).is_O)

lemma is_o_pow_pow_of_abs_lt_left {r₁ r₂ : ℝ} (h : |r₁| < |r₂|) :
  (λ n : ℕ, r₁ ^ n) =o[at_top] (λ n, r₂ ^ n) :=
begin
  refine (is_o.of_norm_left _).of_norm_right,
  exact (is_o_pow_pow_of_lt_left (abs_nonneg r₁) h).congr (pow_abs r₁) (pow_abs r₂)
end

/-- Various statements equivalent to the fact that `f n` grows exponentially slower than `R ^ n`.

* 0: $f n = o(a ^ n)$ for some $-R < a < R$;
* 1: $f n = o(a ^ n)$ for some $0 < a < R$;
* 2: $f n = O(a ^ n)$ for some $-R < a < R$;
* 3: $f n = O(a ^ n)$ for some $0 < a < R$;
* 4: there exist `a < R` and `C` such that one of `C` and `R` is positive and $|f n| ≤ Ca^n$
     for all `n`;
* 5: there exists `0 < a < R` and a positive `C` such that $|f n| ≤ Ca^n$ for all `n`;
* 6: there exists `a < R` such that $|f n| ≤ a ^ n$ for sufficiently large `n`;
* 7: there exists `0 < a < R` such that $|f n| ≤ a ^ n$ for sufficiently large `n`.

NB: For backwards compatibility, if you add more items to the list, please append them at the end of
the list. -/
lemma tfae_exists_lt_is_o_pow (f : ℕ → ℝ) (R : ℝ) :
  tfae [∃ a ∈ Ioo (-R) R, f =o[at_top] pow a,
    ∃ a ∈ Ioo 0 R, f =o[at_top] (pow a),
    ∃ a ∈ Ioo (-R) R, f =O[at_top] pow a,
    ∃ a ∈ Ioo 0 R, f =O[at_top] pow a,
    ∃ (a < R) C (h₀ : 0 < C ∨ 0 < R), ∀ n, |f n| ≤ C * a ^ n,
    ∃ (a ∈ Ioo 0 R) (C > 0), ∀ n, |f n| ≤ C * a ^ n,
    ∃ a < R, ∀ᶠ n in at_top, |f n| ≤ a ^ n,
    ∃ a ∈ Ioo 0 R, ∀ᶠ n in at_top, |f n| ≤ a ^ n] :=
begin
  have A : Ico 0 R ⊆ Ioo (-R) R,
    from λ x hx, ⟨(neg_lt_zero.2 (hx.1.trans_lt hx.2)).trans_le hx.1, hx.2⟩,
  have B : Ioo 0 R ⊆ Ioo (-R) R := subset.trans Ioo_subset_Ico_self A,
  -- First we prove that 1-4 are equivalent using 2 → 3 → 4, 1 → 3, and 2 → 1
  tfae_have : 1 → 3, from λ ⟨a, ha, H⟩, ⟨a, ha, H.is_O⟩,
  tfae_have : 2 → 1, from λ ⟨a, ha, H⟩, ⟨a, B ha, H⟩,
  tfae_have : 3 → 2,
  { rintro ⟨a, ha, H⟩,
    rcases exists_between (abs_lt.2 ha) with ⟨b, hab, hbR⟩,
    exact ⟨b, ⟨(abs_nonneg a).trans_lt hab, hbR⟩,
      H.trans_is_o (is_o_pow_pow_of_abs_lt_left (hab.trans_le (le_abs_self b)))⟩ },
  tfae_have : 2 → 4, from λ ⟨a, ha, H⟩, ⟨a, ha, H.is_O⟩,
  tfae_have : 4 → 3, from λ ⟨a, ha, H⟩, ⟨a, B ha, H⟩,
  -- Add 5 and 6 using 4 → 6 → 5 → 3
  tfae_have : 4 → 6,
  { rintro ⟨a, ha, H⟩,
    rcases bound_of_is_O_nat_at_top H with ⟨C, hC₀, hC⟩,
    refine ⟨a, ha, C, hC₀, λ n, _⟩,
    simpa only [real.norm_eq_abs, abs_pow, abs_of_nonneg ha.1.le]
      using hC (pow_ne_zero n ha.1.ne') },
  tfae_have : 6 → 5, from λ ⟨a, ha, C, H₀, H⟩, ⟨a, ha.2, C, or.inl H₀, H⟩,
  tfae_have : 5 → 3,
  { rintro ⟨a, ha, C, h₀, H⟩,
    rcases sign_cases_of_C_mul_pow_nonneg (λ n, (abs_nonneg _).trans (H n)) with rfl | ⟨hC₀, ha₀⟩,
    { obtain rfl : f = 0, by { ext n, simpa using H n },
      simp only [lt_irrefl, false_or] at h₀,
      exact ⟨0, ⟨neg_lt_zero.2 h₀, h₀⟩, is_O_zero _ _⟩ },
    exact ⟨a, A ⟨ha₀, ha⟩,
      is_O_of_le' _ (λ n, (H n).trans $ mul_le_mul_of_nonneg_left (le_abs_self _) hC₀.le)⟩ },
  -- Add 7 and 8 using 2 → 8 → 7 → 3
  tfae_have : 2 → 8,
  { rintro ⟨a, ha, H⟩,
    refine ⟨a, ha, (H.def zero_lt_one).mono (λ n hn, _)⟩,
    rwa [real.norm_eq_abs, real.norm_eq_abs, one_mul, abs_pow, abs_of_pos ha.1] at hn },
  tfae_have : 8 → 7, from λ ⟨a, ha, H⟩, ⟨a, ha.2, H⟩,
  tfae_have : 7 → 3,
  { rintro ⟨a, ha, H⟩,
    have : 0 ≤ a, from nonneg_of_eventually_pow_nonneg (H.mono $ λ n, (abs_nonneg _).trans),
    refine ⟨a, A ⟨this, ha⟩, is_O.of_bound 1 _⟩,
    simpa only [real.norm_eq_abs, one_mul, abs_pow, abs_of_nonneg this] },
  tfae_finish
end

/-- For any natural `k` and a real `r > 1` we have `n ^ k = o(r ^ n)` as `n → ∞`. -/
lemma is_o_pow_const_const_pow_of_one_lt {R : Type*} [normed_ring R] (k : ℕ) {r : ℝ} (hr : 1 < r) :
  (λ n, n ^ k : ℕ → R) =o[at_top] (λ n, r ^ n) :=
begin
  have : tendsto (λ x : ℝ, x ^ k) (𝓝[>] 1) (𝓝 1),
    from ((continuous_id.pow k).tendsto' (1 : ℝ) 1 (one_pow _)).mono_left inf_le_left,
  obtain ⟨r' : ℝ, hr' : r' ^ k < r, h1 : 1 < r'⟩ :=
    ((this.eventually (gt_mem_nhds hr)).and self_mem_nhds_within).exists,
  have h0 : 0 ≤ r' := zero_le_one.trans h1.le,
  suffices : (λ n, n ^ k : ℕ → R) =O[at_top] (λ n : ℕ, (r' ^ k) ^ n),
    from this.trans_is_o (is_o_pow_pow_of_lt_left (pow_nonneg h0 _) hr'),
  conv in ((r' ^ _) ^ _) { rw [← pow_mul, mul_comm, pow_mul] },
  suffices : ∀ n : ℕ, ∥(n : R)∥ ≤ (r' - 1)⁻¹ * ∥(1 : R)∥ * ∥r' ^ n∥,
    from (is_O_of_le' _ this).pow _,
  intro n, rw mul_right_comm,
  refine n.norm_cast_le.trans (mul_le_mul_of_nonneg_right _ (norm_nonneg _)),
  simpa [div_eq_inv_mul, real.norm_eq_abs, abs_of_nonneg h0] using n.cast_le_pow_div_sub h1
end

/-- For a real `r > 1` we have `n = o(r ^ n)` as `n → ∞`. -/
lemma is_o_coe_const_pow_of_one_lt {R : Type*} [normed_ring R] {r : ℝ} (hr : 1 < r) :
  (coe : ℕ → R) =o[at_top] (λ n, r ^ n) :=
by simpa only [pow_one] using is_o_pow_const_const_pow_of_one_lt 1 hr

/-- If `∥r₁∥ < r₂`, then for any naturak `k` we have `n ^ k r₁ ^ n = o (r₂ ^ n)` as `n → ∞`. -/
lemma is_o_pow_const_mul_const_pow_const_pow_of_norm_lt {R : Type*} [normed_ring R] (k : ℕ)
  {r₁ : R} {r₂ : ℝ} (h : ∥r₁∥ < r₂) :
  (λ n, n ^ k * r₁ ^ n : ℕ → R) =o[at_top] (λ n, r₂ ^ n) :=
begin
  by_cases h0 : r₁ = 0,
  { refine (is_o_zero _ _).congr' (mem_at_top_sets.2 $ ⟨1, λ n hn, _⟩) eventually_eq.rfl,
    simp [zero_pow (zero_lt_one.trans_le hn), h0] },
  rw [← ne.def, ← norm_pos_iff] at h0,
  have A : (λ n, n ^ k : ℕ → R) =o[at_top] (λ n, (r₂ / ∥r₁∥) ^ n),
    from is_o_pow_const_const_pow_of_one_lt k ((one_lt_div h0).2 h),
  suffices : (λ n, r₁ ^ n) =O[at_top] (λ n, ∥r₁∥ ^ n),
    by simpa [div_mul_cancel _ (pow_pos h0 _).ne'] using A.mul_is_O this,
  exact is_O.of_bound 1 (by simpa using eventually_norm_pow_le r₁)
end

lemma tendsto_pow_const_div_const_pow_of_one_lt (k : ℕ) {r : ℝ} (hr : 1 < r) :
  tendsto (λ n, n ^ k / r ^ n : ℕ → ℝ) at_top (𝓝 0) :=
(is_o_pow_const_const_pow_of_one_lt k hr).tendsto_div_nhds_zero

/-- If `|r| < 1`, then `n ^ k r ^ n` tends to zero for any natural `k`. -/
lemma tendsto_pow_const_mul_const_pow_of_abs_lt_one (k : ℕ) {r : ℝ} (hr : |r| < 1) :
  tendsto (λ n, n ^ k * r ^ n : ℕ → ℝ) at_top (𝓝 0) :=
begin
  by_cases h0 : r = 0,
  { exact tendsto_const_nhds.congr'
      (mem_at_top_sets.2 ⟨1, λ n hn, by simp [zero_lt_one.trans_le hn, h0]⟩) },
  have hr' : 1 < (|r|)⁻¹, from one_lt_inv (abs_pos.2 h0) hr,
  rw tendsto_zero_iff_norm_tendsto_zero,
  simpa [div_eq_mul_inv] using tendsto_pow_const_div_const_pow_of_one_lt k hr'
end

/-- If `0 ≤ r < 1`, then `n ^ k r ^ n` tends to zero for any natural `k`.
This is a specialized version of `tendsto_pow_const_mul_const_pow_of_abs_lt_one`, singled out
for ease of application. -/
lemma tendsto_pow_const_mul_const_pow_of_lt_one (k : ℕ) {r : ℝ} (hr : 0 ≤ r) (h'r : r < 1) :
  tendsto (λ n, n ^ k * r ^ n : ℕ → ℝ) at_top (𝓝 0) :=
tendsto_pow_const_mul_const_pow_of_abs_lt_one k (abs_lt.2 ⟨neg_one_lt_zero.trans_le hr, h'r⟩)

/-- If `|r| < 1`, then `n * r ^ n` tends to zero. -/
lemma tendsto_self_mul_const_pow_of_abs_lt_one {r : ℝ} (hr : |r| < 1) :
  tendsto (λ n, n * r ^ n : ℕ → ℝ) at_top (𝓝 0) :=
by simpa only [pow_one] using tendsto_pow_const_mul_const_pow_of_abs_lt_one 1 hr

/-- If `0 ≤ r < 1`, then `n * r ^ n` tends to zero. This is a specialized version of
`tendsto_self_mul_const_pow_of_abs_lt_one`, singled out for ease of application. -/
lemma tendsto_self_mul_const_pow_of_lt_one {r : ℝ} (hr : 0 ≤ r) (h'r : r < 1) :
  tendsto (λ n, n * r ^ n : ℕ → ℝ) at_top (𝓝 0) :=
by simpa only [pow_one] using tendsto_pow_const_mul_const_pow_of_lt_one 1 hr h'r

/-- In a normed ring, the powers of an element x with `∥x∥ < 1` tend to zero. -/
lemma tendsto_pow_at_top_nhds_0_of_norm_lt_1 {R : Type*} [normed_ring R] {x : R}
  (h : ∥x∥ < 1) : tendsto (λ (n : ℕ), x ^ n) at_top (𝓝 0) :=
begin
  apply squeeze_zero_norm' (eventually_norm_pow_le x),
  exact tendsto_pow_at_top_nhds_0_of_lt_1 (norm_nonneg _) h,
end

lemma tendsto_pow_at_top_nhds_0_of_abs_lt_1 {r : ℝ} (h : |r| < 1) :
  tendsto (λn:ℕ, r^n) at_top (𝓝 0) :=
tendsto_pow_at_top_nhds_0_of_norm_lt_1 h

/-! ### Geometric series-/
section geometric

variables {K : Type*} [normed_field K] {ξ : K}

lemma has_sum_geometric_of_norm_lt_1 (h : ∥ξ∥ < 1) : has_sum (λn:ℕ, ξ ^ n) (1 - ξ)⁻¹ :=
begin
  have xi_ne_one : ξ ≠ 1, by { contrapose! h, simp [h] },
  have A : tendsto (λn, (ξ ^ n - 1) * (ξ - 1)⁻¹) at_top (𝓝 ((0 - 1) * (ξ - 1)⁻¹)),
    from ((tendsto_pow_at_top_nhds_0_of_norm_lt_1 h).sub tendsto_const_nhds).mul tendsto_const_nhds,
  rw [has_sum_iff_tendsto_nat_of_summable_norm],
  { simpa [geom_sum_eq, xi_ne_one, neg_inv, div_eq_mul_inv] using A },
  { simp [norm_pow, summable_geometric_of_lt_1 (norm_nonneg _) h] }
end

lemma summable_geometric_of_norm_lt_1 (h : ∥ξ∥ < 1) : summable (λn:ℕ, ξ ^ n) :=
⟨_, has_sum_geometric_of_norm_lt_1 h⟩

lemma tsum_geometric_of_norm_lt_1 (h : ∥ξ∥ < 1) : ∑'n:ℕ, ξ ^ n = (1 - ξ)⁻¹ :=
(has_sum_geometric_of_norm_lt_1 h).tsum_eq

lemma has_sum_geometric_of_abs_lt_1 {r : ℝ} (h : |r| < 1) : has_sum (λn:ℕ, r ^ n) (1 - r)⁻¹ :=
has_sum_geometric_of_norm_lt_1 h

lemma summable_geometric_of_abs_lt_1 {r : ℝ} (h : |r| < 1) : summable (λn:ℕ, r ^ n) :=
summable_geometric_of_norm_lt_1 h

lemma tsum_geometric_of_abs_lt_1 {r : ℝ} (h : |r| < 1) : ∑'n:ℕ, r ^ n = (1 - r)⁻¹ :=
tsum_geometric_of_norm_lt_1 h

/-- A geometric series in a normed field is summable iff the norm of the common ratio is less than
one. -/
@[simp] lemma summable_geometric_iff_norm_lt_1 : summable (λ n : ℕ, ξ ^ n) ↔ ∥ξ∥ < 1 :=
begin
  refine ⟨λ h, _, summable_geometric_of_norm_lt_1⟩,
  obtain ⟨k : ℕ, hk : dist (ξ ^ k) 0 < 1⟩ :=
    (h.tendsto_cofinite_zero.eventually (ball_mem_nhds _ zero_lt_one)).exists,
  simp only [norm_pow, dist_zero_right] at hk,
  rw [← one_pow k] at hk,
  exact lt_of_pow_lt_pow _ zero_le_one hk
end

end geometric

section mul_geometric

lemma summable_norm_pow_mul_geometric_of_norm_lt_1 {R : Type*} [normed_ring R]
  (k : ℕ) {r : R} (hr : ∥r∥ < 1) : summable (λ n : ℕ, ∥(n ^ k * r ^ n : R)∥) :=
begin
  rcases exists_between hr with ⟨r', hrr', h⟩,
  exact summable_of_is_O_nat (summable_geometric_of_lt_1 ((norm_nonneg _).trans hrr'.le) h)
    (is_o_pow_const_mul_const_pow_const_pow_of_norm_lt _ hrr').is_O.norm_left
end

lemma summable_pow_mul_geometric_of_norm_lt_1 {R : Type*} [normed_ring R] [complete_space R]
  (k : ℕ) {r : R} (hr : ∥r∥ < 1) : summable (λ n, n ^ k * r ^ n : ℕ → R) :=
summable_of_summable_norm $ summable_norm_pow_mul_geometric_of_norm_lt_1 _ hr

/-- If `∥r∥ < 1`, then `∑' n : ℕ, n * r ^ n = r / (1 - r) ^ 2`, `has_sum` version. -/
lemma has_sum_coe_mul_geometric_of_norm_lt_1 {𝕜 : Type*} [normed_field 𝕜] [complete_space 𝕜]
  {r : 𝕜} (hr : ∥r∥ < 1) : has_sum (λ n, n * r ^ n : ℕ → 𝕜) (r / (1 - r) ^ 2) :=
begin
  have A : summable (λ n, n * r ^ n : ℕ → 𝕜),
    by simpa using summable_pow_mul_geometric_of_norm_lt_1 1 hr,
  have B : has_sum (pow r : ℕ → 𝕜) (1 - r)⁻¹, from has_sum_geometric_of_norm_lt_1 hr,
  refine A.has_sum_iff.2 _,
  have hr' : r ≠ 1, by { rintro rfl, simpa [lt_irrefl] using hr },
  set s : 𝕜 := ∑' n : ℕ, n * r ^ n,
  calc s = (1 - r) * s / (1 - r) : (mul_div_cancel_left _ (sub_ne_zero.2 hr'.symm)).symm
  ... = (s - r * s) / (1 - r) : by rw [sub_mul, one_mul]
  ... = ((0 : ℕ) * r ^ 0 + (∑' n : ℕ, (n + 1) * r ^ (n + 1)) - r * s) / (1 - r) :
    by { congr, exact tsum_eq_zero_add A }
  ... = (r * (∑' n : ℕ, (n + 1) * r ^ n) - r * s) / (1 - r) :
    by simp [pow_succ, mul_left_comm _ r, tsum_mul_left]
  ... = r / (1 - r) ^ 2 :
    by simp [add_mul, tsum_add A B.summable, mul_add, B.tsum_eq, ← div_eq_mul_inv, sq,
      div_div]
end

/-- If `∥r∥ < 1`, then `∑' n : ℕ, n * r ^ n = r / (1 - r) ^ 2`. -/
lemma tsum_coe_mul_geometric_of_norm_lt_1 {𝕜 : Type*} [normed_field 𝕜] [complete_space 𝕜]
  {r : 𝕜} (hr : ∥r∥ < 1) :
  (∑' n : ℕ, n * r ^ n : 𝕜) = (r / (1 - r) ^ 2) :=
(has_sum_coe_mul_geometric_of_norm_lt_1 hr).tsum_eq

end mul_geometric

section summable_le_geometric

variables [semi_normed_group α] {r C : ℝ} {f : ℕ → α}

lemma semi_normed_group.cauchy_seq_of_le_geometric {C : ℝ} {r : ℝ} (hr : r < 1)
  {u : ℕ → α} (h : ∀ n, ∥u n - u (n + 1)∥ ≤ C*r^n) : cauchy_seq u :=
cauchy_seq_of_le_geometric r C hr (by simpa [dist_eq_norm] using h)

lemma dist_partial_sum_le_of_le_geometric (hf : ∀n, ∥f n∥ ≤ C * r^n) (n : ℕ) :
  dist (∑ i in range n, f i) (∑ i in range (n+1), f i) ≤ C * r ^ n :=
begin
  rw [sum_range_succ, dist_eq_norm, ← norm_neg, neg_sub, add_sub_cancel'],
  exact hf n,
end

/-- If `∥f n∥ ≤ C * r ^ n` for all `n : ℕ` and some `r < 1`, then the partial sums of `f` form a
Cauchy sequence. This lemma does not assume `0 ≤ r` or `0 ≤ C`. -/
lemma cauchy_seq_finset_of_geometric_bound (hr : r < 1) (hf : ∀n, ∥f n∥ ≤ C * r^n) :
  cauchy_seq (λ s : finset (ℕ), ∑ x in s, f x) :=
cauchy_seq_finset_of_norm_bounded _
  (aux_has_sum_of_le_geometric hr (dist_partial_sum_le_of_le_geometric hf)).summable hf

/-- If `∥f n∥ ≤ C * r ^ n` for all `n : ℕ` and some `r < 1`, then the partial sums of `f` are within
distance `C * r ^ n / (1 - r)` of the sum of the series. This lemma does not assume `0 ≤ r` or
`0 ≤ C`. -/
lemma norm_sub_le_of_geometric_bound_of_has_sum (hr : r < 1) (hf : ∀n, ∥f n∥ ≤ C * r^n)
  {a : α} (ha : has_sum f a) (n : ℕ) :
  ∥(∑ x in finset.range n, f x) - a∥ ≤ (C * r ^ n) / (1 - r) :=
begin
  rw ← dist_eq_norm,
  apply dist_le_of_le_geometric_of_tendsto r C hr (dist_partial_sum_le_of_le_geometric hf),
  exact ha.tendsto_sum_nat
end

@[simp] lemma dist_partial_sum (u : ℕ → α) (n : ℕ) :
 dist (∑ k in range (n + 1), u k) (∑ k in range n, u k) = ∥u n∥ :=
by simp [dist_eq_norm, sum_range_succ]

@[simp] lemma dist_partial_sum' (u : ℕ → α) (n : ℕ) :
 dist (∑ k in range n, u k) (∑ k in range (n+1), u k) = ∥u n∥ :=
by simp [dist_eq_norm', sum_range_succ]

lemma cauchy_series_of_le_geometric {C : ℝ} {u : ℕ → α}
  {r : ℝ} (hr : r < 1) (h : ∀ n, ∥u n∥ ≤ C*r^n) : cauchy_seq (λ n, ∑ k in range n, u k) :=
cauchy_seq_of_le_geometric r C hr (by simp [h])

lemma normed_group.cauchy_series_of_le_geometric' {C : ℝ} {u : ℕ → α} {r : ℝ} (hr : r < 1)
  (h : ∀ n, ∥u n∥ ≤ C*r^n) : cauchy_seq (λ n, ∑ k in range (n + 1), u k) :=
(cauchy_series_of_le_geometric hr h).comp_tendsto $ tendsto_add_at_top_nat 1

lemma normed_group.cauchy_series_of_le_geometric'' {C : ℝ} {u : ℕ → α} {N : ℕ} {r : ℝ}
  (hr₀ : 0 < r) (hr₁ : r < 1)
  (h : ∀ n ≥ N, ∥u n∥ ≤ C*r^n) : cauchy_seq (λ n, ∑ k in range (n + 1), u k) :=
begin
  set v : ℕ → α := λ n, if n < N then 0 else u n,
  have hC : 0 ≤ C,
    from (zero_le_mul_right $ pow_pos hr₀ N).mp ((norm_nonneg _).trans $ h N $ le_refl N),
  have : ∀ n ≥ N, u n = v n,
  { intros n hn,
    simp [v, hn, if_neg (not_lt.mpr hn)] },
  refine cauchy_seq_sum_of_eventually_eq this (normed_group.cauchy_series_of_le_geometric' hr₁ _),
  { exact C },
  intro n,
  dsimp [v],
  split_ifs with H H,
  { rw norm_zero,
    exact mul_nonneg hC (pow_nonneg hr₀.le _) },
  { push_neg at H,
    exact h _ H }
end

end summable_le_geometric

section normed_ring_geometric
variables {R : Type*} [normed_ring R] [complete_space R]

open normed_space

/-- A geometric series in a complete normed ring is summable.
Proved above (same name, different namespace) for not-necessarily-complete normed fields. -/
lemma normed_ring.summable_geometric_of_norm_lt_1
  (x : R) (h : ∥x∥ < 1) : summable (λ (n:ℕ), x ^ n) :=
begin
  have h1 : summable (λ (n:ℕ), ∥x∥ ^ n) := summable_geometric_of_lt_1 (norm_nonneg _) h,
  refine summable_of_norm_bounded_eventually _ h1 _,
  rw nat.cofinite_eq_at_top,
  exact eventually_norm_pow_le x,
end

/-- Bound for the sum of a geometric series in a normed ring.  This formula does not assume that the
normed ring satisfies the axiom `∥1∥ = 1`. -/
lemma normed_ring.tsum_geometric_of_norm_lt_1
  (x : R) (h : ∥x∥ < 1) : ∥∑' n:ℕ, x ^ n∥ ≤ ∥(1:R)∥ - 1 + (1 - ∥x∥)⁻¹ :=
begin
  rw tsum_eq_zero_add (normed_ring.summable_geometric_of_norm_lt_1 x h),
  simp only [pow_zero],
  refine le_trans (norm_add_le _ _) _,
  have : ∥∑' b : ℕ, (λ n, x ^ (n + 1)) b∥ ≤ (1 - ∥x∥)⁻¹ - 1,
  { refine tsum_of_norm_bounded _ (λ b, norm_pow_le' _ (nat.succ_pos b)),
    convert (has_sum_nat_add_iff' 1).mpr (has_sum_geometric_of_lt_1 (norm_nonneg x) h),
    simp },
  linarith
end

lemma geom_series_mul_neg (x : R) (h : ∥x∥ < 1) :
  (∑' i:ℕ, x ^ i) * (1 - x) = 1 :=
begin
  have := ((normed_ring.summable_geometric_of_norm_lt_1 x h).has_sum.mul_right (1 - x)),
  refine tendsto_nhds_unique this.tendsto_sum_nat _,
  have : tendsto (λ (n : ℕ), 1 - x ^ n) at_top (𝓝 1),
  { simpa using tendsto_const_nhds.sub (tendsto_pow_at_top_nhds_0_of_norm_lt_1 h) },
  convert ← this,
  ext n,
  rw [←geom_sum_mul_neg, finset.sum_mul],
end

lemma mul_neg_geom_series (x : R) (h : ∥x∥ < 1) :
  (1 - x) * ∑' i:ℕ, x ^ i = 1 :=
begin
  have := (normed_ring.summable_geometric_of_norm_lt_1 x h).has_sum.mul_left (1 - x),
  refine tendsto_nhds_unique this.tendsto_sum_nat _,
  have : tendsto (λ (n : ℕ), 1 - x ^ n) at_top (nhds 1),
  { simpa using tendsto_const_nhds.sub
      (tendsto_pow_at_top_nhds_0_of_norm_lt_1 h) },
  convert ← this,
  ext n,
  rw [←mul_neg_geom_sum, finset.mul_sum]
end

end normed_ring_geometric

/-! ### Summability tests based on comparison with geometric series -/

lemma summable_of_ratio_norm_eventually_le {α : Type*} [semi_normed_group α] [complete_space α]
  {f : ℕ → α} {r : ℝ} (hr₁ : r < 1)
  (h : ∀ᶠ n in at_top, ∥f (n+1)∥ ≤ r * ∥f n∥) : summable f :=
begin
  by_cases hr₀ : 0 ≤ r,
  { rw eventually_at_top at h,
    rcases h with ⟨N, hN⟩,
    rw ← @summable_nat_add_iff α _ _ _ _ N,
    refine summable_of_norm_bounded (λ n, ∥f N∥ * r^n)
      (summable.mul_left _ $ summable_geometric_of_lt_1 hr₀ hr₁) (λ n, _),
    conv_rhs {rw [mul_comm, ← zero_add N]},
    refine le_geom hr₀ n (λ i _, _),
    convert hN (i + N) (N.le_add_left i) using 3,
    ac_refl },
  { push_neg at hr₀,
    refine summable_of_norm_bounded_eventually 0 summable_zero _,
    rw nat.cofinite_eq_at_top,
    filter_upwards [h] with _ hn,
    by_contra' h,
    exact not_lt.mpr (norm_nonneg _) (lt_of_le_of_lt hn $ mul_neg_of_neg_of_pos hr₀ h), },
end

lemma summable_of_ratio_test_tendsto_lt_one {α : Type*} [normed_group α] [complete_space α]
  {f : ℕ → α} {l : ℝ} (hl₁ : l < 1) (hf : ∀ᶠ n in at_top, f n ≠ 0)
  (h : tendsto (λ n, ∥f (n+1)∥/∥f n∥) at_top (𝓝 l)) : summable f :=
begin
  rcases exists_between hl₁ with ⟨r, hr₀, hr₁⟩,
  refine summable_of_ratio_norm_eventually_le hr₁ _,
  filter_upwards [eventually_le_of_tendsto_lt hr₀ h, hf] with _ _ h₁,
  rwa ← div_le_iff (norm_pos_iff.mpr h₁),
end

lemma not_summable_of_ratio_norm_eventually_ge {α : Type*} [semi_normed_group α]
  {f : ℕ → α} {r : ℝ} (hr : 1 < r) (hf : ∃ᶠ n in at_top, ∥f n∥ ≠ 0)
  (h : ∀ᶠ n in at_top, r * ∥f n∥ ≤ ∥f (n+1)∥) : ¬ summable f :=
begin
  rw eventually_at_top at h,
  rcases h with ⟨N₀, hN₀⟩,
  rw frequently_at_top at hf,
  rcases hf N₀ with ⟨N, hNN₀ : N₀ ≤ N, hN⟩,
  rw ← @summable_nat_add_iff α _ _ _ _ N,
  refine mt summable.tendsto_at_top_zero
    (λ h', not_tendsto_at_top_of_tendsto_nhds (tendsto_norm_zero.comp h') _),
  convert tendsto_at_top_of_geom_le _ hr _,
  { refine lt_of_le_of_ne (norm_nonneg _) _,
    intro h'',
    specialize hN₀ N hNN₀,
    simp only [comp_app, zero_add] at h'',
    exact hN h''.symm },
  { intro i,
    dsimp only [comp_app],
    convert (hN₀ (i + N) (hNN₀.trans (N.le_add_left i))) using 3,
    ac_refl }
end

lemma not_summable_of_ratio_test_tendsto_gt_one {α : Type*} [semi_normed_group α]
  {f : ℕ → α} {l : ℝ} (hl : 1 < l)
  (h : tendsto (λ n, ∥f (n+1)∥/∥f n∥) at_top (𝓝 l)) : ¬ summable f :=
begin
  have key : ∀ᶠ n in at_top, ∥f n∥ ≠ 0,
  { filter_upwards [eventually_ge_of_tendsto_gt hl h] with _ hn hc,
    rw [hc, div_zero] at hn,
    linarith },
  rcases exists_between hl with ⟨r, hr₀, hr₁⟩,
  refine not_summable_of_ratio_norm_eventually_ge hr₀ key.frequently _,
  filter_upwards [eventually_ge_of_tendsto_gt hr₁ h, key] with _ _ h₁,
  rwa ← le_div_iff (lt_of_le_of_ne (norm_nonneg _) h₁.symm)
end

section
/-! ### Dirichlet and alternating series tests -/

variables {E : Type*} [normed_group E] [normed_space ℝ E]
variables {b : ℝ} {f : ℕ → ℝ} {z : ℕ → E}

/-- **Dirichlet's Test** for monotone sequences. -/
theorem monotone.cauchy_seq_series_mul_of_tendsto_zero_of_bounded
  (hfa : monotone f) (hf0 : tendsto f at_top (𝓝 0)) (hgb : ∀ n, ∥∑ i in range n, z i∥ ≤ b) :
  cauchy_seq (λ n, ∑ i in range (n + 1), (f i) • z i) :=
begin
  simp_rw [finset.sum_range_by_parts _ _ (nat.succ _), sub_eq_add_neg,
           nat.succ_sub_succ_eq_sub, tsub_zero],
  apply (normed_field.tendsto_zero_smul_of_tendsto_zero_of_bounded hf0
    ⟨b, eventually_map.mpr $ eventually_of_forall $ λ n, hgb $ n+1⟩).cauchy_seq.add,
  apply (cauchy_seq_range_of_norm_bounded _ _ (_ : ∀ n, _ ≤ b * |f(n+1) - f(n)|)).neg,
  { exact normed_uniform_group },
  { simp_rw [abs_of_nonneg (sub_nonneg_of_le (hfa (nat.le_succ _))), ← mul_sum],
    apply real.uniform_continuous_mul_const.comp_cauchy_seq,
    simp_rw [sum_range_sub, sub_eq_add_neg],
    exact (tendsto.cauchy_seq hf0).add_const },
  { intro n,
    rw [norm_smul, mul_comm],
    exact mul_le_mul_of_nonneg_right (hgb _) (abs_nonneg _) },
end

/-- **Dirichlet's test** for antitone sequences. -/
theorem antitone.cauchy_seq_series_mul_of_tendsto_zero_of_bounded
  (hfa : antitone f) (hf0 : tendsto f at_top (𝓝 0)) (hzb : ∀ n, ∥∑ i in range n, z i∥ ≤ b) :
  cauchy_seq (λ n, ∑ i in range (n+1), (f i) • z i) :=
begin
  have hfa': monotone (λ n, -f n) := λ _ _ hab, neg_le_neg $ hfa hab,
  have hf0': tendsto (λ n, -f n) at_top (𝓝 0) := by { convert hf0.neg, norm_num },
  convert (hfa'.cauchy_seq_series_mul_of_tendsto_zero_of_bounded hf0' hzb).neg,
  funext,
  simp
end

lemma norm_sum_neg_one_pow_le (n : ℕ) : ∥∑ i in range n, (-1 : ℝ) ^ i∥ ≤ 1 :=
by { rw [neg_one_geom_sum], split_ifs; norm_num }

/-- The **alternating series test** for monotone sequences.
See also `tendsto_alternating_series_of_monotone_tendsto_zero`. -/
theorem monotone.cauchy_seq_alternating_series_of_tendsto_zero
  (hfa : monotone f) (hf0 : tendsto f at_top (𝓝 0)) :
  cauchy_seq (λ n, ∑ i in range (n+1), (-1) ^ i * f i) :=
begin
  simp_rw [mul_comm],
  exact hfa.cauchy_seq_series_mul_of_tendsto_zero_of_bounded hf0 norm_sum_neg_one_pow_le
end

/-- The **alternating series test** for monotone sequences. -/
theorem monotone.tendsto_alternating_series_of_tendsto_zero
  (hfa : monotone f) (hf0 : tendsto f at_top (𝓝 0)) :
  ∃ l, tendsto (λ n, ∑ i in range (n+1), (-1) ^ i * f i) at_top (𝓝 l) :=
cauchy_seq_tendsto_of_complete $ hfa.cauchy_seq_alternating_series_of_tendsto_zero hf0

/-- The **alternating series test** for antitone sequences.
See also `tendsto_alternating_series_of_antitone_tendsto_zero`. -/
theorem antitone.cauchy_seq_alternating_series_of_tendsto_zero
  (hfa : antitone f) (hf0 : tendsto f at_top (𝓝 0)) :
  cauchy_seq (λ n, ∑ i in range (n+1), (-1) ^ i * f i) :=
begin
  simp_rw [mul_comm],
  exact
    hfa.cauchy_seq_series_mul_of_tendsto_zero_of_bounded hf0 norm_sum_neg_one_pow_le
end

/-- The **alternating series test** for antitone sequences. -/
theorem antitone.tendsto_alternating_series_of_tendsto_zero
  (hfa : antitone f) (hf0 : tendsto f at_top (𝓝 0)) :
  ∃ l, tendsto (λ n, ∑ i in range (n+1), (-1) ^ i * f i) at_top (𝓝 l) :=
cauchy_seq_tendsto_of_complete $ hfa.cauchy_seq_alternating_series_of_tendsto_zero hf0

end

/-!
### Factorial
-/

/-- The series `∑' n, x ^ n / n!` is summable of any `x : ℝ`. See also `exp_series_div_summable`
for a version that also works in `ℂ`, and `exp_series_summable'` for a version that works in
any normed algebra over `ℝ` or `ℂ`. -/
lemma real.summable_pow_div_factorial (x : ℝ) :
  summable (λ n, x ^ n / n! : ℕ → ℝ) :=
begin
  -- We start with trivial extimates
  have A : (0 : ℝ) < ⌊∥x∥⌋₊ + 1, from zero_lt_one.trans_le (by simp),
  have B : ∥x∥ / (⌊∥x∥⌋₊ + 1) < 1, from (div_lt_one A).2 (nat.lt_floor_add_one _),
  -- Then we apply the ratio test. The estimate works for `n ≥ ⌊∥x∥⌋₊`.
  suffices : ∀ n ≥ ⌊∥x∥⌋₊, ∥x ^ (n + 1) / (n + 1)!∥ ≤ ∥x∥ / (⌊∥x∥⌋₊ + 1) * ∥x ^ n / ↑n!∥,
    from summable_of_ratio_norm_eventually_le B (eventually_at_top.2 ⟨⌊∥x∥⌋₊, this⟩),
  -- Finally, we prove the upper estimate
  intros n hn,
  calc ∥x ^ (n + 1) / (n + 1)!∥ = (∥x∥ / (n + 1)) * ∥x ^ n / n!∥ :
    by rw [pow_succ, nat.factorial_succ, nat.cast_mul, ← div_mul_div_comm,
      norm_mul, norm_div, real.norm_coe_nat, nat.cast_succ]
  ... ≤ (∥x∥ / (⌊∥x∥⌋₊ + 1)) * ∥x ^ n / n!∥ :
    by mono* with [0 ≤ ∥x ^ n / n!∥, 0 ≤ ∥x∥]; apply norm_nonneg
end

lemma real.tendsto_pow_div_factorial_at_top (x : ℝ) :
  tendsto (λ n, x ^ n / n! : ℕ → ℝ) at_top (𝓝 0) :=
(real.summable_pow_div_factorial x).tendsto_at_top_zero


<|start_filename|>src/group_theory/schur_zassenhaus.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import group_theory.sylow
import group_theory.transfer

/-!
# The Schur-Zassenhaus Theorem

In this file we prove the Schur-Zassenhaus theorem.

## Main results

- `exists_right_complement'_of_coprime` : The **Schur-Zassenhaus** theorem:
  If `H : subgroup G` is normal and has order coprime to its index,
  then there exists a subgroup `K` which is a (right) complement of `H`.
- `exists_left_complement'_of_coprime`  The **Schur-Zassenhaus** theorem:
  If `H : subgroup G` is normal and has order coprime to its index,
  then there exists a subgroup `K` which is a (left) complement of `H`.
-/

open_locale big_operators

namespace subgroup

section schur_zassenhaus_abelian

open mul_opposite mul_action subgroup.left_transversals mem_left_transversals

variables {G : Type*} [group G] (H : subgroup G) [is_commutative H] [fintype (G ⧸ H)]
  (α β : left_transversals (H : set G))

/-- The quotient of the transversals of an abelian normal `N` by the `diff` relation. -/
def quotient_diff :=
quotient (setoid.mk (λ α β, diff (monoid_hom.id H) α β = 1) ⟨λ α, diff_self (monoid_hom.id H) α,
  λ α β h, by rw [←diff_inv, h, inv_one], λ α β γ h h', by rw [←diff_mul_diff, h, h', one_mul]⟩)

instance : inhabited H.quotient_diff := quotient.inhabited _

lemma smul_diff_smul' [hH : normal H] (g : Gᵐᵒᵖ) :
  diff (monoid_hom.id H) (g • α) (g • β) = ⟨g.unop⁻¹ * (diff (monoid_hom.id H) α β : H) * g.unop,
    hH.mem_comm ((congr_arg (∈ H) (mul_inv_cancel_left _ _)).mpr (set_like.coe_mem _))⟩ :=
begin
  let ϕ : H →* H :=
  { to_fun := λ h, ⟨g.unop⁻¹ * h * g.unop,
      hH.mem_comm ((congr_arg (∈ H) (mul_inv_cancel_left _ _)).mpr (set_like.coe_mem _))⟩,
    map_one' := by rw [subtype.ext_iff, coe_mk, coe_one, mul_one, inv_mul_self],
    map_mul' := λ h₁ h₂, by rw [subtype.ext_iff, coe_mk, coe_mul, coe_mul, coe_mk, coe_mk,
      mul_assoc, mul_assoc, mul_assoc, mul_assoc, mul_assoc, mul_inv_cancel_left] },
  refine eq.trans (finset.prod_bij' (λ q _, g⁻¹ • q) (λ q _, finset.mem_univ _)
    (λ q _, subtype.ext _) (λ q _, g • q) (λ q _, finset.mem_univ _) (λ q _, smul_inv_smul g q)
    (λ q _, inv_smul_smul g q)) (map_prod ϕ _ _).symm,
  simp_rw [monoid_hom.id_apply, monoid_hom.coe_mk, coe_mk, smul_apply_eq_smul_apply_inv_smul,
    smul_eq_mul_unop, mul_inv_rev, mul_assoc],
end

variables {H} [normal H]

instance : mul_action G H.quotient_diff :=
{ smul := λ g, quotient.map' (λ α, op g⁻¹ • α) (λ α β h, subtype.ext (by rwa [smul_diff_smul',
    coe_mk, coe_one, mul_eq_one_iff_eq_inv, mul_right_eq_self, ←coe_one, ←subtype.ext_iff])),
  mul_smul := λ g₁ g₂ q, quotient.induction_on' q (λ T, congr_arg quotient.mk'
    (by rw mul_inv_rev; exact mul_smul (op g₁⁻¹) (op g₂⁻¹) T)),
  one_smul := λ q, quotient.induction_on' q (λ T, congr_arg quotient.mk'
    (by rw inv_one; apply one_smul Gᵐᵒᵖ T)) }

lemma smul_diff' (h : H) :
  diff (monoid_hom.id H) α ((op (h : G)) • β) = diff (monoid_hom.id H) α β * h ^ H.index :=
begin
  rw [diff, diff, index_eq_card, ←finset.card_univ, ←finset.prod_const, ←finset.prod_mul_distrib],
  refine finset.prod_congr rfl (λ q _, _),
  simp_rw [subtype.ext_iff, monoid_hom.id_apply, coe_mul, coe_mk, mul_assoc, mul_right_inj],
  rw [smul_apply_eq_smul_apply_inv_smul, smul_eq_mul_unop, unop_op,
      mul_left_inj, ←subtype.ext_iff, equiv.apply_eq_iff_eq, inv_smul_eq_iff],
  exact self_eq_mul_right.mpr ((quotient_group.eq_one_iff _).mpr h.2),
end

variables [fintype H]

lemma eq_one_of_smul_eq_one (hH : nat.coprime (fintype.card H) H.index)
  (α : H.quotient_diff) (h : H) : h • α = α → h = 1 :=
quotient.induction_on' α $ λ α hα, (pow_coprime hH).injective $
  calc h ^ H.index = diff (monoid_hom.id H) ((op ((h⁻¹ : H) : G)) • α) α :
    by rw [←diff_inv, smul_diff', diff_self, one_mul, inv_pow, inv_inv]
  ... = 1 ^ H.index : (quotient.exact' hα).trans (one_pow H.index).symm

lemma exists_smul_eq (hH : nat.coprime (fintype.card H) H.index)
  (α β : H.quotient_diff) : ∃ h : H, h • α = β :=
quotient.induction_on' α (quotient.induction_on' β (λ β α, exists_imp_exists (λ n, quotient.sound')
  ⟨(pow_coprime hH).symm (diff (monoid_hom.id H) β α), (diff_inv _ _ _).symm.trans
  (inv_eq_one.mpr ((smul_diff' β α ((pow_coprime hH).symm (diff (monoid_hom.id H) β α))⁻¹).trans
  (by rw [inv_pow, ←pow_coprime_apply hH, equiv.apply_symm_apply, mul_inv_self])))⟩))

lemma is_complement'_stabilizer_of_coprime {α : H.quotient_diff}
  (hH : nat.coprime (fintype.card H) H.index) : is_complement' H (stabilizer G α) :=
is_complement'_stabilizer α (eq_one_of_smul_eq_one hH α) (λ g, exists_smul_eq hH (g • α) α)

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma exists_right_complement'_of_coprime_aux
  (hH : nat.coprime (fintype.card H) H.index) : ∃ K : subgroup G, is_complement' H K :=
nonempty_of_inhabited.elim (λ α, ⟨stabilizer G α, is_complement'_stabilizer_of_coprime hH⟩)

end schur_zassenhaus_abelian

open_locale classical

universe u

namespace schur_zassenhaus_induction

/-! ## Proof of the Schur-Zassenhaus theorem

In this section, we prove the Schur-Zassenhaus theorem.
The proof is by contradiction. We assume that `G` is a minimal counterexample to the theorem.
-/

variables {G : Type u} [group G] [fintype G] {N : subgroup G} [normal N]
  (h1 : nat.coprime (fintype.card N) N.index)
  (h2 : ∀ (G' : Type u) [group G'] [fintype G'], by exactI
    ∀ (hG'3 : fintype.card G' < fintype.card G)
    {N' : subgroup G'} [N'.normal] (hN : nat.coprime (fintype.card N') N'.index),
    ∃ H' : subgroup G', is_complement' N' H')
  (h3 : ∀ H : subgroup G, ¬ is_complement' N H)

include h1 h2 h3

/-! We will arrive at a contradiction via the following steps:
 * step 0: `N` (the normal Hall subgroup) is nontrivial.
 * step 1: If `K` is a subgroup of `G` with `K ⊔ N = ⊤`, then `K = ⊤`.
 * step 2: `N` is a minimal normal subgroup, phrased in terms of subgroups of `G`.
 * step 3: `N` is a minimal normal subgroup, phrased in terms of subgroups of `N`.
 * step 4: `p` (`min_fact (fintype.card N)`) is prime (follows from step0).
 * step 5: `P` (a Sylow `p`-subgroup of `N`) is nontrivial.
 * step 6: `N` is a `p`-group (applies step 1 to the normalizer of `P` in `G`).
 * step 7: `N` is abelian (applies step 3 to the center of `N`).
-/

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
@[nolint unused_arguments] private lemma step0 : N ≠ ⊥ :=
begin
  unfreezingI { rintro rfl },
  exact h3 ⊤ is_complement'_bot_top,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step1 (K : subgroup G) (hK : K ⊔ N = ⊤) : K = ⊤ :=
begin
  contrapose! h3,
  have h4 : (N.comap K.subtype).index = N.index,
  { rw [←N.relindex_top_right, ←hK],
    exact relindex_eq_relindex_sup K N },
  have h5 : fintype.card K < fintype.card G,
  { rw ← K.index_mul_card,
    exact lt_mul_of_one_lt_left fintype.card_pos (one_lt_index_of_ne_top h3) },
  have h6 : nat.coprime (fintype.card (N.comap K.subtype)) (N.comap K.subtype).index,
  { rw h4,
    exact h1.coprime_dvd_left (card_comap_dvd_of_injective N K.subtype subtype.coe_injective) },
  obtain ⟨H, hH⟩ := h2 K h5 h6,
  replace hH : fintype.card (H.map K.subtype) = N.index :=
  ((set.card_image_of_injective _ subtype.coe_injective).trans (nat.mul_left_injective
    fintype.card_pos (hH.symm.card_mul.trans (N.comap K.subtype).index_mul_card.symm))).trans h4,
  have h7 : fintype.card N * fintype.card (H.map K.subtype) = fintype.card G,
  { rw [hH, ←N.index_mul_card, mul_comm] },
  have h8 : (fintype.card N).coprime (fintype.card (H.map K.subtype)),
  { rwa hH },
  exact ⟨H.map K.subtype, is_complement'_of_coprime h7 h8⟩,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step2 (K : subgroup G) [K.normal] (hK : K ≤ N) : K = ⊥ ∨ K = N :=
begin
  have : function.surjective (quotient_group.mk' K) := quotient.surjective_quotient_mk',
  have h4 := step1 h1 h2 h3,
  contrapose! h4,
  have h5 : fintype.card (G ⧸ K) < fintype.card G,
  { rw [←index_eq_card, ←K.index_mul_card],
    refine lt_mul_of_one_lt_right (nat.pos_of_ne_zero index_ne_zero_of_fintype)
      (K.one_lt_card_iff_ne_bot.mpr h4.1) },
  have h6 : nat.coprime (fintype.card (N.map (quotient_group.mk' K)))
    (N.map (quotient_group.mk' K)).index,
  { have index_map := N.index_map_eq this (by rwa quotient_group.ker_mk),
    have index_pos : 0 < N.index := nat.pos_of_ne_zero index_ne_zero_of_fintype,
    rw index_map,
    refine h1.coprime_dvd_left _,
    rw [←nat.mul_dvd_mul_iff_left index_pos, index_mul_card, ←index_map, index_mul_card],
    exact K.card_quotient_dvd_card },
  obtain ⟨H, hH⟩ := h2 (G ⧸ K) h5 h6,
  refine ⟨H.comap (quotient_group.mk' K), _, _⟩,
  { have key : (N.map (quotient_group.mk' K)).comap (quotient_group.mk' K) = N,
    { refine comap_map_eq_self _,
      rwa quotient_group.ker_mk },
    rwa [←key, comap_sup_eq, hH.symm.sup_eq_top, comap_top] },
  { rw ← comap_top (quotient_group.mk' K),
    intro hH',
    rw [comap_injective this hH', is_complement'_top_right,
        map_eq_bot_iff, quotient_group.ker_mk] at hH,
    { exact h4.2 (le_antisymm hK hH) } },
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step3 (K : subgroup N) [(K.map N.subtype).normal] : K = ⊥ ∨ K = ⊤ :=
begin
  have key := step2 h1 h2 h3 (K.map N.subtype) K.map_subtype_le,
  rw ← map_bot N.subtype at key,
  conv at key { congr, skip, to_rhs, rw [←N.subtype_range, N.subtype.range_eq_map] },
  have inj := map_injective (show function.injective N.subtype, from subtype.coe_injective),
  rwa [inj.eq_iff, inj.eq_iff] at key,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step4 : (fintype.card N).min_fac.prime :=
(nat.min_fac_prime (N.one_lt_card_iff_ne_bot.mpr (step0 h1 h2 h3)).ne')

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step5 {P : sylow (fintype.card N).min_fac N} : P.1 ≠ ⊥ :=
begin
  haveI : fact ((fintype.card N).min_fac.prime) := ⟨step4 h1 h2 h3⟩,
  exact P.ne_bot_of_dvd_card (fintype.card N).min_fac_dvd,
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma step6 : is_p_group (fintype.card N).min_fac N :=
begin
  haveI : fact ((fintype.card N).min_fac.prime) := ⟨step4 h1 h2 h3⟩,
  refine sylow.nonempty.elim (λ P, P.2.of_surjective P.1.subtype _),
  rw [←monoid_hom.range_top_iff_surjective, subtype_range],
  haveI : (P.1.map N.subtype).normal := normalizer_eq_top.mp
    (step1 h1 h2 h3 (P.1.map N.subtype).normalizer P.normalizer_sup_eq_top),
  exact (step3 h1 h2 h3 P.1).resolve_left (step5 h1 h2 h3),
end

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
lemma step7 : is_commutative N :=
begin
  haveI := N.bot_or_nontrivial.resolve_left (step0 h1 h2 h3),
  haveI : fact ((fintype.card N).min_fac.prime) := ⟨step4 h1 h2 h3⟩,
  exact ⟨⟨λ g h, eq_top_iff.mp ((step3 h1 h2 h3 N.center).resolve_left
    (step6 h1 h2 h3).bot_lt_center.ne') (mem_top h) g⟩⟩,
end

end schur_zassenhaus_induction

variables {n : ℕ} {G : Type u} [group G]

/-- Do not use this lemma: It is made obsolete by `exists_right_complement'_of_coprime` -/
private lemma exists_right_complement'_of_coprime_aux' [fintype G] (hG : fintype.card G = n)
  {N : subgroup G} [N.normal] (hN : nat.coprime (fintype.card N) N.index) :
  ∃ H : subgroup G, is_complement' N H :=
begin
  unfreezingI { revert G },
  apply nat.strong_induction_on n,
  rintros n ih G _ _ rfl N _ hN,
  refine not_forall_not.mp (λ h3, _),
  haveI := by exactI
    schur_zassenhaus_induction.step7 hN (λ G' _ _ hG', by { apply ih _ hG', refl }) h3,
  exact not_exists_of_forall_not h3 (exists_right_complement'_of_coprime_aux hN),
end

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (right) complement of `H`. -/
theorem exists_right_complement'_of_coprime_of_fintype [fintype G]
  {N : subgroup G} [N.normal] (hN : nat.coprime (fintype.card N) N.index) :
  ∃ H : subgroup G, is_complement' N H :=
exists_right_complement'_of_coprime_aux' rfl hN

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (right) complement of `H`. -/
theorem exists_right_complement'_of_coprime
  {N : subgroup G} [N.normal] (hN : nat.coprime (nat.card N) N.index) :
  ∃ H : subgroup G, is_complement' N H :=
begin
  by_cases hN1 : nat.card N = 0,
  { rw [hN1, nat.coprime_zero_left, index_eq_one] at hN,
    rw hN,
    exact ⟨⊥, is_complement'_top_bot⟩ },
  by_cases hN2 : N.index = 0,
  { rw [hN2, nat.coprime_zero_right] at hN,
    haveI := (cardinal.to_nat_eq_one_iff_unique.mp hN).1,
    rw N.eq_bot_of_subsingleton,
    exact ⟨⊤, is_complement'_bot_top⟩ },
  have hN3 : nat.card G ≠ 0,
  { rw ← N.card_mul_index,
    exact mul_ne_zero hN1 hN2 },
  haveI := (cardinal.lt_aleph_0_iff_fintype.mp
    (lt_of_not_ge (mt cardinal.to_nat_apply_of_aleph_0_le hN3))).some,
  rw nat.card_eq_fintype_card at hN,
  exact exists_right_complement'_of_coprime_of_fintype hN,
end

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (left) complement of `H`. -/
theorem exists_left_complement'_of_coprime_of_fintype
  [fintype G] {N : subgroup G} [N.normal] (hN : nat.coprime (fintype.card N) N.index) :
  ∃ H : subgroup G, is_complement' H N :=
Exists.imp (λ _, is_complement'.symm) (exists_right_complement'_of_coprime_of_fintype hN)

/-- **Schur-Zassenhaus** for normal subgroups:
  If `H : subgroup G` is normal, and has order coprime to its index, then there exists a
  subgroup `K` which is a (left) complement of `H`. -/
theorem exists_left_complement'_of_coprime
  {N : subgroup G} [N.normal] (hN : nat.coprime (nat.card N) N.index) :
  ∃ H : subgroup G, is_complement' H N :=
Exists.imp (λ _, is_complement'.symm) (exists_right_complement'_of_coprime hN)

end subgroup


<|start_filename|>src/analysis/specific_limits/floor_pow.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import analysis.specific_limits.basic
import analysis.special_functions.pow

/-!
# Results on discretized exponentials

We state several auxiliary results pertaining to sequences of the form `⌊c^n⌋₊`.

* `tendsto_div_of_monotone_of_tendsto_div_floor_pow`: If a monotone sequence `u` is such that
  `u ⌊c^n⌋₊ / ⌊c^n⌋₊` converges to a limit `l` for all `c > 1`, then `u n / n` tends to `l`.
* `sum_div_nat_floor_pow_sq_le_div_sq`: The sum of `1/⌊c^i⌋₊^2` above a threshold `j` is comparable
  to `1/j^2`, up to a multiplicative constant.
-/

open filter finset
open_locale topological_space big_operators

/-- If a monotone sequence `u` is such that `u n / n` tends to a limit `l` along subsequences with
exponential growth rate arbitrarily close to `1`, then `u n / n` tends to `l`. -/
lemma tendsto_div_of_monotone_of_exists_subseq_tendsto_div (u : ℕ → ℝ) (l : ℝ) (hmono : monotone u)
  (hlim : ∀ (a : ℝ), 1 < a → ∃ c : ℕ → ℕ, (∀ᶠ n in at_top, (c (n+1) : ℝ) ≤ a * c n) ∧
    tendsto c at_top at_top ∧ tendsto (λ n, u (c n) / (c n)) at_top (𝓝 l)) :
  tendsto (λ n, u n / n) at_top (𝓝 l) :=
begin
  /- To check the result up to some `ε > 0`, we use a sequence `c` for which the ratio
  `c (N+1) / c N` is bounded by `1 + ε`. Sandwiching a given `n` between two consecutive values of
  `c`, say `c N` and `c (N+1)`, one can then bound `u n / n` from above by `u (c N) / c (N - 1)`
  and from below by `u (c (N - 1)) / c N` (using that `u` is monotone), which are both comparable
  to the limit `l` up to `1 + ε`.
  We give a version of this proof by clearing out denominators first, to avoid discussing the sign
  of different quantities. -/
  have lnonneg : 0 ≤ l,
  { rcases hlim 2 one_lt_two with ⟨c, cgrowth, ctop, clim⟩,
    have : tendsto (λ n, u 0 / (c n)) at_top (𝓝 0) :=
      tendsto_const_nhds.div_at_top (tendsto_coe_nat_at_top_iff.2 ctop),
    apply le_of_tendsto_of_tendsto' this clim (λ n, _),
    simp_rw [div_eq_inv_mul],
    exact mul_le_mul_of_nonneg_left (hmono (zero_le _)) (inv_nonneg.2 (nat.cast_nonneg _)) },
  have A : ∀ (ε : ℝ), 0 < ε → ∀ᶠ n in at_top, u n - n * l ≤ (ε * (1 + ε + l)) * n,
  { assume ε εpos,
    rcases hlim (1 + ε) ((lt_add_iff_pos_right _).2 εpos) with ⟨c, cgrowth, ctop, clim⟩,
    have L : ∀ᶠ n in at_top, u (c n) - c n * l ≤ ε * c n,
    { rw [← tendsto_sub_nhds_zero_iff, ← asymptotics.is_o_one_iff ℝ,
          asymptotics.is_o_iff] at clim,
      filter_upwards [clim εpos, ctop (Ioi_mem_at_top 0)] with n hn cnpos',
      have cnpos : 0 < c n := cnpos',
      calc u (c n) - c n * l
      = (u (c n) / c n - l) * c n:
        by simp only [cnpos.ne', ne.def, nat.cast_eq_zero, not_false_iff] with field_simps
      ... ≤ ε * c n :
        begin
          apply mul_le_mul_of_nonneg_right _ (nat.cast_nonneg _),
          simp only [mul_one, real.norm_eq_abs, abs_one] at hn,
          exact le_trans (le_abs_self _) hn,
        end },
    obtain ⟨a, ha⟩ : ∃ (a : ℕ), ∀ (b : ℕ), a ≤ b → (c (b + 1) : ℝ) ≤ (1 + ε) * c b
        ∧ u (c b) - c b * l ≤ ε * c b := eventually_at_top.1 (cgrowth.and L),
    let M := ((finset.range (a+1)).image (λ i, c i)).max' (by simp),
    filter_upwards [Ici_mem_at_top M] with n hn,
    have exN : ∃ N, n < c N,
    { rcases (tendsto_at_top.1 ctop (n+1)).exists with ⟨N, hN⟩,
      exact ⟨N, by linarith only [hN]⟩ },
    let N := nat.find exN,
    have ncN : n < c N := nat.find_spec exN,
    have aN : a + 1 ≤ N,
    { by_contra' h,
      have cNM : c N ≤ M,
      { apply le_max',
        apply mem_image_of_mem,
        exact mem_range.2 h },
      exact lt_irrefl _ ((cNM.trans hn).trans_lt ncN) },
    have Npos : 0 < N := lt_of_lt_of_le (nat.succ_pos') aN,
    have cNn : c (N - 1) ≤ n,
    { have : N - 1 < N := nat.pred_lt Npos.ne',
      simpa only [not_lt] using nat.find_min exN this },
    have IcN : (c N : ℝ) ≤ (1 + ε) * (c (N - 1)),
    { have A : a ≤ N - 1, by linarith only [aN, Npos],
      have B : N - 1 + 1 = N := nat.succ_pred_eq_of_pos Npos,
      have := (ha _ A).1,
      rwa B at this },
    calc u n - n * l ≤ u (c N) - c (N - 1) * l :
      begin
        apply sub_le_sub (hmono ncN.le),
        apply mul_le_mul_of_nonneg_right (nat.cast_le.2 cNn) lnonneg,
      end
    ... = (u (c N) - c N * l) + (c N - c (N - 1)) * l : by ring
    ... ≤ ε * c N + (ε * c (N - 1)) * l :
      begin
        apply add_le_add,
        { apply (ha _ _).2,
          exact le_trans (by simp only [le_add_iff_nonneg_right, zero_le']) aN },
        { apply mul_le_mul_of_nonneg_right _ lnonneg,
          linarith only [IcN] },
      end
    ... ≤ ε * ((1 + ε) * c (N-1)) + (ε * c (N - 1)) * l :
      add_le_add (mul_le_mul_of_nonneg_left IcN εpos.le) le_rfl
    ... = (ε * (1 + ε + l)) * c (N - 1) : by ring
    ... ≤ (ε * (1 + ε + l)) * n :
      begin
        refine mul_le_mul_of_nonneg_left (nat.cast_le.2 cNn) _,
        apply mul_nonneg εpos.le,
        linarith only [εpos, lnonneg]
      end },
  have B : ∀ (ε : ℝ), 0 < ε → ∀ᶠ (n : ℕ) in at_top, (n : ℝ) * l - u n ≤ (ε * (1 + l)) * n,
  { assume ε εpos,
    rcases hlim (1 + ε) ((lt_add_iff_pos_right _).2 εpos) with ⟨c, cgrowth, ctop, clim⟩,
    have L : ∀ᶠ (n : ℕ) in at_top, (c n : ℝ) * l - u (c n) ≤ ε * c n,
    { rw [← tendsto_sub_nhds_zero_iff, ← asymptotics.is_o_one_iff ℝ,
          asymptotics.is_o_iff] at clim,
      filter_upwards [clim εpos, ctop (Ioi_mem_at_top 0)] with n hn cnpos',
      have cnpos : 0 < c n := cnpos',
      calc (c n : ℝ) * l - u (c n)
      = -(u (c n) / c n - l) * c n:
        by simp only [cnpos.ne', ne.def, nat.cast_eq_zero, not_false_iff, neg_sub] with field_simps
      ... ≤ ε * c n :
        begin
          apply mul_le_mul_of_nonneg_right _ (nat.cast_nonneg _),
          simp only [mul_one, real.norm_eq_abs, abs_one] at hn,
          exact le_trans (neg_le_abs_self _) hn,
        end },
    obtain ⟨a, ha⟩ : ∃ (a : ℕ), ∀ (b : ℕ), a ≤ b → (c (b + 1) : ℝ) ≤ (1 + ε) * c b
        ∧ (c b : ℝ) * l - u (c b) ≤ ε * c b := eventually_at_top.1 (cgrowth.and L),
    let M := ((finset.range (a+1)).image (λ i, c i)).max' (by simp),
    filter_upwards [Ici_mem_at_top M] with n hn,
    have exN : ∃ N, n < c N,
    { rcases (tendsto_at_top.1 ctop (n+1)).exists with ⟨N, hN⟩,
      exact ⟨N, by linarith only [hN]⟩ },
    let N := nat.find exN,
    have ncN : n < c N := nat.find_spec exN,
    have aN : a + 1 ≤ N,
    { by_contra' h,
      have cNM : c N ≤ M,
      { apply le_max',
        apply mem_image_of_mem,
        exact mem_range.2 h },
      exact lt_irrefl _ ((cNM.trans hn).trans_lt ncN) },
    have Npos : 0 < N := lt_of_lt_of_le (nat.succ_pos') aN,
    have aN' : a ≤ N - 1 := by linarith only [aN, Npos],
    have cNn : c (N - 1) ≤ n,
    { have : N - 1 < N := nat.pred_lt Npos.ne',
      simpa only [not_lt] using nat.find_min exN this },
    calc (n : ℝ) * l - u n ≤ c N * l - u (c (N - 1)) :
      begin
        refine add_le_add (mul_le_mul_of_nonneg_right (nat.cast_le.2 ncN.le) lnonneg) _,
        exact neg_le_neg (hmono cNn),
      end
    ... ≤ ((1 + ε) * c (N - 1)) * l - u (c (N - 1)) :
      begin
        refine add_le_add (mul_le_mul_of_nonneg_right _ lnonneg) le_rfl,
        have B : N - 1 + 1 = N := nat.succ_pred_eq_of_pos Npos,
        have := (ha _ aN').1,
        rwa B at this,
      end
    ... = (c (N - 1) * l - u (c (N - 1))) + ε * c (N - 1) * l : by ring
    ... ≤ ε * c (N - 1) + ε * c (N - 1) * l :
      add_le_add (ha _ aN').2 le_rfl
    ... = (ε * (1 + l)) * c (N - 1) : by ring
    ... ≤ (ε * (1 + l)) * n :
      begin
        refine mul_le_mul_of_nonneg_left (nat.cast_le.2 cNn) _,
        exact mul_nonneg (εpos.le) (add_nonneg zero_le_one lnonneg),
      end },
  refine tendsto_order.2 ⟨λ d hd, _, λ d hd, _⟩,
  { obtain ⟨ε, hε, εpos⟩ : ∃ (ε : ℝ), d + ε * (1 + l) < l ∧ 0 < ε,
    { have L : tendsto (λ ε, d + (ε * (1 + l))) (𝓝[>] 0) (𝓝 (d + 0 * (1 + l))),
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        exact tendsto_const_nhds.add (tendsto_id.mul tendsto_const_nhds) },
      simp only [zero_mul, add_zero] at L,
      exact (((tendsto_order.1 L).2 l hd).and (self_mem_nhds_within)).exists },
    filter_upwards [B ε εpos, Ioi_mem_at_top 0] with n hn npos,
    simp_rw [div_eq_inv_mul],
    calc d < (n⁻¹ * n) * (l - ε * (1 + l)) :
      begin
        rw [inv_mul_cancel, one_mul],
        { linarith only [hε] },
        { exact nat.cast_ne_zero.2 (ne_of_gt npos) }
      end
    ... = n⁻¹ * (n * l - ε * (1 + l) * n) : by ring
    ... ≤ n⁻¹ * u n :
      begin
        refine mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (nat.cast_nonneg _)),
        linarith only [hn],
      end },
  { obtain ⟨ε, hε, εpos⟩ : ∃ (ε : ℝ), l + ε * (1 + ε + l) < d ∧ 0 < ε,
    { have L : tendsto (λ ε, l + (ε * (1 + ε + l))) (𝓝[>] 0) (𝓝 (l + 0 * (1 + 0 + l))),
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        exact tendsto_const_nhds.add
          (tendsto_id.mul ((tendsto_const_nhds.add tendsto_id).add tendsto_const_nhds)) },
      simp only [zero_mul, add_zero] at L,
      exact (((tendsto_order.1 L).2 d hd).and (self_mem_nhds_within)).exists },
    filter_upwards [A ε εpos, Ioi_mem_at_top 0] with n hn npos,
    simp_rw [div_eq_inv_mul],
    calc (n : ℝ)⁻¹ * u n ≤ (n : ℝ)⁻¹ * (n * l + ε * (1 + ε + l) * n) :
      begin
        refine mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (nat.cast_nonneg _)),
        linarith only [hn],
      end
    ... = ((n : ℝ) ⁻¹ * n) * (l + ε * (1 + ε + l)) : by ring
    ... < d :
      begin
        rwa [inv_mul_cancel, one_mul],
        exact nat.cast_ne_zero.2 (ne_of_gt npos),
      end }
end

/-- If a monotone sequence `u` is such that `u ⌊c^n⌋₊ / ⌊c^n⌋₊` converges to a limit `l` for all
`c > 1`, then `u n / n` tends to `l`. It is even enough to have the assumption for a sequence of
`c`s converging to `1`. -/
lemma tendsto_div_of_monotone_of_tendsto_div_floor_pow
  (u : ℕ → ℝ) (l : ℝ) (hmono : monotone u)
  (c : ℕ → ℝ) (cone : ∀ k, 1 < c k) (clim : tendsto c at_top (𝓝 1))
  (hc : ∀ k, tendsto (λ (n : ℕ), u (⌊(c k) ^ n⌋₊) / ⌊(c k)^n⌋₊) at_top (𝓝 l)) :
  tendsto (λ n, u n / n) at_top (𝓝 l) :=
begin
  apply tendsto_div_of_monotone_of_exists_subseq_tendsto_div u l hmono,
  assume a ha,
  obtain ⟨k, hk⟩ : ∃ k, c k < a := ((tendsto_order.1 clim).2 a ha).exists,
  refine ⟨λ n, ⌊(c k)^n⌋₊, _,
    tendsto_nat_floor_at_top.comp (tendsto_pow_at_top_at_top_of_one_lt (cone k)), hc k⟩,
  have H : ∀ (n : ℕ), (0 : ℝ) < ⌊c k ^ n⌋₊,
  { assume n,
    refine zero_lt_one.trans_le _,
    simp only [nat.one_le_cast, nat.one_le_floor_iff, one_le_pow_of_one_le (cone k).le n] },
  have A : tendsto (λ (n : ℕ), ((⌊c k ^ (n+1)⌋₊ : ℝ) / c k ^ (n+1)) * c k /
    (⌊c k ^ n⌋₊ / c k ^ n)) at_top (𝓝 (1 * c k / 1)),
  { refine tendsto.div (tendsto.mul _ tendsto_const_nhds) _ one_ne_zero,
    { refine tendsto_nat_floor_div_at_top.comp _,
      exact (tendsto_pow_at_top_at_top_of_one_lt (cone k)).comp (tendsto_add_at_top_nat 1) },
    { refine tendsto_nat_floor_div_at_top.comp _,
      exact tendsto_pow_at_top_at_top_of_one_lt (cone k) } },
  have B : tendsto (λ (n : ℕ), (⌊c k ^ (n+1)⌋₊ : ℝ) / ⌊c k ^ n⌋₊) at_top (𝓝 (c k)),
  { simp only [one_mul, div_one] at A,
    convert A,
    ext1 n,
    simp only [(zero_lt_one.trans (cone k)).ne', ne.def, not_false_iff, (H n).ne']
      with field_simps {discharger := tactic.field_simp.ne_zero},
    ring_exp },
  filter_upwards [(tendsto_order.1 B).2 a hk] with n hn,
  exact (div_le_iff (H n)).1 hn.le
end

/-- The sum of `1/(c^i)^2` above a threshold `j` is comparable to `1/j^2`, up to a multiplicative
constant. -/
lemma sum_div_pow_sq_le_div_sq (N : ℕ) {j : ℝ} (hj : 0 < j) {c : ℝ} (hc : 1 < c) :
  ∑ i in (range N).filter (λ i, j < c ^ i), 1 / (c ^ i) ^ 2 ≤ (c^3 * (c - 1) ⁻¹) / j ^ 2 :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  have A : 0 < (c⁻¹) ^ 2 := sq_pos_of_pos (inv_pos.2 cpos),
  have B : c^2 * (1 - c⁻¹ ^ 2) ⁻¹ ≤ c^3 * (c - 1) ⁻¹,
  { rw [← div_eq_mul_inv, ← div_eq_mul_inv, div_le_div_iff _ (sub_pos.2 hc)], swap,
    { exact sub_pos.2 (pow_lt_one (inv_nonneg.2 cpos.le) (inv_lt_one hc) two_ne_zero) },
    have : c ^ 3 = c^2 * c, by ring_exp,
    simp only [mul_sub, this, mul_one, inv_pow, sub_le_sub_iff_left],
    rw [mul_assoc, mul_comm c, ← mul_assoc, mul_inv_cancel (sq_pos_of_pos cpos).ne', one_mul],
    simpa using pow_le_pow hc.le one_le_two },
  calc
  ∑ i in (range N).filter (λ i, j < c ^ i), 1/ (c ^ i) ^ 2
    ≤ ∑ i in Ico (⌊real.log j / real.log c⌋₊) N, 1 / (c ^ i) ^ 2 :
  begin
    refine sum_le_sum_of_subset_of_nonneg _ (λ i hi hident, div_nonneg zero_le_one (sq_nonneg _)),
    assume i hi,
    simp only [mem_filter, mem_range] at hi,
    simp only [hi.1, mem_Ico, and_true],
    apply nat.floor_le_of_le,
    apply le_of_lt,
    rw [div_lt_iff (real.log_pos hc), ← real.log_pow],
    exact real.log_lt_log hj hi.2
  end
  ... = ∑ i in Ico (⌊real.log j / real.log c⌋₊) N, ((c⁻¹) ^ 2) ^ i :
  begin
    congr' 1 with i,
    simp [← pow_mul, mul_comm],
  end
  ... ≤ ((c⁻¹) ^ 2) ^ (⌊real.log j / real.log c⌋₊) / (1 - (c⁻¹) ^ 2) :
  begin
    apply geom_sum_Ico_le_of_lt_one (sq_nonneg _),
    rw sq_lt_one_iff (inv_nonneg.2 (zero_le_one.trans hc.le)),
    exact inv_lt_one hc
  end
  ... ≤ ((c⁻¹) ^ 2) ^ (real.log j / real.log c - 1) / (1 - (c⁻¹) ^ 2) :
  begin
    apply div_le_div _ _ _ le_rfl,
    { apply real.rpow_nonneg_of_nonneg (sq_nonneg _) },
    { rw ← real.rpow_nat_cast,
      apply real.rpow_le_rpow_of_exponent_ge A,
      { exact pow_le_one _ (inv_nonneg.2 (zero_le_one.trans hc.le)) (inv_le_one hc.le) },
      { exact (nat.sub_one_lt_floor _).le } },
    { simpa only [inv_pow, sub_pos] using inv_lt_one (one_lt_pow hc two_ne_zero) }
  end
  ... = (c^2 * (1 - c⁻¹ ^ 2) ⁻¹) / j ^ 2 :
  begin
    have I : (c ⁻¹ ^ 2) ^ (real.log j / real.log c) = 1 / j ^ 2,
    { apply real.log_inj_on_pos (real.rpow_pos_of_pos A _),
      { rw [one_div], exact inv_pos.2 (sq_pos_of_pos hj) },
      rw real.log_rpow A,
      simp only [one_div, real.log_inv, real.log_pow, nat.cast_bit0, nat.cast_one, mul_neg,
        neg_inj],
      field_simp [(real.log_pos hc).ne'],
      ring },
    rw [real.rpow_sub A, I],
    have : c^2 - 1 ≠ 0 := (sub_pos.2 (one_lt_pow hc two_ne_zero)).ne',
    field_simp [hj.ne', (zero_lt_one.trans hc).ne'],
    ring,
  end
  ... ≤ (c^3 * (c - 1) ⁻¹) / j ^ 2 :
  begin
    apply div_le_div _ B (sq_pos_of_pos hj) le_rfl,
    exact mul_nonneg (pow_nonneg cpos.le _) (inv_nonneg.2 (sub_pos.2 hc).le),
  end
end

lemma mul_pow_le_nat_floor_pow {c : ℝ} (hc : 1 < c) (i : ℕ) :
  (1 - c⁻¹) * c ^ i ≤ ⌊c ^ i⌋₊ :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  rcases nat.eq_zero_or_pos i with rfl|hi,
  { simp only [pow_zero, nat.floor_one, nat.cast_one, mul_one, sub_le_self_iff, inv_nonneg,
      cpos.le] },
  have hident : 1 ≤ i := hi,
  calc (1 - c⁻¹) * c ^ i
      = c ^ i - c ^ i * c ⁻¹ : by ring
  ... ≤ c ^ i - 1 :
    by simpa only [←div_eq_mul_inv, sub_le_sub_iff_left, one_le_div cpos, pow_one]
      using pow_le_pow hc.le hident
  ... ≤ ⌊c ^ i⌋₊ : (nat.sub_one_lt_floor _).le
end

/-- The sum of `1/⌊c^i⌋₊^2` above a threshold `j` is comparable to `1/j^2`, up to a multiplicative
constant. -/
lemma sum_div_nat_floor_pow_sq_le_div_sq (N : ℕ) {j : ℝ} (hj : 0 < j) {c : ℝ} (hc : 1 < c) :
  ∑ i in (range N).filter (λ i, j < ⌊c ^ i⌋₊), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2
    ≤ (c ^ 5 * (c - 1) ⁻¹ ^ 3) / j ^ 2 :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  have A : 0 < 1 - c⁻¹ := sub_pos.2 (inv_lt_one hc),
  calc
  ∑ i in (range N).filter (λ i, j < ⌊c ^ i⌋₊), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2
      ≤ ∑ i in (range N).filter (λ i, j < c ^ i), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2 :
  begin
    apply sum_le_sum_of_subset_of_nonneg,
    { assume i hi,
      simp only [mem_filter, mem_range] at hi,
      simpa only [hi.1, mem_filter, mem_range, true_and]
        using hi.2.trans_le (nat.floor_le (pow_nonneg cpos.le _)) },
    { assume i hi hident,
      exact div_nonneg zero_le_one (sq_nonneg _), }
  end
  ... ≤ ∑ i in (range N).filter (λ i, j < c ^ i), ((1 - c⁻¹) ⁻¹) ^ 2 * (1 / (c ^ i) ^ 2) :
  begin
    apply sum_le_sum (λ i hi, _),
    rw [mul_div_assoc', mul_one, div_le_div_iff], rotate,
    { apply sq_pos_of_pos,
      refine zero_lt_one.trans_le _,
      simp only [nat.le_floor, one_le_pow_of_one_le, hc.le, nat.one_le_cast, nat.cast_one] },
    { exact sq_pos_of_pos (pow_pos cpos _) },
    rw [one_mul, ← mul_pow],
    apply pow_le_pow_of_le_left (pow_nonneg cpos.le _),
    rw [← div_eq_inv_mul, le_div_iff A, mul_comm],
    exact mul_pow_le_nat_floor_pow hc i,
  end
  ... ≤ ((1 - c⁻¹) ⁻¹) ^ 2 * (c^3 * (c - 1) ⁻¹) / j ^ 2 :
  begin
    rw [← mul_sum, ← mul_div_assoc'],
    refine mul_le_mul_of_nonneg_left _ (sq_nonneg _),
    exact sum_div_pow_sq_le_div_sq N hj hc,
  end
  ... = (c ^ 5 * (c - 1) ⁻¹ ^ 3) / j ^ 2 :
  begin
    congr' 1,
    field_simp [cpos.ne', (sub_pos.2 hc).ne'],
    ring,
  end
end


<|start_filename|>counterexamples/homogeneous_prime_not_prime.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>
-/
import ring_theory.graded_algebra.homogeneous_ideal
import data.zmod.basic
import tactic.derive_fintype

/-!
# A homogeneous prime that is homogeneously prime but not prime

In `src/ring_theory/graded_algebra/radical.lean`,  we assumed that the underline grading is indexed
by a `linear_ordered_cancel_add_comm_monoid` to prove that a homogeneous ideal is prime if and only
if it is homogeneously prime. This file is aimed to show that even if this assumption isn't strictly
necessary, the assumption of "being cancellative" is. We construct a counterexample where the
underlying indexing set is a `linear_ordered_add_comm_monoid` but is not cancellative and the
statement is false.

We achieve this by considering the ring `R=ℤ/4ℤ`. We first give the two element set `ι = {0, 1}` a
structure of linear ordered additive commutative monoid by setting `0 + 0 = 0` and `_ + _ = 1` and
`0 < 1`. Then we use `ι` to grade `R²` by setting `{(a, a) | a ∈ R}` to have grade `0`; and
`{(0, b) | b ∈ R}` to have grade 1. Then the ideal `I = span {(0, 2)} ⊆ ℤ/4ℤ` is homogeneous and not
prime. But it is homogeneously prime, i.e. if `(a, b), (c, d)` are two homogeneous elements then
`(a, b) * (c, d) ∈ I` implies either `(a, b) ∈ I` or `(c, d) ∈ I`.


## Tags

homogeneous, prime
-/

namespace counterexample_not_prime_but_homogeneous_prime

open direct_sum
local attribute [reducible] with_zero

abbreviation two := with_zero unit

instance : linear_ordered_add_comm_monoid two :=
{ add_le_add_left := by delta two with_zero; dec_trivial,
  ..(_ : linear_order two),
  ..(_ : add_comm_monoid two)}

section

variables (R : Type*) [comm_ring R]

/-- The grade 0 part of `R²` is `{(a, a) | a ∈ R}`. -/
def submodule_z : submodule R (R × R) :=
{ carrier := { zz | zz.1 = zz.2 },
  zero_mem' := rfl,
  add_mem' := λ a b ha hb, congr_arg2 (+) ha hb,
  smul_mem' := λ a b hb, congr_arg ((*) a) hb }

/-- The grade 1 part of `R²` is `{(0, b) | b ∈ R}`. -/
def submodule_o : submodule R (R × R) := (linear_map.fst R R R).ker

/-- Given the above grading (see `submodule_z` and `submodule_o`),
  we turn `R²` into a graded ring. -/
def grading : two → submodule R (R × R)
| 0 := submodule_z R
| 1 := submodule_o R

lemma grading.one_mem : (1 : (R × R)) ∈ grading R 0 :=
eq.refl (1, 1).fst

lemma grading.mul_mem : ∀ ⦃i j : two⦄ {a b : (R × R)} (ha : a ∈ grading R i) (hb : b ∈ grading R j),
  a * b ∈ grading R (i + j)
| 0 0 a b (ha : a.1 = a.2) (hb : b.1 = b.2) := show a.1 * b.1 = a.2 * b.2, by rw [ha, hb]
| 0 1 a b (ha : a.1 = a.2) (hb : b.1 = 0)   := show a.1 * b.1 = 0, by rw [hb, mul_zero]
| 1 0 a b (ha : a.1 = 0) hb                 := show a.1 * b.1 = 0, by rw [ha, zero_mul]
| 1 1 a b (ha : a.1 = 0) hb                 := show a.1 * b.1 = 0, by rw [ha, zero_mul]

end

notation `R` := zmod 4

/-- `R² ≅ {(a, a) | a ∈ R} ⨁ {(0, b) | b ∈ R}` by `(x, y) ↦ (x, x) + (0, y - x)`. -/
def grading.decompose : (R × R) →+ direct_sum two (λ i, grading R i) :=
{ to_fun := λ zz, of (λ i, grading R i) 0 ⟨(zz.1, zz.1), rfl⟩ +
    of (λ i, grading R i) 1 ⟨(0, zz.2 - zz.1), rfl⟩,
  map_zero' := by { ext1 (_|⟨⟨⟩⟩); refl },
  map_add' := begin
    rintros ⟨a1, b1⟩ ⟨a2, b2⟩,
    have H : b1 + b2 - (a1 + a2) = b1 - a1 + (b2 - a2), by abel,
    ext (_|⟨⟨⟩⟩) : 3;
    simp only [prod.fst_add, prod.snd_add, add_apply, submodule.coe_add, prod.mk_add_mk, H];
    repeat { erw of_eq_same }; repeat { erw of_eq_of_ne }; try { apply option.no_confusion };
    dsimp; simp only [zero_add, add_zero]; refl,
  end }

lemma grading.left_inv :
  function.left_inverse grading.decompose (coe_linear_map (grading R)) := λ zz,
begin
  induction zz using direct_sum.induction_on with i zz d1 d2 ih1 ih2,
  { simp only [map_zero],},
  { rcases i with (_|⟨⟨⟩⟩); rcases zz with ⟨⟨a, b⟩, (hab : _ = _)⟩;
    dsimp at hab; cases hab; dec_trivial! },
  { simp only [map_add, ih1, ih2], },
end

lemma grading.right_inv :
  function.right_inverse grading.decompose (coe_linear_map (grading R)) := λ zz,
begin
  cases zz with a b,
  unfold grading.decompose,
  simp only [add_monoid_hom.coe_mk, map_add, coe_linear_map_of, subtype.coe_mk, prod.mk_add_mk,
    add_zero, add_sub_cancel'_right],
end

instance : graded_algebra (grading R) :=
{ one_mem := grading.one_mem R,
  mul_mem := grading.mul_mem R,
  decompose' := grading.decompose,
  left_inv := by { convert grading.left_inv, },
  right_inv := by { convert grading.right_inv, } }

/-- The counterexample is the ideal `I = span {(2, 2)}`. -/
def I : ideal (R × R) := ideal.span {((2, 2) : (R × R))}.

lemma I_not_prime : ¬ I.is_prime :=
begin
  rintro ⟨rid1, rid2⟩,
  apply rid1, clear rid1, revert rid2,
  simp only [I, ideal.mem_span_singleton, ideal.eq_top_iff_one],
  dec_trivial,
end

lemma I_is_homogeneous : I.is_homogeneous (grading R) :=
begin
  rw ideal.is_homogeneous.iff_exists,
  refine ⟨{⟨(2, 2), ⟨0, rfl⟩⟩}, _⟩,
  rw set.image_singleton,
  refl,
end

lemma homogeneous_mem_or_mem {x y : (R × R)} (hx : set_like.is_homogeneous (grading R) x)
  (hy : set_like.is_homogeneous (grading R) y)
  (hxy : x * y ∈ I) : x ∈ I ∨ y ∈ I :=
begin
  simp only [I, ideal.mem_span_singleton] at hxy ⊢,
  cases x, cases y,
  obtain ⟨(_|⟨⟨⟩⟩), hx : _ = _⟩ := hx;
  obtain ⟨(_|⟨⟨⟩⟩), hy : _ = _⟩ := hy;
  dsimp at hx hy;
  cases hx; cases hy; clear hx hy;
  dec_trivial!,
end

end counterexample_not_prime_but_homogeneous_prime


<|start_filename|>src/measure_theory/integral/interval_average.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.convex.integral
import measure_theory.integral.interval_integral

/-!
# Integral average over an interval

In this file we introduce notation `⨍ x in a..b, f x` for the average `⨍ x in Ι a b, f x` of `f`
over the interval `Ι a b = set.Ioc (min a b) (max a b)` w.r.t. the Lebesgue measure, then prove
formulas for this average:

* `interval_average_eq`: `⨍ x in a..b, f x = (b - a)⁻¹ • ∫ x in a..b, f x`;
* `interval_average_eq_div`: `⨍ x in a..b, f x = (∫ x in a..b, f x) / (b - a)`.

We also prove that `⨍ x in a..b, f x = ⨍ x in b..a, f x`, see `interval_average_symm`.

## Notation

`⨍ x in a..b, f x`: average of `f` over the interval `Ι a b` w.r.t. the Lebesgue measure.

-/

open measure_theory set topological_space
open_locale interval

variables {E : Type*} [normed_group E] [normed_space ℝ E] [complete_space E]

notation `⨍` binders ` in ` a `..` b `, `
  r:(scoped:60 f, average (measure.restrict volume (Ι a b)) f) := r

lemma interval_average_symm (f : ℝ → E) (a b : ℝ) : ⨍ x in a..b, f x = ⨍ x in b..a, f x :=
by rw [set_average_eq, set_average_eq, interval_oc_swap]

lemma interval_average_eq (f : ℝ → E) (a b : ℝ) : ⨍ x in a..b, f x = (b - a)⁻¹ • ∫ x in a..b, f x :=
begin
  cases le_or_lt a b with h h,
  { rw [set_average_eq, interval_oc_of_le h, real.volume_Ioc, interval_integral.integral_of_le h,
      ennreal.to_real_of_real (sub_nonneg.2 h)] },
  { rw [set_average_eq, interval_oc_of_lt h, real.volume_Ioc, interval_integral.integral_of_ge h.le,
     ennreal.to_real_of_real (sub_nonneg.2 h.le), smul_neg, ← neg_smul, ← inv_neg, neg_sub] }
end

lemma interval_average_eq_div (f : ℝ → ℝ) (a b : ℝ) :
  ⨍ x in a..b, f x = (∫ x in a..b, f x) / (b - a) :=
by rw [interval_average_eq, smul_eq_mul, div_eq_inv_mul]


<|start_filename|>src/order/filter/pi.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import order.filter.bases

/-!
# (Co)product of a family of filters

In this file we define two filters on `Π i, α i` and prove some basic properties of these filters.

* `filter.pi (f : Π i, filter (α i))` to be the maximal filter on `Π i, α i` such that
  `∀ i, filter.tendsto (function.eval i) (filter.pi f) (f i)`. It is defined as
  `Π i, filter.comap (function.eval i) (f i)`. This is a generalization of `filter.prod` to indexed
  products.

* `filter.Coprod (f : Π i, filter (α i))`: a generalization of `filter.coprod`; it is the supremum
  of `comap (eval i) (f i)`.
-/

open set function
open_locale classical filter

namespace filter

variables {ι : Type*} {α : ι → Type*} {f f₁ f₂ : Π i, filter (α i)} {s : Π i, set (α i)}

section pi

/-- The product of an indexed family of filters. -/
def pi (f : Π i, filter (α i)) : filter (Π i, α i) := ⨅ i, comap (eval i) (f i)

lemma tendsto_eval_pi (f : Π i, filter (α i)) (i : ι) :
  tendsto (eval i) (pi f) (f i) :=
tendsto_infi' i tendsto_comap

lemma tendsto_pi {β : Type*} {m : β → Π i, α i} {l : filter β} :
  tendsto m l (pi f) ↔ ∀ i, tendsto (λ x, m x i) l (f i) :=
by simp only [pi, tendsto_infi, tendsto_comap_iff]

lemma le_pi {g : filter (Π i, α i)} : g ≤ pi f ↔ ∀ i, tendsto (eval i) g (f i) := tendsto_pi

@[mono] lemma pi_mono (h : ∀ i, f₁ i ≤ f₂ i) : pi f₁ ≤ pi f₂ := infi_mono $ λ i, comap_mono $ h i

lemma mem_pi_of_mem (i : ι) {s : set (α i)} (hs : s ∈ f i) :
  eval i ⁻¹' s ∈ pi f :=
mem_infi_of_mem i $ preimage_mem_comap hs

lemma pi_mem_pi {I : set ι} (hI : I.finite) (h : ∀ i ∈ I, s i ∈ f i) :
  I.pi s ∈ pi f :=
begin
  rw [pi_def, bInter_eq_Inter],
  refine mem_infi_of_Inter hI (λ i, _) subset.rfl,
  exact preimage_mem_comap (h i i.2)
end

lemma mem_pi {s : set (Π i, α i)} : s ∈ pi f ↔
  ∃ (I : set ι), I.finite ∧ ∃ t : Π i, set (α i), (∀ i, t i ∈ f i) ∧ I.pi t ⊆ s :=
begin
  split,
  { simp only [pi, mem_infi', mem_comap, pi_def],
    rintro ⟨I, If, V, hVf, hVI, rfl, -⟩, choose t htf htV using hVf,
    exact ⟨I, If, t, htf, Inter₂_mono (λ i _, htV i)⟩ },
  { rintro ⟨I, If, t, htf, hts⟩,
    exact mem_of_superset (pi_mem_pi If $ λ i _, htf i) hts }
end

lemma mem_pi' {s : set (Π i, α i)} : s ∈ pi f ↔
  ∃ (I : finset ι), ∃ t : Π i, set (α i), (∀ i, t i ∈ f i) ∧ set.pi ↑I t ⊆ s :=
mem_pi.trans exists_finite_iff_finset

lemma mem_of_pi_mem_pi [∀ i, ne_bot (f i)] {I : set ι} (h : I.pi s ∈ pi f) {i : ι} (hi : i ∈ I) :
  s i ∈ f i :=
begin
  rcases mem_pi.1 h with ⟨I', I'f, t, htf, hts⟩,
  refine mem_of_superset (htf i) (λ x hx, _),
  have : ∀ i, (t i).nonempty, from λ i, nonempty_of_mem (htf i),
  choose g hg,
  have : update g i x ∈ I'.pi t,
  { intros j hj, rcases eq_or_ne j i with (rfl|hne); simp * },
  simpa using hts this i hi
end

@[simp] lemma pi_mem_pi_iff [∀ i, ne_bot (f i)] {I : set ι} (hI : I.finite) :
  I.pi s ∈ pi f ↔ ∀ i ∈ I, s i ∈ f i :=
⟨λ h i hi, mem_of_pi_mem_pi h hi, pi_mem_pi hI⟩

lemma has_basis_pi {ι' : ι → Type} {s : Π i, ι' i → set (α i)} {p : Π i, ι' i → Prop}
  (h : ∀ i, (f i).has_basis (p i) (s i)) :
  (pi f).has_basis (λ If : set ι × Π i, ι' i, If.1.finite ∧ ∀ i ∈ If.1, p i (If.2 i))
    (λ If : set ι × Π i, ι' i, If.1.pi (λ i, s i $ If.2 i)) :=
begin
  have : (pi f).has_basis _ _ := has_basis_infi (λ i, (h i).comap (eval i : (Π j, α j) → α i)),
  convert this,
  ext,
  simp
end

@[simp] lemma pi_inf_principal_univ_pi_eq_bot :
  pi f ⊓ 𝓟 (set.pi univ s) = ⊥ ↔ ∃ i, f i ⊓ 𝓟 (s i) = ⊥ :=
begin
  split,
  { simp only [inf_principal_eq_bot, mem_pi], contrapose!,
    rintros (hsf : ∀ i, ∃ᶠ x in f i, x ∈ s i) I If t htf hts,
    have : ∀ i, (s i ∩ t i).nonempty, from λ i, ((hsf i).and_eventually (htf i)).exists,
    choose x hxs hxt,
    exact hts (λ i hi, hxt i) (mem_univ_pi.2 hxs) },
  { simp only [inf_principal_eq_bot],
    rintro ⟨i, hi⟩,
    filter_upwards [mem_pi_of_mem i hi] with x using mt (λ h, h i trivial), },
end

@[simp] lemma pi_inf_principal_pi_eq_bot [Π i, ne_bot (f i)] {I : set ι} :
  pi f ⊓ 𝓟 (set.pi I s) = ⊥ ↔ ∃ i ∈ I, f i ⊓ 𝓟 (s i) = ⊥ :=
begin
  rw [← univ_pi_piecewise I, pi_inf_principal_univ_pi_eq_bot],
  refine exists_congr (λ i, _),
  by_cases hi : i ∈ I; simp [hi, (‹Π i, ne_bot (f i)› i).ne]
end

@[simp] lemma pi_inf_principal_univ_pi_ne_bot :
  ne_bot (pi f ⊓ 𝓟 (set.pi univ s)) ↔ ∀ i, ne_bot (f i ⊓ 𝓟 (s i)) :=
by simp [ne_bot_iff]

@[simp] lemma pi_inf_principal_pi_ne_bot [Π i, ne_bot (f i)] {I : set ι} :
  ne_bot (pi f ⊓ 𝓟 (I.pi s)) ↔ ∀ i ∈ I, ne_bot (f i ⊓ 𝓟 (s i)) :=
by simp [ne_bot_iff]

instance pi_inf_principal_pi.ne_bot [h : ∀ i, ne_bot (f i ⊓ 𝓟 (s i))] {I : set ι} :
  ne_bot (pi f ⊓ 𝓟 (I.pi s)) :=
(pi_inf_principal_univ_pi_ne_bot.2 ‹_›).mono $ inf_le_inf_left _ $ principal_mono.2 $
  λ x hx i hi, hx i trivial

@[simp] lemma pi_eq_bot : pi f = ⊥ ↔ ∃ i, f i = ⊥ :=
by simpa using @pi_inf_principal_univ_pi_eq_bot ι α f (λ _, univ)

@[simp] lemma pi_ne_bot : ne_bot (pi f) ↔ ∀ i, ne_bot (f i) := by simp [ne_bot_iff]

instance [∀ i, ne_bot (f i)] : ne_bot (pi f) := pi_ne_bot.2 ‹_›

end pi

/-! ### `n`-ary coproducts of filters -/

section Coprod

/-- Coproduct of filters. -/
protected def Coprod (f : Π i, filter (α i)) : filter (Π i, α i) :=
⨆ i : ι, comap (eval i) (f i)

lemma mem_Coprod_iff {s : set (Π i, α i)} :
  (s ∈ filter.Coprod f) ↔ (∀ i : ι, (∃ t₁ ∈ f i, eval i ⁻¹' t₁ ⊆ s)) :=
by simp [filter.Coprod]

lemma compl_mem_Coprod {s : set (Π i, α i)} :
  sᶜ ∈ filter.Coprod f ↔ ∀ i, (eval i '' s)ᶜ ∈ f i :=
by simp only [filter.Coprod, mem_supr, compl_mem_comap]

lemma Coprod_ne_bot_iff' :
  ne_bot (filter.Coprod f) ↔ (∀ i, nonempty (α i)) ∧ ∃ d, ne_bot (f d) :=
by simp only [filter.Coprod, supr_ne_bot, ← exists_and_distrib_left, ← comap_eval_ne_bot_iff']

@[simp] lemma Coprod_ne_bot_iff [∀ i, nonempty (α i)] :
  ne_bot (filter.Coprod f) ↔ ∃ d, ne_bot (f d) :=
by simp [Coprod_ne_bot_iff', *]

lemma Coprod_eq_bot_iff' : filter.Coprod f = ⊥ ↔ (∃ i, is_empty (α i)) ∨ f = ⊥ :=
by simpa [not_and_distrib, funext_iff] using not_congr Coprod_ne_bot_iff'

@[simp] lemma Coprod_eq_bot_iff [∀ i, nonempty (α i)] : filter.Coprod f = ⊥ ↔ f = ⊥ :=
by simpa [funext_iff] using not_congr Coprod_ne_bot_iff

@[simp] lemma Coprod_bot' : filter.Coprod (⊥ : Π i, filter (α i)) = ⊥ :=
Coprod_eq_bot_iff'.2 (or.inr rfl)

@[simp] lemma Coprod_bot : filter.Coprod (λ _, ⊥ : Π i, filter (α i)) = ⊥ := Coprod_bot'

lemma ne_bot.Coprod [∀ i, nonempty (α i)] {i : ι} (h : ne_bot (f i)) :
  ne_bot (filter.Coprod f) :=
Coprod_ne_bot_iff.2 ⟨i, h⟩

@[instance] lemma Coprod_ne_bot [∀ i, nonempty (α i)] [nonempty ι] (f : Π i, filter (α i))
  [H : ∀ i, ne_bot (f i)] : ne_bot (filter.Coprod f) :=
(H (classical.arbitrary ι)).Coprod

@[mono] lemma Coprod_mono (hf : ∀ i, f₁ i ≤ f₂ i) : filter.Coprod f₁ ≤ filter.Coprod f₂ :=
supr_mono $ λ i, comap_mono (hf i)

variables {β : ι → Type*} {m : Π i, α i → β i}

lemma map_pi_map_Coprod_le :
  map (λ (k : Π i, α i), λ i, m i (k i)) (filter.Coprod f) ≤ filter.Coprod (λ i, map (m i) (f i)) :=
begin
  simp only [le_def, mem_map, mem_Coprod_iff],
  intros s h i,
  obtain ⟨t, H, hH⟩ := h i,
  exact ⟨{x : α i | m i x ∈ t}, H, λ x hx, hH hx⟩
end

lemma tendsto.pi_map_Coprod {g : Π i, filter (β i)} (h : ∀ i, tendsto (m i) (f i) (g i)) :
  tendsto (λ (k : Π i, α i), λ i, m i (k i)) (filter.Coprod f) (filter.Coprod g) :=
map_pi_map_Coprod_le.trans (Coprod_mono h)

end Coprod

end filter


<|start_filename|>src/linear_algebra/matrix/bilinear_form.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import linear_algebra.matrix.basis
import linear_algebra.matrix.nondegenerate
import linear_algebra.matrix.nonsingular_inverse
import linear_algebra.matrix.to_linear_equiv
import linear_algebra.bilinear_form

/-!
# Bilinear form

This file defines the conversion between bilinear forms and matrices.

## Main definitions

 * `matrix.to_bilin` given a basis define a bilinear form
 * `matrix.to_bilin'` define the bilinear form on `n → R`
 * `bilin_form.to_matrix`: calculate the matrix coefficients of a bilinear form
 * `bilin_form.to_matrix'`: calculate the matrix coefficients of a bilinear form on `n → R`

## Notations

In this file we use the following type variables:
 - `M`, `M'`, ... are modules over the semiring `R`,
 - `M₁`, `M₁'`, ... are modules over the ring `R₁`,
 - `M₂`, `M₂'`, ... are modules over the commutative semiring `R₂`,
 - `M₃`, `M₃'`, ... are modules over the commutative ring `R₃`,
 - `V`, ... is a vector space over the field `K`.

## Tags

bilinear_form, matrix, basis

-/

variables {R : Type*} {M : Type*} [semiring R] [add_comm_monoid M] [module R M]
variables {R₁ : Type*} {M₁ : Type*} [ring R₁] [add_comm_group M₁] [module R₁ M₁]
variables {R₂ : Type*} {M₂ : Type*} [comm_semiring R₂] [add_comm_monoid M₂] [module R₂ M₂]
variables {R₃ : Type*} {M₃ : Type*} [comm_ring R₃] [add_comm_group M₃] [module R₃ M₃]
variables {V : Type*} {K : Type*} [field K] [add_comm_group V] [module K V]
variables {B : bilin_form R M} {B₁ : bilin_form R₁ M₁} {B₂ : bilin_form R₂ M₂}

section matrix
variables {n o : Type*}

open_locale big_operators
open bilin_form finset linear_map matrix
open_locale matrix

/-- The map from `matrix n n R` to bilinear forms on `n → R`.

This is an auxiliary definition for the equivalence `matrix.to_bilin_form'`. -/
def matrix.to_bilin'_aux [fintype n] (M : matrix n n R₂) : bilin_form R₂ (n → R₂) :=
{ bilin := λ v w, ∑ i j, v i * M i j * w j,
  bilin_add_left := λ x y z, by simp only [pi.add_apply, add_mul, sum_add_distrib],
  bilin_smul_left := λ a x y, by simp only [pi.smul_apply, smul_eq_mul, mul_assoc, mul_sum],
  bilin_add_right := λ x y z, by simp only [pi.add_apply, mul_add, sum_add_distrib],
  bilin_smul_right := λ a x y,
    by simp only [pi.smul_apply, smul_eq_mul, mul_assoc, mul_left_comm, mul_sum] }

lemma matrix.to_bilin'_aux_std_basis [fintype n] [decidable_eq n] (M : matrix n n R₂)
  (i j : n) : M.to_bilin'_aux (std_basis R₂ (λ _, R₂) i 1) (std_basis R₂ (λ _, R₂) j 1) = M i j :=
begin
  rw [matrix.to_bilin'_aux, coe_fn_mk, sum_eq_single i, sum_eq_single j],
  { simp only [std_basis_same, std_basis_same, one_mul, mul_one] },
  { rintros j' - hj',
    apply mul_eq_zero_of_right,
    exact std_basis_ne R₂ (λ _, R₂) _ _ hj' 1 },
  { intros,
    have := finset.mem_univ j,
    contradiction },
  { rintros i' - hi',
    refine finset.sum_eq_zero (λ j _, _),
    apply mul_eq_zero_of_left,
    apply mul_eq_zero_of_left,
    exact std_basis_ne R₂ (λ _, R₂) _ _ hi' 1 },
  { intros,
    have := finset.mem_univ i,
    contradiction }
end

/-- The linear map from bilinear forms to `matrix n n R` given an `n`-indexed basis.

This is an auxiliary definition for the equivalence `matrix.to_bilin_form'`. -/
def bilin_form.to_matrix_aux (b : n → M₂) : bilin_form R₂ M₂ →ₗ[R₂] matrix n n R₂ :=
{ to_fun := λ B i j, B (b i) (b j),
  map_add' := λ f g, rfl,
  map_smul' := λ f g, rfl }

variables [fintype n] [fintype o]

lemma to_bilin'_aux_to_matrix_aux [decidable_eq n] (B₂ : bilin_form R₂ (n → R₂)) :
  matrix.to_bilin'_aux (bilin_form.to_matrix_aux (λ j, std_basis R₂ (λ _, R₂) j 1) B₂) = B₂ :=
begin
  refine ext_basis (pi.basis_fun R₂ n) (λ i j, _),
  rw [bilin_form.to_matrix_aux, linear_map.coe_mk, pi.basis_fun_apply, pi.basis_fun_apply,
      matrix.to_bilin'_aux_std_basis]
end

section to_matrix'

/-! ### `to_matrix'` section

This section deals with the conversion between matrices and bilinear forms on `n → R₂`.
-/

variables [decidable_eq n] [decidable_eq o]

/-- The linear equivalence between bilinear forms on `n → R` and `n × n` matrices -/
def bilin_form.to_matrix' : bilin_form R₂ (n → R₂) ≃ₗ[R₂] matrix n n R₂ :=
{ inv_fun := matrix.to_bilin'_aux,
  left_inv := by convert to_bilin'_aux_to_matrix_aux,
  right_inv := λ M,
    by { ext i j, simp only [bilin_form.to_matrix_aux, matrix.to_bilin'_aux_std_basis] },
  ..bilin_form.to_matrix_aux (λ j, std_basis R₂ (λ _, R₂) j 1) }

@[simp] lemma bilin_form.to_matrix_aux_std_basis (B : bilin_form R₂ (n → R₂)) :
  bilin_form.to_matrix_aux (λ j, std_basis R₂ (λ _, R₂) j 1) B =
    bilin_form.to_matrix' B :=
rfl

/-- The linear equivalence between `n × n` matrices and bilinear forms on `n → R` -/
def matrix.to_bilin' : matrix n n R₂ ≃ₗ[R₂] bilin_form R₂ (n → R₂) :=
bilin_form.to_matrix'.symm

@[simp] lemma matrix.to_bilin'_aux_eq (M : matrix n n R₂) :
  matrix.to_bilin'_aux M = matrix.to_bilin' M :=
rfl

lemma matrix.to_bilin'_apply (M : matrix n n R₂) (x y : n → R₂) :
  matrix.to_bilin' M x y = ∑ i j, x i * M i j * y j := rfl

lemma matrix.to_bilin'_apply' (M : matrix n n R₂) (v w : n → R₂) :
  matrix.to_bilin' M v w = matrix.dot_product v (M.mul_vec w) :=
begin
  simp_rw [matrix.to_bilin'_apply, matrix.dot_product,
           matrix.mul_vec, matrix.dot_product],
  refine finset.sum_congr rfl (λ _ _, _),
  rw finset.mul_sum,
  refine finset.sum_congr rfl (λ _ _, _),
  rw ← mul_assoc,
end

@[simp] lemma matrix.to_bilin'_std_basis (M : matrix n n R₂) (i j : n) :
  matrix.to_bilin' M (std_basis R₂ (λ _, R₂) i 1) (std_basis R₂ (λ _, R₂) j 1) =
    M i j :=
matrix.to_bilin'_aux_std_basis M i j

@[simp] lemma bilin_form.to_matrix'_symm :
  (bilin_form.to_matrix'.symm : matrix n n R₂ ≃ₗ[R₂] _) = matrix.to_bilin' :=
rfl

@[simp] lemma matrix.to_bilin'_symm :
  (matrix.to_bilin'.symm : _ ≃ₗ[R₂] matrix n n R₂) = bilin_form.to_matrix' :=
bilin_form.to_matrix'.symm_symm

@[simp] lemma matrix.to_bilin'_to_matrix' (B : bilin_form R₂ (n → R₂)) :
  matrix.to_bilin' (bilin_form.to_matrix' B) = B :=
matrix.to_bilin'.apply_symm_apply B

@[simp] lemma bilin_form.to_matrix'_to_bilin' (M : matrix n n R₂) :
  bilin_form.to_matrix' (matrix.to_bilin' M) = M :=
bilin_form.to_matrix'.apply_symm_apply M

@[simp] lemma bilin_form.to_matrix'_apply (B : bilin_form R₂ (n → R₂)) (i j : n) :
  bilin_form.to_matrix' B i j =
    B (std_basis R₂ (λ _, R₂) i 1) (std_basis R₂ (λ _, R₂) j 1) :=
rfl

@[simp] lemma bilin_form.to_matrix'_comp (B : bilin_form R₂ (n → R₂))
  (l r : (o → R₂) →ₗ[R₂] (n → R₂)) :
  (B.comp l r).to_matrix' = l.to_matrix'ᵀ ⬝ B.to_matrix' ⬝ r.to_matrix' :=
begin
  ext i j,
  simp only [bilin_form.to_matrix'_apply, bilin_form.comp_apply, transpose_apply, matrix.mul_apply,
    linear_map.to_matrix', linear_equiv.coe_mk, sum_mul],
  rw sum_comm,
  conv_lhs { rw ← bilin_form.sum_repr_mul_repr_mul (pi.basis_fun R₂ n) (l _) (r _) },
  rw finsupp.sum_fintype,
  { apply sum_congr rfl,
    rintros i' -,
    rw finsupp.sum_fintype,
    { apply sum_congr rfl,
      rintros j' -,
      simp only [smul_eq_mul, pi.basis_fun_repr, mul_assoc, mul_comm, mul_left_comm,
                 pi.basis_fun_apply] },
    { intros, simp only [zero_smul, smul_zero] } },
  { intros, simp only [zero_smul, finsupp.sum_zero] }
end

lemma bilin_form.to_matrix'_comp_left (B : bilin_form R₂ (n → R₂))
  (f : (n → R₂) →ₗ[R₂] (n → R₂)) : (B.comp_left f).to_matrix' = f.to_matrix'ᵀ ⬝ B.to_matrix' :=
by simp only [bilin_form.comp_left, bilin_form.to_matrix'_comp, to_matrix'_id, matrix.mul_one]

lemma bilin_form.to_matrix'_comp_right (B : bilin_form R₂ (n → R₂))
  (f : (n → R₂) →ₗ[R₂] (n → R₂)) : (B.comp_right f).to_matrix' = B.to_matrix' ⬝ f.to_matrix' :=
by simp only [bilin_form.comp_right, bilin_form.to_matrix'_comp, to_matrix'_id,
              transpose_one, matrix.one_mul]

lemma bilin_form.mul_to_matrix'_mul (B : bilin_form R₂ (n → R₂))
  (M : matrix o n R₂) (N : matrix n o R₂) :
  M ⬝ B.to_matrix' ⬝ N = (B.comp Mᵀ.to_lin' N.to_lin').to_matrix' :=
by simp only [B.to_matrix'_comp, transpose_transpose, to_matrix'_to_lin']

lemma bilin_form.mul_to_matrix' (B : bilin_form R₂ (n → R₂)) (M : matrix n n R₂) :
  M ⬝ B.to_matrix' = (B.comp_left Mᵀ.to_lin').to_matrix' :=
by simp only [B.to_matrix'_comp_left, transpose_transpose, to_matrix'_to_lin']

lemma bilin_form.to_matrix'_mul (B : bilin_form R₂ (n → R₂)) (M : matrix n n R₂) :
  B.to_matrix' ⬝ M = (B.comp_right M.to_lin').to_matrix' :=
by simp only [B.to_matrix'_comp_right, to_matrix'_to_lin']

lemma matrix.to_bilin'_comp (M : matrix n n R₂) (P Q : matrix n o R₂) :
  M.to_bilin'.comp P.to_lin' Q.to_lin' = (Pᵀ ⬝ M ⬝ Q).to_bilin' :=
bilin_form.to_matrix'.injective
  (by simp only [bilin_form.to_matrix'_comp, bilin_form.to_matrix'_to_bilin', to_matrix'_to_lin'])

end to_matrix'

section to_matrix

/-! ### `to_matrix` section

This section deals with the conversion between matrices and bilinear forms on
a module with a fixed basis.
-/

variables [decidable_eq n] (b : basis n R₂ M₂)

/-- `bilin_form.to_matrix b` is the equivalence between `R`-bilinear forms on `M` and
`n`-by-`n` matrices with entries in `R`, if `b` is an `R`-basis for `M`. -/
noncomputable def bilin_form.to_matrix : bilin_form R₂ M₂ ≃ₗ[R₂] matrix n n R₂ :=
(bilin_form.congr b.equiv_fun).trans bilin_form.to_matrix'

/-- `bilin_form.to_matrix b` is the equivalence between `R`-bilinear forms on `M` and
`n`-by-`n` matrices with entries in `R`, if `b` is an `R`-basis for `M`. -/
noncomputable def matrix.to_bilin : matrix n n R₂ ≃ₗ[R₂] bilin_form R₂ M₂ :=
(bilin_form.to_matrix b).symm

@[simp] lemma basis.equiv_fun_symm_std_basis (i : n) :
  b.equiv_fun.symm (std_basis R₂ (λ _, R₂) i 1) = b i :=
begin
  rw [b.equiv_fun_symm_apply, finset.sum_eq_single i],
  { rw [std_basis_same, one_smul] },
  { rintros j - hj,
    rw [std_basis_ne _ _ _ _ hj, zero_smul] },
  { intro,
    have := mem_univ i,
    contradiction }
end

@[simp] lemma bilin_form.to_matrix_apply (B : bilin_form R₂ M₂) (i j : n) :
  bilin_form.to_matrix b B i j = B (b i) (b j) :=
by rw [bilin_form.to_matrix, linear_equiv.trans_apply, bilin_form.to_matrix'_apply, congr_apply,
       b.equiv_fun_symm_std_basis, b.equiv_fun_symm_std_basis]

@[simp] lemma matrix.to_bilin_apply (M : matrix n n R₂) (x y : M₂) :
  matrix.to_bilin b M x y = ∑ i j, b.repr x i * M i j * b.repr y j :=
begin
  rw [matrix.to_bilin, bilin_form.to_matrix, linear_equiv.symm_trans_apply, ← matrix.to_bilin'],
  simp only [congr_symm, congr_apply, linear_equiv.symm_symm, matrix.to_bilin'_apply,
    basis.equiv_fun_apply]
end

-- Not a `simp` lemma since `bilin_form.to_matrix` needs an extra argument
lemma bilinear_form.to_matrix_aux_eq (B : bilin_form R₂ M₂) :
  bilin_form.to_matrix_aux b B = bilin_form.to_matrix b B :=
ext (λ i j, by rw [bilin_form.to_matrix_apply, bilin_form.to_matrix_aux, linear_map.coe_mk])

@[simp] lemma bilin_form.to_matrix_symm :
  (bilin_form.to_matrix b).symm = matrix.to_bilin b :=
rfl

@[simp] lemma matrix.to_bilin_symm :
  (matrix.to_bilin b).symm = bilin_form.to_matrix b :=
(bilin_form.to_matrix b).symm_symm

lemma matrix.to_bilin_basis_fun :
  matrix.to_bilin (pi.basis_fun R₂ n) = matrix.to_bilin' :=
by { ext M, simp only [matrix.to_bilin_apply, matrix.to_bilin'_apply, pi.basis_fun_repr] }

lemma bilin_form.to_matrix_basis_fun :
  bilin_form.to_matrix (pi.basis_fun R₂ n) = bilin_form.to_matrix' :=
by { ext B, rw [bilin_form.to_matrix_apply, bilin_form.to_matrix'_apply,
                pi.basis_fun_apply, pi.basis_fun_apply] }

@[simp] lemma matrix.to_bilin_to_matrix (B : bilin_form R₂ M₂) :
  matrix.to_bilin b (bilin_form.to_matrix b B) = B :=
(matrix.to_bilin b).apply_symm_apply B

@[simp] lemma bilin_form.to_matrix_to_bilin (M : matrix n n R₂) :
  bilin_form.to_matrix b (matrix.to_bilin b M) = M :=
(bilin_form.to_matrix b).apply_symm_apply M

variables {M₂' : Type*} [add_comm_monoid M₂'] [module R₂ M₂']
variables (c : basis o R₂ M₂')
variables [decidable_eq o]

-- Cannot be a `simp` lemma because `b` must be inferred.
lemma bilin_form.to_matrix_comp
  (B : bilin_form R₂ M₂) (l r : M₂' →ₗ[R₂] M₂) :
  bilin_form.to_matrix c (B.comp l r) =
    (to_matrix c b l)ᵀ ⬝ bilin_form.to_matrix b B ⬝ to_matrix c b r :=
begin
  ext i j,
  simp only [bilin_form.to_matrix_apply, bilin_form.comp_apply, transpose_apply, matrix.mul_apply,
    linear_map.to_matrix', linear_equiv.coe_mk, sum_mul],
  rw sum_comm,
  conv_lhs { rw ← bilin_form.sum_repr_mul_repr_mul b },
  rw finsupp.sum_fintype,
  { apply sum_congr rfl,
    rintros i' -,
    rw finsupp.sum_fintype,
    { apply sum_congr rfl,
      rintros j' -,
      simp only [smul_eq_mul, linear_map.to_matrix_apply,
        basis.equiv_fun_apply, mul_assoc, mul_comm, mul_left_comm] },
    { intros, simp only [zero_smul, smul_zero] } },
  { intros, simp only [zero_smul, finsupp.sum_zero] }
end

lemma bilin_form.to_matrix_comp_left (B : bilin_form R₂ M₂) (f : M₂ →ₗ[R₂] M₂) :
  bilin_form.to_matrix b (B.comp_left f) = (to_matrix b b f)ᵀ ⬝ bilin_form.to_matrix b B :=
by simp only [comp_left, bilin_form.to_matrix_comp b b, to_matrix_id, matrix.mul_one]

lemma bilin_form.to_matrix_comp_right (B : bilin_form R₂ M₂) (f : M₂ →ₗ[R₂] M₂) :
  bilin_form.to_matrix b (B.comp_right f) = bilin_form.to_matrix b B ⬝ (to_matrix b b f) :=
by simp only [bilin_form.comp_right, bilin_form.to_matrix_comp b b, to_matrix_id,
              transpose_one, matrix.one_mul]

@[simp]
lemma bilin_form.to_matrix_mul_basis_to_matrix (c : basis o R₂ M₂) (B : bilin_form R₂ M₂) :
  (b.to_matrix c)ᵀ ⬝ bilin_form.to_matrix b B ⬝ b.to_matrix c = bilin_form.to_matrix c B :=
by rw [← linear_map.to_matrix_id_eq_basis_to_matrix, ← bilin_form.to_matrix_comp,
       bilin_form.comp_id_id]

lemma bilin_form.mul_to_matrix_mul (B : bilin_form R₂ M₂)
  (M : matrix o n R₂) (N : matrix n o R₂) :
  M ⬝ bilin_form.to_matrix b B ⬝ N =
    bilin_form.to_matrix c (B.comp (to_lin c b Mᵀ) (to_lin c b N)) :=
by simp only [B.to_matrix_comp b c, to_matrix_to_lin, transpose_transpose]

lemma bilin_form.mul_to_matrix (B : bilin_form R₂ M₂) (M : matrix n n R₂) :
  M ⬝ bilin_form.to_matrix b B =
    bilin_form.to_matrix b (B.comp_left (to_lin b b Mᵀ)) :=
by rw [B.to_matrix_comp_left b, to_matrix_to_lin, transpose_transpose]

lemma bilin_form.to_matrix_mul (B : bilin_form R₂ M₂) (M : matrix n n R₂) :
  bilin_form.to_matrix b B ⬝ M =
    bilin_form.to_matrix b (B.comp_right (to_lin b b M)) :=
by rw [B.to_matrix_comp_right b, to_matrix_to_lin]

lemma matrix.to_bilin_comp (M : matrix n n R₂) (P Q : matrix n o R₂) :
  (matrix.to_bilin b M).comp (to_lin c b P) (to_lin c b Q) = matrix.to_bilin c (Pᵀ ⬝ M ⬝ Q) :=
(bilin_form.to_matrix c).injective
  (by simp only [bilin_form.to_matrix_comp b c, bilin_form.to_matrix_to_bilin, to_matrix_to_lin])

end to_matrix

end matrix
section matrix_adjoints
open_locale matrix

variables {n : Type*} [fintype n]
variables (b : basis n R₃ M₃)
variables (J J₃ A A' : matrix n n R₃)

/-- The condition for the square matrices `A`, `A'` to be an adjoint pair with respect to the square
matrices `J`, `J₃`. -/
def matrix.is_adjoint_pair := Aᵀ ⬝ J₃ = J ⬝ A'

/-- The condition for a square matrix `A` to be self-adjoint with respect to the square matrix
`J`. -/
def matrix.is_self_adjoint := matrix.is_adjoint_pair J J A A

/-- The condition for a square matrix `A` to be skew-adjoint with respect to the square matrix
`J`. -/
def matrix.is_skew_adjoint := matrix.is_adjoint_pair J J A (-A)

@[simp] lemma is_adjoint_pair_to_bilin' [decidable_eq n] :
  bilin_form.is_adjoint_pair (matrix.to_bilin' J) (matrix.to_bilin' J₃)
      (matrix.to_lin' A) (matrix.to_lin' A') ↔
    matrix.is_adjoint_pair J J₃ A A' :=
begin
  rw bilin_form.is_adjoint_pair_iff_comp_left_eq_comp_right,
  have h : ∀ (B B' : bilin_form R₃ (n → R₃)), B = B' ↔
    (bilin_form.to_matrix' B) = (bilin_form.to_matrix' B'),
  { intros B B',
    split; intros h,
    { rw h },
    { exact bilin_form.to_matrix'.injective h } },
  rw [h, bilin_form.to_matrix'_comp_left, bilin_form.to_matrix'_comp_right,
      linear_map.to_matrix'_to_lin', linear_map.to_matrix'_to_lin',
      bilin_form.to_matrix'_to_bilin', bilin_form.to_matrix'_to_bilin'],
  refl,
end

@[simp] lemma is_adjoint_pair_to_bilin [decidable_eq n] :
  bilin_form.is_adjoint_pair (matrix.to_bilin b J) (matrix.to_bilin b J₃)
      (matrix.to_lin b b A) (matrix.to_lin b b A') ↔
    matrix.is_adjoint_pair J J₃ A A' :=
begin
  rw bilin_form.is_adjoint_pair_iff_comp_left_eq_comp_right,
  have h : ∀ (B B' : bilin_form R₃ M₃), B = B' ↔
    (bilin_form.to_matrix b B) = (bilin_form.to_matrix b B'),
  { intros B B',
    split; intros h,
    { rw h },
    { exact (bilin_form.to_matrix b).injective h } },
  rw [h, bilin_form.to_matrix_comp_left, bilin_form.to_matrix_comp_right,
      linear_map.to_matrix_to_lin, linear_map.to_matrix_to_lin,
      bilin_form.to_matrix_to_bilin, bilin_form.to_matrix_to_bilin],
  refl,
end

lemma matrix.is_adjoint_pair_equiv [decidable_eq n] (P : matrix n n R₃) (h : is_unit P) :
  (Pᵀ ⬝ J ⬝ P).is_adjoint_pair (Pᵀ ⬝ J ⬝ P) A A' ↔
    J.is_adjoint_pair J (P ⬝ A ⬝ P⁻¹) (P ⬝ A' ⬝ P⁻¹) :=
have h' : is_unit P.det := P.is_unit_iff_is_unit_det.mp h,
begin
  let u := P.nonsing_inv_unit h',
  let v := Pᵀ.nonsing_inv_unit (P.is_unit_det_transpose h'),
  let x := Aᵀ * Pᵀ * J,
  let y := J * P * A',
  suffices : x * ↑u = ↑v * y ↔ ↑v⁻¹ * x = y * ↑u⁻¹,
  { dunfold matrix.is_adjoint_pair,
    repeat { rw matrix.transpose_mul, },
    simp only [←matrix.mul_eq_mul, ←mul_assoc, P.transpose_nonsing_inv],
    conv_lhs { to_rhs, rw [mul_assoc, mul_assoc], congr, skip, rw ←mul_assoc, },
    conv_rhs { rw [mul_assoc, mul_assoc], conv { to_lhs, congr, skip, rw ←mul_assoc }, },
    exact this, },
  rw units.eq_mul_inv_iff_mul_eq, conv_rhs { rw mul_assoc, }, rw v.inv_mul_eq_iff_eq_mul,
end

variables [decidable_eq n]

/-- The submodule of pair-self-adjoint matrices with respect to bilinear forms corresponding to
given matrices `J`, `J₂`. -/
def pair_self_adjoint_matrices_submodule : submodule R₃ (matrix n n R₃) :=
(bilin_form.is_pair_self_adjoint_submodule (matrix.to_bilin' J) (matrix.to_bilin' J₃)).map
  ((linear_map.to_matrix' : ((n → R₃) →ₗ[R₃] (n → R₃)) ≃ₗ[R₃] matrix n n R₃) :
  ((n → R₃) →ₗ[R₃] (n → R₃)) →ₗ[R₃] matrix n n R₃)

@[simp] lemma mem_pair_self_adjoint_matrices_submodule :
  A ∈ (pair_self_adjoint_matrices_submodule J J₃) ↔ matrix.is_adjoint_pair J J₃ A A :=
begin
  simp only [pair_self_adjoint_matrices_submodule, linear_equiv.coe_coe,
    linear_map.to_matrix'_apply, submodule.mem_map, bilin_form.mem_is_pair_self_adjoint_submodule],
  split,
  { rintros ⟨f, hf, hA⟩,
    have hf' : f = A.to_lin' := by rw [←hA, matrix.to_lin'_to_matrix'], rw hf' at hf,
    rw ← is_adjoint_pair_to_bilin',
    exact hf, },
  { intros h, refine ⟨A.to_lin', _, linear_map.to_matrix'_to_lin' _⟩,
    exact (is_adjoint_pair_to_bilin' _ _ _ _).mpr h, },
end

/-- The submodule of self-adjoint matrices with respect to the bilinear form corresponding to
the matrix `J`. -/
def self_adjoint_matrices_submodule : submodule R₃ (matrix n n R₃) :=
  pair_self_adjoint_matrices_submodule J J

@[simp] lemma mem_self_adjoint_matrices_submodule :
  A ∈ self_adjoint_matrices_submodule J ↔ J.is_self_adjoint A :=
by { erw mem_pair_self_adjoint_matrices_submodule, refl, }

/-- The submodule of skew-adjoint matrices with respect to the bilinear form corresponding to
the matrix `J`. -/
def skew_adjoint_matrices_submodule : submodule R₃ (matrix n n R₃) :=
  pair_self_adjoint_matrices_submodule (-J) J

@[simp] lemma mem_skew_adjoint_matrices_submodule :
  A ∈ skew_adjoint_matrices_submodule J ↔ J.is_skew_adjoint A :=
begin
  erw mem_pair_self_adjoint_matrices_submodule,
  simp [matrix.is_skew_adjoint, matrix.is_adjoint_pair],
end

end matrix_adjoints

namespace bilin_form


section det

open matrix

variables {A : Type*} [comm_ring A] [is_domain A] [module A M₃] (B₃ : bilin_form A M₃)
variables {ι : Type*} [decidable_eq ι] [fintype ι]

lemma _root_.matrix.nondegenerate_to_bilin'_iff_nondegenerate_to_bilin {M : matrix ι ι R₂}
  (b : basis ι R₂ M₂) : M.to_bilin'.nondegenerate ↔ (matrix.to_bilin b M).nondegenerate :=
(nondegenerate_congr_iff b.equiv_fun.symm).symm

-- Lemmas transferring nondegeneracy between a matrix and its associated bilinear form

theorem _root_.matrix.nondegenerate.to_bilin' {M : matrix ι ι R₃} (h : M.nondegenerate) :
  M.to_bilin'.nondegenerate :=
λ x hx, h.eq_zero_of_ortho $ λ y, by simpa only [to_bilin'_apply'] using hx y

@[simp] lemma _root_.matrix.nondegenerate_to_bilin'_iff {M : matrix ι ι R₃} :
  M.to_bilin'.nondegenerate ↔ M.nondegenerate :=
⟨λ h v hv, h v $ λ w, (M.to_bilin'_apply' _ _).trans $ hv w, matrix.nondegenerate.to_bilin'⟩

theorem _root_.matrix.nondegenerate.to_bilin {M : matrix ι ι R₃} (h : M.nondegenerate)
  (b : basis ι R₃ M₃) : (to_bilin b M).nondegenerate :=
(matrix.nondegenerate_to_bilin'_iff_nondegenerate_to_bilin b).mp h.to_bilin'

@[simp] lemma _root_.matrix.nondegenerate_to_bilin_iff {M : matrix ι ι R₃} (b : basis ι R₃ M₃) :
  (to_bilin b M).nondegenerate ↔ M.nondegenerate :=
by rw [←matrix.nondegenerate_to_bilin'_iff_nondegenerate_to_bilin,
       matrix.nondegenerate_to_bilin'_iff]

-- Lemmas transferring nondegeneracy between a bilinear form and its associated matrix

@[simp] theorem nondegenerate_to_matrix'_iff {B : bilin_form R₃ (ι → R₃)} :
  B.to_matrix'.nondegenerate ↔ B.nondegenerate :=
matrix.nondegenerate_to_bilin'_iff.symm.trans $ (matrix.to_bilin'_to_matrix' B).symm ▸ iff.rfl

theorem nondegenerate.to_matrix' {B : bilin_form R₃ (ι → R₃)} (h : B.nondegenerate) :
  B.to_matrix'.nondegenerate :=
nondegenerate_to_matrix'_iff.mpr h

@[simp] theorem nondegenerate_to_matrix_iff {B : bilin_form R₃ M₃} (b : basis ι R₃ M₃) :
  (to_matrix b B).nondegenerate ↔ B.nondegenerate :=
(matrix.nondegenerate_to_bilin_iff b).symm.trans $ (matrix.to_bilin_to_matrix b B).symm ▸ iff.rfl

theorem nondegenerate.to_matrix {B : bilin_form R₃ M₃} (h : B.nondegenerate)
  (b : basis ι R₃ M₃) : (to_matrix b B).nondegenerate :=
(nondegenerate_to_matrix_iff b).mpr h

-- Some shorthands for combining the above with `matrix.nondegenerate_of_det_ne_zero`

lemma nondegenerate_to_bilin'_iff_det_ne_zero {M : matrix ι ι A} :
  M.to_bilin'.nondegenerate ↔ M.det ≠ 0 :=
by rw [matrix.nondegenerate_to_bilin'_iff, matrix.nondegenerate_iff_det_ne_zero]

theorem nondegenerate_to_bilin'_of_det_ne_zero' (M : matrix ι ι A) (h : M.det ≠ 0) :
  M.to_bilin'.nondegenerate :=
nondegenerate_to_bilin'_iff_det_ne_zero.mpr h

lemma nondegenerate_iff_det_ne_zero {B : bilin_form A M₃}
  (b : basis ι A M₃) : B.nondegenerate ↔ (to_matrix b B).det ≠ 0 :=
by rw [←matrix.nondegenerate_iff_det_ne_zero, nondegenerate_to_matrix_iff]

theorem nondegenerate_of_det_ne_zero (b : basis ι A M₃) (h : (to_matrix b B₃).det ≠ 0) :
  B₃.nondegenerate :=
(nondegenerate_iff_det_ne_zero b).mpr h

end det

end bilin_form


<|start_filename|>src/topology/sequences.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import topology.subset_properties
import topology.metric_space.basic

/-!
# Sequences in topological spaces

In this file we define sequences in topological spaces and show how they are related to
filters and the topology. In particular, we
* define the sequential closure of a set and prove that it's contained in the closure,
* define a type class "sequential_space" in which closure and sequential closure agree,
* define sequential continuity and show that it coincides with continuity in sequential spaces,
* provide an instance that shows that every first-countable (and in particular metric) space is
  a sequential space.
* define sequential compactness, prove that compactness implies sequential compactness in first
  countable spaces, and prove they are equivalent for uniform spaces having a countable uniformity
  basis (in particular metric spaces).
-/

open set function filter
open_locale topological_space

variables {X Y : Type*}

local notation x ` ⟶ ` a := tendsto x at_top (𝓝 a)

/-! ### Sequential closures, sequential continuity, and sequential spaces. -/
section topological_space
variables [topological_space X] [topological_space Y]

/-- The sequential closure of a set `s : set X` in a topological space `X` is
the set of all `a : X` which arise as limit of sequences in `s`. -/
def seq_closure (s : set X) : set X :=
{a | ∃ x : ℕ → X, (∀ n : ℕ, x n ∈ s) ∧ (x ⟶ a)}

lemma subset_seq_closure (s : set X) : s ⊆ seq_closure s :=
λ a ha, ⟨const ℕ a, λ n, ha, tendsto_const_nhds⟩

/-- A set `s` is sequentially closed if for any converging sequence `x n` of elements of `s`,
the limit belongs to `s` as well. -/
def is_seq_closed (s : set X) : Prop := s = seq_closure s

/-- A convenience lemma for showing that a set is sequentially closed. -/
lemma is_seq_closed_of_def {s : set X}
  (h : ∀ (x : ℕ → X) (a : X), (∀ n : ℕ, x n ∈ s) → (x ⟶ a) → a ∈ s) : is_seq_closed s :=
show s = seq_closure s, from subset.antisymm
  (subset_seq_closure s)
  (show ∀ a, a ∈ seq_closure s → a ∈ s, from
    (assume a ⟨x, _, _⟩, show a ∈ s, from h x a ‹∀ n : ℕ, ((x n) ∈ s)› ‹(x ⟶ a)›))

/-- The sequential closure of a set is contained in the closure of that set.
The converse is not true. -/
lemma seq_closure_subset_closure (s : set X) : seq_closure s ⊆ closure s :=
assume a ⟨x, xM, xa⟩,
mem_closure_of_tendsto xa (eventually_of_forall xM)

/-- A set is sequentially closed if it is closed. -/
lemma is_closed.is_seq_closed {s : set X} (hs : is_closed s) : is_seq_closed s :=
suffices seq_closure s ⊆ s, from (subset_seq_closure s).antisymm this,
calc seq_closure s ⊆ closure s : seq_closure_subset_closure s
               ... = s         : hs.closure_eq

/-- The limit of a convergent sequence in a sequentially closed set is in that set.-/
lemma is_seq_closed.mem_of_tendsto {s : set X} (hs : is_seq_closed s) {x : ℕ → X}
  (hmem : ∀ n, x n ∈ s) {a : X} (ha : (x ⟶ a)) : a ∈ s :=
have a ∈ seq_closure s, from
  show ∃ x : ℕ → X, (∀ n : ℕ, x n ∈ s) ∧ (x ⟶ a), from ⟨x, ‹∀ n, x n ∈ s›, ‹(x ⟶ a)›⟩,
eq.subst (eq.symm ‹is_seq_closed s›) ‹a ∈ seq_closure s›

/-- A sequential space is a space in which 'sequences are enough to probe the topology'. This can be
 formalised by demanding that the sequential closure and the closure coincide. The following
 statements show that other topological properties can be deduced from sequences in sequential
 spaces. -/
class sequential_space (X : Type*) [topological_space X] : Prop :=
(seq_closure_eq_closure : ∀ s : set X, seq_closure s = closure s)

/-- In a sequential space, a set is closed iff it's sequentially closed. -/
lemma is_seq_closed_iff_is_closed [sequential_space X] {s : set X} :
  is_seq_closed s ↔ is_closed s :=
iff.intro
  (assume _, closure_eq_iff_is_closed.mp (eq.symm
    (calc s = seq_closure s : by assumption
        ... = closure s     : sequential_space.seq_closure_eq_closure s)))
  is_closed.is_seq_closed

alias is_seq_closed_iff_is_closed ↔ is_seq_closed.is_closed _

/-- In a sequential space, a point belongs to the closure of a set iff it is a limit of a sequence
taking values in this set. -/
lemma mem_closure_iff_seq_limit [sequential_space X] {s : set X} {a : X} :
  a ∈ closure s ↔ ∃ x : ℕ → X, (∀ n : ℕ, x n ∈ s) ∧ (x ⟶ a) :=
by { rw ← sequential_space.seq_closure_eq_closure, exact iff.rfl }

/-- A function between topological spaces is sequentially continuous if it commutes with limit of
 convergent sequences. -/
def seq_continuous (f : X → Y) : Prop :=
∀ (x : ℕ → X), ∀ {a : X}, (x ⟶ a) → (f ∘ x ⟶ f a)

/- A continuous function is sequentially continuous. -/
protected lemma continuous.seq_continuous {f : X → Y} (hf : continuous f) : seq_continuous f :=
assume x a (_ : x ⟶ a),
have tendsto f (𝓝 a) (𝓝 (f a)), from continuous.tendsto ‹continuous f› a,
show (f ∘ x) ⟶ (f a), from tendsto.comp this ‹(x ⟶ a)›

/-- In a sequential space, continuity and sequential continuity coincide. -/
lemma continuous_iff_seq_continuous {f : X → Y} [sequential_space X] :
  continuous f ↔ seq_continuous f :=
iff.intro
  continuous.seq_continuous
  (assume : seq_continuous f, show continuous f, from
    suffices h : ∀ {s : set Y}, is_closed s → is_seq_closed (f ⁻¹' s), from
      continuous_iff_is_closed.mpr (assume s _, is_seq_closed_iff_is_closed.mp $ h ‹is_closed s›),
    assume s (_ : is_closed s),
      is_seq_closed_of_def $
        assume (x : ℕ → X) a (_ : ∀ n, f (x n) ∈ s) (_ : x ⟶ a),
        have (f ∘ x) ⟶ (f a), from ‹seq_continuous f› x ‹(x ⟶ a)›,
        show f a ∈ s,
          from ‹is_closed s›.is_seq_closed.mem_of_tendsto ‹∀ n, f (x n) ∈ s› ‹(f∘x ⟶ f a)›)

alias continuous_iff_seq_continuous ↔ _ seq_continuous.continuous

end topological_space

namespace topological_space

namespace first_countable_topology

variables [topological_space X] [first_countable_topology X]

/-- Every first-countable space is sequential. -/
@[priority 100] -- see Note [lower instance priority]
instance : sequential_space X :=
⟨show ∀ s, seq_closure s = closure s, from assume s,
  suffices closure s ⊆ seq_closure s,
    from set.subset.antisymm (seq_closure_subset_closure s) this,
  -- For every a ∈ closure s, we need to construct a sequence `x` in `s` that converges to `a`:
  assume (a : X) (ha : a ∈ closure s),
  -- Since we are in a first-countable space, the neighborhood filter around `a` has a decreasing
  -- basis `U` indexed by `ℕ`.
  let ⟨U, hU⟩ := (𝓝 a).exists_antitone_basis in
  -- Since `p ∈ closure M`, there is an element in each `M ∩ U i`
  have ha : ∀ (i : ℕ), ∃ (y : X), y ∈ s ∧ y ∈ U i,
    by simpa using (mem_closure_iff_nhds_basis hU.1).mp ha,
  begin
    -- The axiom of (countable) choice builds our sequence from the later fact
    choose u hu using ha,
    rw forall_and_distrib at hu,
    -- It clearly takes values in `M`
    use [u, hu.1],
    -- and converges to `p` because the basis is decreasing.
    apply hU.tendsto hu.2,
  end⟩


end first_countable_topology

end topological_space

section seq_compact
open topological_space topological_space.first_countable_topology
variables [topological_space X]

/-- A set `s` is sequentially compact if every sequence taking values in `s` has a
converging subsequence. -/
def is_seq_compact (s : set X) :=
∀ ⦃x : ℕ → X⦄, (∀ n, x n ∈ s) → ∃ (a ∈ s) (φ : ℕ → ℕ), strict_mono φ ∧ (x ∘ φ ⟶ a)

/-- A space `X` is sequentially compact if every sequence in `X` has a
converging subsequence. -/
class seq_compact_space (X : Type*) [topological_space X] : Prop :=
(seq_compact_univ : is_seq_compact (univ : set X))

lemma is_seq_compact.subseq_of_frequently_in {s : set X} (hs : is_seq_compact s) {x : ℕ → X}
  (hx : ∃ᶠ n in at_top, x n ∈ s) :
  ∃ (a ∈ s) (φ : ℕ → ℕ), strict_mono φ ∧ (x ∘ φ ⟶ a) :=
let ⟨ψ, hψ, huψ⟩ := extraction_of_frequently_at_top hx, ⟨a, a_in, φ, hφ, h⟩ := hs huψ in
⟨a, a_in, ψ ∘ φ, hψ.comp hφ, h⟩

lemma seq_compact_space.tendsto_subseq [seq_compact_space X] (x : ℕ → X) :
  ∃ a (φ : ℕ → ℕ), strict_mono φ ∧ (x ∘ φ ⟶ a) :=
let ⟨a, _, φ, mono, h⟩ := seq_compact_space.seq_compact_univ (λ n, mem_univ (x n)) in
⟨a, φ, mono, h⟩

section first_countable_topology
variables [first_countable_topology X]
open topological_space.first_countable_topology

lemma is_compact.is_seq_compact {s : set X} (hs : is_compact s) : is_seq_compact s :=
λ x x_in,
let ⟨a, a_in, ha⟩ := @hs (map x at_top) _
  (le_principal_iff.mpr (univ_mem' x_in : _)) in ⟨a, a_in, tendsto_subseq ha⟩

lemma is_compact.tendsto_subseq' {s : set X} {x : ℕ → X} (hs : is_compact s)
  (hx : ∃ᶠ n in at_top, x n ∈ s) :
  ∃ (a ∈ s) (φ : ℕ → ℕ), strict_mono φ ∧ (x ∘ φ ⟶ a) :=
hs.is_seq_compact.subseq_of_frequently_in hx

lemma is_compact.tendsto_subseq {s : set X} {x : ℕ → X} (hs : is_compact s) (hx : ∀ n, x n ∈ s) :
  ∃ (a ∈ s) (φ : ℕ → ℕ), strict_mono φ ∧ (x ∘ φ ⟶ a) :=
hs.is_seq_compact hx

@[priority 100] -- see Note [lower instance priority]
instance first_countable_topology.seq_compact_of_compact [compact_space X] : seq_compact_space X :=
⟨compact_univ.is_seq_compact⟩

lemma compact_space.tendsto_subseq [compact_space X] (x : ℕ → X) :
  ∃ a (φ : ℕ → ℕ), strict_mono φ ∧ (x ∘ φ ⟶ a) :=
seq_compact_space.tendsto_subseq x

end first_countable_topology
end seq_compact

section uniform_space_seq_compact

open_locale uniformity
open uniform_space prod

variables [uniform_space X] {s : set X}

lemma lebesgue_number_lemma_seq {ι : Type*} [is_countably_generated (𝓤 X)] {c : ι → set X}
  (hs : is_seq_compact s) (hc₁ : ∀ i, is_open (c i)) (hc₂ : s ⊆ ⋃ i, c i) :
  ∃ V ∈ 𝓤 X, symmetric_rel V ∧ ∀ x ∈ s, ∃ i, ball x V ⊆ c i :=
begin
  classical,
  obtain ⟨V, hV, Vsymm⟩ :
    ∃ V : ℕ → set (X × X), (𝓤 X).has_antitone_basis V ∧ ∀ n, swap ⁻¹' V n = V n,
      from uniform_space.has_seq_basis X,
  suffices : ∃ n, ∀ x ∈ s, ∃ i, ball x (V n) ⊆ c i,
  { cases this with n hn,
    exact ⟨V n, hV.to_has_basis.mem_of_mem trivial, Vsymm n, hn⟩ },
  by_contradiction H,
  obtain ⟨x, x_in, hx⟩ : ∃ x : ℕ → X, (∀ n, x n ∈ s) ∧ ∀ n i, ¬ ball (x n) (V n) ⊆ c i,
  { push_neg at H,
    choose x hx using H,
    exact ⟨x, forall_and_distrib.mp hx⟩ }, clear H,
  obtain ⟨x₀, x₀_in, φ, φ_mono, hlim⟩ : ∃ (x₀ ∈ s) (φ : ℕ → ℕ), strict_mono φ ∧ (x ∘ φ ⟶ x₀),
    from hs x_in, clear hs,
  obtain ⟨i₀, x₀_in⟩ : ∃ i₀, x₀ ∈ c i₀,
  { rcases hc₂ x₀_in with ⟨_, ⟨i₀, rfl⟩, x₀_in_c⟩,
    exact ⟨i₀, x₀_in_c⟩ }, clear hc₂,
  obtain ⟨n₀, hn₀⟩ : ∃ n₀, ball x₀ (V n₀) ⊆ c i₀,
  { rcases (nhds_basis_uniformity hV.to_has_basis).mem_iff.mp
      (is_open_iff_mem_nhds.mp (hc₁ i₀) _ x₀_in) with ⟨n₀, _, h⟩,
    use n₀,
    rwa ← ball_eq_of_symmetry (Vsymm n₀) at h }, clear hc₁,
  obtain ⟨W, W_in, hWW⟩ : ∃ W ∈ 𝓤 X, W ○ W ⊆ V n₀,
    from comp_mem_uniformity_sets (hV.to_has_basis.mem_of_mem trivial),
  obtain ⟨N, x_φ_N_in, hVNW⟩ : ∃ N, x (φ N) ∈ ball x₀ W ∧ V (φ N) ⊆ W,
  { obtain ⟨N₁, h₁⟩ : ∃ N₁, ∀ n ≥ N₁, x (φ n) ∈ ball x₀ W,
      from tendsto_at_top'.mp hlim _ (mem_nhds_left x₀ W_in),
    obtain ⟨N₂, h₂⟩ : ∃ N₂, V (φ N₂) ⊆ W,
    { rcases hV.to_has_basis.mem_iff.mp W_in with ⟨N, _, hN⟩,
      use N,
      exact subset.trans (hV.antitone $ φ_mono.id_le _) hN },
    have : φ N₂ ≤ φ (max N₁ N₂),
      from φ_mono.le_iff_le.mpr (le_max_right _ _),
    exact ⟨max N₁ N₂, h₁ _ (le_max_left _ _), trans (hV.antitone this) h₂⟩ },
  suffices : ball (x (φ N)) (V (φ N)) ⊆ c i₀,
    from hx (φ N) i₀ this,
  calc
    ball (x $ φ N) (V $ φ N) ⊆ ball (x $ φ N) W : preimage_mono hVNW
                         ... ⊆ ball x₀ (V n₀)   : ball_subset_of_comp_subset x_φ_N_in hWW
                         ... ⊆ c i₀             : hn₀,
end

lemma is_seq_compact.totally_bounded (h : is_seq_compact s) : totally_bounded s :=
begin
  classical,
  apply totally_bounded_of_forall_symm,
  unfold is_seq_compact at h,
  contrapose! h,
  rcases h with ⟨V, V_in, V_symm, h⟩,
  simp_rw [not_subset] at h,
  have : ∀ (t : set X), t.finite → ∃ a, a ∈ s ∧ a ∉ ⋃ y ∈ t, ball y V,
  { intros t ht,
    obtain ⟨a, a_in, H⟩ : ∃ a ∈ s, ∀ x ∈ t, (x, a) ∉ V,
      by simpa [ht] using h t,
    use [a, a_in],
    intro H',
    obtain ⟨x, x_in, hx⟩ := mem_Union₂.mp H',
    exact H x x_in hx },
  cases seq_of_forall_finite_exists this with u hu, clear h this,
  simp [forall_and_distrib] at hu,
  cases hu with u_in hu,
  use [u, u_in], clear u_in,
  intros x x_in φ,
  intros hφ huφ,
  obtain ⟨N, hN⟩ : ∃ N, ∀ p q, p ≥ N → q ≥ N → (u (φ p), u (φ q)) ∈ V,
    from huφ.cauchy_seq.mem_entourage V_in,
  specialize hN N (N+1) (le_refl N) (nat.le_succ N),
  specialize hu (φ $ N+1) (φ N) (hφ $ lt_add_one N),
  exact hu hN,
end

protected lemma is_seq_compact.is_compact [is_countably_generated $ 𝓤 X] (hs : is_seq_compact s) :
  is_compact s :=
begin
  classical,
  rw is_compact_iff_finite_subcover,
  intros ι U Uop s_sub,
  rcases lebesgue_number_lemma_seq hs Uop s_sub with ⟨V, V_in, Vsymm, H⟩,
  rcases totally_bounded_iff_subset.mp hs.totally_bounded V V_in with ⟨t,t_sub, tfin,  ht⟩,
  have : ∀ x : t, ∃ (i : ι), ball x.val V ⊆ U i,
  { rintros ⟨x, x_in⟩,
    exact H x (t_sub x_in) },
  choose i hi using this,
  haveI : fintype t := tfin.fintype,
  use finset.image i finset.univ,
  transitivity ⋃ y ∈ t, ball y V,
  { intros x x_in,
    specialize ht x_in,
    rw mem_Union₂ at *,
    simp_rw ball_eq_of_symmetry Vsymm,
    exact ht },
  { refine Union₂_mono' (λ x x_in, _),
    exact ⟨i ⟨x, x_in⟩, finset.mem_image_of_mem _ (finset.mem_univ _), hi ⟨x, x_in⟩⟩ },
end

/-- A version of Bolzano-Weistrass: in a uniform space with countably generated uniformity filter
(e.g., in a metric space), a set is compact if and only if it is sequentially compact. -/
protected lemma uniform_space.compact_iff_seq_compact [is_countably_generated $ 𝓤 X] :
 is_compact s ↔ is_seq_compact s :=
⟨λ H, H.is_seq_compact, λ H, H.is_compact⟩

lemma uniform_space.compact_space_iff_seq_compact_space [is_countably_generated $ 𝓤 X] :
  compact_space X ↔ seq_compact_space X :=
have key : is_compact (univ : set X) ↔ is_seq_compact univ := uniform_space.compact_iff_seq_compact,
⟨λ ⟨h⟩, ⟨key.mp h⟩, λ ⟨h⟩, ⟨key.mpr h⟩⟩

end uniform_space_seq_compact

section metric_seq_compact

variables [pseudo_metric_space X]
open metric

lemma seq_compact.lebesgue_number_lemma_of_metric {ι : Sort*} {c : ι → set X}
  {s : set X} (hs : is_seq_compact s) (hc₁ : ∀ i, is_open (c i)) (hc₂ : s ⊆ ⋃ i, c i) :
  ∃ δ > 0, ∀ a ∈ s, ∃ i, ball a δ ⊆ c i :=
lebesgue_number_lemma_of_metric hs.is_compact hc₁ hc₂

variables [proper_space X] {s : set X}

/-- A version of **Bolzano-Weistrass**: in a proper metric space (eg. $ℝ^n$),
every bounded sequence has a converging subsequence. This version assumes only
that the sequence is frequently in some bounded set. -/
lemma tendsto_subseq_of_frequently_bounded (hs : bounded s)
  {x : ℕ → X} (hx : ∃ᶠ n in at_top, x n ∈ s) :
  ∃ a ∈ closure s, ∃ φ : ℕ → ℕ, strict_mono φ ∧ (x ∘ φ ⟶ a) :=
have hcs : is_seq_compact (closure s), from hs.is_compact_closure.is_seq_compact,
have hu' : ∃ᶠ n in at_top, x n ∈ closure s, from hx.mono (λ n hn, subset_closure hn),
hcs.subseq_of_frequently_in hu'

/-- A version of Bolzano-Weistrass: in a proper metric space (eg. $ℝ^n$),
every bounded sequence has a converging subsequence. -/
lemma tendsto_subseq_of_bounded (hs : bounded s) {x : ℕ → X} (hx : ∀ n, x n ∈ s) :
  ∃ a ∈ closure s, ∃ φ : ℕ → ℕ, strict_mono φ ∧ (x ∘ φ ⟶ a) :=
tendsto_subseq_of_frequently_bounded hs $ frequently_of_forall hx

end metric_seq_compact


<|start_filename|>src/algebra/monoid_algebra/grading.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import linear_algebra.finsupp
import algebra.monoid_algebra.basic
import algebra.direct_sum.internal
import ring_theory.graded_algebra.basic

/-!
# Internal grading of an `add_monoid_algebra`

In this file, we show that an `add_monoid_algebra` has an internal direct sum structure.

## Main results

* `add_monoid_algebra.grade_by R f i`: the `i`th grade of an `add_monoid_algebra R M` given by the
  degree function `f`.
* `add_monoid_algebra.grade R i`: the `i`th grade of an `add_monoid_algebra R M` when the degree
  function is the identity.
* `add_monoid_algebra.grade_by.graded_algebra`: `add_monoid_algebra` is an algebra graded by
  `add_monoid_algebra.grade_by`.
* `add_monoid_algebra.grade.graded_algebra`: `add_monoid_algebra` is an algebra graded by
  `add_monoid_algebra.grade`.
* `add_monoid_algebra.grade_by.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade_by` defines an internal graded structure.
* `add_monoid_algebra.grade.is_internal`: propositionally, the statement that
  `add_monoid_algebra.grade` defines an internal graded structure when the degree function
  is the identity.
-/

noncomputable theory

namespace add_monoid_algebra
variables {M : Type*} {ι : Type*} {R : Type*} [decidable_eq M]

section
variables (R) [comm_semiring R]

/-- The submodule corresponding to each grade given by the degree function `f`. -/
abbreviation grade_by (f : M → ι) (i : ι) : submodule R (add_monoid_algebra R M) :=
{ carrier := {a | ∀ m, m ∈ a.support → f m = i },
  zero_mem' := set.empty_subset _,
  add_mem' := λ a b ha hb m h,
    or.rec_on (finset.mem_union.mp (finsupp.support_add h)) (ha m) (hb m),
  smul_mem' := λ a m h, set.subset.trans finsupp.support_smul h }

/-- The submodule corresponding to each grade. -/
abbreviation grade (m : M) : submodule R (add_monoid_algebra R M) := grade_by R id m

lemma grade_by_id : grade_by R (id : M → M) = grade R := by refl

lemma mem_grade_by_iff (f : M → ι) (i : ι) (a : add_monoid_algebra R M) :
  a ∈ grade_by R f i ↔ (a.support : set M) ⊆ f ⁻¹' {i} := by refl

lemma mem_grade_iff (m : M) (a : add_monoid_algebra R M) : a ∈ grade R m ↔ a.support ⊆ {m} :=
begin
  rw [← finset.coe_subset, finset.coe_singleton],
  refl
end

lemma mem_grade_iff' (m : M) (a : add_monoid_algebra R M) :
  a ∈ grade R m ↔
    a ∈ ((finsupp.lsingle m).range : submodule R (add_monoid_algebra R M)) :=
begin
  rw [mem_grade_iff, finsupp.support_subset_singleton'],
  apply exists_congr,
  intros r,
  split; exact eq.symm
end

lemma grade_eq_lsingle_range (m : M) : grade R m = (finsupp.lsingle m).range :=
submodule.ext (mem_grade_iff' R m)

lemma single_mem_grade_by {R} [comm_semiring R] (f : M → ι) (m : M) (r : R) :
  finsupp.single m r ∈ grade_by R f (f m) :=
begin
  intros x hx,
  rw finset.mem_singleton.mp (finsupp.support_single_subset hx),
end

lemma single_mem_grade {R} [comm_semiring R] (i : M) (r : R) : finsupp.single i r ∈ grade R i :=
single_mem_grade_by _ _ _

end

open_locale direct_sum

instance grade_by.graded_monoid [add_monoid M] [add_monoid ι] [comm_semiring R] (f : M →+ ι) :
  set_like.graded_monoid (grade_by R f : ι → submodule R (add_monoid_algebra R M)) :=
{ one_mem := λ m h, begin
    rw one_def at h,
    by_cases H : (1 : R) = (0 : R),
    { rw [H , finsupp.single_zero] at h,
      exfalso,
      exact h },
    { rw [finsupp.support_single_ne_zero _ H, finset.mem_singleton] at h,
      rw [h, add_monoid_hom.map_zero] }
  end,
  mul_mem := λ i j a b ha hb c hc, begin
    set h := support_mul a b hc,
    simp only [finset.mem_bUnion] at h,
    rcases h with ⟨ma, ⟨hma, ⟨mb, ⟨hmb, hmc⟩⟩⟩⟩,
    rw [← ha ma hma, ← hb mb hmb, finset.mem_singleton.mp hmc],
    apply add_monoid_hom.map_add
  end }

instance grade.graded_monoid [add_monoid M] [comm_semiring R] :
  set_like.graded_monoid (grade R : M → submodule R (add_monoid_algebra R M)) :=
by apply grade_by.graded_monoid (add_monoid_hom.id _)

variables {R} [add_monoid M] [decidable_eq ι] [add_monoid ι] [comm_semiring R] (f : M →+ ι)

/-- Auxiliary definition; the canonical grade decomposition, used to provide
`graded_algebra.decompose`. -/
def decompose_aux : add_monoid_algebra R M →ₐ[R] ⨁ i : ι, grade_by R f i :=
add_monoid_algebra.lift R M _
{ to_fun := λ m, direct_sum.of (λ i : ι, grade_by R f i) (f m.to_add)
    ⟨finsupp.single m.to_add 1, single_mem_grade_by _ _ _⟩,
  map_one' := direct_sum.of_eq_of_graded_monoid_eq (by congr' 2; try {ext};
    simp only [submodule.mem_to_add_submonoid, to_add_one, add_monoid_hom.map_zero]),
  map_mul' := λ i j, begin
    symmetry,
    convert direct_sum.of_mul_of _ _,
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2,
    { rw [to_add_mul, add_monoid_hom.map_add] },
    { ext,
      simp only [submodule.mem_to_add_submonoid, add_monoid_hom.map_add, to_add_mul] },
    { exact eq.trans (by rw [one_mul, to_add_mul]) single_mul_single.symm }
  end }

lemma decompose_aux_single (m : M) (r : R) :
  decompose_aux f (finsupp.single m r) =
    direct_sum.of (λ i : ι, grade_by R f i) (f m)
      ⟨finsupp.single m r, single_mem_grade_by _ _ _⟩ :=
begin
  refine (lift_single _ _ _).trans _,
  refine (direct_sum.of_smul _ _ _ _).symm.trans _,
  apply direct_sum.of_eq_of_graded_monoid_eq,
  refine sigma.subtype_ext rfl _,
  refine (finsupp.smul_single' _ _ _).trans _,
  rw mul_one,
  refl,
end

lemma decompose_aux_coe {i : ι} (x : grade_by R f i) :
  decompose_aux f ↑x = direct_sum.of (λ i, grade_by R f i) i x :=
begin
  obtain ⟨x, hx⟩ := x,
  revert hx,
  refine finsupp.induction x _ _,
  { intros hx,
    symmetry,
    exact add_monoid_hom.map_zero _ },
  { intros m b y hmy hb ih hmby,
    have : disjoint (finsupp.single m b).support y.support,
    { simpa only [finsupp.support_single_ne_zero _ hb, finset.disjoint_singleton_left] },
    rw [mem_grade_by_iff, finsupp.support_add_eq this, finset.coe_union,
      set.union_subset_iff] at hmby,
    cases hmby with h1 h2,
    have : f m = i,
    { rwa [finsupp.support_single_ne_zero _ hb, finset.coe_singleton,
        set.singleton_subset_iff] at h1 },
    subst this,
    simp only [alg_hom.map_add, submodule.coe_mk, decompose_aux_single f m],
    let ih' := ih h2,
    dsimp at ih',
    rw [ih', ← add_monoid_hom.map_add],
    apply direct_sum.of_eq_of_graded_monoid_eq,
    congr' 2 }
end

instance grade_by.graded_algebra : graded_algebra (grade_by R f) :=
graded_algebra.of_alg_hom _
  (decompose_aux f)
  (begin
    ext : 2,
    dsimp,
    rw [decompose_aux_single, direct_sum.coe_alg_hom_of, subtype.coe_mk],
  end)
  (λ i x, by convert (decompose_aux_coe f x : _))

@[simp] lemma decompose_aux_eq_decompose :
  ⇑(decompose_aux f : add_monoid_algebra R M →ₐ[R] ⨁ i : ι, grade_by R f i) =
    (graded_algebra.decompose (grade_by R f)) := rfl

@[simp] lemma grades_by.decompose_single (m : M) (r : R) :
  graded_algebra.decompose (grade_by R f) (finsupp.single m r) =
    direct_sum.of (λ i : ι, grade_by R f i) (f m)
      ⟨finsupp.single m r, single_mem_grade_by _ _ _⟩ :=
decompose_aux_single _ _ _

instance grade.graded_algebra : graded_algebra (grade R : ι → submodule _ _) :=
add_monoid_algebra.grade_by.graded_algebra (add_monoid_hom.id _)

@[simp]
lemma grade.decompose_single (i : ι) (r : R) :
  graded_algebra.decompose (grade R : ι → submodule _ _) (finsupp.single i r) =
    direct_sum.of (λ i : ι, grade R i) i ⟨finsupp.single i r, single_mem_grade _ _⟩ :=
decompose_aux_single _ _ _

/-- `add_monoid_algebra.gradesby` describe an internally graded algebra -/
lemma grade_by.is_internal : direct_sum.is_internal (grade_by R f) :=
graded_algebra.is_internal _

/-- `add_monoid_algebra.grades` describe an internally graded algebra -/
lemma grade.is_internal : direct_sum.is_internal (grade R : ι → submodule R _) :=
graded_algebra.is_internal _

end add_monoid_algebra


<|start_filename|>src/topology/instances/rat.lean<|end_filename|>
/-
Copyright (c) 2017 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import topology.metric_space.basic
import topology.algebra.order.archimedean
import topology.instances.int
import topology.instances.nat
import topology.instances.real
/-!
# Topology on the ratonal numbers

The structure of a metric space on `ℚ` is introduced in this file, induced from `ℝ`.
-/
noncomputable theory
open metric set filter

namespace rat

instance : metric_space ℚ :=
metric_space.induced coe rat.cast_injective real.metric_space

theorem dist_eq (x y : ℚ) : dist x y = |x - y| := rfl

@[norm_cast, simp] lemma dist_cast (x y : ℚ) : dist (x : ℝ) y = dist x y := rfl

theorem uniform_continuous_coe_real : uniform_continuous (coe : ℚ → ℝ) :=
uniform_continuous_comap

theorem uniform_embedding_coe_real : uniform_embedding (coe : ℚ → ℝ) :=
uniform_embedding_comap rat.cast_injective

theorem dense_embedding_coe_real : dense_embedding (coe : ℚ → ℝ) :=
uniform_embedding_coe_real.dense_embedding rat.dense_range_cast

theorem embedding_coe_real : embedding (coe : ℚ → ℝ) := dense_embedding_coe_real.to_embedding

theorem continuous_coe_real : continuous (coe : ℚ → ℝ) := uniform_continuous_coe_real.continuous

end rat

@[norm_cast, simp] theorem nat.dist_cast_rat (x y : ℕ) : dist (x : ℚ) y = dist x y :=
by rw [← nat.dist_cast_real, ← rat.dist_cast]; congr' 1; norm_cast

lemma nat.uniform_embedding_coe_rat : uniform_embedding (coe : ℕ → ℚ) :=
uniform_embedding_bot_of_pairwise_le_dist zero_lt_one $ by simpa using nat.pairwise_one_le_dist

lemma nat.closed_embedding_coe_rat : closed_embedding (coe : ℕ → ℚ) :=
closed_embedding_of_pairwise_le_dist zero_lt_one $ by simpa using nat.pairwise_one_le_dist

@[norm_cast, simp] theorem int.dist_cast_rat (x y : ℤ) : dist (x : ℚ) y = dist x y :=
by rw [← int.dist_cast_real, ← rat.dist_cast]; congr' 1; norm_cast

lemma int.uniform_embedding_coe_rat : uniform_embedding (coe : ℤ → ℚ) :=
uniform_embedding_bot_of_pairwise_le_dist zero_lt_one $ by simpa using int.pairwise_one_le_dist

lemma int.closed_embedding_coe_rat : closed_embedding (coe : ℤ → ℚ) :=
closed_embedding_of_pairwise_le_dist zero_lt_one $ by simpa using int.pairwise_one_le_dist

instance : noncompact_space ℚ := int.closed_embedding_coe_rat.noncompact_space

-- TODO(Mario): Find a way to use rat_add_continuous_lemma
theorem rat.uniform_continuous_add : uniform_continuous (λp : ℚ × ℚ, p.1 + p.2) :=
rat.uniform_embedding_coe_real.to_uniform_inducing.uniform_continuous_iff.2 $
  by simp only [(∘), rat.cast_add]; exact real.uniform_continuous_add.comp
    (rat.uniform_continuous_coe_real.prod_map rat.uniform_continuous_coe_real)

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

instance : uniform_add_group ℚ :=
uniform_add_group.mk' rat.uniform_continuous_add rat.uniform_continuous_neg

instance : topological_add_group ℚ := by apply_instance

instance : order_topology ℚ :=
induced_order_topology _ (λ x y, rat.cast_lt) (@exists_rat_btwn _ _ _)

lemma rat.uniform_continuous_abs : uniform_continuous (abs : ℚ → ℚ) :=
metric.uniform_continuous_iff.2 $ λ ε ε0,
  ⟨ε, ε0, λ a b h, lt_of_le_of_lt
    (by simpa [rat.dist_eq] using abs_abs_sub_abs_le_abs_sub _ _) h⟩

lemma rat.continuous_mul : continuous (λp : ℚ × ℚ, p.1 * p.2) :=
rat.embedding_coe_real.continuous_iff.2 $ by simp [(∘)]; exact
real.continuous_mul.comp ((rat.continuous_coe_real.prod_map rat.continuous_coe_real))

instance : topological_ring ℚ :=
{ continuous_mul := rat.continuous_mul, ..rat.topological_add_group }

lemma rat.totally_bounded_Icc (a b : ℚ) : totally_bounded (Icc a b) :=
begin
  have := totally_bounded_preimage rat.uniform_embedding_coe_real (totally_bounded_Icc a b),
  rwa (set.ext (λ q, _) : Icc _ _ = _), simp
end


<|start_filename|>src/data/zmod/quotient.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.zmod.basic
import group_theory.quotient_group
import ring_theory.int.basic

/-!
# `zmod n` and quotient groups / rings

This file relates `zmod n` to the quotient group
`quotient_add_group.quotient (add_subgroup.zmultiples n)` and to the quotient ring
`(ideal.span {n}).quotient`.

## Main definitions

 - `zmod.quotient_zmultiples_nat_equiv_zmod` and `zmod.quotient_zmultiples_equiv_zmod`:
   `zmod n` is the group quotient of `ℤ` by `n ℤ := add_subgroup.zmultiples (n)`,
   (where `n : ℕ` and `n : ℤ` respectively)
 - `zmod.quotient_span_nat_equiv_zmod` and `zmod.quotient_span_equiv_zmod`:
   `zmod n` is the ring quotient of `ℤ` by `n ℤ : ideal.span {n}`
   (where `n : ℕ` and `n : ℤ` respectively)
 - `zmod.lift n f` is the map from `zmod n` induced by `f : ℤ →+ A` that maps `n` to `0`.

## Tags

zmod, quotient group, quotient ring, ideal quotient
-/

open quotient_add_group
open zmod

variables (n : ℕ) {A R : Type*} [add_group A] [ring R]

namespace int

/-- `ℤ` modulo multiples of `n : ℕ` is `zmod n`. -/
def quotient_zmultiples_nat_equiv_zmod :
  ℤ ⧸ add_subgroup.zmultiples (n : ℤ) ≃+ zmod n :=
(equiv_quotient_of_eq (zmod.ker_int_cast_add_hom _)).symm.trans $
quotient_ker_equiv_of_right_inverse (int.cast_add_hom (zmod n)) coe int_cast_zmod_cast

/-- `ℤ` modulo multiples of `a : ℤ` is `zmod a.nat_abs`. -/
def quotient_zmultiples_equiv_zmod (a : ℤ) :
  ℤ ⧸ add_subgroup.zmultiples a ≃+ zmod a.nat_abs :=
(equiv_quotient_of_eq (zmultiples_nat_abs a)).symm.trans
  (quotient_zmultiples_nat_equiv_zmod a.nat_abs)

/-- `ℤ` modulo the ideal generated by `n : ℕ` is `zmod n`. -/
def quotient_span_nat_equiv_zmod :
  ℤ ⧸ ideal.span {↑n} ≃+* zmod n :=
(ideal.quot_equiv_of_eq (zmod.ker_int_cast_ring_hom _)).symm.trans $
  ring_hom.quotient_ker_equiv_of_right_inverse $
  show function.right_inverse coe (int.cast_ring_hom (zmod n)),
  from int_cast_zmod_cast

/-- `ℤ` modulo the ideal generated by `a : ℤ` is `zmod a.nat_abs`. -/
def quotient_span_equiv_zmod (a : ℤ) :
  ℤ ⧸ ideal.span ({a} : set ℤ) ≃+* zmod a.nat_abs :=
(ideal.quot_equiv_of_eq (span_nat_abs a)).symm.trans
  (quotient_span_nat_equiv_zmod a.nat_abs)

end int

namespace add_action

open add_subgroup add_monoid_hom add_equiv function

variables {α β : Type*} [add_group α] (a : α) [add_action α β] (b : β)

/-- The quotient `(ℤ ∙ a) ⧸ (stabilizer b)` is cyclic of order `minimal_period ((+ᵥ) a) b`. -/
noncomputable def zmultiples_quotient_stabilizer_equiv :
  zmultiples a ⧸ stabilizer (zmultiples a) b ≃+ zmod (minimal_period ((+ᵥ) a) b) :=
(of_bijective (map _ (stabilizer (zmultiples a) b)
  (zmultiples_hom (zmultiples a) ⟨a, mem_zmultiples a⟩) (by
  { rw [zmultiples_le, mem_comap, mem_stabilizer_iff,
        zmultiples_hom_apply, coe_nat_zsmul, ←vadd_iterate],
    exact is_periodic_pt_minimal_period ((+ᵥ) a) b })) ⟨by
  { rw [←ker_eq_bot_iff, eq_bot_iff],
    refine λ q, induction_on' q (λ n hn, _),
    rw [mem_bot, eq_zero_iff, int.mem_zmultiples_iff, ←zsmul_vadd_eq_iff_minimal_period_dvd],
    exact (eq_zero_iff _).mp hn },
  λ q, induction_on' q (λ ⟨_, n, rfl⟩, ⟨n, rfl⟩)⟩).symm.trans
  (int.quotient_zmultiples_nat_equiv_zmod (minimal_period ((+ᵥ) a) b))

lemma zmultiples_quotient_stabilizer_equiv_symm_apply (n : zmod (minimal_period ((+ᵥ) a) b)) :
  (zmultiples_quotient_stabilizer_equiv a b).symm n =
    (n : ℤ) • (⟨a, mem_zmultiples a⟩ : zmultiples a) :=
rfl

end add_action

namespace mul_action

open add_action subgroup add_subgroup function

variables {α β : Type*} [group α] (a : α) [mul_action α β] (b : β)

/-- The quotient `(a ^ ℤ) ⧸ (stabilizer b)` is cyclic of order `minimal_period ((•) a) b`. -/
noncomputable def zpowers_quotient_stabilizer_equiv :
  zpowers a ⧸ stabilizer (zpowers a) b ≃* multiplicative (zmod (minimal_period ((•) a) b)) :=
let f := zmultiples_quotient_stabilizer_equiv (additive.of_mul a) b in
⟨f.to_fun, f.inv_fun, f.left_inv, f.right_inv, f.map_add'⟩

lemma zpowers_quotient_stabilizer_equiv_symm_apply (n : zmod (minimal_period ((•) a) b)) :
  (zpowers_quotient_stabilizer_equiv a b).symm n = (⟨a, mem_zpowers a⟩ : zpowers a) ^ (n : ℤ) :=
rfl

/-- The orbit `(a ^ ℤ) • b` is a cycle of order `minimal_period ((•) a) b`. -/
noncomputable def orbit_zpowers_equiv : orbit (zpowers a) b ≃ zmod (minimal_period ((•) a) b) :=
(orbit_equiv_quotient_stabilizer _ b).trans (zpowers_quotient_stabilizer_equiv a b).to_equiv

/-- The orbit `(ℤ • a) +ᵥ b` is a cycle of order `minimal_period ((+ᵥ) a) b`. -/
noncomputable def _root_.add_action.orbit_zmultiples_equiv
  {α β : Type*} [add_group α] (a : α) [add_action α β] (b : β) :
  add_action.orbit (zmultiples a) b ≃ zmod (minimal_period ((+ᵥ) a) b) :=
(add_action.orbit_equiv_quotient_stabilizer (zmultiples a) b).trans
  (zmultiples_quotient_stabilizer_equiv a b).to_equiv

attribute [to_additive orbit_zmultiples_equiv] orbit_zpowers_equiv

@[to_additive orbit_zmultiples_equiv_symm_apply]
lemma orbit_zpowers_equiv_symm_apply (k : zmod (minimal_period ((•) a) b)) :
  (orbit_zpowers_equiv a b).symm k =
    (⟨a, mem_zpowers a⟩ : zpowers a) ^ (k : ℤ) • ⟨b, mem_orbit_self b⟩ :=
rfl

lemma orbit_zpowers_equiv_symm_apply' (k : ℤ) :
  (orbit_zpowers_equiv a b).symm k =
    (⟨a, mem_zpowers a⟩ : zpowers a) ^ k • ⟨b, mem_orbit_self b⟩ :=
begin
  rw [orbit_zpowers_equiv_symm_apply, zmod.coe_int_cast],
  exact subtype.ext (zpow_smul_mod_minimal_period _ _ k),
end

lemma _root_.add_action.orbit_zmultiples_equiv_symm_apply'
  {α β : Type*} [add_group α] (a : α) [add_action α β] (b : β) (k : ℤ) :
  (add_action.orbit_zmultiples_equiv a b).symm k =
    (k • (⟨a, mem_zmultiples a⟩ : zmultiples a)) +ᵥ ⟨b, add_action.mem_orbit_self b⟩ :=
begin
  rw [add_action.orbit_zmultiples_equiv_symm_apply, zmod.coe_int_cast],
  exact subtype.ext (zsmul_vadd_mod_minimal_period _ _ k),
end

attribute [to_additive orbit_zmultiples_equiv_symm_apply'] orbit_zpowers_equiv_symm_apply'

@[to_additive] lemma minimal_period_eq_card [fintype (orbit (zpowers a) b)] :
  minimal_period ((•) a) b = fintype.card (orbit (zpowers a) b) :=
by rw [←fintype.of_equiv_card (orbit_zpowers_equiv a b), zmod.card]

@[to_additive] instance minimal_period_pos [fintype $ orbit (zpowers a) b] :
  ne_zero $ minimal_period ((•) a) b :=
⟨begin
  haveI : nonempty (orbit (zpowers a) b) := (orbit_nonempty b).to_subtype,
  rw minimal_period_eq_card,
  exact fintype.card_ne_zero,
end⟩

end mul_action


<|start_filename|>src/algebraic_topology/dold_kan/homotopies.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import algebra.homology.homotopy
import algebraic_topology.dold_kan.notations

/-!

# Construction of homotopies for the Dold-Kan correspondence

TODO (@joelriou) continue adding the various files references below

(The general strategy of proof of the Dold-Kan correspondence is explained
in `equivalence.lean`.)

The purpose of the files `homotopies.lean`, `faces.lean`, `projections.lean`
and `p_infty.lean` is to construct an idempotent endomorphism
`P_infty : K[X] ⟶ K[X]` of the alternating face map complex
for each `X : simplicial_object C` when `C` is a preadditive category.
In the case `C` is abelian, this `P_infty` shall be the projection on the
normalized Moore subcomplex of `K[X]` associated to the decomposition of the
complex `K[X]` as a direct sum of this normalized subcomplex and of the
degenerate subcomplex.

In `p_infty.lean`, this endomorphism `P_infty` shall be obtained by
passing to the limit idempotent endomorphisms `P q` for all `(q : ℕ)`.
These endomorphisms `P q` are defined by induction. The idea is to
start from the identity endomorphism `P 0` of `K[X]` and to ensure by
induction that the `q` higher face maps (except $d_0$) vanish on the
image of `P q`. Then, in a certain degree `n`, the image of `P q` for
a big enough `q` will be contained in the normalized subcomplex. This
construction is done in `projections.lean`.

It would be easy to define the `P q` degreewise (similarly as it is done
in *Simplicial Homotopy Theory* by Goerrs-Jardine p. 149), but then we would
have to prove that they are compatible with the differential (i.e. they
are chain complex maps), and also that they are homotopic to the identity.
These two verifications are quite technical. In order to reduce the number
of such technical lemmas, the strategy that is followed here is to define
a series of null homotopic maps `Hσ q` (attached to families of maps `hσ`)
and use these in order to construct `P q` : the endomorphisms `P q`
shall basically be obtained by altering the identity endomorphism by adding
null homotopic maps, so that we get for free that they are morphisms
of chain complexes and that they are homotopic to the identity. The most
technical verifications that are needed about the null homotopic maps `Hσ`
are obtained in `faces.lean`.

In this file `homotopies.lean`, we define the null homotopic maps
`Hσ q : K[X] ⟶ K[X]`, show that they are natural (see `nat_trans_Hσ`) and
compatible the application of additive functors (see `map_Hσ`).

## References
* [<NAME>, *Homology of Symmetric Products and Other Functors of Complexes*][dold1958]
* [<NAME>, <NAME>, *Simplical Homotopy Theory*][goerss-jardine-2009]

-/

open category_theory
open category_theory.category
open category_theory.limits
open category_theory.preadditive
open category_theory.simplicial_object
open homotopy
open opposite
open_locale simplicial dold_kan

noncomputable theory

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C]
variables {X : simplicial_object C}

/-- As we are using chain complexes indexed by `ℕ`, we shall need the relation
`c` such `c m n` if and only if `n+1=m`. -/
abbreviation c := complex_shape.down ℕ

/-- Helper when we need some `c.rel i j` (i.e. `complex_shape.down ℕ`),
e.g. `c_mk n (n+1) rfl` -/
lemma c_mk (i j : ℕ) (h : j+1 = i) : c.rel i j :=
complex_shape.down_mk i j h

/-- This lemma is meant to be used with `null_homotopic_map'_f_of_not_rel_left` -/
lemma cs_down_0_not_rel_left (j : ℕ) : ¬c.rel 0 j :=
begin
  intro hj,
  dsimp at hj,
  apply nat.not_succ_le_zero j,
  rw [nat.succ_eq_add_one, hj],
end

/-- The sequence of maps which gives the null homotopic maps `Hσ` that shall be in
the inductive construction of the projections `P q : K[X] ⟶ K[X]` -/
def hσ (q : ℕ) (n : ℕ) : X _[n] ⟶ X _[n+1] :=
if n<q
  then 0
  else (-1 : ℤ)^(n-q) • X.σ ⟨n-q, nat.sub_lt_succ n q⟩

/-- We can turn `hσ` into a datum that can be passed to `null_homotopic_map'`. -/
def hσ' (q : ℕ) : Π n m, c.rel m n → (K[X].X n ⟶ K[X].X m) :=
λ n m hnm, (hσ q n) ≫ eq_to_hom (by congr')

lemma hσ'_eq_zero {q n m : ℕ} (hnq : n<q) (hnm : c.rel m n) :
  (hσ' q n m hnm : X _[n] ⟶ X _[m])= 0 :=
by { simp only [hσ', hσ], split_ifs, exact zero_comp, }

lemma hσ'_eq {q n a m : ℕ} (ha : n=a+q) (hnm : c.rel m n) :
  (hσ' q n m hnm : X _[n] ⟶ X _[m]) =
  ((-1 : ℤ)^a • X.σ ⟨a, nat.lt_succ_iff.mpr (nat.le.intro (eq.symm ha))⟩) ≫
      eq_to_hom (by congr') :=
begin
  simp only [hσ', hσ],
  split_ifs,
  { exfalso, linarith, },
  { have h' := tsub_eq_of_eq_add ha,
    congr', }
end

/-- The null homotopic map $(hσ q) ∘ d + d ∘ (hσ q)$ -/
def Hσ (q : ℕ) : K[X] ⟶ K[X] := null_homotopic_map' (hσ' q)

/-- `Hσ` is null homotopic -/
def homotopy_Hσ_to_zero (q : ℕ) : homotopy (Hσ q : K[X] ⟶ K[X]) 0 :=
null_homotopy' (hσ' q)

/-- In degree `0`, the null homotopic map `Hσ` is zero. -/
lemma Hσ_eq_zero (q : ℕ) : (Hσ q : K[X] ⟶ K[X]).f 0 = 0  :=
begin
  unfold Hσ,
  rw null_homotopic_map'_f_of_not_rel_left (c_mk 1 0 rfl) cs_down_0_not_rel_left,
  cases q,
  { rw hσ'_eq (show 0=0+0, by refl) (c_mk 1 0 rfl),
    simp only [pow_zero, fin.mk_zero, one_zsmul, eq_to_hom_refl, category.comp_id],
    erw chain_complex.of_d,
    simp only [alternating_face_map_complex.obj_d, fin.sum_univ_two,
      fin.coe_zero, pow_zero, one_zsmul, fin.coe_one, pow_one, comp_add,
      neg_smul, one_zsmul, comp_neg, add_neg_eq_zero],
    erw [δ_comp_σ_self, δ_comp_σ_succ], },
  { rw [hσ'_eq_zero (nat.succ_pos q) (c_mk 1 0 rfl), zero_comp], },
end

/-- The maps `hσ' q n m hnm` are natural on the simplicial object -/
lemma hσ'_naturality (q : ℕ) (n m : ℕ) (hnm : c.rel m n)
  {X Y : simplicial_object C} (f : X ⟶ Y) :
  f.app (op [n]) ≫ hσ' q n m hnm = hσ' q n m hnm ≫ f.app (op [m]) :=
begin
  have h : n+1 = m := hnm,
  subst h,
  simp only [hσ', eq_to_hom_refl, comp_id],
  unfold hσ,
  split_ifs,
  { rw [zero_comp, comp_zero], },
  { simp only [zsmul_comp, comp_zsmul],
    erw f.naturality,
    refl, },
end

/-- For each q, `Hσ q` is a natural transformation. -/
def nat_trans_Hσ (q : ℕ) :
  alternating_face_map_complex C ⟶ alternating_face_map_complex C :=
{ app := λ X, Hσ q,
  naturality' := λ X Y f, begin
    unfold Hσ,
    rw [null_homotopic_map'_comp, comp_null_homotopic_map'],
    congr,
    ext n m hnm,
    simp only [alternating_face_map_complex_map, alternating_face_map_complex.map,
      chain_complex.of_hom_f, hσ'_naturality],
  end, }

/-- The maps `hσ' q n m hnm` are compatible with the application of additive functors. -/
lemma map_hσ' {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C)
  (q n m : ℕ) (hnm : c.rel m n) :
  (hσ' q n m hnm : K[((whiskering _ _).obj G).obj X].X n ⟶ _) =
    G.map (hσ' q n m hnm : K[X].X n ⟶ _) :=
begin
  unfold hσ' hσ,
  split_ifs,
  { simp only [functor.map_zero, zero_comp], },
  { simpa only [eq_to_hom_map, functor.map_comp, functor.map_zsmul], },
end

/-- The null homotopic maps `Hσ` are compatible with the application of additive functors. -/
lemma map_Hσ {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C) (q n : ℕ) :
  (Hσ q : K[((whiskering C D).obj G).obj X] ⟶ _).f n =
    G.map ((Hσ q : K[X] ⟶ _).f n) :=
begin
  unfold Hσ,
  have eq := homological_complex.congr_hom (map_null_homotopic_map' G (hσ' q)) n,
  simp only [functor.map_homological_complex_map_f, ← map_hσ'] at eq,
  rw eq,
  let h := (functor.congr_obj (map_alternating_face_map_complex G) X).symm,
  congr',
end

end dold_kan

end algebraic_topology


<|start_filename|>src/analysis/complex/removable_singularity.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.calculus.fderiv_analytic
import analysis.asymptotics.specific_asymptotics
import analysis.complex.cauchy_integral

/-!
# Removable singularity theorem

In this file we prove Riemann's removable singularity theorem: if `f : ℂ → E` is complex
differentiable in a punctured neighborhood of a point `c` and is bounded in a punctured neighborhood
of `c` (or, more generally, $f(z) - f(c)=o((z-c)^{-1})$), then it has a limit at `c` and the
function `function.update f c (lim (𝓝[≠] c) f)` is complex differentiable in a neighborhood of `c`.
-/

open topological_space metric set filter asymptotics function
open_locale topological_space filter nnreal

universe u
variables {E : Type u} [normed_group E] [normed_space ℂ E] [complete_space E]

namespace complex

/-- **Removable singularity** theorem, weak version. If `f : ℂ → E` is differentiable in a punctured
neighborhood of a point and is continuous at this point, then it is analytic at this point. -/
lemma analytic_at_of_differentiable_on_punctured_nhds_of_continuous_at {f : ℂ → E} {c : ℂ}
  (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z) (hc : continuous_at f c) :
  analytic_at ℂ f c :=
begin
  rcases (nhds_within_has_basis nhds_basis_closed_ball _).mem_iff.1 hd with ⟨R, hR0, hRs⟩,
  lift R to ℝ≥0 using hR0.le,
  replace hc : continuous_on f (closed_ball c R),
  { refine λ z hz, continuous_at.continuous_within_at _,
    rcases eq_or_ne z c with rfl | hne,
    exacts [hc, (hRs ⟨hz, hne⟩).continuous_at] },
  exact (has_fpower_series_on_ball_of_differentiable_off_countable (countable_singleton c) hc
    (λ z hz, hRs (diff_subset_diff_left ball_subset_closed_ball hz)) hR0).analytic_at
end

lemma differentiable_on_compl_singleton_and_continuous_at_iff {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hs : s ∈ 𝓝 c) : differentiable_on ℂ f (s \ {c}) ∧ continuous_at f c ↔ differentiable_on ℂ f s :=
begin
  refine ⟨_, λ hd, ⟨hd.mono (diff_subset _ _), (hd.differentiable_at hs).continuous_at⟩⟩,
  rintro ⟨hd, hc⟩ x hx,
  rcases eq_or_ne x c with rfl | hne,
  { refine (analytic_at_of_differentiable_on_punctured_nhds_of_continuous_at _ hc)
      .differentiable_at.differentiable_within_at,
    refine eventually_nhds_within_iff.2 ((eventually_mem_nhds.2 hs).mono $ λ z hz hzx, _),
    exact hd.differentiable_at (inter_mem hz (is_open_ne.mem_nhds hzx)) },
  { simpa only [differentiable_within_at, has_fderiv_within_at, hne.nhds_within_diff_singleton]
      using hd x ⟨hx, hne⟩ }
end

lemma differentiable_on_dslope {f : ℂ → E} {s : set ℂ} {c : ℂ} (hc : s ∈ 𝓝 c) :
  differentiable_on ℂ (dslope f c) s ↔ differentiable_on ℂ f s :=
⟨λ h, h.of_dslope, λ h, (differentiable_on_compl_singleton_and_continuous_at_iff hc).mp $
  ⟨iff.mpr (differentiable_on_dslope_of_nmem $ λ h, h.2 rfl) (h.mono $ diff_subset _ _),
    continuous_at_dslope_same.2 $ h.differentiable_at hc⟩⟩

/-- **Removable singularity** theorem: if `s` is a neighborhood of `c : ℂ`, a function `f : ℂ → E`
is complex differentiable on `s \ {c}`, and $f(z) - f(c)=o((z-c)^{-1})$, then `f` redefined to be
equal to `lim (𝓝[≠] c) f` at `c` is complex differentiable on `s`. -/
lemma differentiable_on_update_lim_of_is_o {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝 c) (hd : differentiable_on ℂ f (s \ {c}))
  (ho : (λ z, f z - f c) =o[𝓝[≠] c] (λ z, (z - c)⁻¹)) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) s :=
begin
  set F : ℂ → E := λ z, (z - c) • f z with hF,
  suffices : differentiable_on ℂ F (s \ {c}) ∧ continuous_at F c,
  { rw [differentiable_on_compl_singleton_and_continuous_at_iff hc, ← differentiable_on_dslope hc,
      dslope_sub_smul] at this; try { apply_instance },
    have hc : tendsto f (𝓝[≠] c) (𝓝 (deriv F c)),
      from continuous_at_update_same.mp (this.continuous_on.continuous_at hc),
    rwa hc.lim_eq },
  refine ⟨(differentiable_on_id.sub_const _).smul hd, _⟩,
  rw ← continuous_within_at_compl_self,
  have H := ho.tendsto_inv_smul_nhds_zero,
  have H' : tendsto (λ z, (z - c) • f c) (𝓝[≠] c) (𝓝 (F c)),
    from (continuous_within_at_id.tendsto.sub tendsto_const_nhds).smul tendsto_const_nhds,
  simpa [← smul_add, continuous_within_at] using H.add H'
end

/-- **Removable singularity** theorem: if `s` is a punctured neighborhood of `c : ℂ`, a function
`f : ℂ → E` is complex differentiable on `s`, and $f(z) - f(c)=o((z-c)^{-1})$, then `f` redefined to
be equal to `lim (𝓝[≠] c) f` at `c` is complex differentiable on `{c} ∪ s`. -/
lemma differentiable_on_update_lim_insert_of_is_o {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝[≠] c) (hd : differentiable_on ℂ f s)
  (ho : (λ z, f z - f c) =o[𝓝[≠] c] (λ z, (z - c)⁻¹)) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) (insert c s) :=
differentiable_on_update_lim_of_is_o (insert_mem_nhds_iff.2 hc)
  (hd.mono $ λ z hz, hz.1.resolve_left hz.2) ho

/-- **Removable singularity** theorem: if `s` is a neighborhood of `c : ℂ`, a function `f : ℂ → E`
is complex differentiable and is bounded on `s \ {c}`, then `f` redefined to be equal to
`lim (𝓝[≠] c) f` at `c` is complex differentiable on `s`. -/
lemma differentiable_on_update_lim_of_bdd_above {f : ℂ → E} {s : set ℂ} {c : ℂ}
  (hc : s ∈ 𝓝 c) (hd : differentiable_on ℂ f (s \ {c}))
  (hb : bdd_above (norm ∘ f '' (s \ {c}))) :
  differentiable_on ℂ (update f c (lim (𝓝[≠] c) f)) s :=
differentiable_on_update_lim_of_is_o hc hd $ is_bounded_under.is_o_sub_self_inv $
  let ⟨C, hC⟩ := hb in ⟨C + ∥f c∥, eventually_map.2 $ mem_nhds_within_iff_exists_mem_nhds_inter.2
    ⟨s, hc, λ z hz, norm_sub_le_of_le (hC $ mem_image_of_mem _ hz) le_rfl⟩⟩

/-- **Removable singularity** theorem: if a function `f : ℂ → E` is complex differentiable on a
punctured neighborhood of `c` and $f(z) - f(c)=o((z-c)^{-1})$, then `f` has a limit at `c`. -/
lemma tendsto_lim_of_differentiable_on_punctured_nhds_of_is_o {f : ℂ → E} {c : ℂ}
  (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z)
  (ho : (λ z, f z - f c) =o[𝓝[≠] c] (λ z, (z - c)⁻¹)) :
  tendsto f (𝓝[≠] c) (𝓝 $ lim (𝓝[≠] c) f) :=
begin
  rw eventually_nhds_within_iff at hd,
  have : differentiable_on ℂ f ({z | z ≠ c → differentiable_at ℂ f z} \ {c}),
    from λ z hz, (hz.1 hz.2).differentiable_within_at,
  have H := differentiable_on_update_lim_of_is_o hd this ho,
  exact continuous_at_update_same.1 (H.differentiable_at hd).continuous_at
end

/-- **Removable singularity** theorem: if a function `f : ℂ → E` is complex differentiable and
bounded on a punctured neighborhood of `c`, then `f` has a limit at `c`. -/
lemma tendsto_lim_of_differentiable_on_punctured_nhds_of_bounded_under {f : ℂ → E}
  {c : ℂ} (hd : ∀ᶠ z in 𝓝[≠] c, differentiable_at ℂ f z)
  (hb : is_bounded_under (≤) (𝓝[≠] c) (λ z, ∥f z - f c∥)) :
  tendsto f (𝓝[≠] c) (𝓝 $ lim (𝓝[≠] c) f) :=
tendsto_lim_of_differentiable_on_punctured_nhds_of_is_o hd hb.is_o_sub_self_inv

end complex


<|start_filename|>src/tactic/linear_combination.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/

import tactic.ring

/-!

# linear_combination Tactic

In this file, the `linear_combination` tactic is created.  This tactic, which
works over `ring`s, attempts to prove the target by creating and applying a
linear combination of a list of equalities.  This file also includes a
definition for `linear_combination_config`.  A `linear_combination_config`
object can be passed into the tactic, allowing the user to specify a
normalization tactic.

## Implementation Notes

This tactic works by creating a weighted sum of the given equations with the
given coefficients.  Then, it subtracts the right side of the weighted sum
from the left side so that the right side equals 0, and it does the same with
the target.  Afterwards, it sets the goal to be the equality between the
lefthand side of the new goal and the lefthand side of the new weighted sum.
Lastly, it uses a normalization tactic to see if the weighted sum is equal
to the target.

## References

* <https://leanprover.zulipchat.com/#narrow/stream/239415-metaprogramming-.2F.20tactics/topic/Linear.20algebra.20tactic/near/213928196>

-/

namespace linear_combo
open tactic

/-! ### Lemmas -/

lemma left_mul_both_sides {α} [h : has_mul α] {x y : α} (z : α) (h1 : x = y) :
  z * x = z * y :=
congr_arg (has_mul.mul z) h1

lemma sum_two_equations {α} [h : has_add α] {x1 y1 x2 y2 : α} (h1 : x1 = y1)
  (h2: x2 = y2) : x1 + x2 = y1 + y2 :=
congr (congr_arg has_add.add h1) h2

lemma left_minus_right {α} [h : add_group α] {x y : α} (h1 : x = y) :
  x - y = 0 :=
sub_eq_zero.mpr h1

lemma all_on_left_equiv {α} [h : add_group α] (x y : α) :
  (x = y) = (x - y = 0) :=
propext (⟨left_minus_right, sub_eq_zero.mp⟩)

lemma replace_eq_expr {α} [h : has_zero α] {x y : α} (h1 : x = 0) (h2 : y = x) :
  y = 0 :=
by rwa h2


/-! ### Configuration -/


/--
A configuration object for `linear_combination`.

`normalize` describes whether or not the normalization step should be used.

`normalization_tactic` describes the tactic used for normalization when
checking if the weighted sum is equivalent to the goal (when `normalize` is `tt`).
-/
meta structure linear_combination_config : Type :=
(normalize : bool := tt)
(normalization_tactic : tactic unit := `[ring1])


/-! ### Part 1: Multiplying Equations by Constants and Adding Them Together -/


/--
Given that `lhs = rhs`, this tactic returns an `expr` proving that
  `coeff * lhs = coeff * rhs`.

* Input:
  * `h_equality` : an `expr`, whose type should be an equality between terms of
      type `α`, where there is an instance of `has_mul α`
  * `coeff` : a `pexpr`, which should be a value of type `α`

* Output: an `expr`, which proves that the result of multiplying both sides
    of `h_equality` by the `coeff` holds
-/
meta def mul_equality_expr (h_equality : expr) (coeff : pexpr) : tactic expr :=
do
  `(%%lhs = %%rhs) ← infer_type h_equality,
  -- Mark the coefficient as having the same type as the sides of `h_equality` -
  --   this is necessary in order to use the left_mul_both_sides lemma
  left_type ← infer_type lhs,
  coeff_expr ← to_expr ``(%%coeff : %%left_type),
  mk_app ``left_mul_both_sides [coeff_expr, h_equality]

/--
Given two hypotheses that `a = b` and `c = d`, this tactic returns an `expr` proving
  that `a + c = b + d`.

* Input:
  * `h_equality1` : an `expr`, whose type should be an equality between terms of
      type `α`, where there is an instance of `has_add α`
  * `h_equality2` : an `expr`, whose type should be an equality between terms of
      type `α`

* Output: an `expr`, which proves that the result of adding the two
    equalities holds
-/
meta def sum_equalities (h_equality1 h_equality2 : expr) : tactic expr :=
mk_app ``sum_two_equations [h_equality1, h_equality2]

/--
Given that `a = b` and `c = d`, along with a coefficient, this tactic returns an
  `expr` proving that `a + coeff * c = b + coeff * d`.

* Input:
  * `h_equality1` : an `expr`, whose type should be an equality between terms of
      type `α`, where there are instances of `has_add α` and `has_mul α`
  * `h_equality2` : an `expr`, whose type should be an equality between terms of
      type `α`
  * `coeff_for_eq2` : a `pexpr`, which should be a value of type `α`

* Output: an `expr`, which proves that the result of adding the first
  equality to the result of multiplying `coeff_for_eq2` by the second equality
  holds
-/
meta def sum_two_hyps_one_mul_helper (h_equality1 h_equality2 : expr)
  (coeff_for_eq2 : pexpr) : tactic expr :=
mul_equality_expr h_equality2 coeff_for_eq2 >>= sum_equalities h_equality1

/--
Given that `l_sum1 = r_sum1`, `l_h1 = r_h1`, ..., `l_hn = r_hn`, and given
  coefficients `c_1`, ..., `c_n`, this tactic returns an `expr` proving that
    `l_sum1 + (c_1 * l_h1) + ... + (c_n * l_hn)`
  `= r_sum1 + (c_1 * r_h1) + ... + (c_n * r_hn)`

* Input:
  * `expected_tp`: the type of the terms being compared in the target equality
  * an `option (tactic expr)` : `none`, if there is no sum to add to yet, or
      `some` containing the base summation equation
  * a `list name` : a list of names, referring to equalities in the local context
  * a `list pexpr` : a list of coefficients to be multiplied with the
      corresponding equalities in the list of names

* Output: an `expr`, which proves that the weighted sum of the given
    equalities added to the base equation holds
-/
meta def make_sum_of_hyps_helper (expected_tp : expr) :
  option (tactic expr) → list expr → list pexpr → tactic expr
| none [] []                                                             :=
  to_expr ``(rfl : (0 : %%expected_tp) = 0)
| (some tactic_hcombo) [] []                                             :=
  do tactic_hcombo
| none (h_equality :: h_eqs_names) (coeff :: coeffs)                 :=
 do
    -- This is the first equality, and we do not have anything to add to it
    -- h_equality ← get_local h_equality_nam,
    `(@eq %%eqtp _ _) ← infer_type h_equality |
      fail!"{h_equality} is expected to be a proof of an equality",
    is_def_eq eqtp expected_tp <|>
      fail!("{h_equality} is an equality between terms of type {eqtp}, but is expected to be" ++
        " between terms of type {expected_tp}"),
    make_sum_of_hyps_helper
      (some (mul_equality_expr h_equality coeff))
      h_eqs_names
      coeffs
| (some tactic_hcombo) (h_equality :: h_eqs_names) (coeff :: coeffs) :=
  do
    -- h_equality ← get_local h_equality_nam,
    hcombo ← tactic_hcombo,
    -- We want to add this weighted equality to the current equality in
    --   the hypothesis
    make_sum_of_hyps_helper
      (some (sum_two_hyps_one_mul_helper hcombo h_equality coeff))
      h_eqs_names
      coeffs
| _ _ _                                                                  :=
  do fail ("The length of the input list of equalities should be the " ++
    "same as the length of the input list of coefficients")

/--
Given a list of names referencing equalities and a list of pexprs representing
  coefficients, this tactic proves that a weighted sum of the equalities
  (where each equation is multiplied by the corresponding coefficient) holds.

* Input:
  * `expected_tp`: the type of the terms being compared in the target equality
  * `h_eqs_names` : a list of names, referring to equalities in the local
      context
  * `coeffs` : a list of coefficients to be multiplied with the corresponding
      equalities in the list of names

* Output: an `expr`, which proves that the weighted sum of the equalities
    holds
-/
meta def make_sum_of_hyps (expected_tp : expr) (h_eqs_names : list expr) (coeffs : list pexpr) :
  tactic expr :=
make_sum_of_hyps_helper expected_tp none h_eqs_names coeffs

/-! ### Part 2: Simplifying -/


/--
This tactic proves that the result of moving all the terms in an equality to
  the left side of the equals sign by subtracting the right side of the
  equation from the left side holds.  In other words, given `lhs = rhs`,
  this tactic proves that `lhs - rhs = 0`.

* Input:
  * `h_equality` : an `expr`, whose type should be an equality between terms of
      type `α`, where there is an instance of `add_group α`

* Output: an `expr`, which proves that `lhs - rhs = 0`, where `lhs` and `rhs` are
   the left and right sides of `h_equality` respectively
-/
meta def move_to_left_side (h_equality : expr) : tactic expr :=
mk_app ``left_minus_right [h_equality]

/--
This tactic replaces the target with the result of moving all the terms in the
  target to the left side of the equals sign by subtracting the right side of
  the equation from the left side.  In other words, when the target is
  lhs = rhs, this tactic proves that `lhs - rhs = 0` and replaces the target
  with this new equality.
Note: The target must be an equality when this tactic is called, and the
  equality must have some type `α` on each side, where there is an instance of
  `add_group α`.

* Input: N/A

* Output: N/A
-/
meta def move_target_to_left_side : tactic unit :=
do
  -- Move all the terms in the target equality to the left side
  target ← target,
  (targ_lhs, targ_rhs) ← match_eq target,
  target_left_eq ← to_expr ``(%%targ_lhs - %%targ_rhs = 0),
  mk_app ``all_on_left_equiv [targ_lhs, targ_rhs] >>= replace_target target_left_eq


/-! ### Part 3: Matching the Linear Combination to the Target -/


/--
This tactic changes the goal to be that the lefthand side of the target is
  equal to the lefthand side of the given expression.  For example,
  if `hsum_on_left` is `5*x - 5*y = 0`, and the target is `-5*y + 5*x = 0`, this
  tactic will change the target to be `-5*y + 5*x = 5*x - 5*y`.

This tactic only should be used when the target's type an equality whose
  right side is 0.

* Input:
  * `hsum_on_left` : expr, whose type should be an equality with 0 on the right
      side of the equals sign

* Output: N/A
-/
meta def set_goal_to_hleft_eq_tleft (hsum_on_left : expr) : tactic unit :=
do to_expr ``(replace_eq_expr %%hsum_on_left) >>= apply, skip

/--
This tactic attempts to prove the goal by normalizing the target if the
`normalize` field of the given configuration is true.

* Input:
  * `config` : a `linear_combination_config`, which determines the tactic used
      for normalization if normalization is done

* Output: N/A
-/
meta def prove_equal_if_desired (config : linear_combination_config) :
  tactic unit :=
when config.normalize config.normalization_tactic

/-! ### Part 4: Completed Tactic -/


/--
This is a tactic that attempts to prove the target by creating and applying a
  linear combination of a list of equalities.  (If the `normalize` field of the
  configuration is set to ff, then the tactic will simply set the user up to
  prove their target using the linear combination instead of attempting to
  finish the proof.)

Note: The left and right sides of all the equalities should have the same
  ring type, and the coefficients should also have this type.  There must be
  instances of `has_mul` and `add_group` for this type.  Also note that the
  target must involve at least one variable.

* Input:
  * `h_eqs_names` : a list of names, referring to equations in the local
      context
  * `coeffs` : a list of coefficients to be multiplied with the corresponding
    equations in the list of names
  * `config` : a `linear_combination_config`, which determines the tactic used
      for normalization; by default, this value is the standard configuration
      for a `linear_combination_config`

* Output: N/A
-/
meta def linear_combination (h_eqs_names : list pexpr) (coeffs : list pexpr)
  (config : linear_combination_config := {}) : tactic unit :=
do
  `(@eq %%ext _ _) ← target | fail "linear_combination can only be used to prove equality goals",
  h_eqs ← h_eqs_names.mmap to_expr,
  hsum ← make_sum_of_hyps ext h_eqs coeffs,
  hsum_on_left ← move_to_left_side hsum,
  move_target_to_left_side,
  set_goal_to_hleft_eq_tleft hsum_on_left,
  prove_equal_if_desired config

/-- `mk_mul [p₀, p₁, ..., pₙ]` produces the pexpr `p₀ * p₁ * ... * pₙ`. -/
meta def mk_mul : list pexpr → pexpr
| [] := ``(1)
| [e] := e
| (e::es) := ``(%%e * %%(mk_mul es))

/--
`as_linear_combo neg ms e` is used to parse the argument to `linear_combination`.
This argument is a sequence of literals `x`, `-x`, or `c*x` combined with `+` or `-`,
given by the pexpr `e`.
The `neg` and `ms` arguments are used recursively; called at the top level, its usage should be
`as_linear_combo ff [] e`.
-/
meta def as_linear_combo : bool → list pexpr → pexpr → list (pexpr × pexpr)
| neg ms e :=
  let (head, args) := pexpr.get_app_fn_args e in
  match head.get_frozen_name, args with
  | ``has_add.add, [e1, e2] := as_linear_combo neg ms e1 ++ as_linear_combo neg ms e2
  | ``has_sub.sub, [e1, e2] := as_linear_combo neg ms e1 ++ as_linear_combo (bnot neg) ms e2
  | ``has_mul.mul, [e1, e2] := as_linear_combo neg (e1::ms) e2
  | ``has_neg.neg, [e1] := as_linear_combo (bnot neg) ms e1
  | _, _ := let m := mk_mul ms in [(e, if neg then ``(-%%m) else m)]
  end

section interactive_mode
setup_tactic_parser

/--
`linear_combination` attempts to prove the target by creating and applying a
  linear combination of a list of equalities.  The tactic will create a linear
  combination by adding the equalities together from left to right, so the order
  of the input hypotheses does matter.  If the `normalize` field of the
  configuration is set to false, then the tactic will simply set the user up to
  prove their target using the linear combination instead of attempting to
  finish the proof.

Note: The left and right sides of all the equalities should have the same
  type, and the coefficients should also have this type.  There must be
  instances of `has_mul` and `add_group` for this type.

* Input:
  * `input` : the linear combination of proofs of equalities, given as a sum/difference
      of coefficients multiplied by expressions. The coefficients may be arbitrary
      pre-expressions; if a coefficient is an application of `+` or `-` it should be
      surrounded by parentheses. The expressions can be arbitrary proof terms proving
      equalities. Most commonly they are hypothesis names `h1, h2, ...`.

      If a coefficient is omitted, it is taken to be `1`.
  * `config` : a `linear_combination_config`, which determines the tactic used
      for normalization; by default, this value is the standard configuration
      for a linear_combination_config.  In the standard configuration,
      `normalize` is set to tt (meaning this tactic is set to use
      normalization), and `normalization_tactic` is set to  `ring1`.

Example Usage:
```
example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination 1*h1 - 2*h2

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination h1 - 2*h2

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  -3*x - 3*y - 4*z = 2 :=
by linear_combination ha - hb - 2*hc

example (x y : ℚ) (h1 : x + y = 3) (h2 : 3*x = 7) :
  x*x*y + y*x*y + 6*x = 3*x*y + 14 :=
by linear_combination x*y*h1 + 2*h2

example (x y : ℤ) (h1 : x = -3) (h2 : y = 10) :
  2*x = -6 :=
begin
  linear_combination 2*h1 with {normalize := ff},
  simp,
  norm_cast
end

constants (qc : ℚ) (hqc : qc = 2*qc)

example (a b : ℚ) (h : ∀ p q : ℚ, p = q) : 3*a + qc = 3*b + 2*qc :=
by linear_combination 3 * h a b + hqc
```
-/
meta def _root_.tactic.interactive.linear_combination
  (input : parse (as_linear_combo ff [] <$> texpr)?)
  (_ : parse (tk "with")?)
  (config : linear_combination_config := {})
  : tactic unit :=
let (h_eqs_names, coeffs) := list.unzip (input.get_or_else []) in
linear_combination h_eqs_names coeffs config

add_tactic_doc
{ name := "linear_combination",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.linear_combination],
  tags := ["arithmetic"] }

end interactive_mode
end linear_combo


<|start_filename|>src/algebra/lie/engel.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import algebra.lie.nilpotent
import algebra.lie.centralizer

/-!
# Engel's theorem

This file contains a proof of Engel's theorem providing necessary and sufficient conditions for Lie
algebras and Lie modules to be nilpotent.

The key result `lie_module.is_nilpotent_iff_forall` says that if `M` is a Lie module of a
Noetherian Lie algebra `L`, then `M` is nilpotent iff the image of `L → End(M)` consists of
nilpotent elements. In the special case that we have the adjoint representation `M = L`, this says
that a Lie algebra is nilpotent iff `ad x : End(L)` is nilpotent for all `x : L`.

Engel's theorem is true for any coefficients (i.e., it is really a theorem about Lie rings) and so
we work with coefficients in any commutative ring `R` throughout.

On the other hand, Engel's theorem is not true for infinite-dimensional Lie algebras and so a
finite-dimensionality assumption is required. We prove the theorem subject to the the assumption
that the Lie algebra is Noetherian as an `R`-module, though actually we only need the slightly
weaker property that the relation `>` is well-founded on the complete lattice of Lie subalgebras.

## Remarks about the proof

Engel's theorem is usually proved in the special case that the coefficients are a field, and uses
an inductive argument on the dimension of the Lie algebra. One begins by choosing either a maximal
proper Lie subalgebra (in some proofs) or a maximal nilpotent Lie subalgebra (in other proofs, at
the cost of obtaining a weaker end result).

Since we work with general coefficients, we cannot induct on dimension and an alternate approach
must be taken. The key ingredient is the concept of nilpotency, not just for Lie algebras, but for
Lie modules. Using this concept, we define an _Engelian Lie algebra_ `lie_algebra.is_engelian` to
be one for which a Lie module is nilpotent whenever the action consists of nilpotent endomorphisms.
The argument then proceeds by selecting a maximal Engelian Lie subalgebra and showing that it cannot
be proper.

The first part of the traditional statement of Engel's theorem consists of the statement that if `M`
is a non-trivial `R`-module and `L ⊆ End(M)` is a finite-dimensional Lie subalgebra of nilpotent
elements, then there exists a non-zero element `m : M` that is annihilated by every element of `L`.
This follows trivially from the result established here `lie_module.is_nilpotent_iff_forall`, that
`M` is a nilpotent Lie module over `L`, since the last non-zero term in the lower central series
will consist of such elements `m` (see: `lie_module.nontrivial_max_triv_of_is_nilpotent`). It seems
that this result has not previously been established at this level of generality.

The second part of the traditional statement of Engel's theorem concerns nilpotency of the Lie
algebra and a proof of this for general coefficients appeared in the literature as long ago
[as 1937](zorn1937). This also follows trivially from `lie_module.is_nilpotent_iff_forall` simply by
taking `M = L`.

It is pleasing that the two parts of the traditional statements of Engel's theorem are thus unified
into a single statement about nilpotency of Lie modules. This is not usually emphasised.

## Main definitions

  * `lie_algebra.is_engelian`
  * `lie_algebra.is_engelian_of_is_noetherian`
  * `lie_module.is_nilpotent_iff_forall`
  * `lie_algebra.is_nilpotent_iff_forall`

-/

universes u₁ u₂ u₃ u₄

variables {R : Type u₁} {L : Type u₂} {L₂ : Type u₃} {M : Type u₄}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L₂] [lie_algebra R L₂]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]

include R L

namespace lie_submodule

open lie_module

variables {I : lie_ideal R L} {x : L} (hxI : (R ∙ x) ⊔ I = ⊤)

include hxI

lemma exists_smul_add_of_span_sup_eq_top (y : L) : ∃ (t : R) (z ∈ I), y = t • x + z :=
begin
  have hy : y ∈ (⊤ : submodule R L) := submodule.mem_top,
  simp only [← hxI, submodule.mem_sup, submodule.mem_span_singleton] at hy,
  obtain ⟨-, ⟨t, rfl⟩, z, hz, rfl⟩ := hy,
  exact ⟨t, z, hz, rfl⟩,
end

lemma lie_top_eq_of_span_sup_eq_top (N : lie_submodule R L M) :
  (↑⁅(⊤ : lie_ideal R L), N⁆ : submodule R M) =
  (N : submodule R M).map (to_endomorphism R L M x) ⊔ (↑⁅I, N⁆ : submodule R M) :=
begin
  simp only [lie_ideal_oper_eq_linear_span', submodule.sup_span, mem_top, exists_prop,
    exists_true_left, submodule.map_coe, to_endomorphism_apply_apply],
  refine le_antisymm (submodule.span_le.mpr _) (submodule.span_mono (λ z hz, _)),
  { rintros z ⟨y, n, hn : n ∈ N, rfl⟩,
    obtain ⟨t, z, hz, rfl⟩ := exists_smul_add_of_span_sup_eq_top hxI y,
    simp only [set_like.mem_coe, submodule.span_union, submodule.mem_sup],
    exact ⟨t • ⁅x, n⁆, submodule.subset_span ⟨t • n, N.smul_mem' t hn, lie_smul t x n⟩,
      ⁅z, n⁆, submodule.subset_span ⟨z, hz, n, hn, rfl⟩, by simp⟩, },
  { rcases hz with ⟨m, hm, rfl⟩ | ⟨y, hy, m, hm, rfl⟩,
    exacts [⟨x, m, hm, rfl⟩, ⟨y, m, hm, rfl⟩], },
end

lemma lcs_le_lcs_of_is_nilpotent_span_sup_eq_top {n i j : ℕ} (hxn : (to_endomorphism R L M x)^n = 0)
  (hIM : lower_central_series R L M i ≤ I.lcs M j) :
  lower_central_series R L M (i + n) ≤ I.lcs M (j + 1) :=
begin
  suffices : ∀ l, ((⊤ : lie_ideal R L).lcs M (i + l) : submodule R M) ≤
    (I.lcs M j : submodule R M).map
    ((to_endomorphism R L M x)^l) ⊔ (I.lcs M (j + 1) : submodule R M),
  { simpa only [bot_sup_eq, lie_ideal.incl_coe, submodule.map_zero, hxn] using this n, },
  intros l,
  induction l with l ih,
  { simp only [add_zero, lie_ideal.lcs_succ, pow_zero, linear_map.one_eq_id, submodule.map_id],
    exact le_sup_of_le_left hIM, },
  { simp only [lie_ideal.lcs_succ, i.add_succ l, lie_top_eq_of_span_sup_eq_top hxI, sup_le_iff],
    refine ⟨(submodule.map_mono ih).trans _, le_sup_of_le_right _⟩,
    { rw [submodule.map_sup, ← submodule.map_comp, ← linear_map.mul_eq_comp, ← pow_succ,
        ← I.lcs_succ],
      exact sup_le_sup_left coe_map_to_endomorphism_le _, },
    { refine le_trans (mono_lie_right _ _ I _) (mono_lie_right _ _ I hIM),
      exact antitone_lower_central_series R L M le_self_add, }, },
end

lemma is_nilpotent_of_is_nilpotent_span_sup_eq_top
  (hnp : is_nilpotent $ to_endomorphism R L M x) (hIM : is_nilpotent R I M) :
  is_nilpotent R L M :=
begin
  obtain ⟨n, hn⟩ := hnp,
  unfreezingI { obtain ⟨k, hk⟩ := hIM, },
  have hk' : I.lcs M k = ⊥,
  { simp only [← coe_to_submodule_eq_iff, I.coe_lcs_eq, hk, bot_coe_submodule], },
  suffices : ∀ l, lower_central_series R L M (l * n) ≤ I.lcs M l,
  { use k * n,
    simpa [hk'] using this k, },
  intros l,
  induction l with l ih,
  { simp, },
  { exact (l.succ_mul n).symm ▸ lcs_le_lcs_of_is_nilpotent_span_sup_eq_top hxI hn ih, },
end

end lie_submodule

section lie_algebra

open lie_module (hiding is_nilpotent)

variables (R L)

/-- A Lie algebra `L` is said to be Engelian if a sufficient condition for any `L`-Lie module `M` to
be nilpotent is that the image of the map `L → End(M)` consists of nilpotent elements.

Engel's theorem `lie_algebra.is_engelian_of_is_noetherian` states that any Noetherian Lie algebra is
Engelian. -/
def lie_algebra.is_engelian : Prop :=
  ∀ (M : Type u₄) [add_comm_group M], by exactI ∀ [module R M] [lie_ring_module L M], by exactI ∀
    [lie_module R L M], by exactI ∀ (h : ∀ (x : L), is_nilpotent (to_endomorphism R L M x)),
    lie_module.is_nilpotent R L M

variables {R L}

lemma lie_algebra.is_engelian_of_subsingleton [subsingleton L] : lie_algebra.is_engelian R L :=
begin
  intros M _i1 _i2 _i3 _i4 h,
  use 1,
  suffices : (⊤ : lie_ideal R L) = ⊥, { simp [this], },
  haveI := (lie_submodule.subsingleton_iff R L L).mpr infer_instance,
  apply subsingleton.elim,
end

lemma function.surjective.is_engelian
  {f : L →ₗ⁅R⁆ L₂} (hf : function.surjective f) (h : lie_algebra.is_engelian.{u₁ u₂ u₄} R L) :
  lie_algebra.is_engelian.{u₁ u₃ u₄} R L₂ :=
begin
  introsI M _i1 _i2 _i3 _i4 h',
  letI : lie_ring_module L M := lie_ring_module.comp_lie_hom M f,
  letI : lie_module R L M := comp_lie_hom M f,
  have hnp : ∀ x, is_nilpotent (to_endomorphism R L M x) := λ x, h' (f x),
  have surj_id : function.surjective (linear_map.id : M →ₗ[R] M) := function.surjective_id,
  haveI : lie_module.is_nilpotent R L M := h M hnp,
  apply hf.lie_module_is_nilpotent surj_id,
  simp,
end

lemma lie_equiv.is_engelian_iff (e : L ≃ₗ⁅R⁆ L₂) :
  lie_algebra.is_engelian.{u₁ u₂ u₄} R L ↔ lie_algebra.is_engelian.{u₁ u₃ u₄} R L₂ :=
⟨e.surjective.is_engelian, e.symm.surjective.is_engelian⟩

lemma lie_algebra.exists_engelian_lie_subalgebra_of_lt_normalizer
  {K : lie_subalgebra R L} (hK₁ : lie_algebra.is_engelian.{u₁ u₂ u₄} R K) (hK₂ : K < K.normalizer) :
  ∃ (K' : lie_subalgebra R L) (hK' : lie_algebra.is_engelian.{u₁ u₂ u₄} R K'), K < K' :=
begin
  obtain ⟨x, hx₁, hx₂⟩ := set_like.exists_of_lt hK₂,
  let K' : lie_subalgebra R L :=
  { lie_mem' := λ y z, lie_subalgebra.lie_mem_sup_of_mem_normalizer hx₁,
    .. (R ∙ x) ⊔ (K : submodule R L) },
  have hxK' : x ∈ K' := submodule.mem_sup_left (submodule.subset_span (set.mem_singleton _)),
  have hKK' : K ≤ K' := (lie_subalgebra.coe_submodule_le_coe_submodule K K').mp le_sup_right,
  have hK' : K' ≤ K.normalizer,
  { rw ← lie_subalgebra.coe_submodule_le_coe_submodule,
    exact sup_le ((submodule.span_singleton_le_iff_mem _ _).mpr hx₁) hK₂.le, },
  refine ⟨K', _, lt_iff_le_and_ne.mpr ⟨hKK', λ contra, hx₂ (contra.symm ▸ hxK')⟩⟩,
  introsI M _i1 _i2 _i3 _i4 h,
  obtain ⟨I, hI₁ : (I : lie_subalgebra R K') = lie_subalgebra.of_le hKK'⟩ :=
    lie_subalgebra.exists_nested_lie_ideal_of_le_normalizer hKK' hK',
  have hI₂ : (R ∙ (⟨x, hxK'⟩ : K')) ⊔ I = ⊤,
  { rw [← lie_ideal.coe_to_lie_subalgebra_to_submodule R K' I, hI₁],
    apply submodule.map_injective_of_injective (K' : submodule R L).injective_subtype,
    simpa, },
  have e : K ≃ₗ⁅R⁆ I := (lie_subalgebra.equiv_of_le hKK').trans
    (lie_equiv.of_eq _ _ ((lie_subalgebra.coe_set_eq _ _).mpr hI₁.symm)),
  have hI₃ : lie_algebra.is_engelian R I := e.is_engelian_iff.mp hK₁,
  exact lie_submodule.is_nilpotent_of_is_nilpotent_span_sup_eq_top hI₂ (h _) (hI₃ _ (λ x, h x)),
end

local attribute [instance] lie_subalgebra.subsingleton_bot

variables [is_noetherian R L]

/-- *Engel's theorem*.

Note that this implies all traditional forms of Engel's theorem via
`lie_module.nontrivial_max_triv_of_is_nilpotent`, `lie_module.is_nilpotent_iff_forall`,
`lie_algebra.is_nilpotent_iff_forall`. -/
lemma lie_algebra.is_engelian_of_is_noetherian : lie_algebra.is_engelian R L :=
begin
  introsI M _i1 _i2 _i3 _i4 h,
  rw ← is_nilpotent_range_to_endomorphism_iff,
  let L' := (to_endomorphism R L M).range,
  replace h : ∀ (y : L'), is_nilpotent (y : module.End R M),
  { rintros ⟨-, ⟨y, rfl⟩⟩,
    simp [h], },
  change lie_module.is_nilpotent R L' M,
  let s := { K : lie_subalgebra R L' | lie_algebra.is_engelian R K },
  have hs : s.nonempty := ⟨⊥, lie_algebra.is_engelian_of_subsingleton⟩,
  suffices : ⊤ ∈ s,
  { rw ← is_nilpotent_of_top_iff,
    apply this M,
    simp [lie_subalgebra.to_endomorphism_eq, h], },
  have : ∀ (K ∈ s), K ≠ ⊤ → ∃ (K' ∈ s), K < K',
  { rintros K (hK₁ : lie_algebra.is_engelian R K) hK₂,
    apply lie_algebra.exists_engelian_lie_subalgebra_of_lt_normalizer hK₁,
    apply lt_of_le_of_ne K.le_normalizer,
    rw [ne.def, eq_comm, K.normalizer_eq_self_iff, ← ne.def,
      ← lie_submodule.nontrivial_iff_ne_bot R K],
    haveI : nontrivial (L' ⧸ K.to_lie_submodule),
    { replace hK₂ : K.to_lie_submodule ≠ ⊤ :=
        by rwa [ne.def, ← lie_submodule.coe_to_submodule_eq_iff, K.coe_to_lie_submodule,
          lie_submodule.top_coe_submodule, ← lie_subalgebra.top_coe_submodule,
          K.coe_to_submodule_eq_iff],
      exact submodule.quotient.nontrivial_of_lt_top _ hK₂.lt_top, },
    haveI : lie_module.is_nilpotent R K (L' ⧸ K.to_lie_submodule),
    { refine hK₁ _ (λ x, _),
      have hx := lie_algebra.is_nilpotent_ad_of_is_nilpotent (h x),
      exact module.End.is_nilpotent.mapq _ hx, },
    exact nontrivial_max_triv_of_is_nilpotent R K (L' ⧸ K.to_lie_submodule), },
  haveI _i5 : is_noetherian R L' :=
    is_noetherian_of_surjective L _ (linear_map.range_range_restrict (to_endomorphism R L M)),
  obtain ⟨K, hK₁, hK₂⟩ :=
    well_founded.well_founded_iff_has_max'.mp (lie_subalgebra.well_founded_of_noetherian R L') s hs,
  have hK₃ : K = ⊤,
  { by_contra contra,
    obtain ⟨K', hK'₁, hK'₂⟩ := this K hK₁ contra,
    specialize hK₂ K' hK'₁ (le_of_lt hK'₂),
    replace hK'₂ := (ne_of_lt hK'₂).symm,
    contradiction, },
  exact hK₃ ▸ hK₁,
end

/-- Engel's theorem. -/
lemma lie_module.is_nilpotent_iff_forall :
  lie_module.is_nilpotent R L M ↔ ∀ x, is_nilpotent $ to_endomorphism R L M x :=
⟨begin
  introsI h,
  obtain ⟨k, hk⟩ := nilpotent_endo_of_nilpotent_module R L M,
  exact λ x, ⟨k, hk x⟩,
end,
λ h, lie_algebra.is_engelian_of_is_noetherian M h⟩

/-- Engel's theorem. -/
lemma lie_algebra.is_nilpotent_iff_forall :
  lie_algebra.is_nilpotent R L ↔ ∀ x, is_nilpotent $ lie_algebra.ad R L x :=
lie_module.is_nilpotent_iff_forall

end lie_algebra


<|start_filename|>src/algebra/group/ext.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import algebra.hom.group

/-!
# Extensionality lemmas for monoid and group structures

In this file we prove extensionality lemmas for `monoid` and higher algebraic structures with one
binary operation. Extensionality lemmas for structures that are lower in the hierarchy can be found
in `algebra.group.defs`.

## Implementation details

To get equality of `npow` etc, we define a monoid homomorphism between two monoid structures on the
same type, then apply lemmas like `monoid_hom.map_div`, `monoid_hom.map_pow` etc.

## Tags
monoid, group, extensionality
-/

universe u

@[ext, to_additive]
lemma monoid.ext {M : Type u} ⦃m₁ m₂ : monoid M⦄ (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
begin
  have h₁ : (@monoid.to_mul_one_class _ m₁).one = (@monoid.to_mul_one_class _ m₂).one,
    from congr_arg (@mul_one_class.one M) (mul_one_class.ext h_mul),
  set f : @monoid_hom M M (@monoid.to_mul_one_class _ m₁) (@monoid.to_mul_one_class _ m₂) :=
    { to_fun := id, map_one' := h₁, map_mul' := λ x y, congr_fun (congr_fun h_mul x) y },
  have hpow : m₁.npow = m₂.npow, by { ext n x, exact @monoid_hom.map_pow M M m₁ m₂ f x n },
  unfreezingI { cases m₁, cases m₂ },
  congr; assumption
end

@[to_additive]
lemma comm_monoid.to_monoid_injective {M : Type u} :
  function.injective (@comm_monoid.to_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma comm_monoid.ext {M : Type*} ⦃m₁ m₂ : comm_monoid M⦄ (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
comm_monoid.to_monoid_injective $ monoid.ext h_mul

@[to_additive]
lemma left_cancel_monoid.to_monoid_injective {M : Type u} :
  function.injective (@left_cancel_monoid.to_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma left_cancel_monoid.ext {M : Type u} ⦃m₁ m₂ : left_cancel_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
left_cancel_monoid.to_monoid_injective $ monoid.ext h_mul

@[to_additive]
lemma right_cancel_monoid.to_monoid_injective {M : Type u} :
  function.injective (@right_cancel_monoid.to_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma right_cancel_monoid.ext {M : Type u} ⦃m₁ m₂ : right_cancel_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
right_cancel_monoid.to_monoid_injective $ monoid.ext h_mul

@[to_additive]
lemma cancel_monoid.to_left_cancel_monoid_injective {M : Type u} :
  function.injective (@cancel_monoid.to_left_cancel_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma cancel_monoid.ext {M : Type*} ⦃m₁ m₂ : cancel_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
cancel_monoid.to_left_cancel_monoid_injective $ left_cancel_monoid.ext h_mul

@[to_additive]
lemma cancel_comm_monoid.to_comm_monoid_injective {M : Type u} :
  function.injective (@cancel_comm_monoid.to_comm_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma cancel_comm_monoid.ext {M : Type*} ⦃m₁ m₂ : cancel_comm_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
cancel_comm_monoid.to_comm_monoid_injective $ comm_monoid.ext h_mul

@[ext, to_additive]
lemma div_inv_monoid.ext {M : Type*} ⦃m₁ m₂ : div_inv_monoid M⦄ (h_mul : m₁.mul = m₂.mul)
  (h_inv : m₁.inv = m₂.inv) : m₁ = m₂ :=
begin
  have h₁ : (@div_inv_monoid.to_monoid _ m₁).one = (@div_inv_monoid.to_monoid _ m₂).one,
    from congr_arg (@monoid.one M) (monoid.ext h_mul),
  set f : @monoid_hom M M (by letI := m₁; apply_instance) (by letI := m₂; apply_instance) :=
    { to_fun := id, map_one' := h₁, map_mul' := λ x y, congr_fun (congr_fun h_mul x) y },
  have hpow : (@div_inv_monoid.to_monoid _ m₁).npow = (@div_inv_monoid.to_monoid _ m₂).npow :=
    congr_arg (@monoid.npow M) (monoid.ext h_mul),
  have hzpow : m₁.zpow = m₂.zpow,
  { ext m x,
    exact @monoid_hom.map_zpow' M M m₁ m₂ f (congr_fun h_inv) x m },
  have hdiv : m₁.div = m₂.div,
  { ext a b,
    exact @map_div' M M _ m₁ m₂ _ f (congr_fun h_inv) a b },
  unfreezingI { cases m₁, cases m₂ },
  congr, exacts [h_mul, h₁, hpow, h_inv, hdiv, hzpow]
end

@[ext, to_additive]
lemma group.ext {G : Type*} ⦃g₁ g₂ : group G⦄ (h_mul : g₁.mul = g₂.mul) : g₁ = g₂ :=
begin
  set f := @monoid_hom.mk' G G (by letI := g₁; apply_instance) g₂ id
    (λ a b, congr_fun (congr_fun h_mul a) b),
  exact group.to_div_inv_monoid_injective (div_inv_monoid.ext h_mul
    (funext $ @monoid_hom.map_inv G G g₁ (@group.to_division_monoid _ g₂) f))
end

@[ext, to_additive]
lemma comm_group.ext {G : Type*} ⦃g₁ g₂ : comm_group G⦄
  (h_mul : g₁.mul = g₂.mul) : g₁ = g₂ :=
comm_group.to_group_injective $ group.ext h_mul


<|start_filename|>archive/imo/imo2001_q6.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.int.basic
import algebra.associated
import tactic.linarith
import tactic.linear_combination

/-!
# IMO 2001 Q6
Let $a$, $b$, $c$, $d$ be integers with $a > b > c > d > 0$. Suppose that

$$ a*c + b*d = (a + b - c + d) * (-a + b + c + d). $$

Prove that $a*b + c*d$ is not prime.

-/

variables {a b c d : ℤ}

theorem imo2001_q6 (hd : 0 < d) (hdc : d < c) (hcb : c < b) (hba : b < a)
  (h : a*c + b*d = (a + b - c + d) * (-a + b + c + d)) :
  ¬ prime (a*b + c*d) :=
begin
  assume h0 : prime (a*b + c*d),
  have ha : 0 < a, { linarith },
  have hb : 0 < b, { linarith },
  have hc : 0 < c, { linarith },
  -- the key step is to show that `a*c + b*d` divides the product `(a*b + c*d) * (a*d + b*c)`
  have dvd_mul : a*c + b*d ∣ (a*b + c*d) * (a*d + b*c),
  { use b^2 + b*d + d^2,
    linear_combination b*d*h },
  -- since `a*b + c*d` is prime (by assumption), it must divide `a*c + b*d` or `a*d + b*c`
  obtain (h1 : a*b + c*d ∣ a*c + b*d) | (h2 : a*c + b*d ∣ a*d + b*c) :=
    h0.left_dvd_or_dvd_right_of_dvd_mul dvd_mul,
  -- in both cases, we derive a contradiction
  { have aux : 0 < a*c + b*d,         { nlinarith only [ha, hb, hc, hd] },
    have : a*b + c*d ≤ a*c + b*d,     { from int.le_of_dvd aux h1 },
    nlinarith only [hba, hcb, hdc, h, this] },
  { have aux : 0 < a*d + b*c,         { nlinarith only [ha, hb, hc, hd] },
    have : a*c + b*d ≤ a*d + b*c,     { from int.le_of_dvd aux h2 },
    nlinarith only [hba, hdc, h, this] },
end


<|start_filename|>src/data/set/intervals/infinite.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import data.set.finite

/-!
# Infinitude of intervals

Bounded intervals in dense orders are infinite, as are unbounded intervals
in orders that are unbounded on the appropriate side. We also prove that an unbounded
preorder is an infinite type.
-/

variables {α : Type*} [preorder α]

/-- A nonempty preorder with no maximal element is infinite. This is not an instance to avoid
a cycle with `infinite α → nontrivial α → nonempty α`. -/
lemma no_max_order.infinite [nonempty α] [no_max_order α] : infinite α :=
let ⟨f, hf⟩ := nat.exists_strict_mono α in infinite.of_injective f hf.injective

/-- A nonempty preorder with no minimal element is infinite. This is not an instance to avoid
a cycle with `infinite α → nontrivial α → nonempty α`. -/
lemma no_min_order.infinite [nonempty α] [no_min_order α] : infinite α :=
@no_max_order.infinite αᵒᵈ _ _ _

namespace set

section densely_ordered

variables [densely_ordered α] {a b : α} (h : a < b)

lemma Ioo.infinite : infinite (Ioo a b) := @no_max_order.infinite _ _ (nonempty_Ioo_subtype h) _
lemma Ioo_infinite : (Ioo a b).infinite := infinite_coe_iff.1 $ Ioo.infinite h

lemma Ico_infinite : (Ico a b).infinite := (Ioo_infinite h).mono Ioo_subset_Ico_self
lemma Ico.infinite : infinite (Ico a b) := infinite_coe_iff.2 $ Ico_infinite h

lemma Ioc_infinite : (Ioc a b).infinite := (Ioo_infinite h).mono Ioo_subset_Ioc_self
lemma Ioc.infinite : infinite (Ioc a b) := infinite_coe_iff.2 $ Ioc_infinite h

lemma Icc_infinite : (Icc a b).infinite := (Ioo_infinite h).mono Ioo_subset_Icc_self
lemma Icc.infinite : infinite (Icc a b) := infinite_coe_iff.2 $ Icc_infinite h

end densely_ordered

instance [no_min_order α] {a : α} : infinite (Iio a) := no_min_order.infinite
lemma Iio_infinite [no_min_order α] (a : α) : (Iio a).infinite := infinite_coe_iff.1 Iio.infinite

instance [no_min_order α] {a : α} : infinite (Iic a) := no_min_order.infinite
lemma Iic_infinite [no_min_order α] (a : α) : (Iic a).infinite := infinite_coe_iff.1 Iic.infinite

instance [no_max_order α] {a : α} : infinite (Ioi a) := no_max_order.infinite
lemma Ioi_infinite [no_min_order α] (a : α) : (Iio a).infinite := infinite_coe_iff.1 Iio.infinite

instance [no_max_order α] {a : α} : infinite (Ici a) := no_max_order.infinite
lemma Ici_infinite [no_max_order α] (a : α) : (Ici a).infinite := infinite_coe_iff.1 Ici.infinite

end set


<|start_filename|>src/category_theory/monoidal/subcategory.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.monoidal.braided
import category_theory.concrete_category.basic

/-!
# Full monoidal subcategories

Given a monidal category `C` and a monoidal predicate on `C`, that is a function `P : C → Prop`
closed under `𝟙_` and `⊗`, we can put a monoidal structure on `{X : C // P X}` (the category
structure is defined in `category_theory.full_subcategory`).

When `C` is also braided/symmetric, the full monoidal subcategory also inherits the
braided/symmetric structure.

## TODO
* Add monoidal/braided versions of `category_theory.full_subcategory.lift`
-/

universes u v

namespace category_theory

namespace monoidal_category

open iso

variables {C : Type u} [category.{v} C] [monoidal_category C] (P : C → Prop)

/--
A property `C → Prop` is a monoidal predicate if it is closed under `𝟙_` and `⊗`.
-/
class monoidal_predicate :=
(prop_id' : P (𝟙_ C) . obviously)
(prop_tensor' : ∀ {X Y}, P X → P Y → P (X ⊗ Y) . obviously)

restate_axiom monoidal_predicate.prop_id'
restate_axiom monoidal_predicate.prop_tensor'

open monoidal_predicate

variables [monoidal_predicate P]

/--
When `P` is a monoidal predicate, the full subcategory `{X : C // P X}` inherits the monoidal
structure of `C`
-/
instance full_monoidal_subcategory : monoidal_category {X : C // P X} :=
{ tensor_obj := λ X Y, ⟨X ⊗ Y, prop_tensor X.2 Y.2⟩,
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, by { change X₁.1 ⊗ X₂.1 ⟶ Y₁.1 ⊗ Y₂.1,
    change X₁.1 ⟶ Y₁.1 at f, change X₂.1 ⟶ Y₂.1 at g, exact f ⊗ g },
  tensor_unit := ⟨𝟙_ C, prop_id⟩,
  associator := λ X Y Z,
    ⟨(α_ X.1 Y.1 Z.1).hom, (α_ X.1 Y.1 Z.1).inv,
     hom_inv_id (α_ X.1 Y.1 Z.1), inv_hom_id (α_ X.1 Y.1 Z.1)⟩,
  left_unitor := λ X, ⟨(λ_ X.1).hom, (λ_ X.1).inv, hom_inv_id (λ_ X.1), inv_hom_id (λ_ X.1)⟩,
  right_unitor := λ X, ⟨(ρ_ X.1).hom, (ρ_ X.1).inv, hom_inv_id (ρ_ X.1), inv_hom_id (ρ_ X.1)⟩,
  tensor_id' := λ X Y, tensor_id X.1 Y.1,
  tensor_comp' := λ X₁ Y₁ Z₁ X₂ Y₂ Z₂ f₁ f₂ g₁ g₂, tensor_comp f₁ f₂ g₁ g₂,
  associator_naturality' := λ X₁ X₂ X₃ Y₁ Y₂ Y₃ f₁ f₂ f₃, associator_naturality f₁ f₂ f₃,
  left_unitor_naturality' := λ X Y f, left_unitor_naturality f,
  right_unitor_naturality' := λ X Y f, right_unitor_naturality f,
  pentagon' := λ W X Y Z, pentagon W.1 X.1 Y.1 Z.1,
  triangle' := λ X Y, triangle X.1 Y.1 }

/--
The forgetful monoidal functor from a full monoidal subcategory into the original category
("forgetting" the condition).
-/
@[simps]
def full_monoidal_subcategory_inclusion : monoidal_functor {X : C // P X} C :=
{ to_functor := full_subcategory_inclusion P,
  ε := 𝟙 _,
  μ := λ X Y, 𝟙 _ }

instance full_monoidal_subcategory.full :
  full (full_monoidal_subcategory_inclusion P).to_functor := full_subcategory.full P
instance full_monoidal_subcategory.faithful :
  faithful (full_monoidal_subcategory_inclusion P).to_functor := full_subcategory.faithful P

variables {P} {P' : C → Prop} [monoidal_predicate P']

/-- An implication of predicates `P → P'` induces a monoidal functor between full monoidal
subcategories. -/
@[simps]
def full_monoidal_subcategory.map (h : ∀ ⦃X⦄, P X → P' X) :
  monoidal_functor {X : C // P X} {X : C // P' X}  :=
{ to_functor := full_subcategory.map h,
  ε := 𝟙 _,
  μ := λ X Y, 𝟙 _ }

instance full_monoidal_subcategory.map_full (h : ∀ ⦃X⦄, P X → P' X) :
  full (full_monoidal_subcategory.map h).to_functor := { preimage := λ X Y f, f }
instance full_monoidal_subcategory.map_faithful (h : ∀ ⦃X⦄, P X → P' X) :
  faithful (full_monoidal_subcategory.map h).to_functor := {}

section braided

variables (P) [braided_category C]

/--
The braided structure on `{X : C // P X}` inherited by the braided structure on `C`.
-/
instance full_braided_subcategory : braided_category {X : C // P X} :=
braided_category_of_faithful (full_monoidal_subcategory_inclusion P)
  (λ X Y, ⟨(β_ X.1 Y.1).hom, (β_ X.1 Y.1).inv, (β_ X.1 Y.1).hom_inv_id, (β_ X.1 Y.1).inv_hom_id⟩)
  (λ X Y, by tidy)

/--
The forgetful braided functor from a full braided subcategory into the original category
("forgetting" the condition).
-/
@[simps]
def full_braided_subcategory_inclusion : braided_functor {X : C // P X} C :=
{ to_monoidal_functor := full_monoidal_subcategory_inclusion P,
  braided' := λ X Y, by { rw [is_iso.eq_inv_comp], tidy } }

instance full_braided_subcategory.full :
  full (full_braided_subcategory_inclusion P).to_functor := full_monoidal_subcategory.full P
instance full_braided_subcategory.faithful :
  faithful (full_braided_subcategory_inclusion P).to_functor := full_monoidal_subcategory.faithful P

variables {P}

/-- An implication of predicates `P → P'` induces a braided functor between full braided
subcategories. -/
@[simps]
def full_braided_subcategory.map (h : ∀ ⦃X⦄, P X → P' X) :
  braided_functor {X : C // P X} {X : C // P' X}  :=
{ to_monoidal_functor := full_monoidal_subcategory.map h,
  braided' := λ X Y, by { rw [is_iso.eq_inv_comp], tidy }  }

instance full_braided_subcategory.map_full (h : ∀ ⦃X⦄, P X → P' X) :
  full (full_braided_subcategory.map h).to_functor := full_monoidal_subcategory.map_full h
instance full_braided_subcategory.map_faithful (h : ∀ ⦃X⦄, P X → P' X) :
  faithful (full_braided_subcategory.map h).to_functor := full_monoidal_subcategory.map_faithful h

end braided

section symmetric

variables (P) [symmetric_category C]

instance full_symmetric_subcategory : symmetric_category {X : C // P X} :=
symmetric_category_of_faithful (full_braided_subcategory_inclusion P)

end symmetric

end monoidal_category

end category_theory


<|start_filename|>src/analysis/complex/phragmen_lindelof.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import analysis.complex.abs_max
import analysis.asymptotics.superpolynomial_decay

/-!
# Phragmen-Lindelöf principle

In this file we prove several versions of the Phragmen-Lindelöf principle, a version of the maximum
modulus principle for an unbounded domain.

## Main statements

* `phragmen_lindelof.horizontal_strip`: the Phragmen-Lindelöf principle in a horizontal strip
  `{z : ℂ | a < complex.im z < b}`;

* `phragmen_lindelof.eq_zero_on_horizontal_strip`, `phragmen_lindelof.eq_on_horizontal_strip`:
  extensionality lemmas based on the Phragmen-Lindelöf principle in a horizontal strip;

* `phragmen_lindelof.vertical_strip`: the Phragmen-Lindelöf principle in a vertical strip
  `{z : ℂ | a < complex.re z < b}`;

* `phragmen_lindelof.eq_zero_on_vertical_strip`, `phragmen_lindelof.eq_on_vertical_strip`:
  extensionality lemmas based on the Phragmen-Lindelöf principle in a vertical strip;

* `phragmen_lindelof.quadrant_I`, `phragmen_lindelof.quadrant_II`, `phragmen_lindelof.quadrant_III`,
  `phragmen_lindelof.quadrant_IV`: the Phragmen-Lindelöf principle in the coordinate quadrants;

* `phragmen_lindelof.right_half_plane_of_tendsto_zero_on_real`,
  `phragmen_lindelof.right_half_plane_of_bounded_on_real`: two versions of the Phragmen-Lindelöf
  principle in the right half-plane;

* `phragmen_lindelof.eq_zero_on_right_half_plane_of_superexponential_decay`,
  `phragmen_lindelof.eq_on_right_half_plane_of_superexponential_decay`: extensionality lemmas based
  on the Phragmen-Lindelöf principle in the right half-plane.

In the case of the right half-plane, we prove a version of the Phragmen-Lindelöf principle that is
useful for Ilyashenko's proof of the individual finiteness theorem (a polynomial vector field on the
real plane has only finitely many limit cycles).
-/

open set function filter asymptotics metric complex
open_locale topological_space filter real

local notation `expR` := real.exp

namespace phragmen_lindelof

/-!
### Auxiliary lemmas
-/

variables {E : Type*} [normed_group E]

/-- An auxiliary lemma that combines two double exponential estimates into a similar estimate
on the difference of the functions. -/
lemma is_O_sub_exp_exp {a : ℝ} {f g : ℂ → E} {l : filter ℂ} {u : ℂ → ℝ}
  (hBf : ∃ (c < a) B, f =O[l] (λ z, expR (B * expR (c * |u z|))))
  (hBg : ∃ (c < a) B, g =O[l] (λ z, expR (B * expR (c * |u z|)))) :
  ∃ (c < a) B, (f - g) =O[l] (λ z, expR (B * expR (c * |u z|))) :=
begin
  have : ∀ {c₁ c₂ B₁ B₂}, c₁ ≤ c₂ → 0 ≤ B₂ → B₁ ≤ B₂ → ∀ z,
    ∥expR (B₁ * expR (c₁ * |u z|))∥ ≤ ∥expR (B₂ * expR (c₂ * |u z|))∥,
  { intros c₁ c₂ B₁ B₂ hc hB₀ hB z,
    rw [real.norm_eq_abs, real.norm_eq_abs, real.abs_exp, real.abs_exp, real.exp_le_exp],
    exact mul_le_mul hB (real.exp_le_exp.2 $ mul_le_mul_of_nonneg_right hc $ abs_nonneg _)
      (real.exp_pos _).le hB₀ },
  rcases hBf with ⟨cf, hcf, Bf, hOf⟩, rcases hBg with ⟨cg, hcg, Bg, hOg⟩,
  refine ⟨max cf cg, max_lt hcf hcg, max 0 (max Bf Bg), _⟩,
  refine (hOf.trans_le $ this _ _ _).sub (hOg.trans_le $ this _ _ _),
  exacts [le_max_left _ _, le_max_left _ _, (le_max_left _ _).trans (le_max_right _ _),
    le_max_right _ _, le_max_left _ _, (le_max_right _ _).trans (le_max_right _ _)]
end

/-- An auxiliary lemma that combines two “exponential of a power” estimates into a similar estimate
on the difference of the functions. -/
lemma is_O_sub_exp_rpow {a : ℝ} {f g : ℂ → E} {l : filter ℂ}
  (hBf : ∃ (c < a) B, f =O[comap complex.abs at_top ⊓ l] (λ z, expR (B * (abs z) ^ c)))
  (hBg : ∃ (c < a) B, g =O[comap complex.abs at_top ⊓ l] (λ z, expR (B * (abs z) ^ c))) :
  ∃ (c < a) B, (f - g) =O[comap complex.abs at_top ⊓ l] (λ z, expR (B * (abs z) ^ c)) :=
begin
  have : ∀ {c₁ c₂ B₁ B₂ : ℝ}, c₁ ≤ c₂ → 0 ≤ B₂ → B₁ ≤ B₂ →
    (λ z : ℂ, expR (B₁ * (abs z) ^ c₁)) =O[comap complex.abs at_top ⊓ l]
      (λ z, expR (B₂ * (abs z) ^ c₂)),
  { have : ∀ᶠ z : ℂ in comap abs at_top ⊓ l, 1 ≤ abs z,
      from ((eventually_ge_at_top 1).comap _).filter_mono inf_le_left,
    refine λ c₁ c₂ B₁ B₂ hc hB₀ hB, is_O.of_bound 1 (this.mono $ λ z hz, _),
    rw [one_mul, real.norm_eq_abs, real.norm_eq_abs, real.abs_exp, real.abs_exp, real.exp_le_exp],
    exact mul_le_mul hB (real.rpow_le_rpow_of_exponent_le hz hc)
      (real.rpow_nonneg_of_nonneg (abs_nonneg _) _) hB₀ },
  rcases hBf with ⟨cf, hcf, Bf, hOf⟩, rcases hBg with ⟨cg, hcg, Bg, hOg⟩,
  refine ⟨max cf cg, max_lt hcf hcg, max 0 (max Bf Bg), _⟩,
  refine (hOf.trans $ this _ _ _).sub (hOg.trans $ this _ _ _),
  exacts [le_max_left _ _, le_max_left _ _, (le_max_left _ _).trans (le_max_right _ _),
    le_max_right _ _, le_max_left _ _, (le_max_right _ _).trans (le_max_right _ _)]
end

variables [normed_space ℂ E] {a b C : ℝ} {f g : ℂ → E} {z : ℂ}

/-!
### Phragmen-Lindelöf principle in a horizontal strip
-/

/-- **Phragmen-Lindelöf principle** in a strip `U = {z : ℂ | a < im z < b}`.
Let `f : ℂ → E` be a function such that

* `f` is differentiable on `U` and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * exp(c * |re z|))` on `U` for some `c < π / (b - a)`;
* `∥f z∥` is bounded from above by a constant `C` on the boundary of `U`.

Then `∥f z∥` is bounded by the same constant on the closed strip
`{z : ℂ | a ≤ im z ≤ b}`. Moreover, it suffices to verify the second assumption
only for sufficiently large values of `|re z|`.
-/
lemma horizontal_strip (hfd : diff_cont_on_cl ℂ f (im ⁻¹' Ioo a b))
  (hB : ∃ (c < π / (b - a)) B, f =O[comap (has_abs.abs ∘ re) at_top ⊓ 𝓟 (im ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.re|))))
  (hle_a : ∀ z : ℂ, im z = a → ∥f z∥ ≤ C) (hle_b : ∀ z, im z = b → ∥f z∥ ≤ C)
  (hza : a ≤ im z) (hzb : im z ≤ b) :
  ∥f z∥ ≤ C :=
begin
  -- If `im z = a` or `im z = b`, then we apply `hle_a` or `hle_b`, otherwise `im z ∈ Ioo a b`.
  rw le_iff_eq_or_lt at hza hzb,
  cases hza with hza hza, { exact hle_a _ hza.symm },
  cases hzb with hzb hzb, { exact hle_b _ hzb },
  -- WLOG, `0 < C`.
  suffices : ∀ C' : ℝ, 0 < C' → (∀ w : ℂ, im w = a → ∥f w∥ ≤ C') →
    (∀ w : ℂ, im w = b → ∥f w∥ ≤ C') → ∥f z∥ ≤ C',
  { refine le_of_forall_le_of_dense (λ C' hC', this C' _ (λ w hw, _) (λ w hw, _)),
    { refine ((norm_nonneg (f (a * I))).trans (hle_a _ _)).trans_lt hC',
      rw [mul_I_im, of_real_re] },
    exacts [(hle_a _ hw).trans hC'.le, (hle_b _ hw).trans hC'.le] },
  clear_dependent C, intros C hC₀ hle_a hle_b,
  -- After a change of variables, we deal with the strip `a - b < im z < a + b` instead
  -- of `a < im z < b`
  obtain ⟨a, b, rfl, rfl⟩ : ∃ a' b', a = a' - b' ∧ b = a' + b' :=
    ⟨(a + b) / 2, (b - a) / 2, by ring, by ring⟩,
  have hab : a - b < a + b, from hza.trans hzb,
  have hb : 0 < b,
    by simpa only [sub_eq_add_neg, add_lt_add_iff_left, neg_lt_self_iff] using hab,
  rw [add_sub_sub_cancel, ← two_mul, div_mul_eq_div_div] at hB,
  have hπb : 0 < π / 2 / b, from div_pos real.pi_div_two_pos hb,
  -- Choose some `c B : ℝ` satisfying `hB`, then choose `max c 0 < d < π / 2 / b`.
  rcases hB with ⟨c, hc, B, hO⟩,
  obtain ⟨d, ⟨hcd, hd₀⟩, hd⟩ : ∃ d, (c < d ∧ 0 < d) ∧ d < π / 2 / b,
    by simpa only [max_lt_iff] using exists_between (max_lt hc hπb),
  have hb' : d * b < π / 2, from (lt_div_iff hb).1 hd,
  set aff : ℂ → ℂ := λ w, d * (w - a * I),
  set g : ℝ → ℂ → ℂ := λ ε w, exp (ε * (exp (aff w) + exp (-aff w))),
  /- Since `g ε z → 1` as `ε → 0⁻`, it suffices to prove that `∥g ε z • f z∥ ≤ C`
  for all negative `ε`. -/
  suffices : ∀ᶠ ε : ℝ in 𝓝[<] 0, ∥g ε z • f z∥ ≤ C,
  { refine le_of_tendsto (tendsto.mono_left _ nhds_within_le_nhds) this,
    apply ((continuous_of_real.mul continuous_const).cexp.smul continuous_const).norm.tendsto',
    simp, apply_instance },
  filter_upwards [self_mem_nhds_within] with ε ε₀, change ε < 0 at ε₀,
  -- An upper estimate on `∥g ε w∥` that will be used in two branches of the proof.
  obtain ⟨δ, δ₀, hδ⟩ : ∃ δ : ℝ, δ < 0 ∧ ∀ ⦃w⦄, im w ∈ Icc (a - b) (a + b) →
    abs (g ε w) ≤ expR (δ * expR (d * |re w|)),
  { refine ⟨ε * real.cos (d * b), mul_neg_of_neg_of_pos ε₀ (real.cos_pos_of_mem_Ioo $ abs_lt.1 $
      (abs_of_pos (mul_pos hd₀ hb)).symm ▸ hb'), λ w hw, _⟩,
    replace hw : |im (aff w)| ≤ d * b,
    { rw [← real.closed_ball_eq_Icc] at hw,
      rwa [of_real_mul_im, sub_im, mul_I_im, of_real_re, _root_.abs_mul, abs_of_pos hd₀,
        mul_le_mul_left hd₀] },
    simpa only [of_real_mul_re, _root_.abs_mul, abs_of_pos hd₀, sub_re, mul_I_re, of_real_im,
      zero_mul, neg_zero, sub_zero]
      using abs_exp_mul_exp_add_exp_neg_le_of_abs_im_le ε₀.le hw hb'.le },
  -- `abs (g ε w) ≤ 1` on the lines `w.im = a ± b` (actually, it holds everywhere in the strip)
  have hg₁ : ∀ w, (im w = a - b ∨ im w = a + b) → abs (g ε w) ≤ 1,
  { refine λ w hw, (hδ $ hw.by_cases _ _).trans (real.exp_le_one_iff.2 _),
    exacts [λ h, h.symm ▸ left_mem_Icc.2 hab.le, λ h, h.symm ▸ right_mem_Icc.2 hab.le,
      mul_nonpos_of_nonpos_of_nonneg δ₀.le (real.exp_pos _).le] },
  /- Our apriori estimate on `f` implies that `g ε w • f w → 0` as `|w.re| → ∞` along the strip. In
  particular, its norm is less than or equal to `C` for sufficiently large `|w.re|`. -/
  obtain ⟨R, hzR, hR⟩ : ∃ R : ℝ, |z.re| < R ∧ ∀ w, |re w| = R → im w ∈ Ioo (a - b) (a + b) →
    ∥g ε w • f w∥ ≤ C,
  { refine ((eventually_gt_at_top _).and _).exists,
    rcases hO.exists_pos with ⟨A, hA₀, hA⟩,
    simp only [is_O_with_iff, eventually_inf_principal, eventually_comap, mem_Ioo, ← abs_lt,
      mem_preimage, (∘), real.norm_eq_abs, abs_of_pos (real.exp_pos _)] at hA,
    suffices : tendsto (λ R, expR (δ * expR (d * R) + B * expR (c * R) + real.log A)) at_top (𝓝 0),
    { filter_upwards [this.eventually (ge_mem_nhds hC₀), hA] with R hR Hle w hre him,
      calc ∥g ε w • f w∥ ≤ expR (δ * expR (d * R) + B * expR (c * R) + real.log A) : _
      ... ≤ C : hR,
      rw [norm_smul, real.exp_add, ← hre, real.exp_add, real.exp_log hA₀, mul_assoc, mul_comm _ A],
      exact mul_le_mul (hδ $ Ioo_subset_Icc_self him) (Hle _ hre him) (norm_nonneg _)
        (real.exp_pos _).le },
    refine real.tendsto_exp_at_bot.comp _,
    suffices H : tendsto (λ R, δ + B * (expR ((d - c) * R))⁻¹) at_top (𝓝 (δ + B * 0)),
    { rw [mul_zero, add_zero] at H,
      refine tendsto.at_bot_add _ tendsto_const_nhds,
      simpa only [id, (∘), add_mul, mul_assoc, ← div_eq_inv_mul, ← real.exp_sub,
        ← sub_mul, sub_sub_cancel]
        using H.neg_mul_at_top δ₀ (real.tendsto_exp_at_top.comp $
          tendsto_const_nhds.mul_at_top hd₀ tendsto_id) },
    refine tendsto_const_nhds.add (tendsto_const_nhds.mul _),
    exact tendsto_inv_at_top_zero.comp (real.tendsto_exp_at_top.comp $
      tendsto_const_nhds.mul_at_top (sub_pos.2 hcd) tendsto_id) },
  have hR₀ : 0 < R, from (_root_.abs_nonneg _).trans_lt hzR,
  /- Finally, we apply the bounded version of the maximum modulus principle to the rectangle
  `(-R, R) × (a - b, a + b)`. The function is bounded by `C` on the horizontal sides by assumption
  (and because `∥g ε w∥ ≤ 1`) and on the vertical sides by the choice of `R`. -/
  have hgd : differentiable ℂ (g ε),
    from ((((differentiable_id.sub_const _).const_mul _).cexp.add
      ((differentiable_id.sub_const _).const_mul _).neg.cexp).const_mul _).cexp,
  replace hd : diff_cont_on_cl ℂ (λ w, g ε w • f w) (Ioo (-R) R ×ℂ Ioo (a - b) (a + b)),
    from (hgd.diff_cont_on_cl.smul hfd).mono (inter_subset_right _ _),
  convert norm_le_of_forall_mem_frontier_norm_le ((bounded_Ioo _ _).re_prod_im (bounded_Ioo _ _))
    hd (λ w hw, _) _,
  { have hwc := frontier_subset_closure hw,
    rw [frontier_re_prod_im, closure_Ioo (neg_lt_self hR₀).ne, frontier_Ioo hab,
      closure_Ioo hab.ne, frontier_Ioo (neg_lt_self hR₀)] at hw,
    by_cases him : w.im = a - b ∨ w.im = a + b,
    { rw [closure_re_prod_im, closure_Ioo (neg_lt_self hR₀).ne] at hwc,
      rw [norm_smul, ← one_mul C],
      exact mul_le_mul (hg₁ _ him) (him.by_cases (hle_a _) (hle_b _)) (norm_nonneg _) zero_le_one },
    { replace hw : w ∈ {-R, R} ×ℂ Icc (a - b) (a + b), from hw.resolve_left (λ h, him h.2),
      have hw' := eq_endpoints_or_mem_Ioo_of_mem_Icc hw.2, rw ← or.assoc at hw',
      exact hR _ ((abs_eq hR₀.le).2 hw.1.symm) (hw'.resolve_left him) } },
  { rw [closure_re_prod_im, closure_Ioo hab.ne, closure_Ioo (neg_lt_self hR₀).ne],
    exact ⟨abs_le.1 hzR.le, ⟨hza.le, hzb.le⟩⟩ }
end

/-- **Phragmen-Lindelöf principle** in a strip `U = {z : ℂ | a < im z < b}`.
Let `f : ℂ → E` be a function such that

* `f` is differentiable on `U` and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * exp(c * |re z|))` on `U` for some `c < π / (b - a)`;
* `f z = 0` on the boundary of `U`.

Then `f` is equal to zero on the closed strip `{z : ℂ | a ≤ im z ≤ b}`.
-/
lemma eq_zero_on_horizontal_strip (hd : diff_cont_on_cl ℂ f (im ⁻¹' Ioo a b))
  (hB : ∃ (c < π / (b - a)) B, f =O[comap (has_abs.abs ∘ re) at_top ⊓ 𝓟 (im ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.re|))))
  (ha : ∀ z : ℂ, z.im = a → f z = 0) (hb : ∀ z : ℂ, z.im = b → f z = 0) :
  eq_on f 0 (im ⁻¹' Icc a b) :=
λ z hz, norm_le_zero_iff.1 $ horizontal_strip hd hB
  (λ z hz, (ha z hz).symm ▸ norm_zero.le) (λ z hz, (hb z hz).symm ▸ norm_zero.le) hz.1 hz.2

/-- **Phragmen-Lindelöf principle** in a strip `U = {z : ℂ | a < im z < b}`.
Let `f g : ℂ → E` be functions such that

* `f` and `g` are differentiable on `U` and are continuous on its closure;
* `∥f z∥` and `∥g z∥` are bounded from above by `A * exp(B * exp(c * |re z|))` on `U` for some
  `c < π / (b - a)`;
* `f z = g z` on the boundary of `U`.

Then `f` is equal to `g` on the closed strip `{z : ℂ | a ≤ im z ≤ b}`.
-/
lemma eq_on_horizontal_strip {g : ℂ → E} (hdf : diff_cont_on_cl ℂ f (im ⁻¹' Ioo a b))
  (hBf : ∃ (c < π / (b - a)) B, f =O[comap (has_abs.abs ∘ re) at_top ⊓ 𝓟 (im ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.re|))))
  (hdg : diff_cont_on_cl ℂ g (im ⁻¹' Ioo a b))
  (hBg : ∃ (c < π / (b - a)) B, g =O[comap (has_abs.abs ∘ re) at_top ⊓ 𝓟 (im ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.re|))))
  (ha : ∀ z : ℂ, z.im = a → f z = g z) (hb : ∀ z : ℂ, z.im = b → f z = g z) :
  eq_on f g (im ⁻¹' Icc a b) :=
λ z hz, sub_eq_zero.1 (eq_zero_on_horizontal_strip (hdf.sub hdg) (is_O_sub_exp_exp hBf hBg)
  (λ w hw, sub_eq_zero.2 (ha w hw)) (λ w hw, sub_eq_zero.2 (hb w hw)) hz)

/-!
### Phragmen-Lindelöf principle in a vertical strip
-/

/-- **Phragmen-Lindelöf principle** in a strip `U = {z : ℂ | a < re z < b}`.
Let `f : ℂ → E` be a function such that

* `f` is differentiable on `U` and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * exp(c * |im z|))` on `U` for some `c < π / (b - a)`;
* `∥f z∥` is bounded from above by a constant `C` on the boundary of `U`.

Then `∥f z∥` is bounded by the same constant on the closed strip
`{z : ℂ | a ≤ re z ≤ b}`. Moreover, it suffices to verify the second assumption
only for sufficiently large values of `|im z|`.
-/
lemma vertical_strip (hfd : diff_cont_on_cl ℂ f (re ⁻¹' Ioo a b))
  (hB : ∃ (c < π / (b - a)) B, f =O[comap (has_abs.abs ∘ im) at_top ⊓ 𝓟 (re ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.im|))))
  (hle_a : ∀ z : ℂ, re z = a → ∥f z∥ ≤ C) (hle_b : ∀ z, re z = b → ∥f z∥ ≤ C)
  (hza : a ≤ re z) (hzb : re z ≤ b) :
  ∥f z∥ ≤ C :=
begin
  suffices : ∥(λ z, f (z * (-I))) (z * I)∥ ≤ C, by simpa [mul_assoc] using this,
  have H : maps_to (λ z, z * (-I)) (im ⁻¹' Ioo a b) (re ⁻¹' Ioo a b),
  { intros z hz, simpa using hz },
  refine horizontal_strip (hfd.comp (differentiable_id.mul_const _).diff_cont_on_cl H)
    _ (λ z hz, hle_a _ _) (λ z hz, hle_b _ _) _ _,
  { refine Exists₃.imp (λ c hc B hO, _) hB,
    have : tendsto (λ z, z * (-I)) (comap (has_abs.abs ∘ re) at_top ⊓ 𝓟 (im ⁻¹' Ioo a b))
      (comap (has_abs.abs ∘ im) at_top ⊓ 𝓟 (re ⁻¹' Ioo a b)),
    { refine (tendsto_comap_iff.2 _).inf H.tendsto,
      simpa [(∘)] using tendsto_comap },
    simpa [(∘)] using hO.comp_tendsto this },
  all_goals { simpa }
end

/-- **Phragmen-Lindelöf principle** in a strip `U = {z : ℂ | a < re z < b}`.
Let `f : ℂ → E` be a function such that

* `f` is differentiable on `U` and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * exp(c * |im z|))` on `U` for some `c < π / (b - a)`;
* `f z = 0` on the boundary of `U`.

Then `f` is equal to zero on the closed strip `{z : ℂ | a ≤ re z ≤ b}`.
-/
lemma eq_zero_on_vertical_strip (hd : diff_cont_on_cl ℂ f (re ⁻¹' Ioo a b))
  (hB : ∃ (c < π / (b - a)) B, f =O[comap (has_abs.abs ∘ im) at_top ⊓ 𝓟 (re ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.im|))))
  (ha : ∀ z : ℂ, re z = a → f z = 0) (hb : ∀ z : ℂ, re z = b → f z = 0) :
  eq_on f 0 (re ⁻¹' Icc a b) :=
λ z hz, norm_le_zero_iff.1 $ vertical_strip hd hB
  (λ z hz, (ha z hz).symm ▸ norm_zero.le) (λ z hz, (hb z hz).symm ▸ norm_zero.le) hz.1 hz.2

/-- **Phragmen-Lindelöf principle** in a strip `U = {z : ℂ | a < re z < b}`.
Let `f g : ℂ → E` be functions such that

* `f` and `g` are differentiable on `U` and are continuous on its closure;
* `∥f z∥` and `∥g z∥` are bounded from above by `A * exp(B * exp(c * |im z|))` on `U` for some
  `c < π / (b - a)`;
* `f z = g z` on the boundary of `U`.

Then `f` is equal to `g` on the closed strip `{z : ℂ | a ≤ re z ≤ b}`.
-/
lemma eq_on_vertical_strip {g : ℂ → E} (hdf : diff_cont_on_cl ℂ f (re ⁻¹' Ioo a b))
  (hBf : ∃ (c < π / (b - a)) B, f =O[comap (has_abs.abs ∘ im) at_top ⊓ 𝓟 (re ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.im|))))
  (hdg : diff_cont_on_cl ℂ g (re ⁻¹' Ioo a b))
  (hBg : ∃ (c < π / (b - a)) B, g =O[comap (has_abs.abs ∘ im) at_top ⊓ 𝓟 (re ⁻¹' Ioo a b)]
    (λ z, expR (B * expR (c * |z.im|))))
  (ha : ∀ z : ℂ, re z = a → f z = g z) (hb : ∀ z : ℂ, re z = b → f z = g z) :
  eq_on f g (re ⁻¹' Icc a b) :=
λ z hz, sub_eq_zero.1 (eq_zero_on_vertical_strip (hdf.sub hdg) (is_O_sub_exp_exp hBf hBg)
  (λ w hw, sub_eq_zero.2 (ha w hw)) (λ w hw, sub_eq_zero.2 (hb w hw)) hz)

/-!
### Phragmen-Lindelöf principle in coordinate quadrants
-/

/-- **Phragmen-Lindelöf principle** in the first quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open first quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open first quadrant
  for some `c < 2`;
* `∥f z∥` is bounded from above by a constant `C` on the boundary of the first quadrant.

Then `∥f z∥` is bounded from above by the same constant on the closed first quadrant. -/
lemma quadrant_I (hd : diff_cont_on_cl ℂ f (Ioi 0 ×ℂ Ioi 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, 0 ≤ x → ∥f x∥ ≤ C) (him : ∀ x : ℝ, 0 ≤ x → ∥f (x * I)∥ ≤ C)
  (hz_re : 0 ≤ z.re) (hz_im : 0 ≤ z.im) :
  ∥f z∥ ≤ C :=
begin
  -- The case `z = 0` is trivial.
  rcases eq_or_ne z 0 with rfl|hzne, { exact hre 0 le_rfl },
  -- Otherwise, `z = e ^ ζ` for some `ζ : ℂ`, `0 < Im ζ < π / 2`.
  obtain ⟨ζ, hζ, rfl⟩ : ∃ ζ : ℂ, ζ.im ∈ Icc 0 (π / 2) ∧ exp ζ = z,
  { refine ⟨log z, _, exp_log hzne⟩,
    rw log_im,
    exact ⟨arg_nonneg_iff.2 hz_im, arg_le_pi_div_two_iff.2 (or.inl hz_re)⟩ },
  clear hz_re hz_im hzne,
  -- We are going to apply `phragmen_lindelof.horizontal_strip` to `f ∘ complex.exp` and `ζ`.
  change ∥(f ∘ exp) ζ∥ ≤ C,
  have H : maps_to exp (im ⁻¹' Ioo 0 (π / 2)) (Ioi 0 ×ℂ Ioi 0),
  { intros z hz,
    rw [mem_re_prod_im, exp_re, exp_im, mem_Ioi, mem_Ioi],
    refine ⟨mul_pos (real.exp_pos _)
      (real.cos_pos_of_mem_Ioo ⟨(neg_lt_zero.2 $ div_pos real.pi_pos two_pos).trans hz.1, hz.2⟩),
      mul_pos (real.exp_pos _)
        (real.sin_pos_of_mem_Ioo ⟨hz.1, hz.2.trans (half_lt_self real.pi_pos)⟩)⟩ },
  refine horizontal_strip (hd.comp differentiable_exp.diff_cont_on_cl H) _ _ _ hζ.1 hζ.2;
    clear hζ ζ,
  { -- The estimate `hB` on `f` implies the required estimate on
    -- `f ∘ exp` with the same `c` and `B' = max B 0`.
    rw [sub_zero, div_div_cancel' real.pi_pos.ne'],
    rcases hB with ⟨c, hc, B, hO⟩,
    refine ⟨c, hc, max B 0, _⟩,
    rw [← comap_comap, comap_abs_at_top, comap_sup, inf_sup_right],
    -- We prove separately the estimates as `ζ.re → ∞` and as `ζ.re → -∞`
    refine is_O.sup _ ((hO.comp_tendsto $ tendsto_exp_comap_re_at_top.inf H.tendsto).trans $
      is_O.of_bound 1 _),
    { -- For the estimate as `ζ.re → -∞`, note that `f` is continuous within the first quadrant at
      -- zero, hence `f (exp ζ)` has a limit as `ζ.re → -∞`, `0 < ζ.im < π / 2`.
      have hc : continuous_within_at f (Ioi 0 ×ℂ Ioi 0) 0,
      { refine (hd.continuous_on _ _).mono subset_closure,
        simp [closure_re_prod_im, mem_re_prod_im] },
      refine (is_O_one_of_tendsto ℝ (hc.tendsto.comp $ tendsto_exp_comap_re_at_bot.inf
        H.tendsto)).trans (is_O_of_le _ (λ w, _)),
      rw [norm_one, real.norm_of_nonneg (real.exp_pos _).le, real.one_le_exp_iff],
      exact mul_nonneg (le_max_right _ _) (real.exp_pos _).le },
    { -- For the estimate as `ζ.re → ∞`, we reuse the uppoer estimate on `f`
      simp only [eventually_inf_principal, eventually_comap, comp_app, one_mul,
        real.norm_of_nonneg (real.exp_pos _).le, abs_exp, ← real.exp_mul, real.exp_le_exp],
      refine (eventually_ge_at_top 0).mono (λ x hx z hz hz', _),
      rw [hz, _root_.abs_of_nonneg hx, mul_comm _ c],
      exact mul_le_mul_of_nonneg_right (le_max_left _ _) (real.exp_pos _).le } },
  { -- If `ζ.im = 0`, then `complex.exp ζ` is a positive real number
    intros ζ hζ, lift ζ to ℝ using hζ,
    rw [comp_app, ← of_real_exp],
    exact hre _ (real.exp_pos _).le },
  { -- If `ζ.im = π / 2`, then `complex.exp ζ` is a purely imaginary number with positive `im`
    intros ζ hζ,
    rw [← re_add_im ζ, hζ, comp_app, exp_add_mul_I, ← of_real_cos, ← of_real_sin,
      real.cos_pi_div_two, real.sin_pi_div_two, of_real_zero, of_real_one, one_mul, zero_add,
      ← of_real_exp],
    exact him _ (real.exp_pos _).le }
end

/-- **Phragmen-Lindelöf principle** in the first quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open first quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open first quadrant
  for some `A`, `B`, and `c < 2`;
* `f` is equal to zero on the boundary of the first quadrant.

Then `f` is equal to zero on the closed first quadrant. -/
lemma eq_zero_on_quadrant_I (hd : diff_cont_on_cl ℂ f (Ioi 0 ×ℂ Ioi 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, 0 ≤ x → f x = 0) (him : ∀ x : ℝ, 0 ≤ x → f (x * I) = 0) :
  eq_on f 0 {z | 0 ≤ z.re ∧ 0 ≤ z.im} :=
λ z hz, norm_le_zero_iff.1 $ quadrant_I hd hB (λ x hx, norm_le_zero_iff.2 $ hre x hx)
  (λ x hx, norm_le_zero_iff.2 $ him x hx) hz.1 hz.2

/-- **Phragmen-Lindelöf principle** in the first quadrant. Let `f g : ℂ → E` be functions such that

* `f` and `g` are differentiable in the open first quadrant and are continuous on its closure;
* `∥f z∥` and `∥g z∥` are bounded from above by `A * exp(B * (abs z) ^ c)` on the open first
  quadrant for some `A`, `B`, and `c < 2`;
* `f` is equal to `g` on the boundary of the first quadrant.

Then `f` is equal to `g` on the closed first quadrant. -/
lemma eq_on_quadrant_I (hdf : diff_cont_on_cl ℂ f (Ioi 0 ×ℂ Ioi 0))
  (hBf : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hdg : diff_cont_on_cl ℂ g (Ioi 0 ×ℂ Ioi 0))
  (hBg : ∃ (c < (2 : ℝ)) B, g =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, 0 ≤ x → f x = g x) (him : ∀ x : ℝ, 0 ≤ x → f (x * I) = g (x * I)) :
  eq_on f g {z | 0 ≤ z.re ∧ 0 ≤ z.im} :=
λ z hz, sub_eq_zero.1 $ eq_zero_on_quadrant_I (hdf.sub hdg) (is_O_sub_exp_rpow hBf hBg)
  (λ x hx, sub_eq_zero.2 $ hre x hx) (λ x hx, sub_eq_zero.2 $ him x hx) hz

/-- **Phragmen-Lindelöf principle** in the second quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open second quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open second quadrant
  for some `c < 2`;
* `∥f z∥` is bounded from above by a constant `C` on the boundary of the second quadrant.

Then `∥f z∥` is bounded from above by the same constant on the closed second quadrant. -/
lemma quadrant_II (hd : diff_cont_on_cl ℂ f (Iio 0 ×ℂ Ioi 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, x ≤ 0 → ∥f x∥ ≤ C) (him : ∀ x : ℝ, 0 ≤ x → ∥f (x * I)∥ ≤ C)
  (hz_re : z.re ≤ 0) (hz_im : 0 ≤ z.im) :
  ∥f z∥ ≤ C :=
begin
  obtain ⟨z, rfl⟩ : ∃ z', z' * I = z, from ⟨z / I, div_mul_cancel _ I_ne_zero⟩,
  simp only [mul_I_re, mul_I_im, neg_nonpos] at hz_re hz_im,
  change ∥(f ∘ (* I)) z∥ ≤ C,
  have H : maps_to (* I) (Ioi 0 ×ℂ Ioi 0) (Iio 0 ×ℂ Ioi 0),
  { intros w hw,
    simpa only [mem_re_prod_im, mul_I_re, mul_I_im, neg_lt_zero, mem_Iio] using hw.symm },
  refine quadrant_I (hd.comp (differentiable_id.mul_const _).diff_cont_on_cl H)
    (Exists₃.imp (λ c hc B hO, _) hB) him (λ x hx, _) hz_im hz_re,
  { simpa only [(∘), complex.abs_mul, abs_I, mul_one]
      using hO.comp_tendsto ((tendsto_mul_right_cobounded I_ne_zero).inf H.tendsto) },
  { rw [comp_app, mul_assoc, I_mul_I, mul_neg_one, ← of_real_neg],
    exact hre _ (neg_nonpos.2 hx) }
end

/-- **Phragmen-Lindelöf principle** in the second quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open second quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open second quadrant
  for some `A`, `B`, and `c < 2`;
* `f` is equal to zero on the boundary of the second quadrant.

Then `f` is equal to zero on the closed second quadrant. -/
lemma eq_zero_on_quadrant_II (hd : diff_cont_on_cl ℂ f (Iio 0 ×ℂ Ioi 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, x ≤ 0 → f x = 0) (him : ∀ x : ℝ, 0 ≤ x → f (x * I) = 0) :
  eq_on f 0 {z | z.re ≤ 0 ∧ 0 ≤ z.im} :=
λ z hz, norm_le_zero_iff.1 $ quadrant_II hd hB (λ x hx, norm_le_zero_iff.2 $ hre x hx)
  (λ x hx, norm_le_zero_iff.2 $ him x hx) hz.1 hz.2

/-- **Phragmen-Lindelöf principle** in the second quadrant. Let `f g : ℂ → E` be functions such that

* `f` and `g` are differentiable in the open second quadrant and are continuous on its closure;
* `∥f z∥` and `∥g z∥` are bounded from above by `A * exp(B * (abs z) ^ c)` on the open second
  quadrant for some `A`, `B`, and `c < 2`;
* `f` is equal to `g` on the boundary of the second quadrant.

Then `f` is equal to `g` on the closed second quadrant. -/
lemma eq_on_quadrant_II (hdf : diff_cont_on_cl ℂ f (Iio 0 ×ℂ Ioi 0))
  (hBf : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hdg : diff_cont_on_cl ℂ g (Iio 0 ×ℂ Ioi 0))
  (hBg : ∃ (c < (2 : ℝ)) B, g =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Ioi 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, x ≤ 0 → f x = g x) (him : ∀ x : ℝ, 0 ≤ x → f (x * I) = g (x * I)) :
  eq_on f g {z | z.re ≤ 0 ∧ 0 ≤ z.im} :=
λ z hz, sub_eq_zero.1 $ eq_zero_on_quadrant_II (hdf.sub hdg) (is_O_sub_exp_rpow hBf hBg)
  (λ x hx, sub_eq_zero.2 $ hre x hx) (λ x hx, sub_eq_zero.2 $ him x hx) hz

/-- **Phragmen-Lindelöf principle** in the third quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open third quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp (B * (abs z) ^ c)` on the open third quadrant
  for some `c < 2`;
* `∥f z∥` is bounded from above by a constant `C` on the boundary of the third quadrant.

Then `∥f z∥` is bounded from above by the same constant on the closed third quadrant. -/
lemma quadrant_III (hd : diff_cont_on_cl ℂ f (Iio 0 ×ℂ Iio 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, x ≤ 0 → ∥f x∥ ≤ C) (him : ∀ x : ℝ, x ≤ 0 → ∥f (x * I)∥ ≤ C)
  (hz_re : z.re ≤ 0) (hz_im : z.im ≤ 0) :
  ∥f z∥ ≤ C :=
begin
  obtain ⟨z, rfl⟩ : ∃ z', -z' = z, from ⟨-z, neg_neg z⟩,
  simp only [neg_re, neg_im, neg_nonpos] at hz_re hz_im,
  change ∥(f ∘ has_neg.neg) z∥ ≤ C,
  have H : maps_to has_neg.neg (Ioi 0 ×ℂ Ioi 0) (Iio 0 ×ℂ Iio 0),
  { intros w hw,
    simpa only [mem_re_prod_im, neg_re, neg_im, neg_lt_zero, mem_Iio] using hw },
  refine quadrant_I (hd.comp differentiable_neg.diff_cont_on_cl H) _ (λ x hx, _) (λ x hx, _)
    hz_re hz_im,
  { refine Exists₃.imp (λ c hc B hO, _) hB,
    simpa only [(∘), complex.abs_neg]
      using hO.comp_tendsto (tendsto_neg_cobounded.inf H.tendsto) },
  { rw [comp_app, ← of_real_neg],
    exact hre (-x) (neg_nonpos.2 hx) },
  { rw [comp_app, ← neg_mul, ← of_real_neg],
    exact him (-x) (neg_nonpos.2 hx) }
end

/-- **Phragmen-Lindelöf principle** in the third quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open third quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open third quadrant
  for some `A`, `B`, and `c < 2`;
* `f` is equal to zero on the boundary of the third quadrant.

Then `f` is equal to zero on the closed third quadrant. -/
lemma eq_zero_on_quadrant_III (hd : diff_cont_on_cl ℂ f (Iio 0 ×ℂ Iio 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, x ≤ 0 → f x = 0) (him : ∀ x : ℝ, x ≤ 0 → f (x * I) = 0) :
  eq_on f 0 {z | z.re ≤ 0 ∧ z.im ≤ 0} :=
λ z hz, norm_le_zero_iff.1 $ quadrant_III hd hB (λ x hx, norm_le_zero_iff.2 $ hre x hx)
  (λ x hx, norm_le_zero_iff.2 $ him x hx) hz.1 hz.2

/-- **Phragmen-Lindelöf principle** in the third quadrant. Let `f g : ℂ → E` be functions such that

* `f` and `g` are differentiable in the open third quadrant and are continuous on its closure;
* `∥f z∥` and `∥g z∥` are bounded from above by `A * exp(B * (abs z) ^ c)` on the open third
  quadrant for some `A`, `B`, and `c < 2`;
* `f` is equal to `g` on the boundary of the third quadrant.

Then `f` is equal to `g` on the closed third quadrant. -/
lemma eq_on_quadrant_III (hdf : diff_cont_on_cl ℂ f (Iio 0 ×ℂ Iio 0))
  (hBf : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hdg : diff_cont_on_cl ℂ g (Iio 0 ×ℂ Iio 0))
  (hBg : ∃ (c < (2 : ℝ)) B, g =O[comap complex.abs at_top ⊓ 𝓟 (Iio 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, x ≤ 0 → f x = g x) (him : ∀ x : ℝ, x ≤ 0 → f (x * I) = g (x * I)) :
  eq_on f g {z | z.re ≤ 0 ∧ z.im ≤ 0} :=
λ z hz, sub_eq_zero.1 $ eq_zero_on_quadrant_III (hdf.sub hdg) (is_O_sub_exp_rpow hBf hBg)
  (λ x hx, sub_eq_zero.2 $ hre x hx) (λ x hx, sub_eq_zero.2 $ him x hx) hz

/-- **Phragmen-Lindelöf principle** in the fourth quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open fourth quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open fourth quadrant
  for some `c < 2`;
* `∥f z∥` is bounded from above by a constant `C` on the boundary of the fourth quadrant.

Then `∥f z∥` is bounded from above by the same constant on the closed fourth quadrant. -/
lemma quadrant_IV (hd : diff_cont_on_cl ℂ f (Ioi 0 ×ℂ Iio 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, 0 ≤ x → ∥f x∥ ≤ C) (him : ∀ x : ℝ, x ≤ 0 → ∥f (x * I)∥ ≤ C)
  (hz_re : 0 ≤ z.re) (hz_im : z.im ≤ 0) :
  ∥f z∥ ≤ C :=
begin
  obtain ⟨z, rfl⟩ : ∃ z', -z' = z, from ⟨-z, neg_neg z⟩,
  simp only [neg_re, neg_im, neg_nonpos, neg_nonneg] at hz_re hz_im,
  change ∥(f ∘ has_neg.neg) z∥ ≤ C,
  have H : maps_to has_neg.neg (Iio 0 ×ℂ Ioi 0) (Ioi 0 ×ℂ Iio 0),
  { intros w hw,
    simpa only [mem_re_prod_im, neg_re, neg_im, neg_lt_zero, neg_pos, mem_Ioi, mem_Iio] using hw },
  refine quadrant_II (hd.comp differentiable_neg.diff_cont_on_cl H) _ (λ x hx, _) (λ x hx, _)
    hz_re hz_im,
  { refine Exists₃.imp (λ c hc B hO, _) hB,
    simpa only [(∘), complex.abs_neg]
      using hO.comp_tendsto (tendsto_neg_cobounded.inf H.tendsto) },
  { rw [comp_app, ← of_real_neg],
    exact hre (-x) (neg_nonneg.2 hx) },
  { rw [comp_app, ← neg_mul, ← of_real_neg],
    exact him (-x) (neg_nonpos.2 hx) }
end

/-- **Phragmen-Lindelöf principle** in the fourth quadrant. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open fourth quadrant and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open fourth quadrant
  for some `A`, `B`, and `c < 2`;
* `f` is equal to zero on the boundary of the fourth quadrant.

Then `f` is equal to zero on the closed fourth quadrant. -/
lemma eq_zero_on_quadrant_IV (hd : diff_cont_on_cl ℂ f (Ioi 0 ×ℂ Iio 0))
  (hB : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, 0 ≤ x → f x = 0) (him : ∀ x : ℝ, x ≤ 0 → f (x * I) = 0) :
  eq_on f 0 {z | 0 ≤ z.re ∧ z.im ≤ 0} :=
λ z hz, norm_le_zero_iff.1 $ quadrant_IV hd hB (λ x hx, norm_le_zero_iff.2 $ hre x hx)
  (λ x hx, norm_le_zero_iff.2 $ him x hx) hz.1 hz.2

/-- **Phragmen-Lindelöf principle** in the fourth quadrant. Let `f g : ℂ → E` be functions such that

* `f` and `g` are differentiable in the open fourth quadrant and are continuous on its closure;
* `∥f z∥` and `∥g z∥` are bounded from above by `A * exp(B * (abs z) ^ c)` on the open fourth
  quadrant for some `A`, `B`, and `c < 2`;
* `f` is equal to `g` on the boundary of the fourth quadrant.

Then `f` is equal to `g` on the closed fourth quadrant. -/
lemma eq_on_quadrant_IV (hdf : diff_cont_on_cl ℂ f (Ioi 0 ×ℂ Iio 0))
  (hBf : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hdg : diff_cont_on_cl ℂ g (Ioi 0 ×ℂ Iio 0))
  (hBg : ∃ (c < (2 : ℝ)) B, g =O[comap complex.abs at_top ⊓ 𝓟 (Ioi 0 ×ℂ Iio 0)]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : ∀ x : ℝ, 0 ≤ x → f x = g x) (him : ∀ x : ℝ, x ≤ 0 → f (x * I) = g (x * I)) :
  eq_on f g {z | 0 ≤ z.re ∧ z.im ≤ 0} :=
λ z hz, sub_eq_zero.1 $ eq_zero_on_quadrant_IV (hdf.sub hdg) (is_O_sub_exp_rpow hBf hBg)
  (λ x hx, sub_eq_zero.2 $ hre x hx) (λ x hx, sub_eq_zero.2 $ him x hx) hz

/-!
### Phragmen-Lindelöf principle in the right half-plane
-/

/-- **Phragmen-Lindelöf principle** in the right half-plane. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open right half-plane and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open right half-plane
  for some `c < 2`;
* `∥f z∥` is bounded from above by a constant `C` on the imaginary axis;
* `f x → 0` as `x : ℝ` tends to infinity.

Then `∥f z∥` is bounded from above by the same constant on the closed right half-plane.
See also `phragmen_lindelof.right_half_plane_of_bounded_on_real` for a stronger version. -/
lemma right_half_plane_of_tendsto_zero_on_real (hd : diff_cont_on_cl ℂ f {z | 0 < z.re})
  (hexp : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 {z | 0 < z.re}]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : tendsto (λ x : ℝ, f x) at_top (𝓝 0)) (him : ∀ x : ℝ, ∥f (x * I)∥ ≤ C) (hz : 0 ≤ z.re) :
  ∥f z∥ ≤ C :=
begin
  /- We are going to apply the Phragmen-Lindelöf principle in the first and fourth quadrants.
  The lemmas immediately imply that for any upper estimate `C'` on `∥f x∥`, `x : ℝ`, `0 ≤ x`,
  the number `max C C'` is an upper estimate on `f` in the whole right half-plane. -/
  revert z,
  have hle : ∀ C', (∀ x : ℝ, 0 ≤ x → ∥f x∥ ≤ C') → ∀ z : ℂ, 0 ≤ z.re → ∥f z∥ ≤ max C C',
  { intros C' hC' z hz,
    cases le_total z.im 0,
    { refine quadrant_IV (hd.mono $ λ _, and.left) (Exists₃.imp (λ c hc B hO, _) hexp)
        (λ x hx, (hC' x hx).trans $ le_max_right _ _) (λ x hx, (him x).trans (le_max_left _ _))
        hz h,
      exact hO.mono (inf_le_inf_left _ $ principal_mono.2 $ λ _, and.left) },
    { refine quadrant_I (hd.mono $ λ _, and.left) (Exists₃.imp (λ c hc B hO, _) hexp)
        (λ x hx, (hC' x hx).trans $ le_max_right _ _) (λ x hx, (him x).trans (le_max_left _ _))
        hz h,
      exact hO.mono (inf_le_inf_left _ $ principal_mono.2 $ λ _, and.left) } },
  -- Since `f` is continuous on `Ici 0` and `∥f x∥` tends to zero as `x → ∞`,
  -- the norm `∥f x∥` takes its maximum value at some `x₀ : ℝ`.
  obtain ⟨x₀, hx₀, hmax⟩ : ∃ x : ℝ, 0 ≤ x ∧ ∀ y : ℝ, 0 ≤ y → ∥f y∥ ≤ ∥f x∥,
  { have hfc : continuous_on (λ x : ℝ, f x) (Ici 0),
    { refine hd.continuous_on.comp continuous_of_real.continuous_on (λ x hx, _),
      rwa closure_set_of_lt_re },
    by_cases h₀ : ∀ x : ℝ, 0 ≤ x → f x = 0,
    { refine ⟨0, le_rfl, λ y hy, _⟩, rw [h₀ y hy, h₀ 0 le_rfl] },
    push_neg at h₀,
    rcases h₀ with ⟨x₀, hx₀, hne⟩,
    have hlt : ∥(0 : E)∥ < ∥f x₀∥, by rwa [norm_zero, norm_pos_iff],
    suffices : ∀ᶠ x : ℝ in cocompact ℝ ⊓ 𝓟 (Ici 0), ∥f x∥ ≤ ∥f x₀∥,
      by simpa only [exists_prop] using hfc.norm.exists_forall_ge' is_closed_Ici hx₀ this,
    rw [real.cocompact_eq, inf_sup_right, (disjoint_at_bot_principal_Ici (0 : ℝ)).eq_bot,
      bot_sup_eq],
    exact (hre.norm.eventually $ ge_mem_nhds hlt).filter_mono inf_le_left },
  cases le_or_lt (∥f x₀∥) C,
  { -- If `∥f x₀∥ ≤ C`, then `hle` implies the required estimate
    simpa only [max_eq_left h] using hle _ hmax },
  { -- Otherwise, `∥f z∥ ≤ ∥f x₀∥` for all `z` in the right half-plane due to `hle`.
    replace hmax : is_max_on (norm ∘ f) {z | 0 < z.re} x₀,
    { rintros z (hz : 0 < z.re),
      simpa [max_eq_right h.le] using hle _ hmax _ hz.le },
    -- Due to the maximum modulus principle applied to the closed ball of radius `x₀.re`,
    -- `∥f 0∥ = ∥f x₀∥`.
    have : ∥f 0∥ = ∥f x₀∥,
    { apply norm_eq_norm_of_is_max_on_of_ball_subset hd hmax,
      -- move to a lemma?
      intros z hz,
      rw [mem_ball, dist_zero_left, dist_eq, norm_eq_abs, complex.abs_of_nonneg hx₀] at hz,
      rw mem_set_of_eq,
      contrapose! hz,
      calc x₀ ≤ x₀ - z.re : (le_sub_self_iff _).2 hz
      ... ≤ |x₀ - z.re| : le_abs_self _
      ... = |(z - x₀).re| : by rw [sub_re, of_real_re, _root_.abs_sub_comm]
      ... ≤ abs (z - x₀) : abs_re_le_abs _ },
    -- Thus we have `C < ∥f x₀∥ = ∥f 0∥ ≤ C`. Contradiction completes the proof.
    refine (h.not_le $ this ▸ _).elim,
    simpa using him 0 }
end

/-- **Phragmen-Lindelöf principle** in the right half-plane. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open right half-plane and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open right half-plane
  for some `c < 2`;
* `∥f z∥` is bounded from above by a constant `C` on the imaginary axis;
* `∥f x∥` is bounded from above by a constant for large real values of `x`.

Then `∥f z∥` is bounded from above by `C` on the closed right half-plane.
See also `phragmen_lindelof.right_half_plane_of_tendsto_zero_on_real` for a weaker version. -/
lemma right_half_plane_of_bounded_on_real (hd : diff_cont_on_cl ℂ f {z | 0 < z.re})
  (hexp : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 {z | 0 < z.re}]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : is_bounded_under (≤) at_top (λ x : ℝ, ∥f x∥))
  (him : ∀ x : ℝ, ∥f (x * I)∥ ≤ C) (hz : 0 ≤ z.re) :
  ∥f z∥ ≤ C :=
begin
  -- For each `ε < 0`, the function `λ z, exp (ε * z) • f z` satisfies assumptions of
  -- `right_half_plane_of_tendsto_zero_on_real`, hence `∥exp (ε * z) • f z∥ ≤ C` for all `ε < 0`.
  -- Taking the limit as `ε → 0`, we obtain the required inequality.
  suffices : ∀ᶠ ε : ℝ in 𝓝[<] 0, ∥exp (ε * z) • f z∥ ≤ C,
  { refine le_of_tendsto (tendsto.mono_left _ nhds_within_le_nhds) this,
    apply ((continuous_of_real.mul continuous_const).cexp.smul continuous_const).norm.tendsto',
    simp, apply_instance },
  filter_upwards [self_mem_nhds_within] with ε ε₀, change ε < 0 at ε₀,
  set g : ℂ → E := λ z, exp (ε * z) • f z, change ∥g z∥ ≤ C,
  replace hd : diff_cont_on_cl ℂ g {z : ℂ | 0 < z.re},
    from (differentiable_id.const_mul _).cexp.diff_cont_on_cl.smul hd,
  have hgn : ∀ z, ∥g z∥ = expR (ε * z.re) * ∥f z∥,
  { intro z, rw [norm_smul, norm_eq_abs, abs_exp, of_real_mul_re] },
  refine right_half_plane_of_tendsto_zero_on_real hd _ _ (λ y, _) hz,
  { refine Exists₃.imp (λ c hc B hO, (is_O.of_bound 1  _).trans hO) hexp,
    refine (eventually_inf_principal.2 $ eventually_of_forall $ λ z hz, _),
    rw [hgn, one_mul],
    refine mul_le_of_le_one_left (norm_nonneg _) (real.exp_le_one_iff.2 _),
    exact mul_nonpos_of_nonpos_of_nonneg ε₀.le (le_of_lt hz) },
  { simp_rw [g, ← of_real_mul, ← of_real_exp, coe_smul],
    have h₀ : tendsto (λ x : ℝ, expR (ε * x)) at_top (𝓝 0),
      from real.tendsto_exp_at_bot.comp (tendsto_const_nhds.neg_mul_at_top ε₀ tendsto_id),
    exact h₀.zero_smul_is_bounded_under_le hre },
  { rw [hgn, of_real_mul_re, I_re, mul_zero, mul_zero, real.exp_zero, one_mul],
    exact him y }
end

/-- **Phragmen-Lindelöf principle** in the right half-plane. Let `f : ℂ → E` be a function such that

* `f` is differentiable in the open right half-plane and is continuous on its closure;
* `∥f z∥` is bounded from above by `A * exp(B * (abs z) ^ c)` on the open right half-plane
  for some `c < 2`;
* `∥f z∥` is bounded from above by a constant on the imaginary axis;
* `f x`, `x : ℝ`, tends to zero superexponentially fast as `x → ∞`:
  for any natural `n`, `exp (n * x) * ∥f x∥` tends to zero as `x → ∞`.

Then `f` is equal to zero on the closed right half-plane. -/
lemma eq_zero_on_right_half_plane_of_superexponential_decay
  (hd : diff_cont_on_cl ℂ f {z | 0 < z.re})
  (hexp : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 {z | 0 < z.re}]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : superpolynomial_decay at_top expR (λ x, ∥f x∥))
  (him : ∃ C, ∀ x : ℝ, ∥f (x * I)∥ ≤ C) :
  eq_on f 0 {z : ℂ | 0 ≤ z.re} :=
begin
  rcases him with ⟨C, hC⟩,
  -- Due to continuity, it suffices to prove the equality on the open right half-plane.
  suffices : ∀ z : ℂ, 0 < z.re → f z = 0,
  { simpa only [closure_set_of_lt_re] using eq_on.of_subset_closure this hd.continuous_on
      continuous_on_const subset_closure subset.rfl },
  -- Consider $g_n(z)=e^{nz}f(z)$.
  set g : ℕ → ℂ → E := λ n z, (exp z) ^ n • f z,
  have hg : ∀ n z, ∥g n z∥ = (expR z.re) ^ n * ∥f z∥,
  { intros n z, simp only [norm_smul, norm_eq_abs, complex.abs_pow, abs_exp] },
  intros z hz,
  -- Since `e^{nz} → ∞` as `n → ∞`, it suffices to show that each `g_n` is bounded from above by `C`
  suffices H : ∀ n : ℕ, ∥g n z∥ ≤ C,
  { contrapose! H,
    simp only [hg],
    exact (((tendsto_pow_at_top_at_top_of_one_lt (real.one_lt_exp_iff.2 hz)).at_top_mul
      (norm_pos_iff.2 H) tendsto_const_nhds).eventually (eventually_gt_at_top C)).exists },
  intro n,
  -- This estimate follows from the Phragmen-Lindelöf principle in the right half-plane.
  refine right_half_plane_of_tendsto_zero_on_real (differentiable_exp.pow.diff_cont_on_cl.smul hd)
    _ _ (λ y, _) hz.le,
  { rcases hexp with ⟨c, hc, B, hO⟩,
    refine ⟨max c 1, max_lt hc one_lt_two, n + max B 0, is_O.of_norm_left _⟩,
    simp only [hg],
    refine ((is_O_refl (λ z : ℂ, expR z.re ^ n) _).mul hO.norm_left).trans (is_O.of_bound 1 _),
    simp only [← real.exp_nat_mul, ← real.exp_add, real.norm_of_nonneg (real.exp_pos _).le,
      real.exp_le_exp, add_mul, eventually_inf_principal, eventually_comap, one_mul],
    filter_upwards [eventually_ge_at_top (1 : ℝ)] with r hr z hzr hre, subst r,
    refine add_le_add (mul_le_mul_of_nonneg_left _ n.cast_nonneg) _,
    { calc z.re ≤ abs z : re_le_abs _
      ... = abs z ^ (1 : ℝ) : (real.rpow_one _).symm
      ... ≤ abs z ^ (max c 1) : real.rpow_le_rpow_of_exponent_le hr (le_max_right _ _) },
    { exact mul_le_mul (le_max_left _ _) (real.rpow_le_rpow_of_exponent_le hr (le_max_left _ _))
        (real.rpow_nonneg_of_nonneg (abs_nonneg _) _) (le_max_right _ _) } },
  { rw tendsto_zero_iff_norm_tendsto_zero, simp only [hg],
    exact hre n },
  { rw [hg, of_real_mul_re, I_re, mul_zero, real.exp_zero, one_pow, one_mul],
    exact hC y }
end

/-- **Phragmen-Lindelöf principle** in the right half-plane. Let `f g : ℂ → E` be functions such
that

* `f` and `g` are differentiable in the open right half-plane and are continuous on its closure;
* `∥f z∥` and `∥g z∥` are bounded from above by `A * exp(B * (abs z) ^ c)` on the open right
  half-plane for some `c < 2`;
* `∥f z∥` and `∥g z∥` are bounded from above by constants on the imaginary axis;
* `f x - g x`, `x : ℝ`, tends to zero superexponentially fast as `x → ∞`:
  for any natural `n`, `exp (n * x) * ∥f x - g x∥` tends to zero as `x → ∞`.

Then `f` is equal to `g` on the closed right half-plane. -/
lemma eq_on_right_half_plane_of_superexponential_decay {g : ℂ → E}
  (hfd : diff_cont_on_cl ℂ f {z | 0 < z.re}) (hgd : diff_cont_on_cl ℂ g {z | 0 < z.re})
  (hfexp : ∃ (c < (2 : ℝ)) B, f =O[comap complex.abs at_top ⊓ 𝓟 {z | 0 < z.re}]
    (λ z, expR (B * (abs z) ^ c)))
  (hgexp : ∃ (c < (2 : ℝ)) B, g =O[comap complex.abs at_top ⊓ 𝓟 {z | 0 < z.re}]
    (λ z, expR (B * (abs z) ^ c)))
  (hre : superpolynomial_decay at_top expR (λ x, ∥f x - g x∥))
  (hfim : ∃ C, ∀ x : ℝ, ∥f (x * I)∥ ≤ C) (hgim : ∃ C, ∀ x : ℝ, ∥g (x * I)∥ ≤ C) :
  eq_on f g {z : ℂ | 0 ≤ z.re} :=
begin
  suffices : eq_on (f - g) 0 {z : ℂ | 0 ≤ z.re},
    by simpa only [eq_on, pi.sub_apply, pi.zero_apply, sub_eq_zero] using this,
  refine eq_zero_on_right_half_plane_of_superexponential_decay (hfd.sub hgd) _ hre _,
  { set l : filter ℂ := comap abs at_top ⊓ 𝓟 {z : ℂ | 0 < z.re},
    suffices : ∀ {c₁ c₂ B₁ B₂ : ℝ}, c₁ ≤ c₂ → B₁ ≤ B₂ → 0 ≤ B₂ →
      (λ z, expR (B₁ * abs z ^ c₁)) =O[l] (λ z, expR (B₂ * abs z ^ c₂)),
    { rcases hfexp with ⟨cf, hcf, Bf, hOf⟩, rcases hgexp with ⟨cg, hcg, Bg, hOg⟩,
      refine ⟨max cf cg, max_lt hcf hcg, max 0 (max Bf Bg), _⟩,
      refine is_O.sub (hOf.trans $ this _ _ _) (hOg.trans $ this _ _ _); simp },
    intros c₁ c₂ B₁ B₂ hc hB hB₂,
    have : ∀ᶠ z : ℂ in l, 1 ≤ abs z,
      from ((eventually_ge_at_top 1).comap _).filter_mono inf_le_left,
    refine is_O.of_bound 1 (this.mono $ λ z hz, _),
    simp only [real.norm_of_nonneg (real.exp_pos _).le, real.exp_le_exp, one_mul],
    exact mul_le_mul hB (real.rpow_le_rpow_of_exponent_le hz hc)
      (real.rpow_nonneg_of_nonneg (abs_nonneg _) _) hB₂ },
  { rcases hfim with ⟨Cf, hCf⟩, rcases hgim with ⟨Cg, hCg⟩,
    exact ⟨Cf + Cg, λ x, norm_sub_le_of_le (hCf x) (hCg x)⟩ }
end

end phragmen_lindelof


<|start_filename|>src/group_theory/submonoid/center.lean<|end_filename|>
/-
Copyright (c) 2021 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import group_theory.submonoid.operations
import group_theory.subsemigroup.center
import data.fintype.basic

/-!
# Centers of monoids

## Main definitions

* `submonoid.center`: the center of a monoid
* `add_submonoid.center`: the center of an additive monoid

We provide `subgroup.center`, `add_subgroup.center`, `subsemiring.center`, and `subring.center` in
other files.
-/

namespace submonoid
section
variables (M : Type*) [monoid M]

/-- The center of a monoid `M` is the set of elements that commute with everything in `M` -/
@[to_additive "The center of a monoid `M` is the set of elements that commute with everything in
`M`"]
def center : submonoid M :=
{ carrier := set.center M,
  one_mem' := set.one_mem_center M,
  mul_mem' := λ a b, set.mul_mem_center }

@[to_additive] lemma coe_center : ↑(center M) = set.center M := rfl

@[simp]
lemma center_to_subsemigroup : (center M).to_subsemigroup = subsemigroup.center M := rfl

lemma _root_.add_submonoid.center_to_add_subsemigroup (M) [add_monoid M] :
  (add_submonoid.center M).to_add_subsemigroup = add_subsemigroup.center M := rfl

attribute [to_additive add_submonoid.center_to_add_subsemigroup] submonoid.center_to_subsemigroup

variables {M}

@[to_additive] lemma mem_center_iff {z : M} : z ∈ center M ↔ ∀ g, g * z = z * g := iff.rfl

instance decidable_mem_center [decidable_eq M] [fintype M] : decidable_pred (∈ center M) :=
λ _, decidable_of_iff' _ mem_center_iff

/-- The center of a monoid is commutative. -/
instance : comm_monoid (center M) :=
{ mul_comm := λ a b, subtype.ext $ b.prop _,
  .. (center M).to_monoid }

/-- The center of a monoid acts commutatively on that monoid. -/
instance center.smul_comm_class_left : smul_comm_class (center M) M M :=
{ smul_comm := λ m x y, (commute.left_comm (m.prop x) y).symm }

/-- The center of a monoid acts commutatively on that monoid. -/
instance center.smul_comm_class_right : smul_comm_class M (center M) M :=
smul_comm_class.symm _ _ _

/-! Note that `smul_comm_class (center M) (center M) M` is already implied by
`submonoid.smul_comm_class_right` -/
example : smul_comm_class (center M) (center M) M := by apply_instance

end

section
variables (M : Type*) [comm_monoid M]

@[simp] lemma center_eq_top : center M = ⊤ :=
set_like.coe_injective (set.center_eq_univ M)

end

end submonoid


<|start_filename|>src/topology/sheaves/sheaf_condition/equalizer_products.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.full_subcategory
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.products
import topology.sheaves.presheaf

/-!
# The sheaf condition in terms of an equalizer of products

Here we set up the machinery for the "usual" definition of the sheaf condition,
e.g. as in https://stacks.math.columbia.edu/tag/0072
in terms of an equalizer diagram where the two objects are
`∏ F.obj (U i)` and `∏ F.obj (U i) ⊓ (U j)`.

-/

universes v u

noncomputable theory

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

namespace Top

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

namespace presheaf

namespace sheaf_condition_equalizer_products

/-- The product of the sections of a presheaf over a family of open sets. -/
def pi_opens : C := ∏ (λ i : ι, F.obj (op (U i)))
/--
The product of the sections of a presheaf over the pairwise intersections of
a family of open sets.
-/
def pi_inters : C := ∏ (λ p : ι × ι, F.obj (op (U p.1 ⊓ U p.2)))

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U i` to `U i ⊓ U j`.
-/
def left_res : pi_opens F U ⟶ pi_inters F U :=
pi.lift (λ p : ι × ι, pi.π _ p.1 ≫ F.map (inf_le_left (U p.1) (U p.2)).op)

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def right_res : pi_opens F U ⟶ pi_inters F U :=
pi.lift (λ p : ι × ι, pi.π _ p.2 ≫ F.map (inf_le_right (U p.1) (U p.2)).op)

/--
The morphism `F.obj U ⟶ Π F.obj (U i)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def res : F.obj (op (supr U)) ⟶ pi_opens F U :=
pi.lift (λ i : ι, F.map (topological_space.opens.le_supr U i).op)

@[simp, elementwise]
lemma res_π (i : ι) : res F U ≫ limit.π _ ⟨i⟩ = F.map (opens.le_supr U i).op :=
by rw [res, limit.lift_π, fan.mk_π_app]

@[elementwise]
lemma w : res F U ≫ left_res F U = res F U ≫ right_res F U :=
begin
  dsimp [res, left_res, right_res],
  ext,
  simp only [limit.lift_π, limit.lift_π_assoc, fan.mk_π_app, category.assoc],
  rw [←F.map_comp],
  rw [←F.map_comp],
  congr,
end

/--
The equalizer diagram for the sheaf condition.
-/
@[reducible]
def diagram : walking_parallel_pair.{v} ⥤ C :=
parallel_pair (left_res F U) (right_res F U)

/--
The restriction map `F.obj U ⟶ Π F.obj (U i)` gives a cone over the equalizer diagram
for the sheaf condition. The sheaf condition asserts this cone is a limit cone.
-/
def fork : fork.{v} (left_res F U) (right_res F U) := fork.of_ι _ (w F U)

@[simp]
lemma fork_X : (fork F U).X = F.obj (op (supr U)) := rfl

@[simp]
lemma fork_ι : (fork F U).ι = res F U := rfl
@[simp]
lemma fork_π_app_walking_parallel_pair_zero :
  (fork F U).π.app walking_parallel_pair.zero = res F U := rfl
@[simp]
lemma fork_π_app_walking_parallel_pair_one :
  (fork F U).π.app walking_parallel_pair.one = res F U ≫ left_res F U := rfl

variables {F} {G : presheaf C X}

/-- Isomorphic presheaves have isomorphic `pi_opens` for any cover `U`. -/
@[simp]
def pi_opens.iso_of_iso (α : F ≅ G) : pi_opens F U ≅ pi_opens G U :=
pi.map_iso (λ X, α.app _)

/-- Isomorphic presheaves have isomorphic `pi_inters` for any cover `U`. -/
@[simp]
def pi_inters.iso_of_iso (α : F ≅ G) : pi_inters F U ≅ pi_inters G U :=
pi.map_iso (λ X, α.app _)

/-- Isomorphic presheaves have isomorphic sheaf condition diagrams. -/
def diagram.iso_of_iso (α : F ≅ G) : diagram F U ≅ diagram G U :=
nat_iso.of_components
  begin rintro ⟨⟩, exact pi_opens.iso_of_iso U α, exact pi_inters.iso_of_iso U α end
  begin
    rintro ⟨⟩ ⟨⟩ ⟨⟩,
    { simp, },
    { ext, simp [left_res], },
    { ext, simp [right_res], },
    { simp, },
  end.

/--
If `F G : presheaf C X` are isomorphic presheaves,
then the `fork F U`, the canonical cone of the sheaf condition diagram for `F`,
is isomorphic to `fork F G` postcomposed with the corresponding isomorphism between
sheaf condition diagrams.
-/
def fork.iso_of_iso (α : F ≅ G) :
  fork F U ≅ (cones.postcompose (diagram.iso_of_iso U α).inv).obj (fork G U) :=
begin
  fapply fork.ext,
  { apply α.app, },
  { ext,
    dunfold fork.ι, -- Ugh, `simp` can't unfold abbreviations.
    simp [res, diagram.iso_of_iso], }
end

section open_embedding

variables {V : Top.{v}} {j : V ⟶ X} (oe : open_embedding j)
variables (𝒰 : ι → opens V)

/--
Push forward a cover along an open embedding.
-/
@[simp]
def cover.of_open_embedding : ι → opens X := (λ i, oe.is_open_map.functor.obj (𝒰 i))

/--
The isomorphism between `pi_opens` corresponding to an open embedding.
-/
@[simp]
def pi_opens.iso_of_open_embedding :
  pi_opens (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ pi_opens F (cover.of_open_embedding oe 𝒰) :=
pi.map_iso (λ X, F.map_iso (iso.refl _))

/--
The isomorphism between `pi_inters` corresponding to an open embedding.
-/
@[simp]
def pi_inters.iso_of_open_embedding :
  pi_inters (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ pi_inters F (cover.of_open_embedding oe 𝒰) :=
pi.map_iso (λ X, F.map_iso
  begin
    dsimp [is_open_map.functor],
    exact iso.op
    { hom := hom_of_le (by
      { simp only [oe.to_embedding.inj, set.image_inter],
        exact le_rfl, }),
      inv := hom_of_le (by
      { simp only [oe.to_embedding.inj, set.image_inter],
        exact le_rfl, }), },
  end)

/-- The isomorphism of sheaf condition diagrams corresponding to an open embedding. -/
def diagram.iso_of_open_embedding :
  diagram (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ diagram F (cover.of_open_embedding oe 𝒰) :=
nat_iso.of_components
  begin
    rintro ⟨⟩,
    exact pi_opens.iso_of_open_embedding oe 𝒰,
    exact pi_inters.iso_of_open_embedding oe 𝒰
  end
  begin
    rintro ⟨⟩ ⟨⟩ ⟨⟩,
    { simp, },
    { ext,
      dsimp [left_res, is_open_map.functor],
      simp only [limit.lift_π, cones.postcompose_obj_π, iso.op_hom, discrete.nat_iso_hom_app,
        functor.map_iso_refl, functor.map_iso_hom, lim_map_π_assoc, limit.lift_map, fan.mk_π_app,
        nat_trans.comp_app, category.assoc],
      dsimp,
      rw [category.id_comp, ←F.map_comp],
      refl, },
    { ext,
      dsimp [right_res, is_open_map.functor],
      simp only [limit.lift_π, cones.postcompose_obj_π, iso.op_hom, discrete.nat_iso_hom_app,
        functor.map_iso_refl, functor.map_iso_hom, lim_map_π_assoc, limit.lift_map, fan.mk_π_app,
        nat_trans.comp_app, category.assoc],
      dsimp,
      rw [category.id_comp, ←F.map_comp],
      refl, },
    { simp, },
  end.

/--
If `F : presheaf C X` is a presheaf, and `oe : U ⟶ X` is an open embedding,
then the sheaf condition fork for a cover `𝒰` in `U` for the composition of `oe` and `F` is
isomorphic to sheaf condition fork for `oe '' 𝒰`, precomposed with the isomorphism
of indexing diagrams `diagram.iso_of_open_embedding`.

We use this to show that the restriction of sheaf along an open embedding is still a sheaf.
-/
def fork.iso_of_open_embedding :
  fork (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅
    (cones.postcompose (diagram.iso_of_open_embedding oe 𝒰).inv).obj
      (fork F (cover.of_open_embedding oe 𝒰)) :=
begin
  fapply fork.ext,
  { dsimp [is_open_map.functor],
    exact
    F.map_iso (iso.op
    { hom := hom_of_le
      (by simp only [supr_s, supr_mk, le_def, subtype.coe_mk, set.le_eq_subset, set.image_Union]),
      inv := hom_of_le
      (by simp only [supr_s, supr_mk, le_def, subtype.coe_mk, set.le_eq_subset,
                     set.image_Union]) }), },
  { ext ⟨j⟩,
    dunfold fork.ι, -- Ugh, it is unpleasant that we need this.
    simp only [res, diagram.iso_of_open_embedding, discrete.nat_iso_inv_app, functor.map_iso_inv,
      limit.lift_π, cones.postcompose_obj_π, functor.comp_map,
      fork_π_app_walking_parallel_pair_zero, pi_opens.iso_of_open_embedding,
      nat_iso.of_components.inv_app, functor.map_iso_refl, functor.op_map, limit.lift_map,
      fan.mk_π_app, nat_trans.comp_app, quiver.hom.unop_op, category.assoc, lim_map_eq_lim_map],
    dsimp,
    rw [category.comp_id, ←F.map_comp],
    refl, },
end

end open_embedding

end sheaf_condition_equalizer_products

end presheaf

end Top


<|start_filename|>src/probability/variance.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import probability.notation
import probability.integration

/-!
# Variance of random variables

We define the variance of a real-valued random variable as `Var[X] = 𝔼[(X - 𝔼[X])^2]` (in the
`probability_theory` locale).

We prove the basic properties of the variance:
* `variance_le_expectation_sq`: the inequality `Var[X] ≤ 𝔼[X^2]`.
* `meas_ge_le_variance_div_sq`: Chebyshev's inequality, i.e.,
      `ℙ {ω | c ≤ |X ω - 𝔼[X]|} ≤ ennreal.of_real (Var[X] / c ^ 2)`.
* `indep_fun.variance_add`: the variance of the sum of two independent random variables is the sum
  of the variances.
* `indep_fun.variance_sum`: the variance of a finite sum of pairwise independent random variables is
  the sum of the variances.
-/

open measure_theory filter finset

noncomputable theory

open_locale big_operators measure_theory probability_theory ennreal nnreal

namespace probability_theory

/-- The variance of a random variable is `𝔼[X^2] - 𝔼[X]^2` or, equivalently, `𝔼[(X - 𝔼[X])^2]`. We
use the latter as the definition, to ensure better behavior even in garbage situations. -/
def variance {Ω : Type*} {m : measurable_space Ω} (f : Ω → ℝ) (μ : measure Ω) : ℝ :=
μ[(f - (λ x, μ[f])) ^ 2]

@[simp] lemma variance_zero {Ω : Type*} {m : measurable_space Ω} (μ : measure Ω) :
  variance 0 μ = 0 :=
by simp [variance]

lemma variance_nonneg {Ω : Type*} {m : measurable_space Ω} (f : Ω → ℝ) (μ : measure Ω) :
  0 ≤ variance f μ :=
integral_nonneg (λ x, sq_nonneg _)

lemma variance_mul {Ω : Type*} {m : measurable_space Ω} (c : ℝ) (f : Ω → ℝ) (μ : measure Ω) :
  variance (λ x, c * f x) μ = c^2 * variance f μ :=
calc
variance (λ x, c * f x) μ
    = ∫ x, (c * f x - ∫ y, c * f y ∂μ) ^ 2 ∂μ : rfl
... = ∫ x, (c * (f x - ∫ y, f y ∂μ)) ^ 2 ∂μ :
  by { congr' 1 with x, simp_rw [integral_mul_left, mul_sub] }
... = c^2 * variance f μ :
  by { simp_rw [mul_pow, integral_mul_left], refl }

lemma variance_smul {Ω : Type*} {m : measurable_space Ω} (c : ℝ) (f : Ω → ℝ) (μ : measure Ω) :
  variance (c • f) μ = c^2 * variance f μ :=
variance_mul c f μ

lemma variance_smul' {A : Type*} [comm_semiring A] [algebra A ℝ]
  {Ω : Type*} {m : measurable_space Ω} (c : A) (f : Ω → ℝ) (μ : measure Ω) :
  variance (c • f) μ = c^2 • variance f μ :=
begin
  convert variance_smul (algebra_map A ℝ c) f μ,
  { ext1 x, simp only [algebra_map_smul], },
  { simp only [algebra.smul_def, map_pow], }
end

localized
"notation `Var[` X `]` := probability_theory.variance X measure_theory.measure_space.volume"
in probability_theory

variables {Ω : Type*} [measure_space Ω] [is_probability_measure (volume : measure Ω)]

lemma variance_def' {X : Ω → ℝ} (hX : mem_ℒp X 2) :
  Var[X] = 𝔼[X^2] - 𝔼[X]^2 :=
begin
  rw [variance, sub_sq', integral_sub', integral_add'], rotate,
  { exact hX.integrable_sq },
  { convert integrable_const (𝔼[X] ^ 2),
    apply_instance },
  { apply hX.integrable_sq.add,
    convert integrable_const (𝔼[X] ^ 2),
    apply_instance },
  { exact ((hX.integrable ennreal.one_le_two).const_mul 2).mul_const' _ },
  simp only [integral_mul_right, pi.pow_apply, pi.mul_apply, pi.bit0_apply, pi.one_apply,
    integral_const (integral ℙ X ^ 2), integral_mul_left (2 : ℝ), one_mul,
    variance, pi.pow_apply, measure_univ, ennreal.one_to_real, algebra.id.smul_eq_mul],
  ring,
end

lemma variance_le_expectation_sq {X : Ω → ℝ} :
  Var[X] ≤ 𝔼[X^2] :=
begin
  by_cases h_int : integrable X, swap,
  { simp only [variance, integral_undef h_int, pi.pow_apply, pi.sub_apply, sub_zero] },
  by_cases hX : mem_ℒp X 2,
  { rw variance_def' hX,
    simp only [sq_nonneg, sub_le_self_iff] },
  { rw [variance, integral_undef],
    { exact integral_nonneg (λ a, sq_nonneg _) },
    { assume h,
      have A : mem_ℒp (X - λ (x : Ω), 𝔼[X]) 2 ℙ := (mem_ℒp_two_iff_integrable_sq
        (h_int.ae_strongly_measurable.sub ae_strongly_measurable_const)).2 h,
      have B : mem_ℒp (λ (x : Ω), 𝔼[X]) 2 ℙ := mem_ℒp_const _,
      apply hX,
      convert A.add B,
      simp } }
end

/-- *Chebyshev's inequality* : one can control the deviation probability of a real random variable
from its expectation in terms of the variance. -/
theorem meas_ge_le_variance_div_sq {X : Ω → ℝ} (hX : mem_ℒp X 2) {c : ℝ} (hc : 0 < c) :
  ℙ {ω | c ≤ |X ω - 𝔼[X]|} ≤ ennreal.of_real (Var[X] / c ^ 2) :=
begin
  have A : (ennreal.of_real c : ℝ≥0∞) ≠ 0,
    by simp only [hc, ne.def, ennreal.of_real_eq_zero, not_le],
  have B : ae_strongly_measurable (λ (ω : Ω), 𝔼[X]) ℙ := ae_strongly_measurable_const,
  convert meas_ge_le_mul_pow_snorm ℙ ennreal.two_ne_zero ennreal.two_ne_top
    (hX.ae_strongly_measurable.sub B) A,
  { ext ω,
    set d : ℝ≥0 := ⟨c, hc.le⟩ with hd,
    have cd : c = d, by simp only [subtype.coe_mk],
    simp only [pi.sub_apply, ennreal.coe_le_coe, ← real.norm_eq_abs, ← coe_nnnorm,
      nnreal.coe_le_coe, cd, ennreal.of_real_coe_nnreal] },
  { rw (hX.sub (mem_ℒp_const _)).snorm_eq_integral_rpow_norm
      ennreal.two_ne_zero ennreal.two_ne_top,
    simp only [pi.sub_apply, ennreal.to_real_bit0, ennreal.one_to_real],
    rw ennreal.of_real_rpow_of_nonneg _ zero_le_two, rotate,
    { apply real.rpow_nonneg_of_nonneg,
      exact integral_nonneg (λ x, real.rpow_nonneg_of_nonneg (norm_nonneg _) _) },
    rw [variance, ← real.rpow_mul, inv_mul_cancel], rotate,
    { exact two_ne_zero },
    { exact integral_nonneg (λ x, real.rpow_nonneg_of_nonneg (norm_nonneg _) _) },
    simp only [pi.pow_apply, pi.sub_apply, real.rpow_two, real.rpow_one, real.norm_eq_abs,
      pow_bit0_abs, ennreal.of_real_inv_of_pos hc, ennreal.rpow_two],
    rw [← ennreal.of_real_pow (inv_nonneg.2 hc.le), ← ennreal.of_real_mul (sq_nonneg _),
      div_eq_inv_mul, inv_pow] }
end

/-- The variance of the sum of two independent random variables is the sum of the variances. -/
theorem indep_fun.variance_add {X Y : Ω → ℝ}
  (hX : mem_ℒp X 2) (hY : mem_ℒp Y 2) (h : indep_fun X Y) :
  Var[X + Y] = Var[X] + Var[Y] :=
calc
Var[X + Y] = 𝔼[λ a, (X a)^2 + (Y a)^2 + 2 * X a * Y a] - 𝔼[X+Y]^2 :
  by simp [variance_def' (hX.add hY), add_sq']
... = (𝔼[X^2] + 𝔼[Y^2] + 2 * 𝔼[X * Y]) - (𝔼[X] + 𝔼[Y])^2 :
begin
  simp only [pi.add_apply, pi.pow_apply, pi.mul_apply, mul_assoc],
  rw [integral_add, integral_add, integral_add, integral_mul_left],
  { exact hX.integrable ennreal.one_le_two },
  { exact hY.integrable ennreal.one_le_two },
  { exact hX.integrable_sq },
  { exact hY.integrable_sq },
  { exact hX.integrable_sq.add hY.integrable_sq },
  { apply integrable.const_mul,
    exact h.integrable_mul (hX.integrable ennreal.one_le_two) (hY.integrable ennreal.one_le_two) }
end
... = (𝔼[X^2] + 𝔼[Y^2] + 2 * (𝔼[X] * 𝔼[Y])) - (𝔼[X] + 𝔼[Y])^2 :
begin
  congr,
  exact h.integral_mul_of_integrable
    (hX.integrable ennreal.one_le_two) (hY.integrable ennreal.one_le_two),
end
... = Var[X] + Var[Y] :
  by { simp only [variance_def', hX, hY, pi.pow_apply], ring }

/-- The variance of a finite sum of pairwise independent random variables is the sum of the
variances. -/
theorem indep_fun.variance_sum {ι : Type*} {X : ι → Ω → ℝ} {s : finset ι}
  (hs : ∀ i ∈ s, mem_ℒp (X i) 2) (h : set.pairwise ↑s (λ i j, indep_fun (X i) (X j))) :
  Var[∑ i in s, X i] = ∑ i in s, Var[X i] :=
begin
  classical,
  induction s using finset.induction_on with k s ks IH,
  { simp only [finset.sum_empty, variance_zero] },
  rw [variance_def' (mem_ℒp_finset_sum' _ hs), sum_insert ks, sum_insert ks],
  simp only [add_sq'],
  calc 𝔼[X k ^ 2 + (∑ i in s, X i) ^ 2 + 2 * X k * ∑ i in s, X i] - 𝔼[X k + ∑ i in s, X i] ^ 2
  = (𝔼[X k ^ 2] + 𝔼[(∑ i in s, X i) ^ 2] + 𝔼[2 * X k * ∑ i in s, X i])
    - (𝔼[X k] + 𝔼[∑ i in s, X i]) ^ 2 :
  begin
    rw [integral_add', integral_add', integral_add'],
    { exact mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_self _ _)) },
    { apply integrable_finset_sum' _ (λ i hi, _),
      exact mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_of_mem hi)) },
    { exact mem_ℒp.integrable_sq (hs _ (mem_insert_self _ _)) },
    { apply mem_ℒp.integrable_sq,
      exact mem_ℒp_finset_sum' _ (λ i hi, (hs _ (mem_insert_of_mem hi))) },
    { apply integrable.add,
      { exact mem_ℒp.integrable_sq (hs _ (mem_insert_self _ _)) },
      { apply mem_ℒp.integrable_sq,
        exact mem_ℒp_finset_sum' _ (λ i hi, (hs _ (mem_insert_of_mem hi))) } },
    { rw mul_assoc,
      apply integrable.const_mul _ 2,
      simp only [mul_sum, sum_apply, pi.mul_apply],
      apply integrable_finset_sum _ (λ i hi, _),
      apply indep_fun.integrable_mul _
        (mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_self _ _)))
        (mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_of_mem hi))),
      apply h (mem_insert_self _ _) (mem_insert_of_mem hi),
      exact (λ hki, ks (hki.symm ▸ hi)) }
  end
  ... = Var[X k] + Var[∑ i in s, X i] +
    (𝔼[2 * X k * ∑ i in s, X i] - 2 * 𝔼[X k] * 𝔼[∑ i in s, X i]) :
  begin
    rw [variance_def' (hs _ (mem_insert_self _ _)),
        variance_def' (mem_ℒp_finset_sum' _ (λ i hi, (hs _ (mem_insert_of_mem hi))))],
    ring,
  end
  ... = Var[X k] + Var[∑ i in s, X i] :
  begin
    simp only [mul_assoc, integral_mul_left, pi.mul_apply, pi.bit0_apply, pi.one_apply, sum_apply,
      add_right_eq_self, mul_sum],
    rw integral_finset_sum s (λ i hi, _), swap,
    { apply integrable.const_mul _ 2,
      apply indep_fun.integrable_mul _
        (mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_self _ _)))
        (mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_of_mem hi))),
      apply h (mem_insert_self _ _) (mem_insert_of_mem hi),
      exact (λ hki, ks (hki.symm ▸ hi)) },
    rw [integral_finset_sum s
      (λ i hi, (mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_of_mem hi)))),
      mul_sum, mul_sum, ← sum_sub_distrib],
    apply finset.sum_eq_zero (λ i hi, _),
    rw [integral_mul_left, indep_fun.integral_mul_of_integrable', sub_self],
    { apply h (mem_insert_self _ _) (mem_insert_of_mem hi),
      exact (λ hki, ks (hki.symm ▸ hi)) },
    { exact mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_self _ _)) },
    { exact mem_ℒp.integrable ennreal.one_le_two (hs _ (mem_insert_of_mem hi)) }
  end
  ... = Var[X k] + ∑ i in s, Var[X i] :
    by rw IH (λ i hi, hs i (mem_insert_of_mem hi))
      (h.mono (by simp only [coe_insert, set.subset_insert]))
end

end probability_theory


<|start_filename|>src/category_theory/limits/shapes/zero_objects.lean<|end_filename|>
/-
Copyright (c) 2019 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import category_theory.limits.shapes.products
import category_theory.limits.shapes.images
import category_theory.isomorphism_classes

/-!
# Zero objects

A category "has a zero object" if it has an object which is both initial and terminal. Having a
zero object provides zero morphisms, as the unique morphisms factoring through the zero object;
see `category_theory.limits.shapes.zero_morphisms`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]
-/

noncomputable theory

universes v u v' u'

open category_theory
open category_theory.category

variables {C : Type u} [category.{v} C]
variables {D : Type u'} [category.{v'} D]

namespace category_theory

namespace limits

/-- An object `X` in a category is a *zero object* if for every object `Y`
there is a unique morphism `to : X → Y` and a unique morphism `from : Y → X`.

This is a characteristic predicate for `has_zero_object`. -/
structure is_zero (X : C) : Prop :=
(unique_to   : ∀ Y, nonempty (unique (X ⟶ Y)))
(unique_from : ∀ Y, nonempty (unique (Y ⟶ X)))

namespace is_zero

variables {X Y : C}

/-- If `h : is_zero X`, then `h.to Y` is a choice of unique morphism `X → Y`. -/
protected def «to» (h : is_zero X) (Y : C) : X ⟶ Y :=
@default (X ⟶ Y) $ @unique.inhabited _ $ (h.unique_to Y).some

lemma eq_to (h : is_zero X) (f : X ⟶ Y) : f = h.to Y :=
@unique.eq_default _ (id _) _

lemma to_eq (h : is_zero X) (f : X ⟶ Y) : h.to Y = f :=
(h.eq_to f).symm

/-- If `h : is_zero X`, then `h.from Y` is a choice of unique morphism `Y → X`. -/
protected def «from» (h : is_zero X) (Y : C) : Y ⟶ X :=
@default (Y ⟶ X) $ @unique.inhabited _ $ (h.unique_from Y).some

lemma eq_from (h : is_zero X) (f : Y ⟶ X) : f = h.from Y :=
@unique.eq_default _ (id _) _

lemma from_eq (h : is_zero X) (f : Y ⟶ X) : h.from Y = f :=
(h.eq_from f).symm

lemma eq_of_src (hX : is_zero X) (f g : X ⟶ Y) : f = g :=
(hX.eq_to f).trans (hX.eq_to g).symm

lemma eq_of_tgt (hX : is_zero X) (f g : Y ⟶ X) : f = g :=
(hX.eq_from f).trans (hX.eq_from g).symm

/-- Any two zero objects are isomorphic. -/
def iso (hX : is_zero X) (hY : is_zero Y) : X ≅ Y :=
{ hom := hX.to Y,
  inv := hX.from Y,
  hom_inv_id' := hX.eq_of_src _ _,
  inv_hom_id' := hY.eq_of_src _ _, }

/-- A zero object is in particular initial. -/
protected def is_initial (hX : is_zero X) : is_initial X :=
@is_initial.of_unique _ _ X $ λ Y, (hX.unique_to Y).some

/-- A zero object is in particular terminal. -/
protected def is_terminal (hX : is_zero X) : is_terminal X :=
@is_terminal.of_unique _ _ X $ λ Y, (hX.unique_from Y).some

/-- The (unique) isomorphism between any initial object and the zero object. -/
def iso_is_initial (hX : is_zero X) (hY : is_initial Y) : X ≅ Y :=
hX.is_initial.unique_up_to_iso hY

/-- The (unique) isomorphism between any terminal object and the zero object. -/
def iso_is_terminal (hX : is_zero X) (hY : is_terminal Y) : X ≅ Y :=
hX.is_terminal.unique_up_to_iso hY

lemma of_iso (hY : is_zero Y) (e : X ≅ Y) : is_zero X :=
begin
  refine ⟨λ Z, ⟨⟨⟨e.hom ≫ hY.to Z⟩, λ f, _⟩⟩, λ Z, ⟨⟨⟨hY.from Z ≫ e.inv⟩, λ f, _⟩⟩⟩,
  { rw ← cancel_epi e.inv, apply hY.eq_of_src, },
  { rw ← cancel_mono e.hom, apply hY.eq_of_tgt, },
end

end is_zero

end limits

open category_theory.limits

lemma iso.is_zero_iff {X Y : C} (e : X ≅ Y) :
  is_zero X ↔ is_zero Y :=
⟨λ h, h.of_iso e.symm, λ h, h.of_iso e⟩

lemma functor.is_zero (F : C ⥤ D) (hF : ∀ X, is_zero (F.obj X)) :
  is_zero F :=
begin
  split; intros G; refine ⟨⟨⟨_⟩, _⟩⟩,
  { refine { app := λ X, (hF _).to _, naturality' := _ },
    intros, exact (hF _).eq_of_src _ _ },
  { intro f, ext, apply (hF _).eq_of_src _ _ },
  { refine { app := λ X, (hF _).from _, naturality' := _ },
    intros, exact (hF _).eq_of_tgt _ _ },
  { intro f, ext, apply (hF _).eq_of_tgt _ _ },
end

namespace limits

variables (C)

/-- A category "has a zero object" if it has an object which is both initial and terminal. -/
class has_zero_object : Prop :=
(zero : ∃ X : C, is_zero X)

instance has_zero_object_punit : has_zero_object (discrete punit) :=
{ zero := ⟨⟨⟨⟩⟩, by tidy, by tidy⟩, }

section

variables [has_zero_object C]

/--
Construct a `has_zero C` for a category with a zero object.
This can not be a global instance as it will trigger for every `has_zero C` typeclass search.
-/
protected def has_zero_object.has_zero : has_zero C :=
{ zero := has_zero_object.zero.some }

localized "attribute [instance] category_theory.limits.has_zero_object.has_zero" in zero_object

lemma is_zero_zero : is_zero (0 : C) :=
has_zero_object.zero.some_spec

end

open_locale zero_object

variables {C}

lemma is_zero.has_zero_object {X : C} (hX : is_zero X) : has_zero_object C := ⟨⟨X, hX⟩⟩

/-- Every zero object is isomorphic to *the* zero object. -/
def is_zero.iso_zero [has_zero_object C] {X : C} (hX : is_zero X) : X ≅ 0 :=
hX.iso (is_zero_zero C)

lemma is_zero.obj [has_zero_object D] {F : C ⥤ D} (hF : is_zero F) (X : C) :
  is_zero (F.obj X) :=
begin
  let G : C ⥤ D := (category_theory.functor.const C).obj 0,
  have hG : is_zero G := functor.is_zero _ (λ X, is_zero_zero _),
  let e : F ≅ G := hF.iso hG,
  exact (is_zero_zero _).of_iso (e.app X),
end

namespace has_zero_object
variables [has_zero_object C]

/-- There is a unique morphism from the zero object to any object `X`. -/
protected def unique_to (X : C) : unique (0 ⟶ X) :=
((is_zero_zero C).unique_to X).some

/-- There is a unique morphism from any object `X` to the zero object. -/
protected def unique_from (X : C) : unique (X ⟶ 0) :=
((is_zero_zero C).unique_from X).some

localized "attribute [instance] category_theory.limits.has_zero_object.unique_to" in zero_object
localized "attribute [instance] category_theory.limits.has_zero_object.unique_from" in zero_object

@[ext]
lemma to_zero_ext {X : C} (f g : X ⟶ 0) : f = g :=
(is_zero_zero C).eq_of_tgt _ _

@[ext]
lemma from_zero_ext {X : C} (f g : 0 ⟶ X) : f = g :=
(is_zero_zero C).eq_of_src _ _

instance (X : C) : subsingleton (X ≅ 0) := by tidy

instance {X : C} (f : 0 ⟶ X) : mono f :=
{ right_cancellation := λ Z g h w, by ext, }

instance {X : C} (f : X ⟶ 0) : epi f :=
{ left_cancellation := λ Z g h w, by ext, }

instance zero_to_zero_is_iso (f : (0 : C) ⟶ 0) :
  is_iso f :=
by convert (show is_iso (𝟙 (0 : C)), by apply_instance)

/-- A zero object is in particular initial. -/
def zero_is_initial : is_initial (0 : C) :=
(is_zero_zero C).is_initial

/-- A zero object is in particular terminal. -/
def zero_is_terminal : is_terminal (0 : C) :=
(is_zero_zero C).is_terminal

/-- A zero object is in particular initial. -/
@[priority 10]
instance has_initial : has_initial C :=
has_initial_of_unique 0

/-- A zero object is in particular terminal. -/
@[priority 10]
instance has_terminal : has_terminal C :=
has_terminal_of_unique 0

/-- The (unique) isomorphism between any initial object and the zero object. -/
def zero_iso_is_initial {X : C} (t : is_initial X) : 0 ≅ X :=
zero_is_initial.unique_up_to_iso t

/-- The (unique) isomorphism between any terminal object and the zero object. -/
def zero_iso_is_terminal {X : C} (t : is_terminal X) : 0 ≅ X :=
zero_is_terminal.unique_up_to_iso t

/-- The (unique) isomorphism between the chosen initial object and the chosen zero object. -/
def zero_iso_initial [has_initial C] : 0 ≅ ⊥_ C :=
zero_is_initial.unique_up_to_iso initial_is_initial

/-- The (unique) isomorphism between the chosen terminal object and the chosen zero object. -/
def zero_iso_terminal [has_terminal C] : 0 ≅ ⊤_ C :=
zero_is_terminal.unique_up_to_iso terminal_is_terminal

@[priority 100]
instance has_strict_initial : initial_mono_class C :=
initial_mono_class.of_is_initial zero_is_initial (λ X, category_theory.mono _)

end has_zero_object

end limits

open category_theory.limits
open_locale zero_object

lemma functor.is_zero_iff [has_zero_object D] (F : C ⥤ D) :
  is_zero F ↔ ∀ X, is_zero (F.obj X) :=
⟨λ hF X, hF.obj X, functor.is_zero _⟩

end category_theory


<|start_filename|>src/topology/vector_bundle/basic.lean<|end_filename|>
/-
Copyright © 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>, <NAME>, <NAME>, <NAME>
-/

import analysis.normed_space.bounded_linear_maps
import topology.fiber_bundle

/-!
# Topological vector bundles

In this file we define topological vector bundles.

Let `B` be the base space. In our formalism, a topological vector bundle is by definition the type
`bundle.total_space E` where `E : B → Type*` is a function associating to
`x : B` the fiber over `x`. This type `bundle.total_space E` is just a type synonym for
`Σ (x : B), E x`, with the interest that one can put another topology than on `Σ (x : B), E x`
which has the disjoint union topology.

To have a topological vector bundle structure on `bundle.total_space E`, one should
additionally have the following data:

* `F` should be a normed space over a normed field `R`;
* There should be a topology on `bundle.total_space E`, for which the projection to `B` is
a topological fiber bundle with fiber `F` (in particular, each fiber `E x` is homeomorphic to `F`);
* For each `x`, the fiber `E x` should be a topological vector space over `R`, and the injection
from `E x` to `bundle.total_space F E` should be an embedding;
* There should be a distinguished set of bundle trivializations (which are continuous linear equivs
in the fibres), the "trivialization atlas"
* There should be a choice of bundle trivialization at each point, which belongs to this atlas.

If all these conditions are satisfied, and if moreover for any two trivializations `e`, `e'` in the
atlas the transition function considered as a map from `B` into `F →L[R] F` is continuous on
`e.base_set ∩ e'.base_set` with respect to the operator norm topology on `F →L[R] F`, we register
the typeclass `topological_vector_bundle R F E`.

We define constructions on vector bundles like pullbacks and direct sums in other files.
Only the trivial bundle is defined in this file.

## Tags
Vector bundle
-/

noncomputable theory

open bundle set
open_locale classical

variables (R 𝕜 : Type*) {B : Type*} (F : Type*) (E : B → Type*)

section topological_vector_space
variables [semiring R] [∀ x, add_comm_monoid (E x)] [∀ x, module R (E x)]
  [topological_space F] [add_comm_monoid F] [module R F] [topological_space B]

/-- A pretrivialization for a (yet to be defined) topological vector bundle `total_space E` is a
local equiv between sets of the form `proj ⁻¹' base_set` and `base_set × F` which respects the
first coordinate, and is linear in each fiber. -/
@[nolint has_inhabited_instance]
structure topological_vector_bundle.pretrivialization extends to_fiber_bundle_pretrivialization :
  topological_fiber_bundle.pretrivialization F (@total_space.proj B E) :=
(linear' : ∀ x ∈ base_set, is_linear_map R (λ y : E x, (to_fun (total_space_mk x y)).2))

instance : has_coe_to_fun (topological_vector_bundle.pretrivialization R F E) _ := ⟨λ e, e.to_fun⟩

instance : has_coe (topological_vector_bundle.pretrivialization R F E)
  (topological_fiber_bundle.pretrivialization F (@total_space.proj B E)) :=
⟨topological_vector_bundle.pretrivialization.to_fiber_bundle_pretrivialization⟩

namespace topological_vector_bundle.pretrivialization

open topological_vector_bundle

variables {R F E} (e : pretrivialization R F E) {x : total_space E} {b : B} {y : E b}

protected lemma linear (hb : b ∈ e.base_set) :
  is_linear_map R (λ y : E b, (e (total_space_mk b y)).2) :=
e.linear' b hb

@[simp, mfld_simps] lemma coe_coe : ⇑e.to_local_equiv = e := rfl
@[simp, mfld_simps] lemma coe_fst (ex : x ∈ e.source) : (e x).1 = x.proj := e.proj_to_fun x ex
lemma mem_source : x ∈ e.source ↔ x.proj ∈ e.base_set := by rw [e.source_eq, mem_preimage]
lemma coe_mem_source : ↑y ∈ e.source ↔ b ∈ e.base_set := e.mem_source
lemma coe_fst' (ex : x.proj ∈ e.base_set) : (e x).1 = x.proj :=
e.coe_fst (e.mem_source.2 ex)

protected lemma eq_on : eq_on (prod.fst ∘ e) total_space.proj e.source := λ x hx, e.coe_fst hx
lemma mk_proj_snd (ex : x ∈ e.source) : (x.proj, (e x).2) = e x :=
prod.ext (e.coe_fst ex).symm rfl

@[simp, mfld_simps] lemma coe_coe_fst (hb : b ∈ e.base_set) : (e y).1 = b :=
e.coe_fst (e.mem_source.2 hb)

lemma mk_proj_snd' (ex : x.proj ∈ e.base_set) : (x.proj, (e x).2) = e x :=
prod.ext (e.coe_fst' ex).symm rfl

lemma mem_target {x : B × F} : x ∈ e.target ↔ x.1 ∈ e.base_set :=
e.to_fiber_bundle_pretrivialization.mem_target

lemma mk_mem_target {x : B} {y : F} : (x, y) ∈ e.target ↔ x ∈ e.base_set :=
e.mem_target

lemma proj_symm_apply {x : B × F} (hx : x ∈ e.target) : (e.to_local_equiv.symm x).proj = x.1 :=
e.to_fiber_bundle_pretrivialization.proj_symm_apply hx

lemma proj_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  (e.to_local_equiv.symm (b, x)).proj = b :=
e.proj_symm_apply (e.mem_target.2 hx)

lemma apply_symm_apply {x : B × F} (hx : x ∈ e.target) : e (e.to_local_equiv.symm x) = x :=
e.to_local_equiv.right_inv hx

lemma symm_apply_apply {x : total_space E} (hx : x ∈ e.source) : e.to_local_equiv.symm (e x) = x :=
e.to_local_equiv.left_inv hx

lemma apply_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  e (e.to_local_equiv.symm (b, x)) = (b, x) :=
e.apply_symm_apply (e.mem_target.2 hx)

@[simp, mfld_simps] lemma symm_apply_mk_proj (ex : x ∈ e.source) :
  e.to_local_equiv.symm (x.proj, (e x).2) = x :=
by rw [← e.coe_fst ex, prod.mk.eta, ← e.coe_coe, e.to_local_equiv.left_inv ex]

@[simp, mfld_simps] lemma preimage_symm_proj_base_set :
  (e.to_local_equiv.symm ⁻¹' (total_space.proj ⁻¹' e.base_set)) ∩ e.target  = e.target :=
e.to_fiber_bundle_pretrivialization.preimage_symm_proj_base_set

lemma symm_coe_proj {x : B} {y : F} (e : pretrivialization R F E) (h : x ∈ e.base_set) :
  (e.to_local_equiv.symm (x, y)).1 = x :=
e.proj_symm_apply' h

/-- A fiberwise inverse to `e`. This is the function `F → E b` that induces a local inverse
`B × F → total_space E` of `e` on `e.base_set`. It is defined to be `0` outside `e.base_set`. -/
protected def symm (e : pretrivialization R F E) (b : B) (y : F) : E b :=
if hb : b ∈ e.base_set
then cast (congr_arg E (e.proj_symm_apply' hb)) (e.to_local_equiv.symm (b, y)).2
else 0

lemma symm_apply (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e.symm b y = cast (congr_arg E (e.symm_coe_proj hb)) (e.to_local_equiv.symm (b, y)).2 :=
dif_pos hb

lemma symm_apply_of_not_mem (e : pretrivialization R F E) {b : B} (hb : b ∉ e.base_set) (y : F) :
  e.symm b y = 0 :=
dif_neg hb

lemma coe_symm_of_not_mem (e : pretrivialization R F E) {b : B} (hb : b ∉ e.base_set) :
  (e.symm b : F → E b) = 0 :=
funext $ λ y, dif_neg hb

lemma mk_symm (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  total_space_mk b (e.symm b y) = e.to_local_equiv.symm (b, y) :=
by rw [e.symm_apply hb, total_space.mk_cast, total_space.eta]

lemma symm_proj_apply (e : pretrivialization R F E) (z : total_space E)
  (hz : z.proj ∈ e.base_set) : e.symm z.proj (e z).2 = z.2 :=
by rw [e.symm_apply hz, cast_eq_iff_heq, e.mk_proj_snd' hz,
  e.symm_apply_apply (e.mem_source.mpr hz)]

lemma symm_apply_apply_mk (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : E b) :
  e.symm b (e (total_space_mk b y)).2 = y :=
e.symm_proj_apply (total_space_mk b y) hb

lemma apply_mk_symm (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e (total_space_mk b (e.symm b y)) = (b, y) :=
by rw [e.mk_symm hb, e.apply_symm_apply (e.mk_mem_target.mpr hb)]

/-- A fiberwise linear inverse to `e`. -/
@[simps] protected def symmₗ (e : pretrivialization R F E) (b : B) : F →ₗ[R] E b :=
begin
  refine is_linear_map.mk' (e.symm b) _,
  by_cases hb : b ∈ e.base_set,
  { exact (((e.linear hb).mk' _).inverse (e.symm b) (e.symm_apply_apply_mk hb)
      (λ v, congr_arg prod.snd $ e.apply_mk_symm hb v)).is_linear },
  { rw [e.coe_symm_of_not_mem hb], exact (0 : F →ₗ[R] E b).is_linear }
end

/-- A pretrivialization for a topological vector bundle defines linear equivalences between the
fibers and the model space. -/
@[simps {fully_applied := ff}] def linear_equiv_at (e : pretrivialization R F E) (b : B)
  (hb : b ∈ e.base_set) :
  E b ≃ₗ[R] F :=
{ to_fun := λ y, (e (total_space_mk b y)).2,
  inv_fun := e.symm b,
  left_inv := e.symm_apply_apply_mk hb,
  right_inv := λ v, by simp_rw [e.apply_mk_symm hb v],
  map_add' := λ v w, (e.linear hb).map_add v w,
  map_smul' := λ c v, (e.linear hb).map_smul c v }

/-- A fiberwise linear map equal to `e` on `e.base_set`. -/
protected def linear_map_at (e : pretrivialization R F E) (b : B) : E b →ₗ[R] F :=
if hb : b ∈ e.base_set then e.linear_equiv_at b hb else 0

lemma coe_linear_map_at (e : pretrivialization R F E) (b : B) :
  ⇑(e.linear_map_at b) = λ y, if b ∈ e.base_set then (e (total_space_mk b y)).2 else 0 :=
by { rw [pretrivialization.linear_map_at], split_ifs; refl }

lemma coe_linear_map_at_of_mem (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) :
  ⇑(e.linear_map_at b) = λ y, (e (total_space_mk b y)).2 :=
by simp_rw [coe_linear_map_at, if_pos hb]

lemma linear_map_at_apply (e : pretrivialization R F E) {b : B} (y : E b) :
  e.linear_map_at b y = if b ∈ e.base_set then (e (total_space_mk b y)).2 else 0 :=
by rw [coe_linear_map_at]

lemma linear_map_at_def_of_mem (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) :
  e.linear_map_at b = e.linear_equiv_at b hb :=
dif_pos hb

lemma linear_map_at_def_of_not_mem (e : pretrivialization R F E) {b : B} (hb : b ∉ e.base_set) :
  e.linear_map_at b = 0 :=
dif_neg hb

lemma linear_map_at_eq_zero (e : pretrivialization R F E) {b : B} (hb : b ∉ e.base_set) :
  e.linear_map_at b = 0 :=
dif_neg hb

lemma symmₗ_linear_map_at (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : E b) :
  e.symmₗ b (e.linear_map_at b y) = y :=
by { rw [e.linear_map_at_def_of_mem hb], exact (e.linear_equiv_at b hb).left_inv y }

lemma linear_map_at_symmₗ (e : pretrivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e.linear_map_at b (e.symmₗ b y) = y :=
by { rw [e.linear_map_at_def_of_mem hb], exact (e.linear_equiv_at b hb).right_inv y }


end topological_vector_bundle.pretrivialization

variable [topological_space (total_space E)]

/--
A structure extending local homeomorphisms, defining a local trivialization of the projection
`proj : total_space E → B` with fiber `F`, as a local homeomorphism between `total_space E`
and `B × F` defined between two sets of the form `proj ⁻¹' base_set` and `base_set × F`,
acting trivially on the first coordinate and linear in the fibers.
-/
@[nolint has_inhabited_instance]
structure topological_vector_bundle.trivialization extends to_fiber_bundle_trivialization :
  topological_fiber_bundle.trivialization F (@total_space.proj B E) :=
(linear' : ∀ x ∈ base_set, is_linear_map R (λ y : E x, (to_fun (total_space_mk x y)).2))

open topological_vector_bundle

instance : has_coe_to_fun (trivialization R F E) (λ _, total_space E → B × F) := ⟨λ e, e.to_fun⟩

instance : has_coe (trivialization R F E)
  (topological_fiber_bundle.trivialization F (@total_space.proj B E)) :=
⟨topological_vector_bundle.trivialization.to_fiber_bundle_trivialization⟩

namespace topological_vector_bundle.trivialization

variables {R F E} (e : trivialization R F E) {x : total_space E} {b : B} {y : E b}

/-- Natural identification as `topological_vector_bundle.pretrivialization`. -/
def to_pretrivialization (e : trivialization R F E) :
  topological_vector_bundle.pretrivialization R F E := { ..e }

protected lemma linear (hb : b ∈ e.base_set) :
  is_linear_map R (λ y : E b, (e (total_space_mk b y)).2) :=
e.linear' b hb

protected lemma continuous_on : continuous_on e e.source := e.continuous_to_fun

@[simp, mfld_simps] lemma coe_coe : ⇑e.to_local_homeomorph = e := rfl
@[simp, mfld_simps] lemma coe_fst (ex : x ∈ e.source) : (e x).1 = x.proj := e.proj_to_fun x ex
lemma mem_source : x ∈ e.source ↔ x.proj ∈ e.base_set := by rw [e.source_eq, mem_preimage]
lemma coe_mem_source : ↑y ∈ e.source ↔ b ∈ e.base_set := e.mem_source
lemma coe_fst' (ex : x.proj ∈ e.base_set) : (e x).1 = x.proj :=
e.coe_fst (e.mem_source.2 ex)

protected lemma eq_on : eq_on (prod.fst ∘ e) total_space.proj e.source := λ x hx, e.coe_fst hx
lemma mk_proj_snd (ex : x ∈ e.source) : (x.proj, (e x).2) = e x :=
prod.ext (e.coe_fst ex).symm rfl
lemma mk_proj_snd' (ex : x.proj ∈ e.base_set) : (x.proj, (e x).2) = e x :=
prod.ext (e.coe_fst' ex).symm rfl

lemma open_target : is_open e.target :=
by { rw e.target_eq, exact e.open_base_set.prod is_open_univ }

@[simp, mfld_simps] lemma coe_coe_fst (hb : b ∈ e.base_set) : (e y).1 = b :=
e.coe_fst (e.mem_source.2 hb)

lemma source_inter_preimage_target_inter (s : set (B × F)) :
  e.source ∩ (e ⁻¹' (e.target ∩ s)) = e.source ∩ (e ⁻¹' s) :=
e.to_local_homeomorph.source_inter_preimage_target_inter s

lemma mem_target {x : B × F} : x ∈ e.target ↔ x.1 ∈ e.base_set :=
e.to_pretrivialization.mem_target

lemma mk_mem_target {y : F} : (b, y) ∈ e.target ↔ b ∈ e.base_set :=
e.to_pretrivialization.mem_target

lemma map_target {x : B × F} (hx : x ∈ e.target) : e.to_local_homeomorph.symm x ∈ e.source :=
e.to_local_homeomorph.map_target hx

lemma proj_symm_apply {x : B × F} (hx : x ∈ e.target) :
  (e.to_local_homeomorph.symm x).proj = x.1 :=
e.to_pretrivialization.proj_symm_apply hx

lemma proj_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  (e.to_local_homeomorph.symm (b, x)).proj  = b :=
e.to_pretrivialization.proj_symm_apply' hx

lemma apply_symm_apply {x : B × F} (hx : x ∈ e.target) : e (e.to_local_homeomorph.symm x) = x :=
e.to_local_homeomorph.right_inv hx

lemma apply_symm_apply' {b : B} {x : F} (hx : b ∈ e.base_set) :
  e (e.to_local_homeomorph.symm (b, x)) = (b, x) :=
e.to_pretrivialization.apply_symm_apply' hx

lemma symm_apply_apply {x : total_space E} (hx : x ∈ e.source) :
  e.to_local_homeomorph.symm (e x) = x :=
e.to_local_equiv.left_inv hx

@[simp, mfld_simps] lemma symm_coe_proj {x : B} {y : F}
  (e : trivialization R F E) (h : x ∈ e.base_set) :
  (e.to_local_homeomorph.symm (x, y)).1 = x := e.proj_symm_apply' h

/-- A fiberwise inverse to `e`. The function `F → E x` that induces a local inverse
  `B × F → total_space E` of `e` on `e.base_set`. It is defined to be `0` outside `e.base_set`. -/
protected def symm (e : trivialization R F E) (b : B) (y : F) : E b :=
e.to_pretrivialization.symm b y

lemma symm_apply (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e.symm b y = cast (congr_arg E (e.symm_coe_proj hb)) (e.to_local_homeomorph.symm (b, y)).2 :=
dif_pos hb

lemma symm_apply_of_not_mem (e : trivialization R F E) {b : B} (hb : b ∉ e.base_set) (y : F) :
  e.symm b y = 0 :=
dif_neg hb

lemma mk_symm (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  total_space_mk b (e.symm b y) = e.to_local_homeomorph.symm (b, y) :=
e.to_pretrivialization.mk_symm hb y

lemma symm_proj_apply (e : trivialization R F E) (z : total_space E)
  (hz : z.proj ∈ e.base_set) : e.symm z.proj (e z).2 = z.2 :=
e.to_pretrivialization.symm_proj_apply z hz

lemma symm_apply_apply_mk (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : E b) :
  e.symm b (e (total_space_mk b y)).2 = y :=
e.symm_proj_apply (total_space_mk b y) hb

lemma apply_mk_symm (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e (total_space_mk b (e.symm b y)) = (b, y) :=
e.to_pretrivialization.apply_mk_symm hb y

lemma continuous_on_symm (e : trivialization R F E) :
  continuous_on (λ z : B × F, total_space_mk z.1 (e.symm z.1 z.2))
    (e.base_set ×ˢ (univ : set F)) :=
begin
  have : ∀ (z : B × F) (hz : z ∈ e.base_set ×ˢ (univ : set F)),
    total_space_mk z.1 (e.symm z.1 z.2) = e.to_local_homeomorph.symm z,
  { rintro x ⟨hx : x.1 ∈ e.base_set, _⟩, simp_rw [e.mk_symm hx, prod.mk.eta] },
  refine continuous_on.congr _ this,
  rw [← e.target_eq],
  exact e.to_local_homeomorph.continuous_on_symm
end

/-- A trivialization for a topological vector bundle defines linear equivalences between the
fibers and the model space. -/
def linear_equiv_at (e : trivialization R F E) (b : B) (hb : b ∈ e.base_set) :
  E b ≃ₗ[R] F :=
e.to_pretrivialization.linear_equiv_at b hb

@[simp]
lemma linear_equiv_at_apply (e : trivialization R F E) (b : B) (hb : b ∈ e.base_set) (v : E b) :
  e.linear_equiv_at b hb v = (e (total_space_mk b v)).2 := rfl

@[simp]
lemma linear_equiv_at_symm_apply (e : trivialization R F E) (b : B) (hb : b ∈ e.base_set) (v : F) :
  (e.linear_equiv_at b hb).symm v = e.symm b v := rfl

/-- A fiberwise linear inverse to `e`. -/
protected def symmₗ (e : trivialization R F E) (b : B) : F →ₗ[R] E b :=
e.to_pretrivialization.symmₗ b

lemma coe_symmₗ (e : trivialization R F E) (b : B) : ⇑(e.symmₗ b) = e.symm b :=
rfl

/-- A fiberwise linear map equal to `e` on `e.base_set`. -/
protected def linear_map_at (e : trivialization R F E) (b : B) : E b →ₗ[R] F :=
e.to_pretrivialization.linear_map_at b

lemma coe_linear_map_at (e : trivialization R F E) (b : B) :
  ⇑(e.linear_map_at b) = λ y, if b ∈ e.base_set then (e (total_space_mk b y)).2 else 0 :=
e.to_pretrivialization.coe_linear_map_at b

lemma coe_linear_map_at_of_mem (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) :
  ⇑(e.linear_map_at b) = λ y, (e (total_space_mk b y)).2 :=
by simp_rw [coe_linear_map_at, if_pos hb]

lemma linear_map_at_apply (e : trivialization R F E) {b : B} (y : E b) :
  e.linear_map_at b y = if b ∈ e.base_set then (e (total_space_mk b y)).2 else 0 :=
by rw [coe_linear_map_at]

lemma linear_map_at_def_of_mem (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) :
  e.linear_map_at b = e.linear_equiv_at b hb :=
dif_pos hb

lemma linear_map_at_def_of_not_mem (e : trivialization R F E) {b : B} (hb : b ∉ e.base_set) :
  e.linear_map_at b = 0 :=
dif_neg hb

lemma symmₗ_linear_map_at (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : E b) :
  e.symmₗ b (e.linear_map_at b y) = y :=
e.to_pretrivialization.symmₗ_linear_map_at hb y

lemma linear_map_at_symmₗ (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) (y : F) :
  e.linear_map_at b (e.symmₗ b y) = y :=
e.to_pretrivialization.linear_map_at_symmₗ hb y

/-- A coordinate change function between two trivializations, as a continuous linear equivalence.
  Defined to be the identity when `b` does not lie in the base set of both trivializations. -/
def coord_change (e e' : trivialization R F E) (b : B) : F ≃L[R] F :=
{ continuous_to_fun := begin
    by_cases hb : b ∈ e.base_set ∩ e'.base_set,
    { simp_rw [dif_pos hb],
      refine (e'.continuous_on.comp_continuous _ _).snd,
      exact e.continuous_on_symm.comp_continuous (continuous.prod.mk b)
        (λ y, mk_mem_prod hb.1 (mem_univ y)),
      exact (λ y, e'.mem_source.mpr hb.2) },
    { rw [dif_neg hb], exact continuous_id }
  end,
  continuous_inv_fun := begin
    by_cases hb : b ∈ e.base_set ∩ e'.base_set,
    { simp_rw [dif_pos hb],
      refine (e.continuous_on.comp_continuous _ _).snd,
      exact e'.continuous_on_symm.comp_continuous (continuous.prod.mk b)
        (λ y, mk_mem_prod hb.2 (mem_univ y)),
      exact (λ y, e.mem_source.mpr hb.1) },
    { rw [dif_neg hb], exact continuous_id }
  end,
  .. if hb : b ∈ e.base_set ∩ e'.base_set then
     (e.linear_equiv_at b (hb.1 : _)).symm.trans (e'.linear_equiv_at b hb.2)
    else linear_equiv.refl R F }

lemma coe_coord_change (e e' : trivialization R F E) {b : B}
  (hb : b ∈ e.base_set ∩ e'.base_set) :
  ⇑(coord_change e e' b) = (e.linear_equiv_at b hb.1).symm.trans (e'.linear_equiv_at b hb.2) :=
congr_arg linear_equiv.to_fun (dif_pos hb)

lemma coord_change_apply (e e' : trivialization R F E) {b : B}
  (hb : b ∈ e.base_set ∩ e'.base_set) (y : F) :
  coord_change e e' b y = (e' (total_space_mk b (e.symm b y))).2 :=
congr_arg (λ f, linear_equiv.to_fun f y) (dif_pos hb)

lemma mk_coord_change (e e' : trivialization R F E) {b : B}
  (hb : b ∈ e.base_set ∩ e'.base_set) (y : F) :
  (b, coord_change e e' b y) = e' (total_space_mk b (e.symm b y)) :=
begin
  ext,
  { rw [e.mk_symm hb.1 y, e'.coe_fst', e.proj_symm_apply' hb.1],
    rw [e.proj_symm_apply' hb.1], exact hb.2 },
  { exact e.coord_change_apply e' hb y }
end

/-- A version of `coord_change_apply` that fully unfolds `coord_change`. The right-hand side is
ugly, but has good definitional properties for specifically defined trivializations. -/
lemma coord_change_apply' (e e' : trivialization R F E) {b : B}
  (hb : b ∈ e.base_set ∩ e'.base_set) (y : F) :
  coord_change e e' b y = (e' (e.to_local_homeomorph.symm (b, y))).2 :=
by rw [e.coord_change_apply e' hb, e.mk_symm hb.1]

lemma coord_change_symm_apply (e e' : trivialization R F E) {b : B}
  (hb : b ∈ e.base_set ∩ e'.base_set) :
  ⇑(coord_change e e' b).symm = (e'.linear_equiv_at b hb.2).symm.trans (e.linear_equiv_at b hb.1) :=
congr_arg linear_equiv.inv_fun (dif_pos hb)

end topological_vector_bundle.trivialization

end topological_vector_space

section
open topological_vector_bundle

variables (B)
variables [nondiscrete_normed_field R] [∀ x, add_comm_monoid (E x)] [∀ x, module R (E x)]
  [normed_group F] [normed_space R F] [topological_space B]
  [topological_space (total_space E)] [∀ x, topological_space (E x)]

/-- The valid transition functions for a topological vector bundle over `B` modelled on
a normed space `F`: a transition function must be a local homeomorphism of `B × F` with source and
target both `s ×ˢ univ`, which on this set is of the form `λ (b, v), (b, ε b v)` for some continuous
map `ε` from `s` to `F ≃L[R] F`. Here continuity is with respect to the operator norm on
`F →L[R] F`. -/
def continuous_transitions (e : local_equiv (B × F) (B × F)) : Prop :=
∃ s : set B, e.source = s ×ˢ (univ : set F) ∧ e.target = s ×ˢ (univ : set F)
    ∧ ∃ ε : B → (F ≃L[R] F), continuous_on (λ b, (ε b : F →L[R] F)) s
      ∧ ∀ b ∈ s, ∀ v : F, e (b, v) = (b, ε b v)

variables {B}

/-- The space `total_space E` (for `E : B → Type*` such that each `E x` is a topological vector
space) has a topological vector space structure with fiber `F` (denoted with
`topological_vector_bundle R F E`) if around every point there is a fiber bundle trivialization
which is linear in the fibers. -/
class topological_vector_bundle :=
(total_space_mk_inducing [] : ∀ (b : B), inducing (@total_space_mk B E b))
(trivialization_atlas [] : set (trivialization R F E))
(trivialization_at [] : B → trivialization R F E)
(mem_base_set_trivialization_at [] : ∀ b : B, b ∈ (trivialization_at b).base_set)
(trivialization_mem_atlas [] : ∀ b : B, trivialization_at b ∈ trivialization_atlas)
(continuous_on_coord_change [] : ∀ (e e' ∈ trivialization_atlas), continuous_on
  (λ b, trivialization.coord_change e e' b : B → F →L[R] F) (e.base_set ∩ e'.base_set))

export topological_vector_bundle (trivialization_atlas trivialization_at
  mem_base_set_trivialization_at trivialization_mem_atlas continuous_on_coord_change)

variables {R F E} [topological_vector_bundle R F E]

namespace topological_vector_bundle

namespace trivialization

/-- Forward map of `continuous_linear_equiv_at` (only propositionally equal),
  defined everywhere (`0` outside domain). -/
@[simps apply {fully_applied := ff}]
def continuous_linear_map_at (e : trivialization R F E) (b : B) :
  E b →L[R] F :=
{ cont := begin
    dsimp,
    rw [e.coe_linear_map_at b],
    refine continuous_if_const _ (λ hb, _) (λ _, continuous_zero),
    exact continuous_snd.comp (e.to_local_homeomorph.continuous_on.comp_continuous
      (total_space_mk_inducing R F E b).continuous (λ x, e.mem_source.mpr hb))
  end,
  .. e.linear_map_at b }

/-- Backwards map of `continuous_linear_equiv_at`, defined everywhere. -/
@[simps apply {fully_applied := ff}]
def symmL (e : trivialization R F E) (b : B) : F →L[R] E b :=
{ cont := begin
    by_cases hb : b ∈ e.base_set,
    { rw (topological_vector_bundle.total_space_mk_inducing R F E b).continuous_iff,
      exact e.continuous_on_symm.comp_continuous (continuous_const.prod_mk continuous_id)
        (λ x, mk_mem_prod hb (mem_univ x)) },
    { refine continuous_zero.congr (λ x, (e.symm_apply_of_not_mem hb x).symm) },
  end,
  .. e.symmₗ b }

lemma symmL_continuous_linear_map_at (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set)
  (y : E b) :
  e.symmL b (e.continuous_linear_map_at b y) = y :=
e.symmₗ_linear_map_at hb y

lemma continuous_linear_map_at_symmL (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set)
  (y : F) :
  e.continuous_linear_map_at b (e.symmL b y) = y :=
e.linear_map_at_symmₗ hb y

/-- In a topological vector bundle, a trivialization in the fiber (which is a priori only linear)
is in fact a continuous linear equiv between the fibers and the model fiber. -/
@[simps apply symm_apply {fully_applied := ff}]
def continuous_linear_equiv_at (e : trivialization R F E) (b : B)
  (hb : b ∈ e.base_set) : E b ≃L[R] F :=
{ to_fun := λ y, (e (total_space_mk b y)).2,
  inv_fun := e.symm b,
  continuous_to_fun := continuous_snd.comp (e.to_local_homeomorph.continuous_on.comp_continuous
    (total_space_mk_inducing R F E b).continuous (λ x, e.mem_source.mpr hb)),
  continuous_inv_fun := (e.symmL b).continuous,
  .. e.to_pretrivialization.linear_equiv_at b hb }

lemma coe_continuous_linear_equiv_at_eq (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) :
  (e.continuous_linear_equiv_at b hb : E b → F) = e.continuous_linear_map_at b :=
(e.coe_linear_map_at_of_mem hb).symm

lemma symm_continuous_linear_equiv_at_eq (e : trivialization R F E) {b : B} (hb : b ∈ e.base_set) :
  ((e.continuous_linear_equiv_at b hb).symm : F → E b) = e.symmL b :=
rfl

@[simp] lemma continuous_linear_equiv_at_apply' (e : trivialization R F E)
  (x : total_space E) (hx : x ∈ e.source) :
  e.continuous_linear_equiv_at x.proj (e.mem_source.1 hx) x.2 = (e x).2 := by { cases x, refl }

lemma apply_eq_prod_continuous_linear_equiv_at (e : trivialization R F E) (b : B)
  (hb : b ∈ e.base_set) (z : E b) :
  e.to_local_homeomorph ⟨b, z⟩ = (b, e.continuous_linear_equiv_at b hb z) :=
begin
  ext,
  { refine e.coe_fst _,
    rw e.source_eq,
    exact hb },
  { simp only [coe_coe, continuous_linear_equiv_at_apply] }
end

lemma symm_apply_eq_mk_continuous_linear_equiv_at_symm (e : trivialization R F E) (b : B)
  (hb : b ∈ e.base_set) (z : F) :
  e.to_local_homeomorph.symm ⟨b, z⟩
  = total_space_mk b ((e.continuous_linear_equiv_at b hb).symm z) :=
begin
  have h : (b, z) ∈ e.to_local_homeomorph.target,
  { rw e.target_eq,
    exact ⟨hb, mem_univ _⟩ },
  apply e.to_local_homeomorph.inj_on (e.to_local_homeomorph.map_target h),
  { simp only [e.source_eq, hb, mem_preimage]},
  simp_rw [e.apply_eq_prod_continuous_linear_equiv_at b hb, e.to_local_homeomorph.right_inv h,
    continuous_linear_equiv.apply_symm_apply],
end

lemma comp_continuous_linear_equiv_at_eq_coord_change (e e' : trivialization R F E) {b : B}
  (hb : b ∈ e.1.base_set ∩ e'.1.base_set) :
  (e.continuous_linear_equiv_at b hb.1).symm.trans (e'.continuous_linear_equiv_at b hb.2)
  = coord_change e e' b :=
by { ext v, rw [coord_change_apply e e' hb], refl }

end trivialization

section

instance {B : Type*} {F : Type*} [add_comm_monoid F] (b : B) :
  add_comm_monoid (bundle.trivial B F b) := ‹add_comm_monoid F›

instance {B : Type*} {F : Type*} [add_comm_group F] (b : B) :
  add_comm_group (bundle.trivial B F b) := ‹add_comm_group F›

instance {B : Type*} {F : Type*} [add_comm_monoid F] [module R F] (b : B) :
  module R (bundle.trivial B F b) := ‹module R F›

end

namespace trivial_topological_vector_bundle
variables (R B F)

/-- Local trivialization for trivial bundle. -/
def trivialization : trivialization R F (bundle.trivial B F) :=
{ to_fun := λ x, (x.fst, x.snd),
  inv_fun := λ y, ⟨y.fst, y.snd⟩,
  source := univ,
  target := univ,
  map_source' := λ x h, mem_univ (x.fst, x.snd),
  map_target' := λ y h,  mem_univ ⟨y.fst, y.snd⟩,
  left_inv' := λ x h, sigma.eq rfl rfl,
  right_inv' := λ x h, prod.ext rfl rfl,
  open_source := is_open_univ,
  open_target := is_open_univ,
  continuous_to_fun := by { rw [←continuous_iff_continuous_on_univ, continuous_iff_le_induced],
    simp only [prod.topological_space, induced_inf, induced_compose], exact le_rfl, },
  continuous_inv_fun := by { rw [←continuous_iff_continuous_on_univ, continuous_iff_le_induced],
    simp only [bundle.total_space.topological_space, induced_inf, induced_compose],
    exact le_rfl, },
  base_set := univ,
  open_base_set := is_open_univ,
  source_eq := rfl,
  target_eq := by simp only [univ_prod_univ],
  proj_to_fun := λ y hy, rfl,
  linear' := λ x hx, ⟨λ y z, rfl, λ c y, rfl⟩ }

lemma trivialization.coord_change (b : B) :
  (trivialization R B F).coord_change
    (trivialization R B F) b = continuous_linear_equiv.refl R F :=
begin
  ext v,
  rw [trivialization.coord_change_apply'],
  exacts [rfl, ⟨mem_univ _, mem_univ _⟩]
end

@[simp]
lemma trivialization_source : (trivialization R B F).source = univ := rfl

@[simp]
lemma trivialization_target : (trivialization R B F).target = univ := rfl

instance topological_vector_bundle :
  topological_vector_bundle R F (bundle.trivial B F) :=
{ trivialization_atlas := {trivial_topological_vector_bundle.trivialization R B F},
  trivialization_at := λ x, trivial_topological_vector_bundle.trivialization R B F,
  mem_base_set_trivialization_at := mem_univ,
  trivialization_mem_atlas := λ x, mem_singleton _,
  total_space_mk_inducing := λ b, ⟨begin
    have : (λ (x : trivial B F b), x) = @id F, by { ext x, refl },
    simp only [total_space.topological_space, induced_inf, induced_compose, function.comp,
      total_space.proj, induced_const, top_inf_eq, trivial.proj_snd, id.def,
      trivial.topological_space, this, induced_id],
  end⟩,
  continuous_on_coord_change := begin
    intros e he e' he',
    rw [mem_singleton_iff.mp he, mem_singleton_iff.mp he'],
    simp_rw [trivial_topological_vector_bundle.trivialization.coord_change],
    exact continuous_const.continuous_on
  end }

end trivial_topological_vector_bundle

/- Not registered as an instance because of a metavariable. -/
lemma is_topological_vector_bundle_is_topological_fiber_bundle :
  is_topological_fiber_bundle F (@total_space.proj B E) :=
λ x, ⟨(trivialization_at R F E x).to_fiber_bundle_trivialization,
  mem_base_set_trivialization_at R F E x⟩

include R F

lemma continuous_total_space_mk (x : B) : continuous (@total_space_mk B E x) :=
(topological_vector_bundle.total_space_mk_inducing R F E x).continuous

variables (R B F)

@[continuity] lemma continuous_proj : continuous (@total_space.proj B E) :=
begin
  apply @is_topological_fiber_bundle.continuous_proj B F,
  apply @is_topological_vector_bundle_is_topological_fiber_bundle R,
end

end topological_vector_bundle

/-! ### Constructing topological vector bundles -/

variables (R B F)

/-- Analogous construction of `topological_fiber_bundle_core` for vector bundles. This
construction gives a way to construct vector bundles from a structure registering how
trivialization changes act on fibers. -/
structure topological_vector_bundle_core (ι : Type*) :=
(base_set          : ι → set B)
(is_open_base_set  : ∀ i, is_open (base_set i))
(index_at          : B → ι)
(mem_base_set_at   : ∀ x, x ∈ base_set (index_at x))
(coord_change      : ι → ι → B → (F →L[R] F))
(coord_change_self : ∀ i, ∀ x ∈ base_set i, ∀ v, coord_change i i x v = v)
(coord_change_continuous : ∀ i j, continuous_on (coord_change i j) (base_set i ∩ base_set j))
(coord_change_comp : ∀ i j k, ∀ x ∈ (base_set i) ∩ (base_set j) ∩ (base_set k), ∀ v,
  (coord_change j k x) (coord_change i j x v) = coord_change i k x v)

/-- The trivial topological vector bundle core, in which all the changes of coordinates are the
identity. -/
def trivial_topological_vector_bundle_core (ι : Type*) [inhabited ι] :
  topological_vector_bundle_core R B F ι :=
{ base_set := λ ι, univ,
  is_open_base_set := λ i, is_open_univ,
  index_at := default,
  mem_base_set_at := λ x, mem_univ x,
  coord_change := λ i j x, continuous_linear_map.id R F,
  coord_change_self := λ i x hx v, rfl,
  coord_change_comp := λ i j k x hx v, rfl,
  coord_change_continuous := λ i j, continuous_on_const }

instance (ι : Type*) [inhabited ι] : inhabited (topological_vector_bundle_core R B F ι) :=
⟨trivial_topological_vector_bundle_core R B F ι⟩

namespace topological_vector_bundle_core

variables {R B F} {ι : Type*} (Z : topological_vector_bundle_core R B F ι)

/-- Natural identification to a `topological_fiber_bundle_core`. -/
def to_topological_vector_bundle_core : topological_fiber_bundle_core ι B F :=
{ coord_change := λ i j b, Z.coord_change i j b,
  coord_change_continuous := λ i j, is_bounded_bilinear_map_apply.continuous.comp_continuous_on
      ((Z.coord_change_continuous i j).prod_map continuous_on_id),
  ..Z }

instance to_topological_vector_bundle_core_coe : has_coe (topological_vector_bundle_core R B F ι)
  (topological_fiber_bundle_core ι B F) := ⟨to_topological_vector_bundle_core⟩

include Z

lemma coord_change_linear_comp (i j k : ι): ∀ x ∈ (Z.base_set i) ∩ (Z.base_set j) ∩ (Z.base_set k),
  (Z.coord_change j k x).comp (Z.coord_change i j x) = Z.coord_change i k x :=
λ x hx, by { ext v, exact Z.coord_change_comp i j k x hx v }

/-- The index set of a topological vector bundle core, as a convenience function for dot notation -/
@[nolint unused_arguments has_inhabited_instance]
def index := ι

/-- The base space of a topological vector bundle core, as a convenience function for dot notation-/
@[nolint unused_arguments, reducible]
def base := B

/-- The fiber of a topological vector bundle core, as a convenience function for dot notation and
typeclass inference -/
@[nolint unused_arguments has_inhabited_instance]
def fiber (x : B) := F

instance topological_space_fiber (x : B) : topological_space (Z.fiber x) :=
by delta_instance topological_vector_bundle_core.fiber
instance add_comm_monoid_fiber : ∀ (x : B), add_comm_monoid (Z.fiber x) :=
by delta_instance topological_vector_bundle_core.fiber
instance module_fiber : ∀ (x : B), module R (Z.fiber x) :=
by delta_instance topological_vector_bundle_core.fiber
instance add_comm_group_fiber [add_comm_group F] : ∀ (x : B), add_comm_group (Z.fiber x) :=
by delta_instance topological_vector_bundle_core.fiber

/-- The projection from the total space of a topological fiber bundle core, on its base. -/
@[reducible, simp, mfld_simps] def proj : total_space Z.fiber → B := total_space.proj

/-- The total space of the topological vector bundle, as a convenience function for dot notation.
It is by definition equal to `bundle.total_space Z.fiber`, a.k.a. `Σ x, Z.fiber x` but with a
different name for typeclass inference. -/
@[nolint unused_arguments, reducible]
def total_space := bundle.total_space Z.fiber

/-- Local homeomorphism version of the trivialization change. -/
def triv_change (i j : ι) : local_homeomorph (B × F) (B × F) :=
topological_fiber_bundle_core.triv_change ↑Z i j

@[simp, mfld_simps] lemma mem_triv_change_source (i j : ι) (p : B × F) :
  p ∈ (Z.triv_change i j).source ↔ p.1 ∈ Z.base_set i ∩ Z.base_set j :=
topological_fiber_bundle_core.mem_triv_change_source ↑Z i j p

variable (ι)

/-- Topological structure on the total space of a topological bundle created from core, designed so
that all the local trivialization are continuous. -/
instance to_topological_space : topological_space (Z.total_space) :=
topological_fiber_bundle_core.to_topological_space ι ↑Z

variables {ι} (b : B) (a : F)

@[simp, mfld_simps] lemma coe_coord_change (i j : ι) :
  topological_fiber_bundle_core.coord_change ↑Z i j b = Z.coord_change i j b := rfl

/-- Extended version of the local trivialization of a fiber bundle constructed from core,
registering additionally in its type that it is a local bundle trivialization. -/
def local_triv (i : ι) : topological_vector_bundle.trivialization R F Z.fiber :=
{ linear' := λ x hx,
  { map_add := λ v w, by simp only [continuous_linear_map.map_add] with mfld_simps,
    map_smul := λ r v, by simp only [continuous_linear_map.map_smul] with mfld_simps},
  ..topological_fiber_bundle_core.local_triv ↑Z i }

variables (i j : ι)

@[simp, mfld_simps] lemma mem_local_triv_source (p : Z.total_space) :
  p ∈ (Z.local_triv i).source ↔ p.1 ∈ Z.base_set i := iff.rfl

@[simp, mfld_simps] lemma base_set_at : Z.base_set i = (Z.local_triv i).base_set := rfl

@[simp, mfld_simps] lemma local_triv_apply (p : Z.total_space) :
  (Z.local_triv i) p = ⟨p.1, Z.coord_change (Z.index_at p.1) i p.1 p.2⟩ := rfl

@[simp, mfld_simps] lemma mem_local_triv_target (p : B × F) :
  p ∈ (Z.local_triv i).target ↔ p.1 ∈ (Z.local_triv i).base_set :=
topological_fiber_bundle_core.mem_local_triv_target Z i p

@[simp, mfld_simps] lemma local_triv_symm_fst (p : B × F) :
  (Z.local_triv i).to_local_homeomorph.symm p =
    ⟨p.1, Z.coord_change i (Z.index_at p.1) p.1 p.2⟩ := rfl

@[simp, mfld_simps] lemma local_triv_symm_apply {b : B} (hb : b ∈ Z.base_set i) (v : F) :
  (Z.local_triv i).symm b v = Z.coord_change i (Z.index_at b) b v :=
by apply (Z.local_triv i).symm_apply hb v

@[simp, mfld_simps] lemma local_triv_coord_change_eq {b : B} (hb : b ∈ Z.base_set i ∩ Z.base_set j)
  (v : F) :
  (Z.local_triv i).coord_change (Z.local_triv j) b v = Z.coord_change i j b v :=
begin
  rw [trivialization.coord_change_apply', local_triv_symm_fst, local_triv_apply,
    coord_change_comp],
  exacts [⟨⟨hb.1, Z.mem_base_set_at b⟩, hb.2⟩, hb]
end

/-- Preferred local trivialization of a vector bundle constructed from core, at a given point, as
a bundle trivialization -/
def local_triv_at (b : B) : topological_vector_bundle.trivialization R F Z.fiber :=
Z.local_triv (Z.index_at b)

@[simp, mfld_simps] lemma local_triv_at_def :
  Z.local_triv (Z.index_at b) = Z.local_triv_at b := rfl

@[simp, mfld_simps] lemma mem_source_at : (⟨b, a⟩ : Z.total_space) ∈ (Z.local_triv_at b).source :=
by { rw [local_triv_at, mem_local_triv_source], exact Z.mem_base_set_at b }

@[simp, mfld_simps] lemma local_triv_at_apply : ((Z.local_triv_at b) ⟨b, a⟩) = ⟨b, a⟩ :=
topological_fiber_bundle_core.local_triv_at_apply Z b a

@[simp, mfld_simps] lemma mem_local_triv_at_base_set :
  b ∈ (Z.local_triv_at b).base_set :=
topological_fiber_bundle_core.mem_local_triv_at_base_set Z b

instance : topological_vector_bundle R F Z.fiber :=
{ total_space_mk_inducing := λ b, ⟨ begin refine le_antisymm _ (λ s h, _),
    { rw ←continuous_iff_le_induced,
      exact topological_fiber_bundle_core.continuous_total_space_mk ↑Z b, },
    { refine is_open_induced_iff.mpr ⟨(Z.local_triv_at b).source ∩ (Z.local_triv_at b) ⁻¹'
        ((Z.local_triv_at b).base_set ×ˢ s), (continuous_on_open_iff
        (Z.local_triv_at b).open_source).mp (Z.local_triv_at b).continuous_to_fun _
        ((Z.local_triv_at b).open_base_set.prod h), _⟩,
      rw [preimage_inter, ←preimage_comp, function.comp],
      simp only [total_space_mk],
      refine ext_iff.mpr (λ a, ⟨λ ha, _, λ ha, ⟨Z.mem_base_set_at b, _⟩⟩),
      { simp only [mem_prod, mem_preimage, mem_inter_eq, local_triv_at_apply] at ha,
        exact ha.2.2, },
      { simp only [mem_prod, mem_preimage, mem_inter_eq, local_triv_at_apply],
        exact ⟨Z.mem_base_set_at b, ha⟩, } } end⟩,
  trivialization_atlas := set.range Z.local_triv,
  trivialization_at := Z.local_triv_at,
  mem_base_set_trivialization_at := Z.mem_base_set_at,
  trivialization_mem_atlas := λ b, ⟨Z.index_at b, rfl⟩,
  continuous_on_coord_change := begin
    rintros _ ⟨i, rfl⟩ _ ⟨i', rfl⟩,
    refine (Z.coord_change_continuous i i').congr (λ b hb, _),
    ext v,
    simp_rw [continuous_linear_equiv.coe_coe, Z.local_triv_coord_change_eq i i' hb],
  end }

/-- The projection on the base of a topological vector bundle created from core is continuous -/
@[continuity] lemma continuous_proj : continuous Z.proj :=
topological_fiber_bundle_core.continuous_proj Z

/-- The projection on the base of a topological vector bundle created from core is an open map -/
lemma is_open_map_proj : is_open_map Z.proj :=
topological_fiber_bundle_core.is_open_map_proj Z

end topological_vector_bundle_core

end

/-! ### Topological vector prebundle -/

section
variables [nondiscrete_normed_field R] [∀ x, add_comm_monoid (E x)] [∀ x, module R (E x)]
  [normed_group F] [normed_space R F] [topological_space B]

open topological_space

open topological_vector_bundle
/-- This structure permits to define a vector bundle when trivializations are given as local
equivalences but there is not yet a topology on the total space or the fibers.
The total space is hence given a topology in such a way that there is a fiber bundle structure for
which the local equivalences are also local homeomorphisms and hence vector bundle trivializations.
The topology on the fibers is induced from the one on the total space.

The field `exists_coord_change` is stated as an existential statement (instead of 3 separate
fields), since it depends on propositional information (namely `e e' ∈ pretrivialization_atlas`).
This makes it inconvenient to explicitly define a `coord_change` function when constructing a
`topological_vector_prebundle`. -/
@[nolint has_inhabited_instance]
structure topological_vector_prebundle :=
(pretrivialization_atlas : set (pretrivialization R F E))
(pretrivialization_at : B → pretrivialization R F E)
(mem_base_pretrivialization_at : ∀ x : B, x ∈ (pretrivialization_at x).base_set)
(pretrivialization_mem_atlas : ∀ x : B, pretrivialization_at x ∈ pretrivialization_atlas)
(exists_coord_change : ∀ (e e' ∈ pretrivialization_atlas), ∃ f : B → F →L[R] F,
  continuous_on f (e.base_set ∩ e'.base_set) ∧
  ∀ (b : B) (hb : b ∈ e.base_set ∩ e'.base_set) (v : F),
    f b v = (e' (total_space_mk b (e.symm b v))).2)

namespace topological_vector_prebundle

variables {R E F}

/-- A randomly chosen coordinate change on a `topological_vector_prebundle`, given by
  the field `exists_coord_change`. -/
def coord_change (a : topological_vector_prebundle R F E)
  {e e' : pretrivialization R F E} (he : e ∈ a.pretrivialization_atlas)
  (he' : e' ∈ a.pretrivialization_atlas) (b : B) : F →L[R] F :=
classical.some (a.exists_coord_change e he e' he') b

lemma continuous_on_coord_change (a : topological_vector_prebundle R F E)
  {e e' : pretrivialization R F E} (he : e ∈ a.pretrivialization_atlas)
  (he' : e' ∈ a.pretrivialization_atlas) :
  continuous_on (a.coord_change he he') (e.base_set ∩ e'.base_set) :=
(classical.some_spec (a.exists_coord_change e he e' he')).1

lemma coord_change_apply (a : topological_vector_prebundle R F E)
  {e e' : pretrivialization R F E} (he : e ∈ a.pretrivialization_atlas)
  (he' : e' ∈ a.pretrivialization_atlas) {b : B} (hb : b ∈ e.base_set ∩ e'.base_set) (v : F) :
  a.coord_change he he' b v = (e' (total_space_mk b (e.symm b v))).2 :=
(classical.some_spec (a.exists_coord_change e he e' he')).2 b hb v

lemma mk_coord_change (a : topological_vector_prebundle R F E)
  {e e' : pretrivialization R F E} (he : e ∈ a.pretrivialization_atlas)
  (he' : e' ∈ a.pretrivialization_atlas) {b : B} (hb : b ∈ e.base_set ∩ e'.base_set) (v : F) :
  (b, a.coord_change he he' b v) = e' (total_space_mk b (e.symm b v)) :=
begin
  ext,
  { rw [e.mk_symm hb.1 v, e'.coe_fst', e.proj_symm_apply' hb.1],
    rw [e.proj_symm_apply' hb.1], exact hb.2 },
  { exact a.coord_change_apply he he' hb v }
end

/-- Natural identification of `topological_vector_prebundle` as a `topological_fiber_prebundle`. -/
def to_topological_fiber_prebundle (a : topological_vector_prebundle R F E) :
  topological_fiber_prebundle F (@total_space.proj B E) :=
{ pretrivialization_atlas :=
    pretrivialization.to_fiber_bundle_pretrivialization '' a.pretrivialization_atlas,
  pretrivialization_at := λ x, (a.pretrivialization_at x).to_fiber_bundle_pretrivialization,
  pretrivialization_mem_atlas := λ x, ⟨_, a.pretrivialization_mem_atlas x, rfl⟩,
  continuous_triv_change := begin
    rintros _ ⟨e, he, rfl⟩ _ ⟨e', he', rfl⟩,
    have := is_bounded_bilinear_map_apply.continuous.comp_continuous_on
      ((a.continuous_on_coord_change he' he).prod_map continuous_on_id),
    have H : e'.to_fiber_bundle_pretrivialization.to_local_equiv.target ∩
      e'.to_fiber_bundle_pretrivialization.to_local_equiv.symm ⁻¹'
      e.to_fiber_bundle_pretrivialization.to_local_equiv.source =
      (e'.base_set ∩ e.base_set) ×ˢ (univ : set F),
    { rw [e'.target_eq, e.source_eq],
      ext ⟨b, f⟩,
      simp only [-total_space.proj, and.congr_right_iff, e'.proj_symm_apply', iff_self,
        implies_true_iff] with mfld_simps {contextual := tt} },
    rw [H],
    refine (continuous_on_fst.prod this).congr _,
    rintros ⟨b, f⟩ ⟨hb, -⟩,
    dsimp only [function.comp, prod.map],
    rw [a.mk_coord_change _ _ hb, e'.mk_symm hb.1],
    refl,
  end,
  .. a }

/-- Topology on the total space that will make the prebundle into a bundle. -/
def total_space_topology (a : topological_vector_prebundle R F E) :
  topological_space (total_space E) :=
a.to_topological_fiber_prebundle.total_space_topology

/-- Promotion from a `topologial_vector_prebundle.trivialization` to a
  `topological_vector_bundle.trivialization`. -/
def trivialization_of_mem_pretrivialization_atlas (a : topological_vector_prebundle R F E)
  {e : topological_vector_bundle.pretrivialization R F E} (he : e ∈ a.pretrivialization_atlas) :
  @topological_vector_bundle.trivialization R _ F E _ _ _ _ _ _ _ a.total_space_topology :=
begin
  letI := a.total_space_topology,
  exact { linear' := λ b, e.linear,
  ..a.to_topological_fiber_prebundle.trivialization_of_mem_pretrivialization_atlas ⟨e, he, rfl⟩ }
end

variable (a : topological_vector_prebundle R F E)

lemma mem_trivialization_at_source (b : B) (x : E b) :
  total_space_mk b x ∈ (a.pretrivialization_at b).source :=
begin
  simp only [(a.pretrivialization_at b).source_eq, mem_preimage, total_space.proj],
  exact a.mem_base_pretrivialization_at b,
end

@[simp] lemma total_space_mk_preimage_source (b : B) :
  (total_space_mk b) ⁻¹' (a.pretrivialization_at b).source = univ :=
begin
  apply eq_univ_of_univ_subset,
  rw [(a.pretrivialization_at b).source_eq, ←preimage_comp, function.comp],
  simp only [total_space.proj],
  rw preimage_const_of_mem _,
  exact a.mem_base_pretrivialization_at b,
end

/-- Topology on the fibers `E b` induced by the map `E b → E.total_space`. -/
def fiber_topology (b : B) : topological_space (E b) :=
topological_space.induced (total_space_mk b) a.total_space_topology

@[continuity] lemma inducing_total_space_mk (b : B) :
  @inducing _ _ (a.fiber_topology b) a.total_space_topology (total_space_mk b) :=
by { letI := a.total_space_topology, letI := a.fiber_topology b, exact ⟨rfl⟩ }

@[continuity] lemma continuous_total_space_mk (b : B) :
  @continuous _ _ (a.fiber_topology b) a.total_space_topology (total_space_mk b) :=
begin
  letI := a.total_space_topology, letI := a.fiber_topology b,
  exact (a.inducing_total_space_mk b).continuous
end

/-- Make a `topological_vector_bundle` from a `topological_vector_prebundle`.  Concretely this means
that, given a `topological_vector_prebundle` structure for a sigma-type `E` -- which consists of a
number of "pretrivializations" identifying parts of `E` with product spaces `U × F` -- one
establishes that for the topology constructed on the sigma-type using
`topological_vector_prebundle.total_space_topology`, these "pretrivializations" are actually
"trivializations" (i.e., homeomorphisms with respect to the constructed topology). -/
def to_topological_vector_bundle :
  @topological_vector_bundle R _ F E _ _ _ _ _ _ a.total_space_topology a.fiber_topology :=
{ total_space_mk_inducing := a.inducing_total_space_mk,
  trivialization_atlas := {e | ∃ e₀ (he₀ : e₀ ∈ a.pretrivialization_atlas),
    e = a.trivialization_of_mem_pretrivialization_atlas he₀},
  trivialization_at := λ x, a.trivialization_of_mem_pretrivialization_atlas
    (a.pretrivialization_mem_atlas x),
  mem_base_set_trivialization_at := a.mem_base_pretrivialization_at,
  trivialization_mem_atlas := λ x, ⟨_, a.pretrivialization_mem_atlas x, rfl⟩,
  continuous_on_coord_change := begin
    rintros _ ⟨e, he, rfl⟩ _ ⟨e', he', rfl⟩,
    refine (a.continuous_on_coord_change he he').congr _,
    intros b hb,
    ext v,
    rw [a.coord_change_apply he he' hb v, continuous_linear_equiv.coe_coe,
      trivialization.coord_change_apply],
    exacts [rfl, hb]
  end }

end topological_vector_prebundle

end


<|start_filename|>src/ring_theory/graded_algebra/radical.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/

import ring_theory.graded_algebra.homogeneous_ideal

/-!

This file contains a proof that the radical of any homogeneous ideal is a homogeneous ideal

## Main statements

* `ideal.is_homogeneous.is_prime_iff`: for any `I : ideal A`, if `I` is homogeneous, then
  `I` is prime if and only if `I` is homogeneously prime, i.e. `I ≠ ⊤` and if `x, y` are
  homogeneous elements such that `x * y ∈ I`, then at least one of `x,y` is in `I`.
* `ideal.is_prime.homogeneous_core`: for any `I : ideal A`, if `I` is prime, then
  `I.homogeneous_core 𝒜` (i.e. the largest homogeneous ideal contained in `I`) is also prime.
* `ideal.is_homogeneous.radical`: for any `I : ideal A`, if `I` is homogeneous, then the
  radical of `I` is homogeneous as well.
* `homogeneous_ideal.radical`: for any `I : homogeneous_ideal 𝒜`, `I.radical` is the the
  radical of `I` as a `homogeneous_ideal 𝒜`

## Implementation details

Throughout this file, the indexing type `ι` of grading is assumed to be a
`linear_ordered_cancel_add_comm_monoid`. This might be stronger than necessary but cancelling
property is strictly necessary; for a counterexample of how `ideal.is_homogeneous.is_prime_iff`
fails for a non-cancellative set see `counterexample/homogeneous_prime_not_prime.lean`.

## Tags

homogeneous, radical
-/

open graded_algebra set_like finset
open_locale big_operators

variables {ι R A : Type*}
variables [comm_semiring R] [comm_ring A] [algebra R A]
variables [linear_ordered_cancel_add_comm_monoid ι]
variables {𝒜 : ι → submodule R A} [graded_algebra 𝒜]

lemma ideal.is_homogeneous.is_prime_of_homogeneous_mem_or_mem
  {I : ideal A} (hI : I.is_homogeneous 𝒜) (I_ne_top : I ≠ ⊤)
  (homogeneous_mem_or_mem : ∀ {x y : A},
    is_homogeneous 𝒜 x → is_homogeneous 𝒜 y → (x * y ∈ I → x ∈ I ∨ y ∈ I)) :
  ideal.is_prime I :=
⟨I_ne_top, begin
  intros x y hxy,
  by_contradiction rid,
  obtain ⟨rid₁, rid₂⟩ := not_or_distrib.mp rid,
  /-
  The idea of the proof is the following :
  since `x * y ∈ I` and `I` homogeneous, then `proj i (x * y) ∈ I` for any `i : ι`.
  Then consider two sets `{i ∈ x.support | xᵢ ∉ I}` and `{j ∈ y.support | yⱼ ∉ J}`;
  let `max₁, max₂` be the maximum of the two sets, then `proj (max₁ + max₂) (x * y) ∈ I`.
  Then, `proj max₁ x ∉ I` and `proj max₂ j ∉ I`
  but `proj i x ∈ I` for all `max₁ < i` and `proj j y ∈ I` for all `max₂ < j`.
  `  proj (max₁ + max₂) (x * y)`
  `= ∑ {(i, j) ∈ supports | i + j = max₁ + max₂}, xᵢ * yⱼ`
  `= proj max₁ x * proj max₂ y`
  `  + ∑ {(i, j) ∈ supports \ {(max₁, max₂)} | i + j = max₁ + max₂}, xᵢ * yⱼ`.
  This is a contradiction, because both `proj (max₁ + max₂) (x * y) ∈ I` and the sum on the
  right hand side is in `I` however `proj max₁ x * proj max₂ y` is not in `I`.
  -/
  classical,
  letI : Π (x : A),
    decidable_pred (λ (i : ι), proj 𝒜 i x ∉ I) := λ x, classical.dec_pred _,
  set set₁ := (support 𝒜 x).filter (λ i, proj 𝒜 i x ∉ I) with set₁_eq,
  set set₂ := (support 𝒜 y).filter (λ i, proj 𝒜 i y ∉ I) with set₂_eq,
  have nonempty : ∀ (x : A), (x ∉ I) → ((support 𝒜 x).filter (λ i, proj 𝒜 i x ∉ I)).nonempty,
  { intros x hx,
    rw filter_nonempty_iff,
    contrapose! hx,
    rw ← sum_support_decompose 𝒜 x,
    apply ideal.sum_mem _ hx, },
  set max₁ := set₁.max' (nonempty x rid₁) with max₁_eq,
  set max₂ := set₂.max' (nonempty y rid₂) with max₂_eq,
  have mem_max₁ : max₁ ∈ set₁ := max'_mem set₁ (nonempty x rid₁),
  have mem_max₂ : max₂ ∈ set₂ := max'_mem set₂ (nonempty y rid₂),
  replace hxy : proj 𝒜 (max₁ + max₂) (x * y) ∈ I := hI _ hxy,

  have mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∈ I,
  { set antidiag :=
      ((support 𝒜 x).product (support 𝒜 y)).filter (λ z : ι × ι, z.1 + z.2 = max₁ + max₂) with ha,
    have mem_antidiag : (max₁, max₂) ∈ antidiag,
    { simp only [add_sum_erase, mem_filter, mem_product],
      exact ⟨⟨mem_of_mem_filter _ mem_max₁, mem_of_mem_filter _ mem_max₂⟩, rfl⟩ },
    have eq_add_sum :=
      calc  proj 𝒜 (max₁ + max₂) (x * y)
          = ∑ ij in antidiag, proj 𝒜 ij.1 x * proj 𝒜 ij.2 y
          : by simp_rw [ha, proj_apply, map_mul, support, direct_sum.coe_mul_apply 𝒜]
      ... = proj 𝒜 max₁ x * proj 𝒜 max₂ y + ∑ ij in antidiag.erase (max₁, max₂),
                                              proj 𝒜 ij.1 x * proj 𝒜 ij.2 y
          : (add_sum_erase _ _ mem_antidiag).symm,
    rw eq_sub_of_add_eq eq_add_sum.symm,
    refine ideal.sub_mem _ hxy (ideal.sum_mem _ (λ z H, _)),
    rcases z with ⟨i, j⟩,
    simp only [mem_erase, prod.mk.inj_iff, ne.def, mem_filter, mem_product] at H,
    rcases H with ⟨H₁, ⟨H₂, H₃⟩, H₄⟩,
    have max_lt : max₁ < i ∨ max₂ < j,
    { rcases lt_trichotomy max₁ i with h | rfl | h,
      { exact or.inl h },
      { refine false.elim (H₁ ⟨rfl, add_left_cancel H₄⟩), },
      { apply or.inr,
        have := add_lt_add_right h j,
        rw H₄ at this,
        exact lt_of_add_lt_add_left this, }, },
    cases max_lt,
    { -- in this case `max₁ < i`, then `xᵢ ∈ I`; for otherwise `i ∈ set₁` then `i ≤ max₁`.
      have not_mem : i ∉ set₁ := λ h, lt_irrefl _
        ((max'_lt_iff set₁ (nonempty x rid₁)).mp max_lt i h),
      rw set₁_eq at not_mem,
      simp only [not_and, not_not, ne.def, dfinsupp.mem_support_to_fun, mem_filter] at not_mem,
      exact ideal.mul_mem_right _ I (not_mem H₂), },
    { -- in this case  `max₂ < j`, then `yⱼ ∈ I`; for otherwise `j ∈ set₂`, then `j ≤ max₂`.
      have not_mem : j ∉ set₂ := λ h, lt_irrefl _
        ((max'_lt_iff set₂ (nonempty y rid₂)).mp max_lt j h),
      rw set₂_eq at not_mem,
      simp only [not_and, not_not, ne.def, dfinsupp.mem_support_to_fun, mem_filter] at not_mem,
      exact ideal.mul_mem_left I _ (not_mem H₃), }, },

  have not_mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∉ I,
  { have neither_mem : proj 𝒜 max₁ x ∉ I ∧ proj 𝒜 max₂ y ∉ I,
    { rw mem_filter at mem_max₁ mem_max₂,
      exact ⟨mem_max₁.2, mem_max₂.2⟩, },
    intro rid,
    cases homogeneous_mem_or_mem ⟨max₁, submodule.coe_mem _⟩ ⟨max₂, submodule.coe_mem _⟩ mem_I,
    { apply neither_mem.1 h },
    { apply neither_mem.2 h }, },

  exact not_mem_I mem_I,
end⟩

lemma ideal.is_homogeneous.is_prime_iff {I : ideal A} (h : I.is_homogeneous 𝒜) :
  I.is_prime ↔
  (I ≠ ⊤) ∧
    ∀ {x y : A}, set_like.is_homogeneous 𝒜 x → set_like.is_homogeneous 𝒜 y
      → (x * y ∈ I → x ∈ I ∨ y ∈ I) :=
⟨λ HI,
  ⟨ne_of_apply_ne _ HI.ne_top, λ x y hx hy hxy, ideal.is_prime.mem_or_mem HI hxy⟩,
  λ ⟨I_ne_top, homogeneous_mem_or_mem⟩,
    h.is_prime_of_homogeneous_mem_or_mem I_ne_top @homogeneous_mem_or_mem⟩

lemma ideal.is_prime.homogeneous_core {I : ideal A} (h : I.is_prime) :
  (I.homogeneous_core 𝒜).to_ideal.is_prime :=
begin
  apply (ideal.homogeneous_core 𝒜 I).is_homogeneous.is_prime_of_homogeneous_mem_or_mem,
  { exact ne_top_of_le_ne_top h.ne_top (ideal.to_ideal_homogeneous_core_le 𝒜 I) },
  rintros x y hx hy hxy,
  have H := h.mem_or_mem (ideal.to_ideal_homogeneous_core_le 𝒜 I hxy),
  refine H.imp _ _,
  { exact ideal.mem_homogeneous_core_of_is_homogeneous_of_mem hx, },
  { exact ideal.mem_homogeneous_core_of_is_homogeneous_of_mem hy, },
end

lemma ideal.is_homogeneous.radical_eq {I : ideal A} (hI : I.is_homogeneous 𝒜) :
  I.radical = Inf { J | J.is_homogeneous 𝒜 ∧ I ≤ J ∧ J.is_prime } :=
begin
  rw ideal.radical_eq_Inf,
  apply le_antisymm,
  { exact Inf_le_Inf (λ J, and.right), },
  { refine Inf_le_Inf_of_forall_exists_le _,
    rintros J ⟨HJ₁, HJ₂⟩,
    refine ⟨(J.homogeneous_core 𝒜).to_ideal, _, J.to_ideal_homogeneous_core_le _⟩,
    refine ⟨homogeneous_ideal.is_homogeneous _, _, HJ₂.homogeneous_core⟩,
    refine hI.to_ideal_homogeneous_core_eq_self.symm.trans_le (ideal.homogeneous_core_mono _ HJ₁), }
end

lemma ideal.is_homogeneous.radical {I : ideal A} (h : I.is_homogeneous 𝒜)  :
  I.radical.is_homogeneous 𝒜 :=
by { rw h.radical_eq, exact ideal.is_homogeneous.Inf (λ _, and.left) }

/-- The radical of a homogenous ideal, as another homogenous ideal. -/
def homogeneous_ideal.radical (I : homogeneous_ideal 𝒜) : homogeneous_ideal 𝒜 :=
⟨I.to_ideal.radical, I.is_homogeneous.radical⟩

@[simp]
lemma homogeneous_ideal.coe_radical (I : homogeneous_ideal 𝒜) :
  I.radical.to_ideal = I.to_ideal.radical := rfl


<|start_filename|>src/set_theory/ordinal/topology.lean<|end_filename|>
/-
Copyright (c) 2022 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import set_theory.ordinal.arithmetic
import topology.algebra.order.basic

/-!
### Topology of ordinals

We prove some miscellaneous results involving the order topology of ordinals.

### Main results

* `ordinal.is_closed_iff_sup` / `ordinal.is_closed_iff_bsup`: A set of ordinals is closed iff it's
  closed under suprema.
* `ordinal.is_normal_iff_strict_mono_and_continuous`: A characterization of normal ordinal
  functions.
* `ordinal.enum_ord_is_normal_iff_is_closed`: The function enumerating the ordinals of a set is
  normal iff the set is closed.
-/

noncomputable theory

universes u v

open cardinal order

namespace ordinal

variables {s : set ordinal.{u}} {a : ordinal.{u}}

instance : topological_space ordinal.{u} :=
preorder.topology ordinal.{u}

instance : order_topology ordinal.{u} :=
⟨rfl⟩

theorem is_open_singleton_iff : is_open ({a} : set ordinal) ↔ ¬ is_limit a :=
begin
  refine ⟨λ h ha, _, λ ha, _⟩,
  { obtain ⟨b, c, hbc, hbc'⟩ := (mem_nhds_iff_exists_Ioo_subset'
      ⟨0, ordinal.pos_iff_ne_zero.2 ha.1⟩ ⟨_, lt_succ a⟩).1 (h.mem_nhds rfl),
    have hba := ha.2 b hbc.1,
    exact hba.ne (hbc' ⟨lt_succ b, hba.trans hbc.2⟩) },
  { rcases zero_or_succ_or_limit a with rfl | ⟨b, hb⟩ | ha',
    { convert is_open_gt' (1 : ordinal),
      ext,
      exact ordinal.lt_one_iff_zero.symm },
    { convert @is_open_Ioo _ _ _ _ b (a + 1),
      ext c,
      refine ⟨λ hc, _, _⟩,
      { rw set.mem_singleton_iff.1 hc,
        refine ⟨_, lt_succ a⟩,
        rw hb,
        exact lt_succ b },
      { rintro ⟨hc, hc'⟩,
        apply le_antisymm (le_of_lt_succ hc'),
        rw hb,
        exact succ_le_of_lt hc } },
    { exact (ha ha').elim } }
end

theorem is_open_iff : is_open s ↔ ∀ o ∈ s, is_limit o → ∃ a < o, set.Ioo a o ⊆ s :=
begin
  classical,
  refine ⟨_, λ h, _⟩,
  { rw is_open_iff_generate_intervals,
    intros h o hos ho,
    have ho₀ := ordinal.pos_iff_ne_zero.2 ho.1,
    induction h with t ht t u ht hu ht' hu' t ht H,
    { rcases ht with ⟨a, rfl | rfl⟩,
      { exact ⟨a, hos, λ b hb, hb.1⟩ },
      { exact ⟨0, ho₀, λ b hb, hb.2.trans hos⟩ } },
    { exact ⟨0, ho₀, λ b _, set.mem_univ b⟩ },
    { rcases ht' hos.1 with ⟨a, ha, ha'⟩,
      rcases hu' hos.2 with ⟨b, hb, hb'⟩,
      exact ⟨_, max_lt ha hb, λ c hc, ⟨
        ha' ⟨(le_max_left a b).trans_lt hc.1, hc.2⟩,
        hb' ⟨(le_max_right a b).trans_lt hc.1, hc.2⟩⟩⟩ },
    { rcases hos with ⟨u, hu, hu'⟩,
      rcases H u hu hu' with ⟨a, ha, ha'⟩,
      exact ⟨a, ha, λ b hb, ⟨u, hu, ha' hb⟩⟩ } },
  { let f : s → set ordinal := λ o,
      if ho : is_limit o.val
      then set.Ioo (classical.some (h o.val o.prop ho)) (o + 1)
      else {o.val},
    have : ∀ a, is_open (f a) := λ a, begin
      change is_open (dite _ _ _),
      split_ifs,
      { exact is_open_Ioo },
      { rwa is_open_singleton_iff }
    end,
    convert is_open_Union this,
    ext o,
    refine ⟨λ ho, set.mem_Union.2 ⟨⟨o, ho⟩, _⟩, _⟩,
    { split_ifs with ho',
      { refine ⟨_, lt_succ o⟩,
        cases classical.some_spec (h o ho ho') with H,
        exact H },
      { exact set.mem_singleton o } },
    { rintro ⟨t, ⟨a, ht⟩, hoa⟩,
      change dite _ _ _ = t at ht,
      split_ifs at ht with ha;
      subst ht,
      { cases classical.some_spec (h a.val a.prop ha) with H has,
        rcases lt_or_eq_of_le (le_of_lt_succ hoa.2) with hoa' | rfl,
        { exact has ⟨hoa.1, hoa'⟩ },
        { exact a.prop } },
      { convert a.prop } } }
end

theorem mem_closure_iff_sup : a ∈ closure s ↔ ∃ {ι : Type u} [nonempty ι] (f : ι → ordinal),
  (∀ i, f i ∈ s) ∧ sup.{u u} f = a :=
begin
  refine mem_closure_iff.trans ⟨λ h, _, _⟩,
  { by_cases has : a ∈ s,
    { exact ⟨punit, by apply_instance, λ _, a, λ _, has, sup_const a⟩ },
    { have H := λ b (hba : b < a), h _ (@is_open_Ioo _ _ _ _ b (a + 1)) ⟨hba, lt_succ a⟩,
      let f : a.out.α → ordinal := λ i, classical.some (H (typein (<) i) (typein_lt_self i)),
      have hf : ∀ i, f i ∈ set.Ioo (typein (<) i) (a + 1) ∩ s :=
        λ i, classical.some_spec (H _ _),
      rcases eq_zero_or_pos a with rfl | ha₀,
      { rcases h _ (is_open_singleton_iff.2 not_zero_is_limit) rfl with ⟨b, hb, hb'⟩,
        rw set.mem_singleton_iff.1 hb at *,
        exact (has hb').elim },
      refine ⟨_, out_nonempty_iff_ne_zero.2 (ordinal.pos_iff_ne_zero.1 ha₀), f,
        λ i, (hf i).2, le_antisymm (sup_le (λ i, le_of_lt_succ (hf i).1.2)) _⟩,
      by_contra' h,
      cases H _ h with b hb,
      rcases eq_or_lt_of_le (le_of_lt_succ hb.1.2) with rfl | hba,
      { exact has hb.2 },
      { have : b < f (enum (<) b (by rwa type_lt)) := begin
          have := (hf (enum (<) b (by rwa type_lt))).1.1,
          rwa typein_enum at this
        end,
        have : b ≤ sup.{u u} f := this.le.trans (le_sup f _),
        exact this.not_lt hb.1.1 } } },
  { rintro ⟨ι, ⟨i⟩, f, hf, rfl⟩ t ht hat,
    cases eq_zero_or_pos (sup.{u u} f) with ha₀ ha₀,
    { rw ha₀ at hat,
      use [0, hat],
      convert hf i,
      exact (sup_eq_zero_iff.1 ha₀ i).symm },
    rcases (mem_nhds_iff_exists_Ioo_subset' ⟨0, ha₀⟩ ⟨_, lt_succ _⟩).1 (ht.mem_nhds hat) with
      ⟨b, c, ⟨hab, hac⟩, hbct⟩,
    cases lt_sup.1 hab with i hi,
    exact ⟨_, hbct ⟨hi, (le_sup.{u u} f i).trans_lt hac⟩, hf i⟩ }
end

theorem mem_closed_iff_sup (hs : is_closed s) :
  a ∈ s ↔ ∃ {ι : Type u} (hι : nonempty ι) (f : ι → ordinal),
  (∀ i, f i ∈ s) ∧ sup.{u u} f = a :=
by rw [←mem_closure_iff_sup, hs.closure_eq]

theorem mem_closure_iff_bsup :
  a ∈ closure s ↔ ∃ {o : ordinal} (ho : o ≠ 0) (f : Π a < o, ordinal),
  (∀ i hi, f i hi ∈ s) ∧ bsup.{u u} o f = a :=
mem_closure_iff_sup.trans ⟨
  λ ⟨ι, ⟨i⟩, f, hf, ha⟩, ⟨_, λ h, (type_eq_zero_iff_is_empty.1 h).elim i, bfamily_of_family f,
    λ i hi, hf _, by rwa bsup_eq_sup⟩,
  λ ⟨o, ho, f, hf, ha⟩, ⟨_, out_nonempty_iff_ne_zero.2 ho, family_of_bfamily o f,
    λ i, hf _ _, by rwa sup_eq_bsup⟩⟩

theorem mem_closed_iff_bsup (hs : is_closed s) :
  a ∈ s ↔ ∃ {o : ordinal} (ho : o ≠ 0) (f : Π a < o, ordinal),
  (∀ i hi, f i hi ∈ s) ∧ bsup.{u u} o f = a :=
by rw [←mem_closure_iff_bsup, hs.closure_eq]

theorem is_closed_iff_sup :
  is_closed s ↔ ∀ {ι : Type u} (hι : nonempty ι) (f : ι → ordinal),
  (∀ i, f i ∈ s) → sup.{u u} f ∈ s :=
begin
  use λ hs ι hι f hf, (mem_closed_iff_sup hs).2 ⟨ι, hι, f, hf, rfl⟩,
  rw ←closure_subset_iff_is_closed,
  intros h x hx,
  rcases mem_closure_iff_sup.1 hx with ⟨ι, hι, f, hf, rfl⟩,
  exact h hι f hf
end

theorem is_closed_iff_bsup :
  is_closed s ↔ ∀ {o : ordinal} (ho : o ≠ 0) (f : Π a < o, ordinal),
  (∀ i hi, f i hi ∈ s) → bsup.{u u} o f ∈ s :=
begin
  rw is_closed_iff_sup,
  refine ⟨λ H o ho f hf, H (out_nonempty_iff_ne_zero.2 ho) _ _, λ  H ι hι f hf, _⟩,
  { exact λ i, hf _ _ },
  { rw ←bsup_eq_sup,
    apply H (type_ne_zero_iff_nonempty.2 hι),
    exact λ i hi, hf _ }
end

theorem is_limit_of_mem_frontier (ha : a ∈ frontier s) : is_limit a :=
begin
  simp only [frontier_eq_closure_inter_closure, set.mem_inter_iff, mem_closure_iff] at ha,
  by_contra h,
  rw ←is_open_singleton_iff at h,
  rcases ha.1 _ h rfl with ⟨b, hb, hb'⟩,
  rcases ha.2 _ h rfl with ⟨c, hc, hc'⟩,
  rw set.mem_singleton_iff at *,
  subst hb, subst hc,
  exact hc' hb'
end

theorem is_normal_iff_strict_mono_and_continuous (f : ordinal.{u} → ordinal.{u}) :
  is_normal f ↔ strict_mono f ∧ continuous f :=
begin
  refine ⟨λ h, ⟨h.strict_mono, _⟩, _⟩,
  { rw continuous_def,
    intros s hs,
    rw is_open_iff at *,
    intros o ho ho',
    rcases hs _ ho (h.is_limit ho') with ⟨a, ha, has⟩,
    rw [←is_normal.bsup_eq.{u u} h ho', lt_bsup] at ha,
    rcases ha with ⟨b, hb, hab⟩,
    exact ⟨b, hb, λ c hc,
      set.mem_preimage.2 (has ⟨hab.trans (h.strict_mono hc.1), h.strict_mono hc.2⟩)⟩ },
  { rw is_normal_iff_strict_mono_limit,
    rintro ⟨h, h'⟩,
    refine ⟨h, λ o ho a h, _⟩,
    suffices : o ∈ (f ⁻¹' set.Iic a), from set.mem_preimage.1 this,
    rw mem_closed_iff_sup (is_closed.preimage h' (@is_closed_Iic _ _ _ _  a)),
    exact ⟨_, out_nonempty_iff_ne_zero.2 ho.1, typein (<),
      λ i, h _ (typein_lt_self i), sup_typein_limit ho.2⟩ }
end

theorem enum_ord_is_normal_iff_is_closed (hs : s.unbounded (<)) :
  is_normal (enum_ord s) ↔ is_closed s :=
begin
  have Hs := enum_ord_strict_mono hs,
  refine ⟨λ h, is_closed_iff_sup.2 (λ ι hι f hf, _),
    λ h, (is_normal_iff_strict_mono_limit _).2 ⟨Hs, λ a ha o H, _⟩⟩,
  { let g : ι → ordinal.{u} := λ i, (enum_ord_order_iso hs).symm ⟨_, hf i⟩,
    suffices : enum_ord s (sup.{u u} g) = sup.{u u} f,
    { rw ←this, exact enum_ord_mem hs _ },
    rw is_normal.sup.{u u u} h g hι,
    congr, ext,
    change ((enum_ord_order_iso hs) _).val = f x,
    rw order_iso.apply_symm_apply },
  { rw is_closed_iff_bsup at h,
    suffices : enum_ord s a ≤ bsup.{u u} a (λ b < a, enum_ord s b), from this.trans (bsup_le H),
    cases enum_ord_surjective hs _ (h ha.1 (λ b hb, enum_ord s b) (λ b hb, enum_ord_mem hs b))
      with b hb,
    rw ←hb,
    apply Hs.monotone,
    by_contra' hba,
    apply (Hs (lt_succ b)).not_le,
    rw hb,
    exact le_bsup.{u u} _ _ (ha.2 _ hba) }
end

end ordinal


<|start_filename|>src/data/pfunctor/multivariate/basic.lean<|end_filename|>
/-
Copyright (c) 2018 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>, <NAME>
-/
import control.functor.multivariate
import data.pfunctor.univariate.basic

/-!
# Multivariate polynomial functors.

Multivariate polynomial functors are used for defining M-types and W-types.
They map a type vector `α` to the type `Σ a : A, B a ⟹ α`, with `A : Type` and
`B : A → typevec n`. They interact well with Lean's inductive definitions because
they guarantee that occurrences of `α` are positive.
-/

universes u v
open_locale mvfunctor

/--
multivariate polynomial functors
-/
structure mvpfunctor (n : ℕ) :=
(A : Type.{u}) (B : A → typevec.{u} n)

namespace mvpfunctor
open mvfunctor (liftp liftr)

variables {n m : ℕ} (P : mvpfunctor.{u} n)

/-- Applying `P` to an object of `Type` -/
def obj (α : typevec.{u} n) : Type u := Σ a : P.A, P.B a ⟹ α

/-- Applying `P` to a morphism of `Type` -/
def map {α β : typevec n} (f : α ⟹ β) : P.obj α → P.obj β :=
λ ⟨a, g⟩, ⟨a, typevec.comp f g⟩

instance : inhabited (mvpfunctor n) :=
⟨⟨default, default⟩⟩

instance obj.inhabited {α : typevec n} [inhabited P.A] [Π i, inhabited (α i)] :
  inhabited (P.obj α) :=
⟨ ⟨default, λ _ _, default⟩ ⟩

instance : mvfunctor P.obj :=
⟨@mvpfunctor.map n P⟩

theorem map_eq {α β : typevec n} (g : α ⟹ β) (a : P.A) (f : P.B a ⟹ α) :
  @mvfunctor.map _ P.obj _ _ _ g ⟨a, f⟩ = ⟨a, g ⊚ f⟩ :=
rfl

theorem id_map {α : typevec n} : ∀ x : P.obj α, typevec.id <$$> x = x
| ⟨a, g⟩ := rfl

theorem comp_map {α β γ : typevec n} (f : α ⟹ β) (g : β ⟹ γ) :
  ∀ x : P.obj α, (g ⊚ f) <$$> x = g <$$> (f <$$> x)
| ⟨a, h⟩ := rfl

instance : is_lawful_mvfunctor P.obj :=
{ id_map := @id_map _ P,
  comp_map := @comp_map _ P }

/-- Constant functor where the input object does not affect the output -/
def const (n : ℕ) (A : Type u) : mvpfunctor n :=
{ A := A, B := λ a i, pempty }

section const
variables (n) {A : Type u}  {α β : typevec.{u} n}

/-- Constructor for the constant functor -/
def const.mk (x : A) {α} : (const n A).obj α :=
⟨ x, λ i a, pempty.elim a ⟩

variables {n A}

/-- Destructor for the constant functor -/
def const.get (x : (const n A).obj α) : A :=
x.1

@[simp]
lemma const.get_map (f : α ⟹ β) (x : (const n A).obj α) :
  const.get (f <$$> x) = const.get x :=
by { cases x, refl }

@[simp]
lemma const.get_mk (x : A) : const.get (const.mk n x : (const n A).obj α) = x :=
by refl

@[simp]
lemma const.mk_get (x : (const n A).obj α) : const.mk n (const.get x) = x :=
by { cases x, dsimp [const.get,const.mk], congr' with _ ⟨ ⟩ }

end const

/-- Functor composition on polynomial functors -/
def comp (P : mvpfunctor.{u} n) (Q : fin2 n → mvpfunctor.{u} m) : mvpfunctor m :=
{ A := Σ a₂ : P.1, Π i, P.2 a₂ i → (Q i).1,
  B := λ a, λ i, Σ j (b : P.2 a.1 j), (Q j).2 (a.snd j b) i }

variables {P} {Q : fin2 n → mvpfunctor.{u} m} {α β : typevec.{u} m}

/-- Constructor for functor composition -/
def comp.mk (x : P.obj (λ i, (Q i).obj α)) : (comp P Q).obj α :=
⟨ ⟨ x.1, λ i a, (x.2 _ a).1  ⟩, λ i a, (x.snd a.fst (a.snd).fst).snd i (a.snd).snd ⟩

/-- Destructor for functor composition -/
def comp.get (x : (comp P Q).obj α) : P.obj (λ i, (Q i).obj α) :=
⟨ x.1.1, λ i a, ⟨x.fst.snd i a, λ (j : fin2 m) (b : (Q i).B _ j), x.snd j ⟨i, ⟨a, b⟩⟩⟩ ⟩

lemma comp.get_map (f : α ⟹ β) (x : (comp P Q).obj α) :
  comp.get (f <$$> x) = (λ i (x : (Q i).obj α), f <$$> x) <$$> comp.get x :=
by { cases x, refl }

@[simp]
lemma comp.get_mk (x : P.obj (λ i, (Q i).obj α)) : comp.get (comp.mk x) = x :=
begin
  cases x,
  simp! [comp.get,comp.mk],
end

@[simp]
lemma comp.mk_get (x : (comp P Q).obj α) : comp.mk (comp.get x) = x :=
begin
  cases x,
  dsimp [comp.get,comp.mk],
  ext : 2; intros, refl, refl,
  congr, ext1; intros; refl,
  ext : 2, congr, rcases x_1 with ⟨a,b,c⟩; refl
end

/-
lifting predicates and relations
-/

theorem liftp_iff {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (x : P.obj α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i j, p (f i j) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i j, (f i j).val, _, λ i j, (f i j).property⟩,
    rw [←hy, h, map_eq], refl },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i j, ⟨f i j, pf i j⟩⟩,
  rw [xeq], reflexivity
end

theorem liftp_iff' {α : typevec n} (p : Π ⦃i⦄ , α i → Prop) (a : P.A) (f : P.B a ⟹ α) :
  @liftp.{u} _ P.obj _ α p ⟨a,f⟩ ↔ ∀ i x, p (f i x) :=
begin
  simp only [liftp_iff, sigma.mk.inj_iff]; split; intro,
  { casesm* [Exists _, _ ∧ _], subst_vars, assumption },
  repeat { constructor <|> assumption }
end

theorem liftr_iff {α : typevec n} (r : Π ⦃i⦄, α i → α i → Prop) (x y : P.obj α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i j, r (f₀ i j) (f₁ i j) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i j, (f i j).val.fst, λ i j, (f i j).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intros i j, exact (f i j).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i j, ⟨(f₀ i j, f₁ i j), h i j⟩⟩,
  dsimp, split,
  { rw [xeq], refl },
  rw [yeq], refl
end

open set mvfunctor

theorem supp_eq {α : typevec n} (a : P.A) (f : P.B a ⟹ α) (i) :
  @supp.{u} _ P.obj _ α  (⟨a,f⟩ : P.obj α) i = f i '' univ :=
begin
  ext, simp only [supp, image_univ, mem_range, mem_set_of_eq],
  split; intro h,
  { apply @h (λ i x, ∃ (y : P.B a i), f i y = x),
    rw liftp_iff', intros, refine ⟨_,rfl⟩ },
  { simp only [liftp_iff'], cases h, subst x,
    tauto }
end

end mvpfunctor

/-
Decomposing an n+1-ary pfunctor.
-/

namespace mvpfunctor
open typevec
variables {n : ℕ} (P : mvpfunctor.{u} (n+1))

/-- Split polynomial functor, get a n-ary functor
from a `n+1`-ary functor -/
def drop : mvpfunctor n :=
{ A := P.A, B := λ a, (P.B a).drop }

/-- Split polynomial functor, get a univariate functor
from a `n+1`-ary functor -/
def last : pfunctor :=
{ A := P.A, B := λ a, (P.B a).last }

/-- append arrows of a polynomial functor application -/
@[reducible] def append_contents {α : typevec n} {β : Type*}
    {a : P.A} (f' : P.drop.B a ⟹ α) (f : P.last.B a → β) :
  P.B a ⟹ α ::: β :=
split_fun f' f

end mvpfunctor


<|start_filename|>src/category_theory/monoidal/CommMon_.lean<|end_filename|>
/-
Copyright (c) 2020 <NAME>. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: <NAME>
-/
import category_theory.monoidal.braided
import category_theory.monoidal.Mon_

/-!
# The category of commutative monoids in a braided monoidal category.
-/

universes v₁ v₂ u₁ u₂ u

open category_theory
open category_theory.monoidal_category

variables (C : Type u₁) [category.{v₁} C] [monoidal_category.{v₁} C] [braided_category.{v₁} C]

/--
A commutative monoid object internal to a monoidal category.
-/
structure CommMon_ extends Mon_ C :=
(mul_comm' : (β_ _ _).hom ≫ mul = mul . obviously)

restate_axiom CommMon_.mul_comm'
attribute [simp, reassoc] CommMon_.mul_comm

namespace CommMon_

/--
The trivial commutative monoid object. We later show this is initial in `CommMon_ C`.
-/
@[simps]
def trivial : CommMon_ C :=
{ mul_comm' := begin dsimp, rw [braiding_left_unitor, unitors_equal], end
  ..Mon_.trivial C }

instance : inhabited (CommMon_ C) := ⟨trivial C⟩

variables {C} {M : CommMon_ C}

instance : category (CommMon_ C) :=
induced_category.category CommMon_.to_Mon_

@[simp] lemma id_hom (A : CommMon_ C) : Mon_.hom.hom (𝟙 A) = 𝟙 A.X := rfl
@[simp] lemma comp_hom {R S T : CommMon_ C} (f : R ⟶ S) (g : S ⟶ T) :
  Mon_.hom.hom (f ≫ g) = f.hom ≫ g.hom := rfl

section
variables (C)

/-- The forgetful functor from commutative monoid objects to monoid objects. -/
@[derive [full, faithful]]
def forget₂_Mon_ : CommMon_ C ⥤ Mon_ C :=
induced_functor CommMon_.to_Mon_

@[simp] lemma forget₂_Mon_obj_one (A : CommMon_ C) : ((forget₂_Mon_ C).obj A).one = A.one := rfl
@[simp] lemma forget₂_Mon_obj_mul (A : CommMon_ C) : ((forget₂_Mon_ C).obj A).mul = A.mul := rfl
@[simp] lemma forget₂_Mon_map_hom {A B : CommMon_ C} (f : A ⟶ B) :
  ((forget₂_Mon_ C).map f).hom = f.hom := rfl

end

instance unique_hom_from_trivial (A : CommMon_ C) : unique (trivial C ⟶ A) :=
Mon_.unique_hom_from_trivial A.to_Mon_

open category_theory.limits

instance : has_initial (CommMon_ C) :=
has_initial_of_unique (trivial C)

end CommMon_

namespace category_theory.lax_braided_functor

variables {C} {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D] [braided_category.{v₂} D]

/--
A lax braided functor takes commutative monoid objects to commutative monoid objects.

That is, a lax braided functor `F : C ⥤ D` induces a functor `CommMon_ C ⥤ CommMon_ D`.
-/
@[simps]
def map_CommMon (F : lax_braided_functor C D) : CommMon_ C ⥤ CommMon_ D :=
{ obj := λ A,
  { mul_comm' :=
    begin
      dsimp,
      have := F.braided,
      slice_lhs 1 2 { rw ←this, },
      slice_lhs 2 3 { rw [←category_theory.functor.map_comp, A.mul_comm], },
    end,
    ..F.to_lax_monoidal_functor.map_Mon.obj A.to_Mon_ },
  map := λ A B f, F.to_lax_monoidal_functor.map_Mon.map f, }

variables (C) (D)

/-- `map_CommMon` is functorial in the lax braided functor. -/
def map_CommMon_functor : (lax_braided_functor C D) ⥤ (CommMon_ C ⥤ CommMon_ D) :=
{ obj := map_CommMon,
  map := λ F G α,
  { app := λ A,
    { hom := α.app A.X, } } }

end category_theory.lax_braided_functor

namespace CommMon_

open category_theory.lax_braided_functor

namespace equiv_lax_braided_functor_punit

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def lax_braided_to_CommMon : lax_braided_functor (discrete punit.{u+1}) C ⥤ CommMon_ C :=
{ obj := λ F, (F.map_CommMon : CommMon_ _ ⥤ CommMon_ C).obj (trivial (discrete punit)),
  map := λ F G α, ((map_CommMon_functor (discrete punit) C).map α).app _ }

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def CommMon_to_lax_braided : CommMon_ C ⥤ lax_braided_functor (discrete punit.{u+1}) C :=
{ obj := λ A,
  { obj := λ _, A.X,
    map := λ _ _ _, 𝟙 _,
    ε := A.one,
    μ := λ _ _, A.mul,
    map_id' := λ _, rfl,
    map_comp' := λ _ _ _ _ _, (category.id_comp (𝟙 A.X)).symm, },
  map := λ A B f,
  { app := λ _, f.hom,
    naturality' := λ _ _ _, by { dsimp, rw [category.id_comp, category.comp_id], },
    unit' := f.one_hom,
    tensor' := λ _ _, f.mul_hom, }, }

local attribute [tidy] tactic.discrete_cases
local attribute [simp] eq_to_iso_map

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def unit_iso :
  𝟭 (lax_braided_functor (discrete punit.{u+1}) C) ≅
    lax_braided_to_CommMon C ⋙ CommMon_to_lax_braided C :=
nat_iso.of_components (λ F, lax_braided_functor.mk_iso
  (monoidal_nat_iso.of_components
    (λ _, F.to_lax_monoidal_functor.to_functor.map_iso (eq_to_iso (by ext)))
    (by tidy) (by tidy) (by tidy)))
  (by tidy)

/-- Implementation of `CommMon_.equiv_lax_braided_functor_punit`. -/
@[simps]
def counit_iso : CommMon_to_lax_braided C ⋙ lax_braided_to_CommMon C ≅ 𝟭 (CommMon_ C) :=
nat_iso.of_components (λ F, { hom := { hom := 𝟙 _, }, inv := { hom := 𝟙 _, } })
  (by tidy)

end equiv_lax_braided_functor_punit

open equiv_lax_braided_functor_punit
local attribute [simp] eq_to_iso_map

/--
Commutative monoid objects in `C` are "just" braided lax monoidal functors from the trivial
braided monoidal category to `C`.
-/
@[simps]
def equiv_lax_braided_functor_punit : lax_braided_functor (discrete punit.{u+1}) C ≌ CommMon_ C :=
{ functor := lax_braided_to_CommMon C,
  inverse := CommMon_to_lax_braided C,
  unit_iso := unit_iso C,
  counit_iso := counit_iso C, }

end CommMon_
