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

! This file was ported from Lean 3 source module algebra.hom.freiman
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.BigOperators.Multiset.Basic
import Mathlib.Data.FunLike.Basic

/-!
# Freiman homomorphisms

In this file, we define Freiman homomorphisms. A `n`-Freiman homomorphism on `A` is a function
`f : α → β` such that `f (x₁) * ... * f (xₙ) = f (y₁) * ... * f (yₙ)` for all
`x₁, ..., xₙ, y₁, ..., yₙ ∈ A` such that `x₁ * ... * xₙ = y₁ * ... * yₙ`. In particular, any
`MulHom` is a Freiman homomorphism.

They are of interest in additive combinatorics.

## Main declaration

* `FreimanHom`: Freiman homomorphism.
* `AddFreimanHom`: Additive Freiman homomorphism.

## Notation

* `A →*[n] β`: Multiplicative `n`-Freiman homomorphism on `A`
* `A →+[n] β`: Additive `n`-Freiman homomorphism on `A`

## Implementation notes

In the context of combinatorics, we are interested in Freiman homomorphisms over sets which are not
necessarily closed under addition/multiplication. This means we must parametrize them with a set in
an `AddMonoid`/`Monoid` instead of the `AddMonoid`/`Monoid` itself.

## References

[Yufei Zhao, *18.225: Graph Theory and Additive Combinatorics*](https://yufeizhao.com/gtac/)

## TODO

`MonoidHom.toFreimanHom` could be relaxed to `MulHom.toFreimanHom` by proving
`(s.map f).prod = (t.map f).prod` directly by induction instead of going through `f s.prod`.

Define `n`-Freiman isomorphisms.

Affine maps induce Freiman homs. Concretely, provide the `AddFreimanHomClass (α →ₐ[𝕜] β) A β n`
instance.
-/

open Multiset

variable {F α β γ δ G : Type _}

/-- An additive `n`-Freiman homomorphism is a map which preserves sums of `n` elements. -/
structure AddFreimanHom (A : Set α) (β : Type _) [AddCommMonoid α] [AddCommMonoid β] (n : ℕ) where
  /-- The underlying function. -/
  toFun : α → β
  /-- An additive `n`-Freiman homomorphism preserves sums of `n` elements. -/
  map_sum_eq_map_sum' {s t : Multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A)
    (hs : Multiset.card s = n) (ht : Multiset.card t = n) (h : s.sum = t.sum) :
    (s.map toFun).sum = (t.map toFun).sum
#align add_freiman_hom AddFreimanHom

/-- A `n`-Freiman homomorphism on a set `A` is a map which preserves products of `n` elements. -/
@[to_additive AddFreimanHom]
structure FreimanHom (A : Set α) (β : Type _) [CommMonoid α] [CommMonoid β] (n : ℕ) where
  /-- The underlying function. -/
  toFun : α → β
  /-- A `n`-Freiman homomorphism preserves products of `n` elements. -/
  map_prod_eq_map_prod' {s t : Multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A)
    (hs : Multiset.card s = n) (ht : Multiset.card t = n) (h : s.prod = t.prod) :
    (s.map toFun).prod = (t.map toFun).prod
#align freiman_hom FreimanHom

/- Porting note: local notation given a name, conflict with Algebra.Hom.GroupAction
 see https://github.com/leanprover/lean4/issues/2000 -/
@[inherit_doc]
notation:25 (name := «AddFreimanHomLocal≺») A " →+[" n:25 "] " β:0 => AddFreimanHom A β n

/- Porting note: local notation given a name, conflict with Algebra.Hom.GroupAction
 see https://github.com/leanprover/lean4/issues/2000 -/
@[inherit_doc]
notation:25 (name := «FreimanHomLocal≺») A " →*[" n:25 "] " β:0 => FreimanHom A β n

/-- `AddFreimanHomClass F A β n` states that `F` is a type of `n`-ary sums-preserving morphisms.
You should extend this class when you extend `AddFreimanHom`. -/
class AddFreimanHomClass (F : Type _) (A : outParam <| Set α) (β : outParam <| Type _)
  [AddCommMonoid α] [AddCommMonoid β] (n : ℕ) [FunLike F α fun _ => β] : Prop where
  /-- An additive `n`-Freiman homomorphism preserves sums of `n` elements. -/
  map_sum_eq_map_sum' (f : F) {s t : Multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A)
    (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : Multiset.card s = n) (ht : Multiset.card t = n)
    (h : s.sum = t.sum) :
    (s.map f).sum = (t.map f).sum
#align add_freiman_hom_class AddFreimanHomClass

/-- `FreimanHomClass F A β n` states that `F` is a type of `n`-ary products-preserving morphisms.
You should extend this class when you extend `FreimanHom`. -/
@[to_additive AddFreimanHomClass
      "`AddFreimanHomClass F A β n` states that `F` is a type of `n`-ary
      sums-preserving morphisms. You should extend this class when you extend `AddFreimanHom`."]
class FreimanHomClass (F : Type _) (A : outParam <| Set α) (β : outParam <| Type _) [CommMonoid α]
  [CommMonoid β] (n : ℕ) [FunLike F α fun _ => β] : Prop where
  /-- A `n`-Freiman homomorphism preserves products of `n` elements. -/
  map_prod_eq_map_prod' (f : F) {s t : Multiset α} (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A)
    (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A) (hs : Multiset.card s = n) (ht : Multiset.card t = n)
    (h : s.prod = t.prod) :
    (s.map f).prod = (t.map f).prod
#align freiman_hom_class FreimanHomClass

variable [FunLike F α fun _ => β]

section CommMonoid

variable [CommMonoid α] [CommMonoid β] [CommMonoid γ] [CommMonoid δ] [CommGroup G] {A : Set α}
  {B : Set β} {C : Set γ} {n : ℕ} {a b c d : α}

/- porting note: inserted following def & instance for consistent coercion behaviour,
see also Algebra.Hom.Group for similar -/
/-- Turn an element of a type `F` satisfying `FreimanHomClass F A β n` into an actual
`FreimanHom`. This is declared as the default coercion from `F` to `FreimanHom A β n`. -/
@[to_additive (attr := coe)
    " Turn an element of a type `F` satisfying `AddFreimanHomClass F A β n` into an actual
    `AddFreimanHom`. This is declared as the default coercion from `F` to `AddFreimanHom A β n`."]
def _root_.FreimanHomClass.toFreimanHom [FreimanHomClass F A β n] (f : F) : A →*[n] β where
  toFun := FunLike.coe f
  map_prod_eq_map_prod' := FreimanHomClass.map_prod_eq_map_prod' f

/-- Any type satisfying `SMulHomClass` can be cast into `MulActionHom` via
  `SMulHomClass.toMulActionHom`. -/
instance [FreimanHomClass F A β n] : CoeTC F (A →*[n] β) :=
  ⟨FreimanHomClass.toFreimanHom⟩

@[to_additive]
theorem map_prod_eq_map_prod [FreimanHomClass F A β n] (f : F) {s t : Multiset α}
    (hsA : ∀ ⦃x⦄, x ∈ s → x ∈ A) (htA : ∀ ⦃x⦄, x ∈ t → x ∈ A)
    (hs : Multiset.card s = n) (ht : Multiset.card t = n)
    (h : s.prod = t.prod) : (s.map f).prod = (t.map f).prod :=
  FreimanHomClass.map_prod_eq_map_prod' f hsA htA hs ht h
#align map_prod_eq_map_prod map_prod_eq_map_prod
#align map_sum_eq_map_sum map_sum_eq_map_sum

@[to_additive]
theorem map_mul_map_eq_map_mul_map [FreimanHomClass F A β 2] (f : F) (ha : a ∈ A) (hb : b ∈ A)
    (hc : c ∈ A) (hd : d ∈ A) (h : a * b = c * d) : f a * f b = f c * f d := by
  simp_rw [← prod_pair] at h⊢
  refine' map_prod_eq_map_prod f _ _ (card_pair _ _) (card_pair _ _) h <;> simp [ha, hb, hc, hd]
#align map_mul_map_eq_map_mul_map map_mul_map_eq_map_mul_map
#align map_add_map_eq_map_add_map map_add_map_eq_map_add_map

namespace FreimanHom

@[to_additive]
instance funLike : FunLike (A →*[n] β) α fun _ => β where
  coe := toFun
  coe_injective' f g h := by cases f; cases g; congr
#align freiman_hom.fun_like FreimanHom.funLike
#align add_freiman_hom.fun_like AddFreimanHom.funLike

@[to_additive addFreimanHomClass]
instance freimanHomClass : FreimanHomClass (A →*[n] β) A β n where
  map_prod_eq_map_prod' := map_prod_eq_map_prod'
#align freiman_hom.freiman_hom_class FreimanHom.freimanHomClass
#align add_freiman_hom.freiman_hom_class AddFreimanHom.addFreimanHomClass

-- porting note: not helpful in lean4
-- /-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
-- directly. -/
-- @[to_additive
--       "Helper instance for when there's too many metavariables to apply
--       `fun_like.has_coe_to_fun` directly."]
-- instance : CoeFun (A →*[n] β) fun _ => α → β :=
--   ⟨toFun⟩

initialize_simps_projections FreimanHom (toFun → apply)
initialize_simps_projections AddFreimanHom (toFun → apply)

@[to_additive (attr := simp)]
theorem toFun_eq_coe (f : A →*[n] β) : f.toFun = f :=
  rfl
#align freiman_hom.to_fun_eq_coe FreimanHom.toFun_eq_coe
#align add_freiman_hom.to_fun_eq_coe AddFreimanHom.toFun_eq_coe

@[to_additive (attr := ext)]
theorem ext ⦃f g : A →*[n] β⦄ (h : ∀ x, f x = g x) : f = g :=
  FunLike.ext f g h
#align freiman_hom.ext FreimanHom.ext
#align add_freiman_hom.ext AddFreimanHom.ext

@[to_additive (attr := simp)]
theorem coe_mk (f : α → β)
    (h :
      ∀ s t : Multiset α,
        (∀ ⦃x⦄, x ∈ s → x ∈ A) →
          (∀ ⦃x⦄, x ∈ t → x ∈ A) →
            Multiset.card s = n → Multiset.card t = n →
              s.prod = t.prod → (s.map f).prod = (t.map f).prod) :
    ⇑(mk f (h _ _)) = f :=
  rfl
#align freiman_hom.coe_mk FreimanHom.coe_mk
#align add_freiman_hom.coe_mk AddFreimanHom.coe_mk

@[to_additive (attr := simp)]
theorem mk_coe (f : A →*[n] β) (h) : mk f h = f :=
  ext fun _ => rfl
#align freiman_hom.mk_coe FreimanHom.mk_coe
#align add_freiman_hom.mk_coe AddFreimanHom.mk_coe

/-- The identity map from a commutative monoid to itself. -/
@[to_additive (attr := simps) "The identity map from an additive commutative monoid to itself."]
protected def id (A : Set α) (n : ℕ) : A →*[n] α where
  toFun x := x
  map_prod_eq_map_prod' _ _ _ _ h := by rw [map_id', map_id', h]
#align freiman_hom.id FreimanHom.id
#align add_freiman_hom.id AddFreimanHom.id
#align freiman_hom.id_apply FreimanHom.id_apply

/-- Composition of Freiman homomorphisms as a Freiman homomorphism. -/
@[to_additive "Composition of additive Freiman homomorphisms as an additive Freiman homomorphism."]
protected def comp (f : B →*[n] γ) (g : A →*[n] β) (hAB : A.MapsTo g B) : A →*[n] γ where
  toFun := f ∘ g
  map_prod_eq_map_prod' hsA htA hs ht h := by
    rw [← map_map, ← map_map]
    apply map_prod_eq_map_prod f _ _ ((card_map _ _).trans hs)
    · rwa [card_map]
    · apply (map_prod_eq_map_prod g hsA htA hs ht h)
    · simpa using fun a h => hAB (hsA h)
    · simpa using fun a h => hAB (htA h)
#align freiman_hom.comp FreimanHom.comp
#align add_freiman_hom.comp AddFreimanHom.comp

@[to_additive (attr := simp)]
theorem coe_comp (f : B →*[n] γ) (g : A →*[n] β) {hfg} : ⇑(f.comp g hfg) = f ∘ g :=
  rfl
#align freiman_hom.coe_comp FreimanHom.coe_comp
#align add_freiman_hom.coe_comp AddFreimanHom.coe_comp

@[to_additive]
theorem comp_apply (f : B →*[n] γ) (g : A →*[n] β) {hfg} (x : α) : f.comp g hfg x = f (g x) :=
  rfl
#align freiman_hom.comp_apply FreimanHom.comp_apply
#align add_freiman_hom.comp_apply AddFreimanHom.comp_apply

@[to_additive]
theorem comp_assoc (f : A →*[n] β) (g : B →*[n] γ) (h : C →*[n] δ) {hf hhg hgf}
    {hh : A.MapsTo (g.comp f hgf) C} : (h.comp g hhg).comp f hf = h.comp (g.comp f hgf) hh :=
  rfl
#align freiman_hom.comp_assoc FreimanHom.comp_assoc
#align add_freiman_hom.comp_assoc AddFreimanHom.comp_assoc

@[to_additive]
theorem cancel_right {g₁ g₂ : B →*[n] γ} {f : A →*[n] β} (hf : Function.Surjective f) {hg₁ hg₂} :
    g₁.comp f hg₁ = g₂.comp f hg₂ ↔ g₁ = g₂ :=
  ⟨fun h => ext <| hf.forall.2 <| FunLike.ext_iff.1 h, fun h => h ▸ rfl⟩
#align freiman_hom.cancel_right FreimanHom.cancel_right
#align add_freiman_hom.cancel_right AddFreimanHom.cancel_right

@[to_additive]
theorem cancel_right_on {g₁ g₂ : B →*[n] γ} {f : A →*[n] β} (hf : A.SurjOn f B) {hf'} :
    A.EqOn (g₁.comp f hf') (g₂.comp f hf') ↔ B.EqOn g₁ g₂ :=
  by simp [hf.cancel_right hf']
#align freiman_hom.cancel_right_on FreimanHom.cancel_right_on
#align add_freiman_hom.cancel_right_on AddFreimanHom.cancel_right_on

@[to_additive]
theorem cancel_left_on {g : B →*[n] γ} {f₁ f₂ : A →*[n] β} (hg : B.InjOn g) {hf₁ hf₂} :
    A.EqOn (g.comp f₁ hf₁) (g.comp f₂ hf₂) ↔ A.EqOn f₁ f₂ :=
  by simp [hg.cancel_left hf₁ hf₂]
#align freiman_hom.cancel_left_on FreimanHom.cancel_left_on
#align add_freiman_hom.cancel_left_on AddFreimanHom.cancel_left_on

@[to_additive (attr := simp)]
theorem comp_id (f : A →*[n] β) {hf} : f.comp (FreimanHom.id A n) hf = f :=
  ext fun _ => rfl
#align freiman_hom.comp_id FreimanHom.comp_id
#align add_freiman_hom.comp_id AddFreimanHom.comp_id

@[to_additive (attr := simp)]
theorem id_comp (f : A →*[n] β) {hf} : (FreimanHom.id B n).comp f hf = f :=
  ext fun _ => rfl
#align freiman_hom.id_comp FreimanHom.id_comp
#align add_freiman_hom.id_comp AddFreimanHom.id_comp

/-- `FreimanHom.const A n b` is the Freiman homomorphism sending everything to `b`. -/
@[to_additive "`AddFreimanHom.const An b` is the Freiman homomorphism sending everything to `b`."]
def const (A : Set α) (n : ℕ) (b : β) : A →*[n] β where
  toFun _ := b
  map_prod_eq_map_prod' _ _ hs ht _ := by
    simp only [map_const', hs, prod_replicate, ht]
#align freiman_hom.const FreimanHom.const
#align add_freiman_hom.const AddFreimanHom.const

@[to_additive (attr := simp)]
theorem const_apply (n : ℕ) (b : β) (x : α) : const A n b x = b :=
  rfl
#align freiman_hom.const_apply FreimanHom.const_apply
#align add_freiman_hom.const_apply AddFreimanHom.const_apply

@[to_additive (attr := simp)]
theorem const_comp (n : ℕ) (c : γ) (f : A →*[n] β) {hf} : (const B n c).comp f hf = const A n c :=
  rfl
#align freiman_hom.const_comp FreimanHom.const_comp
#align add_freiman_hom.const_comp AddFreimanHom.const_comp

/-- `1` is the Freiman homomorphism sending everything to `1`. -/
@[to_additive "`0` is the Freiman homomorphism sending everything to `0`."]
instance : One (A →*[n] β) :=
  ⟨const A n 1⟩

@[to_additive (attr := simp)]
theorem one_apply (x : α) : (1 : A →*[n] β) x = 1 :=
  rfl
#align freiman_hom.one_apply FreimanHom.one_apply
#align add_freiman_hom.zero_apply AddFreimanHom.zero_apply

@[to_additive (attr := simp)]
theorem one_comp (f : A →*[n] β) {hf} : (1 : B →*[n] γ).comp f hf = 1 :=
  rfl
#align freiman_hom.one_comp FreimanHom.one_comp
#align add_freiman_hom.zero_comp AddFreimanHom.zero_comp

@[to_additive]
instance : Inhabited (A →*[n] β) :=
  ⟨1⟩

/-- `f * g` is the Freiman homomorphism  sends `x` to `f x * g x`. -/
@[to_additive "`f + g` is the Freiman homomorphism sending `x` to `f x + g x`."]
instance : Mul (A →*[n] β) :=
  ⟨fun f g =>
    { toFun := fun x => f x * g x
      map_prod_eq_map_prod' := fun hsA htA hs ht h => by
          rw [prod_map_mul, prod_map_mul]
          rw [map_prod_eq_map_prod f hsA htA hs ht h]
          rw [map_prod_eq_map_prod g hsA htA hs ht h]}⟩

@[to_additive (attr := simp)]
theorem mul_apply (f g : A →*[n] β) (x : α) : (f * g) x = f x * g x :=
  rfl
#align freiman_hom.mul_apply FreimanHom.mul_apply
#align add_freiman_hom.add_apply AddFreimanHom.add_apply

@[to_additive]
theorem mul_comp (g₁ g₂ : B →*[n] γ) (f : A →*[n] β) {hg hg₁ hg₂} :
    (g₁ * g₂).comp f hg = g₁.comp f hg₁ * g₂.comp f hg₂ :=
  rfl
#align freiman_hom.mul_comp FreimanHom.mul_comp
#align add_freiman_hom.add_comp AddFreimanHom.add_comp

/-- If `f` is a Freiman homomorphism to a commutative group, then `f⁻¹` is the Freiman homomorphism
sending `x` to `(f x)⁻¹`. -/
@[to_additive
      "If `f` is a Freiman homomorphism to an additive commutative group, then `-f` is the
      Freiman homomorphism sending `x` to `-f x`."]
instance : Inv (A →*[n] G) :=
  ⟨fun f =>
    { toFun := fun x => (f x)⁻¹
      map_prod_eq_map_prod' := fun hsA htA hs ht h => by
        rw [prod_map_inv, prod_map_inv, map_prod_eq_map_prod f hsA htA hs ht h] }⟩

@[to_additive (attr := simp)]
theorem inv_apply (f : A →*[n] G) (x : α) : f⁻¹ x = (f x)⁻¹ :=
  rfl
#align freiman_hom.inv_apply FreimanHom.inv_apply
#align add_freiman_hom.neg_apply AddFreimanHom.neg_apply

@[to_additive (attr := simp)]
theorem inv_comp (f : B →*[n] G) (g : A →*[n] β) {hf hf'} : f⁻¹.comp g hf = (f.comp g hf')⁻¹ :=
  ext fun _ => rfl
#align freiman_hom.inv_comp FreimanHom.inv_comp
#align add_freiman_hom.neg_comp AddFreimanHom.neg_comp

/-- If `f` and `g` are Freiman homomorphisms to a commutative group, then `f / g` is the Freiman
homomorphism sending `x` to `f x / g x`. -/
@[to_additive
      "If `f` and `g` are additive Freiman homomorphisms to an additive commutative group,
      then `f - g` is the additive Freiman homomorphism sending `x` to `f x - g x`"]
instance : Div (A →*[n] G) :=
  ⟨fun f g =>
    { toFun := fun x => f x / g x
      map_prod_eq_map_prod' := fun hsA htA hs ht h => by
        rw [prod_map_div, prod_map_div, map_prod_eq_map_prod f hsA htA hs ht h,
          map_prod_eq_map_prod g hsA htA hs ht h] }⟩

@[to_additive (attr := simp)]
theorem div_apply (f g : A →*[n] G) (x : α) : (f / g) x = f x / g x :=
  rfl
#align freiman_hom.div_apply FreimanHom.div_apply
#align add_freiman_hom.sub_apply AddFreimanHom.sub_apply

@[to_additive (attr := simp)]
theorem div_comp (f₁ f₂ : B →*[n] G) (g : A →*[n] β) {hf hf₁ hf₂} :
    (f₁ / f₂).comp g hf = f₁.comp g hf₁ / f₂.comp g hf₂ :=
  ext fun _ => rfl
#align freiman_hom.div_comp FreimanHom.div_comp
#align add_freiman_hom.sub_comp AddFreimanHom.sub_comp

/-! ### Instances -/

/-- `A →*[n] β` is a `CommMonoid`. -/
@[to_additive "`α →+[n] β` is an `AddCommMonoid`."]
instance commMonoid : CommMonoid (A →*[n] β) where
  mul_assoc a b c := by
    ext
    apply mul_assoc
  one_mul a := by
    ext
    apply one_mul
  mul_one a := by
    ext
    apply mul_one
  mul_comm a b := by
    ext
    apply mul_comm
#align freiman_hom.comm_monoid FreimanHom.commMonoid
#align add_freiman_hom.add_comm_monoid AddFreimanHom.addCommMonoid

/-- If `β` is a commutative group, then `A →*[n] β` is a commutative group too. -/
@[to_additive
      "If `β` is an additive commutative group, then `A →*[n] β` is an additive commutative
      group too."]
instance commGroup {β} [CommGroup β]: CommGroup (A →*[n] β) :=
  { FreimanHom.commMonoid with
    div_eq_mul_inv := by
      intros
      ext
      apply div_eq_mul_inv
    mul_left_inv := by
      intros
      ext
      apply mul_left_inv}
#align freiman_hom.comm_group FreimanHom.commGroup
#align add_freiman_hom.add_comm_group AddFreimanHom.addCommGroup

end FreimanHom

/-! ### Hom hierarchy -/

--TODO: change to `MonoidHomClass F A β → FreimanHomClass F A β n` once `map_multiset_prod` is
-- generalized
/-- A monoid homomorphism is naturally a `FreimanHom` on its entire domain.

We can't leave the domain `A : Set α` of the `FreimanHom` a free variable, since it wouldn't be
inferrable. -/
@[to_additive AddMonoidHom.addFreimanHomClass
      " An additive monoid homomorphism is naturally an `AddFreimanHom` on its entire
      domain.

      We can't leave the domain `A : Set α` of the `AddFreimanHom` a free variable, since it
      wouldn't be inferrable."]
instance MonoidHom.freimanHomClass : FreimanHomClass (α →* β) Set.univ β n where
  map_prod_eq_map_prod' f s t _ _ _ _ h := by
    rw [← f.map_multiset_prod, h, f.map_multiset_prod]
#align monoid_hom.freiman_hom_class MonoidHom.freimanHomClass
#align add_monoid_hom.freiman_hom_class AddMonoidHom.addFreimanHomClass

/-- A `MonoidHom` is naturally a `FreimanHom`. -/
@[to_additive AddMonoidHom.toAddFreimanHom
      "An `AddMonoidHom` is naturally an `AddFreimanHom`"]
def MonoidHom.toFreimanHom (A : Set α) (n : ℕ) (f : α →* β) : A →*[n] β where
  toFun := f
  map_prod_eq_map_prod' _ _ :=
    map_prod_eq_map_prod f (fun _ _ => Set.mem_univ _) fun _ _ => Set.mem_univ _
#align monoid_hom.to_freiman_hom MonoidHom.toFreimanHom
#align add_monoid_hom.to_add_freiman_hom AddMonoidHom.toAddFreimanHom

@[to_additive (attr := simp) toAddFreimanHom_coe]
theorem MonoidHom.toFreimanHom_coe (f : α →* β) : (f.toFreimanHom A n : α → β) = f :=
  rfl
#align monoid_hom.to_freiman_hom_coe MonoidHom.toFreimanHom_coe
#align add_monoid_hom.to_freiman_hom_coe AddMonoidHom.toAddFreimanHom_coe

@[to_additive AddMonoidHom.toAddFreimanHom_injective]
theorem MonoidHom.toFreimanHom_injective :
    Function.Injective (MonoidHom.toFreimanHom A n : (α →* β) → A →*[n] β) := fun f g h =>
   by rwa [toFreimanHom, toFreimanHom, FreimanHom.mk.injEq, FunLike.coe_fn_eq] at h
#align monoid_hom.to_freiman_hom_injective MonoidHom.toFreimanHom_injective
#align add_monoid_hom.to_freiman_hom_injective AddMonoidHom.toAddFreimanHom_injective

end CommMonoid

section CancelCommMonoid

variable [CommMonoid α] [CancelCommMonoid β] {A : Set α} {m n : ℕ}

@[to_additive]
theorem map_prod_eq_map_prod_of_le [FreimanHomClass F A β n] (f : F) {s t : Multiset α}
    (hsA : ∀ x ∈ s, x ∈ A) (htA : ∀ x ∈ t, x ∈ A)
    (hs : Multiset.card s = m) (ht : Multiset.card t = m)
    (hst : s.prod = t.prod) (h : m ≤ n) : (s.map f).prod = (t.map f).prod := by
  obtain rfl | hm := m.eq_zero_or_pos
  · rw [card_eq_zero] at hs ht
    rw [hs, ht]
  simp [← hs, card_pos_iff_exists_mem] at hm
  obtain ⟨a, ha⟩ := hm
  suffices
    ((s + Multiset.replicate (n - m) a).map f).prod =
      ((t + Multiset.replicate (n - m) a).map f).prod by
    simp_rw [Multiset.map_add, prod_add] at this
    exact mul_right_cancel this
  replace ha := hsA _ ha
  apply map_prod_eq_map_prod f (A := A) (β := β) (n := n) (fun x hx => _) (fun x hx => _) _ _ _
  -- porting note: below could be golfed when wlog is available
  · intro x hx
    rw [mem_add] at hx
    cases' hx with hx hx
    · exact hsA x hx
    · rwa [eq_of_mem_replicate hx]
  · intro x hx
    rw [mem_add] at hx
    cases' hx with hx hx
    · exact htA x hx
    · rwa [eq_of_mem_replicate hx]
  · rw [_root_.map_add, card_replicate, hs]; simp [h]
  · rw [_root_.map_add, card_replicate, ht]; simp [h]
  · rw [prod_add, prod_add, hst]

#align map_prod_eq_map_prod_of_le map_prod_eq_map_prod_of_le
#align map_sum_eq_map_sum_of_le map_sum_eq_map_sum_of_le

/-- `α →*[n] β` is naturally included in  `A →*[m] β` for any `m ≤ n`. -/
@[to_additive AddFreimanHom.toAddFreimanHom
      "`α →+[n] β` is naturally included in  `α →+[m] β`
      for any `m ≤ n`"]
def FreimanHom.toFreimanHom (h : m ≤ n) (f : A →*[n] β) : A →*[m] β where
  toFun := f
  map_prod_eq_map_prod' hsA htA hs ht hst := map_prod_eq_map_prod_of_le f hsA htA hs ht hst h
#align freiman_hom.to_freiman_hom FreimanHom.toFreimanHom
#align add_freiman_hom.to_add_freiman_hom AddFreimanHom.toAddFreimanHom

/-- A `n`-Freiman homomorphism is also a `m`-Freiman homomorphism for any `m ≤ n`. -/
@[to_additive AddFreimanHom.addFreimanHomClass_of_le
      "An additive `n`-Freiman homomorphism is
      also an additive `m`-Freiman homomorphism for any `m ≤ n`."]
theorem FreimanHom.FreimanHomClass_of_le [FreimanHomClass F A β n] (h : m ≤ n) :
    FreimanHomClass F A β m where
  map_prod_eq_map_prod' f _ _ hsA htA hs ht hst :=
    map_prod_eq_map_prod_of_le f hsA htA hs ht hst h
#align freiman_hom.freiman_hom_class_of_le FreimanHom.FreimanHomClass_of_le
#align add_freiman_hom.add_freiman_hom_class_of_le AddFreimanHom.addFreimanHomClass_of_le

@[to_additive (attr := simp) AddFreimanHom.toAddFreimanHom_coe]
theorem FreimanHom.toFreimanHom_coe (h : m ≤ n) (f : A →*[n] β) :
    (f.toFreimanHom h : α → β) = f :=
  rfl
#align freiman_hom.to_freiman_hom_coe FreimanHom.toFreimanHom_coe
#align add_freiman_hom.to_add_freiman_hom_coe AddFreimanHom.toAddFreimanHom_coe

@[to_additive AddFreimanHom.toAddFreimanHom_injective]
theorem FreimanHom.toFreimanHom_injective (h : m ≤ n) :
    Function.Injective (FreimanHom.toFreimanHom h : (A →*[n] β) → A →*[m] β) := fun f g hfg =>
  FreimanHom.ext <| by convert FunLike.ext_iff.1 hfg using 0
#align freiman_hom.to_freiman_hom_injective FreimanHom.toFreimanHom_injective
#align add_freiman_hom.to_freiman_hom_injective AddFreimanHom.toAddFreimanHom_injective

end CancelCommMonoid


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

! This file was ported from Lean 3 source module data.int.cast.prod
! leanprover-community/mathlib commit ee0c179cd3c8a45aa5bffbf1b41d8dbede452865
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Int.Cast.Lemmas
import Mathlib.Data.Nat.Cast.Prod

/-!
# The product of two `AddGroupWithOne`s.
-/

namespace Prod

variable {α β : Type _} [AddGroupWithOne α] [AddGroupWithOne β]

instance : AddGroupWithOne (α × β) :=
  { Prod.instAddMonoidWithOneProd, Prod.instAddGroupSum with
    intCast := fun n => (n, n)
    intCast_ofNat := fun _ => by simp; rfl
    intCast_negSucc := fun _ => by simp; rfl }

@[simp]
theorem fst_intCast (n : ℤ) : (n : α × β).fst = n :=
  rfl
#align prod.fst_int_cast Prod.fst_intCast

@[simp]
theorem snd_intCast (n : ℤ) : (n : α × β).snd = n :=
  rfl
#align prod.snd_int_cast Prod.snd_intCast

end Prod


import lambda_calculus.utlc.basic
import lambda_calculus.utlc.reduction
import lambda_calculus.utlc.beta.basic
import lambda_calculus.utlc.beta.parallel
import logic.relation

namespace lambda_calculus
namespace utlc
namespace β

local notation a `[` b `:=` c  `]` : 70 := has_substitution.substitution a b c

theorem β_of_parallel {f g : utlc}: f →∥ g → f ↠β g :=
begin
  intro pfg,
  induction f generalizing g,
  { simp at pfg, simp [← pfg] },
  { cases g,
    all_goals { simp at pfg },
    any_goals { contradiction },
    apply lambda_reduction_lambda,
    apply f_ih pfg },
  { cases parallel.dot_step_cases pfg with h h,
    all_goals { rcases h with ⟨x, y, hfx, hfy, hgxy⟩ },
    { rw [hgxy],
      apply dot_reduction_dot (f_ih_f hfx) (f_ih_g hfy) },
    rw [hgxy],
    simp,
    apply dot_reduction_substitution,
    apply f_ih_f hfx,
    apply f_ih_g hfy }
end

theorem parallel_of_β {f g : utlc}: f →β g → f →∥ g :=
begin
  induction f using lambda_calculus.utlc.notation_induction_on generalizing g,
  { simp },
  { intro hfg,
    rcases lambda_step_exists hfg with ⟨x, hgx, hfx⟩,
    rw [hgx],
    exact parallel.lambda_step_lambda (f_ih hfx) },
  { intro hfg,
    obtain hfg|hfg|hfg := dot_step_cases hfg;
    rcases hfg with ⟨x, hgx, hfx⟩;
    rw [hgx],
    { exact parallel.dot_step_substitution _ (parallel.step_refl _) (parallel.step_refl _) hfx },
    all_goals { apply parallel.dot_step_dot },
    apply f_ih_f hfx,
    refl,
    refl,
    apply f_ih_g hfx }
end

theorem parallel_iff_β {f g : utlc}: f ↠∥ g ↔ f ↠β g :=
begin
  split;
  intro p;
  induction p with b c pb pbc fb,
  { refl },
  { exact trans fb (β_of_parallel pbc) },
  { refl },
  { exact trans fb (relation.refl_trans_gen.single (parallel_of_β pbc)) }
end

theorem church_rosser {a b c : utlc} (hab : a ↠β b) (hac : a ↠β c): b ≡β c :=
begin
  unfold relation.join,
  rw [← parallel_iff_β] at hab hac,
  cases parallel.church_rosser hab hac with d hd,
  use d,
  simp only [parallel_iff_β] at hd,
  apply hd,
end

@[refl]
theorem equiv_refl (f : utlc): f ≡β f :=
  ⟨f, relation.refl_trans_gen.refl, relation.refl_trans_gen.refl⟩

@[symm]
theorem equiv_symm {a b: utlc}: a ≡β b → b ≡β a :=
by apply relation.symmetric_join

@[trans]
theorem equiv_trans {a b c : utlc}: a ≡β b → b ≡β c → a ≡β c :=
by apply relation.transitive_join (@relation.refl_trans_gen.trans _ _) @church_rosser

theorem lambda_equiv_lambda {f g : utlc}: f ≡β g → Λ f ≡β Λ g :=
begin
  intro p,
  cases p with c p,
  exact ⟨Λ c, lambda_reduction_lambda p.left, lambda_reduction_lambda p.right⟩
end

theorem dot_equiv_dot {f f' g g': utlc}: f ≡β f' → g ≡β g' → f·g ≡β f'·g' :=
begin
  intros p q,
  cases p with c p,
  cases q with d q,
  exact ⟨c·d, dot_reduction_dot p.left q.left, dot_reduction_dot p.right q.right⟩
end

theorem dot_equiv_dot_left {f f' g: utlc}: f ≡β f' → f·g ≡β f'·g :=
  λ p, dot_equiv_dot p (by refl)

theorem dot_equiv_dot_right {f g g': utlc}: g ≡β g' → f·g ≡β f·g' :=
  dot_equiv_dot (by refl)

theorem reduced_reduction_inj {f g: utlc}: reduced f → f ↠β g → f = g :=
begin
  intros hf p,
  induction p with x y hx hy fx,
  { refl },
  rw [←fx] at *,
  exfalso,
  apply (reduced_of_not_reduction _).mp hf _ hy
end

theorem reduced_equiv_inj {f g: utlc}: reduced f → reduced g → f ≡β g → f = g :=
begin
  intros hf hg p,
  cases p with x p,
  rw [reduced_reduction_inj hf p.left, reduced_reduction_inj hg p.right]
end

end β
end utlc
end lambda_calculus


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

import category_theory.preadditive.injective
import algebra.category.Module.epi_mono
import ring_theory.ideal.basic
import linear_algebra.linear_pmap

/-!
# Injective modules

## Main definitions

* `module.injective`: an `R`-module `Q` is injective if and only if every injective `R`-linear
  map descends to a linear map to `Q`, i.e. in the following diagram, if `f` is injective then there
  is an `R`-linear map `h : Y ⟶ Q` such that `g = h ∘ f`
  ```
  X --- f ---> Y
  |
  | g
  v
  Q
  ```
* `module.Baer`: an `R`-module `Q` satisfies Baer's criterion if any `R`-linear map from an
  `ideal R` extends to an `R`-linear map `R ⟶ Q`

## Main statements

* `module.Baer.criterion`: an `R`-module is injective if it is Baer.

-/

noncomputable theory

universes u v

variables (R : Type u) [ring R] (Q : Type (max u v)) [add_comm_group Q] [module R Q]

/--An `R`-module `Q` is injective if and only if every injective `R`-linear map descends to a linear
map to `Q`, i.e. in the following diagram, if `f` is injective then there is an `R`-linear map
`h : Y ⟶ Q` such that `g = h ∘ f`
  ```
  X --- f ---> Y
  |
  | g
  v
  Q
  ```
-/
class module.injective : Prop :=
(out : ∀ (X Y : Type (max u v)) [add_comm_group X] [add_comm_group Y] [module R X] [module R Y]
  (f : X →ₗ[R] Y) (hf : function.injective f) (g : X →ₗ[R] Q),
  ∃ (h : Y →ₗ[R] Q), ∀ x, h (f x) = g x)

lemma module.injective_object_of_injective_module [module.injective.{u v} R Q] :
  category_theory.injective.{max u v} (⟨Q⟩ : Module.{max u v} R) :=
{ factors := λ X Y g f mn, begin
    rcases module.injective.out X Y f ((Module.mono_iff_injective f).mp mn) g with ⟨h, eq1⟩,
    exact ⟨h, linear_map.ext eq1⟩,
  end }

lemma module.injective_module_of_injective_object
  [category_theory.injective.{max u v} (⟨Q⟩ : Module.{max u v} R)] :
  module.injective.{u v} R Q :=
{ out := λ X Y ins1 ins2 ins3 ins4 f hf g, begin
    resetI,
    rcases @category_theory.injective.factors (Module R) _ ⟨Q⟩ _ ⟨X⟩ ⟨Y⟩ g f
      ((Module.mono_iff_injective _).mpr hf) with ⟨h, rfl⟩,
    exact ⟨h, λ x, rfl⟩
  end }

lemma module.injective_iff_injective_object :
  module.injective.{u v} R Q ↔ category_theory.injective.{max u v} (⟨Q⟩ : Module.{max u v} R) :=
⟨λ h, @@module.injective_object_of_injective_module R _ Q _ _ h,
 λ h, @@module.injective_module_of_injective_object R _ Q _ _ h⟩

/--An `R`-module `Q` satisfies Baer's criterion if any `R`-linear map from an `ideal R` extends to
an `R`-linear map `R ⟶ Q`-/
def module.Baer : Prop := ∀ (I : ideal R) (g : I →ₗ[R] Q), ∃ (g' : R →ₗ[R] Q),
  ∀ (x : R) (mem : x ∈ I), g' x = g ⟨x, mem⟩

namespace module.Baer

variables {R Q} {M N : Type (max u v)} [add_comm_group M] [add_comm_group N]
variables [module R M] [module R N] (i : M →ₗ[R] N) (f : M →ₗ[R] Q)

/-- If we view `M` as a submodule of `N` via the injective linear map `i : M ↪ N`, then a submodule
between `M` and `N` is a submodule `N'` of `N`. To prove Baer's criterion, we need to consider
pairs of `(N', f')` such that `M ≤ N' ≤ N` and `f'` extends `f`. -/
structure extension_of extends linear_pmap R N Q :=
(le : i.range ≤ domain)
(is_extension : ∀ (m : M), f m = to_linear_pmap ⟨i m, le ⟨m, rfl⟩⟩)
section ext

variables {i f}

@[ext] lemma extension_of.ext {a b : extension_of i f}
  (domain_eq : a.domain = b.domain)
  (to_fun_eq : ∀ ⦃x : a.domain⦄ ⦃y : b.domain⦄,
    (x : N) = y → a.to_linear_pmap x = b.to_linear_pmap y) : a = b :=
begin
  rcases a with ⟨a, a_le, e1⟩,
  rcases b with ⟨b, b_le, e2⟩,
  congr,
  exact linear_pmap.ext domain_eq to_fun_eq,
end

lemma extension_of.ext_iff {a b : extension_of i f} :
  a = b ↔ ∃ (domain_eq : a.domain = b.domain),
    ∀ ⦃x : a.domain⦄ ⦃y : b.domain⦄, (x : N) = y → a.to_linear_pmap x = b.to_linear_pmap y :=
⟨λ r, r ▸ ⟨rfl, λ x y h, congr_arg a.to_fun $ by exact_mod_cast h⟩,
 λ ⟨h1, h2⟩, extension_of.ext h1 h2⟩

end ext

instance : has_inf (extension_of i f) :=
{ inf := λ X1 X2,
  { le := λ x hx, (begin
      rcases hx with ⟨x, rfl⟩,
      refine ⟨X1.le (set.mem_range_self _), X2.le (set.mem_range_self _), _⟩,
      rw [← X1.is_extension x, ← X2.is_extension x],
    end : x ∈ X1.to_linear_pmap.eq_locus X2.to_linear_pmap),
    is_extension := λ m, X1.is_extension _,
    .. (X1.to_linear_pmap ⊓ X2.to_linear_pmap)} }

instance : semilattice_inf (extension_of i f) :=
function.injective.semilattice_inf extension_of.to_linear_pmap
  (λ X Y h, extension_of.ext (by rw h) $ λ x y h', by { induction h, congr, exact_mod_cast h' }) $
    λ X Y, linear_pmap.ext rfl $ λ x y h, by { congr, exact_mod_cast h }

variables {R i f}

lemma chain_linear_pmap_of_chain_extension_of
  {c : set (extension_of i f)} (hchain : is_chain (≤) c) :
  (is_chain (≤) $ (λ x : extension_of i f, x.to_linear_pmap) '' c) :=
begin
  rintro _ ⟨a, a_mem, rfl⟩ _ ⟨b, b_mem, rfl⟩ neq,
  exact hchain a_mem b_mem (ne_of_apply_ne _ neq),
end

/-- The maximal element of every nonempty chain of `extension_of i f`. -/
def extension_of.max {c : set (extension_of i f)} (hchain : is_chain (≤) c)
  (hnonempty : c.nonempty) :
  extension_of i f :=
{ le := le_trans hnonempty.some.le $ (linear_pmap.le_Sup _ $ (set.mem_image _ _ _).mpr
    ⟨hnonempty.some, hnonempty.some_spec, rfl⟩).1,
  is_extension := λ m, begin
    refine eq.trans (hnonempty.some.is_extension m) _,
    symmetry,
    generalize_proofs _ h0 h1,
    exact linear_pmap.Sup_apply
      (is_chain.directed_on $ chain_linear_pmap_of_chain_extension_of hchain)
        ((set.mem_image _ _ _).mpr ⟨hnonempty.some, hnonempty.some_spec, rfl⟩) ⟨i m, h1⟩,
  end,
  ..linear_pmap.Sup _ (is_chain.directed_on $ chain_linear_pmap_of_chain_extension_of hchain) }

variables (i f) [fact $ function.injective i]

instance extension_of.inhabited : inhabited (extension_of i f) :=
{ default :=
  { domain := i.range,
    to_fun :=
    { to_fun := λ x, f x.2.some,
      map_add' := λ x y, begin
        have eq1  : _ + _ = (x + y).1 := congr_arg2 (+) x.2.some_spec y.2.some_spec,
        rw [← map_add, ← (x + y).2.some_spec] at eq1,
        rw [← fact.out (function.injective i) eq1, map_add],
      end,
      map_smul' := λ r x, begin
        have eq1 : r • _ = (r • x).1 := congr_arg ((•) r) x.2.some_spec,
        rw [← linear_map.map_smul, ← (r • x).2.some_spec] at eq1,
        rw [ring_hom.id_apply, ← fact.out (function.injective i) eq1, linear_map.map_smul],
      end },
    le := le_refl _,
    is_extension := λ m, begin
      simp only [linear_pmap.mk_apply, linear_map.coe_mk],
      congr,
      exact fact.out (function.injective i) (⟨i m, ⟨_, rfl⟩⟩ : i.range).2.some_spec.symm,
    end } }

/-- Since every nonempty chain has a maximal element, by Zorn's lemma, there is a maximal
`extension_of i f`. -/
def extension_of_max : extension_of i f :=
(@zorn_nonempty_partial_order (extension_of i f) _ ⟨inhabited.default⟩
  (λ c hchain hnonempty,
    ⟨extension_of.max hchain hnonempty, extension_of.le_max hchain hnonempty⟩)).some

lemma extension_of_max_is_max :
  ∀ (a : extension_of i f), extension_of_max i f ≤ a → a = extension_of_max i f :=
(@zorn_nonempty_partial_order (extension_of i f) _ ⟨inhabited.default⟩
  ((λ c hchain hnonempty,
    ⟨extension_of.max hchain hnonempty, extension_of.le_max hchain hnonempty⟩))).some_spec

variables {f}
private lemma extension_of_max_adjoin.aux1
  {y : N}
  (x : (extension_of_max i f).domain ⊔ submodule.span R {y}) :
  ∃ (a : (extension_of_max i f).domain) (b : R), x.1 = a.1 + b • y :=
begin
  have mem1 : x.1 ∈ (_ : set _) := x.2,
  rw submodule.coe_sup at mem1,
  rcases mem1 with ⟨a, b, a_mem, (b_mem : b ∈ (submodule.span R _ : submodule R N)), eq1⟩,
  rw submodule.mem_span_singleton at b_mem,
  rcases b_mem with ⟨z, eq2⟩,
  exact ⟨⟨a, a_mem⟩, z, by rw [← eq1, ← eq2]⟩,
end

/--If `x ∈ M ⊔ ⟨y⟩`, then `x = m + r • y`, `fst` pick an arbitrary such `m`.-/
def extension_of_max_adjoin.fst
  {y : N} (x : (extension_of_max i f).domain ⊔ submodule.span R {y}) :
  (extension_of_max i f).domain :=
(extension_of_max_adjoin.aux1 i x).some

/--If `x ∈ M ⊔ ⟨y⟩`, then `x = m + r • y`, `snd` pick an arbitrary such `r`.-/
def extension_of_max_adjoin.snd
  {y : N} (x : (extension_of_max i f).domain ⊔ submodule.span R {y}) : R :=
(extension_of_max_adjoin.aux1 i x).some_spec.some

lemma extension_of_max_adjoin.eqn
  {y : N} (x : (extension_of_max i f).domain ⊔ submodule.span R {y}) :
  ↑x = ↑(extension_of_max_adjoin.fst i x) + (extension_of_max_adjoin.snd i x) • y :=
(extension_of_max_adjoin.aux1 i x).some_spec.some_spec

variables (f)
/--the ideal `I = {r | r • y ∈ N}`-/
def extension_of_max_adjoin.ideal (y : N) :
  ideal R :=
(extension_of_max i f).domain.comap ((linear_map.id : R →ₗ[R] R).smul_right y)

/--A linear map `I ⟶ Q` by `x ↦ f' (x • y)` where `f'` is the maximal extension-/
def extension_of_max_adjoin.ideal_to (y : N) :
  extension_of_max_adjoin.ideal i f y →ₗ[R] Q :=
{ to_fun := λ z, (extension_of_max i f).to_linear_pmap ⟨(↑z : R) • y, z.prop⟩,
  map_add' := λ z1 z2, by simp [← (extension_of_max i f).to_linear_pmap.map_add, add_smul],
  map_smul' := λ z1 z2, by simp [← (extension_of_max i f).to_linear_pmap.map_smul, mul_smul]; refl }

/-- Since we assumed `Q` being Baer, the linear map `x ↦ f' (x • y) : I ⟶ Q` extends to `R ⟶ Q`,
call this extended map `φ`-/
def extension_of_max_adjoin.extend_ideal_to (h : module.Baer R Q) (y : N) : R →ₗ[R] Q :=
(h (extension_of_max_adjoin.ideal i f y) (extension_of_max_adjoin.ideal_to i f y)).some

lemma extension_of_max_adjoin.extend_ideal_to_is_extension (h : module.Baer R Q) (y : N) :
  ∀ (x : R) (mem : x ∈ extension_of_max_adjoin.ideal i f y),
  extension_of_max_adjoin.extend_ideal_to i f h y x =
  extension_of_max_adjoin.ideal_to i f y ⟨x, mem⟩ :=
(h (extension_of_max_adjoin.ideal i f y) (extension_of_max_adjoin.ideal_to i f y)).some_spec

lemma extension_of_max_adjoin.extend_ideal_to_wd' (h : module.Baer R Q) {y : N} (r : R)
  (eq1 : r • y = 0) :
  extension_of_max_adjoin.extend_ideal_to i f h y r = 0 :=
begin
  rw extension_of_max_adjoin.extend_ideal_to_is_extension i f h y r
    (by rw eq1; exact submodule.zero_mem _ : r • y ∈ _),
  simp only [extension_of_max_adjoin.ideal_to, linear_map.coe_mk, eq1, subtype.coe_mk,
    ← zero_mem_class.zero_def, (extension_of_max i f).to_linear_pmap.map_zero]
end

lemma extension_of_max_adjoin.extend_ideal_to_wd (h : module.Baer R Q) {y : N} (r r' : R)
  (eq1 : r • y = r' • y) :
  extension_of_max_adjoin.extend_ideal_to i f h y r =
  extension_of_max_adjoin.extend_ideal_to i f h y r' :=
begin
  rw [← sub_eq_zero, ← map_sub],
  convert extension_of_max_adjoin.extend_ideal_to_wd' i f h (r - r') _,
  rw [sub_smul, sub_eq_zero, eq1],
end

lemma extension_of_max_adjoin.extend_ideal_to_eq (h : module.Baer R Q) {y : N} (r : R)
  (hr : r • y ∈ (extension_of_max i f).domain) :
  extension_of_max_adjoin.extend_ideal_to i f h y r =
    (extension_of_max i f).to_linear_pmap ⟨r • y, hr⟩ :=
by simp only [extension_of_max_adjoin.extend_ideal_to_is_extension i f h _ _ hr,
  extension_of_max_adjoin.ideal_to, linear_map.coe_mk, subtype.coe_mk]

/--We can finally define a linear map `M ⊔ ⟨y⟩ ⟶ Q` by `x + r • y ↦ f x + φ r`
-/
def extension_of_max_adjoin.extension_to_fun (h : module.Baer R Q)
  {y : N} :
  (extension_of_max i f).domain ⊔ submodule.span R {y} → Q :=
λ x, (extension_of_max i f).to_linear_pmap (extension_of_max_adjoin.fst i x) +
  extension_of_max_adjoin.extend_ideal_to i f h y (extension_of_max_adjoin.snd i x)

lemma extension_of_max_adjoin.extension_to_fun_wd (h : module.Baer R Q)
  {y : N} (x : (extension_of_max i f).domain ⊔ submodule.span R {y})
  (a : (extension_of_max i f).domain) (r : R)
  (eq1 : ↑x = ↑a + r • y) :
  extension_of_max_adjoin.extension_to_fun i f h x =
    (extension_of_max i f).to_linear_pmap a +
      extension_of_max_adjoin.extend_ideal_to i f h y r :=
begin
  cases a with a ha,
  rw subtype.coe_mk at eq1,
  have eq2 : (extension_of_max_adjoin.fst i x - a : N) = (r - extension_of_max_adjoin.snd i x) • y,
  { rwa [extension_of_max_adjoin.eqn, ← sub_eq_zero, ←sub_sub_sub_eq,
      sub_eq_zero, ← sub_smul] at eq1 },
  have eq3 := extension_of_max_adjoin.extend_ideal_to_eq i f h (r - extension_of_max_adjoin.snd i x)
    (by rw ← eq2; exact submodule.sub_mem _ (extension_of_max_adjoin.fst i x).2 ha),
  simp only [map_sub, sub_smul, sub_eq_iff_eq_add] at eq3,
  unfold extension_of_max_adjoin.extension_to_fun,
  rw [eq3, ← add_assoc, ← (extension_of_max i f).to_linear_pmap.map_add, add_mem_class.mk_add_mk],
  congr,
  ext,
  rw [subtype.coe_mk, add_sub, ← eq1],
  exact eq_sub_of_add_eq (extension_of_max_adjoin.eqn _ _).symm
end

/--The linear map `M ⊔ ⟨y⟩ ⟶ Q` by `x + r • y ↦ f x + φ r` is an extension of `f`-/
def extension_of_max_adjoin (h : module.Baer R Q) (y : N) :
  extension_of i f :=
{ domain := (extension_of_max i f).domain ⊔ submodule.span R {y},
  le := le_trans (extension_of_max i f).le le_sup_left,
  to_fun :=
    { to_fun := extension_of_max_adjoin.extension_to_fun i f h,
      map_add' := λ a b, begin
        have eq1 : ↑a + ↑b =
          ↑((extension_of_max_adjoin.fst i a) + (extension_of_max_adjoin.fst i b)) +
          (extension_of_max_adjoin.snd i a + extension_of_max_adjoin.snd i b) • y,
        { rw [extension_of_max_adjoin.eqn, extension_of_max_adjoin.eqn, add_smul],
          abel, },
        rw [extension_of_max_adjoin.extension_to_fun_wd i f h (a + b) _ _ eq1,
          linear_pmap.map_add, map_add],
        unfold extension_of_max_adjoin.extension_to_fun,
        abel,
      end,
      map_smul' := λ r a, begin
        rw [ring_hom.id_apply],
        have eq1 : r • ↑a = ↑(r • extension_of_max_adjoin.fst i a) +
          (r • extension_of_max_adjoin.snd i a) • y,
        { rw [extension_of_max_adjoin.eqn, smul_add, smul_eq_mul, mul_smul],
          refl, },
        rw [extension_of_max_adjoin.extension_to_fun_wd i f h (r • a) _ _ eq1,
          linear_map.map_smul, linear_pmap.map_smul, ← smul_add],
        congr',
      end },
  is_extension := λ m, begin
    simp only [linear_pmap.mk_apply, linear_map.coe_mk],
    rw [(extension_of_max i f).is_extension, extension_of_max_adjoin.extension_to_fun_wd i f h
      _ ⟨i m, _⟩ 0 _, map_zero, add_zero],
    simp,
  end }

lemma extension_of_max_le (h : module.Baer R Q) {y : N} :
  extension_of_max i f ≤ extension_of_max_adjoin i f h y :=
⟨le_sup_left, λ x x' EQ, begin
  symmetry,
  change extension_of_max_adjoin.extension_to_fun i f h _ = _,
  rw [extension_of_max_adjoin.extension_to_fun_wd i f h x' x 0 (by simp [EQ]), map_zero, add_zero],
end⟩

lemma extension_of_max_to_submodule_eq_top (h : module.Baer R Q) :
  (extension_of_max i f).domain = ⊤ :=
begin
  refine submodule.eq_top_iff'.mpr (λ y, _),
  rw [← extension_of_max_is_max i f _ (extension_of_max_le i f h), extension_of_max_adjoin,
      submodule.mem_sup],
  exact ⟨0, submodule.zero_mem _, y, submodule.mem_span_singleton_self _, zero_add _⟩
end

/--**Baer's criterion** for injective module : a Baer module is an injective module, i.e. if every
linear map from an ideal can be extended, then the module is injective.-/
protected theorem injective (h : module.Baer R Q) :
  module.injective R Q :=
{ out := λ X Y ins1 ins2 ins3 ins4 i hi f, begin
    haveI : fact (function.injective i) := ⟨hi⟩,
    exact ⟨{ to_fun := λ y, (extension_of_max i f).to_linear_pmap
        ⟨y, (extension_of_max_to_submodule_eq_top i f h).symm ▸ trivial⟩,
      map_add' := λ x y, by { rw ← linear_pmap.map_add, congr, },
      map_smul' := λ r x, by { rw ← linear_pmap.map_smul, congr } },
      λ x, ((extension_of_max i f).is_extension x).symm⟩,
  end }

end module.Baer


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Proof that the simple, non-memoized version of stochastic backpropagation
is correct.
-/
import .graph .estimators .predicates .compute_grad .lemmas .tgrads .tactics

namespace certigrad
namespace theorems
open list

lemma compute_grad_slow_correct {costs : list ID} :
  ∀ {nodes : list node} {inputs : env} {tgt : reference},
  well_formed_at costs nodes inputs tgt →
  grads_exist_at nodes inputs tgt →
  pdfs_exist_at nodes inputs →
  is_gdifferentiable (λ m, ⟦sum_costs m costs⟧) tgt inputs nodes dvec.head →
  is_nabla_gintegrable (λ m, ⟦sum_costs m costs⟧) tgt inputs nodes dvec.head →
  is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes dvec.head →
  can_differentiate_under_integrals costs nodes inputs tgt →
  ∇ (λ θ₀, E (graph.to_dist (λ m, ⟦sum_costs m costs⟧) (env.insert tgt θ₀ inputs) nodes) dvec.head) (env.get tgt inputs)
  =
  E (graph.to_dist (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) inputs nodes) dvec.head
| [] inputs tgt :=
assume (H_wf : well_formed_at costs [] inputs tgt)
       (H_gs_exist : grads_exist_at [] inputs tgt)
       (H_pdfs_exist : pdfs_exist_at [] inputs)
       (H_gdiff : true)
       (H_nabla_gint : true)
       (H_grad_gint : true)
       (H_diff_under_int : true),
begin
dunfold graph.to_dist,
simp [E.E_ret],
dunfold dvec.head compute_grad_slow sum_costs,
rw T.grad_sumr _ _ _ (sum_costs_differentiable costs tgt inputs),
apply congr_arg,
apply map_congr_fn_pred,
intros cost H_cost_in_costs,
assertv H_em : tgt = (cost, []) ∨ tgt ≠ (cost, []) := decidable.em _,
cases H_em with H_eq H_neq,
-- case 1: tgt = (cost, [])
{ rw H_eq, simp [env.get_insert_same, T.grad_id] },
-- case 2: tgt ≠ (cost, [])
{ simp [λ (x : T tgt.2), env.get_insert_diff x inputs (ne.symm H_neq), H_neq, T.grad_const] }
end

| (⟨ref, parents, operator.det op⟩ :: nodes) inputs tgt :=
assume H_wf H_gs_exist H_pdfs_exist H_gdiff H_nabla_gint H_grad_gint H_diff_under_int,

let θ := env.get tgt inputs in
let x := op^.f (env.get_ks parents inputs) in
let next_inputs := env.insert ref x inputs in

-- 0. Collect useful helpers
have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,

have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,

have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,

have H_get_ks_next_inputs : env.get_ks parents next_inputs = env.get_ks parents inputs,
  begin dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents) end,

have H_get_ref_next : env.get ref next_inputs = op^.f (env.get_ks parents inputs),
  begin dsimp, rw env.get_insert_same end,

have H_can_insert : env.get tgt next_inputs = env.get tgt inputs,
  begin dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_insert_next : ∀ (y : T ref.2), env.insert ref y inputs = env.insert ref y next_inputs,
  begin intro y, dsimp, rw env.insert_insert_same end,

have H_wfs : well_formed_at costs nodes next_inputs tgt ∧ well_formed_at costs nodes next_inputs ref, from wf_at_next H_wf,
have H_gs_exist_tgt : grads_exist_at nodes next_inputs tgt, from H_gs_exist^.left,
have H_pdfs_exist_next : pdfs_exist_at nodes next_inputs, from H_pdfs_exist,

have H_grad_gint_tgt : is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m tgt⟧) next_inputs nodes dvec.head, from
  (iff.mpr (is_gintegrable_k_add _ _ _ _) H_grad_gint)^.left,

have H_nabla_gint_tgt : is_nabla_gintegrable (λ m, ⟦sum_costs m costs⟧) tgt next_inputs nodes dvec.head, from H_nabla_gint^.left,

have H_grad_gint₁ : is_gintegrable (λ (m : env), ⟦compute_grad_slow costs nodes m tgt⟧)
                             (env.insert ref (det.op.f op (env.get_ks parents inputs)) inputs)
                             nodes
                             dvec.head,
  begin dunfold is_gintegrable compute_grad_slow at H_grad_gint, apply (iff.mpr (is_gintegrable_k_add _ _ _ _) H_grad_gint)^.left end,

have H_grad_gint₂ : is_gintegrable
    (λ (m : env),
       ⟦sumr
         (map
            (λ (idx : ℕ),
               det.op.pb op (env.get_ks parents m) (env.get ref m) (compute_grad_slow costs nodes m ref) idx (tgt.snd))
            (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))⟧)
    (env.insert ref (det.op.f op (env.get_ks parents inputs)) inputs)
    nodes
    dvec.head,
    begin dunfold is_gintegrable compute_grad_slow at H_grad_gint, apply (iff.mpr (is_gintegrable_k_add _ _ _ _) H_grad_gint)^.right end,

begin
dunfold graph.to_dist operator.to_dist compute_grad_slow,
simp [E.E_bind, E.E_ret],
dunfold dvec.head,
rw E.E_k_add _ _ _ _ H_grad_gint₁ H_grad_gint₂,
simp only,
rw E.E_k_sum_map _ _ nodes _ H_pdfs_exist H_grad_gint₂,

-- 1. Use the general estimator on the LHS
pose g := (λ (v : dvec T parents^.p2) (θ : T tgt.2), E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧) (env.insert ref (det.op.f op v) (env.insert tgt θ inputs)) nodes) dvec.head),
assert H_diff₁ : T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), g (env.get_ks parents (env.insert tgt θ inputs)) θ₀) θ,
  { exact H_gdiff^.left },

assert H_diff₂ : T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (idx : ℕ), g (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ inputs)) idx) θ)
                                                                 (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents)))))
                                      θ,
  { exact H_gdiff^.right^.left },

rw (T.multiple_args_general parents tgt inputs g θ H_diff₁ H_diff₂),
dsimp,

-- 2. Make the first terms equal, recursively
simp [env.insert_get_same H_wf^.m_contains_tgt],

pose H_almost_tgt := (eq.symm (compute_grad_slow_correct H_wfs^.left H_gs_exist_tgt H_pdfs_exist_next H_gdiff^.right^.right^.left H_nabla_gint_tgt H_grad_gint_tgt H_diff_under_int^.left)),
rw (env.get_insert_diff _ _ H_tgt_neq_ref) at H_almost_tgt,
erw H_almost_tgt,
dsimp,
simp [λ (θ : T tgt.2), env.insert_insert_flip x θ inputs (ne.symm H_tgt_neq_ref)],
apply congr_arg,

-- 3. Time for the second term: get rid of sum and use map_filter_congr
apply (congr_arg sumr),
apply map_filter_congr,
intros idx H_idx_in_riota H_tgt_dnth_parents_idx,
assertv H_tgt_at_idx : at_idx parents idx tgt := ⟨in_riota_lt H_idx_in_riota, H_tgt_dnth_parents_idx⟩,
assertv H_tshape_at_idx : at_idx parents^.p2 idx tgt.2 := at_idx_p2 H_tgt_at_idx,
assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_tgt_at_idx,

-- 4. Put the LHS in terms of T.tmulT
rw (T.grad_chain_rule (λ (θ : T tgt.2), det.op.f op (dvec.update_at θ (env.get_ks parents inputs) idx))
                      (λ (x : T ref.2), E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                                                         (env.insert ref x inputs)
                                                         nodes)
                                           dvec.head)),

-- 5. Replace `m` with `inputs`/`next_inputs` so that we can use `pb_correct`
assert H_swap_m_for_inputs :
graph.to_dist (λ (m : env),
                   ⟦op^.pb (env.get_ks parents m)
                           (env.get ref m)
                           (compute_grad_slow costs nodes m ref)
                           idx
                           tgt.2⟧)
                next_inputs
                nodes
=
(graph.to_dist (λ (m : env),
                    ⟦op^.pb (env.get_ks parents next_inputs)
                            x
                            (compute_grad_slow costs nodes m ref)
                            idx
                            tgt.2⟧)
                 next_inputs
                 nodes),
begin
  apply graph.to_dist_congr,
  exact H_wfs^.right^.uids,
  dsimp,
  intros m H_envs_match,
  apply dvec.singleton_congr,
  assert H_parents_match : env.get_ks parents m = env.get_ks parents next_inputs,
  begin
    apply env.get_ks_env_eq,
    intros parent H_parent_in_parents,
    apply H_envs_match,
    apply env.has_key_insert,
    exact (H_wf^.ps_in_env^.left parent H_parent_in_parents)
  end,
  assert H_ref_matches : env.get ref m = x,
  begin
    assertv H_env_has_key_ref : env.has_key ref next_inputs := env.has_key_insert_same _ _,
    rw [H_envs_match ref H_env_has_key_ref, env.get_insert_same]
  end,
  simp [H_parents_match, H_ref_matches],
end,

rw H_swap_m_for_inputs,
clear H_swap_m_for_inputs,

-- 6. Use pb_correct
assertv H_f_pre : op^.pre (env.get_ks parents next_inputs) := eq.rec_on (eq.symm H_get_ks_next_inputs) (H_gs_exist^.right H_tgt_in_parents)^.left,
simp [λ (m : env), op^.pb_correct (env.get_ks parents next_inputs) x (by rw H_get_ks_next_inputs) (compute_grad_slow costs nodes m ref) H_tshape_at_idx H_f_pre],

-- 7. Push E over tmulT and cancel the first terms
simp [E.E_k_tmulT, H_get_ks_next_inputs, env.dvec_get_get_ks inputs H_tgt_at_idx],
apply congr_arg,

-- 8. Final recursive case
assertv H_gs_exist_ref : grads_exist_at nodes next_inputs ref := (H_gs_exist^.right H_tgt_in_parents)^.right,

assert H_grad_gint_ref : is_gintegrable (λ m, ⟦compute_grad_slow costs nodes m ref⟧) next_inputs nodes dvec.head,
begin
assertv H_op_called : is_gintegrable (λ m, ⟦det.op.pb op (env.get_ks parents m) (env.get ref m) (compute_grad_slow costs nodes m ref) idx (tgt.snd)⟧)
                                    next_inputs nodes dvec.head :=
  is_gintegrable_of_sumr_map (λ m idx, det.op.pb op (env.get_ks parents m) (env.get ref m) (compute_grad_slow costs nodes m ref) idx (tgt.snd))
                                    next_inputs nodes _ H_grad_gint₂ idx (in_filter _ _ _ H_idx_in_riota H_tgt_dnth_parents_idx),

assert H_op_called_swap : is_gintegrable (λ m, ⟦det.op.pb op (env.get_ks parents next_inputs) x (compute_grad_slow costs nodes m ref) idx (tgt.snd)⟧)
                                         next_inputs nodes dvec.head,
{
apply is_gintegrable_k_congr _ _ _ _ _ H_wfs^.right^.uids _ H_op_called,
intros m H_envs_match,
-- TODO(dhs): this is copy-pasted from above
assert H_parents_match : env.get_ks parents m = env.get_ks parents next_inputs,
begin
  apply env.get_ks_env_eq,
  intros parent H_parent_in_parents,
  apply H_envs_match,
  apply env.has_key_insert,
  exact (H_wf^.ps_in_env^.left parent H_parent_in_parents)
end,
assert H_ref_matches : env.get ref m = x,
begin
  assertv H_env_has_key_ref : env.has_key ref next_inputs := env.has_key_insert_same _ _,
  rw [H_envs_match ref H_env_has_key_ref, env.get_insert_same]
end,
simp only [H_parents_match, H_ref_matches],
},

simp only [λ (m : env), op^.pb_correct (env.get_ks parents next_inputs) x (by rw H_get_ks_next_inputs) (compute_grad_slow costs nodes m ref) H_tshape_at_idx H_f_pre] at H_op_called_swap,
exact iff.mpr (is_gintegrable_tmulT _ _ _ _) H_op_called_swap
end,

assert H_gdiff_ref : is_gdifferentiable (λ m, ⟦sum_costs m costs⟧) ref next_inputs nodes dvec.head,
  { exact H_gdiff^.right^.right^.right H_idx_in_riota H_tgt_dnth_parents_idx },

assert H_nabla_gint_ref : is_nabla_gintegrable (λ m, ⟦sum_costs m costs⟧) ref next_inputs nodes dvec.head,
  { exact H_nabla_gint^.right H_idx_in_riota H_tgt_dnth_parents_idx },

pose H_correct_ref := compute_grad_slow_correct H_wfs^.right H_gs_exist_ref H_pdfs_exist_next
                                                H_gdiff_ref H_nabla_gint_ref H_grad_gint_ref (H_diff_under_int^.right H_tgt_in_parents),

simp [H_get_ref_next] at H_correct_ref,
dsimp at H_correct_ref,
simp [env.insert_insert_same] at H_correct_ref,
dsimp,
simp [env.dvec_update_at_env inputs H_tgt_at_idx],
exact H_correct_ref
end

| (⟨ref, parents, operator.rand op⟩ :: nodes) inputs tgt :=
assume H_wf H_gs_exist H_pdfs_exist H_gdiff H_nabla_gint H_grad_gint H_diff_under_int,

let θ := env.get tgt inputs in
let next_inputs := λ (y : T ref.2), env.insert ref y inputs in

-- 0. Collect useful helpers
have H_ref_in_refs : ref ∈ ref :: map node.ref nodes, from mem_of_cons_same,
have H_ref_notin_parents : ref ∉ parents, from ref_notin_parents H_wf^.ps_in_env H_wf^.uids,
have H_tgt_neq_ref : tgt ≠ ref, from ref_ne_tgt H_wf^.m_contains_tgt H_wf^.uids,
have H_insert_θ : env.insert tgt θ inputs = inputs, by rw env.insert_get_same H_wf^.m_contains_tgt,

have H_parents_match : ∀ y, env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin intro y, dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), end,

have H_can_insert_y : ∀ y, env.get tgt (next_inputs y) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_wfs : ∀ y, well_formed_at costs nodes (next_inputs y) tgt ∧ well_formed_at costs nodes (next_inputs y) ref,
  from assume y, wf_at_next H_wf,

have H_parents_match : ∀ y, env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin intro y, dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents), end,

have H_can_insert_y : ∀ y, env.get tgt (next_inputs y) = env.get tgt inputs,
  begin intro y, dsimp, rw (env.get_insert_diff _ _ H_tgt_neq_ref) end,

have H_op_pre : op^.pre (env.get_ks parents inputs), from H_pdfs_exist^.left,

begin
dunfold graph.to_dist operator.to_dist,
simp [E.E_bind],

-- 1. Rewrite with the hybrid estimator
definev g : T ref.2 → T tgt.2 → ℝ :=
  (λ (x : T ref.2) (θ₀ : T tgt.2),
      E (graph.to_dist (λ (m : env), ⟦sum_costs m costs⟧)
                       (env.insert ref x (env.insert tgt θ₀ inputs))
                       nodes)
        dvec.head),

definev θ : T tgt.2 := env.get tgt inputs,

assert H_diff₁ : T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), E (sprog.prim op (env.get_ks parents (env.insert tgt θ inputs))) (λ (y : dvec T [ref.snd]), g y^.head θ₀)) θ,
  { exact H_gdiff^.left },

assert H_diff₂ : T.is_cdifferentiable (λ (θ₀ : T (tgt.snd)), sumr (map (λ (idx : ℕ),
                                                                         E (sprog.prim op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ inputs)) idx))
                                                                           (λ (y : dvec T [ref.snd]), g y^.head θ))
                                                                      (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))) θ,
  { exact H_gdiff^.right^.left },

assert H_eint₁ : E.is_eintegrable (sprog.prim op (env.get_ks parents (env.insert tgt θ inputs))) (λ (x : dvec T [ref.snd]), ∇ (g x^.head) θ),
begin
dsimp [E.is_eintegrable, dvec.head],
simp only [env.insert_get_same H_wf^.m_contains_tgt],
exact H_nabla_gint^.left
end,

assert H_eint₂ : E.is_eintegrable (sprog.prim op (env.get_ks parents (env.insert tgt θ inputs)))
    (λ (x : dvec T [ref.snd]),
       sumr
         (map
            (λ (idx : ℕ),
               g x^.head θ ⬝ ∇
                 (λ (θ₀ : T (tgt.snd)),
                    T.log
                      (rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ inputs)) idx)
                         (dvec.head x)))
                 θ)
            (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))),
begin
dsimp [E.is_eintegrable, dvec.head],
simp only [env.insert_get_same H_wf^.m_contains_tgt],
exact H_nabla_gint^.right^.left,
end,

assert H_g_diff : ∀ (x : T (ref.snd)), T.is_cdifferentiable (g x) θ,
begin
  intros y,
  dsimp,
  simp [λ θ₀, env.insert_insert_flip y θ₀ inputs (ne.symm H_tgt_neq_ref)],
  simp [eq.symm (H_can_insert_y y)],
  apply pd_is_cdifferentiable _ _ _ _ (H_wfs _)^.left (H_gs_exist^.right _) (H_pdfs_exist^.right _) (H_diff_under_int^.right _)
end,

assertv H_g_uint : T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), rand.op.pdf op (env.get_ks parents (env.insert tgt θ inputs)) x ⬝ g x θ₀) θ :=
  can_diff_under_ints_alt1 H_diff_under_int,

assertv H_g_grad_uint : T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), ∇ (λ (θ₁ : T (tgt.snd)), rand.op.pdf op (env.get_ks parents (env.insert tgt θ inputs)) x ⬝ g x θ₁) θ₀) θ :=
  H_diff_under_int^.left^.right^.left^.right,

assert H_d'_pdf_cdiff: ∀ (idx : ℕ), at_idx parents idx tgt →
    ∀ (v : T (ref.snd)), T.is_cdifferentiable (λ (x₀ : T (tgt.snd)), rand.op.pdf op (dvec.update_at x₀ (env.get_ks parents (env.insert tgt θ inputs)) idx) v) θ,
begin
  intros idx H_at_idx y,
  assertv H_tgt_in_parents : tgt ∈ parents := mem_of_at_idx H_at_idx,
  assertv H_pre_satisfied : op^.pre (env.get_ks parents inputs) := H_gs_exist^.left H_tgt_in_parents,
  simp [H_insert_θ],
  dunfold E, dsimp,
  simp [eq.symm (env.dvec_get_get_ks inputs H_at_idx)],
  exact (op^.pdf_cdiff (at_idx_p2 H_at_idx) H_pre_satisfied)
end,

assertv H_d'_uint : ∀ (idx : ℕ), at_idx parents idx tgt →
    T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ inputs)) idx) x ⬝ g x θ) θ := H_diff_under_int^.left^.right^.right^.left,

assertv H_d'_grad_uint : ∀ (idx : ℕ),  at_idx parents idx tgt →
    T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)),
                                         ∇ (λ (θ₀ : T (tgt.snd)), rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ inputs)) idx) x ⬝ g x θ) θ₀) θ :=
H_diff_under_int^.left^.right^.right^.right,

dsimp,
rw (estimators.hybrid_general inputs H_wf^.m_contains_tgt op H_op_pre g θ rfl
                              H_g_diff H_g_uint H_g_grad_uint
                              H_d'_pdf_cdiff H_d'_uint H_d'_grad_uint H_diff₁ H_diff₂ H_eint₁ H_eint₂),

-- 2. Cancel first stochastic choice
dsimp,
simp [env.insert_get_same H_wf^.m_contains_tgt],
apply congr_arg,
apply funext,
intro y,
cases y with ignore y ignore dnil,
cases dnil,
dunfold dvec.head,

assert H_get_ks_next_inputs : env.get_ks parents (next_inputs y) = env.get_ks parents inputs,
  begin dsimp, rw (env.get_ks_insert_diff H_ref_notin_parents) end,

assert H_get_ref_next : env.get ref (next_inputs y) = y,
  begin dsimp, rw env.get_insert_same end,

-- 3. Push E over sum on RHS
dunfold compute_grad_slow,
assert H_grad_gint₁ : is_gintegrable (λ (m : env), ⟦compute_grad_slow costs nodes m tgt⟧) (env.insert ref y inputs) nodes dvec.head,
 { dsimp [is_gintegrable, compute_grad_slow] at H_grad_gint, apply (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_grad_gint^.right y))^.left },

assert H_grad_gint₂ : is_gintegrable
    (λ (m : env),
       ⟦sumr
         (map
            (λ (idx : ℕ),
               sum_downstream_costs nodes costs ref m ⬝ rand.op.glogpdf op (env.get_ks parents m) (env.get ref m) idx
                 (tgt.snd))
            (filter (λ (idx : ℕ), tgt = dnth parents idx) (riota (length parents))))⟧)
    (env.insert ref y inputs)
    nodes
    dvec.head,
  { dsimp [is_gintegrable, compute_grad_slow] at H_grad_gint, apply (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_grad_gint^.right y))^.right },

rw E.E_k_add _ _ _ _ H_grad_gint₁ H_grad_gint₂,

-- 4. Cancel the first terms
assert H_gdiff_tgt : is_gdifferentiable (λ (m : env), ⟦sum_costs m costs⟧) tgt (next_inputs y) nodes dvec.head,
  { exact H_gdiff^.right^.right y },

assert H_grad_gint_tgt : is_gintegrable (λ (m : env), ⟦compute_grad_slow costs nodes m tgt⟧) (next_inputs y) nodes dvec.head,
  { exact (iff.mpr (is_gintegrable_k_add _ _ _ _) (H_grad_gint^.right y))^.left },

assert H_nabla_gint_tgt : is_nabla_gintegrable (λ m, ⟦sum_costs m costs⟧) tgt (next_inputs y) nodes dvec.head,
  { exact H_nabla_gint^.right^.right y },

-- TODO(dhs): confirm ERW is only needed because of the `definev`
erw -(compute_grad_slow_correct (H_wfs _)^.left (H_gs_exist^.right y) (H_pdfs_exist^.right _) H_gdiff_tgt H_nabla_gint_tgt H_grad_gint_tgt (H_diff_under_int^.right y)),
dsimp,

simp [λ (θ : T tgt.2), env.insert_insert_flip θ y inputs H_tgt_neq_ref],
rw (env.get_insert_diff _ _ H_tgt_neq_ref),
apply congr_arg,

-- 5. Push E over sumr and expose map

rw E.E_k_sum_map _ _ _ _ (H_pdfs_exist^.right _) H_grad_gint₂,
apply congr_arg,

-- 6. Apply map_filter_congr
exact map_filter_expand_helper _ _ _ _ _ _ H_wf H_gs_exist _
end
end theorems
end certigrad


import tuto_lib

set_option pp.beta true
set_option pp.coercions false

/-
This is the final file in the series. Here we use everything covered
in previous files to prove a couple of famous theorems from
elementary real analysis. Of course they all have more general versions
in mathlib.

As usual, keep in mind the following:

  abs_le (x y : ℝ) : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y

  ge_max_iff (p q r) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q

  le_max_left p q : p ≤ max p q

  le_max_right p q : q ≤ max p q

as well as a lemma from the previous file:

  le_of_le_add_all : (∀ ε > 0, y ≤ x + ε) →  y ≤ x

Let's start with a variation on a known exercise.
-/

-- 0071
lemma le_lim {x y : ℝ} {u : ℕ → ℝ} (hu : seq_limit u x)
  (ineg : ∃ N, ∀ n ≥ N, y ≤ u n) : y ≤ x :=
begin
  sorry
end

/-
Let's now return to the result proved in the `00_` file of this series,
and prove again the sequential characterization of upper bounds (with a slighly
different proof).

For this, and other exercises below, we'll need many things that we proved in previous files,
and a couple of extras.

From the 5th file:

  limit_const (x : ℝ) : seq_limit (λ n, x) x

  squeeze (lim_u : seq_limit u l) (lim_w : seq_limit w l)
    (hu : ∀ n, u n ≤ v n) (hw : ∀ n, v n ≤ w n)  : seq_limit v l

From the 8th:

  def upper_bound (A : set ℝ) (x : ℝ) := ∀ a ∈ A, a ≤ x

  def is_sup (A : set ℝ) (x : ℝ) := upper_bound A x ∧ ∀ y, upper_bound A y → x ≤ y

  lt_sup (hx : is_sup A x) : ∀ y, y < x → ∃ a ∈ A, y < a :=

You can also use

  inv_succ_pos : ∀ n : ℕ, 1/(n + 1 : ℝ) > 0

  inv_succ_le_all :  ∀ ε > 0, ∃ N : ℕ, ∀ n ≥ N, 1/(n + 1 : ℝ) ≤ ε

and their easy consequences:

  limit_of_sub_le_inv_succ (h : ∀ n, |u n - x| ≤ 1/(n+1)) : seq_limit u x

  limit_const_add_inv_succ (x : ℝ) : seq_limit (λ n, x + 1/(n+1)) x

  limit_const_sub_inv_succ (x : ℝ) : seq_limit (λ n, x - 1/(n+1)) x

The structure of the proof is offered. It features a new tactic:
`choose` which invokes the axiom of choice (observing the tactic state before and
after using it should be enough to understand everything).
-/
-- 0072
lemma is_sup_iff (A : set ℝ) (x : ℝ) :
(is_sup A x) ↔ (upper_bound A x ∧ ∃ u : ℕ → ℝ, seq_limit u x ∧ ∀ n, u n ∈ A ) :=
begin
  split,
  { intro h,
    split,
    {
      sorry
    },
    { have : ∀ n : ℕ, ∃ a ∈ A, x - 1/(n+1) < a,
      { intros n,
        have : 1/(n+1 : ℝ) > 0,
          exact nat.one_div_pos_of_nat,
        sorry
      },
      choose u hu using this,
      sorry
  } },
  { rintro ⟨maj, u, limu, u_in⟩,
    sorry
  },
end

/-- Continuity of a function at a point  -/
def continuous_at_pt (f : ℝ → ℝ) (x₀ : ℝ) : Prop :=
∀ ε > 0, ∃ δ > 0, ∀ x, |x - x₀| ≤ δ → |f x - f x₀| ≤ ε

variables {f : ℝ → ℝ} {x₀ : ℝ} {u : ℕ → ℝ}

-- 0073
lemma seq_continuous_of_continuous (hf : continuous_at_pt f x₀)
  (hu : seq_limit u x₀) : seq_limit (f ∘ u) (f x₀) :=
begin
  sorry
end

-- 0074
example :
  (∀ u : ℕ → ℝ, seq_limit u x₀ → seq_limit (f ∘ u) (f x₀)) →
  continuous_at_pt f x₀ :=
begin
  sorry
end

/-
Recall from the 6th file:

  def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m

  def cluster_point (u : ℕ → ℝ) (a : ℝ) :=
    ∃ φ, extraction φ ∧ seq_limit (u ∘ φ) a

  id_le_extraction : extraction φ → ∀ n, n ≤ φ n

and from the 8th file:

  def tendsto_infinity (u : ℕ → ℝ) := ∀ A, ∃ N, ∀ n ≥ N, u n ≥ A

  not_seq_limit_of_tendstoinfinity : tendsto_infinity u → ∀ l, ¬ seq_limit u l
-/

variables {φ : ℕ → ℕ}

-- 0075
lemma subseq_tenstoinfinity
  (h : tendsto_infinity u) (hφ : extraction φ) :
tendsto_infinity (u ∘ φ) :=
begin
  sorry
end

-- 0076
lemma squeeze_infinity {u v : ℕ → ℝ} (hu : tendsto_infinity u)
(huv : ∀ n, u n ≤ v n) : tendsto_infinity v :=
begin
  sorry
end

/-
We will use segments: Icc a b := { x | a ≤ x ∧ x ≤ b }
The notation stands for Interval-closed-closed. Variations exist with
o or i instead of c, where o stands for open and i for infinity.

We will use the following version of Bolzano-Weirstrass

  bolzano_weierstrass (h : ∀ n, u n ∈ [a, b]) :
    ∃ c ∈ [a, b], cluster_point u c

as well as the obvious

  seq_limit_id : tendsto_infinity (λ n, n)
-/
open set

-- 0077
lemma bdd_above_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ M, ∀ x ∈ Icc a b, f x ≤ M :=
begin
  sorry
end

/-
In the next exercise, we can use:

  abs_neg x : |-x| = |x|
-/

-- 0078
lemma continuous_opposite {f : ℝ → ℝ} {x₀ : ℝ} (h : continuous_at_pt f x₀) :
  continuous_at_pt (λ x, -f x) x₀ :=
begin
  sorry
end

/-
Now let's combine the two exercises above
-/

-- 0079
lemma bdd_below_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ m, ∀ x ∈ Icc a b, m ≤ f x :=
begin
  sorry
end

/-
Remember from the 5th file:

 unique_limit : seq_limit u l → seq_limit u l' → l = l'

and from the 6th one:

  subseq_tendsto_of_tendsto (h : seq_limit u l) (hφ : extraction φ) :
    seq_limit (u ∘ φ) l

We now admit the following version of the least upper bound theorem
(that cannot be proved without discussing the construction of real numbers
or admitting another strong theorem).

sup_segment {a b : ℝ} {A : set ℝ} (hnonvide : ∃ x, x ∈ A) (h : A ⊆ Icc a b) :
  ∃ x ∈ Icc a b, is_sup A x

In the next exercise, it can be useful to prove inclusions of sets of real number.
By definition, A ⊆ B means : ∀ x, x ∈ A → x ∈ B.
Hence one can start a proof of A ⊆ B by `intros x x_in`,
which brings `x : ℝ` and `x_in : x ∈ A` in the local context,
and then prove `x ∈ B`.

Note also the use of
  {x | P x}
which denotes the set of x satisfying predicate P.

Hence `x' ∈ { x | P x} ↔ P x'`, by definition.
-/

-- 0080
example {a b : ℝ} (hab : a ≤ b) (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ x₀ ∈ Icc a b, ∀ x ∈ Icc a b, f x ≤ f x₀ :=
begin
  sorry
end

lemma stupid {a b x : ℝ} (h : x ∈ Icc a b) (h' : x ≠ b) : x < b :=
lt_of_le_of_ne h.right h'

/-
And now the final boss...
-/

def I := (Icc 0 1 : set ℝ) -- the type ascription makes sure 0 and 1 are real numbers here

-- 0081
example (f : ℝ → ℝ) (hf : ∀ x, continuous_at_pt f x) (h₀ : f 0 < 0) (h₁ : f 1 > 0) :
∃ x₀ ∈ I, f x₀ = 0 :=
begin
  let A := { x | x ∈ I ∧ f x < 0},
  have ex_x₀ : ∃ x₀ ∈ I, is_sup A x₀,
  {
    sorry
  },
  rcases ex_x₀ with ⟨x₀, x₀_in, x₀_sup⟩,
  use [x₀, x₀_in],
  have : f x₀ ≤ 0,
  {
    sorry
  },
  have x₀_1: x₀ < 1,
  {
    sorry
  },
  have : f x₀ ≥ 0,
  { have dans : ∃ N : ℕ, ∀ n ≥ N, x₀ + 1/(n+1) ∈ I,
    { have : ∃ N : ℕ, ∀ n≥ N, 1/(n+1 : ℝ) ≤ 1-x₀,
      {
        sorry
      },
      sorry
    },
    have not_in : ∀ n : ℕ, x₀ + 1/(n+1) ∉ A,
    -- By definition, x ∉ A means ¬ (x ∈ A).
    {
      sorry
    },
    dsimp [A] at not_in, -- This is useful to unfold a let
    sorry
  },
  linarith,
end


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import group_theory.group_action group_theory.quotient_group
import group_theory.order_of_element data.zmod.basic algebra.pi_instances

open equiv fintype finset mul_action function
open equiv.perm is_subgroup list quotient_group
universes u v w
variables {G : Type u} {α : Type v} {β : Type w} [group G]

local attribute [instance, priority 0] subtype.fintype set_fintype classical.prop_decidable

namespace mul_action
variables [mul_action G α]

lemma mem_fixed_points_iff_card_orbit_eq_one {a : α}
  [fintype (orbit G a)] : a ∈ fixed_points G α ↔ card (orbit G a) = 1 :=
begin
  rw [fintype.card_eq_one_iff, mem_fixed_points],
  split,
  { exact λ h, ⟨⟨a, mem_orbit_self _⟩, λ ⟨b, ⟨x, hx⟩⟩, subtype.eq $ by simp [h x, hx.symm]⟩ },
  { assume h x,
    rcases h with ⟨⟨z, hz⟩, hz₁⟩,
    exact calc x • a = z : subtype.mk.inj (hz₁ ⟨x • a, mem_orbit _ _⟩)
      ... = a : (subtype.mk.inj (hz₁ ⟨a, mem_orbit_self _⟩)).symm }
end

lemma card_modeq_card_fixed_points [fintype α] [fintype G] [fintype (fixed_points G α)]
  {p n : ℕ} (hp : nat.prime p) (h : card G = p ^ n) : card α ≡ card (fixed_points G α) [MOD p] :=
calc card α = card (Σ y : quotient (orbit_rel G α), {x // quotient.mk' x = y}) :
  card_congr (equiv_fib (@quotient.mk' _ (orbit_rel G α)))
... = univ.sum (λ a : quotient (orbit_rel G α), card {x // quotient.mk' x = a}) : card_sigma _
... ≡ (@univ (fixed_points G α) _).sum (λ _, 1) [MOD p] :
begin
  rw [← zmodp.eq_iff_modeq_nat hp, sum_nat_cast, sum_nat_cast],
  refine eq.symm (sum_bij_ne_zero (λ a _ _, quotient.mk' a.1)
    (λ _ _ _, mem_univ _)
    (λ a₁ a₂ _ _ _ _ h,
      subtype.eq ((mem_fixed_points' α).1 a₂.2 a₁.1 (quotient.exact' h)))
      (λ b, _)
      (λ a ha _, by rw [← mem_fixed_points_iff_card_orbit_eq_one.1 a.2];
        simp only [quotient.eq']; congr)),
  { refine quotient.induction_on' b (λ b _ hb, _),
    have : card (orbit G b) ∣ p ^ n,
    { rw [← h, fintype.card_congr (orbit_equiv_quotient_stabilizer G b)];
      exact card_quotient_dvd_card _ },
    rcases (nat.dvd_prime_pow hp).1 this with ⟨k, _, hk⟩,
    have hb' :¬ p ^ 1 ∣ p ^ k,
    { rw [nat.pow_one, ← hk, ← nat.modeq.modeq_zero_iff, ← zmodp.eq_iff_modeq_nat hp,
        nat.cast_zero, ← ne.def],
      exact eq.mpr (by simp only [quotient.eq']; congr) hb },
    have : k = 0 := nat.le_zero_iff.1 (nat.le_of_lt_succ (lt_of_not_ge (mt (nat.pow_dvd_pow p) hb'))),
    refine ⟨⟨b, mem_fixed_points_iff_card_orbit_eq_one.2 $ by rw [hk, this, nat.pow_zero]⟩, mem_univ _,
      by simp [zero_ne_one], rfl⟩ }
end
... = _ : by simp; refl

end mul_action

lemma quotient_group.card_preimage_mk [fintype G] (s : set G) [is_subgroup s]
  (t : set (quotient s)) : fintype.card (quotient_group.mk ⁻¹' t) =
  fintype.card s * fintype.card t :=
by rw [← fintype.card_prod, fintype.card_congr
  (preimage_mk_equiv_subgroup_times_set _ _)]

namespace sylow

def mk_vector_prod_eq_one (n : ℕ) (v : vector G n) : vector G (n+1) :=
v.to_list.prod⁻¹ :: v

lemma mk_vector_prod_eq_one_inj (n : ℕ) : injective (@mk_vector_prod_eq_one G _ n) :=
λ ⟨v, _⟩ ⟨w, _⟩ h, subtype.eq (show v = w, by injection h with h; injection h)

def vectors_prod_eq_one (G : Type*) [group G] (n : ℕ) : set (vector G n) :=
{v | v.to_list.prod = 1}

lemma mem_vectors_prod_eq_one {n : ℕ} (v : vector G n) :
  v ∈ vectors_prod_eq_one G n ↔ v.to_list.prod = 1 := iff.rfl

lemma mem_vectors_prod_eq_one_iff {n : ℕ} (v : vector G (n + 1)) :
  v ∈ vectors_prod_eq_one G (n + 1) ↔ v ∈ set.range (@mk_vector_prod_eq_one G _ n) :=
⟨λ (h : v.to_list.prod = 1), ⟨v.tail,
  begin
    unfold mk_vector_prod_eq_one,
    conv {to_rhs, rw ← vector.cons_head_tail v},
    suffices : (v.tail.to_list.prod)⁻¹ = v.head,
    { rw this },
    rw [← mul_right_inj v.tail.to_list.prod, inv_mul_self, ← list.prod_cons,
      ← vector.to_list_cons, vector.cons_head_tail, h]
  end⟩,
  λ ⟨w, hw⟩, by rw [mem_vectors_prod_eq_one, ← hw, mk_vector_prod_eq_one,
    vector.to_list_cons, list.prod_cons, inv_mul_self]⟩

def rotate_vectors_prod_eq_one (G : Type*) [group G] (n : ℕ+) (m : multiplicative (zmod n))
  (v : vectors_prod_eq_one G n) : vectors_prod_eq_one G n :=
⟨⟨v.1.to_list.rotate m.1, by simp⟩, prod_rotate_eq_one_of_prod_eq_one v.2 _⟩

instance rotate_vectors_prod_eq_one.mul_action (n : ℕ+) :
  mul_action (multiplicative (zmod n)) (vectors_prod_eq_one G n) :=
{ smul := (rotate_vectors_prod_eq_one G n),
  one_smul := λ v, subtype.eq $ vector.eq _ _ $ rotate_zero v.1.to_list,
  mul_smul := λ a b ⟨⟨v, hv₁⟩, hv₂⟩, subtype.eq $ vector.eq _ _ $
    show v.rotate ((a + b : zmod n).val) = list.rotate (list.rotate v (b.val)) (a.val),
    by rw [zmod.add_val, rotate_rotate, ← rotate_mod _ (b.1 + a.1), add_comm, hv₁] }

lemma one_mem_vectors_prod_eq_one (n : ℕ) : vector.repeat (1 : G) n ∈ vectors_prod_eq_one G n :=
by simp [vector.repeat, vectors_prod_eq_one]

lemma one_mem_fixed_points_rotate (n : ℕ+) :
  (⟨vector.repeat (1 : G) n, one_mem_vectors_prod_eq_one n⟩ : vectors_prod_eq_one G n) ∈
  fixed_points (multiplicative (zmod n)) (vectors_prod_eq_one G n) :=
λ m, subtype.eq $ vector.eq _ _ $
by haveI : nonempty G := ⟨1⟩; exact
rotate_eq_self_iff_eq_repeat.2 ⟨(1 : G),
  show list.repeat (1 : G) n = list.repeat 1 (list.repeat (1 : G) n).length, by simp⟩ _

/-- Cauchy's theorem -/
lemma exists_prime_order_of_dvd_card [fintype G] {p : ℕ} (hp : nat.prime p)
  (hdvd : p ∣ card G) : ∃ x : G, order_of x = p :=
let n : ℕ+ := ⟨p - 1, nat.sub_pos_of_lt hp.gt_one⟩ in
let p' : ℕ+ := ⟨p, hp.pos⟩ in
have hn : p' = n + 1 := subtype.eq (nat.succ_sub hp.pos),
have hcard : card (vectors_prod_eq_one G (n + 1)) = card G ^ (n : ℕ),
  by rw [set.ext mem_vectors_prod_eq_one_iff,
    set.card_range_of_injective (mk_vector_prod_eq_one_inj _), card_vector],
have hzmod : fintype.card (multiplicative (zmod p')) =
  (p' : ℕ) ^ 1 := (nat.pow_one p').symm ▸ card_fin _,
have hmodeq : _ = _ := @mul_action.card_modeq_card_fixed_points
  (multiplicative (zmod p')) (vectors_prod_eq_one G p') _ _ _ _ _ _ 1 hp hzmod,
have hdvdcard : p ∣ fintype.card (vectors_prod_eq_one G (n + 1)) :=
  calc p ∣ card G ^ 1 : by rwa nat.pow_one
  ... ∣ card G ^ (n : ℕ) : nat.pow_dvd_pow _ n.2
  ... = card (vectors_prod_eq_one G (n + 1)) : hcard.symm,
have hdvdcard₂ : p ∣ card (fixed_points (multiplicative (zmod p')) (vectors_prod_eq_one G p')) :=
  nat.dvd_of_mod_eq_zero (hmodeq ▸ hn.symm ▸ nat.mod_eq_zero_of_dvd hdvdcard),
have hcard_pos : 0 < card (fixed_points (multiplicative (zmod p')) (vectors_prod_eq_one G p')) :=
  fintype.card_pos_iff.2 ⟨⟨⟨vector.repeat 1 p', one_mem_vectors_prod_eq_one _⟩,
    one_mem_fixed_points_rotate _⟩⟩,
have hlt : 1 < card (fixed_points (multiplicative (zmod p')) (vectors_prod_eq_one G p')) :=
  calc (1 : ℕ) < p' : hp.gt_one
  ... ≤ _ : nat.le_of_dvd hcard_pos hdvdcard₂,
let ⟨⟨⟨⟨x, hx₁⟩, hx₂⟩, hx₃⟩, hx₄⟩ := fintype.exists_ne_of_card_gt_one hlt
  ⟨_, one_mem_fixed_points_rotate p'⟩ in
have hx : x ≠ list.repeat (1 : G) p', from λ h, by simpa [h, vector.repeat] using hx₄,
have nG : nonempty G, from ⟨1⟩,
have ∃ a, x = list.repeat a x.length := by exactI rotate_eq_self_iff_eq_repeat.1 (λ n,
  have list.rotate x (n : zmod p').val = x :=
    subtype.mk.inj (subtype.mk.inj (hx₃ (n : zmod p'))),
  by rwa [zmod.val_cast_nat, ← hx₁, rotate_mod] at this),
let ⟨a, ha⟩ := this in
⟨a, have hx1 : x.prod = 1 := hx₂,
  have ha1: a ≠ 1, from λ h, hx (ha.symm ▸ h ▸ hx₁ ▸ rfl),
  have a ^ p = 1, by rwa [ha, list.prod_repeat, hx₁] at hx1,
  (hp.2 _ (order_of_dvd_of_pow_eq_one this)).resolve_left
    (λ h, ha1 (order_of_eq_one_iff.1 h))⟩

open is_subgroup is_submonoid is_group_hom mul_action

lemma mem_fixed_points_mul_left_cosets_iff_mem_normalizer {H : set G} [is_subgroup H] [fintype H]
  {x : G} : (x : quotient H) ∈ fixed_points H (quotient H) ↔ x ∈ normalizer H :=
⟨λ hx, have ha : ∀ {y : quotient H}, y ∈ orbit H (x : quotient H) → y = x,
  from λ _, ((mem_fixed_points' _).1 hx _),
  (inv_mem_iff _).1 (mem_normalizer_fintype (λ n hn,
    have (n⁻¹ * x)⁻¹ * x ∈ H := quotient_group.eq.1 (ha (mem_orbit _ ⟨n⁻¹, inv_mem hn⟩)),
    by simpa only [mul_inv_rev, inv_inv] using this)),
λ (hx : ∀ (n : G), n ∈ H ↔ x * n * x⁻¹ ∈ H),
(mem_fixed_points' _).2 $ λ y, quotient.induction_on' y $ λ y hy, quotient_group.eq.2
  (let ⟨⟨b, hb₁⟩, hb₂⟩ := hy in
  have hb₂ : (b * x)⁻¹ * y ∈ H := quotient_group.eq.1 hb₂,
  (inv_mem_iff H).1 $ (hx _).2 $ (mul_mem_cancel_right H (inv_mem hb₁)).1
  $ by rw hx at hb₂;
    simpa [mul_inv_rev, mul_assoc] using hb₂)⟩

lemma fixed_points_mul_left_cosets_equiv_quotient (H : set G) [is_subgroup H] [fintype H] :
  fixed_points H (quotient H) ≃ quotient (subtype.val ⁻¹' H : set (normalizer H)) :=
@subtype_quotient_equiv_quotient_subtype G (normalizer H) (id _) (id _) (fixed_points _ _)
  (λ a, mem_fixed_points_mul_left_cosets_iff_mem_normalizer.symm) (by intros; refl)

local attribute [instance] set_fintype

lemma exists_subgroup_card_pow_prime [fintype G] {p : ℕ} : ∀ {n : ℕ} (hp : nat.prime p)
  (hdvd : p ^ n ∣ card G), ∃ H : set G, is_subgroup H ∧ fintype.card H = p ^ n
| 0 := λ _ _, ⟨trivial G, by apply_instance, by simp⟩
| (n+1) := λ hp hdvd,
let ⟨H, ⟨hH1, hH2⟩⟩ := exists_subgroup_card_pow_prime hp
  (dvd.trans (nat.pow_dvd_pow _ (nat.le_succ _)) hdvd) in
let ⟨s, hs⟩ := exists_eq_mul_left_of_dvd hdvd in
by exactI
have hcard : card (quotient H) = s * p :=
  (nat.mul_right_inj (show card H > 0, from fintype.card_pos_iff.2
      ⟨⟨1, is_submonoid.one_mem H⟩⟩)).1
    (by rwa [← card_eq_card_quotient_mul_card_subgroup, hH2, hs,
      nat.pow_succ, mul_assoc, mul_comm p]),
have hm : s * p % p = card (quotient (subtype.val ⁻¹' H : set (normalizer H))) % p :=
  card_congr (fixed_points_mul_left_cosets_equiv_quotient H) ▸ hcard ▸
    card_modeq_card_fixed_points hp hH2,
have hm' : p ∣ card (quotient (subtype.val ⁻¹' H : set (normalizer H))) :=
  nat.dvd_of_mod_eq_zero
    (by rwa [nat.mod_eq_zero_of_dvd (dvd_mul_left _ _), eq_comm] at hm),
let ⟨x, hx⟩ := @exists_prime_order_of_dvd_card _ (quotient_group.group _) _ _ hp hm' in
have hxcard : ∀ {f : fintype (gpowers x)}, card (gpowers x) = p,
  from λ f, by rw [← hx, order_eq_card_gpowers]; congr,
have is_subgroup (mk ⁻¹' gpowers x),
  from is_group_hom.preimage _ _,
have fintype (mk ⁻¹' gpowers x), by apply_instance,
have hequiv : H ≃ (subtype.val ⁻¹' H : set (normalizer H)):=
  ⟨λ a, ⟨⟨a.1, subset_normalizer _ a.2⟩, a.2⟩, λ a, ⟨a.1.1, a.2⟩,
    λ ⟨_, _⟩, rfl, λ ⟨⟨_, _⟩, _⟩, rfl⟩,
⟨subtype.val '' (mk ⁻¹' gpowers x), by apply_instance,
  by rw [set.card_image_of_injective (mk ⁻¹' gpowers x) subtype.val_injective,
      nat.pow_succ, ← hH2, fintype.card_congr hequiv, ← hx, order_eq_card_gpowers,
      ← fintype.card_prod];
    exact @fintype.card_congr _ _ (id _) (id _) (preimage_mk_equiv_subgroup_times_set _ _)⟩

end sylow


/-
Copyright (c) 2022 Rémy Degenne, Kexing Ying. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne, Kexing Ying
-/

import measure_theory.function.egorov

/-!
# Convergence in measure

We define convergence in measure which is one of the many notions of convergence in probability.
A sequence of functions `f` is said to converge in measure to some function `g`
if for all `ε > 0`, the measure of the set `{x | ε ≤ dist (f i x) (g x)}` tends to 0 as `i`
converges along some given filter `l`.

Convergence in measure is most notably used in the formulation of the weak law of large numbers
and is also useful in theorems such as the Vitali convergence theorem. This file provides some
basic lemmas for working with convergence in measure and establishes some relations between
convergence in measure and other notions of convergence.

## Main definitions

* `measure_theory.tendsto_in_measure (μ : measure α) (f : ι → α → E) (g : α → E)`: `f` converges
  in `μ`-measure to `g`.

## Main results

* `measure_theory.tendsto_in_measure_of_tendsto_ae`: convergence almost everywhere in a finite
  measure space implies convergence in measure.
* `measure_theory.tendsto_in_measure.exists_seq_tendsto_ae`: if `f` is a sequence of functions
  which converges in measure to `g`, then `f` has a subsequence which convergence almost
  everywhere to `g`.
* `measure_theory.tendsto_in_measure_of_tendsto_snorm`: convergence in Lp implies convergence
  in measure.
-/

open topological_space filter
open_locale nnreal ennreal measure_theory topological_space

namespace measure_theory

variables {α ι E : Type*} {m : measurable_space α} {μ : measure α}

/-- A sequence of functions `f` is said to converge in measure to some function `g` if for all
`ε > 0`, the measure of the set `{x | ε ≤ dist (f i x) (g x)}` tends to 0 as `i` converges along
some given filter `l`. -/
def tendsto_in_measure [has_dist E] {m : measurable_space α}
  (μ : measure α) (f : ι → α → E) (l : filter ι) (g : α → E) : Prop :=
∀ ε (hε : 0 < ε), tendsto (λ i, μ {x | ε ≤ dist (f i x) (g x)}) l (𝓝 0)

lemma tendsto_in_measure_iff_norm [semi_normed_group E] {l : filter ι}
  {f : ι → α → E} {g : α → E} :
  tendsto_in_measure μ f l g
  ↔ ∀ ε (hε : 0 < ε), tendsto (λ i, μ {x | ε ≤ ∥f i x - g x∥}) l (𝓝 0) :=
by simp_rw [tendsto_in_measure, dist_eq_norm]

namespace tendsto_in_measure

variables [has_dist E] {l : filter ι} {f f' : ι → α → E} {g g' : α → E}

protected lemma congr' (h_left : ∀ᶠ i in l, f i =ᵐ[μ] f' i) (h_right : g =ᵐ[μ] g')
  (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f' l g' :=
begin
  intros ε hε,
  suffices : (λ i, μ {x | ε ≤ dist (f' i x) (g' x)})
      =ᶠ[l] (λ i, μ {x | ε ≤ dist (f i x) (g x)}),
  { rw tendsto_congr' this,
    exact h_tendsto ε hε, },
  filter_upwards [h_left] with i h_ae_eq,
  refine measure_congr _,
  filter_upwards [h_ae_eq, h_right] with x hxf hxg,
  rw eq_iff_iff,
  change ε ≤ dist (f' i x) (g' x) ↔ ε ≤ dist (f i x) (g x),
  rw [hxg, hxf],
end

protected lemma congr (h_left : ∀ i, f i =ᵐ[μ] f' i) (h_right : g =ᵐ[μ] g')
  (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f' l g' :=
tendsto_in_measure.congr' (eventually_of_forall h_left) h_right h_tendsto

lemma congr_left (h : ∀ i, f i =ᵐ[μ] f' i) (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f' l g :=
h_tendsto.congr h (eventually_eq.rfl)

lemma congr_right (h : g =ᵐ[μ] g') (h_tendsto : tendsto_in_measure μ f l g) :
  tendsto_in_measure μ f l g' :=
h_tendsto.congr (λ i, eventually_eq.rfl) h

end tendsto_in_measure

section exists_seq_tendsto_ae

variables [metric_space E]
variables {f : ℕ → α → E} {g : α → E}

/-- Auxiliary lemma for `tendsto_in_measure_of_tendsto_ae`. -/
lemma tendsto_in_measure_of_tendsto_ae_of_strongly_measurable [is_finite_measure μ]
  (hf : ∀ n, strongly_measurable (f n)) (hg : strongly_measurable g)
  (hfg : ∀ᵐ x ∂μ, tendsto (λ n, f n x) at_top (𝓝 (g x))) :
  tendsto_in_measure μ f at_top g :=
begin
  refine λ ε hε, ennreal.tendsto_at_top_zero.mpr (λ δ hδ, _),
  by_cases hδi : δ = ∞,
  { simp only [hδi, implies_true_iff, le_top, exists_const], },
  lift δ to ℝ≥0 using hδi,
  rw [gt_iff_lt, ennreal.coe_pos, ← nnreal.coe_pos] at hδ,
  obtain ⟨t, htm, ht, hunif⟩ := tendsto_uniformly_on_of_ae_tendsto' hf hg hfg hδ,
  rw ennreal.of_real_coe_nnreal at ht,
  rw metric.tendsto_uniformly_on_iff at hunif,
  obtain ⟨N, hN⟩ := eventually_at_top.1 (hunif ε hε),
  refine ⟨N, λ n hn, _⟩,
  suffices : {x : α | ε ≤ dist (f n x) (g x)} ⊆ t, from (measure_mono this).trans ht,
  rw ← set.compl_subset_compl,
  intros x hx,
  rw [set.mem_compl_eq, set.nmem_set_of_eq, dist_comm, not_le],
  exact hN n hn x hx,
end

/-- Convergence a.e. implies convergence in measure in a finite measure space. -/
lemma tendsto_in_measure_of_tendsto_ae [is_finite_measure μ]
  (hf : ∀ n, ae_strongly_measurable (f n) μ)
  (hfg : ∀ᵐ x ∂μ, tendsto (λ n, f n x) at_top (𝓝 (g x))) :
  tendsto_in_measure μ f at_top g :=
begin
  have hg : ae_strongly_measurable g μ, from ae_strongly_measurable_of_tendsto_ae _ hf hfg,
  refine tendsto_in_measure.congr (λ i, (hf i).ae_eq_mk.symm) hg.ae_eq_mk.symm _,
  refine tendsto_in_measure_of_tendsto_ae_of_strongly_measurable
    (λ i, (hf i).strongly_measurable_mk) hg.strongly_measurable_mk _,
  have hf_eq_ae : ∀ᵐ x ∂μ, ∀ n, (hf n).mk (f n) x = f n x,
    from ae_all_iff.mpr (λ n, (hf n).ae_eq_mk.symm),
  filter_upwards [hf_eq_ae, hg.ae_eq_mk, hfg] with x hxf hxg hxfg,
  rw [← hxg, funext (λ n, hxf n)],
  exact hxfg,
end

namespace exists_seq_tendsto_ae

lemma exists_nat_measure_lt_two_inv (hfg : tendsto_in_measure μ f at_top g) (n : ℕ) :
  ∃ N, ∀ m ≥ N, μ {x | 2⁻¹ ^ n ≤ dist (f m x) (g x)} ≤ 2⁻¹ ^ n :=
begin
  specialize hfg (2⁻¹ ^ n) (by simp only [zero_lt_bit0, pow_pos, zero_lt_one, inv_pos]),
  rw ennreal.tendsto_at_top_zero at hfg,
  exact hfg (2⁻¹ ^ n) (pos_iff_ne_zero.mpr (λ h_zero, by simpa using pow_eq_zero h_zero))
end

/-- Given a sequence of functions `f` which converges in measure to `g`,
`seq_tendsto_ae_seq_aux` is a sequence such that
`∀ m ≥ seq_tendsto_ae_seq_aux n, μ {x | 2⁻¹ ^ n ≤ dist (f m x) (g x)} ≤ 2⁻¹ ^ n`. -/
noncomputable
def seq_tendsto_ae_seq_aux (hfg : tendsto_in_measure μ f at_top g) (n : ℕ) :=
classical.some (exists_nat_measure_lt_two_inv hfg n)

/-- Transformation of `seq_tendsto_ae_seq_aux` to makes sure it is strictly monotone. -/
noncomputable
def seq_tendsto_ae_seq (hfg : tendsto_in_measure μ f at_top g) : ℕ → ℕ
| 0 := seq_tendsto_ae_seq_aux hfg 0
| (n + 1) := max (seq_tendsto_ae_seq_aux hfg (n + 1))
  (seq_tendsto_ae_seq n + 1)

lemma seq_tendsto_ae_seq_succ (hfg : tendsto_in_measure μ f at_top g) {n : ℕ} :
  seq_tendsto_ae_seq hfg (n + 1) =
  max (seq_tendsto_ae_seq_aux hfg (n + 1)) (seq_tendsto_ae_seq hfg n + 1) :=
by rw seq_tendsto_ae_seq

lemma seq_tendsto_ae_seq_spec (hfg : tendsto_in_measure μ f at_top g)
  (n k : ℕ) (hn : seq_tendsto_ae_seq hfg n ≤ k) :
  μ {x | 2⁻¹ ^ n ≤ dist (f k x) (g x)} ≤ 2⁻¹ ^ n :=
begin
  cases n,
  { exact classical.some_spec (exists_nat_measure_lt_two_inv hfg 0) k hn },
  { exact classical.some_spec (exists_nat_measure_lt_two_inv hfg _) _
      (le_trans (le_max_left _ _) hn) }
end

lemma seq_tendsto_ae_seq_strict_mono (hfg : tendsto_in_measure μ f at_top g) :
  strict_mono (seq_tendsto_ae_seq hfg) :=
begin
  refine strict_mono_nat_of_lt_succ (λ n, _),
  rw seq_tendsto_ae_seq_succ,
  exact lt_of_lt_of_le (lt_add_one $ seq_tendsto_ae_seq hfg n) (le_max_right _ _),
end

end exists_seq_tendsto_ae

/-- If `f` is a sequence of functions which converges in measure to `g`, then there exists a
subsequence of `f` which converges a.e. to `g`. -/
lemma tendsto_in_measure.exists_seq_tendsto_ae
  (hfg : tendsto_in_measure μ f at_top g) :
  ∃ ns : ℕ → ℕ, strict_mono ns ∧ ∀ᵐ x ∂μ, tendsto (λ i, f (ns i) x) at_top (𝓝 (g x)) :=
begin
  /- Since `f` tends to `g` in measure, it has a subsequence `k ↦ f (ns k)` such that
  `μ {|f (ns k) - g| ≥ 2⁻ᵏ} ≤ 2⁻ᵏ` for all `k`. Defining
  `s := ⋂ k, ⋃ i ≥ k, {|f (ns k) - g| ≥ 2⁻ᵏ}`, we see that `μ s = 0` by the
  first Borel-Cantelli lemma.

  On the other hand, as `s` is precisely the set for which `f (ns k)`
  doesn't converge to `g`, `f (ns k)` converges almost everywhere to `g` as required. -/
  have h_lt_ε_real : ∀ (ε : ℝ) (hε : 0 < ε), ∃ k : ℕ, 2 * 2⁻¹ ^ k < ε,
  { intros ε hε,
    obtain ⟨k, h_k⟩ : ∃ (k : ℕ), 2⁻¹ ^ k < ε := exists_pow_lt_of_lt_one hε (by norm_num),
    refine ⟨k + 1, (le_of_eq _).trans_lt h_k⟩,
    rw pow_add, ring },
  set ns := exists_seq_tendsto_ae.seq_tendsto_ae_seq hfg,
  use ns,
  let S := λ k, {x | 2⁻¹ ^ k ≤ dist (f (ns k) x) (g x)},
  have hμS_le : ∀ k, μ (S k) ≤ 2⁻¹ ^ k :=
    λ k, exists_seq_tendsto_ae.seq_tendsto_ae_seq_spec hfg k (ns k) (le_rfl),
  set s := filter.at_top.limsup S with hs,
  have hμs : μ s = 0,
  { refine measure_limsup_eq_zero (ne_of_lt $ lt_of_le_of_lt (ennreal.tsum_le_tsum hμS_le) _),
    simp only [ennreal.tsum_geometric, ennreal.one_sub_inv_two, inv_inv],
    dec_trivial },
  have h_tendsto : ∀ x ∈ sᶜ, tendsto (λ i, f (ns i) x) at_top (𝓝 (g x)),
  { refine λ x hx, metric.tendsto_at_top.mpr (λ ε hε, _),
    rw [hs, limsup_eq_infi_supr_of_nat] at hx,
    simp only [set.supr_eq_Union, set.infi_eq_Inter, set.compl_Inter, set.compl_Union,
      set.mem_Union, set.mem_Inter, set.mem_compl_eq, set.mem_set_of_eq, not_le] at hx,
    obtain ⟨N, hNx⟩ := hx,
    obtain ⟨k, hk_lt_ε⟩ := h_lt_ε_real ε hε,
    refine ⟨max N (k - 1), λ n hn_ge, lt_of_le_of_lt _ hk_lt_ε⟩,
    specialize hNx n ((le_max_left _ _).trans hn_ge),
    have h_inv_n_le_k : (2 : ℝ)⁻¹ ^ n ≤ 2 * 2⁻¹ ^ k,
    { rw [mul_comm, ← inv_mul_le_iff' (@two_pos ℝ _ _)],
      conv_lhs { congr, rw ← pow_one (2 : ℝ)⁻¹ },
      rw [← pow_add, add_comm],
      exact pow_le_pow_of_le_one ((one_div (2 : ℝ)) ▸ one_half_pos.le) (inv_le_one one_le_two)
        ((le_tsub_add.trans (add_le_add_right (le_max_right _ _) 1)).trans
        (add_le_add_right hn_ge 1)) },
    exact le_trans hNx.le h_inv_n_le_k },
  rw ae_iff,
  refine ⟨exists_seq_tendsto_ae.seq_tendsto_ae_seq_strict_mono hfg, measure_mono_null (λ x, _) hμs⟩,
  rw [set.mem_set_of_eq, ← @not_not (x ∈ s), not_imp_not],
  exact h_tendsto x,
end

lemma tendsto_in_measure.exists_seq_tendsto_in_measure_at_top
  {u : filter ι} [ne_bot u] [is_countably_generated u] {f : ι → α → E} {g : α → E}
  (hfg : tendsto_in_measure μ f u g) :
  ∃ ns : ℕ → ι, tendsto_in_measure μ (λ n, f (ns n)) at_top g :=
begin
  obtain ⟨ns, h_tendsto_ns⟩ : ∃ (ns : ℕ → ι), tendsto ns at_top u := exists_seq_tendsto u,
  exact ⟨ns, λ ε hε, (hfg ε hε).comp h_tendsto_ns⟩,
end

lemma tendsto_in_measure.exists_seq_tendsto_ae'
  {u : filter ι} [ne_bot u] [is_countably_generated u] {f : ι → α → E} {g : α → E}
  (hfg : tendsto_in_measure μ f u g) :
  ∃ ns : ℕ → ι, ∀ᵐ x ∂μ, tendsto (λ i, f (ns i) x) at_top (𝓝 (g x)) :=
begin
  obtain ⟨ms, hms⟩ := hfg.exists_seq_tendsto_in_measure_at_top,
  obtain ⟨ns, -, hns⟩ := hms.exists_seq_tendsto_ae,
  exact ⟨ms ∘ ns, hns⟩,
end

end exists_seq_tendsto_ae

section ae_measurable_of

variables [measurable_space E] [normed_group E] [borel_space E]

lemma tendsto_in_measure.ae_measurable
  {u : filter ι} [ne_bot u] [is_countably_generated u]
  {f : ι → α → E} {g : α → E} (hf : ∀ n, ae_measurable (f n) μ)
  (h_tendsto : tendsto_in_measure μ f u g) :
  ae_measurable g μ :=
begin
  obtain ⟨ns, hns⟩ := h_tendsto.exists_seq_tendsto_ae',
  exact ae_measurable_of_tendsto_metric_ae at_top (λ n, hf (ns n)) hns,
end

end ae_measurable_of

section tendsto_in_measure_of

variables [normed_group E] {p : ℝ≥0∞}
variables {f : ι → α → E} {g : α → E}

/-- This lemma is superceded by `measure_theory.tendsto_in_measure_of_tendsto_snorm` where we
allow `p = ∞` and only require `ae_strongly_measurable`. -/
lemma tendsto_in_measure_of_tendsto_snorm_of_strongly_measurable
  (hp_ne_zero : p ≠ 0) (hp_ne_top : p ≠ ∞)
  (hf : ∀ n, strongly_measurable (f n)) (hg : strongly_measurable g) {l : filter ι}
  (hfg : tendsto (λ n, snorm (f n - g) p μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  intros ε hε,
  replace hfg := ennreal.tendsto.const_mul (tendsto.ennrpow_const p.to_real hfg)
    (or.inr $ @ennreal.of_real_ne_top (1 / ε ^ (p.to_real))),
  simp only [mul_zero, ennreal.zero_rpow_of_pos (ennreal.to_real_pos hp_ne_zero hp_ne_top)] at hfg,
  rw ennreal.tendsto_nhds_zero at hfg ⊢,
  intros δ hδ,
  refine (hfg δ hδ).mono (λ n hn, _),
  refine le_trans _ hn,
  rw [ennreal.of_real_div_of_pos (real.rpow_pos_of_pos hε _), ennreal.of_real_one, mul_comm,
    mul_one_div, ennreal.le_div_iff_mul_le _ (or.inl (ennreal.of_real_ne_top)), mul_comm],
  { convert mul_meas_ge_le_pow_snorm' μ hp_ne_zero hp_ne_top ((hf n).sub hg).ae_strongly_measurable
      (ennreal.of_real ε),
    { exact (ennreal.of_real_rpow_of_pos hε).symm },
    { ext x,
      rw [dist_eq_norm, ← ennreal.of_real_le_of_real_iff (norm_nonneg _),
          of_real_norm_eq_coe_nnnorm],
      exact iff.rfl } },
  { rw [ne, ennreal.of_real_eq_zero, not_le],
    exact or.inl (real.rpow_pos_of_pos hε _) },
end

/-- This lemma is superceded by `measure_theory.tendsto_in_measure_of_tendsto_snorm` where we
allow `p = ∞`. -/
lemma tendsto_in_measure_of_tendsto_snorm_of_ne_top
  (hp_ne_zero : p ≠ 0) (hp_ne_top : p ≠ ∞)
  (hf : ∀ n, ae_strongly_measurable (f n) μ) (hg : ae_strongly_measurable g μ) {l : filter ι}
  (hfg : tendsto (λ n, snorm (f n - g) p μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  refine tendsto_in_measure.congr (λ i, (hf i).ae_eq_mk.symm) hg.ae_eq_mk.symm _,
  refine tendsto_in_measure_of_tendsto_snorm_of_strongly_measurable hp_ne_zero hp_ne_top
    (λ i, (hf i).strongly_measurable_mk) hg.strongly_measurable_mk _,
  have : (λ n, snorm ((hf n).mk (f n) - hg.mk g) p μ) = (λ n, snorm (f n - g) p μ),
  { ext1 n, refine snorm_congr_ae (eventually_eq.sub (hf n).ae_eq_mk.symm hg.ae_eq_mk.symm), },
  rw this,
  exact hfg,
end

/-- See also `measure_theory.tendsto_in_measure_of_tendsto_snorm` which work for general
Lp-convergence for all `p ≠ 0`. -/
lemma tendsto_in_measure_of_tendsto_snorm_top {E} [normed_group E] {f : ι → α → E} {g : α → E}
  {l : filter ι} (hfg : tendsto (λ n, snorm (f n - g) ∞ μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  intros δ hδ,
  simp only [snorm_exponent_top, snorm_ess_sup] at hfg,
  rw ennreal.tendsto_nhds_zero at hfg ⊢,
  intros ε hε,
  specialize hfg ((ennreal.of_real δ) / 2) (ennreal.div_pos_iff.2
    ⟨(ennreal.of_real_pos.2 hδ).ne.symm, ennreal.two_ne_top⟩),
  refine hfg.mono (λ n hn, _),
  simp only [true_and, gt_iff_lt, ge_iff_le, zero_tsub, zero_le, zero_add, set.mem_Icc,
    pi.sub_apply] at *,
  have : ess_sup (λ (x : α), (∥f n x - g x∥₊ : ℝ≥0∞)) μ < ennreal.of_real δ :=
    lt_of_le_of_lt hn (ennreal.half_lt_self (ennreal.of_real_pos.2 hδ).ne.symm
      ennreal.of_real_lt_top.ne),
  refine ((le_of_eq _).trans (ae_lt_of_ess_sup_lt this).le).trans hε.le,
  congr' with x,
  simp only [ennreal.of_real_le_iff_le_to_real ennreal.coe_lt_top.ne, ennreal.coe_to_real,
    not_lt, coe_nnnorm, set.mem_set_of_eq, set.mem_compl_eq],
  rw ← dist_eq_norm (f n x) (g x),
  refl
end

/-- Convergence in Lp implies convergence in measure. -/
lemma tendsto_in_measure_of_tendsto_snorm {l : filter ι}
  (hp_ne_zero : p ≠ 0) (hf : ∀ n, ae_strongly_measurable (f n) μ) (hg : ae_strongly_measurable g μ)
  (hfg : tendsto (λ n, snorm (f n - g) p μ) l (𝓝 0)) :
  tendsto_in_measure μ f l g :=
begin
  by_cases hp_ne_top : p = ∞,
  { subst hp_ne_top,
    exact tendsto_in_measure_of_tendsto_snorm_top hfg },
  { exact tendsto_in_measure_of_tendsto_snorm_of_ne_top hp_ne_zero hp_ne_top hf hg hfg }
end

/-- Convergence in Lp implies convergence in measure. -/
lemma tendsto_in_measure_of_tendsto_Lp [hp : fact (1 ≤ p)]
  {f : ι → Lp E p μ} {g : Lp E p μ} {l : filter ι} (hfg : tendsto f l (𝓝 g)) :
  tendsto_in_measure μ (λ n, f n) l g :=
tendsto_in_measure_of_tendsto_snorm (ennreal.zero_lt_one.trans_le hp.elim).ne.symm
  (λ n, Lp.ae_strongly_measurable _) (Lp.ae_strongly_measurable _)
  ((Lp.tendsto_Lp_iff_tendsto_ℒp' _ _).mp hfg)

end tendsto_in_measure_of

end measure_theory