universes u v

/-- Ex falso, the nondependent eliminator for the `Empty` type. -/
def Empty.elim {C : Sort u} (t : Empty) : C := nomatch t

instance : Subsingleton Empty := ⟨λ a => a.elim⟩

instance {α : Type u} {β : Type v} [Subsingleton α] [Subsingleton β] : Subsingleton (α × β) :=
⟨λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ => congr (congrArg _ $ Subsingleton.elim _ _) (Subsingleton.elim _ _)⟩

instance : DecidableEq Empty := λa => a.elim

instance instSortInhabited' : Inhabited (Inhabited.default : Sort u) := ⟨PUnit.unit⟩

instance decidableEqOfSubsingleton {α : Sort u} [Subsingleton α] : DecidableEq α :=
fun a b => isTrue (Subsingleton.elim a b)

@[simp] theorem eqIffTrueOfSubsingleton [Subsingleton α] (x y : α) : x = y ↔ true :=
⟨λ _ => ⟨_⟩, λ _ => Subsingleton.elim x y⟩

/-- Add an instance to "undo" coercion transitivity into a chain of coercions, because
   most simp lemmas are stated with respect to simple coercions and will not match when
   part of a chain. -/
@[simp] theorem coeCoe {α β γ} [Coe α β] [Coe β γ]
  (a : α) : (a : γ) = (a : β) := rfl

-- Translator's note: `coe_fn_coe_trans`, `coe_fn_coe_base`, and `coe_sort_coe_trans` are not
-- translated because the relavant instances do not exist.

set_option bootstrap.inductiveCheckResultingUniverse false in
/-- `PEmpty` is the universe-polymorphic analogue of `Empty`. -/
inductive PEmpty : Sort u

/-- Ex falso, the nondependent eliminator for the `PEmpty` type. -/
def PEmpty.elim {C : Sort v} (t : PEmpty.{u}) : C := nomatch t

instance : Subsingleton PEmpty := ⟨λ a => a.elim⟩

@[simp] theorem notNonemptyPEmpty : ¬ Nonempty PEmpty :=
λ ⟨h⟩ => h.elim

@[simp] theorem forallPEmpty {P : PEmpty → Prop} : (∀ x : PEmpty, P x) ↔ True :=
⟨λ h => trivial, λ h x => by cases x⟩

@[simp] theorem existsPEmpty {P : PEmpty → Prop} : (∃ x : PEmpty, P x) ↔ False :=
⟨λ ⟨w, hw⟩ => w.elim, False.elim⟩


import data.real.basic
import data.fp.basic
import tactic.omega.main

-- Idea: prove that float is a metric space. Not very promising.

section fp_topology

open real fp

variable [C : float_cfg]
include C

def dist : float → float → with_top ℝ
| (float.inf b₁)                (float.inf b₂)                := if b₁ = b₂ then 0 else ⊤
| (float.inf _)                 _                             := ⊤
| _                             (float.inf _)                 := ⊤
| float.nan                     _                             := ⊤
| _                             float.nan                     := ⊤
| x₁@(float.finite s₁ e₁ m₁ f₁) x₂@(float.finite s₂ e₂ m₂ f₂) :=
    real.of_rat (@abs ℚ _ ((to_rat x₁ rfl) - (to_rat x₂ rfl)))

lemma int.shift2_eq_mk_nat_eq (a₁ a₂ : ℕ) (x₁ x₂ : ℤ)
: int.shift2 a₁ 1 x₁ = int.shift2 a₂ 1 x₂ →
    rat.mk_nat (int.shift2 a₁ 1 x₁).1 (int.shift2 a₁ 1 x₁).2
  = rat.mk_nat (int.shift2 a₂ 1 x₂).1 (int.shift2 a₂ 1 x₂).2 :=
begin
    intros h,
    cases x₁; cases x₂; unfold int.shift2 at *; dsimp; injection h with hfst hsnd,
    { rw [hfst, hsnd], },
    { -- No tactic works for this case...
      rw [nat.shiftl_eq_mul_pow, one_mul] at hsnd, exfalso,
      have h := @nat.pow_lt_pow_succ 2 (by norm_num) x₂,
      rw [←hsnd] at h,
      cases x₂,
      { rw [pow_zero] at h,
        exact (lt_irrefl _ h), },
      { have h' := @nat.pow_lt_pow_of_lt_left 1 2 (by norm_num) x₂.succ (by norm_num),
        rw [one_pow] at h',
        exact (lt_irrefl _ (lt_trans h h')), }, },
    { -- Same as above.
      rw [nat.shiftl_eq_mul_pow, one_mul] at hsnd, exfalso,
      sorry, },
    { iterate 2 { rw [nat.shiftl_eq_mul_pow, one_mul] at hsnd, },
      rw [hfst, nat.succ_injective (@nat.pow_right_injective 2 (by norm_num) _ _ hsnd)], },
end

lemma to_rat_inj (x y : float) (hx : x.is_finite) (hy : y.is_finite)
: to_rat x hx = to_rat y hy → x = y :=
begin
    intros h,
    cases x; cases y; try { cases hx, }; try { cases hy, },
    unfold to_rat at h,
    --split_ifs at h,
    --cases x_a; cases y_a; unfold to_rat at h,
    sorry,
end

lemma dist_eq_zero_iff (x y : float) : dist x y = 0 ↔ x = y :=
begin
    split,
    { intros h,
      cases x; cases y; unfold dist at h; try { cases h, },
      { split_ifs at h,
        { congr', },
        { cases h, }, },
      { replace h := with_top.coe_eq_zero.mp h,
        rw of_rat_eq_cast at h,
        replace h := rat.cast_eq_zero.mp h,
        rw [abs_eq_zero, sub_eq_zero] at h,
        sorry, }, },
    { sorry, }
end

lemma dist_triangle_inequlity (x y z : float) : dist x y ≤ dist x z + dist z y :=
begin
    sorry,
end

end fp_topology


/- Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: ...
-/
import linear_algebra.basic
import algebra.group.hom
/- we will probably need to import other files soon too, like `linear_algebra.finite_dimensional`. -/
-- set_option trace.simplify true
run_cmd mk_simp_attr `RW_REP
meta def rw_simp  : tactic unit :=
`[  try {simp only with RW_REP}, try {exact rfl}]
run_cmd add_interactive [`rw_simp]
universe variables u v w w'
class has_coe_inv (a : Sort u) (b : Sort v) :=
(coe : a → b)
notation `inv`:max x:max := has_coe_inv
open group
open linear_map
open linear_equiv
open submodule
open linear_map.general_linear_group
/-
     I thinck i add three  lemma into  mathlib  line 1922 at the file linear_algebra.bassic
def to_linear_map (f : general_linear_group R M) : M →ₗ[R] M :=(to_linear_equiv f).to_linear_map
def to_linear_map_inv (f : general_linear_group R M) :
M →ₗ[R] M := (to_linear_equiv f⁻¹).to_linear_map
def to_fun (f : general_linear_group R M) : M → M :=  f.val
-/
attribute [RW_REP] coe_add coe_neg coe_smul coe_mk subtype.eta   eq.symm
namespace NOTATION
notation  `GL`                := general_linear_group
notation  `L`:80 f :80        := general_linear_group.to_linear_map f
notation  `F`:80 f :82        := general_linear_group.to_fun f   --- add in mathlib
notation  a` ⊚ `:80 b:80     := linear_map.comp a b
end NOTATION
/- maybe needs a shorter name -/
/-- A representation of a group `G` is an `R`-module `M` with a group homomorphisme from  `G` to
  `GL(M)`. Normally `M` is a vector space, but we don't need that for the definition. -/

def group_representation (G R M : Type*) [group G] [ring R] [add_comm_group M] [module R M] :
  Type* :=  G →* GL R M
-- open NOTATION
variables {G : Type u} {R : Type v} {M : Type w} {M' : Type w'}
  [group G] [ring R] [add_comm_group M] [module R M] [add_comm_group M'] [module R M']

instance : has_coe_to_fun (group_representation G R M) := ⟨_, λ g, g.to_fun⟩   ---
def has_coe_to (ρ : group_representation G R M) : G → (M →ₗ[R] M ) := λ g, L ρ g
notation  `⟦` ρ `⟧` :=  has_coe_to ρ
namespace MY_TEST
variables (f  : M →ₗ[R] M) ( x y : M)
variables (ρ : group_representation G R M)
include ρ
example : f (x+ y) = f(x)+f(y) :=  f.add x y

@[RW_REP] theorem   linearity (g : G ) (x y : M): ⟦ ρ ⟧ g (x+y) = ⟦ρ⟧ g (x) + ⟦ρ⟧ g (y) :=
begin exact (⟦ρ⟧ g).add x y end
@[RW_REP] theorem   smul' (g : G)  (r : R)(m : M) : (⟦ ρ⟧  g) (r • m) = r • ((⟦ ρ ⟧  g) m) := begin
     exact ( ⟦ ρ ⟧ g).smul r m,
end
variables  (g g' : G)

variables (p : submodule R M)

@[RW_REP]lemma F_linearity (x y : M) (g : G) : (F ρ g) (x+y) = (F ρ g) x + (F ρ g) y := begin
     exact ( L ρ  g).add x y,   --- the same for L !
end

variables (h : ∀ x : M, ∀ g : G,  (L ρ  g) x ∈ p)

--- le mécanisme est le suivant :
--- ρ : G →* GL R M
--- le problème étant que :: c'est un morphsime de groupe  mais c'est une structure
--- GL R M donc convertion merdique via L
--- Il y a ⇑

theorem L_to_F  (g : G) : (F ρ g)  = ⟦ρ⟧ g  := rfl

example (ρ : group_representation G R M) ( g g' : G) : ρ (g * g') = ρ g * ρ g' := ρ.map_mul g g'
@[RW_REP]lemma rmap_mul (ρ : group_representation G R M) ( g g' : G) :
      ⟦ ρ ⟧  (g * g')  =  ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g' :=
begin
     ext, rw comp_apply, iterate 3 {rw ← L_to_F}, rw ρ.map_mul,exact rfl,
end
-- @[RW_REP]lemma rmap_mul' (ρ : group_representation G R M) ( g g' : G) :
--           ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g' = ⟦ ρ ⟧  (g * g') :=
-- begin
--      ext, rw comp_apply, iterate 3{rw ← L_to_F}, rw ρ.map_mul,exact rfl,
-- end
@[RW_REP] lemma rmap_one (ρ : group_representation G R M)  :
      ⟦ ρ ⟧  (1)  =  linear_map.id := begin
      ext,rw ← L_to_F,rw ρ.map_one,exact rfl,
      end
@[RW_REP] lemma rmap_inv_mul (ρ : group_representation G R M)(g: G)  :
      ⟦ ρ ⟧  (g * g⁻¹ )  =  linear_map.id := begin
      rw mul_inv_self,exact rmap_one ρ,
      end
@[RW_REP] lemma rmap_mul_inv (ρ : group_representation G R M)(g: G)  :
      ⟦ ρ ⟧  (g⁻¹  * g )  =  linear_map.id := begin
      rw inv_mul_self,exact rmap_one ρ,
      end
@[RW_REP] lemma rmap_inv' (ρ : group_representation G R M) (g : G) :
     ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g⁻¹  = linear_map.id := begin
          rw ← rmap_mul,exact rmap_inv_mul ρ g,
     end
@[RW_REP] lemma rmap_inv''(ρ : group_representation G R M) (g : G) :
     ⟦ρ⟧  g⁻¹    ⊚  ⟦ ρ ⟧  g  = linear_map.id := begin
          rw ← rmap_mul,exact rmap_mul_inv ρ g ,
     end
@[RW_REP] lemma rmap_inv_apply'' (ρ : group_representation G R M) (g : G)(x : M) :
     (⟦ρ⟧  g⁻¹    ⊚  ⟦ ρ ⟧  g ) x = x := begin
          rw rmap_inv'',exact rfl,
     end
@[RW_REP] lemma rmap_inv_apply' (ρ : group_representation G R M) (g : G)(x : M) :
     (⟦ρ⟧  g    ⊚  ⟦ ρ ⟧  g⁻¹  ) x = x := begin
          rw rmap_inv',exact rfl,
     end
def has_inv (ρ : group_representation G R M)(g : G) :  M ≃ₗ[R]  M :=  {
     to_fun := ⟦ ρ ⟧ g ,
     add := linearity ρ g ,
     smul :=  smul' ρ g,
     inv_fun :=  ⟦ ρ ⟧ g⁻¹,
     left_inv :=  rmap_inv_apply'' ρ g,
     right_inv :=  rmap_inv_apply' ρ g
}
-- @[RW_REP] lemma rmap_inv (ρ : group_representation G R M)(g : G) :  -- 207
--      ⟦ ρ ⟧ g⁻¹ =  to_linear_map_inv (has_inv' ρ g )   := begin
--           ext,
--           sorry,
--      end
@[RW_REP]lemma star_is_oo (ρ : group_representation G R M) ( g g' : G) :
      ⟦ρ⟧  g   ⊚  ⟦ ρ ⟧  g'  =  ⟦ρ⟧  g   *  ⟦ ρ ⟧  g' :=  by rw_simp

@[RW_REP]lemma rmap_map_assoc (ρ : group_representation G R M)( g1 g2 g3 : G) : ⟦ρ⟧ (g1 * g2 *g3)  =
     ⟦ρ⟧ (g1) ⊚  (⟦ρ⟧  g2 ⊚   ⟦ρ⟧ g3)  :=
begin
      rw  group.mul_assoc,rw rmap_mul,rw rmap_mul,
     -- rw_simp,
end
example (ρ : group_representation G R M)( g1 g2 g3 g4 : G) : ⟦ρ⟧ (g1 * (g2 *g3 * g4))  =
     ⟦ρ⟧ (g1) ⊚  (⟦ρ⟧  g2 ⊚   ⟦ρ⟧ g3) * ⟦ ρ ⟧ g4  :=
begin

     rw_simp,
end
@[RW_REP]lemma times_to_oo (ρ : group_representation G R M)( g g' : G) :  ⟦ ρ ⟧  (g * g')  =  ⟦ρ⟧  g  *  ⟦ ρ ⟧  g' := begin
     rw_simp,
end
example (ρ : group_representation G R M)( g1 g2 g3 : G) : ⟦ρ⟧ (g1 * g2 *g3)  =
     ⟦ρ⟧ (g1) ⊚  ⟦ρ⟧  g2  *   ⟦ρ⟧ g3  :=
begin
     rw_simp,
end
@[RW_REP]lemma mul_to_composition_of_function (ρ : group_representation G R M) ( g g' : G) :
 ⟦ ρ⟧  (g * g')  = ( ⟦ ρ⟧  g )  *  (⟦  ρ ⟧  g') := begin
  rw_simp,
end
@[RW_REP]lemma mixte_linearity (ρ : group_representation G R M) ( g g' : G) (x y : M) (r : R):
       ⟦ ρ⟧  (g * g') (x+r • y) = ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' x )+ r • ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' y ) := begin
          iterate 2 {rw ← comp_apply},rw_simp, rw ← rmap_mul,
end
-- @[RW_REP]lemma L_to_F (g : G) :  (L ρ g).to_fun = (F ρ g) := rfl

example :    ⟦ ρ ⟧  (g * g') = (L ρ g) ⊚   (L ρ g')  := by rw_simp
lemma mul_one (ρ : group_representation G R M) : (L ρ 1) = 1 := begin
rw ρ.map_one, exact rfl,
end
instance has_coe_too :               -----------------
  is_monoid_hom (has_coe_to ρ : G → (M →ₗ[R] M)) :=
{ map_one := rmap_one ρ,
  map_mul := rmap_mul ρ}
def new_groupe_representation :
( group_representation G R M)  →  G →* (M →ₗ[R] M) := λ ρ, { to_fun := ⟦ρ⟧ ,
  map_one' := by rw_simp,
  map_mul' := by {intros,rw_simp} }
end MY_TEST
namespace group_representation
/- do we want this instance? Then we don't have to write `(ρ g).1 x` instead of `ρ g x`. -/
-- instance : has_coe (general_linear_group R M) (M →ₗ[R] M) := ⟨λ x, x.1⟩
protected structure morphism (ρ : group_representation G R M) (π : group_representation G R M') :
  Type (max w w') :=
  (linear_map : M →ₗ[R] M')
  (commute : ∀(g : G), linear_map  ⊚ (⟦ ρ ⟧  g)  = (⟦ π ⟧  g) ⊚  linear_map)
infixr ` ⟶₁ `:25 := morphism
protected structure equiv (ρ : group_representation G R M) (π : group_representation G R M') :
  Type (max w w') :=
  (f : M ≃ₗ[R] M')
  (commute : ∀(g : G), to_linear_map f ⊚ ⟦ ρ ⟧ g = ⟦π⟧  g ⊚ to_linear_map f)
variables (ρ : group_representation G R M) (π : group_representation G R M')
instance has_coe_to_linear_map  : has_coe (equiv ρ π)  (M →ₗ[R] M') := ⟨λ φ ,to_linear_map φ.f⟩
lemma coe  (φ : equiv ρ π  ) :  ↑φ = to_linear_map φ.f := rfl
lemma  coe_ext (φ : equiv ρ π  )(g : G) :     (↑φ)  ⊚ (⟦ρ⟧ g)= (⟦π ⟧ g) ⊚  (↑φ) := begin
     rw coe,rw φ.commute,
end
#print has_coe
#print has_inv
instance inverse : has_coe_inv (equiv ρ π)  (M' →ₗ[R] M) := ⟨ λ φ, to_linear_map φ.f.symm ⟩
lemma coe_inv       (φ : equiv ρ π  ) :  ↑φ = to_linear_map φ.f.symm := rfl
lemma heye (ρ : group_representation G R M) (π : group_representation G R M') (φ : equiv ρ  π ) :
     ( φ : M' →ₗ[R] M) ⊚ (↑φ) = (linear_map.id : M →ₗ[R] M) :=
     begin
          sorry,
     end

variables (g g' : G)(x : M)
-- example (x y : M) (g : G) :  ρ  g (x+y)= ρ g x + ρ g y := begin rw (L ρ g).add x y, end

namespace stability
/-
     We define the notion of stable submodule.
     We make a sub-representation.
     ligne  384 algebra module submodule (conduit)
     il y a des lemmes de convertions.
 -/
variables {ρ1 : group_representation G R M}{p : submodule R M}
/-
     Strategy maths : We have ρ g x ∈ p for x ∈ p so
     you have a map : ρ' g : p → p ... linear_map, invertible (restriction of ρ g⁻¹ ) and trivial trivial trivial
     For lean : this is not trivial. We have to verify some stuff.
     Lemma to try to deal with convertion
-/
@[RW_REP]lemma sub_module.eq_trans (x y : M) (hx : x ∈ p)(hy : y ∈ p) :
(x : M) = (y : M) →  (⟨x,hx⟩ : p)   = (⟨ y,hy⟩ : p )  := begin
     intros,congr ; try { assumption },
end
@[RW_REP] lemma sub_module.eq_trans' (x y : p) : (x : M) = (y : M) → x = y := begin
          intros,rcases x,rcases y,congr; try {assumption},
end
-- lemma sub_module_val (x : M) (hx : x ∈ p) : (⟨x,hx ⟩ : p).val = (x : M) := rfl

def stable_sub_module (ρ : group_representation G R M)(p : submodule R M) :=
                     ∀ g : G, ∀ x : p, ( ⟦ ρ ⟧  g) x ∈ p
/-
     First Step : we define G → (p →ₗ[R] p)
-/

def restriction (hyp_stab : stable_sub_module ρ p) : G → (p →ₗ[R] p)  := λ g, begin
     exact {
          to_fun    := λ x, ⟨( ⟦ ρ⟧  g ) x, hyp_stab g x⟩,
          add       := by {intros x y, rw_simp},
          smul      := by {intro c, intros x, rw_simp},
     },
end
open MY_TEST
@[RW_REP]lemma restriction_ext (h : stable_sub_module ρ p) (y : p)
: (( ⟦ρ⟧  g) y : M ) = (restriction ρ h g y : M) := rfl
@[RW_REP]lemma restriction_ext' (h : stable_sub_module ρ p) (y : p)
:   (restriction ρ h g y : M) = (( ⟦ρ⟧  g) y : M ) := rfl
def  restriction_equiv (h : stable_sub_module ρ p) (g : G) :  (p ≃ p) :=
{ to_fun := (restriction ρ h g),
  inv_fun := (restriction ρ h g⁻¹),
  left_inv := begin
               intros x,
                    apply sub_module.eq_trans',
                    iterate 2 {rw ← restriction_ext},
                    rw ← comp_apply,
                    apply rmap_inv_apply'',
                    -- rw [← comp_apply,←  mul_to_composition_of_linear_map, inv_mul_self, ρ.map_one],
                    -- exact rfl,end,
               end
  , right_inv := begin
               intros x,
               apply sub_module.eq_trans',
               iterate 2 {rw ← restriction_ext},
               rw  ← comp_apply,
               apply rmap_inv_apply',
  end }
def Restriction (h : stable_sub_module ρ p) (g : G) : p ≃ₗ[R] p :=
 { .. restriction ρ h g, .. restriction_equiv ρ h g}
/-
     Helper rfl
-/
def sub_representation (h : stable_sub_module ρ p) : group_representation G R p :=
{ to_fun := λ g, of_linear_equiv (Restriction ρ h g),
  map_one' := begin
               rw units.ext_iff, --- Creer un helper pour la sous structure car c'est chiant
               ext,rcases x,
               apply sub_module.eq_trans,
                rw rmap_one,exact rfl,
               end,
  map_mul' := begin intros g1 g2,rw units.ext_iff, ext, rcases x,
                    apply sub_module.eq_trans,rw_simp,rw of_linear_equiv_val,
                    rw rmap_mul,
                    rw comp_apply, exact rfl,
 end }
 variables (h : stable_sub_module ρ p)
 #check sub_representation ρ h
 notation ρ `/`h := sub_representation ρ h
 #check  ⟦ ρ / h⟧  g
 @[RW_REP]lemma sub_representation.val (ρ : group_representation G R M) (h : stable_sub_module ρ p)( x : p) :
     (⟦ρ⟧ g ) x.val = ( ⟦ ρ / h ⟧  g) x    := rfl

@[RW_REP] lemma rw_sub_module_action_to (ρ : group_representation G R M) (h : stable_sub_module ρ p) (x : p) :
     (⟦ρ ⟧ g) x = ⟦ρ / h⟧ g x :=
     begin
          -- rw_simp, --- joke :D
          exact rfl,
     end
example (ρ : group_representation G R M) (h : stable_sub_module ρ p) (x y : p)(r : R) (g g' : G): true :=
     begin
          have R : ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' x )+ r • ⟦ ρ ⟧ g ( ⟦ ρ ⟧ g' y ) =   ⟦ ρ / h ⟧ (g * g') (x+ r • y),
               iterate 2 {rw ← comp_apply}, rw ← rmap_mul,rw ← smul',rw ← linearity,rw_simp,
          trivial,
          end
variables ( e r t : ( (M →ₗ[R] M)))
#check e*t
end stability

namespace sum
/-
     Define direct sum of representation
-/
end sum
end group_representation


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import linear_algebra.span
import ring_theory.ideal.operations
import ring_theory.finiteness
import ring_theory.localization.ideal
import ring_theory.ideal.minimal_prime

/-!

# Associated primes of a module

We provide the definition and related lemmas about associated primes of modules.

## Main definition
- `is_associated_prime`: `is_associated_prime I M` if the prime ideal `I` is the
  annihilator of some `x : M`.
- `associated_primes`: The set of associated primes of a module.

## Main results
- `exists_le_is_associated_prime_of_is_noetherian_ring`: In a noetherian ring, any `ann(x)` is
  contained in an associated prime for `x ≠ 0`.
- `associated_primes.eq_singleton_of_is_primary`: In a noetherian ring, `I.radical` is the only
  associated prime of `R ⧸ I` when `I` is primary.

## Todo

Generalize this to a non-commutative setting once there are annihilator for non-commutative rings.

-/

variables {R : Type*} [comm_ring R] (I J : ideal R) (M : Type*) [add_comm_group M] [module R M]

/-- `is_associated_prime I M` if the prime ideal `I` is the annihilator of some `x : M`. -/
def is_associated_prime : Prop :=
I.is_prime ∧ ∃ x : M, I = (R ∙ x).annihilator

variables (R)

/-- The set of associated primes of a module. -/
def associated_primes : set (ideal R) := { I | is_associated_prime I M }

variables {I J M R} (h : is_associated_prime I M)
variables {M' : Type*} [add_comm_group M'] [module R M'] (f : M →ₗ[R] M')

lemma associate_primes.mem_iff : I ∈ associated_primes R M ↔ is_associated_prime I M := iff.rfl

lemma is_associated_prime.is_prime : I.is_prime := h.1

lemma is_associated_prime.map_of_injective
  (h : is_associated_prime I M) (hf : function.injective f) :
  is_associated_prime I M' :=
begin
  obtain ⟨x, rfl⟩ := h.2,
  refine ⟨h.1, ⟨f x, _⟩⟩,
  ext r,
  rw [submodule.mem_annihilator_span_singleton, submodule.mem_annihilator_span_singleton,
    ← map_smul, ← f.map_zero, hf.eq_iff],
end

lemma linear_equiv.is_associated_prime_iff (l : M ≃ₗ[R] M') :
  is_associated_prime I M ↔ is_associated_prime I M' :=
⟨λ h, h.map_of_injective l l.injective, λ h, h.map_of_injective l.symm l.symm.injective⟩

lemma not_is_associated_prime_of_subsingleton [subsingleton M] : ¬ is_associated_prime I M :=
begin
  rintro ⟨hI, x, hx⟩,
  apply hI.ne_top,
  rwa [subsingleton.elim x 0, submodule.span_singleton_eq_bot.mpr rfl,
    submodule.annihilator_bot] at hx
end

variable (R)

lemma exists_le_is_associated_prime_of_is_noetherian_ring [H : is_noetherian_ring R]
  (x : M) (hx : x ≠ 0) :
  ∃ P : ideal R, is_associated_prime P M ∧ (R ∙ x).annihilator ≤ P :=
begin
  have : (R ∙ x).annihilator ≠ ⊤,
  { rwa [ne.def, ideal.eq_top_iff_one, submodule.mem_annihilator_span_singleton, one_smul] },
  obtain ⟨P, ⟨l, h₁, y, rfl⟩, h₃⟩ := set_has_maximal_iff_noetherian.mpr H
    ({ P | (R ∙ x).annihilator ≤ P ∧ P ≠ ⊤ ∧ ∃ y : M, P = (R ∙ y).annihilator })
    ⟨(R ∙ x).annihilator, rfl.le, this, x, rfl⟩,
  refine ⟨_, ⟨⟨h₁, _⟩, y, rfl⟩, l⟩,
  intros a b hab,
  rw or_iff_not_imp_left,
  intro ha,
  rw submodule.mem_annihilator_span_singleton at ha hab,
  have H₁ : (R ∙ y).annihilator ≤ (R ∙ a • y).annihilator,
  { intros c hc,
    rw submodule.mem_annihilator_span_singleton at hc ⊢,
    rw [smul_comm, hc, smul_zero] },
  have H₂ : (submodule.span R {a • y}).annihilator ≠ ⊤,
  { rwa [ne.def, submodule.annihilator_eq_top_iff, submodule.span_singleton_eq_bot] },
  rwa [H₁.eq_of_not_lt (h₃ (R ∙ a • y).annihilator ⟨l.trans H₁, H₂, _, rfl⟩),
    submodule.mem_annihilator_span_singleton, smul_comm, smul_smul]
end

variable {R}

lemma associated_primes.subset_of_injective (hf : function.injective f) :
  associated_primes R M ⊆ associated_primes R M' :=
λ I h, h.map_of_injective f hf

lemma linear_equiv.associated_primes.eq (l : M ≃ₗ[R] M') :
  associated_primes R M = associated_primes R M' :=
le_antisymm (associated_primes.subset_of_injective l l.injective)
  (associated_primes.subset_of_injective l.symm l.symm.injective)

lemma associated_primes.eq_empty_of_subsingleton [subsingleton M] : associated_primes R M = ∅ :=
begin
  ext, simp only [set.mem_empty_iff_false, iff_false], apply not_is_associated_prime_of_subsingleton
end

variables (R M)

lemma associated_primes.nonempty [is_noetherian_ring R] [nontrivial M] :
  (associated_primes R M).nonempty :=
begin
  obtain ⟨x, hx⟩ := exists_ne (0 : M),
  obtain ⟨P, hP, _⟩ := exists_le_is_associated_prime_of_is_noetherian_ring R x hx,
  exact ⟨P, hP⟩,
end

variables {R M}

lemma is_associated_prime.annihilator_le (h : is_associated_prime I M) :
  (⊤ : submodule R M).annihilator ≤ I :=
begin
  obtain ⟨hI, x, rfl⟩ := h,
  exact submodule.annihilator_mono le_top,
end

lemma is_associated_prime.eq_radical (hI : I.is_primary) (h : is_associated_prime J (R ⧸ I)) :
  J = I.radical :=
begin
  obtain ⟨hJ, x, e⟩ := h,
  have : x ≠ 0,
  { rintro rfl, apply hJ.1,
    rwa [submodule.span_singleton_eq_bot.mpr rfl, submodule.annihilator_bot] at e },
  obtain ⟨x, rfl⟩ := ideal.quotient.mkₐ_surjective R _ x,
  replace e : ∀ {y}, y ∈ J ↔ x * y ∈ I,
  { intro y, rw [e, submodule.mem_annihilator_span_singleton, ← map_smul, smul_eq_mul, mul_comm,
      ideal.quotient.mkₐ_eq_mk, ← ideal.quotient.mk_eq_mk, submodule.quotient.mk_eq_zero] },
  apply le_antisymm,
  { intros y hy,
    exact (hI.2 $ e.mp hy).resolve_left ((submodule.quotient.mk_eq_zero I).not.mp this) },
  { rw hJ.radical_le_iff, intros y hy, exact e.mpr (I.mul_mem_left x hy) }
end

lemma associated_primes.eq_singleton_of_is_primary [is_noetherian_ring R] (hI : I.is_primary) :
  associated_primes R (R ⧸ I) = {I.radical} :=
begin
  ext J,
  rw [set.mem_singleton_iff],
  refine ⟨is_associated_prime.eq_radical hI, _⟩,
  rintro rfl,
  haveI : nontrivial (R ⧸ I) := ⟨⟨(I^.quotient.mk : _) 1, (I^.quotient.mk : _) 0, _⟩⟩,
  obtain ⟨a, ha⟩ := associated_primes.nonempty R (R ⧸ I),
  exact ha.eq_radical hI ▸ ha,
  rw [ne.def, ideal.quotient.eq, sub_zero, ← ideal.eq_top_iff_one],
  exact hI.1
end


/-
Copyright (c) 2021 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.monoidal.free.basic
import category_theory.groupoid
import category_theory.discrete_category

/-!
# The monoidal coherence theorem

In this file, we prove the monoidal coherence theorem, stated in the following form: the free
monoidal category over any type `C` is thin.

We follow a proof described by Ilya Beylin and Peter Dybjer, which has been previously formalized
in the proof assistant ALF. The idea is to declare a normal form (with regard to association and
adding units) on objects of the free monoidal category and consider the discrete subcategory of
objects that are in normal form. A normalization procedure is then just a functor
`full_normalize : free_monoidal_category C ⥤ discrete (normal_monoidal_object C)`, where
functoriality says that two objects which are related by associators and unitors have the
same normal form. Another desirable property of a normalization procedure is that an object is
isomorphic (i.e., related via associators and unitors) to its normal form. In the case of the
specific normalization procedure we use we not only get these isomorphismns, but also that they
assemble into a natural isomorphism `𝟭 (free_monoidal_category C) ≅ full_normalize ⋙ inclusion`.
But this means that any two parallel morphisms in the free monoidal category factor through a
discrete category in the same way, so they must be equal, and hence the free monoidal category
is thin.

## References

* [Ilya Beylin and Peter Dybjer, Extracting a proof of coherence for monoidal categories from a
   proof of normalization for monoids][beylin1996]

-/

universe u

namespace category_theory
open monoidal_category

namespace free_monoidal_category

variables {C : Type u}

section
variables (C)

/-- We say an object in the free monoidal category is in normal form if it is of the form
    `(((𝟙_ C) ⊗ X₁) ⊗ X₂) ⊗ ⋯`. -/
@[nolint has_inhabited_instance]
inductive normal_monoidal_object : Type u
| unit : normal_monoidal_object
| tensor : normal_monoidal_object → C → normal_monoidal_object

end

local notation `F` := free_monoidal_category
local notation `N` := discrete ∘ normal_monoidal_object
local infixr ` ⟶ᵐ `:10 := hom

/-- Auxiliary definition for `inclusion`. -/
@[simp] def inclusion_obj : normal_monoidal_object C → F C
| normal_monoidal_object.unit := unit
| (normal_monoidal_object.tensor n a) := tensor (inclusion_obj n) (of a)

/-- The discrete subcategory of objects in normal form includes into the free monoidal category. -/
@[simp] def inclusion : N C ⥤ F C :=
discrete.functor inclusion_obj

/-- Auxiliary definition for `normalize`. -/
@[simp] def normalize_obj : F C → normal_monoidal_object C → normal_monoidal_object C
| unit n := n
| (of X) n := normal_monoidal_object.tensor n X
| (tensor X Y) n := normalize_obj Y (normalize_obj X n)

@[simp] lemma normalize_obj_unitor (n : N C) : normalize_obj (𝟙_ (F C)) n = n :=
rfl

@[simp] lemma normalize_obj_tensor (X Y : F C) (n : N C) :
  normalize_obj (X ⊗ Y) n = normalize_obj Y (normalize_obj X n) :=
rfl

section
open hom

/-- Auxiliary definition for `normalize`. Here we prove that objects that are related by
    associators and unitors map to the same normal form. -/
@[simp] def normalize_map_aux : Π {X Y : F C},
  (X ⟶ᵐ Y) →
    ((discrete.functor (normalize_obj X) : _ ⥤ N C) ⟶ discrete.functor (normalize_obj Y))
| _ _ (id _) := 𝟙 _
| _ _ (α_hom _ _ _) := ⟨λ X, 𝟙 _⟩
| _ _ (α_inv _ _ _) := ⟨λ X, 𝟙 _⟩
| _ _ (l_hom _) := ⟨λ X, 𝟙 _⟩
| _ _ (l_inv _) := ⟨λ X, 𝟙 _⟩
| _ _ (ρ_hom _) := ⟨λ X, 𝟙 _⟩
| _ _ (ρ_inv _) := ⟨λ X, 𝟙 _⟩
| X Y (@comp _ U V W f g) := normalize_map_aux f ≫ normalize_map_aux g
| X Y (@hom.tensor _ T U V W f g) :=
    ⟨λ X, (normalize_map_aux g).app (normalize_obj T X) ≫
      (discrete.functor (normalize_obj W) : _ ⥤ N C).map ((normalize_map_aux f).app X), by tidy⟩

end

section
variables (C)

/-- Our normalization procedure works by first defining a functor `F C ⥤ (N C ⥤ N C)` (which turns
    out to be very easy), and then obtain a functor `F C ⥤ N C` by plugging in the normal object
    `𝟙_ C`. -/
@[simp] def normalize : F C ⥤ N C ⥤ N C :=
{ obj := λ X, discrete.functor (normalize_obj X),
  map := λ X Y, quotient.lift normalize_map_aux (by tidy) }

/-- A variant of the normalization functor where we consider the result as an object in the free
    monoidal category (rather than an object of the discrete subcategory of objects in normal
    form). -/
@[simp] def normalize' : F C ⥤ N C ⥤ F C :=
normalize C ⋙ (whiskering_right _ _ _).obj inclusion

/-- The normalization functor for the free monoidal category over `C`. -/
def full_normalize : F C ⥤ N C :=
{ obj := λ X, ((normalize C).obj X).obj normal_monoidal_object.unit,
  map := λ X Y f, ((normalize C).map f).app normal_monoidal_object.unit }

/-- Given an object `X` of the free monoidal category and an object `n` in normal form, taking
    the tensor product `n ⊗ X` in the free monoidal category is functorial in both `X` and `n`. -/
@[simp] def tensor_func : F C ⥤ N C ⥤ F C :=
{ obj := λ X, discrete.functor (λ n, (inclusion.obj n) ⊗ X),
  map := λ X Y f, ⟨λ n, 𝟙 _ ⊗ f, by tidy⟩ }

lemma tensor_func_map_app {X Y : F C} (f : X ⟶ Y) (n) : ((tensor_func C).map f).app n =
  𝟙 _ ⊗ f :=
rfl

lemma tensor_func_obj_map (Z : F C) {n n' : N C} (f : n ⟶ n') :
  ((tensor_func C).obj Z).map f = inclusion.map f ⊗ 𝟙 Z :=
by tidy

/-- Auxiliary definition for `normalize_iso`. Here we construct the isomorphism between
    `n ⊗ X` and `normalize X n`. -/
@[simp] def normalize_iso_app :
  Π (X : F C) (n : N C), ((tensor_func C).obj X).obj n ≅ ((normalize' C).obj X).obj n
| (of X) n := iso.refl _
| unit n := ρ_ _
| (tensor X Y) n :=
    (α_ _ _ _).symm ≪≫ tensor_iso (normalize_iso_app X n) (iso.refl _) ≪≫ normalize_iso_app _ _

@[simp] lemma normalize_iso_app_tensor (X Y : F C) (n : N C) :
  normalize_iso_app C (X ⊗ Y) n =
  (α_ _ _ _).symm ≪≫ tensor_iso (normalize_iso_app C X n) (iso.refl _) ≪≫
    normalize_iso_app _ _ _ :=
rfl

@[simp] lemma normalize_iso_app_unitor (n : N C) : normalize_iso_app C (𝟙_ (F C)) n = ρ_ _ :=
rfl

/-- Auxiliary definition for `normalize_iso`. -/
@[simp] def normalize_iso_aux (X : F C) : (tensor_func C).obj X ≅ (normalize' C).obj X :=
nat_iso.of_components (normalize_iso_app C X) (by tidy)

/-- The isomorphism between `n ⊗ X` and `normalize X n` is natural (in both `X` and `n`, but
    naturality in `n` is trivial and was "proved" in `normalize_iso_aux`). This is the real heart
    of our proof of the coherence theorem. -/
def normalize_iso : tensor_func C ≅ normalize' C :=
nat_iso.of_components (normalize_iso_aux C)
begin
  rintros X Y f,
  apply quotient.induction_on f,
  intro f,
  ext n,
  induction f generalizing n,
  { simp only [mk_id, functor.map_id, category.id_comp, category.comp_id] },
  { dsimp,
    simp only [id_tensor_associator_inv_naturality_assoc, ←pentagon_inv_assoc,
      tensor_hom_inv_id_assoc, tensor_id, category.id_comp, discrete.functor_map_id, comp_tensor_id,
      iso.cancel_iso_inv_left, category.assoc],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    simp only [discrete.functor_map_id, comp_tensor_id, category.assoc, pentagon_inv_assoc,
      ←associator_inv_naturality_assoc, tensor_id, iso.cancel_iso_inv_left],
    dsimp, simp only [category.comp_id],},
  { dsimp,
    rw triangle_assoc_comp_right_assoc,
    simp only [discrete.functor_map_id, category.assoc],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    simp only [triangle_assoc_comp_left_inv_assoc, inv_hom_id_tensor_assoc, tensor_id,
      category.id_comp, discrete.functor_map_id],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    rw [←(iso.inv_comp_eq _).2 (right_unitor_tensor _ _), category.assoc, ←right_unitor_naturality],
    simp only [discrete.functor_map_id, iso.cancel_iso_inv_left, category.assoc],
    dsimp, simp only [category.comp_id] },
  { dsimp,
    simp only [←(iso.eq_comp_inv _).1 (right_unitor_tensor_inv _ _), iso.hom_inv_id_assoc,
      right_unitor_conjugation, discrete.functor_map_id, category.assoc],
    dsimp, simp only [category.comp_id], },
  { dsimp at *,
    rw [id_tensor_comp, category.assoc, f_ih_g ⟦f_g⟧, ←category.assoc, f_ih_f ⟦f_f⟧, category.assoc,
      ←functor.map_comp],
    congr' 2 },
  { dsimp at *,
    rw associator_inv_naturality_assoc,
    slice_lhs 2 3 { rw [←tensor_comp, f_ih_f ⟦f_f⟧] },
    conv_lhs { rw [←@category.id_comp (F C) _ _ _ ⟦f_g⟧] },
    simp only [category.comp_id, tensor_comp, category.assoc],
    congr' 2,
    rw [←mk_tensor, quotient.lift_mk],
    dsimp,
    rw [functor.map_comp, ←category.assoc, ←f_ih_g ⟦f_g⟧, ←@category.comp_id (F C) _ _ _ ⟦f_g⟧,
      ←category.id_comp ((discrete.functor inclusion_obj).map _), tensor_comp],
    dsimp,
    simp only [category.assoc, category.comp_id],
    congr' 1,
    convert (normalize_iso_aux C f_Z).hom.naturality ((normalize_map_aux f_f).app n),
    exact (tensor_func_obj_map _ _ _).symm }
end

/-- The isomorphism between an object and its normal form is natural. -/
def full_normalize_iso : 𝟭 (F C) ≅ full_normalize C ⋙ inclusion :=
nat_iso.of_components
  (λ X, (λ_ X).symm ≪≫ ((normalize_iso C).app X).app normal_monoidal_object.unit)
  begin
    intros X Y f,
    dsimp,
    rw [left_unitor_inv_naturality_assoc, category.assoc, iso.cancel_iso_inv_left],
    exact congr_arg (λ f, nat_trans.app f normal_monoidal_object.unit)
      ((normalize_iso.{u} C).hom.naturality f),
  end

end

/-- The monoidal coherence theorem. -/
instance subsingleton_hom {X Y : F C} : subsingleton (X ⟶ Y) :=
⟨λ f g, have (full_normalize C).map f = (full_normalize C).map g, from subsingleton.elim _ _,
 begin
  rw [←functor.id_map f, ←functor.id_map g],
  simp [←nat_iso.naturality_2 (full_normalize_iso.{u} C), this]
 end⟩

section groupoid

section
open hom

/-- Auxiliary construction for showing that the free monoidal category is a groupoid. Do not use
    this, use `is_iso.inv` instead. -/
def inverse_aux : Π {X Y : F C}, (X ⟶ᵐ Y) → (Y ⟶ᵐ X)
| _ _ (id X) := id X
| _ _ (α_hom _ _ _) := α_inv _ _ _
| _ _ (α_inv _ _ _) := α_hom _ _ _
| _ _ (ρ_hom _) := ρ_inv _
| _ _ (ρ_inv _) := ρ_hom _
| _ _ (l_hom _) := l_inv _
| _ _ (l_inv _) := l_hom _
| _ _ (comp f g) := (inverse_aux g).comp (inverse_aux f)
| _ _ (hom.tensor f g) := (inverse_aux f).tensor (inverse_aux g)

end

instance : groupoid.{u} (F C) :=
{ inv := λ X Y, quotient.lift (λ f, ⟦inverse_aux f⟧) (by tidy),
  ..(infer_instance : category (F C)) }

end groupoid

end free_monoidal_category

end category_theory


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison, Bhavik Mehta, Jakob von Raumer
-/
import category_theory.products.basic

/-!
# Monoidal categories

A monoidal category is a category equipped with a tensor product, unitors, and an associator.
In the definition, we provide the tensor product as a pair of functions
* `tensor_obj : C → C → C`
* `tensor_hom : (X₁ ⟶ Y₁) → (X₂ ⟶ Y₂) → ((X₁ ⊗ X₂) ⟶ (Y₁ ⊗ Y₂))`
and allow use of the overloaded notation `⊗` for both.
The unitors and associator are provided componentwise.

The tensor product can be expressed as a functor via `tensor : C × C ⥤ C`.
The unitors and associator are gathered together as natural
isomorphisms in `left_unitor_nat_iso`, `right_unitor_nat_iso` and `associator_nat_iso`.

Some consequences of the definition are proved in other files,
e.g. `(λ_ (𝟙_ C)).hom = (ρ_ (𝟙_ C)).hom` in `category_theory.monoidal.unitors_equal`.

## Implementation
Dealing with unitors and associators is painful, and at this stage we do not have a useful
implementation of coherence for monoidal categories.

In an effort to lessen the pain, we put some effort into choosing the right `simp` lemmas.
Generally, the rule is that the component index of a natural transformation "weighs more"
in considering the complexity of an expression than does a structural isomorphism (associator, etc).

As an example when we prove Proposition 2.2.4 of
<http://www-math.mit.edu/~etingof/egnobookfinal.pdf>
we state it as a `@[simp]` lemma as
```
(λ_ (X ⊗ Y)).hom = (α_ (𝟙_ C) X Y).inv ≫ (λ_ X).hom ⊗ (𝟙 Y)
```

This is far from completely effective, but seems to prove a useful principle.

## References
* Tensor categories, Etingof, Gelaki, Nikshych, Ostrik,
  http://www-math.mit.edu/~etingof/egnobookfinal.pdf
* https://stacks.math.columbia.edu/tag/0FFK.
-/

open category_theory

universes v u

open category_theory
open category_theory.category
open category_theory.iso

namespace category_theory

/--
In a monoidal category, we can take the tensor product of objects, `X ⊗ Y` and of morphisms `f ⊗ g`.
Tensor product does not need to be strictly associative on objects, but there is a
specified associator, `α_ X Y Z : (X ⊗ Y) ⊗ Z ≅ X ⊗ (Y ⊗ Z)`. There is a tensor unit `𝟙_ C`,
with specified left and right unitor isomorphisms `λ_ X : 𝟙_ C ⊗ X ≅ X` and `ρ_ X : X ⊗ 𝟙_ C ≅ X`.
These associators and unitors satisfy the pentagon and triangle equations.

See https://stacks.math.columbia.edu/tag/0FFK.
-/
class monoidal_category (C : Type u) [𝒞 : category.{v} C] :=
-- curried tensor product of objects:
(tensor_obj               : C → C → C)
(infixr ` ⊗ `:70          := tensor_obj) -- This notation is only temporary
-- curried tensor product of morphisms:
(tensor_hom               :
  Π {X₁ Y₁ X₂ Y₂ : C}, (X₁ ⟶ Y₁) → (X₂ ⟶ Y₂) → ((X₁ ⊗ X₂) ⟶ (Y₁ ⊗ Y₂)))
(infixr ` ⊗' `:69         := tensor_hom) -- This notation is only temporary
-- tensor product laws:
(tensor_id'               :
  ∀ (X₁ X₂ : C), (𝟙 X₁) ⊗' (𝟙 X₂) = 𝟙 (X₁ ⊗ X₂) . obviously)
(tensor_comp'             :
  ∀ {X₁ Y₁ Z₁ X₂ Y₂ Z₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : Y₁ ⟶ Z₁) (g₂ : Y₂ ⟶ Z₂),
  (f₁ ≫ g₁) ⊗' (f₂ ≫ g₂) = (f₁ ⊗' f₂) ≫ (g₁ ⊗' g₂) . obviously)
-- tensor unit:
(tensor_unit []           : C)
(notation `𝟙_`            := tensor_unit)
-- associator:
(associator               :
  Π X Y Z : C, (X ⊗ Y) ⊗ Z ≅ X ⊗ (Y ⊗ Z))
(notation `α_`            := associator)
(associator_naturality'   :
  ∀ {X₁ X₂ X₃ Y₁ Y₂ Y₃ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (f₃ : X₃ ⟶ Y₃),
  ((f₁ ⊗' f₂) ⊗' f₃) ≫ (α_ Y₁ Y₂ Y₃).hom = (α_ X₁ X₂ X₃).hom ≫ (f₁ ⊗' (f₂ ⊗' f₃)) . obviously)
-- left unitor:
(left_unitor              : Π X : C, 𝟙_ ⊗ X ≅ X)
(notation `λ_`            := left_unitor)
(left_unitor_naturality'  :
  ∀ {X Y : C} (f : X ⟶ Y), ((𝟙 𝟙_) ⊗' f) ≫ (λ_ Y).hom = (λ_ X).hom ≫ f . obviously)
-- right unitor:
(right_unitor             : Π X : C, X ⊗ 𝟙_ ≅ X)
(notation `ρ_`            := right_unitor)
(right_unitor_naturality' :
  ∀ {X Y : C} (f : X ⟶ Y), (f ⊗' (𝟙 𝟙_)) ≫ (ρ_ Y).hom = (ρ_ X).hom ≫ f . obviously)
-- pentagon identity:
(pentagon'                : ∀ W X Y Z : C,
  ((α_ W X Y).hom ⊗' (𝟙 Z)) ≫ (α_ W (X ⊗ Y) Z).hom ≫ ((𝟙 W) ⊗' (α_ X Y Z).hom)
  = (α_ (W ⊗ X) Y Z).hom ≫ (α_ W X (Y ⊗ Z)).hom . obviously)
-- triangle identity:
(triangle'                :
  ∀ X Y : C, (α_ X 𝟙_ Y).hom ≫ ((𝟙 X) ⊗' (λ_ Y).hom) = (ρ_ X).hom ⊗' (𝟙 Y) . obviously)

restate_axiom monoidal_category.tensor_id'
attribute [simp] monoidal_category.tensor_id
restate_axiom monoidal_category.tensor_comp'
attribute [reassoc] monoidal_category.tensor_comp -- This would be redundant in the simp set.
attribute [simp] monoidal_category.tensor_comp
restate_axiom monoidal_category.associator_naturality'
attribute [reassoc] monoidal_category.associator_naturality
restate_axiom monoidal_category.left_unitor_naturality'
attribute [reassoc] monoidal_category.left_unitor_naturality
restate_axiom monoidal_category.right_unitor_naturality'
attribute [reassoc] monoidal_category.right_unitor_naturality
restate_axiom monoidal_category.pentagon'
restate_axiom monoidal_category.triangle'
attribute [reassoc] monoidal_category.pentagon
attribute [simp, reassoc] monoidal_category.triangle

open monoidal_category

infixr ` ⊗ `:70 := tensor_obj
infixr ` ⊗ `:70 := tensor_hom

notation `𝟙_` := tensor_unit
notation `α_` := associator
notation `λ_` := left_unitor
notation `ρ_` := right_unitor

/-- The tensor product of two isomorphisms is an isomorphism. -/
@[simps]
def tensor_iso {C : Type u} {X Y X' Y' : C} [category.{v} C] [monoidal_category.{v} C]
  (f : X ≅ Y) (g : X' ≅ Y') :
    X ⊗ X' ≅ Y ⊗ Y' :=
{ hom := f.hom ⊗ g.hom,
  inv := f.inv ⊗ g.inv,
  hom_inv_id' := by rw [←tensor_comp, iso.hom_inv_id, iso.hom_inv_id, ←tensor_id],
  inv_hom_id' := by rw [←tensor_comp, iso.inv_hom_id, iso.inv_hom_id, ←tensor_id] }

infixr ` ⊗ `:70 := tensor_iso

namespace monoidal_category

section

variables {C : Type u} [category.{v} C] [monoidal_category.{v} C]

instance tensor_is_iso {W X Y Z : C} (f : W ⟶ X) [is_iso f] (g : Y ⟶ Z) [is_iso g] :
  is_iso (f ⊗ g) :=
is_iso.of_iso (as_iso f ⊗ as_iso g)

@[simp] lemma inv_tensor {W X Y Z : C} (f : W ⟶ X) [is_iso f] (g : Y ⟶ Z) [is_iso g] :
  inv (f ⊗ g) = inv f ⊗ inv g :=
by { ext, simp [←tensor_comp], }

variables {U V W X Y Z : C}

-- When `rewrite_search` lands, add @[search] attributes to

-- monoidal_category.tensor_id monoidal_category.tensor_comp monoidal_category.associator_naturality
-- monoidal_category.left_unitor_naturality monoidal_category.right_unitor_naturality
-- monoidal_category.pentagon monoidal_category.triangle

-- tensor_comp_id tensor_id_comp comp_id_tensor_tensor_id
-- triangle_assoc_comp_left triangle_assoc_comp_right
-- triangle_assoc_comp_left_inv triangle_assoc_comp_right_inv
-- left_unitor_tensor left_unitor_tensor_inv
-- right_unitor_tensor right_unitor_tensor_inv
-- pentagon_inv
-- associator_inv_naturality
-- left_unitor_inv_naturality
-- right_unitor_inv_naturality

@[reassoc, simp] lemma comp_tensor_id (f : W ⟶ X) (g : X ⟶ Y) :
  (f ≫ g) ⊗ (𝟙 Z) = (f ⊗ (𝟙 Z)) ≫ (g ⊗ (𝟙 Z)) :=
by { rw ←tensor_comp, simp }

@[reassoc, simp]

@[simp, reassoc] lemma id_tensor_comp_tensor_id (f : W ⟶ X) (g : Y ⟶ Z) :
  ((𝟙 Y) ⊗ f) ≫ (g ⊗ (𝟙 X)) = g ⊗ f :=
by { rw [←tensor_comp], simp }

@[simp, reassoc] lemma tensor_id_comp_id_tensor (f : W ⟶ X) (g : Y ⟶ Z) :
  (g ⊗ (𝟙 W)) ≫ ((𝟙 Z) ⊗ f) = g ⊗ f :=
by { rw [←tensor_comp], simp }

@[reassoc]
lemma left_unitor_inv_naturality {X X' : C} (f : X ⟶ X') :
  f ≫ (λ_ X').inv = (λ_ X).inv ≫ (𝟙 _ ⊗ f) :=
begin
  apply (cancel_mono (λ_ X').hom).1,
  simp only [assoc, comp_id, iso.inv_hom_id],
  rw [left_unitor_naturality, ←category.assoc, iso.inv_hom_id, category.id_comp]
end

@[reassoc]
lemma right_unitor_inv_naturality {X X' : C} (f : X ⟶ X') :
  f ≫ (ρ_ X').inv = (ρ_ X).inv ≫ (f ⊗ 𝟙 _) :=
begin
  apply (cancel_mono (ρ_ X').hom).1,
  simp only [assoc, comp_id, iso.inv_hom_id],
  rw [right_unitor_naturality, ←category.assoc, iso.inv_hom_id, category.id_comp]
end

@[simp]
lemma right_unitor_conjugation {X Y : C} (f : X ⟶ Y) :
  (ρ_ X).inv ≫ (f ⊗ (𝟙 (𝟙_ C))) ≫ (ρ_ Y).hom = f :=
by rw [right_unitor_naturality, ←category.assoc, iso.inv_hom_id, category.id_comp]

@[simp]
lemma left_unitor_conjugation {X Y : C} (f : X ⟶ Y) :
  (λ_ X).inv ≫ ((𝟙 (𝟙_ C)) ⊗ f) ≫ (λ_ Y).hom = f :=
by rw [left_unitor_naturality, ←category.assoc, iso.inv_hom_id, category.id_comp]

@[simp] lemma tensor_left_iff
  {X Y : C} (f g : X ⟶ Y) :
  ((𝟙 (𝟙_ C)) ⊗ f = (𝟙 (𝟙_ C)) ⊗ g) ↔ (f = g) :=
by { rw [←cancel_mono (λ_ Y).hom, left_unitor_naturality, left_unitor_naturality], simp }

@[simp] lemma tensor_right_iff
  {X Y : C} (f g : X ⟶ Y) :
  (f ⊗ (𝟙 (𝟙_ C)) = g ⊗ (𝟙 (𝟙_ C))) ↔ (f = g) :=
by { rw [←cancel_mono (ρ_ Y).hom, right_unitor_naturality, right_unitor_naturality], simp }

-- See Proposition 2.2.4 of <http://www-math.mit.edu/~etingof/egnobookfinal.pdf>
@[reassoc]
lemma left_unitor_tensor' (X Y : C) :
  ((α_ (𝟙_ C) X Y).hom) ≫ ((λ_ (X ⊗ Y)).hom) = ((λ_ X).hom ⊗ (𝟙 Y)) :=
by
  rw [←tensor_left_iff, id_tensor_comp, ←cancel_epi (α_ (𝟙_ C) (𝟙_ C ⊗ X) Y).hom,
    ←cancel_epi ((α_ (𝟙_ C) (𝟙_ C) X).hom ⊗ 𝟙 Y), pentagon_assoc, triangle, ←associator_naturality,
    ←comp_tensor_id_assoc, triangle, associator_naturality, tensor_id]

@[reassoc, simp]
lemma left_unitor_tensor (X Y : C) :
  ((λ_ (X ⊗ Y)).hom) = ((α_ (𝟙_ C) X Y).inv) ≫ ((λ_ X).hom ⊗ (𝟙 Y)) :=
by { rw [←left_unitor_tensor'], simp }

lemma left_unitor_tensor_inv' (X Y : C) :
  ((λ_ (X ⊗ Y)).inv) ≫ ((α_ (𝟙_ C) X Y).inv) = ((λ_ X).inv ⊗ (𝟙 Y)) :=
eq_of_inv_eq_inv (by simp)

@[reassoc, simp]
lemma left_unitor_tensor_inv (X Y : C) :
  (λ_ (X ⊗ Y)).inv = ((λ_ X).inv ⊗ (𝟙 Y)) ≫ (α_ (𝟙_ C) X Y).hom :=
by { rw [←left_unitor_tensor_inv'], simp }

@[reassoc, simp]
lemma right_unitor_tensor (X Y : C) :
  (ρ_ (X ⊗ Y)).hom = (α_ X Y (𝟙_ C)).hom ≫ ((𝟙 X) ⊗ (ρ_ Y).hom) :=
by
  rw [←tensor_right_iff, comp_tensor_id, ←cancel_mono (α_ X Y (𝟙_ C)).hom, assoc,
      associator_naturality, ←triangle_assoc, ←triangle, id_tensor_comp, pentagon_assoc,
      ←associator_naturality, tensor_id]

@[reassoc, simp]
lemma right_unitor_tensor_inv (X Y : C) :
  ((ρ_ (X ⊗ Y)).inv) = ((𝟙 X) ⊗ (ρ_ Y).inv) ≫ (α_ X Y (𝟙_ C)).inv :=
eq_of_inv_eq_inv (by simp)

@[reassoc]
lemma id_tensor_right_unitor_inv (X Y : C) : 𝟙 X ⊗ (ρ_ Y).inv = (ρ_ _).inv ≫ (α_ _ _ _).hom :=
by simp only [right_unitor_tensor_inv, category.comp_id, iso.inv_hom_id, category.assoc]

@[reassoc]
lemma left_unitor_inv_tensor_id (X Y : C) : (λ_ X).inv ⊗ 𝟙 Y = (λ_ _).inv ≫ (α_ _ _ _).inv :=
by simp only [left_unitor_tensor_inv, assoc, comp_id, hom_inv_id]

@[reassoc]
lemma associator_inv_naturality {X Y Z X' Y' Z' : C} (f : X ⟶ X') (g : Y ⟶ Y') (h : Z ⟶ Z') :
  (f ⊗ (g ⊗ h)) ≫ (α_ X' Y' Z').inv = (α_ X Y Z).inv ≫ ((f ⊗ g) ⊗ h) :=
by { rw [comp_inv_eq, assoc, associator_naturality], simp }

@[reassoc]
lemma id_tensor_associator_naturality {X Y Z Z' : C} (h : Z ⟶ Z') :
  (𝟙 (X ⊗ Y) ⊗ h) ≫ (α_ X Y Z').hom = (α_ X Y Z).hom ≫ (𝟙 X ⊗ (𝟙 Y ⊗ h)) :=
by { rw [←tensor_id, associator_naturality], }

@[reassoc]
lemma id_tensor_associator_inv_naturality {X Y Z X' : C} (f : X ⟶ X')  :
  (f ⊗ 𝟙 (Y ⊗ Z)) ≫ (α_ X' Y Z).inv = (α_ X Y Z).inv ≫ ((f ⊗ 𝟙 Y) ⊗ 𝟙 Z) :=
by { rw [←tensor_id, associator_inv_naturality] }

@[reassoc]
lemma associator_conjugation {X X' Y Y' Z Z' : C} (f : X ⟶ X') (g : Y ⟶ Y') (h : Z ⟶ Z') :
  (α_ X Y Z).hom ≫ (f ⊗ (g ⊗ h)) ≫ (α_ X' Y' Z').inv = (f ⊗ g) ⊗ h :=
by rw [associator_inv_naturality, hom_inv_id_assoc]

@[reassoc]
lemma associator_inv_conjugation {X X' Y Y' Z Z' : C} (f : X ⟶ X') (g : Y ⟶ Y') (h : Z ⟶ Z') :
  (α_ X Y Z).inv ≫ ((f ⊗ g) ⊗ h) ≫ (α_ X' Y' Z').hom = f ⊗ g ⊗ h :=
by rw [associator_naturality, inv_hom_id_assoc]

@[reassoc]
lemma pentagon_inv (W X Y Z : C) :
  ((𝟙 W) ⊗ (α_ X Y Z).inv) ≫ (α_ W (X ⊗ Y) Z).inv ≫ ((α_ W X Y).inv ⊗ (𝟙 Z))
    = (α_ W X (Y ⊗ Z)).inv ≫ (α_ (W ⊗ X) Y Z).inv :=
category_theory.eq_of_inv_eq_inv (by simp [pentagon])

@[reassoc]
lemma pentagon_inv_inv_hom (W X Y Z : C) :
  (α_ W (X ⊗ Y) Z).inv ≫ ((α_ W X Y).inv ⊗ (𝟙 Z)) ≫ (α_ (W ⊗ X) Y Z).hom
  = ((𝟙 W) ⊗ (α_ X Y Z).hom) ≫ (α_ W X (Y ⊗ Z)).inv :=
begin
  rw ←((iso.eq_comp_inv _).mp (pentagon_inv W X Y Z)),
  slice_rhs 1 2 { rw [←id_tensor_comp, iso.hom_inv_id] },
  simp only [tensor_id, assoc, id_comp]
end

lemma triangle_assoc_comp_left (X Y : C) :
  (α_ X (𝟙_ C) Y).hom ≫ ((𝟙 X) ⊗ (λ_ Y).hom) = (ρ_ X).hom ⊗ 𝟙 Y :=
monoidal_category.triangle X Y

@[simp, reassoc] lemma triangle_assoc_comp_right (X Y : C) :
  (α_ X (𝟙_ C) Y).inv ≫ ((ρ_ X).hom ⊗ 𝟙 Y) = ((𝟙 X) ⊗ (λ_ Y).hom) :=
by rw [←triangle_assoc_comp_left, iso.inv_hom_id_assoc]

@[simp, reassoc] lemma triangle_assoc_comp_right_inv (X Y : C) :
  ((ρ_ X).inv ⊗ 𝟙 Y) ≫ (α_ X (𝟙_ C) Y).hom = ((𝟙 X) ⊗ (λ_ Y).inv) :=
begin
  apply (cancel_mono (𝟙 X ⊗ (λ_ Y).hom)).1,
  simp only [assoc, triangle_assoc_comp_left],
  rw [←comp_tensor_id, iso.inv_hom_id, ←id_tensor_comp, iso.inv_hom_id]
end

@[simp, reassoc] lemma triangle_assoc_comp_left_inv (X Y : C) :
  ((𝟙 X) ⊗ (λ_ Y).inv) ≫ (α_ X (𝟙_ C) Y).inv = ((ρ_ X).inv ⊗ 𝟙 Y) :=
begin
  apply (cancel_mono ((ρ_ X).hom ⊗ 𝟙 Y)).1,
  simp only [triangle_assoc_comp_right, assoc],
  rw [←id_tensor_comp, iso.inv_hom_id, ←comp_tensor_id, iso.inv_hom_id]
end

lemma unitors_equal : (λ_ (𝟙_ C)).hom = (ρ_ (𝟙_ C)).hom :=
by rw [←tensor_left_iff, ←cancel_epi (α_ (𝟙_ C) (𝟙_ _) (𝟙_ _)).hom, ←cancel_mono (ρ_ (𝟙_ C)).hom,
       triangle, ←right_unitor_tensor, right_unitor_naturality]

lemma unitors_inv_equal : (λ_ (𝟙_ C)).inv = (ρ_ (𝟙_ C)).inv :=
by { ext, simp [←unitors_equal] }

@[reassoc]
lemma right_unitor_inv_comp_tensor (f : W ⟶ X) (g : 𝟙_ C ⟶ Z) :
  (ρ_ _).inv ≫ (f ⊗ g) = f ≫ (ρ_ _).inv ≫ (𝟙 _ ⊗ g) :=
by { slice_rhs 1 2 { rw right_unitor_inv_naturality }, simp }

@[reassoc]
lemma left_unitor_inv_comp_tensor (f : W ⟶ X) (g : 𝟙_ C ⟶ Z) :
  (λ_ _).inv ≫ (g ⊗ f) = f ≫ (λ_ _).inv ≫ (g ⊗ 𝟙 _) :=
by { slice_rhs 1 2 { rw left_unitor_inv_naturality }, simp }

@[simp, reassoc]
lemma hom_inv_id_tensor {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (f.hom ⊗ g) ≫ (f.inv ⊗ h) = 𝟙 V ⊗ (g ≫ h) :=
by rw [←tensor_comp, f.hom_inv_id]

@[simp, reassoc]
lemma inv_hom_id_tensor {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (f.inv ⊗ g) ≫ (f.hom ⊗ h) = 𝟙 W ⊗ (g ≫ h) :=
by rw [←tensor_comp, f.inv_hom_id]

@[simp, reassoc]
lemma tensor_hom_inv_id {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (g ⊗ f.hom) ≫ (h ⊗ f.inv) = (g ≫ h) ⊗ 𝟙 V :=
by rw [←tensor_comp, f.hom_inv_id]

@[simp, reassoc]
lemma tensor_inv_hom_id {V W X Y Z : C} (f : V ≅ W) (g : X ⟶ Y) (h : Y ⟶ Z) :
  (g ⊗ f.inv) ≫ (h ⊗ f.hom) = (g ≫ h) ⊗ 𝟙 W :=
by rw [←tensor_comp, f.inv_hom_id]

@[reassoc]
lemma pentagon_hom_inv {W X Y Z : C} :
  (α_ W X (Y ⊗ Z)).hom ≫ (𝟙 W ⊗ (α_ X Y Z).inv)
  = (α_ (W ⊗ X) Y Z).inv ≫ ((α_ W X Y).hom ⊗ 𝟙 Z) ≫ (α_ W (X ⊗ Y) Z).hom :=
begin
  have pent := pentagon W X Y Z,
  rw ←iso.comp_inv_eq at pent,
  rw [iso.eq_inv_comp, ←pent],
  simp only [tensor_hom_inv_id, iso.inv_hom_id_assoc, tensor_id, category.comp_id, category.assoc],
end

@[reassoc]
lemma pentagon_inv_hom (W X Y Z : C) :
  (α_ (W ⊗ X) Y Z).inv ≫ ((α_ W X Y).hom ⊗ 𝟙 Z)
  = (α_ W X (Y ⊗ Z)).hom ≫ (𝟙 W ⊗ (α_ X Y Z).inv) ≫ (α_ W (X ⊗ Y) Z).inv :=
begin
  have pent := pentagon W X Y Z,
  rw ←iso.inv_comp_eq at pent,
  rw [←pent],
  simp only [tensor_id, assoc, id_comp, comp_id, hom_inv_id, tensor_hom_inv_id_assoc],
end

@[reassoc]
lemma pentagon_comp_id_tensor {W X Y Z : C} :
  (α_ W (X ⊗ Y) Z).hom ≫ ((𝟙 W) ⊗ (α_ X Y Z).hom)
  = ((α_ W X Y).inv ⊗ (𝟙 Z)) ≫ (α_ (W ⊗ X) Y Z).hom ≫ (α_ W X (Y ⊗ Z)).hom :=
by { rw ←pentagon W X Y Z, simp }

end

section
variables (C : Type u) [category.{v} C] [monoidal_category.{v} C]

/-- The tensor product expressed as a functor. -/
def tensor : (C × C) ⥤ C :=
{ obj := λ X, X.1 ⊗ X.2,
  map := λ {X Y : C × C} (f : X ⟶ Y), f.1 ⊗ f.2 }

/-- The left-associated triple tensor product as a functor. -/
def left_assoc_tensor : (C × C × C) ⥤ C :=
{ obj := λ X, (X.1 ⊗ X.2.1) ⊗ X.2.2,
  map := λ {X Y : C × C × C} (f : X ⟶ Y), (f.1 ⊗ f.2.1) ⊗ f.2.2 }

@[simp] lemma left_assoc_tensor_obj (X) :
  (left_assoc_tensor C).obj X = (X.1 ⊗ X.2.1) ⊗ X.2.2 := rfl
@[simp] lemma left_assoc_tensor_map {X Y} (f : X ⟶ Y) :
  (left_assoc_tensor C).map f = (f.1 ⊗ f.2.1) ⊗ f.2.2 := rfl

/-- The right-associated triple tensor product as a functor. -/
def right_assoc_tensor : (C × C × C) ⥤ C :=
{ obj := λ X, X.1 ⊗ (X.2.1 ⊗ X.2.2),
  map := λ {X Y : C × C × C} (f : X ⟶ Y), f.1 ⊗ (f.2.1 ⊗ f.2.2) }

@[simp] lemma right_assoc_tensor_obj (X) :
  (right_assoc_tensor C).obj X = X.1 ⊗ (X.2.1 ⊗ X.2.2) := rfl
@[simp] lemma right_assoc_tensor_map {X Y} (f : X ⟶ Y) :
  (right_assoc_tensor C).map f = f.1 ⊗ (f.2.1 ⊗ f.2.2) := rfl

/-- The functor `λ X, 𝟙_ C ⊗ X`. -/
def tensor_unit_left : C ⥤ C :=
{ obj := λ X, 𝟙_ C ⊗ X,
  map := λ {X Y : C} (f : X ⟶ Y), (𝟙 (𝟙_ C)) ⊗ f }
/-- The functor `λ X, X ⊗ 𝟙_ C`. -/
def tensor_unit_right : C ⥤ C :=
{ obj := λ X, X ⊗ 𝟙_ C,
  map := λ {X Y : C} (f : X ⟶ Y), f ⊗ (𝟙 (𝟙_ C)) }

-- We can express the associator and the unitors, given componentwise above,
-- as natural isomorphisms.

/-- The associator as a natural isomorphism. -/
@[simps]
def associator_nat_iso :
  left_assoc_tensor C ≅ right_assoc_tensor C :=
nat_iso.of_components
  (by { intros, apply monoidal_category.associator })
  (by { intros, apply monoidal_category.associator_naturality })

/-- The left unitor as a natural isomorphism. -/
@[simps]
def left_unitor_nat_iso :
  tensor_unit_left C ≅ 𝟭 C :=
nat_iso.of_components
  (by { intros, apply monoidal_category.left_unitor })
  (by { intros, apply monoidal_category.left_unitor_naturality })

/-- The right unitor as a natural isomorphism. -/
@[simps]
def right_unitor_nat_iso :
  tensor_unit_right C ≅ 𝟭 C :=
nat_iso.of_components
  (by { intros, apply monoidal_category.right_unitor })
  (by { intros, apply monoidal_category.right_unitor_naturality })

section
variables {C}

/-- Tensoring on the left with a fixed object, as a functor. -/
@[simps]
def tensor_left (X : C) : C ⥤ C :=
{ obj := λ Y, X ⊗ Y,
  map := λ Y Y' f, (𝟙 X) ⊗ f, }

/--
Tensoring on the left with `X ⊗ Y` is naturally isomorphic to
tensoring on the left with `Y`, and then again with `X`.
-/
def tensor_left_tensor (X Y : C) : tensor_left (X ⊗ Y) ≅ tensor_left Y ⋙ tensor_left X :=
nat_iso.of_components
  (associator _ _)
  (λ Z Z' f, by { dsimp, rw[←tensor_id], apply associator_naturality })

@[simp] lemma tensor_left_tensor_hom_app (X Y Z : C) :
  (tensor_left_tensor X Y).hom.app Z = (associator X Y Z).hom :=
rfl
@[simp] lemma tensor_left_tensor_inv_app (X Y Z : C) :
  (tensor_left_tensor X Y).inv.app Z = (associator X Y Z).inv :=
by { simp [tensor_left_tensor], }

/-- Tensoring on the right with a fixed object, as a functor. -/
@[simps]
def tensor_right (X : C) : C ⥤ C :=
{ obj := λ Y, Y ⊗ X,
  map := λ Y Y' f, f ⊗ (𝟙 X), }

variables (C)

/--
Tensoring on the left, as a functor from `C` into endofunctors of `C`.

TODO: show this is a op-monoidal functor.
-/
@[simps]
def tensoring_left : C ⥤ C ⥤ C :=
{ obj := tensor_left,
  map := λ X Y f,
  { app := λ Z, f ⊗ (𝟙 Z) } }

instance : faithful (tensoring_left C) :=
{ map_injective' := λ X Y f g h,
  begin
    injections with h,
    replace h := congr_fun h (𝟙_ C),
    simpa using h,
  end }

/--
Tensoring on the right, as a functor from `C` into endofunctors of `C`.

We later show this is a monoidal functor.
-/
@[simps]
def tensoring_right : C ⥤ C ⥤ C :=
{ obj := tensor_right,
  map := λ X Y f,
  { app := λ Z, (𝟙 Z) ⊗ f } }

instance : faithful (tensoring_right C) :=
{ map_injective' := λ X Y f g h,
  begin
    injections with h,
    replace h := congr_fun h (𝟙_ C),
    simpa using h,
  end }

variables {C}

/--
Tensoring on the right with `X ⊗ Y` is naturally isomorphic to
tensoring on the right with `X`, and then again with `Y`.
-/
def tensor_right_tensor (X Y : C) : tensor_right (X ⊗ Y) ≅ tensor_right X ⋙ tensor_right Y :=
nat_iso.of_components
  (λ Z, (associator Z X Y).symm)
  (λ Z Z' f, by { dsimp, rw[←tensor_id], apply associator_inv_naturality })

@[simp] lemma tensor_right_tensor_hom_app (X Y Z : C) :
  (tensor_right_tensor X Y).hom.app Z = (associator Z X Y).inv :=
rfl
@[simp] lemma tensor_right_tensor_inv_app (X Y Z : C) :
  (tensor_right_tensor X Y).inv.app Z = (associator Z X Y).hom :=
by simp [tensor_right_tensor]

variables {C}

/--
Any property closed under `𝟙_` and `⊗` induces a full monoidal subcategory of `C`, where
the category on the subtype is given by `full_subcategory`.
-/
def full_monoidal_subcategory (P : C → Prop) (h_id : P (𝟙_ C))
 (h_tensor : ∀ {X Y}, P X → P Y → P (X ⊗ Y)) : monoidal_category {X : C // P X} :=
{ tensor_obj := λ X Y, ⟨X ⊗ Y, h_tensor X.2 Y.2⟩,
  tensor_hom := λ X₁ Y₁ X₂ Y₂ f g, by { change X₁.1 ⊗ X₂.1 ⟶ Y₁.1 ⊗ Y₂.1,
    change X₁.1 ⟶ Y₁.1 at f, change X₂.1 ⟶ Y₂.1 at g, exact f ⊗ g },
  tensor_unit := ⟨𝟙_ C, h_id⟩,
  associator := λ X Y Z,
    ⟨(α_ X.1 Y.1 Z.1).hom, (α_ X.1 Y.1 Z.1).inv,
     hom_inv_id (α_ X.1 Y.1 Z.1), inv_hom_id (α_ X.1 Y.1 Z.1)⟩,
  left_unitor := λ X, ⟨(λ_ X.1).hom, (λ_ X.1).inv, hom_inv_id (λ_ X.1), inv_hom_id (λ_ X.1)⟩,
  right_unitor := λ X, ⟨(ρ_ X.1).hom, (ρ_ X.1).inv, hom_inv_id (ρ_ X.1), inv_hom_id (ρ_ X.1)⟩,
  tensor_id' := λ X Y, tensor_id X.1 Y.1,
  tensor_comp' := λ X₁ Y₁ Z₁ X₂ Y₂ Z₂ f₁ f₂ g₁ g₂, tensor_comp f₁ f₂ g₁ g₂,
  associator_naturality' := λ X₁ X₂ X₃ Y₁ Y₂ Y₃ f₁ f₂ f₃, associator_naturality f₁ f₂ f₃,
  left_unitor_naturality' := λ X Y f, left_unitor_naturality f,
  right_unitor_naturality' := λ X Y f, right_unitor_naturality f,
  pentagon' := λ W X Y Z, pentagon W.1 X.1 Y.1 Z.1,
  triangle' := λ X Y, triangle X.1 Y.1 }

end

end

end monoidal_category

end category_theory


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

import algebra.ordered_ring
import data.int.basic
import tactic.norm_num

/-!
# Lemmas for `linarith`

This file contains auxiliary lemmas that `linarith` uses to construct proofs.
If you find yourself looking for a theorem here, you might be in the wrong place.
-/

namespace linarith

lemma int.coe_nat_bit0 (n : ℕ) : (↑(bit0 n : ℕ) : ℤ) = bit0 (↑n : ℤ) := by simp [bit0]
lemma int.coe_nat_bit1 (n : ℕ) : (↑(bit1 n : ℕ) : ℤ) = bit1 (↑n : ℤ) := by simp [bit1, bit0]
lemma int.coe_nat_bit0_mul (n : ℕ) (x : ℕ) : (↑(bit0 n * x) : ℤ) = (↑(bit0 n) : ℤ) * (↑x : ℤ) :=
by simp
lemma int.coe_nat_bit1_mul (n : ℕ) (x : ℕ) : (↑(bit1 n * x) : ℤ) = (↑(bit1 n) : ℤ) * (↑x : ℤ) :=
by simp
lemma int.coe_nat_one_mul (x : ℕ) : (↑(1 * x) : ℤ) = 1 * (↑x : ℤ) := by simp
lemma int.coe_nat_zero_mul (x : ℕ) : (↑(0 * x) : ℤ) = 0 * (↑x : ℤ) := by simp
lemma int.coe_nat_mul_bit0 (n : ℕ) (x : ℕ) : (↑(x * bit0 n) : ℤ) = (↑x : ℤ) * (↑(bit0 n) : ℤ) :=
by simp
lemma int.coe_nat_mul_bit1 (n : ℕ) (x : ℕ) : (↑(x * bit1 n) : ℤ) = (↑x : ℤ) * (↑(bit1 n) : ℤ) :=
by simp
lemma int.coe_nat_mul_one (x : ℕ) : (↑(x * 1) : ℤ) = (↑x : ℤ) * 1 := by simp
lemma int.coe_nat_mul_zero (x : ℕ) : (↑(x * 0) : ℤ) = (↑x : ℤ) * 0 := by simp

lemma nat_eq_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 = n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) :
  z1 = z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_eq_coe_nat_iff]

lemma nat_le_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 ≤ n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) :
  z1 ≤ z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_le]

lemma nat_lt_subst {n1 n2 : ℕ} {z1 z2 : ℤ} (hn : n1 < n2) (h1 : ↑n1 = z1) (h2 : ↑n2 = z2) :
  z1 < z2 :=
by simpa [eq.symm h1, eq.symm h2, int.coe_nat_lt]

lemma eq_of_eq_of_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b = 0) : a + b = 0 :=
by simp *

lemma le_of_eq_of_le {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b ≤ 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_eq_of_lt {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : b < 0) : a + b < 0 :=
by simp *

lemma le_of_le_of_eq {α} [ordered_semiring α] {a b : α} (ha : a ≤ 0) (hb : b = 0) : a + b ≤ 0 :=
by simp *

lemma lt_of_lt_of_eq {α} [ordered_semiring α] {a b : α} (ha : a < 0) (hb : b = 0) : a + b < 0 :=
by simp *

lemma mul_neg {α} [ordered_ring α] {a b : α} (ha : a < 0) (hb : 0 < b) : b * a < 0 :=
have (-b)*a > 0, from mul_pos_of_neg_of_neg (neg_neg_of_pos hb) ha,
neg_of_neg_pos (by simpa)

lemma mul_nonpos {α} [ordered_ring α] {a b : α} (ha : a ≤ 0) (hb : 0 < b) : b * a ≤ 0 :=
have (-b)*a ≥ 0, from mul_nonneg_of_nonpos_of_nonpos (le_of_lt (neg_neg_of_pos hb)) ha,
by simpa

-- used alongside `mul_neg` and `mul_nonpos`, so has the same argument pattern for uniformity
@[nolint unused_arguments]
lemma mul_eq {α} [ordered_semiring α] {a b : α} (ha : a = 0) (hb : 0 < b) : b * a = 0 :=
by simp *

lemma eq_of_not_lt_of_not_gt {α} [linear_order α] (a b : α) (h1 : ¬ a < b) (h2 : ¬ b < a) : a = b :=
le_antisymm (le_of_not_gt h2) (le_of_not_gt h1)

-- used in the `nlinarith` normalization steps. The `_` argument is for uniformity.
@[nolint unused_arguments]
lemma mul_zero_eq {α} {R : α → α → Prop} [semiring α] {a b : α} (_ : R a 0) (h : b = 0) :
  a * b = 0 :=
by simp [h]

-- used in the `nlinarith` normalization steps. The `_` argument is for uniformity.
@[nolint unused_arguments]
lemma zero_mul_eq {α} {R : α → α → Prop} [semiring α] {a b : α} (h : a = 0) (_ : R b 0) :
  a * b = 0 :=
by simp [h]

end linarith