/-
Copyright (c) 2022 Jireh Loreaux. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jireh Loreaux

! This file was ported from Lean 3 source module analysis.normed_space.star.continuous_functional_calculus
! leanprover-community/mathlib commit e65771194f9e923a70dfb49b6ca7be6e400d8b6f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.NormedSpace.Star.GelfandDuality
import Mathbin.Topology.Algebra.StarSubalgebra

/-! # Continuous functional calculus

In this file we construct the `continuous_functional_calculus` for a normal element `a` of a
(unital) C⋆-algebra over `ℂ`. This is a star algebra equivalence
`C(spectrum ℂ a, ℂ) ≃⋆ₐ[ℂ] elemental_star_algebra ℂ a` which sends the (restriction of) the
identity map `continuous_map.id ℂ` to the (unique) preimage of `a` under the coercion of
`elemental_star_algebra ℂ a` to `A`.

Being a star algebra equivalence between C⋆-algebras, this map is continuous (even an isometry),
and by the Stone-Weierstrass theorem it is the unique star algebra equivalence which extends the
polynomial functional calculus (i.e., `polynomial.aeval`).

For any continuous function `f : spectrum ℂ a →  ℂ`, this makes it possible to define an element
`f a` (not valid notation) in the original algebra, which heuristically has the same eigenspaces as
`a` and acts on eigenvector of `a` for an eigenvalue `λ` as multiplication by `f λ`. This
description is perfectly accurate in finite dimension, but only heuristic in infinite dimension as
there might be no genuine eigenvector. In particular, when `f` is a polynomial `∑ cᵢ Xⁱ`, then
`f a` is `∑ cᵢ aⁱ`. Also, `id a = a`.

This file also includes a proof of the **spectral permanence** theorem for (unital) C⋆-algebras
(see `star_subalgebra.spectrum_eq`)

## Main definitions

* `continuous_functional_calculus : C(spectrum ℂ a, ℂ) ≃⋆ₐ[ℂ] elemental_star_algebra ℂ a`: this
  is the composition of the inverse of the `gelfand_star_transform` with the natural isomorphism
  induced by the homeomorphism `elemental_star_algebra.character_space_homeo`.
* `elemental_star_algebra.character_space_homeo :
  `character_space ℂ (elemental_star_algebra ℂ a) ≃ₜ spectrum ℂ a`: this homeomorphism is defined
  by evaluating a character `φ` at `a`, and noting that `φ a ∈ spectrum ℂ a` since `φ` is an
  algebra homomorphism. Moreover, this map is continuous and bijective and since the spaces involved
  are compact Hausdorff, it is a homeomorphism.

## Main statements

* `star_subalgebra.coe_is_unit`: for `x : S` in a C⋆-subalgebra `S` of `A`, then `↑x : A` is a unit
  if and only if `x` is a unit.
* `star_subalgebra.spectrum_eq`: **spectral_permanence** for `x : S`, where `S` is a C⋆-subalgebra
  of `A`, `spectrum ℂ x = spectrum ℂ (x : A)`.

## Notes

The result we have established here is the strongest possible, but it is likely not the version
which will be most useful in practice. Future work will include developing an appropriate API for
the continuous functional calculus (including one for real-valued functions with real argument that
applies to self-adjoint elements of the algebra). -/

open Pointwise ENNReal NNReal ComplexOrder

open WeakDual WeakDual.characterSpace elementalStarAlgebra

variable {A : Type _} [NormedRing A] [NormedAlgebra ℂ A]

variable [StarRing A] [CstarRing A] [StarModule ℂ A]

instance {R A : Type _} [CommRing R] [StarRing R] [NormedRing A] [Algebra R A] [StarRing A]
    [ContinuousStar A] [StarModule R A] (a : A) [IsStarNormal a] :
    NormedCommRing (elementalStarAlgebra R a) :=
  { SubringClass.toNormedRing (elementalStarAlgebra R a) with mul_comm := mul_comm }

instance {R A : Type _} [NormedField R] [StarRing R] [NormedRing A] [NormedAlgebra R A] [StarRing A]
    [ContinuousStar A] [StarModule R A] (a : A) : NormedAlgebra R (elementalStarAlgebra R a) :=
  StarSubalgebra.toNormedAlgebra (elementalStarAlgebra R a)

instance {R A : Type _} [NormedField R] [StarRing R] [NormedRing A] [NormedAlgebra R A] [StarRing A]
    [ContinuousStar A] [StarModule R A] (a : A) : NormedSpace R (elementalStarAlgebra R a) :=
  NormedAlgebra.toNormedSpace _

-- without this instance type class search causes timeouts
noncomputable instance elementalStarAlgebra.Complex.normedAlgebra (a : A) :
    NormedAlgebra ℂ (elementalStarAlgebra ℂ a) :=
  inferInstance
#align elemental_star_algebra.complex.normed_algebra elementalStarAlgebra.Complex.normedAlgebra

variable [CompleteSpace A] (a : A) [IsStarNormal a] (S : StarSubalgebra ℂ A)

/-- This lemma is used in the proof of `star_subalgebra.is_unit_of_is_unit_of_is_star_normal`,
which in turn is the key to spectral permanence `star_subalgebra.spectrum_eq`, which is itself
necessary for the continuous functional calculus. Using the continuous functional calculus, this
lemma can be superseded by one that omits the `is_star_normal` hypothesis. -/
theorem spectrum_star_mul_self_of_isStarNormal :
    spectrum ℂ (star a * a) ⊆ Set.Icc (0 : ℂ) ‖star a * a‖ :=
  by
  -- this instance should be found automatically, but without providing it Lean goes on a wild
  -- goose chase when trying to apply `spectrum.gelfand_transform_eq`.
  letI := elementalStarAlgebra.Complex.normedAlgebra a
  rcases subsingleton_or_nontrivial A with ⟨⟩
  · simp only [spectrum.of_subsingleton, Set.empty_subset]
  · set a' : elementalStarAlgebra ℂ a := ⟨a, self_mem ℂ a⟩
    refine' (spectrum.subset_starSubalgebra (star a' * a')).trans _
    rw [← spectrum.gelfandTransform_eq (star a' * a'), ContinuousMap.spectrum_eq_range]
    rintro - ⟨φ, rfl⟩
    rw [gelfand_transform_apply_apply ℂ _ (star a' * a') φ, map_mul φ, map_star φ]
    rw [Complex.eq_coe_norm_of_nonneg star_mul_self_nonneg, ← map_star, ← map_mul]
    exact
      ⟨Complex.zero_le_real.2 (norm_nonneg _),
        Complex.real_le_real.2 (AlgHom.norm_apply_le_self φ (star a' * a'))⟩
#align spectrum_star_mul_self_of_is_star_normal spectrum_star_mul_self_of_isStarNormal

variable {a}

/-- This is the key lemma on the way to establishing spectral permanence for C⋆-algebras, which is
established in `star_subalgebra.spectrum_eq`. This lemma is superseded by
`star_subalgebra.coe_is_unit`, which does not require an `is_star_normal` hypothesis and holds for
any closed star subalgebra. -/
theorem elementalStarAlgebra.isUnit_of_isUnit_of_isStarNormal (h : IsUnit a) :
    IsUnit (⟨a, self_mem ℂ a⟩ : elementalStarAlgebra ℂ a) :=
  by
  /- Sketch of proof: Because `a` is normal, it suffices to prove that `star a * a` is invertible
    in `elemental_star_algebra ℂ a`. For this it suffices to prove that it is sufficiently close to a
    unit, namely `algebra_map ℂ _ ‖star a * a‖`, and in this case the required distance is
    `‖star a * a‖`. So one must show `‖star a * a - algebra_map ℂ _ ‖star a * a‖‖ < ‖star a * a‖`.
    Since `star a * a - algebra_map ℂ _ ‖star a * a‖` is selfadjoint, by a corollary of Gelfand's
    formula for the spectral radius (`is_self_adjoint.spectral_radius_eq_nnnorm`) its norm is the
    supremum of the norms of elements in its spectrum (we may use the spectrum in `A` here because
    the norm in `A` and the norm in the subalgebra coincide).

    By `spectrum_star_mul_self_of_is_star_normal`, the spectrum (in the algebra `A`) of `star a * a`
    is contained in the interval `[0, ‖star a * a‖]`, and since `a` (and hence `star a * a`) is
    invertible in `A`, we may omit `0` from this interval. Therefore, by basic spectral mapping
    properties, the spectrum (in the algebra `A`) of `star a * a - algebra_map ℂ _ ‖star a * a‖` is
    contained in `[0, ‖star a * a‖)`. The supremum of the (norms of) elements of the spectrum must be
    *strictly* less that `‖star a * a‖` because the spectrum is compact, which completes the proof. -/
  /- We may assume `A` is nontrivial. It suffices to show that `star a * a` is invertible in the
    commutative (because `a` is normal) ring `elemental_star_algebra ℂ a`. Indeed, by commutativity,
    if `star a * a` is invertible, then so is `a`. -/
  nontriviality A
  set a' : elementalStarAlgebra ℂ a := ⟨a, self_mem ℂ a⟩
  suffices : IsUnit (star a' * a')
  exact (IsUnit.mul_iff.1 this).2
  replace h := (show Commute (star a) a from star_comm_self' a).isUnit_mul_iff.2 ⟨h.star, h⟩
  /- Since `a` is invertible, `‖star a * a‖ ≠ 0`, so `‖star a * a‖ • 1` is invertible in
    `elemental_star_algebra ℂ a`, and so it suffices to show that the distance between this unit and
    `star a * a` is less than `‖star a * a‖`. -/
  have h₁ : (‖star a * a‖ : ℂ) ≠ 0 := complex.of_real_ne_zero.mpr (norm_ne_zero_iff.mpr h.ne_zero)
  set u : Units (elementalStarAlgebra ℂ a) :=
    Units.map (algebraMap ℂ (elementalStarAlgebra ℂ a)).toMonoidHom (Units.mk0 _ h₁)
  refine' ⟨u.unit_of_nearby _ _, rfl⟩
  simp only [Complex.abs_ofReal, map_inv₀, Units.coe_map, Units.val_inv_eq_inv_val, [anonymous],
    RingHom.toMonoidHom_eq_coe, Units.val_mk0, Units.coe_map_inv, norm_algebra_map', inv_inv,
    Complex.norm_eq_abs, abs_norm_eq_norm, Subtype.val_eq_coe, coe_coe]
  /- Since `a` is invertible, by `spectrum_star_mul_self_of_is_star_normal`, the spectrum (in `A`)
    of `star a * a` is contained in the half-open interval `(0, ‖star a * a‖]`. Therefore, by basic
    spectral mapping properties, the spectrum of `‖star a * a‖ • 1 - star a * a` is contained in
    `[0, ‖star a * a‖)`. -/
  have h₂ : ∀ z ∈ spectrum ℂ (algebraMap ℂ A ‖star a * a‖ - star a * a), ‖z‖₊ < ‖star a * a‖₊ :=
    by
    intro z hz
    rw [← spectrum.singleton_sub_eq, Set.singleton_sub] at hz
    have h₃ : z ∈ Set.Icc (0 : ℂ) ‖star a * a‖ :=
      by
      replace hz := Set.image_subset _ (spectrum_star_mul_self_of_isStarNormal a) hz
      rwa [Set.image_const_sub_Icc, sub_self, sub_zero] at hz
    refine' lt_of_le_of_ne (Complex.real_le_real.1 <| Complex.eq_coe_norm_of_nonneg h₃.1 ▸ h₃.2) _
    · intro hz'
      replace hz' := congr_arg (fun x : ℝ≥0 => ((x : ℝ) : ℂ)) hz'
      simp only [coe_nnnorm] at hz'
      rw [← Complex.eq_coe_norm_of_nonneg h₃.1] at hz'
      obtain ⟨w, hw₁, hw₂⟩ := hz
      refine' (spectrum.zero_not_mem_iff ℂ).mpr h _
      rw [hz', sub_eq_self] at hw₂
      rwa [hw₂] at hw₁
  /- The norm of `‖star a * a‖ • 1 - star a * a` in the subalgebra and in `A` coincide. In `A`,
    because this element is selfadjoint, by `is_self_adjoint.spectral_radius_eq_nnnorm`, its norm is
    the supremum of the norms of the elements of the spectrum, which is strictly less than
    `‖star a * a‖` by `h₂` and because the spectrum is compact. -/
  exact
    ENNReal.coe_lt_coe.1
      (calc
        (‖star a' * a' - algebraMap ℂ _ ‖star a * a‖‖₊ : ℝ≥0∞) =
            ‖algebraMap ℂ A ‖star a * a‖ - star a * a‖₊ :=
          by
          rw [← nnnorm_neg, neg_sub]
          rfl
        _ = spectralRadius ℂ (algebraMap ℂ A ‖star a * a‖ - star a * a) :=
          by
          refine' (IsSelfAdjoint.spectralRadius_eq_nnnorm _).symm
          rw [IsSelfAdjoint, star_sub, star_mul, star_star, ← algebraMap_star_comm, IsROrC.star_def,
            IsROrC.conj_of_real]
        _ < ‖star a * a‖₊ := spectrum.spectralRadius_lt_of_forall_lt _ h₂
        )
#align elemental_star_algebra.is_unit_of_is_unit_of_is_star_normal elementalStarAlgebra.isUnit_of_isUnit_of_isStarNormal

/-- For `x : A` which is invertible in `A`, the inverse lies in any unital C⋆-subalgebra `S`
containing `x`. -/
theorem StarSubalgebra.isUnit_coe_inv_mem {S : StarSubalgebra ℂ A} (hS : IsClosed (S : Set A))
    {x : A} (h : IsUnit x) (hxS : x ∈ S) : ↑h.Unit⁻¹ ∈ S :=
  by
  have hx := h.star.mul h
  suffices this : (↑hx.unit⁻¹ : A) ∈ S
  · rw [← one_mul (↑h.unit⁻¹ : A), ← hx.unit.inv_mul, mul_assoc, IsUnit.unit_spec, mul_assoc,
      h.mul_coe_inv, mul_one]
    exact mul_mem this (star_mem hxS)
  refine' le_of_is_closed_of_mem ℂ hS (mul_mem (star_mem hxS) hxS) _
  haveI := (IsSelfAdjoint.star_mul_self x).IsStarNormal
  have hx' := elementalStarAlgebra.isUnit_of_isUnit_of_isStarNormal hx
  convert(↑hx'.unit⁻¹ : elementalStarAlgebra ℂ (star x * x)).Prop using 1
  exact left_inv_eq_right_inv hx.unit.inv_mul (congr_arg coe hx'.unit.mul_inv)
#align star_subalgebra.is_unit_coe_inv_mem StarSubalgebra.isUnit_coe_inv_mem

/-- For a unital C⋆-subalgebra `S` of `A` and `x : S`, if `↑x : A` is invertible in `A`, then
`x` is invertible in `S`. -/
theorem StarSubalgebra.coe_isUnit {S : StarSubalgebra ℂ A} (hS : IsClosed (S : Set A)) {x : S} :
    IsUnit (x : A) ↔ IsUnit x :=
  by
  refine'
    ⟨fun hx => ⟨⟨x, ⟨(↑hx.Unit⁻¹ : A), StarSubalgebra.isUnit_coe_inv_mem hS hx x.prop⟩, _, _⟩, rfl⟩,
      fun hx => hx.map S.subtype⟩
  exacts[Subtype.coe_injective hx.mul_coe_inv, Subtype.coe_injective hx.coe_inv_mul]
#align star_subalgebra.coe_is_unit StarSubalgebra.coe_isUnit

theorem StarSubalgebra.mem_spectrum_iff {S : StarSubalgebra ℂ A} (hS : IsClosed (S : Set A)) {x : S}
    {z : ℂ} : z ∈ spectrum ℂ x ↔ z ∈ spectrum ℂ (x : A) :=
  not_iff_not.2 (StarSubalgebra.coe_isUnit hS).symm
#align star_subalgebra.mem_spectrum_iff StarSubalgebra.mem_spectrum_iff

/-- **Spectral permanence.** The spectrum of an element is invariant of the (closed)
`star_subalgebra` in which it is contained. -/
theorem StarSubalgebra.spectrum_eq {S : StarSubalgebra ℂ A} (hS : IsClosed (S : Set A)) (x : S) :
    spectrum ℂ x = spectrum ℂ (x : A) :=
  Set.ext fun z => StarSubalgebra.mem_spectrum_iff hS
#align star_subalgebra.spectrum_eq StarSubalgebra.spectrum_eq

variable (a)

/-- The natural map from `character_space ℂ (elemental_star_algebra ℂ x)` to `spectrum ℂ x` given
by evaluating `φ` at `x`. This is essentially just evaluation of the `gelfand_transform` of `x`,
but because we want something in `spectrum ℂ x`, as opposed to
`spectrum ℂ ⟨x, elemental_star_algebra.self_mem ℂ x⟩` there is slightly more work to do. -/
@[simps]
noncomputable def elementalStarAlgebra.characterSpaceToSpectrum (x : A)
    (φ : characterSpace ℂ (elementalStarAlgebra ℂ x)) : spectrum ℂ x
    where
  val := φ ⟨x, self_mem ℂ x⟩
  property := by
    simpa only [StarSubalgebra.spectrum_eq (elementalStarAlgebra.isClosed ℂ x)
        ⟨x, self_mem ℂ x⟩] using
      AlgHom.apply_mem_spectrum φ ⟨x, self_mem ℂ x⟩
#align elemental_star_algebra.character_space_to_spectrum elementalStarAlgebra.characterSpaceToSpectrum

theorem elementalStarAlgebra.continuous_characterSpaceToSpectrum (x : A) :
    Continuous (elementalStarAlgebra.characterSpaceToSpectrum x) :=
  continuous_induced_rng.2
    (map_continuous <| gelfandTransform ℂ (elementalStarAlgebra ℂ x) ⟨x, self_mem ℂ x⟩)
#align elemental_star_algebra.continuous_character_space_to_spectrum elementalStarAlgebra.continuous_characterSpaceToSpectrum

theorem elementalStarAlgebra.bijective_characterSpaceToSpectrum :
    Function.Bijective (elementalStarAlgebra.characterSpaceToSpectrum a) :=
  by
  refine'
    ⟨fun φ ψ h =>
      star_alg_hom_class_ext ℂ (map_continuous φ) (map_continuous ψ)
        (by
          simpa only [elementalStarAlgebra.characterSpaceToSpectrum, Subtype.mk_eq_mk,
            ContinuousMap.coe_mk] using h),
      _⟩
  rintro ⟨z, hz⟩
  have hz' :=
    (StarSubalgebra.spectrum_eq (elementalStarAlgebra.isClosed ℂ a) ⟨a, self_mem ℂ a⟩).symm.subst hz
  rw [character_space.mem_spectrum_iff_exists] at hz'
  obtain ⟨φ, rfl⟩ := hz'
  exact ⟨φ, rfl⟩
#align elemental_star_algebra.bijective_character_space_to_spectrum elementalStarAlgebra.bijective_characterSpaceToSpectrum

/-- The homeomorphism between the character space of the unital C⋆-subalgebra generated by a
single normal element `a : A` and `spectrum ℂ a`. -/
noncomputable def elementalStarAlgebra.characterSpaceHomeo :
    characterSpace ℂ (elementalStarAlgebra ℂ a) ≃ₜ spectrum ℂ a :=
  @Continuous.homeoOfEquivCompactToT2 _ _ _ _ _ _
    (Equiv.ofBijective (elementalStarAlgebra.characterSpaceToSpectrum a)
      (elementalStarAlgebra.bijective_characterSpaceToSpectrum a))
    (elementalStarAlgebra.continuous_characterSpaceToSpectrum a)
#align elemental_star_algebra.character_space_homeo elementalStarAlgebra.characterSpaceHomeo

/-- **Continuous functional calculus.** Given a normal element `a : A` of a unital C⋆-algebra,
the continuous functional calculus is a `star_alg_equiv` from the complex-valued continuous
functions on the spectrum of `a` to the unital C⋆-subalgebra generated by `a`. Moreover, this
equivalence identifies `(continuous_map.id ℂ).restrict (spectrum ℂ a))` with `a`; see
`continuous_functional_calculus_map_id`. As such it extends the polynomial functional calculus. -/
noncomputable def continuousFunctionalCalculus :
    C(spectrum ℂ a, ℂ) ≃⋆ₐ[ℂ] elementalStarAlgebra ℂ a :=
  ((elementalStarAlgebra.characterSpaceHomeo a).compStarAlgEquiv' ℂ ℂ).trans
    (gelfandStarTransform (elementalStarAlgebra ℂ a)).symm
#align continuous_functional_calculus continuousFunctionalCalculus

theorem continuousFunctionalCalculus_map_id :
    continuousFunctionalCalculus a ((ContinuousMap.id ℂ).restrict (spectrum ℂ a)) =
      ⟨a, self_mem ℂ a⟩ :=
  StarAlgEquiv.symm_apply_apply _ _
#align continuous_functional_calculus_map_id continuousFunctionalCalculus_map_id


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

universes u v

namespace Mathlib

/-!
# Endofunctors as a monoidal category.

We give the monoidal category structure on `C ⥤ C`,
and show that when `C` itself is monoidal, it embeds via a monoidal functor into `C ⥤ C`.

## TODO

Can we use this to show coherence results, e.g. a cheap proof that `λ_ (𝟙_ C) = ρ_ (𝟙_ C)`?
I suspect this is harder than is usually made out.
-/

namespace category_theory

/--
The category of endofunctors of any category is a monoidal category,
with tensor product given by composition of functors
(and horizontal composition of natural transformations).
-/
def endofunctor_monoidal_category (C : Type u) [category C] : monoidal_category (C ⥤ C) :=
  monoidal_category.mk (fun (F G : C ⥤ C) => F ⋙ G) (fun (F G F' G' : C ⥤ C) (α : F ⟶ G) (β : F' ⟶ G') => α ◫ β) 𝟭
    (fun (F G H : C ⥤ C) => functor.associator F G H) (fun (F : C ⥤ C) => functor.left_unitor F)
    fun (F : C ⥤ C) => functor.right_unitor F

/--
Tensoring on the right gives a monoidal functor from `C` into endofunctors of `C`.
-/
@[simp] theorem tensoring_right_monoidal_to_lax_monoidal_functor_to_functor (C : Type u) [category C] [monoidal_category C] : lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor (tensoring_right_monoidal C)) =
  monoidal_category.tensoring_right C :=
  Eq.refl (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor (tensoring_right_monoidal C)))


import field_theory.separable
import field_theory.normal
import field_theory.fixed
import group_theory.group_action
import automorphisms
import primitive_element

variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

@[class] def is_galois : Prop := is_separable F E ∧ normal F E

@[class] def fin_galois : Prop := finite_dimensional F E ∧ is_galois F E

--splitting field of separable polynomial
def fin_galois' : Prop := ∃ f : polynomial F, f.separable ∧  polynomial.is_splitting_field F E f

--fixed field of aut
def fin_galois'' : Prop := finite_dimensional F E ∧ base_field_image F E = mul_action.fixed_points (E ≃ₐ[F] E) E

--fixed field of some subgroup of aut
def fin_galois''' : Prop := ∃ H : subgroup (E ≃ₐ[F] E), ∃ is_fin : fintype H,  base_field_image F E = mul_action.fixed_points H E

lemma fin_galois'_implies_fin_galois'' : fin_galois' F E → fin_galois'' F E :=
begin
    intro h,
    cases h with f hf,
    split,
    exact @polynomial.is_splitting_field.finite_dimensional F E _ _ _ f hf.2,
    sorry,
end

lemma fin_galois''_implies_fin_galois''': fin_galois'' F E → fin_galois''' F E :=
begin
    intro h,
    use (⊤ : subgroup (E ≃ₐ[F] E)),
    sorry,
end

lemma fis_galois'''_implies_fin_galois : fin_galois''' F E → fin_galois F E := sorry

lemma fin_galois_implies_fin_galois' : fin_galois F E → fin_galois' F E :=
begin
    intro h,
    cases primitive_element F h.2.1 h.1 with α hE,
    cases h.2.2 α with hα hf,
    use minimal_polynomial hα,
    sorry,
end

lemma fin_galois_iff_fin_galois' : fin_galois F E ↔ fin_galois' F E := sorry
lemma fin_galois_iff_fin_galois'' : fin_galois F E ↔ fin_galois'' F E := sorry
lemma fin_galois_iff_fin_galois''' : fin_galois F E ↔ fin_galois''' F E := sorry


import data.list.basic
open list
universe u
variables {α : Type} (x y z : α) (xs ys zs : list α)

def mk_symm (xs : list α) := xs ++ reverse xs

@[simp] theorem reverse_mk_symm (xs : list α) :
  reverse (mk_symm xs) = mk_symm xs :=
  by simp [mk_symm]

example (xs ys : list ℕ) :
  reverse (xs ++ mk_symm ys) = mk_symm ys ++ reverse xs :=
  by simp

example (xs ys : list ℕ) (p : list ℕ → Prop) (h : p (reverse (xs ++ (mk_symm ys)))) :
  p (mk_symm ys ++ reverse xs) :=
  by simp at h; assumption


import ring_theory.local_properties
.

open polynomial

lemma ring_hom.localization_is_integral :
  ring_hom.localization_preserves (λ R S _ _ f, by exactI f.is_integral) :=
begin
  introsI R S _ _ f M R' S' _ _ _ _ _ _ hf,
  letI := f.to_algebra,
  exact is_integral_localization (show algebra.is_integral R S, from hf)
end

lemma ring_hom.is_integral_of_localization_span :
  ring_hom.of_localization_span (λ R S _ _ f, by exactI f.is_integral) :=
begin
  introsI R S _ _ f s hs H x,
  letI := f.to_algebra,
  apply (integral_closure R S).to_submodule.mem_of_span_eq_top_of_smul_pow_mem _ hs,
  intros r,
  letI := (localization.away_map f r).to_algebra,
  haveI : is_scalar_tower R (localization.away (r : R)) (localization.away $ f r) :=
    is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,
  haveI : is_scalar_tower R S (localization.away $ f r) :=
    is_scalar_tower.of_algebra_map_eq' rfl,
  obtain ⟨⟨_, n, rfl⟩, p, hp, hp'⟩ := is_integral.exists_multiple_integral_of_is_localization
    (submonoid.powers (r : R)) _ (H r (algebra_map _ _ x)),
  simp only [submonoid.smul_def, subtype.coe_mk, algebra.smul_def, ring_hom.comp_apply,
    is_scalar_tower.algebra_map_eq R S (localization.away $ f r), ← map_mul] at hp',
  rw [eval₂_eq_eval_map, ← map_map, eval_map, eval₂_at_apply, ← @is_localization.mk'_one _ _
    (submonoid.powers $ f r), is_localization.mk'_eq_zero_iff] at hp',
  obtain ⟨⟨_, m, rfl⟩, H'⟩ := hp',
  rw [subtype.coe_mk, mul_comm, ← map_pow, ← ring_hom.algebra_map_to_algebra f,
    eval_map, ← eval₂_smul] at H',
  by_cases (r : R) ^ m = 0, { use m, rw [h, zero_smul], exact zero_mem _ },
  have hp'' : ((r : R) ^ m • p).leading_coeff = (r : R) ^ m,
  { have hp'' : ((r : R) ^ m • p).coeff p.nat_degree = (r : R) ^ m,
    { rw [coeff_smul, coeff_nat_degree, hp.leading_coeff, smul_eq_mul, mul_one] },
    have : ((r : R) ^ m • p).nat_degree = p.nat_degree,
    { exact (nat_degree_smul_le _ _).antisymm (le_nat_degree_of_ne_zero $ hp''.trans_ne h) },
    rw [leading_coeff, this, hp''] },
  have := is_integral_leading_coeff_smul _ _ H',
  rw [hp'', ← algebra.smul_def, smul_smul, ← pow_add] at this,
  exact ⟨m+n, this⟩
end


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

Measure spaces -- measures

Measures are restricted to a measurable space (associated by the type class `measurable_space`).
This allows us to prove equalities between measures by restricting to a generating set of the
measurable space.

On the other hand, the `μ.measure s` projection (i.e. the measure of `s` on the measure space `μ`)
is the _outer_ measure generated by `μ`. This gives us a unrestricted monotonicity rule and it is
somehow well-behaved on non-measurable sets.

This allows us for the `lebesgue` measure space to have the `borel` measurable space, but still be
a complete measure.
-/
import data.set order.galois_connection topology.instances.ennreal
       measure_theory.outer_measure

noncomputable theory

open classical set lattice filter finset function
local attribute [instance] prop_decidable

universes u v w x

namespace measure_theory

section of_measurable
parameters {α : Type*} [measurable_space α]
parameters (m : Π (s : set α), is_measurable s → ennreal)
parameters (m0 : m ∅ is_measurable.empty = 0)
include m0

/-- Measure projection which is ∞ for non-measurable sets.

`measure'` is mainly used to derive the outer measure, for the main `measure` projection. -/
def measure' (s : set α) : ennreal := ⨅ h : is_measurable s, m s h

lemma measure'_eq {s} (h : is_measurable s) : measure' s = m s h :=
by simp [measure', h]

lemma measure'_empty : measure' ∅ = 0 :=
(measure'_eq is_measurable.empty).trans m0

lemma measure'_Union_nat
  {f : ℕ → set α}
  (hm : ∀i, is_measurable (f i))
  (mU : m (⋃i, f i) (is_measurable.Union hm) = (∑i, m (f i) (hm i))) :
  measure' (⋃i, f i) = (∑i, measure' (f i)) :=
(measure'_eq _).trans $ mU.trans $
by congr; funext i; rw measure'_eq

/-- outer measure of a measure -/
def outer_measure' : outer_measure α :=
outer_measure.of_function measure' measure'_empty

lemma measure'_Union_le_tsum_nat'
  (mU : ∀ {f : ℕ → set α} (hm : ∀i, is_measurable (f i)),
    m (⋃i, f i) (is_measurable.Union hm) ≤ (∑i, m (f i) (hm i)))
  (s : ℕ → set α) :
  measure' (⋃i, s i) ≤ (∑i, measure' (s i)) :=
begin
  by_cases h : ∀i, is_measurable (s i),
  { rw [measure'_eq _ _ (is_measurable.Union h),
        congr_arg tsum _], {apply mU h},
    funext i, apply measure'_eq _ _ (h i) },
  { cases not_forall.1 h with i hi,
    exact le_trans (le_infi $ λ h, hi.elim h) (ennreal.le_tsum i) }
end

parameter (mU : ∀ {f : ℕ → set α} (hm : ∀i, is_measurable (f i)),
  pairwise (disjoint on f) →
  m (⋃i, f i) (is_measurable.Union hm) = (∑i, m (f i) (hm i)))
include mU

lemma measure'_Union
  {β} [encodable β] {f : β → set α}
  (hd : pairwise (disjoint on f)) (hm : ∀i, is_measurable (f i)) :
  measure' (⋃i, f i) = (∑i, measure' (f i)) :=
begin
  rw [encodable.Union_decode2, outer_measure.Union_aux],
  { exact measure'_Union_nat _ _
      (λ n, encodable.Union_decode2_cases is_measurable.empty hm)
      (mU _ (measurable_space.Union_decode2_disjoint_on hd)) },
  { apply measure'_empty },
end

lemma measure'_union {s₁ s₂ : set α}
  (hd : disjoint s₁ s₂) (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) :
  measure' (s₁ ∪ s₂) = measure' s₁ + measure' s₂ :=
begin
  rw [union_eq_Union, measure'_Union _ _ @mU
      (pairwise_disjoint_on_bool.2 hd) (bool.forall_bool.2 ⟨h₂, h₁⟩),
    tsum_fintype],
  change _+_ = _, simp
end

lemma measure'_mono {s₁ s₂ : set α} (h₁ : is_measurable s₁) (hs : s₁ ⊆ s₂) :
  measure' s₁ ≤ measure' s₂ :=
le_infi $ λ h₂, begin
  have := measure'_union _ _ @mU disjoint_diff h₁ (h₂.diff h₁),
  rw union_diff_cancel hs at this,
  rw ← measure'_eq m m0 _,
  exact le_iff_exists_add.2 ⟨_, this⟩
end

lemma measure'_Union_le_tsum_nat : ∀ (s : ℕ → set α),
  measure' (⋃i, s i) ≤ (∑i, measure' (s i)) :=
measure'_Union_le_tsum_nat' $ λ f h, begin
  simp [Union_disjointed.symm] {single_pass := tt},
  rw [mU (is_measurable.disjointed h) disjoint_disjointed],
  refine ennreal.tsum_le_tsum (λ i, _),
  rw [← measure'_eq m m0, ← measure'_eq m m0],
  exact measure'_mono _ _ @mU (is_measurable.disjointed h _) (inter_subset_left _ _)
end

lemma outer_measure'_eq {s : set α} (hs : is_measurable s) :
  outer_measure' s = m s hs :=
by rw ← measure'_eq m m0 hs; exact
(le_antisymm (outer_measure.of_function_le _ _ _) $
  le_infi $ λ f, le_infi $ λ hf,
  le_trans (measure'_mono _ _ @mU hs hf) $
  measure'_Union_le_tsum_nat _ _ @mU _)

lemma outer_measure'_eq_measure' {s : set α} (hs : is_measurable s) :
  outer_measure' s = measure' s :=
by rw [measure'_eq m m0 hs, outer_measure'_eq m m0 @mU hs]

end of_measurable

namespace outer_measure
variables {α : Type*} [measurable_space α] (m : outer_measure α)

def trim : outer_measure α :=
outer_measure' (λ s _, m s) m.empty

theorem trim_ge : m ≤ m.trim :=
λ s, le_infi $ λ f, le_infi $ λ hs,
le_trans (m.mono hs) $ le_trans (m.Union_nat f) $
ennreal.tsum_le_tsum $ λ i, le_infi $ λ hf, le_refl _

theorem trim_eq {s : set α} (hs : is_measurable s) : m.trim s = m s :=
le_antisymm (le_trans (of_function_le _ _ _) (infi_le _ hs)) (trim_ge _ _)

theorem trim_congr {m₁ m₂ : outer_measure α}
  (H : ∀ {s : set α}, is_measurable s → m₁ s = m₂ s) :
  m₁.trim = m₂.trim :=
by unfold trim; congr; funext s hs; exact H hs

theorem trim_le_trim {m₁ m₂ : outer_measure α} (H : m₁ ≤ m₂) : m₁.trim ≤ m₂.trim :=
λ s, infi_le_infi $ λ f, infi_le_infi $ λ hs,
ennreal.tsum_le_tsum $ λ b, infi_le_infi $ λ hf, H _

theorem le_trim_iff {m₁ m₂ : outer_measure α} : m₁ ≤ m₂.trim ↔
  ∀ s, is_measurable s → m₁ s ≤ m₂ s :=
le_of_function.trans $ forall_congr $ λ s, le_infi_iff

theorem trim_eq_infi (s : set α) : m.trim s = ⨅ t (st : s ⊆ t) (ht : is_measurable t), m t :=
begin
  refine le_antisymm
    (le_infi $ λ t, le_infi $ λ st, le_infi $ λ ht, _)
    (le_infi $ λ f, le_infi $ λ hf, _),
  { rw ← trim_eq m ht, exact (trim m).mono st },
  { by_cases h : ∀i, is_measurable (f i),
    { refine infi_le_of_le _ (infi_le_of_le hf $
        infi_le_of_le (is_measurable.Union h) _),
      rw congr_arg tsum _, {exact m.Union_nat _},
      funext i, exact measure'_eq _ _ (h i) },
    { cases not_forall.1 h with i hi,
      exact le_trans (le_infi $ λ h, hi.elim h) (ennreal.le_tsum i) } }
end

theorem trim_eq_infi' (s : set α) : m.trim s = ⨅ t : {t // s ⊆ t ∧ is_measurable t}, m t.1 :=
by simp [infi_subtype, infi_and, trim_eq_infi]

theorem trim_trim (m : outer_measure α) : m.trim.trim = m.trim :=
le_antisymm (le_trim_iff.2 $ λ s hs, by simp [trim_eq _ hs, le_refl]) (trim_ge _)

theorem trim_zero : (0 : outer_measure α).trim = 0 :=
ext $ λ s, le_antisymm
  (le_trans ((trim 0).mono (subset_univ s)) $
    le_of_eq $ trim_eq _ is_measurable.univ)
  (zero_le _)

theorem trim_add (m₁ m₂ : outer_measure α) : (m₁ + m₂).trim = m₁.trim + m₂.trim :=
ext $ λ s, begin
  simp [trim_eq_infi'],
  rw ennreal.infi_add_infi,
  rintro ⟨t₁, st₁, ht₁⟩ ⟨t₂, st₂, ht₂⟩,
  exact ⟨⟨_, subset_inter_iff.2 ⟨st₁, st₂⟩, ht₁.inter ht₂⟩,
    add_le_add'
      (m₁.mono' (inter_subset_left _ _))
      (m₂.mono' (inter_subset_right _ _))⟩,
end

theorem trim_sum_ge {ι} (m : ι → outer_measure α) : sum (λ i, (m i).trim) ≤ (sum m).trim :=
λ s, by simp [trim_eq_infi]; exact
λ t st ht, ennreal.tsum_le_tsum (λ i,
  infi_le_of_le t $ infi_le_of_le st $ infi_le _ ht)

end outer_measure

structure measure (α : Type*) [measurable_space α] extends outer_measure α :=
(m_Union {f : ℕ → set α} :
  (∀i, is_measurable (f i)) → pairwise (disjoint on f) →
  measure_of (⋃i, f i) = (∑i, measure_of (f i)))
(trimmed : to_outer_measure.trim = to_outer_measure)

/-- Measure projections for a measure space.

For measurable sets this returns the measure assigned by the `measure_of` field in `measure`.
But we can extend this to _all_ sets, but using the outer measure. This gives us monotonicity and
subadditivity for all sets.
-/
instance measure.has_coe_to_fun {α} [measurable_space α] : has_coe_to_fun (measure α) :=
⟨λ _, set α → ennreal, λ m, m.to_outer_measure⟩

namespace measure

def of_measurable {α} [measurable_space α]
  (m : Π (s : set α), is_measurable s → ennreal)
  (m0 : m ∅ is_measurable.empty = 0)
  (mU : ∀ {f : ℕ → set α} (h : ∀i, is_measurable (f i)),
    pairwise (disjoint on f) →
    m (⋃i, f i) (is_measurable.Union h) = (∑i, m (f i) (h i))) :
  measure α :=
{ m_Union := λ f hf hd,
  show outer_measure' m m0 (Union f) =
      ∑ i, outer_measure' m m0 (f i), begin
    rw [outer_measure'_eq m m0 @mU, mU hf hd],
    congr, funext n, rw outer_measure'_eq m m0 @mU
  end,
  trimmed :=
  show (outer_measure' m m0).trim = outer_measure' m m0, begin
    unfold outer_measure.trim,
    congr, funext s hs,
    exact outer_measure'_eq m m0 @mU hs
  end,
  ..outer_measure' m m0 }

lemma of_measurable_apply {α} [measurable_space α]
  {m : Π (s : set α), is_measurable s → ennreal}
  {m0 : m ∅ is_measurable.empty = 0}
  {mU : ∀ {f : ℕ → set α} (h : ∀i, is_measurable (f i)),
    pairwise (disjoint on f) →
    m (⋃i, f i) (is_measurable.Union h) = (∑i, m (f i) (h i))}
  (s : set α) (hs : is_measurable s) :
  of_measurable m m0 @mU s = m s hs :=
outer_measure'_eq m m0 @mU hs

@[extensionality] lemma ext {α} [measurable_space α] :
  ∀ {μ₁ μ₂ : measure α}, (∀s, is_measurable s → μ₁ s = μ₂ s) → μ₁ = μ₂
| ⟨m₁, u₁, h₁⟩ ⟨m₂, u₂, h₂⟩ h := by congr; rw [← h₁, ← h₂];
  exact outer_measure.trim_congr h

end measure

section
variables {α : Type*} {β : Type*} [measurable_space α] {μ μ₁ μ₂ : measure α} {s s₁ s₂ : set α}

@[simp] lemma to_outer_measure_apply (s) : μ.to_outer_measure s = μ s := rfl

lemma measure_eq_trim (s) : μ s = μ.to_outer_measure.trim s :=
by rw μ.trimmed; refl

lemma measure_eq_infi (s) : μ s = ⨅ t (st : s ⊆ t) (ht : is_measurable t), μ t :=
by rw [measure_eq_trim, outer_measure.trim_eq_infi]; refl

lemma measure_eq_outer_measure' :
  μ s = outer_measure' (λ s _, μ s) μ.empty s :=
measure_eq_trim _

lemma to_outer_measure_eq_outer_measure' :
  μ.to_outer_measure = outer_measure' (λ s _, μ s) μ.empty :=
μ.trimmed.symm

lemma measure_eq_measure' (hs : is_measurable s) :
  μ s = measure' (λ s _, μ s) μ.empty s :=
by rw [measure_eq_outer_measure',
  outer_measure'_eq_measure' (λ s _, μ s) _ μ.m_Union hs]

@[simp] lemma measure_empty : μ ∅ = 0 := μ.empty

lemma measure_mono (h : s₁ ⊆ s₂) : μ s₁ ≤ μ s₂ := μ.mono h

lemma measure_mono_null (h : s₁ ⊆ s₂) (h₂ : μ s₂ = 0) : μ s₁ = 0 :=
by rw [← le_zero_iff_eq, ← h₂]; exact measure_mono h

lemma exists_is_measurable_superset_of_measure_eq_zero {s : set α} (h : μ s = 0) :
  ∃t, s ⊆ t ∧ is_measurable t ∧ μ t = 0 :=
begin
  rw [measure_eq_infi] at h,
  have h := (infi_eq_bot _).1 h,
  choose t ht using show ∀n:ℕ, ∃t, s ⊆ t ∧ is_measurable t ∧ μ t < n⁻¹,
  { assume n,
    have : (0 : ennreal) < n⁻¹ :=
      (zero_lt_iff_ne_zero.2 $ ennreal.inv_ne_zero.2 $ ennreal.nat_ne_top _),
    rcases h _ this with ⟨t, ht⟩,
    use [t],
    simpa [(>), infi_lt_iff, -add_comm] using ht },
  refine ⟨⋂n, t n, subset_Inter (λn, (ht n).1), is_measurable.Inter (λn, (ht n).2.1), _⟩,
  refine eq_of_le_of_forall_le_of_dense bot_le (assume r hr, _),
  rcases ennreal.exists_inv_nat_lt (ne_of_gt hr) with ⟨n, hn⟩,
  calc μ (⋂n, t n) ≤ μ (t n) : measure_mono (Inter_subset _ _)
    ... ≤ n⁻¹ : le_of_lt (ht n).2.2
    ... ≤ r : le_of_lt hn
end

theorem measure_Union_le {β} [encodable β] (s : β → set α) : μ (⋃i, s i) ≤ (∑i, μ (s i)) :=
μ.to_outer_measure.Union _

lemma measure_Union_null {β} [encodable β] {s : β → set α} :
  (∀ i, μ (s i) = 0) → μ (⋃i, s i) = 0 :=
μ.to_outer_measure.Union_null

theorem measure_union_le (s₁ s₂ : set α) : μ (s₁ ∪ s₂) ≤ μ s₁ + μ s₂ :=
μ.to_outer_measure.union _ _

lemma measure_union_null {s₁ s₂ : set α} : μ s₁ = 0 → μ s₂ = 0 → μ (s₁ ∪ s₂) = 0 :=
μ.to_outer_measure.union_null

lemma measure_Union {β} [encodable β] {f : β → set α}
  (hn : pairwise (disjoint on f)) (h : ∀i, is_measurable (f i)) :
  μ (⋃i, f i) = (∑i, μ (f i)) :=
by rw [measure_eq_measure' (is_measurable.Union h),
     measure'_Union (λ s _, μ s) _ μ.m_Union hn h];
   simp [measure_eq_measure', h]

lemma measure_union (hd : disjoint s₁ s₂) (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) :
  μ (s₁ ∪ s₂) = μ s₁ + μ s₂ :=
by rw [measure_eq_measure' (h₁.union h₂),
     measure'_union (λ s _, μ s) _ μ.m_Union hd h₁ h₂];
   simp [measure_eq_measure', h₁, h₂]

lemma measure_bUnion {s : set β} {f : β → set α} (hs : countable s)
  (hd : pairwise_on s (disjoint on f)) (h : ∀b∈s, is_measurable (f b)) :
  μ (⋃b∈s, f b) = ∑p:s, μ (f p.1) :=
begin
  haveI := hs.to_encodable,
  rw [← measure_Union, bUnion_eq_Union],
  { rintro ⟨i, hi⟩ ⟨j, hj⟩ ij x ⟨h₁, h₂⟩,
    exact hd i hi j hj (mt subtype.eq' ij:_) ⟨h₁, h₂⟩ },
  { simpa }
end

lemma measure_sUnion {S : set (set α)} (hs : countable S)
  (hd : pairwise_on S disjoint) (h : ∀s∈S, is_measurable s) :
  μ (⋃₀ S) = ∑s:S, μ s.1 :=
by rw [sUnion_eq_bUnion, measure_bUnion hs hd h]

lemma measure_diff {s₁ s₂ : set α} (h : s₂ ⊆ s₁)
  (h₁ : is_measurable s₁) (h₂ : is_measurable s₂)
  (h_fin : μ s₂ < ⊤) : μ (s₁ \ s₂) = μ s₁ - μ s₂ :=
begin
  refine (ennreal.add_sub_self' h_fin).symm.trans _,
  rw [← measure_union disjoint_diff h₂ (h₁.diff h₂), union_diff_cancel h]
end

lemma measure_Union_eq_supr_nat {s : ℕ → set α} (h : ∀i, is_measurable (s i)) (hs : monotone s) :
  μ (⋃i, s i) = (⨆i, μ (s i)) :=
begin
  refine le_antisymm _ (supr_le $ λ i, measure_mono $ subset_Union _ _),
  rw [← Union_disjointed,
    measure_Union disjoint_disjointed (is_measurable.disjointed h),
    ennreal.tsum_eq_supr_nat],
  refine supr_le (λ n, _),
  cases n, {apply zero_le _},
  suffices : sum (finset.range n.succ) (λ i, μ (disjointed s i)) = μ (s n),
  { rw this, exact le_supr _ n },
  rw [← Union_disjointed_of_mono hs, measure_Union, tsum_eq_sum],
  { apply sum_congr rfl, intros i hi,
    simp [finset.mem_range.1 hi] },
  { intros i hi, simp [mt finset.mem_range.2 hi] },
  { rintro i j ij x ⟨⟨_, ⟨_, rfl⟩, h₁⟩, ⟨_, ⟨_, rfl⟩, h₂⟩⟩,
    exact disjoint_disjointed i j ij ⟨h₁, h₂⟩ },
  { intro i,
    by_cases h' : i < n.succ; simp [h', is_measurable.empty],
    apply is_measurable.disjointed h }
end

lemma measure_Inter_eq_infi_nat {s : ℕ → set α}
  (h : ∀i, is_measurable (s i)) (hs : ∀i j, i ≤ j → s j ⊆ s i)
  (hfin : ∃i, μ (s i) < ⊤) :
  μ (⋂i, s i) = (⨅i, μ (s i)) :=
begin
  rcases hfin with ⟨k, hk⟩,
  rw [← ennreal.sub_sub_cancel (by exact hk) (infi_le _ k),
    ennreal.sub_infi,
    ← ennreal.sub_sub_cancel (by exact hk) (measure_mono (Inter_subset _ k)),
    ← measure_diff (Inter_subset _ k) (h k) (is_measurable.Inter h)
      (lt_of_le_of_lt (measure_mono (Inter_subset _ k)) hk),
    diff_Inter_left, measure_Union_eq_supr_nat],
  { congr, funext i,
    cases le_total k i with ik ik,
    { exact measure_diff (hs _ _ ik) (h k) (h i)
        (lt_of_le_of_lt (measure_mono (hs _ _ ik)) hk) },
    { rw [diff_eq_empty.2 (hs _ _ ik), measure_empty,
      ennreal.sub_eq_zero_of_le (measure_mono (hs _ _ ik))] } },
  { exact λ i, (h k).diff (h i) },
  { exact λ i j ij, diff_subset_diff_right (hs _ _ ij) }
end

lemma measure_eq_inter_diff {μ : measure α} {s t : set α}
  (hs : is_measurable s) (ht : is_measurable t) :
  μ s = μ (s ∩ t) + μ (s \ t) :=
have hd : disjoint (s ∩ t) (s \ t) := assume a ⟨⟨_, hs⟩, _, hns⟩, hns hs ,
by rw [← measure_union hd (hs.inter ht) (hs.diff ht), inter_union_diff s t]

lemma tendsto_measure_Union {μ : measure α} {s : ℕ → set α}
  (hs : ∀n, is_measurable (s n)) (hm : monotone s) :
  tendsto (μ ∘ s) at_top (nhds (μ (⋃n, s n))) :=
begin
  rw measure_Union_eq_supr_nat hs hm,
  exact tendsto_at_top_supr_nat (μ ∘ s) (assume n m hnm, measure_mono $ hm $ hnm)
end

lemma tendsto_measure_Inter {μ : measure α} {s : ℕ → set α}
  (hs : ∀n, is_measurable (s n)) (hm : ∀n m, n ≤ m → s m ⊆ s n) (hf : ∃i, μ (s i) < ⊤):
  tendsto (μ ∘ s) at_top (nhds (μ (⋂n, s n))) :=
begin
  rw measure_Inter_eq_infi_nat hs hm hf,
  exact tendsto_at_top_infi_nat (μ ∘ s) (assume n m hnm, measure_mono $ hm _ _ $ hnm),
end

end

def outer_measure.to_measure {α} (m : outer_measure α)
  [ms : measurable_space α] (h : ms ≤ m.caratheodory) :
  measure α :=
measure.of_measurable (λ s _, m s) m.empty
  (λ f hf hd, m.Union_eq_of_caratheodory (λ i, h _ (hf i)) hd)

lemma le_to_outer_measure_caratheodory {α} [ms : measurable_space α]
  (μ : measure α) : ms ≤ μ.to_outer_measure.caratheodory :=
begin
  assume s hs,
  rw to_outer_measure_eq_outer_measure',
  refine outer_measure.caratheodory_is_measurable (λ t, le_infi $ λ ht, _),
  rw [← measure_eq_measure' (ht.inter hs),
    ← measure_eq_measure' (ht.diff hs),
    ← measure_union _ (ht.inter hs) (ht.diff hs),
    inter_union_diff],
  exact le_refl _,
  exact λ x ⟨⟨_, h₁⟩, _, h₂⟩, h₂ h₁
end

lemma to_measure_to_outer_measure {α} (m : outer_measure α)
  [ms : measurable_space α] (h : ms ≤ m.caratheodory) :
  (m.to_measure h).to_outer_measure = m.trim := rfl

@[simp] lemma to_measure_apply {α} (m : outer_measure α)
  [ms : measurable_space α] (h : ms ≤ m.caratheodory)
  {s : set α} (hs : is_measurable s) :
  m.to_measure h s = m s := m.trim_eq hs

lemma to_outer_measure_to_measure {α : Type*} [ms : measurable_space α] {μ : measure α} :
  μ.to_outer_measure.to_measure (le_to_outer_measure_caratheodory _) = μ :=
measure.ext $ λ s, μ.to_outer_measure.trim_eq

namespace measure
variables {α : Type*} {β : Type*} {γ : Type*}
  [measurable_space α] [measurable_space β] [measurable_space γ]

instance : has_zero (measure α) :=
⟨{ to_outer_measure := 0,
   m_Union := λ f hf hd, tsum_zero.symm,
   trimmed := outer_measure.trim_zero }⟩

@[simp] theorem zero_to_outer_measure :
  (0 : measure α).to_outer_measure = 0 := rfl

@[simp] theorem zero_apply (s : set α) : (0 : measure α) s = 0 := rfl

instance : inhabited (measure α) := ⟨0⟩

instance : has_add (measure α) :=
⟨λμ₁ μ₂, {
  to_outer_measure := μ₁.to_outer_measure + μ₂.to_outer_measure,
  m_Union := λs hs hd,
    show μ₁ (⋃ i, s i) + μ₂ (⋃ i, s i) = ∑ i, μ₁ (s i) + μ₂ (s i),
    by rw [ennreal.tsum_add, measure_Union hd hs, measure_Union hd hs],
  trimmed := by rw [outer_measure.trim_add, μ₁.trimmed, μ₂.trimmed] }⟩

@[simp] theorem add_to_outer_measure (μ₁ μ₂ : measure α) :
  (μ₁ + μ₂).to_outer_measure = μ₁.to_outer_measure + μ₂.to_outer_measure := rfl

@[simp] theorem add_apply (μ₁ μ₂ : measure α) (s : set α) :
  (μ₁ + μ₂) s = μ₁ s + μ₂ s := rfl

instance : add_comm_monoid (measure α) :=
{ zero      := 0,
  add       := (+),
  add_assoc := assume a b c, ext $ assume s hs, add_assoc _ _ _,
  add_comm  := assume a b, ext $ assume s hs, add_comm _ _,
  zero_add  := assume a, ext $ assume s hs, zero_add _,
  add_zero  := assume a, ext $ assume s hs, add_zero _ }

instance : partial_order (measure α) :=
{ le          := λm₁ m₂, ∀ s, is_measurable s → m₁ s ≤ m₂ s,
  le_refl     := assume m s hs, le_refl _,
  le_trans    := assume m₁ m₂ m₃ h₁ h₂ s hs, le_trans (h₁ s hs) (h₂ s hs),
  le_antisymm := assume m₁ m₂ h₁ h₂, ext $
    assume s hs, le_antisymm (h₁ s hs) (h₂ s hs) }

theorem le_iff {μ₁ μ₂ : measure α} :
  μ₁ ≤ μ₂ ↔ ∀ s, is_measurable s → μ₁ s ≤ μ₂ s := iff.rfl

theorem to_outer_measure_le {μ₁ μ₂ : measure α} :
  μ₁.to_outer_measure ≤ μ₂.to_outer_measure ↔ μ₁ ≤ μ₂ :=
by rw [← μ₂.trimmed, outer_measure.le_trim_iff]; refl

theorem le_iff' {μ₁ μ₂ : measure α} :
  μ₁ ≤ μ₂ ↔ ∀ s, μ₁ s ≤ μ₂ s :=
to_outer_measure_le.symm

section
variables {m : set (measure α)} {μ : measure α}

lemma Inf_caratheodory (s : set α) (hs : is_measurable s) :
  (Inf (measure.to_outer_measure '' m)).caratheodory.is_measurable s :=
begin
  rw [outer_measure.Inf_eq_of_function_Inf_gen],
  refine outer_measure.caratheodory_is_measurable (assume t, _),
  by_cases ht : t = ∅, { simp [ht] },
  simp only [outer_measure.Inf_gen_nonempty1 _ _ ht, le_infi_iff, ball_image_iff,
    to_outer_measure_apply, measure_eq_infi t],
  assume μ hμ u htu hu,
  have hm : ∀{s t}, s ⊆ t → outer_measure.Inf_gen (to_outer_measure '' m) s ≤ μ t,
  { assume s t hst,
    rw [outer_measure.Inf_gen_nonempty2 _ _ (mem_image_of_mem _ hμ)],
    refine infi_le_of_le (μ.to_outer_measure) (infi_le_of_le (mem_image_of_mem _ hμ) _),
    rw [to_outer_measure_apply],
    refine measure_mono hst },
  rw [measure_eq_inter_diff hu hs],
  refine add_le_add' (hm $ inter_subset_inter_left _ htu) (hm $ diff_subset_diff_left htu)
end

instance : has_Inf (measure α) :=
⟨λm, (Inf (to_outer_measure '' m)).to_measure $ Inf_caratheodory⟩

lemma Inf_apply {m : set (measure α)} {s : set α} (hs : is_measurable s) :
  Inf m s = Inf (to_outer_measure '' m) s :=
to_measure_apply _ _ hs

private lemma Inf_le (h : μ ∈ m) : Inf m ≤ μ :=
have Inf (to_outer_measure '' m) ≤ μ.to_outer_measure := Inf_le (mem_image_of_mem _ h),
assume s hs, by rw [Inf_apply hs, ← to_outer_measure_apply]; exact this s

private lemma le_Inf (h : ∀μ' ∈ m, μ ≤ μ') : μ ≤ Inf m :=
have μ.to_outer_measure ≤ Inf (to_outer_measure '' m) :=
  le_Inf $ ball_image_of_ball $ assume μ hμ, to_outer_measure_le.2 $ h _ hμ,
assume s hs, by rw [Inf_apply hs, ← to_outer_measure_apply]; exact this s

instance : has_Sup (measure α) := ⟨λs, Inf {μ' | ∀μ∈s, μ ≤ μ' }⟩
private lemma le_Sup (h : μ ∈ m) : μ ≤ Sup m := le_Inf $ assume μ' h', h' _ h
private lemma Sup_le (h : ∀μ' ∈ m, μ' ≤ μ) : Sup m ≤ μ := Inf_le h

instance : order_bot (measure α) :=
{ bot := 0, bot_le := assume a s hs, bot_le, .. measure.partial_order }

instance : order_top (measure α) :=
{ top := (⊤ : outer_measure α).to_measure (by rw [outer_measure.top_caratheodory]; exact le_top),
  le_top := assume a s hs,
    by by_cases s = ∅; simp [h, to_measure_apply ⊤ _ hs, outer_measure.top_apply],
  .. measure.partial_order }

instance : complete_lattice (measure α) :=
{ Inf          := Inf,
  Sup          := Sup,
  inf          := λa b, Inf {a, b},
  sup          := λa b, Sup {a, b},
  le_Sup       := assume s μ h, le_Sup h,
  Sup_le       := assume s μ h, Sup_le h,
  Inf_le       := assume s μ h, Inf_le h,
  le_Inf       := assume s μ h, le_Inf h,
  le_sup_left  := assume a b, le_Sup $ by simp,
  le_sup_right := assume a b, le_Sup $ by simp,
  sup_le       := assume a b c hac hbc, Sup_le $ by simp [*, or_imp_distrib] {contextual := tt},
  inf_le_left  := assume a b, Inf_le $ by simp,
  inf_le_right := assume a b, Inf_le $ by simp,
  le_inf       := assume a b c hac hbc, le_Inf $ by simp [*, or_imp_distrib] {contextual := tt},
  .. measure.partial_order, .. measure.lattice.order_top, .. measure.lattice.order_bot }

end

def map (f : α → β) (μ : measure α) : measure β :=
if hf : measurable f then
  (μ.to_outer_measure.map f).to_measure $ λ s hs t,
  le_to_outer_measure_caratheodory μ _ (hf _ hs) (f ⁻¹' t)
else 0

variables {μ ν : measure α}

@[simp] theorem map_apply {f : α → β} (hf : measurable f)
  {s : set β} (hs : is_measurable s) :
  (map f μ : measure β) s = μ (f ⁻¹' s) :=
by rw [map, dif_pos hf, to_measure_apply _ _ hs]; refl

@[simp] lemma map_id : map id μ = μ :=
ext $ λ s, map_apply measurable_id

lemma map_map {f : α → β} {g : β → γ} (hf : measurable f) (hg : measurable g) :
  map g (map f μ) = map (g ∘ f) μ :=
ext $ λ s hs,
by simp [hf, hg, hs, hg.preimage hs, hf.comp hg];
   rw ← preimage_comp

/-- The dirac measure. -/
def dirac (a : α) : measure α :=
(outer_measure.dirac a).to_measure (by simp)

@[simp] lemma dirac_apply (a : α) {s : set α} (hs : is_measurable s) :
  (dirac a : measure α) s = ⨆ h : a ∈ s, 1 :=
to_measure_apply _ _ hs

/-- Sum of an indexed family of measures. -/
def sum {ι : Type*} (f : ι → measure α) : measure α :=
(outer_measure.sum (λ i, (f i).to_outer_measure)).to_measure $
le_trans
  (by exact le_infi (λ i, le_to_outer_measure_caratheodory _))
  (outer_measure.le_sum_caratheodory _)

/-- Counting measure on any measurable space. -/
def count : measure α := sum dirac

@[class] def is_complete {α} {_:measurable_space α} (μ : measure α) : Prop :=
∀ s, μ s = 0 → is_measurable s

/-- The "almost everywhere" filter of co-null sets. -/
def a_e (μ : measure α) : filter α :=
{ sets := {s | μ (-s) = 0},
  univ_sets := by simp [measure_empty],
  inter_sets := λ s t hs ht, by simp [compl_inter]; exact measure_union_null hs ht,
  sets_of_superset := λ s t hs hst, measure_mono_null (set.compl_subset_compl.2 hst) hs }

lemma mem_a_e_iff (s : set α) : s ∈ μ.a_e.sets ↔ μ (- s) = 0 := iff.refl _

end measure

end measure_theory

section is_complete
open measure_theory

variables {α : Type*} [measurable_space α] (μ : measure α)

def is_null_measurable (s : set α) : Prop :=
∃ t z, s = t ∪ z ∧ is_measurable t ∧ μ z = 0

theorem is_null_measurable_iff {μ : measure α} {s : set α} :
  is_null_measurable μ s ↔
  ∃ t, t ⊆ s ∧ is_measurable t ∧ μ (s \ t) = 0 :=
begin
  split,
  { rintro ⟨t, z, rfl, ht, hz⟩,
    refine ⟨t, set.subset_union_left _ _, ht, measure_mono_null _ hz⟩,
    simp [union_diff_left, diff_subset] },
  { rintro ⟨t, st, ht, hz⟩,
    exact ⟨t, _, (union_diff_cancel st).symm, ht, hz⟩ }
end

theorem is_null_measurable_measure_eq {μ : measure α} {s t : set α}
  (st : t ⊆ s) (hz : μ (s \ t) = 0) : μ s = μ t :=
begin
  refine le_antisymm _ (measure_mono st),
  have := measure_union_le t (s \ t),
  rw [union_diff_cancel st, hz] at this, simpa
end

theorem is_measurable.is_null_measurable
  {s : set α} (hs : is_measurable s) : is_null_measurable μ s :=
⟨s, ∅, by simp, hs, μ.empty⟩

theorem is_null_measurable_of_complete [c : μ.is_complete]
  {s : set α} : is_null_measurable μ s ↔ is_measurable s :=
⟨by rintro ⟨t, z, rfl, ht, hz⟩; exact
  is_measurable.union ht (c _ hz),
 λ h, h.is_null_measurable _⟩

variables {μ}
theorem is_null_measurable.union_null {s z : set α}
  (hs : is_null_measurable μ s) (hz : μ z = 0) :
  is_null_measurable μ (s ∪ z) :=
begin
  rcases hs with ⟨t, z', rfl, ht, hz'⟩,
  exact ⟨t, z' ∪ z, set.union_assoc _ _ _, ht, le_zero_iff_eq.1
    (le_trans (measure_union_le _ _) $ by simp [hz, hz'])⟩
end

theorem null_is_null_measurable {z : set α}
  (hz : μ z = 0) : is_null_measurable μ z :=
by simpa using (is_measurable.empty.is_null_measurable _).union_null hz

theorem is_null_measurable.Union_nat {s : ℕ → set α}
  (hs : ∀ i, is_null_measurable μ (s i)) :
  is_null_measurable μ (Union s) :=
begin
  choose t ht using assume i, is_null_measurable_iff.1 (hs i),
  simp [forall_and_distrib] at ht,
  rcases ht with ⟨st, ht, hz⟩,
  refine is_null_measurable_iff.2
    ⟨Union t, Union_subset_Union st, is_measurable.Union ht,
      measure_mono_null _ (measure_Union_null hz)⟩,
  rw [diff_subset_iff, ← Union_union_distrib],
  exact Union_subset_Union (λ i, by rw ← diff_subset_iff)
end

theorem is_measurable.diff_null {s z : set α}
  (hs : is_measurable s) (hz : μ z = 0) :
  is_null_measurable μ (s \ z) :=
begin
  rw measure_eq_infi at hz,
  choose f hf using show ∀ q : {q:ℚ//q>0}, ∃ t:set α,
    z ⊆ t ∧ is_measurable t ∧ μ t < (nnreal.of_real q.1 : ennreal),
  { rintro ⟨ε, ε0⟩,
    have : 0 < (nnreal.of_real ε : ennreal), { simpa using ε0 },
    rw ← hz at this, simpa [infi_lt_iff] },
  refine is_null_measurable_iff.2 ⟨s \ Inter f,
    diff_subset_diff_right (subset_Inter (λ i, (hf i).1)),
    hs.diff (is_measurable.Inter (λ i, (hf i).2.1)),
    measure_mono_null _ (le_zero_iff_eq.1 $ le_of_not_lt $ λ h, _)⟩,
  { exact Inter f },
  { rw [diff_subset_iff, diff_union_self],
    exact subset.trans (diff_subset _ _) (subset_union_left _ _) },
  rcases ennreal.lt_iff_exists_rat_btwn.1 h with ⟨ε, ε0', ε0, h⟩,
  simp at ε0,
  apply not_le_of_lt (lt_trans (hf ⟨ε, ε0⟩).2.2 h),
  exact measure_mono (Inter_subset _ _)
end

theorem is_null_measurable.diff_null {s z : set α}
  (hs : is_null_measurable μ s) (hz : μ z = 0) :
  is_null_measurable μ (s \ z) :=
begin
  rcases hs with ⟨t, z', rfl, ht, hz'⟩,
  rw [set.union_diff_distrib],
  exact (ht.diff_null hz).union_null (measure_mono_null (diff_subset _ _) hz')
end

theorem is_null_measurable.compl {s : set α}
  (hs : is_null_measurable μ s) :
  is_null_measurable μ (-s) :=
begin
  rcases hs with ⟨t, z, rfl, ht, hz⟩,
  rw compl_union,
  exact ht.compl.diff_null hz
end

def null_measurable {α : Type u} [measurable_space α]
  (μ : measure α) : measurable_space α :=
{ is_measurable := is_null_measurable μ,
  is_measurable_empty := is_measurable.empty.is_null_measurable _,
  is_measurable_compl := λ s hs, hs.compl,
  is_measurable_Union := λ f, is_null_measurable.Union_nat }

def completion {α : Type u} [measurable_space α] (μ : measure α) :
  @measure_theory.measure α (null_measurable μ) :=
{ to_outer_measure := μ.to_outer_measure,
  m_Union := λ s hs hd, show μ (Union s) = ∑ i, μ (s i), begin
    choose t ht using assume i, is_null_measurable_iff.1 (hs i),
    simp [forall_and_distrib] at ht, rcases ht with ⟨st, ht, hz⟩,
    rw is_null_measurable_measure_eq (Union_subset_Union st),
    { rw measure_Union _ ht,
      { congr, funext i,
        exact (is_null_measurable_measure_eq (st i) (hz i)).symm },
      { rintro i j ij x ⟨h₁, h₂⟩,
        exact hd i j ij ⟨st i h₁, st j h₂⟩ } },
    { refine measure_mono_null _ (measure_Union_null hz),
      rw [diff_subset_iff, ← Union_union_distrib],
      exact Union_subset_Union (λ i, by rw ← diff_subset_iff) }
  end,
  trimmed := begin
    letI := null_measurable μ,
    refine le_antisymm (λ s, _) (outer_measure.trim_ge _),
    rw outer_measure.trim_eq_infi,
    dsimp, clear _inst,
    rw measure_eq_infi s,
    exact infi_le_infi (λ t, infi_le_infi $ λ st,
      infi_le_infi2 $ λ ht, ⟨ht.is_null_measurable _, le_refl _⟩)
  end }

instance completion.is_complete {α : Type u} [measurable_space α] (μ : measure α) :
  (completion μ).is_complete :=
λ z hz, null_is_null_measurable hz

end is_complete

namespace measure_theory

/-- A measure space is a measurable space equipped with a
  measure, referred to as `volume`. -/
class measure_space (α : Type*) extends measurable_space α :=
(μ {} : measure α)

section measure_space
variables {α : Type*} [measure_space α] {s₁ s₂ : set α}
open measure_space

def volume : set α → ennreal := @μ α _

@[simp] lemma volume_empty : volume (∅ : set α) = 0 := μ.empty

lemma volume_mono : s₁ ⊆ s₂ → volume s₁ ≤ volume s₂ := measure_mono

lemma volume_mono_null : s₁ ⊆ s₂ → volume s₂ = 0 → volume s₁ = 0 :=
measure_mono_null

theorem volume_Union_le {β} [encodable β] :
  ∀ (s : β → set α), volume (⋃i, s i) ≤ (∑i, volume (s i)) :=
measure_Union_le

lemma volume_Union_null {β} [encodable β] {s : β → set α} :
  (∀ i, volume (s i) = 0) → volume (⋃i, s i) = 0 :=
measure_Union_null

theorem volume_union_le : ∀ (s₁ s₂ : set α), volume (s₁ ∪ s₂) ≤ volume s₁ + volume s₂ :=
measure_union_le

lemma volume_union_null : volume s₁ = 0 → volume s₂ = 0 → volume (s₁ ∪ s₂) = 0 :=
measure_union_null

lemma volume_Union {β} [encodable β] {f : β → set α} :
  pairwise (disjoint on f) → (∀i, is_measurable (f i)) →
  volume (⋃i, f i) = (∑i, volume (f i)) :=
measure_Union

lemma volume_union : disjoint s₁ s₂ → is_measurable s₁ → is_measurable s₂ →
  volume (s₁ ∪ s₂) = volume s₁ + volume s₂ :=
measure_union

lemma volume_bUnion {β} {s : set β} {f : β → set α} : countable s →
  pairwise_on s (disjoint on f) → (∀b∈s, is_measurable (f b)) →
  volume (⋃b∈s, f b) = ∑p:s, volume (f p.1) :=
measure_bUnion

lemma volume_sUnion {S : set (set α)} : countable S →
  pairwise_on S disjoint → (∀s∈S, is_measurable s) →
  volume (⋃₀ S) = ∑s:S, volume s.1 :=
measure_sUnion

lemma volume_bUnion_finset {β} {s : finset β} {f : β → set α}
  (hd : pairwise_on ↑s (disjoint on f)) (hm : ∀b∈s, is_measurable (f b)) :
  volume (⋃b∈s, f b) = s.sum (λp, volume (f p)) :=
show volume (⋃b∈(↑s : set β), f b) = s.sum (λp, volume (f p)),
begin
  rw [volume_bUnion (countable_finite (finset.finite_to_set s)) hd hm, tsum_eq_sum],
  { show s.attach.sum (λb:(↑s : set β), volume (f b)) = s.sum (λb, volume (f b)),
    exact @finset.sum_attach _ _ s _ (λb, volume (f b)) },
  simp
end

lemma volume_diff : s₂ ⊆ s₁ → is_measurable s₁ → is_measurable s₂ →
  volume s₂ < ⊤ → volume (s₁ \ s₂) = volume s₁ - volume s₂ :=
measure_diff

/-- `∀ₘ a:α, p a` states that the property `p` is almost everywhere true in the measure space
associated with `α`. This means that the measure of the complementary of `p` is `0`.

In a probability measure, the measure of `p` is `1`, when `p` is measurable.
-/
def all_ae (p : α → Prop) : Prop := { a | p a } ∈ (@measure_space.μ α _).a_e

notation `∀ₘ` binders `, ` r:(scoped P, all_ae P) := r

lemma all_ae_congr {p q : α → Prop} (h : ∀ₘ a, p a ↔ q a) : (∀ₘ a, p a) ↔ (∀ₘ a, q a) :=
iff.intro
  (assume h', by filter_upwards [h, h'] assume a hpq hp, hpq.1 hp)
  (assume h', by filter_upwards [h, h'] assume a hpq hq, hpq.2 hq)

lemma all_ae_iff {p : α → Prop} : (∀ₘ a, p a) ↔ volume { a | ¬ p a } = 0 := iff.refl _

lemma all_ae_all_iff {ι : Type*} [encodable ι] {p : α → ι → Prop} :
  (∀ₘ a, ∀i, p a i) ↔ (∀i, ∀ₘ a, p a i):=
begin
  refine iff.intro (assume h i, _) (assume h, _),
  { filter_upwards [h] assume a ha, ha i },
  { have h := measure_Union_null h,
    rw [← compl_Inter] at h,
    filter_upwards [h] assume a, mem_Inter.1 }
end

end measure_space

end measure_theory


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import deprecated.subgroup
import deprecated.group

universes u v

open group

variables {R : Type u} [ring R]

/-- `S` is a subring: a set containing 1 and closed under multiplication, addition and additive
inverse. -/
class is_subring (S : set R) extends is_add_subgroup S, is_submonoid S : Prop.

/-- The ring structure on a subring coerced to a type. -/
local attribute [instance]
def subset.ring {S : set R} [is_subring S] : ring S :=
{ left_distrib := λ x y z, subtype.eq $ left_distrib x.1 y.1 z.1,
  right_distrib := λ x y z, subtype.eq $ right_distrib x.1 y.1 z.1,
  .. subtype.add_comm_group, .. subtype.monoid }

/-- The ring structure on a subring coerced to a type. -/
def subtype.ring {S : set R} [is_subring S] : ring (subtype S) := subset.ring

namespace ring_hom

instance is_subring_preimage {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) (s : set S) [is_subring s] : is_subring (f ⁻¹' s) := {}

instance is_subring_image {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) (s : set R) [is_subring s] : is_subring (f '' s) := {}

instance is_subring_set_range {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) : is_subring (set.range f) := {}

end ring_hom

/-- Restrict the codomain of a ring homomorphism to a subring that includes the range. -/
def ring_hom.cod_restrict {R : Type u} {S : Type v} [ring R] [ring S] (f : R →+* S)
  (s : set S) [is_subring s] (h : ∀ x, f x ∈ s) :
  R →+* s :=
{ to_fun := λ x, ⟨f x, h x⟩,
  map_add' := λ x y, subtype.eq $ f.map_add x y,
  map_zero' := subtype.eq f.map_zero,
  map_mul' := λ x y, subtype.eq $ f.map_mul x y,
  map_one' := subtype.eq f.map_one }

/-- Coersion `S → R` as a ring homormorphism-/
def is_subring.subtype (S : set R) [is_subring S] : S →+* R :=
⟨coe, rfl, λ _ _, rfl, rfl, λ _ _, rfl⟩

@[simp] lemma is_subring.coe_subtype {S : set R} [is_subring S] :
  ⇑(is_subring.subtype S) = coe := rfl

variables {cR : Type u} [comm_ring cR]

/-- The commutative ring structure on a subring coerced to a type. -/
def subset.comm_ring {S : set cR} [is_subring S] : comm_ring S :=
{ mul_comm := λ x y, subtype.eq $ mul_comm x.1 y.1,
  .. subset.ring }

/-- The commutative ring structure on a subring coerced to a type. -/
def subtype.comm_ring {S : set cR} [is_subring S] : comm_ring (subtype S) := subset.comm_ring

/-- The integral domain structure on a subring of an integral domain coerced to a type. -/
def subring.domain {D : Type*} [integral_domain D] (S : set D) [is_subring S] :
  integral_domain S :=
{ exists_pair_ne := ⟨0, 1, mt subtype.ext_iff_val.1 zero_ne_one⟩,
  eq_zero_or_eq_zero_of_mul_eq_zero := λ ⟨x, hx⟩ ⟨y, hy⟩,
    by { simp only [subtype.ext_iff_val, subtype.coe_mk], exact eq_zero_or_eq_zero_of_mul_eq_zero },
  .. subset.comm_ring }

instance is_subring.inter (S₁ S₂ : set R) [is_subring S₁] [is_subring S₂] :
  is_subring (S₁ ∩ S₂) :=
{ }

instance is_subring.Inter {ι : Sort*} (S : ι → set R) [h : ∀ y : ι, is_subring (S y)] :
  is_subring (set.Inter S) :=
{ }

lemma is_subring_Union_of_directed {ι : Type*} [hι : nonempty ι]
  (s : ι → set R) [∀ i, is_subring (s i)]
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_subring (⋃i, s i) :=
{ to_is_add_subgroup := is_add_subgroup_Union_of_directed s directed,
  to_is_submonoid := is_submonoid_Union_of_directed s directed }

namespace ring

def closure (s : set R) := add_group.closure (monoid.closure s)

variable {s : set R}

local attribute [reducible] closure

theorem exists_list_of_mem_closure {a : R} (h : a ∈ closure s) :
  (∃ L : list (list R), (∀ l ∈ L, ∀ x ∈ l, x ∈ s ∨ x = (-1:R)) ∧ (L.map list.prod).sum = a) :=
add_group.in_closure.rec_on h
  (λ x hx, match x, monoid.exists_list_of_mem_closure hx with
    | _, ⟨L, h1, rfl⟩ := ⟨[L], list.forall_mem_singleton.2 (λ r hr, or.inl (h1 r hr)), zero_add _⟩
    end)
  ⟨[], list.forall_mem_nil _, rfl⟩
  (λ b _ ih, match b, ih with
    | _, ⟨L1, h1, rfl⟩ := ⟨L1.map (list.cons (-1)),
      λ L2 h2, match L2, list.mem_map.1 h2 with
        | _, ⟨L3, h3, rfl⟩ := list.forall_mem_cons.2 ⟨or.inr rfl, h1 L3 h3⟩
        end,
      by simp only [list.map_map, (∘), list.prod_cons, neg_one_mul];
      exact list.rec_on L1 neg_zero.symm (λ hd tl ih,
        by rw [list.map_cons, list.sum_cons, ih, list.map_cons, list.sum_cons, neg_add])⟩
    end)
  (λ r1 r2 hr1 hr2 ih1 ih2, match r1, r2, ih1, ih2 with
    | _, _, ⟨L1, h1, rfl⟩, ⟨L2, h2, rfl⟩ := ⟨L1 ++ L2, list.forall_mem_append.2 ⟨h1, h2⟩,
      by rw [list.map_append, list.sum_append]⟩
    end)

@[elab_as_eliminator]
protected theorem in_closure.rec_on {C : R → Prop} {x : R} (hx : x ∈ closure s)
  (h1 : C 1) (hneg1 : C (-1)) (hs : ∀ z ∈ s, ∀ n, C n → C (z * n))
  (ha : ∀ {x y}, C x → C y → C (x + y)) : C x :=
begin
  have h0 : C 0 := add_neg_self (1:R) ▸ ha h1 hneg1,
  rcases exists_list_of_mem_closure hx with ⟨L, HL, rfl⟩, clear hx,
  induction L with hd tl ih, { exact h0 },
  rw list.forall_mem_cons at HL,
  suffices : C (list.prod hd),
  { rw [list.map_cons, list.sum_cons],
    exact ha this (ih HL.2) },
  replace HL := HL.1, clear ih tl,
  suffices : ∃ L : list R,
    (∀ x ∈ L, x ∈ s) ∧ (list.prod hd = list.prod L ∨ list.prod hd = -list.prod L),
  { rcases this with ⟨L, HL', HP | HP⟩,
    { rw HP, clear HP HL hd, induction L with hd tl ih, { exact h1 },
      rw list.forall_mem_cons at HL',
      rw list.prod_cons,
      exact hs _ HL'.1 _ (ih HL'.2) },
    rw HP, clear HP HL hd, induction L with hd tl ih, { exact hneg1 },
    rw [list.prod_cons, neg_mul_eq_mul_neg],
    rw list.forall_mem_cons at HL',
    exact hs _ HL'.1 _ (ih HL'.2) },
  induction hd with hd tl ih,
  { exact ⟨[], list.forall_mem_nil _, or.inl rfl⟩ },
  rw list.forall_mem_cons at HL,
  rcases ih HL.2 with ⟨L, HL', HP | HP⟩; cases HL.1 with hhd hhd,
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inl $
      by rw [list.prod_cons, list.prod_cons, HP]⟩ },
  { exact ⟨L, HL', or.inr $ by rw [list.prod_cons, hhd, neg_one_mul, HP]⟩ },
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inr $
      by rw [list.prod_cons, list.prod_cons, HP, neg_mul_eq_mul_neg]⟩ },
  { exact ⟨L, HL', or.inl $ by rw [list.prod_cons, hhd, HP, neg_one_mul, neg_neg]⟩ }
end

instance : is_subring (closure s) :=
{ one_mem := add_group.mem_closure is_submonoid.one_mem,
  mul_mem := λ a b ha hb, add_group.in_closure.rec_on hb
    (λ b hb, add_group.in_closure.rec_on ha
      (λ a ha, add_group.subset_closure (is_submonoid.mul_mem ha hb))
      ((zero_mul b).symm ▸ is_add_submonoid.zero_mem)
      (λ a ha hab, (neg_mul_eq_neg_mul a b) ▸ is_add_subgroup.neg_mem hab)
      (λ a c ha hc hab hcb, (add_mul a c b).symm ▸ is_add_submonoid.add_mem hab hcb))
    ((mul_zero a).symm ▸ is_add_submonoid.zero_mem)
    (λ b hb hab, (neg_mul_eq_mul_neg a b) ▸ is_add_subgroup.neg_mem hab)
    (λ b c hb hc hab hac, (mul_add a b c).symm ▸ is_add_submonoid.add_mem hab hac),
  .. add_group.closure.is_add_subgroup _ }

theorem mem_closure {a : R} : a ∈ s → a ∈ closure s :=
add_group.mem_closure ∘ @monoid.subset_closure _ _ _ _

theorem subset_closure : s ⊆ closure s :=
λ _, mem_closure

theorem closure_subset {t : set R} [is_subring t] : s ⊆ t → closure s ⊆ t :=
add_group.closure_subset ∘ monoid.closure_subset

theorem closure_subset_iff (s t : set R) [is_subring t] : closure s ⊆ t ↔ s ⊆ t :=
(add_group.closure_subset_iff _ t).trans
  ⟨set.subset.trans monoid.subset_closure, monoid.closure_subset⟩

theorem closure_mono {s t : set R} (H : s ⊆ t) : closure s ⊆ closure t :=
closure_subset $ set.subset.trans H subset_closure

lemma image_closure {S : Type*} [ring S] (f : R →+* S) (s : set R) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { rw [f.map_one], apply is_submonoid.one_mem },
    { rw [f.map_neg, f.map_one],
      apply is_add_subgroup.neg_mem, apply is_submonoid.one_mem },
    { rw [f.map_mul],
      apply is_submonoid.mul_mem; solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [f.map_add], apply is_add_submonoid.add_mem, assumption' },
  end
  (closure_subset $ set.image_subset _ subset_closure)

end ring


import ground_zero.proto ground_zero.meta.hott_theory

namespace ground_zero.types
universes u v

theorem K {α : Sort u} {a b : α} (p q : a = b) : p = q :=
by trivial

inductive eq {α : Sort u} (a : α) : α → Sort u
| refl : eq a

attribute [refl] eq.refl

hott theory
notation a ` = ` b ` :> ` α := @eq α a b

/- fails!
theorem K₁ {α : Sort u} {a b : α} (p q : a = b :> α) :
  p = q :> (a = b :> α) :=
by trivial
-/

namespace eq
  @[inline] def rfl {α : Sort u} {a : α} : a = a :> α :=
  eq.refl a

  @[trans] def trans {α : Sort u} {a b c : α}
    (p : a = b :> α) (q : b = c :> α) : a = c :> α :=
  begin induction p, assumption end

  @[symm] def symm {α : Sort u} {a b : α} (p : a = b :> α) :
    b = a :> α :=
  begin induction p, reflexivity end

  infixr ` ⬝ ` := trans
  postfix ⁻¹ := symm

  def comp_inv {α : Sort u} {a b : α} (p : a = b :> α) :
    p ⬝ p⁻¹ = eq.refl a :> a = a :> α :=
  begin induction p, trivial end

  def inv_comp {α : Sort u} {a b : α} (p : a = b :> α) :
    p⁻¹ ⬝ p = eq.refl b :> b = b :> α :=
  begin induction p, trivial end

  def refl_left {α : Sort u} {a b : α} (p : a = b :> α) :
    eq.refl a ⬝ p = p :> a = b :> α :=
  begin induction p, trivial end

  def refl_right {α : Sort u} {a b : α} (p : a = b :> α) :
    p ⬝ eq.refl b = p :> a = b :> α :=
  begin induction p, trivial end

  def refl_twice {α : Sort u} {a b : α} (p : a = b :> α) :
    rfl ⬝ p ⬝ rfl = p :> a = b :> α :=
  begin induction p, trivial end

  def explode_inv {α : Sort u} {a b c : α}
    (p : a = b :> α) (q : b = c :> α) :
    (p ⬝ q)⁻¹ = q⁻¹ ⬝ p⁻¹ :> c = a :> α :=
  begin induction p, induction q, trivial end

  def inv_inv {α : Sort u} {a b : α}
    (p : a = b :> α) : (p⁻¹)⁻¹ = p :> a = b :> α :=
  begin induction p, trivial end

  def assoc {α : Sort u} {a b c d : α}
    (p : a = b :> α) (q : b = c :> α) (r : c = d :> α) :
    p ⬝ (q ⬝ r) = (p ⬝ q) ⬝ r := begin
    induction p, induction q, induction r,
    trivial
  end

  def mpr {α β : Sort u} (p : α = β) : β → α :=
  begin induction p, intro x, exact x end

  def map {α : Sort u} {β : Sort v} {a b : α}
    (f : α → β) (p : a = b :> α) : f a = f b :> β :=
  begin induction p, reflexivity end
  infix [parsing_only] ` # ` := map

  section
    variables {α : Sort u} {β : Sort v} {a b : α}
              (f : α → β) (p : a = b :> α)

    abbreviation cong := map f p
    abbreviation ap := map f p
  end

  def ap₂ {α : Sort u} {β : Sort v} {a b : α}
    {p q : a = b :> α} (f : α → β)
    (r : p = q :> a = b :> α) :
    f # p = f # q :> f a = f b :> β :=
  begin induction r, reflexivity end

  class dotted (space : Sort u) :=
  (point : space)

  structure pointed :=
  (space : Sort u) (point : space)

  def loop_space (X : pointed) : pointed :=
  ⟨X.point = X.point :> X.space, eq.refl X.point⟩

  def iterated_loop_space : pointed → ℕ → pointed
  | X 0 := X
  | X (n + 1) := iterated_loop_space (loop_space X) n

  def loop_pointed_space (α : Sort u) [h : dotted α] :=
  iterated_loop_space ⟨α, dotted.point α⟩

  notation `Ω` `[` n `]` `, ` X := (iterated_loop_space X n).space
  notation `Θ` `[` n `]` `, ` X := (iterated_loop_space X n).point

  notation `Ω¹` X := (loop_pointed_space X 1).space
end eq

namespace not
  notation `¬` a := a → empty
  notation a ` ≠ ` b := ¬(a = b :> _)
end not

namespace whiskering
  variables {α : Sort u} {a b c : α}
  variables {p q : a = b :> α} {r s : b = c :> α}
  variables {ν : p = q} {κ : r = s}

  def right_whs (ν : p = q) (r : b = c) : p ⬝ r = q ⬝ r := begin
    induction r,
    exact (eq.refl_right p) ⬝ ν ⬝ (eq.refl_right q)⁻¹
  end
  infix ` ⬝ᵣ `:60 := right_whs

  def left_whs (q : a = b) (κ : r = s) : q ⬝ r = q ⬝ s := begin
    induction q,
    exact (eq.refl_left r) ⬝ κ ⬝ (eq.refl_left s)⁻¹
  end
  infix ` ⬝ₗ `:60 := left_whs

  def horizontal_comp₁ (ν : p = q) (κ : r = s) :=
  (ν ⬝ᵣ r) ⬝ (q ⬝ₗ κ)
  infix ` ⋆ `:65 := horizontal_comp₁

  def horizontal_comp₂ (ν : p = q) (κ : r = s) :=
  (p ⬝ₗ κ) ⬝ (ν ⬝ᵣ s)
  infix ` ⋆′ `:65 := horizontal_comp₂

  lemma comp_uniq : ν ⋆ κ = ν ⋆′ κ := begin
    induction p, induction r, induction ν, induction κ,
    reflexivity
  end

  lemma loop₁ {α : Sort u} {a : α}
    {ν κ : eq.refl a = eq.refl a} :
    ν ⬝ κ = ν ⋆ κ := begin
    symmetry, unfold horizontal_comp₁,
    unfold right_whs, unfold left_whs,
    transitivity,
    { apply eq.map, apply eq.refl_twice },
    apply eq.map (λ p, p ⬝ κ), apply eq.refl_twice
  end

  lemma loop₂ {α : Sort u} {a : α}
    {ν κ : eq.refl a = eq.refl a} :
    ν ⋆′ κ = κ ⬝ ν := begin
    unfold horizontal_comp₂,
    unfold right_whs, unfold left_whs,
    transitivity,
    { apply eq.map, apply eq.refl_twice },
    apply eq.map (λ p, p ⬝ ν), apply eq.refl_twice
  end

  theorem «Eckmann–Hilton argument» {α : Sort u} {a : α}
    (ν κ : eq.refl a = eq.refl a) : ν ⬝ κ = κ ⬝ ν :=
  loop₁ ⬝ comp_uniq ⬝ loop₂
end whiskering

end ground_zero.types