/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.sites.canonical
! leanprover-community/mathlib commit 9e7c80f638149bfb3504ba8ff48dfdbfc949fb1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Sites.SheafOfTypes

/-!
# The canonical topology on a category

We define the finest (largest) Grothendieck topology for which a given presheaf `P` is a sheaf.
This is well defined since if `P` is a sheaf for a topology `J`, then it is a sheaf for any
coarser (smaller) topology. Nonetheless we define the topology explicitly by specifying its sieves:
A sieve `S` on `X` is covering for `finest_topology_single P` iff
  for any `f : Y ⟶ X`, `P` satisfies the sheaf axiom for `S.pullback f`.
Showing that this is a genuine Grothendieck topology (namely that it satisfies the transitivity
axiom) forms the bulk of this file.

This generalises to a set of presheaves, giving the topology `finest_topology Ps` which is the
finest topology for which every presheaf in `Ps` is a sheaf.
Using `Ps` as the set of representable presheaves defines the `canonical_topology`: the finest
topology for which every representable is a sheaf.

A Grothendieck topology is called `subcanonical` if it is smaller than the canonical topology,
equivalently it is subcanonical iff every representable presheaf is a sheaf.

## References
* https://ncatlab.org/nlab/show/canonical+topology
* https://ncatlab.org/nlab/show/subcanonical+coverage
* https://stacks.math.columbia.edu/tag/00Z9
* https://math.stackexchange.com/a/358709/
-/

universe v u

namespace CategoryTheory

open CategoryTheory Category Limits Sieve Classical

variable {C : Type u} [Category.{v} C]

namespace Sheaf

variable {P : Cᵒᵖ ⥤ Type v}

variable {X Y : C} {S : Sieve X} {R : Presieve X}

variable (J J₂ : GrothendieckTopology C)

/--
To show `P` is a sheaf for the binding of `U` with `B`, it suffices to show that `P` is a sheaf for
`U`, that `P` is a sheaf for each sieve in `B`, and that it is separated for any pullback of any
sieve in `B`.

This is mostly an auxiliary lemma to show `is_sheaf_for_trans`.
Adapted from [Elephant], Lemma C2.1.7(i) with suggestions as mentioned in
https://math.stackexchange.com/a/358709/
-/
theorem isSheafFor_bind (P : Cᵒᵖ ⥤ Type v) (U : Sieve X) (B : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄, U f → Sieve Y)
    (hU : Presieve.IsSheafFor P U) (hB : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), Presieve.IsSheafFor P (B hf))
    (hB' :
      ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (h : U f) ⦃Z⦄ (g : Z ⟶ Y), Presieve.IsSeparatedFor P ((B h).pullback g)) :
    Presieve.IsSheafFor P (Sieve.bind U B) :=
  by
  intro s hs
  let y : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), presieve.family_of_elements P (B hf) := fun Y f hf Z g hg =>
    s _ (presieve.bind_comp _ _ hg)
  have hy : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), (y hf).Compatible :=
    by
    intro Y f H Y₁ Y₂ Z g₁ g₂ f₁ f₂ hf₁ hf₂ comm
    apply hs
    apply reassoc_of comm
  let t : presieve.family_of_elements P U := fun Y f hf => (hB hf).amalgamate (y hf) (hy hf)
  have ht : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : U f), (y hf).IsAmalgamation (t f hf) := fun Y f hf =>
    (hB hf).IsAmalgamation _
  have hT : t.compatible := by
    rw [presieve.compatible_iff_sieve_compatible]
    intro Z W f h hf
    apply (hB (U.downward_closed hf h)).IsSeparatedFor.ext
    intro Y l hl
    apply (hB' hf (l ≫ h)).ext
    intro M m hm
    have : bind U B (m ≫ l ≫ h ≫ f) :=
      by
      have : bind U B _ := presieve.bind_comp f hf hm
      simpa using this
    trans s (m ≫ l ≫ h ≫ f) this
    · have := ht (U.downward_closed hf h) _ ((B _).downward_closed hl m)
      rw [op_comp, functor_to_types.map_comp_apply] at this
      rw [this]
      change s _ _ = s _ _
      simp
    · have : s _ _ = _ := (ht hf _ hm).symm
      simp only [assoc] at this
      rw [this]
      simp
  refine' ⟨hU.amalgamate t hT, _, _⟩
  · rintro Z _ ⟨Y, f, g, hg, hf, rfl⟩
    rw [op_comp, functor_to_types.map_comp_apply, presieve.is_sheaf_for.valid_glue _ _ _ hg]
    apply ht hg _ hf
  · intro y hy
    apply hU.is_separated_for.ext
    intro Y f hf
    apply (hB hf).IsSeparatedFor.ext
    intro Z g hg
    rw [← functor_to_types.map_comp_apply, ← op_comp, hy _ (presieve.bind_comp _ _ hg),
      hU.valid_glue _ _ hf, ht hf _ hg]
#align category_theory.sheaf.is_sheaf_for_bind CategoryTheory.Sheaf.isSheafFor_bind

/-- Given two sieves `R` and `S`, to show that `P` is a sheaf for `S`, we can show:
* `P` is a sheaf for `R`
* `P` is a sheaf for the pullback of `S` along any arrow in `R`
* `P` is separated for the pullback of `R` along any arrow in `S`.

This is mostly an auxiliary lemma to construct `finest_topology`.
Adapted from [Elephant], Lemma C2.1.7(ii) with suggestions as mentioned in
https://math.stackexchange.com/a/358709
-/
theorem isSheafFor_trans (P : Cᵒᵖ ⥤ Type v) (R S : Sieve X) (hR : Presieve.IsSheafFor P R)
    (hR' : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : S f), Presieve.IsSeparatedFor P (R.pullback f))
    (hS : ∀ ⦃Y⦄ ⦃f : Y ⟶ X⦄ (hf : R f), Presieve.IsSheafFor P (S.pullback f)) :
    Presieve.IsSheafFor P S :=
  by
  have : (bind R fun Y f hf => S.pullback f : presieve X) ≤ S :=
    by
    rintro Z f ⟨W, f, g, hg, hf : S _, rfl⟩
    apply hf
  apply presieve.is_sheaf_for_subsieve_aux P this
  apply is_sheaf_for_bind _ _ _ hR hS
  · intro Y f hf Z g
    dsimp
    rw [← pullback_comp]
    apply (hS (R.downward_closed hf _)).IsSeparatedFor
  · intro Y f hf
    have : sieve.pullback f (bind R fun T (k : T ⟶ X) (hf : R k) => pullback k S) = R.pullback f :=
      by
      ext (Z g)
      constructor
      · rintro ⟨W, k, l, hl, _, comm⟩
        rw [pullback_apply, ← comm]
        simp [hl]
      · intro a
        refine' ⟨Z, 𝟙 Z, _, a, _⟩
        simp [hf]
    rw [this]
    apply hR' hf
#align category_theory.sheaf.is_sheaf_for_trans CategoryTheory.Sheaf.isSheafFor_trans

/-- Construct the finest (largest) Grothendieck topology for which the given presheaf is a sheaf.

This is a special case of https://stacks.math.columbia.edu/tag/00Z9, but following a different
proof (see the comments there).
-/
def finestTopologySingle (P : Cᵒᵖ ⥤ Type v) : GrothendieckTopology C
    where
  sieves X S := ∀ (Y) (f : Y ⟶ X), Presieve.IsSheafFor P (S.pullback f)
  top_mem' X Y f := by
    rw [sieve.pullback_top]
    exact presieve.is_sheaf_for_top_sieve P
  pullback_stable' X Y S f hS Z g := by
    rw [← pullback_comp]
    apply hS
  transitive' X S hS R hR Z g :=
    by
    -- This is the hard part of the construction, showing that the given set of sieves satisfies
    -- the transitivity axiom.
    refine' is_sheaf_for_trans P (pullback g S) _ (hS Z g) _ _
    · intro Y f hf
      rw [← pullback_comp]
      apply (hS _ _).IsSeparatedFor
    · intro Y f hf
      have := hR hf _ (𝟙 _)
      rw [pullback_id, pullback_comp] at this
      apply this
#align category_theory.sheaf.finest_topology_single CategoryTheory.Sheaf.finestTopologySingle

/--
Construct the finest (largest) Grothendieck topology for which all the given presheaves are sheaves.

This is equal to the construction of <https://stacks.math.columbia.edu/tag/00Z9>.
-/
def finestTopology (Ps : Set (Cᵒᵖ ⥤ Type v)) : GrothendieckTopology C :=
  infₛ (finestTopologySingle '' Ps)
#align category_theory.sheaf.finest_topology CategoryTheory.Sheaf.finestTopology

/-- Check that if `P ∈ Ps`, then `P` is indeed a sheaf for the finest topology on `Ps`. -/
theorem sheaf_for_finestTopology (Ps : Set (Cᵒᵖ ⥤ Type v)) (h : P ∈ Ps) :
    Presieve.IsSheaf (finestTopology Ps) P := fun X S hS => by
  simpa using hS _ ⟨⟨_, _, ⟨_, h, rfl⟩, rfl⟩, rfl⟩ _ (𝟙 _)
#align category_theory.sheaf.sheaf_for_finest_topology CategoryTheory.Sheaf.sheaf_for_finestTopology

/--
Check that if each `P ∈ Ps` is a sheaf for `J`, then `J` is a subtopology of `finest_topology Ps`.
-/
theorem le_finestTopology (Ps : Set (Cᵒᵖ ⥤ Type v)) (J : GrothendieckTopology C)
    (hJ : ∀ P ∈ Ps, Presieve.IsSheaf J P) : J ≤ finestTopology Ps :=
  by
  rintro X S hS _ ⟨⟨_, _, ⟨P, hP, rfl⟩, rfl⟩, rfl⟩
  intro Y f
  -- this can't be combined with the previous because the `subst` is applied at the end
  exact hJ P hP (S.pullback f) (J.pullback_stable f hS)
#align category_theory.sheaf.le_finest_topology CategoryTheory.Sheaf.le_finestTopology

/-- The `canonical_topology` on a category is the finest (largest) topology for which every
representable presheaf is a sheaf.

See <https://stacks.math.columbia.edu/tag/00ZA>
-/
def canonicalTopology (C : Type u) [Category.{v} C] : GrothendieckTopology C :=
  finestTopology (Set.range yoneda.obj)
#align category_theory.sheaf.canonical_topology CategoryTheory.Sheaf.canonicalTopology

/-- `yoneda.obj X` is a sheaf for the canonical topology. -/
theorem isSheaf_yoneda_obj (X : C) : Presieve.IsSheaf (canonicalTopology C) (yoneda.obj X) :=
  fun Y S hS => sheaf_for_finestTopology _ (Set.mem_range_self _) _ hS
#align category_theory.sheaf.is_sheaf_yoneda_obj CategoryTheory.Sheaf.isSheaf_yoneda_obj

/-- A representable functor is a sheaf for the canonical topology. -/
theorem isSheaf_of_representable (P : Cᵒᵖ ⥤ Type v) [P.Representable] :
    Presieve.IsSheaf (canonicalTopology C) P :=
  Presieve.isSheaf_iso (canonicalTopology C) P.reprW (isSheaf_yoneda_obj _)
#align category_theory.sheaf.is_sheaf_of_representable CategoryTheory.Sheaf.isSheaf_of_representable

/-- A subcanonical topology is a topology which is smaller than the canonical topology.
Equivalently, a topology is subcanonical iff every representable is a sheaf.
-/
def Subcanonical (J : GrothendieckTopology C) : Prop :=
  J ≤ canonicalTopology C
#align category_theory.sheaf.subcanonical CategoryTheory.Sheaf.Subcanonical

namespace Subcanonical

/-- If every functor `yoneda.obj X` is a `J`-sheaf, then `J` is subcanonical. -/
theorem of_yoneda_isSheaf (J : GrothendieckTopology C)
    (h : ∀ X, Presieve.IsSheaf J (yoneda.obj X)) : Subcanonical J :=
  le_finestTopology _ _
    (by
      rintro P ⟨X, rfl⟩
      apply h)
#align category_theory.sheaf.subcanonical.of_yoneda_is_sheaf CategoryTheory.Sheaf.Subcanonical.of_yoneda_isSheaf

/-- If `J` is subcanonical, then any representable is a `J`-sheaf. -/
theorem isSheaf_of_representable {J : GrothendieckTopology C} (hJ : Subcanonical J)
    (P : Cᵒᵖ ⥤ Type v) [P.Representable] : Presieve.IsSheaf J P :=
  Presieve.isSheaf_of_le _ hJ (isSheaf_of_representable P)
#align category_theory.sheaf.subcanonical.is_sheaf_of_representable CategoryTheory.Sheaf.Subcanonical.isSheaf_of_representable

end Subcanonical

end Sheaf

end CategoryTheory


import category_theory.Fintype
import data.real.nnreal
import laurent_measures.basic
import order.filter.at_top_bot
import pseudo_normed_group.basic
import pseudo_normed_group.category
import real_measures
import ring_theory.principal_ideal_domain
import ring_theory.power_series.basic

/-- SECTIONS
Everything takes place in the `namespace theta`

* Section `aux_lemmas` contain some technicalities concerning convergent sequence
* Section `summability` shows that the series defining `ϑ` converges
* In Section `theta_surjective` We define the map ϑ : (laurent_measures r `S`) → ℝ and we
  show it is surjective.
* Section `ker_theta` studies the kernel of `ϑ`, in particular showing it is principal.

   VARIABLES
* The variable `ξ : ℝ` here corresponds to `r'` of `Analytic.pdf`, so that, for every `r`, `ϑ ξ r`
  is`θ_r'` as a map from `r`-convergent Laurent measures to `ℝ`. It is supposed to be positive almost
everywhere, and this is recorded as a `fact`.
* The variable `x : ℝ` is defined globally in Sections `aux_lemmas` and `summability`.
* The variable `r : ℝ≥0` (specifying the radius of convergency of `laurent_measures` makes its
  first appearance in Section `theta_surjective`, but it is not globally defined. Whenever it occurs
  it is assumed to be positive and strictly smaller than `1`, both recorded as facts.
-/

noncomputable theory

open set filter function classical finset nat
open_locale topological_space classical nnreal big_operators

-- def laurent_measures.to_Rfct (r : ℝ≥0) :
--   (laurent_measures r (Fintype.of punit)) → (ℤ → ℤ) := λ ⟨F, _⟩, (F punit.star)

namespace theta

variable (ξ : ℝ)

/--The basic function computing the **integer-valued** `ξ`-adic expansion of `x` -/
noncomputable def y (x : ℝ) : ℕ → ℝ
| 0         := x
| (n + 1)   := (y n) - (⌊(((y n) / ξ ^ n) : ℝ)⌋ : ℝ) * ξ ^ n

section aux_lemmas

variable (x : ℝ)
variable [fact (0 < ξ)]

lemma bdd_floor : bdd_above (range (λ n : ℕ, (⌊ y ξ x n / ξ ^ n⌋ : ℝ))) :=
begin
  use (max x ξ ⁻¹ : ℝ),
  intros z hz,
  obtain ⟨m, h_mz⟩ := (set.mem_range).mp hz,
    by_cases hm : m = 0,
  { rw [hm, pow_zero, div_one] at h_mz,
    rw [← h_mz, y, le_max_iff],
    apply or.intro_left,
    exact int.floor_le x },
  rw ← h_mz,
  apply (int.floor_le _).trans,
  obtain ⟨k, hk⟩ : ∃ k : ℕ, m = k + 1 := nat.exists_eq_succ_of_ne_zero hm,
  rw [hk, y],
  have : ξ ^ k ≠ 0 := ne_of_gt (pow_pos (fact.out _) k),
  calc (y ξ x k - ↑⌊y ξ x k / ξ ^ k⌋ * ξ ^ k) / ξ ^ (k + 1) =
              (y ξ x k - ↑⌊y ξ x k / ξ ^ k⌋ * ξ ^ k) / (ξ ^ k * ξ) : by {rw [pow_add, pow_one]}
        ... = (y ξ x k - ↑⌊y ξ x k / ξ ^ k⌋ * ξ ^ k) / ξ ^ k / ξ : by {field_simp}
        ... = (y ξ x k / ξ ^ k - ↑⌊y ξ x k / ξ ^ k⌋ * ξ ^ k / ξ ^ k) / ξ : by {rw [sub_div]}
        ... = (y ξ x k / ξ ^ k - ↑⌊y ξ x k / ξ ^ k⌋) / ξ : by {simp only [mul_div_cancel,
                                                                      this, ne.def, not_false_iff]}
        ... ≤ 1 / ξ : div_le_div_of_le (le_of_lt _) (le_of_lt _)
        ... ≤ max x ξ ⁻¹ : by {field_simp},
  exact fact.out _,
  {rw [sub_lt_iff_lt_add, add_comm], from (int.lt_floor_add_one _)},
end

lemma eventually_pos_y : ∀ n : ℕ, n ≥ 1 → 0 ≤ y ξ x n :=
begin
  have h_pos : ∀ n : ℕ, n ≥ 1 → ξ ^ n > 0 := λ n _, pow_pos (fact.out _) n,
  have : ∀ n : ℕ, n ≥ 1 →  (y ξ x n) / ξ ^ n ≥ ⌊(((y ξ x n) / ξ ^ n) : ℝ)⌋ := λ n _, int.floor_le _,
  intros n hn₁,
  by_cases hn₀ : n = 1,
  { rw [hn₀, y,pow_zero, div_one, mul_one, sub_nonneg], apply int.floor_le },
  { replace hn₁ : n > 1, {apply (lt_of_le_of_ne hn₁), tauto },
    obtain ⟨m, hm⟩ : ∃ m : ℕ, m ≥ 1 ∧ n = m + 1,
    use ⟨n - 1, and.intro (nat.le_pred_of_lt hn₁) (nat.sub_add_cancel (le_of_lt hn₁)).symm⟩,
    rw [hm.2, y],
    replace this := (le_div_iff (h_pos m hm.1)).mp (this m hm.1),
    rwa ← sub_nonneg at this },
end

lemma eventually_pos_floor : ∀ n : ℕ, n ≥ 1 → (⌊((y ξ x n) / ξ ^ n )⌋ : ℝ) ≥ 0 :=
begin
  have h_pos : ∀ n : ℕ, n ≥ 1 → ξ ^ n > 0 := λ n _, pow_pos (fact.out _) n,
  intros n hn,
  norm_cast,
  apply int.floor_nonneg.mpr,
  exact div_nonneg (eventually_pos_y ξ x n hn) (le_of_lt (h_pos n hn)),
end

lemma eventually_le : ∀ n, n ≥ 1 → y ξ x (n + 1) ≤ (y ξ x n) :=
begin
  have h_pos : ∀ n : ℕ, n ≥ 1 → ξ ^ n > 0 := λ n _, pow_pos (fact.out _) n,
  intros n hn,
  rw y,
  apply sub_le_self (y ξ x n),
  apply mul_nonneg _ (le_of_lt (h_pos n hn)),
  exact eventually_pos_floor ξ x n hn,
end

lemma eventually_le_one {n : ℕ} (hn : n ≥ 1) : (y ξ x n) ≤ (y ξ x 1) :=
begin
  induction hn with n hn h_ind,
  exact le_of_eq (refl _),
  have := (eventually_le ξ x n hn).trans h_ind,
  rwa nat.succ_eq_add_one,
end

def aux_y : ℕ → ℝ := λ n, if n = 0 then y ξ x 1 else y ξ x n

lemma eventually_antitone : antitone (aux_y ξ x) :=
begin
  apply antitone_nat_of_succ_le,
  intro n,
  by_cases hn : n = 0,
  {rw [hn, zero_add, aux_y],
    simp only [nat.one_ne_zero, if_true, eq_self_iff_true, if_false] },
  { simp only [aux_y, if_neg hn, function.comp_app, nat.succ_ne_zero, if_false],
    replace hn : n ≥ 1 := le_of_not_gt ((not_iff_not.mpr nat.lt_one_iff).mpr hn),
    exact eventually_le ξ x n hn },
end

lemma limit_neg_geometric [fact (ξ < 1)] : tendsto (λ i : ℕ, - ξ ^ i) at_top (𝓝 0) :=
begin
  apply summable.tendsto_at_top_zero,
  rw summable_neg_iff,
  apply summable_geometric_of_abs_lt_1,
  rw abs_of_pos,
  all_goals {exact fact.out _},
end

end aux_lemmas

section summability

variable (x : ℝ)

lemma finite_sum (n : ℕ) : (y ξ x (n + 1) : ℝ) =
  x - ∑ i in range(n + 1),  (⌊(((y ξ x i) / ξ ^ i) : ℝ)⌋ : ℝ) * (ξ ^ i) :=
begin
  induction n with n h_ind,
  { rw [zero_add, range_one, sum_singleton], refl },
  { replace h_ind : (x - (y ξ x (n + 1)) : ℝ) =
    ∑ i in range(n + 1),  (⌊(y ξ x i / ξ ^ i : ℝ)⌋ : ℝ) * ξ ^ i := by {rw [sub_eq_iff_eq_add,
      ← sub_eq_iff_eq_add', h_ind] },
    nth_rewrite_rhs 2 [nat.succ_eq_add_one, ← nat.succ_eq_add_one, range_succ],
    rw [sum_insert, nat.succ_eq_add_one, ← sub_sub, ← h_ind, sub_sub, add_sub, add_comm _ x,
      ← add_sub, ← sub_sub, sub_self, zero_sub, neg_sub],
    refl,
    simp },
end

lemma finite_sum' (n : ℕ) : x - (y ξ x n : ℝ) =
  ∑ i in range (n),  (⌊(((y ξ x i) / ξ ^ i) : ℝ)⌋ : ℝ) * (ξ ^ i) :=
begin
  by_cases hn : n =0,
  { rw [hn, range_zero, sum_empty, sub_eq_zero], refl },
  { replace hn : n ≥ 1 := le_of_not_gt ((not_iff_not.mpr nat.lt_one_iff).mpr hn),
    rw [← (nat.sub_add_cancel hn), finite_sum ξ x (n - 1)],
    simp only [sub_sub_cancel] at * },
end

variable [fact (0 < ξ)]

lemma exists_limit_y : ∃ a, tendsto (λ n, y ξ x n) at_top (𝓝 a) :=
begin
  have h_bdd : bdd_below (range (aux_y ξ x)),
  { use 0,
    intros z hz,
    obtain ⟨m, h_mz⟩ := (set.mem_range).mp hz,
    by_cases hm : m = 0,
    { simp_rw [hm, aux_y, if_pos] at h_mz,
      rw ← h_mz,
      exact eventually_pos_y ξ x 1 (le_of_eq (refl _)), },
      simp_rw [aux_y, (if_neg hm)] at h_mz,
      rw ← h_mz,
      replace hm : m ≥ 1 := le_of_not_gt ((not_iff_not.mpr nat.lt_one_iff).mpr hm),
      exact eventually_pos_y ξ x m hm },
  have := tendsto_at_top_cinfi (eventually_antitone ξ x) h_bdd,
  use (⨅ (i : ℕ), aux_y ξ x i),
  apply @tendsto.congr' _ _ (aux_y ξ x) _ _ _ _ this,
  apply (filter.eventually_eq_iff_exists_mem).mpr,
  use {n | n ≥ 1},
  simp only [mem_at_top_sets, ge_iff_le, mem_set_of_eq],
  use 1,
  simp only [imp_self, forall_const],
  intros n hn,
  replace hn : n ≥ 1 := by {simp only [*, ge_iff_le, mem_set_of_eq] at * },
  have := ne_of_lt (lt_of_lt_of_le nat.zero_lt_one hn),
  rw [aux_y, ite_eq_right_iff],
  tauto,
end

lemma summable_norm (r : ℝ≥0) (hr₁ : r < 1) :
      summable (λ i, ∥⌊(y ξ x i / ξ ^ i : ℝ)⌋∥ * (r ^ i)) :=
begin
  by_cases hr₀ : r = 0,
  { rw hr₀,
    apply @summable_of_ne_finset_zero _ _ _ _ _ (range 1),
    simp only [int.cast_eq_zero, nnreal.coe_zero, zero_pow_eq_zero, finset.mem_singleton,
      mul_eq_zero, range_one],
    intros _ hb,
    exact or.intro_right _ (nat.pos_of_ne_zero hb) },
  have h_nonneg : ∀ n : ℕ, n ≥ 1 → (r ^ n : ℝ) ≥ 0 := λ n _, pow_nonneg (r.2) n,
  have H : ∀ j : {i // i ∉ range 1}, j.1 ≥ 1,
  { rintro ⟨n, h_n⟩,
    simp only [ge_iff_le, finset.mem_singleton, range_one] at h_n,
    exact le_of_not_gt ((not_iff_not.mpr nat.lt_one_iff).mpr h_n) },
  apply (finset.summable_compl_iff (finset.range 1)).mp,
  swap, apply_instance,
  have h_nonneg : ∀ i : {i // i ∉ range 1}, (∥⌊(y ξ x i.1 / ξ ^ i.1 : ℝ)⌋∥) * r ^ i.1 ≥ 0,
    { intro i,
      apply mul_nonneg _ (h_nonneg i.1 (H i)),
      simp only [norm_nonneg] },
  obtain ⟨μ, hμ⟩  := bdd_floor ξ x,
  have h_bdd : ∀ i : {i // i ∉ range 1}, (∥⌊(y ξ x i.1 / ξ ^ i.1 : ℝ)⌋∥) ≤ μ,
  { rw upper_bounds at hμ,
    simp only [*, forall_apply_eq_imp_iff', lt_one_iff, set.mem_range, forall_const,
      forall_exists_index, nnreal.zero_le_coe, ge_iff_le, set.mem_set_of_eq, implies_true_iff,
      nonempty_of_inhabited, subtype.forall, pow_nonneg, finset.mem_range, subtype.val_eq_coe] at *,
    intros a ha,
    rw [subtype.coe_mk, int.norm_eq_abs],
    replace ha : a ≥ 1 := le_of_not_gt ((not_iff_not.mpr nat.lt_one_iff).mpr ha),
    rwa [abs_eq_self.mpr (eventually_pos_floor ξ x a ha)],
    exact hμ a },
  replace h_bdd : ∀ i : {i // i ∉ range 1}, (∥⌊(y ξ x i.1 / ξ ^ i.1 : ℝ)⌋∥) * r ^ i.1
      ≤ μ * r ^ i.1,
    { intro i,
    rw mul_le_mul_right,
    exacts [h_bdd i, pow_pos ((ne.symm hr₀).le_iff_lt.mp r.2) i.1] },
  apply summable_of_nonneg_of_le h_nonneg h_bdd,
  apply (@finset.summable_compl_iff _ _ _ _ _ (λ i, μ * r ^ i) (finset.range 1)).mpr,
  apply summable.mul_left,
  apply summable_geometric_of_abs_lt_1,
  rwa [← nnreal.val_eq_coe, abs_eq_self.mpr r.2],
end

lemma summable_nnnorm (r : ℝ≥0) (hr₁ : r < 1) :
      summable (λ i, ∥⌊(y ξ x i / ξ ^ i : ℝ)⌋∥₊ * (r ^ i)) :=
by simpa only [← nnreal.summable_coe, nonneg.coe_mul, coe_nnnorm, nnreal.coe_pow]
  using summable_norm ξ x r hr₁

lemma summable_floor (r : ℝ≥0) (hr₁ : r < 1) :
   summable (λ i, (⌊(y ξ x i / ξ ^ i : ℝ)⌋ : ℝ) * r ^ i) :=
begin
  have h_norm_eq : (λ i : ℕ, (∥⌊y ξ x i / ξ ^ i⌋∥ * (r ^ i : ℝ))) =
    (λ i : ℕ, (∥(⌊y ξ x i / ξ ^ i⌋ : ℝ) * (r ^ i)∥)),
    { funext,
      simp only [norm_mul, norm_pow, nnreal.norm_eq, mul_eq_mul_right_iff],
      rw [real.norm_eq_abs, int.norm_eq_abs],
      tauto },
  have := summable_norm ξ x r hr₁,
  rw h_norm_eq at this,
  apply summable_of_summable_norm (this),
end

lemma limit_y [fact (ξ < 1)]: tendsto (λ n, y ξ x n) at_top (𝓝 0) :=
begin
  have h_pos : 0 < ξ := fact.out _,
  let ξ₀ : ℝ≥0 := ⟨ξ, le_of_lt (fact.out _)⟩,
  have h_right : ∀ n, n ≥ 1 → (⌊(y ξ x n / ξ ^ n)⌋ : ℝ) ≤ (y ξ x n / ξ ^ n) :=
    (λ _ _, int.floor_le _),
  replace h_right : ∀ n, n ≥ 1 → (⌊(y ξ x n / ξ ^ n)⌋ : ℝ) * ξ ^ n  ≤ y ξ x n :=
    (λ n hn, (le_div_iff (pow_pos h_pos n)).mp (h_right n hn)),
  replace h_right : ∀ᶠ n in at_top, (⌊(y ξ x n / ξ ^ n)⌋ : ℝ) * ξ ^ n  ≤ y ξ x n,
  { simp only [ge_iff_le, eventually_at_top], use [1, h_right] },
  have h_left : ∀ n, n ≥ 1 → (y ξ x n / ξ ^ n) - 1 ≤ ⌊(y ξ x n / ξ ^ n)⌋ :=
    (λ n hn, le_of_lt (int.sub_one_lt_floor _)),
  replace h_left : ∀ n, n ≥ 1 → (y ξ x n - ξ ^ n) ≤ ⌊(y ξ x n / ξ ^ n)⌋ * ξ ^ n,
  { have h_one : ∀ n : ℕ, 0 < ξ ^ n := (λ n, pow_pos h_pos n),
    intros n hn,
    calc y ξ x n - ξ ^ n
        = ((y ξ x n / ξ ^ n) - 1) * ξ ^ n : by { rw [sub_mul, one_mul, div_mul_cancel _ (h_one _).ne'], }
    ... ≤ ⌊(y ξ x n / ξ ^ n)⌋ * ξ ^ n : (mul_le_mul_right (h_one n)).mpr (h_left n hn) },
  replace h_left : ∀ᶠ n in at_top, y ξ x n - ξ ^ n ≤ (⌊(y ξ x n / ξ ^ n)⌋ : ℝ) * ξ ^ n,
  { simp only [eventually_at_top], use [1, h_left] },
  have : tendsto (λ n, y ξ x n - ξ ^ n) at_top (𝓝 (exists_limit_y ξ x).some),
  { convert tendsto.add (exists_limit_y ξ x).some_spec (limit_neg_geometric ξ),
    rw add_zero } ,
  have h₁ := (le_of_tendsto_of_tendsto this
    (summable_floor ξ x ξ₀ _).tendsto_at_top_zero h_left).antisymm (le_of_tendsto_of_tendsto
    (summable_floor ξ x ξ₀ _).tendsto_at_top_zero (exists_limit_y ξ x).some_spec h_right),
  have := (exists_limit_y ξ x).some_spec,
  rwa h₁ at this,
  all_goals {rw [← nnreal.coe_lt_coe, nnreal.coe_one, subtype.coe_mk], exact fact.out _},
end

lemma has_sum_x [fact (ξ < 1)] : has_sum (λ i, (⌊(((y ξ x i) / ξ ^ i) : ℝ)⌋ : ℝ) * (ξ ^ i)) x :=
begin
  let ξ₀ : ℝ≥0 := ⟨ξ, le_of_lt (fact.out _)⟩,
  apply (summable_floor ξ x ξ₀ _).has_sum_iff_tendsto_nat.mpr,
  simp_rw [subtype.coe_mk, ← (finite_sum' ξ x), sub_eq_add_neg],
  nth_rewrite_rhs 0 [← add_zero x],
  apply @tendsto.const_add ℕ ℝ _ _ _ x 0 _ at_top,
  rw ← neg_zero,
  refine tendsto.neg (limit_y ξ x),
  { rw [← nnreal.coe_lt_coe, nnreal.coe_one, subtype.coe_mk],
    exact fact.out _},
end

end summability

section theta_surj

/--The map `ϑ` defined in Theorem 6.9 of Analytic.pdf. Given the definition of `tsum` we do not need
 to require that `r ≤ ξ` to simply define `ϑ`.-/

def seval_ℒ {r : ℝ≥0} (S : Fintype) (s : S): (laurent_measures r S) →
  (laurent_measures r (Fintype.of punit)) := λ F, ⟨(λ _, F s), (λ _, F.2 s)⟩

def ϑ₀ (r : ℝ≥0) : (laurent_measures r (Fintype.of punit)) → ℝ :=
  λ F, tsum (λ n, (F punit.star n) * ξ ^ n)--TODO: remove this

def ϑ (r p : ℝ≥0) (S : Fintype) : (laurent_measures r S) → real_measures p S :=
  λ F s, tsum (λ n, (F s n) * ξ ^ n)

@[nolint unused_arguments]
def ϑ' (r p: ℝ≥0) (S : Fintype) : (laurent_measures r S) → (S → ℝ) :=
  λ F s, (ϑ₀ ξ r) (seval_ℒ S s F)

lemma ϑ_eq_ϑ' : ϑ = ϑ' := rfl

def ϑ_section (r p : ℝ≥0) (S : Fintype) (g : real_measures p S) [fact (r < 1)] [fact (0 < ξ)]
   [fact (ξ < 1)] : (S → ℤ → ℤ) := λ s m, int.rec_on m (λ i, ⌊((y ξ (g s) i) / ξ ^ i)⌋) (0)

lemma summable_ϑ_section (r p : ℝ≥0) (S : Fintype) (g : real_measures p S) [fact (r < 1)]
  [fact (0 < ξ)] [fact (ξ < 1)] : ∀ s, summable (λ n, ∥(ϑ_section ξ r p S g ) s n∥₊ * r ^ n) :=
begin
  let F₀ := ϑ_section ξ r p S g,
  have hinj : function.injective (coe : ℕ → ℤ) := by {apply int.coe_nat_inj},
  have h_aux : ∀ s : S, ∀ n : ℤ, n ∉ set.range (coe : ℕ → ℤ) → F₀ s n = 0,
  { rintros s ( _ | _ ),
    simp only [is_empty.forall_iff, set.mem_range_self, not_true, int.of_nat_eq_coe],
    intro,
    refl },
  have h_range_norm : ∀ s : S, ∀ n : ℤ, n ∉ set.range (coe : ℕ → ℤ) → ∥F₀ s n ∥₊ * r ^ n = 0,
  { intros s n,
    specialize h_aux s n,
    simp only [h_aux, int.cast_eq_zero, mul_eq_zero, nnnorm_eq_zero],
    tauto},
  intro s,
  apply (@function.injective.summable_iff _ _ _ _ _ _ _ hinj (h_range_norm s)).mp,
  exact summable_nnnorm ξ (g s) r (fact.out _),
end

theorem ϑ_surjective (r p : ℝ≥0) (S : Fintype) (g : real_measures p S) [fact (r < 1)] [fact (0 < ξ)]
   [fact (ξ < 1)] : ∃ (F : laurent_measures r S), (ϑ ξ r p S F) = g :=
begin
  have hinj : function.injective (coe : ℕ → ℤ) := by {apply int.coe_nat_inj},
    let F : laurent_measures r S := ⟨ϑ_section ξ r p S g, summable_ϑ_section ξ r p S g⟩,
    have h_aux : ∀ s : S, ∀ n : ℤ, n ∉ set.range (coe : ℕ → ℤ) → F s n = 0,
    { rintros s ( _ | _ ),
      simp only [is_empty.forall_iff, set.mem_range_self, not_true, int.of_nat_eq_coe],
      intro,
      refl },
    have h_range : ∀ s : S, ∀ n : ℤ, n ∉ set.range (coe : ℕ → ℤ) → (F s n : ℝ) * ξ ^ n = 0,
    { intros n hn,
    specialize h_aux n hn,
    simp only [h_aux, int.cast_eq_zero, mul_eq_zero, nnnorm_eq_zero],
    tauto },
    use F,
    have : ∀ s : S, has_sum (λ n, ((F s n) : ℝ) * ξ ^ n) (g s),
    { intro s,
      apply (@function.injective.has_sum_iff _ _ _ _ _ _ (g s) _ hinj (h_range s)).mp,
      exact has_sum_x ξ (g s) },
    funext,
    apply has_sum.tsum_eq,
    exact this s,
end

end theta_surj

-- theorem ϑ₀_surjective (x : ℝ) (r : ℝ≥0) [fact (r < 1)] [fact (0 < ξ)] [fact (ξ < 1)] :
--   ∃ (F : laurent_measures r (Fintype.of punit)), (ϑ₀ ξ r F) = x :=
-- begin
--   let f₀ : ℤ → ℤ := λ m, int.rec_on m (λ i, ⌊((y ξ x i) / ξ ^ i)⌋) (0),
--   let F₀ : Fintype.of punit → ℤ → ℤ := λ a, f₀,
--   have hinj : function.injective (coe : ℕ → ℤ) := by {apply int.coe_nat_inj},
--   have h_aux : ∀ n : ℤ, n ∉ set.range (coe : ℕ → ℤ) → f₀ n = 0,
--   { rintro ( _ | _ ),
--     simp only [is_empty.forall_iff, set.mem_range_self, not_true, int.of_nat_eq_coe],
--     intro,
--     refl },
--   have h_range : ∀ n : ℤ,
--     n ∉ set.range (coe : ℕ → ℤ) → (F₀ punit.star n : ℝ) * ξ ^ n = 0,
--   swap,
--   have h_range_norm : ∀ n : ℤ,
--     n ∉ set.range (coe : ℕ → ℤ) → ∥F₀ punit.star n ∥ * r ^ n = 0,
--   swap,
--   { have HF₀ : ∀ (s : Fintype.of punit), summable (λ (n : ℤ), ∥F₀ s n∥ * r ^ n),
--     { intro s,
--       apply (@function.injective.summable_iff _ _ _ _ _ _ _ hinj h_range_norm).mp,
--       apply summable_norm ξ x r (fact.out _) },
--     let F : laurent_measures r (Fintype.of punit) := ⟨F₀, HF₀⟩,
--     use F,
--     have : has_sum (λ n, ((F₀ punit.star n) : ℝ) * ξ ^ n) x,
--     { apply (@function.injective.has_sum_iff _ _ _ _ _ _ x _ hinj h_range).mp,
--       exact has_sum_x ξ x },
--     apply has_sum.tsum_eq,
--     exact this },
--   all_goals { intros n hn,
--     specialize h_aux n hn,
--     simp only [h_aux, int.cast_eq_zero, mul_eq_zero, norm_eq_zero],
--     tauto },
-- end

end theta


import
  data.real.sqrt
  extra.real_hom.semifield_char0_hom
  extra.real_hom.nnreal_odd_ext
  extra.real_prop.real_quadratic_sol

/-! # IMO 2012 A5 -/

namespace IMOSL
namespace IMO2012A5

open function nnreal
open_locale nnreal

def good {R S : Type*} [ring R] [ring S] (f : R → S) :=
  ∀ x y : R, f (1 + x * y) - f(x + y) = f x * f y

section extra_lemmas

private lemma one_add_mul_sub_add {R : Type*} [ring R] (x y : R) :
  (1 + x * y) - (x + y) = (x - 1) * (y - 1) :=
  by rw [add_comm, ← sub_add_sub_comm, ← mul_sub_one,
    ← neg_sub y, ← sub_eq_add_neg, ← sub_one_mul]

private lemma one_add_mul_add_add {R : Type*} [ring R] (x y : R) :
  (1 + x * y) + (x + y) = (x + 1) * (y + 1) :=
  by rw [add_add_add_comm, ← add_one_mul, add_comm 1 x, ← mul_one_add, add_comm 1 y]

end extra_lemmas

section basic_results

section answer

variables {R S : Type*} [ring R]

private lemma good_zero [ring S] : good (λ (_ : R), (0 : S)) :=
  λ x y, by rw [sub_zero, mul_zero]

private lemma good_hom_sub_one [ring S] (φ : R →+* S) :
  good (λ (x : R), φ x - 1) :=
  λ x y, by rw [sub_sub_sub_cancel_right, φ.map_add, φ.map_one, φ.map_add, φ.map_mul];
    exact one_add_mul_sub_add (φ x) (φ y)

private lemma good_hom_sq_sub_one [comm_ring S] (φ : R →+* S) :
  good (λ (x : R), φ x ^ 2 - 1) :=
  λ x y, by rw [sub_sub_sub_cancel_right, φ.map_add, φ.map_one, φ.map_add, φ.map_mul, sq_sub_sq,
    one_add_mul_sub_add, one_add_mul_add_add, mul_mul_mul_comm, ← sq_sub_sq, ← sq_sub_sq, one_pow]

end answer

private lemma good_subst_neg_one {R S : Type*} [ring R] [ring S] {f : R → S} (h : good f) (x : R) :
  f x - f (-x) = f (-1) * f (1 - x) :=
  by rw [← h, neg_one_mul, neg_sub, add_sub_cancel'_right, ← add_sub_assoc, neg_add_self, zero_sub]

section domain

variables {R S : Type*} [ring R] [comm_ring S] [is_domain S] {f : R → S} (h : good f)
include h

private lemma good_map_one : f 1 = 0 :=
  by replace h := h 1 1; rwa [mul_one, sub_self, zero_eq_mul_self] at h

private lemma good_eq_zero_of_map_zero_ne_neg_one (h0 : f 0 ≠ -1) : f = 0 :=
  funext (λ x, by have h1 := h x 0; rwa [mul_zero, add_zero, good_map_one h, zero_sub,
    add_zero, ← mul_neg_one, mul_eq_mul_left_iff, or_iff_right h0.symm] at h1)

end domain

end basic_results

section results

variables {R : Type*} [comm_ring R] [is_domain R] {f : ℝ → R} (feq : good f)
include feq

section case_fneg1_ne_0

variable (fneg1_ne_0 : f (-1) ≠ 0)
include fneg1_ne_0

private lemma lem2_1 : f 0 = -1 :=
begin
  contrapose! fneg1_ne_0 with f0_ne_neg1,
  rw [good_eq_zero_of_map_zero_ne_neg_one feq f0_ne_neg1, pi.zero_apply]
end

private lemma lem2_2 (x : ℝ) : f (2 - x) = -f x :=
begin
  have h := good_subst_neg_one feq (-(1 - x)),
  rwa [neg_neg, ← neg_sub, good_subst_neg_one feq (1 - x), ← mul_neg, mul_eq_mul_left_iff,
       or_iff_left fneg1_ne_0, sub_sub_cancel, sub_neg_eq_add, ← add_sub_assoc, eq_comm] at h
end

private lemma lem2_3 (x : ℝ) : f (x + 2) = f x + 2 :=
begin
  revert x; suffices : ∀ x : ℝ, x ≤ 0 → f (x + 2) - f x = f 3 - f 1,
  { have h := lem2_2 feq fneg1_ne_0 0,
    rw [sub_zero, lem2_1 feq fneg1_ne_0, neg_neg] at h,
    have h0 := this 0 (le_refl 0),
    rw [← h0, zero_add, h, lem2_1 feq fneg1_ne_0, sub_neg_eq_add, ← bit0] at this,
    clear h0; intros x,
    cases le_total x 0 with h0 h0,
    rw [← sub_eq_iff_eq_add', this x h0],
    rw [← this (-x) (by rwa neg_nonpos), add_comm (-x), ← sub_eq_add_neg,
        lem2_2 feq fneg1_ne_0, ← add_sub_assoc, add_neg_self, zero_sub,
        ← lem2_2 feq fneg1_ne_0, sub_neg_eq_add, add_comm] },
  intros x h,
  obtain ⟨u, v, h0, h1⟩ : ∃ u v : ℝ, u + v = 1 ∧ u * v = x - 1 :=
  begin
    refine extra.exists_add_eq_mul_eq (le_trans _ (sq_nonneg 1)),
    exact mul_nonpos_of_nonneg_of_nonpos zero_le_four (sub_nonpos_of_le (le_trans h zero_le_one))
  end,
  have h2 := feq (2 - u) (2 - v),
  rw [lem2_2 feq fneg1_ne_0, lem2_2 feq fneg1_ne_0, neg_mul_neg, ← feq, h1,
      sub_add_sub_comm, h0, sub_eq_sub_iff_sub_eq_sub, add_sub_cancel'_right] at h2,
  convert h2 using 3,
  work_on_goal 2 { rw [eq_sub_iff_add_eq, bit1, add_assoc, ← bit0] },
  rw [add_comm (1 : ℝ), ← sub_eq_sub_iff_add_eq_add, ← h1, sub_mul, mul_sub,
      mul_sub, ← sub_add, sub_sub, mul_comm u 2, ← mul_add, add_comm v u, h0,
      mul_one, two_mul, add_sub_cancel, add_sub_cancel']
end

private lemma lem2_4 (x : ℝ) : f (-x) = -(2 + f x) :=
begin
  have h := lem2_3 feq fneg1_ne_0 (-x),
  rw [add_comm, ← sub_eq_add_neg, lem2_2 feq fneg1_ne_0, ← sub_eq_iff_eq_add] at h,
  rw [← h, sub_eq_add_neg, add_comm, neg_add]
end

private lemma lem2_5 (x y : ℝ) : f (x + y) = f x + f y + 1 :=
begin
  have h := feq (-x) (-y),
  rw [neg_mul_neg, ← neg_add, lem2_4 feq fneg1_ne_0, sub_neg_eq_add, lem2_4 feq fneg1_ne_0,
      lem2_4 feq fneg1_ne_0, neg_mul_neg, add_mul, mul_add, mul_add, ← feq, ← sub_eq_zero] at h,
  replace h : 2 * (f (x + y) - (f x + f y + 1)) = 0 := by rw ← h; ring,
  rwa [mul_eq_zero, sub_eq_zero, or_comm] at h,
  cases h with h h,
  exact h,
  have h0 := lem2_3 feq fneg1_ne_0 (-1),
  rw [bit0, neg_add_cancel_comm_assoc, h, add_zero, good_map_one feq, eq_comm] at h0,
  exfalso; exact fneg1_ne_0 h0
end

private lemma lem2_6 : ∃ φ : ℝ →+* R, f = φ - 1 :=
begin
  use f + 1; simp,
  exact good_map_one feq,
  intros x y,
  have h := feq x y,
  rw [sub_eq_iff_eq_add, lem2_5 feq fneg1_ne_0, good_map_one feq, zero_add] at h,
  rw [h, lem2_5 feq fneg1_ne_0, add_one_mul, mul_add_one, add_assoc, add_assoc],
  rw [lem2_1 feq fneg1_ne_0, neg_add_self],
  intros x y; rw [lem2_5 feq fneg1_ne_0, add_assoc, add_add_add_comm]
end

end case_fneg1_ne_0

section case_fneg1_eq_0

variable (fneg1_eq_0 : f (-1) = 0)
include fneg1_eq_0

private lemma lem3_1 (x : ℝ) : f (-x) = f x :=
  by rw [eq_comm, ← sub_eq_zero, good_subst_neg_one feq x, fneg1_eq_0, zero_mul]

private lemma lem3_2 (u v : ℝ≥0) : f (1 + v / 4) - f (1 - v / 4) = f (sqrt (u + v)) - f (sqrt u) :=
begin
  obtain ⟨x, y, h, h0⟩ : ∃ x y : ℝ, x + y = sqrt (u + v) ∧ x * y = v / 4 :=
  begin
    apply extra.exists_add_eq_mul_eq,
    rw [real.coe_sqrt, nonneg.coe_add, real.sq_sqrt, mul_div_cancel'],
    exacts [le_add_of_nonneg_left (coe_nonneg u), four_ne_zero,
            add_nonneg (coe_nonneg u) (coe_nonneg v)]
  end,
  rw [← h, ← h0, sub_eq_sub_iff_sub_eq_sub, feq, ← lem3_1 feq fneg1_eq_0 y,
      ← feq, mul_neg, ← sub_eq_add_neg, sub_right_inj, ← sub_eq_add_neg],
  suffices : (u : ℝ) = (x - y) ^ 2,
  { rw [real.coe_sqrt, this, real.sqrt_sq_eq_abs],
    cases le_total 0 (x - y) with h1 h1,
    rw abs_eq_self.mpr h1,
    rw [abs_eq_neg_self.mpr h1, lem3_1 feq fneg1_eq_0] },
  replace h := congr_arg (λ x, x ^ 2) h; simp only [] at h,
  rw [← nonneg.coe_pow, sq_sqrt, nonneg.coe_add, ← sub_eq_iff_eq_add] at h,
  rw [← h, sub_eq_iff_eq_add', ← sub_eq_iff_eq_add, add_sq, sub_sq, add_sub_add_right_eq_sub,
      add_sub_sub_cancel, mul_assoc, ← add_mul, h0, ← bit0, mul_div_cancel'],
  exact four_ne_zero
end

variable (f0_eq_neg1 : f 0 = -1)
include f0_eq_neg1

private lemma lem3_3 (u v : ℝ≥0) : f (sqrt (u + v)) = f (sqrt u) + f (sqrt v) + 1 :=
  by rw [add_assoc, ← sub_eq_iff_eq_add', ← lem3_2 feq fneg1_eq_0, lem3_2 feq fneg1_eq_0 0,
         zero_add, sqrt_zero, nonneg.coe_zero, sub_eq_add_neg, f0_eq_neg1, neg_neg]

private lemma lem3_4 (u v : ℝ≥0) : f (u * v) + 1 = (f u + 1) * (f v + 1) :=
begin
  revert u v; suffices : ∀ u v : ℝ≥0, f (u + v) = f u + f v + f (sqrt (2 * u * v)) + 2,
  { intros u v,
    have h := feq u v,
    rw [← nonneg.coe_one, ← nonneg.coe_mul, this, nonneg.coe_one, ← lem3_1 feq fneg1_eq_0,
        fneg1_eq_0, zero_add, mul_one, this, add_sub_add_right_eq_sub, mul_assoc,
        add_sub_add_right_eq_sub, nonneg.coe_mul, sub_eq_iff_eq_add, ← add_assoc] at h,
    rw [h, add_one_mul, mul_add_one, ← add_assoc] },
  intros u v,
  have h := lem3_3 feq fneg1_eq_0 f0_eq_neg1,
  rw [← nonneg.coe_add, ← sqrt_sq (u + v), add_sq, h, sqrt_sq, h, sqrt_sq,
      add_right_comm _ 1 (f v), add_right_comm (f u), add_assoc, ← bit0]
end

private lemma lem3_5 : ∃ φ : ℝ≥0 →+* R, f = λ x : ℝ, φ (x.nnabs ^ 2) - 1 :=
begin
  use λ x, f (sqrt x) + 1,
  rw [sqrt_one, nonneg.coe_one, good_map_one feq, zero_add],
  intros x y; rw [sqrt_mul, nonneg.coe_mul, lem3_4 feq fneg1_eq_0 f0_eq_neg1],
  rw [sqrt_zero, nonneg.coe_zero, f0_eq_neg1, neg_add_self],
  intros x y; rw [lem3_3 feq fneg1_eq_0 f0_eq_neg1, add_add_add_comm, add_assoc],
  funext x,
  rw [ring_hom.coe_mk, add_sub_cancel, sqrt_sq, real.coe_nnabs],
  cases le_total 0 x with h h,
  rw abs_eq_self.mpr h,
  rw [abs_eq_neg_self.mpr h, lem3_1 feq fneg1_eq_0]
end

end case_fneg1_eq_0

end results

/-- Final solution -/
theorem final_solution_general {R : Type*} [comm_ring R] [is_domain R] (f : ℝ → R) : good f ↔
  f = 0 ∨ (∃ φ : ℝ →+* R, f = φ - 1) ∨ (∃ φ : ℝ≥0 →+* R, f = λ x : ℝ, φ (x.nnabs ^ 2) - 1) :=
begin
  split,
  { intros feq,
    cases ne_or_eq (f 0) (-1) with h h,
    left; exact good_eq_zero_of_map_zero_ne_neg_one feq h,
    right; cases eq_or_ne (f (-1)) 0 with h0 h0,
    right; exact lem3_5 feq h0 h,
    left; exact lem2_6 feq h0 },
  { rintros (rfl | ⟨φ, rfl⟩ | ⟨φ, h⟩),
    exact good_zero,
    exact good_hom_sub_one φ,
    intros x y,
    conv at h { congr, skip, funext,
      rw [← extra.nnreal_ring_hom.coe_fn_apply, nnreal.coe_pow, real.coe_nnabs, pow_bit0_abs] },
    subst h; simp only [],
    rw [add_sq, add_sq, one_pow, mul_one, sub_sub_sub_cancel_right, add_right_comm, mul_assoc,
        add_right_comm (x ^ 2), map_add, map_add, map_add, add_sub_add_right_eq_sub,
        map_one, map_add, mul_pow, map_mul, sub_one_mul, mul_sub_one, sub_sub, ← add_sub_assoc,
        ← sub_add, add_comm, add_sub_right_comm] }
end

/-- Final solution, case char(R) ≠ 0 -/
theorem final_solution_char_ne_0 {R : Type*} [comm_ring R] [is_domain R]
    (p : ℕ) [fact (p ≠ 0)] [char_p R p] (f : ℝ → R) : good f ↔ f = 0 :=
  by rw [final_solution_general, is_empty.exists_iff, is_empty.exists_iff, or_false, or_false]

/-- Final solution, case R = ℝ -/
theorem final_solution_real (f : ℝ → ℝ) : good f ↔ f = 0 ∨ (f = id - 1) ∨ (f = λ x, x ^ 2 - 1) :=
begin
  rw [final_solution_general, unique.exists_iff, unique.exists_iff],
  unfold default; refine or_congr_right' (or_congr_right' _),
  conv_lhs { congr, skip, funext,
    rw [nnreal.coe_to_real_hom, nnreal.coe_pow, real.coe_nnabs, pow_bit0_abs] }
end

end IMO2012A5
end IMOSL


import .util

namespace inverse
    open function
    open classical (renaming some → unexists) (renaming some_spec → unexists_prop)
    open classical (choice prop_decidable)
    local attribute [instance] prop_decidable

    open util

    -- one-sided inverses:
    class invertible.one_sided {T T': Sort _} (f: T → T') :=
        (g: T' → T)
        (left_inv:
            ∀ x: T,
            g (f x) = x)

    @[reducible, inline] def inv {T T': Sort _} (f: T → T') [hf: invertible.one_sided f]:
        T' → T := hf.g

    @[simp] theorem inv.elim {T T': Sort _} (f: T → T') [hf: invertible.one_sided f]:
        ∀ x: T,
        inv f (f x) = x := by apply hf.left_inv

    instance inv.surjective {T T': Sort _} (f: T → T') [hf: invertible.one_sided f]:
        surjective (inv f) := begin
            intro x,
            apply exists.intro (f x),
            simp,
        end

    instance invertible.one_sided.injective {T T': Sort _} (f: T → T') [hf: invertible.one_sided f]:
        injective f := begin
            intros x y hxy,
            have hinvxy: inv f (f x) = inv f (f y) := congr rfl hxy,
            simp at hinvxy,
            assumption,
        end

    -- noncomputable inverse:
    noncomputable def inj_inv {T T': Sort _} [hT: nonempty T] (f: T → T') (y: T'): T :=
        if h: ∃ x: T, f x = y then
            unexists h
        else
            choice hT

    noncomputable def inj_inv.is_inverse {T T': Sort _} [hT: nonempty T] (f: T → T') [hf: injective f]:
        invertible.one_sided f := {
            g := inj_inv f,
            left_inv := begin
                intros,
                rw [inj_inv],
                cases em (∃ (x' : T), f x' = f x),
                case or.inl {
                    rw [dif_pos h],
                    apply hf,
                    exact unexists_prop h,
                },
                case or.inr {
                    rw [dif_neg h],
                    apply false.elim,
                    apply h,
                    apply exists.intro x,
                    refl,
                },
            end,
        }

    -- two-sided inverses:
    class invertible {T T': Sort _} (f: T → T') extends invertible.one_sided f :=
        (right_inv:
            ∀ y: T',
            f (g y) = y)

    instance invertible.surjective {T T': Sort _} (f: T → T') [hf: invertible f]:
        surjective f := begin
            intro y,
            apply exists.intro ((inv f) y),
            rw [hf.right_inv],
        end

    instance invertible.bijective {T T': Sort _} (f: T → T') [hf: invertible f]:
        bijective f := {
            -- injective:
            left := by apply invertible.one_sided.injective,
            -- surjective:
            right := by apply invertible.surjective,
        }

    instance invertible.of_surjective {T T': Sort _} (f: T → T') [hfinv: invertible.one_sided f] [hfsur: surjective f]:
        invertible f := begin
            split,
            intros,
            have hex := hfsur y,
            apply exists.elim hex,
            intros x hx,
            rw [←hx],
            exact congr rfl (invertible.one_sided.left_inv f x),
        end

    instance inv.invertible {T T': Sort _} (f: T → T') [hf: invertible f]:
        invertible (inv f) := {
            g := f,
            left_inv := hf.right_inv,
            right_inv := hf.left_inv,
        }

    @[simp] theorem inv.elim_of_inv {T T': Sort _} (f: T → T') [hf: invertible f]:
        inv (inv f) = f := by rw [inv.invertible]

    theorem inv.uniq {T T': Sort _} (f: T → T') [hf: invertible f]:
        ∀ {g: T' → T},
        (∀ x: T, g (f x) = x) →
        g = inv f := begin
            intros g hg,
            funext,
            have hfsurx := invertible.surjective f x,
            apply exists.elim hfsurx,
            intros y hy,
            rw [←hy, hg y],
            rw [inv, hf.left_inv],
        end

    instance inv.injective {T T': Sort _} (f: T → T') [hf: invertible f]:
        injective (inv f) := begin
            intros x y hxy,
            have hfx := invertible.surjective f x,
            have hfy := invertible.surjective f y,
            apply exists.elim hfx,
            intros a ha,
            apply exists.elim hfy,
            intros b hb,
            rw [←ha, ←hb] at *,
            simp at hxy,
            rw [hxy],
        end

    -- id:
    instance id.invertible {T: Sort _}:
        invertible (@id T) := {
            g := id,
            left_inv := begin
                intros,
                refl,
            end,
            right_inv := begin
                intros,
                refl,
            end,
        }
end inverse


import tactic.qify

example (a b : ℕ) : (a : ℚ) ≤ b ↔ a ≤ b := by qify ; refl
example (a b : ℕ) : (a : ℚ) < b ↔ a < b := by qify ; refl
example (a b : ℕ) : (a : ℚ) = b ↔ a = b := by qify ; refl
example (a b : ℕ) : (a : ℚ) ≠ b ↔ a ≠ b := by qify ; refl

example (a b : ℤ) : (a : ℚ) ≤ b ↔ a ≤ b := by qify ; refl
example (a b : ℤ) : (a : ℚ) < b ↔ a < b := by qify ; refl
example (a b : ℤ) : (a : ℚ) = b ↔ a = b := by qify ; refl
example (a b : ℤ) : (a : ℚ) ≠ b ↔ a ≠ b := by qify ; refl

example (a b c : ℕ) (h : a - b = c) (hab : b ≤ a) : a = c + b :=
begin
  qify [hab] at h ⊢, -- `zify` does the same thing here.
  exact sub_eq_iff_eq_add.1 h,
end

example (a b c : ℤ) (h : a / b = c) (hab : b ∣ a) (hb : b ≠ 0) : a = c * b :=
begin
  qify [hab] at h hb ⊢,
  exact (div_eq_iff hb).1 h,
end


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import measure_theory.measure.ae_measurable

/-!
# Typeclasses for measurability of operations

In this file we define classes `has_measurable_mul` etc and prove dot-style lemmas
(`measurable.mul`, `ae_measurable.mul` etc). For binary operations we define two typeclasses:

- `has_measurable_mul` says that both left and right multiplication are measurable;
- `has_measurable_mul₂` says that `λ p : α × α, p.1 * p.2` is measurable,

and similarly for other binary operations. The reason for introducing these classes is that in case
of topological space `α` equipped with the Borel `σ`-algebra, instances for `has_measurable_mul₂`
etc require `α` to have a second countable topology.

We define separate classes for `has_measurable_div`/`has_measurable_sub`
because on some types (e.g., `ℕ`, `ℝ≥0∞`) division and/or subtraction are not defined as `a * b⁻¹` /
`a + (-b)`.

For instances relating, e.g., `has_continuous_mul` to `has_measurable_mul` see file
`measure_theory.borel_space`.

## Implementation notes

For the heuristics of `@[to_additive]` it is important that the type with a multiplication
(or another multiplicative operations) is the first (implicit) argument of all declarations.

## Tags

measurable function, arithmetic operator

## Todo

* Uniformize the treatment of `pow` and `smul`.
* Use `@[to_additive]` to send `has_measurable_pow` to `has_measurable_smul₂`.
* This might require changing the definition (swapping the arguments in the function that is
  in the conclusion of `measurable_smul`.)
-/

universes u v

open_locale big_operators pointwise measure_theory
open measure_theory

/-!
### Binary operations: `(+)`, `(*)`, `(-)`, `(/)`
-/

/-- We say that a type `has_measurable_add` if `((+) c)` and `(+ c)` are measurable functions.
For a typeclass assuming measurability of `uncurry (+)` see `has_measurable_add₂`. -/
class has_measurable_add (M : Type*) [measurable_space M] [has_add M] : Prop :=
(measurable_const_add : ∀ c : M, measurable ((+) c))
(measurable_add_const : ∀ c : M, measurable (+ c))

export has_measurable_add (measurable_const_add measurable_add_const)

/-- We say that a type `has_measurable_add` if `uncurry (+)` is a measurable functions.
For a typeclass assuming measurability of `((+) c)` and `(+ c)` see `has_measurable_add`. -/
class has_measurable_add₂ (M : Type*) [measurable_space M] [has_add M] : Prop :=
(measurable_add : measurable (λ p : M × M, p.1 + p.2))

export has_measurable_add₂ (measurable_add)
  has_measurable_add (measurable_const_add measurable_add_const)

/-- We say that a type `has_measurable_mul` if `((*) c)` and `(* c)` are measurable functions.
For a typeclass assuming measurability of `uncurry (*)` see `has_measurable_mul₂`. -/
@[to_additive]
class has_measurable_mul (M : Type*) [measurable_space M] [has_mul M] : Prop :=
(measurable_const_mul : ∀ c : M, measurable ((*) c))
(measurable_mul_const : ∀ c : M, measurable (* c))

export has_measurable_mul (measurable_const_mul measurable_mul_const)

/-- We say that a type `has_measurable_mul` if `uncurry (*)` is a measurable functions.
For a typeclass assuming measurability of `((*) c)` and `(* c)` see `has_measurable_mul`. -/
@[to_additive has_measurable_add₂]
class has_measurable_mul₂ (M : Type*) [measurable_space M] [has_mul M] : Prop :=
(measurable_mul : measurable (λ p : M × M, p.1 * p.2))

export has_measurable_mul₂ (measurable_mul)

section mul

variables {M α : Type*} [measurable_space M] [has_mul M] {m : measurable_space α}
  {f g : α → M} {μ : measure α}

include m

@[measurability, to_additive]
lemma measurable.const_mul [has_measurable_mul M] (hf : measurable f) (c : M) :
  measurable (λ x, c * f x) :=
(measurable_const_mul c).comp hf

@[measurability, to_additive]
lemma ae_measurable.const_mul [has_measurable_mul M] (hf : ae_measurable f μ) (c : M) :
  ae_measurable (λ x, c * f x) μ :=
(has_measurable_mul.measurable_const_mul c).comp_ae_measurable hf

@[measurability, to_additive]
lemma measurable.mul_const [has_measurable_mul M] (hf : measurable f) (c : M) :
  measurable (λ x, f x * c) :=
(measurable_mul_const c).comp hf

@[measurability, to_additive]
lemma ae_measurable.mul_const [has_measurable_mul M] (hf : ae_measurable f μ) (c : M) :
  ae_measurable (λ x, f x * c) μ :=
(measurable_mul_const c).comp_ae_measurable hf

@[measurability, to_additive]
lemma measurable.mul' [has_measurable_mul₂ M] (hf : measurable f) (hg : measurable g) :
  measurable (f * g) :=
measurable_mul.comp (hf.prod_mk hg)

@[measurability, to_additive]
lemma measurable.mul [has_measurable_mul₂ M] (hf : measurable f) (hg : measurable g) :
  measurable (λ a, f a * g a) :=
measurable_mul.comp (hf.prod_mk hg)

@[measurability, to_additive]
lemma ae_measurable.mul' [has_measurable_mul₂ M] (hf : ae_measurable f μ)
  (hg : ae_measurable g μ) :
  ae_measurable (f * g) μ :=
measurable_mul.comp_ae_measurable (hf.prod_mk hg)

@[measurability, to_additive]
lemma ae_measurable.mul [has_measurable_mul₂ M] (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ a, f a * g a) μ :=
measurable_mul.comp_ae_measurable (hf.prod_mk hg)

omit m

@[priority 100, to_additive]
instance has_measurable_mul₂.to_has_measurable_mul [has_measurable_mul₂ M] :
  has_measurable_mul M :=
⟨λ c, measurable_const.mul measurable_id, λ c, measurable_id.mul measurable_const⟩

@[to_additive]
instance pi.has_measurable_mul {ι : Type*} {α : ι → Type*} [∀ i, has_mul (α i)]
  [∀ i, measurable_space (α i)] [∀ i, has_measurable_mul (α i)] :
  has_measurable_mul (Π i, α i) :=
⟨λ g, measurable_pi_iff.mpr $ λ i, (measurable_pi_apply i).const_mul _,
 λ g, measurable_pi_iff.mpr $ λ i, (measurable_pi_apply i).mul_const _⟩

@[to_additive pi.has_measurable_add₂]
instance pi.has_measurable_mul₂ {ι : Type*} {α : ι → Type*} [∀ i, has_mul (α i)]
  [∀ i, measurable_space (α i)] [∀ i, has_measurable_mul₂ (α i)] :
  has_measurable_mul₂ (Π i, α i) :=
⟨measurable_pi_iff.mpr $ λ i, measurable_fst.eval.mul measurable_snd.eval⟩

attribute [measurability] measurable.add' measurable.add ae_measurable.add ae_measurable.add'
  measurable.const_add ae_measurable.const_add measurable.add_const ae_measurable.add_const

end mul

/-- A version of `measurable_div_const` that assumes `has_measurable_mul` instead of
  `has_measurable_div`. This can be nice to avoid unnecessary type-class assumptions. -/
@[to_additive /-" A version of `measurable_sub_const` that assumes `has_measurable_add` instead of
  `has_measurable_sub`. This can be nice to avoid unnecessary type-class assumptions. "-/]
lemma measurable_div_const' {G : Type*} [div_inv_monoid G] [measurable_space G]
  [has_measurable_mul G] (g : G) : measurable (λ h, h / g) :=
by simp_rw [div_eq_mul_inv, measurable_mul_const]

/-- This class assumes that the map `β × γ → β` given by `(x, y) ↦ x ^ y` is measurable. -/
class has_measurable_pow (β γ : Type*) [measurable_space β] [measurable_space γ] [has_pow β γ] :=
(measurable_pow : measurable (λ p : β × γ, p.1 ^ p.2))

export has_measurable_pow (measurable_pow)

/-- `monoid.has_pow` is measurable. -/
instance monoid.has_measurable_pow (M : Type*) [monoid M] [measurable_space M]
  [has_measurable_mul₂ M] : has_measurable_pow M ℕ :=
⟨measurable_from_prod_countable $ λ n, begin
  induction n with n ih,
  { simp only [pow_zero, ←pi.one_def, measurable_one] },
  { simp only [pow_succ], exact measurable_id.mul ih }
end⟩

section pow

variables {β γ α : Type*} [measurable_space β] [measurable_space γ] [has_pow β γ]
  [has_measurable_pow β γ] {m : measurable_space α} {μ : measure α} {f : α → β} {g : α → γ}

include m

@[measurability]
lemma measurable.pow (hf : measurable f) (hg : measurable g) :
  measurable (λ x, f x ^ g x) :=
measurable_pow.comp (hf.prod_mk hg)

@[measurability]
lemma ae_measurable.pow (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ x, f x ^ g x) μ :=
measurable_pow.comp_ae_measurable (hf.prod_mk hg)

@[measurability]
lemma measurable.pow_const (hf : measurable f) (c : γ) :
  measurable (λ x, f x ^ c) :=
hf.pow measurable_const

@[measurability]
lemma ae_measurable.pow_const (hf : ae_measurable f μ) (c : γ) :
  ae_measurable (λ x, f x ^ c) μ :=
hf.pow ae_measurable_const

@[measurability]
lemma measurable.const_pow (hg : measurable g) (c : β) :
  measurable (λ x, c ^ g x) :=
measurable_const.pow hg

@[measurability]
lemma ae_measurable.const_pow (hg : ae_measurable g μ) (c : β) :
  ae_measurable (λ x, c ^ g x) μ :=
ae_measurable_const.pow hg

omit m

end pow

/-- We say that a type `has_measurable_sub` if `(λ x, c - x)` and `(λ x, x - c)` are measurable
functions. For a typeclass assuming measurability of `uncurry (-)` see `has_measurable_sub₂`. -/
class has_measurable_sub (G : Type*) [measurable_space G] [has_sub G] : Prop :=
(measurable_const_sub : ∀ c : G, measurable (λ x, c - x))
(measurable_sub_const : ∀ c : G, measurable (λ x, x - c))

export has_measurable_sub (measurable_const_sub measurable_sub_const)

/-- We say that a type `has_measurable_sub` if `uncurry (-)` is a measurable functions.
For a typeclass assuming measurability of `((-) c)` and `(- c)` see `has_measurable_sub`. -/
class has_measurable_sub₂ (G : Type*) [measurable_space G] [has_sub G] : Prop :=
(measurable_sub : measurable (λ p : G × G, p.1 - p.2))

export has_measurable_sub₂ (measurable_sub)

/-- We say that a type `has_measurable_div` if `((/) c)` and `(/ c)` are measurable functions.
For a typeclass assuming measurability of `uncurry (/)` see `has_measurable_div₂`. -/
@[to_additive] class has_measurable_div (G₀: Type*) [measurable_space G₀] [has_div G₀] : Prop :=
(measurable_const_div : ∀ c : G₀, measurable ((/) c))
(measurable_div_const : ∀ c : G₀, measurable (/ c))

export has_measurable_div (measurable_const_div measurable_div_const)

/-- We say that a type `has_measurable_div` if `uncurry (/)` is a measurable functions.
For a typeclass assuming measurability of `((/) c)` and `(/ c)` see `has_measurable_div`. -/
@[to_additive has_measurable_sub₂]
class has_measurable_div₂ (G₀: Type*) [measurable_space G₀] [has_div G₀] : Prop :=
(measurable_div : measurable (λ p : G₀× G₀, p.1 / p.2))

export has_measurable_div₂ (measurable_div)

section div

variables {G α : Type*} [measurable_space G] [has_div G] {m : measurable_space α} {f g : α → G}
  {μ : measure α}

include m

@[measurability, to_additive]
lemma measurable.const_div [has_measurable_div G] (hf : measurable f) (c : G) :
  measurable (λ x, c / f x) :=
(has_measurable_div.measurable_const_div c).comp hf

@[measurability, to_additive]
lemma ae_measurable.const_div [has_measurable_div G] (hf : ae_measurable f μ) (c : G) :
  ae_measurable (λ x, c / f x) μ :=
(has_measurable_div.measurable_const_div c).comp_ae_measurable hf

@[measurability, to_additive]
lemma measurable.div_const [has_measurable_div G] (hf : measurable f) (c : G) :
  measurable (λ x, f x / c) :=
(has_measurable_div.measurable_div_const c).comp hf

@[measurability, to_additive]
lemma ae_measurable.div_const [has_measurable_div G] (hf : ae_measurable f μ) (c : G) :
  ae_measurable (λ x, f x / c) μ :=
(has_measurable_div.measurable_div_const c).comp_ae_measurable hf

@[measurability, to_additive]
lemma measurable.div' [has_measurable_div₂ G] (hf : measurable f) (hg : measurable g) :
  measurable (f / g) :=
measurable_div.comp (hf.prod_mk hg)

@[measurability, to_additive]
lemma measurable.div [has_measurable_div₂ G] (hf : measurable f) (hg : measurable g) :
  measurable (λ a, f a / g a) :=
measurable_div.comp (hf.prod_mk hg)

@[measurability, to_additive]
lemma ae_measurable.div' [has_measurable_div₂ G] (hf : ae_measurable f μ)
  (hg : ae_measurable g μ) :
  ae_measurable (f / g) μ :=
measurable_div.comp_ae_measurable (hf.prod_mk hg)

@[measurability, to_additive]
lemma ae_measurable.div [has_measurable_div₂ G] (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ a, f a / g a) μ :=
measurable_div.comp_ae_measurable (hf.prod_mk hg)

attribute [measurability] measurable.sub measurable.sub' ae_measurable.sub ae_measurable.sub'
  measurable.const_sub ae_measurable.const_sub measurable.sub_const ae_measurable.sub_const

omit m

@[priority 100, to_additive]
instance has_measurable_div₂.to_has_measurable_div [has_measurable_div₂ G] :
  has_measurable_div G :=
⟨λ c, measurable_const.div measurable_id, λ c, measurable_id.div measurable_const⟩

@[to_additive]
instance pi.has_measurable_div {ι : Type*} {α : ι → Type*} [∀ i, has_div (α i)]
  [∀ i, measurable_space (α i)] [∀ i, has_measurable_div (α i)] :
  has_measurable_div (Π i, α i) :=
⟨λ g, measurable_pi_iff.mpr $ λ i, (measurable_pi_apply i).const_div _,
 λ g, measurable_pi_iff.mpr $ λ i, (measurable_pi_apply i).div_const _⟩

@[to_additive pi.has_measurable_sub₂]
instance pi.has_measurable_div₂ {ι : Type*} {α : ι → Type*} [∀ i, has_div (α i)]
  [∀ i, measurable_space (α i)] [∀ i, has_measurable_div₂ (α i)] :
  has_measurable_div₂ (Π i, α i) :=
⟨measurable_pi_iff.mpr $ λ i, measurable_fst.eval.div measurable_snd.eval⟩

@[measurability]
lemma measurable_set_eq_fun {m : measurable_space α} {E} [measurable_space E] [add_group E]
  [measurable_singleton_class E] [has_measurable_sub₂ E] {f g : α → E}
  (hf : measurable f) (hg : measurable g) :
  measurable_set {x | f x = g x} :=
begin
  suffices h_set_eq : {x : α | f x = g x} = {x | (f-g) x = (0 : E)},
  { rw h_set_eq,
    exact (hf.sub hg) measurable_set_eq, },
  ext,
  simp_rw [set.mem_set_of_eq, pi.sub_apply, sub_eq_zero],
end

lemma null_measurable_set_eq_fun {E} [measurable_space E] [add_group E]
  [measurable_singleton_class E] [has_measurable_sub₂ E] {f g : α → E}
  (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  null_measurable_set {x | f x = g x} μ :=
begin
  apply (measurable_set_eq_fun hf.measurable_mk hg.measurable_mk).null_measurable_set.congr,
  filter_upwards [hf.ae_eq_mk, hg.ae_eq_mk] with x hfx hgx,
  change (hf.mk f x = hg.mk g x) = (f x = g x),
  simp only [hfx, hgx],
end

lemma measurable_set_eq_fun_of_countable {m : measurable_space α} {E} [measurable_space E]
  [measurable_singleton_class E] [countable E] {f g : α → E}
  (hf : measurable f) (hg : measurable g) :
  measurable_set {x | f x = g x} :=
begin
  have : {x | f x = g x} = ⋃ j, {x | f x = j} ∩ {x | g x = j},
  { ext1 x, simp only [set.mem_set_of_eq, set.mem_Union, set.mem_inter_iff, exists_eq_right'], },
  rw this,
  refine measurable_set.Union (λ j, measurable_set.inter _ _),
  { exact hf (measurable_set_singleton j), },
  { exact hg (measurable_set_singleton j), },
end

lemma ae_eq_trim_of_measurable {α E} {m m0 : measurable_space α} {μ : measure α}
  [measurable_space E] [add_group E] [measurable_singleton_class E] [has_measurable_sub₂ E]
  (hm : m ≤ m0) {f g : α → E} (hf : measurable[m] f) (hg : measurable[m] g)
  (hfg : f =ᵐ[μ] g) :
  f =ᶠ[@measure.ae α m (μ.trim hm)] g :=
begin
  rwa [filter.eventually_eq, ae_iff, trim_measurable_set_eq hm _],
  exact (@measurable_set.compl α _ m (@measurable_set_eq_fun α m E _ _ _ _ _ _ hf hg)),
end

end div

/-- We say that a type `has_measurable_neg` if `x ↦ -x` is a measurable function. -/
class has_measurable_neg (G : Type*) [has_neg G] [measurable_space G] : Prop :=
(measurable_neg : measurable (has_neg.neg : G → G))

/-- We say that a type `has_measurable_inv` if `x ↦ x⁻¹` is a measurable function. -/
@[to_additive]
class has_measurable_inv (G : Type*) [has_inv G] [measurable_space G] : Prop :=
(measurable_inv : measurable (has_inv.inv : G → G))

export has_measurable_inv (measurable_inv) has_measurable_neg (measurable_neg)

@[priority 100, to_additive]
instance has_measurable_div_of_mul_inv (G : Type*) [measurable_space G]
  [div_inv_monoid G] [has_measurable_mul G] [has_measurable_inv G] :
  has_measurable_div G :=
{ measurable_const_div := λ c,
    by { convert (measurable_inv.const_mul c), ext1, apply div_eq_mul_inv },
  measurable_div_const := λ c,
    by { convert (measurable_id.mul_const c⁻¹), ext1, apply div_eq_mul_inv } }

section inv

variables {G α : Type*} [has_inv G] [measurable_space G] [has_measurable_inv G]
  {m : measurable_space α} {f : α → G} {μ : measure α}

include m

@[measurability, to_additive]
lemma measurable.inv (hf : measurable f) : measurable (λ x, (f x)⁻¹) := measurable_inv.comp hf

@[measurability, to_additive]
lemma ae_measurable.inv (hf : ae_measurable f μ) : ae_measurable (λ x, (f x)⁻¹) μ :=
measurable_inv.comp_ae_measurable hf

attribute [measurability] measurable.neg ae_measurable.neg

@[simp, to_additive] lemma measurable_inv_iff {G : Type*} [group G] [measurable_space G]
  [has_measurable_inv G] {f : α → G} : measurable (λ x, (f x)⁻¹) ↔ measurable f :=
⟨λ h, by simpa only [inv_inv] using h.inv, λ h, h.inv⟩

@[simp, to_additive] lemma ae_measurable_inv_iff {G : Type*} [group G] [measurable_space G]
  [has_measurable_inv G] {f : α → G} :
  ae_measurable (λ x, (f x)⁻¹) μ ↔ ae_measurable f μ :=
⟨λ h, by simpa only [inv_inv] using h.inv, λ h, h.inv⟩

@[simp] lemma measurable_inv_iff₀ {G₀ : Type*} [group_with_zero G₀]
  [measurable_space G₀] [has_measurable_inv G₀] {f : α → G₀} :
  measurable (λ x, (f x)⁻¹) ↔ measurable f :=
⟨λ h, by simpa only [inv_inv] using h.inv, λ h, h.inv⟩

@[simp] lemma ae_measurable_inv_iff₀ {G₀ : Type*} [group_with_zero G₀]
  [measurable_space G₀] [has_measurable_inv G₀] {f : α → G₀} :
  ae_measurable (λ x, (f x)⁻¹) μ ↔ ae_measurable f μ :=
⟨λ h, by simpa only [inv_inv] using h.inv, λ h, h.inv⟩

omit m

@[to_additive]
instance pi.has_measurable_inv {ι : Type*} {α : ι → Type*} [∀ i, has_inv (α i)]
  [∀ i, measurable_space (α i)] [∀ i, has_measurable_inv (α i)] :
  has_measurable_inv (Π i, α i) :=
⟨measurable_pi_iff.mpr $ λ i, (measurable_pi_apply i).inv⟩

@[to_additive] lemma measurable_set.inv {s : set G} (hs : measurable_set s) : measurable_set s⁻¹ :=
measurable_inv hs

end inv

/-- `div_inv_monoid.has_pow` is measurable. -/
instance div_inv_monoid.has_measurable_zpow (G : Type u) [div_inv_monoid G] [measurable_space G]
  [has_measurable_mul₂ G] [has_measurable_inv G] :
  has_measurable_pow G ℤ :=
⟨measurable_from_prod_countable $ λ n, begin
  cases n with n n,
  { simp_rw zpow_of_nat, exact measurable_id.pow_const _ },
  { simp_rw zpow_neg_succ_of_nat, exact (measurable_id.pow_const (n + 1)).inv }
end⟩

@[priority 100, to_additive]
instance has_measurable_div₂_of_mul_inv (G : Type*) [measurable_space G]
  [div_inv_monoid G] [has_measurable_mul₂ G] [has_measurable_inv G] :
  has_measurable_div₂ G :=
⟨by { simp only [div_eq_mul_inv], exact measurable_fst.mul measurable_snd.inv }⟩

/-- We say that the action of `M` on `α` `has_measurable_vadd` if for each `c` the map `x ↦ c +ᵥ x`
is a measurable function and for each `x` the map `c ↦ c +ᵥ x` is a measurable function. -/
class has_measurable_vadd (M α : Type*) [has_vadd M α] [measurable_space M] [measurable_space α] :
  Prop :=
(measurable_const_vadd : ∀ c : M, measurable ((+ᵥ) c : α → α))
(measurable_vadd_const : ∀ x : α, measurable (λ c : M, c +ᵥ x))

/-- We say that the action of `M` on `α` `has_measurable_smul` if for each `c` the map `x ↦ c • x`
is a measurable function and for each `x` the map `c ↦ c • x` is a measurable function. -/
@[to_additive]
class has_measurable_smul (M α : Type*) [has_smul M α] [measurable_space M] [measurable_space α] :
  Prop :=
(measurable_const_smul : ∀ c : M, measurable ((•) c : α → α))
(measurable_smul_const : ∀ x : α, measurable (λ c : M, c • x))

/-- We say that the action of `M` on `α` `has_measurable_vadd₂` if the map
`(c, x) ↦ c +ᵥ x` is a measurable function. -/
class has_measurable_vadd₂ (M α : Type*) [has_vadd M α] [measurable_space M]
  [measurable_space α] : Prop :=
(measurable_vadd : measurable (function.uncurry (+ᵥ) : M × α → α))

/-- We say that the action of `M` on `α` `has_measurable_smul₂` if the map
`(c, x) ↦ c • x` is a measurable function. -/
@[to_additive has_measurable_vadd₂]
class has_measurable_smul₂ (M α : Type*) [has_smul M α] [measurable_space M]
  [measurable_space α] : Prop :=
(measurable_smul : measurable (function.uncurry (•) : M × α → α))

export has_measurable_smul (measurable_const_smul measurable_smul_const)
export has_measurable_smul₂ (measurable_smul)
export has_measurable_vadd (measurable_const_vadd measurable_vadd_const)
export has_measurable_vadd₂ (measurable_vadd)

@[to_additive]
instance has_measurable_smul_of_mul (M : Type*) [has_mul M] [measurable_space M]
  [has_measurable_mul M] :
  has_measurable_smul M M :=
⟨measurable_id.const_mul, measurable_id.mul_const⟩

@[to_additive]
instance has_measurable_smul₂_of_mul (M : Type*) [has_mul M] [measurable_space M]
  [has_measurable_mul₂ M] :
  has_measurable_smul₂ M M :=
⟨measurable_mul⟩

@[to_additive] instance submonoid.has_measurable_smul {M α} [measurable_space M]
  [measurable_space α] [monoid M] [mul_action M α] [has_measurable_smul M α] (s : submonoid M) :
  has_measurable_smul s α :=
⟨λ c, by simpa only using measurable_const_smul (c : M),
  λ x, (measurable_smul_const x : measurable (λ c : M, c • x)).comp measurable_subtype_coe⟩

@[to_additive] instance subgroup.has_measurable_smul {G α} [measurable_space G]
  [measurable_space α] [group G] [mul_action G α] [has_measurable_smul G α] (s : subgroup G) :
  has_measurable_smul s α :=
s.to_submonoid.has_measurable_smul

section smul

variables {M β α : Type*} [measurable_space M] [measurable_space β] [has_smul M β]
  {m : measurable_space α} {f : α → M} {g : α → β}

include m

@[measurability, to_additive]
lemma measurable.smul [has_measurable_smul₂ M β] (hf : measurable f) (hg : measurable g) :
  measurable (λ x, f x • g x) :=
measurable_smul.comp (hf.prod_mk hg)

@[measurability, to_additive]
lemma ae_measurable.smul [has_measurable_smul₂ M β]
  {μ : measure α} (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ae_measurable (λ x, f x • g x) μ :=
has_measurable_smul₂.measurable_smul.comp_ae_measurable (hf.prod_mk hg)

omit m

@[priority 100, to_additive]
instance has_measurable_smul₂.to_has_measurable_smul [has_measurable_smul₂ M β] :
  has_measurable_smul M β :=
⟨λ c, measurable_const.smul measurable_id, λ y, measurable_id.smul measurable_const⟩

include m

variables [has_measurable_smul M β] {μ : measure α}

@[measurability, to_additive]
lemma measurable.smul_const (hf : measurable f) (y : β) :
  measurable (λ x, f x • y) :=
(has_measurable_smul.measurable_smul_const y).comp hf

@[measurability, to_additive]
lemma ae_measurable.smul_const (hf : ae_measurable f μ) (y : β) :
  ae_measurable (λ x, f x • y) μ :=
(has_measurable_smul.measurable_smul_const y).comp_ae_measurable hf

@[measurability, to_additive]
lemma measurable.const_smul' (hg : measurable g) (c : M) :
  measurable (λ x, c • g x) :=
(has_measurable_smul.measurable_const_smul c).comp hg

@[measurability, to_additive]
lemma measurable.const_smul (hg : measurable g) (c : M) :
  measurable (c • g) :=
hg.const_smul' c

@[measurability, to_additive]
lemma ae_measurable.const_smul' (hg : ae_measurable g μ) (c : M) :
  ae_measurable (λ x, c • g x) μ :=
(has_measurable_smul.measurable_const_smul c).comp_ae_measurable hg

@[measurability, to_additive]
lemma ae_measurable.const_smul (hf : ae_measurable g μ) (c : M) :
  ae_measurable (c • g) μ :=
hf.const_smul' c

omit m

@[to_additive]
instance pi.has_measurable_smul {ι : Type*} {α : ι → Type*} [∀ i, has_smul M (α i)]
  [∀ i, measurable_space (α i)] [∀ i, has_measurable_smul M (α i)] :
  has_measurable_smul M (Π i, α i) :=
⟨λ g, measurable_pi_iff.mpr $ λ i, (measurable_pi_apply i).const_smul _,
 λ g, measurable_pi_iff.mpr $ λ i, measurable_smul_const _⟩

/-- `add_monoid.has_smul_nat` is measurable. -/
instance add_monoid.has_measurable_smul_nat₂ (M : Type*) [add_monoid M] [measurable_space M]
  [has_measurable_add₂ M] : has_measurable_smul₂ ℕ M :=
⟨begin
  suffices : measurable (λ p : M × ℕ, p.2 • p.1),
  { apply this.comp measurable_swap, },
  refine measurable_from_prod_countable (λ n, _),
  induction n with n ih,
  { simp only [zero_smul, ←pi.zero_def, measurable_zero] },
  { simp only [succ_nsmul], exact measurable_id.add ih }
end⟩

/-- `sub_neg_monoid.has_smul_int` is measurable. -/
instance sub_neg_monoid.has_measurable_smul_int₂ (M : Type*) [sub_neg_monoid M] [measurable_space M]
  [has_measurable_add₂ M] [has_measurable_neg M] : has_measurable_smul₂ ℤ M :=
⟨begin
  suffices : measurable (λ p : M × ℤ, p.2 • p.1),
  { apply this.comp measurable_swap, },
  refine measurable_from_prod_countable (λ n, _),
  induction n with n n ih,
  { simp only [of_nat_zsmul], exact measurable_const_smul _, },
  { simp only [zsmul_neg_succ_of_nat], exact (measurable_const_smul _).neg }
end⟩

end smul

section mul_action

variables {M β α : Type*} [measurable_space M] [measurable_space β] [monoid M] [mul_action M β]
  [has_measurable_smul M β] [measurable_space α] {f : α → β} {μ : measure α}

variables {G : Type*} [group G] [measurable_space G] [mul_action G β]
  [has_measurable_smul G β]

@[to_additive]
lemma measurable_const_smul_iff (c : G) :
  measurable (λ x, c • f x) ↔ measurable f :=
⟨λ h, by simpa only [inv_smul_smul] using h.const_smul' c⁻¹, λ h, h.const_smul c⟩

@[to_additive]
lemma ae_measurable_const_smul_iff (c : G) :
  ae_measurable (λ x, c • f x) μ ↔ ae_measurable f μ :=
⟨λ h, by simpa only [inv_smul_smul] using h.const_smul' c⁻¹, λ h, h.const_smul c⟩

@[to_additive]
instance : measurable_space Mˣ := measurable_space.comap (coe : Mˣ → M) ‹_›

@[to_additive]
instance units.has_measurable_smul : has_measurable_smul Mˣ β :=
{ measurable_const_smul := λ c, (measurable_const_smul (c : M) : _),
  measurable_smul_const := λ x,
    (measurable_smul_const x : measurable (λ c : M, c • x)).comp measurable_space.le_map_comap, }

@[to_additive]
lemma is_unit.measurable_const_smul_iff {c : M} (hc : is_unit c) :
  measurable (λ x, c • f x) ↔ measurable f :=
let ⟨u, hu⟩ := hc in hu ▸ measurable_const_smul_iff u

@[to_additive]
lemma is_unit.ae_measurable_const_smul_iff {c : M} (hc : is_unit c) :
  ae_measurable (λ x, c • f x) μ ↔ ae_measurable f μ :=
let ⟨u, hu⟩ := hc in hu ▸ ae_measurable_const_smul_iff u

variables {G₀ : Type*} [group_with_zero G₀] [measurable_space G₀] [mul_action G₀ β]
  [has_measurable_smul G₀ β]

lemma measurable_const_smul_iff₀ {c : G₀} (hc : c ≠ 0) :
  measurable (λ x, c • f x) ↔ measurable f :=
(is_unit.mk0 c hc).measurable_const_smul_iff

lemma ae_measurable_const_smul_iff₀ {c : G₀} (hc : c ≠ 0) :
  ae_measurable (λ x, c • f x) μ ↔ ae_measurable f μ :=
(is_unit.mk0 c hc).ae_measurable_const_smul_iff

end mul_action

/-!
### Opposite monoid
-/

section opposite
open mul_opposite

@[to_additive]
instance {α : Type*} [h : measurable_space α] : measurable_space αᵐᵒᵖ := measurable_space.map op h

@[to_additive]
lemma measurable_mul_op {α : Type*} [measurable_space α] : measurable (op : α → αᵐᵒᵖ) := λ s, id

@[to_additive]
lemma measurable_mul_unop {α : Type*} [measurable_space α] : measurable (unop : αᵐᵒᵖ → α) := λ s, id

@[to_additive]
instance {M : Type*} [has_mul M] [measurable_space M] [has_measurable_mul M] :
  has_measurable_mul Mᵐᵒᵖ :=
⟨λ c, measurable_mul_op.comp (measurable_mul_unop.mul_const _),
  λ c, measurable_mul_op.comp (measurable_mul_unop.const_mul _)⟩

@[to_additive]
instance {M : Type*} [has_mul M] [measurable_space M] [has_measurable_mul₂ M] :
  has_measurable_mul₂ Mᵐᵒᵖ :=
⟨measurable_mul_op.comp ((measurable_mul_unop.comp measurable_snd).mul
  (measurable_mul_unop.comp measurable_fst))⟩

/-- If a scalar is central, then its right action is measurable when its left action is. -/
instance has_measurable_smul.op {M α} [measurable_space M]
  [measurable_space α] [has_smul M α] [has_smul Mᵐᵒᵖ α] [is_central_scalar M α]
  [has_measurable_smul M α] : has_measurable_smul Mᵐᵒᵖ α :=
⟨ mul_opposite.rec $ λ c, show measurable (λ x, op c • x),
                          by simpa only [op_smul_eq_smul] using measurable_const_smul c,
  λ x, show measurable (λ c, op (unop c) • x),
       by simpa only [op_smul_eq_smul] using (measurable_smul_const x).comp measurable_mul_unop⟩

/-- If a scalar is central, then its right action is measurable when its left action is. -/
instance has_measurable_smul₂.op {M α} [measurable_space M]
  [measurable_space α] [has_smul M α] [has_smul Mᵐᵒᵖ α] [is_central_scalar M α]
  [has_measurable_smul₂ M α] : has_measurable_smul₂ Mᵐᵒᵖ α :=
⟨show measurable (λ x : Mᵐᵒᵖ × α, op (unop x.1) • x.2), begin
  simp_rw op_smul_eq_smul,
  refine (measurable_mul_unop.comp measurable_fst).smul measurable_snd,
end⟩

@[to_additive]
instance has_measurable_smul_opposite_of_mul {M : Type*} [has_mul M] [measurable_space M]
  [has_measurable_mul M] : has_measurable_smul Mᵐᵒᵖ M :=
⟨λ c, measurable_mul_const (unop c), λ x, measurable_mul_unop.const_mul x⟩

@[to_additive]
instance has_measurable_smul₂_opposite_of_mul {M : Type*} [has_mul M] [measurable_space M]
  [has_measurable_mul₂ M] : has_measurable_smul₂ Mᵐᵒᵖ M :=
⟨measurable_snd.mul (measurable_mul_unop.comp measurable_fst)⟩

end opposite

/-!
### Big operators: `∏` and `∑`
-/

section monoid
variables {M α : Type*} [monoid M] [measurable_space M] [has_measurable_mul₂ M]
  {m : measurable_space α} {μ : measure α}

include m

@[measurability, to_additive]
lemma list.measurable_prod' (l : list (α → M)) (hl : ∀ f ∈ l, measurable f) :
  measurable l.prod :=
begin
  induction l with f l ihl, { exact measurable_one },
  rw [list.forall_mem_cons] at hl,
  rw [list.prod_cons],
  exact hl.1.mul (ihl hl.2)
end

@[measurability, to_additive]
lemma list.ae_measurable_prod' (l : list (α → M))
  (hl : ∀ f ∈ l, ae_measurable f μ) : ae_measurable l.prod μ :=
begin
  induction l with f l ihl, { exact ae_measurable_one },
  rw [list.forall_mem_cons] at hl,
  rw [list.prod_cons],
  exact hl.1.mul (ihl hl.2)
end

@[measurability, to_additive]
lemma list.measurable_prod (l : list (α → M)) (hl : ∀ f ∈ l, measurable f) :
  measurable (λ x, (l.map (λ f : α → M, f x)).prod) :=
by simpa only [← pi.list_prod_apply] using l.measurable_prod' hl

@[measurability, to_additive]
lemma list.ae_measurable_prod (l : list (α → M)) (hl : ∀ f ∈ l, ae_measurable f μ) :
  ae_measurable (λ x, (l.map (λ f : α → M, f x)).prod) μ :=
by simpa only [← pi.list_prod_apply] using l.ae_measurable_prod' hl

omit m

end monoid

section comm_monoid
variables {M ι α : Type*} [comm_monoid M] [measurable_space M] [has_measurable_mul₂ M]
  {m : measurable_space α} {μ : measure α} {f : ι → α → M}

include m

@[measurability, to_additive]
lemma multiset.measurable_prod' (l : multiset (α → M)) (hl : ∀ f ∈ l, measurable f) :
  measurable l.prod :=
by { rcases l with ⟨l⟩, simpa using l.measurable_prod' (by simpa using hl) }

@[measurability, to_additive]
lemma multiset.ae_measurable_prod' (l : multiset (α → M))
  (hl : ∀ f ∈ l, ae_measurable f μ) : ae_measurable l.prod μ :=
by { rcases l with ⟨l⟩, simpa using l.ae_measurable_prod' (by simpa using hl) }

@[measurability, to_additive]
lemma multiset.measurable_prod (s : multiset (α → M)) (hs : ∀ f ∈ s, measurable f) :
  measurable (λ x, (s.map (λ f : α → M, f x)).prod) :=
by simpa only [← pi.multiset_prod_apply] using s.measurable_prod' hs

@[measurability, to_additive]
lemma multiset.ae_measurable_prod (s : multiset (α → M))
  (hs : ∀ f ∈ s, ae_measurable f μ) : ae_measurable (λ x, (s.map (λ f : α → M, f x)).prod) μ :=
by simpa only [← pi.multiset_prod_apply] using s.ae_measurable_prod' hs

@[measurability, to_additive]
lemma finset.measurable_prod' (s : finset ι) (hf : ∀i ∈ s, measurable (f i)) :
  measurable (∏ i in s, f i) :=
finset.prod_induction _ _ (λ _ _, measurable.mul) (@measurable_one M _ _ _ _) hf

@[measurability, to_additive]
lemma finset.measurable_prod (s : finset ι) (hf : ∀i ∈ s, measurable (f i)) :
  measurable (λ a, ∏ i in s, f i a) :=
by simpa only [← finset.prod_apply] using s.measurable_prod' hf

@[measurability, to_additive]
lemma finset.ae_measurable_prod' (s : finset ι) (hf : ∀i ∈ s, ae_measurable (f i) μ) :
  ae_measurable (∏ i in s, f i) μ :=
multiset.ae_measurable_prod' _ $
  λ g hg, let ⟨i, hi, hg⟩ := multiset.mem_map.1 hg in (hg ▸ hf _ hi)

@[measurability, to_additive]
lemma finset.ae_measurable_prod (s : finset ι) (hf : ∀i ∈ s, ae_measurable (f i) μ) :
  ae_measurable (λ a, ∏ i in s, f i a) μ :=
by simpa only [← finset.prod_apply] using s.ae_measurable_prod' hf

omit m

end comm_monoid


import lang
import normalization
import data.set

-- V⟦−⟧ : type → PowerSet(ClosedVal)
-- V⟦−⟧ : type → (ClosedVal → 2)
-- interp_val : type → val → Prop
--

open exp typ

notation e ` ↦* `:90 e' := is_many_step e e'

def irred (e:exp) := ¬(∃ e', e ↦str e')

-- Approach to defining inductive relation inspired from ModuRes.

def T := set exp
instance T_has_mem : has_mem (exp) T := set.has_mem
instance T_has_inter : has_inter T := set.has_inter

def step_closure (s:T) : T :=
  { e:exp | ∀ e', (e ↦* e') ∧ irred(e') → e' ∈ s }

inductive rel_arrow: T → T → T
| Rlam (Rτ1 Rτ2:T) (x:string) (τ:typ) (e:exp)
  (Hfunc: ∀ (v:exp), (v ∈ Rτ1) → (substitute x v e) ∈ step_closure Rτ2) :
  (rel_arrow Rτ1 Rτ2 (lam x τ e))

def closed_vals := { e : exp | is_val e }

def interp_val : typ → (set exp)
| unitT := (singleton exp.unit)
| (arrowT τ1 τ2) := (rel_arrow (interp_val τ1) (interp_val τ2)) ∩ closed_vals

def interp_exp (τ:typ) := step_closure (interp_val τ)

notation `V⟦` τ `⟧` := interp_val τ
notation `E⟦` τ `⟧` := interp_exp τ

-- XXX: now, we're gonna call context_list Γ, and have to explicitly to
-- (mk_context Γ) in has_type.
def interp_ctx : context_list → set env
| [] [] := true
| ((y,τ)::Γ) ((x,v)::γ) := x=y ∧ interp_ctx Γ γ ∧ (v ∈ V⟦τ⟧)
| _ _ := false

notation `G⟦` Γ `⟧` := interp_ctx Γ

def semantic_has_type (Γ:context_list) (e:exp) (τ:typ) : Prop :=
  ∀ γ, γ ∈ G⟦Γ⟧ → env_sub γ e ∈ E⟦τ⟧

notation Γ ` ⊨ `:90 e:90 ` : `:90 τ := semantic_has_type Γ e τ

def safe (e:exp) : Prop :=
∀ e', (e ↦* e') → (is_val e') ∨ (∃ e'', e' ↦str e'')

lemma interp_val_implies_closedval :
∀ v τ, v ∈ V⟦τ⟧ → v ∈ closed_vals :=
begin
  introv Hval,
  cases τ,
  {
      unfold interp_val at Hval,
      unfold singleton at Hval,
      simp at Hval, subst Hval,
      constructor
  },
  {
      unfold interp_val at Hval,
      cases Hval,
      unfold closed_vals at Hval_right,
      simp at Hval_right, assumption
  }
end

lemma semantic_implies_type_safety :
∀ e τ,
  ([] ⊨ e : τ) →
  safe(e) :=
begin
  introv HTy,
  intros e' Hstep,
  by_cases irred(e'), tactic.swap,
  { -- easy case, just take a step
    unfold irred at h,
    simp at h,
    cases h with e'',
    right,
    existsi e'',
    assumption
  },
  { -- otherwise, show
    unfold semantic_has_type at HTy,
    specialize HTy [] _,
    { constructor },
    unfold env_sub at HTy,
    specialize HTy e' ⟨Hstep, h⟩,
    left,
    apply interp_val_implies_closedval,
    assumption
  }
end

def not_in_env (γ:env) (x:string) : Prop := (∀ v, (x, v) ∉ γ)

lemma env_sub_lam_notin :
∀ γ x τ e,
  not_in_env γ x →
  env_sub γ (lam x τ e) = lam x τ (env_sub γ e) :=
begin
  introv Hnot,
  induction γ,
  { unfold env_sub },
  cases γ_hd,
  unfold env_sub,
  sorry,
end

lemma env_sub_lam_in :
∀ γ x τ e v,
  ((x, v) ∈ γ) →
  env_sub γ (lam x τ e) = lam x τ e :=
begin
sorry
end

-- This is the "substitution lemma" on page 13 of notes.
lemma substitution_lemma :
  ∀ γ x vx e,
  not_in_env γ x →
  env_sub ((x,vx)::γ) e = substitute x vx (env_sub γ e) :=
begin
  introv Hnot,
  unfold env_sub,
  induction γ generalizing e,
  { unfold env_sub },
  cases γ_hd,
  unfold env_sub,
  rw <- γ_ih, tactic.swap,
  {
    intros v,
    specialize Hnot v,
    intros H,
    apply Hnot,
    right, assumption
  },
  rw substitute_commute,
  repeat { sorry }
end

theorem fundamental_property :
∀ Γ e τ,
  (mk_context Γ ⊢ e : τ) →
  (Γ ⊨ e : τ) :=
begin
  introv Hty,
  generalize h : (mk_context Γ) = (ctx),
  rw h at *,
  induction Hty generalizing Γ; subst h; unfold semantic_has_type,
  { -- case: unit
    introv Hγ, rw env_sub_unit,
    unfold interp_exp step_closure, simp *,
    introv Hstep Hirred,
    cases Hstep,
    { constructor },
    exfalso, cases Hstep_Hstep,
  },
  { -- case: var
    introv Hγ,
    rename [Hty_x → x, Hty_τ → τ],
    -- Argument:
    -- Knowing (mk_context Γ) x = some τ and γ ∈ G⟦Γ⟧ should tells us:
    -- ∃ (x,vx) ∈ γ, vx ∈ V⟦τ⟧,
    --    env_sub γ (var x) = vx
    -- At that point, we're done because V⟦τ⟧ ⊆ E⟦τ⟧.
    sorry,
  },
  { -- case: abs; this is where induction will be a bit tricky.
    introv Hγ,
    rename [Hty_x → x, Hty_τ1 → τ1, Hty_τ2 → τ2, Hty_e → e],
    -- FIXME: using this false lemma (could be made true modulo α-substitutions)
    -- to mimic the argument in the lecture notes for now.
    by_cases (not_in_env γ x), tactic.swap,
    { sorry },
    {
      rw env_sub_lam_notin, tactic.swap, { tauto },
      intros e' Hstep,
      cases Hstep with Hstep Hirred,
      cases Hstep, tactic.swap, { cases Hstep_Hstep },
      unfold interp_val,
      split, tactic.swap,
      { unfold closed_vals, constructor },
      constructor,
      intros v Hv,
      -- NOTE: step_closure V⟦τ2⟧ is the same as E⟦τ2⟧.
      rw (_:step_closure V⟦τ2⟧ = E⟦τ2⟧), tactic.swap,
      { unfold interp_exp },

      -- Apply inductive hypothesis
      specialize Hty_ih ((x,τ1)::Γ) _,
      { unfold mk_context },
      specialize Hty_ih ((x,v)::γ) _,
      { constructor, { refl },
        split; assumption,
      },
      unfold env_sub at Hty_ih,
      rw <- substitution_lemma, tactic.swap, assumption,
      apply Hty_ih,
    }
  },
  repeat { sorry }
end


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

! This file was ported from Lean 3 source module algebra.module.pid
! leanprover-community/mathlib commit f62c15c01a5409b31b97a82d79a12980be4eff35
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Module.DedekindDomain
import Mathbin.LinearAlgebra.FreeModule.Pid
import Mathbin.Algebra.Module.Projective
import Mathbin.Algebra.Category.Module.Biproducts

/-!
# Structure of finitely generated modules over a PID

## Main statements

* `module.equiv_direct_sum_of_is_torsion` : A finitely generated torsion module over a PID is
  isomorphic to a direct sum of some `R ⧸ R ∙ (p i ^ e i)` where the `p i ^ e i` are prime powers.
* `module.equiv_free_prod_direct_sum` : A finitely generated module over a PID is isomorphic to the
  product of a free module (its torsion free part) and a direct sum of the form above (its torsion
  submodule).

## Notation

* `R` is a PID and `M` is a (finitely generated for main statements) `R`-module, with additional
  torsion hypotheses in the intermediate lemmas.
* `N` is a `R`-module lying over a higher type universe than `R`. This assumption is needed on the
  final statement for technical reasons.
* `p` is an irreducible element of `R` or a tuple of these.

## Implementation details

We first prove (`submodule.is_internal_prime_power_torsion_of_pid`) that a finitely generated
torsion module is the internal direct sum of its `p i ^ e i`-torsion submodules for some
(finitely many) prime powers `p i ^ e i`. This is proved in more generality for a Dedekind domain
at `submodule.is_internal_prime_power_torsion`.

Then we treat the case of a `p ^ ∞`-torsion module (that is, a module where all elements are
cancelled by scalar multiplication by some power of `p`) and apply it to the `p i ^ e i`-torsion
submodules (that are `p i ^ ∞`-torsion) to get the result for torsion modules.

Then we get the general result using that a torsion free module is free (which has been proved at
`module.free_of_finite_type_torsion_free'` at `linear_algebra/free_module/pid.lean`.)

## Tags

Finitely generated module, principal ideal domain, classification, structure theorem
-/

universe u v

open BigOperators

variable {R : Type u} [CommRing R] [IsDomain R] [IsPrincipalIdealRing R]

variable {M : Type v} [AddCommGroup M] [Module R M]

variable {N : Type max u v} [AddCommGroup N] [Module R N]

open DirectSum

open Submodule

/-- A finitely generated torsion module over a PID is an internal direct sum of its
`p i ^ e i`-torsion submodules for some primes `p i` and numbers `e i`.-/
theorem Submodule.isInternal_prime_power_torsion_of_pid [Module.Finite R M]
    (hM : Module.IsTorsion R M) :
    ∃ (ι : Type u)(_ : Fintype ι)(_ : DecidableEq ι)(p : ι → R)(h : ∀ i, Irreducible <| p i)(e :
      ι → ℕ), DirectSum.IsInternal fun i => torsion_by R M <| p i ^ e i :=
  by
  obtain ⟨P, dec, hP, e, this⟩ := is_internal_prime_power_torsion hM
  refine' ⟨P, inferInstance, dec, fun p => is_principal.generator (p : Ideal R), _, e, _⟩
  · rintro ⟨p, hp⟩
    haveI := Ideal.isPrime_of_prime (hP p hp)
    exact (is_principal.prime_generator_of_is_prime p (hP p hp).NeZero).Irreducible
  · convert this
    ext p : 1
    rw [← torsion_by_span_singleton_eq, Ideal.submodule_span_eq, ← Ideal.span_singleton_pow,
      Ideal.span_singleton_generator]
#align submodule.is_internal_prime_power_torsion_of_pid Submodule.isInternal_prime_power_torsion_of_pid

namespace Module

section PTorsion

variable {p : R} (hp : Irreducible p) (hM : Module.IsTorsion' M (Submonoid.powers p))

variable [dec : ∀ x : M, Decidable (x = 0)]

open Ideal Submodule.IsPrincipal

include dec

include hp hM

theorem Ideal.torsionOf_eq_span_pow_pOrder (x : M) : torsionOf R M x = span {p ^ pOrder hM x} :=
  by
  dsimp only [p_order]
  rw [← (torsion_of R M x).span_singleton_generator, Ideal.span_singleton_eq_span_singleton, ←
    Associates.mk_eq_mk_iff_associated, Associates.mk_pow]
  have prop :
    (fun n : ℕ => p ^ n • x = 0) = fun n : ℕ =>
      (Associates.mk <| generator <| torsion_of R M x) ∣ Associates.mk p ^ n :=
    by
    ext n
    rw [← Associates.mk_pow, Associates.mk_dvd_mk, ← mem_iff_generator_dvd]
    rfl
  have := (is_torsion'_powers_iff p).mp hM x
  rw [prop] at this
  classical convert Associates.eq_pow_find_of_dvd_irreducible_pow
        ((Associates.irreducible_mk p).mpr hp) this.some_spec
#align ideal.torsion_of_eq_span_pow_p_order Ideal.torsionOf_eq_span_pow_pOrder

theorem p_pow_smul_lift {x y : M} {k : ℕ} (hM' : Module.IsTorsionBy R M (p ^ pOrder hM y))
    (h : p ^ k • x ∈ R ∙ y) : ∃ a : R, p ^ k • x = p ^ k • a • y :=
  by
  by_cases hk : k ≤ p_order hM y
  · let f :=
      ((R ∙ p ^ (p_order hM y - k) * p ^ k).quotEquivOfEq _ _).trans
        (quot_torsion_of_equiv_span_singleton R M y)
    have :
      f.symm ⟨p ^ k • x, h⟩ ∈ R ∙ Ideal.Quotient.mk (R ∙ p ^ (p_order hM y - k) * p ^ k) (p ^ k) :=
      by
      rw [← quotient.torsion_by_eq_span_singleton, mem_torsion_by_iff, ← f.symm.map_smul]
      convert f.symm.map_zero
      ext
      rw [coe_smul_of_tower, coe_mk, coe_zero, smul_smul, ← pow_add, Nat.sub_add_cancel hk, @hM' x]
      · exact mem_nonZeroDivisors_of_ne_zero (pow_ne_zero _ hp.ne_zero)
    rw [Submodule.mem_span_singleton] at this
    obtain ⟨a, ha⟩ := this
    use a
    rw [f.eq_symm_apply, ← Ideal.Quotient.mk_eq_mk, ← quotient.mk_smul] at ha
    dsimp only [smul_eq_mul, f, LinearEquiv.trans_apply, Submodule.quotEquivOfEq_mk,
      quot_torsion_of_equiv_span_singleton_apply_mk] at ha
    rw [smul_smul, mul_comm]
    exact congr_arg coe ha.symm
    · symm
      convert Ideal.torsionOf_eq_span_pow_pOrder hp hM y
      rw [← pow_add, Nat.sub_add_cancel hk]
  · use 0
    rw [zero_smul, smul_zero, ← Nat.sub_add_cancel (le_of_not_le hk), pow_add, mul_smul, hM',
      smul_zero]
#align module.p_pow_smul_lift Module.p_pow_smul_lift

open Submodule.Quotient

theorem exists_smul_eq_zero_and_mk_eq {z : M} (hz : Module.IsTorsionBy R M (p ^ pOrder hM z))
    {k : ℕ} (f : (R ⧸ R ∙ p ^ k) →ₗ[R] M ⧸ R ∙ z) :
    ∃ x : M, p ^ k • x = 0 ∧ Submodule.Quotient.mk x = f 1 :=
  by
  have f1 := mk_surjective (R ∙ z) (f 1)
  have : p ^ k • f1.some ∈ R ∙ z :=
    by
    rw [← quotient.mk_eq_zero, mk_smul, f1.some_spec, ← f.map_smul]
    convert f.map_zero
    change _ • Submodule.Quotient.mk _ = _
    rw [← mk_smul, quotient.mk_eq_zero, Algebra.id.smul_eq_mul, mul_one]
    exact Submodule.mem_span_singleton_self _
  obtain ⟨a, ha⟩ := p_pow_smul_lift hp hM hz this
  refine' ⟨f1.some - a • z, by rw [smul_sub, sub_eq_zero, ha], _⟩
  rw [mk_sub, mk_smul, (quotient.mk_eq_zero _).mpr <| Submodule.mem_span_singleton_self _,
    smul_zero, sub_zero, f1.some_spec]
#align module.exists_smul_eq_zero_and_mk_eq Module.exists_smul_eq_zero_and_mk_eq

open Finset Multiset

omit dec hM

/-- A finitely generated `p ^ ∞`-torsion module over a PID is isomorphic to a direct sum of some
  `R ⧸ R ∙ (p ^ e i)` for some `e i`.-/
theorem torsion_by_prime_power_decomposition (hN : Module.IsTorsion' N (Submonoid.powers p))
    [h' : Module.Finite R N] :
    ∃ (d : ℕ)(k : Fin d → ℕ), Nonempty <| N ≃ₗ[R] ⨁ i : Fin d, R ⧸ R ∙ p ^ (k i : ℕ) :=
  by
  obtain ⟨d, s, hs⟩ := @Module.Finite.exists_fin _ _ _ _ _ h'; use d; clear h'
  induction' d with d IH generalizing N
  · use fun i => finZeroElim i
    rw [Set.range_eq_empty, Submodule.span_empty] at hs
    haveI : Unique N :=
      ⟨⟨0⟩, fun x => by
        rw [← mem_bot _, hs]
        trivial⟩
    exact ⟨0⟩
  · have : ∀ x : N, Decidable (x = 0)
    classical
      infer_instance
      obtain ⟨j, hj⟩ := exists_is_torsion_by hN d.succ d.succ_ne_zero s hs
      let s' : Fin d → N ⧸ R ∙ s j := Submodule.Quotient.mk ∘ s ∘ j.succ_above
      obtain ⟨k, ⟨f⟩⟩ := IH _ s' _ <;> clear IH
      · have :
          ∀ i : Fin d,
            ∃ x : N, p ^ k i • x = 0 ∧ f (Submodule.Quotient.mk x) = DirectSum.lof R _ _ i 1 :=
          by
          intro i
          let fi := f.symm.to_linear_map.comp (DirectSum.lof _ _ _ i)
          obtain ⟨x, h0, h1⟩ := exists_smul_eq_zero_and_mk_eq hp hN hj fi
          refine' ⟨x, h0, _⟩
          rw [h1]
          simp only [LinearMap.coe_comp, f.symm.coe_to_linear_map, f.apply_symm_apply]
        refine'
          ⟨_,
            ⟨(((@lequivProdOfRightSplitExact _ _ _ _ _ _ _ _ _ _ _ _
                              ((f.trans ULift.moduleEquiv.{u, u, v}.symm).toLinearMap.comp <| mkq _)
                              ((DirectSum.toModule _ _ _ fun i =>
                                    (liftQSpanSingleton.{u, u} (p ^ k i)
                                        (LinearMap.toSpanSingleton _ _ _)
                                        (this i).choose_spec.left :
                                      R ⧸ _ →ₗ[R] _)).comp
                                ulift.module_equiv.to_linear_map)
                              (R ∙ s j).injective_subtype _ _).symm.trans <|
                        ((quot_torsion_of_equiv_span_singleton _ _ _).symm.trans <|
                              quot_equiv_of_eq _ _ <|
                                Ideal.torsionOf_eq_span_pow_pOrder hp hN _).Prod <|
                          ULift.moduleEquiv).trans <|
                    (@DirectSum.lequivProdDirectSum R _ _ _
                        (fun i => R ⧸ R ∙ p ^ @Option.rec _ (fun _ => ℕ) (p_order hN <| s j) k i) _
                        _).symm).trans <|
                DirectSum.lequivCongrLeft R (finSuccEquiv d).symm⟩⟩
        · rw [range_subtype, LinearEquiv.toLinearMap_eq_coe, LinearEquiv.ker_comp, ker_mkq]
        · rw [LinearEquiv.toLinearMap_eq_coe, ← f.comp_coe, LinearMap.comp_assoc,
            LinearMap.comp_assoc, ← LinearEquiv.toLinearMap_eq_coe,
            LinearEquiv.toLinearMap_symm_comp_eq, LinearMap.comp_id, ← LinearMap.comp_assoc, ←
            LinearMap.comp_assoc]
          suffices (f.to_linear_map.comp (R ∙ s j).mkQ).comp _ = LinearMap.id by
            rw [← f.to_linear_map_eq_coe, this, LinearMap.id_comp]
          ext i : 3
          simp only [LinearMap.coe_comp, Function.comp_apply, mkq_apply]
          rw [LinearEquiv.coe_toLinearMap, LinearMap.id_apply, DirectSum.toModule_lof,
            liftq_span_singleton_apply, LinearMap.toSpanSingleton_one, Ideal.Quotient.mk_eq_mk,
            map_one, (this i).choose_spec.right]
      ·
        exact
          (mk_surjective _).forall.mpr fun x =>
            ⟨(@hN x).some, by rw [← quotient.mk_smul, (@hN x).choose_spec, quotient.mk_zero]⟩
      · have hs' := congr_arg (Submodule.map <| mkq <| R ∙ s j) hs
        rw [Submodule.map_span, Submodule.map_top, range_mkq] at hs'
        simp only [mkq_apply] at hs'
        simp only [s']
        rw [Set.range_comp (_ ∘ s), Fin.range_succAbove]
        rw [← Set.range_comp, ← Set.insert_image_compl_eq_range _ j, Function.comp_apply,
          (quotient.mk_eq_zero _).mpr (Submodule.mem_span_singleton_self _), span_insert_zero] at
          hs'
        exact hs'
#align module.torsion_by_prime_power_decomposition Module.torsion_by_prime_power_decomposition

end PTorsion

/-- A finitely generated torsion module over a PID is isomorphic to a direct sum of some
  `R ⧸ R ∙ (p i ^ e i)` where the `p i ^ e i` are prime powers.-/
theorem equiv_directSum_of_isTorsion [h' : Module.Finite R N] (hN : Module.IsTorsion R N) :
    ∃ (ι : Type u)(_ : Fintype ι)(p : ι → R)(h : ∀ i, Irreducible <| p i)(e : ι → ℕ),
      Nonempty <| N ≃ₗ[R] ⨁ i : ι, R ⧸ R ∙ p i ^ e i :=
  by
  obtain ⟨I, fI, _, p, hp, e, h⟩ := Submodule.isInternal_prime_power_torsion_of_pid hN
  haveI := fI
  have :
    ∀ i,
      ∃ (d : ℕ)(k : Fin d → ℕ),
        Nonempty <| torsion_by R N (p i ^ e i) ≃ₗ[R] ⨁ j, R ⧸ R ∙ p i ^ k j :=
    by
    haveI := isNoetherian_of_fg_of_noetherian' (module.finite_def.mp h')
    haveI := fun i => isNoetherian_submodule' (torsion_by R N <| p i ^ e i)
    exact fun i =>
      torsion_by_prime_power_decomposition (hp i)
        ((is_torsion'_powers_iff <| p i).mpr fun x => ⟨e i, smul_torsion_by _ _⟩)
  classical
    refine'
      ⟨Σi, Fin (this i).some, inferInstance, fun ⟨i, j⟩ => p i, fun ⟨i, j⟩ => hp i, fun ⟨i, j⟩ =>
        (this i).choose_spec.some j,
        ⟨(LinearEquiv.ofBijective (DirectSum.coeLinearMap _) h).symm.trans <|
            (Dfinsupp.mapRange.linearEquiv fun i => (this i).choose_spec.choose_spec.some).trans <|
              (DirectSum.sigmaLcurryEquiv R).symm.trans
                (Dfinsupp.mapRange.linearEquiv fun i => quot_equiv_of_eq _ _ _)⟩⟩
    cases' i with i j
    simp only
#align module.equiv_direct_sum_of_is_torsion Module.equiv_directSum_of_isTorsion

/-- **Structure theorem of finitely generated modules over a PID** : A finitely generated
  module over a PID is isomorphic to the product of a free module and a direct sum of some
  `R ⧸ R ∙ (p i ^ e i)` where the `p i ^ e i` are prime powers.-/
theorem equiv_free_prod_directSum [h' : Module.Finite R N] :
    ∃ (n : ℕ)(ι : Type u)(_ : Fintype ι)(p : ι → R)(h : ∀ i, Irreducible <| p i)(e : ι → ℕ),
      Nonempty <| N ≃ₗ[R] (Fin n →₀ R) × ⨁ i : ι, R ⧸ R ∙ p i ^ e i :=
  by
  haveI := isNoetherian_of_fg_of_noetherian' (module.finite_def.mp h')
  haveI := isNoetherian_submodule' (torsion R N)
  haveI := Module.Finite.of_surjective _ (torsion R N).mkQ_surjective
  obtain ⟨I, fI, p, hp, e, ⟨h⟩⟩ := equiv_direct_sum_of_is_torsion (@torsion_is_torsion R N _ _ _)
  obtain ⟨n, ⟨g⟩⟩ := @Module.basisOfFiniteTypeTorsionFree' R _ _ _ (N ⧸ torsion R N) _ _ _ _
  haveI : Module.Projective R (N ⧸ torsion R N) := Module.projectiveOfBasis ⟨g⟩
  obtain ⟨f, hf⟩ := Module.projective_lifting_property _ LinearMap.id (torsion R N).mkQ_surjective
  refine'
    ⟨n, I, fI, p, hp, e,
      ⟨(lequivProdOfRightSplitExact (torsion R N).injective_subtype _ hf).symm.trans <|
          (h.prod g).trans <| LinearEquiv.prodComm R _ _⟩⟩
  rw [range_subtype, ker_mkq]
#align module.equiv_free_prod_direct_sum Module.equiv_free_prod_directSum

end Module


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .action

namespace algebra

signature magma (α : Type*) :=
(op : α → α → α)

namespace magma_sig
variables {α : Type*} (s : magma_sig α)

@[signature_instance]
definition to_left_action : left_action_sig α α :=
{ act := s.op
}

@[signature_instance]
definition to_right_action : right_action_sig α α :=
{ act := s.op
}

end magma_sig

class magma {α} (s : magma_sig α) : Prop := intro [] ::

abbreviation magma.infer {α} (s : magma_sig α) : magma s := magma.intro _

@[theory]
class cancel_magma {α} (s : magma_sig α) : Prop := intro ::
(left_cancellative : identity.op_left_cancellative s.op)
(right_cancellative : identity.op_right_cancellative s.op)

instance cancel_magma.to_magma {α} (s : magma_sig α) [i : cancel_magma s] : magma s := magma.infer _

@[theory]
class comm_magma {α} (s : magma_sig α) : Prop := intro ::
(commutative : identity.op_commutative s.op)

instance comm_magma.to_magma {α} (s : magma_sig α) [i : comm_magma s] : magma s := magma.infer _

@[theory]
class cancel_comm_magma {α} (s : magma_sig α) : Prop := intro ::
(commutative : identity.op_commutative s.op)
(right_cancellative : identity.op_right_cancellative s.op)

instance cancel_comm_magma.to_comm_magma {α} (s : magma_sig α) [i : cancel_comm_magma s] : comm_magma s := comm_magma.infer _

@[identity_instance]
theorem cancel_comm_magma.left_cancellative {α} (s : magma_sig α) [i : cancel_comm_magma s] :
identity.op_left_cancellative s.op :=
λ x y z h, have s.op y x = s.op z x,
from calc s.op y x
= s.op x y : by rw op_commutative s.op ...
= s.op x z : by rw h ...
= s.op z x : by rw op_commutative s.op,
op_right_cancellative s.op this

instance cancel_comm_magma.to_cancel_magma {α} (s : magma_sig α) [i : cancel_comm_magma s] : cancel_magma s := cancel_magma.infer _

end algebra