/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.field_theory.adjoin
import Mathlib.field_theory.minpoly
import Mathlib.ring_theory.adjoin
import Mathlib.ring_theory.adjoin_root
import Mathlib.ring_theory.algebraic
import Mathlib.PostPort

universes u_8 u_9 l u_2 u_6 u_1 u_4 u_7

namespace Mathlib

/-!
# Power basis

This file defines a structure `power_basis R S`, giving a basis of the
`R`-algebra `S` as a finite list of powers `1, x, ..., x^n`.
There are also constructors for `power_basis` when adjoining an algebraic
element to a ring/field.

## Definitions

* `power_basis R A`: a structure containing an `x` and an `n` such that
`1, x, ..., x^n` is a basis for the `R`-algebra `A` (viewed as an `R`-module).

* `findim (hf : f ≠ 0) : finite_dimensional.findim K (adjoin_root f) = f.nat_degree`,
  the dimension of `adjoin_root f` equals the degree of `f`

* `power_basis.lift (pb : power_basis R S)`: if `y : S'` satisfies the same
  equations as `pb.gen`, this is the map `S →ₐ[R] S'` sending `pb.gen` to `y`

* `power_basis.equiv`: if two power bases satisfy the same equations, they are
  equivalent as algebras

## Implementation notes

Throughout this file, `R`, `S`, ... are `comm_ring`s, `A`, `B`, ... are
`integral_domain`s and `K`, `L`, ... are `field`s.
`S` is an `R`-algebra, `B` is an `A`-algebra, `L` is a `K`-algebra.

## Tags

power basis, powerbasis

-/

/-- `pb : power_basis R S` states that `1, pb.gen, ..., pb.gen ^ (pb.dim - 1)`
is a basis for the `R`-algebra `S` (viewed as `R`-module).

This is a structure, not a class, since the same algebra can have many power bases.
For the common case where `S` is defined by adjoining an integral element to `R`,
the canonical power basis is given by `{algebra,intermediate_field}.adjoin.power_basis`.
-/
structure power_basis (R : Type u_8) (S : Type u_9) [comm_ring R] [ring S] [algebra R S]
where
  gen : S
  dim : ℕ
  is_basis : is_basis R fun (i : fin dim) => gen ^ ↑i

namespace power_basis

/-- Cannot be an instance because `power_basis` cannot be a class. -/
theorem finite_dimensional {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S] (pb : power_basis K S) : finite_dimensional K S :=
  finite_dimensional.of_fintype_basis (is_basis pb)

theorem findim {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S] (pb : power_basis K S) : finite_dimensional.findim K S = dim pb := sorry

/-- TODO: this mixes `polynomial` and `finsupp`, we should hide this behind a
new function `polynomial.of_finsupp`. -/
theorem polynomial.mem_supported_range {R : Type u_1} [comm_ring R] {f : polynomial R} {d : ℕ} : f ∈ finsupp.supported R R ↑(finset.range d) ↔ polynomial.degree f < ↑d := sorry

theorem mem_span_pow' {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S] {x : S} {y : S} {d : ℕ} : y ∈ submodule.span R (set.range fun (i : fin d) => x ^ ↑i) ↔
  ∃ (f : polynomial R), polynomial.degree f < ↑d ∧ y = coe_fn (polynomial.aeval x) f := sorry

theorem mem_span_pow {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S] {x : S} {y : S} {d : ℕ} (hd : d ≠ 0) : y ∈ submodule.span R (set.range fun (i : fin d) => x ^ ↑i) ↔
  ∃ (f : polynomial R), polynomial.nat_degree f < d ∧ y = coe_fn (polynomial.aeval x) f := sorry

theorem dim_ne_zero {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S] [nontrivial S] (pb : power_basis R S) : dim pb ≠ 0 := sorry

theorem exists_eq_aeval {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S] [nontrivial S] (pb : power_basis R S) (y : S) : ∃ (f : polynomial R), polynomial.nat_degree f < dim pb ∧ y = coe_fn (polynomial.aeval (gen pb)) f :=
  iff.mp (mem_span_pow (dim_ne_zero pb)) (is_basis.mem_span (is_basis pb) y)

/-- `pb.minpoly_gen` is a minimal polynomial for `pb.gen`.

If `A` is not a field, it might not necessarily be *the* minimal polynomial,
however `nat_degree_minpoly` shows its degree is indeed minimal.
-/
def minpoly_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] (pb : power_basis A S) : polynomial A :=
  polynomial.X ^ dim pb -
    finset.sum finset.univ
      fun (i : fin (dim pb)) =>
        coe_fn polynomial.C (coe_fn (coe_fn (is_basis.repr sorry) (gen pb ^ dim pb)) i) * polynomial.X ^ ↑i

@[simp] theorem nat_degree_minpoly_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] (pb : power_basis A S) : polynomial.nat_degree (minpoly_gen pb) = dim pb := sorry

theorem minpoly_gen_monic {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] (pb : power_basis A S) : polynomial.monic (minpoly_gen pb) := sorry

@[simp] theorem aeval_minpoly_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] (pb : power_basis A S) : coe_fn (polynomial.aeval (gen pb)) (minpoly_gen pb) = 0 := sorry

theorem is_integral_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] (pb : power_basis A S) : is_integral A (gen pb) :=
  Exists.intro (minpoly_gen pb) { left := minpoly_gen_monic pb, right := aeval_minpoly_gen pb }

theorem dim_le_nat_degree_of_root {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] (h : power_basis A S) {p : polynomial A} (ne_zero : p ≠ 0) (root : coe_fn (polynomial.aeval (gen h)) p = 0) : dim h ≤ polynomial.nat_degree p := sorry

@[simp] theorem nat_degree_minpoly {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] (pb : power_basis A S) : polynomial.nat_degree (minpoly A (gen pb)) = dim pb := sorry

theorem nat_degree_lt_nat_degree {R : Type u_1} [comm_ring R] {p : polynomial R} {q : polynomial R} (hp : p ≠ 0) (hpq : polynomial.degree p < polynomial.degree q) : polynomial.nat_degree p < polynomial.nat_degree q := sorry

theorem constr_pow_aeval {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] (pb : power_basis A S) {y : S'} (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) (f : polynomial A) : coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) (coe_fn (polynomial.aeval (gen pb)) f) =
  coe_fn (polynomial.aeval y) f := sorry

theorem constr_pow_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] (pb : power_basis A S) {y : S'} (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) : coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) (gen pb) = y := sorry

theorem constr_pow_algebra_map {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] (pb : power_basis A S) {y : S'} (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) (x : A) : coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) (coe_fn (algebra_map A S) x) =
  coe_fn (algebra_map A S') x := sorry

theorem constr_pow_mul {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] (pb : power_basis A S) {y : S'} (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) (x : S) (x' : S) : coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) (x * x') =
  coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) x *
    coe_fn (is_basis.constr (is_basis pb) fun (i : fin (dim pb)) => y ^ ↑i) x' := sorry

/-- `pb.lift y hy` is the algebra map sending `pb.gen` to `y`,
where `hy` states the higher powers of `y` are the same as the higher powers of `pb.gen`. -/
def lift {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] (pb : power_basis A S) (y : S') (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) : alg_hom A S S' :=
  alg_hom.mk (linear_map.to_fun (is_basis.constr sorry fun (i : fin (dim pb)) => y ^ ↑i)) sorry (constr_pow_mul pb hy)
    sorry sorry (constr_pow_algebra_map pb hy)

@[simp] theorem lift_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] (pb : power_basis A S) (y : S') (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) : coe_fn (lift pb y hy) (gen pb) = y :=
  constr_pow_gen pb hy

@[simp] theorem lift_aeval {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] (pb : power_basis A S) (y : S') (hy : coe_fn (polynomial.aeval y) (minpoly A (gen pb)) = 0) (f : polynomial A) : coe_fn (lift pb y hy) (coe_fn (polynomial.aeval (gen pb)) f) = coe_fn (polynomial.aeval y) f :=
  constr_pow_aeval pb hy f

/-- `pb.equiv pb' h` is an equivalence of algebras with the same power basis. -/
def equiv {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S'] (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb')) : alg_equiv A S S' :=
  alg_equiv.of_alg_hom (lift pb (gen pb') sorry) (lift pb' (gen pb) sorry) sorry sorry

@[simp] theorem equiv_aeval {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S'] (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb')) (f : polynomial A) : coe_fn (equiv pb pb' h) (coe_fn (polynomial.aeval (gen pb)) f) = coe_fn (polynomial.aeval (gen pb')) f :=
  lift_aeval pb (gen pb') (Eq.symm h ▸ minpoly.aeval A (gen pb')) f

@[simp] theorem equiv_gen {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S'] (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb')) : coe_fn (equiv pb pb' h) (gen pb) = gen pb' :=
  lift_gen pb (gen pb') (Eq.symm h ▸ minpoly.aeval A (gen pb'))

@[simp] theorem equiv_symm {S : Type u_2} [comm_ring S] {A : Type u_4} [integral_domain A] [algebra A S] {S' : Type u_8} [comm_ring S'] [algebra A S'] [nontrivial S] [nontrivial S'] (pb : power_basis A S) (pb' : power_basis A S') (h : minpoly A (gen pb) = minpoly A (gen pb')) : alg_equiv.symm (equiv pb pb' h) = equiv pb' pb (Eq.symm h) :=
  rfl

end power_basis

namespace algebra

theorem mem_span_power_basis {R : Type u_1} {S : Type u_2} [comm_ring R] [comm_ring S] [algebra R S] [nontrivial R] {x : S} {y : S} (hx : is_integral R x) (hy : ∃ (f : polynomial R), y = coe_fn (polynomial.aeval x) f) : y ∈ submodule.span R (set.range fun (i : fin (polynomial.nat_degree (minpoly R x))) => x ^ ↑i) := sorry

theorem linear_independent_power_basis {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S] {x : S} (hx : is_integral K x) : linear_independent K fun (i : fin (polynomial.nat_degree (minpoly K x))) => x ^ ↑i := sorry

theorem power_basis_is_basis {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S] {x : S} (hx : is_integral K x) : is_basis K
  fun (i : fin (polynomial.nat_degree (minpoly K x))) =>
    { val := x, property := subset_adjoin (set.mem_singleton x) } ^ ↑i := sorry

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K[x]`,
where `d` is the degree of the minimal polynomial of `x`. -/
def adjoin.power_basis {S : Type u_2} [comm_ring S] {K : Type u_6} [field K] [algebra K S] {x : S} (hx : is_integral K x) : power_basis K ↥(adjoin K (singleton x)) :=
  power_basis.mk { val := x, property := sorry } (polynomial.nat_degree (minpoly K x)) (power_basis_is_basis hx)

end algebra

namespace adjoin_root

theorem power_basis_is_basis {K : Type u_6} [field K] {f : polynomial K} (hf : f ≠ 0) : is_basis K fun (i : fin (polynomial.nat_degree f)) => root f ^ subtype.val i := sorry

/-- The power basis `1, root f, ..., root f ^ (d - 1)` for `adjoin_root f`,
where `f` is an irreducible polynomial over a field of degree `d`. -/
def power_basis {K : Type u_6} [field K] {f : polynomial K} (hf : f ≠ 0) : power_basis K (adjoin_root f) :=
  power_basis.mk (root f) (polynomial.nat_degree f) (power_basis_is_basis hf)

end adjoin_root

namespace intermediate_field

theorem power_basis_is_basis {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L} (hx : is_integral K x) : is_basis K fun (i : fin (polynomial.nat_degree (minpoly K x))) => adjoin_simple.gen K x ^ ↑i := sorry

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K⟮x⟯`,
where `d` is the degree of the minimal polynomial of `x`. -/
def adjoin.power_basis {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L} (hx : is_integral K x) : power_basis K ↥(adjoin K (insert.insert ∅ x)) :=
  power_basis.mk (adjoin_simple.gen K x) (polynomial.nat_degree (minpoly K x)) (power_basis_is_basis hx)

@[simp] theorem adjoin.power_basis.gen_eq {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L} (hx : is_integral K x) : power_basis.gen (adjoin.power_basis hx) = adjoin_simple.gen K x :=
  rfl

theorem adjoin.finite_dimensional {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L} (hx : is_integral K x) : finite_dimensional K ↥(adjoin K (insert.insert ∅ x)) :=
  power_basis.finite_dimensional (adjoin.power_basis hx)

theorem adjoin.findim {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] {x : L} (hx : is_integral K x) : finite_dimensional.findim K ↥(adjoin K (insert.insert ∅ x)) = polynomial.nat_degree (minpoly K x) := sorry

end intermediate_field

namespace power_basis

/-- `pb.equiv_adjoin_simple` is the equivalence between `K⟮pb.gen⟯` and `L` itself. -/
def equiv_adjoin_simple {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] (pb : power_basis K L) : alg_equiv K (↥(intermediate_field.adjoin K (intermediate_field.insert.insert ∅ (gen pb)))) L :=
  equiv (intermediate_field.adjoin.power_basis sorry) pb sorry

@[simp] theorem equiv_adjoin_simple_aeval {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] (pb : power_basis K L) (f : polynomial K) : coe_fn (equiv_adjoin_simple pb) (coe_fn (polynomial.aeval (intermediate_field.adjoin_simple.gen K (gen pb))) f) =
  coe_fn (polynomial.aeval (gen pb)) f :=
  equiv_aeval (intermediate_field.adjoin.power_basis (equiv_adjoin_simple._proof_3 pb)) pb
    (equiv_adjoin_simple._proof_4 pb) f

@[simp] theorem equiv_adjoin_simple_gen {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] (pb : power_basis K L) : coe_fn (equiv_adjoin_simple pb) (intermediate_field.adjoin_simple.gen K (gen pb)) = gen pb :=
  equiv_gen (intermediate_field.adjoin.power_basis (equiv_adjoin_simple._proof_3 pb)) pb (equiv_adjoin_simple._proof_4 pb)

@[simp] theorem equiv_adjoin_simple_symm_aeval {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] (pb : power_basis K L) (f : polynomial K) : coe_fn (alg_equiv.symm (equiv_adjoin_simple pb)) (coe_fn (polynomial.aeval (gen pb)) f) =
  coe_fn (polynomial.aeval (intermediate_field.adjoin_simple.gen K (gen pb))) f := sorry

@[simp] theorem equiv_adjoin_simple_symm_gen {K : Type u_6} {L : Type u_7} [field K] [field L] [algebra K L] (pb : power_basis K L) : coe_fn (alg_equiv.symm (equiv_adjoin_simple pb)) (gen pb) = intermediate_field.adjoin_simple.gen K (gen pb) := sorry


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.category.default
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Tools to reformulate category-theoretic axioms in a more associativity-friendly way

## The `reassoc` attribute

The `reassoc` attribute can be applied to a lemma

```lean
@[reassoc]
lemma some_lemma : foo ≫ bar = baz := ...
```

and produce

```lean
lemma some_lemma_assoc {Y : C} (f : X ⟶ Y) : foo ≫ bar ≫ f = baz ≫ f := ...
```

The name of the produced lemma can be specified with `@[reassoc other_lemma_name]`. If
`simp` is added first, the generated lemma will also have the `simp` attribute.

## The `reassoc_axiom` command

When declaring a class of categories, the axioms can be reformulated to be more amenable
to manipulation in right associated expressions:

```lean
class some_class (C : Type) [category C] :=
(foo : Π X : C, X ⟶ X)
(bar : ∀ {X Y : C} (f : X ⟶ Y), foo X ≫ f = f ≫ foo Y)

reassoc_axiom some_class.bar
```

Here too, the `reassoc` attribute can be used instead. It works well when combined with
`simp`:

```lean
attribute [simp, reassoc] some_class.bar
```
-/

namespace tactic

/-- From an expression `f ≫ g`, extract the expression representing the category instance. -/
/-- (internals for `@[reassoc]`)
Given a lemma of the form `f ≫ g = h`, proves a new lemma of the form
`h : ∀ {W} (k), f ≫ (g ≫ k) = h ≫ k`, and returns the type and proof of this lemma.
-/
/-- (implementation for `@[reassoc]`)
Given a declaration named `n` of the form `f ≫ g = h`, proves a new lemma named `n'`
of the form `∀ {W} (k), f ≫ (g ≫ k) = h ≫ k`.
-/
/--
The `reassoc` attribute can be applied to a lemma

```lean
@[reassoc]
lemma some_lemma : foo ≫ bar = baz := ...
```

to produce

```lean
lemma some_lemma_assoc {Y : C} (f : X ⟶ Y) : foo ≫ bar ≫ f = baz ≫ f := ...
```

The name of the produced lemma can be specified with `@[reassoc other_lemma_name]`. If
`simp` is added first, the generated lemma will also have the `simp` attribute.
-/
/--
When declaring a class of categories, the axioms can be reformulated to be more amenable
to manipulation in right associated expressions:

```lean
class some_class (C : Type) [category C] :=
(foo : Π X : C, X ⟶ X)
(bar : ∀ {X Y : C} (f : X ⟶ Y), foo X ≫ f = f ≫ foo Y)

reassoc_axiom some_class.bar
```

The above will produce:

```lean
lemma some_class.bar_assoc {Z : C} (g : Y ⟶ Z) :
  foo X ≫ f ≫ g = f ≫ foo Y ≫ g := ...
```

Here too, the `reassoc` attribute can be used instead. It works well when combined with
`simp`:

```lean
attribute [simp, reassoc] some_class.bar
```
-/
namespace interactive

/-- `reassoc h`, for assumption `h : x ≫ y = z`, creates a new assumption
`h : ∀ {W} (f : Z ⟶ W), x ≫ y ≫ f = z ≫ f`.
`reassoc! h`, does the same but deletes the initial `h` assumption.
(You can also add the attribute `@[reassoc]` to lemmas to generate new declarations generalized
in this way.)
-/
end interactive

def calculated_Prop {α : Sort u_1} (β : Prop) (hh : α) :=
  β

end tactic

/-- With `h : x ≫ y ≫ z = x` (with universal quantifiers tolerated),
`reassoc_of h : ∀ {X'} (f : W ⟶ X'), x ≫ y ≫ z ≫ f = x ≫ f`.

The type and proof of `reassoc_of h` is generated by `tactic.derive_reassoc_proof`
which make `reassoc_of` meta-programming adjacent. It is not called as a tactic but as
an expression. The goal is to avoid creating assumptions that are dismissed after one use:

```lean
example (X Y Z W : C) (x : X ⟶ Y) (y : Y ⟶ Z) (z z' : Z ⟶ W) (w : X ⟶ Z)
  (h : x ≫ y = w)
  (h' : y ≫ z = y ≫ z') :
  x ≫ y ≫ z = w ≫ z' :=
begin
  rw [h',reassoc_of h],
end
```
-/
theorem category_theory.reassoc_of {α : Sort u_1} (hh : α) {β : Prop} (x : autoParam (tactic.calculated_Prop β hh)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.derive_reassoc_proof")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "derive_reassoc_proof")
    [])) : β :=
  x

/--
`reassoc_of h` takes local assumption `h` and add a ` ≫ f` term on the right of


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import category_theory.types
import category_theory.equivalence

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

open opposite

variables {C : Type u₁}

section quiver

variables [quiver.{v₁} C]

lemma quiver.hom.op_inj {X Y : C} :
  function.injective (quiver.hom.op : (X ⟶ Y) → (op Y ⟶ op X)) :=
λ _ _ H, congr_arg quiver.hom.unop H

lemma quiver.hom.unop_inj {X Y : Cᵒᵖ} :
  function.injective (quiver.hom.unop : (X ⟶ Y) → (unop Y ⟶ unop X)) :=
λ _ _ H, congr_arg quiver.hom.op H

@[simp] lemma quiver.hom.unop_op {X Y : C} {f : X ⟶ Y} : f.op.unop = f := rfl
@[simp] lemma quiver.hom.op_unop {X Y : Cᵒᵖ} {f : X ⟶ Y} : f.unop.op = f := rfl

end quiver

namespace category_theory

variables [category.{v₁} C]

/--
The opposite category.

See https://stacks.math.columbia.edu/tag/001M.
-/
instance category.opposite : category.{v₁} Cᵒᵖ :=
{ comp := λ _ _ _ f g, (g.unop ≫ f.unop).op,
  id   := λ X, (𝟙 (unop X)).op }

@[simp] lemma op_comp {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).op = g.op ≫ f.op := rfl
@[simp] lemma op_id {X : C} : (𝟙 X).op = 𝟙 (op X) := rfl

@[simp] lemma unop_comp {X Y Z : Cᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).unop = g.unop ≫ f.unop := rfl
@[simp] lemma unop_id {X : Cᵒᵖ} : (𝟙 X).unop = 𝟙 (unop X) := rfl

@[simp] lemma unop_id_op {X : C} : (𝟙 (op X)).unop = 𝟙 X := rfl
@[simp] lemma op_id_unop {X : Cᵒᵖ} : (𝟙 (unop X)).op = 𝟙 X := rfl

section
variables (C)

/-- The functor from the double-opposite of a category to the underlying category. -/
@[simps]
def op_op : (Cᵒᵖ)ᵒᵖ ⥤ C :=
{ obj := λ X, unop (unop X),
  map := λ X Y f, f.unop.unop }

/-- The functor from a category to its double-opposite.  -/
@[simps]
def unop_unop : C ⥤ Cᵒᵖᵒᵖ :=
{ obj := λ X, op (op X),
  map := λ X Y f, f.op.op }

/-- The double opposite category is equivalent to the original. -/
@[simps]
def op_op_equivalence : Cᵒᵖᵒᵖ ≌ C :=
{ functor := op_op C,
  inverse := unop_unop C,
  unit_iso := iso.refl (𝟭 Cᵒᵖᵒᵖ),
  counit_iso := iso.refl (unop_unop C ⋙ op_op C) }

end

/--
If `f.op` is an isomorphism `f` must be too.
(This cannot be an instance as it would immediately loop!)
-/
lemma is_iso_of_op {X Y : C} (f : X ⟶ Y) [is_iso f.op] : is_iso f :=
⟨⟨(inv (f.op)).unop,
  ⟨quiver.hom.op_inj (by simp), quiver.hom.op_inj (by simp)⟩⟩⟩

namespace functor

section

variables {D : Type u₂} [category.{v₂} D]

variables {C D}

/--
The opposite of a functor, i.e. considering a functor `F : C ⥤ D` as a functor `Cᵒᵖ ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made between these.
-/
@[simps]
protected def op (F : C ⥤ D) : Cᵒᵖ ⥤ Dᵒᵖ :=
{ obj := λ X, op (F.obj (unop X)),
  map := λ X Y f, (F.map f.unop).op }

/--
Given a functor `F : Cᵒᵖ ⥤ Dᵒᵖ` we can take the "unopposite" functor `F : C ⥤ D`.
In informal mathematics no distinction is made between these.
-/
@[simps]
protected def unop (F : Cᵒᵖ ⥤ Dᵒᵖ) : C ⥤ D :=
{ obj := λ X, unop (F.obj (op X)),
  map := λ X Y f, (F.map f.op).unop }

/-- The isomorphism between `F.op.unop` and `F`. -/
def op_unop_iso (F : C ⥤ D) : F.op.unop ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

/-- The isomorphism between `F.unop.op` and `F`. -/
def unop_op_iso (F : Cᵒᵖ ⥤ Dᵒᵖ) : F.unop.op ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

variables (C D)

/--
Taking the opposite of a functor is functorial.
-/
@[simps]
def op_hom : (C ⥤ D)ᵒᵖ ⥤ (Cᵒᵖ ⥤ Dᵒᵖ) :=
{ obj := λ F, (unop F).op,
  map := λ F G α,
  { app := λ X, (α.unop.app (unop X)).op,
    naturality' := λ X Y f, quiver.hom.unop_inj (α.unop.naturality f.unop).symm } }

/--
Take the "unopposite" of a functor is functorial.
-/
@[simps]
def op_inv : (Cᵒᵖ ⥤ Dᵒᵖ) ⥤ (C ⥤ D)ᵒᵖ :=
{ obj := λ F, op F.unop,
  map := λ F G α, quiver.hom.op
  { app := λ X, (α.app (op X)).unop,
    naturality' := λ X Y f, quiver.hom.op_inj $ (α.naturality f.op).symm } }

-- TODO show these form an equivalence

variables {C D}

/--
Another variant of the opposite of functor, turning a functor `C ⥤ Dᵒᵖ` into a functor `Cᵒᵖ ⥤ D`.
In informal mathematics no distinction is made.
-/
@[simps]
protected def left_op (F : C ⥤ Dᵒᵖ) : Cᵒᵖ ⥤ D :=
{ obj := λ X, unop (F.obj (unop X)),
  map := λ X Y f, (F.map f.unop).unop }

/--
Another variant of the opposite of functor, turning a functor `Cᵒᵖ ⥤ D` into a functor `C ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made.
-/
@[simps]
protected def right_op (F : Cᵒᵖ ⥤ D) : C ⥤ Dᵒᵖ :=
{ obj := λ X, op (F.obj (op X)),
  map := λ X Y f, (F.map f.op).op }

-- TODO show these form an equivalence

instance {F : C ⥤ D} [full F] : full F.op :=
{ preimage := λ X Y f, (F.preimage f.unop).op }

instance {F : C ⥤ D} [faithful F] : faithful F.op :=
{ map_injective' := λ X Y f g h,
    quiver.hom.unop_inj $ by simpa using map_injective F (quiver.hom.op_inj h) }

/-- If F is faithful then the right_op of F is also faithful. -/
instance right_op_faithful {F : Cᵒᵖ ⥤ D} [faithful F] : faithful F.right_op :=
{ map_injective' := λ X Y f g h, quiver.hom.op_inj (map_injective F (quiver.hom.op_inj h)) }

/-- If F is faithful then the left_op of F is also faithful. -/
instance left_op_faithful {F : C ⥤ Dᵒᵖ} [faithful F] : faithful F.left_op :=
{ map_injective' := λ X Y f g h, quiver.hom.unop_inj (map_injective F (quiver.hom.unop_inj h)) }

end

end functor

namespace nat_trans

variables {D : Type u₂} [category.{v₂} D]

section
variables {F G : C ⥤ D}

local attribute [semireducible] quiver.opposite

/-- The opposite of a natural transformation. -/
@[simps] protected def op (α : F ⟶ G) : G.op ⟶ F.op :=
{ app         := λ X, (α.app (unop X)).op,
  naturality' := begin tidy, erw α.naturality, refl, end }

@[simp] lemma op_id (F : C ⥤ D) : nat_trans.op (𝟙 F) = 𝟙 (F.op) := rfl

/-- The "unopposite" of a natural transformation. -/
@[simps] protected def unop {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F ⟶ G) : G.unop ⟶ F.unop :=
{ app         := λ X, (α.app (op X)).unop,
  naturality' := begin tidy, erw α.naturality, refl, end }

@[simp] lemma unop_id (F : Cᵒᵖ ⥤ Dᵒᵖ) : nat_trans.unop (𝟙 F) = 𝟙 (F.unop) := rfl

/--
Given a natural transformation `α : F.op ⟶ G.op`,
we can take the "unopposite" of each component obtaining a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_op (α : F.op ⟶ G.op) : G ⟶ F :=
{ app         := λ X, (α.app (op X)).unop,
  naturality' :=
  begin
    intros X Y f,
    have := congr_arg quiver.hom.op (α.naturality f.op),
    dsimp at this,
    erw this,
    refl,
  end }

@[simp] lemma remove_op_id (F : C ⥤ D) : nat_trans.remove_op (𝟙 F.op) = 𝟙 F := rfl

end

section
variables {F G : C ⥤ Dᵒᵖ}

local attribute [semireducible] quiver.opposite

/--
Given a natural transformation `α : F ⟶ G`, for `F G : C ⥤ Dᵒᵖ`,
taking `unop` of each component gives a natural transformation `G.left_op ⟶ F.left_op`.
-/
@[simps] protected def left_op (α : F ⟶ G) : G.left_op ⟶ F.left_op :=
{ app         := λ X, (α.app (unop X)).unop,
  naturality' := begin tidy, erw α.naturality, refl, end }

/--
Given a natural transformation `α : F.left_op ⟶ G.left_op`, for `F G : C ⥤ Dᵒᵖ`,
taking `op` of each component gives a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_left_op (α : F.left_op ⟶ G.left_op) : G ⟶ F :=
{ app         := λ X, (α.app (op X)).op,
  naturality' :=
  begin
    intros X Y f,
    have := congr_arg quiver.hom.op (α.naturality f.op),
    dsimp at this,
    erw this
  end }

end
end nat_trans

namespace iso

variables {X Y : C}

/--
The opposite isomorphism.
-/
@[simps]
protected def op (α : X ≅ Y) : op Y ≅ op X :=
{ hom := α.hom.op,
  inv := α.inv.op,
  hom_inv_id' := quiver.hom.unop_inj α.inv_hom_id,
  inv_hom_id' := quiver.hom.unop_inj α.hom_inv_id }

end iso

namespace nat_iso

variables {D : Type u₂} [category.{v₂} D]
variables {F G : C ⥤ D}

/-- The natural isomorphism between opposite functors `G.op ≅ F.op` induced by a natural
isomorphism between the original functors `F ≅ G`. -/
@[simps] protected def op (α : F ≅ G) : G.op ≅ F.op :=
{ hom := nat_trans.op α.hom,
  inv := nat_trans.op α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←op_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←op_comp, rw α.hom_inv_id_app, refl, end }

/-- The natural isomorphism between functors `G ≅ F` induced by a natural isomorphism
between the opposite functors `F.op ≅ G.op`. -/
@[simps] protected def remove_op (α : F.op ≅ G.op) : G ≅ F :=
{ hom := nat_trans.remove_op α.hom,
  inv := nat_trans.remove_op α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←unop_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←unop_comp, rw α.hom_inv_id_app, refl, end }

/-- The natural isomorphism between functors `G.unop ≅ F.unop` induced by a natural isomorphism
between the original functors `F ≅ G`. -/
@[simps] protected def unop {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F ≅ G) : G.unop ≅ F.unop :=
{ hom := nat_trans.unop α.hom,
  inv := nat_trans.unop α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←unop_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←unop_comp, rw α.hom_inv_id_app, refl, end }

end nat_iso

namespace equivalence

variables {D : Type u₂} [category.{v₂} D]

/--
An equivalence between categories gives an equivalence between the opposite categories.
-/
@[simps]
def op (e : C ≌ D) : Cᵒᵖ ≌ Dᵒᵖ :=
{ functor := e.functor.op,
  inverse := e.inverse.op,
  unit_iso := (nat_iso.op e.unit_iso).symm,
  counit_iso := (nat_iso.op e.counit_iso).symm,
  functor_unit_iso_comp' := λ X, by { apply quiver.hom.unop_inj, dsimp, simp, }, }

/--
An equivalence between opposite categories gives an equivalence between the original categories.
-/
@[simps]
def unop (e : Cᵒᵖ ≌ Dᵒᵖ) : C ≌ D :=
{ functor := e.functor.unop,
  inverse := e.inverse.unop,
  unit_iso := (nat_iso.unop e.unit_iso).symm,
  counit_iso := (nat_iso.unop e.counit_iso).symm,
  functor_unit_iso_comp' := λ X, by { apply quiver.hom.op_inj, dsimp, simp, }, }

end equivalence

/-- The equivalence between arrows of the form `A ⟶ B` and `B.unop ⟶ A.unop`. Useful for building
adjunctions.
Note that this (definitionally) gives variants
```
def op_equiv' (A : C) (B : Cᵒᵖ) : (opposite.op A ⟶ B) ≃ (B.unop ⟶ A) :=
op_equiv _ _

def op_equiv'' (A : Cᵒᵖ) (B : C) : (A ⟶ opposite.op B) ≃ (B ⟶ A.unop) :=
op_equiv _ _

def op_equiv''' (A B : C) : (opposite.op A ⟶ opposite.op B) ≃ (B ⟶ A) :=
op_equiv _ _
```
-/
@[simps] def op_equiv (A B : Cᵒᵖ) : (A ⟶ B) ≃ (B.unop ⟶ A.unop) :=
{ to_fun := λ f, f.unop,
  inv_fun := λ g, g.op,
  left_inv := λ _, rfl,
  right_inv := λ _, rfl }

instance subsingleton_of_unop (A B : Cᵒᵖ) [subsingleton (unop B ⟶ unop A)] : subsingleton (A ⟶ B) :=
(op_equiv A B).subsingleton

instance decidable_eq_of_unop (A B : Cᵒᵖ) [decidable_eq (unop B ⟶ unop A)] : decidable_eq (A ⟶ B) :=
(op_equiv A B).decidable_eq

universes v
variables {α : Type v} [preorder α]

/-- Construct a morphism in the opposite of a preorder category from an inequality. -/
def op_hom_of_le {U V : αᵒᵖ} (h : unop V ≤ unop U) : U ⟶ V :=
quiver.hom.op (hom_of_le h)

lemma le_of_op_hom {U V : αᵒᵖ} (h : U ⟶ V) : unop V ≤ unop U :=
le_of_hom (h.unop)

end category_theory


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Stephen Morgan, Scott Morrison
import .tensor_product

open categories
open categories.functor
open categories.products
open categories.natural_transformation

namespace categories.monoidal_category

universes u v

class monoidal_category (C : Type u) extends category.{u v} C :=
  (tensor                      : TensorProduct C)
  (tensor_unit                 : C)
  (associator_transformation   : Associator tensor)
  (left_unitor_transformation  : LeftUnitor tensor_unit tensor)
  (right_unitor_transformation : RightUnitor tensor_unit tensor)

  (pentagon                  : Pentagon associator_transformation . obviously)
  (triangle                  : Triangle left_unitor_transformation right_unitor_transformation associator_transformation . obviously)

make_lemma monoidal_category.pentagon
make_lemma monoidal_category.triangle
attribute [ematch] monoidal_category.pentagon_lemma
attribute [simp,ematch] monoidal_category.triangle_lemma

open monoidal_category

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

-- Convenience methods which take two arguments, rather than a pair. (This seems to often help the elaborator avoid getting stuck on `prod.mk`.)
definition tensorObjects (X Y : C) : C := (tensor C) +> (X, Y)

infixr ` ⊗ `:80 := tensorObjects -- type as \otimes

definition tensorMorphisms {W X Y Z : C} (f : W ⟶ X) (g : Y ⟶ Z) : (W ⊗ Y) ⟶ (X ⊗ Z) := (tensor C) &> ⟨f, g⟩

infixr ` ⊗ `:80 := tensorMorphisms -- type as \otimes

@[reducible] definition left_unitor (X : C) : ((tensor_unit C) ⊗ X) ⟶ X := ((left_unitor_transformation C).components X).morphism

@[reducible] definition right_unitor (X : C) : (X ⊗ (tensor_unit C)) ⟶ X := ((right_unitor_transformation C).components X).morphism

@[reducible] definition inverse_left_unitor (X : C) : X ⟶ ((tensor_unit C) ⊗ X) := (left_unitor_transformation C).inverse.components X

@[reducible] definition inverse_right_unitor (X : C) : X ⟶ (X ⊗ (tensor_unit C)) := (right_unitor_transformation C).inverse.components X

@[reducible] definition associator (X Y Z : C) : ((X ⊗ Y) ⊗ Z) ⟶ (X ⊗ (Y ⊗ Z)) :=
  ((associator_transformation C).components ⟨⟨X, Y⟩, Z⟩).morphism

@[reducible] definition inverse_associator (X Y Z : C) : (X ⊗ (Y ⊗ Z)) ⟶ ((X ⊗ Y) ⊗ Z) :=
  (associator_transformation C).inverse.components ⟨⟨X, Y⟩, Z⟩

variables {U V W X Y Z : C}

@[simp] lemma rewrite_tensor_as_otimes  (X Y : C) : (tensor C) +> (X, Y) = X ⊗ Y := by refl
@[simp] lemma rewrite_tensor_as_otimes' (f : W ⟶ X) (g : Y ⟶ Z) : (tensor C) &> ((f, g) : (W, Y) ⟶ (X, Z)) = f ⊗ g := by refl

@[ematch] definition interchange (f : U ⟶ V) (g : V ⟶ W) (h : X ⟶ Y) (k : Y ⟶ Z) :
  (f ≫ g) ⊗ (h ≫ k) = (f ⊗ h) ≫ (g ⊗ k) :=
  @Functor.functoriality (C × C) _ C _ (tensor C) ⟨U, X⟩ ⟨V, Y⟩ ⟨W, Z⟩ ⟨f, h⟩ ⟨g, k⟩

@[simp,ematch] lemma interchange_left_identity (f : W ⟶ X) (g : X ⟶ Y) :
  (f ⊗ 𝟙 Z) ≫ (g ⊗ 𝟙 Z) = (f ≫ g) ⊗ (𝟙 Z)
    := by obviously

@[simp,ematch] lemma interchange_right_identity (f : W ⟶ X) (g : X ⟶ Y) :
  (𝟙 Z ⊗ f) ≫ (𝟙 Z ⊗ g) = (𝟙 Z) ⊗ (f ≫ g)
    := by obviously

@[ematch] lemma interchange_identities (f : W ⟶ X) (g : Y ⟶ Z) :
  ((𝟙 Y) ⊗ f) ≫ (g ⊗ (𝟙 X)) = (g ⊗ (𝟙 W)) ≫ ((𝟙 Z) ⊗ f) := by obviously

@[simp,ematch] lemma tensor_identities (X Y : C) :
   (𝟙 X) ⊗ (𝟙 Y) = 𝟙 (X ⊗ Y) := (tensor C).identities ⟨X, Y⟩

lemma inverse_associator_naturality_0
  (f : U ⟶ V ) (g : W ⟶ X) (h : Y ⟶ Z) : (f ⊗ (g ⊗ h)) ≫ (inverse_associator V X Z) = (inverse_associator U  W Y) ≫ ((f ⊗ g) ⊗ h) :=
  begin
    apply @NaturalTransformation.naturality _ _ _ _ _ _ ((associator_transformation C).inverse) ((U, W), Y) ((V, X), Z) ((f, g), h)
  end

end categories.monoidal_category


import tactic.aesop.default_rules

open tactic.aesop.default_rule (split_hyps)

/-!
# split_hyps

Note: the names of generated hypotheses are more or less arbitrary and should
not be relied upon.
-/

/- We can split product-like types. -/
example {P Q : Prop} {A B : Type}
  (h₁ : P ∧ Q) (h₂ : A × B) (h₃ : pprod A B) : true :=
begin
  split_hyps,
  guard_hyp h₁_1 : P,
  guard_hyp h₁_2 : Q,
  guard_hyp h₂_1 : A,
  guard_hyp h₂_2 : B,
  guard_hyp h₃_1 : A,
  guard_hyp h₃_2 : B,
  trivial
end

/- We can split product-like types under leading Π binders. -/
example {X : Type} {P Q : X → Prop} (h : ∀ x, P x ∧ Q x) : true :=
begin
  split_hyps,
  guard_hyp h_1 : ∀ x, P x,
  guard_hyp h_2 : ∀ x, Q x,
  trivial
end

/- We can split sigma-like types. -/
example {X : Type} {P : X → Prop} {Q : X → Type}
  (h₁ : ∃ x, P x) (h₂ : Σ x, Q x ) (h₃ : psigma Q) (h₄ : subtype P) : true :=
begin
  split_hyps,
  guard_hyp h₁_w : X,
  guard_hyp h₁_h : P h₁_w,
  guard_hyp h₂_fst : X,
  guard_hyp h₂_snd : Q h₂_fst,
  guard_hyp h₃_fst : X,
  guard_hyp h₃_snd : Q h₃_fst,
  guard_hyp h₄_val : X,
  guard_hyp h₄_property : P h₄_val,
  trivial
end

/- Splitting is recursive, so nested products are supported. -/
example {X Y : Type} {Z : Prop} {P Q : X → Y → Prop}
  (h : (∃ x, ∃ y, P x y ∧ Q x y) ∧ Z) : true :=
begin
  split_hyps,
  guard_hyp h_2 : Z,
  guard_hyp h_1_w : X,
  guard_hyp h_1_h_w : Y,
  guard_hyp h_1_h_h_1 : P h_1_w h_1_h_w,
  guard_hyp h_1_h_h_2 : Q h_1_w h_1_h_w,
  trivial
end


/-
Copyright (c) 2022 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Oleksandr Manzyuk
-/
import category_theory.bicategory.basic
import category_theory.monoidal.Mon_
import category_theory.limits.preserves.shapes.equalizers

/-!
# The category of bimodule objects over a pair of monoid objects.
-/

universes v₁ v₂ u₁ u₂

open category_theory
open category_theory.monoidal_category

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

section

open category_theory.limits

variables [has_coequalizers C]

section

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]

lemma id_tensor_π_preserves_coequalizer_inv_desc
  {W X Y Z : C} (f g : X ⟶ Y)
  (h : Z ⊗ Y ⟶ W) (wh : (𝟙 Z ⊗ f) ≫ h = (𝟙 Z ⊗ g) ≫ h) :
  (𝟙 Z ⊗ coequalizer.π f g) ≫ (preserves_coequalizer.iso (tensor_left Z) f g).inv ≫
    coequalizer.desc h wh = h :=
map_π_preserves_coequalizer_inv_desc (tensor_left Z) f g h wh

lemma id_tensor_π_preserves_coequalizer_inv_colim_map_desc
  {X Y Z X' Y' Z' : C} (f g : X ⟶ Y) (f' g' : X' ⟶ Y') (p : Z ⊗ X ⟶ X') (q : Z ⊗ Y ⟶ Y')
  (wf : (𝟙 Z ⊗ f) ≫ q = p ≫ f') (wg : (𝟙 Z ⊗ g) ≫ q = p ≫ g')
  (h : Y' ⟶ Z') (wh : f' ≫ h = g' ≫ h) :
  (𝟙 Z ⊗ coequalizer.π f g) ≫ (preserves_coequalizer.iso (tensor_left Z) f g).inv ≫
  colim_map (parallel_pair_hom (𝟙 Z ⊗ f) (𝟙 Z ⊗ g) f' g' p q wf wg) ≫
  coequalizer.desc h wh =
  q ≫ h :=
map_π_preserves_coequalizer_inv_colim_map_desc (tensor_left Z) f g f' g' p q wf wg h wh

end

section

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

lemma π_tensor_id_preserves_coequalizer_inv_desc
  {W X Y Z : C} (f g : X ⟶ Y)
  (h : Y ⊗ Z ⟶ W) (wh : (f ⊗ 𝟙 Z) ≫ h = (g ⊗ 𝟙 Z) ≫ h) :
  (coequalizer.π f g ⊗ 𝟙 Z) ≫ (preserves_coequalizer.iso (tensor_right Z) f g).inv ≫
    coequalizer.desc h wh = h :=
map_π_preserves_coequalizer_inv_desc (tensor_right Z) f g h wh

lemma π_tensor_id_preserves_coequalizer_inv_colim_map_desc
  {X Y Z X' Y' Z' : C} (f g : X ⟶ Y) (f' g' : X' ⟶ Y') (p : X ⊗ Z ⟶ X') (q : Y ⊗ Z ⟶ Y')
  (wf : (f ⊗ 𝟙 Z) ≫ q = p ≫ f') (wg : (g ⊗ 𝟙 Z) ≫ q = p ≫ g')
  (h : Y' ⟶ Z') (wh : f' ≫ h = g' ≫ h) :
  (coequalizer.π f g ⊗ 𝟙 Z) ≫ (preserves_coequalizer.iso (tensor_right Z) f g).inv ≫
  colim_map (parallel_pair_hom (f ⊗ 𝟙 Z) (g ⊗ 𝟙 Z) f' g' p q wf wg) ≫
  coequalizer.desc h wh =
  q ≫ h :=
map_π_preserves_coequalizer_inv_colim_map_desc (tensor_right Z) f g f' g' p q wf wg h wh

end

end

/-- A bimodule object for a pair of monoid objects, all internal to some monoidal category. -/
structure Bimod (A B : Mon_ C) :=
(X : C)
(act_left : A.X ⊗ X ⟶ X)
(one_act_left' : (A.one ⊗ 𝟙 X) ≫ act_left = (λ_ X).hom . obviously)
(left_assoc' :
  (A.mul ⊗ 𝟙 X) ≫ act_left = (α_ A.X A.X X).hom ≫ (𝟙 A.X ⊗ act_left) ≫ act_left . obviously)
(act_right : X ⊗ B.X ⟶ X)
(act_right_one' : (𝟙 X ⊗ B.one) ≫ act_right = (ρ_ X).hom . obviously)
(right_assoc' :
  (𝟙 X ⊗ B.mul) ≫ act_right = (α_ X B.X B.X).inv ≫ (act_right ⊗ 𝟙 B.X) ≫ act_right . obviously)
(middle_assoc' :
  (act_left ⊗ 𝟙 B.X) ≫ act_right = (α_ A.X X B.X).hom ≫ (𝟙 A.X ⊗ act_right) ≫ act_left . obviously)

restate_axiom Bimod.one_act_left'
restate_axiom Bimod.act_right_one'
restate_axiom Bimod.left_assoc'
restate_axiom Bimod.right_assoc'
restate_axiom Bimod.middle_assoc'
attribute [simp, reassoc]
Bimod.one_act_left Bimod.act_right_one Bimod.left_assoc Bimod.right_assoc Bimod.middle_assoc

namespace Bimod

variables {A B : Mon_ C} (M : Bimod A B)

/-- A morphism of bimodule objects. -/
@[ext]
structure hom (M N : Bimod A B) :=
(hom : M.X ⟶ N.X)
(left_act_hom' : M.act_left ≫ hom = (𝟙 A.X ⊗ hom) ≫ N.act_left . obviously)
(right_act_hom' : M.act_right ≫ hom = (hom ⊗ 𝟙 B.X) ≫ N.act_right . obviously)

restate_axiom hom.left_act_hom'
restate_axiom hom.right_act_hom'
attribute [simp, reassoc] hom.left_act_hom hom.right_act_hom

/-- The identity morphism on a bimodule object. -/
@[simps]
def id' (M : Bimod A B) : hom M M :=
{ hom := 𝟙 M.X, }

instance hom_inhabited (M : Bimod A B) : inhabited (hom M M) := ⟨id' M⟩

/-- Composition of bimodule object morphisms. -/
@[simps]
def comp {M N O : Bimod A B} (f : hom M N) (g : hom N O) : hom M O :=
{ hom := f.hom ≫ g.hom, }

instance : category (Bimod A B) :=
{ hom := λ M N, hom M N,
  id := id',
  comp := λ M N O f g, comp f g, }

@[simp] lemma id_hom' (M : Bimod A B) : (𝟙 M : hom M M).hom = 𝟙 M.X := rfl
@[simp] lemma comp_hom' {M N K : Bimod A B} (f : M ⟶ N) (g : N ⟶ K) :
  (f ≫ g : hom M K).hom = f.hom ≫ g.hom := rfl

/--
Construct an isomorphism of bimodules by giving an isomorphism between the underlying objects
and checking compatibility with left and right actions only in the forward direction.
-/
@[simps]
def iso_of_iso {X Y : Mon_ C} {P Q : Bimod X Y}
  (f : P.X ≅ Q.X)
  (f_left_act_hom : P.act_left ≫ f.hom = (𝟙 X.X ⊗ f.hom) ≫ Q.act_left)
  (f_right_act_hom : P.act_right ≫ f.hom = (f.hom ⊗ 𝟙 Y.X) ≫ Q.act_right) :
  P ≅ Q :=
{ hom := ⟨f.hom⟩,
  inv :=
  { hom := f.inv,
    left_act_hom' := begin
      rw [←(cancel_mono f.hom), category.assoc, category.assoc, iso.inv_hom_id, category.comp_id,
          f_left_act_hom, ←category.assoc, ←id_tensor_comp, iso.inv_hom_id,
          monoidal_category.tensor_id, category.id_comp],
    end,
    right_act_hom' := begin
      rw [←(cancel_mono f.hom), category.assoc, category.assoc, iso.inv_hom_id, category.comp_id,
          f_right_act_hom, ←category.assoc, ←comp_tensor_id, iso.inv_hom_id,
          monoidal_category.tensor_id, category.id_comp],
    end },
  hom_inv_id' := begin
    ext, dsimp, rw iso.hom_inv_id,
  end,
  inv_hom_id' := begin
    ext, dsimp, rw iso.inv_hom_id,
  end }

variables (A)

/-- A monoid object as a bimodule over itself. -/
@[simps]
def regular : Bimod A A :=
{ X := A.X,
  act_left := A.mul,
  act_right := A.mul, }

instance : inhabited (Bimod A A) := ⟨regular A⟩

/-- The forgetful functor from bimodule objects to the ambient category. -/
def forget : Bimod A B ⥤ C :=
{ obj := λ A, A.X,
  map := λ A B f, f.hom, }

open category_theory.limits

variables [has_coequalizers C]

namespace tensor_Bimod
variables {R S T : Mon_ C} (P : Bimod R S) (Q : Bimod S T)

/-- The underlying object of the tensor product of two bimodules. -/
noncomputable
def X : C := coequalizer (P.act_right ⊗ 𝟙 Q.X) ((α_ _ _ _).hom ≫ (𝟙 P.X ⊗ Q.act_left))

section

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]

/-- Left action for the tensor product of two bimodules. -/
noncomputable
def act_left : R.X ⊗ X P Q ⟶ X P Q :=
(preserves_coequalizer.iso (tensor_left R.X) _ _).inv ≫
colim_map
  (parallel_pair_hom _ _ _ _
    ((𝟙 _ ⊗ (α_ _ _ _).hom) ≫ (α_ _ _ _).inv ≫ (P.act_left ⊗ 𝟙 S.X ⊗ 𝟙 Q.X) ≫ (α_ _ _ _).inv)
    ((α_ _ _ _).inv ≫ (P.act_left ⊗ 𝟙 Q.X))
    begin
      dsimp,
      slice_lhs 1 2 { rw associator_inv_naturality },
      slice_rhs 3 4 { rw associator_inv_naturality },
      slice_rhs 4 5 { rw [←tensor_comp, middle_assoc, tensor_comp, comp_tensor_id] },
      coherence,
    end
    begin
      dsimp,
      slice_lhs 1 1 { rw id_tensor_comp },
      slice_lhs 2 3 { rw associator_inv_naturality },
      slice_lhs 3 4 { rw [tensor_id, id_tensor_comp_tensor_id] },
      slice_rhs 4 6 { rw iso.inv_hom_id_assoc },
      slice_rhs 3 4 { rw [tensor_id, tensor_id_comp_id_tensor] },
    end)

lemma id_tensor_π_act_left :
  (𝟙 R.X ⊗ coequalizer.π _ _) ≫ act_left P Q =
  (α_ _ _ _).inv ≫ (P.act_left ⊗ 𝟙 Q.X) ≫ coequalizer.π _ _ :=
begin
  erw map_π_preserves_coequalizer_inv_colim_map (tensor_left _),
  simp only [category.assoc],
end

lemma one_act_left' : (R.one ⊗ 𝟙 _) ≫ act_left P Q = (λ_ _).hom :=
begin
  refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
  dsimp [X],
  slice_lhs 1 2 { rw [id_tensor_comp_tensor_id, ←tensor_id_comp_id_tensor] },
  slice_lhs 2 3 { rw id_tensor_π_act_left },
  slice_lhs 1 2 { rw [←monoidal_category.tensor_id, associator_inv_naturality] },
  slice_lhs 2 3 { rw [←comp_tensor_id, one_act_left] },
  slice_rhs 1 2 { rw left_unitor_naturality },
  coherence,
end

lemma left_assoc' :
  (R.mul ⊗ 𝟙 _) ≫ act_left P Q =
  (α_ R.X R.X _).hom ≫ (𝟙 R.X ⊗ act_left P Q) ≫ act_left P Q :=
begin
  refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
  dsimp [X],
  slice_lhs 1 2 { rw [id_tensor_comp_tensor_id, ←tensor_id_comp_id_tensor] },
  slice_lhs 2 3 { rw id_tensor_π_act_left },
  slice_lhs 1 2 { rw [←monoidal_category.tensor_id, associator_inv_naturality] },
  slice_lhs 2 3 { rw [←comp_tensor_id, left_assoc, comp_tensor_id, comp_tensor_id] },
  slice_rhs 1 2 { rw [←monoidal_category.tensor_id, associator_naturality] },
  slice_rhs 2 3 { rw [←id_tensor_comp, id_tensor_π_act_left, id_tensor_comp, id_tensor_comp] },
  slice_rhs 4 5 { rw id_tensor_π_act_left },
  slice_rhs 3 4 { rw associator_inv_naturality },
  coherence,
end

end

section

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

/-- Right action for the tensor product of two bimodules. -/
noncomputable
def act_right : X P Q ⊗ T.X ⟶ X P Q :=
(preserves_coequalizer.iso (tensor_right T.X) _ _).inv ≫
colim_map
  (parallel_pair_hom _ _ _ _
    ((α_ _ _ _).hom ≫ (α_ _ _ _).hom ≫ (𝟙 P.X ⊗ 𝟙 S.X ⊗ Q.act_right) ≫ (α_ _ _ _).inv)
    ((α_ _ _ _).hom ≫ (𝟙 P.X ⊗ Q.act_right))
    begin
      dsimp,
      slice_lhs 1 2 { rw associator_naturality },
      slice_lhs 2 3 { rw [tensor_id, tensor_id_comp_id_tensor] },
      slice_rhs 3 4 { rw associator_inv_naturality },
      slice_rhs 2 4 { rw iso.hom_inv_id_assoc },
      slice_rhs 2 3 { rw [tensor_id, id_tensor_comp_tensor_id] },
    end
    begin
      dsimp,
      slice_lhs 1 1 { rw comp_tensor_id },
      slice_lhs 2 3 { rw associator_naturality },
      slice_lhs 3 4 { rw [←id_tensor_comp, middle_assoc, id_tensor_comp] },
      slice_rhs 4 6 { rw iso.inv_hom_id_assoc },
      slice_rhs 3 4 { rw ←id_tensor_comp },
      coherence,
    end)

lemma π_tensor_id_act_right :
  (coequalizer.π _ _ ⊗ 𝟙 T.X) ≫ act_right P Q =
  (α_ _ _ _).hom ≫ (𝟙 P.X ⊗ Q.act_right) ≫ coequalizer.π _ _ :=
begin
  erw map_π_preserves_coequalizer_inv_colim_map (tensor_right _),
  simp only [category.assoc],
end

lemma act_right_one' : (𝟙 _ ⊗ T.one) ≫ act_right P Q = (ρ_ _).hom :=
begin
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp [X],
  slice_lhs 1 2 { rw [tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
  slice_lhs 2 3 { rw π_tensor_id_act_right },
  slice_lhs 1 2 { rw [←monoidal_category.tensor_id, associator_naturality] },
  slice_lhs 2 3 { rw [←id_tensor_comp, act_right_one] },
  slice_rhs 1 2 { rw right_unitor_naturality },
  coherence,
end

lemma right_assoc' :
  (𝟙 _ ⊗ T.mul) ≫ act_right P Q =
  (α_ _ T.X T.X).inv ≫ (act_right P Q ⊗ 𝟙 T.X) ≫ act_right P Q :=
begin
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp [X],
  slice_lhs 1 2 { rw [tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
  slice_lhs 2 3 { rw π_tensor_id_act_right },
  slice_lhs 1 2 { rw [←monoidal_category.tensor_id, associator_naturality] },
  slice_lhs 2 3 { rw [←id_tensor_comp, right_assoc, id_tensor_comp, id_tensor_comp] },
  slice_rhs 1 2 { rw [←monoidal_category.tensor_id, associator_inv_naturality] },
  slice_rhs 2 3 { rw [←comp_tensor_id, π_tensor_id_act_right, comp_tensor_id, comp_tensor_id] },
  slice_rhs 4 5 { rw π_tensor_id_act_right },
  slice_rhs 3 4 { rw associator_naturality },
  coherence,
end

end

section

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]
variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

lemma middle_assoc' :
  (act_left P Q ⊗ 𝟙 T.X) ≫ act_right P Q =
  (α_ R.X _ T.X).hom ≫ (𝟙 R.X ⊗ act_right P Q) ≫ act_left P Q :=
begin
  refine (cancel_epi ((tensor_left _ ⋙ tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp [X],
  slice_lhs 1 2 { rw [←comp_tensor_id, id_tensor_π_act_left, comp_tensor_id, comp_tensor_id] },
  slice_lhs 3 4 { rw π_tensor_id_act_right },
  slice_lhs 2 3 { rw associator_naturality },
  slice_lhs 3 4 { rw [monoidal_category.tensor_id, tensor_id_comp_id_tensor] },
  slice_rhs 1 2 { rw associator_naturality },
  slice_rhs 2 3 { rw [←id_tensor_comp, π_tensor_id_act_right, id_tensor_comp, id_tensor_comp] },
  slice_rhs 4 5 { rw id_tensor_π_act_left },
  slice_rhs 3 4 { rw associator_inv_naturality },
  slice_rhs 4 5 { rw [monoidal_category.tensor_id, id_tensor_comp_tensor_id] },
  coherence,
end

end

end tensor_Bimod

section

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]
variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

/-- Tensor product of two bimodule objects as a bimodule object. -/
@[simps]
noncomputable
def tensor_Bimod {X Y Z : Mon_ C} (M : Bimod X Y) (N : Bimod Y Z) : Bimod X Z :=
{ X := tensor_Bimod.X M N,
  act_left := tensor_Bimod.act_left M N,
  act_right := tensor_Bimod.act_right M N,
  one_act_left' := tensor_Bimod.one_act_left' M N,
  act_right_one' := tensor_Bimod.act_right_one' M N,
  left_assoc' := tensor_Bimod.left_assoc' M N,
  right_assoc' := tensor_Bimod.right_assoc' M N,
  middle_assoc' := tensor_Bimod.middle_assoc' M N, }

/-- Tensor product of two morphisms of bimodule objects. -/
@[simps]
noncomputable
def tensor_hom {X Y Z : Mon_ C} {M₁ M₂ : Bimod X Y} {N₁ N₂ : Bimod Y Z}
  (f : M₁ ⟶ M₂) (g : N₁ ⟶ N₂) : M₁.tensor_Bimod N₁ ⟶ M₂.tensor_Bimod N₂ :=
{ hom :=
    colim_map
      (parallel_pair_hom _ _ _ _ ((f.hom ⊗ 𝟙 Y.X) ⊗ g.hom) (f.hom ⊗ g.hom)
        (by rw [←tensor_comp, ←tensor_comp, hom.right_act_hom, category.id_comp, category.comp_id])
        begin
          slice_lhs 2 3 { rw [←tensor_comp, hom.left_act_hom, category.id_comp] },
          slice_rhs 1 2 { rw associator_naturality },
          slice_rhs 2 3 { rw [←tensor_comp, category.comp_id] },
        end),
  left_act_hom' := begin
    refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
    dsimp,
    slice_lhs 1 2 { rw tensor_Bimod.id_tensor_π_act_left },
    slice_lhs 3 4 { rw [ι_colim_map, parallel_pair_hom_app_one] },
    slice_lhs 2 3 { rw [←tensor_comp, hom.left_act_hom, category.id_comp] },
    slice_rhs 1 2 { rw [←id_tensor_comp, ι_colim_map, parallel_pair_hom_app_one, id_tensor_comp] },
    slice_rhs 2 3 { rw tensor_Bimod.id_tensor_π_act_left },
    slice_rhs 1 2 { rw associator_inv_naturality },
    slice_rhs 2 3 { rw [←tensor_comp, category.comp_id] },
  end,
  right_act_hom' := begin
    refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
    dsimp,
    slice_lhs 1 2 { rw tensor_Bimod.π_tensor_id_act_right },
    slice_lhs 3 4 { rw [ι_colim_map, parallel_pair_hom_app_one] },
    slice_lhs 2 3 { rw [←tensor_comp, category.id_comp, hom.right_act_hom] },
    slice_rhs 1 2 { rw [←comp_tensor_id, ι_colim_map, parallel_pair_hom_app_one, comp_tensor_id] },
    slice_rhs 2 3 { rw tensor_Bimod.π_tensor_id_act_right },
    slice_rhs 1 2 { rw associator_naturality },
    slice_rhs 2 3 { rw [←tensor_comp, category.comp_id] },
  end }

lemma tensor_id {X Y Z : Mon_ C} {M : Bimod X Y} {N : Bimod Y Z} :
  tensor_hom (𝟙 M) (𝟙 N) = 𝟙 (M.tensor_Bimod N) :=
begin
  ext,
  simp only [id_hom', tensor_id, tensor_hom_hom, ι_colim_map, parallel_pair_hom_app_one],
  dsimp, dunfold tensor_Bimod.X,
  simp only [category.id_comp, category.comp_id],
end

lemma tensor_comp {X Y Z : Mon_ C} {M₁ M₂ M₃ : Bimod X Y} {N₁ N₂ N₃ : Bimod Y Z}
  (f₁ : M₁ ⟶ M₂) (f₂ : M₂ ⟶ M₃) (g₁ : N₁ ⟶ N₂) (g₂ : N₂ ⟶ N₃) :
  tensor_hom (f₁ ≫ f₂) (g₁ ≫ g₂) = tensor_hom f₁ g₁ ≫ tensor_hom f₂ g₂ :=
begin
  ext,
  simp only [comp_hom', tensor_comp, tensor_hom_hom, ι_colim_map, parallel_pair_hom_app_one,
    category.assoc, ι_colim_map_assoc]
end

end

namespace associator_Bimod

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]
variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

variables {R S T U : Mon_ C} (P : Bimod R S) (Q : Bimod S T) (L : Bimod T U)

/-- An auxiliary morphism for the definition of the underlying morphism of the forward component of
the associator isomorphism. -/
noncomputable
def hom_aux : (P.tensor_Bimod Q).X ⊗ L.X ⟶ (P.tensor_Bimod (Q.tensor_Bimod L)).X :=
(preserves_coequalizer.iso (tensor_right L.X) _ _).inv ≫
coequalizer.desc
  ((α_ _ _ _).hom ≫ (𝟙 P.X ⊗ (coequalizer.π _ _)) ≫ (coequalizer.π _ _))
  begin
    dsimp, dsimp [tensor_Bimod.X],
    slice_lhs 1 2 { rw associator_naturality },
    slice_lhs 2 3 { rw [monoidal_category.tensor_id,
                        tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
    slice_lhs 3 4 { rw coequalizer.condition },
    slice_lhs 2 3 { rw [←monoidal_category.tensor_id, associator_naturality] },
    slice_lhs 3 4 { rw [←id_tensor_comp, tensor_Bimod.id_tensor_π_act_left, id_tensor_comp] },
    slice_rhs 1 1 { rw comp_tensor_id },
    slice_rhs 2 3 { rw associator_naturality },
    slice_rhs 3 4 { rw ←id_tensor_comp },
    coherence,
  end

/-- The underlying morphism of the forward component of the associator isomorphism. -/
noncomputable
def hom : ((P.tensor_Bimod Q).tensor_Bimod L).X ⟶ (P.tensor_Bimod (Q.tensor_Bimod L)).X :=
coequalizer.desc
  (hom_aux P Q L)
  begin
    dsimp [hom_aux],
    refine (cancel_epi ((tensor_right _ ⋙ tensor_right _).map (coequalizer.π _ _))).1 _,
    dsimp [tensor_Bimod.X],
    slice_lhs 1 2 { rw [←comp_tensor_id,
                        tensor_Bimod.π_tensor_id_act_right,
                        comp_tensor_id, comp_tensor_id] },
    slice_lhs 3 5 { rw π_tensor_id_preserves_coequalizer_inv_desc },
    slice_lhs 2 3 { rw associator_naturality },
    slice_lhs 3 4 { rw [←id_tensor_comp, coequalizer.condition, id_tensor_comp, id_tensor_comp] },
    slice_rhs 1 2 { rw associator_naturality },
    slice_rhs 2 3 { rw [monoidal_category.tensor_id,
                        tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
    slice_rhs 3 5 { rw π_tensor_id_preserves_coequalizer_inv_desc },
    slice_rhs 2 3 { rw [←monoidal_category.tensor_id, associator_naturality] },
    coherence,
  end

lemma hom_left_act_hom' :
  ((P.tensor_Bimod Q).tensor_Bimod L).act_left ≫ hom P Q L =
  (𝟙 R.X ⊗ hom P Q L) ≫ (P.tensor_Bimod (Q.tensor_Bimod L)).act_left :=
begin
  dsimp, dsimp [hom, hom_aux],
  refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
  rw tensor_left_map,
  slice_lhs 1 2 { rw tensor_Bimod.id_tensor_π_act_left },
  slice_lhs 3 4 { rw coequalizer.π_desc },
  slice_rhs 1 2 { rw [←id_tensor_comp, coequalizer.π_desc, id_tensor_comp] },
  refine (cancel_epi ((tensor_right _ ⋙ tensor_left _).map (coequalizer.π _ _))).1 _,
  dsimp, dsimp [tensor_Bimod.X],
  slice_lhs 1 2 { rw associator_inv_naturality },
  slice_lhs 2 3 { rw [←comp_tensor_id,
                      tensor_Bimod.id_tensor_π_act_left,
                      comp_tensor_id, comp_tensor_id] },
  slice_lhs 4 6 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_lhs 3 4 { rw associator_naturality },
  slice_lhs 4 5 { rw [monoidal_category.tensor_id, tensor_id_comp_id_tensor] },
  slice_rhs 1 3 { rw [←id_tensor_comp, ←id_tensor_comp,
                      π_tensor_id_preserves_coequalizer_inv_desc,
                      id_tensor_comp, id_tensor_comp] },
  slice_rhs 3 4 { erw tensor_Bimod.id_tensor_π_act_left P (Q.tensor_Bimod L) },
  slice_rhs 2 3 { erw associator_inv_naturality },
  slice_rhs 3 4 { erw [monoidal_category.tensor_id, id_tensor_comp_tensor_id] },
  coherence,
end

lemma hom_right_act_hom' :
  ((P.tensor_Bimod Q).tensor_Bimod L).act_right ≫ hom P Q L =
  (hom P Q L ⊗ 𝟙 U.X) ≫ (P.tensor_Bimod (Q.tensor_Bimod L)).act_right :=
begin
  dsimp, dsimp [hom, hom_aux],
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  rw tensor_right_map,
  slice_lhs 1 2 { rw tensor_Bimod.π_tensor_id_act_right },
  slice_lhs 3 4 { rw coequalizer.π_desc },
  slice_rhs 1 2 { rw [←comp_tensor_id, coequalizer.π_desc, comp_tensor_id] },
  refine (cancel_epi ((tensor_right _ ⋙ tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp, dsimp [tensor_Bimod.X],
  slice_lhs 1 2 { rw associator_naturality },
  slice_lhs 2 3 { rw [monoidal_category.tensor_id,
                      tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
  slice_lhs 3 5 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_lhs 2 3 { rw [←monoidal_category.tensor_id,
                      associator_naturality] },
  slice_rhs 1 3 { rw [←comp_tensor_id, ←comp_tensor_id,
                      π_tensor_id_preserves_coequalizer_inv_desc,
                      comp_tensor_id, comp_tensor_id] },
  slice_rhs 3 4 { erw tensor_Bimod.π_tensor_id_act_right P (Q.tensor_Bimod L) },
  slice_rhs 2 3 { erw associator_naturality },
  dsimp,
  slice_rhs 3 4 { rw [←id_tensor_comp,
                      tensor_Bimod.π_tensor_id_act_right,
                      id_tensor_comp, id_tensor_comp] },
  coherence,
end

/-- An auxiliary morphism for the definition of the underlying morphism of the inverse component of
the associator isomorphism. -/
noncomputable
def inv_aux : P.X ⊗ (Q.tensor_Bimod L).X ⟶ ((P.tensor_Bimod Q).tensor_Bimod L).X :=
(preserves_coequalizer.iso (tensor_left P.X) _ _).inv ≫
coequalizer.desc
  ((α_ _ _ _).inv ≫ ((coequalizer.π _ _) ⊗ 𝟙 L.X) ≫ (coequalizer.π _ _))
  begin
    dsimp, dsimp [tensor_Bimod.X],
    slice_lhs 1 2 { rw associator_inv_naturality },
    rw [←(iso.inv_hom_id_assoc (α_ _ _ _) (𝟙 P.X ⊗ Q.act_right)), comp_tensor_id],
    slice_lhs 3 4 { rw [←comp_tensor_id, category.assoc, ←tensor_Bimod.π_tensor_id_act_right,
                        comp_tensor_id] },
    slice_lhs 4 5 { rw coequalizer.condition },
    slice_lhs 3 4 { rw associator_naturality },
    slice_lhs 4 5 { rw [monoidal_category.tensor_id, tensor_id_comp_id_tensor] },
    slice_rhs 1 2 { rw id_tensor_comp },
    slice_rhs 2 3 { rw associator_inv_naturality },
    slice_rhs 3 4 { rw [monoidal_category.tensor_id, id_tensor_comp_tensor_id] },
    coherence,
  end

/-- The underlying morphism of the inverse component of the associator isomorphism. -/
noncomputable
def inv : (P.tensor_Bimod (Q.tensor_Bimod L)).X ⟶ ((P.tensor_Bimod Q).tensor_Bimod L).X :=
coequalizer.desc
  (inv_aux P Q L)
  begin
    dsimp [inv_aux],
    refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
    dsimp [tensor_Bimod.X],
    slice_lhs 1 2 { rw [id_tensor_comp_tensor_id, ←tensor_id_comp_id_tensor] },
    slice_lhs 2 4 { rw id_tensor_π_preserves_coequalizer_inv_desc },
    slice_lhs 1 2 { rw [←monoidal_category.tensor_id, associator_inv_naturality] },
    slice_lhs 2 3 { rw [←comp_tensor_id, coequalizer.condition, comp_tensor_id, comp_tensor_id] },
    slice_rhs 1 2 { rw [←monoidal_category.tensor_id, associator_naturality] },
    slice_rhs 2 3 { rw [←id_tensor_comp,
                        tensor_Bimod.id_tensor_π_act_left,
                        id_tensor_comp, id_tensor_comp] },
    slice_rhs 4 6 { rw id_tensor_π_preserves_coequalizer_inv_desc },
    slice_rhs 3 4 { rw associator_inv_naturality },
    coherence,
  end

lemma hom_inv_id : hom P Q L ≫ inv P Q L = 𝟙 _ :=
begin
  dsimp [hom, hom_aux, inv, inv_aux],
  ext,
  slice_lhs 1 2 { rw coequalizer.π_desc },
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  rw tensor_right_map,
  slice_lhs 1 3 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_lhs 3 4 { rw coequalizer.π_desc },
  slice_lhs 2 4 { rw id_tensor_π_preserves_coequalizer_inv_desc },
  slice_lhs 1 3 { rw iso.hom_inv_id_assoc },
  dunfold tensor_Bimod.X,
  slice_rhs 2 3 { rw category.comp_id },
  refl,
end

lemma inv_hom_id : inv P Q L ≫ hom P Q L = 𝟙 _ :=
begin
  dsimp [hom, hom_aux, inv, inv_aux],
  ext,
  slice_lhs 1 2 { rw coequalizer.π_desc },
  refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
  rw tensor_left_map,
  slice_lhs 1 3 { rw id_tensor_π_preserves_coequalizer_inv_desc },
  slice_lhs 3 4 { rw coequalizer.π_desc },
  slice_lhs 2 4 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_lhs 1 3 { rw iso.inv_hom_id_assoc },
  dunfold tensor_Bimod.X,
  slice_rhs 2 3 { rw category.comp_id },
  refl,
end

end associator_Bimod

namespace left_unitor_Bimod
variables {R S : Mon_ C} (P : Bimod R S)

/-- The underlying morphism of the forward component of the left unitor isomorphism. -/
noncomputable
def hom : tensor_Bimod.X (regular R) P ⟶ P.X :=
coequalizer.desc P.act_left (by { dsimp, rw [category.assoc, left_assoc] })

/-- The underlying morphism of the inverse component of the left unitor isomorphism. -/
noncomputable
def inv : P.X ⟶ tensor_Bimod.X (regular R) P :=
(λ_ P.X).inv ≫ (R.one ⊗ 𝟙 _) ≫ coequalizer.π _ _

lemma hom_inv_id : hom P ≫ inv P = 𝟙 _ :=
begin
  dunfold hom inv tensor_Bimod.X,
  ext, dsimp,
  slice_lhs 1 2 { rw coequalizer.π_desc },
  slice_lhs 1 2 { rw left_unitor_inv_naturality },
  slice_lhs 2 3 { rw [id_tensor_comp_tensor_id, ←tensor_id_comp_id_tensor] },
  slice_lhs 3 3 { rw ←(iso.inv_hom_id_assoc (α_ R.X R.X P.X) (𝟙 R.X ⊗ P.act_left)) },
  slice_lhs 4 6 { rw [←category.assoc, ←coequalizer.condition] },
  slice_lhs 2 3 { rw [←monoidal_category.tensor_id, associator_inv_naturality] },
  slice_lhs 3 4 { rw [←comp_tensor_id, Mon_.one_mul] },
  slice_rhs 1 2 { rw category.comp_id },
  coherence,
end

lemma inv_hom_id : inv P ≫ hom P = 𝟙 _ :=
begin
  dsimp [hom, inv],
  slice_lhs 3 4 { rw coequalizer.π_desc },
  rw [one_act_left, iso.inv_hom_id],
end

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]
variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

lemma hom_left_act_hom' :
  ((regular R).tensor_Bimod P).act_left ≫ hom P = (𝟙 R.X ⊗ hom P) ≫ P.act_left :=
begin
  dsimp, dsimp [hom, tensor_Bimod.act_left, regular],
  refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
  dsimp,
  slice_lhs 1 4 { rw id_tensor_π_preserves_coequalizer_inv_colim_map_desc },
  slice_lhs 2 3 { rw left_assoc },
  slice_rhs 1 2 { rw [←id_tensor_comp, coequalizer.π_desc] },
  rw iso.inv_hom_id_assoc,
end

lemma hom_right_act_hom' :
  ((regular R).tensor_Bimod P).act_right ≫ hom P = (hom P ⊗ 𝟙 S.X) ≫ P.act_right :=
begin
  dsimp, dsimp [hom, tensor_Bimod.act_right, regular],
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp,
  slice_lhs 1 4 { rw π_tensor_id_preserves_coequalizer_inv_colim_map_desc },
  slice_rhs 1 2 { rw [←comp_tensor_id, coequalizer.π_desc] },
  slice_rhs 1 2 { rw middle_assoc },
  simp only [category.assoc],
end

end left_unitor_Bimod

namespace right_unitor_Bimod
variables {R S : Mon_ C} (P : Bimod R S)

/-- The underlying morphism of the forward component of the right unitor isomorphism. -/
noncomputable
def hom : tensor_Bimod.X P (regular S) ⟶ P.X :=
coequalizer.desc P.act_right
  (by { dsimp, rw [category.assoc, right_assoc, iso.hom_inv_id_assoc] })

/-- The underlying morphism of the inverse component of the right unitor isomorphism. -/
noncomputable
def inv : P.X ⟶ tensor_Bimod.X P (regular S) :=
(ρ_ P.X).inv ≫ (𝟙 _ ⊗ S.one) ≫ coequalizer.π _ _

lemma hom_inv_id : hom P ≫ inv P = 𝟙 _ :=
begin
  dunfold hom inv tensor_Bimod.X,
  ext, dsimp,
  slice_lhs 1 2 { rw coequalizer.π_desc },
  slice_lhs 1 2 { rw right_unitor_inv_naturality },
  slice_lhs 2 3 { rw [tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
  slice_lhs 3 4 { rw coequalizer.condition },
  slice_lhs 2 3 { rw [←monoidal_category.tensor_id, associator_naturality] },
  slice_lhs 3 4 { rw [←id_tensor_comp, Mon_.mul_one] },
  slice_rhs 1 2 { rw category.comp_id },
  coherence,
end

lemma inv_hom_id : inv P ≫ hom P = 𝟙 _ :=
begin
  dsimp [hom, inv],
  slice_lhs 3 4 { rw coequalizer.π_desc },
  rw [act_right_one, iso.inv_hom_id],
end

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]
variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

lemma hom_left_act_hom' :
  (P.tensor_Bimod (regular S)).act_left ≫ hom P = (𝟙 R.X ⊗ hom P) ≫ P.act_left :=
begin
  dsimp, dsimp [hom, tensor_Bimod.act_left, regular],
  refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
  dsimp,
  slice_lhs 1 4 { rw id_tensor_π_preserves_coequalizer_inv_colim_map_desc },
  slice_lhs 2 3 { rw middle_assoc },
  slice_rhs 1 2 { rw [←id_tensor_comp, coequalizer.π_desc] },
  rw iso.inv_hom_id_assoc,
end

lemma hom_right_act_hom' :
  (P.tensor_Bimod (regular S)).act_right ≫ hom P = (hom P ⊗ 𝟙 S.X) ≫ P.act_right :=
begin
  dsimp, dsimp [hom, tensor_Bimod.act_right, regular],
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp,
  slice_lhs 1 4 { rw π_tensor_id_preserves_coequalizer_inv_colim_map_desc },
  slice_lhs 2 3 { rw right_assoc },
  slice_rhs 1 2 { rw [←comp_tensor_id, coequalizer.π_desc] },
  rw iso.hom_inv_id_assoc,
end

end right_unitor_Bimod

variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_left X)]
variables [∀ X : C, preserves_colimits_of_size.{0 0} (tensor_right X)]

/-- The associator as a bimodule isomorphism. -/
noncomputable
def associator_Bimod {W X Y Z : Mon_ C} (L : Bimod W X) (M : Bimod X Y) (N : Bimod Y Z) :
   (L.tensor_Bimod M).tensor_Bimod N ≅ L.tensor_Bimod (M.tensor_Bimod N) :=
iso_of_iso
  { hom := associator_Bimod.hom L M N,
    inv := associator_Bimod.inv L M N,
    hom_inv_id' := associator_Bimod.hom_inv_id L M N,
    inv_hom_id' := associator_Bimod.inv_hom_id L M N }
  (associator_Bimod.hom_left_act_hom' L M N)
  (associator_Bimod.hom_right_act_hom' L M N)

/-- The left unitor as a bimodule isomorphism. -/
noncomputable
def left_unitor_Bimod {X Y : Mon_ C} (M : Bimod X Y) : (regular X).tensor_Bimod M ≅ M :=
iso_of_iso
  { hom := left_unitor_Bimod.hom M,
    inv := left_unitor_Bimod.inv M,
    hom_inv_id' := left_unitor_Bimod.hom_inv_id M,
    inv_hom_id' := left_unitor_Bimod.inv_hom_id M }
  (left_unitor_Bimod.hom_left_act_hom' M)
  (left_unitor_Bimod.hom_right_act_hom' M)

/-- The right unitor as a bimodule isomorphism. -/
noncomputable
def right_unitor_Bimod {X Y : Mon_ C} (M : Bimod X Y) : M.tensor_Bimod (regular Y) ≅ M :=
iso_of_iso
  { hom := right_unitor_Bimod.hom M,
    inv := right_unitor_Bimod.inv M,
    hom_inv_id' := right_unitor_Bimod.hom_inv_id M,
    inv_hom_id' := right_unitor_Bimod.inv_hom_id M }
  (right_unitor_Bimod.hom_left_act_hom' M)
  (right_unitor_Bimod.hom_right_act_hom' M)

lemma whisker_left_comp_Bimod {X Y Z : Mon_ C}
  (M : Bimod X Y) {N P Q : Bimod Y Z} (f : N ⟶ P) (g : P ⟶ Q) :
  tensor_hom (𝟙 M) (f ≫ g) = tensor_hom (𝟙 M) f ≫ tensor_hom (𝟙 M) g :=
by rw [←tensor_comp, category.comp_id]

lemma id_whisker_left_Bimod {X Y : Mon_ C} {M N : Bimod X Y} (f : M ⟶ N) :
  tensor_hom (𝟙 (regular X)) f = (left_unitor_Bimod M).hom ≫ f ≫ (left_unitor_Bimod N).inv :=
begin
  dsimp [tensor_hom, regular, left_unitor_Bimod],
  ext, dsimp,
  slice_lhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  dsimp [left_unitor_Bimod.hom],
  slice_rhs 1 2 { rw coequalizer.π_desc },
  dsimp [left_unitor_Bimod.inv],
  slice_rhs 1 2 { rw hom.left_act_hom },
  slice_rhs 2 3 { rw left_unitor_inv_naturality },
  slice_rhs 3 4 { rw [id_tensor_comp_tensor_id, ←tensor_id_comp_id_tensor] },
  slice_rhs 4 4 { rw ←(iso.inv_hom_id_assoc (α_ X.X X.X N.X) (𝟙 X.X ⊗ N.act_left)) },
  slice_rhs 5 7 { rw [←category.assoc, ←coequalizer.condition] },
  slice_rhs 3 4 { rw [←monoidal_category.tensor_id, associator_inv_naturality] },
  slice_rhs 4 5 { rw [←comp_tensor_id, Mon_.one_mul] },
  have :
    (λ_ (X.X ⊗ N.X)).inv ≫ (α_ (𝟙_ C) X.X N.X).inv ≫ ((λ_ X.X).hom ⊗ 𝟙 N.X) = 𝟙 _ :=
    by pure_coherence,
  slice_rhs 2 4 { rw this },
  slice_rhs 1 2 { rw category.comp_id },
end

lemma comp_whisker_left_Bimod {W X Y Z : Mon_ C}
  (M : Bimod W X) (N : Bimod X Y) {P P' : Bimod Y Z} (f : P ⟶ P') :
  tensor_hom (𝟙 (M.tensor_Bimod N)) f =
  (associator_Bimod M N P).hom ≫ tensor_hom (𝟙 M) (tensor_hom (𝟙 N) f) ≫
    (associator_Bimod M N P').inv :=
begin
  dsimp [tensor_hom, tensor_Bimod, associator_Bimod],
  ext, dsimp,
  slice_lhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  dsimp [tensor_Bimod.X, associator_Bimod.hom],
  slice_rhs 1 2 { rw coequalizer.π_desc },
  dsimp [associator_Bimod.hom_aux, associator_Bimod.inv],
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  rw tensor_right_map,
  slice_rhs 1 3 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_rhs 3 4 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 2 3 { rw [←id_tensor_comp, ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 3 4 { rw coequalizer.π_desc },
  dsimp [associator_Bimod.inv_aux],
  slice_rhs 2 2 { rw id_tensor_comp },
  slice_rhs 3 5 { rw id_tensor_π_preserves_coequalizer_inv_desc },
  slice_rhs 2 3 { rw associator_inv_naturality },
  slice_rhs 1 3 { rw [iso.hom_inv_id_assoc, monoidal_category.tensor_id] },
  slice_lhs 1 2 { rw [tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
  dunfold tensor_Bimod.X,
  simp only [category.assoc],
end

lemma comp_whisker_right_Bimod {X Y Z : Mon_ C}
  {M N P : Bimod X Y} (f : M ⟶ N) (g : N ⟶ P) (Q : Bimod Y Z) :
  tensor_hom (f ≫ g) (𝟙 Q) = tensor_hom f (𝟙 Q) ≫ tensor_hom g (𝟙 Q) :=
by rw [←tensor_comp, category.comp_id]

lemma whisker_right_id_Bimod {X Y : Mon_ C} {M N : Bimod X Y} (f : M ⟶ N) :
  tensor_hom f (𝟙 (regular Y)) = (right_unitor_Bimod M).hom ≫ f ≫ (right_unitor_Bimod N).inv :=
begin
  dsimp [tensor_hom, regular, right_unitor_Bimod],
  ext, dsimp,
  slice_lhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  dsimp [right_unitor_Bimod.hom],
  slice_rhs 1 2 { rw coequalizer.π_desc },
  dsimp [right_unitor_Bimod.inv],
  slice_rhs 1 2 { rw hom.right_act_hom },
  slice_rhs 2 3 { rw right_unitor_inv_naturality },
  slice_rhs 3 4 { rw [tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
  slice_rhs 4 5 { rw coequalizer.condition },
  slice_rhs 3 4 { rw [←monoidal_category.tensor_id, associator_naturality] },
  slice_rhs 4 5 { rw [←id_tensor_comp, Mon_.mul_one] },
  have :
    (ρ_ (N.X ⊗ Y.X)).inv ≫ (α_ N.X Y.X (𝟙_ C)).hom ≫ (𝟙 N.X ⊗ (ρ_ Y.X).hom) = 𝟙 _ :=
    by pure_coherence,
  slice_rhs 2 4 { rw this },
  slice_rhs 1 2 { rw category.comp_id },
end

lemma whisker_right_comp_Bimod {W X Y Z : Mon_ C}
  {M M' : Bimod W X} (f : M ⟶ M') (N : Bimod X Y) (P : Bimod Y Z) :
  tensor_hom f (𝟙 (N.tensor_Bimod P)) =
  (associator_Bimod M N P).inv ≫ tensor_hom (tensor_hom f (𝟙 N)) (𝟙 P) ≫
    (associator_Bimod M' N P).hom :=
begin
  dsimp [tensor_hom, tensor_Bimod, associator_Bimod],
  ext, dsimp,
  slice_lhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  dsimp [tensor_Bimod.X, associator_Bimod.inv],
  slice_rhs 1 2 { rw coequalizer.π_desc },
  dsimp [associator_Bimod.inv_aux, associator_Bimod.hom],
  refine (cancel_epi ((tensor_left _).map (coequalizer.π _ _))).1 _,
  rw tensor_left_map,
  slice_rhs 1 3 { rw id_tensor_π_preserves_coequalizer_inv_desc },
  slice_rhs 3 4 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 2 3 { rw [←comp_tensor_id, ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 3 4 { rw coequalizer.π_desc },
  dsimp [associator_Bimod.hom_aux],
  slice_rhs 2 2 { rw comp_tensor_id },
  slice_rhs 3 5 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_rhs 2 3 { rw associator_naturality },
  slice_rhs 1 3 { rw [iso.inv_hom_id_assoc, monoidal_category.tensor_id] },
  slice_lhs 1 2 { rw [id_tensor_comp_tensor_id, ←tensor_id_comp_id_tensor] },
  dunfold tensor_Bimod.X,
  simp only [category.assoc],
end

lemma whisker_assoc_Bimod {W X Y Z : Mon_ C}
  (M : Bimod W X) {N N' : Bimod X Y} (f : N ⟶ N') (P : Bimod Y Z) :
  tensor_hom (tensor_hom (𝟙 M) f) (𝟙 P) =
  (associator_Bimod M N P).hom ≫ tensor_hom (𝟙 M) (tensor_hom f (𝟙 P)) ≫
    (associator_Bimod M N' P).inv :=
begin
  dsimp [tensor_hom, tensor_Bimod, associator_Bimod],
  ext, dsimp,
  slice_lhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  dsimp [associator_Bimod.hom],
  slice_rhs 1 2 { rw coequalizer.π_desc },
  dsimp [associator_Bimod.hom_aux],
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  rw tensor_right_map,
  slice_lhs 1 2 { rw [←comp_tensor_id, ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 1 3 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_rhs 3 4 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 2 3 { rw [←id_tensor_comp, ι_colim_map, parallel_pair_hom_app_one] },
  dsimp [associator_Bimod.inv],
  slice_rhs 3 4 { rw coequalizer.π_desc },
  dsimp [associator_Bimod.inv_aux],
  slice_rhs 2 2 { rw id_tensor_comp },
  slice_rhs 3 5 { rw id_tensor_π_preserves_coequalizer_inv_desc },
  slice_rhs 2 3 { rw associator_inv_naturality },
  slice_rhs 1 3 { rw iso.hom_inv_id_assoc },
  slice_lhs 1 1 { rw comp_tensor_id },
end

lemma whisker_exchange_Bimod {X Y Z : Mon_ C}
  {M N : Bimod X Y} {P Q : Bimod Y Z} (f : M ⟶ N) (g : P ⟶ Q) :
  tensor_hom (𝟙 M) g ≫ tensor_hom f (𝟙 Q) = tensor_hom f (𝟙 P) ≫ tensor_hom (𝟙 N) g :=
begin
  dsimp [tensor_hom],
  ext, dsimp,
  slice_lhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_lhs 2 3 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_lhs 1 2 { rw id_tensor_comp_tensor_id },
  slice_rhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 2 3 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_rhs 1 2 { rw tensor_id_comp_id_tensor },
end

lemma pentagon_Bimod {V W X Y Z : Mon_ C}
  (M : Bimod V W) (N : Bimod W X) (P : Bimod X Y) (Q : Bimod Y Z) :
  tensor_hom (associator_Bimod M N P).hom (𝟙 Q) ≫ (associator_Bimod M (N.tensor_Bimod P) Q).hom ≫
    tensor_hom (𝟙 M) (associator_Bimod N P Q).hom =
  (associator_Bimod (M.tensor_Bimod N) P Q).hom ≫ (associator_Bimod M N (P.tensor_Bimod Q)).hom :=
begin
  dsimp [tensor_hom, associator_Bimod], ext, dsimp,
  dunfold associator_Bimod.hom,
  slice_lhs 1 2 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_lhs 2 3 { rw coequalizer.π_desc },
  slice_rhs 1 2 { rw coequalizer.π_desc },
  dsimp [associator_Bimod.hom_aux],
  refine (cancel_epi ((tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp,
  slice_lhs 1 2 { rw [←comp_tensor_id, coequalizer.π_desc] },
  slice_rhs 1 3 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_rhs 3 4 { rw coequalizer.π_desc },
  refine (cancel_epi ((tensor_right _ ⋙ tensor_right _).map (coequalizer.π _ _))).1 _,
  dsimp,
  slice_lhs 1 2 { rw [←comp_tensor_id,
                      π_tensor_id_preserves_coequalizer_inv_desc,
                      comp_tensor_id, comp_tensor_id ]},
  slice_lhs 3 5 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  dunfold tensor_Bimod.X,
  slice_lhs 2 3 { rw associator_naturality },
  slice_lhs 5 6 { rw [ι_colim_map, parallel_pair_hom_app_one] },
  slice_lhs 4 5 { rw [←id_tensor_comp, coequalizer.π_desc] },
  slice_lhs 3 4 { rw [←id_tensor_comp,
                      π_tensor_id_preserves_coequalizer_inv_desc,
                      id_tensor_comp, id_tensor_comp] },
  slice_rhs 1 2 { rw associator_naturality },
  slice_rhs 2 3 { rw [monoidal_category.tensor_id,
                      tensor_id_comp_id_tensor, ←id_tensor_comp_tensor_id] },
  slice_rhs 3 5 { rw π_tensor_id_preserves_coequalizer_inv_desc },
  slice_rhs 2 3 { rw [←monoidal_category.tensor_id, associator_naturality] },
  coherence,
end

/-- The bicategory of algebras (monoids) and bimodules, all internal to some monoidal category. -/
noncomputable
def Mon_bicategory : bicategory (Mon_ C) :=
{ hom := λ X Y, Bimod X Y,
  id := λ X, regular X,
  comp := λ _ _ _ M N, tensor_Bimod M N,
  whisker_left := λ _ _ _ L _ _ f, tensor_hom (𝟙 L) f,
  whisker_right := λ _ _ _ _ _ f N, tensor_hom f (𝟙 N),
  associator := λ _ _ _ _ L M N, associator_Bimod L M N,
  left_unitor := λ _ _ M, left_unitor_Bimod M,
  right_unitor := λ _ _ M, right_unitor_Bimod M,
  whisker_left_id' := λ _ _ _ _ _, tensor_id,
  whisker_left_comp' := λ _ _ _ M _ _ _ f g, whisker_left_comp_Bimod M f g,
  id_whisker_left' := λ _ _ _ _ f, id_whisker_left_Bimod f,
  comp_whisker_left' := λ _ _ _ _ M N _ _ f, comp_whisker_left_Bimod M N f,
  id_whisker_right' := λ _ _ _ _ _, tensor_id,
  comp_whisker_right' := λ _ _ _ _ _ _ f g Q, comp_whisker_right_Bimod f g Q,
  whisker_right_id' := λ _ _ _ _ f, whisker_right_id_Bimod f,
  whisker_right_comp' := λ _ _ _ _ _ _ f N P, whisker_right_comp_Bimod f N P,
  whisker_assoc' := λ _ _ _ _ M _ _ f P, whisker_assoc_Bimod M f P,
  whisker_exchange' := λ _ _ _ _ _ _ _ f g, whisker_exchange_Bimod f g,
  pentagon' := λ _ _ _ _ _ M N P Q, pentagon_Bimod M N P Q,
  triangle' := λ _ _ _ M N, triangle_Bimod M N }

end Bimod


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.sites.compatible_sheafification
import category_theory.adjunction.whiskering

/-!

In this file, we show that an adjunction `F ⊣ G` induces an adjunction between
categories of sheaves, under certain hypotheses on `F` and `G`.

-/

namespace category_theory

open category_theory.grothendieck_topology
open category_theory
open category_theory.limits
open opposite

universes w₁ w₂ v u
variables {C : Type u} [category.{v} C] (J : grothendieck_topology C)
variables {D : Type w₁} [category.{max v u} D]
variables {E : Type w₂} [category.{max v u} E]
variables {F : D ⥤ E} {G : E ⥤ D}
variables [∀ (X : C) (S : J.cover X) (P : Cᵒᵖ ⥤ D),
  preserves_limit (S.index P).multicospan F]

variables
  [concrete_category.{max v u} D]
  [preserves_limits (forget D)]

/-- The forgetful functor from `Sheaf J D` to sheaves of types, for a concrete category `D`
whose forgetful functor preserves the correct limits. -/
abbreviation Sheaf_forget : Sheaf J D ⥤ SheafOfTypes J :=
Sheaf_compose J (forget D) ⋙ (Sheaf_equiv_SheafOfTypes J).functor

-- We need to sheafify...
variables
  [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
  [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
  [reflects_isomorphisms (forget D)]

namespace Sheaf
noncomputable theory

/-- This is the functor sending a sheaf `X : Sheaf J E` to the sheafification
of `X ⋙ G`. -/
abbreviation compose_and_sheafify (G : E ⥤ D) : Sheaf J E ⥤ Sheaf J D :=
Sheaf_to_presheaf J E ⋙ (whiskering_right _ _ _).obj G ⋙ presheaf_to_Sheaf J D

/-- An auxiliary definition to be used in defining `category_theory.Sheaf.adjunction` below. -/
@[simps]
def compose_equiv (adj : G ⊣ F) (X : Sheaf J E) (Y : Sheaf J D) :
((compose_and_sheafify J G).obj X ⟶ Y) ≃ (X ⟶ (Sheaf_compose J F).obj Y) :=
let A := adj.whisker_right Cᵒᵖ in
{ to_fun := λ η, A.hom_equiv _ _ (J.to_sheafify _  ≫ η),
  inv_fun := λ γ, J.sheafify_lift ((A.hom_equiv _ _).symm ((Sheaf_to_presheaf _ _).map γ)) Y.2,
  left_inv := begin
    intros η,
    symmetry,
    apply J.sheafify_lift_unique,
    erw equiv.symm_apply_apply,
  end,
  right_inv := begin
    intros γ,
    dsimp,
    rw [J.to_sheafify_sheafify_lift, equiv.apply_symm_apply],
  end }

/-- An adjunction `adj : G ⊣ F` with `F : D ⥤ E` and `G : E ⥤ D` induces an adjunction
between `Sheaf J D` and `Sheaf J E`, in contexts where one can sheafify `D`-valued presheaves,
and `F` preserves the correct limits. -/
def adjunction (adj : G ⊣ F) : compose_and_sheafify J G ⊣ Sheaf_compose J F :=
adjunction.mk_of_hom_equiv
{ hom_equiv := compose_equiv J adj,
  hom_equiv_naturality_left_symm' := begin
    intros X' X Y f g,
    symmetry,
    apply J.sheafify_lift_unique,
    dsimp [compose_equiv, adjunction.whisker_right],
    erw [sheafify_map_sheafify_lift, to_sheafify_sheafify_lift],
    ext : 2,
    dsimp,
    simp,
  end,
  hom_equiv_naturality_right' := begin
    intros X Y Y' f g,
    dsimp [compose_equiv, adjunction.whisker_right],
    ext : 2,
    dsimp,
    simp,
  end }

@[simp]
lemma adjunction_hom_equiv_apply (adj : G ⊣ F) (X : Sheaf J D) (Y : Sheaf J E)
  (η : (compose_and_sheafify J G).obj Y ⟶ X) : (adjunction J adj).hom_equiv _ _ η =
  (adj.whisker_right _).hom_equiv _ _ (J.to_sheafify _ ≫ η) := rfl

@[simp]
lemma adjunction_hom_equiv_symm_apply (adj : G ⊣ F) (X : Sheaf J D) (Y : Sheaf J E)
  (η : Y ⟶ (Sheaf_compose J F).obj X) : ((adjunction J adj).hom_equiv _ _).symm η =
  J.sheafify_lift (((adj.whisker_right _).hom_equiv _ _).symm η) X.2 := rfl

@[simp]
lemma adjunction_unit_app (adj : G ⊣ F) (X : Sheaf J E) :
  (Sheaf_to_presheaf _ _).map ((adjunction J adj).unit.app X) =
  (adj.whisker_right _).unit.app _ ≫ whisker_right (J.to_sheafify _) F :=
begin
  dsimp [adjunction],
  erw category.comp_id,
  refl,
end

@[simp]
lemma adjunction_counit_app (adj : G ⊣ F) (Y : Sheaf J D) :
  (Sheaf_to_presheaf _ _).map ((adjunction J adj).counit.app Y) =
  J.sheafify_lift ((functor.associator _ _ _).hom ≫
  (adj.whisker_right _).counit.app _) Y.2 :=
begin
  dsimp [adjunction],
  simp only [whiskering_right_obj_map, adjunction.hom_equiv_counit],
  erw [whisker_right_id],
  refl,
end

instance [is_right_adjoint F] : is_right_adjoint (Sheaf_compose J F) :=
⟨_, adjunction J (adjunction.of_right_adjoint F)⟩

section forget_to_type

/-- This is the functor sending a sheaf of types `X` to the sheafification of `X ⋙ G`. -/
abbreviation compose_and_sheafify_from_types (G : Type (max v u) ⥤ D) :
  SheafOfTypes J ⥤ Sheaf J D :=
(Sheaf_equiv_SheafOfTypes J).inverse ⋙ compose_and_sheafify _ G

/-- A variant of the adjunction between sheaf categories, in the case where the right adjoint
is the forgetful functor to sheaves of types. -/
def adjunction_to_types {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D) :
  compose_and_sheafify_from_types J G ⊣ Sheaf_forget J :=
adjunction.comp _ _ ((Sheaf_equiv_SheafOfTypes J).symm.to_adjunction) (adjunction J adj)

@[simp]
lemma adjunction_to_types_hom_equiv_apply {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D)
  (X : Sheaf J D) (Y : SheafOfTypes J) (η : (compose_and_sheafify_from_types J G).obj Y ⟶ X) :
  (adjunction_to_types J adj).hom_equiv _ _ η =
  (adj.whisker_right _).hom_equiv _ _ (J.to_sheafify _ ≫ η) := rfl

@[simp]
lemma adjunction_to_types_hom_equiv_symm_apply {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D)
  (X : Sheaf J D) (Y : SheafOfTypes J) (η : Y ⟶ (Sheaf_forget J).obj X) :
  ((adjunction_to_types J adj).hom_equiv _ _).symm η =
  J.sheafify_lift (((adj.whisker_right _).hom_equiv _ _).symm η) X.2 := rfl

@[simp]
lemma adjunction_to_types_unit_app {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D)
  (Y : SheafOfTypes J) :
  (SheafOfTypes_to_presheaf J).map ((adjunction_to_types J adj).unit.app Y) =
  (adj.whisker_right _).unit.app ((SheafOfTypes_to_presheaf J).obj Y) ≫
  whisker_right (J.to_sheafify _) (forget D) :=
begin
  dsimp [adjunction_to_types, adjunction.comp],
  rw category.comp_id,
  change (SheafOfTypes_to_presheaf _).map _ = _,
  erw [functor.map_comp, adjunction_unit_app],
  refl,
end

@[simp]
lemma adjunction_to_types_counit_app {G : Type (max v u) ⥤ D} (adj : G ⊣ forget D)
  (X : Sheaf J D) :
  (Sheaf_to_presheaf _ _).map ((adjunction_to_types J adj).counit.app X) =
  J.sheafify_lift ((functor.associator _ _ _).hom ≫ (adj.whisker_right _).counit.app _) X.2 :=
begin
  dsimp only [adjunction_to_types, adjunction.comp],
  erw [functor.map_comp, functor.map_comp, adjunction_counit_app, ← category.assoc],
  convert category.id_comp _,
  dsimp only [functor.associator],
  erw [functor.map_id, category.id_comp, functor.map_id],
  refl,
end

instance [is_right_adjoint (forget D)] : is_right_adjoint (Sheaf_forget J) :=
⟨_, adjunction_to_types J (adjunction.of_right_adjoint (forget D))⟩

end forget_to_type

end Sheaf

end category_theory


import polyhedral_lattice.Hom
import Lbar.pseudo_normed_group

import normed_spectral

import pseudo_normed_group.homotopy

import thm95.double_complex
import thm95.constants

noncomputable theory

universes u v

open_locale nnreal -- enable the notation `ℝ≥0` for the nonnegative real numbers.

open polyhedral_lattice opposite
open thm95.universal_constants system_of_double_complexes category_theory breen_deligne
open ProFiltPseuNormGrpWithTinv (of)

section

variables (BD : package)
variables (r r' : ℝ≥0) [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r' ≤ 1)]
variables (V : SemiNormedGroup.{v}) [normed_with_aut r V]
variables (κ κ' : ℕ → ℝ≥0) [BD.data.very_suitable r r' κ]
variables (M : ProFiltPseuNormGrpWithTinv.{u} r')
variables (m : ℕ)
variables (Λ : PolyhedralLattice.{u})

def NSH_aux_type (N : ℕ) (M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ) :=
normed_spectral_homotopy
  ((BD_system_map (BD.data.sum (2^N)) κ (rescale_constants κ (2^N)) r V).app M)
  m (k' κ' m) (ε r r' BD κ' m) (c₀ r r' BD κ κ' m Λ) (H r r' BD κ' m)

section

variables {BD r r' V κ κ' m}

section NSH_h

variables [package.adept BD κ κ']

def NSH_h {M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ} (q q' : ℕ) (c : ℝ≥0) :
  ((BD.data.system κ r V r').obj M) (k' κ' m * c) q' ⟶
    ((((data.mul (2 ^ N₂ r r' BD κ' m)).obj BD.data).system
      (rescale_constants κ (2 ^ N₂ r r' BD κ' m)) r V r').obj M) c q :=
if hqm : q' ≤ m + 1
then
begin
  refine (universal_map.eval_CLCFPTinv _ _ _ _ _ _).app _,
  { exact (data.homotopy_mul BD.data BD.homotopy (N₂ r r' BD κ' m)).hom q q' },
  { dsimp,
    refine universal_map.suitable.le _ _ (c * (κ' q' * κ q')) _
      infer_instance le_rfl _,
    calc c * (κ' q' * κ q')
        = κ' q' * (c * κ q') : mul_left_comm _ _ _
    ... ≤ k' κ' m * (c * κ q') : mul_le_mul' (κ'_le_k' _ _ hqm) le_rfl
    ... = k' κ' m * c * κ q' : (mul_assoc _ _ _).symm, }
end
else 0

lemma norm_NSH_h_le {M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ} (q : ℕ) (hqm : q ≤ m) (c : ℝ≥0) :
  ∥@NSH_h BD r r' _ _ _ _ V _ κ κ' _ m _ M q (q+1) c∥ ≤ (H r r' BD κ' m) :=
begin
  rw [NSH_h, dif_pos (nat.succ_le_succ hqm)],
  apply universal_map.norm_eval_CLCFPTinv₂_le,
  exact (bound_by_H r r' BD κ' _ hqm),
end

end NSH_h

instance NSH_δ_res' (N i : ℕ) (c : ℝ≥0) [hN : fact (k' κ' m ≤ 2 ^ N)] :
  fact (k' κ' m * c * rescale_constants κ (2 ^ N) i ≤ c * κ i) :=
begin
  refine ⟨_⟩,
  calc k' κ' m * c * (κ i * (2 ^ N)⁻¹)
     = (k' κ' m * (2 ^ N)⁻¹) * (c * κ i) : by ring1
  ... ≤ 1 * (c * κ i) : mul_le_mul' _ le_rfl
  ... = c * κ i : one_mul _,
  apply mul_inv_le_of_le_mul,
  rw one_mul,
  exact hN.1
end

variables (κ')

@[simps f]
def NSH_δ_res {BD : data} [BD.suitable κ] {r r' : ℝ≥0}
  [fact (0 < r)] [fact (0 < r')] [fact (r' ≤ 1)] {V : SemiNormedGroup.{u}} [normed_with_aut r V]
  (N : ℕ) [fact (k' κ' m ≤ 2 ^ N)] (c : ℝ≥0) {M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ} :
  ((BD.system κ r V r').obj M).obj (op c) ⟶
    ((BD.system (rescale_constants κ (2 ^ N)) r V r').obj M).obj (op (k' κ' m * c)) :=
{ f := λ i, (@CLCFPTinv.res r V _ _ r' _ _ _ _ _ (NSH_δ_res' _ _ _)).app M,
  comm' :=
  begin
    intros i j hij,
    dsimp [data.system_obj, data.complex],
    exact nat_trans.congr_app (universal_map.res_comp_eval_CLCFPTinv r V r' _ _ _ _ _) M,
  end }
.

variables {κ'}

def NSH_δ {M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ} (c : ℝ≥0) :
  ((BD.data.system κ r V r').obj M).obj (op c) ⟶
    ((((data.mul (2 ^ N₂ r r' BD κ' m)).obj BD.data).system
      (rescale_constants κ (2 ^ N₂ r r' BD κ' m)) r V r').obj M).obj (op (k' κ' m * c)) :=
NSH_δ_res κ' (N₂ r r' BD κ' m) _ ≫ (BD_map (BD.data.proj (2 ^ N₂ r r' BD κ' m)) _ _ r V _).app M

lemma norm_NSH_δ_le {M : (ProFiltPseuNormGrpWithTinv r')ᵒᵖ} (c : ℝ≥0) (q : ℕ) :
  ∥(@NSH_δ BD r r' _ _ _ _ V _ κ κ' _ m M c).f q∥ ≤ (ε r r' BD κ' m) :=
begin
  refine le_trans (normed_add_group_hom.norm_comp_le_of_le'
    (r ^ (b r r' BD κ' m)) (N r r' BD κ' m) _ (mul_comm _ _) _ _) _,
  { apply universal_map.norm_eval_CLCFPTinv₂_le,
    apply universal_map.proj_bound_by },
  { refine @CLCFPTinv.norm_res_le_pow r V _ _ r' _ _ _ _ _ _ _ ⟨_⟩ _,
    dsimp only [unop_op, rescale_constants],
    simp only [← mul_assoc, mul_right_comm _ c],
    simp only [mul_right_comm _ (κ q)],
    refine mul_le_mul' _ le_rfl,
    refine mul_le_mul' _ le_rfl,
    apply thm95.universal_constants.N₂_spec, },
  { apply_mod_cast r_pow_b_le_ε }
end

variables (V κ' m)

open homological_complex category_theory.preadditive

end

variables [package.adept BD κ κ']

def NSH_aux' (M) (hδ) : NSH_aux_type BD r r' V κ κ' m Λ (N₂ r r' BD κ' m) M :=
{ h := λ q q' c, NSH_h q q' c,
  norm_h_le := by { rintro q q' hqm rfl c hc, rw nnreal.coe_nat_cast, exact norm_NSH_h_le q hqm c },
  δ := NSH_δ,
  hδ := hδ,
  norm_δ_le := λ c hc q hqm, by apply norm_NSH_δ_le }
.

def NSH_aux (M) : NSH_aux_type BD r r' V κ κ' m Λ (N₂ r r' BD κ' m) M :=
NSH_aux' BD r r' V κ κ' m Λ M
begin
  introsI c hc q hqm,
  haveI hqm_ : fact (q ≤ m) := ⟨hqm⟩,
  rw [NSH_δ, NSH_h, NSH_h, dif_pos (nat.succ_le_succ hqm), dif_pos (hqm.trans (nat.le_succ _))],
  erw [homological_complex.comp_f],
  dsimp only [unop_op, NSH_δ_res_f, data.system_res_def, quiver.hom.apply,
    BD_system_map_app_app, BD_map_app_f, data.system_obj_d],
  simp only [← universal_map.eval_CLCFPTinv_def],
  have hcomm := (data.homotopy_mul BD.data BD.homotopy (N₂ r r' BD κ' m)).comm q,
  simp only [universal_map.res_comp_eval_CLCFPTinv_absorb, hcomm, ← nat_trans.app_add, add_assoc,
    ← nat_trans.comp_app, ← category.assoc, ← universal_map.eval_CLCFPTinv_comp,
    universal_map.eval_CLCFPTinv_comp_res_absorb, ← universal_map.eval_CLCFPTinv_add],
  congr' 2,
  rw [← add_assoc, add_comm, @prev_d_eq _ _ _ _ _ _ _ _ q (q+1)],
  swap, { dsimp, refl },
  congr' 1,
  rw add_comm,
  congr' 1,
  rw d_next_nat,
end
.

end


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.adjunction.fully_faithful
import category_theory.functor.reflects_isomorphisms
import category_theory.epi_mono

/-!
# Reflective functors

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

Basic properties of reflective functors, especially those relating to their essential image.

Note properties of reflective functors relating to limits and colimits are included in
`category_theory.monad.limits`.
-/

universes v₁ v₂ v₃ u₁ u₂ u₃

noncomputable theory

namespace category_theory

open category adjunction

variables {C : Type u₁} {D : Type u₂} {E : Type u₃}
variables [category.{v₁} C] [category.{v₂} D] [category.{v₃} E]

/--
A functor is *reflective*, or *a reflective inclusion*, if it is fully faithful and right adjoint.
-/
class reflective (R : D ⥤ C) extends is_right_adjoint R, full R, faithful R.

variables {i : D ⥤ C}

/--
For a reflective functor `i` (with left adjoint `L`), with unit `η`, we have `η_iL = iL η`.
-/
-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
lemma unit_obj_eq_map_unit [reflective i] (X : C) :
  (of_right_adjoint i).unit.app (i.obj ((left_adjoint i).obj X))
    = i.map ((left_adjoint i).map ((of_right_adjoint i).unit.app X)) :=
begin
 rw [←cancel_mono (i.map ((of_right_adjoint i).counit.app ((left_adjoint i).obj X))),
     ←i.map_comp],
 simp,
end

/--
When restricted to objects in `D` given by `i : D ⥤ C`, the unit is an isomorphism. In other words,
`η_iX` is an isomorphism for any `X` in `D`.
More generally this applies to objects essentially in the reflective subcategory, see
`functor.ess_image.unit_iso`.
-/
instance is_iso_unit_obj [reflective i] {B : D} :
  is_iso ((of_right_adjoint i).unit.app (i.obj B)) :=
begin
  have : (of_right_adjoint i).unit.app (i.obj B) =
            inv (i.map ((of_right_adjoint i).counit.app B)),
  { rw ← comp_hom_eq_id,
    apply (of_right_adjoint i).right_triangle_components },
  rw this,
  exact is_iso.inv_is_iso,
end

/--
If `A` is essentially in the image of a reflective functor `i`, then `η_A` is an isomorphism.
This gives that the "witness" for `A` being in the essential image can instead be given as the
reflection of `A`, with the isomorphism as `η_A`.

(For any `B` in the reflective subcategory, we automatically have that `ε_B` is an iso.)
-/
lemma functor.ess_image.unit_is_iso [reflective i] {A : C} (h : A ∈ i.ess_image) :
  is_iso ((of_right_adjoint i).unit.app A) :=
begin
  suffices : (of_right_adjoint i).unit.app A =
                h.get_iso.inv ≫ (of_right_adjoint i).unit.app (i.obj h.witness) ≫
                  (left_adjoint i ⋙ i).map h.get_iso.hom,
  { rw this,
    apply_instance },
  rw ← nat_trans.naturality,
  simp,
end

/-- If `η_A` is an isomorphism, then `A` is in the essential image of `i`. -/
lemma mem_ess_image_of_unit_is_iso [is_right_adjoint i] (A : C)
  [is_iso ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
⟨(left_adjoint i).obj A, ⟨(as_iso ((of_right_adjoint i).unit.app A)).symm⟩⟩

/-- If `η_A` is a split monomorphism, then `A` is in the reflective subcategory. -/
lemma mem_ess_image_of_unit_is_split_mono [reflective i] {A : C}
  [is_split_mono ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
begin
  let η : 𝟭 C ⟶ left_adjoint i ⋙ i := (of_right_adjoint i).unit,
  haveI : is_iso (η.app (i.obj ((left_adjoint i).obj A))) := (i.obj_mem_ess_image _).unit_is_iso,
  have : epi (η.app A),
  { apply epi_of_epi (retraction (η.app A)) _,
    rw (show retraction _ ≫ η.app A = _, from η.naturality (retraction (η.app A))),
    apply epi_comp (η.app (i.obj ((left_adjoint i).obj A))) },
  resetI,
  haveI := is_iso_of_epi_of_is_split_mono (η.app A),
  exact mem_ess_image_of_unit_is_iso A,
end

/-- Composition of reflective functors. -/
instance reflective.comp (F : C ⥤ D) (G : D ⥤ E) [Fr : reflective F] [Gr : reflective G] :
  reflective (F ⋙ G) := { to_faithful := faithful.comp F G, }

/-- (Implementation) Auxiliary definition for `unit_comp_partial_bijective`. -/
def unit_comp_partial_bijective_aux [reflective i] (A : C) (B : D) :
  (A ⟶ i.obj B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :=
((adjunction.of_right_adjoint i).hom_equiv _ _).symm.trans (equiv_of_fully_faithful i)

/-- The description of the inverse of the bijection `unit_comp_partial_bijective_aux`. -/
lemma unit_comp_partial_bijective_aux_symm_apply [reflective i] {A : C} {B : D}
  (f : i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :
  (unit_comp_partial_bijective_aux _ _).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective_aux]

/--
If `i` has a reflector `L`, then the function `(i.obj (L.obj A) ⟶ B) → (A ⟶ B)` given by
precomposing with `η.app A` is a bijection provided `B` is in the essential image of `i`.
That is, the function `λ (f : i.obj (L.obj A) ⟶ B), η.app A ≫ f` is bijective, as long as `B` is in
the essential image of `i`.
This definition gives an equivalence: the key property that the inverse can be described
nicely is shown in `unit_comp_partial_bijective_symm_apply`.

This establishes there is a natural bijection `(A ⟶ B) ≃ (i.obj (L.obj A) ⟶ B)`. In other words,
from the point of view of objects in `D`, `A` and `i.obj (L.obj A)` look the same: specifically
that `η.app A` is an isomorphism.
-/
def unit_comp_partial_bijective [reflective i] (A : C) {B : C} (hB : B ∈ i.ess_image) :
  (A ⟶ B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) :=
calc (A ⟶ B) ≃ (A ⟶ i.obj hB.witness) : iso.hom_congr (iso.refl _) hB.get_iso.symm
     ...     ≃ (i.obj _ ⟶ i.obj hB.witness) : unit_comp_partial_bijective_aux _ _
     ...     ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) : iso.hom_congr (iso.refl _) hB.get_iso

@[simp]
lemma unit_comp_partial_bijective_symm_apply [reflective i] (A : C) {B : C}
  (hB : B ∈ i.ess_image) (f) :
  (unit_comp_partial_bijective A hB).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective, unit_comp_partial_bijective_aux_symm_apply]

lemma unit_comp_partial_bijective_symm_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : i.obj ((left_adjoint i).obj A) ⟶ B) :
  (unit_comp_partial_bijective A hB').symm (f ≫ h) =
    (unit_comp_partial_bijective A hB).symm f ≫ h :=
by simp

lemma unit_comp_partial_bijective_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : A ⟶ B) :
  (unit_comp_partial_bijective A hB') (f ≫ h) = unit_comp_partial_bijective A hB f ≫ h :=
by rw [←equiv.eq_symm_apply, unit_comp_partial_bijective_symm_natural A h, equiv.symm_apply_apply]

/-- If `i : D ⥤ C` is reflective, the inverse functor of `i ≌ F.ess_image` can be explicitly
defined by the reflector. -/
@[simps]
def equiv_ess_image_of_reflective [reflective i] : D ≌ i.ess_image_subcategory :=
{ functor := i.to_ess_image,
  inverse := i.ess_image_inclusion ⋙ (left_adjoint i : _),
  unit_iso := nat_iso.of_components (λ X, (as_iso $ (of_right_adjoint i).counit.app X).symm)
    (by { intros X Y f, dsimp, simp only [is_iso.eq_inv_comp, is_iso.comp_inv_eq, category.assoc],
      exact ((of_right_adjoint i).counit.naturality _).symm }),
  counit_iso :=
  nat_iso.of_components
    (λ X, by { refine (iso.symm $ as_iso _), exact (of_right_adjoint i).unit.app X.obj,
      apply_with (is_iso_of_reflects_iso _ i.ess_image_inclusion) { instances := ff },
      exact functor.ess_image.unit_is_iso X.property })
    (by { intros X Y f, dsimp, rw [is_iso.comp_inv_eq, assoc],
      have h := ((of_right_adjoint i).unit.naturality f).symm,
      rw [functor.id_map] at h, erw [← h, is_iso.inv_hom_id_assoc, functor.comp_map] }) }

end category_theory