import kassel.Tangle
import category_theory.monoidal.braided
import kassel.lemma.right_pivotal_category

open category_theory category_theory.monoidal_category

namespace kassel

universes v u
variables
  {C: Type u}
  [category.{v} C]
  [monoidal_category.{v} C]
  [right_rigid_category.{v} C]
  [right_pivotal_category.{v} C]
  [braided_category.{v} C]

def flip (V W: C) := (β_ V W).hom
notation `τ_` := flip

def trace {V: C} (f: V ⟶ V) := η_⁺ _ ≫ (f ⊗ 𝟙 Vᘁ) ≫ ε_⁻ _

def trace_2 {V: C} (f: V ⊗ V ⟶ V ⊗ V)
  :=                  (ρ_ _).inv
  ≫ (𝟙 V ⊗ η_⁺ _) ≫ (α_ _ _ _).inv
  ≫ (f ⊗ 𝟙 Vᘁ)    ≫ (α_ _ _ _).hom
  ≫ (𝟙 V ⊗ ε_⁻ _) ≫ (ρ_ _).hom

variable (C)

structure enhanced_R_matrix (V: C) :=
  (c: V ⊗ V ≅ V ⊗ V)
  (μ: V ≅ V)
  (relation_1:
       (𝟙 V ⊗ c.hom) ≫ (α_ _ _ _).inv
    ≫ (c.hom ⊗ 𝟙 V) ≫ (α_ _ _ _).hom
    ≫ (𝟙 V ⊗ c.hom) ≫ (α_ _ _ _).inv
  =                    (α_ _ _ _).inv
    ≫ (c.hom ⊗ 𝟙 V) ≫ (α_ _ _ _).hom
    ≫ (𝟙 V ⊗ c.hom) ≫ (α_ _ _ _).inv
    ≫ (c.hom ⊗ 𝟙 V)
  )
  (relation_2: c.hom ≫ (μ.hom ⊗ μ.hom) = (μ.hom ⊗ μ.hom) ≫ c.hom)
  (relation_3_1: trace_2 (c.hom ≫ (𝟙 V ⊗ μ.hom)) = 𝟙 V)
  (relation_3_2: trace_2 (c.inv ≫ (𝟙 V ⊗ μ.hom)) = 𝟙 V)
  (relation_4_1: (λ_ (V ⊗ Vᘁ)).inv ≫ (η_⁻ V ≫ (𝟙 Vᘁ ⊗ μ.inv) ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.inv ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ (μ.hom ⊗ 𝟙 Vᘁ) ≫ ε_⁻ V) ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ η_⁺ V) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ (ε_⁺ V ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (λ_ (V ⊗ Vᘁ)).hom = 𝟙 V ⊗ 𝟙 Vᘁ)
  (relation_4_2: (λ_ (V ⊗ Vᘁ)).inv ≫ (η_⁻ V ≫ (𝟙 Vᘁ ⊗ μ.inv) ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ (μ.hom ⊗ 𝟙 Vᘁ) ≫ ε_⁻ V) ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ η_⁺ V) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.inv ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ (ε_⁺ V ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (λ_ (V ⊗ Vᘁ)).hom = 𝟙 V ⊗ 𝟙 Vᘁ)
  (relation_4_3: (ρ_ (Vᘁ ⊗ V)).inv ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ η_⁺ V) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ (ε_⁺ V ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (η_⁻ V ≫ (𝟙 Vᘁ ⊗ μ.inv) ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.inv ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ (μ.hom ⊗ 𝟙 Vᘁ) ≫ ε_⁻ V) ≫ (ρ_ (Vᘁ ⊗ V)).hom = 𝟙 Vᘁ ⊗ 𝟙 V)
  (relation_4_4: (ρ_ (Vᘁ ⊗ V)).inv ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ η_⁺ V) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.inv ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ (ε_⁺ V ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (η_⁻ V ≫ (𝟙 Vᘁ ⊗ μ.inv) ⊗ 𝟙 V ⊗ 𝟙 Vᘁ) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).hom ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).inv) ≫ (𝟙 Vᘁ ⊗ c.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 Vᘁ ⊗ (α_ V V Vᘁ).hom) ≫ (α_ Vᘁ V (V ⊗ Vᘁ)).inv ≫ ((𝟙 Vᘁ ⊗ 𝟙 V) ⊗ (μ.hom ⊗ 𝟙 Vᘁ) ≫ ε_⁻ V) ≫ (ρ_ (Vᘁ ⊗ V)).hom = 𝟙 Vᘁ ⊗ 𝟙 V)

variable {C}

namespace enhanced_R_matrix

variables (V: C) (R: enhanced_R_matrix C V)

@[simp] def functor_obj: Tangle → C
  | Tangle.id := 𝟙_ C
  | ↓ := V
  | ↑ := Vᘁ
  | (a ⊗ᵗ b) := functor_obj a ⊗ functor_obj b

def functor_map: Π {X Y}, (X ⟶ᵐ Y) → (functor_obj V X ⟶ functor_obj V Y)
  | _ _ (𝟙ᵐ a) := 𝟙 (functor_obj V a)
  | _ _ (f ≫ᵐ g) := functor_map f ≫ functor_map g
  | _ _ (f ⊗ᵐ g) := functor_map f ⊗ functor_map g
  | _ _ (α _ _ _) := (α_ _ _ _).hom
  | _ _ (α⁻¹ _ _ _) := (α_ _ _ _).inv
  | _ _ (ℓ _) := (λ_ _).hom
  | _ _ (ℓ⁻¹ _) := (λ_ _).inv
  | _ _ (ρ _) := (ρ_ _).hom
  | _ _ (ρ⁻¹ _) := (ρ_ _).inv
  | _ _ η⁺ := η_⁺ V
  | _ _ η⁻ := η_⁻ _ ≫ (𝟙 Vᘁ ⊗ R.μ.inv)
  | _ _ ε⁺ := ε_⁺ _
  | _ _ ε⁻ := (R.μ.hom ⊗ 𝟙 Vᘁ) ≫ ε_⁻ V
  | _ _ β := R.c.hom
  | _ _ β⁻¹ := R.c.inv

namespace aux

lemma relation_2_c_inv:
  R.c.inv ≫ (R.μ.hom ⊗ R.μ.hom) = (R.μ.hom ⊗ R.μ.hom) ≫ R.c.inv :=
by rw [iso.eq_comp_inv, category.assoc, iso.inv_comp_eq, R.relation_2]

lemma functor_map_well_defined_1_1:
  functor_map V R (ρ⁻¹ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ η⁻ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ ε⁻ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ ℓ _) =
  functor_map V R (𝟙ᵐ _) :=
begin
  dsimp [functor_map],
  simp_rw [id_tensor_comp, comp_tensor_id, category.assoc],

  rw ←associator_inv_naturality_assoc,
  iterate 2 { rw [←tensor_comp_assoc _ _ R.μ.hom _, id_comp_comp_id R.μ.hom, tensor_comp_assoc], },
  rw [tensor_id, tensor_id, category.id_comp],
  rw [←tensor_id_comp_id_tensor_assoc _ R.μ.hom, ←right_unitor_inv_naturality_assoc],

  rw associator_inv_naturality_assoc,
  rw [←tensor_comp_assoc, ←id_comp_comp_id, tensor_comp_assoc],
  rw [tensor_id, tensor_id, category.id_comp],
  rw [←tensor_id_comp_id_tensor_assoc R.μ.inv _, left_unitor_naturality],

  slice_lhs 3 5 { rw coevaluation_evaluation_rev, },
  simp_rw [category.assoc, iso.inv_hom_id_assoc],
  rw iso.hom_inv_id,
end

lemma functor_map_well_defined_1_2:
  functor_map V R (ℓ⁻¹ _ ≫ᵐ η⁺ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ ε⁺ ≫ᵐ ρ _) = functor_map V R (𝟙ᵐ _) :=
begin
  dsimp [functor_map],
  rw [evaluation_coevaluation_assoc, iso.inv_hom_id_assoc, iso.inv_hom_id],
end

lemma functor_map_well_defined_2_1:
  functor_map V R (ρ⁻¹ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ η⁺ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ ε⁺ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ ℓ _) = functor_map V R (𝟙ᵐ _) :=
begin
  dsimp [functor_map],
  rw [coevaluation_evaluation_assoc, iso.inv_hom_id_assoc, iso.inv_hom_id],
end

lemma functor_map_well_defined_2_2:
  functor_map V R (ℓ⁻¹ _ ≫ᵐ η⁻ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ ε⁻ ≫ᵐ ρ _) = functor_map V R (𝟙ᵐ _) :=
begin
  dsimp [functor_map],
  simp_rw [id_tensor_comp, comp_tensor_id, category.assoc],
  rw associator_naturality_assoc,
  slice_lhs 4 5 { rw [←tensor_comp, ←tensor_comp, category.comp_id, iso.inv_hom_id, tensor_id, tensor_id], },
  rw category.id_comp,
  rw [evaluation_coevaluation_rev_assoc, iso.inv_hom_id_assoc, iso.inv_hom_id],
end

abbreviation functor_map_well_defined_3_lhs (b: ↓ ⊗ᵗ ↓ ⟶ᵐ ↓ ⊗ᵗ ↓) :=
  functor_map V R (                             ℓ⁻¹ _
    ≫ᵐ η⁻                   ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ ℓ⁻¹ _) ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ η⁻ ⊗ᵐ 𝟙ᵐ ↓) ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ α _ _ _) ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ α⁻¹ _ _ _ ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ α _ _ _
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ b  ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ α _ _ _ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ 𝟙ᵐ ↓ ⊗ᵐ α⁻¹ _ _ _
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ 𝟙ᵐ ↓ ⊗ᵐ ε⁻ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ 𝟙ᵐ ↓ ⊗ᵐ ℓ _
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ ε⁻                 ≫ᵐ ρ _
  )

abbreviation functor_map_well_defined_3_rhs (b: ↓ ⊗ᵗ ↓ ⟶ᵐ ↓ ⊗ᵗ ↓) :=
  functor_map V R (                             ρ⁻¹ _
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ η⁺                 ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ 𝟙ᵐ ↓ ⊗ᵐ ℓ⁻¹ ↑
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ 𝟙ᵐ ↓ ⊗ᵐ η⁺ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ 𝟙ᵐ ↓ ⊗ᵐ α _ _ _ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ α⁻¹ _ _ _
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑) ⊗ᵐ b  ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ α _ _ _ ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ α⁻¹ _ _ _) ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑
    ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ ε⁺ ⊗ᵐ 𝟙ᵐ ↓) ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ (𝟙ᵐ ↑ ⊗ᵐ ℓ _) ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑
    ≫ᵐ ε⁺                   ⊗ᵐ 𝟙ᵐ ↑ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ ℓ _
  )

abbreviation functor_map_well_defined_3_mid (b: ↓ ⊗ᵗ ↓ ⟶ᵐ ↓ ⊗ᵗ ↓) :=
  (δ_ V V).inv ≫ (functor_map V R b)ᘁ ≫ (δ_ V V).hom

lemma functor_map_well_defined_3_left (b: ↓ ⊗ᵗ ↓ ⟶ᵐ ↓ ⊗ᵗ ↓) (h: functor_map V R b ≫ (R.μ.hom ⊗ R.μ.hom) = (R.μ.hom ⊗ R.μ.hom) ≫ functor_map V R b):
  functor_map_well_defined_3_lhs V R b =
  functor_map_well_defined_3_mid V R b :=
begin
  dunfold functor_map_well_defined_3_lhs,
  dunfold functor_map_well_defined_3_mid,
  dsimp [functor_map],
  simp only [tensor_id, id_tensor_comp, comp_tensor_id, category.assoc],

  iterate 6 { rw [←tensor_comp_assoc _ (𝟙 (Vᘁ ⊗ Vᘁ)) _ (𝟙 (Vᘁ ⊗ Vᘁ)), category.comp_id], repeat { rw category.assoc, }, },
  rw [←tensor_comp_assoc _ R.μ.inv _ _, left_unitor_inv_naturality, tensor_comp_assoc],
  iterate 2 { rw [←tensor_comp_assoc _ (_ ⊗ R.μ.inv) _ _, ←tensor_comp _ R.μ.inv _ _, ←id_comp_comp_id R.μ.inv, tensor_comp, tensor_comp_assoc], },
  rw [←tensor_comp_assoc _ (_ ⊗ R.μ.inv) _ _, associator_naturality, tensor_comp_assoc],
  rw associator_inv_naturality,
  rw [tensor_id, id_tensor_comp_tensor_id_assoc, ←category.id_comp ((_ ⊗ 𝟙 Vᘁ) ⊗ (_ ⊗ R.μ.inv)), ←tensor_id],
  nth_rewrite 0 ←(δ_ _ _).inv_hom_id,
  rw [comp_tensor_id_assoc (δ_ _ _).inv _ _, ←coevaluation_rev_tensor_assoc],
  rw [tensor_id, tensor_id_comp_id_tensor, comp_tensor_id_assoc, associator_naturality_assoc],

  iterate 6 { nth_rewrite 1 ←tensor_comp_assoc (𝟙 (Vᘁ ⊗ Vᘁ)) _ (𝟙 (Vᘁ ⊗ Vᘁ)) _, rw category.comp_id, repeat { rw category.assoc, }, },
  rw [←tensor_comp_assoc _ _ _ ((R.μ.hom ⊗ 𝟙 _) ⊗ 𝟙 Vᘁ), ←associator_inv_naturality, tensor_comp_assoc],
  iterate 4 { rw [←tensor_comp_assoc _ _ R.μ.hom _, id_comp_comp_id R.μ.hom, tensor_comp_assoc], },
  rw [←associator_naturality_assoc R.μ.hom _ _, tensor_id, ←tensor_id_comp_id_tensor_assoc _ (R.μ.hom ⊗ _)],
  nth_rewrite 6 ←(δ_ _ _).inv_hom_id,
  rw [id_tensor_comp_assoc (δ_ _ _).inv _, tensor_id_comp_id_tensor_assoc],
  rw [tensor_id, category.id_comp, ←evaluation_rev_tensor],
  rw id_tensor_comp_assoc,

  iterate 3 { rw [←tensor_comp_assoc (δ_ _ _).hom _ _ _, ←id_comp_comp_id, tensor_comp_assoc], },
  rw [←id_tensor_comp_tensor_id_assoc _ (δ_ _ _).hom, right_unitor_naturality],
  simp_rw ←category.assoc, rw iso.cancel_iso_hom_right, simp_rw category.assoc,

  simp_rw ←associator_naturality_assoc,
  iterate 3 { rw [←tensor_comp_assoc _ _ _ (δ_ _ _).inv, id_comp_comp_id, tensor_comp_assoc], },
  rw [←id_tensor_comp_tensor_id_assoc (δ_ _ _).inv _, ←left_unitor_inv_naturality_assoc],
  rw iso.cancel_iso_inv_left,

  slice_lhs 3 5 { simp only [←tensor_comp, category.id_comp], },
  simp_rw category.assoc, rw right_adjoint_mate_rev,
  rw [h, ←tensor_iso_hom, ←tensor_iso_inv, iso.inv_hom_id_assoc],
end

lemma functor_map_well_defined_3_right (b: ↓ ⊗ᵗ ↓ ⟶ᵐ ↓ ⊗ᵗ ↓):
  functor_map_well_defined_3_rhs V R b =
  functor_map_well_defined_3_mid V R b :=
begin
  dunfold functor_map_well_defined_3_rhs,
  dunfold functor_map_well_defined_3_mid,
  dsimp [functor_map],
  simp only [tensor_id, id_tensor_comp, comp_tensor_id, category.assoc],

  iterate 4 { rw ←tensor_comp_assoc (𝟙 (Vᘁ ⊗ Vᘁ)) _ (𝟙 (Vᘁ ⊗ Vᘁ)) _, rw category.comp_id, }, repeat { rw category.assoc, },
  rw [←category.comp_id (α_ V V (Vᘁ ⊗ Vᘁ)).inv, ←tensor_id (V ⊗ V) (Vᘁ ⊗ Vᘁ)],
  nth_rewrite 1 ←(δ_ _ _).inv_hom_id, rw id_tensor_comp (δ_ V V).inv _,
  rw [←coevaluation_hom_tensor_assoc, id_tensor_comp_assoc],

  iterate 4 { rw ←comp_tensor_id_assoc, }, repeat { rw category.assoc, },
  rw [←category.id_comp (α_ Vᘁ Vᘁ (V ⊗ V)).hom, ←tensor_id (Vᘁ ⊗ Vᘁ) (V ⊗ V)],
  nth_rewrite 4 ←(δ_ _ _).inv_hom_id, rw comp_tensor_id_assoc (δ_ V V).inv _, repeat { rw category.assoc, },
  rw [←evaluation_hom_tensor, comp_tensor_id_assoc],

  rw ←associator_inv_naturality_assoc,
  iterate 3 { rw [←tensor_comp_assoc  _ _ (δ_ _ _).inv _, id_comp_comp_id, tensor_comp_assoc], },
  rw [←tensor_id_comp_id_tensor_assoc _ (δ_ _ _).inv, ←right_unitor_inv_naturality_assoc],
  rw iso.cancel_iso_inv_left,

  slice_lhs 3 5 { simp only [←tensor_comp, category.comp_id], rw @category.id_comp _ _ (V ⊗ V) (V ⊗ V) (functor_map V R b), }, simp_rw category.assoc,
  rw associator_inv_naturality_assoc,
  rw ←tensor_id_comp_id_tensor_assoc (δ_ V V).hom _,
  rw [←tensor_comp_assoc _ (δ_ _ _).hom _ _, ←id_comp_comp_id, tensor_comp_assoc],
  rw [←tensor_id_comp_id_tensor_assoc (δ_ V V).hom _, left_unitor_naturality],
  simp_rw ←category.assoc, rw iso.cancel_iso_hom_right, simp_rw category.assoc,

  simp_rw [tensor_id, category.id_comp],
  rw [←associator_inv_naturality_assoc], rw right_adjoint_mate,
end

lemma functor_map_well_defined_3_1:
  functor_map_well_defined_3_lhs V R β =
  functor_map_well_defined_3_rhs V R β :=
  eq.trans
    (functor_map_well_defined_3_left V R β (by rw [functor_map, R.relation_2]))
    (functor_map_well_defined_3_right V R β).symm

lemma functor_map_well_defined_3_2:
  functor_map_well_defined_3_lhs V R β⁻¹ =
  functor_map_well_defined_3_rhs V R β⁻¹ :=
  eq.trans
    (functor_map_well_defined_3_left V R β⁻¹ (by rw [functor_map, relation_2_c_inv]))
    (functor_map_well_defined_3_right V R β⁻¹).symm

lemma functor_map_well_defined_4_1:
  functor_map V R (β ≫ᵐ β⁻¹) = functor_map V R (𝟙ᵐ (↓ ⊗ᵗ ↓)) :=
by simp [functor_map]

lemma functor_map_well_defined_4_2:
  functor_map V R (β⁻¹ ≫ᵐ β) = functor_map V R (𝟙ᵐ (↓ ⊗ᵗ ↓)) :=
by simp [functor_map]

lemma functor_map_well_defined_5:
  functor_map V R (α⁻¹ _ _ _ ≫ᵐ β ⊗ᵐ 𝟙ᵐ ↓ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ ↓ ⊗ᵐ β ≫ᵐ α⁻¹ _ _ _ ≫ᵐ β ⊗ᵐ 𝟙ᵐ _) = functor_map V R (𝟙ᵐ ↓ ⊗ᵐ β ≫ᵐ α⁻¹ _ _ _ ≫ᵐ β ⊗ᵐ 𝟙ᵐ ↓ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ ↓ ⊗ᵐ β ≫ᵐ α⁻¹ _ _ _) :=
by dsimp [functor_map]; exact R.relation_1.symm

lemma functor_map_well_defined_6_1:
  functor_map V R (ρ⁻¹ _ ≫ᵐ 𝟙ᵐ ↓ ⊗ᵐ η⁺ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ β ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ ↓ ⊗ᵐ ε⁻ ≫ᵐ ρ _) = functor_map V R (𝟙ᵐ ↓) :=
begin
  simp [functor_map],
  change (ρ_ _).inv ≫ (𝟙 V ⊗ η_⁺ V) ≫ (α_ _ _ _).inv ≫ (R.c.hom ⊗ 𝟙 Vᘁ) ≫ (α_ _ _ _).hom ≫ (𝟙 V ⊗ R.μ.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 V ⊗ ε_⁻ V) ≫ (ρ_ _).hom = 𝟙 V,
  have h: trace_2 (R.c.hom ≫ (𝟙 V ⊗ R.μ.hom)) = (ρ_ _).inv ≫ (𝟙 V ⊗ η_⁺ V) ≫ (α_ _ _ _).inv ≫ (R.c.hom ⊗ 𝟙 Vᘁ) ≫ (α_ _ _ _).hom ≫ (𝟙 V ⊗ R.μ.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 V ⊗ ε_⁻ V) ≫ (ρ_ _).hom :=
    by simp [functor_map, trace_2, coevaluation, evaluation, evaluation_rev],
  rw ←h,
  exact R.relation_3_1,
end
lemma functor_map_well_defined_6_2:
  functor_map V R (ρ⁻¹ _ ≫ᵐ 𝟙ᵐ ↓ ⊗ᵐ η⁺ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ β⁻¹ ⊗ᵐ 𝟙ᵐ ↑ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ ↓ ⊗ᵐ ε⁻ ≫ᵐ ρ _) = functor_map V R (𝟙ᵐ ↓) :=
begin
  simp [functor_map],
  change (ρ_ _).inv ≫ (𝟙 V ⊗ η_⁺ V) ≫ (α_ _ _ _).inv ≫ (R.c.inv ⊗ 𝟙 Vᘁ) ≫ (α_ _ _ _).hom ≫ (𝟙 V ⊗ R.μ.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 V ⊗ ε_⁻ V) ≫ (ρ_ _).hom = 𝟙 V,
  have h: trace_2 (R.c.inv ≫ (𝟙 V ⊗ R.μ.hom)) = (ρ_ _).inv ≫ (𝟙 V ⊗ η_⁺ V) ≫ (α_ _ _ _).inv ≫ (R.c.inv ⊗ 𝟙 Vᘁ) ≫ (α_ _ _ _).hom ≫ (𝟙 V ⊗ R.μ.hom ⊗ 𝟙 Vᘁ) ≫ (𝟙 V ⊗ ε_⁻ V) ≫ (ρ_ _).hom :=
    by simp [functor_map, trace_2, coevaluation, evaluation, evaluation_rev],
  rw ←h,
  exact R.relation_3_2,
end

lemma functor_map_well_defined_7_1:
  functor_map V R (ℓ⁻¹ _ ≫ᵐ η⁻ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β⁻¹ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ ε⁻ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ η⁺ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ ε⁺ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ ℓ _) = functor_map V R (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) :=
by dsimp [functor_map]; exact R.relation_4_1

lemma functor_map_well_defined_7_2:
  functor_map V R (ℓ⁻¹ _ ≫ᵐ η⁻ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ ε⁻ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ η⁺ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β⁻¹ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ ε⁺ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ ℓ _) = functor_map V R (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) :=
by dsimp [functor_map]; exact R.relation_4_2

lemma functor_map_well_defined_8_1:
  functor_map V R (ρ⁻¹ _ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ η⁺ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ ↑ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ ε⁺ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ η⁻ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β⁻¹ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ ↑ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ ε⁻ ≫ᵐ ρ _) = functor_map V R (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) :=
by dsimp [functor_map]; exact R.relation_4_3

lemma functor_map_well_defined_8_2:
  functor_map V R (ρ⁻¹ _ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ η⁺ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ ↑ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β⁻¹ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ ε⁺ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ η⁻ ⊗ᵐ 𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _ ≫ᵐ α _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ α⁻¹ _ _ _ ≫ᵐ 𝟙ᵐ _ ⊗ᵐ β ⊗ᵐ 𝟙ᵐ _ ≫ᵐ 𝟙ᵐ ↑ ⊗ᵐ α _ _ _ ≫ᵐ α⁻¹ _ _ _ ≫ᵐ (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) ⊗ᵐ ε⁻ ≫ᵐ ρ _) = functor_map V R (𝟙ᵐ _ ⊗ᵐ 𝟙ᵐ _) :=
by dsimp [functor_map]; exact R.relation_4_4

lemma functor_map_well_defined {X Y}: ∀ (f g: X ⟶ᵐ Y), f ≈ g → functor_map V R f = functor_map V R g := begin
  intros f g r, induction r,
  { refl, },
  { rw r_ih, },
  { rw [r_ih_ᾰ, r_ih_ᾰ_1], },
  { simp only [functor_map, r_ih_ᾰ, r_ih_ᾰ_1], },
  { simp only [functor_map, category.id_comp'], },
  { simp only [functor_map, category.comp_id'], },
  { simp only [functor_map, category.assoc'], },
  { simp only [functor_map, r_ih_ᾰ, r_ih_ᾰ_1], },
  { simp only [functor_map, monoidal_category.tensor_id'], refl, },
  { simp only [functor_map, monoidal_category.tensor_comp'], },
  { simp only [functor_map, (α_ _ _ _).hom_inv_id'], refl, },
  { simp only [functor_map, (α_ _ _ _).inv_hom_id'], refl, },
  { simp only [functor_map, monoidal_category.associator_naturality'], },
  { simp only [functor_map, (λ_ _).hom_inv_id'], refl, },
  { simp only [functor_map, (λ_ _).inv_hom_id'], },
  { simp only [functor_map, monoidal_category.left_unitor_naturality'], dsimp at *, simp at *, },
  { simp only [functor_map, (ρ_ _).hom_inv_id'], refl, },
  { simp only [functor_map, (ρ_ _).inv_hom_id'], },
  { simp only [functor_map, monoidal_category.right_unitor_naturality'], dsimp at *, simp at *, },
  { dsimp [functor_map], rw monoidal_category.pentagon', },
  { simp only [functor_map, monoidal_category.triangle'], dsimp at *, simp at *, },
  exact aux.functor_map_well_defined_1_1 V R,
  exact aux.functor_map_well_defined_1_2 V R,
  exact aux.functor_map_well_defined_2_1 V R,
  exact aux.functor_map_well_defined_2_2 V R,
  exact aux.functor_map_well_defined_3_1 V R,
  exact aux.functor_map_well_defined_3_2 V R,
  exact aux.functor_map_well_defined_4_1 V R,
  exact aux.functor_map_well_defined_4_2 V R,
  exact aux.functor_map_well_defined_5 V R,
  exact aux.functor_map_well_defined_6_1 V R,
  exact aux.functor_map_well_defined_6_2 V R,
  exact aux.functor_map_well_defined_7_1 V R,
  exact aux.functor_map_well_defined_7_2 V R,
  exact aux.functor_map_well_defined_8_1 V R,
  exact aux.functor_map_well_defined_8_2 V R,
end

end aux

@[simp] def functor (R: enhanced_R_matrix C V): Tangle ⥤ C := {
  obj := functor_obj V,
  map := λ X Y f, quotient.lift_on' f (functor_map V R) (aux.functor_map_well_defined V R)
}

end enhanced_R_matrix
end kassel


example (p q r : Prop) (hp : p) (hq : q) (hr : r) : p ∧ q ∧ r :=
begin
  split,
  all_goals { try { split } },
  all_goals { assumption }
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.Mon_
import Mathlib.PostPort

universes v₁ u₁ l

namespace Mathlib

/-!
# The category of module objects over a monoid object.
-/

/-- A module object for a monoid object, all internal to some monoidal category. -/
structure Mod {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C]
    (A : Mon_ C)
    where
  X : C
  act : Mon_.X A ⊗ X ⟶ X
  one_act' :
    autoParam ((Mon_.one A ⊗ 𝟙) ≫ act = category_theory.iso.hom λ_)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  assoc' :
    autoParam ((Mon_.mul A ⊗ 𝟙) ≫ act = category_theory.iso.hom α_ ≫ (𝟙 ⊗ act) ≫ act)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem Mod.one_act {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} (c : Mod A) :
    (Mon_.one A ⊗ 𝟙) ≫ Mod.act c = category_theory.iso.hom λ_ :=
  sorry

@[simp] theorem Mod.assoc {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} (c : Mod A) :
    (Mon_.mul A ⊗ 𝟙) ≫ Mod.act c = category_theory.iso.hom α_ ≫ (𝟙 ⊗ Mod.act c) ≫ Mod.act c :=
  sorry

@[simp] theorem Mod.one_act_assoc {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} (c : Mod A) {X' : C} (f' : Mod.X c ⟶ X') :
    (Mon_.one A ⊗ 𝟙) ≫ Mod.act c ≫ f' = category_theory.iso.hom λ_ ≫ f' :=
  sorry

namespace Mod

theorem assoc_flip {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C]
    {A : Mon_ C} (M : Mod A) :
    (𝟙 ⊗ act M) ≫ act M = category_theory.iso.inv α_ ≫ (Mon_.mul A ⊗ 𝟙) ≫ act M :=
  sorry

/-- A morphism of module objects. -/
structure hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C]
    {A : Mon_ C} (M : Mod A) (N : Mod A)
    where
  hom : X M ⟶ X N
  act_hom' :
    autoParam (act M ≫ hom = (𝟙 ⊗ hom) ≫ act N)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem hom.act_hom {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} {M : Mod A} {N : Mod A} (c : hom M N) :
    act M ≫ hom.hom c = (𝟙 ⊗ hom.hom c) ≫ act N :=
  sorry

@[simp] theorem hom.act_hom_assoc {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} {M : Mod A} {N : Mod A} (c : hom M N)
    {X' : C} (f' : X N ⟶ X') : act M ≫ hom.hom c ≫ f' = (𝟙 ⊗ hom.hom c) ≫ act N ≫ f' :=
  sorry

/-- The identity morphism on a module object. -/
def id {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C}
    (M : Mod A) : hom M M :=
  hom.mk 𝟙

protected instance hom_inhabited {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} (M : Mod A) : Inhabited (hom M M) :=
  { default := id M }

/-- Composition of module object morphisms. -/
def comp {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C]
    {A : Mon_ C} {M : Mod A} {N : Mod A} {O : Mod A} (f : hom M N) (g : hom N O) : hom M O :=
  hom.mk (hom.hom f ≫ hom.hom g)

protected instance category_theory.category {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} : category_theory.category (Mod A) :=
  category_theory.category.mk

@[simp] theorem id_hom' {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} (M : Mod A) : hom.hom 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_hom' {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} {M : Mod A} {N : Mod A} {K : Mod A}
    (f : M ⟶ N) (g : N ⟶ K) : hom.hom (f ≫ g) = hom.hom f ≫ hom.hom g :=
  rfl

/-- A monoid object as a module over itself. -/
@[simp] theorem regular_X {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] (A : Mon_ C) : X (regular A) = Mon_.X A :=
  Eq.refl (X (regular A))

protected instance inhabited {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] (A : Mon_ C) : Inhabited (Mod A) :=
  { default := regular A }

/-- The forgetful functor from module objects to the ambient category. -/
def forget {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C]
    (A : Mon_ C) : Mod A ⥤ C :=
  category_theory.functor.mk (fun (A_1 : Mod A) => X A_1)
    fun (A_1 B : Mod A) (f : A_1 ⟶ B) => hom.hom f

/--
A morphism of monoid objects induces a "restriction" or "comap" functor
between the categories of module objects.
-/
@[simp] theorem comap_obj_act {C : Type u₁} [category_theory.category C]
    [category_theory.monoidal_category C] {A : Mon_ C} {B : Mon_ C} (f : A ⟶ B) (M : Mod B) :
    act (category_theory.functor.obj (comap f) M) = (Mon_.hom.hom f ⊗ 𝟙) ≫ act M :=
  Eq.refl (act (category_theory.functor.obj (comap f) M))

end Mathlib


-- import category_theory.opposites
-- import category_theory.full_subcategory
-- import category_theory.limits.types
-- import topology.Top.basic
-- import category_theory.limits.obviously

-- open category_theory
-- open category_theory.limits
-- open topological_space

-- universes u v u₁ v₁ u₂ v₂

-- variable (X : Top.{v})

-- local attribute [back] topological_space.is_open_inter
-- -- local attribute [back] opens.property

-- instance has_inter_open_set : has_inter (opens X) :=
-- { inter := λ U V, ⟨ U.val ∩ V.val, by obviously ⟩ }

-- instance has_inter_open_set_op : has_inter ((opens X)ᵒᵖ) := sorry -- has_inter_open_set X

-- -- def cover_intersections_index (I : Type v) : grothendieck_category (ParallelPair_functor (@prod.fst I I) (@prod.snd I I))
-- -- def cover_intersections (c : cover X) : (cover_intersections_index c.I) ⥤ open_set X :=
-- -- { obj := λ p, match p.1 with
-- --   | _1 := c.U p.2.1 ∩ c.U p.2.2
-- --   | _2 := c.U p.2
-- --   end,
-- --   map := λ p q f, sorry
-- -- }

-- -- @[tidy] meta def sbe := `[solve_by_elim [sum.inl, sum.inr, ulift.up, plift.up, trivial] {max_rep := 5}]

-- -- instance (I : Type v) : category (I × I ⊕ I) :=
-- -- { hom := λ X Y, match (X, Y) with
-- --   | (sum.inl (i, j), sum.inr k) := ulift (plift (i = k)) ⊕ ulift (plift (j = k))
-- --   | (sum.inl (i, j), sum.inl (i', j')) := ulift (plift (i = i' ∧ j = j'))
-- --   | (sum.inr k, sum.inr k') := ulift (plift (k = k'))
-- --   | (sum.inr k, sum.inl (i, j)) := pempty
-- --   end,
-- --   id := by tidy,
-- --   comp := by tidy,
-- -- }

-- structure cover :=
-- (I : Type v)
-- (U : I → (opens X))

-- variables {X}

-- def cover.union (c : cover X) : opens X :=
-- ⟨ set.Union (λ i : c.I, (c.U i).1),
--   begin
--   apply topological_space.is_open_sUnion,
--   tidy,
--   subst H_h,
--   exact (c.U H_w).2
--   end ⟩

-- def cover.sub (c : cover X) (i : c.I) : c.U i ⟶ c.union := sorry

-- definition cover.left (c : cover X) (i j : c.I) : (c.U i ∩ c.U j) ⟶ (c.U i) := by obviously
-- definition cover.right (c : cover X) (i j : c.I) : (c.U i ∩ c.U j) ⟶ (c.U j) := by obviously

-- section
-- variables {D : Type u₂} [𝒟 : category.{u₂ v₂} D]
-- variables {c : cover X} (i j : c.I) (F : (opens X)ᵒᵖ ⥤ D)
-- include 𝒟

-- definition res_left : (F.obj (c.U i)) ⟶ (F.obj ((c.U i) ∩ (c.U j))) :=
-- F.map (c.left i j)

-- definition res_right :=
-- F.map (c.right i j)

-- definition res_union : (F.obj (c.union)) ⟶ (F.obj ((c.U i))) :=
-- F.map (c.sub i)

-- @[simp] lemma res_left_right : res_union i F ≫ res_left i j F = res_union j F ≫ res_right i j F :=
-- begin
--   dsimp [res_union, res_left, res_right],
--   rw ← functor.map_comp,
--   rw ← functor.map_comp,
--   refl,
-- end
-- end

-- section
-- variables {V : Type u} [𝒱 : category.{u v} V] [has_products.{u v} V]
-- include 𝒱

-- variables (c : cover X) (F : (opens X)ᵒᵖ ⥤ V)

-- def sections : V :=
-- limits.pi.{u v} (λ i : c.I, F.obj (c.U i))

-- def overlaps : V :=
-- limits.pi.{u v} (λ p : c.I × c.I, F.obj (c.U p.1 ∩ c.U p.2))

-- def left : (sections c F) ⟶ (overlaps c F) :=
-- pi.pre _ (λ p : c.I × c.I, p.1) ≫ pi.map (λ p, res_left p.1 p.2 F)

-- def right : (sections c F) ⟶ (overlaps c F) :=
-- pi.pre _ (λ p : c.I × c.I, p.2) ≫ pi.map (λ p, res_right p.1 p.2 F)

-- def res : F.obj (c.union) ⟶ (sections c F) :=
-- pi.lift (λ i, res_union i F)

-- @[simp] lemma res_left_right' : res c F ≫ left c F = res c F ≫ right c F :=
-- begin
--   dsimp [left, right, res],
--   rw ← category.assoc,
--   simp,
--   rw ← category.assoc,
--   simp,
-- end

-- def cover_fork : fork (left c F) (right c F) :=
-- fork.of_ι (res c F) (by tidy)

-- class is_sheaf (presheaf : (opens X)ᵒᵖ ⥤ V) :=
-- (sheaf_condition : Π (c : cover X), is_equalizer (cover_fork c presheaf))

-- variables (X V)

-- structure sheaf  :=
-- (presheaf : (opens X)ᵒᵖ ⥤ V)
-- (sheaf_condition : is_sheaf presheaf)

-- end


import for_mathlib.short_complex_projections
import for_mathlib.homology_map_datum

noncomputable theory

open category_theory category_theory.category category_theory.limits
open_locale zero_object

variables {J C : Type*} [category J] [category C] [has_zero_morphisms C]

namespace short_complex

namespace functor_category_equivalence

instance evaluation_preserves_zero_morphisms
  (j : J) : ((evaluation J C).obj j).preserves_zero_morphisms := ⟨λ F G, rfl⟩

/- deterministic timeouts may occur if we add @[simps] attributes --/

def functor : short_complex (J ⥤ C) ⥤ J ⥤ short_complex C :=
functor.flip
{ obj := λ j, functor.map_short_complex ((evaluation J C).obj j),
  map := λ i j f, nat_trans.map_short_complex ((evaluation J C).map f), }

@[simps]
def inverse.obj (F : (J ⥤ short_complex C)) : short_complex (J ⥤ C) :=
mk ((𝟙 F) ◫ φ₁₂) ((𝟙 F) ◫ φ₂₃) begin
  ext,
  simp only [nat_trans.comp_app, nat_trans.hcomp_app, φ₁₂_app, nat_trans.id_app,
    π₂_map, φ₂₃_app, π₃_map, assoc, zero_app],
  erw [id_comp, comp_id],
  apply short_complex.zero,
end

@[simps]
def inverse.map {F G : (J ⥤ short_complex C)} (φ : F ⟶ G) : inverse.obj F ⟶ inverse.obj G :=
begin
  refine ⟨φ ◫ 𝟙 _, φ ◫ 𝟙 _, φ ◫ 𝟙 _, _, _⟩;
  ext; dsimp; erw [comp_id, id_comp, id_comp, comp_id],
  exacts [(φ.app x).comm₁₂, (φ.app x).comm₂₃],
end

def inverse : (J ⥤ short_complex C) ⥤ short_complex (J ⥤ C) :=
{ obj := inverse.obj,
  map := λ F G, inverse.map,
  map_id' := λ F, by { ext; apply comp_id, },
  map_comp' := λ F₁ F₂ F₃ φ ψ, by { ext; dsimp; erw [id_comp, id_comp, id_comp], }, }

def unit_iso.obj (S : short_complex (J ⥤ C)) : S ≅ (functor ⋙ inverse).obj S :=
begin
  refine iso_mk _ _ _ _ _;
  try { refine nat_iso.of_components (λ X, iso.refl _) _,
    intros i j f, dsimp, erw [comp_id, id_comp], refl, },
  all_goals { ext, dsimp [functor, inverse], erw [comp_id, id_comp], },
end

def unit_iso : 𝟭 (short_complex (J ⥤ C)) ≅
  functor_category_equivalence.functor ⋙ functor_category_equivalence.inverse :=
nat_iso.of_components unit_iso.obj
(λ S₁ S₂ ψ, begin
  ext;
  dsimp [iso_mk, nat_iso.of_components, iso_mk, functor, inverse, unit_iso.obj];
  erw [comp_id, id_comp, id_comp],
end)

def counit_iso.obj (F : J ⥤ short_complex C) : (inverse ⋙ functor).obj F ≅ F :=
nat_iso.of_components
(λ j, begin
  refine iso_mk (iso.refl _) (iso.refl _) (iso.refl _) _ _,
  all_goals { dsimp [functor, inverse], erw [id_comp, comp_id, comp_id], },
end)
(λ i j f, by { ext; dsimp; erw [comp_id, id_comp]; refl, })

def counit_iso : functor_category_equivalence.inverse ⋙
  functor_category_equivalence.functor ≅ 𝟭 (J ⥤ short_complex C) :=
nat_iso.of_components counit_iso.obj
(λ F₁ F₂ φ, by { ext; dsimp [functor, inverse, counit_iso.obj]; erw [id_comp, comp_id], })

lemma functor_unit_iso_comp (F : short_complex (J ⥤ C)) :
  functor_category_equivalence.functor.map (functor_category_equivalence.unit_iso.hom.app F) ≫
  functor_category_equivalence.counit_iso.hom.app (functor_category_equivalence.functor.obj F) =
  𝟙 _ :=
begin
  dsimp [functor_category_equivalence.functor, functor_category_equivalence.unit_iso,
    functor_category_equivalence.inverse, functor_category_equivalence.counit_iso,
    evaluation, functor.flip, functor.map_short_complex,
    functor_category_equivalence.counit_iso.obj,
    functor_category_equivalence.unit_iso.obj,
    nat_iso.of_components],
  ext;
  apply id_comp,
end

end functor_category_equivalence

@[simps]
def functor_category_equivalence : short_complex (J ⥤ C) ≌ J ⥤ short_complex C :=
{ functor := functor_category_equivalence.functor,
  inverse := functor_category_equivalence.inverse,
  unit_iso := functor_category_equivalence.unit_iso,
  counit_iso := functor_category_equivalence.counit_iso,
  functor_unit_iso_comp' := functor_category_equivalence.functor_unit_iso_comp, }

@[simps]
def functor_lift {X Y Z : J ⥤ C} (f : X ⟶ Y) (g : Y ⟶ Z) (h : f ≫ g = 0) :
  J ⥤ short_complex C :=
functor_category_equivalence.functor.obj (mk f g h)

@[simps]
def ι_middle [has_zero_object C] : C ⥤ short_complex C :=
functor_lift (0 : 0 ⟶ 𝟭 C) (0 : 𝟭 C ⟶ 0) zero_comp

def ι_middle_homology_nat_iso {A : Type*} [category A] [abelian A] :
  𝟭 A ≅ ι_middle ⋙ homology_functor :=
nat_iso.of_components
(λ X, (homology_iso_datum.of_both_zeros _ _ rfl rfl).iso)
(λ X Y f, begin
  erw (homology_map_datum.of_both_are_zeros (ι_middle.map f) rfl rfl rfl rfl).homology_map_eq,
  erw iso.hom_inv_id_assoc,
  refl,
end)

lemma ι_middle_π₁_is_zero [has_zero_object C] :
  is_zero ((ι_middle : C ⥤ _ ) ⋙ short_complex.π₁) :=
begin
  rw functor.is_zero_iff,
  intro X,
  dsimp,
  simp only [functor.zero_obj],
end

lemma ι_middle_π₃_is_zero [has_zero_object C] :
  is_zero ((ι_middle : C ⥤ _ ) ⋙ short_complex.π₃) :=
begin
  rw functor.is_zero_iff,
  intro X,
  dsimp,
  simp only [functor.zero_obj],
end

@[simps]
def nat_trans_hom_mk {S₁ S₂ : J ⥤ short_complex C} (τ₁ : S₁ ⋙ π₁ ⟶ S₂ ⋙ π₁)
  (τ₂ : S₁ ⋙ π₂ ⟶ S₂ ⋙ π₂) (τ₃ : S₁ ⋙ π₃ ⟶ S₂ ⋙ π₃)
  (comm₁₂ : (𝟙 S₁) ◫ φ₁₂ ≫ τ₂ = τ₁ ≫ (𝟙 S₂) ◫ φ₁₂)
  (comm₂₃ : (𝟙 S₁) ◫ φ₂₃ ≫ τ₃ = τ₂ ≫ (𝟙 S₂) ◫ φ₂₃) :
  S₁ ⟶ S₂ :=
functor_category_equivalence.counit_iso.inv.app S₁ ≫
  functor_category_equivalence.functor.map (hom_mk τ₁ τ₂ τ₃ comm₁₂ comm₂₃) ≫
  functor_category_equivalence.counit_iso.hom.app S₂

lemma nat_trans_hom_mk_app_τ₂_eq {S₁ S₂ : J ⥤ short_complex C} (τ₁ : S₁ ⋙ π₁ ⟶ S₂ ⋙ π₁)
  (τ₂ : S₁ ⋙ π₂ ⟶ S₂ ⋙ π₂) (τ₃ : S₁ ⋙ π₃ ⟶ S₂ ⋙ π₃)
  (comm₁₂ : (𝟙 S₁) ◫ φ₁₂ ≫ τ₂ = τ₁ ≫ (𝟙 S₂) ◫ φ₁₂)
  (comm₂₃ : (𝟙 S₁) ◫ φ₂₃ ≫ τ₃ = τ₂ ≫ (𝟙 S₂) ◫ φ₂₃) (j : J) :
  ((nat_trans_hom_mk τ₁ τ₂ τ₃ comm₁₂ comm₂₃).app j).τ₂ = τ₂.app j :=
begin
  dsimp [functor_category_equivalence.counit_iso,
    functor_category_equivalence.counit_iso.obj, iso.refl],
  erw [id_comp, comp_id],
  refl,
end

@[simp, reassoc]
def nat_trans_hom_mk_comp {S₁ S₂ S₃ : J ⥤ short_complex C} (τ₁ : S₁ ⋙ π₁ ⟶ S₂ ⋙ π₁)
  (τ₂ : S₁ ⋙ π₂ ⟶ S₂ ⋙ π₂) (τ₃ : S₁ ⋙ π₃ ⟶ S₂ ⋙ π₃)
  (comm₁₂ : (𝟙 S₁) ◫ φ₁₂ ≫ τ₂ = τ₁ ≫ (𝟙 S₂) ◫ φ₁₂)
  (comm₂₃ : (𝟙 S₁) ◫ φ₂₃ ≫ τ₃ = τ₂ ≫ (𝟙 S₂) ◫ φ₂₃)
  (τ₁' : S₂ ⋙ π₁ ⟶ S₃ ⋙ π₁)
  (τ₂' : S₂ ⋙ π₂ ⟶ S₃ ⋙ π₂) (τ₃' : S₂ ⋙ π₃ ⟶ S₃ ⋙ π₃)
  (comm₁₂' : (𝟙 S₂) ◫ φ₁₂ ≫ τ₂' = τ₁' ≫ (𝟙 S₃) ◫ φ₁₂)
  (comm₂₃' : (𝟙 S₂) ◫ φ₂₃ ≫ τ₃' = τ₂' ≫ (𝟙 S₃) ◫ φ₂₃) :
  nat_trans_hom_mk τ₁ τ₂ τ₃ comm₁₂ comm₂₃ ≫
    nat_trans_hom_mk τ₁' τ₂' τ₃' comm₁₂' comm₂₃' =
    nat_trans_hom_mk (τ₁ ≫ τ₁') (τ₂ ≫ τ₂') (τ₃ ≫ τ₃')
    (by rw [← assoc, comm₁₂, assoc, comm₁₂', assoc])
    (by rw [← assoc, comm₂₃, assoc, comm₂₃', assoc]) :=
begin
  ext,
  all_goals
  { dsimp [functor_category_equivalence.counit_iso, nat_iso.of_components,
      functor_category_equivalence.counit_iso.obj,
      functor_category_equivalence.functor],
    erw [id_comp, id_comp, id_comp, comp_id, comp_id, comp_id], },
end

@[simp]
def nat_trans_hom_mk_id (S : J ⥤ short_complex C) :
  nat_trans_hom_mk (𝟙 (S ⋙ π₁)) (𝟙 (S ⋙ π₂)) (𝟙 (S ⋙ π₃))
  (by simp only [id_comp, comp_id]) (by simp only [id_comp, comp_id]) = 𝟙 S :=
begin
  ext,
  all_goals
  { dsimp [functor_category_equivalence.counit_iso, nat_iso.of_components,
      functor_category_equivalence.counit_iso.obj,
      functor_category_equivalence.functor],
    erw [id_comp, comp_id],
    refl, },
end

@[simps]
def functor_nat_iso_mk {S₁ S₂ : J ⥤ short_complex C} (τ₁ : S₁ ⋙ π₁ ≅ S₂ ⋙ π₁)
  (τ₂ : S₁ ⋙ π₂ ≅ S₂ ⋙ π₂) (τ₃ : S₁ ⋙ π₃ ≅ S₂ ⋙ π₃)
  (comm₁₂ : (𝟙 S₁) ◫ φ₁₂ ≫ τ₂.hom = τ₁.hom ≫ (𝟙 S₂) ◫ φ₁₂)
  (comm₂₃ : (𝟙 S₁) ◫ φ₂₃ ≫ τ₃.hom = τ₂.hom ≫ (𝟙 S₂) ◫ φ₂₃) :
  S₁ ≅ S₂ :=
begin
  have comm₁₂' : 𝟙 S₂ ◫ φ₁₂ ≫ τ₂.inv = τ₁.inv ≫ 𝟙 S₁ ◫ φ₁₂,
  { simpa only [← cancel_epi τ₁.hom, ← cancel_mono τ₂.hom, assoc, τ₂.inv_hom_id, comp_id,
      τ₁.hom_inv_id_assoc] using comm₁₂.symm, },
  have comm₂₃' : 𝟙 S₂ ◫ φ₂₃ ≫ τ₃.inv = τ₂.inv ≫ 𝟙 S₁ ◫ φ₂₃,
  { simpa only [← cancel_epi τ₂.hom, ← cancel_mono τ₃.hom, assoc, τ₃.inv_hom_id, comp_id,
      τ₂.hom_inv_id_assoc] using comm₂₃.symm, },
  exact
  { hom := nat_trans_hom_mk τ₁.hom τ₂.hom τ₃.hom comm₁₂ comm₂₃,
    inv := nat_trans_hom_mk τ₁.inv τ₂.inv τ₃.inv comm₁₂' comm₂₃',
    hom_inv_id' := by simp only [nat_trans_hom_mk_comp, iso.hom_inv_id, nat_trans_hom_mk_id],
    inv_hom_id' := by simp only [nat_trans_hom_mk_comp, iso.inv_hom_id, nat_trans_hom_mk_id], },
end

end short_complex


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fintype.basic
import Mathlib.category_theory.fin_category
import Mathlib.category_theory.limits.shapes.products
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.pullbacks
import Mathlib.PostPort

universes v u u_1

namespace Mathlib

/-!
# Categories with finite limits.

A typeclass for categories with all finite (co)limits.
-/

namespace category_theory.limits

/--
A category has all finite limits if every functor `J ⥤ C` with a `fin_category J` instance
has a limit.

This is often called 'finitely complete'.
-/
-- We can't just made this an `abbreviation`

-- because of https://github.com/leanprover-community/lean/issues/429

def has_finite_limits (C : Type u) [category C] :=
  ∀ (J : Type v) [𝒥 : small_category J] [_inst_2 : fin_category J], has_limits_of_shape J C

protected instance has_limits_of_shape_of_has_finite_limits (C : Type u) [category C] (J : Type v) [small_category J] [fin_category J] [has_finite_limits C] : has_limits_of_shape J C :=
  _inst_4 J

/-- If `C` has all limits, it has finite limits. -/
theorem has_finite_limits_of_has_limits (C : Type u) [category C] [has_limits C] : has_finite_limits C :=
  fun (J : Type v) (𝒥₁ : small_category J) (𝒥₂ : fin_category J) => limits.has_limits_of_shape_of_has_limits

/--
A category has all finite colimits if every functor `J ⥤ C` with a `fin_category J` instance
has a colimit.

This is often called 'finitely cocomplete'.
-/
def has_finite_colimits (C : Type u) [category C] :=
  ∀ (J : Type v) [𝒥 : small_category J] [_inst_2 : fin_category J], has_colimits_of_shape J C

protected instance has_colimits_of_shape_of_has_finite_colimits (C : Type u) [category C] (J : Type v) [small_category J] [fin_category J] [has_finite_colimits C] : has_colimits_of_shape J C :=
  _inst_4 J

/-- If `C` has all colimits, it has finite colimits. -/
theorem has_finite_colimits_of_has_colimits (C : Type u) [category C] [has_colimits C] : has_finite_colimits C :=
  fun (J : Type v) (𝒥₁ : small_category J) (𝒥₂ : fin_category J) => limits.has_colimits_of_shape_of_has_colimits

protected instance fintype_walking_parallel_pair : fintype walking_parallel_pair :=
  fintype.mk (list.to_finset [walking_parallel_pair.zero, walking_parallel_pair.one]) sorry

protected instance walking_parallel_pair_hom.fintype (j : walking_parallel_pair) (j' : walking_parallel_pair) : fintype (walking_parallel_pair_hom j j') :=
  fintype.mk
    (walking_parallel_pair.rec_on j
      (walking_parallel_pair.rec_on j' (list.to_finset [walking_parallel_pair_hom.id walking_parallel_pair.zero])
        (list.to_finset [walking_parallel_pair_hom.left, walking_parallel_pair_hom.right]))
      (walking_parallel_pair.rec_on j' ∅ (list.to_finset [walking_parallel_pair_hom.id walking_parallel_pair.one])))
    sorry

protected instance walking_parallel_pair.category_theory.fin_category : fin_category walking_parallel_pair :=
  fin_category.mk

/-- Equalizers are finite limits, so if `C` has all finite limits, it also has all equalizers -/
/-- Coequalizers are finite colimits, of if `C` has all finite colimits, it also has all
    coequalizers -/
namespace wide_pullback_shape

protected instance fintype_obj {J : Type v} [fintype J] : fintype (wide_pullback_shape J) :=
  eq.mpr sorry option.fintype

protected instance fintype_hom {J : Type v} [DecidableEq J] (j : wide_pullback_shape J) (j' : wide_pullback_shape J) : fintype (j ⟶ j') :=
  fintype.mk
    (option.cases_on j' (option.cases_on j (singleton (hom.id none)) fun (j : J) => singleton (hom.term j))
      fun (j' : J) =>
        dite (some j' = j) (fun (h : some j' = j) => eq.mpr sorry (singleton (hom.id j))) fun (h : ¬some j' = j) => ∅)
    sorry

end wide_pullback_shape

namespace wide_pushout_shape

protected instance fintype_obj {J : Type v} [fintype J] : fintype (wide_pushout_shape J) :=
  eq.mpr sorry option.fintype

protected instance fintype_hom {J : Type v} [DecidableEq J] (j : wide_pushout_shape J) (j' : wide_pushout_shape J) : fintype (j ⟶ j') :=
  fintype.mk
    (option.cases_on j (option.cases_on j' (singleton (hom.id none)) fun (j' : J) => singleton (hom.init j'))
      fun (j : J) =>
        dite (some j = j') (fun (h : some j = j') => eq.mpr sorry (singleton (hom.id j'))) fun (h : ¬some j = j') => ∅)
    sorry

end wide_pushout_shape

protected instance fin_category_wide_pullback {J : Type v} [DecidableEq J] [fintype J] : fin_category (wide_pullback_shape J) :=
  fin_category.mk

protected instance fin_category_wide_pushout {J : Type v} [DecidableEq J] [fintype J] : fin_category (wide_pushout_shape J) :=
  fin_category.mk

/--
`has_finite_wide_pullbacks` represents a choice of wide pullback
for every finite collection of morphisms
-/
-- We can't just made this an `abbreviation`

-- because of https://github.com/leanprover-community/lean/issues/429

def has_finite_wide_pullbacks (C : Type u) [category C] :=
  ∀ (J : Type v) [_inst_2 : DecidableEq J] [_inst_3 : fintype J], has_limits_of_shape (wide_pullback_shape J) C

protected instance has_limits_of_shape_wide_pullback_shape (C : Type u) [category C] (J : Type v) [fintype J] [has_finite_wide_pullbacks C] : has_limits_of_shape (wide_pullback_shape J) C :=
  _inst_3 J

/--
`has_finite_wide_pushouts` represents a choice of wide pushout
for every finite collection of morphisms
-/
def has_finite_wide_pushouts (C : Type u) [category C] :=
  ∀ (J : Type v) [_inst_2 : DecidableEq J] [_inst_3 : fintype J], has_colimits_of_shape (wide_pushout_shape J) C

protected instance has_colimits_of_shape_wide_pushout_shape (C : Type u) [category C] (J : Type v) [fintype J] [has_finite_wide_pushouts C] : has_colimits_of_shape (wide_pushout_shape J) C :=
  _inst_3 J

/--
Finite wide pullbacks are finite limits, so if `C` has all finite limits,
it also has finite wide pullbacks
-/
theorem has_finite_wide_pullbacks_of_has_finite_limits (C : Type u) [category C] [has_finite_limits C] : has_finite_wide_pullbacks C :=
  fun (J : Type v) (_x : DecidableEq J) (_x_1 : fintype J) =>
    limits.has_limits_of_shape_of_has_finite_limits C (wide_pullback_shape J)

/--
Finite wide pushouts are finite colimits, so if `C` has all finite colimits,
it also has finite wide pushouts
-/
theorem has_finite_wide_pushouts_of_has_finite_limits (C : Type u) [category C] [has_finite_colimits C] : has_finite_wide_pushouts C :=
  fun (J : Type v) (_x : DecidableEq J) (_x_1 : fintype J) =>
    limits.has_colimits_of_shape_of_has_finite_colimits C (wide_pushout_shape J)

protected instance fintype_walking_pair : fintype walking_pair :=
  fintype.mk (insert walking_pair.left (singleton walking_pair.right)) sorry


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.coherence_lemmas
import category_theory.monoidal.natural_transformation
import category_theory.monoidal.discrete

/-!
# Braided and symmetric monoidal categories

The basic definitions of braided monoidal categories, and symmetric monoidal categories,
as well as braided functors.

## Implementation note

We make `braided_monoidal_category` another typeclass, but then have `symmetric_monoidal_category`
extend this. The rationale is that we are not carrying any additional data,
just requiring a property.

## Future work

* Construct the Drinfeld center of a monoidal category as a braided monoidal category.
* Say something about pseudo-natural transformations.

-/

open category_theory

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

namespace category_theory

/--
A braided monoidal category is a monoidal category equipped with a braiding isomorphism
`β_ X Y : X ⊗ Y ≅ Y ⊗ X`
which is natural in both arguments,
and also satisfies the two hexagon identities.
-/
class braided_category (C : Type u) [category.{v} C] [monoidal_category.{v} C] :=
-- braiding natural iso:
(braiding             : Π X Y : C, X ⊗ Y ≅ Y ⊗ X)
(braiding_naturality' : ∀ {X X' Y Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y'),
  (f ⊗ g) ≫ (braiding Y Y').hom = (braiding X X').hom ≫ (g ⊗ f) . obviously)
-- hexagon identities:
(hexagon_forward'     : Π X Y Z : C,
    (α_ X Y Z).hom ≫ (braiding X (Y ⊗ Z)).hom ≫ (α_ Y Z X).hom
  = ((braiding X Y).hom ⊗ (𝟙 Z)) ≫ (α_ Y X Z).hom ≫ ((𝟙 Y) ⊗ (braiding X Z).hom)
  . obviously)
(hexagon_reverse'     : Π X Y Z : C,
    (α_ X Y Z).inv ≫ (braiding (X ⊗ Y) Z).hom ≫ (α_ Z X Y).inv
  = ((𝟙 X) ⊗ (braiding Y Z).hom) ≫ (α_ X Z Y).inv ≫ ((braiding X Z).hom ⊗ (𝟙 Y))
  . obviously)

restate_axiom braided_category.braiding_naturality'
attribute [simp,reassoc] braided_category.braiding_naturality
restate_axiom braided_category.hexagon_forward'
restate_axiom braided_category.hexagon_reverse'
attribute [reassoc] braided_category.hexagon_forward braided_category.hexagon_reverse

open category
open monoidal_category
open braided_category

notation `β_` := braiding

/--
Verifying the axioms for a braiding by checking that the candidate braiding is sent to a braiding
by a faithful monoidal functor.
-/
def braided_category_of_faithful {C D : Type*} [category C] [category D]
  [monoidal_category C] [monoidal_category D] (F : monoidal_functor C D) [faithful F.to_functor]
  [braided_category D] (β : Π X Y : C, X ⊗ Y ≅ Y ⊗ X)
  (w : ∀ X Y, F.μ _ _ ≫ F.map (β X Y).hom = (β_ _ _).hom ≫ F.μ _ _) : braided_category C :=
{ braiding := β,
  braiding_naturality' := begin
    intros,
    apply F.to_functor.map_injective,
    refine (cancel_epi (F.μ _ _)).1 _,
    rw [functor.map_comp, ←lax_monoidal_functor.μ_natural_assoc, w, functor.map_comp, reassoc_of w,
      braiding_naturality_assoc, lax_monoidal_functor.μ_natural],
  end,
  hexagon_forward' := begin
    intros,
    apply F.to_functor.map_injective,
    refine (cancel_epi (F.μ _ _)).1 _,
    refine (cancel_epi (F.μ _ _ ⊗ 𝟙 _)).1 _,
    rw [functor.map_comp, functor.map_comp, functor.map_comp, functor.map_comp,
      ←lax_monoidal_functor.μ_natural_assoc, functor.map_id, ←comp_tensor_id_assoc, w,
      comp_tensor_id, category.assoc, lax_monoidal_functor.associativity_assoc,
      lax_monoidal_functor.associativity_assoc, ←lax_monoidal_functor.μ_natural, functor.map_id,
      ←id_tensor_comp_assoc, w, id_tensor_comp_assoc, reassoc_of w, braiding_naturality_assoc,
      lax_monoidal_functor.associativity, hexagon_forward_assoc],
  end,
  hexagon_reverse' := begin
    intros,
    apply F.to_functor.map_injective,
    refine (cancel_epi (F.μ _ _)).1 _,
    refine (cancel_epi (𝟙 _ ⊗ F.μ _ _)).1 _,
    rw [functor.map_comp, functor.map_comp, functor.map_comp, functor.map_comp,
      ←lax_monoidal_functor.μ_natural_assoc, functor.map_id, ←id_tensor_comp_assoc, w,
      id_tensor_comp_assoc, lax_monoidal_functor.associativity_inv_assoc,
      lax_monoidal_functor.associativity_inv_assoc, ←lax_monoidal_functor.μ_natural, functor.map_id,
      ←comp_tensor_id_assoc, w, comp_tensor_id_assoc, reassoc_of w, braiding_naturality_assoc,
      lax_monoidal_functor.associativity_inv, hexagon_reverse_assoc],
  end, }

/-- Pull back a braiding along a fully faithful monoidal functor. -/
noncomputable
def braided_category_of_fully_faithful {C D : Type*} [category C] [category D]
  [monoidal_category C] [monoidal_category D] (F : monoidal_functor C D)
  [full F.to_functor] [faithful F.to_functor]
  [braided_category D] : braided_category C :=
braided_category_of_faithful F (λ X Y, F.to_functor.preimage_iso
  ((as_iso (F.μ _ _)).symm ≪≫ β_ (F.obj X) (F.obj Y) ≪≫ (as_iso (F.μ _ _))))
  (by tidy)

section
/-!
We now establish how the braiding interacts with the unitors.

I couldn't find a detailed proof in print, but this is discussed in:

* Proposition 1 of André Joyal and Ross Street,
  "Braided monoidal categories", Macquarie Math Reports 860081 (1986).
* Proposition 2.1 of André Joyal and Ross Street,
  "Braided tensor categories" , Adv. Math. 102 (1993), 20–78.
* Exercise 8.1.6 of Etingof, Gelaki, Nikshych, Ostrik,
  "Tensor categories", vol 25, Mathematical Surveys and Monographs (2015), AMS.
-/

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

lemma braiding_left_unitor_aux₁ (X : C) :
  (α_ (𝟙_ C) (𝟙_ C) X).hom ≫ (𝟙 (𝟙_ C) ⊗ (β_ X (𝟙_ C)).inv) ≫ (α_ _ X _).inv ≫ ((λ_ X).hom ⊗ 𝟙 _) =
  ((λ_ _).hom ⊗ 𝟙 X) ≫ (β_ X (𝟙_ C)).inv :=
by { rw [←left_unitor_tensor, left_unitor_naturality], simp, }

lemma braiding_left_unitor_aux₂ (X : C) :
  ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C))) = (ρ_ X).hom ⊗ (𝟙 (𝟙_ C)) :=
calc ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
    = ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ (α_ _ _ _).hom ≫ (α_ _ _ _).inv ≫
        ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by coherence
... = ((β_ X (𝟙_ C)).hom ⊗ (𝟙 (𝟙_ C))) ≫ (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (β_ X _).hom) ≫
        (𝟙 _ ⊗ (β_ X _).inv) ≫ (α_ _ _ _).inv ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by { slice_rhs 3 4 { rw [←id_tensor_comp, iso.hom_inv_id, tensor_id], }, rw [id_comp], }
... = (α_ _ _ _).hom ≫ (β_ _ _).hom ≫
        (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (β_ X _).inv) ≫ (α_ _ _ _).inv ≫ ((λ_ X).hom ⊗ (𝟙 (𝟙_ C)))
         : by { slice_lhs 1 3 { rw ←hexagon_forward }, simp only [assoc], }
... = (α_ _ _ _).hom ≫ (β_ _ _).hom ≫ ((λ_ _).hom ⊗ 𝟙 X) ≫ (β_ X _).inv
         : by rw braiding_left_unitor_aux₁
... = (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (λ_ _).hom) ≫ (β_ _ _).hom ≫ (β_ X _).inv
         : by { slice_lhs 2 3 { rw [←braiding_naturality] }, simp only [assoc], }
... = (α_ _ _ _).hom ≫ (𝟙 _ ⊗ (λ_ _).hom)
         : by rw [iso.hom_inv_id, comp_id]
... = (ρ_ X).hom ⊗ (𝟙 (𝟙_ C))
         : by rw triangle

@[simp]
lemma braiding_left_unitor (X : C) : (β_ X (𝟙_ C)).hom ≫ (λ_ X).hom = (ρ_ X).hom :=
by rw [←tensor_right_iff, comp_tensor_id, braiding_left_unitor_aux₂]

lemma braiding_right_unitor_aux₁ (X : C) :
  (α_ X (𝟙_ C) (𝟙_ C)).inv ≫ ((β_ (𝟙_ C) X).inv ⊗ 𝟙 (𝟙_ C)) ≫ (α_ _ X _).hom ≫ (𝟙 _ ⊗ (ρ_ X).hom) =
  (𝟙 X ⊗ (ρ_ _).hom) ≫ (β_ (𝟙_ C) X).inv :=
by { rw [←right_unitor_tensor, right_unitor_naturality], simp, }

lemma braiding_right_unitor_aux₂ (X : C) :
  ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom) = (𝟙 (𝟙_ C)) ⊗ (λ_ X).hom :=
calc ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
    = ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ (α_ _ _ _).inv ≫ (α_ _ _ _).hom ≫
        ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by coherence
... = ((𝟙 (𝟙_ C)) ⊗ (β_ (𝟙_ C) X).hom) ≫ (α_ _ _ _).inv ≫ ((β_ _ X).hom ⊗ 𝟙 _) ≫
        ((β_ _ X).inv ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by { slice_rhs 3 4 { rw [←comp_tensor_id, iso.hom_inv_id, tensor_id], }, rw [id_comp], }
... = (α_ _ _ _).inv ≫ (β_ _ _).hom ≫
        (α_ _ _ _).inv ≫ ((β_ _ X).inv ⊗ 𝟙 _) ≫ (α_ _ _ _).hom ≫ ((𝟙 (𝟙_ C)) ⊗ (ρ_ X).hom)
         : by { slice_lhs 1 3 { rw ←hexagon_reverse }, simp only [assoc], }
... = (α_ _ _ _).inv ≫ (β_ _ _).hom ≫ (𝟙 X ⊗ (ρ_ _).hom) ≫ (β_ _ X).inv
         : by rw braiding_right_unitor_aux₁
... = (α_ _ _ _).inv ≫ ((ρ_ _).hom ⊗ 𝟙 _) ≫ (β_ _ X).hom ≫ (β_ _ _).inv
         : by { slice_lhs 2 3 { rw [←braiding_naturality] }, simp only [assoc], }
... = (α_ _ _ _).inv ≫ ((ρ_ _).hom ⊗ 𝟙 _)
         : by rw [iso.hom_inv_id, comp_id]
... = (𝟙 (𝟙_ C)) ⊗ (λ_ X).hom
         : by rw [triangle_assoc_comp_right]

@[simp]
lemma braiding_right_unitor (X : C) : (β_ (𝟙_ C) X).hom ≫ (ρ_ X).hom = (λ_ X).hom :=
by rw [←tensor_left_iff, id_tensor_comp, braiding_right_unitor_aux₂]

@[simp]
lemma left_unitor_inv_braiding (X : C) : (λ_ X).inv ≫ (β_ (𝟙_ C) X).hom = (ρ_ X).inv :=
begin
  apply (cancel_mono (ρ_ X).hom).1,
  simp only [assoc, braiding_right_unitor, iso.inv_hom_id],
end

@[simp]
lemma right_unitor_inv_braiding (X : C) : (ρ_ X).inv ≫ (β_ X (𝟙_ C)).hom = (λ_ X).inv :=
begin
  apply (cancel_mono (λ_ X).hom).1,
  simp only [assoc, braiding_left_unitor, iso.inv_hom_id],
end

end

/--
A symmetric monoidal category is a braided monoidal category for which the braiding is symmetric.

See <https://stacks.math.columbia.edu/tag/0FFW>.
-/
class symmetric_category (C : Type u) [category.{v} C] [monoidal_category.{v} C]
   extends braided_category.{v} C :=
-- braiding symmetric:
(symmetry' : ∀ X Y : C, (β_ X Y).hom ≫ (β_ Y X).hom = 𝟙 (X ⊗ Y) . obviously)

restate_axiom symmetric_category.symmetry'
attribute [simp,reassoc] symmetric_category.symmetry

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

/--
A lax braided functor between braided monoidal categories is a lax monoidal functor
which preserves the braiding.
-/
structure lax_braided_functor extends lax_monoidal_functor C D :=
(braided' : ∀ X Y : C, μ X Y ≫ map (β_ X Y).hom = (β_ (obj X) (obj Y)).hom ≫ μ Y X . obviously)

restate_axiom lax_braided_functor.braided'

namespace lax_braided_functor

/-- The identity lax braided monoidal functor. -/
@[simps] def id : lax_braided_functor C C :=
{ .. monoidal_functor.id C }

instance : inhabited (lax_braided_functor C C) := ⟨id C⟩

variables {C D E}

/-- The composition of lax braided monoidal functors. -/
@[simps]
def comp (F : lax_braided_functor C D) (G : lax_braided_functor D E) : lax_braided_functor C E :=
{ braided' := λ X Y,
  begin
    dsimp,
    slice_lhs 2 3 { rw [←category_theory.functor.map_comp, F.braided,
      category_theory.functor.map_comp], },
    slice_lhs 1 2 { rw [G.braided], },
    simp only [category.assoc],
  end,
  ..(lax_monoidal_functor.comp F.to_lax_monoidal_functor G.to_lax_monoidal_functor) }

instance category_lax_braided_functor : category (lax_braided_functor C D) :=
induced_category.category lax_braided_functor.to_lax_monoidal_functor

@[simp] lemma comp_to_nat_trans {F G H : lax_braided_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

/--
Interpret a natural isomorphism of the underlyling lax monoidal functors as an
isomorphism of the lax braided monoidal functors.
-/
@[simps]
def mk_iso {F G : lax_braided_functor C D}
  (i : F.to_lax_monoidal_functor ≅ G.to_lax_monoidal_functor) : F ≅ G :=
{ ..i }

end lax_braided_functor

/--
A braided functor between braided monoidal categories is a monoidal functor
which preserves the braiding.
-/
structure braided_functor extends monoidal_functor C D :=
-- Note this is stated differently than for `lax_braided_functor`.
-- We move the `μ X Y` to the right hand side,
-- so that this makes a good `@[simp]` lemma.
(braided' :
  ∀ X Y : C, map (β_ X Y).hom = inv (μ X Y) ≫ (β_ (obj X) (obj Y)).hom ≫ μ Y X . obviously)

restate_axiom braided_functor.braided'
attribute [simp] braided_functor.braided

/-- A braided category with a braided functor to a symmetric category is itself symmetric. -/
def symmetric_category_of_faithful {C D : Type*} [category C] [category D]
  [monoidal_category C] [monoidal_category D] [braided_category C] [symmetric_category D]
  (F : braided_functor C D) [faithful F.to_functor] : symmetric_category C :=
{ symmetry' := λ X Y, F.to_functor.map_injective (by simp), }

namespace braided_functor

/-- Turn a braided functor into a lax braided functor. -/
@[simps]
def to_lax_braided_functor (F : braided_functor C D) : lax_braided_functor C D :=
{ braided' := λ X Y, by { rw F.braided, simp, }
  .. F }

/-- The identity braided monoidal functor. -/
@[simps] def id : braided_functor C C :=
{ .. monoidal_functor.id C }

instance : inhabited (braided_functor C C) := ⟨id C⟩

variables {C D E}

/-- The composition of braided monoidal functors. -/
@[simps]
def comp (F : braided_functor C D) (G : braided_functor D E) : braided_functor C E :=
{ ..(monoidal_functor.comp F.to_monoidal_functor G.to_monoidal_functor) }

instance category_braided_functor : category (braided_functor C D) :=
induced_category.category braided_functor.to_monoidal_functor

@[simp] lemma comp_to_nat_trans {F G H : braided_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

/--
Interpret a natural isomorphism of the underlyling monoidal functors as an
isomorphism of the braided monoidal functors.
-/
@[simps]
def mk_iso {F G : braided_functor C D}
  (i : F.to_monoidal_functor ≅ G.to_monoidal_functor) : F ≅ G :=
{ ..i }

end braided_functor

section comm_monoid

variables (M : Type u) [comm_monoid M]

instance : braided_category (discrete M) :=
{ braiding := λ X Y, discrete.eq_to_iso (mul_comm X.as Y.as), }

variables {M} {N : Type u} [comm_monoid N]

/--
A multiplicative morphism between commutative monoids gives a braided functor between
the corresponding discrete braided monoidal categories.
-/
@[simps]
def discrete.braided_functor (F : M →* N) : braided_functor (discrete M) (discrete N) :=
{ ..discrete.monoidal_functor F }

end comm_monoid

section tensor

/-- The strength of the tensor product functor from `C × C` to `C`. -/
def tensor_μ (X Y : C × C) : (tensor C).obj X ⊗ (tensor C).obj Y ⟶ (tensor C).obj (X ⊗ Y) :=
(α_ X.1 X.2 (Y.1 ⊗ Y.2)).hom ≫ (𝟙 X.1 ⊗ (α_ X.2 Y.1 Y.2).inv) ≫
  (𝟙 X.1 ⊗ ((β_ X.2 Y.1).hom ⊗ 𝟙 Y.2)) ≫
  (𝟙 X.1 ⊗ (α_ Y.1 X.2 Y.2).hom) ≫ (α_ X.1 Y.1 (X.2 ⊗ Y.2)).inv

lemma tensor_μ_def₁ (X₁ X₂ Y₁ Y₂ : C) :
    tensor_μ C (X₁, X₂) (Y₁, Y₂) ≫ (α_ X₁ Y₁ (X₂ ⊗ Y₂)).hom ≫ (𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).inv)
  = (α_ X₁ X₂ (Y₁ ⊗ Y₂)).hom ≫ (𝟙 X₁ ⊗ (α_ X₂ Y₁ Y₂).inv) ≫ (𝟙 X₁ ⊗ ((β_ X₂ Y₁).hom ⊗ 𝟙 Y₂)) :=
by { dsimp [tensor_μ], simp }

lemma tensor_μ_def₂ (X₁ X₂ Y₁ Y₂ : C) :
    (𝟙 X₁ ⊗ (α_ X₂ Y₁ Y₂).hom) ≫ (α_ X₁ X₂ (Y₁ ⊗ Y₂)).inv ≫ tensor_μ C (X₁, X₂) (Y₁, Y₂)
  = (𝟙 X₁ ⊗ ((β_ X₂ Y₁).hom ⊗ 𝟙 Y₂)) ≫ (𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).hom) ≫ (α_ X₁ Y₁ (X₂ ⊗ Y₂)).inv :=
by { dsimp [tensor_μ], simp }

lemma tensor_μ_natural {X₁ X₂ Y₁ Y₂ U₁ U₂ V₁ V₂ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (g₁ : U₁ ⟶ V₁) (g₂ : U₂ ⟶ V₂) :
  ((f₁ ⊗ f₂) ⊗ (g₁ ⊗ g₂)) ≫ tensor_μ C (Y₁, Y₂) (V₁, V₂) =
    tensor_μ C (X₁, X₂) (U₁, U₂) ≫ ((f₁ ⊗ g₁) ⊗ (f₂ ⊗ g₂)) :=
begin
  dsimp [tensor_μ],
  slice_lhs 1 2 { rw [associator_naturality] },
  slice_lhs 2 3 { rw [←tensor_comp,
                      comp_id f₁, ←id_comp f₁,
                      associator_inv_naturality,
                      tensor_comp] },
  slice_lhs 3 4 { rw [←tensor_comp, ←tensor_comp,
                      comp_id f₁, ←id_comp f₁,
                      comp_id g₂, ←id_comp g₂,
                      braiding_naturality,
                      tensor_comp, tensor_comp] },
  slice_lhs 4 5 { rw [←tensor_comp,
                      comp_id f₁, ←id_comp f₁,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 5 6 { rw [associator_inv_naturality] },
  simp only [assoc],
end

lemma tensor_left_unitality (X₁ X₂ : C) :
    (λ_ (X₁ ⊗ X₂)).hom
  = ((λ_ (𝟙_ C)).inv ⊗ 𝟙 (X₁ ⊗ X₂)) ≫
    tensor_μ C (𝟙_ C, 𝟙_ C) (X₁, X₂) ≫
    ((λ_ X₁).hom ⊗ (λ_ X₂).hom) :=
begin
  dsimp [tensor_μ],
  have :
      ((λ_ (𝟙_ C)).inv ⊗ 𝟙 (X₁ ⊗ X₂)) ≫
      (α_ (𝟙_ C) (𝟙_ C) (X₁ ⊗ X₂)).hom ≫
      (𝟙 (𝟙_ C) ⊗ (α_ (𝟙_ C) X₁ X₂).inv)
    = 𝟙 (𝟙_ C) ⊗ ((λ_ X₁).inv ⊗ 𝟙 X₂) := by pure_coherence,
  slice_rhs 1 3 { rw this }, clear this,
  slice_rhs 1 2 { rw [←tensor_comp, ←tensor_comp,
                      comp_id, comp_id,
                      left_unitor_inv_braiding] },
  simp only [assoc],
  coherence,
end

lemma tensor_right_unitality (X₁ X₂ : C) :
    (ρ_ (X₁ ⊗ X₂)).hom
  = (𝟙 (X₁ ⊗ X₂) ⊗ (λ_ (𝟙_ C)).inv) ≫
    tensor_μ C (X₁, X₂) (𝟙_ C, 𝟙_ C) ≫
    ((ρ_ X₁).hom ⊗ (ρ_ X₂).hom) :=
begin
  dsimp [tensor_μ],
  have :
      (𝟙 (X₁ ⊗ X₂) ⊗ (λ_ (𝟙_ C)).inv) ≫
      (α_ X₁ X₂ (𝟙_ C ⊗ 𝟙_ C)).hom ≫
      (𝟙 X₁ ⊗ (α_ X₂ (𝟙_ C) (𝟙_ C)).inv)
    = (α_ X₁ X₂ (𝟙_ C)).hom ≫
      (𝟙 X₁ ⊗ ((ρ_ X₂).inv ⊗ 𝟙 (𝟙_ C))) := by pure_coherence,
  slice_rhs 1 3 { rw this }, clear this,
  slice_rhs 2 3 { rw [←tensor_comp, ←tensor_comp,
                      comp_id, comp_id,
                      right_unitor_inv_braiding] },
  simp only [assoc],
  coherence,
end

/-
Diagram B6 from Proposition 1 of [Joyal and Street, *Braided monoidal categories*][Joyal_Street].
-/
lemma tensor_associativity_aux (W X Y Z : C) :
    ((β_ W X).hom ⊗ 𝟙 (Y ⊗ Z)) ≫
    (α_ X W (Y ⊗ Z)).hom ≫
    (𝟙 X ⊗ (α_ W Y Z).inv) ≫
    (𝟙 X ⊗ (β_ (W ⊗ Y) Z).hom) ≫
    (𝟙 X ⊗ (α_ Z W Y).inv)
  = (𝟙 (W ⊗ X) ⊗ (β_ Y Z).hom) ≫
    (α_ (W ⊗ X) Z Y).inv ≫
    ((α_ W X Z).hom ⊗ 𝟙 Y) ≫
    ((β_ W (X ⊗ Z)).hom ⊗ 𝟙 Y) ≫
    ((α_ X Z W).hom ⊗ 𝟙 Y) ≫
    (α_ X (Z ⊗ W) Y).hom :=
begin
  slice_rhs 3 5 { rw [←tensor_comp, ←tensor_comp,
                      hexagon_forward,
                      tensor_comp, tensor_comp] },
  slice_rhs 5 6 { rw [associator_naturality] },
  slice_rhs 2 3 { rw [←associator_inv_naturality] },
  slice_rhs 3 5 { rw [←pentagon_hom_inv] },
  slice_rhs 1 2 { rw [tensor_id,
                      id_tensor_comp_tensor_id,
                      ←tensor_id_comp_id_tensor] },
  slice_rhs 2 3 { rw [← tensor_id, associator_naturality] },
  slice_rhs 3 5 { rw [←tensor_comp, ←tensor_comp,
                      ←hexagon_reverse,
                      tensor_comp, tensor_comp] },
end

lemma tensor_associativity (X₁ X₂ Y₁ Y₂ Z₁ Z₂ : C) :
    (tensor_μ C (X₁, X₂) (Y₁, Y₂) ⊗ 𝟙 (Z₁ ⊗ Z₂)) ≫
    tensor_μ C (X₁ ⊗ Y₁, X₂ ⊗ Y₂) (Z₁, Z₂) ≫
    ((α_ X₁ Y₁ Z₁).hom ⊗ (α_ X₂ Y₂ Z₂).hom)
  = (α_ (X₁ ⊗ X₂) (Y₁ ⊗ Y₂) (Z₁ ⊗ Z₂)).hom ≫
    (𝟙 (X₁ ⊗ X₂) ⊗ tensor_μ C (Y₁, Y₂) (Z₁, Z₂)) ≫
    tensor_μ C (X₁, X₂) (Y₁ ⊗ Z₁, Y₂ ⊗ Z₂) :=
begin
  have :
      ((α_ X₁ Y₁ Z₁).hom ⊗ (α_ X₂ Y₂ Z₂).hom)
    = (α_ (X₁ ⊗ Y₁) Z₁ ((X₂ ⊗ Y₂) ⊗ Z₂)).hom ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ Z₁ (X₂ ⊗ Y₂) Z₂).inv) ≫
      (α_ X₁ Y₁ ((Z₁ ⊗ (X₂ ⊗ Y₂)) ⊗ Z₂)).hom ≫
      (𝟙 X₁ ⊗ (α_ Y₁ (Z₁ ⊗ (X₂ ⊗ Y₂)) Z₂).inv) ≫
      (α_ X₁ (Y₁ ⊗ (Z₁ ⊗ (X₂ ⊗ Y₂))) Z₂).inv ≫
      ((𝟙 X₁ ⊗ (𝟙 Y₁ ⊗ (α_ Z₁ X₂ Y₂).inv)) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ (Z₁ ⊗ X₂) Y₂).inv) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ ((α_ Y₁ Z₁ X₂).inv ⊗ 𝟙 Y₂)) ⊗ 𝟙 Z₂) ≫
      (α_ X₁ (((Y₁ ⊗ Z₁) ⊗ X₂) ⊗ Y₂) Z₂).hom ≫
      (𝟙 X₁ ⊗ (α_ ((Y₁ ⊗ Z₁) ⊗ X₂) Y₂ Z₂).hom) ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ Z₁) X₂ (Y₂ ⊗ Z₂)).hom) ≫
      (α_ X₁ (Y₁ ⊗ Z₁) (X₂ ⊗ (Y₂ ⊗ Z₂))).inv := by pure_coherence,
  rw this, clear this,
  slice_lhs 2 4 { rw [tensor_μ_def₁] },
  slice_lhs 4 5 { rw [←tensor_id, associator_naturality] },
  slice_lhs 5 6 { rw [←tensor_comp,
                      associator_inv_naturality,
                      tensor_comp] },
  slice_lhs 6 7 { rw [associator_inv_naturality] },
  have :
      (α_ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) (Z₁ ⊗ Z₂)).hom ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ (X₂ ⊗ Y₂) Z₁ Z₂).inv) ≫
      (α_ X₁ Y₁ (((X₂ ⊗ Y₂) ⊗ Z₁) ⊗ Z₂)).hom ≫
      (𝟙 X₁ ⊗ (α_ Y₁ ((X₂ ⊗ Y₂) ⊗ Z₁) Z₂).inv) ≫
      (α_ X₁ (Y₁ ⊗ ((X₂ ⊗ Y₂) ⊗ Z₁)) Z₂).inv
    = ((α_ X₁ Y₁ (X₂ ⊗ Y₂)).hom ⊗ 𝟙 (Z₁ ⊗ Z₂)) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).inv) ⊗ 𝟙 (Z₁ ⊗ Z₂)) ≫
      (α_ (X₁ ⊗ ((Y₁ ⊗ X₂) ⊗ Y₂)) Z₁ Z₂).inv ≫
      ((α_ X₁ ((Y₁ ⊗ X₂) ⊗ Y₂) Z₁).hom ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) Y₂ Z₁).hom) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ X₂ (Y₂ ⊗ Z₁)).hom) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (𝟙 Y₁ ⊗ (α_ X₂ Y₂ Z₁).inv)) ⊗ 𝟙 Z₂) := by pure_coherence,
  slice_lhs 2 6 { rw this }, clear this,
  slice_lhs 1 3 { rw [←tensor_comp, ←tensor_comp,
                      tensor_μ_def₁,
                      tensor_comp, tensor_comp] },
  slice_lhs 3 4 { rw [←tensor_id,
                      associator_inv_naturality] },
  slice_lhs 4 5 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 5 6 { rw [←tensor_comp, ←tensor_comp,
                      associator_naturality,
                      tensor_comp, tensor_comp] },
  slice_lhs 6 10 { rw [←tensor_comp, ←tensor_comp, ←tensor_comp, ←tensor_comp,
                       ←tensor_comp, ←tensor_comp, ←tensor_comp, ←tensor_comp,
                       tensor_id,
                       tensor_associativity_aux,
                       ←tensor_id,
                       ←id_comp (𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁),
                       ←id_comp (𝟙 Z₂ ≫ 𝟙 Z₂ ≫ 𝟙 Z₂ ≫ 𝟙 Z₂ ≫ 𝟙 Z₂),
                       tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp,
                       tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp] },
  slice_lhs 11 12 { rw [←tensor_comp, ←tensor_comp,
                        iso.hom_inv_id],
                    simp },
  simp only [assoc, id_comp],
  slice_lhs 10 11 { rw [←tensor_comp, ←tensor_comp, ←tensor_comp,
                        iso.hom_inv_id],
                    simp },
  simp only [assoc, id_comp],
  slice_lhs 9 10 { rw [associator_naturality] },
  slice_lhs 10 11 { rw [←tensor_comp,
                        associator_naturality,
                        tensor_comp] },
  slice_lhs 11 13 { rw [tensor_id, ←tensor_μ_def₂] },
  have :
      ((𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁) Z₁ Y₂).inv) ⊗ 𝟙 Z₂) ≫
      ((𝟙 X₁ ⊗ (α_ X₂ Y₁ Z₁).hom ⊗ 𝟙 Y₂) ⊗ 𝟙 Z₂) ≫
      (α_ X₁ ((X₂ ⊗ Y₁ ⊗ Z₁) ⊗ Y₂) Z₂).hom ≫
      (𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁ ⊗ Z₁) Y₂ Z₂).hom) ≫
      (𝟙 X₁ ⊗ (α_ X₂ (Y₁ ⊗ Z₁) (Y₂ ⊗ Z₂)).hom) ≫
      (α_ X₁ X₂ ((Y₁ ⊗ Z₁) ⊗ Y₂ ⊗ Z₂)).inv
    = (α_ X₁ ((X₂ ⊗ Y₁) ⊗ (Z₁ ⊗ Y₂)) Z₂).hom ≫
      (𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁) (Z₁ ⊗ Y₂) Z₂).hom) ≫
      (𝟙 X₁ ⊗ (α_ X₂ Y₁ ((Z₁ ⊗ Y₂) ⊗ Z₂)).hom) ≫
      (α_ X₁ X₂ (Y₁ ⊗ ((Z₁ ⊗ Y₂) ⊗ Z₂))).inv ≫
      (𝟙 (X₁ ⊗ X₂) ⊗ (𝟙 Y₁ ⊗ (α_ Z₁ Y₂ Z₂).hom)) ≫
      (𝟙 (X₁ ⊗ X₂) ⊗ (α_ Y₁ Z₁ (Y₂ ⊗ Z₂)).inv) := by pure_coherence,
  slice_lhs 7 12 { rw this }, clear this,
  slice_lhs 6 7 { rw [associator_naturality] },
  slice_lhs 7 8 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 8 9 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 9 10 { rw [associator_inv_naturality] },
  slice_lhs 10 12 { rw [←tensor_comp, ←tensor_comp,
                        ←tensor_μ_def₂,
                        tensor_comp, tensor_comp] },
  dsimp,
  coherence,
end

/-- The tensor product functor from `C × C` to `C` as a monoidal functor. -/
@[simps]
def tensor_monoidal : monoidal_functor (C × C) C :=
{ ε := (λ_ (𝟙_ C)).inv,
  μ := λ X Y, tensor_μ C X Y,
  μ_natural' := λ X Y X' Y' f g, tensor_μ_natural C f.1 f.2 g.1 g.2,
  associativity' := λ X Y Z, tensor_associativity C X.1 X.2 Y.1 Y.2 Z.1 Z.2,
  left_unitality' := λ ⟨X₁, X₂⟩, tensor_left_unitality C X₁ X₂,
  right_unitality' := λ ⟨X₁, X₂⟩, tensor_right_unitality C X₁ X₂,
  μ_is_iso := by { dsimp [tensor_μ], apply_instance },
  .. tensor C }

lemma left_unitor_monoidal (X₁ X₂ : C) :
    (λ_ X₁).hom ⊗ (λ_ X₂).hom
  = tensor_μ C (𝟙_ C, X₁) (𝟙_ C, X₂) ≫
    ((λ_ (𝟙_ C)).hom ⊗ 𝟙 (X₁ ⊗ X₂)) ≫
    (λ_ (X₁ ⊗ X₂)).hom :=
begin
  dsimp [tensor_μ],
  have :
      (λ_ X₁).hom ⊗ (λ_ X₂).hom
    = (α_ (𝟙_ C) X₁ (𝟙_ C ⊗ X₂)).hom ≫
      (𝟙 (𝟙_ C) ⊗ (α_ X₁ (𝟙_ C) X₂).inv) ≫
      (λ_ ((X₁ ⊗ (𝟙_ C)) ⊗ X₂)).hom ≫
      ((ρ_ X₁).hom ⊗ (𝟙 X₂)) := by pure_coherence,
  rw this, clear this,
  rw ←braiding_left_unitor,
  slice_lhs 3 4 { rw [←id_comp (𝟙 X₂), tensor_comp] },
  slice_lhs 3 4 { rw [←left_unitor_naturality] },
  coherence,
end

lemma right_unitor_monoidal (X₁ X₂ : C) :
    (ρ_ X₁).hom ⊗ (ρ_ X₂).hom
  = tensor_μ C (X₁, 𝟙_ C) (X₂, 𝟙_ C) ≫
    (𝟙 (X₁ ⊗ X₂) ⊗ (λ_ (𝟙_ C)).hom) ≫
    (ρ_ (X₁ ⊗ X₂)).hom :=
begin
  dsimp [tensor_μ],
  have :
      (ρ_ X₁).hom ⊗ (ρ_ X₂).hom
    = (α_ X₁ (𝟙_ C) (X₂ ⊗ (𝟙_ C))).hom ≫
      (𝟙 X₁ ⊗ (α_ (𝟙_ C) X₂ (𝟙_ C)).inv) ≫
      (𝟙 X₁ ⊗ (ρ_ (𝟙_ C ⊗ X₂)).hom) ≫
      (𝟙 X₁ ⊗ (λ_ X₂).hom) := by pure_coherence,
  rw this, clear this,
  rw ←braiding_right_unitor,
  slice_lhs 3 4 { rw [←id_comp (𝟙 X₁), tensor_comp, id_comp] },
  slice_lhs 3 4 { rw [←tensor_comp,
                      ←right_unitor_naturality,
                      tensor_comp] },
  coherence,
end

lemma associator_monoidal (X₁ X₂ X₃ Y₁ Y₂ Y₃ : C) :
    tensor_μ C (X₁ ⊗ X₂, X₃) (Y₁ ⊗ Y₂, Y₃) ≫
    (tensor_μ C (X₁, X₂) (Y₁, Y₂) ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
    (α_ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) (X₃ ⊗ Y₃)).hom
  = ((α_ X₁ X₂ X₃).hom ⊗ (α_ Y₁ Y₂ Y₃).hom) ≫
    tensor_μ C (X₁, X₂ ⊗ X₃) (Y₁, Y₂ ⊗ Y₃) ≫
    (𝟙 (X₁ ⊗ Y₁) ⊗ tensor_μ C (X₂, X₃) (Y₂, Y₃)) :=
begin
  have :
      (α_ (X₁ ⊗ Y₁) (X₂ ⊗ Y₂) (X₃ ⊗ Y₃)).hom
    = ((α_ X₁ Y₁ (X₂ ⊗ Y₂)).hom ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      ((𝟙 X₁ ⊗ (α_ Y₁ X₂ Y₂).inv) ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      (α_ (X₁ ⊗ ((Y₁ ⊗ X₂) ⊗ Y₂)) X₃ Y₃).inv ≫
      ((α_ X₁ ((Y₁ ⊗ X₂) ⊗ Y₂) X₃).hom ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) Y₂ X₃).hom) ⊗ 𝟙 Y₃) ≫
      (α_ X₁ ((Y₁ ⊗ X₂) ⊗ (Y₂ ⊗ X₃)) Y₃).hom ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) (Y₂ ⊗ X₃) Y₃).hom) ≫
      (𝟙 X₁ ⊗ (α_ Y₁ X₂ ((Y₂ ⊗ X₃) ⊗ Y₃)).hom) ≫
      (α_ X₁ Y₁ (X₂ ⊗ ((Y₂ ⊗ X₃) ⊗ Y₃))).inv ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (𝟙 X₂ ⊗ (α_ Y₂ X₃ Y₃).hom)) ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ X₂ Y₂ (X₃ ⊗ Y₃)).inv) := by pure_coherence,
  rw this, clear this,
  slice_lhs 2 4 { rw [←tensor_comp, ←tensor_comp,
                      tensor_μ_def₁,
                      tensor_comp, tensor_comp] },
  slice_lhs 4 5 { rw [←tensor_id,
                      associator_inv_naturality] },
  slice_lhs 5 6 { rw [←tensor_comp,
                      associator_naturality,
                      tensor_comp] },
  slice_lhs 6 7 { rw [←tensor_comp, ←tensor_comp,
                      associator_naturality,
                      tensor_comp, tensor_comp] },
  have :
      ((α_ X₁ X₂ (Y₁ ⊗ Y₂)).hom ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      ((𝟙 X₁ ⊗ (α_ X₂ Y₁ Y₂).inv) ⊗ 𝟙 (X₃ ⊗ Y₃)) ≫
      (α_ (X₁ ⊗ ((X₂ ⊗ Y₁) ⊗ Y₂)) X₃ Y₃).inv ≫
      ((α_ X₁ ((X₂ ⊗ Y₁) ⊗ Y₂) X₃).hom ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ (X₂ ⊗ Y₁) Y₂ X₃).hom) ⊗ 𝟙 Y₃)
    = (α_ (X₁ ⊗ X₂) (Y₁ ⊗ Y₂) (X₃ ⊗ Y₃)).hom ≫
      (𝟙 (X₁ ⊗ X₂) ⊗ (α_ (Y₁ ⊗ Y₂) X₃ Y₃).inv) ≫
      (α_ X₁ X₂ (((Y₁ ⊗ Y₂) ⊗ X₃) ⊗ Y₃)).hom ≫
      (𝟙 X₁ ⊗ (α_ X₂ ((Y₁ ⊗ Y₂) ⊗ X₃) Y₃).inv) ≫
      (α_ X₁ (X₂ ⊗ ((Y₁ ⊗ Y₂) ⊗ X₃)) Y₃).inv ≫
      ((𝟙 X₁ ⊗ (𝟙 X₂ ⊗ (α_ Y₁ Y₂ X₃).hom)) ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ X₂ Y₁ (Y₂ ⊗ X₃)).inv) ⊗ 𝟙 Y₃) := by pure_coherence,
  slice_lhs 2 6 { rw this }, clear this,
  slice_lhs 1 3 { rw tensor_μ_def₁ },
  slice_lhs 3 4 { rw [←tensor_id,
                      associator_naturality] },
  slice_lhs 4 5 { rw [←tensor_comp,
                      associator_inv_naturality,
                      tensor_comp] },
  slice_lhs 5 6 { rw associator_inv_naturality },
  slice_lhs 6 9 { rw [←tensor_comp, ←tensor_comp, ←tensor_comp,
                      ←tensor_comp, ←tensor_comp, ←tensor_comp,
                      tensor_id,
                      associator_monoidal_aux,
                      ←id_comp (𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁),
                      ←id_comp (𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁ ≫ 𝟙 X₁),
                      ←id_comp (𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃),
                      ←id_comp (𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃ ≫ 𝟙 Y₃),
                      tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp,
                      tensor_comp, tensor_comp, tensor_comp, tensor_comp, tensor_comp] },
  slice_lhs 11 12 { rw associator_naturality },
  slice_lhs 12 13 { rw [←tensor_comp,
                        associator_naturality,
                        tensor_comp] },
  slice_lhs 13 14 { rw [←tensor_comp, ←tensor_id,
                        associator_naturality,
                        tensor_comp] },
  slice_lhs 14 15 { rw associator_inv_naturality },
  slice_lhs 15 17 { rw [tensor_id, ←tensor_comp, ←tensor_comp,
                        ←tensor_μ_def₂,
                        tensor_comp, tensor_comp] },
  have :
      ((𝟙 X₁ ⊗ ((α_ Y₁ X₂ X₃).inv ⊗ 𝟙 Y₂)) ⊗ 𝟙 Y₃) ≫
      ((𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) X₃ Y₂).hom) ⊗ 𝟙 Y₃) ≫
      (α_ X₁ ((Y₁ ⊗ X₂) ⊗ (X₃ ⊗ Y₂)) Y₃).hom ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ X₂) (X₃ ⊗ Y₂) Y₃).hom) ≫
      (𝟙 X₁ ⊗ (α_ Y₁ X₂ ((X₃ ⊗ Y₂) ⊗ Y₃)).hom) ≫
      (α_ X₁ Y₁ (X₂ ⊗ ((X₃ ⊗ Y₂) ⊗ Y₃))).inv ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (𝟙 X₂ ⊗ (α_ X₃ Y₂ Y₃).hom)) ≫
      (𝟙 (X₁ ⊗ Y₁) ⊗ (α_ X₂ X₃ (Y₂ ⊗ Y₃)).inv)
    = (α_ X₁ ((Y₁ ⊗ (X₂ ⊗ X₃)) ⊗ Y₂) Y₃).hom ≫
      (𝟙 X₁ ⊗ (α_ (Y₁ ⊗ (X₂ ⊗ X₃)) Y₂ Y₃).hom) ≫
      (𝟙 X₁ ⊗ (α_ Y₁ (X₂ ⊗ X₃) (Y₂ ⊗ Y₃)).hom) ≫
      (α_ X₁ Y₁ ((X₂ ⊗ X₃) ⊗ (Y₂ ⊗ Y₃))).inv := by pure_coherence,
  slice_lhs 9 16 { rw this }, clear this,
  slice_lhs 8 9 { rw associator_naturality },
  slice_lhs 9 10 { rw [←tensor_comp,
                       associator_naturality,
                       tensor_comp] },
  slice_lhs 10 12 { rw [tensor_id,
                        ←tensor_μ_def₂] },
  dsimp,
  coherence,
end

end tensor

end category_theory


import algebra.category.Group.adjunctions
import category_theory.sites.adjunction
import category_theory.sites.left_exact
import algebra.category.Group.abelian
import algebra.category.Group.filtered_colimits

import for_mathlib.SheafOfTypes_sheafification
import for_mathlib.whisker_adjunction
import for_mathlib.abelian_sheaves.exact
import for_mathlib.abelian_sheaves.main
import for_mathlib.AddCommGroup

import condensed.basic

universe u

open category_theory category_theory.limits

noncomputable theory

@[simps obj map]
def CondensedSet_to_presheaf : CondensedSet ⥤ Profiniteᵒᵖ ⥤ Type* :=
Sheaf_to_presheaf _ _

@[simps obj_val map]
def presheaf_to_CondensedSet : (Profiniteᵒᵖ ⥤ Type*) ⥤ CondensedSet :=
presheaf_to_Sheaf _ _

def CondensedSet_presheaf_adjunction : presheaf_to_CondensedSet ⊣ CondensedSet_to_presheaf :=
sheafification_adjunction proetale_topology (Type (u+1))

@[simp]
lemma CondensedSet_presheaf_adjunction_hom_equiv_apply (X : Profiniteᵒᵖ ⥤ Type*)
  (Y : CondensedSet) (e : presheaf_to_CondensedSet.obj X ⟶ Y) :
  CondensedSet_presheaf_adjunction.hom_equiv _ _ e =
  proetale_topology.to_sheafify X ≫ e.val := rfl

@[simp]
lemma CondensedSet_presheaf_adjunction_hom_equiv_symm_apply (X : Profiniteᵒᵖ ⥤ Type*)
  (Y : CondensedSet) (e : X ⟶ CondensedSet_to_presheaf.obj Y) :
  ((CondensedSet_presheaf_adjunction.hom_equiv _ _).symm e).val =
  proetale_topology.sheafify_lift e Y.cond := rfl

@[simp]
lemma CondensedSet_presheaf_adjunction_unit_app (X : Profiniteᵒᵖ ⥤ Type*) :
  CondensedSet_presheaf_adjunction.unit.app X =
  proetale_topology.to_sheafify X := rfl

@[simp]
lemma CondensedSet_presheaf_adjunction_counit_app (Y : CondensedSet) :
  (CondensedSet_presheaf_adjunction.counit.app Y).val =
  proetale_topology.sheafify_lift (𝟙 _) Y.cond := rfl

@[simps obj_val map]
def Condensed_Ab_to_CondensedSet : Condensed Ab ⥤ CondensedSet :=
Sheaf_compose _ (forget _)

@[simps obj_val map]
def CondensedSet_to_Condensed_Ab : CondensedSet ⥤ Condensed Ab :=
Sheaf.compose_and_sheafify _ AddCommGroup.free

@[simps obj_val map]
def CondensedSet_to_Condensed_Ab' : CondensedSet ⥤ Condensed Ab :=
Sheaf.compose_and_sheafify _ AddCommGroup.free'

@[simps hom_app_val inv_app_val]
def CondensedSet_to_Condensed_Ab_iso :
  CondensedSet_to_Condensed_Ab ≅ CondensedSet_to_Condensed_Ab' :=
iso_whisker_left _ $ iso_whisker_right (functor.map_iso _ $ AddCommGroup.free_iso_free') _

@[simps unit_app counit_app]
def Condensed_Ab_CondensedSet_adjunction :
  CondensedSet_to_Condensed_Ab ⊣ Condensed_Ab_to_CondensedSet :=
Sheaf.adjunction _ AddCommGroup.adj

@[simps unit_app counit_app]
def Condensed_Ab_CondensedSet_adjunction' :
  CondensedSet_to_Condensed_Ab' ⊣ Condensed_Ab_to_CondensedSet :=
Sheaf.adjunction _ AddCommGroup.adj'

@[simp]
lemma Condensed_Ab_CondensedSet_adjunction_hom_equiv_apply (X : CondensedSet)
  (Y : Condensed Ab) (e : CondensedSet_to_Condensed_Ab.obj X ⟶ Y) :
  (Condensed_Ab_CondensedSet_adjunction.hom_equiv _ _ e).val =
  (AddCommGroup.adj.whisker_right _).hom_equiv _ _ (proetale_topology.to_sheafify _ ≫ e.val) := rfl

@[simp]
lemma Condensed_Ab_CondensedSet_adjunction_hom_equiv_symm_apply (X : CondensedSet)
  (Y : Condensed Ab) (e : X ⟶ Condensed_Ab_to_CondensedSet.obj Y) :
  ((Condensed_Ab_CondensedSet_adjunction.hom_equiv _ _).symm e).val =
  proetale_topology.sheafify_lift
    (((AddCommGroup.adj.whisker_right _).hom_equiv _ _).symm e.val) Y.2 := rfl

@[simp]
lemma Condensed_Ab_CondensedSet_adjunction'_hom_equiv_apply (X : CondensedSet)
  (Y : Condensed Ab) (e : CondensedSet_to_Condensed_Ab'.obj X ⟶ Y) :
  (Condensed_Ab_CondensedSet_adjunction'.hom_equiv _ _ e).val =
  (AddCommGroup.adj'.whisker_right _).hom_equiv _ _ (proetale_topology.to_sheafify _ ≫ e.val) := rfl

@[simp]
lemma Condensed_Ab_CondensedSet_adjunction'_hom_equiv_symm_apply (X : CondensedSet)
  (Y : Condensed Ab) (e : X ⟶ Condensed_Ab_to_CondensedSet.obj Y) :
  ((Condensed_Ab_CondensedSet_adjunction'.hom_equiv _ _).symm e).val =
  proetale_topology.sheafify_lift
    (((AddCommGroup.adj'.whisker_right _).hom_equiv _ _).symm e.val) Y.2 := rfl

def presheaf_to_Condensed_Ab :
  (Profinite.{u}ᵒᵖ ⥤ Ab.{u+1}) ⥤ Condensed.{u} Ab.{u+1} :=
presheaf_to_Sheaf _ _

def Condensed_Ab_to_presheaf :
  Condensed.{u} Ab.{u+1} ⥤ Profinite.{u}ᵒᵖ ⥤ Ab.{u+1} :=
Sheaf_to_presheaf _ _

def Condensed_Ab_presheaf_adjunction :
  presheaf_to_Condensed_Ab.{u} ⊣ Condensed_Ab_to_presheaf.{u} :=
sheafification_adjunction _ _

instance presheaf_to_Condensed_Ab_preserves_colimits :
  preserves_colimits presheaf_to_Condensed_Ab.{u} :=
Condensed_Ab_presheaf_adjunction.left_adjoint_preserves_colimits

set_option pp.universes true

instance : functor.additive presheaf_to_Condensed_Ab.{u} :=
by apply category_theory.Sheaf.presheaf_to_Sheaf_additive.{u+2 u u+1}

instance : functor.additive Condensed_Ab_to_presheaf := ⟨⟩

instance : preserves_colimits presheaf_to_Condensed_Ab :=
Condensed_Ab_presheaf_adjunction.left_adjoint_preserves_colimits

instance : preserves_finite_limits presheaf_to_Condensed_Ab :=
category_theory.presheaf_to_Sheaf.limits.preserves_finite_limits.{u+2 u u+1}


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.functor
import Mathlib.category_theory.full_subcategory
import Mathlib.PostPort

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

namespace Mathlib

/-!
# Monoidal natural transformations

Natural transformations between (lax) monoidal functors must satisfy
an additional compatibility relation with the tensorators:
`F.μ X Y ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ X Y`.

(Lax) monoidal functors between a fixed pair of monoidal categories
themselves form a category.
-/

namespace category_theory

/--
A monoidal natural transformation is a natural transformation between (lax) monoidal functors
additionally satisfying:
`F.μ X Y ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ X Y`
-/
structure monoidal_nat_trans {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] (F : lax_monoidal_functor C D) (G : lax_monoidal_functor C D)
    extends nat_trans (lax_monoidal_functor.to_functor F) (lax_monoidal_functor.to_functor G) where
  unit' :
    autoParam (lax_monoidal_functor.ε F ≫ nat_trans.app _to_nat_trans 𝟙_ = lax_monoidal_functor.ε G)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  tensor' :
    autoParam
      (∀ (X Y : C),
        lax_monoidal_functor.μ F X Y ≫ nat_trans.app _to_nat_trans (X ⊗ Y) =
          (nat_trans.app _to_nat_trans X ⊗ nat_trans.app _to_nat_trans Y) ≫
            lax_monoidal_functor.μ G X Y)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem monoidal_nat_trans.tensor {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] {F : lax_monoidal_functor C D}
    {G : lax_monoidal_functor C D} (c : monoidal_nat_trans F G) (X : C) (Y : C) :
    lax_monoidal_functor.μ F X Y ≫ nat_trans.app (monoidal_nat_trans.to_nat_trans c) (X ⊗ Y) =
        (nat_trans.app (monoidal_nat_trans.to_nat_trans c) X ⊗
            nat_trans.app (monoidal_nat_trans.to_nat_trans c) Y) ≫
          lax_monoidal_functor.μ G X Y :=
  sorry

@[simp] theorem monoidal_nat_trans.tensor_assoc {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] {F : lax_monoidal_functor C D}
    {G : lax_monoidal_functor C D} (c : monoidal_nat_trans F G) (X : C) (Y : C) {X' : D}
    (f' : functor.obj (lax_monoidal_functor.to_functor G) (X ⊗ Y) ⟶ X') :
    lax_monoidal_functor.μ F X Y ≫ nat_trans.app (monoidal_nat_trans.to_nat_trans c) (X ⊗ Y) ≫ f' =
        (nat_trans.app (monoidal_nat_trans.to_nat_trans c) X ⊗
            nat_trans.app (monoidal_nat_trans.to_nat_trans c) Y) ≫
          lax_monoidal_functor.μ G X Y ≫ f' :=
  sorry

@[simp] theorem monoidal_nat_trans.unit {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] {F : lax_monoidal_functor C D}
    {G : lax_monoidal_functor C D} (c : monoidal_nat_trans F G) :
    lax_monoidal_functor.ε F ≫ nat_trans.app (monoidal_nat_trans.to_nat_trans c) 𝟙_ =
        lax_monoidal_functor.ε G :=
  sorry

@[simp] theorem monoidal_nat_trans.unit_assoc {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] {F : lax_monoidal_functor C D}
    {G : lax_monoidal_functor C D} (c : monoidal_nat_trans F G) {X' : D}
    (f' : functor.obj (lax_monoidal_functor.to_functor G) 𝟙_ ⟶ X') :
    lax_monoidal_functor.ε F ≫ nat_trans.app (monoidal_nat_trans.to_nat_trans c) 𝟙_ ≫ f' =
        lax_monoidal_functor.ε G ≫ f' :=
  sorry

namespace monoidal_nat_trans

/--
The identity monoidal natural transformation.
-/
def id {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] (F : lax_monoidal_functor C D) : monoidal_nat_trans F F :=
  mk (nat_trans.mk (nat_trans.app 𝟙))

protected instance inhabited {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] (F : lax_monoidal_functor C D) :
    Inhabited (monoidal_nat_trans F F) :=
  { default := id F }

/--
Vertical composition of monoidal natural transformations.
-/
def vcomp {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : lax_monoidal_functor C D} {G : lax_monoidal_functor C D}
    {H : lax_monoidal_functor C D} (α : monoidal_nat_trans F G) (β : monoidal_nat_trans G H) :
    monoidal_nat_trans F H :=
  mk (nat_trans.mk (nat_trans.app (nat_trans.vcomp (to_nat_trans α) (to_nat_trans β))))

protected instance category_lax_monoidal_functor {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] : category (lax_monoidal_functor C D) :=
  category.mk

@[simp] theorem comp_to_nat_trans' {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] {F : lax_monoidal_functor C D} {G : lax_monoidal_functor C D}
    {H : lax_monoidal_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
    to_nat_trans (α ≫ β) = to_nat_trans α ≫ to_nat_trans β :=
  rfl

protected instance category_monoidal_functor {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] : category (monoidal_functor C D) :=
  induced_category.category monoidal_functor.to_lax_monoidal_functor

@[simp] theorem comp_to_nat_trans'' {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] {F : monoidal_functor C D} {G : monoidal_functor C D}
    {H : monoidal_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
    to_nat_trans (α ≫ β) = to_nat_trans α ≫ to_nat_trans β :=
  rfl

/--
Horizontal composition of monoidal natural transformations.
-/
@[simp] theorem hcomp_to_nat_trans {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] {E : Type u₃} [category E] [monoidal_category E]
    {F : lax_monoidal_functor C D} {G : lax_monoidal_functor C D} {H : lax_monoidal_functor D E}
    {K : lax_monoidal_functor D E} (α : monoidal_nat_trans F G) (β : monoidal_nat_trans H K) :
    to_nat_trans (hcomp α β) = to_nat_trans α ◫ to_nat_trans β :=
  Eq.refl (to_nat_trans (hcomp α β))

end monoidal_nat_trans

namespace monoidal_nat_iso

protected instance is_iso_of_is_iso_app {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] {F : lax_monoidal_functor C D}
    {G : lax_monoidal_functor C D} (α : F ⟶ G)
    [(X : C) → is_iso (nat_trans.app (monoidal_nat_trans.to_nat_trans α) X)] : is_iso α :=
  is_iso.mk
    (monoidal_nat_trans.mk
      (nat_trans.mk fun (X : C) => inv (nat_trans.app (monoidal_nat_trans.to_nat_trans α) X)))

/--
Construct a monoidal natural isomorphism from object level isomorphisms,
and the monoidal naturality in the forward direction.
-/
def of_components {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] {F : lax_monoidal_functor C D} {G : lax_monoidal_functor C D}
    (app :
      (X : C) →
        functor.obj (lax_monoidal_functor.to_functor F) X ≅
          functor.obj (lax_monoidal_functor.to_functor G) X)
    (naturality :
      ∀ {X Y : C} (f : X ⟶ Y),
        functor.map (lax_monoidal_functor.to_functor F) f ≫ iso.hom (app Y) =
          iso.hom (app X) ≫ functor.map (lax_monoidal_functor.to_functor G) f)
    (unit : lax_monoidal_functor.ε F ≫ iso.hom (app 𝟙_) = lax_monoidal_functor.ε G)
    (tensor :
      ∀ (X Y : C),
        lax_monoidal_functor.μ F X Y ≫ iso.hom (app (X ⊗ Y)) =
          (iso.hom (app X) ⊗ iso.hom (app Y)) ≫ lax_monoidal_functor.μ G X Y) :
    F ≅ G :=
  as_iso (monoidal_nat_trans.mk (nat_trans.mk fun (X : C) => iso.hom (app X)))

@[simp] theorem of_components.hom_app {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] {F : lax_monoidal_functor C D} {G : lax_monoidal_functor C D}
    (app :
      (X : C) →
        functor.obj (lax_monoidal_functor.to_functor F) X ≅
          functor.obj (lax_monoidal_functor.to_functor G) X)
    (naturality :
      ∀ {X Y : C} (f : X ⟶ Y),
        functor.map (lax_monoidal_functor.to_functor F) f ≫ iso.hom (app Y) =
          iso.hom (app X) ≫ functor.map (lax_monoidal_functor.to_functor G) f)
    (unit : lax_monoidal_functor.ε F ≫ iso.hom (app 𝟙_) = lax_monoidal_functor.ε G)
    (tensor :
      ∀ (X Y : C),
        lax_monoidal_functor.μ F X Y ≫ iso.hom (app (X ⊗ Y)) =
          (iso.hom (app X) ⊗ iso.hom (app Y)) ≫ lax_monoidal_functor.μ G X Y)
    (X : C) :
    nat_trans.app
          (monoidal_nat_trans.to_nat_trans (iso.hom (of_components app naturality unit tensor))) X =
        iso.hom (app X) :=
  rfl

@[simp] theorem of_components.inv_app {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] {F : lax_monoidal_functor C D} {G : lax_monoidal_functor C D}
    (app :
      (X : C) →
        functor.obj (lax_monoidal_functor.to_functor F) X ≅
          functor.obj (lax_monoidal_functor.to_functor G) X)
    (naturality :
      ∀ {X Y : C} (f : X ⟶ Y),
        functor.map (lax_monoidal_functor.to_functor F) f ≫ iso.hom (app Y) =
          iso.hom (app X) ≫ functor.map (lax_monoidal_functor.to_functor G) f)
    (unit : lax_monoidal_functor.ε F ≫ iso.hom (app 𝟙_) = lax_monoidal_functor.ε G)
    (tensor :
      ∀ (X Y : C),
        lax_monoidal_functor.μ F X Y ≫ iso.hom (app (X ⊗ Y)) =
          (iso.hom (app X) ⊗ iso.hom (app Y)) ≫ lax_monoidal_functor.μ G X Y)
    (X : C) :
    nat_trans.app
          (monoidal_nat_trans.to_nat_trans (iso.inv (of_components app naturality unit tensor))) X =
        iso.inv (app X) :=
  rfl

end Mathlib


import Lean
open Lean
open Lean.Elab
open Lean.Meta
open Lean.Elab.Tactic

example (a b c : Nat) (h₁ : a = b) (h₂ : b = c) : a = c := by
  apply Eq.trans _ h₂  -- the metavars created during elaboration become new goals
  trace_state
  exact h₁

example (a : Nat) : ∃ x, x = a := by
  apply Exists.intro  -- the goal for the witness should occur "after" the goal for x = a
  trace_state
  rfl

elab "fapply " e:term : tactic =>
  evalApplyLikeTactic (Meta.apply (cfg := {newGoals := ApplyNewGoals.all})) e

elab "eapply " e:term : tactic =>
  evalApplyLikeTactic (Meta.apply (cfg := {newGoals := ApplyNewGoals.nonDependentOnly})) e

example (a : Nat) : ∃ x, x = a := by
  eapply Exists.intro  -- only metavars with out forward dependencies are added as goals.
  trace_state
  rfl

example (a : Nat) : ∃ x, x = a := by
  fapply Exists.intro  -- all unassigned metavars are added as new goals using the order they were created.
  trace_state
  exact a
  trace_state
  rfl


/-
 Copyright 2023 RISC Zero, Inc.

 Licensed under the Apache License, Version 2.0 (the "License");
 you may not use this file except in compliance with the License.
 You may obtain a copy of the License at

     http://www.apache.org/licenses/LICENSE-2.0

 Unless required by applicable law or agreed to in writing, software
 distributed under the License is distributed on an "AS IS" BASIS,
 WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 See the License for the specific language governing permissions and
 limitations under the License.
-/

import Mathlib.Data.Option.Basic
import Init.Data.Nat.Log2
import Zkvm.Verify.Merkle

/-!
# Merkle Trees in Lean

Implements merkle trees

## Indexing

01            -- Level 0
|   \
02    03      -- Level 1
| \   | \
04 05 06 07   -- Level 2

## Merkle Tree Collision Extraction

The main def here is MerkleTreeCollisionExtractor, which,
given two merkle branches to the same index proving different values,
returns a collision of the hash function.

There is also code for a proof of this fact. This proof is in the process of being ported from Lean 3, but a few more tactics will be needed first.

-/

-- variables  {F : Type} {A : Type} [decidable_eq A] [inhabited F] [inhabited A]

/-- A collection of functions representing a hash function which can act on a field type and also on pairs of its own hashes,
as well as return field elements. -/
structure hashing_scheme (F A : Type) :=
  (of_hash_pair : A -> A -> A)
  (of_field_element : F -> A)
  -- (hash_to_field : A -> F) -- might readd later

variable (h : hashing_scheme F A)

def LayersFromRowSize (row_size : Nat) := Nat.log2 row_size

def TopLayerFromQueries (queries : Nat) := Nat.log2 (queries) + 1

-- Pairs elements off to make a row in the Merkle tree one layer closer to the root
def CollapseLayer : List A -> List A
| [] => []
| (a :: []) => a :: []
| (a :: b :: tail') => (h.of_hash_pair a b) :: (CollapseLayer tail')

/-- Takes a height and a List of hashes of length 2^height and returns the hash tree -/
def hash_tree (height : Nat) (hashes: List A) : List A :=
match height with
| 0 => hashes ++ hashes
| (n+1) => hash_tree n (CollapseLayer h hashes) ++ hashes

/-- A structure representing a merkle tree of elements of leaf type F and hash type A
leaves is expected to be a List of power-of-2-length, and hashes a List of twice the length
The indexing of hashes is as follows:
the first element is a default,
the index one element is the root,
the index 2-3 elements are the next row of the tree
and so forth, up to the n to (2*n-1)th elements, which are the indices of the hashes of the leaves-/
structure merkle_tree (F A : Type) :=
  (hashes : List A)
  (leaves : List F)

def merkle_tree.root [Inhabited A] (tree : merkle_tree F A) : A := tree.hashes.get! 1

/-- Contains the List of hashes and the leaf value field element.
The head element of the branch hashes is closest to the leaves -/
structure MerkleBranch (F A : Type) :=
  (branch_hashes : List A)
  (leaf : F)

def merkle_tree.of_leaf_list (leaves : List F) : merkle_tree F A :=
{ hashes := hash_tree h (Nat.log2 leaves.length) (leaves.map h.of_field_element),
  leaves := leaves }

def merkle_tree.layers (tree : merkle_tree F A) : Nat := (Nat.log2 tree.leaves.length)

/-- Given an index as described in the module docstring and a level, returns the descendant of that index in that level.
e.g. get_ancestor_at_level 1 7 should return 3. -/
def get_ancestor_at_level (level : Nat) (val : Nat): Nat :=
val / 2 ^ (Nat.log2 val - level)

def get_sibling (idx : Nat) : Nat :=
if idx % 2 = 1 then idx - 1 else idx + 1

def merkle_tree.get_branch [Inhabited F] [Inhabited A] (tree : merkle_tree F A) (idx : Nat) : MerkleBranch F A :=
{ branch_hashes :=
    (List.range tree.layers).map
      (λ i => tree.hashes.get! (get_sibling (get_ancestor_at_level (tree.layers - i) idx))),
  leaf := tree.leaves.get! idx }

/-- Given `top_layer` a row of a Merkle tree at layer top, an index into the tree,
a value at that index, and a Merkle branch putatively proving that value to that top row,
this checks if the verification of the branch will return correct
-/
def merkle_tree.verify_aux [Inhabited A] [DecidableEq A] (hash : A -> A -> A)
  (top_layer_idx : Nat) (top_layer : List A) (tree_idx: Nat) (value: A) (branch: List A):
  Bool :=
match branch with
| [] =>
    Nat.ble (2 ^ top_layer_idx) tree_idx
    &&
    Nat.blt tree_idx (2 ^ (Nat.succ top_layer_idx))
    &&
    List.get! top_layer (tree_idx - 2 ^ top_layer_idx) == some value
| (h :: tail) =>
    if tree_idx % 2 = 1
      then merkle_tree.verify_aux hash top_layer_idx top_layer (tree_idx / 2) (hash h value) tail
      else merkle_tree.verify_aux hash top_layer_idx top_layer (tree_idx / 2) (hash value h) tail

--  * Given `top` a row of a Merkle tree at layer top_layer, a row_size, an index into the row of leaves, a leaf value at that index, and a Merkle branch putatively proving that value to that top row, this checks if the verification of the branch will return correct *)
def MerkleTreeVerifyToTop [Inhabited A] [DecidableEq A] (top_layer : Nat) (top : List A) (row_size : Nat) (idx : Nat) (value : A)
  (branch : List A) : Bool :=
merkle_tree.verify_aux h.of_hash_pair top_layer top (idx + row_size) value branch

--  Given a root of a Merkle tree, a row_size, an index into the row of leaves, a leaf value at that index, and a Merkle branch putatively proving that value to that top row, this checks if the verification of the branch will return correct *)
def MerkleTreeVerifyToRoot [Inhabited A] [DecidableEq A] (root : A) (row_size : Nat) (idx : Nat) (value : A)
  (branch : List A) : Bool :=
MerkleTreeVerifyToTop h 0 (root :: []) row_size idx value branch

def merkle_branch.verify [Inhabited A] [DecidableEq A] (branch : MerkleBranch F A) (root_hash : A) (index : Nat) : Bool :=
MerkleTreeVerifyToRoot h root_hash (2^branch.branch_hashes.length) index
  (h.of_field_element branch.leaf) (branch.branch_hashes)

structure MerkleTreeVerifier : Type :=
  (top_layer_idx : Nat)
  (top_layer : List A)

--     (* Given two merkle branches to two values at the same index, returns the first pair of pairs of hashes that result in the same value. *)
def MerkleTreeCollisionExtractor [Inhabited A] [DecidableEq A] (hash : A -> A -> A)
  (idx : Nat) (value1 value2 : A) (branch1 branch2 : List A):
  (Option ((A × A) × (A × A))) :=
match branch1, branch2 with
| [], _ => none
| _, [] => none
| (h1 :: tail1), (h2 :: tail2) =>
  if idx % 2 = 1
    then if (hash h1 value1) == (hash h2 value2)
      then some ((h1, value1), (h2, value2))
      else MerkleTreeCollisionExtractor hash (idx / 2) (hash h1 value1) (hash h2 value2) tail1 tail2
    else if (hash value1 h1) == (hash value2 h2)
      then some ((value1, h1), (value2, h2))
      else MerkleTreeCollisionExtractor hash (idx / 2) (hash value1 h1) (hash value2 h2) tail1 tail2

--     (* A helper lemma telling us the length of a Merkle Branch *)
def BranchLengthOfMerkleTreeVerifyAux [Inhabited A] [DecidableEq A]
  (hash: A -> A -> A)
  {top_layer_idx : Nat} {top_layer : List A} {tree_idx : Nat}
  {value : A} {branch : List A}
  (h_verifies : merkle_tree.verify_aux hash top_layer_idx top_layer tree_idx value branch) :
    List.length branch = (Nat.log2 tree_idx) - top_layer_idx := by
  revert h_verifies
  revert tree_idx
  revert value
  induction branch
  { intros value tree_idx h_verifies
    unfold merkle_tree.verify_aux at h_verifies
    sorry
    -- cases h_verifies with ⟨hva, hvb, hve⟩
    -- clear hve value top_layer
    -- simp
    -- symmetry
    -- rw tsub_eq_zero_iff_le
    -- have : (Nat.log2 tree_idx = top_layer_idx)
    -- {
    --   sorry,
    -- },
    -- rw this,
    -- apply Nat,log2_unique,
    -- apply Nat,le_0_l,
    -- split,
    -- auto,
    -- auto,
    -- rewrite H,
    -- apply Nat,le_refl,
  }
  {
    intros value tree_idx h_verifies
    simp
    sorry
    -- (* simpl in h_verifies, *)
    -- unfold MerkleTreeVerifyAux in h_verifies,
    -- fold MerkleTreeVerifyAux in h_verifies,

    -- destruct (tree_idx mod 2 =? 1 ),
    -- {
    --   apply (IHbranch (hash a value) (tree_idx / 2)) in h_verifies,
    --   rewrite h_verifies,
    --   (* Not quite true for tree_idx <= 1, add edge case*)
    --   admit,
    -- }
    -- {
    --   apply (IHbranch (hash value a) (tree_idx / 2)) in h_verifies,
    --   rewrite h_verifies,
    --   admit,
    -- }

  }

-- --     (* Proves the output of `MerkleTreeCollisionExtractor` returns two distinct values, when given two branches that both verify against that same top. *)
def MerkleTreeCollisionExtractor__CollidesAux
    [Inhabited A] [DecidableEq A]
    (hash: A -> A -> A)
    (top_layer : Nat) (top : List A) (row_size : Nat) -- (* A Merkle Tree *)
    (idx : Nat)       --  (* A specific leaf location *)
    (value1 value2 : A) -- (* Two (ostensibly different) leaf values *)
    (branch1 branch2 : List A) -- (* Two branches to those values *)
    (hbranch1 : merkle_tree.verify_aux hash top_layer top idx value1 branch1)
    (hbranch2 : merkle_tree.verify_aux hash top_layer top idx value2 branch2)
    (hneq : value1 ≠ value2) :
    (MerkleTreeCollisionExtractor hash idx value1 value2 branch1 branch2).casesOn' false (λ p => p.fst.fst = p.snd.fst ∧ p.fst.snd = p.snd.snd) :=
by
  revert value1 value2 idx branch2
  sorry
  -- induction branch1
  -- { --(* Case where one branch is empty *)
  --   intros value1 value2 idx branch2 hv1 hv2 neq
  --   pose proof BranchLengthOfMerkleTreeVerifyAux hv1 as H1
  --   pose proof BranchLengthOfMerkleTreeVerifyAux hv2 as H2
  --   rewrite <-H1 in H2.

  --   simpl.
  --   apply neq.

  --   simpl in H1.

  --   simpl in H2.
  --   rewrite length_zero_iff_nil in H2.
  --   rewrite H2 in hv2.
  --   unfold MerkleTreeVerifyAux in hv1.
  --   unfold MerkleTreeVerifyAux in hv2.
  --   destruct hv1 as [hv1a [hv1b hv1e]].
  --   destruct hv2 as [hv2a [hv2b hv2e]].
  --   rewrite hv1e in hv2e.
  --   inversion hv2e.
  --   rewrite (refl_eq value2).
  --   simpl.
  --   constructor.
  -- }
  -- intros value1 value2 idx branch2 hv1 hv2 neq.
  -- destruct branch2.
  -- {
  --   exfalso.
  --   pose proof BranchLengthOfMerkleTreeVerifyAux hv1 as H1.
  --   pose proof BranchLengthOfMerkleTreeVerifyAux hv2 as H2.
  --   rewrite <-H1 in H2.
  --   simpl in H2.
  --   inversion H2.
  -- }
  -- unfold MerkleTreeCollisionExtractor.
  -- fold MerkleTreeCollisionExtractor.
  -- unfold MerkleTreeVerifyAux in hv1.
  -- unfold MerkleTreeVerifyAux in hv2.
  -- fold MerkleTreeVerifyAux in hv1.
  -- fold MerkleTreeVerifyAux in hv2.

  -- destruct (idx mod 2 =? 1) eqn:?.
  -- { pose proof IHbranch1 (hash a value1) (hash a0 value2) (idx / 2) branch2 hv1 hv2.

  --   destruct (eq (hash a value1) (hash a0 value2)) eqn:?.
  --   {
  --     intro H2.
  --     apply neq.
  --     elim (andb_prop_elim _ _ H2).
  --     intros left_ right_.
  --     exact right_.
  --   }
  --   {
  --     apply H.
  --     simpl. (* What is the canonical way of solving this? *)
  --     intro f.
  --     exact f.
  --   }
  -- }
  -- { pose proof IHbranch1 (hash value1 a) (hash value2 a0) (idx / 2) branch2 hv1 hv2.
  --   destruct (eq (hash value1 a) (hash value2 a0)) eqn:?.
  --   {
  --     intro H2.
  --     apply neq.
  --     elim (andb_prop_elim _ _ H2).
  --     intros left_ right_.
  --     exact left_.
  --   }
  --   {
  --     apply H.
  --     simpl.
  --     intro f.
  --     exact f.
  --   }
  --   (* Similar to previous block *)
  -- },