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

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

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

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

     |                        |
     |                        |
     |                        |
     V                        V

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

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

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

## Main definitions and results:

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

noncomputable theory

open set normed_group_hom uniform_space

section completion

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

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

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

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

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

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

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

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

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

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

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

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

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

open normed_group

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

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

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

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

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

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

end completion

section extension

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

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

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

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

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

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

end extension


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

import algebra.ring.equiv
import group_theory.group_action.group
import ring_theory.subring.basic

/-!
# Group action on rings

This file defines the typeclass of monoid acting on semirings `mul_semiring_action M R`,
and the corresponding typeclass of invariant subrings.

Note that `algebra` does not satisfy the axioms of `mul_semiring_action`.

## Implementation notes

There is no separate typeclass for group acting on rings, group acting on fields, etc.
They are all grouped under `mul_semiring_action`.

## Tags

group action, invariant subring

-/

universes u v
open_locale big_operators

/-- Typeclass for multiplicative actions by monoids on semirings.

This combines `distrib_mul_action` with `mul_distrib_mul_action`. -/
class mul_semiring_action (M : Type u) (R : Type v) [monoid M] [semiring R]
  extends distrib_mul_action M R :=
(smul_one : ∀ (g : M), (g • 1 : R) = 1)
(smul_mul : ∀ (g : M) (x y : R), g • (x * y) = (g • x) * (g • y))

section semiring

variables (M G : Type u) [monoid M] [group G]
variables (A R S F : Type v) [add_monoid A] [semiring R] [comm_semiring S] [division_ring F]

-- note we could not use `extends` since these typeclasses are made with `old_structure_cmd`
@[priority 100]
instance mul_semiring_action.to_mul_distrib_mul_action [h : mul_semiring_action M R] :
  mul_distrib_mul_action M R :=
{ ..h }

/-- Each element of the monoid defines a semiring homomorphism. -/
@[simps]
def mul_semiring_action.to_ring_hom [mul_semiring_action M R] (x : M) : R →+* R :=
{ .. mul_distrib_mul_action.to_monoid_hom R x,
  .. distrib_mul_action.to_add_monoid_hom R x }

theorem to_ring_hom_injective [mul_semiring_action M R] [has_faithful_scalar M R] :
  function.injective (mul_semiring_action.to_ring_hom M R) :=
λ m₁ m₂ h, eq_of_smul_eq_smul $ λ r, ring_hom.ext_iff.1 h r

/-- Each element of the group defines a semiring isomorphism. -/
@[simps]
def mul_semiring_action.to_ring_equiv [mul_semiring_action G R] (x : G) : R ≃+* R :=
{ .. distrib_mul_action.to_add_equiv R x,
  .. mul_semiring_action.to_ring_hom G R x }

section
variables {M G R}

/-- A stronger version of `submonoid.distrib_mul_action`. -/
instance submonoid.mul_semiring_action [mul_semiring_action M R] (H : submonoid M) :
  mul_semiring_action H R :=
{ smul := (•),
  .. H.mul_distrib_mul_action,
  .. H.distrib_mul_action }

/-- A stronger version of `subgroup.distrib_mul_action`. -/
instance subgroup.mul_semiring_action [mul_semiring_action G R] (H : subgroup G) :
  mul_semiring_action H R :=
H.to_submonoid.mul_semiring_action

/-- A stronger version of `subsemiring.distrib_mul_action`. -/
instance subsemiring.mul_semiring_action {R'} [semiring R'] [mul_semiring_action R' R]
  (H : subsemiring R') :
  mul_semiring_action H R :=
H.to_submonoid.mul_semiring_action

/-- A stronger version of `subring.distrib_mul_action`. -/
instance subring.mul_semiring_action {R'} [ring R'] [mul_semiring_action R' R]
  (H : subring R') :
  mul_semiring_action H R :=
H.to_subsemiring.mul_semiring_action

end

section simp_lemmas

variables {M G A R F}

attribute [simp] smul_one smul_mul' smul_zero smul_add

/-- Note that `smul_inv'` refers to the group case, and `smul_inv` has an additional inverse
on `x`. -/
@[simp] lemma smul_inv'' [mul_semiring_action M F] (x : M) (m : F) : x • m⁻¹ = (x • m)⁻¹ :=
(mul_semiring_action.to_ring_hom M F x).map_inv _

end simp_lemmas

end semiring

section ring

variables (M : Type u) [monoid M] {R : Type v} [ring R] [mul_semiring_action M R]
variables (S : subring R)
open mul_action

/-- A typeclass for subrings invariant under a `mul_semiring_action`. -/
class is_invariant_subring : Prop :=
(smul_mem : ∀ (m : M) {x : R}, x ∈ S → m • x ∈ S)

instance is_invariant_subring.to_mul_semiring_action [is_invariant_subring M S] :
  mul_semiring_action M S :=
{ smul := λ m x, ⟨m • x, is_invariant_subring.smul_mem m x.2⟩,
  one_smul := λ s, subtype.eq $ one_smul M s,
  mul_smul := λ m₁ m₂ s, subtype.eq $ mul_smul m₁ m₂ s,
  smul_add := λ m s₁ s₂, subtype.eq $ smul_add m s₁ s₂,
  smul_zero := λ m, subtype.eq $ smul_zero m,
  smul_one := λ m, subtype.eq $ smul_one m,
  smul_mul := λ m s₁ s₂, subtype.eq $ smul_mul' m s₁ s₂ }

end ring


/-
Copyright (c) 2020 Paul van Wamelen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul van Wamelen
-/
import number_theory.pythagorean_triples
import ring_theory.coprime.lemmas
import tactic.linear_combination

/-!
# Fermat's Last Theorem for the case n = 4
There are no non-zero integers `a`, `b` and `c` such that `a ^ 4 + b ^ 4 = c ^ 4`.
-/

noncomputable theory
open_locale classical

/-- Shorthand for three non-zero integers `a`, `b`, and `c` satisfying `a ^ 4 + b ^ 4 = c ^ 2`.
We will show that no integers satisfy this equation. Clearly Fermat's Last theorem for n = 4
follows. -/
def fermat_42 (a b c : ℤ) : Prop := a ≠ 0 ∧ b ≠ 0 ∧ a ^ 4 + b ^ 4 = c ^ 2

namespace fermat_42

lemma comm {a b c : ℤ} :
 (fermat_42 a b c) ↔ (fermat_42 b a c) :=
 by { delta fermat_42, rw add_comm, tauto }

lemma mul {a b c k : ℤ} (hk0 : k ≠ 0) :
  fermat_42 a b c ↔ fermat_42 (k * a) (k * b) (k ^ 2 * c) :=
begin
  delta fermat_42,
  split,
  { intro f42,
    split, { exact mul_ne_zero hk0 f42.1 },
    split, { exact mul_ne_zero hk0 f42.2.1 },
    { have H : a ^ 4 + b ^ 4 = c ^ 2 := f42.2.2,
      linear_combination (H, k ^ 4) } },
  { intro f42,
    split, { exact right_ne_zero_of_mul f42.1 },
    split, { exact right_ne_zero_of_mul f42.2.1 },
    apply (mul_right_inj' (pow_ne_zero 4 hk0)).mp,
    have H : (k * a) ^ 4 + (k * b) ^ 4 = (k ^ 2 * c) ^ 2 := f42.2.2,
    linear_combination H }
end

lemma ne_zero {a b c : ℤ} (h : fermat_42 a b c) : c ≠ 0 :=
begin
  apply ne_zero_pow (dec_trivial : 2 ≠ 0), apply ne_of_gt,
  rw [← h.2.2, (by ring : a ^ 4 + b ^ 4 = (a ^ 2) ^ 2 + (b ^ 2) ^ 2)],
  exact add_pos (sq_pos_of_ne_zero _ (pow_ne_zero 2 h.1))
      (sq_pos_of_ne_zero _ (pow_ne_zero 2 h.2.1))
end

/-- We say a solution to `a ^ 4 + b ^ 4 = c ^ 2` is minimal if there is no other solution with
a smaller `c` (in absolute value). -/
def minimal (a b c : ℤ) : Prop :=
  (fermat_42 a b c) ∧ ∀ (a1 b1 c1 : ℤ), (fermat_42 a1 b1 c1) → int.nat_abs c ≤ int.nat_abs c1

/-- if we have a solution to `a ^ 4 + b ^ 4 = c ^ 2` then there must be a minimal one. -/
lemma exists_minimal {a b c : ℤ} (h : fermat_42 a b c) :
  ∃ (a0 b0 c0), (minimal a0 b0 c0) :=
begin
  let S : set ℕ := { n | ∃ (s : ℤ × ℤ × ℤ), fermat_42 s.1 s.2.1 s.2.2 ∧ n = int.nat_abs s.2.2},
  have S_nonempty : S.nonempty,
  { use int.nat_abs c,
    rw set.mem_set_of_eq,
    use ⟨a, ⟨b, c⟩⟩, tauto },
  let m : ℕ := nat.find S_nonempty,
  have m_mem : m ∈ S := nat.find_spec S_nonempty,
  rcases m_mem with ⟨s0, hs0, hs1⟩,
  use [s0.1, s0.2.1, s0.2.2, hs0],
  intros a1 b1 c1 h1,
  rw ← hs1,
  apply nat.find_min',
  use ⟨a1, ⟨b1, c1⟩⟩, tauto
end

/-- a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` must have `a` and `b` coprime. -/
lemma coprime_of_minimal {a b c : ℤ} (h : minimal a b c) : is_coprime a b :=
begin
  apply int.gcd_eq_one_iff_coprime.mp,
  by_contradiction hab,
  obtain ⟨p, hp, hpa, hpb⟩ := nat.prime.not_coprime_iff_dvd.mp hab,
  obtain ⟨a1, rfl⟩ := (int.coe_nat_dvd_left.mpr hpa),
  obtain ⟨b1, rfl⟩ := (int.coe_nat_dvd_left.mpr hpb),
  have hpc : (p : ℤ) ^ 2 ∣ c,
  { apply (int.pow_dvd_pow_iff (dec_trivial : 0 < 2)).mp,
    rw ← h.1.2.2,
    apply dvd.intro (a1 ^ 4 + b1 ^ 4), ring },
  obtain ⟨c1, rfl⟩ := hpc,
  have hf : fermat_42 a1 b1 c1,
    exact (fermat_42.mul (int.coe_nat_ne_zero.mpr (nat.prime.ne_zero hp))).mpr h.1,
  apply nat.le_lt_antisymm (h.2 _ _ _ hf),
  rw [int.nat_abs_mul, lt_mul_iff_one_lt_left, int.nat_abs_pow, int.nat_abs_of_nat],
  { exact nat.one_lt_pow _ _ (show 0 < 2, from dec_trivial) (nat.prime.one_lt hp) },
  { exact (nat.pos_of_ne_zero (int.nat_abs_ne_zero_of_ne_zero (ne_zero hf))) },
end

/-- We can swap `a` and `b` in a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2`. -/

/-- We can assume that a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` has positive `c`. -/
lemma neg_of_minimal {a b c : ℤ} :
 (minimal a b c) → (minimal a b (-c)) :=
begin
  rintros ⟨⟨ha, hb, heq⟩, h2⟩,
  split,
  { apply and.intro ha (and.intro hb _),
    rw heq, exact (neg_sq c).symm },
  rwa (int.nat_abs_neg c),
end

/-- We can assume that a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` has `a` odd. -/
lemma exists_odd_minimal {a b c : ℤ} (h : fermat_42 a b c) :
  ∃ (a0 b0 c0), (minimal a0 b0 c0) ∧ a0 % 2 = 1 :=
begin
  obtain ⟨a0, b0, c0, hf⟩ := exists_minimal h,
  cases int.mod_two_eq_zero_or_one a0 with hap hap,
  { cases int.mod_two_eq_zero_or_one b0 with hbp hbp,
    { exfalso,
      have h1 : 2 ∣ (int.gcd a0 b0 : ℤ),
      { exact int.dvd_gcd (int.dvd_of_mod_eq_zero hap) (int.dvd_of_mod_eq_zero hbp) },
        rw int.gcd_eq_one_iff_coprime.mpr (coprime_of_minimal hf) at h1, revert h1, norm_num },
    { exact ⟨b0, ⟨a0, ⟨c0, minimal_comm hf, hbp⟩⟩⟩ } },
  exact ⟨a0, ⟨b0, ⟨c0 , hf, hap⟩⟩⟩,
end

/-- We can assume that a minimal solution to `a ^ 4 + b ^ 4 = c ^ 2` has
`a` odd and `c` positive. -/
lemma exists_pos_odd_minimal {a b c : ℤ} (h : fermat_42 a b c) :
  ∃ (a0 b0 c0), (minimal a0 b0 c0) ∧ a0 % 2 = 1 ∧ 0 < c0  :=
begin
  obtain ⟨a0, b0, c0, hf, hc⟩ := exists_odd_minimal h,
  rcases lt_trichotomy 0 c0 with (h1 | rfl | h1),
  { use [a0, b0, c0], tauto },
  { exfalso, exact ne_zero hf.1 rfl},
  { use [a0, b0, -c0, neg_of_minimal hf, hc],
    exact neg_pos.mpr h1 },
end

end fermat_42

lemma int.coprime_of_sq_sum {r s : ℤ} (h2 : is_coprime s r) :
  is_coprime (r ^ 2 + s ^ 2) r :=
begin
  rw [sq, sq],
  exact (is_coprime.mul_left h2 h2).mul_add_left_left r
end

lemma int.coprime_of_sq_sum' {r s : ℤ} (h : is_coprime r s) :
  is_coprime (r ^ 2 + s ^ 2) (r * s) :=
begin
  apply is_coprime.mul_right (int.coprime_of_sq_sum (is_coprime_comm.mp h)),
  rw add_comm, apply int.coprime_of_sq_sum h
end

namespace fermat_42

-- If we have a solution to a ^ 4 + b ^ 4 = c ^ 2, we can construct a smaller one. This
-- implies there can't be a smallest solution.
lemma not_minimal {a b c : ℤ}
  (h : minimal a b c) (ha2 : a % 2 = 1) (hc : 0 < c) : false :=
begin
  -- Use the fact that a ^ 2, b ^ 2, c form a pythagorean triple to obtain m and n such that
  -- a ^ 2 = m ^ 2 - n ^ 2, b ^ 2 = 2 * m * n and c = m ^ 2 + n ^ 2
  -- first the formula:
  have ht : pythagorean_triple (a ^ 2) (b ^ 2) c,
  { delta pythagorean_triple,
    have H := h.1.2.2,
    linear_combination H },
  -- coprime requirement:
  have h2 : int.gcd (a ^ 2) (b ^ 2) = 1 :=
    int.gcd_eq_one_iff_coprime.mpr (coprime_of_minimal h).pow,
  -- in order to reduce the possibilities we get from the classification of pythagorean triples
  -- it helps if we know the parity of a ^ 2 (and the sign of c):
  have ha22 : a ^ 2 % 2 = 1, { rw [sq, int.mul_mod, ha2], norm_num },
  obtain ⟨m, n, ht1, ht2, ht3, ht4, ht5, ht6⟩ := ht.coprime_classification' h2 ha22 hc,
  -- Now a, n, m form a pythagorean triple and so we can obtain r and s such that
  -- a = r ^ 2 - s ^ 2, n = 2 * r * s and m = r ^ 2 + s ^ 2
  -- formula:
  have htt : pythagorean_triple a n m,
  { delta pythagorean_triple,
    linear_combination ht1 },
  -- a and n are coprime, because a ^ 2 = m ^ 2 - n ^ 2 and m and n are coprime.
  have h3 : int.gcd a n = 1,
  { apply int.gcd_eq_one_iff_coprime.mpr,
    apply @is_coprime.of_mul_left_left _ _ _ a,
    rw [← sq, ht1, (by ring : m ^ 2 - n ^ 2 = m ^ 2 + (-n) * n)],
    exact (int.gcd_eq_one_iff_coprime.mp ht4).pow_left.add_mul_right_left (-n) },
  -- m is positive because b is non-zero and b ^ 2 = 2 * m * n and we already have 0 ≤ m.
  have hb20 : b ^ 2 ≠ 0 := mt pow_eq_zero h.1.2.1,
  have h4 : 0 < m,
  { apply lt_of_le_of_ne ht6,
    rintro rfl,
    revert hb20,
    rw ht2, simp },
  obtain ⟨r, s, htt1, htt2, htt3, htt4, htt5, htt6⟩ := htt.coprime_classification' h3 ha2 h4,
  -- Now use the fact that (b / 2) ^ 2 = m * r * s, and m, r and s are pairwise coprime to obtain
  -- i, j and k such that m = i ^ 2, r = j ^ 2 and s = k ^ 2.
  -- m and r * s are coprime because m = r ^ 2 + s ^ 2 and r and s are coprime.
  have hcp : int.gcd m (r * s) = 1,
  { rw htt3,
    exact int.gcd_eq_one_iff_coprime.mpr (int.coprime_of_sq_sum'
      (int.gcd_eq_one_iff_coprime.mp htt4)) },
  -- b is even because b ^ 2 = 2 * m * n.
  have hb2 : 2 ∣ b,
  { apply @int.prime.dvd_pow' _ 2 _ (by norm_num : nat.prime 2),
    rw [ht2, mul_assoc], exact dvd_mul_right 2 (m * n) },
  cases hb2 with b' hb2',
  have hs : b' ^ 2 = m * (r * s),
  { apply (mul_right_inj' (by norm_num : (4 : ℤ) ≠ 0)).mp,
    linear_combination (hb2', - b - 2 * b') (ht2, 1) (htt2, 2 * m) },
  have hrsz : r * s ≠ 0, -- because b ^ 2 is not zero and (b / 2) ^ 2 = m * (r * s)
  { by_contradiction hrsz,
    revert hb20, rw [ht2, htt2, mul_assoc, @mul_assoc _ _ _ r s, hrsz],
    simp },
  have h2b0 : b' ≠ 0,
  { apply ne_zero_pow (dec_trivial : 2 ≠ 0),
    rw hs, apply mul_ne_zero, { exact ne_of_gt h4}, { exact hrsz } },
  obtain ⟨i, hi⟩ := int.sq_of_gcd_eq_one hcp hs.symm,
  -- use m is positive to exclude m = - i ^ 2
  have hi' : ¬ m = - i ^ 2,
  { by_contradiction h1,
    have hit : - i ^ 2 ≤ 0, apply neg_nonpos.mpr (sq_nonneg i),
    rw ← h1 at hit,
    apply absurd h4 (not_lt.mpr hit) },
  replace hi : m = i ^ 2, { apply or.resolve_right hi hi' },
  rw mul_comm at hs,
  rw [int.gcd_comm] at hcp,
  -- obtain d such that r * s = d ^ 2
  obtain ⟨d, hd⟩ := int.sq_of_gcd_eq_one hcp hs.symm,
  -- (b / 2) ^ 2 and m are positive so r * s is positive
  have hd' : ¬ r * s = - d ^ 2,
  { by_contradiction h1,
    rw h1 at hs,
    have h2 : b' ^ 2 ≤ 0,
    { rw [hs, (by ring : - d ^ 2 * m = - (d ^ 2 * m))],
      exact neg_nonpos.mpr ((zero_le_mul_right h4).mpr (sq_nonneg d)) },
    have h2' : 0 ≤ b' ^ 2, { apply sq_nonneg b' },
    exact absurd (lt_of_le_of_ne h2' (ne.symm (pow_ne_zero _ h2b0))) (not_lt.mpr h2) },
  replace hd : r * s = d ^ 2, { apply or.resolve_right hd hd' },
  -- r = +/- j ^ 2
  obtain ⟨j, hj⟩ := int.sq_of_gcd_eq_one htt4 hd,
  have hj0 : j ≠ 0,
  { intro h0, rw [h0, zero_pow (dec_trivial : 0 < 2), neg_zero, or_self] at hj,
    apply left_ne_zero_of_mul hrsz hj },
  rw mul_comm at hd,
  rw [int.gcd_comm] at htt4,
  -- s = +/- k ^ 2
  obtain ⟨k, hk⟩ := int.sq_of_gcd_eq_one htt4 hd,
  have hk0 : k ≠ 0,
  { intro h0, rw [h0, zero_pow (dec_trivial : 0 < 2), neg_zero, or_self] at hk,
    apply right_ne_zero_of_mul hrsz hk },
  have hj2 : r ^ 2 = j ^ 4, { cases hj with hjp hjp; { rw hjp, ring } },
  have hk2 : s ^ 2 = k ^ 4, { cases hk with hkp hkp; { rw hkp, ring } },
  -- from m = r ^ 2 + s ^ 2 we now get a new solution to a ^ 4 + b ^ 4 = c ^ 2:
  have hh : i ^ 2 = j ^ 4 + k ^ 4, { rw [← hi, htt3, hj2, hk2] },
  have hn : n ≠ 0, { rw ht2 at hb20, apply right_ne_zero_of_mul hb20 },
  -- and it has a smaller c: from c = m ^ 2 + n ^ 2 we see that m is smaller than c, and i ^ 2 = m.
  have hic : int.nat_abs i < int.nat_abs c,
  { apply int.coe_nat_lt.mp, rw ← (int.eq_nat_abs_of_zero_le (le_of_lt hc)),
    apply gt_of_gt_of_ge _ (int.abs_le_self_sq i),
    rw [← hi, ht3],
    apply gt_of_gt_of_ge _ (int.le_self_sq m),
    exact lt_add_of_pos_right (m ^ 2) (sq_pos_of_ne_zero n hn) },
  have hic' : int.nat_abs c ≤ int.nat_abs i,
  { apply (h.2 j k i),
    exact ⟨hj0, hk0, hh.symm⟩ },
  apply absurd (not_le_of_lt hic) (not_not.mpr hic')
end

end fermat_42

lemma not_fermat_42 {a b c : ℤ} (ha : a ≠ 0) (hb : b ≠ 0) :
  a ^ 4 + b ^ 4 ≠ c ^ 2 :=
begin
  intro h,
  obtain ⟨a0, b0, c0, ⟨hf, h2, hp⟩⟩ :=
    fermat_42.exists_pos_odd_minimal (and.intro ha (and.intro hb h)),
  apply fermat_42.not_minimal hf h2 hp
end

theorem not_fermat_4 {a b c : ℤ} (ha : a ≠ 0) (hb : b ≠ 0) :
  a ^ 4 + b ^ 4 ≠ c ^ 4 :=
begin
  intro heq,
  apply @not_fermat_42 _ _ (c ^ 2) ha hb,
  rw heq, ring
end


/-
Copyright (c) 2020 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Anatole Dedecker

! This file was ported from Lean 3 source module topology.extend_from
! leanprover-community/mathlib commit b363547b3113d350d053abdf2884e9850a56b205
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Separation

/-!
# Extending a function from a subset

The main definition of this file is `extendFrom A f` where `f : X → Y`
and `A : Set X`. This defines a new function `g : X → Y` which maps any
`x₀ : X` to the limit of `f` as `x` tends to `x₀`, if such a limit exists.

This is analoguous to the way `DenseInducing.extend` "extends" a function
`f : X → Z` to a function `g : Y → Z` along a dense inducing `i : X → Y`.

The main theorem we prove about this definition is `continuousOn_extendFrom`
which states that, for `extendFrom A f` to be continuous on a set `B ⊆ closure A`,
it suffices that `f` converges within `A` at any point of `B`, provided that
`f` is a function to a T₃ space.

-/

noncomputable section

open Topology

open Filter Set

variable {X Y : Type _} [TopologicalSpace X] [TopologicalSpace Y]

/-- Extend a function from a set `A`. The resulting function `g` is such that
at any `x₀`, if `f` converges to some `y` as `x` tends to `x₀` within `A`,
then `g x₀` is defined to be one of these `y`. Else, `g x₀` could be anything. -/
def extendFrom (A : Set X) (f : X → Y) : X → Y :=
  fun x ↦ @limUnder _ _ _ ⟨f x⟩ (𝓝[A] x) f
#align extend_from extendFrom

/-- If `f` converges to some `y` as `x` tends to `x₀` within `A`,
then `f` tends to `extendFrom A f x` as `x` tends to `x₀`. -/
theorem tendsto_extendFrom {A : Set X} {f : X → Y} {x : X} (h : ∃ y, Tendsto f (𝓝[A] x) (𝓝 y)) :
    Tendsto f (𝓝[A] x) (𝓝 <| extendFrom A f x) :=
  tendsto_nhds_limUnder h
#align tendsto_extend_from tendsto_extendFrom

theorem extendFrom_eq [T2Space Y] {A : Set X} {f : X → Y} {x : X} {y : Y} (hx : x ∈ closure A)
    (hf : Tendsto f (𝓝[A] x) (𝓝 y)) : extendFrom A f x = y :=
  haveI := mem_closure_iff_nhdsWithin_neBot.mp hx
  tendsto_nhds_unique (tendsto_nhds_limUnder ⟨y, hf⟩) hf
#align extend_from_eq extendFrom_eq

theorem extendFrom_extends [T2Space Y] {f : X → Y} {A : Set X} (hf : ContinuousOn f A) :
    ∀ x ∈ A, extendFrom A f x = f x :=
  fun x x_in ↦ extendFrom_eq (subset_closure x_in) (hf x x_in)
#align extend_from_extends extendFrom_extends

/-- If `f` is a function to a T₃ space `Y` which has a limit within `A` at any
point of a set `B ⊆ closure A`, then `extendFrom A f` is continuous on `B`. -/
theorem continuousOn_extendFrom [RegularSpace Y] {f : X → Y} {A B : Set X} (hB : B ⊆ closure A)
    (hf : ∀ x ∈ B, ∃ y, Tendsto f (𝓝[A] x) (𝓝 y)) : ContinuousOn (extendFrom A f) B := by
  set φ := extendFrom A f
  intro x x_in
  suffices ∀ V' ∈ 𝓝 (φ x), IsClosed V' → φ ⁻¹' V' ∈ 𝓝[B] x by
    simpa [ContinuousWithinAt, (closed_nhds_basis (φ x)).tendsto_right_iff]
  intro V' V'_in V'_closed
  obtain ⟨V, V_in, V_op, hV⟩ : ∃ V ∈ 𝓝 x, IsOpen V ∧ V ∩ A ⊆ f ⁻¹' V' := by
    have := tendsto_extendFrom (hf x x_in)
    rcases (nhdsWithin_basis_open x A).tendsto_left_iff.mp this V' V'_in with ⟨V, ⟨hxV, V_op⟩, hV⟩
    exact ⟨V, IsOpen.mem_nhds V_op hxV, V_op, hV⟩
  suffices : ∀ y ∈ V ∩ B, φ y ∈ V'
  exact mem_of_superset (inter_mem_inf V_in <| mem_principal_self B) this
  rintro y ⟨hyV, hyB⟩
  haveI := mem_closure_iff_nhdsWithin_neBot.mp (hB hyB)
  have limy : Tendsto f (𝓝[A] y) (𝓝 <| φ y) := tendsto_extendFrom (hf y hyB)
  have hVy : V ∈ 𝓝 y := IsOpen.mem_nhds V_op hyV
  have : V ∩ A ∈ 𝓝[A] y := by simpa only [inter_comm] using inter_mem_nhdsWithin A hVy
  exact V'_closed.mem_of_tendsto limy (mem_of_superset this hV)
#align continuous_on_extend_from continuousOn_extendFrom

/-- If a function `f` to a T₃ space `Y` has a limit within a
dense set `A` for any `x`, then `extendFrom A f` is continuous. -/
theorem continuous_extendFrom [RegularSpace Y] {f : X → Y} {A : Set X} (hA : Dense A)
    (hf : ∀ x, ∃ y, Tendsto f (𝓝[A] x) (𝓝 y)) : Continuous (extendFrom A f) := by
  rw [continuous_iff_continuousOn_univ]
  exact continuousOn_extendFrom (fun x _ ↦ hA x) (by simpa using hf)
#align continuous_extend_from continuous_extendFrom


-- @file   jensen.lean
-- @author Brandon H. Gomes
-- @affil  Rutgers University

/-!
# Jensen's Inequality

In this file, we prove a famous and important inequality. The file is self-contained and
requires no other definitions other than those in the Lean core.

We first state the classical Jensen's Inequality:

- Theorem. Let `μ` be a positive measure on a σ-algebra `𝔐` in a set `Ω`, so that
  `μ(Ω) = 1`. If `f` is a real function in `L¹(μ)` such that `∀x ∈ Ω, f(x) ∈ (a,b)` and if
  `φ` is convex on `(a,b)`, then `φ (∫_Ω f dμ) ≤ ∫_Ω (φ ∘ f) dμ`. More succinctly,
  `φ (∫ f) ≤ ∫ (φ ∘ f)`.

The inequality follows from certain facts about integration, real numbers, convex
functions, ... etc. The theorem we prove is a strict generalization in which we state the
theorem in as high of an abstract form as possible with facts about subtraction and certain
kinds of relations. We will define a type-theoretic analogue of integration theory and of
the theory of convex functions. More details are discussed below.

We begin our discussion with power sets.
-/

--———————————————————————————————————————————————————————————————————————————————————————--
/--
`Power X` (`𝒫 X`) The powerset of a type.

Given a type `X : 𝒰i` we can consider the type of functions from `X` into a fixed type
universe `𝒰j`.

One can view this type of functions `𝒫 X` as the space of characteristic functions on `X`.
Classically, we can associate any subset `A ⊆ S` to an appropriate characteristic function
`χ_A : S → {0,1}` which takes value `1` on `A` and `0` elsewhere in `S`. This association
is a "bijective correspondence", that is, we can freely change our interpretation of the
subset `A` either as an actual subset or as a characteristic function. In the language of
types there is no natural notion of "subset" but there is a natural (but non-canonical
since it depends on the universe level `j`) notion of a characteristic function.

In general `𝒫 X` behaves like the classical power set of `X`, i.e. a complete lattice:
  - Bottom:                 `⊥ := λ x, 𝟘`
  - Top:                    `⊤ := λ x, 𝟙`
  - Union:                  `P ∪ Q := λ x, P x ∨ Q x`
  - Intersection:           `P ∩ Q := λ x, P x ∧ Q x`
  - Aribtrary Union:        `⋃ 𝓕 := λ x, Σ i, (𝓕 i) x`
  - Aribtrary Intersection: `⋂ 𝓕 := λ x, Π i, (𝓕 i) x`

where `𝟘` and `𝟙` are the empty type (the type with no terms) and unit type (the type with
one canonical term) respectively. The `⊥` element can be called the "empty set" and the
`⊤` element can be called the "total space" and can be associated to `X` itself.
Classically one can think of the union as the sum of characteristic functions `χ_P + χ_Q`
and the intersection as the product `χ_P * χ_Q`. There is a similar story for the
arbitrary union/intersection.

NB: To know that a term `x : X` is contained in the subset `A : 𝒫 X`, we need a witness of
the form `w : A x`, since `A` is a function and concatenation is function application.

We will be using the `Power` construction many times throughout since partial functions
play an important role in the `jensen_inequality` and also in the theory of integration in
general; partial functions only make sense if we have defined the notion of power set.
-/
definition Power (X : Type*)
    := X → Type*
notation `𝒫` X := Power X

/--
`const b` (`↓b`) The constant function at a point.

Given a type `X` and a pointed type `⟨Y, b⟩`, we can consider the constant function which
takes every point of `X` to the basepoint `b`.

Such functions are important for the `jensen_inequality`, and are also important in the
study of pointed spaces in general.
-/
definition const {X : Type*} {Y : Type*}
    := λ b:Y, (λ x:X, b)
notation `↓`:max y:max := const y

section difference_domain --—————————————————————————————————————————————————————————————--
variables (Y : Type*)

/--
`DifferenceDomain Y extends has_zero Y, has_sub Y` A good place to do subtraction.

A `DifferenceDomain` is a minimal structure that admits a version of subtraction like the
one we are familiar with from the theory of abelian groups. The main property that
distingushes subtraction is that image of the diagonal always vanishes. This property is
called `vanishing_diagonal` below.

There are other axioms which would make sense to add like the following two:
  - `zero_is_right_id  : Π y, y - 0 = y`
  - `sub_associativity : Π a b c, a - (b - c) = (a - b) - (0 - c)`

which makes the subtraction more like the inverse of some addition operation like
`a + b := a - (0 - b)`, but such details are not considered here. For the
`jensen_inequality`, we need only the `vanishing_diagonal` property.
-/
class DifferenceDomain extends has_zero Y, has_sub Y
    := (vanishing_diagonal : Π y, y - y = zero)

/--
`OrderedDifferenceDomain Y extends has_le Y, DifferenceDomain Y`

We will need an order structure on `Y` to state and prove the `jensen_inequality` so we
add it here. There are no asumptions on the behavior of `≤` like reflexivity/transitivity.
-/
class OrderedDifferenceDomain
    extends has_le Y, DifferenceDomain Y

end difference_domain --—————————————————————————————————————————————————————————————————--

section reduction --—————————————————————————————————————————————————————————————————————--
variables {Y : Type*} {X : Type*} (𝓕 : 𝒫 (X → Y))

/--
`Reduction` A generalized functional.

Given types `X` and `Y`, a `Reduction` is a partial function from the type of functions
`X → Y` to the type `Y`. The domain of this function is denoted `𝓕` throughout. One reads
the definition of reduction as "a type which takes a function `f : X → Y` and a proof that
`f` is contained in the family `𝓕` (`p : 𝓕 f`, see `Power` above) and sends this pair to
term of type `Y`".

Examples of reductions:
  - evaluation at a point (`x₀ : X`, `eval : (X → Y) → Y := λ f, f x₀`)
      (`𝓕` can be taken to be the total or "everywhere true" predicate)
  - integration (`∫_Ω (—) dμ : (X → Y) → Y`)
      (`𝓕` is the appropriate subset corresponding to the integrable functions on `Ω`)
  - limit of a sequence (`lim : (ℕ → R) → R`)
      (`𝓕` is the appropriate subset corresponding to the convergent sequences)

For the `jensen_inequality` we will be using something like the second example as we want
to imitate a weak kind of integration.

For a fixed reduction we call a function `f` *reducible* if it is contained in the family
corresponding to that reduction, i.e. `reducible f := 𝓕 f`. We say that a reduction
*admits (a reduction of) a function `f`* if `f` is reducible with respect to the family
corresponding to the given reduction.
-/
definition Reduction
    := Π f, 𝓕 f → Y

/--
`left_closed_at 𝓕 f g` Left closedness of `g` at `f`.

We say that a function `g : Y → Y` is *left closed at `f` with respect to `𝓕`* when the
reducibility of `f` implies the reducibility of the composition `g ∘ f` with respect to
the fixed family `𝓕`.
-/
definition left_closed_at (f : X → Y) (g : Y → Y)
    := 𝓕 f → 𝓕 (g ∘ f)

/--
`left_closed 𝓕 g` Left closedness of `g`.

We say that a function `g : Y → Y` is *left closed with respect to `𝓕`* when it is left
closed at every function `f : X → Y`.
-/
definition left_closed (g : Y → Y)
    := Π f, left_closed_at 𝓕 f g

/--
`PointFamily` Family of functions which contains all constant functions.

A reasonable reduction family might admit constant functions as a trivial case of some
more interesting property.
-/
class PointFamily
    := (has_constants : Π y, 𝓕 ↓y)

section subtraction --———————————————————————————————————————————————————————————————————--

/--
`pointwise_subtraction` Lifting codomain subtraction to pointwise subtraction.

If `Y` has a subtraction structure then for any type `X`, the function space `X → Y` has a
canonical pointwise subtraction. This `instance` is added to simplify the notation below.
-/
instance pointwise_subtraction [has_sub Y] : has_sub (X → Y)
    := ⟨λ f g, (λ x, f x - g x)⟩

/--
`DifferenceFamily` Family of functions closed under pointwise subtraction.
-/
class DifferenceFamily [has_sub Y]
    := (closure : Π f g (f𝓕 : 𝓕 f) (g𝓕 : 𝓕 g), 𝓕 (f - g))

--———————————————————————————————————————————————————————————————————————————————————————--
/--
We fix `Int : Reduction 𝓕` which will be written symbolically `∫` to conote something like
an integral. This reduction will be used below.
-/
variables (Int : Reduction 𝓕)

/--
`left_factors 𝓕 β lc_β` Left factorizability of `β`.

We say that a left closed function `β` *left factors with respect to `Int`* when for every
reducible `f` we have the identity `∫ (β ∘ f) = β (∫ f)`.
-/
definition left_factors (β : Y → Y) (lc_β : left_closed 𝓕 β)
    := Π f (f𝓕 : 𝓕 f), Int (β ∘ f) (lc_β f f𝓕) = β (Int f f𝓕)

--———————————————————————————————————————————————————————————————————————————————————————--
/-- For the rest of this section we assume `𝓕` is a `PointFamily`. -/
variables [PointFamily 𝓕]

/--
`UnitalReduction` A reduction which is friendly to constant functions.

We say that a reduction is unital if it admits all constant functions and that the
reduction of a constant function is the constant which defines it, i.e. `∫ ↓y = y`.
-/
class UnitalReduction
    := (constant_reduction : Π y, Int ↓y (PointFamily.has_constants 𝓕 y) = y)

--———————————————————————————————————————————————————————————————————————————————————————--
/-- For the rest of this section we assume `Y` has a `≤` structure. -/
variables [has_le Y]

/--
`pointwise_le` Lifting codomain order to pointwise order.

If `Y` has an order structure `≤` then for any type `X`, the function space `X → Y` has a
canonical pointwise order. This `instance` is added to simplify the notation below.
-/
instance pointwise_le : has_le (X → Y)
    := ⟨λ f g, (Π x, f x ≤ g x)⟩

/--
`MonotonicReduction Y` A reduction which is functorial over `≤`.

We can also make a reduction functorial over the order structure on the space of
functions `X → Y` (restricted to `𝓕`) by requiring that `Int` be a monotonic operator.
-/
class MonotonicReduction
    := (monotonicity : Π f g {f𝓕 g𝓕}, (f ≤ g) → (Int f f𝓕 ≤ Int g g𝓕))

--———————————————————————————————————————————————————————————————————————————————————————--
/--
For the rest of this section we assume `Y` has a zero element and subtraction structure
and that `𝓕` is a `DifferenceFamily`. We want to consider a reduction that interacts with
a subtraction structure on its codomain.
-/
variables [has_zero Y] [has_sub Y] [DifferenceFamily 𝓕]

/--
`constant_difference_property` A weak homomorphism property.

For a reduction compatible with subtraction, we would like to have that reductions are
homomorphisms of difference domains but this turns out to be too strong of a property. In
the case of classical integration we do not have in general the property
`∫ (g - f) = (∫ g) - (∫ f)` since both integrals on the right may take "value" at `±∞` so
the subtraction is not well defined. We instead use the weaker property that we can
commute with subtraction of a constant function, this will be enough for our purposes.
-/
definition constant_difference_property
    := Π f k {f𝓕},
        Int (f - ↓k) (DifferenceFamily.closure f ↓k f𝓕 (PointFamily.has_constants 𝓕 k))
      = Int f f𝓕 - Int ↓k (PointFamily.has_constants 𝓕 k)

/--
`translation_invariance_property` A weak translation property across inequalities.

For a reduction compatible with subtraction, we would like to capture the property from
the classical integral that the integral of a difference `g - f` is in the positive cone,
then `∫ f ≤ ∫ g`.
-/
definition translation_invariance_property
    := Π f g {f𝓕 g𝓕}, 0 ≤ Int (g - f) (DifferenceFamily.closure g f g𝓕 f𝓕)
                         → Int f f𝓕 ≤ Int g g𝓕

/--
`TranslativeReduction` A reduction which is compatible with subtraction.

We call a reduction a `TranslativeReduction` when it satisfies the
`constant_difference_property` and the `translation_invariance_property` defined above.
-/
class TranslativeReduction
    := (constant_difference    : constant_difference_property 𝓕 Int)
       (translation_invariance : translation_invariance_property 𝓕 Int)

end subtraction --———————————————————————————————————————————————————————————————————————--
end reduction --—————————————————————————————————————————————————————————————————————————--

section subdifferential --———————————————————————————————————————————————————————————————--
variables {Y : Type*} [has_zero Y] [has_sub Y] [has_le Y]
          (φ : Y → Y) (t : Y) (𝒩 : 𝒫 Y)

/--
`SubDifferential φ t 𝒩` The subdifferential property.

The primary role of convexity in the classical inequality is the following. Given a convex
function `φ` on `(a,b)` we know that for any `s,t,u ∈ (a,b)` such that `s < t < u`, it
follows that
    `(φ t - φ s) / (t - s) ≤ (φ u - φ t) / (u - t)`
From this we can deduce that there exists the supremum
    `β := sup_{s ∈ (a,t)} (φ t - φ s) / (t - s)`
which then gives us the following inequality:
    `β ⬝ (s - t) ≤ φ s - φ t`

To generalize this to a domain of discourse that does not have convex functions, we
instead accept the last inequality by hypothesis and generalize multiplication by `β` from
the left to function application. To ensure that this function application behaves well
with zero we need that it vanish there which is analogous to the fact that `y ⬝ 0 = 0` in
the real numbers.

Since the inequality above holds only in `(a,b)` in the classical case, not on all of `ℝ`,
we need to restrict the inequality to a specific subset of `Y`. We call this subset `𝒩`.
-/
structure SubDifferential
    := (map                  : Y → Y)
       (root_at_zero         : map 0 = 0)
       (lower_bound_property : Π s, 𝒩 s → map (s - t) ≤ (φ s) - (φ t))

--———————————————————————————————————————————————————————————————————————————————————————--
variables {X : Type*} (𝓕 : 𝒫 (X → Y)) (Int : Reduction 𝓕)

/--
`LeftFactorSubDifferential φ t 𝒩` A left factorizable subdifferential.

If we have `β` a subdifferential corresponding to `φ`, `t`, and `𝒩`, then we say that it
is a *left factor subdifferential* when `β` left factors with respect to the family `𝓕`.
-/
structure LeftFactorSubDifferential extends SubDifferential φ t 𝒩
    := (is_left_closed : left_closed 𝓕 map)
       (left_factors   : left_factors 𝓕 Int map is_left_closed)

end subdifferential --———————————————————————————————————————————————————————————————————--

section jensen_inequality --—————————————————————————————————————————————————————————————--
variables {Y : Type*} [OrderedDifferenceDomain Y]
          {X : Type*}
          (𝓕 : 𝒫 (X → Y)) [PointFamily 𝓕] [DifferenceFamily 𝓕]
          (Int : Reduction 𝓕)

/--
`JensenReduction` A reduction which is strong enough to prove Jensen's Inequality.

We have the following properties inherited from the individual structures:
  - `UnitalReduction`
      - `∫ ↓t = t`
  - `MonotonicReduction`
      - `(Π x, f x ≤ g x) → (∫ f ≤ ∫ g)`
  - `TranslativeReduction`
      - `∫ (f - ↓k) = (∫ f) - (∫ ↓k)`
      - `(0 ≤ ∫ (g - f)) → (∫ f ≤ ∫ g)`
-/
class JensenReduction
    extends UnitalReduction      𝓕 Int,
            MonotonicReduction   𝓕 Int,
            TranslativeReduction 𝓕 Int

/--
`jensen_inequality` Jensen's Inequality (`φ (∫ f) ≤ ∫ (φ ∘ f)`).

The theorem exactly generalizes the classical Jensen inequality and so it is sufficient to
prove that the measure-theoretic integral is a `JensenReduction` and that convex functions
have the `LeftFactorSubDifferential` property to apply the following proof to the
classical case. Proof sketches for these two facts are discussed above.

NB: In this proof, we will be working to find a term which has the type of the goal
    instead of modifying the goal directly, so it is not necessary to look at the goals.
    Instead, follow the proof by reading the commentary which describes the change in the
    main term `inequality` which will satisfy the goal in the end. For simplicity the
    reducibility proofs are left unspecified while following the main term.
-/
theorem jensen_inequality
    -- Proof that Int is a nice reduction.
    [JensenReduction 𝓕 Int]

    -- A reducible function f.
    (f : X → Y) (f𝓕 : 𝓕 f)

    -- A distinguished superset of the image of f.
    (𝒩 : 𝒫 Y) (image_contained_in_𝒩 : Π x, 𝒩 (f x))

    -- A function φ which is left closed at f and has a LeftFactorSubDifferential at the
    -- reduction of f with the above distinguished superset 𝒩.
    (φ : Y → Y) (φf𝓕 : 𝓕 (φ ∘ f))
    (subdifferential : LeftFactorSubDifferential φ (Int f f𝓕) 𝒩 𝓕 Int)

    -- From above, the Jensen Inequality follows:
    : φ (Int f f𝓕) ≤ Int (φ ∘ f) φf𝓕

:= begin -- We begin by introducing some relevant variables:

    -- The reduction of f.
    let t := Int f f𝓕,

    -- The function F := λ x, f x - t and its proof of reducibility.
    let F := f - ↓t,
    let F𝓕 := DifferenceFamily.closure f ↓t _ _,

    -- The subderivative of φ.
    let β := subdifferential.map,

    /-
    Π s, 𝒩 s → β (s - t) ≤ (φ s) - (φ t)
    —————————————————————————————————————— image_contained_in_𝒩
       Π x, β (F x) ≤ (φ (f x)) - (φ t)

    To begin the proof, we use the fact that the subdifferential has the lower bound
    property inside of 𝒩 which contains the image of f, so we have that the inequality
    holds for all points of X. This is the main term to follow throughout the proof.
    -/
    let inequality
        := λ x, subdifferential.lower_bound_property (f x) (image_contained_in_𝒩 x),

    /-
    Π x, β (F x) ≤ (φ (f x)) - (φ t)
    ————————————————————————————————— monotonicity
      ∫ β ∘ F ≤ ∫ (φ ∘ f - ↓(φ t))

    Next, we use the fact that the reduction is monotonic to "integrate" both sides.
    -/
    let inequality
        := MonotonicReduction.monotonicity Int (β ∘ F) (φ ∘ f - ↓(φ t)) inequality,

    /-
    ∫ β ∘ F ≤ ∫ (φ ∘ f - ↓(φ t))
    ————————————————————————————— left_factors
    β (∫ F) ≤ ∫ (φ ∘ f - ↓(φ t))

    Here we use the fact that the subdifferential left factors with respect to the
    reduction family.
    -/
    rewrite subdifferential.left_factors F F𝓕 at inequality,

    /-
         β (∫ F) ≤ ∫ (φ ∘ f - ↓(φ t))
    ———————————————————————————————————————— constant_difference
    β ((∫ f) - (∫ ↓t)) ≤ ∫ (φ ∘ f - ↓(φ t))

    Now we use the fact that our reduction has the constant difference property to
    distribute the reduction over the difference of functions.
    -/
    rewrite TranslativeReduction.constant_difference Int at inequality,

    /-
    β ((∫ f) - (∫ ↓t)) ≤ ∫ (φ ∘ f - ↓(φ t))
    ———————————————————————————————————————— constant_reduction
      β ((∫ f) - t) ≤ ∫ (φ ∘ f - ↓(φ t))

    Since our reduction is unital we can replace the reduction of the constant function
    with the defining constant.
    -/
    rewrite UnitalReduction.constant_reduction Int at inequality,

    /-
    β ((∫ f) - t) ≤ ∫ (φ ∘ f - ↓(φ t))
    ——————————————————————————————————— vanishing_diagonal
        β 0 ≤ ∫ (φ ∘ f - ↓(φ t))

    Since
        t := ∫ f
    we have that,
        (∫ f) - t := (∫ f) - (∫ f)
    so we can cancel like terms using the fact that Y is a difference domain.
    -/
    rewrite DifferenceDomain.vanishing_diagonal at inequality,

    /-
    β 0 ≤ ∫ (φ ∘ f - ↓(φ t))
    ————————————————————————— root_at_zero
     0 ≤ ∫ (φ ∘ f - ↓(φ t))

    To simplify the left hand side of the inequality we use the fact that the
    subderivative has a root at zero.
    -/
    rewrite subdifferential.root_at_zero at inequality,

    /-
    0 ≤ ∫ (φ ∘ f - ↓(φ t))
    ——————————————————————— translation_invariance
     ∫ ↓(φ t) ≤ ∫ (φ ∘ f)

    To split the reduction of a difference, we use the translation invariance property
    because our reduction is translative.
    -/
    let inequality
        := TranslativeReduction.translation_invariance Int ↓(φ t) (φ ∘ f) inequality,

    /-
    ∫ ↓(φ t) ≤ ∫ (φ ∘ f)
    ————————————————————— constant_reduction
      φ t ≤ ∫ (φ ∘ f)

    Again we use the fact that out reduction is unital to pull out the constant on the
    left hand side.
    -/
    rewrite UnitalReduction.constant_reduction Int at inequality,

    /-
      φ t ≤ ∫ (φ ∘ f)
    ———————————————————— definition
    φ (∫ f) ≤ ∫ (φ ∘ f)

    And now the proof is complete. The inequality has the correct type to satisfy the main
    goal. All other goals can be deduced canonically by the proof assistant since the
    relevant proof terms are in the given context.
    -/
    exact inequality,
end --                                                                                □
end jensen_inequality --—————————————————————————————————————————————————————————————————--


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin
-/
import algebra.category.Module.monoidal
import category_theory.monoidal.functorial
import category_theory.monoidal.types
import linear_algebra.direct_sum.finsupp
import category_theory.linear.linear_functor

/-!
The functor of forming finitely supported functions on a type with values in a `[ring R]`
is the left adjoint of
the forgetful functor from `R`-modules to types.
-/

noncomputable theory

open category_theory

namespace Module

universe u

open_locale classical

variables (R : Type u)

section
variables [ring R]

/--
The free functor `Type u ⥤ Module R` sending a type `X` to the
free `R`-module with generators `x : X`, implemented as the type `X →₀ R`.
-/
@[simps]
def free : Type u ⥤ Module R :=
{ obj := λ X, Module.of R (X →₀ R),
  map := λ X Y f, finsupp.lmap_domain _ _ f,
  map_id' := by { intros, exact finsupp.lmap_domain_id _ _ },
  map_comp' := by { intros, exact finsupp.lmap_domain_comp _ _ _ _, } }

/--
The free-forgetful adjunction for R-modules.
-/
def adj : free R ⊣ forget (Module.{u} R) :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X M, (finsupp.lift M R X).to_equiv.symm,
  hom_equiv_naturality_left_symm' := λ _ _ M f g,
  finsupp.lhom_ext' (λ x, linear_map.ext_ring
    (finsupp.sum_map_domain_index_add_monoid_hom (λ y, ((smul_add_hom R M).flip) (g y))).symm) }

instance : is_right_adjoint (forget (Module.{u} R)) := ⟨_, adj R⟩

end

namespace free
variables [comm_ring R]
local attribute [ext] tensor_product.ext

/-- (Implementation detail) The unitor for `free R`. -/
def ε : 𝟙_ (Module.{u} R) ⟶ (free R).obj (𝟙_ (Type u)) :=
finsupp.lsingle punit.star

@[simp] lemma ε_apply (r : R) : ε R r = finsupp.single punit.star r := rfl

/-- (Implementation detail) The tensorator for `free R`. -/
def μ (α β : Type u) : (free R).obj α ⊗ (free R).obj β ≅ (free R).obj (α ⊗ β) :=
(finsupp_tensor_finsupp' R α β).to_Module_iso

lemma μ_natural {X Y X' Y' : Type u} (f : X ⟶ Y) (g : X' ⟶ Y') :
  ((free R).map f ⊗ (free R).map g) ≫ (μ R Y Y').hom =
    (μ R X X').hom ≫ (free R).map (f ⊗ g) :=
begin
  intros,
  ext x x' ⟨y, y'⟩,
  dsimp [μ],
  simp_rw [finsupp.map_domain_single, finsupp_tensor_finsupp'_single_tmul_single, mul_one,
    finsupp.map_domain_single, category_theory.tensor_apply],
end

lemma left_unitality (X : Type u) :
  (λ_ ((free R).obj X)).hom =
  (ε R ⊗ 𝟙 ((free R).obj X)) ≫ (μ R (𝟙_ (Type u)) X).hom ≫ map (free R).obj (λ_ X).hom :=
begin
  intros,
  ext,
  dsimp [ε, μ],
  simp_rw [finsupp_tensor_finsupp'_single_tmul_single,
    Module.monoidal_category.left_unitor_hom_apply, finsupp.smul_single', mul_one,
    finsupp.map_domain_single, category_theory.left_unitor_hom_apply],
end

lemma right_unitality (X : Type u) :
  (ρ_ ((free R).obj X)).hom =
  (𝟙 ((free R).obj X) ⊗ ε R) ≫ (μ R X (𝟙_ (Type u))).hom ≫ map (free R).obj (ρ_ X).hom :=
begin
  intros,
  ext,
  dsimp [ε, μ],
  simp_rw [finsupp_tensor_finsupp'_single_tmul_single,
    Module.monoidal_category.right_unitor_hom_apply, finsupp.smul_single', mul_one,
    finsupp.map_domain_single, category_theory.right_unitor_hom_apply],
end

lemma associativity (X Y Z : Type u) :
  ((μ R X Y).hom ⊗ 𝟙 ((free R).obj Z)) ≫ (μ R (X ⊗ Y) Z).hom ≫ map (free R).obj (α_ X Y Z).hom =
  (α_ ((free R).obj X) ((free R).obj Y) ((free R).obj Z)).hom ≫
    (𝟙 ((free R).obj X) ⊗ (μ R Y Z).hom) ≫ (μ R X (Y ⊗ Z)).hom :=
begin
  intros,
  ext,
  dsimp [μ],
  simp_rw [finsupp_tensor_finsupp'_single_tmul_single, finsupp.map_domain_single, mul_one,
    category_theory.associator_hom_apply],
end

/-- The free R-module functor is lax monoidal. -/
-- In fact, it's strong monoidal, but we don't yet have a typeclass for that.
@[simps]
instance : lax_monoidal.{u} (free R).obj :=
{ -- Send `R` to `punit →₀ R`
  ε := ε R,
  -- Send `(α →₀ R) ⊗ (β →₀ R)` to `α × β →₀ R`
  μ := λ X Y, (μ R X Y).hom,
  μ_natural' := λ X Y X' Y' f g, μ_natural R f g,
  left_unitality' := left_unitality R,
  right_unitality' := right_unitality R,
  associativity' := associativity R, }

instance : is_iso (lax_monoidal.ε (free R).obj) :=
⟨⟨finsupp.lapply punit.star, ⟨by { ext, simp, }, by { ext ⟨⟩ ⟨⟩, simp, }⟩⟩⟩

end free

variables [comm_ring R]

/-- The free functor `Type u ⥤ Module R`, as a monoidal functor. -/
def monoidal_free : monoidal_functor (Type u) (Module.{u} R) :=
{ ε_is_iso := by { dsimp, apply_instance, },
  μ_is_iso := λ X Y, by { dsimp, apply_instance, },
  ..lax_monoidal_functor.of (free R).obj }

example (X Y : Type u) : (free R).obj (X × Y) ≅ (free R).obj X ⊗ (free R).obj Y :=
((monoidal_free R).μ_iso X Y).symm

end Module

namespace category_theory

universes v u

/--
`Free R C` is a type synonym for `C`, which, given `[comm_ring R]` and `[category C]`,
we will equip with a category structure where the morphisms are formal `R`-linear combinations
of the morphisms in `C`.
-/
@[nolint unused_arguments has_inhabited_instance]
def Free (R : Type*) (C : Type u) := C

/--
Consider an object of `C` as an object of the `R`-linear completion.

It may be preferable to use `(Free.embedding R C).obj X` instead;
this functor can also be used to lift morphisms.
-/
def Free.of (R : Type*) {C : Type u} (X : C) : Free R C := X

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

open finsupp

-- Conceptually, it would be nice to construct this via "transport of enrichment",
-- using the fact that `Module.free R : Type ⥤ Module R` and `Module.forget` are both lax monoidal.
-- This still seems difficult, so we just do it by hand.
instance category_Free : category (Free R C) :=
{ hom := λ (X Y : C), (X ⟶ Y) →₀ R,
  id := λ (X : C), finsupp.single (𝟙 X) 1,
  comp := λ (X Y Z : C) f g, f.sum (λ f' s, g.sum (λ g' t, finsupp.single (f' ≫ g') (s * t))),
  assoc' := λ W X Y Z f g h,
  begin
    dsimp,
    -- This imitates the proof of associativity for `monoid_algebra`.
    simp only [sum_sum_index, sum_single_index,
      single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff,
      add_mul, mul_add, category.assoc, mul_assoc, zero_mul, mul_zero, sum_zero, sum_add],
  end }.

namespace Free

section
local attribute [reducible] category_theory.category_Free

instance : preadditive (Free R C) :=
{ hom_group := λ X Y, finsupp.add_comm_group,
  add_comp' := λ X Y Z f f' g, begin
    dsimp,
    rw [finsupp.sum_add_index];
    { simp [add_mul], }
  end,
  comp_add' := λ X Y Z f g g', begin
    dsimp,
    rw ← finsupp.sum_add,
    congr, ext r h,
    rw [finsupp.sum_add_index];
    { simp [mul_add], },
  end, }

instance : linear R (Free R C) :=
{ hom_module := λ X Y, finsupp.module (X ⟶ Y) R,
  smul_comp' := λ X Y Z r f g, begin
    dsimp,
    rw [finsupp.sum_smul_index];
    simp [finsupp.smul_sum, mul_assoc],
  end,
  comp_smul' := λ X Y Z f r g, begin
    dsimp,
    simp_rw [finsupp.smul_sum],
    congr, ext h s,
    rw [finsupp.sum_smul_index];
    simp [finsupp.smul_sum, mul_left_comm],
  end, }

lemma single_comp_single {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (r s : R) :
  (single f r ≫ single g s : (Free.of R X) ⟶ (Free.of R Z)) = single (f ≫ g) (r * s) :=
by { dsimp, simp, }

end

local attribute [simp] single_comp_single

/--
A category embeds into its `R`-linear completion.
-/
@[simps]
def embedding : C ⥤ Free R C :=
{ obj := λ X, X,
  map := λ X Y f, finsupp.single f 1,
  map_id' := λ X, rfl,
  map_comp' := λ X Y Z f g, by simp, }

variables (R) {C} {D : Type u} [category.{v} D] [preadditive D] [linear R D]

open preadditive linear

/--
A functor to an `R`-linear category lifts to a functor from its `R`-linear completion.
-/
@[simps]
def lift (F : C ⥤ D) : Free R C ⥤ D :=
{ obj := λ X, F.obj X,
  map := λ X Y f, f.sum (λ f' r, r • (F.map f')),
  map_id' := by { dsimp [category_theory.category_Free], simp },
  map_comp' := λ X Y Z f g, begin
    apply finsupp.induction_linear f,
    { simp, },
    { intros f₁ f₂ w₁ w₂,
      rw add_comp,
      rw [finsupp.sum_add_index, finsupp.sum_add_index],
      { simp [w₁, w₂, add_comp], },
      { simp, },
      { intros, simp only [add_smul], },
      { simp, },
      { intros, simp only [add_smul], }, },
    { intros f' r,
      apply finsupp.induction_linear g,
      { simp, },
      { intros f₁ f₂ w₁ w₂,
        rw comp_add,
        rw [finsupp.sum_add_index, finsupp.sum_add_index],
        { simp [w₁, w₂, add_comp], },
        { simp, },
        { intros, simp only [add_smul], },
        { simp, },
        { intros, simp only [add_smul], }, },
      { intros g' s,
        erw single_comp_single,
        simp [mul_comm r s, mul_smul], } }
  end, }

@[simp]
lemma lift_map_single (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) (r : R) :
  (lift R F).map (single f r) = r • F.map f :=
by simp

instance lift_additive (F : C ⥤ D) : (lift R F).additive :=
{ map_add' := λ X Y f g, begin
    dsimp,
    rw finsupp.sum_add_index; simp [add_smul]
  end, }

instance lift_linear (F : C ⥤ D) : (lift R F).linear R :=
{ map_smul' := λ X Y f r, begin
    dsimp,
    rw finsupp.sum_smul_index;
    simp [finsupp.smul_sum, mul_smul],
  end, }

/--
The embedding into the `R`-linear completion, followed by the lift,
is isomorphic to the original functor.
-/
def embedding_lift_iso (F : C ⥤ D) : embedding R C ⋙ lift R F ≅ F :=
nat_iso.of_components
  (λ X, iso.refl _)
  (by tidy)

/--
Two `R`-linear functors out of the `R`-linear completion are isomorphic iff their
compositions with the embedding functor are isomorphic.
-/
@[ext]
def ext {F G : Free R C ⥤ D} [F.additive] [F.linear R] [G.additive] [G.linear R]
  (α : embedding R C ⋙ F ≅ embedding R C ⋙ G) : F ≅ G :=
nat_iso.of_components
  (λ X, α.app X)
  begin
    intros X Y f,
    apply finsupp.induction_linear f,
    { simp, },
    { intros f₁ f₂ w₁ w₂,
      simp only [F.map_add, G.map_add, add_comp, comp_add, w₁, w₂], },
    { intros f' r,
      rw [iso.app_hom, iso.app_hom, ←smul_single_one, F.map_smul, G.map_smul, smul_comp, comp_smul],
      change r • (embedding R C ⋙ F).map f' ≫ _ = r • _ ≫ (embedding R C ⋙ G).map f',
      rw α.hom.naturality f',
      apply_instance, -- Why are these not picked up automatically when we rewrite?
      apply_instance, }
  end

/--
`Free.lift` is unique amongst `R`-linear functors `Free R C ⥤ D`
which compose with `embedding ℤ C` to give the original functor.
-/
def lift_unique (F : C ⥤ D) (L : Free R C ⥤ D) [L.additive] [L.linear R]
  (α : embedding R C ⋙ L ≅ F) :
  L ≅ lift R F :=
ext R (α.trans (embedding_lift_iso R F).symm)

end Free

end category_theory


import generalTactics deduction.deduction category_theory.category.preorder
open deduction_basic

namespace synPoset

  variable {Form : Type}

  instance syn_preorder [Der : has_struct_derives Form] : preorder Form :=
  { le := λ φ ψ, φ ⊢ ψ,
    le_refl := derive_refl,
    le_trans := @derive_trans Form Der.to_has_derives,
  }

  def inter_der [Der : has_struct_derives Form] : Form → Form → Prop :=
    λ φ ψ,  φ ⊢ ψ ∧ ψ ⊢ φ

  infix `⊣⊢`:78 := inter_der

  instance syn_setoid [Der : has_struct_derives Form] : setoid Form :=
  { r := (⊣⊢),
    iseqv := ⟨ begin
                assume φ, constructor,
                apply derive_refl, apply derive_refl,
              end,
              begin
                assume φ ψ h, cases h with φψ ψφ,
                constructor, exact ψφ, exact φψ,
              end,
              begin
                assume φ ψ θ j k, cases j with φψ ψφ,
                cases k with ψθ θψ, constructor,
                apply derive_trans, exact φψ, exact ψθ,
                apply derive_trans, exact θψ, exact ψφ,
              end
              ⟩
  }

  -- notation (name:=syn_setoid.r) φ `⊣⊢` ψ :78 := syn_setoid.r φ ψ

  def Form_eq [Der : has_struct_derives Form] : Type := @quot Form (⊣⊢)
  def Form_eq_x (F : Type) [Der : has_struct_derives F] : Type := @Form_eq F Der

  notation (name:=Form_eq_explicit) F ` _eq`:max := Form_eq_x F

  def Form_eq_in [Der : has_struct_derives Form] : Form → Form _eq := quot.mk (⊣⊢)

  notation (name:=PPC_eq_in) ⦃φ⦄ := Form_eq_in φ

  -- Lemmas that ⊢ respects ⊣⊢
  lemma syn_preorder_liftable1 [Der : has_struct_derives Form] :
    ∀ φ ψ θ : Form, ψ ⊣⊢ θ → (φ ⊢ ψ) = (φ ⊢ θ) :=
  begin
    assume φ ψ θ ψiffθ,
    cases ψiffθ with ψθ θψ,
    apply propext,
    constructor,
    assume φψ, apply derive_trans, exact φψ, exact ψθ,
    assume φθ, apply derive_trans, exact φθ, exact θψ,
  end
  lemma syn_preorder_liftable2 [Der : has_struct_derives Form] :
    ∀ φ ψ θ : Form, φ ⊣⊢ ψ → (φ ⊢ θ) = (ψ ⊢ θ) :=
  begin
    assume φ ψ θ φiffψ,
    cases φiffψ with φψ ψφ,
    apply propext,
    constructor,
    assume φθ, apply derive_trans, exact ψφ, exact φθ,
    assume ψθ, apply derive_trans, exact φψ, exact ψθ,
  end

  def Form_eq_order [Der : has_struct_derives Form] : @Form_eq Form Der → @Form_eq Form Der → Prop
    := quot.lift₂ synPoset.syn_preorder.le syn_preorder_liftable1 syn_preorder_liftable2

  instance syn_poset [Der : has_struct_derives Form] : partial_order Form_eq :=
  { le := @Form_eq_order Form Der,
    le_refl :=
      begin
        repeat_assume_induct [`φ],
        dsimp[(≤),setoid.r,Form_eq_order],
        apply derive_refl,refl,
      end,
    le_trans :=
      begin
        repeat_assume_then_induct `[ assume h j ] [`φ,`ψ,`θ],
        dsimp[(≤),setoid.r,Form_eq_order],
        dsimp[(≤)] at h, dsimp[(≤)] at j,
        apply derive_trans,
        exact h, exact j,
        refl, refl, refl,
      end,
    le_antisymm :=
      begin
        repeat_assume_then_induct `[ assume h j ] [`φ,`ψ],
        apply quotient.sound,
        dsimp[(≈),setoid.r],dsimp[(≤)] at h, dsimp[(≤)] at j,
        constructor, exact h, exact j, refl, refl,
      end
  }

  instance syn_eq_pre {Form : Type} [Der : has_struct_derives Form] : preorder (Form _eq) :=
    @partial_order.to_preorder (Form _eq) synPoset.syn_poset

end synPoset


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import topology.bornology.basic

/-!
# Bornology structure on products and subtypes

In this file we define `bornology` and `bounded_space` instances on `α × β`, `Π i, π i`, and
`{x // p x}`. We also prove basic lemmas about `bornology.cobounded` and `bornology.is_bounded`
on these types.
-/

open set filter bornology function
open_locale filter

variables {α β ι : Type*} {π : ι → Type*} [fintype ι] [bornology α] [bornology β]
  [Π i, bornology (π i)]

instance : bornology (α × β) :=
{ cobounded := (cobounded α).coprod (cobounded β),
  le_cofinite := @coprod_cofinite α β ▸ coprod_mono ‹bornology α›.le_cofinite
    ‹bornology β›.le_cofinite }

instance : bornology (Π i, π i) :=
{ cobounded := filter.Coprod (λ i, cobounded (π i)),
  le_cofinite := @Coprod_cofinite ι π _ ▸ (filter.Coprod_mono $ λ i, bornology.le_cofinite _) }

/-- Inverse image of a bornology. -/
@[reducible] def bornology.induced {α β : Type*} [bornology β] (f : α → β) : bornology α :=
{ cobounded := comap f (cobounded β),
  le_cofinite := (comap_mono (bornology.le_cofinite β)).trans (comap_cofinite_le _) }

instance {p : α → Prop} : bornology (subtype p) := bornology.induced (coe : subtype p → α)

namespace bornology

/-!
### Bounded sets in `α × β`
-/

lemma cobounded_prod : cobounded (α × β) = (cobounded α).coprod (cobounded β) := rfl

lemma is_bounded_image_fst_and_snd {s : set (α × β)} :
  is_bounded (prod.fst '' s) ∧ is_bounded (prod.snd '' s) ↔ is_bounded s :=
compl_mem_coprod.symm

variables {s : set α} {t : set β} {S : Π i, set (π i)}

lemma is_bounded.fst_of_prod (h : is_bounded (s ×ˢ t)) (ht : t.nonempty) :
  is_bounded s :=
fst_image_prod s ht ▸ (is_bounded_image_fst_and_snd.2 h).1

lemma is_bounded.snd_of_prod (h : is_bounded (s ×ˢ t)) (hs : s.nonempty) :
  is_bounded t :=
snd_image_prod hs t ▸ (is_bounded_image_fst_and_snd.2 h).2

lemma is_bounded.prod (hs : is_bounded s) (ht : is_bounded t) : is_bounded (s ×ˢ t) :=
is_bounded_image_fst_and_snd.1
  ⟨hs.subset $ fst_image_prod_subset _ _, ht.subset $ snd_image_prod_subset _ _⟩

lemma is_bounded_prod_of_nonempty (hne : set.nonempty (s ×ˢ t)) :
  is_bounded (s ×ˢ t) ↔ is_bounded s ∧ is_bounded t :=
⟨λ h, ⟨h.fst_of_prod hne.snd, h.snd_of_prod hne.fst⟩, λ h, h.1.prod h.2⟩

lemma is_bounded_prod : is_bounded (s ×ˢ t) ↔ s = ∅ ∨ t = ∅ ∨ is_bounded s ∧ is_bounded t :=
begin
  rcases s.eq_empty_or_nonempty with rfl|hs, { simp },
  rcases t.eq_empty_or_nonempty with rfl|ht, { simp },
  simp only [hs.ne_empty, ht.ne_empty, is_bounded_prod_of_nonempty (hs.prod ht), false_or]
end

lemma is_bounded_prod_self : is_bounded (s ×ˢ s) ↔ is_bounded s :=
begin
  rcases s.eq_empty_or_nonempty with rfl|hs, { simp },
  exact (is_bounded_prod_of_nonempty (hs.prod hs)).trans (and_self _)
end

/-!
### Bounded sets in `Π i, π i`
-/

lemma cobounded_pi : cobounded (Π i, π i) = filter.Coprod (λ i, cobounded (π i)) := rfl

lemma forall_is_bounded_image_eval_iff {s : set (Π i, π i)} :
  (∀ i, is_bounded (eval i '' s)) ↔ is_bounded s :=
compl_mem_Coprod.symm

lemma is_bounded.pi (h : ∀ i, is_bounded (S i)) : is_bounded (pi univ S) :=
forall_is_bounded_image_eval_iff.1 $ λ i, (h i).subset eval_image_univ_pi_subset

lemma is_bounded_pi_of_nonempty (hne : (pi univ S).nonempty) :
  is_bounded (pi univ S) ↔ ∀ i, is_bounded (S i) :=
⟨λ H i, @eval_image_univ_pi _ _ _ i hne ▸ forall_is_bounded_image_eval_iff.2 H i, is_bounded.pi⟩

lemma is_bounded_pi : is_bounded (pi univ S) ↔ (∃ i, S i = ∅) ∨ ∀ i, is_bounded (S i) :=
begin
  by_cases hne : ∃ i, S i = ∅,
  { simp [hne, univ_pi_eq_empty_iff.2 hne] },
  { simp only [hne, false_or],
    simp only [not_exists, ← ne.def, ne_empty_iff_nonempty, ← univ_pi_nonempty_iff] at hne,
    exact is_bounded_pi_of_nonempty hne }
end

/-!
### Bounded sets in `{x // p x}`
-/

lemma is_bounded_induced {α β : Type*} [bornology β] {f : α → β} {s : set α} :
  @is_bounded α (bornology.induced f) s ↔ is_bounded (f '' s) :=
compl_mem_comap

lemma is_bounded_image_subtype_coe {p : α → Prop} {s : set {x // p x}} :
  is_bounded (coe '' s : set α) ↔ is_bounded s :=
is_bounded_induced.symm

end bornology

/-!
### Bounded spaces
-/

open bornology

instance [bounded_space α] [bounded_space β] : bounded_space (α × β) :=
by simp [← cobounded_eq_bot_iff, cobounded_prod]

instance [∀ i, bounded_space (π i)] : bounded_space (Π i, π i) :=
by simp [← cobounded_eq_bot_iff, cobounded_pi]

lemma bounded_space_induced_iff {α β : Type*} [bornology β] {f : α → β} :
  @bounded_space α (bornology.induced f) ↔ is_bounded (range f) :=
by rw [← is_bounded_univ, is_bounded_induced, image_univ]

lemma bounded_space_subtype_iff {p : α → Prop} : bounded_space (subtype p) ↔ is_bounded {x | p x} :=
by rw [bounded_space_induced_iff, subtype.range_coe_subtype]

lemma bounded_space_coe_set_iff {s : set α} : bounded_space s ↔ is_bounded s :=
bounded_space_subtype_iff

alias bounded_space_subtype_iff ↔ _ bornology.is_bounded.bounded_space_subtype
alias bounded_space_coe_set_iff ↔ _ bornology.is_bounded.bounded_space_coe

instance [bounded_space α] {p : α → Prop} : bounded_space (subtype p) :=
(is_bounded.all {x | p x}).bounded_space_subtype


/-
  If (fᵢ) = R, the sequene R → Π R[1/fᵢ] → Π R[1/fᵢfⱼ] is exact.

  https://stacks.math.columbia.edu/tag/00EJ

  TODO : Factor out all the finset sum lemmas and clean up the main proof.
-/

import ring_theory.localization
import algebra.pi_instances
import linear_algebra.finsupp
import to_mathlib.localization.localization_alt
import to_mathlib.finset_range
import to_mathlib.ring_hom
import spectrum_of_a_ring.structure_presheaf_res

universes u v w

local attribute [instance] classical.prop_decidable

open localization_alt
open finset

lemma finset.sum_of_mem_span
{α : Type u} {β : Type v} [comm_ring α] [add_comm_group β] [module α β]
{S : finset β} {x : β}
: x ∈ submodule.span α S.to_set →
  ∃ r : β → α, x = finset.sum S (λ y, r y • y) :=
begin
  intros Hx,
  have Hfs := (@finsupp.mem_span_iff_total β _ α _ _ _ id S.to_set x).1,
  simp at Hfs,
  replace Hx := Hfs Hx,
  rcases Hx with ⟨l, Hls, Hlt⟩,
  rw finsupp.total_apply at Hlt,
  rw finsupp.mem_supported at Hls,
  rw ←Hlt,
  simp [finsupp.sum],
  use (λ x, if x ∈ S then l.to_fun x else 0),
  apply finset.sum_bij_ne_zero (λ x _ _, x),
  { intros a H₁ H₂,
    exact Hls H₁, },
  { intros a₁ a₂ H₁₁ H₁₂ H₂₁ H₂₂ H,
    exact H, },
  { intros b HbS Hb,
    use b,
    erw (if_pos HbS) at Hb,
    have Hlbnz : l.to_fun b ≠ 0,
      intros HC,
      rw HC at Hb,
      rw zero_smul at Hb,
      exact (Hb rfl),
    use [(finsupp.mem_support_iff.2 Hlbnz), Hb], },
  { intros a H₁ H₂,
    have HaS : a ∈ S := Hls H₁,
    rw (if_pos HaS),
    refl, },
end

lemma finset.image_sum_of_mem_span
{α : Type u} {β : Type v} [comm_ring α] [comm_ring β] [module α β]
{γ : Type w} {S : finset γ} {f : γ → β} {x : β}
: x ∈ submodule.span α (finset.image f S).to_set →
  ∃ r : γ → α, x = finset.sum S (λ b, r b • f b) :=
begin
  intros Hx,
  rcases (finset.sum_of_mem_span Hx) with ⟨r, Hr⟩,
  have Hz : ∀ y ∈ S, ∃ z ∈ S, f z = f y := λ y hy, ⟨y, hy, rfl⟩,
  use (λ y, if ∃ Hy : y ∈ S, y = classical.some (Hz y Hy) then r (f y) else 0),
  rw Hr,
  apply finset.sum_bij_ne_zero (λ a Ha _, classical.some (finset.mem_image.1 Ha)),
  { intros a H₁ H₂,
    rcases (classical.some_spec (finset.mem_image.1 H₁)) with ⟨Ha, Hf⟩,
    exact Ha, },
  { intros a₁ a₂ H₁₁ H₁₂ H₂₁ H₂₂ H,
    rcases (classical.some_spec (finset.mem_image.1 H₁₁)) with ⟨Ha₁, Hf₁⟩,
    rcases (classical.some_spec (finset.mem_image.1 H₂₁)) with ⟨Ha₂, Hf₂⟩,
    rw [←Hf₁, ←Hf₂],
    congr,
    exact H, },
  { intros b HbS Hb,
    have Hfb : f b ∈ finset.image f S := finset.mem_image.2 ⟨b, HbS, rfl⟩,
    have Hbeq : b = classical.some (finset.mem_image.1 Hfb),
      apply classical.by_contradiction,
      intros HC,
      replace HC := not_exists.2 (λ Hy : b ∈ S, HC),
      rw if_neg HC at Hb,
      rw zero_smul at Hb,
      exact (Hb rfl),
    have Hbex :  ∃ (Hy : b ∈ S), b = classical.some _ := ⟨HbS, Hbeq⟩,
    rw if_pos Hbex at Hb,
    use [f b, Hfb, Hb],
    exact Hbeq, },
  { intros a H₁ H₂,
    rcases (classical.some_spec (finset.mem_image.1 H₁)) with ⟨Ha, Hf⟩,
    rw [if_pos, Hf],
    use Ha,
    simp only [Hf], }
end

lemma sum_pow_mem_span_pow
{α : Type u} {β : Type v} [comm_ring α]
(f r : β → α) (n : β → ℕ) {S : finset β}
: (S.sum (λ a, r a • f a)) ^ ((S.sum n) + 1)
  ∈ submodule.span α (↑(S.image (λ a, f a ^ n a)) : set α) :=
begin
  apply finset.induction_on S,
  { simp, },
  { intros a T HanT IH,
    repeat { rw finset.sum_insert HanT, },
    rw [finset.image_insert, finset.coe_insert, submodule.mem_span_insert],
    have H := add_pow_sum (r a * f a) (sum T (λ a, r a • f a)) (n a) (sum T n + 1),
    rcases H with ⟨x, y, H⟩,
    have Hx := @submodule.smul_mem _ _ _ _ _ _ _ x IH,
    use [y * (r a) ^ (n a), x • sum T (λ (a : β), r a • f a) ^ (sum T n + 1), Hx],
    repeat { rw smul_eq_mul, },
    rw [add_assoc, H, add_comm, mul_pow, mul_assoc], }
end

lemma one_mem_span_pow_of_mem_span
{α : Type u} {β : Type v} [comm_ring α]
(f : β → α) (n : β → ℕ) {S : finset β}
(Hx : (1 : α) ∈ submodule.span α (↑(S.image f) : set α))
: (1 : α) ∈ submodule.span α (↑(S.image (λ x, f x ^ n x)) : set α) :=
begin
  rcases (finset.image_sum_of_mem_span Hx) with ⟨r, Hr⟩,
  rw [←one_pow ((S.sum n) + 1), Hr],
  apply sum_pow_mem_span_pow,
end

section exact_sequence

-- Ring R.
parameters (R : Type u) [comm_ring R]
-- f1, ..., fn
parameters {γ : Type v} [fintype γ] {f : γ → R}
-- R[1/f1], ..., R[1/fn]
parameters {Rfi : γ → Type w} [Π i, comm_ring (Rfi i)]
-- α1 : R → R[1/f1], ...., αn → R[1/fn]
parameters {αi : Π i, R → (Rfi i)} [Π i, is_ring_hom (αi i)]
parameters (Hlocα : Π i, is_localization (powers (f i)) (αi i))
parameters (Hlocα' : Π i, is_localization_data (powers (f i)) (αi i))

def α : R → Π i, Rfi i := λ r i, (αi i) r

section alpha_injective

instance PRfs.comm_ring : comm_ring (Π i, Rfi i) :=
pi.comm_ring

instance α.is_ring_hom : is_ring_hom α :=
pi.is_ring_hom_pi αi

-- First part of the lemma.

include Hlocα'

lemma standard_covering₁ (H : (1 : R) ∈ ideal.span (set.range f))
: function.injective α :=
begin
  rw ←@is_ring_hom.inj_iff_trivial_ker _ _ _ _ α (α.is_ring_hom),
  intros x Hx,
  replace Hx := congr_fun Hx,
  have Hn : ∀ i, ∃ n : ℕ, f i ^ n * x = 0,
    intros i,
    replace Hx : x ∈ ker (αi i) := Hx i,
    replace Hloc := Hlocα' i,
    rcases Hloc with ⟨Hinv, Hden, Hker⟩,
    replace Hx := Hker Hx,
    rcases Hx with ⟨⟨⟨u, ⟨fn, ⟨n, Hfn⟩⟩⟩, Hufn⟩, Hx⟩,
    existsi n,
    rw [Hfn, ←Hx, mul_comm],
    exact Hufn,
  let e : γ → ℕ := λ i, classical.some (Hn i),
  have He : ∀ i, f i ^ e i * x = 0 := λ i, classical.some_spec (Hn i),
  rw ←one_mul x,
  -- Σ ai * (f i) = 1
  rw finset.coe_image_univ at H,
  cases finset.image_sum_of_mem_span (one_mem_span_pow_of_mem_span f e H) with r Hone,
  rw [Hone, finset.sum_mul, ←@finset.sum_const_zero γ _ finset.univ],
  apply finset.sum_congr rfl (λ i _, _),
  rw [smul_eq_mul, mul_assoc, He i, mul_zero],
end

end alpha_injective

section beta_kernel_image_alpha

-- R[1/f1f1], ..., R[1/fnfn]
parameters {Rfij : γ → γ → Type w} [Π i j, comm_ring (Rfij i j)]
parameters {φij : Π i j, R → (Rfij i j)} [Π i j, is_ring_hom (φij i j)]
parameters (Hlocφ : Π i j, is_localization (powers ((f i)*(f j))) (φij i j))
parameters (Hlocφ' : Π i j, is_localization_data (powers ((f i)*(f j))) (φij i j))

include Hlocφ'

-- fj is invertible in R[1/fifj].

noncomputable def inverts_powers1 : Π i j, inverts_data (powers (f j)) (φij i j) :=
λ i j r,
begin
  rcases r with ⟨r, Hr⟩,
  rcases (classical.indefinite_description _ Hr) with ⟨n, Hn⟩,
  rcases ((Hlocφ' i j).inverts ⟨((f i)*(f j))^n, ⟨n , by simp⟩⟩) with ⟨w, Hw⟩,
  use ((φij i j ((f i)^n)) * w),
  simp,
  simp at Hw,
  rw [←Hn, ←mul_assoc, ←is_ring_hom.map_mul (φij i j), ←mul_pow, mul_comm (f j)],
  exact Hw,
end

-- fi is invertible in R[1/fifj].

noncomputable def inverts_powers2 : Π i j, inverts_data (powers (f i)) (φij i j) :=
λ i j r,
begin
  cases r with r Hr,
  cases (classical.indefinite_description _ Hr) with n Hn,
  cases ((Hlocφ' i j).inverts ⟨((f i)*(f j))^n, ⟨n , by simp⟩⟩) with w Hw,
  use ((φij i j ((f j)^n)) * w),
  simp,
  simp at Hw,
  rw [←Hn, ←mul_assoc, ←is_ring_hom.map_mul (φij i j), ←mul_pow],
  exact Hw,
end

noncomputable def β1 : (Π i, Rfi i) → (Π i j, Rfij i j)
:= λ ri i j, (is_localization_initial (powers (f j)) (αi j) (Hlocα' j) (φij i j) (inverts_powers1 i j)) (ri j)

noncomputable def β2 : (Π i, Rfi i) → (Π i j, Rfij i j)
:= λ ri i j, (is_localization_initial (powers (f i)) (αi i) (Hlocα' i) (φij i j) (inverts_powers2 i j)) (ri i)

noncomputable def β : (Π i, Rfi i) → (Π i j, Rfij i j) := λ r, (β1 r) - (β2 r)

lemma standard_covering₂.aux (s : Π i, Rfi i)
: ∀ i j, (β1 s i j = β2 s i j →
  ∃ n : ℕ,
    (((Hlocα' j).has_denom (s j)).1.2 * ((Hlocα' i).has_denom (s i)).1.1 -
     ((Hlocα' i).has_denom (s i)).1.2 * ((Hlocα' j).has_denom (s j)).1.1) *
     ((f i) * (f j))^n = 0) :=
begin
  intros i j,
  simp [β1, β2, is_localization_initial],
  rcases ((Hlocα' i).has_denom (s i)) with ⟨⟨q1, p1⟩, Hp1q1⟩,
  rcases ((Hlocα' j).has_denom (s j)) with ⟨⟨q2, p2⟩, Hp2q2⟩,
  simp at Hp1q1,
  simp at Hp2q2,
  dsimp [subtype.coe_mk],
  rcases ((Hlocα' i).inverts q1) with ⟨w1, Hw1⟩,
  rcases ((Hlocα' j).inverts q2) with ⟨w2, Hw2⟩,
  rcases (inverts_powers2 i j q1) with ⟨v1, Hv1⟩,
  rcases (inverts_powers1 i j q2) with ⟨v2, Hv2⟩,
  dsimp [subtype.coe_mk],
  intros H,
  have Hker : φij i j (p2 * q1 - p1 * q2) = 0,
    rw is_ring_hom.map_sub (φij i j),
    iterate 2 { rw is_ring_hom.map_mul (φij i j), },
    rw [sub_eq_zero, ←one_mul (_ * _), ←Hv2, ←mul_assoc, mul_assoc _ v2 _, mul_comm v2],
    rw [H, ←mul_assoc, mul_assoc _ v1 _, mul_comm v1],
    rw [Hv1, mul_one, mul_comm],
  replace Hker : _ ∈ ker (φij i j) := Hker,
  replace Hker := (Hlocφ' i j).ker_le Hker,
  rcases Hker with ⟨⟨⟨u, v⟩, Huv⟩, Hzer⟩,
  dsimp at Huv,
  dsimp only [subtype.coe_mk] at Hzer,
  rw Hzer at Huv,
  rcases v with ⟨v, ⟨n, Hn⟩⟩,
  dsimp only [subtype.coe_mk] at Huv,
  rw ←Hn at Huv,
  existsi n,
  rw ←Huv,
  simp,
end

lemma standard_covering₂.aux₂ (s : Π i, Rfi i)
: (∀ i j, β1 s i j = β2 s i j) →
  ∃ N : ℕ, ∀ i j,
    (((Hlocα' j).has_denom (s j)).1.2 * ((Hlocα' i).has_denom (s i)).1.1 -
     ((Hlocα' i).has_denom (s i)).1.2 * ((Hlocα' j).has_denom (s j)).1.1) *
     ((f i) * (f j))^N = 0 :=
begin
  intros Hs,
  let n : γ × γ → ℕ := λ ij, classical.some (standard_covering₂.aux s ij.1 ij.2 (Hs ij.1 ij.2)),
  let N := finset.sum (@finset.univ (γ × γ) _) n,
  existsi N,
  intros i j,
  have Hn : ∀ i j, n (i, j) ≤ N,
    intros i j,
    exact finset.single_le_sum (λ _ _, nat.zero_le _) (finset.mem_univ (i, j)),
  rw [←nat.sub_add_cancel (Hn i j), add_comm, pow_add, ←mul_assoc],
  rw [classical.some_spec (standard_covering₂.aux s i j (Hs i j)), zero_mul],
end

lemma standard_covering₂.aux₃ (s : Π i, Rfi i)
: (∀ i j, β1 s i j = β2 s i j) →
  ∃ N : ℕ, ∀ i j,
    (((Hlocα' j).has_denom (s j)).1.2 * (f j)^N * ((Hlocα' i).has_denom (s i)).1.1 * (f i)^N =
     ((Hlocα' i).has_denom (s i)).1.2 * (f i)^N * ((Hlocα' j).has_denom (s j)).1.1 * (f j)^N) :=
begin
  intros H,
  rcases (standard_covering₂.aux₂ s H) with ⟨N, HN⟩,
  existsi N,
  intros i j,
  replace HN := HN i j,
  rw [sub_mul, sub_eq_zero] at HN,
  rw [mul_assoc _ (f i ^ N) _, mul_assoc _ (f j ^ N) _],
  rw [mul_comm (f i ^ N), mul_comm (f j ^ N), ←mul_assoc, ←mul_assoc],
  rw [mul_assoc _ _ (f i ^ N), ←mul_pow, mul_comm (f j)],
  rw [mul_assoc _ _ (f j ^ N), ←mul_pow],
  exact HN,
end

lemma standard_covering₂
(Hone : (1:R) ∈ ideal.span (set.range f)) (s : Π i, Rfi i)
: β s = 0 ↔ ∃ r, α r = s :=
begin
  rw finset.coe_image_univ at Hone,
  split,
  { intros H,
    suffices Hsuff : ∃ (r : R), ∀ i, α r i = s i,
      rcases Hsuff with ⟨r, Hr⟩,
      use r,
      apply funext,
      exact Hr,
    simp [α],
    -- Setting up.
    replace H := sub_eq_zero.1 H,
    replace H := congr_fun H,
    replace H := λ i j, (congr_fun (H i)) j,
    rcases (standard_covering₂.aux₃ s H) with ⟨N, HN⟩,
    let r := λ i, classical.some ((Hlocα' i).has_denom (s i)).1.1.2,
    have Hfiri : ∀ i, ((Hlocα' i).has_denom (s i)).1.1.1 = (f i)^(r i),
      intros i,
      simp [classical.some_spec ((Hlocα' i).has_denom (s i)).1.1.2],
    let t := λ i, ((Hlocα' i).has_denom (s i)).1.2,
    replace HN : ∀ i j, (t j) * (f j)^N * (f i)^(r i + N) = (t i) * (f i)^N * (f j)^(r j + N),
      intros i j,
      iterate 2 { rw pow_add, rw ←mul_assoc, },
      rw [←Hfiri i, ←Hfiri j],
      exact (HN i j),
    -- We use the fact that if (ti) = R then (ti') = R.
    replace Hone := (one_mem_span_pow_of_mem_span f (λ i, r i + N) Hone),
    rcases (finset.image_sum_of_mem_span Hone) with ⟨a, Ha⟩,
    dsimp at Ha,
    use [finset.univ.sum (λ i, a i * (t i) * (f i) ^ N)],
    intros i,
    -- Note that: si = ti / fi^ri.
    have Hsi : αi i ((f i)^(r i)) * (s i) = αi i (t i),
      rw ←Hfiri i,
      exact ((Hlocα' i).has_denom (s i)).2,
    -- Multiply the sum by fi^(ri + N) / fi^(ri + N).
    rcases (Hlocα' i).inverts ⟨(f i)^(r i + N), ⟨r i + N, rfl⟩⟩ with ⟨w, Hw⟩,
    dsimp only [subtype.coe_mk] at Hw,
    rw [←mul_one (αi i _ ), ←Hw, ←mul_assoc, ←is_ring_hom.map_mul (αi i), finset.sum_mul],
    -- Key part : Σ ax tx' fi' = Σ ax fx' ti'.
    have Hsum : (λ x, a x * t x * f x ^ N * f i ^ (r i + N)) =
                (λ x, a x * f x ^ (r x + N) * (t i * f i ^ N)),
      apply funext,
      intros j,
      iterate 3 { rw mul_assoc (a j) },
      rw (HN i j),
      symmetry,
      rw mul_comm (_ * _),
    -- Rewrite sum and use the fact that it is one.
    rw [Hsum, ←finset.sum_mul, is_ring_hom.map_mul (αi i)],
    rw [←Ha, is_ring_hom.map_one (αi i), one_mul, ←mul_one (s i)],
    -- Finishing.
    rw [←Hw, pow_add, is_ring_hom.map_mul (αi i), is_ring_hom.map_mul (αi i)],
    rw [←mul_assoc, ←mul_assoc, mul_comm (s i), Hsi], },
  { rintros ⟨r, Hr⟩,
    rw ←Hr,
    erw sub_eq_zero,
    apply funext,
    intros i,
    apply funext,
    intros j,
    simp [β, α, β1, β2],
    iterate 2 { rw is_localization_initial_comp, }, }
end

end beta_kernel_image_alpha

end exact_sequence