/-
Copyright (c) 2020 Kyle Miller. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Kyle Miller
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.combinatorics.simple_graph.basic
import Mathlib.algebra.big_operators.basic
import Mathlib.data.nat.parity
import Mathlib.data.zmod.parity
import Mathlib.tactic.omega.default
import Mathlib.PostPort

universes u l

namespace Mathlib

/-!
# Degree-sum formula and handshaking lemma

The degree-sum formula is that the sum of the degrees of the vertices in
a finite graph is equal to twice the number of edges.  The handshaking lemma,
a corollary, is that the number of odd-degree vertices is even.

## Main definitions

- A `dart` is a directed edge, consisting of an ordered pair of adjacent vertices,
  thought of as being a directed edge.
- `simple_graph.sum_degrees_eq_twice_card_edges` is the degree-sum formula.
- `simple_graph.even_card_odd_degree_vertices` is the handshaking lemma.
- `simple_graph.odd_card_odd_degree_vertices_ne` is that the number of odd-degree
  vertices different from a given odd-degree vertex is odd.
- `simple_graph.exists_ne_odd_degree_of_exists_odd_degree` is that the existence of an
  odd-degree vertex implies the existence of another one.

## Implementation notes

We give a combinatorial proof by using the facts that (1) the map from
darts to vertices is such that each fiber has cardinality the degree
of the corresponding vertex and that (2) the map from darts to edges is 2-to-1.

## Tags

simple graphs, sums, degree-sum formula, handshaking lemma
-/

namespace simple_graph

/-- A dart is a directed edge, consisting of an ordered pair of adjacent vertices. -/
structure dart {V : Type u} (G : simple_graph V) where
  fst : V
  snd : V
  is_adj : adj G fst snd

protected instance dart.fintype {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableRel (adj G)] : fintype (dart G) :=
  fintype.of_equiv (sigma fun (v : V) => ↥(neighbor_set G v))
    (equiv.mk
      (fun (s : sigma fun (v : V) => ↥(neighbor_set G v)) =>
        dart.mk (sigma.fst s) ↑(sigma.snd s) sorry)
      (fun (d : dart G) => sigma.mk (dart.fst d) { val := dart.snd d, property := dart.is_adj d })
      sorry sorry)

/-- The edge associated to the dart. -/
def dart.edge {V : Type u} {G : simple_graph V} (d : dart G) : sym2 V :=
  quotient.mk (dart.fst d, dart.snd d)

@[simp] theorem dart.edge_mem {V : Type u} {G : simple_graph V} (d : dart G) :
    dart.edge d ∈ edge_set G :=
  dart.is_adj d

/-- The dart with reversed orientation from a given dart. -/
def dart.rev {V : Type u} {G : simple_graph V} (d : dart G) : dart G :=
  dart.mk (dart.snd d) (dart.fst d) sorry

@[simp] theorem dart.rev_edge {V : Type u} {G : simple_graph V} (d : dart G) :
    dart.edge (dart.rev d) = dart.edge d :=
  sym2.eq_swap

@[simp] theorem dart.rev_rev {V : Type u} {G : simple_graph V} (d : dart G) :
    dart.rev (dart.rev d) = d :=
  dart.ext (dart.rev (dart.rev d)) d rfl rfl

@[simp] theorem dart.rev_involutive {V : Type u} {G : simple_graph V} :
    function.involutive dart.rev :=
  dart.rev_rev

theorem dart.rev_ne {V : Type u} {G : simple_graph V} (d : dart G) : dart.rev d ≠ d := sorry

theorem dart_edge_eq_iff {V : Type u} {G : simple_graph V} (d₁ : dart G) (d₂ : dart G) :
    dart.edge d₁ = dart.edge d₂ ↔ d₁ = d₂ ∨ d₁ = dart.rev d₂ :=
  sorry

/-- For a given vertex `v`, this is the bijective map from the neighbor set at `v`
to the darts `d` with `d.fst = v`. --/
def dart_of_neighbor_set {V : Type u} (G : simple_graph V) (v : V) (w : ↥(neighbor_set G v)) :
    dart G :=
  dart.mk v ↑w sorry

theorem dart_of_neighbor_set_injective {V : Type u} (G : simple_graph V) (v : V) :
    function.injective (dart_of_neighbor_set G v) :=
  fun (e₁ e₂ : ↥(neighbor_set G v))
    (h : dart_of_neighbor_set G v e₁ = dart_of_neighbor_set G v e₂) =>
    dart.mk.inj_arrow h fun (h₁ : v = v) (h₂ : ↑e₁ = ↑e₂) => subtype.ext h₂

protected instance dart.inhabited {V : Type u} (G : simple_graph V) [Inhabited V]
    [Inhabited ↥(neighbor_set G Inhabited.default)] : Inhabited (dart G) :=
  { default := dart_of_neighbor_set G Inhabited.default Inhabited.default }

theorem dart_fst_fiber {V : Type u} (G : simple_graph V) [fintype V] [DecidableRel (adj G)]
    [DecidableEq V] (v : V) :
    finset.filter (fun (d : dart G) => dart.fst d = v) finset.univ =
        finset.image (dart_of_neighbor_set G v) finset.univ :=
  sorry

theorem dart_fst_fiber_card_eq_degree {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableRel (adj G)] [DecidableEq V] (v : V) :
    finset.card (finset.filter (fun (d : dart G) => dart.fst d = v) finset.univ) = degree G v :=
  sorry

theorem dart_card_eq_sum_degrees {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableRel (adj G)] :
    fintype.card (dart G) = finset.sum finset.univ fun (v : V) => degree G v :=
  sorry

theorem dart.edge_fiber {V : Type u} {G : simple_graph V} [fintype V] [DecidableRel (adj G)]
    [DecidableEq V] (d : dart G) :
    finset.filter (fun (d' : dart G) => dart.edge d' = dart.edge d) finset.univ =
        insert d (singleton (dart.rev d)) :=
  sorry

theorem dart_edge_fiber_card {V : Type u} (G : simple_graph V) [fintype V] [DecidableRel (adj G)]
    [DecidableEq V] (e : sym2 V) (h : e ∈ edge_set G) :
    finset.card (finset.filter (fun (d : dart G) => dart.edge d = e) finset.univ) = bit0 1 :=
  sorry

theorem dart_card_eq_twice_card_edges {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableRel (adj G)] [DecidableEq V] :
    fintype.card (dart G) = bit0 1 * finset.card (edge_finset G) :=
  sorry

/-- The degree-sum formula.  This is also known as the handshaking lemma, which might
more specifically refer to `simple_graph.even_card_odd_degree_vertices`. -/
theorem sum_degrees_eq_twice_card_edges {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableRel (adj G)] [DecidableEq V] :
    (finset.sum finset.univ fun (v : V) => degree G v) = bit0 1 * finset.card (edge_finset G) :=
  Eq.trans (Eq.symm (dart_card_eq_sum_degrees G)) (dart_card_eq_twice_card_edges G)

/-- The handshaking lemma.  See also `simple_graph.sum_degrees_eq_twice_card_edges`. -/
theorem even_card_odd_degree_vertices {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableRel (adj G)] :
    even (finset.card (finset.filter (fun (v : V) => odd (degree G v)) finset.univ)) :=
  sorry

theorem odd_card_odd_degree_vertices_ne {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableEq V] [DecidableRel (adj G)] (v : V) (h : odd (degree G v)) :
    odd (finset.card (finset.filter (fun (w : V) => w ≠ v ∧ odd (degree G w)) finset.univ)) :=
  sorry

theorem exists_ne_odd_degree_of_exists_odd_degree {V : Type u} (G : simple_graph V) [fintype V]
    [DecidableRel (adj G)] (v : V) (h : odd (degree G v)) : ∃ (w : V), w ≠ v ∧ odd (degree G w) :=
  sorry

end Mathlib


/-
Copyright (c) 2021 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.hahn_series
import ring_theory.localization.fraction_ring

/-!
# Laurent Series

## Main Definitions
* Defines `laurent_series` as an abbreviation for `hahn_series ℤ`.
* Provides a coercion `power_series R` into `laurent_series R` given by
  `hahn_series.of_power_series`.
* Defines `laurent_series.power_series_part`
* Defines the localization map `laurent_series.of_power_series_localization` which evaluates to
  `hahn_series.of_power_series`.

-/

open hahn_series
open_locale big_operators classical polynomial
noncomputable theory

universe u

/-- A `laurent_series` is implemented as a `hahn_series` with value group `ℤ`. -/
abbreviation laurent_series (R : Type*) [has_zero R] := hahn_series ℤ R

variables {R : Type u}

namespace laurent_series

section semiring
variable [semiring R]

instance : has_coe (power_series R) (laurent_series R) :=
⟨hahn_series.of_power_series ℤ R⟩

lemma coe_power_series (x : power_series R) : (x : laurent_series R) =
  hahn_series.of_power_series ℤ R x := rfl

@[simp] lemma coeff_coe_power_series (x : power_series R) (n : ℕ) :
  hahn_series.coeff (x : laurent_series R) n = power_series.coeff R n x :=
by rw [← int.nat_cast_eq_coe_nat, coe_power_series, of_power_series_apply_coeff]

/-- This is a power series that can be multiplied by an integer power of `X` to give our
  Laurent series. If the Laurent series is nonzero, `power_series_part` has a nonzero
  constant term.  -/
def power_series_part (x : laurent_series R) : power_series R :=
power_series.mk (λ n, x.coeff (x.order + n))

@[simp] lemma power_series_part_coeff (x : laurent_series R) (n : ℕ) :
  power_series.coeff R n x.power_series_part = x.coeff (x.order + n) :=
power_series.coeff_mk _ _

@[simp] lemma power_series_part_zero : power_series_part (0 : laurent_series R) = 0 :=
by { ext, simp }

@[simp] lemma power_series_part_eq_zero (x : laurent_series R) :
  x.power_series_part = 0 ↔ x = 0 :=
begin
  split,
  { contrapose!,
    intro h,
    rw [power_series.ext_iff, not_forall],
    refine ⟨0, _⟩,
    simp [coeff_order_ne_zero h] },
  { rintro rfl,
    simp }
end

@[simp] lemma single_order_mul_power_series_part (x : laurent_series R) :
  (single x.order 1 : laurent_series R) * x.power_series_part = x :=
begin
  ext n,
  rw [← sub_add_cancel n x.order, single_mul_coeff_add, sub_add_cancel, one_mul],
  by_cases h : x.order ≤ n,
  { rw [int.eq_nat_abs_of_zero_le (sub_nonneg_of_le h), coeff_coe_power_series,
      power_series_part_coeff, ← int.eq_nat_abs_of_zero_le (sub_nonneg_of_le h),
      add_sub_cancel'_right] },
  { rw [coe_power_series, of_power_series_apply, emb_domain_notin_range],
    { contrapose! h,
      exact order_le_of_coeff_ne_zero h.symm },
    { contrapose! h,
      simp only [set.mem_range, rel_embedding.coe_fn_mk, function.embedding.coe_fn_mk,
        int.nat_cast_eq_coe_nat] at h,
      obtain ⟨m, hm⟩ := h,
      rw [← sub_nonneg, ← hm],
      exact int.zero_le_of_nat _ } }
end

lemma of_power_series_power_series_part (x : laurent_series R) :
  of_power_series ℤ R x.power_series_part = single (-x.order) 1 * x :=
begin
  refine eq.trans _ (congr rfl x.single_order_mul_power_series_part),
  rw [← mul_assoc, single_mul_single, neg_add_self, mul_one, ← C_apply, C_one, one_mul,
    coe_power_series],
end

end semiring

instance [comm_semiring R] : algebra (power_series R) (laurent_series R) :=
(hahn_series.of_power_series ℤ R).to_algebra

@[simp] lemma coe_algebra_map [comm_semiring R] :
  ⇑(algebra_map (power_series R) (laurent_series R)) = hahn_series.of_power_series ℤ R :=
rfl

/-- The localization map from power series to Laurent series. -/
@[simps] instance of_power_series_localization [comm_ring R] :
  is_localization (submonoid.powers (power_series.X : power_series R)) (laurent_series R) :=
{ map_units := (begin rintro ⟨_, n, rfl⟩,
    refine ⟨⟨single (n : ℤ) 1, single (-n : ℤ) 1, _, _⟩, _⟩,
    { simp only [single_mul_single, mul_one, add_right_neg],
      refl },
    { simp only [single_mul_single, mul_one, add_left_neg],
      refl },
    { simp } end),
 surj := (begin intro z,
    by_cases h : 0 ≤ z.order,
    { refine ⟨⟨power_series.X ^ (int.nat_abs z.order) * power_series_part z, 1⟩, _⟩,
      simp only [ring_hom.map_one, mul_one, ring_hom.map_mul, coe_algebra_map,
        of_power_series_X_pow, submonoid.coe_one, int.nat_cast_eq_coe_nat],
      rw [int.nat_abs_of_nonneg h, ← coe_power_series, single_order_mul_power_series_part] },
    { refine ⟨⟨power_series_part z, power_series.X ^ (int.nat_abs z.order), ⟨_, rfl⟩⟩, _⟩,
      simp only [coe_algebra_map, of_power_series_power_series_part],
      rw [mul_comm _ z],
      refine congr rfl _,
      rw [subtype.coe_mk, of_power_series_X_pow,
          int.nat_cast_eq_coe_nat, int.of_nat_nat_abs_of_nonpos],
      exact le_of_not_ge h } end),
  eq_iff_exists := (begin intros x y,
    rw [coe_algebra_map, of_power_series_injective.eq_iff],
    split,
    { rintro rfl,
      exact ⟨1, rfl⟩ },
    { rintro ⟨⟨_, n, rfl⟩, hc⟩,
      rw [← sub_eq_zero, ← sub_mul, power_series.ext_iff] at hc,
      rw [← sub_eq_zero, power_series.ext_iff],
      intro m,
      have h := hc (m + n),
      rw [linear_map.map_zero, subtype.coe_mk, power_series.X_pow_eq, power_series.monomial,
        power_series.coeff, finsupp.single_add, mv_power_series.coeff_add_mul_monomial,
        mul_one] at h,
      exact h } end) }

instance {K : Type u} [field K] : is_fraction_ring (power_series K) (laurent_series K) :=
is_localization.of_le (submonoid.powers (power_series.X : power_series K)) _
  (powers_le_non_zero_divisors_of_no_zero_divisors power_series.X_ne_zero)
  (λ f hf, is_unit_of_mem_non_zero_divisors $ map_mem_non_zero_divisors _
    hahn_series.of_power_series_injective hf)

end laurent_series

namespace power_series

open laurent_series

variables {R' : Type*} [semiring R] [ring R'] (f g : power_series R) (f' g' : power_series R')

@[simp, norm_cast] lemma coe_zero : ((0 : power_series R) : laurent_series R) = 0 :=
(of_power_series ℤ R).map_zero

@[simp, norm_cast] lemma coe_one : ((1 : power_series R) : laurent_series R) = 1 :=
(of_power_series ℤ R).map_one

@[simp, norm_cast] lemma coe_add : ((f + g : power_series R) : laurent_series R) = f + g :=
(of_power_series ℤ R).map_add _ _

@[simp, norm_cast] lemma coe_sub : ((f' - g' : power_series R') : laurent_series R') = f' - g' :=
(of_power_series ℤ R').map_sub _ _

@[simp, norm_cast]

@[simp, norm_cast] lemma coe_mul : ((f * g : power_series R) : laurent_series R) = f * g :=
(of_power_series ℤ R).map_mul _ _

lemma coeff_coe (i : ℤ) :
  ((f : power_series R) : laurent_series R).coeff i =
    if i < 0 then 0 else power_series.coeff R i.nat_abs f :=
begin
  cases i,
  { rw [int.nat_abs_of_nat_core, int.of_nat_eq_coe, coeff_coe_power_series,
        if_neg (int.coe_nat_nonneg _).not_lt] },
  { rw [coe_power_series, of_power_series_apply, emb_domain_notin_image_support,
        if_pos (int.neg_succ_lt_zero _)],
    simp only [not_exists, rel_embedding.coe_fn_mk, set.mem_image, not_and,
               function.embedding.coe_fn_mk, ne.def, to_power_series_symm_apply_coeff, mem_support,
               int.nat_cast_eq_coe_nat, int.coe_nat_eq, implies_true_iff, not_false_iff] }
end

@[simp, norm_cast] lemma coe_C (r : R) : ((C R r : power_series R) : laurent_series R) =
  hahn_series.C r :=
of_power_series_C _

@[simp] lemma coe_X : ((X : power_series R) : laurent_series R) = single 1 1 :=
of_power_series_X

@[simp, norm_cast] lemma coe_smul {S : Type*} [semiring S] [module R S]
  (r : R) (x : power_series S) : ((r • x : power_series S) : laurent_series S) = r • x :=
by { ext, simp [coeff_coe, coeff_smul, smul_ite] }

@[simp, norm_cast] lemma coe_bit0 :
  ((bit0 f : power_series R) : laurent_series R) = bit0 f :=
(of_power_series ℤ R).map_bit0 _

@[simp, norm_cast] lemma coe_bit1 :
  ((bit1 f : power_series R) : laurent_series R) = bit1 f :=
(of_power_series ℤ R).map_bit1 _

@[simp, norm_cast] lemma coe_pow (n : ℕ) :
  ((f ^ n : power_series R) : laurent_series R) = f ^ n :=
(of_power_series ℤ R).map_pow _ _

end power_series


structure S :=
(x y z : Nat := 0)

def f1 : Nat × Nat → S → Nat :=
by {
  intro (x, y);
  intro ⟨a, b, c⟩;
  exact x+y+a
}

theorem ex1 : f1 (10, 20) { x := 10 } = 40 :=
rfl

def f2 : Nat × Nat → S → Nat :=
by {
  intro (a, b) { y := y, .. };
  exact a+b+y
}

#eval f2 (10, 20) { y := 5 }

theorem ex2 : f2 (10, 20) { y := 5 } = 35 :=
rfl

def f3 : Nat × Nat → S → S → Nat :=
by {
  intro (a, b) { y := y, .. } s;
  exact a+b+y+s.x
}

#eval f3 (10, 20) { y := 5 } { x := 1 }

theorem ex3 : f3 (10, 20) { y := 5 } { x := 1 } = 36 :=
rfl


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

Free abelian groups as abelianization of free groups.

-- TODO: rewrite in terms of finsupp
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.group.pi
import Mathlib.group_theory.free_group
import Mathlib.group_theory.abelianization
import Mathlib.PostPort

universes u v u_1 u_2 u_3

namespace Mathlib

def free_abelian_group (α : Type u) :=
  additive (abelianization (free_group α))

protected instance free_abelian_group.add_comm_group (α : Type u) : add_comm_group (free_abelian_group α) :=
  additive.add_comm_group

protected instance free_abelian_group.inhabited (α : Type u) : Inhabited (free_abelian_group α) :=
  { default := 0 }

namespace free_abelian_group

def of {α : Type u} (x : α) : free_abelian_group α :=
  coe_fn abelianization.of (free_group.of x)

def lift {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) : free_abelian_group α →+ β :=
  coe_fn monoid_hom.to_additive (abelianization.lift (monoid_hom.of ⇑(free_group.to_group f)))

namespace lift

@[simp] protected theorem add {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) (x : free_abelian_group α) (y : free_abelian_group α) : coe_fn (lift f) (x + y) = coe_fn (lift f) x + coe_fn (lift f) y :=
  is_add_hom.map_add (⇑(lift f)) x y

@[simp] protected theorem neg {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) (x : free_abelian_group α) : coe_fn (lift f) (-x) = -coe_fn (lift f) x :=
  is_add_group_hom.map_neg (⇑(lift f)) x

@[simp] protected theorem sub {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) (x : free_abelian_group α) (y : free_abelian_group α) : coe_fn (lift f) (x - y) = coe_fn (lift f) x - coe_fn (lift f) y := sorry

@[simp] protected theorem zero {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) : coe_fn (lift f) 0 = 0 :=
  is_add_group_hom.map_zero ⇑(lift f)

@[simp] protected theorem of {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) (x : α) : coe_fn (lift f) (of x) = f x := sorry

protected theorem unique {α : Type u} {β : Type v} [add_comm_group β] (f : α → β) (g : free_abelian_group α →+ β) (hg : ∀ (x : α), coe_fn g (of x) = f x) {x : free_abelian_group α} : coe_fn g x = coe_fn (lift f) x :=
  abelianization.lift.unique (monoid_hom.of ⇑(free_group.to_group f)) (coe_fn add_monoid_hom.to_multiplicative g)
    fun (x : free_group α) =>
      free_group.to_group.unique (monoid_hom.comp (coe_fn add_monoid_hom.to_multiplicative' g) abelianization.of) hg

/-- See note [partially-applied ext lemmas]. -/
protected theorem ext {α : Type u} {β : Type v} [add_comm_group β] (g : free_abelian_group α →+ β) (h : free_abelian_group α →+ β) (H : ∀ (x : α), coe_fn g (of x) = coe_fn h (of x)) : g = h := sorry

theorem map_hom {α : Type u_1} {β : Type u_2} {γ : Type u_3} [add_comm_group β] [add_comm_group γ] (a : free_abelian_group α) (f : α → β) (g : β →+ γ) : coe_fn g (coe_fn (lift f) a) = coe_fn (lift (⇑g ∘ f)) a := sorry

end lift

theorem of_injective {α : Type u} : function.injective of := sorry

/-- The bijection underlying the free-forgetful adjunction for abelian groups.-/
def hom_equiv (X : Type u_1) (G : Type u_2) [add_comm_group G] : (free_abelian_group X →+ G) ≃ (X → G) :=
  equiv.mk (fun (f : free_abelian_group X →+ G) => add_monoid_hom.to_fun f ∘ of)
    (fun (f : X → G) => add_monoid_hom.of ⇑(lift f)) sorry sorry

@[simp] theorem hom_equiv_apply (X : Type u_1) (G : Type u_2) [add_comm_group G] (f : free_abelian_group X →+ G) (x : X) : coe_fn (hom_equiv X G) f x = coe_fn f (of x) :=
  rfl

@[simp] theorem hom_equiv_symm_apply (X : Type u_1) (G : Type u_2) [add_comm_group G] (f : X → G) (x : free_abelian_group X) : coe_fn (coe_fn (equiv.symm (hom_equiv X G)) f) x = coe_fn (lift f) x :=
  rfl

protected theorem induction_on {α : Type u} {C : free_abelian_group α → Prop} (z : free_abelian_group α) (C0 : C 0) (C1 : ∀ (x : α), C (of x)) (Cn : ∀ (x : α), C (of x) → C (-of x)) (Cp : ∀ (x y : free_abelian_group α), C x → C y → C (x + y)) : C z := sorry

theorem lift.add' {α : Type u_1} {β : Type u_2} [add_comm_group β] (a : free_abelian_group α) (f : α → β) (g : α → β) : coe_fn (lift (f + g)) a = coe_fn (lift f) a + coe_fn (lift g) a := sorry

protected instance is_add_group_hom_lift' {α : Type u_1} (β : Type u_2) [add_comm_group β] (a : free_abelian_group α) : is_add_group_hom fun (f : α → β) => coe_fn (lift f) a :=
  is_add_group_hom.mk

protected instance monad : Monad free_abelian_group := sorry

protected theorem induction_on' {α : Type u} {C : free_abelian_group α → Prop} (z : free_abelian_group α) (C0 : C 0) (C1 : ∀ (x : α), C (pure x)) (Cn : ∀ (x : α), C (pure x) → C (-pure x)) (Cp : ∀ (x y : free_abelian_group α), C x → C y → C (x + y)) : C z :=
  free_abelian_group.induction_on z C0 C1 Cn Cp

@[simp] theorem map_pure {α : Type u} {β : Type u} (f : α → β) (x : α) : f <$> pure x = pure (f x) :=
  lift.of (of ∘ f) x

@[simp] theorem map_zero {α : Type u} {β : Type u} (f : α → β) : f <$> 0 = 0 :=
  lift.zero (of ∘ f)

@[simp] theorem map_add {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) (y : free_abelian_group α) : f <$> (x + y) = f <$> x + f <$> y :=
  lift.add (of ∘ f) x y

@[simp] theorem map_neg {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) : f <$> (-x) = -f <$> x :=
  lift.neg (of ∘ f) x

@[simp] theorem map_sub {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) (y : free_abelian_group α) : f <$> (x - y) = f <$> x - f <$> y :=
  lift.sub (of ∘ f) x y

@[simp] theorem map_of {α : Type u} {β : Type u} (f : α → β) (y : α) : f <$> of y = of (f y) :=
  rfl

/-- The additive group homomorphism `free_abelian_group α →+ free_abelian_group β` induced from a
  map `α → β` -/
def map {α : Type u} {β : Type u} (f : α → β) : free_abelian_group α →+ free_abelian_group β :=
  add_monoid_hom.mk' (fun (x : free_abelian_group α) => f <$> x) (map_add f)

theorem lift_comp {α : Type u_1} {β : Type u_1} {γ : Type u_2} [add_comm_group γ] (f : α → β) (g : β → γ) (x : free_abelian_group α) : coe_fn (lift (g ∘ f)) x = coe_fn (lift g) (f <$> x) := sorry

@[simp] theorem pure_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) (x : α) : pure x >>= f = f x :=
  lift.of f x

@[simp] theorem zero_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) : 0 >>= f = 0 :=
  lift.zero f

@[simp] theorem add_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) (x : free_abelian_group α) (y : free_abelian_group α) : x + y >>= f = (x >>= f) + (y >>= f) :=
  lift.add f x y

@[simp] theorem neg_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) (x : free_abelian_group α) : -x >>= f = -(x >>= f) :=
  lift.neg f x

@[simp] theorem sub_bind {α : Type u} {β : Type u} (f : α → free_abelian_group β) (x : free_abelian_group α) (y : free_abelian_group α) : x - y >>= f = (x >>= f) - (y >>= f) :=
  lift.sub f x y

@[simp] theorem pure_seq {α : Type u} {β : Type u} (f : α → β) (x : free_abelian_group α) : pure f <*> x = f <$> x :=
  pure_bind
    (fun (_x : α → β) => (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x x)
    f

@[simp] theorem zero_seq {α : Type u} {β : Type u} (x : free_abelian_group α) : 0 <*> x = 0 :=
  zero_bind
    fun (_x : α → β) => (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x x

@[simp] theorem add_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) (g : free_abelian_group (α → β)) (x : free_abelian_group α) : f + g <*> x = (f <*> x) + (g <*> x) :=
  add_bind
    (fun (_x : α → β) => (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x x)
    f g

@[simp] theorem neg_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) (x : free_abelian_group α) : -f <*> x = -(f <*> x) :=
  neg_bind
    (fun (_x : α → β) => (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x x)
    f

@[simp] theorem sub_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) (g : free_abelian_group (α → β)) (x : free_abelian_group α) : f - g <*> x = (f <*> x) - (g <*> x) :=
  sub_bind
    (fun (_x : α → β) => (fun (α β : Type u) (f : α → β) (x : free_abelian_group α) => coe_fn (lift (of ∘ f)) x) α β _x x)
    f g

protected instance is_add_group_hom_seq {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) : is_add_group_hom (Seq.seq f) :=
  is_add_group_hom.mk

@[simp] theorem seq_zero {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) : f <*> 0 = 0 :=
  is_add_group_hom.map_zero (Seq.seq f)

@[simp] theorem seq_add {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) (x : free_abelian_group α) (y : free_abelian_group α) : f <*> x + y = (f <*> x) + (f <*> y) :=
  is_add_hom.map_add (Seq.seq f) x y

@[simp] theorem seq_neg {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) (x : free_abelian_group α) : f <*> -x = -(f <*> x) :=
  is_add_group_hom.map_neg (Seq.seq f) x

@[simp] theorem seq_sub {α : Type u} {β : Type u} (f : free_abelian_group (α → β)) (x : free_abelian_group α) (y : free_abelian_group α) : f <*> x - y = (f <*> x) - (f <*> y) :=
  is_add_group_hom.map_sub (Seq.seq f) x y

protected instance is_lawful_monad : is_lawful_monad free_abelian_group := sorry

protected instance is_comm_applicative : is_comm_applicative free_abelian_group := sorry

protected instance semigroup (α : Type u) [monoid α] : semigroup (free_abelian_group α) :=
  semigroup.mk (fun (x : free_abelian_group α) => ⇑(lift fun (x₂ : α) => coe_fn (lift fun (x₁ : α) => of (x₁ * x₂)) x))
    sorry

theorem mul_def (α : Type u) [monoid α] (x : free_abelian_group α) (y : free_abelian_group α) : x * y = coe_fn (lift fun (x₂ : α) => coe_fn (lift fun (x₁ : α) => of (x₁ * x₂)) x) y :=
  rfl

theorem of_mul_of (α : Type u) [monoid α] (x : α) (y : α) : of x * of y = of (x * y) :=
  rfl

theorem of_mul (α : Type u) [monoid α] (x : α) (y : α) : of (x * y) = of x * of y :=
  rfl

protected instance ring (α : Type u) [monoid α] : ring (free_abelian_group α) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg add_comm_group.sub sorry sorry
    semigroup.mul sorry (of 1) sorry sorry sorry sorry

theorem one_def (α : Type u) [monoid α] : 1 = of 1 :=
  rfl

theorem of_one (α : Type u) [monoid α] : of 1 = 1 :=
  rfl

protected instance comm_ring (α : Type u) [comm_monoid α] : comm_ring (free_abelian_group α) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry ring.one sorry sorry
    sorry sorry sorry


open tactic
open smt_tactic

def pointwise_attribute : user_attribute := {
  name := `pointwise,
  descr := "A lemma that proves things are equal using the fact they are pointwise equal."
}

run_command attribute.register `pointwise_attribute

/- Try to apply one of the given lemas, it succeeds if one of them succeeds. -/
meta def any_apply : list name → tactic unit
| []      := failed
| (c::cs) := (mk_const c >>= fapply) <|> any_apply cs

meta def smt_simp        : tactic unit := using_smt $ intros >> try simp
meta def smt_ematch : tactic unit := using_smt $ intros >> add_lemmas_from_facts >> try ematch

meta def pointwise (and_then : tactic unit) : tactic unit :=
do cs ← attribute.get_instances `pointwise,
   try (seq (any_apply cs) and_then)

attribute [pointwise] funext

meta def blast : tactic unit := smt_simp >> pointwise blast

notation `♮` := by abstract { blast }

@[pointwise] lemma {u v} pair_equality {α : Type u} {β : Type v} { X: α × β }: (X^.fst, X^.snd) = X := begin induction X, blast end
@[pointwise] lemma {u v} pair_equality_1 {α : Type u} {β : Type v} { X: α × β } { A : α } ( p : A = X^.fst ) : (A, X^.snd) = X := begin induction X, blast end
@[pointwise] lemma {u v} pair_equality_2 {α : Type u} {β : Type v} { X: α × β } { B : β } ( p : B = X^.snd ) : (X^.fst, B) = X := begin induction X, blast end
attribute [pointwise] subtype.eq

def {u} auto_cast {α β : Type u} {h : α = β} (a : α) := cast h a
@[simp] lemma {u} auto_cast_identity {α : Type u} (a : α) : @auto_cast α α (by smt_ematch) a = a := ♮
notation `⟦` p `⟧` := @auto_cast _ _ (by smt_ematch) p
universe variables u v

structure Category :=
  (Obj : Type u)
  (Hom : Obj → Obj → Type v)
  (identity : Π X : Obj, Hom X X)
  (compose  : Π { X Y Z : Obj }, Hom X Y → Hom Y Z → Hom X Z)

  (left_identity  : ∀ { X Y : Obj } (f : Hom X Y), compose (identity _) f = f)
  (right_identity : ∀ { X Y : Obj } (f : Hom X Y), compose f (identity _) = f)
  (associativity  : ∀ { W X Y Z : Obj } (f : Hom W X) (g : Hom X Y) (h : Hom Y Z),
    compose (compose f g) h = compose f (compose g h))

attribute [simp] Category.left_identity
attribute [simp] Category.right_identity

@[reducible] definition CategoryOfTypes : Category :=
{
    Obj := Type u,
    Hom := λ a b, a → b,

    identity := λ a, id,
    compose  := λ _ _ _ f g, g ∘ f,

    left_identity  := ♮,
    right_identity := ♮,
    associativity  := ♮
}

universe variables u1 v1 u2 v2 u3 v3

structure Functor (C : Category.{ u1 v1 }) (D : Category.{ u2 v2 }) :=
  (onObjects   : C^.Obj → D^.Obj)
  (onMorphisms : Π { X Y : C^.Obj },
                C^.Hom X Y → D^.Hom (onObjects X) (onObjects Y))
  (identities : ∀ (X : C^.Obj),
    onMorphisms (C^.identity X) = D^.identity (onObjects X))
  (functoriality : ∀ { X Y Z : C^.Obj } (f : C^.Hom X Y) (g : C^.Hom Y Z),
    onMorphisms (C^.compose f g) = D^.compose (onMorphisms f) (onMorphisms g))

attribute [simp] Functor.identities
attribute [simp] Functor.functoriality

-- We define a coercion so that we can write `F X` for the functor `F` applied to the object `X`.
-- One can still write out `onObjects F X` when needed.
instance Functor_to_onObjects { C D : Category }: has_coe_to_fun (Functor C D) :=
{ F   := λ f, C^.Obj -> D^.Obj,
  coe := Functor.onObjects }

@[reducible] definition IdentityFunctor ( C: Category ) : Functor C C :=
{
  onObjects     := id,
  onMorphisms   := λ _ _ f, f,
  identities    := ♮,
  functoriality := ♮
}

@[reducible] definition FunctorComposition { C D E : Category } ( F : Functor C D ) ( G : Functor D E ) : Functor C E :=
{
  onObjects     := λ X, G (F X),
  onMorphisms   := λ _ _ f, G^.onMorphisms (F^.onMorphisms f),
  identities    := ♮,
  functoriality := ♮
}

namespace Functor
  notation F `∘` G := FunctorComposition F G
end Functor

structure NaturalTransformation { C D : Category } ( F G : Functor C D ) :=
  (components: Π X : C^.Obj, D^.Hom (F X) (G X))
  (naturality: ∀ { X Y : C^.Obj } (f : C^.Hom X Y),
     D^.compose (F^.onMorphisms f) (components Y) = D^.compose (components X) (G^.onMorphisms f))

-- This defines a coercion so we can write `α X` for `components α X`.
instance NaturalTransformation_to_components { C D : Category } { F G : Functor C D } : has_coe_to_fun (NaturalTransformation F G) :=
{ F   := λ f, Π X : C^.Obj, D^.Hom (F X) (G X),
  coe := NaturalTransformation.components }

-- We'll want to be able to prove that two natural transformations are equal if they are componentwise equal.
@[pointwise] lemma NaturalTransformations_componentwise_equal
  { C D : Category }
  { F G : Functor C D }
  ( α β : NaturalTransformation F G )
  ( w : ∀ X : C^.Obj, α X = β X ) : α = β :=
  begin
    induction α with αc,
    induction β with βc,
    have hc : αc = βc, from funext w,
    by subst hc
  end

@[reducible] definition IdentityNaturalTransformation { C D : Category } (F : Functor C D) : NaturalTransformation F F :=
  {
    components := λ X, D^.identity (F X),
    naturality := ♮
  }

@[reducible] definition vertical_composition_of_NaturalTransformations
  { C D : Category }
  { F G H : Functor C D }
  ( α : NaturalTransformation F G )
  ( β : NaturalTransformation G H ) : NaturalTransformation F H :=
  {
    components := λ X, D^.compose (α X) (β X),
    naturality := begin
                    blast,
                    begin[smt]
                      eblast_using [ Category.associativity, NaturalTransformation.naturality ]
                    end,
                  end
  }

@[reducible] definition horizontal_composition_of_NaturalTransformations
  { C D E : Category }
  { F G : Functor C D }
  { H I : Functor D E }
  ( α : NaturalTransformation F G )
  ( β : NaturalTransformation H I ) : NaturalTransformation (FunctorComposition F H) (FunctorComposition G I) :=
  {
    components := λ X : C^.Obj, E^.compose (β (F X)) (I^.onMorphisms (α X)),
    naturality := begin
                    blast,
                    begin[smt]
                      eblast_using [ Category.associativity, Functor.functoriality, NaturalTransformation.naturality ]
                    end,
                  end
  }

@[reducible] definition whisker_on_left
  { C D E : Category }
  ( F : Functor C D )
  { G H : Functor D E }
  ( α : NaturalTransformation G H ) :
  NaturalTransformation (FunctorComposition F G) (FunctorComposition F H) :=
  horizontal_composition_of_NaturalTransformations (IdentityNaturalTransformation F) α

@[reducible] definition whisker_on_right
  { C D E : Category }
  { F G : Functor C D }
  ( α : NaturalTransformation F G )
  ( H : Functor D E ) :
  NaturalTransformation (FunctorComposition F H) (FunctorComposition G H) :=
  horizontal_composition_of_NaturalTransformations α (IdentityNaturalTransformation H)

@[reducible] definition ProductCategory (C : Category.{u1 v1}) (D : Category.{u2 v2}) : Category :=
{
  Obj      := C^.Obj × D^.Obj,
  Hom      := (λ X Y : C^.Obj × D^.Obj, C^.Hom (X^.fst) (Y^.fst) × D^.Hom (X^.snd) (Y^.snd)),
  identity := λ X, (C^.identity (X^.fst), D^.identity (X^.snd)),
  compose  := λ _ _ _ f g, (C^.compose (f^.fst) (g^.fst), D^.compose (f^.snd) (g^.snd)),

  left_identity  := ♮,
  right_identity := ♮,
  associativity  := begin
                      blast,
                      begin[smt]
                        eblast_using [ Category.associativity ]
                      end
                    end
}

namespace ProductCategory
  notation C `×` D := ProductCategory C D
end ProductCategory

@[reducible] definition ProductFunctor { A B C D : Category } ( F : Functor A B ) ( G : Functor C D ) : Functor (A × C) (B × D) :=
{
  onObjects     := λ X, (F X^.fst, G X^.snd),
  onMorphisms   := λ _ _ f, (F^.onMorphisms f^.fst, G^.onMorphisms f^.snd),
  identities    := ♮,
  functoriality := ♮
}

namespace ProductFunctor
  notation F `×` G := ProductFunctor F G
end ProductFunctor

@[reducible] definition ProductNaturalTransformation { A B C D : Category } { F G : Functor A B } { H I : Functor C D } (α : NaturalTransformation F G) (β : NaturalTransformation H I) : NaturalTransformation (F × H) (G × I) :=
{
  components := λ X, (α X^.fst, β X^.snd),
  naturality :=
  begin
    blast,
    begin[smt]
      eblast_using [ NaturalTransformation.naturality ]
    end
  end
}

namespace ProductNaturalTransformation
  notation α `×` β := ProductNaturalTransformation α β
end ProductNaturalTransformation

@[reducible] definition ProductCategoryAssociator
  ( C : Category.{ u1 v1 } )
  ( D : Category.{ u2 v2 } )
  ( E : Category.{ u3 v3 } )
  : Functor ((C × D) × E) (C × (D × E)) :=
{
  onObjects     := λ X, (X^.fst^.fst, (X^.fst^.snd, X^.snd)),
  onMorphisms   := λ _ _ f, (f^.fst^.fst, (f^.fst^.snd, f^.snd)),
  identities    := ♮,
  functoriality := ♮
}

@[reducible] definition TensorProduct ( C: Category ) := Functor ( C × C ) C

@[reducible] definition left_associated_triple_tensor ( C : Category.{ u v } ) ( tensor : TensorProduct C ) : Functor ((C × C) × C) C :=
  FunctorComposition (tensor × IdentityFunctor C) tensor
@[reducible] definition right_associated_triple_tensor ( C : Category.{ u v } ) ( tensor : TensorProduct C ) : Functor (C × (C × C)) C :=
  FunctorComposition (IdentityFunctor C × tensor) tensor

@[reducible] definition Associator { C : Category.{ u v } } ( tensor : TensorProduct C ) :=
  NaturalTransformation
    (left_associated_triple_tensor C tensor)
    (FunctorComposition (ProductCategoryAssociator C C C) (right_associated_triple_tensor C tensor))

@[reducible] definition Pentagon { C : Category } { tensor : TensorProduct C } ( associator : Associator tensor ) :=
  let α ( X Y Z : C^.Obj ) := associator ((X, Y), Z) in
  let tensorObjects ( X Y : C^.Obj ) := tensor^.onObjects (X, Y) in
  let tensorMorphisms { W X Y Z : C^.Obj } ( f : C^.Hom W X ) ( g : C^.Hom Y Z ) : C^.Hom (tensorObjects W Y) (tensorObjects X Z) := tensor^.onMorphisms (f, g) in
  ∀ W X Y Z : C^.Obj,
    C^.compose (α (tensorObjects W X) Y Z) (α W X (tensorObjects Y Z))
  = C^.compose (C^.compose (tensorMorphisms (α W X Y) (C^.identity Z)) (α W (tensorObjects X Y) Z)) (tensorMorphisms (C^.identity W) (α X Y Z))

structure MonoidalCategory :=
  (parent : Category)
  (tensor : TensorProduct parent)
  (associator_transformation : Associator tensor)
  (pentagon                  : Pentagon associator_transformation)

instance MonoidalCategory_coercion : has_coe MonoidalCategory.{u v} Category.{u v} :=
  ⟨MonoidalCategory.parent⟩

-- Copying fields. TODO: automate
@[reducible] definition MonoidalCategory.Obj            ( C : MonoidalCategory ) := @Category.Obj            C^.parent
@[reducible] definition MonoidalCategory.Hom            ( C : MonoidalCategory ) := @Category.Hom            C^.parent
@[reducible] definition MonoidalCategory.identity       ( C : MonoidalCategory ) := @Category.identity       C^.parent
@[reducible] definition MonoidalCategory.compose        ( C : MonoidalCategory ) := @Category.compose        C^.parent
@[reducible] definition MonoidalCategory.left_identity  ( C : MonoidalCategory ) := @Category.left_identity  C^.parent
@[reducible] definition MonoidalCategory.right_identity ( C : MonoidalCategory ) := @Category.right_identity C^.parent
@[reducible] definition MonoidalCategory.associativity  ( C : MonoidalCategory ) := @Category.associativity  C^.parent

@[reducible] definition MonoidalCategory.tensorObjects   ( C : MonoidalCategory ) ( X Y : C^.Obj ) : C^.Obj := C^.tensor (X, Y)
@[reducible] definition MonoidalCategory.tensorMorphisms ( C : MonoidalCategory ) { W X Y Z : C^.Obj } ( f : C^.Hom W X ) ( g : C^.Hom Y Z ) : C^.Hom (C^.tensor (W, Y)) (C^.tensor (X, Z)) := C^.tensor^.onMorphisms (f, g)

@[reducible] definition MonoidalCategory.interchange
  ( C : MonoidalCategory )
  { U V W X Y Z: C^.Obj }
  ( f : C^.Hom U V )( g : C^.Hom V W )( h : C^.Hom X Y )( k : C^.Hom Y Z ) :
  @Functor.onMorphisms _ _ C^.tensor (U, X) (W, Z) ((C^.compose f g), (C^.compose h k)) = C^.compose (@Functor.onMorphisms _ _ C^.tensor (U, X) (V, Y) (f, h)) (@Functor.onMorphisms _ _ C^.tensor (V, Y) (W, Z) (g, k)) :=
  @Functor.functoriality (C × C) C C^.tensor (U, X) (V, Y) (W, Z) (f, h) (g, k)

definition TensorProductOfTypes : TensorProduct CategoryOfTypes :=
{
  onObjects     := λ p, prod p.1 p.2,
  onMorphisms   := λ _ _ p, λ q, (p.1 q.1, p.2 q.2),
  identities    := ♮,
  functoriality := ♮
}

definition TypeAssociator : Associator TensorProductOfTypes :=
{
  components := λ p, λ t, (t.1.1,(t.1.2, t.2)),
  naturality := ♮
}

definition MonoidalCategoryOfTypes : MonoidalCategory := {
  parent := CategoryOfTypes,
  tensor := TensorProductOfTypes,
  associator_transformation := TypeAssociator,
  pentagon := ♮
}

local attribute [reducible] lift_t coe_t coe_b

definition tensor_on_left { C: MonoidalCategory.{u v} } ( Z: C^.Obj ) : Functor.{u v u v} C C :=
{
  onObjects := λ X, C^.tensorObjects Z X,
  onMorphisms := λ X Y f, C^.tensorMorphisms (C^.identity Z) f,
  identities := begin
                  blast,
                  rewrite Functor.identities (C^.tensor),
                end,
  functoriality := begin
                      intros,
                      unfold MonoidalCategory.tensorMorphisms,
                      assert h : @Category.compose C = @MonoidalCategory.compose C, blast,
                      rewrite h,
                      rewrite - C^.interchange,
                      assert i : @Category.identity C = @MonoidalCategory.identity C, blast,
                      rewrite - i,
                      rewrite - h,
                      rewrite C^.left_identity
                    end
}

@[reducible] definition pentagon_3step_1 ( C : MonoidalCategory.{ u v } ) :=
  let α := C^.associator_transformation in
  whisker_on_right
    (α × IdentityNaturalTransformation (IdentityFunctor C))
    C^.tensor

@[reducible] definition pentagon_3step_2 ( C : MonoidalCategory.{ u v } ) :=
  let α := C^.associator_transformation in
  whisker_on_left
    (FunctorComposition
      (ProductCategoryAssociator C C C × IdentityFunctor C)
      ((IdentityFunctor C × C^.tensor) × IdentityFunctor C))
    α

@[reducible] definition pentagon_3step_3 ( C : MonoidalCategory.{ u v } ) :=
  let α := C^.associator_transformation in
  whisker_on_left
    (FunctorComposition
      (ProductCategoryAssociator C C C × IdentityFunctor C)
      (ProductCategoryAssociator C (C × C) C))
    (whisker_on_right
      (IdentityNaturalTransformation (IdentityFunctor C) × α)
      C^.tensor)

@[reducible] definition pentagon_3step ( C : MonoidalCategory.{ u v } ) :=
  vertical_composition_of_NaturalTransformations
    (vertical_composition_of_NaturalTransformations
      (pentagon_3step_1 C)
      (pentagon_3step_2 C))
    (pentagon_3step_3 C)

@[reducible] definition pentagon_2step_1 ( C : MonoidalCategory.{ u v } ) :=
  let α := C^.associator_transformation in
  whisker_on_left
    ((C^.tensor × IdentityFunctor C) × IdentityFunctor C)
    α

@[reducible] definition pentagon_2step_2 ( C : MonoidalCategory.{ u v } ) :=
  let α := C^.associator_transformation in
  whisker_on_left
    (FunctorComposition
      (ProductCategoryAssociator (C × C) C C)
      (IdentityFunctor (C × C) × C^.tensor))
    α

@[reducible] definition pentagon_2step ( C : MonoidalCategory.{ u v } ) :=
  vertical_composition_of_NaturalTransformations
    (pentagon_2step_1 C)
    (pentagon_2step_2 C)

attribute [simp] MonoidalCategory.left_identity
attribute [simp] MonoidalCategory.right_identity

lemma pentagon_in_terms_of_natural_transformations
  ( C : MonoidalCategory ) :
  pentagon_2step C = pentagon_3step C :=
  begin
    blast, -- This just unfolds definitions and introduces variables
    induction X with PQR S,
    induction PQR with PQ R,
    induction PQ with P Q,
    pose p := C^.pentagon P Q R S,
    blast, -- this simplifies the hypothesis p back to something reasonable
    repeat { rewrite C^.tensor^.identities }, -- we shouldn't have to do this, as Functor.identities has [simp]
    blast
  end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Yury Kudryashov
-/
import dynamics.fixed_points.basic
import order.hom.order

/-!
# Fixed point construction on complete lattices

This file sets up the basic theory of fixed points of a monotone function in a complete lattice.

## Main definitions

* `order_hom.lfp`: The least fixed point of a bundled monotone function.
* `order_hom.gfp`: The greatest fixed point of a bundled monotone function.
* `order_hom.prev_fixed`: The greatest fixed point of a bundled monotone function smaller than or
  equal to a given element.
* `order_hom.next_fixed`: The least fixed point of a bundled monotone function greater than or
  equal to a given element.
* `fixed_points.complete_lattice`: The Knaster-Tarski theorem: fixed points of a monotone
  self-map of a complete lattice form themselves a complete lattice.

## Tags

fixed point, complete lattice, monotone function
-/

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

open function (fixed_points is_fixed_pt)

namespace order_hom

section basic

variables [complete_lattice α] (f : α →o α)

/-- Least fixed point of a monotone function -/
def lfp : (α →o α) →o α :=
{ to_fun := λ f, Inf {a | f a ≤ a},
  monotone' := λ f g hle, Inf_le_Inf $ λ a ha, (hle a).trans ha }

/-- Greatest fixed point of a monotone function -/
def gfp : (α →o α) →o α :=
{ to_fun := λ f, Sup {a | a ≤ f a},
  monotone' := λ f g hle, Sup_le_Sup $ λ a ha, le_trans ha (hle a) }

lemma lfp_le {a : α} (h : f a ≤ a) : lfp f ≤ a := Inf_le h

lemma lfp_le_fixed {a : α} (h : f a = a) : lfp f ≤ a := f.lfp_le h.le

lemma le_lfp {a : α} (h : ∀ b, f b ≤ b → a ≤ b) : a ≤ lfp f := le_Inf h

lemma map_le_lfp {a : α} (ha : a ≤ f.lfp) : f a ≤ f.lfp :=
f.le_lfp $ λ b hb, (f.mono $ le_Inf_iff.1 ha _ hb).trans hb

@[simp] lemma map_lfp : f (lfp f) = lfp f :=
have h : f (lfp f) ≤ lfp f, from f.map_le_lfp le_rfl,
h.antisymm $ f.lfp_le $ f.mono h

lemma is_fixed_pt_lfp : is_fixed_pt f f.lfp := f.map_lfp

lemma lfp_le_map {a : α} (ha : lfp f ≤ a) : lfp f ≤ f a :=
calc lfp f = f (lfp f) : f.map_lfp.symm
       ... ≤ f a       : f.mono ha

lemma is_least_lfp_le : is_least {a | f a ≤ a} (lfp f) :=
⟨f.map_lfp.le, λ a, f.lfp_le⟩

lemma is_least_lfp : is_least (fixed_points f) (lfp f) :=
⟨f.is_fixed_pt_lfp, λ a, f.lfp_le_fixed⟩

lemma lfp_induction {p : α → Prop} (step : ∀ a, p a → a ≤ lfp f → p (f a))
  (hSup : ∀ s, (∀ a ∈ s, p a) → p (Sup s)) :
  p (lfp f) :=
begin
  set s := {a | a ≤ lfp f ∧ p a},
  specialize hSup s (λ a, and.right),
  suffices : Sup s = lfp f, from this ▸ hSup,
  have h : Sup s ≤ lfp f := Sup_le (λ b, and.left),
  have hmem : f (Sup s) ∈ s, from ⟨f.map_le_lfp h, step _ hSup h⟩,
  exact h.antisymm (f.lfp_le $ le_Sup hmem)
end

lemma le_gfp {a : α} (h : a ≤ f a) : a ≤ gfp f :=
le_Sup h

lemma gfp_le {a : α} (h : ∀ b, b ≤ f b → b ≤ a) : gfp f ≤ a :=
Sup_le h

lemma is_fixed_pt_gfp : is_fixed_pt f (gfp f) := f.dual.is_fixed_pt_lfp

@[simp] lemma map_gfp : f (gfp f) = gfp f := f.dual.map_lfp

lemma map_le_gfp {a : α} (ha : a ≤ gfp f) : f a ≤ gfp f := f.dual.lfp_le_map ha

lemma gfp_le_map {a : α} (ha : gfp f ≤ a) : gfp f ≤ f a := f.dual.map_le_lfp ha

lemma is_greatest_gfp_le : is_greatest {a | a ≤ f a} (gfp f) :=
f.dual.is_least_lfp_le

lemma is_greatest_gfp : is_greatest (fixed_points f) (gfp f) :=
f.dual.is_least_lfp

lemma gfp_induction {p : α → Prop} (step : ∀ a, p a → gfp f ≤ a → p (f a))
  (hInf : ∀ s, (∀ a ∈ s, p a) → p (Inf s)) :
  p (gfp f) :=
f.dual.lfp_induction step hInf

end basic

section eqn

variables [complete_lattice α] [complete_lattice β] (f : β →o α) (g : α →o β)

-- Rolling rule
lemma map_lfp_comp : f (lfp (g.comp f)) = lfp (f.comp g) :=
le_antisymm ((f.comp g).map_lfp ▸ f.mono (lfp_le_fixed _ $ congr_arg g (f.comp g).map_lfp)) $
  lfp_le _ (congr_arg f (g.comp f).map_lfp).le

lemma map_gfp_comp : f ((g.comp f).gfp) = (f.comp g).gfp :=
f.dual.map_lfp_comp g.dual

-- Diagonal rule
lemma lfp_lfp (h : α →o α →o α) :
  lfp (lfp.comp h) = lfp h.on_diag :=
begin
  let a := lfp (lfp.comp h),
  refine (lfp_le _ _).antisymm (lfp_le _ (eq.le _)),
  { exact lfp_le _ h.on_diag.map_lfp.le },
  have ha : (lfp ∘ h) a = a := (lfp.comp h).map_lfp,
  calc h a a = h a (lfp (h a)) : congr_arg (h a) ha.symm
         ... = lfp (h a)       : (h a).map_lfp
         ... = a               : ha
end

lemma gfp_gfp (h : α →o α →o α) :
  gfp (gfp.comp h) = gfp h.on_diag :=
@lfp_lfp (order_dual α) _ $ (order_hom.dual_iso (order_dual α)
  (order_dual α)).symm.to_order_embedding.to_order_hom.comp h.dual

end eqn

section prev_next
variables [complete_lattice α] (f : α →o α)

lemma gfp_const_inf_le (x : α) : gfp (const α x ⊓ f) ≤ x :=
gfp_le _ $ λ b hb, hb.trans inf_le_left

/-- Previous fixed point of a monotone map. If `f` is a monotone self-map of a complete lattice and
`x` is a point such that `f x ≤ x`, then `f.prev_fixed x hx` is the greatest fixed point of `f`
that is less than or equal to `x`. -/
def prev_fixed (x : α) (hx : f x ≤ x) : fixed_points f :=
⟨gfp (const α x ⊓ f),
  calc f (gfp (const α x ⊓ f)) = x ⊓ f (gfp (const α x ⊓ f)) :
    eq.symm $ inf_of_le_right $ (f.mono $ f.gfp_const_inf_le x).trans hx
  ... = gfp (const α x ⊓ f) : (const α x ⊓ f).map_gfp ⟩

/-- Next fixed point of a monotone map. If `f` is a monotone self-map of a complete lattice and
`x` is a point such that `x ≤ f x`, then `f.next_fixed x hx` is the least fixed point of `f`
that is greater than or equal to `x`. -/
def next_fixed (x : α) (hx : x ≤ f x) : fixed_points f :=
{ val := (const α x ⊔ f).lfp,
  .. f.dual.prev_fixed x hx }

lemma prev_fixed_le {x : α} (hx : f x ≤ x) : ↑(f.prev_fixed x hx) ≤ x :=
f.gfp_const_inf_le x

lemma le_next_fixed {x : α} (hx : x ≤ f x) : x ≤ f.next_fixed x hx :=
f.dual.prev_fixed_le hx

lemma next_fixed_le {x : α} (hx : x ≤ f x) {y : fixed_points f} (h : x ≤ y) :
  f.next_fixed x hx ≤ y :=
subtype.coe_le_coe.1 $ lfp_le _ $ sup_le h y.2.le

@[simp] lemma next_fixed_le_iff {x : α} (hx : x ≤ f x) {y : fixed_points f} :
  f.next_fixed x hx ≤ y ↔ x ≤ y :=
⟨λ h, (f.le_next_fixed hx).trans h, f.next_fixed_le hx⟩

@[simp]

lemma le_prev_fixed {x : α} (hx : f x ≤ x) {y : fixed_points f} (h : ↑y ≤ x) :
  y ≤ f.prev_fixed x hx :=
(f.le_prev_fixed_iff hx).2 h

lemma le_map_sup_fixed_points (x y : fixed_points f) : (x ⊔ y : α) ≤ f (x ⊔ y) :=
calc (x ⊔ y : α) = f x ⊔ f y : congr_arg2 (⊔) x.2.symm y.2.symm
             ... ≤ f (x ⊔ y) : f.mono.le_map_sup x y

lemma map_inf_fixed_points_le (x y : fixed_points f) : f (x ⊓ y) ≤ x ⊓ y :=
f.dual.le_map_sup_fixed_points x y

lemma le_map_Sup_subset_fixed_points (A : set α) (hA : A ⊆ fixed_points f) : Sup A ≤ f (Sup A) :=
Sup_le $ λ x hx, hA hx ▸ (f.mono $ le_Sup hx)

lemma map_Inf_subset_fixed_points_le (A : set α) (hA : A ⊆ fixed_points f) : f (Inf A) ≤ Inf A :=
le_Inf $ λ x hx, (hA hx) ▸ (f.mono $ Inf_le hx)

end prev_next

end order_hom

namespace fixed_points

open order_hom

variables [complete_lattice α] (f : α →o α)

instance : semilattice_sup (fixed_points f) :=
{ sup := λ x y, f.next_fixed (x ⊔ y) (f.le_map_sup_fixed_points x y),
  le_sup_left := λ x y, subtype.coe_le_coe.1 $ le_sup_left.trans (f.le_next_fixed _),
  le_sup_right := λ x y, subtype.coe_le_coe.1 $ le_sup_right.trans (f.le_next_fixed _),
  sup_le := λ x y z hxz hyz, f.next_fixed_le _ $ sup_le hxz hyz,
  .. subtype.partial_order _ }

instance : semilattice_inf (fixed_points f) :=
{ inf := λ x y, f.prev_fixed (x ⊓ y) (f.map_inf_fixed_points_le x y),
  .. subtype.partial_order _, .. (order_dual.semilattice_inf (fixed_points f.dual))  }

instance : complete_semilattice_Sup (fixed_points f) :=
{ Sup := λ s, f.next_fixed (Sup (coe '' s))
    (f.le_map_Sup_subset_fixed_points (coe '' s) (λ z ⟨x, hx⟩, hx.2 ▸ x.2)),
  le_Sup := λ s x hx, subtype.coe_le_coe.1 $ le_trans (le_Sup $ set.mem_image_of_mem _ hx)
    (f.le_next_fixed _),
  Sup_le := λ s x hx, f.next_fixed_le _ $ Sup_le $ set.ball_image_iff.2 hx,
  .. subtype.partial_order _ }

instance : complete_semilattice_Inf (fixed_points f) :=
{ Inf := λ s, f.prev_fixed (Inf (coe '' s))
    (f.map_Inf_subset_fixed_points_le (coe '' s) (λ z ⟨x, hx⟩, hx.2 ▸ x.2)),
  le_Inf := λ s x hx, f.le_prev_fixed _ $ le_Inf $ set.ball_image_iff.2 hx,
  Inf_le := λ s x hx, subtype.coe_le_coe.1 $ le_trans (f.prev_fixed_le _)
    (Inf_le $ set.mem_image_of_mem _ hx),
  .. subtype.partial_order _ }

/-- **Knaster-Tarski Theorem**: The fixed points of `f` form a complete lattice. -/
instance : complete_lattice (fixed_points f) :=
{ top := ⟨f.gfp, f.is_fixed_pt_gfp⟩,
  bot := ⟨f.lfp, f.is_fixed_pt_lfp⟩,
  le_top := λ x, f.le_gfp x.2.ge,
  bot_le := λ x, f.lfp_le x.2.le,
  .. subtype.partial_order _,
  .. fixed_points.semilattice_sup f,
  .. fixed_points.semilattice_inf f,
  .. fixed_points.complete_semilattice_Sup f,
  .. fixed_points.complete_semilattice_Inf f }

end fixed_points


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang, Eric Wieser
-/
import ring_theory.localization.at_prime
import ring_theory.graded_algebra.basic

/-!
# Homogeneous Localization

## Notation
- `ι` is a commutative monoid;
- `R` is a commutative semiring;
- `A` is a commutative ring and an `R`-algebra;
- `𝒜 : ι → submodule R A` is the grading of `A`;
- `x : ideal A` is a prime ideal.

## Main definitions and results

This file constructs the subring of `Aₓ` where the numerator and denominator have the same grading,
i.e. `{a/b ∈ Aₓ | ∃ (i : ι), a ∈ 𝒜ᵢ ∧ b ∈ 𝒜ᵢ}`.

* `homogeneous_localization.num_denom_same_deg`: a structure with a numerator and denominator field
  where they are required to have the same grading.

However `num_denom_same_deg 𝒜 x` cannot have a ring structure for many reasons, for example if `c`
is a `num_denom_same_deg`, then generally, `c + (-c)` is not necessarily `0` for degree reasons ---
`0` is considered to have grade zero (see `deg_zero`) but `c + (-c)` has the same degree as `c`. To
circumvent this, we quotient `num_denom_same_deg 𝒜 x` by the kernel of `c ↦ c.num / c.denom`.

* `homogeneous_localization.num_denom_same_deg.embedding` : for `x : prime ideal of A` and any
  `c : num_denom_same_deg 𝒜 x`, or equivalent a numerator and a denominator of the same degree,
  we get an element `c.num / c.denom` of `Aₓ`.
* `homogeneous_localization`: `num_denom_same_deg 𝒜 x` quotiented by kernel of `embedding 𝒜 x`.
* `homogeneous_localization.val`: if `f : homogeneous_localization 𝒜 x`, then `f.val` is an element
  of `Aₓ`. In another word, one can view `homogeneous_localization 𝒜 x` as a subring of `Aₓ`
  through `homogeneous_localization.val`.
* `homogeneous_localization.num`: if `f : homogeneous_localization 𝒜 x`, then `f.num : A` is the
  numerator of `f`.
* `homogeneous_localization.num`: if `f : homogeneous_localization 𝒜 x`, then `f.denom : A` is the
  denominator of `f`.
* `homogeneous_localization.deg`: if `f : homogeneous_localization 𝒜 x`, then `f.deg : ι` is the
  degree of `f` such that `f.num ∈ 𝒜 f.deg` and `f.denom ∈ 𝒜 f.deg`
  (see `homogeneous_localization.num_mem` and `homogeneous_localization.denom_mem`).
* `homogeneous_localization.num_mem`: if `f : homogeneous_localization 𝒜 x`, then `f.num_mem` is a
  proof that `f.num ∈ f.deg`.
* `homogeneous_localization.denom_mem`: if `f : homogeneous_localization 𝒜 x`, then `f.denom_mem`
  is a proof that `f.denom ∈ f.deg`.
* `homogeneous_localization.eq_num_div_denom`: if `f : homogeneous_localization 𝒜 x`, then
  `f.val : Aₓ` is equal to `f.num / f.denom`.

* `homogeneous_localization.local_ring`: `homogeneous_localization 𝒜 x` is a local ring.

## References

* [Robin Hartshorne, *Algebraic Geometry*][Har77]

-/

noncomputable theory

open_locale direct_sum big_operators pointwise
open direct_sum set_like

variables {ι R A: Type*}
variables [add_comm_monoid ι] [decidable_eq ι]
variables [comm_ring R] [comm_ring A] [algebra R A]
variables (𝒜 : ι → submodule R A) [graded_algebra 𝒜]
variables (x : ideal A) [ideal.is_prime x]

local notation `at ` x := localization.at_prime x

namespace homogeneous_localization

section
/--
Let `x` be a prime ideal, then `num_denom_same_deg 𝒜 x` is a structure with a numerator and a
denominator with same grading such that the denominator is not contained in `x`.
-/
@[nolint has_inhabited_instance]
structure num_denom_same_deg :=
(deg : ι)
(num denom : 𝒜 deg)
(denom_not_mem : (denom : A) ∉ x)

end

namespace num_denom_same_deg

open set_like.graded_monoid submodule

variable {𝒜}
@[ext] lemma ext {c1 c2 : num_denom_same_deg 𝒜 x} (hdeg : c1.deg = c2.deg)
  (hnum : (c1.num : A) = c2.num) (hdenom : (c1.denom : A) = c2.denom) :
  c1 = c2 :=
begin
  rcases c1 with ⟨i1, ⟨n1, hn1⟩, ⟨d1, hd1⟩, h1⟩,
  rcases c2 with ⟨i2, ⟨n2, hn2⟩, ⟨d2, hd2⟩, h2⟩,
  dsimp only [subtype.coe_mk] at *,
  simp only,
  exact ⟨hdeg, by subst hdeg; subst hnum, by subst hdeg; subst hdenom⟩,
end

instance : has_one (num_denom_same_deg 𝒜 x) :=
{ one :=
  { deg := 0,
    num := ⟨1, one_mem⟩,
    denom := ⟨1, one_mem⟩,
    denom_not_mem := λ r, (infer_instance : x.is_prime).ne_top $ x.eq_top_iff_one.mpr r } }

@[simp] lemma deg_one : (1 : num_denom_same_deg 𝒜 x).deg = 0 := rfl
@[simp] lemma num_one : ((1 : num_denom_same_deg 𝒜 x).num : A) = 1 := rfl
@[simp] lemma denom_one : ((1 : num_denom_same_deg 𝒜 x).denom : A) = 1 := rfl

instance : has_zero (num_denom_same_deg 𝒜 x) :=
{ zero := ⟨0, 0, ⟨1, one_mem⟩, λ r, (infer_instance : x.is_prime).ne_top $ x.eq_top_iff_one.mpr r⟩ }

@[simp] lemma deg_zero : (0 : num_denom_same_deg 𝒜 x).deg = 0 := rfl
@[simp] lemma num_zero : (0 : num_denom_same_deg 𝒜 x).num = 0 := rfl
@[simp] lemma denom_zero : ((0 : num_denom_same_deg 𝒜 x).denom : A) = 1 := rfl

instance : has_mul (num_denom_same_deg 𝒜 x) :=
{ mul := λ p q,
  { deg := p.deg + q.deg,
    num := ⟨p.num * q.num, mul_mem p.num.prop q.num.prop⟩,
    denom := ⟨p.denom * q.denom, mul_mem p.denom.prop q.denom.prop⟩,
    denom_not_mem := λ r, or.elim
      ((infer_instance : x.is_prime).mem_or_mem r) p.denom_not_mem q.denom_not_mem } }

@[simp] lemma deg_mul (c1 c2 : num_denom_same_deg 𝒜 x) : (c1 * c2).deg = c1.deg + c2.deg := rfl
@[simp] lemma num_mul (c1 c2 : num_denom_same_deg 𝒜 x) :
  ((c1 * c2).num : A) = c1.num * c2.num := rfl
@[simp] lemma denom_mul (c1 c2 : num_denom_same_deg 𝒜 x) :
  ((c1 * c2).denom : A) = c1.denom * c2.denom := rfl

instance : has_add (num_denom_same_deg 𝒜 x) :=
{ add := λ c1 c2,
  { deg := c1.deg + c2.deg,
    num := ⟨c1.denom * c2.num + c2.denom * c1.num,
      add_mem _ (mul_mem c1.denom.2 c2.num.2)
        (add_comm c2.deg c1.deg ▸ mul_mem c2.denom.2 c1.num.2)⟩,
    denom := ⟨c1.denom * c2.denom, mul_mem c1.denom.2 c2.denom.2⟩,
    denom_not_mem := λ r, or.elim
      ((infer_instance : x.is_prime).mem_or_mem r) c1.denom_not_mem c2.denom_not_mem } }

@[simp] lemma deg_add (c1 c2 : num_denom_same_deg 𝒜 x) : (c1 + c2).deg = c1.deg + c2.deg := rfl
@[simp] lemma num_add (c1 c2 : num_denom_same_deg 𝒜 x) :
  ((c1 + c2).num : A) = c1.denom * c2.num + c2.denom * c1.num := rfl
@[simp] lemma denom_add (c1 c2 : num_denom_same_deg 𝒜 x) :
  ((c1 + c2).denom : A) = c1.denom * c2.denom := rfl

instance : has_neg (num_denom_same_deg 𝒜 x) :=
{ neg := λ c, ⟨c.deg, ⟨-c.num, neg_mem _ c.num.2⟩, c.denom, c.denom_not_mem⟩ }

@[simp] lemma deg_neg (c : num_denom_same_deg 𝒜 x) : (-c).deg = c.deg := rfl
@[simp] lemma num_neg (c : num_denom_same_deg 𝒜 x) : ((-c).num : A) = -c.num := rfl
@[simp] lemma denom_neg (c : num_denom_same_deg 𝒜 x) : ((-c).denom : A) = c.denom := rfl

instance : comm_monoid (num_denom_same_deg 𝒜 x) :=
{ one := 1,
  mul := (*),
  mul_assoc := λ c1 c2 c3, ext _ (add_assoc _ _ _) (mul_assoc _ _ _) (mul_assoc _ _ _),
  one_mul := λ c, ext _ (zero_add _) (one_mul _) (one_mul _),
  mul_one := λ c, ext _ (add_zero _) (mul_one _) (mul_one _),
  mul_comm := λ c1 c2, ext _ (add_comm _ _) (mul_comm _ _) (mul_comm _ _) }

instance : has_pow (num_denom_same_deg 𝒜 x) ℕ :=
{ pow := λ c n, ⟨n • c.deg, ⟨c.num ^ n, pow_mem n c.num.2⟩, ⟨c.denom ^ n, pow_mem n c.denom.2⟩,
    begin
      cases n,
      { simp only [pow_zero],
        exact λ r, (infer_instance : x.is_prime).ne_top $ (ideal.eq_top_iff_one _).mpr r, },
      { exact λ r, c.denom_not_mem $
          ((infer_instance : x.is_prime).pow_mem_iff_mem n.succ (nat.zero_lt_succ _)).mp r }
    end⟩ }

@[simp] lemma deg_pow (c : num_denom_same_deg 𝒜 x) (n : ℕ) : (c ^ n).deg = n • c.deg := rfl
@[simp] lemma num_pow (c : num_denom_same_deg 𝒜 x) (n : ℕ) : ((c ^ n).num : A) = c.num ^ n := rfl
@[simp] lemma denom_pow (c : num_denom_same_deg 𝒜 x) (n : ℕ) :
  ((c ^ n).denom : A) = c.denom ^ n := rfl

section has_scalar
variables {α : Type*} [has_scalar α R] [has_scalar α A] [is_scalar_tower α R A]

instance : has_scalar α (num_denom_same_deg 𝒜 x) :=
{ smul := λ m c, ⟨c.deg, m • c.num, c.denom, c.denom_not_mem⟩ }

@[simp] lemma deg_smul (c : num_denom_same_deg 𝒜 x) (m : α) : (m • c).deg = c.deg := rfl
@[simp] lemma num_smul (c : num_denom_same_deg 𝒜 x) (m : α) : ((m • c).num : A) = m • c.num := rfl
@[simp] lemma denom_smul (c : num_denom_same_deg 𝒜 x) (m : α) :
  ((m • c).denom : A) = c.denom := rfl

end has_scalar

variable (𝒜)

/--
For `x : prime ideal of A` and any `p : num_denom_same_deg 𝒜 x`, or equivalent a numerator and a
denominator of the same degree, we get an element `p.num / p.denom` of `Aₓ`.
-/
def embedding (p : num_denom_same_deg 𝒜 x) : at x :=
localization.mk p.num ⟨p.denom, p.denom_not_mem⟩

end num_denom_same_deg

end homogeneous_localization

/--
For `x : prime ideal of A`, `homogeneous_localization 𝒜 x` is `num_denom_same_deg 𝒜 x` modulo the
kernel of `embedding 𝒜 x`. This is essentially the subring of `Aₓ` where the numerator and
denominator share the same grading.
-/
@[nolint has_inhabited_instance]
def homogeneous_localization : Type* :=
quotient (setoid.ker $ homogeneous_localization.num_denom_same_deg.embedding 𝒜 x)

namespace homogeneous_localization

open homogeneous_localization homogeneous_localization.num_denom_same_deg

variables {𝒜} {x}
/--
View an element of `homogeneous_localization 𝒜 x` as an element of `Aₓ` by forgetting that the
numerator and denominator are of the same grading.
-/
def val (y : homogeneous_localization 𝒜 x) : at x :=
quotient.lift_on' y (num_denom_same_deg.embedding 𝒜 x) $ λ _ _, id

@[simp] lemma val_mk' (i : num_denom_same_deg 𝒜 x) :
  val (quotient.mk' i) = localization.mk i.num ⟨i.denom, i.denom_not_mem⟩ :=
rfl

variable (x)
lemma val_injective :
  function.injective (@homogeneous_localization.val _ _ _ _ _ _ _ _ 𝒜 _ x _) :=
λ a b, quotient.rec_on_subsingleton₂' a b $ λ a b h, quotient.sound' h

instance has_pow : has_pow (homogeneous_localization 𝒜 x) ℕ :=
{ pow := λ z n, (quotient.map' (^ n)
    (λ c1 c2 (h : localization.mk _ _ = localization.mk _ _), begin
      change localization.mk _ _ = localization.mk _ _,
      simp only [num_pow, denom_pow],
      convert congr_arg (λ z, z ^ n) h;
      erw localization.mk_pow;
      refl,
    end) : homogeneous_localization 𝒜 x → homogeneous_localization 𝒜 x) z }

section has_scalar
variables {α : Type*} [has_scalar α R] [has_scalar α A] [is_scalar_tower α R A]
variables [is_scalar_tower α A A]

instance : has_scalar α (homogeneous_localization 𝒜 x) :=
{ smul := λ m, quotient.map' ((•) m)
    (λ c1 c2 (h : localization.mk _ _ = localization.mk _ _), begin
      change localization.mk _ _ = localization.mk _ _,
      simp only [num_smul, denom_smul],
      convert congr_arg (λ z : at x, m • z) h;
      rw localization.smul_mk;
      refl,
    end) }

@[simp] lemma smul_val (y : homogeneous_localization 𝒜 x) (n : α) :
  (n • y).val = n • y.val :=
begin
  induction y using quotient.induction_on,
  unfold homogeneous_localization.val has_scalar.smul,
  simp only [quotient.lift_on₂'_mk, quotient.lift_on'_mk],
  change localization.mk _ _ = n • localization.mk _ _,
  dsimp only,
  rw localization.smul_mk,
  congr' 1,
end

end has_scalar

instance : has_neg (homogeneous_localization 𝒜 x) :=
{ neg := quotient.map' has_neg.neg
    (λ c1 c2 (h : localization.mk _ _ = localization.mk _ _), begin
      change localization.mk _ _ = localization.mk _ _,
      simp only [num_neg, denom_neg, ←localization.neg_mk],
      exact congr_arg (λ c, -c) h
    end) }

instance : has_add (homogeneous_localization 𝒜 x) :=
{ add := quotient.map₂' (+) (λ c1 c2 (h : localization.mk _ _ = localization.mk _ _)
    c3 c4 (h' : localization.mk _ _ = localization.mk _ _), begin
    change localization.mk _ _ = localization.mk _ _,
    simp only [num_add, denom_add, ←localization.add_mk],
    convert congr_arg2 (+) h h';
    erw [localization.add_mk];
    refl
  end) }

instance : has_sub (homogeneous_localization 𝒜 x) :=
{ sub := λ z1 z2, z1 + (-z2) }

instance : has_mul (homogeneous_localization 𝒜 x) :=
{ mul := quotient.map₂' (*) (λ c1 c2 (h : localization.mk _ _ = localization.mk _ _)
    c3 c4 (h' : localization.mk _ _ = localization.mk _ _), begin
    change localization.mk _ _ = localization.mk _ _,
    simp only [num_mul, denom_mul],
    convert congr_arg2 (*) h h';
    erw [localization.mk_mul];
    refl,
  end) }

instance : has_one (homogeneous_localization 𝒜 x) :=
{ one := quotient.mk' 1 }

instance : has_zero (homogeneous_localization 𝒜 x) :=
{ zero := quotient.mk' 0 }

lemma zero_eq :
  (0 : homogeneous_localization 𝒜 x) = quotient.mk' 0 := rfl

lemma one_eq :
  (1 : homogeneous_localization 𝒜 x) = quotient.mk' 1 := rfl

variable {x}
lemma zero_val : (0 : homogeneous_localization 𝒜 x).val = 0 :=
localization.mk_zero _

lemma one_val : (1 : homogeneous_localization 𝒜 x).val = 1 :=
localization.mk_one

@[simp] lemma add_val (y1 y2 : homogeneous_localization 𝒜 x) :
  (y1 + y2).val = y1.val + y2.val :=
begin
  induction y1 using quotient.induction_on,
  induction y2 using quotient.induction_on,
  unfold homogeneous_localization.val has_add.add,
  simp only [quotient.lift_on₂'_mk, quotient.lift_on'_mk],
  change localization.mk _ _ = localization.mk _ _ + localization.mk _ _,
  dsimp only,
  rw [localization.add_mk],
  refl
end

@[simp] lemma mul_val (y1 y2 : homogeneous_localization 𝒜 x) :
  (y1 * y2).val = y1.val * y2.val :=
begin
  induction y1 using quotient.induction_on,
  induction y2 using quotient.induction_on,
  unfold homogeneous_localization.val has_mul.mul,
  simp only [quotient.lift_on₂'_mk, quotient.lift_on'_mk],
  change localization.mk _ _ = localization.mk _ _ * localization.mk _ _,
  dsimp only,
  rw [localization.mk_mul],
  refl,
end

@[simp] lemma neg_val (y : homogeneous_localization 𝒜 x) :
  (-y).val = -y.val :=
begin
  induction y using quotient.induction_on,
  unfold homogeneous_localization.val has_neg.neg,
  simp only [quotient.lift_on₂'_mk, quotient.lift_on'_mk],
  change localization.mk _ _ = - localization.mk _ _,
  dsimp only,
  rw [localization.neg_mk],
  refl,
end

@[simp] lemma sub_val (y1 y2 : homogeneous_localization 𝒜 x) :
  (y1 - y2).val = y1.val - y2.val :=
by rw [show y1 - y2 = y1 + (-y2), from rfl, add_val, neg_val]; refl

@[simp] lemma pow_val (y : homogeneous_localization 𝒜 x) (n : ℕ) :
  (y ^ n).val = y.val ^ n :=
begin
  induction y using quotient.induction_on,
  unfold homogeneous_localization.val has_pow.pow,
  simp only [quotient.lift_on₂'_mk, quotient.lift_on'_mk],
  change localization.mk _ _ = (localization.mk _ _) ^ n,
  rw localization.mk_pow,
  dsimp only,
  congr' 1,
end

instance : comm_ring (homogeneous_localization 𝒜 x) :=
(homogeneous_localization.val_injective x).comm_ring _ zero_val one_val add_val mul_val neg_val
  sub_val (λ z n, smul_val x z n) (λ z n, smul_val x z n) pow_val

end homogeneous_localization

namespace homogeneous_localization

open homogeneous_localization homogeneous_localization.num_denom_same_deg

variables {𝒜} {x}

/-- numerator of an element in `homogeneous_localization x`-/
def num (f : homogeneous_localization 𝒜 x) : A :=
(quotient.out' f).num

/-- denominator of an element in `homogeneous_localization x`-/
def denom (f : homogeneous_localization 𝒜 x) : A :=
(quotient.out' f).denom

/-- For an element in `homogeneous_localization x`, degree is the natural number `i` such that
  `𝒜 i` contains both numerator and denominator. -/
def deg (f : homogeneous_localization 𝒜 x) : ι :=
(quotient.out' f).deg

lemma denom_not_mem (f : homogeneous_localization 𝒜 x) :
  f.denom ∉ x :=
(quotient.out' f).denom_not_mem

lemma num_mem (f : homogeneous_localization 𝒜 x) : f.num ∈ 𝒜 f.deg :=
(quotient.out' f).num.2

lemma denom_mem (f : homogeneous_localization 𝒜 x) : f.denom ∈ 𝒜 f.deg :=
(quotient.out' f).denom.2

lemma eq_num_div_denom (f : homogeneous_localization 𝒜 x) :
  f.val = localization.mk f.num ⟨f.denom, f.denom_not_mem⟩ :=
begin
  have := (quotient.out_eq' f),
  apply_fun homogeneous_localization.val at this,
  rw ← this,
  unfold homogeneous_localization.val,
  simp only [quotient.lift_on'_mk'],
  refl,
end

lemma ext_iff_val (f g : homogeneous_localization 𝒜 x) : f = g ↔ f.val = g.val :=
{ mp := λ h, h ▸ rfl,
  mpr := λ h, begin
    induction f using quotient.induction_on,
    induction g using quotient.induction_on,
    rw quotient.eq,
    unfold homogeneous_localization.val at h,
    simpa only [quotient.lift_on'_mk] using h,
  end }

lemma is_unit_iff_is_unit_val (f : homogeneous_localization 𝒜 x) :
  is_unit f.val ↔ is_unit f :=
⟨λ h1, begin
  rcases h1 with ⟨⟨a, b, eq0, eq1⟩, (eq2 : a = f.val)⟩,
  rw eq2 at eq0 eq1,
  clear' a eq2,
  induction b using localization.induction_on with data,
  rcases data with ⟨a, ⟨b, hb⟩⟩,
  dsimp only at eq0 eq1,
  have b_f_denom_not_mem : b * f.denom ∈ x.prime_compl := λ r, or.elim
    (ideal.is_prime.mem_or_mem infer_instance r) (λ r2, hb r2) (λ r2, f.denom_not_mem r2),
  rw [f.eq_num_div_denom, localization.mk_mul,
    show (⟨b, hb⟩ : x.prime_compl) * ⟨f.denom, _⟩ = ⟨b * f.denom, _⟩, from rfl,
    show (1 : at x) = localization.mk 1 1, by erw localization.mk_self 1,
    localization.mk_eq_mk', is_localization.eq] at eq1,
  rcases eq1 with ⟨⟨c, hc⟩, eq1⟩,
  simp only [← subtype.val_eq_coe] at eq1,
  change a * f.num * 1 * c = _ at eq1,
  simp only [one_mul, mul_one] at eq1,
  have mem1 : a * f.num * c ∈ x.prime_compl :=
    eq1.symm ▸ λ r, or.elim (ideal.is_prime.mem_or_mem infer_instance r) (by tauto)(by tauto),
  have mem2 : f.num ∉ x,
  { contrapose! mem1,
    erw [not_not],
    exact ideal.mul_mem_right _ _ (ideal.mul_mem_left _ _ mem1), },
  refine ⟨⟨f, quotient.mk' ⟨f.deg, ⟨f.denom, f.denom_mem⟩, ⟨f.num, f.num_mem⟩, mem2⟩, _, _⟩, rfl⟩;
  simp only [ext_iff_val, mul_val, val_mk', ← subtype.val_eq_coe, f.eq_num_div_denom,
    localization.mk_mul, one_val];
  convert localization.mk_self _;
  simpa only [mul_comm]
end, λ ⟨⟨_, b, eq1, eq2⟩, rfl⟩, begin
  simp only [ext_iff_val, mul_val, one_val] at eq1 eq2,
  exact ⟨⟨f.val, b.val, eq1, eq2⟩, rfl⟩
end⟩

instance : local_ring (homogeneous_localization 𝒜 x) :=
{ exists_pair_ne := ⟨0, 1, λ r, by simpa [ext_iff_val, zero_val, one_val, zero_ne_one] using r⟩,
  is_local := λ a, begin
    simp only [← is_unit_iff_is_unit_val, sub_val, one_val],
    induction a using quotient.induction_on',
    simp only [homogeneous_localization.val_mk', ← subtype.val_eq_coe],
    by_cases mem1 : a.num.1 ∈ x,
    { right,
      have : a.denom.1 - a.num.1 ∈ x.prime_compl := λ h, a.denom_not_mem
        ((sub_add_cancel a.denom.val a.num.val) ▸ ideal.add_mem _ h mem1 : a.denom.1 ∈ x),
      apply is_unit_of_mul_eq_one _ (localization.mk a.denom.1 ⟨a.denom.1 - a.num.1, this⟩),
      simp only [sub_mul, localization.mk_mul, one_mul, localization.sub_mk, ← subtype.val_eq_coe,
        submonoid.coe_mul],
      convert localization.mk_self _,
      simp only [← subtype.val_eq_coe, submonoid.coe_mul],
      ring, },
    { left,
      change _ ∈ x.prime_compl at mem1,
      apply is_unit_of_mul_eq_one _ (localization.mk a.denom.1 ⟨a.num.1, mem1⟩),
      rw [localization.mk_mul],
      convert localization.mk_self _,
      simpa only [mul_comm], },
end }

end homogeneous_localization


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

/-!
# McShane integrability vs Bochner integrability

In this file we prove that any Bochner integrable function is McShane integrable (hence, it is
Henstock and `⊥` integrable) with the same integral. The proof is based on
[Russel A. Gordon, *The integrals of Lebesgue, Denjoy, Perron, and Henstock*][Gordon55].

## Tags

integral, McShane integral, Bochner integral
-/

open_locale classical nnreal ennreal topological_space big_operators

universes u v

variables {ι : Type u} {E : Type v} [fintype ι] [normed_group E] [normed_space ℝ E]

open measure_theory metric set finset filter box_integral

namespace box_integral

/-- The indicator function of a measurable set is McShane integrable with respect to any
locally-finite measure. -/
lemma has_integral_indicator_const (l : integration_params) (hl : l.bRiemann = ff)
  {s : set (ι → ℝ)} (hs : measurable_set s) (I : box ι) (y : E)
  (μ : measure (ι → ℝ)) [is_locally_finite_measure μ] :
  has_integral.{u v v} I l (s.indicator (λ _, y)) μ.to_box_additive.to_smul
    ((μ (s ∩ I)).to_real • y) :=
begin
  refine has_integral_of_mul (∥y∥) (λ ε ε0, _),
  lift ε to ℝ≥0 using ε0.le, rw nnreal.coe_pos at ε0,
  /- First we choose a closed set `F ⊆ s ∩ I.Icc` and an open set `U ⊇ s` such that
  both `(s ∩ I.Icc) \ F` and `U \ s` have measuer less than `ε`. -/
  have A : μ (s ∩ I.Icc) ≠ ∞,
    from ((measure_mono $ set.inter_subset_right _ _).trans_lt (I.measure_Icc_lt_top μ)).ne,
  have B : μ (s ∩ I) ≠ ∞,
    from ((measure_mono $ set.inter_subset_right _ _).trans_lt (I.measure_coe_lt_top μ)).ne,
  obtain ⟨F, hFs, hFc, hμF⟩ : ∃ F ⊆ s ∩ I.Icc, is_closed F ∧ μ ((s ∩ I.Icc) \ F) < ε,
    from (hs.inter I.measurable_set_Icc).exists_is_closed_diff_lt A (ennreal.coe_pos.2 ε0).ne',
  obtain ⟨U, hsU, hUo, hUt, hμU⟩ : ∃ U ⊇ s ∩ I.Icc, is_open U ∧ μ U < ∞ ∧ μ (U \ (s ∩ I.Icc)) < ε,
    from (hs.inter I.measurable_set_Icc).exists_is_open_diff_lt A (ennreal.coe_pos.2 ε0).ne',
  /- Then we choose `r` so that `closed_ball x (r x) ⊆ U` whenever `x ∈ s ∩ I.Icc` and
  `closed_ball x (r x)` is disjoint with `F` otherwise. -/
  have : ∀ x ∈ s ∩ I.Icc, ∃ r : Ioi (0 : ℝ), closed_ball x r ⊆ U,
    from λ x hx, subtype.exists'.1 (nhds_basis_closed_ball.mem_iff.1 (hUo.mem_nhds $ hsU hx)),
  choose! rs hrsU,
  have : ∀ x ∈ I.Icc \ s, ∃ r : Ioi (0 : ℝ), closed_ball x r ⊆ Fᶜ,
    from λ x hx, subtype.exists'.1 (nhds_basis_closed_ball.mem_iff.1 (hFc.is_open_compl.mem_nhds $
      λ hx', hx.2 (hFs hx').1)),
  choose! rs' hrs'F,
  set r : (ι → ℝ) → Ioi (0 : ℝ) := s.piecewise rs rs',
  refine ⟨λ c, r, λ c, l.r_cond_of_bRiemann_eq_ff hl, λ c π hπ hπp, _⟩, rw mul_comm,
  /- Then the union of boxes `J ∈ π` such that `π.tag ∈ s` includes `F` and is included by `U`,
  hence its measure is `ε`-close to the measure of `s`. -/
  dsimp [integral_sum],
  simp only [mem_closed_ball, dist_eq_norm, ← indicator_smul_apply, sum_indicator_eq_sum_filter,
    ← sum_smul, ← sub_smul, norm_smul, real.norm_eq_abs, ← prepartition.filter_boxes,
    ← prepartition.measure_Union_to_real],
  refine mul_le_mul_of_nonneg_right _ (norm_nonneg y),
  set t := (π.to_prepartition.filter (λ J, π.tag J ∈ s)).Union,
  change abs ((μ t).to_real - (μ (s ∩ I)).to_real) ≤ ε,
  have htU : t ⊆ U ∩ I,
  { simp only [t, prepartition.Union_def, Union_subset_iff, prepartition.mem_filter, and_imp],
    refine λ J hJ hJs x hx, ⟨hrsU _ ⟨hJs, π.tag_mem_Icc J⟩  _, π.le_of_mem' J hJ hx⟩,
    simpa only [r, s.piecewise_eq_of_mem _ _ hJs] using hπ.1 J hJ (box.coe_subset_Icc hx) },
  refine abs_sub_le_iff.2 ⟨_, _⟩,
  { refine (ennreal.le_to_real_sub B).trans (ennreal.to_real_le_coe_of_le_coe _),
    refine (tsub_le_tsub (measure_mono htU) le_rfl).trans (le_measure_diff.trans _),
    refine (measure_mono $ λ x hx, _).trans hμU.le,
    exact ⟨hx.1.1, λ hx', hx.2 ⟨hx'.1, hx.1.2⟩⟩ },
  { have hμt : μ t ≠ ∞ :=
      ((measure_mono (htU.trans (inter_subset_left _ _))).trans_lt hUt).ne,
    refine (ennreal.le_to_real_sub hμt).trans (ennreal.to_real_le_coe_of_le_coe _),
    refine le_measure_diff.trans ((measure_mono _).trans hμF.le),
    rintro x ⟨⟨hxs, hxI⟩, hxt⟩,
    refine ⟨⟨hxs, box.coe_subset_Icc hxI⟩, λ hxF, hxt _⟩,
    simp only [t, prepartition.Union_def, prepartition.mem_filter, set.mem_Union, exists_prop],
    rcases hπp x hxI with ⟨J, hJπ, hxJ⟩,
    refine ⟨J, ⟨hJπ, _⟩, hxJ⟩,
    contrapose hxF,
    refine hrs'F _ ⟨π.tag_mem_Icc J, hxF⟩ _,
    simpa only [r, s.piecewise_eq_of_not_mem _ _ hxF] using hπ.1 J hJπ (box.coe_subset_Icc hxJ) }
end

/-- If `f` is a.e. equal to zero on a rectangular box, then it has McShane integral zero on this
box. -/
lemma has_integral_zero_of_ae_eq_zero {l : integration_params} {I : box ι} {f : (ι → ℝ) → E}
  {μ : measure (ι → ℝ)} [is_locally_finite_measure μ] (hf : f =ᵐ[μ.restrict I] 0)
  (hl : l.bRiemann = ff) :
  has_integral.{u v v} I l f μ.to_box_additive.to_smul 0 :=
begin
  /- Each set `{x | n < ∥f x∥ ≤ n + 1}`, `n : ℕ`, has measure zero. We cover it by an open set of
  measure less than `ε / 2 ^ n / (n + 1)`. Then the norm of the integral sum is less than `ε`. -/
  refine has_integral_iff.2 (λ ε ε0, _),
  lift ε to ℝ≥0 using ε0.lt.le, rw [gt_iff_lt, nnreal.coe_pos] at ε0,
  rcases nnreal.exists_pos_sum_of_encodable ε0.ne' ℕ with ⟨δ, δ0, c, hδc, hcε⟩,
  haveI := fact.mk (I.measure_coe_lt_top μ),
  change μ.restrict I {x | f x ≠ 0} = 0 at hf,
  set N : (ι → ℝ) → ℕ := λ x, ⌈∥f x∥⌉₊,
  have N0 : ∀ {x}, N x = 0 ↔ f x = 0, by { intro x, simp [N] },
  have : ∀ n, ∃ U ⊇ N ⁻¹' {n}, is_open U ∧ μ.restrict I U < δ n / n,
  { refine λ n, (N ⁻¹' {n}).exists_is_open_lt_of_lt _ _,
    cases n,
    { simpa [ennreal.div_zero (ennreal.coe_pos.2 (δ0 _)).ne']
        using measure_lt_top (μ.restrict I) _ },
    { refine (measure_mono_null _ hf).le.trans_lt _,
      { exact λ x hxN hxf, n.succ_ne_zero ((eq.symm hxN).trans $ N0.2 hxf) },
      { simp [(δ0 _).ne'] } } },
  choose U hNU hUo hμU,
  have : ∀ x, ∃ r : Ioi (0 : ℝ), closed_ball x r ⊆ U (N x),
    from λ x, subtype.exists'.1 (nhds_basis_closed_ball.mem_iff.1 ((hUo _).mem_nhds (hNU _ rfl))),
  choose r hrU,
  refine ⟨λ _, r, λ c, l.r_cond_of_bRiemann_eq_ff hl, λ c π hπ hπp, _⟩,
  rw [dist_eq_norm, sub_zero, ← integral_sum_fiberwise (λ J, N (π.tag J))],
  refine le_trans _ (nnreal.coe_lt_coe.2 hcε).le,
  refine (norm_sum_le_of_le _ _).trans
    (sum_le_has_sum _ (λ n _, (δ n).2) (nnreal.has_sum_coe.2 hδc)),
  rintro n -,
  dsimp [integral_sum],
  have : ∀ J ∈ π.filter (λ J, N (π.tag J) = n),
    ∥(μ ↑J).to_real • f (π.tag J)∥ ≤ (μ J).to_real * n,
  { intros J hJ, rw tagged_prepartition.mem_filter at hJ,
    rw [norm_smul, real.norm_eq_abs, abs_of_nonneg ennreal.to_real_nonneg],
    exact mul_le_mul_of_nonneg_left (hJ.2 ▸ nat.le_ceil _) ennreal.to_real_nonneg },
  refine (norm_sum_le_of_le _ this).trans _, clear this,
  rw [← sum_mul, ← prepartition.measure_Union_to_real],
  generalize hm : μ (π.filter (λ J, N (π.tag J) = n)).Union = m,
  have : m < δ n / n,
  { simp only [measure.restrict_apply (hUo _).measurable_set] at hμU,
    refine hm ▸ (measure_mono _).trans_lt (hμU _),
    simp only [set.subset_def, tagged_prepartition.mem_Union, exists_prop,
      tagged_prepartition.mem_filter],
    rintro x ⟨J, ⟨hJ, rfl⟩, hx⟩,
    exact ⟨hrU _ (hπ.1 _ hJ (box.coe_subset_Icc hx)), π.le_of_mem' J hJ hx⟩ },
  lift m to ℝ≥0 using ne_top_of_lt this,
  rw [ennreal.coe_to_real, ← nnreal.coe_nat_cast, ← nnreal.coe_mul, nnreal.coe_le_coe,
    ← ennreal.coe_le_coe, ennreal.coe_mul, ennreal.coe_nat, mul_comm],
  exact (mul_le_mul_left' this.le _).trans ennreal.mul_div_le
end

/-- If `f` has integral `y` on a box `I` with respect to a locally finite measure `μ` and `g` is
a.e. equal to `f` on `I`, then `g` has the same integral on `I`.  -/
lemma has_integral.congr_ae {l : integration_params} {I : box ι} {y : E} {f g : (ι → ℝ) → E}
  {μ : measure (ι → ℝ)} [is_locally_finite_measure μ]
  (hf : has_integral.{u v v} I l f μ.to_box_additive.to_smul y)
  (hfg : f =ᵐ[μ.restrict I] g) (hl : l.bRiemann = ff) :
  has_integral.{u v v} I l g μ.to_box_additive.to_smul y :=
begin
  have : (g - f) =ᵐ[μ.restrict I] 0, from hfg.mono (λ x hx, sub_eq_zero.2 hx.symm),
  simpa using hf.add (has_integral_zero_of_ae_eq_zero this hl)
end

end box_integral

namespace measure_theory

namespace simple_func

/-- A simple function is McShane integrable w.r.t. any locally finite measure. -/
lemma has_box_integral (f : simple_func (ι → ℝ) E) (μ : measure (ι → ℝ))
  [is_locally_finite_measure μ] (I : box ι) (l : integration_params) (hl : l.bRiemann = ff) :
  has_integral.{u v v} I l f μ.to_box_additive.to_smul (f.integral (μ.restrict I)) :=
begin
  induction f using measure_theory.simple_func.induction with y s hs f g hd hfi hgi,
  { simpa [function.const, measure.restrict_apply hs]
      using box_integral.has_integral_indicator_const l hl hs I y μ },
  { letI := borel E, haveI : borel_space E := ⟨rfl⟩, haveI := fact.mk (I.measure_coe_lt_top μ),
    rw integral_add,
    exacts [hfi.add hgi, integrable_iff.2 $ λ _ _, measure_lt_top _ _,
      integrable_iff.2 $ λ _ _, measure_lt_top _ _] }
end

/-- For a simple function, its McShane (or Henstock, or `⊥`) box integral is equal to its
integral in the sense of `measure_theory.simple_func.integral`. -/
lemma box_integral_eq_integral (f : simple_func (ι → ℝ) E) (μ : measure (ι → ℝ))
  [is_locally_finite_measure μ] (I : box ι) (l : integration_params) (hl : l.bRiemann = ff) :
  box_integral.integral.{u v v} I l f μ.to_box_additive.to_smul = f.integral (μ.restrict I) :=
(f.has_box_integral μ I l hl).integral_eq

end simple_func

open topological_space

/-- If `f : ℝⁿ → E` is Bochner integrable w.r.t. a locally finite measure `μ` on a rectangular box
`I`, then it is McShane integrable on `I` with the same integral.  -/
lemma integrable_on.has_box_integral [second_countable_topology E] [measurable_space E]
  [borel_space E] [complete_space E] {f : (ι → ℝ) → E} {μ : measure (ι → ℝ)}
  [is_locally_finite_measure μ] {I : box ι} (hf : integrable_on f I μ) (l : integration_params)
  (hl : l.bRiemann = ff) :
  has_integral.{u v v} I l f μ.to_box_additive.to_smul (∫ x in I, f x ∂ μ) :=
begin
  /- First we replace an `ae_measurable` function by a measurable one. -/
  rcases hf.ae_measurable with ⟨g, hg, hfg⟩,
  rw integral_congr_ae hfg, have hgi : integrable_on g I μ := (integrable_congr hfg).1 hf,
  refine box_integral.has_integral.congr_ae _ hfg.symm hl,
  clear_dependent f,
  /- Now consider the sequence of simple functions `simple_func.approx_on g hg univ 0 trivial`
  approximating `g`. Recall some properties of this sequence. -/
  set f : ℕ → simple_func (ι → ℝ) E := simple_func.approx_on g hg univ 0 trivial,
  have hfi : ∀ n, integrable_on (f n) I μ, from simple_func.integrable_approx_on_univ hg hgi,
  have hfi' := λ n, ((f n).has_box_integral μ I l hl).integrable,
  have hfgi : tendsto (λ n, (f n).integral (μ.restrict I)) at_top (𝓝 $ ∫ x in I, g x ∂μ),
    from tendsto_integral_approx_on_univ_of_measurable hg hgi,
  have hfg_mono : ∀ x {m n}, m ≤ n → ∥f n x - g x∥ ≤ ∥f m x - g x∥,
  { intros x m n hmn,
    rw [← dist_eq_norm, ← dist_eq_norm, dist_nndist, dist_nndist, nnreal.coe_le_coe,
      ← ennreal.coe_le_coe, ← edist_nndist, ← edist_nndist],
    exact simple_func.edist_approx_on_mono hg _ x hmn },
  /- Now consider `ε > 0`. We need to find `r` such that for any tagged partition subordinate
  to `r`, the integral sum is `(μ I + 1 + 1) * ε`-close to the Bochner integral. -/
  refine has_integral_of_mul ((μ I).to_real + 1 + 1) (λ ε ε0, _),
  lift ε to ℝ≥0 using ε0.le, rw nnreal.coe_pos at ε0, have ε0' := ennreal.coe_pos.2 ε0,
  /- Choose `N` such that the integral of `∥f N x - g x∥` is less than or equal to `ε`. -/
  obtain ⟨N₀, hN₀⟩ : ∃ N : ℕ, ∫ x in I, ∥f N x - g x∥ ∂μ ≤ ε,
  { have : tendsto (λ n, ∫⁻ x in I, ∥f n x - g x∥₊ ∂μ) at_top (𝓝 0),
      from simple_func.tendsto_approx_on_univ_L1_nnnorm hg hgi,
    refine (this.eventually (ge_mem_nhds ε0')).exists.imp (λ N hN, _),
    exact integral_coe_le_of_lintegral_coe_le hN },
  /- For each `x`, we choose `Nx x ≥ N₀` such that `dist (f Nx x) (g x) ≤ ε`. -/
  have : ∀ x, ∃ N₁, N₀ ≤ N₁ ∧ dist (f N₁ x) (g x) ≤ ε,
  { intro x,
    have : tendsto (λ n, f n x) at_top (𝓝 $ g x),
      from simple_func.tendsto_approx_on hg _ (subset_closure trivial),
    exact ((eventually_ge_at_top N₀).and $ this $ closed_ball_mem_nhds _ ε0).exists },
  choose Nx hNx hNxε,
  /- We also choose a convergent series with `∑' i : ℕ, δ i < ε`. -/
  rcases nnreal.exists_pos_sum_of_encodable ε0.ne' ℕ with ⟨δ, δ0, c, hδc, hcε⟩,
  /- Since each simple function `fᵢ` is integrable, there exists `rᵢ : ℝⁿ → (0, ∞)` such that
  the integral sum of `f` over any tagged prepartition is `δᵢ`-close to the sum of integrals
  of `fᵢ` over the boxes of this prepartition. For each `x`, we choose `r (Nx x)` as the radius
  at `x`. -/
  set r : ℝ≥0 → (ι → ℝ) → Ioi (0 : ℝ) := λ c x, (hfi' $ Nx x).convergence_r (δ $ Nx x) c x,
  refine ⟨r, λ c, l.r_cond_of_bRiemann_eq_ff hl, λ c π hπ hπp, _⟩,
  /- Now we prove the estimate in 3 "jumps": first we replace `g x` in the formula for the
  integral sum by `f (Nx x)`; then we replace each `μ J • f (Nx (π.tag J)) (π.tag J)`
  by the Bochner integral of `f (Nx (π.tag J)) x` over `J`, then we jump to the Bochner
  integral of `g`. -/
  refine (dist_triangle4 _ (∑ J in π.boxes, (μ J).to_real • f (Nx $ π.tag J) (π.tag J))
    (∑ J in π.boxes, ∫ x in J, f (Nx $ π.tag J) x ∂μ) _).trans _,
  rw [add_mul, add_mul, one_mul],
  refine add_le_add_three _ _ _,
  { /- Since each `f (Nx $ π.tag J)` is `ε`-close to `g (π.tag J)`, replacing the latter with
    the former in the formula for the integral sum changes the sum at most by `μ I * ε`. -/
    rw [← hπp.Union_eq, π.to_prepartition.measure_Union_to_real, sum_mul, integral_sum],
    refine dist_sum_sum_le_of_le _ (λ J hJ, _), dsimp,
    rw [dist_eq_norm, ← smul_sub, norm_smul, real.norm_eq_abs,
      abs_of_nonneg ennreal.to_real_nonneg],
    refine mul_le_mul_of_nonneg_left _ ennreal.to_real_nonneg,
    rw [← dist_eq_norm'], exact hNxε _ },
  { /- We group the terms of both sums by the values of `Nx (π.tag J)`.
    For each `N`, the sum of Bochner integrals over the boxes is equal
    to the sum of box integrals, and the sum of box integrals is `δᵢ`-close
    to the corresponding integral sum due to the Henstock-Sacks inequality. -/
    rw [← π.to_prepartition.sum_fiberwise (λ J, Nx (π.tag J)),
      ← π.to_prepartition.sum_fiberwise (λ J, Nx (π.tag J))],
    refine le_trans _ (nnreal.coe_lt_coe.2 hcε).le,
    refine (dist_sum_sum_le_of_le _ (λ n hn, _)).trans
      (sum_le_has_sum _ (λ n _, (δ n).2) (nnreal.has_sum_coe.2 hδc)),
    have hNxn : ∀ J ∈ π.filter (λ J, Nx (π.tag J) = n), Nx (π.tag J) = n,
      from λ J hJ, (π.mem_filter.1 hJ).2,
    have hrn : ∀ J ∈ π.filter (λ J, Nx (π.tag J) = n),
      r c (π.tag J) = (hfi' n).convergence_r (δ n) c (π.tag J),
    { intros J hJ, have := hNxn J hJ, clear hJ, subst n },
    have : l.mem_base_set I c ((hfi' n).convergence_r (δ n) c) (π.filter (λ J, Nx (π.tag J) = n)),
      from (hπ.filter _).mono' _ le_rfl le_rfl (λ J hJ, (hrn J hJ).le),
    convert (hfi' n).dist_integral_sum_sum_integral_le_of_mem_base_set (δ0 _) this using 2,
    { refine sum_congr rfl (λ J hJ, _),
      simp [hNxn J hJ] },
    { refine sum_congr rfl (λ J hJ, _),
      rw [← simple_func.integral_eq_integral, simple_func.box_integral_eq_integral _ _ _ _ hl,
        hNxn J hJ],
      exact (hfi _).mono_set (prepartition.le_of_mem _ hJ) } },
  { /-  For the last jump, we use the fact that the distance between `f (Nx x) x` and `g x` is less
    than or equal to the distance between `f N₀ x` and `g x` and the integral of `∥f N₀ x - g x∥`
    is less than or equal to `ε`. -/
    refine le_trans _ hN₀,
    have hfi : ∀ n (J ∈ π), integrable_on (f n) ↑J  μ,
      from λ n J hJ, (hfi n).mono_set (π.le_of_mem' J hJ),
    have hgi : ∀ J ∈ π, integrable_on g ↑J μ, from λ J hJ, hgi.mono_set (π.le_of_mem' J hJ),
    have hfgi : ∀ n (J ∈ π), integrable_on (λ x, ∥f n x - g x∥) J μ,
      from λ n J hJ, ((hfi n J hJ).sub (hgi J hJ)).norm,
    rw [← hπp.Union_eq, prepartition.Union_def',
      integral_finset_bUnion π.boxes (λ J hJ, J.measurable_set_coe) π.pairwise_disjoint hgi,
      integral_finset_bUnion π.boxes (λ J hJ, J.measurable_set_coe) π.pairwise_disjoint (hfgi _)],
    refine dist_sum_sum_le_of_le _ (λ J hJ, _),
    rw [dist_eq_norm, ← integral_sub (hfi _ J hJ) (hgi J hJ)],
    refine norm_integral_le_of_norm_le (hfgi _ J hJ) (eventually_of_forall $ λ x, _),
    exact hfg_mono x (hNx (π.tag J)) }
end

end measure_theory