/-
Copyright (c) 2021 Alena Gusakov, Bhavik Mehta, Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alena Gusakov, Bhavik Mehta, Kyle Miller
-/
import combinatorics.hall.finite
import category_theory.cofiltered_system
import data.rel

/-!
# Hall's Marriage Theorem

Given a list of finite subsets $X_1, X_2, \dots, X_n$ of some given set
$S$, P. Hall in [Hall1935] gave a necessary and sufficient condition for
there to be a list of distinct elements $x_1, x_2, \dots, x_n$ with
$x_i\in X_i$ for each $i$: it is when for each $k$, the union of every
$k$ of these subsets has at least $k$ elements.

Rather than a list of finite subsets, one may consider indexed families
`t : ι → finset α` of finite subsets with `ι` a `fintype`, and then the list
of distinct representatives is given by an injective function `f : ι → α`
such that `∀ i, f i ∈ t i`, called a *matching*.
This version is formalized as `finset.all_card_le_bUnion_card_iff_exists_injective'`
in a separate module.

The theorem can be generalized to remove the constraint that `ι` be a `fintype`.
As observed in [Halpern1966], one may use the constrained version of the theorem
in a compactness argument to remove this constraint.
The formulation of compactness we use is that inverse limits of nonempty finite sets
are nonempty (`nonempty_sections_of_finite_inverse_system`), which uses the
Tychonoff theorem.
The core of this module is constructing the inverse system: for every finite subset `ι'` of
`ι`, we can consider the matchings on the restriction of the indexed family `t` to `ι'`.

## Main statements

* `finset.all_card_le_bUnion_card_iff_exists_injective` is in terms of `t : ι → finset α`.
* `fintype.all_card_le_rel_image_card_iff_exists_injective` is in terms of a relation
  `r : α → β → Prop` such that `rel.image r {a}` is a finite set for all `a : α`.
* `fintype.all_card_le_filter_rel_iff_exists_injective` is in terms of a relation
  `r : α → β → Prop` on finite types, with the Hall condition given in terms of
  `finset.univ.filter`.

## Todo

* The statement of the theorem in terms of bipartite graphs is in preparation.

## Tags

Hall's Marriage Theorem, indexed families
-/

open finset

universes u v

/-- The set of matchings for `t` when restricted to a `finset` of `ι`. -/
def hall_matchings_on {ι : Type u} {α : Type v} (t : ι → finset α) (ι' : finset ι) :=
{f : ι' → α | function.injective f ∧ ∀ x, f x ∈ t x}

/-- Given a matching on a finset, construct the restriction of that matching to a subset. -/
def hall_matchings_on.restrict {ι : Type u} {α : Type v}
  (t : ι → finset α) {ι' ι'' : finset ι} (h : ι' ⊆ ι'')
  (f : hall_matchings_on t ι'') : hall_matchings_on t ι' :=
begin
  refine ⟨λ i, f.val ⟨i, h i.property⟩, _⟩,
  cases f.property with hinj hc,
  refine ⟨_, λ i, hc ⟨i, h i.property⟩⟩,
  rintro ⟨i, hi⟩ ⟨j, hj⟩ hh,
  simpa only [subtype.mk_eq_mk] using hinj hh,
end

/-- When the Hall condition is satisfied, the set of matchings on a finite set is nonempty.
This is where `finset.all_card_le_bUnion_card_iff_exists_injective'` comes into the argument. -/
lemma hall_matchings_on.nonempty {ι : Type u} {α : Type v} [decidable_eq α]
  (t : ι → finset α) (h : (∀ (s : finset ι), s.card ≤ (s.bUnion t).card))
  (ι' : finset ι) : nonempty (hall_matchings_on t ι') :=
begin
  classical,
  refine ⟨classical.indefinite_description _ _⟩,
  apply (all_card_le_bUnion_card_iff_exists_injective' (λ (i : ι'), t i)).mp,
  intro s',
  convert h (s'.image coe) using 1,
  simp only [card_image_of_injective s' subtype.coe_injective],
  rw image_bUnion,
end

/--
This is the `hall_matchings_on` sets assembled into a directed system.
-/
-- TODO: This takes a long time to elaborate for an unknown reason.
def hall_matchings_functor {ι : Type u} {α : Type v} (t : ι → finset α) :
  (finset ι)ᵒᵖ ⥤ Type (max u v) :=
{ obj := λ ι', hall_matchings_on t ι'.unop,
  map := λ ι' ι'' g f, hall_matchings_on.restrict t (category_theory.le_of_hom g.unop) f }

instance hall_matchings_on.finite {ι : Type u} {α : Type v} (t : ι → finset α) (ι' : finset ι) :
  finite (hall_matchings_on t ι') :=
begin
  classical,
  rw hall_matchings_on,
  let g : hall_matchings_on t ι' → (ι' → ι'.bUnion t),
  { rintro f i,
    refine ⟨f.val i, _⟩,
    rw mem_bUnion,
    exact ⟨i, i.property, f.property.2 i⟩ },
  apply finite.of_injective g,
  intros f f' h,
  simp only [g, function.funext_iff, subtype.val_eq_coe] at h,
  ext a,
  exact h a,
end

/--
This is the version of **Hall's Marriage Theorem** in terms of indexed
families of finite sets `t : ι → finset α`.  It states that there is a
set of distinct representatives if and only if every union of `k` of the
sets has at least `k` elements.

Recall that `s.bUnion t` is the union of all the sets `t i` for `i ∈ s`.

This theorem is bootstrapped from `finset.all_card_le_bUnion_card_iff_exists_injective'`,
which has the additional constraint that `ι` is a `fintype`.
-/
theorem finset.all_card_le_bUnion_card_iff_exists_injective
  {ι : Type u} {α : Type v} [decidable_eq α] (t : ι → finset α) :
  (∀ (s : finset ι), s.card ≤ (s.bUnion t).card) ↔
    (∃ (f : ι → α), function.injective f ∧ ∀ x, f x ∈ t x) :=
begin
  split,
  { intro h,
    /- Set up the functor -/
    haveI : ∀ (ι' : (finset ι)ᵒᵖ), nonempty ((hall_matchings_functor t).obj ι') :=
      λ ι', hall_matchings_on.nonempty t h ι'.unop,
    classical,
    haveI : Π (ι' : (finset ι)ᵒᵖ), finite ((hall_matchings_functor t).obj ι') := begin
      intro ι',
      rw [hall_matchings_functor],
      apply_instance,
    end,
    /- Apply the compactness argument -/
    obtain ⟨u, hu⟩ := nonempty_sections_of_finite_inverse_system (hall_matchings_functor t),
    /- Interpret the resulting section of the inverse limit -/
    refine ⟨_, _, _⟩,
    { /- Build the matching function from the section -/
      exact λ i, (u (opposite.op ({i} : finset ι))).val
                 ⟨i, by simp only [opposite.unop_op, mem_singleton]⟩, },
    { /- Show that it is injective -/
      intros i i',
      have subi : ({i} : finset ι) ⊆ {i,i'} := by simp,
      have subi' : ({i'} : finset ι) ⊆ {i,i'} := by simp,
      have le : ∀ {s t : finset ι}, s ⊆ t → s ≤ t := λ _ _ h, h,
      rw [←hu (category_theory.hom_of_le (le subi)).op,
          ←hu (category_theory.hom_of_le (le subi')).op],
      let uii' := u (opposite.op ({i,i'} : finset ι)),
      exact λ h, subtype.mk_eq_mk.mp (uii'.property.1 h), },
    { /- Show that it maps each index to the corresponding finite set -/
      intro i,
      apply (u (opposite.op ({i} : finset ι))).property.2, }, },
  { /- The reverse direction is a straightforward cardinality argument -/
    rintro ⟨f, hf₁, hf₂⟩ s,
    rw ←finset.card_image_of_injective s hf₁,
    apply finset.card_le_of_subset,
    intro _,
    rw [finset.mem_image, finset.mem_bUnion],
    rintros ⟨x, hx, rfl⟩,
    exact ⟨x, hx, hf₂ x⟩, },
end

/-- Given a relation such that the image of every singleton set is finite, then the image of every
finite set is finite. -/
instance {α : Type u} {β : Type v} [decidable_eq β]
  (r : α → β → Prop) [∀ (a : α), fintype (rel.image r {a})]
  (A : finset α) : fintype (rel.image r A) :=
begin
  have h : rel.image r A = (A.bUnion (λ a, (rel.image r {a}).to_finset) : set β),
  { ext, simp [rel.image], },
  rw [h],
  apply finset_coe.fintype,
end

/--
This is a version of **Hall's Marriage Theorem** in terms of a relation
between types `α` and `β` such that `α` is finite and the image of
each `x : α` is finite (it suffices for `β` to be finite; see
`fintype.all_card_le_filter_rel_iff_exists_injective`).  There is
a transversal of the relation (an injective function `α → β` whose graph is
a subrelation of the relation) iff every subset of
`k` terms of `α` is related to at least `k` terms of `β`.

Note: if `[fintype β]`, then there exist instances for `[∀ (a : α), fintype (rel.image r {a})]`.
-/
theorem fintype.all_card_le_rel_image_card_iff_exists_injective
  {α : Type u} {β : Type v} [decidable_eq β]
  (r : α → β → Prop) [∀ (a : α), fintype (rel.image r {a})] :
  (∀ (A : finset α), A.card ≤ fintype.card (rel.image r A)) ↔
    (∃ (f : α → β), function.injective f ∧ ∀ x, r x (f x)) :=
begin
  let r' := λ a, (rel.image r {a}).to_finset,
  have h : ∀ (A : finset α), fintype.card (rel.image r A) = (A.bUnion r').card,
  { intro A,
    rw ←set.to_finset_card,
    apply congr_arg,
    ext b,
    simp [rel.image], },
  have h' : ∀ (f : α → β) x, r x (f x) ↔ f x ∈ r' x,
  { simp [rel.image], },
  simp only [h, h'],
  apply finset.all_card_le_bUnion_card_iff_exists_injective,
end

/--
This is a version of **Hall's Marriage Theorem** in terms of a relation to a finite type.
There is a transversal of the relation (an injective function `α → β` whose graph is a subrelation
of the relation) iff every subset of `k` terms of `α` is related to at least `k` terms of `β`.

It is like `fintype.all_card_le_rel_image_card_iff_exists_injective` but uses `finset.filter`
rather than `rel.image`.
-/
/- TODO: decidable_pred makes Yael sad. When an appropriate decidable_rel-like exists, fix it. -/
theorem fintype.all_card_le_filter_rel_iff_exists_injective
  {α : Type u} {β : Type v} [fintype β]
  (r : α → β → Prop) [∀ a, decidable_pred (r a)] :
  (∀ (A : finset α), A.card ≤ (univ.filter (λ (b : β), ∃ a ∈ A, r a b)).card) ↔
    (∃ (f : α → β), function.injective f ∧ ∀ x, r x (f x)) :=
begin
  haveI := classical.dec_eq β,
  let r' := λ a, univ.filter (λ b, r a b),
  have h : ∀ (A : finset α), (univ.filter (λ (b : β), ∃ a ∈ A, r a b)) = (A.bUnion r'),
  { intro A,
    ext b,
    simp, },
  have h' : ∀ (f : α → β) x, r x (f x) ↔ f x ∈ r' x,
  { simp, },
  simp_rw [h, h'],
  apply finset.all_card_le_bUnion_card_iff_exists_injective,
end


import algebra.module
import topology.instances.real
import tactic.ring

/-

Construction of a homeomorphism of pairs
(Dⁿ, Sⁿ⁻¹) ⊗ (I, {0}) ≅ (Dⁿ, ∅) ⊗ (I, {0}).
See [tom Dieck, Algebraic Topology, Example 2.3.6].

Rather than specialize in ℝⁿ, we work in an arbitrary normed ℝ-linear
space V. Normed linear spaces are not yet in mathlib, so we just list
the structure and axioms we need on V.

-/

namespace homotopy_theory.topological_spaces.smush

class admissible (R : out_param Type) [discrete_linear_ordered_field R] (V : Type) extends has_scalar R V :=
(mul_smul' : ∀(r s : R) (x : V), (r * s) • x = r • s • x)
(one_smul' : ∀x : V, (1 : R) • x = x)
(norm : V → R)
(norm_nonneg : ∀x : V, 0 ≤ norm x)
(norm_mul : ∀r (x : V), norm (r • x) = abs r * norm x)

namespace construction
section

parameters {R : Type} [discrete_linear_ordered_field R]
parameters {V : Type} [@admissible R _ V]
open admissible

@[reducible] def I := {r : R // 0 ≤ r ∧ r ≤ 1}

local notation `norm` := (@admissible.norm R _ V _)

@[reducible] def unit_disk : Type := {v : V // norm v ≤ 1}
local notation `D` := unit_disk

def α : D × I → { r : R // r ≠ 0 } :=
λ p, ⟨max (2 * norm p.1.val) (2 - p.2.val),
  ne_of_gt $ gt_of_ge_of_gt (le_max_right _ _) $ sub_pos_of_lt $
  lt_of_le_of_lt p.2.property.right one_lt_two⟩

lemma α_ge_one {p} : (α p).val ≥ 1 :=
le_trans
  (le_sub_iff_add_le.mpr $ le_sub_iff_add_le'.mp $
    by norm_num; exact p.2.property.right)
  (le_max_right _ _)

lemma α_le_two {p} : (α p).val ≤ 2 :=
max_le
  (by convert mul_le_mul_of_nonneg_left p.1.property _; norm_num)
  ((sub_le_self_iff _).mpr p.2.property.left)

def H : D × I → D × I :=
λ p, begin
  refine (⟨((α p).val⁻¹ * (1 + p.2.val)) • p.1.val, _⟩, ⟨2 - (α p).val, _⟩),
  { rw [norm_mul, abs_of_nonneg, mul_assoc, ←div_eq_inv_mul, div_le_one, α],
    exact calc
      (1 + p.2.val) * norm p.1.val
        ≤ (1 + 1) * norm p.1.val    : mul_le_mul_of_nonneg_right (add_le_add_left p.2.property.right _) (norm_nonneg _)
    ... = 2 * norm p.1.val          : by norm_num
    ... ≤ α p                       : le_max_left _ _,
    exact lt_of_lt_of_le zero_lt_one α_ge_one,
    apply mul_nonneg,
    apply inv_nonneg.mpr,
    exact le_trans zero_le_one α_ge_one,
    exact le_trans zero_le_one (le_add_of_nonneg_right p.2.property.left) },
  { split,
    exact sub_nonneg_of_le α_le_two,
    apply sub_le_of_sub_le,
    convert α_ge_one,
    norm_num }
end

def v : D × I → D × I :=
λ p, (p.1, ⟨1 - p.2.val, sub_nonneg_of_le p.2.property.right, sub_le_self _ p.2.property.left⟩)

lemma αvH (p : D × I) : (α (v (H p))).val = 1 + p.2.val :=
let ⟨x, t⟩ := p in
begin
  dsimp only [H, v, α, -smul_eq_mul],
  rw norm_mul,
  cases le_total (2 * norm x.val) (2 - t.val) with h1 h2,
  { rw max_eq_right h1,
    convert max_eq_right _ using 1,
    { ring },
    { exact calc
        2 * (abs ((2 + -t.val)⁻¹ * (1 + t.val)) * norm (x.val))
          = (2 * norm x.val) * abs ((2 + -t.val)⁻¹ * (1 + t.val))  : by ac_refl
      ... ≤ (2 + -t.val) * abs ((2 + -t.val)⁻¹ * (1 + t.val))      : mul_le_mul_of_nonneg_right h1 (abs_nonneg _)
      ... = 1 + t.val                                              : begin
              have : 2 - t.val > 0, from sub_pos_of_lt (lt_of_le_of_lt t.property.right (by norm_num)),
              rw [abs_mul, abs_of_nonneg, abs_of_nonneg, ←mul_assoc, mul_inv_cancel, one_mul],
              swap, exact le_trans zero_le_one (le_add_of_nonneg_right t.property.left),
              all_goals { rw ←sub_eq_add_neg },
              exact ne_of_gt this,
              exact inv_nonneg.mpr (le_of_lt this)
            end
      ... = _                                                      : by ring } },
  { rw max_eq_left h2,
    have : 2 * (abs ((2 * norm (x.val))⁻¹ * (1 + t.val)) * norm (x.val)) = 1 + t.val,
    { symmetry,
      rw [abs_mul, abs_of_nonneg, abs_of_nonneg],
      exact calc
        1 + t.val
          = (2 * norm x.val) * (2 * norm x.val)⁻¹ * (1 + t.val) : begin
              rw [mul_inv_cancel, one_mul],
              refine ne_of_gt (lt_of_lt_of_le _ h2),
              rw [sub_pos],
              exact lt_of_le_of_lt t.property.right (by norm_num)
            end
      ... = _ : by ring,
      exact le_trans zero_le_one (le_add_of_nonneg_right t.property.left),
      exact inv_nonneg.mpr (mul_nonneg (by norm_num) (norm_nonneg _))
    },
    rw this,
    apply max_eq_left,
    rw [iff.intro sub_le_of_sub_le sub_le_of_sub_le] at h2,
    apply le_add_of_sub_left_le,
    convert h2 using 1, ring }
end

lemma vHvH (p : D × I) : v (H (v (H p))) = p :=
begin
  rw [H] { occs := occurrences.pos [1] },
  rw [v] { occs := occurrences.pos [1] },
  apply prod.ext; apply subtype.eq; dsimp only []; rw αvH p,
  { rw [H, v], dsimp only [],
    transitivity ((1 + (p.snd).val)⁻¹ * (1 + (p.snd).val)) • ((α p).val * ((α p).val)⁻¹) • (p.fst).val,
    { rw [←admissible.mul_smul', ←admissible.mul_smul'], congr' 1, ring },
    { rw [mul_inv_cancel, inv_mul_cancel, admissible.one_smul', admissible.one_smul'],
      exact ne_of_gt (lt_of_lt_of_le (by norm_num) (le_add_of_nonneg_right p.2.property.left)),
      exact (α p).property } },
  { ring }
end

lemma vv (p : D × I) : v (v p) = p :=
begin
  dsimp [v], apply prod.ext, { refl }, { apply subtype.eq, dsimp, ring }
end

lemma HvHv (p : D × I) : H (v (H (v p))) = p :=
have v (v (H (v (H (v p))))) = v (v p), by rw vHvH,
by rwa [vv, vv] at this

lemma eq_iff_le_of_ge {a b : R} (h : a ≥ b) : a = b ↔ a ≤ b :=
iff.intro le_of_eq (assume h', le_antisymm h' h)

lemma eq_iff_ge_of_le {a b : R} (h : a ≤ b) : a = b ↔ a ≥ b :=
iff.intro ge_of_eq (assume h', le_antisymm h h')

lemma Ht0 (p : D × I) : (H p).2.val = 0 ↔ norm p.1.val = 1 ∨ p.2.val = 0 :=
begin
  rw [H, sub_eq_zero, eq_iff_le_of_ge α_le_two, α, eq_iff_ge_of_le p.1.property, eq_iff_le_of_ge p.2.property.left, le_max_iff],
  apply or_congr,
  { exact le_mul_iff_one_le_right (by norm_num) },
  { rw le_sub_iff_add_le, convert add_le_add_iff_left (2 : R) using 2, simp }
end

end
end construction

section continuity

noncomputable theory

class admissible' (V : Type) [topological_space V] extends admissible ℝ V :=
(continuous_smul : continuous (λ p : ℝ × V, p.1 • p.2))
(continuous_norm : continuous (admissible.norm : V → ℝ))

parameters (V : Type) [topological_space V] [admissible' V]
@[reducible] def I := @construction.I ℝ _
@[reducible] def unit_disk := @construction.unit_disk ℝ _ V _
local notation `D` := unit_disk

parameters {V}
def α : D × I → {r : ℝ // r ≠ 0} := @construction.α ℝ _ V _
def H : D × I → D × I := @construction.H ℝ _ V _
def v : D × I → D × I := @construction.v ℝ _ V _

@[continuity] lemma continuous_smul {β : Type*} [topological_space β]
  {f : β → ℝ} {g : β → V} (hf : continuous f) (hg : continuous g) :
  continuous (λx, f x • g x) :=
(admissible'.continuous_smul).comp (hf.prod_mk hg)

@[tidy] meta def apply_continuous_smul := `[refine continuous_smul _ _]

@[continuity] lemma continuous_norm : continuous (admissible.norm : V → ℝ) :=
admissible'.continuous_norm

lemma continuous_α : continuous α := by continuity!

section
local attribute [elab_simple] continuous.comp
@[continuity] lemma continuous_α_inv : continuous (λ p, (α p).val⁻¹) :=
continuous.comp real.continuous_inv continuous_α
end

lemma continuous_H : continuous H := by continuity!

lemma continuous_v : continuous v := by continuity!

lemma continuous_vHv : continuous (v ∘ H ∘ v) :=
continuous_v.comp (continuous_H.comp continuous_v)

def H_equiv : (D × I) ≃ (D × I) :=
{ to_fun := H,
  inv_fun := v ∘ H ∘ v,
  left_inv := construction.vHvH,
  right_inv := construction.HvHv }

def unit_sphere_in_disk : set unit_disk := {v | admissible.norm v.val = (1 : ℝ)}

lemma Ht0 : {p : D × I | p.1 ∈ unit_sphere_in_disk ∨ p.2.val = 0} = H ⁻¹' {p | false ∨ p.2.val = 0} :=
set.ext $ λ p, by convert (construction.Ht0 p).symm; simp; refl

end continuity

instance : admissible' ℝ :=
{ mul_smul' := _root_.mul_smul,
  one_smul' := _root_.one_smul _,
  norm := abs,
  norm_nonneg := abs_nonneg,
  norm_mul := abs_mul,

  continuous_smul := continuous_mul,
  continuous_norm := real.continuous_abs }

end homotopy_theory.topological_spaces.smush


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

! This file was ported from Lean 3 source module algebra.lie.abelian
! leanprover-community/mathlib commit 8983bec7cdf6cb2dd1f21315c8a34ab00d7b2f6d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Lie.OfAssociative
import Mathbin.Algebra.Lie.IdealOperations

/-!
# Trivial Lie modules and Abelian Lie algebras

The action of a Lie algebra `L` on a module `M` is trivial if `⁅x, m⁆ = 0` for all `x ∈ L` and
`m ∈ M`. In the special case that `M = L` with the adjoint action, triviality corresponds to the
concept of an Abelian Lie algebra.

In this file we define these concepts and provide some related definitions and results.

## Main definitions

  * `lie_module.is_trivial`
  * `is_lie_abelian`
  * `commutative_ring_iff_abelian_lie_ring`
  * `lie_module.ker`
  * `lie_module.max_triv_submodule`
  * `lie_algebra.center`

## Tags

lie algebra, abelian, commutative, center
-/

universe u v w w₁ w₂

/-- A Lie (ring) module is trivial iff all brackets vanish. -/
class LieModule.IsTrivial (L : Type v) (M : Type w) [Bracket L M] [Zero M] : Prop where
  trivial : ∀ (x : L) (m : M), ⁅x, m⁆ = 0
#align lie_module.is_trivial LieModule.IsTrivial

@[simp]
theorem trivial_lie_zero (L : Type v) (M : Type w) [Bracket L M] [Zero M] [LieModule.IsTrivial L M]
    (x : L) (m : M) : ⁅x, m⁆ = 0 :=
  LieModule.IsTrivial.trivial x m
#align trivial_lie_zero trivial_lie_zero

/-- A Lie algebra is Abelian iff it is trivial as a Lie module over itself. -/
abbrev IsLieAbelian (L : Type v) [Bracket L L] [Zero L] : Prop :=
  LieModule.IsTrivial L L
#align is_lie_abelian IsLieAbelian

instance LieIdeal.isLieAbelian_of_trivial (R : Type u) (L : Type v) [CommRing R] [LieRing L]
    [LieAlgebra R L] (I : LieIdeal R L) [h : LieModule.IsTrivial L I] : IsLieAbelian I
    where trivial x y := by apply h.trivial
#align lie_ideal.is_lie_abelian_of_trivial LieIdeal.isLieAbelian_of_trivial

theorem Function.Injective.isLieAbelian {R : Type u} {L₁ : Type v} {L₂ : Type w} [CommRing R]
    [LieRing L₁] [LieRing L₂] [LieAlgebra R L₁] [LieAlgebra R L₂] {f : L₁ →ₗ⁅R⁆ L₂}
    (h₁ : Function.Injective f) (h₂ : IsLieAbelian L₂) : IsLieAbelian L₁ :=
  {
    trivial := fun x y =>
      h₁ <|
        calc
          f ⁅x, y⁆ = ⁅f x, f y⁆ := LieHom.map_lie f x y
          _ = 0 := (trivial_lie_zero _ _ _ _)
          _ = f 0 := f.map_zero.symm
           }
#align function.injective.is_lie_abelian Function.Injective.isLieAbelian

theorem Function.Surjective.isLieAbelian {R : Type u} {L₁ : Type v} {L₂ : Type w} [CommRing R]
    [LieRing L₁] [LieRing L₂] [LieAlgebra R L₁] [LieAlgebra R L₂] {f : L₁ →ₗ⁅R⁆ L₂}
    (h₁ : Function.Surjective f) (h₂ : IsLieAbelian L₁) : IsLieAbelian L₂ :=
  {
    trivial := fun x y => by
      obtain ⟨u, rfl⟩ := h₁ x
      obtain ⟨v, rfl⟩ := h₁ y
      rw [← LieHom.map_lie, trivial_lie_zero, LieHom.map_zero] }
#align function.surjective.is_lie_abelian Function.Surjective.isLieAbelian

theorem lie_abelian_iff_equiv_lie_abelian {R : Type u} {L₁ : Type v} {L₂ : Type w} [CommRing R]
    [LieRing L₁] [LieRing L₂] [LieAlgebra R L₁] [LieAlgebra R L₂] (e : L₁ ≃ₗ⁅R⁆ L₂) :
    IsLieAbelian L₁ ↔ IsLieAbelian L₂ :=
  ⟨e.symm.Injective.IsLieAbelian, e.Injective.IsLieAbelian⟩
#align lie_abelian_iff_equiv_lie_abelian lie_abelian_iff_equiv_lie_abelian

theorem commutative_ring_iff_abelian_lie_ring {A : Type v} [Ring A] :
    IsCommutative A (· * ·) ↔ IsLieAbelian A :=
  by
  have h₁ : IsCommutative A (· * ·) ↔ ∀ a b : A, a * b = b * a := ⟨fun h => h.1, fun h => ⟨h⟩⟩
  have h₂ : IsLieAbelian A ↔ ∀ a b : A, ⁅a, b⁆ = 0 := ⟨fun h => h.1, fun h => ⟨h⟩⟩
  simp only [h₁, h₂, LieRing.of_associative_ring_bracket, sub_eq_zero]
#align commutative_ring_iff_abelian_lie_ring commutative_ring_iff_abelian_lie_ring

theorem LieAlgebra.isLieAbelian_bot (R : Type u) (L : Type v) [CommRing R] [LieRing L]
    [LieAlgebra R L] : IsLieAbelian (⊥ : LieIdeal R L) :=
  ⟨fun ⟨x, hx⟩ _ => by convert zero_lie _⟩
#align lie_algebra.is_lie_abelian_bot LieAlgebra.isLieAbelian_bot

section Center

variable (R : Type u) (L : Type v) (M : Type w) (N : Type w₁)

variable [CommRing R] [LieRing L] [LieAlgebra R L]

variable [AddCommGroup M] [Module R M] [LieRingModule L M] [LieModule R L M]

variable [AddCommGroup N] [Module R N] [LieRingModule L N] [LieModule R L N]

namespace LieModule

/-- The kernel of the action of a Lie algebra `L` on a Lie module `M` as a Lie ideal in `L`. -/
protected def ker : LieIdeal R L :=
  (toEndomorphism R L M).ker
#align lie_module.ker LieModule.ker

@[simp]
protected theorem mem_ker (x : L) : x ∈ LieModule.ker R L M ↔ ∀ m : M, ⁅x, m⁆ = 0 := by
  simp only [LieModule.ker, LieHom.mem_ker, LinearMap.ext_iff, LinearMap.zero_apply,
    to_endomorphism_apply_apply]
#align lie_module.mem_ker LieModule.mem_ker

/-- The largest submodule of a Lie module `M` on which the Lie algebra `L` acts trivially. -/
def maxTrivSubmodule : LieSubmodule R L M
    where
  carrier := { m | ∀ x : L, ⁅x, m⁆ = 0 }
  zero_mem' x := lie_zero x
  add_mem' x y hx hy z := by rw [lie_add, hx, hy, add_zero]
  smul_mem' c x hx y := by rw [lie_smul, hx, smul_zero]
  lie_mem x m hm y := by rw [hm, lie_zero]
#align lie_module.max_triv_submodule LieModule.maxTrivSubmodule

@[simp]
theorem mem_maxTrivSubmodule (m : M) : m ∈ maxTrivSubmodule R L M ↔ ∀ x : L, ⁅x, m⁆ = 0 :=
  Iff.rfl
#align lie_module.mem_max_triv_submodule LieModule.mem_maxTrivSubmodule

instance : IsTrivial L (maxTrivSubmodule R L M) where trivial x m := Subtype.ext (m.property x)

@[simp]
theorem ideal_oper_maxTrivSubmodule_eq_bot (I : LieIdeal R L) : ⁅I, maxTrivSubmodule R L M⁆ = ⊥ :=
  by
  rw [← LieSubmodule.coe_to_submodule_eq_iff, LieSubmodule.lieIdeal_oper_eq_linear_span,
    LieSubmodule.bot_coeSubmodule, Submodule.span_eq_bot]
  rintro m ⟨⟨x, hx⟩, ⟨⟨m, hm⟩, rfl⟩⟩
  exact hm x
#align lie_module.ideal_oper_max_triv_submodule_eq_bot LieModule.ideal_oper_maxTrivSubmodule_eq_bot

theorem le_max_triv_iff_bracket_eq_bot {N : LieSubmodule R L M} :
    N ≤ maxTrivSubmodule R L M ↔ ⁅(⊤ : LieIdeal R L), N⁆ = ⊥ :=
  by
  refine' ⟨fun h => _, fun h m hm => _⟩
  · rw [← le_bot_iff, ← ideal_oper_max_triv_submodule_eq_bot R L M ⊤]
    exact LieSubmodule.mono_lie_right _ _ ⊤ h
  · rw [mem_max_triv_submodule]
    rw [LieSubmodule.lie_eq_bot_iff] at h
    exact fun x => h x (LieSubmodule.mem_top x) m hm
#align lie_module.le_max_triv_iff_bracket_eq_bot LieModule.le_max_triv_iff_bracket_eq_bot

theorem trivial_iff_le_maximal_trivial (N : LieSubmodule R L M) :
    IsTrivial L N ↔ N ≤ maxTrivSubmodule R L M :=
  ⟨fun h m hm x => IsTrivial.dcasesOn h fun h => Subtype.ext_iff.mp (h x ⟨m, hm⟩), fun h =>
    { trivial := fun x m => Subtype.ext (h m.2 x) }⟩
#align lie_module.trivial_iff_le_maximal_trivial LieModule.trivial_iff_le_maximal_trivial

theorem isTrivial_iff_max_triv_eq_top : IsTrivial L M ↔ maxTrivSubmodule R L M = ⊤ :=
  by
  constructor
  · rintro ⟨h⟩
    ext
    simp only [mem_max_triv_submodule, h, forall_const, true_iff_iff, eq_self_iff_true]
  · intro h
    constructor
    intro x m
    revert x
    rw [← mem_max_triv_submodule R L M, h]
    exact LieSubmodule.mem_top m
#align lie_module.is_trivial_iff_max_triv_eq_top LieModule.isTrivial_iff_max_triv_eq_top

variable {R L M N}

/-- `max_triv_submodule` is functorial. -/
def maxTrivHom (f : M →ₗ⁅R,L⁆ N) : maxTrivSubmodule R L M →ₗ⁅R,L⁆ maxTrivSubmodule R L N
    where
  toFun m :=
    ⟨f m, fun x =>
      (LieModuleHom.map_lie _ _ _).symm.trans <|
        (congr_arg f (m.property x)).trans (LieModuleHom.map_zero _)⟩
  map_add' m n := by simpa
  map_smul' t m := by simpa
  map_lie' x m := by simp
#align lie_module.max_triv_hom LieModule.maxTrivHom

@[norm_cast, simp]
theorem coe_maxTrivHom_apply (f : M →ₗ⁅R,L⁆ N) (m : maxTrivSubmodule R L M) :
    (maxTrivHom f m : N) = f m :=
  rfl
#align lie_module.coe_max_triv_hom_apply LieModule.coe_maxTrivHom_apply

/-- The maximal trivial submodules of Lie-equivalent Lie modules are Lie-equivalent. -/
def maxTrivEquiv (e : M ≃ₗ⁅R,L⁆ N) : maxTrivSubmodule R L M ≃ₗ⁅R,L⁆ maxTrivSubmodule R L N :=
  {
    maxTrivHom (e : M →ₗ⁅R,L⁆
          N) with
    toFun := maxTrivHom (e : M →ₗ⁅R,L⁆ N)
    invFun := maxTrivHom (e.symm : N →ₗ⁅R,L⁆ M)
    left_inv := fun m => by
      ext
      simp
    right_inv := fun n => by
      ext
      simp }
#align lie_module.max_triv_equiv LieModule.maxTrivEquiv

@[norm_cast, simp]
theorem coe_maxTrivEquiv_apply (e : M ≃ₗ⁅R,L⁆ N) (m : maxTrivSubmodule R L M) :
    (maxTrivEquiv e m : N) = e ↑m :=
  rfl
#align lie_module.coe_max_triv_equiv_apply LieModule.coe_maxTrivEquiv_apply

@[simp]
theorem maxTrivEquiv_of_refl_eq_refl :
    maxTrivEquiv (LieModuleEquiv.refl : M ≃ₗ⁅R,L⁆ M) = LieModuleEquiv.refl :=
  by
  ext
  simp only [coe_max_triv_equiv_apply, LieModuleEquiv.refl_apply]
#align lie_module.max_triv_equiv_of_refl_eq_refl LieModule.maxTrivEquiv_of_refl_eq_refl

@[simp]
theorem maxTrivEquiv_of_equiv_symm_eq_symm (e : M ≃ₗ⁅R,L⁆ N) :
    (maxTrivEquiv e).symm = maxTrivEquiv e.symm :=
  rfl
#align lie_module.max_triv_equiv_of_equiv_symm_eq_symm LieModule.maxTrivEquiv_of_equiv_symm_eq_symm

/-- A linear map between two Lie modules is a morphism of Lie modules iff the Lie algebra action
on it is trivial. -/
def maxTrivLinearMapEquivLieModuleHom : maxTrivSubmodule R L (M →ₗ[R] N) ≃ₗ[R] M →ₗ⁅R,L⁆ N
    where
  toFun f :=
    { toLinearMap := f.val
      map_lie' := fun x m =>
        by
        have hf : ⁅x, f.val⁆ m = 0 := by rw [f.property x, LinearMap.zero_apply]
        rw [LieHom.lie_apply, sub_eq_zero, ← LinearMap.toFun_eq_coe] at hf
        exact hf.symm }
  map_add' f g := by
    ext
    simp
  map_smul' F G := by
    ext
    simp
  invFun F :=
    ⟨F, fun x => by
      ext
      simp⟩
  left_inv f := by simp
  right_inv F := by simp
#align lie_module.max_triv_linear_map_equiv_lie_module_hom LieModule.maxTrivLinearMapEquivLieModuleHom

@[simp]
theorem coe_maxTrivLinearMapEquivLieModuleHom (f : maxTrivSubmodule R L (M →ₗ[R] N)) :
    (maxTrivLinearMapEquivLieModuleHom f : M → N) = f :=
  by
  ext
  rfl
#align lie_module.coe_max_triv_linear_map_equiv_lie_module_hom LieModule.coe_maxTrivLinearMapEquivLieModuleHom

@[simp]
theorem coe_maxTrivLinearMapEquivLieModuleHom_symm (f : M →ₗ⁅R,L⁆ N) :
    (maxTrivLinearMapEquivLieModuleHom.symm f : M → N) = f :=
  rfl
#align lie_module.coe_max_triv_linear_map_equiv_lie_module_hom_symm LieModule.coe_maxTrivLinearMapEquivLieModuleHom_symm

@[simp]
theorem coe_linearMap_maxTrivLinearMapEquivLieModuleHom (f : maxTrivSubmodule R L (M →ₗ[R] N)) :
    (maxTrivLinearMapEquivLieModuleHom f : M →ₗ[R] N) = (f : M →ₗ[R] N) :=
  by
  ext
  rfl
#align lie_module.coe_linear_map_max_triv_linear_map_equiv_lie_module_hom LieModule.coe_linearMap_maxTrivLinearMapEquivLieModuleHom

@[simp]
theorem coe_linearMap_maxTrivLinearMapEquivLieModuleHom_symm (f : M →ₗ⁅R,L⁆ N) :
    (maxTrivLinearMapEquivLieModuleHom.symm f : M →ₗ[R] N) = (f : M →ₗ[R] N) :=
  rfl
#align lie_module.coe_linear_map_max_triv_linear_map_equiv_lie_module_hom_symm LieModule.coe_linearMap_maxTrivLinearMapEquivLieModuleHom_symm

end LieModule

namespace LieAlgebra

/-- The center of a Lie algebra is the set of elements that commute with everything. It can
be viewed as the maximal trivial submodule of the Lie algebra as a Lie module over itself via the
adjoint representation. -/
abbrev center : LieIdeal R L :=
  LieModule.maxTrivSubmodule R L L
#align lie_algebra.center LieAlgebra.center

instance : IsLieAbelian (center R L) :=
  inferInstance

@[simp]
theorem ad_ker_eq_self_module_ker : (ad R L).ker = LieModule.ker R L L :=
  rfl
#align lie_algebra.ad_ker_eq_self_module_ker LieAlgebra.ad_ker_eq_self_module_ker

@[simp]
theorem self_module_ker_eq_center : LieModule.ker R L L = center R L :=
  by
  ext y
  simp only [LieModule.mem_maxTrivSubmodule, LieModule.mem_ker, ← lie_skew _ y, neg_eq_zero]
#align lie_algebra.self_module_ker_eq_center LieAlgebra.self_module_ker_eq_center

theorem abelian_of_le_center (I : LieIdeal R L) (h : I ≤ center R L) : IsLieAbelian I :=
  haveI : LieModule.IsTrivial L I := (LieModule.trivial_iff_le_maximal_trivial R L L I).mpr h
  LieIdeal.isLieAbelian_of_trivial R L I
#align lie_algebra.abelian_of_le_center LieAlgebra.abelian_of_le_center

theorem isLieAbelian_iff_center_eq_top : IsLieAbelian L ↔ center R L = ⊤ :=
  LieModule.isTrivial_iff_max_triv_eq_top R L L
#align lie_algebra.is_lie_abelian_iff_center_eq_top LieAlgebra.isLieAbelian_iff_center_eq_top

end LieAlgebra

end Center

section IdealOperations

open LieSubmodule LieSubalgebra

variable {R : Type u} {L : Type v} {M : Type w}

variable [CommRing R] [LieRing L] [LieAlgebra R L] [AddCommGroup M] [Module R M]

variable [LieRingModule L M] [LieModule R L M]

variable (N N' : LieSubmodule R L M) (I J : LieIdeal R L)

@[simp]
theorem LieSubmodule.trivial_lie_oper_zero [LieModule.IsTrivial L M] : ⁅I, N⁆ = ⊥ :=
  by
  suffices : ⁅I, N⁆ ≤ ⊥; exact le_bot_iff.mp this
  rw [lie_ideal_oper_eq_span, LieSubmodule.lieSpan_le]
  rintro m ⟨x, n, h⟩; rw [trivial_lie_zero] at h; simp [← h]
#align lie_submodule.trivial_lie_oper_zero LieSubmodule.trivial_lie_oper_zero

theorem LieSubmodule.lie_abelian_iff_lie_self_eq_bot : IsLieAbelian I ↔ ⁅I, I⁆ = ⊥ :=
  by
  simp only [_root_.eq_bot_iff, lie_ideal_oper_eq_span, LieSubmodule.lieSpan_le,
    LieSubmodule.bot_coe, Set.subset_singleton_iff, Set.mem_setOf_eq, exists_imp]
  refine'
    ⟨fun h z x y hz =>
      hz.symm.trans
        (((I : LieSubalgebra R L).coe_bracket x y).symm.trans
          ((coe_zero_iff_zero _ _).mpr (by apply h.trivial))),
      fun h => ⟨fun x y => ((I : LieSubalgebra R L).coe_zero_iff_zero _).mp (h _ x y rfl)⟩⟩
#align lie_submodule.lie_abelian_iff_lie_self_eq_bot LieSubmodule.lie_abelian_iff_lie_self_eq_bot

end IdealOperations


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import algebra.big_operators.finprod
import topology.urysohns_lemma
import topology.paracompact
import topology.shrinking_lemma
import topology.continuous_function.algebra
import set_theory.ordinal

/-!
# Continuous partition of unity

In this file we define `partition_of_unity (ι X : Type*) [topological_space X] (s : set X := univ)`
to be a continuous partition of unity on `s` indexed by `ι`. More precisely, `f : partition_of_unity
ι X s` is a collection of continuous functions `f i : C(X, ℝ)`, `i : ι`, such that

* the supports of `f i` form a locally finite family of sets;
* each `f i` is nonnegative;
* `∑ᶠ i, f i x = 1` for all `x ∈ s`;
* `∑ᶠ i, f i x ≤ 1` for all `x : X`.

In the case `s = univ` the last assumption follows from the previous one but it is convenient to
have this assumption in the case `s ≠ univ`.

We also define a bump function covering,
`bump_covering (ι X : Type*) [topological_space X] (s : set X := univ)`, to be a collection of
functions `f i : C(X, ℝ)`, `i : ι`, such that

* the supports of `f i` form a locally finite family of sets;
* each `f i` is nonnegative;
* for each `x ∈ s` there exists `i : ι` such that `f i y = 1` in a neighborhood of `x`.

The term is motivated by the smooth case.

If `f` is a bump function covering indexed by a linearly ordered type, then
`g i x = f i x * ∏ᶠ j < i, (1 - f j x)` is a partition of unity, see
`bump_covering.to_partition_of_unity`. Note that only finitely many terms `1 - f j x` are not equal
to one, so this product is well-defined.

Note that `g i x = ∏ᶠ j ≤ i, (1 - f j x) - ∏ᶠ j < i, (1 - f j x)`, so most terms in the sum
`∑ᶠ i, g i x` cancel, and we get `∑ᶠ i, g i x = 1 - ∏ᶠ i, (1 - f i x)`, and the latter product
equals zero because one of `f i x` is equal to one.

We say that a partition of unity or a bump function covering `f` is *subordinate* to a family of
sets `U i`, `i : ι`, if the closure of the support of each `f i` is included in `U i`. We use
Urysohn's Lemma to prove that a locally finite open covering of a normal topological space admits a
subordinate bump function covering (hence, a subordinate partition of unity), see
`bump_covering.exists_is_subordinate_of_locally_finite`. If `X` is a paracompact space, then any
open covering admits a locally finite refinement, hence it admits a subordinate bump function
covering and a subordinate partition of unity, see `bump_covering.exists_is_subordinate`.

We also provide two slightly more general versions of these lemmas,
`bump_covering.exists_is_subordinate_of_locally_finite_of_prop` and
`bump_covering.exists_is_subordinate_of_prop`, to be used later in the construction of a smooth
partition of unity.

## Implementation notes

Most (if not all) books only define a partition of unity of the whole space. However, quite a few
proofs only deal with `f i` such that `closure (support (f i))` meets a specific closed subset, and
it is easier to formalize these proofs if we don't have other functions right away.

We use `well_ordering_rel j i` instead of `j < i` in the definition of
`bump_covering.to_partition_of_unity` to avoid a `[linear_order ι]` assumption. While
`well_ordering_rel j i` is a well order, not only a strict linear order, we never use this property.

## Tags

partition of unity, bump function, Urysohn's lemma, normal space, paracompact space
-/

universes u v

open function set filter
open_locale big_operators topological_space classical

noncomputable theory

/-- A continuous partition of unity on a set `s : set X` is a collection of continuous functions
`f i` such that

* the supports of `f i` form a locally finite family of sets, i.e., for every point `x : X` there
  exists a neighborhood `U ∋ x` such that all but finitely many functions `f i` are zero on `U`;
* the functions `f i` are nonnegative;
* the sum `∑ᶠ i, f i x` is equal to one for every `x ∈ s` and is less than or equal to one
  otherwise.

If `X` is a normal paracompact space, then `partition_of_unity.exists_is_subordinate` guarantees
that for every open covering `U : set (set X)` of `s` there exists a partition of unity that is
subordinate to `U`.
-/
structure partition_of_unity (ι X : Type*) [topological_space X] (s : set X := univ) :=
(to_fun : ι → C(X, ℝ))
(locally_finite' : locally_finite (λ i, support (to_fun i)))
(nonneg' : 0 ≤ to_fun)
(sum_eq_one' : ∀ x ∈ s, ∑ᶠ i, to_fun i x = 1)
(sum_le_one' : ∀ x, ∑ᶠ i, to_fun i x ≤ 1)

/-- A `bump_covering ι X s` is an indexed family of functions `f i`, `i : ι`, such that

* the supports of `f i` form a locally finite family of sets, i.e., for every point `x : X` there
  exists a neighborhood `U ∋ x` such that all but finitely many functions `f i` are zero on `U`;
* for all `i`, `x` we have `0 ≤ f i x ≤ 1`;
* each point `x ∈ s` belongs to the interior of `{x | f i x = 1}` for some `i`.

One of the main use cases for a `bump_covering` is to define a `partition_of_unity`, see
`bump_covering.to_partition_of_unity`, but some proofs can directly use a `bump_covering` instead of
a `partition_of_unity`.

If `X` is a normal paracompact space, then `bump_covering.exists_is_subordinate` guarantees that for
every open covering `U : set (set X)` of `s` there exists a `bump_covering` of `s` that is
subordinate to `U`.
-/
structure bump_covering (ι X : Type*) [topological_space X] (s : set X := univ) :=
(to_fun : ι → C(X, ℝ))
(locally_finite' : locally_finite (λ i, support (to_fun i)))
(nonneg' : 0 ≤ to_fun)
(le_one' : to_fun ≤ 1)
(eventually_eq_one' : ∀ x ∈ s, ∃ i, to_fun i =ᶠ[𝓝 x] 1)

variables {ι : Type u} {X : Type v} [topological_space X]

namespace partition_of_unity

variables {s : set X} (f : partition_of_unity ι X s)

instance : has_coe_to_fun (partition_of_unity ι X s) (λ _, ι → C(X, ℝ)) := ⟨to_fun⟩

protected lemma locally_finite : locally_finite (λ i, support (f i)) :=
f.locally_finite'

lemma nonneg (i : ι) (x : X) : 0 ≤ f i x := f.nonneg' i x

lemma sum_eq_one {x : X} (hx : x ∈ s) : ∑ᶠ i, f i x = 1 := f.sum_eq_one' x hx

lemma sum_le_one (x : X) : ∑ᶠ i, f i x ≤ 1 := f.sum_le_one' x

lemma sum_nonneg (x : X) : 0 ≤ ∑ᶠ i, f i x := finsum_nonneg $ λ i, f.nonneg i x

lemma le_one (i : ι) (x : X) : f i x ≤ 1 :=
(single_le_finsum i (f.locally_finite.point_finite x) (λ j, f.nonneg j x)).trans (f.sum_le_one x)

/-- A 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 : partition_of_unity ι X s) (U : ι → set X) : Prop :=
∀ i, closure (support (f i)) ⊆ U i

end partition_of_unity

namespace bump_covering

variables {s : set X} (f : bump_covering ι X s)

instance : has_coe_to_fun (bump_covering ι X s) (λ _, ι → C(X, ℝ)) := ⟨to_fun⟩

protected lemma locally_finite : locally_finite (λ i, support (f i)) :=
f.locally_finite'

protected lemma point_finite (x : X) : finite {i | f i x ≠ 0} :=
f.locally_finite.point_finite x

lemma nonneg (i : ι) (x : X) : 0 ≤ f i x := f.nonneg' i x

lemma le_one (i : ι) (x : X) : f i x ≤ 1 := f.le_one' i x

/-- A `bump_covering` that consists of a single function, uniformly equal to one, defined as an
example for `inhabited` instance. -/
protected def single (i : ι) (s : set X) : bump_covering ι X s :=
{ to_fun := pi.single i 1,
  locally_finite' := λ x,
    begin
      refine ⟨univ, univ_mem, (finite_singleton i).subset _⟩,
      rintro j ⟨x, hx, -⟩,
      contrapose! hx,
      rw [mem_singleton_iff] at hx,
      simp [hx]
    end,
  nonneg' := le_update_iff.2 ⟨λ x, zero_le_one, λ _ _, le_rfl⟩,
  le_one' := update_le_iff.2 ⟨le_rfl, λ _ _ _, zero_le_one⟩,
  eventually_eq_one' := λ x _, ⟨i, by simp⟩ }

@[simp] lemma coe_single (i : ι) (s : set X) : ⇑(bump_covering.single i s) = pi.single i 1 := rfl

instance [inhabited ι] : inhabited (bump_covering ι X s) :=
⟨bump_covering.single (default ι) s⟩

/-- A collection of bump functions `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 : bump_covering ι X s) (U : ι → set X) : Prop :=
∀ i, closure (support (f i)) ⊆ U i

/-- If `X` is a normal topological space and `U i`, `i : ι`, is a locally finite open covering of a
closed set `s`, then there exists a `bump_covering ι X s` that is subordinate to `U`. If `X` is a
paracompact space, then the assumption `hf : locally_finite U` can be omitted, see
`bump_covering.exists_is_subordinate`. This version assumes that `p : (X → ℝ) → Prop` is a predicate
that satisfies Urysohn's lemma, and provides a `bump_covering` such that each function of the
covering satisfies `p`. -/
lemma exists_is_subordinate_of_locally_finite_of_prop [normal_space X] (p : (X → ℝ) → Prop)
  (h01 : ∀ s t, is_closed s → is_closed t → disjoint s t →
    ∃ f : C(X, ℝ), p f ∧ eq_on f 0 s ∧ eq_on f 1 t ∧ ∀ x, f x ∈ Icc (0 : ℝ) 1)
  (hs : is_closed s) (U : ι → set X) (ho : ∀ i, is_open (U i)) (hf : locally_finite U)
  (hU : s ⊆ ⋃ i, U i) :
  ∃ f : bump_covering ι X s, (∀ i, p (f i)) ∧ f.is_subordinate U :=
begin
  rcases exists_subset_Union_closure_subset hs ho (λ x _, hf.point_finite x) hU
    with ⟨V, hsV, hVo, hVU⟩,
  have hVU' : ∀ i, V i ⊆ U i, from λ i, subset.trans subset_closure (hVU i),
  rcases exists_subset_Union_closure_subset hs hVo
    (λ x _, (hf.subset hVU').point_finite x) hsV with ⟨W, hsW, hWo, hWV⟩,
  choose f hfp hf0 hf1 hf01
    using λ i, h01 _ _ (is_closed_compl_iff.2 $ hVo i)
      is_closed_closure (disjoint_right.2 $ λ x hx, not_not.2 (hWV i hx)),
  have hsupp : ∀ i, support (f i) ⊆ V i,
    from λ i, support_subset_iff'.2 (hf0 i),
  refine ⟨⟨f, hf.subset (λ i, subset.trans (hsupp i) (hVU' i)),
    λ i x, (hf01 i x).1, λ i x, (hf01 i x).2, λ x hx, _⟩, hfp,
    λ i, subset.trans (closure_mono (hsupp i)) (hVU i)⟩,
  rcases mem_Union.1 (hsW hx) with ⟨i, hi⟩,
  exact ⟨i, ((hf1 i).mono subset_closure).eventually_eq_of_mem ((hWo i).mem_nhds hi)⟩
end

/-- If `X` is a normal topological space and `U i`, `i : ι`, is a locally finite open covering of a
closed set `s`, then there exists a `bump_covering ι X s` that is subordinate to `U`. If `X` is a
paracompact space, then the assumption `hf : locally_finite U` can be omitted, see
`bump_covering.exists_is_subordinate`. -/
lemma exists_is_subordinate_of_locally_finite [normal_space X] (hs : is_closed s)
  (U : ι → set X) (ho : ∀ i, is_open (U i)) (hf : locally_finite U)
  (hU : s ⊆ ⋃ i, U i) :
  ∃ f : bump_covering ι X s, f.is_subordinate U :=
let ⟨f, _, hfU⟩ :=
  exists_is_subordinate_of_locally_finite_of_prop (λ _, true)
    (λ s t hs ht hd, (exists_continuous_zero_one_of_closed hs ht hd).imp $ λ f hf, ⟨trivial, hf⟩)
    hs U ho hf hU
in ⟨f, hfU⟩

/-- 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`. This version assumes that
`p : (X → ℝ) → Prop` is a predicate that satisfies Urysohn's lemma, and provides a
`bump_covering` such that each function of the covering satisfies `p`. -/
lemma exists_is_subordinate_of_prop [normal_space X] [paracompact_space X] (p : (X → ℝ) → Prop)
  (h01 : ∀ s t, is_closed s → is_closed t → disjoint s t →
    ∃ f : C(X, ℝ), p f ∧ eq_on f 0 s ∧ eq_on f 1 t ∧ ∀ x, f x ∈ Icc (0 : ℝ) 1)
  (hs : is_closed s) (U : ι → set X) (ho : ∀ i, is_open (U i)) (hU : s ⊆ ⋃ i, U i) :
  ∃ f : bump_covering ι X s, (∀ i, p (f i)) ∧ f.is_subordinate U :=
begin
  rcases precise_refinement_set hs _ ho hU with ⟨V, hVo, hsV, hVf, hVU⟩,
  rcases exists_is_subordinate_of_locally_finite_of_prop p h01 hs V hVo hVf hsV with ⟨f, hfp, hf⟩,
  exact ⟨f, hfp, hf.mono hVU⟩
end

/-- 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 [normal_space X] [paracompact_space X]
  (hs : is_closed s) (U : ι → set X) (ho : ∀ i, is_open (U i)) (hU : s ⊆ ⋃ i, U i) :
  ∃ f : bump_covering ι X s, f.is_subordinate U :=
begin
  rcases precise_refinement_set hs _ ho hU with ⟨V, hVo, hsV, hVf, hVU⟩,
  rcases exists_is_subordinate_of_locally_finite hs V hVo hVf hsV with ⟨f, hf⟩,
  exact ⟨f, hf.mono hVU⟩
end

/-- Index of a bump function such that `fs i =ᶠ[𝓝 x] 1`. -/
def ind (x : X) (hx : x ∈ s) : ι := (f.eventually_eq_one' x hx).some

lemma eventually_eq_one (x : X) (hx : x ∈ s) : f (f.ind x hx) =ᶠ[𝓝 x] 1 :=
(f.eventually_eq_one' x hx).some_spec

lemma ind_apply (x : X) (hx : x ∈ s) : f (f.ind x hx) x = 1 :=
(f.eventually_eq_one x hx).eq_of_nhds

/-- Partition of unity defined by a `bump_covering`. We use this auxiliary definition to prove some
properties of the new family of functions before bundling it into a `partition_of_unity`. Do not use
this definition, use `bump_function.to_partition_of_unity` instead.

The partition of unity is given by the formula `g i x = f i x * ∏ᶠ j < i, (1 - f j x)`. In other
words, `g i x = ∏ᶠ j < i, (1 - f j x) - ∏ᶠ j ≤ i, (1 - f j x)`, so
`∑ᶠ i, g i x = 1 - ∏ᶠ j, (1 - f j x)`. If `x ∈ s`, then one of `f j x` equals one, hence the product
of `1 - f j x` vanishes, and `∑ᶠ i, g i x = 1`.

In order to avoid an assumption `linear_order ι`, we use `well_ordering_rel` instead of `(<)`. -/
def to_pou_fun (i : ι) (x : X) : ℝ :=
f i x * ∏ᶠ j (hj : well_ordering_rel j i), (1 - f j x)

lemma to_pou_fun_zero_of_zero {i : ι} {x : X} (h : f i x = 0) :
  f.to_pou_fun i x = 0 :=
by rw [to_pou_fun, h, zero_mul]

lemma support_to_pou_fun_subset (i : ι) :
  support (f.to_pou_fun i) ⊆ support (f i) :=
 λ x, mt $ f.to_pou_fun_zero_of_zero

lemma to_pou_fun_eq_mul_prod (i : ι) (x : X) (t : finset ι)
  (ht : ∀ j, well_ordering_rel j i → f j x ≠ 0 → j ∈ t) :
  f.to_pou_fun i x = f i x * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - f j x) :=
begin
  refine congr_arg _ (finprod_cond_eq_prod_of_cond_iff _ (λ j hj, _)),
  rw [ne.def, sub_eq_self] at hj,
  rw [finset.mem_filter, iff.comm, and_iff_right_iff_imp],
  exact flip (ht j) hj
end

lemma sum_to_pou_fun_eq (x : X) :
  ∑ᶠ i, f.to_pou_fun i x = 1 - ∏ᶠ i, (1 - f i x) :=
begin
  set s := (f.point_finite x).to_finset,
  have hs : (s : set ι) = {i | f i x ≠ 0} := finite.coe_to_finset _,
  have A : support (λ i, to_pou_fun f i x) ⊆ s,
  { rw hs,
    exact λ i hi, f.support_to_pou_fun_subset i hi },
  have B : mul_support (λ i, 1 - f i x) ⊆ s,
  { rw [hs, mul_support_one_sub], exact λ i, id },
  letI : linear_order ι := linear_order_of_STO' well_ordering_rel,
  rw [finsum_eq_sum_of_support_subset _ A, finprod_eq_prod_of_mul_support_subset _ B,
    finset.prod_one_sub_ordered, sub_sub_cancel],
  refine finset.sum_congr rfl (λ i hi, _),
  convert f.to_pou_fun_eq_mul_prod _ _ _ (λ j hji hj, _),
  rwa finite.mem_to_finset
end

lemma exists_finset_to_pou_fun_eventually_eq (i : ι) (x : X) :
  ∃ t : finset ι, f.to_pou_fun i =ᶠ[𝓝 x]
    f i * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - f j) :=
begin
  rcases f.locally_finite x with ⟨U, hU, hf⟩,
  use hf.to_finset,
  filter_upwards [hU],
  intros y hyU,
  simp only [pi.mul_apply, finset.prod_apply],
  apply to_pou_fun_eq_mul_prod,
  intros j hji hj,
  exact hf.mem_to_finset.2 ⟨y, ⟨hj, hyU⟩⟩
end

lemma continuous_to_pou_fun (i : ι) : continuous (f.to_pou_fun i) :=
begin
  refine ((f i).continuous.mul $
    continuous_finprod_cond (λ j _, continuous_const.sub (f j).continuous) _),
  simp only [mul_support_one_sub],
  exact f.locally_finite
end

/-- The partition of unity defined by a `bump_covering`.

The partition of unity is given by the formula `g i x = f i x * ∏ᶠ j < i, (1 - f j x)`. In other
words, `g i x = ∏ᶠ j < i, (1 - f j x) - ∏ᶠ j ≤ i, (1 - f j x)`, so
`∑ᶠ i, g i x = 1 - ∏ᶠ j, (1 - f j x)`. If `x ∈ s`, then one of `f j x` equals one, hence the product
of `1 - f j x` vanishes, and `∑ᶠ i, g i x = 1`.

In order to avoid an assumption `linear_order ι`, we use `well_ordering_rel` instead of `(<)`. -/
def to_partition_of_unity : partition_of_unity ι X s :=
{ to_fun := λ i, ⟨f.to_pou_fun i, f.continuous_to_pou_fun i⟩,
  locally_finite' := f.locally_finite.subset f.support_to_pou_fun_subset,
  nonneg' := λ i x, mul_nonneg (f.nonneg i x)
    (finprod_cond_nonneg $ λ j hj, sub_nonneg.2 $ f.le_one j x),
  sum_eq_one' := λ x hx,
    begin
      simp only [continuous_map.coe_mk, sum_to_pou_fun_eq, sub_eq_self],
      apply finprod_eq_zero (λ i, 1 - f i x) (f.ind x hx),
      { simp only [f.ind_apply x hx, sub_self] },
      { rw mul_support_one_sub, exact f.point_finite x }
    end,
  sum_le_one' := λ x,
    begin
      simp only [continuous_map.coe_mk, sum_to_pou_fun_eq, sub_le_self_iff],
      exact finprod_nonneg (λ i, sub_nonneg.2 $ f.le_one i x)
    end }

lemma to_partition_of_unity_apply (i : ι) (x : X) :
  f.to_partition_of_unity i x = f i x * ∏ᶠ j (hj : well_ordering_rel j i), (1 - f j x) :=
rfl

lemma to_partition_of_unity_eq_mul_prod (i : ι) (x : X) (t : finset ι)
  (ht : ∀ j, well_ordering_rel j i → f j x ≠ 0 → j ∈ t) :
  f.to_partition_of_unity i x = f i x * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - f j x) :=
f.to_pou_fun_eq_mul_prod i x t ht

lemma exists_finset_to_partition_of_unity_eventually_eq (i : ι) (x : X) :
  ∃ t : finset ι, f.to_partition_of_unity i =ᶠ[𝓝 x]
    f i * ∏ j in t.filter (λ j, well_ordering_rel j i), (1 - f j) :=
f.exists_finset_to_pou_fun_eventually_eq i x

lemma to_partition_of_unity_zero_of_zero {i : ι} {x : X} (h : f i x = 0) :
  f.to_partition_of_unity i x = 0 :=
f.to_pou_fun_zero_of_zero h

lemma support_to_partition_of_unity_subset (i : ι) :
  support (f.to_partition_of_unity i) ⊆ support (f i) :=
f.support_to_pou_fun_subset i

lemma sum_to_partition_of_unity_eq (x : X) :
  ∑ᶠ i, f.to_partition_of_unity i x = 1 - ∏ᶠ i, (1 - f i x) :=
f.sum_to_pou_fun_eq x

lemma is_subordinate.to_partition_of_unity {f : bump_covering ι X s} {U : ι → set X}
  (h : f.is_subordinate U) :
  f.to_partition_of_unity.is_subordinate U :=
λ i, subset.trans (closure_mono $ f.support_to_partition_of_unity_subset i) (h i)

end bump_covering

namespace partition_of_unity

variables {s : set X}

instance [inhabited ι] : inhabited (partition_of_unity ι X s) :=
⟨(default (bump_covering ι X s)).to_partition_of_unity⟩

/-- If `X` is a normal topological space and `U` is a locally finite open covering of a closed set
`s`, then there exists a `partition_of_unity ι X s` that is subordinate to `U`. If `X` is a
paracompact space, then the assumption `hf : locally_finite U` can be omitted, see
`bump_covering.exists_is_subordinate`. -/
lemma exists_is_subordinate_of_locally_finite [normal_space X] (hs : is_closed s)
  (U : ι → set X) (ho : ∀ i, is_open (U i)) (hf : locally_finite U)
  (hU : s ⊆ ⋃ i, U i) :
  ∃ f : partition_of_unity ι X s, f.is_subordinate U :=
let ⟨f, hf⟩ := bump_covering.exists_is_subordinate_of_locally_finite hs U ho hf hU
in ⟨f.to_partition_of_unity, hf.to_partition_of_unity⟩

/-- If `X` is a paracompact normal topological space and `U` is an open covering of a closed set
`s`, then there exists a `partition_of_unity ι X s` that is subordinate to `U`. -/
lemma exists_is_subordinate [normal_space X] [paracompact_space X] (hs : is_closed s)
  (U : ι → set X) (ho : ∀ i, is_open (U i)) (hU : s ⊆ ⋃ i, U i) :
  ∃ f : partition_of_unity ι X s, f.is_subordinate U :=
let ⟨f, hf⟩ := bump_covering.exists_is_subordinate hs U ho hU
in ⟨f.to_partition_of_unity, hf.to_partition_of_unity⟩

end partition_of_unity


-- https://leanprover.github.io/lean4/doc/expressions.html

/- UNIVERSES
by def, every type in lean is an expression of type 'Sort u' for some universe level u

universe level is one of the following:
-- natural number n
-- universe variable u (declared w/ command 'universe' or 'universes')
-- expression u + n, where u is universe level and n is natural number
-- expression max u v, where u, v are universes
-- expression imax u v, where u, v are universe levels

universe u v

#check Sort u
#check Sort 5
#check Sort (u + 1)
#check Sort (u + 3)
#check Sort (max u v)
#check Sort (max (u + 3) v)
#check Sort (imax (u + 3) v)
#check Prop
#check Type
-/

theorem and_commutative (p q : Prop) : p ∧ q → q ∧ p :=
  fun hpq : p ∧ q =>
  have hp : p := And.left hpq
  have hq : q := And.right hpq
  show q ∧ p from And.intro hq hp


import tactic.show_term
import tactic.tauto

open tactic

lemma ex1 {P Q R : Prop} (h₁ : Q → P) (h₂ : R) (h₃ : R → Q) : P ∧ R :=
by show_term { tauto }

#print ex1

example (x y : ℕ) (hx : x = 0) (hy : y = 1) : x + y = 1 :=
begin
  show_term { rw hx, }, -- (id ((eq.refl (x + y = 1)).rec hx)).mpr ?m_1
  show_term { rw hy, },
end

example (x y z : ℕ) : x + y + z = x + z + y :=
begin
  show_term { simp [add_comm], },
  sorry,
end


import data.real.basic

#check lt_trichotomy

-- BEGIN
example {x : ℝ} (h : x ≠ 0) : x < 0 ∨ x > 0 :=
begin
  cases lt_trichotomy x 0 with xlt xle,
    left,
    exact xlt,
    sorry,
end
-- END


import game.limits.bounded_if_convergent

namespace xena
/-
"Shift rule" for sequences, used in Series world:
-/

/- Lemma
Shift rule
-/

lemma shift_rule (a : ℕ → ℝ) (k : ℕ) (L : ℝ):
     is_limit a L ↔ is_limit (λ (n : ℕ), a (n+k)) L :=

begin
split,
     {
     intro hlim,
     intros e he,
     unfold is_limit at hlim,
     specialize hlim e he,
     cases hlim with N_1 hypN_1,
     use N_1,
     intros n hn,
     simp,
     have fact : N_1 ≤ n + k, linarith,
     specialize hypN_1 (n + k) fact,
     exact hypN_1,
     },

     {
     intro hlim,
     intros ε hε,
     unfold is_limit at hlim,
     specialize hlim ε hε,
     cases hlim with N_2 hypN_2,
     use (k+ N_2),
     intros N hN,
     have fact : N_2 ≤ N - k, from nat.le_sub_left_of_add_le hN,  -- namespace issue here?
     specialize hypN_2 (N -k) fact,
     rw nat.sub_add_cancel at hypN_2, -- seems to need these nat. theorems
     exact hypN_2,
     linarith,
     }

end
end xena


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
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


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Kevin Buzzard, Jujian Zhang
-/
import algebra.direct_sum.algebra
import algebra.direct_sum.decomposition
import algebra.direct_sum.internal
import algebra.direct_sum.ring

/-!
# Internally-graded rings and algebras

This file defines the typeclass `graded_algebra 𝒜`, for working with an algebra `A` that is
internally graded by a collection of submodules `𝒜 : ι → submodule R A`.
See the docstring of that typeclass for more information.

## Main definitions

* `graded_ring 𝒜`: the typeclass, which is a combination of `set_like.graded_monoid`, and
  `direct_sum.decomposition 𝒜`.
* `graded_algebra 𝒜`: A convenience alias for `graded_ring` when `𝒜` is a family of submodules.
* `direct_sum.decompose_ring_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `direct_sum.decompose_alg_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `graded_algebra.proj 𝒜 i` is the linear map from `A` to its degree `i : ι` component, such that
  `proj 𝒜 i x = decompose 𝒜 x i`.

## Implementation notes

For now, we do not have internally-graded semirings and internally-graded rings; these can be
represented with `𝒜 : ι → submodule ℕ A` and `𝒜 : ι → submodule ℤ A` respectively, since all
`semiring`s are ℕ-algebras via `algebra_nat`, and all `ring`s are `ℤ`-algebras via `algebra_int`.

## Tags

graded algebra, graded ring, graded semiring, decomposition
-/

open_locale direct_sum big_operators

variables {ι R A σ : Type*}
section graded_ring
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ)

include A

open direct_sum

/-- An internally-graded `R`-algebra `A` is one that can be decomposed into a collection
of `submodule R A`s indexed by `ι` such that the canonical map `A → ⨁ i, 𝒜 i` is bijective and
respects multiplication, i.e. the product of an element of degree `i` and an element of degree `j`
is an element of degree `i + j`.

Note that the fact that `A` is internally-graded, `graded_algebra 𝒜`, implies an externally-graded
algebra structure `direct_sum.galgebra R (λ i, ↥(𝒜 i))`, which in turn makes available an
`algebra R (⨁ i, 𝒜 i)` instance.
-/
class graded_ring (𝒜 : ι → σ) extends set_like.graded_monoid 𝒜, direct_sum.decomposition 𝒜.

variables [graded_ring 𝒜]
namespace direct_sum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
a ring to a direct sum of components. -/
def decompose_ring_equiv : A ≃+* ⨁ i, 𝒜 i := ring_equiv.symm
{ map_mul' := (coe_ring_hom 𝒜).map_mul,
  map_add' := (coe_ring_hom 𝒜).map_add,
  ..(decompose_add_equiv 𝒜).symm }

@[simp] lemma decompose_one : decompose 𝒜 (1 : A) = 1 := map_one (decompose_ring_equiv 𝒜)
@[simp] lemma decompose_symm_one : (decompose 𝒜).symm 1 = (1 : A) :=
map_one (decompose_ring_equiv 𝒜).symm

@[simp] lemma decompose_mul (x y : A) : decompose 𝒜 (x * y) = decompose 𝒜 x * decompose 𝒜 y :=
map_mul (decompose_ring_equiv 𝒜) x y
@[simp] lemma decompose_symm_mul (x y : ⨁ i, 𝒜 i) :
  (decompose 𝒜).symm (x * y) = (decompose 𝒜).symm x * (decompose 𝒜).symm y :=
map_mul (decompose_ring_equiv 𝒜).symm x y

end direct_sum

/-- The projection maps of a graded ring -/
def graded_ring.proj (i : ι) : A →+ A :=
(add_submonoid_class.subtype (𝒜 i)).comp $
  (dfinsupp.eval_add_monoid_hom i).comp $
  ring_hom.to_add_monoid_hom $ ring_equiv.to_ring_hom $ direct_sum.decompose_ring_equiv 𝒜

@[simp] lemma graded_ring.proj_apply (i : ι) (r : A) :
  graded_ring.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

lemma graded_ring.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_ring.proj 𝒜 i ((decompose 𝒜).symm a) =
  (decompose 𝒜).symm (direct_sum.of _ i (a i)) :=
by rw [graded_ring.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_ring.mem_support_iff [Π i (x : 𝒜 i), decidable (x ≠ 0)] (r : A) (i : ι) :
  i ∈ (decompose 𝒜 r).support ↔ graded_ring.proj 𝒜 i r ≠ 0 :=
dfinsupp.mem_support_iff.trans zero_mem_class.coe_eq_zero.not.symm

end graded_ring

section add_cancel_monoid

open direct_sum

variables [decidable_eq ι] [semiring A] [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ)
variables {i j : ι}

namespace direct_sum

lemma coe_decompose_mul_add_of_left_mem
  [add_left_cancel_monoid ι] [graded_ring 𝒜] {a b : A} (a_mem : a ∈ 𝒜 i) :
  (decompose 𝒜 (a * b) (i + j) : A) = a * decompose 𝒜 b j :=
by { lift a to 𝒜 i using a_mem, rw [decompose_mul, decompose_coe, coe_of_mul_apply_add] }

lemma coe_decompose_mul_add_of_right_mem
  [add_right_cancel_monoid ι] [graded_ring 𝒜] {a b : A} (b_mem : b ∈ 𝒜 j) :
  (decompose 𝒜 (a * b) (i + j) : A) = decompose 𝒜 a i * b :=
by { lift b to 𝒜 j using b_mem, rw [decompose_mul, decompose_coe, coe_mul_of_apply_add] }

lemma decompose_mul_add_left
  [add_left_cancel_monoid ι] [graded_ring 𝒜] (a : 𝒜 i) {b : A} :
  decompose 𝒜 (↑a * b) (i + j) =
    @graded_monoid.ghas_mul.mul ι (λ i, 𝒜 i) _ _ _ _ a (decompose 𝒜 b j) :=
subtype.ext $ coe_decompose_mul_add_of_left_mem 𝒜 a.2

lemma decompose_mul_add_right
  [add_right_cancel_monoid ι] [graded_ring 𝒜] {a : A} (b : 𝒜 j) :
  decompose 𝒜 (a * ↑b) (i + j) =
    @graded_monoid.ghas_mul.mul ι (λ i, 𝒜 i) _ _ _ _ (decompose 𝒜 a i) b :=
subtype.ext $ coe_decompose_mul_add_of_right_mem 𝒜 b.2

end direct_sum

end add_cancel_monoid

section graded_algebra
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝒜 : ι → submodule R A)

/-- A special case of `graded_ring` with `σ = submodule R A`. This is useful both because it
can avoid typeclass search, and because it provides a more concise name. -/
@[reducible]
def graded_algebra := graded_ring 𝒜

/-- A helper to construct a `graded_algebra` when the `set_like.graded_monoid` structure is already
available. This makes the `left_inv` condition easier to prove, and phrases the `right_inv`
condition in a way that allows custom `@[ext]` lemmas to apply.

See note [reducible non-instances]. -/
@[reducible]
def graded_algebra.of_alg_hom [set_like.graded_monoid 𝒜] (decompose : A →ₐ[R] ⨁ i, 𝒜 i)
  (right_inv : (direct_sum.coe_alg_hom 𝒜).comp decompose = alg_hom.id R A)
  (left_inv : ∀ i (x : 𝒜 i), decompose (x : A) = direct_sum.of (λ i, ↥(𝒜 i)) i x) :
  graded_algebra 𝒜 :=
{ decompose' := decompose,
  left_inv := alg_hom.congr_fun right_inv,
  right_inv := begin
    suffices : decompose.comp (direct_sum.coe_alg_hom 𝒜) = alg_hom.id _ _,
    from alg_hom.congr_fun this,
    ext i x : 2,
    exact (decompose.congr_arg $ direct_sum.coe_alg_hom_of _ _ _).trans (left_inv i x),
  end}

variable [graded_algebra 𝒜]

namespace direct_sum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
an algebra to a direct sum of components. -/
@[simps]
def decompose_alg_equiv : A ≃ₐ[R] ⨁ i, 𝒜 i := alg_equiv.symm
{ map_mul' := (coe_alg_hom 𝒜).map_mul,
  map_add' := (coe_alg_hom 𝒜).map_add,
  commutes' := (coe_alg_hom 𝒜).commutes,
  ..(decompose_add_equiv 𝒜).symm }

end direct_sum

open direct_sum

/-- The projection maps of graded algebra-/
def graded_algebra.proj (𝒜 : ι → submodule R A) [graded_algebra 𝒜] (i : ι) : A →ₗ[R] A :=
(𝒜 i).subtype.comp $
  (dfinsupp.lapply i).comp $
  (decompose_alg_equiv 𝒜).to_alg_hom.to_linear_map

@[simp] lemma graded_algebra.proj_apply (i : ι) (r : A) :
  graded_algebra.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

lemma graded_algebra.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_algebra.proj 𝒜 i ((decompose 𝒜).symm a) =
  (decompose 𝒜).symm (of _ i (a i)) :=
by rw [graded_algebra.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_algebra.mem_support_iff [decidable_eq A] (r : A) (i : ι) :
  i ∈ (decompose 𝒜 r).support ↔ graded_algebra.proj 𝒜 i r ≠ 0 :=
dfinsupp.mem_support_iff.trans submodule.coe_eq_zero.not.symm

end graded_algebra

section canonical_order

open set_like.graded_monoid direct_sum

variables [semiring A] [decidable_eq ι]
variables [canonically_ordered_add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ) [graded_ring 𝒜]

/--
If `A` is graded by a canonically ordered add monoid, then the projection map `x ↦ x₀` is a ring
homomorphism.
-/
@[simps]
def graded_ring.proj_zero_ring_hom : A →+* A :=
{ to_fun := λ a, decompose 𝒜 a 0,
  map_one' := decompose_of_mem_same 𝒜 one_mem,
  map_zero' := by { rw decompose_zero, refl },
  map_add' := λ _ _, by { rw decompose_add, refl },
  map_mul' := begin
    refine direct_sum.decomposition.induction_on 𝒜 (λ x, _) _ _,
    { simp only [zero_mul, decompose_zero, zero_apply, zero_mem_class.coe_zero] },
    { rintros i ⟨c, hc⟩,
      refine direct_sum.decomposition.induction_on 𝒜 _ _ _,
      { simp only [mul_zero, decompose_zero, zero_apply, zero_mem_class.coe_zero] },
      { rintros j ⟨c', hc'⟩,
        { simp only [subtype.coe_mk],
          by_cases h : i + j = 0,
          { rw [decompose_of_mem_same 𝒜 (show c * c' ∈ 𝒜 0, from h ▸ mul_mem hc hc'),
              decompose_of_mem_same 𝒜 (show c ∈ 𝒜 0, from (add_eq_zero_iff.mp h).1 ▸ hc),
              decompose_of_mem_same 𝒜 (show c' ∈ 𝒜 0, from (add_eq_zero_iff.mp h).2 ▸ hc')] },
          { rw [decompose_of_mem_ne 𝒜 (mul_mem hc hc') h],
            cases (show i ≠ 0 ∨ j ≠ 0, by rwa [add_eq_zero_iff, not_and_distrib] at h) with h' h',
            { simp only [decompose_of_mem_ne 𝒜 hc h', zero_mul] },
            { simp only [decompose_of_mem_ne 𝒜 hc' h', mul_zero] } } }, },
      { intros _ _ hd he,
        simp only [mul_add, decompose_add, add_apply, add_mem_class.coe_add, hd, he] }, },
    { rintros _ _ ha hb _,
      simp only [add_mul, decompose_add, add_apply, add_mem_class.coe_add, ha, hb], },
  end }

variables {a b : A} {n i : ι}

namespace direct_sum

lemma coe_decompose_mul_of_left_mem_of_not_le
  (a_mem : a ∈ 𝒜 i) (h : ¬ i ≤ n) : (decompose 𝒜 (a * b) n : A) = 0 :=
by { lift a to 𝒜 i using a_mem, rwa [decompose_mul, decompose_coe, coe_of_mul_apply_of_not_le] }

lemma coe_decompose_mul_of_right_mem_of_not_le
  (b_mem : b ∈ 𝒜 i) (h : ¬ i ≤ n) : (decompose 𝒜 (a * b) n : A) = 0 :=
by { lift b to 𝒜 i using b_mem, rwa [decompose_mul, decompose_coe, coe_mul_of_apply_of_not_le] }

variables [has_sub ι] [has_ordered_sub ι] [contravariant_class ι ι (+) (≤)]

lemma coe_decompose_mul_of_left_mem_of_le
  (a_mem : a ∈ 𝒜 i) (h : i ≤ n) : (decompose 𝒜 (a * b) n : A) = a * decompose 𝒜 b (n - i) :=
by { lift a to 𝒜 i using a_mem, rwa [decompose_mul, decompose_coe, coe_of_mul_apply_of_le] }

lemma coe_decompose_mul_of_right_mem_of_le
  (b_mem : b ∈ 𝒜 i) (h : i ≤ n) : (decompose 𝒜 (a * b) n : A) = decompose 𝒜 a (n - i) * b :=
by { lift b to 𝒜 i using b_mem, rwa [decompose_mul, decompose_coe, coe_mul_of_apply_of_le] }

lemma coe_decompose_mul_of_left_mem (n) [decidable (i ≤ n)] (a_mem : a ∈ 𝒜 i) :
  (decompose 𝒜 (a * b) n : A) = if i ≤ n then a * decompose 𝒜 b (n - i) else 0 :=
by { lift a to 𝒜 i using a_mem, rwa [decompose_mul, decompose_coe, coe_of_mul_apply] }

lemma coe_decompose_mul_of_right_mem (n) [decidable (i ≤ n)] (b_mem : b ∈ 𝒜 i) :
  (decompose 𝒜 (a * b) n : A) = if i ≤ n then decompose 𝒜 a (n - i) * b else 0 :=
by { lift b to 𝒜 i using b_mem, rwa [decompose_mul, decompose_coe, coe_mul_of_apply] }

end direct_sum

end canonical_order


import ring_theory.coprime
import .int

theorem int.is_coprime_iff_gcd_eq_one {m n : ℤ} : is_coprime m n ↔ int.gcd m n = 1 :=
begin
	split,
	{ rintro ⟨a, b, hab⟩,
		have : ↑(int.gcd m n) ∣ (1 : ℤ) :=
			hab ▸ dvd_add
				(dvd_mul_of_dvd_right (int.gcd_dvd_left m n) a)
				(dvd_mul_of_dvd_right (int.gcd_dvd_right m n) b),
		cases int.dvd_one this with h1 hn1,
		{ assumption_mod_cast },
		exfalso,
		have : ↑(int.gcd m n) ≥ 0 := by apply nat.cast_nonneg,
		linarith },
	intro hgcd,
	rcases int.exists_mul_eq_gcd m n with ⟨a, b, hab⟩,
	simp [hgcd] at hab,
	use [a, b],
	conv_lhs { congr, rw mul_comm, skip, rw mul_comm },
	exact hab,
end

theorem int.is_coprime_prime {a : ℤ} {p : ℕ} (hp : p.prime) :
	is_coprime a p ↔ ¬ ↑p ∣ a :=
begin
	rw int.is_coprime_iff_gcd_eq_one,
	split,
	{	intros hgcd hdvd,
		apply_fun int.of_nat at hgcd, simp at hgcd,
		have : ↑p ∣ (1 : ℤ) := hgcd ▸ int.dvd_gcd hdvd (dvd_refl _),
		change ↑p ∣ ↑1 at this,
		rw int.coe_nat_dvd at this,
		exact nat.prime.not_dvd_one hp this },
	intro hndvd,
	have := int.gcd_dvd_right a p, rw int.coe_nat_dvd at this,
	cases (nat.dvd_prime hp).mp this with h1 heqp,
	{	assumption },
	exfalso,
	rw ← heqp at hndvd,
	exact hndvd (int.gcd_dvd_left a p),
end