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

! This file was ported from Lean 3 source module category_theory.monoidal.rigid.basic
! leanprover-community/mathlib commit 3d7987cda72abc473c7cdbbb075170e9ac620042
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Monoidal.CoherenceLemmas
import Mathbin.CategoryTheory.Closed.Monoidal
import Mathbin.Tactic.ApplyFun

/-!
# Rigid (autonomous) monoidal categories

This file defines rigid (autonomous) monoidal categories and the necessary theory about
exact pairings and duals.

## Main definitions

* `exact_pairing` of two objects of a monoidal category
* Type classes `has_left_dual` and `has_right_dual` that capture that a pairing exists
* The `right_adjoint_mate f` as a morphism `fᘁ : Yᘁ ⟶ Xᘁ` for a morphism `f : X ⟶ Y`
* The classes of `right_rigid_category`, `left_rigid_category` and `rigid_category`

## Main statements

* `comp_right_adjoint_mate`: The adjoint mates of the composition is the composition of
  adjoint mates.

## Notations

* `η_` and `ε_` denote the coevaluation and evaluation morphism of an exact pairing.
* `Xᘁ` and `ᘁX` denote the right and left dual of an object, as well as the adjoint
  mate of a morphism.

## Future work

* Show that `X ⊗ Y` and `Yᘁ ⊗ Xᘁ` form an exact pairing.
* Show that the left adjoint mate of the right adjoint mate of a morphism is the morphism itself.
* Simplify constructions in the case where a symmetry or braiding is present.
* Show that `ᘁ` gives an equivalence of categories `C ≅ (Cᵒᵖ)ᴹᵒᵖ`.
* Define pivotal categories (rigid categories equipped with a natural isomorphism `ᘁᘁ ≅ 𝟙 C`).

## Notes

Although we construct the adjunction `tensor_left Y ⊣ tensor_left X` from `exact_pairing X Y`,
this is not a bijective correspondence.
I think the correct statement is that `tensor_left Y` and `tensor_left X` are
module endofunctors of `C` as a right `C` module category,
and `exact_pairing X Y` is in bijection with adjunctions compatible with this right `C` action.

## References

* <https://ncatlab.org/nlab/show/rigid+monoidal+category>

## Tags

rigid category, monoidal category

-/

open CategoryTheory

universe v v₁ v₂ v₃ u u₁ u₂ u₃

noncomputable section

namespace CategoryTheory

variable {C : Type u₁} [Category.{v₁} C] [MonoidalCategory C]

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`coevaluation] [] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`evaluation] [] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`coevaluation_evaluation'] [] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`evaluation_coevaluation'] [] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- An exact pairing is a pair of objects `X Y : C` which admit
  a coevaluation and evaluation morphism which fulfill two triangle equalities. -/
class ExactPairing (X Y : C) where
  coevaluation : 𝟙_ C ⟶ X ⊗ Y
  evaluation : Y ⊗ X ⟶ 𝟙_ C
  coevaluation_evaluation' :
    (𝟙 Y ⊗ coevaluation) ≫ (α_ _ _ _).inv ≫ (evaluation ⊗ 𝟙 Y) = (ρ_ Y).Hom ≫ (λ_ Y).inv := by
    obviously
  evaluation_coevaluation' :
    (coevaluation ⊗ 𝟙 X) ≫ (α_ _ _ _).Hom ≫ (𝟙 X ⊗ evaluation) = (λ_ X).Hom ≫ (ρ_ X).inv := by
    obviously
#align category_theory.exact_pairing CategoryTheory.ExactPairing

open ExactPairing

-- mathport name: exprη_
notation "η_" => ExactPairing.coevaluation

-- mathport name: exprε_
notation "ε_" => ExactPairing.evaluation

restate_axiom coevaluation_evaluation'

attribute [simp, reassoc.1] exact_pairing.coevaluation_evaluation

restate_axiom evaluation_coevaluation'

attribute [simp, reassoc.1] exact_pairing.evaluation_coevaluation

instance exactPairingUnit : ExactPairing (𝟙_ C) (𝟙_ C)
    where
  coevaluation := (ρ_ _).inv
  evaluation := (ρ_ _).Hom
  coevaluation_evaluation' := by coherence
  evaluation_coevaluation' := by coherence
#align category_theory.exact_pairing_unit CategoryTheory.exactPairingUnit

/-- A class of objects which have a right dual. -/
class HasRightDual (X : C) where
  rightDual : C
  [exact : ExactPairing X right_dual]
#align category_theory.has_right_dual CategoryTheory.HasRightDual

/-- A class of objects with have a left dual. -/
class HasLeftDual (Y : C) where
  leftDual : C
  [exact : ExactPairing left_dual Y]
#align category_theory.has_left_dual CategoryTheory.HasLeftDual

attribute [instance] has_right_dual.exact

attribute [instance] has_left_dual.exact

open ExactPairing HasRightDual HasLeftDual MonoidalCategory

-- mathport name: left_dual
prefix:1024 "ᘁ" => leftDual

-- mathport name: right_dual
postfix:1024 "ᘁ" => rightDual

instance hasRightDualUnit : HasRightDual (𝟙_ C) where rightDual := 𝟙_ C
#align category_theory.has_right_dual_unit CategoryTheory.hasRightDualUnit

instance hasLeftDualUnit : HasLeftDual (𝟙_ C) where leftDual := 𝟙_ C
#align category_theory.has_left_dual_unit CategoryTheory.hasLeftDualUnit

instance hasRightDualLeftDual {X : C} [HasLeftDual X] : HasRightDual ᘁX where rightDual := X
#align category_theory.has_right_dual_left_dual CategoryTheory.hasRightDualLeftDual

instance hasLeftDualRightDual {X : C} [HasRightDual X] : HasLeftDual Xᘁ where leftDual := X
#align category_theory.has_left_dual_right_dual CategoryTheory.hasLeftDualRightDual

@[simp]
theorem leftDual_rightDual {X : C} [HasRightDual X] : ᘁXᘁ = X :=
  rfl
#align category_theory.left_dual_right_dual CategoryTheory.leftDual_rightDual

@[simp]
theorem rightDual_leftDual {X : C} [HasLeftDual X] : (ᘁX)ᘁ = X :=
  rfl
#align category_theory.right_dual_left_dual CategoryTheory.rightDual_leftDual

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The right adjoint mate `fᘁ : Xᘁ ⟶ Yᘁ` of a morphism `f : X ⟶ Y`. -/
def rightAdjointMate {X Y : C} [HasRightDual X] [HasRightDual Y] (f : X ⟶ Y) : Yᘁ ⟶ Xᘁ :=
  (ρ_ _).inv ≫ (𝟙 _ ⊗ η_ _ _) ≫ (𝟙 _ ⊗ f ⊗ 𝟙 _) ≫ (α_ _ _ _).inv ≫ (ε_ _ _ ⊗ 𝟙 _) ≫ (λ_ _).Hom
#align category_theory.right_adjoint_mate CategoryTheory.rightAdjointMate

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The left adjoint mate `ᘁf : ᘁY ⟶ ᘁX` of a morphism `f : X ⟶ Y`. -/
def leftAdjointMate {X Y : C} [HasLeftDual X] [HasLeftDual Y] (f : X ⟶ Y) : ᘁY ⟶ ᘁX :=
  (λ_ _).inv ≫ (η_ (ᘁX) X ⊗ 𝟙 _) ≫ ((𝟙 _ ⊗ f) ⊗ 𝟙 _) ≫ (α_ _ _ _).Hom ≫ (𝟙 _ ⊗ ε_ _ _) ≫ (ρ_ _).Hom
#align category_theory.left_adjoint_mate CategoryTheory.leftAdjointMate

-- mathport name: right_adjoint_mate
notation f "ᘁ" => rightAdjointMate f

-- mathport name: left_adjoint_mate
notation "ᘁ" f => leftAdjointMate f

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem rightAdjointMate_id {X : C} [HasRightDual X] : 𝟙 Xᘁ = 𝟙 (Xᘁ) := by
  simp only [right_adjoint_mate, monoidal_category.tensor_id, category.id_comp,
    coevaluation_evaluation_assoc, category.comp_id, iso.inv_hom_id]
#align category_theory.right_adjoint_mate_id CategoryTheory.rightAdjointMate_id

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem leftAdjointMate_id {X : C} [HasLeftDual X] : (ᘁ𝟙 X) = 𝟙 (ᘁX) := by
  simp only [left_adjoint_mate, monoidal_category.tensor_id, category.id_comp,
    evaluation_coevaluation_assoc, category.comp_id, iso.inv_hom_id]
#align category_theory.left_adjoint_mate_id CategoryTheory.leftAdjointMate_id

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem rightAdjointMate_comp {X Y Z : C} [HasRightDual X] [HasRightDual Y] {f : X ⟶ Y}
    {g : Xᘁ ⟶ Z} :
    fᘁ ≫ g =
      (ρ_ (Yᘁ)).inv ≫
        (𝟙 _ ⊗ η_ X (Xᘁ)) ≫ (𝟙 _ ⊗ f ⊗ g) ≫ (α_ (Yᘁ) Y Z).inv ≫ (ε_ Y (Yᘁ) ⊗ 𝟙 _) ≫ (λ_ Z).Hom :=
  by
  dsimp only [right_adjoint_mate]
  rw [category.assoc, category.assoc, associator_inv_naturality_assoc,
    associator_inv_naturality_assoc, ← tensor_id_comp_id_tensor g, category.assoc, category.assoc,
    category.assoc, category.assoc, id_tensor_comp_tensor_id_assoc, ← left_unitor_naturality,
    tensor_id_comp_id_tensor_assoc]
#align category_theory.right_adjoint_mate_comp CategoryTheory.rightAdjointMate_comp

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem leftAdjointMate_comp {X Y Z : C} [HasLeftDual X] [HasLeftDual Y] {f : X ⟶ Y}
    {g : (ᘁX) ⟶ Z} :
    (ᘁf) ≫ g =
      (λ_ _).inv ≫
        (η_ (ᘁX) X ⊗ 𝟙 _) ≫ ((g ⊗ f) ⊗ 𝟙 _) ≫ (α_ _ _ _).Hom ≫ (𝟙 _ ⊗ ε_ _ _) ≫ (ρ_ _).Hom :=
  by
  dsimp only [left_adjoint_mate]
  rw [category.assoc, category.assoc, associator_naturality_assoc, associator_naturality_assoc, ←
    id_tensor_comp_tensor_id _ g, category.assoc, category.assoc, category.assoc, category.assoc,
    tensor_id_comp_id_tensor_assoc, ← right_unitor_naturality, id_tensor_comp_tensor_id_assoc]
#align category_theory.left_adjoint_mate_comp CategoryTheory.leftAdjointMate_comp

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The composition of right adjoint mates is the adjoint mate of the composition. -/
@[reassoc.1]
theorem comp_rightAdjointMate {X Y Z : C} [HasRightDual X] [HasRightDual Y] [HasRightDual Z]
    {f : X ⟶ Y} {g : Y ⟶ Z} : (f ≫ g)ᘁ = gᘁ ≫ fᘁ :=
  by
  rw [right_adjoint_mate_comp]
  simp only [right_adjoint_mate, comp_tensor_id, iso.cancel_iso_inv_left, id_tensor_comp,
    category.assoc]
  symm; iterate 5 trans; rw [← category.id_comp g, tensor_comp]
  rw [← category.assoc]
  symm; iterate 2 trans; rw [← category.assoc]; apply eq_whisker
  repeat' rw [← id_tensor_comp]; congr 1
  rw [← id_tensor_comp_tensor_id (λ_ (Xᘁ)).Hom g, id_tensor_right_unitor_inv, category.assoc,
    category.assoc, right_unitor_inv_naturality_assoc, ← associator_naturality_assoc, tensor_id,
    tensor_id_comp_id_tensor_assoc, ← associator_naturality_assoc]
  slice_rhs 2 3 =>
    rw [← tensor_comp, tensor_id, category.comp_id, ← category.id_comp (η_ Y (Yᘁ)), tensor_comp]
  rw [← id_tensor_comp_tensor_id _ (η_ Y (Yᘁ)), ← tensor_id]
  repeat' rw [category.assoc]
  rw [pentagon_hom_inv_assoc, ← associator_naturality_assoc, associator_inv_naturality_assoc]
  slice_rhs 5 7 => rw [← comp_tensor_id, ← comp_tensor_id, evaluation_coevaluation, comp_tensor_id]
  rw [associator_inv_naturality_assoc]
  slice_rhs 4 5 => rw [← tensor_comp, left_unitor_naturality, tensor_comp]
  repeat' rw [category.assoc]
  rw [triangle_assoc_comp_right_inv_assoc, ← left_unitor_tensor_assoc, left_unitor_naturality_assoc,
    unitors_equal, ← category.assoc, ← category.assoc]
  simp
#align category_theory.comp_right_adjoint_mate CategoryTheory.comp_rightAdjointMate

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- The composition of left adjoint mates is the adjoint mate of the composition. -/
@[reassoc.1]
theorem comp_leftAdjointMate {X Y Z : C} [HasLeftDual X] [HasLeftDual Y] [HasLeftDual Z] {f : X ⟶ Y}
    {g : Y ⟶ Z} : (ᘁf ≫ g) = (ᘁg) ≫ ᘁf :=
  by
  rw [left_adjoint_mate_comp]
  simp only [left_adjoint_mate, id_tensor_comp, iso.cancel_iso_inv_left, comp_tensor_id,
    category.assoc]
  symm; iterate 5 trans; rw [← category.id_comp g, tensor_comp]
  rw [← category.assoc]
  symm; iterate 2 trans; rw [← category.assoc]; apply eq_whisker
  repeat' rw [← comp_tensor_id]; congr 1
  rw [← tensor_id_comp_id_tensor g (ρ_ (ᘁX)).Hom, left_unitor_inv_tensor_id, category.assoc,
    category.assoc, left_unitor_inv_naturality_assoc, ← associator_inv_naturality_assoc, tensor_id,
    id_tensor_comp_tensor_id_assoc, ← associator_inv_naturality_assoc]
  slice_rhs 2 3 =>
    rw [← tensor_comp, tensor_id, category.comp_id, ← category.id_comp (η_ (ᘁY) Y), tensor_comp]
  rw [← tensor_id_comp_id_tensor (η_ (ᘁY) Y), ← tensor_id]
  repeat' rw [category.assoc]
  rw [pentagon_inv_hom_assoc, ← associator_inv_naturality_assoc, associator_naturality_assoc]
  slice_rhs 5 7 => rw [← id_tensor_comp, ← id_tensor_comp, coevaluation_evaluation, id_tensor_comp]
  rw [associator_naturality_assoc]
  slice_rhs 4 5 => rw [← tensor_comp, right_unitor_naturality, tensor_comp]
  repeat' rw [category.assoc]
  rw [triangle_assoc_comp_left_inv_assoc, ← right_unitor_tensor_assoc,
    right_unitor_naturality_assoc, ← unitors_equal, ← category.assoc, ← category.assoc]
  simp
#align category_theory.comp_left_adjoint_mate CategoryTheory.comp_leftAdjointMate

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Given an exact pairing on `Y Y'`,
we get a bijection on hom-sets `(Y' ⊗ X ⟶ Z) ≃ (X ⟶ Y ⊗ Z)`
by "pulling the string on the left" up or down.

This gives the adjunction `tensor_left_adjunction Y Y' : tensor_left Y' ⊣ tensor_left Y`.

This adjunction is often referred to as "Frobenius reciprocity" in the
fusion categories / planar algebras / subfactors literature.
-/
def tensorLeftHomEquiv (X Y Y' Z : C) [ExactPairing Y Y'] : (Y' ⊗ X ⟶ Z) ≃ (X ⟶ Y ⊗ Z)
    where
  toFun f := (λ_ _).inv ≫ (η_ _ _ ⊗ 𝟙 _) ≫ (α_ _ _ _).Hom ≫ (𝟙 _ ⊗ f)
  invFun f := (𝟙 Y' ⊗ f) ≫ (α_ _ _ _).inv ≫ (ε_ _ _ ⊗ 𝟙 _) ≫ (λ_ _).Hom
  left_inv f := by
    dsimp
    simp only [id_tensor_comp]
    slice_lhs 4 5 => rw [associator_inv_naturality]
    slice_lhs 5 6 => rw [tensor_id, id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
    slice_lhs 2 5 => simp only [← tensor_id, associator_inv_conjugation]
    have c :
      (α_ Y' (Y ⊗ Y') X).Hom ≫
          (𝟙 Y' ⊗ (α_ Y Y' X).Hom) ≫ (α_ Y' Y (Y' ⊗ X)).inv ≫ (α_ (Y' ⊗ Y) Y' X).inv =
        (α_ _ _ _).inv ⊗ 𝟙 _
    pure_coherence
    slice_lhs 4 7 => rw [c]
    slice_lhs 3 5 => rw [← comp_tensor_id, ← comp_tensor_id, coevaluation_evaluation]
    simp only [left_unitor_conjugation]
    coherence
  right_inv f := by
    dsimp
    simp only [id_tensor_comp]
    slice_lhs 3 4 => rw [← associator_naturality]
    slice_lhs 2 3 => rw [tensor_id, tensor_id_comp_id_tensor, ← id_tensor_comp_tensor_id]
    slice_lhs 3 6 => simp only [← tensor_id, associator_inv_conjugation]
    have c :
      (α_ (Y ⊗ Y') Y Z).Hom ≫
          (α_ Y Y' (Y ⊗ Z)).Hom ≫ (𝟙 Y ⊗ (α_ Y' Y Z).inv) ≫ (α_ Y (Y' ⊗ Y) Z).inv =
        (α_ _ _ _).Hom ⊗ 𝟙 Z
    pure_coherence
    slice_lhs 5 8 => rw [c]
    slice_lhs 4 6 => rw [← comp_tensor_id, ← comp_tensor_id, evaluation_coevaluation]
    simp only [left_unitor_conjugation]
    coherence
#align category_theory.tensor_left_hom_equiv CategoryTheory.tensorLeftHomEquiv

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Given an exact pairing on `Y Y'`,
we get a bijection on hom-sets `(X ⊗ Y ⟶ Z) ≃ (X ⟶ Z ⊗ Y')`
by "pulling the string on the right" up or down.
-/
def tensorRightHomEquiv (X Y Y' Z : C) [ExactPairing Y Y'] : (X ⊗ Y ⟶ Z) ≃ (X ⟶ Z ⊗ Y')
    where
  toFun f := (ρ_ _).inv ≫ (𝟙 _ ⊗ η_ _ _) ≫ (α_ _ _ _).inv ≫ (f ⊗ 𝟙 _)
  invFun f := (f ⊗ 𝟙 _) ≫ (α_ _ _ _).Hom ≫ (𝟙 _ ⊗ ε_ _ _) ≫ (ρ_ _).Hom
  left_inv f := by
    dsimp
    simp only [comp_tensor_id]
    slice_lhs 4 5 => rw [associator_naturality]
    slice_lhs 5 6 => rw [tensor_id, tensor_id_comp_id_tensor, ← id_tensor_comp_tensor_id]
    slice_lhs 2 5 => simp only [← tensor_id, associator_conjugation]
    have c :
      (α_ X (Y ⊗ Y') Y).inv ≫
          ((α_ X Y Y').inv ⊗ 𝟙 Y) ≫ (α_ (X ⊗ Y) Y' Y).Hom ≫ (α_ X Y (Y' ⊗ Y)).Hom =
        𝟙 _ ⊗ (α_ _ _ _).Hom
    pure_coherence
    slice_lhs 4 7 => rw [c]
    slice_lhs 3 5 => rw [← id_tensor_comp, ← id_tensor_comp, evaluation_coevaluation]
    simp only [right_unitor_conjugation]
    coherence
  right_inv f := by
    dsimp
    simp only [comp_tensor_id]
    slice_lhs 3 4 => rw [← associator_inv_naturality]
    slice_lhs 2 3 => rw [tensor_id, id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
    slice_lhs 3 6 => simp only [← tensor_id, associator_conjugation]
    have c :
      (α_ Z Y' (Y ⊗ Y')).inv ≫
          (α_ (Z ⊗ Y') Y Y').inv ≫ ((α_ Z Y' Y).Hom ⊗ 𝟙 Y') ≫ (α_ Z (Y' ⊗ Y) Y').Hom =
        𝟙 _ ⊗ (α_ _ _ _).inv
    pure_coherence
    slice_lhs 5 8 => rw [c]
    slice_lhs 4 6 => rw [← id_tensor_comp, ← id_tensor_comp, coevaluation_evaluation]
    simp only [right_unitor_conjugation]
    coherence
#align category_theory.tensor_right_hom_equiv CategoryTheory.tensorRightHomEquiv

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem tensorLeftHomEquiv_naturality {X Y Y' Z Z' : C} [ExactPairing Y Y'] (f : Y' ⊗ X ⟶ Z)
    (g : Z ⟶ Z') :
    (tensorLeftHomEquiv X Y Y' Z') (f ≫ g) = (tensorLeftHomEquiv X Y Y' Z) f ≫ (𝟙 Y ⊗ g) :=
  by
  dsimp [tensor_left_hom_equiv]
  simp only [id_tensor_comp, category.assoc]
#align category_theory.tensor_left_hom_equiv_naturality CategoryTheory.tensorLeftHomEquiv_naturality

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem tensorLeftHomEquiv_symm_naturality {X X' Y Y' Z : C} [ExactPairing Y Y'] (f : X ⟶ X')
    (g : X' ⟶ Y ⊗ Z) :
    (tensorLeftHomEquiv X Y Y' Z).symm (f ≫ g) =
      (𝟙 _ ⊗ f) ≫ (tensorLeftHomEquiv X' Y Y' Z).symm g :=
  by
  dsimp [tensor_left_hom_equiv]
  simp only [id_tensor_comp, category.assoc]
#align category_theory.tensor_left_hom_equiv_symm_naturality CategoryTheory.tensorLeftHomEquiv_symm_naturality

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem tensorRightHomEquiv_naturality {X Y Y' Z Z' : C} [ExactPairing Y Y'] (f : X ⊗ Y ⟶ Z)
    (g : Z ⟶ Z') :
    (tensorRightHomEquiv X Y Y' Z') (f ≫ g) = (tensorRightHomEquiv X Y Y' Z) f ≫ (g ⊗ 𝟙 Y') :=
  by
  dsimp [tensor_right_hom_equiv]
  simp only [comp_tensor_id, category.assoc]
#align category_theory.tensor_right_hom_equiv_naturality CategoryTheory.tensorRightHomEquiv_naturality

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem tensorRightHomEquiv_symm_naturality {X X' Y Y' Z : C} [ExactPairing Y Y'] (f : X ⟶ X')
    (g : X' ⟶ Z ⊗ Y') :
    (tensorRightHomEquiv X Y Y' Z).symm (f ≫ g) =
      (f ⊗ 𝟙 Y) ≫ (tensorRightHomEquiv X' Y Y' Z).symm g :=
  by
  dsimp [tensor_right_hom_equiv]
  simp only [comp_tensor_id, category.assoc]
#align category_theory.tensor_right_hom_equiv_symm_naturality CategoryTheory.tensorRightHomEquiv_symm_naturality

/-- If `Y Y'` have an exact pairing,
then the functor `tensor_left Y'` is left adjoint to `tensor_left Y`.
-/
def tensorLeftAdjunction (Y Y' : C) [ExactPairing Y Y'] : tensorLeft Y' ⊣ tensorLeft Y :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X Z => tensorLeftHomEquiv X Y Y' Z
      homEquiv_naturality_left_symm := fun X X' Z f g => tensorLeftHomEquiv_symm_naturality f g
      homEquiv_naturality_right := fun X Z Z' f g => tensorLeftHomEquiv_naturality f g }
#align category_theory.tensor_left_adjunction CategoryTheory.tensorLeftAdjunction

/-- If `Y Y'` have an exact pairing,
then the functor `tensor_right Y` is left adjoint to `tensor_right Y'`.
-/
def tensorRightAdjunction (Y Y' : C) [ExactPairing Y Y'] : tensorRight Y ⊣ tensorRight Y' :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X Z => tensorRightHomEquiv X Y Y' Z
      homEquiv_naturality_left_symm := fun X X' Z f g => tensorRightHomEquiv_symm_naturality f g
      homEquiv_naturality_right := fun X Z Z' f g => tensorRightHomEquiv_naturality f g }
#align category_theory.tensor_right_adjunction CategoryTheory.tensorRightAdjunction

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/--
If `Y` has a left dual `ᘁY`, then it is a closed object, with the internal hom functor `Y ⟶[C] -`
given by left tensoring by `ᘁY`.
This has to be a definition rather than an instance to avoid diamonds, for example between
`category_theory.monoidal_closed.functor_closed` and
`category_theory.monoidal.functor_has_left_dual`. Moreover, in concrete applications there is often
a more useful definition of the internal hom object than `ᘁY ⊗ X`, in which case the closed
structure shouldn't come from `has_left_dual` (e.g. in the category `FinVect k`, it is more
convenient to define the internal hom as `Y →ₗ[k] X` rather than `ᘁY ⊗ X` even though these are
naturally isomorphic).
-/
def closedOfHasLeftDual (Y : C) [HasLeftDual Y] : Closed Y
    where isAdj := ⟨_, tensorLeftAdjunction (ᘁY) Y⟩
#align category_theory.closed_of_has_left_dual CategoryTheory.closedOfHasLeftDual

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- `tensor_left_hom_equiv` commutes with tensoring on the right -/
theorem tensorLeftHomEquiv_tensor {X X' Y Y' Z Z' : C} [ExactPairing Y Y'] (f : X ⟶ Y ⊗ Z)
    (g : X' ⟶ Z') :
    (tensorLeftHomEquiv (X ⊗ X') Y Y' (Z ⊗ Z')).symm ((f ⊗ g) ≫ (α_ _ _ _).Hom) =
      (α_ _ _ _).inv ≫ ((tensorLeftHomEquiv X Y Y' Z).symm f ⊗ g) :=
  by
  dsimp [tensor_left_hom_equiv]
  simp only [id_tensor_comp]
  simp only [associator_inv_conjugation]
  slice_lhs 2 2 => rw [← id_tensor_comp_tensor_id]
  conv_rhs => rw [← id_tensor_comp_tensor_id, comp_tensor_id, comp_tensor_id]
  simp; coherence
#align category_theory.tensor_left_hom_equiv_tensor CategoryTheory.tensorLeftHomEquiv_tensor

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- `tensor_right_hom_equiv` commutes with tensoring on the left -/
theorem tensorRightHomEquiv_tensor {X X' Y Y' Z Z' : C} [ExactPairing Y Y'] (f : X ⟶ Z ⊗ Y')
    (g : X' ⟶ Z') :
    (tensorRightHomEquiv (X' ⊗ X) Y Y' (Z' ⊗ Z)).symm ((g ⊗ f) ≫ (α_ _ _ _).inv) =
      (α_ _ _ _).Hom ≫ (g ⊗ (tensorRightHomEquiv X Y Y' Z).symm f) :=
  by
  dsimp [tensor_right_hom_equiv]
  simp only [comp_tensor_id]
  simp only [associator_conjugation]
  slice_lhs 2 2 => rw [← tensor_id_comp_id_tensor]
  conv_rhs => rw [← tensor_id_comp_id_tensor, id_tensor_comp, id_tensor_comp]
  simp only [← tensor_id, associator_conjugation]
  simp; coherence
#align category_theory.tensor_right_hom_equiv_tensor CategoryTheory.tensorRightHomEquiv_tensor

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorLeftHomEquiv_symm_coevaluation_comp_id_tensor {Y Y' Z : C} [ExactPairing Y Y']
    (f : Y' ⟶ Z) : (tensorLeftHomEquiv _ _ _ _).symm (η_ _ _ ≫ (𝟙 Y ⊗ f)) = (ρ_ _).Hom ≫ f :=
  by
  dsimp [tensor_left_hom_equiv]
  rw [id_tensor_comp]
  slice_lhs 2 3 => rw [associator_inv_naturality]
  slice_lhs 3 4 => rw [tensor_id, id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
  slice_lhs 1 3 => rw [coevaluation_evaluation]
  simp
#align category_theory.tensor_left_hom_equiv_symm_coevaluation_comp_id_tensor CategoryTheory.tensorLeftHomEquiv_symm_coevaluation_comp_id_tensor

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorLeftHomEquiv_symm_coevaluation_comp_tensor_id {X Y : C} [HasRightDual X]
    [HasRightDual Y] (f : X ⟶ Y) :
    (tensorLeftHomEquiv _ _ _ _).symm (η_ _ _ ≫ (f ⊗ 𝟙 (Xᘁ))) = (ρ_ _).Hom ≫ fᘁ :=
  by
  dsimp [tensor_left_hom_equiv, right_adjoint_mate]
  simp
#align category_theory.tensor_left_hom_equiv_symm_coevaluation_comp_tensor_id CategoryTheory.tensorLeftHomEquiv_symm_coevaluation_comp_tensor_id

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorRightHomEquiv_symm_coevaluation_comp_id_tensor {X Y : C} [HasLeftDual X]
    [HasLeftDual Y] (f : X ⟶ Y) :
    (tensorRightHomEquiv _ (ᘁY) _ _).symm (η_ (ᘁX) X ≫ (𝟙 (ᘁX) ⊗ f)) = (λ_ _).Hom ≫ ᘁf :=
  by
  dsimp [tensor_right_hom_equiv, left_adjoint_mate]
  simp
#align category_theory.tensor_right_hom_equiv_symm_coevaluation_comp_id_tensor CategoryTheory.tensorRightHomEquiv_symm_coevaluation_comp_id_tensor

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorRightHomEquiv_symm_coevaluation_comp_tensor_id {Y Y' Z : C} [ExactPairing Y Y']
    (f : Y ⟶ Z) : (tensorRightHomEquiv _ Y _ _).symm (η_ Y Y' ≫ (f ⊗ 𝟙 Y')) = (λ_ _).Hom ≫ f :=
  by
  dsimp [tensor_right_hom_equiv]
  rw [comp_tensor_id]
  slice_lhs 2 3 => rw [associator_naturality]
  slice_lhs 3 4 => rw [tensor_id, tensor_id_comp_id_tensor, ← id_tensor_comp_tensor_id]
  slice_lhs 1 3 => rw [evaluation_coevaluation]
  simp
#align category_theory.tensor_right_hom_equiv_symm_coevaluation_comp_tensor_id CategoryTheory.tensorRightHomEquiv_symm_coevaluation_comp_tensor_id

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorLeftHomEquiv_id_tensor_comp_evaluation {Y Z : C} [HasLeftDual Z] (f : Y ⟶ ᘁZ) :
    (tensorLeftHomEquiv _ _ _ _) ((𝟙 Z ⊗ f) ≫ ε_ _ _) = f ≫ (ρ_ _).inv :=
  by
  dsimp [tensor_left_hom_equiv]
  rw [id_tensor_comp]
  slice_lhs 3 4 => rw [← associator_naturality]
  slice_lhs 2 3 => rw [tensor_id, tensor_id_comp_id_tensor, ← id_tensor_comp_tensor_id]
  slice_lhs 3 5 => rw [evaluation_coevaluation]
  simp
#align category_theory.tensor_left_hom_equiv_id_tensor_comp_evaluation CategoryTheory.tensorLeftHomEquiv_id_tensor_comp_evaluation

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorLeftHomEquiv_tensor_id_comp_evaluation {X Y : C} [HasLeftDual X] [HasLeftDual Y]
    (f : X ⟶ Y) : (tensorLeftHomEquiv _ _ _ _) ((f ⊗ 𝟙 _) ≫ ε_ _ _) = (ᘁf) ≫ (ρ_ _).inv :=
  by
  dsimp [tensor_left_hom_equiv, left_adjoint_mate]
  simp
#align category_theory.tensor_left_hom_equiv_tensor_id_comp_evaluation CategoryTheory.tensorLeftHomEquiv_tensor_id_comp_evaluation

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorRightHomEquiv_id_tensor_comp_evaluation {X Y : C} [HasRightDual X] [HasRightDual Y]
    (f : X ⟶ Y) : (tensorRightHomEquiv _ _ _ _) ((𝟙 (Yᘁ) ⊗ f) ≫ ε_ _ _) = fᘁ ≫ (λ_ _).inv :=
  by
  dsimp [tensor_right_hom_equiv, right_adjoint_mate]
  simp
#align category_theory.tensor_right_hom_equiv_id_tensor_comp_evaluation CategoryTheory.tensorRightHomEquiv_id_tensor_comp_evaluation

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem tensorRightHomEquiv_tensor_id_comp_evaluation {X Y : C} [HasRightDual X] (f : Y ⟶ Xᘁ) :
    (tensorRightHomEquiv _ _ _ _) ((f ⊗ 𝟙 X) ≫ ε_ X (Xᘁ)) = f ≫ (λ_ _).inv :=
  by
  dsimp [tensor_right_hom_equiv]
  rw [comp_tensor_id]
  slice_lhs 3 4 => rw [← associator_inv_naturality]
  slice_lhs 2 3 => rw [tensor_id, id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
  slice_lhs 3 5 => rw [coevaluation_evaluation]
  simp
#align category_theory.tensor_right_hom_equiv_tensor_id_comp_evaluation CategoryTheory.tensorRightHomEquiv_tensor_id_comp_evaluation

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
-- Next four lemmas passing `fᘁ` or `ᘁf` through (co)evaluations.
theorem coevaluation_comp_rightAdjointMate {X Y : C} [HasRightDual X] [HasRightDual Y] (f : X ⟶ Y) :
    η_ Y (Yᘁ) ≫ (𝟙 _ ⊗ fᘁ) = η_ _ _ ≫ (f ⊗ 𝟙 _) :=
  by
  apply_fun (tensor_left_hom_equiv _ Y (Yᘁ) _).symm
  simp
#align category_theory.coevaluation_comp_right_adjoint_mate CategoryTheory.coevaluation_comp_rightAdjointMate

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem leftAdjointMate_comp_evaluation {X Y : C} [HasLeftDual X] [HasLeftDual Y] (f : X ⟶ Y) :
    (𝟙 X ⊗ ᘁf) ≫ ε_ _ _ = (f ⊗ 𝟙 _) ≫ ε_ _ _ :=
  by
  apply_fun tensor_left_hom_equiv _ (ᘁX) X _
  simp
#align category_theory.left_adjoint_mate_comp_evaluation CategoryTheory.leftAdjointMate_comp_evaluation

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem coevaluation_comp_leftAdjointMate {X Y : C} [HasLeftDual X] [HasLeftDual Y] (f : X ⟶ Y) :
    η_ (ᘁY) Y ≫ ((ᘁf) ⊗ 𝟙 Y) = η_ (ᘁX) X ≫ (𝟙 (ᘁX) ⊗ f) :=
  by
  apply_fun (tensor_right_hom_equiv _ (ᘁY) Y _).symm
  simp
#align category_theory.coevaluation_comp_left_adjoint_mate CategoryTheory.coevaluation_comp_leftAdjointMate

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem rightAdjointMate_comp_evaluation {X Y : C} [HasRightDual X] [HasRightDual Y] (f : X ⟶ Y) :
    (fᘁ ⊗ 𝟙 X) ≫ ε_ X (Xᘁ) = (𝟙 (Yᘁ) ⊗ f) ≫ ε_ Y (Yᘁ) :=
  by
  apply_fun tensor_right_hom_equiv _ X (Xᘁ) _
  simp
#align category_theory.right_adjoint_mate_comp_evaluation CategoryTheory.rightAdjointMate_comp_evaluation

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Transport an exact pairing across an isomorphism in the first argument. -/
def exactPairingCongrLeft {X X' Y : C} [ExactPairing X' Y] (i : X ≅ X') : ExactPairing X Y
    where
  evaluation := (𝟙 Y ⊗ i.Hom) ≫ ε_ _ _
  coevaluation := η_ _ _ ≫ (i.inv ⊗ 𝟙 Y)
  evaluation_coevaluation' := by
    rw [id_tensor_comp, comp_tensor_id]
    slice_lhs 2 3 => rw [associator_naturality]
    slice_lhs 3 4 => rw [tensor_id, tensor_id_comp_id_tensor, ← id_tensor_comp_tensor_id]
    slice_lhs 4 5 => rw [tensor_id_comp_id_tensor, ← id_tensor_comp_tensor_id]
    slice_lhs 2 3 => rw [← associator_naturality]
    slice_lhs 1 2 => rw [tensor_id, tensor_id_comp_id_tensor, ← id_tensor_comp_tensor_id]
    slice_lhs 2 4 => rw [evaluation_coevaluation]
    slice_lhs 1 2 => rw [left_unitor_naturality]
    slice_lhs 3 4 => rw [← right_unitor_inv_naturality]
    simp
  coevaluation_evaluation' := by
    rw [id_tensor_comp, comp_tensor_id]
    simp only [iso.inv_hom_id_assoc, associator_conjugation, category.assoc]
    slice_lhs 2 3 =>
      rw [← tensor_comp]
      simp
    simp
#align category_theory.exact_pairing_congr_left CategoryTheory.exactPairingCongrLeft

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Transport an exact pairing across an isomorphism in the second argument. -/
def exactPairingCongrRight {X Y Y' : C} [ExactPairing X Y'] (i : Y ≅ Y') : ExactPairing X Y
    where
  evaluation := (i.Hom ⊗ 𝟙 X) ≫ ε_ _ _
  coevaluation := η_ _ _ ≫ (𝟙 X ⊗ i.inv)
  evaluation_coevaluation' := by
    rw [id_tensor_comp, comp_tensor_id]
    simp only [iso.inv_hom_id_assoc, associator_conjugation, category.assoc]
    slice_lhs 3 4 =>
      rw [← tensor_comp]
      simp
    simp
  coevaluation_evaluation' := by
    rw [id_tensor_comp, comp_tensor_id]
    slice_lhs 3 4 => rw [← associator_inv_naturality]
    slice_lhs 2 3 => rw [tensor_id, id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
    slice_lhs 1 2 => rw [id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
    slice_lhs 3 4 => rw [associator_inv_naturality]
    slice_lhs 4 5 => rw [tensor_id, id_tensor_comp_tensor_id, ← tensor_id_comp_id_tensor]
    slice_lhs 2 4 => rw [coevaluation_evaluation]
    slice_lhs 1 2 => rw [right_unitor_naturality]
    slice_lhs 3 4 => rw [← left_unitor_inv_naturality]
    simp
#align category_theory.exact_pairing_congr_right CategoryTheory.exactPairingCongrRight

/-- Transport an exact pairing across isomorphisms. -/
def exactPairingCongr {X X' Y Y' : C} [ExactPairing X' Y'] (i : X ≅ X') (j : Y ≅ Y') :
    ExactPairing X Y :=
  haveI : exact_pairing X' Y := exact_pairing_congr_right j
  exact_pairing_congr_left i
#align category_theory.exact_pairing_congr CategoryTheory.exactPairingCongr

/-- Right duals are isomorphic. -/
def rightDualIso {X Y₁ Y₂ : C} (_ : ExactPairing X Y₁) (_ : ExactPairing X Y₂) : Y₁ ≅ Y₂
    where
  Hom := @rightAdjointMate C _ _ X X ⟨Y₂⟩ ⟨Y₁⟩ (𝟙 X)
  inv := @rightAdjointMate C _ _ X X ⟨Y₁⟩ ⟨Y₂⟩ (𝟙 X)
  hom_inv_id' := by rw [← comp_right_adjoint_mate, category.comp_id, right_adjoint_mate_id]
  inv_hom_id' := by rw [← comp_right_adjoint_mate, category.comp_id, right_adjoint_mate_id]
#align category_theory.right_dual_iso CategoryTheory.rightDualIso

/-- Left duals are isomorphic. -/
def leftDualIso {X₁ X₂ Y : C} (p₁ : ExactPairing X₁ Y) (p₂ : ExactPairing X₂ Y) : X₁ ≅ X₂
    where
  Hom := @leftAdjointMate C _ _ Y Y ⟨X₂⟩ ⟨X₁⟩ (𝟙 Y)
  inv := @leftAdjointMate C _ _ Y Y ⟨X₁⟩ ⟨X₂⟩ (𝟙 Y)
  hom_inv_id' := by rw [← comp_left_adjoint_mate, category.comp_id, left_adjoint_mate_id]
  inv_hom_id' := by rw [← comp_left_adjoint_mate, category.comp_id, left_adjoint_mate_id]
#align category_theory.left_dual_iso CategoryTheory.leftDualIso

@[simp]
theorem rightDualIso_id {X Y : C} (p : ExactPairing X Y) : rightDualIso p p = Iso.refl Y :=
  by
  ext
  simp only [right_dual_iso, iso.refl_hom, right_adjoint_mate_id]
#align category_theory.right_dual_iso_id CategoryTheory.rightDualIso_id

@[simp]
theorem leftDualIso_id {X Y : C} (p : ExactPairing X Y) : leftDualIso p p = Iso.refl X :=
  by
  ext
  simp only [left_dual_iso, iso.refl_hom, left_adjoint_mate_id]
#align category_theory.left_dual_iso_id CategoryTheory.leftDualIso_id

/-- A right rigid monoidal category is one in which every object has a right dual. -/
class RightRigidCategory (C : Type u) [Category.{v} C] [MonoidalCategory.{v} C] where
  [rightDual : ∀ X : C, HasRightDual X]
#align category_theory.right_rigid_category CategoryTheory.RightRigidCategory

/-- A left rigid monoidal category is one in which every object has a right dual. -/
class LeftRigidCategory (C : Type u) [Category.{v} C] [MonoidalCategory.{v} C] where
  [leftDual : ∀ X : C, HasLeftDual X]
#align category_theory.left_rigid_category CategoryTheory.LeftRigidCategory

attribute [instance] right_rigid_category.right_dual

attribute [instance] left_rigid_category.left_dual

/-- Any left rigid category is monoidal closed, with the internal hom `X ⟶[C] Y = ᘁX ⊗ Y`.
This has to be a definition rather than an instance to avoid diamonds, for example between
`category_theory.monoidal_closed.functor_category` and
`category_theory.monoidal.left_rigid_functor_category`. Moreover, in concrete applications there is
often a more useful definition of the internal hom object than `ᘁY ⊗ X`, in which case the monoidal
closed structure shouldn't come the rigid structure (e.g. in the category `FinVect k`, it is more
convenient to define the internal hom as `Y →ₗ[k] X` rather than `ᘁY ⊗ X` even though these are
naturally isomorphic). -/
def monoidalClosedOfLeftRigidCategory (C : Type u) [Category.{v} C] [MonoidalCategory.{v} C]
    [LeftRigidCategory C] : MonoidalClosed C where closed' X := closedOfHasLeftDual X
#align category_theory.monoidal_closed_of_left_rigid_category CategoryTheory.monoidalClosedOfLeftRigidCategory

/-- A rigid monoidal category is a monoidal category which is left rigid and right rigid. -/
class RigidCategory (C : Type u) [Category.{v} C] [MonoidalCategory.{v} C] extends
  RightRigidCategory C, LeftRigidCategory C
#align category_theory.rigid_category CategoryTheory.RigidCategory

end CategoryTheory


import .basic

namespace data.containers
namespace rbtree

open color

/-- An insert_result is a generalization of the tree to allow
a node with 2-keys and 3-children each of which should have the
same height.

This is used
Specifically, it is either a tree that respects the red-black rules,
or a the concatenation of three trees with the same height.
-/
inductive insert_result (E : Type _)
| tree : Π (t : rbtree E), insert_result
-- When inserting into a binary tree that respects the ordering
-- and red-black color rules, by construction we know that the trees
-- are in ascending order, either the first or third tree are colored
-- black, and the center node is colored black.
| triple : rbtree E → E → rbtree E →  E → rbtree E → insert_result

namespace insert_result
section
parameters {E:Type _}

/--
Convert an insert result to a tree.

N.B. This may increase the black-height, so should only be called in contexts
where that matters (i.e. at the roto.)
-/
def as_tree : insert_result E → rbtree E
| (tree u) := u
| (triple l x c y r) :=
  match l with
  | bin red ll lx lr := bin black (bin black ll lx lr) x (bin black c y r)
  | _ := bin black (bin red l x c) y r
  end

def to_list : insert_result E → list E
| (tree t) := t.to_list
| (triple l x c y r) := l.to_list ++ [x] ++ c.to_list ++ [y] ++ r.to_list

parameters [has_preordering E]

/-- Check whether a insert_result respects the ordering relation. -/
def is_ordered : insert_result E → Prop
| (tree t) := t.is_ordered
| (triple l x c y r) :=
   l.is_ordered
   ∧ all_lt l x
   ∧ all_gt c x
   ∧ c.is_ordered ∧ has_ordering.cmp x y = ordering.lt
   ∧ all_lt c y
   ∧ all_gt r y
   ∧ r.is_ordered

instance (r : insert_result E) : decidable (is_ordered r) :=
begin
  cases r; simp [is_ordered]; apply_instance,
end

/- Return true if keys on right spine of rbtree are less then k. -/
def all_lt : insert_result E → E → Prop
| (tree t) a := t.all_lt a
| (triple l x c y r) a :=
  has_ordering.cmp y a = ordering.lt ∧ r.all_lt a

/- Return true if keys on right spine of rbtree are less then k. -/
def all_gt : insert_result E → E → Prop
| (tree t) a := t.all_gt a
| (triple l x c y r) a :=
  has_ordering.cmp a x = ordering.lt ∧ l.all_gt a

end
end insert_result

section insert_def
parameters {E:Type _}

open insert_result

def balanceL : color → insert_result E → E → rbtree E → insert_result E
-- In this case, the caller should be able to guarantee that co is black, so the
-- black depth of the tree should not change.
| co (triple ll lx lc ly lr) x r :=
  tree (bin red (bin black ll lx lc) ly (bin black lr x r))
| co (tree l) x r :=
  match (co, l) with
  | (red, bin red ll lx lr) := triple ll lx lr x r
  | _ := tree (bin co l x r)
  end

def balanceR : color → rbtree E → E → insert_result E → insert_result E
-- In this case co is guaranteed to be black, so the
-- black depth of the tree should not change.
| co l x (triple rl rx rc ry rr) :=
  tree (bin red (bin black l x rl) rx (bin black rc ry rr))
| co l x (tree r) :=
  match (co, r) with
  | (red, bin red rl rx rr) := triple l x rl rx rr
  | _ := tree (bin co l x r)
  end

parameters [has_preordering E]

def insert_core (y : E) : rbtree E → insert_result E
| empty := tree (bin red empty y empty)
| (bin c l x r) :=
  match has_ordering.cmp y x with
  | ordering.lt := balanceL c (insert_core l) x r
  | ordering.eq := tree (bin c l y r)
  | ordering.gt := balanceR c l x (insert_core r)
  end

def insert (y : E) (t : rbtree E) : rbtree E :=
  (insert_core y t).as_tree

end insert_def

-----------------------------------------------------------------------
-- to_list

section to_list_theorems
parameters {E:Type _}

theorem to_list_balanceL (c : color) (l : insert_result E) (x : E) (r : rbtree E)
: (balanceL c l x r).to_list  = l.to_list ++ [x] ++ r.to_list :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc }; cases c, };
  simp [*, balanceL, insert_result.to_list, to_list],
end

theorem to_list_balanceR
(c : color) (l : rbtree E) (x : E) (r : insert_result E)
: (balanceR c l x r).to_list = l.to_list ++ [x] ++ r.to_list :=
begin
  cases r with t l x tc y r;
    try {
      cases t with rc rl rx rr; try { cases rc };
        cases c,
    };
  simp [*, balanceR, insert_result.to_list, to_list],
end

theorem to_list_as_tree (r : insert_result E)
: r.as_tree.to_list = r.to_list :=
begin
  cases r with t tl tx tc ty tr;
    try { cases tl with tlc tll tlx tlr;  try { cases tlc }, };
    simp [insert_result.as_tree, rbtree.tree_color, insert_result.to_list, to_list],
end

parameters [has_preordering E]

theorem to_list_insert_core (y : E) (t : rbtree E)
: is_ordered t
→ (insert_core y t).to_list
    = t.to_list.filter (key_is_lt y) ++ y :: t.to_list.filter (key_is_gt y) :=
begin
  induction t,
  case empty {
    intros,
    simp [insert_core, insert_result.to_list, to_list],
  },
  case bin c l x r l_ind r_ind {
    simp [is_ordered, insert_core, to_list, list.filter, key_is_lt, key_is_gt],

    have g1 : (ordering.gt ≠ ordering.lt), exact dec_trivial,
    have g2 : ordering.lt ≤ ordering.eq, exact dec_trivial,
    have g3 : ordering.eq ≤ ordering.eq, exact dec_trivial,
    have g4 : ordering.eq ≠ ordering.lt, exact dec_trivial,

    have cmp_x_y_eq : has_ordering.cmp x y = (has_ordering.cmp y x).swap,
    { rw [has_preordering.swap_cmp], },

    intros iso_l iso_r all_gt_r_x all_lt_l_x,
    have all_lt_r_key := all_lt_congr l x y,
    have all_gt_r_key := all_gt_congr r y x,
    have l_lt := filter_lt_of_all_lt l y,
    have l_gt := filter_gt_of_all_lt l y,
    have r_lt := filter_lt_of_all_gt r y,
    have r_gt := filter_gt_of_all_gt r y,
    destruct (has_ordering.cmp y x); intro cmp_y_x;
      simp [cmp_y_x, ordering.swap] at cmp_x_y_eq,
    { simp [insert_core, *, to_list_balanceL, l_ind], },
    { simp [insert_core, *, insert_result.to_list, to_list ], },
    { simp [insert_core, *, to_list_balanceR, r_ind], },
  },
end

theorem to_list_insert (y : E) (t : rbtree E) : is_ordered t
 → to_list (insert y t)
    = t.to_list.filter (key_is_lt y) ++ y :: t.to_list.filter (key_is_gt y) :=
begin
  intros,
  simp [insert, to_list_as_tree, to_list_insert_core, *],
end

theorem insert_eq (y : E)
: ∀{t u : rbtree E},
   is_ordered t
   → is_ordered u
   → t.to_list = u.to_list
   → to_list (insert y t) = to_list (insert y t) :=
begin
  intros x y x_order y_order x_eq_y,
  simp [to_list_insert, *],
end

end to_list_theorems

-----------------------------------------------------------------------
-- is_ordered

section is_ordered_theorems
parameters {E:Type _}

parameters [has_preordering E]
local attribute [simp] balanceL balanceR insert_result.is_ordered is_ordered
  insert_result.all_lt all_lt insert_result.all_gt all_gt
  insert_core

section balanceL
parameters (c : color) (l : insert_result E) (y : E) (r : rbtree E)

theorem all_lt_balanceL (a : E)
  (all_lt_l : l.all_lt a)
  (y_lt_bnd : has_ordering.cmp y a = ordering.lt)
  (all_lt_r : all_lt r a)
: (balanceL c l y r).all_lt a :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc }; cases c, };
  try { simp at all_lt_l, simp [*], },
end

theorem all_gt_balanceL (a : E)
  (iso : l.is_ordered)
  (a_lt_y : has_ordering.cmp a y = ordering.lt)
  (all_gt_l : l.all_gt a)
: (balanceL c l y r).all_gt a :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc }; cases c, };
  try { simp at all_gt_l, simp [*], },
  simp at iso,
  apply has_preordering.lt_of_lt_of_lt a tx ty; simp [*],
end

theorem is_ordered_balanceL
  (l_iso : l.is_ordered)
  (all_lt_l_y : l.all_lt y)
  (all_gt_r_y : all_gt r y)
  (iso_r : is_ordered r)
: (balanceL c l y r).is_ordered :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc }; cases c, };
  try {   simp at l_iso all_lt_l_y, simp [*],},
end
end balanceL

section balanceR
parameters (c : color) (l : rbtree E) (y : E) (r : insert_result E)

theorem all_lt_balanceR (a : E)
  (iso : r.is_ordered)
  (y_lt_a : has_ordering.cmp y a = ordering.lt)
  (all_lt_r_a : r.all_lt a)
: (balanceR c l y r).all_lt a :=
begin
  cases r with t tl tx tc ty tr;
    try { cases t with rc rl rx rr; try { cases rc }; cases c, };
  try { simp at all_lt_r_a, simp [*], },
  simp at iso,
  apply has_preordering.lt_of_lt_of_lt tx ty a; simp [*],
end

theorem all_gt_balanceR (a : E)
  (a_lt_y : has_ordering.cmp a y = ordering.lt)
  (all_gt_l : all_gt l a)
  (all_gt_r : r.all_gt a)
: (balanceR c l y r).all_gt a :=
begin
  cases r with t tl tx tc ty tr;
    try { cases t with rc rl rx rr; try { cases rc }; cases c, };
  try { simp at all_gt_r, simp[*], },
end

theorem is_ordered_balanceR
  (l_iso : is_ordered l)
  (all_lt_l_y : all_lt l y)
  (all_gt_r_y : r.all_gt y)
  (r_iso : r.is_ordered)
: (balanceR c l y r).is_ordered :=
begin
  cases r with t tl tx tc ty tr;
    try { cases t with rc rl rx rr; try { cases rc }; cases c, };
  try { simp at all_gt_r_y r_iso, simp[*], },
end
end balanceR

theorem is_ordered_as_tree {r : insert_result E}
  (iso : r.is_ordered)
: r.as_tree.is_ordered :=
begin
  cases r with t tl tx tc ty tr;
    try { cases tl with lc ll lx lr; try { cases lc}, };
  simp at iso; simp [insert_result.as_tree, *],
end

theorem insert_core_preserves (y : E) {t : rbtree E}
  (iso : is_ordered t)
: (insert_core y t).is_ordered
∧ (∀ (a : E), has_ordering.cmp y a = ordering.lt
            → t.all_lt a
            → (insert_core y t).all_lt a)
∧ (∀ (a:E), has_ordering.cmp a y = ordering.lt
               → t.all_gt a
               → (insert_core y t).all_gt a) :=
begin
  induction t,
  case empty {
    intros,
    simp,
  },
  case bin c l x r l_ind r_ind {
    simp at iso,
    simp only [iso, true_implies_iff] at l_ind r_ind,
    have l_all_lt := l_ind.right.left,
    have r_all_gt := r_ind.right.right,
    destruct (has_ordering.cmp y x);
      intro cmp_y_s;
      simp only [cmp_y_s, insert_core, all_lt],
    { apply and.intro,
      { apply is_ordered_balanceL,
        all_goals { simp [*], },
      },
      apply and.intro,
      { intros a y_lt_a pr,
        apply all_lt_balanceL,
        apply l_all_lt,
        all_goals { try { simp [*],} },
        apply all_lt_congr l x a; simp[*],
      },
      { intros a a_lt_y pr,
        simp at pr,
        apply all_gt_balanceL,
        all_goals { simp [*], },
      }
    },
    { apply and.intro,
      { simp [*],
        apply and.intro,
        { apply all_gt_congr r y x; simp [*], },
        { have h0 := has_preordering.eq_symm y x,
          apply all_lt_congr l x y; simp [*],
        },
      },
      apply and.intro,
      { intros a y_lt_a x_lt_a, simp [*], },
      { intros a a_lt_y gt_a, simp at gt_a, simp [*], },
    },
    { rw [has_preordering.gt_lt_symm] at cmp_y_s,
      apply and.intro,
      { apply is_ordered_balanceR; simp[*], },
      apply and.intro,
      { intros a y_lt_a x_lt_a,
        apply all_lt_balanceR; simp[*],
      },
      { intros a a_lt_y pr,
        simp at pr,
        apply all_gt_balanceR; try { simp[*] },
        apply r_all_gt; try { simp[*] },
        apply all_gt_congr r a x; try { simp[*] },
      },
    },
  },
end

theorem is_ordered_insert (y : E) (t : rbtree E)
: is_ordered t → is_ordered (insert y t) :=
begin
  intro iso,
  simp [insert],
  apply is_ordered_as_tree,
  have h := insert_core_preserves y iso,
  simp[h],
end
end is_ordered_theorems

-----------------------------------------------------------------------
-- to_list

namespace insert_result
section
parameters {E:Type _}

def black_height : insert_result E → ℕ
| (triple l _ _ _ _) := l.black_height
| (tree t) := t.black_height

def well_formed : insert_result E → Prop
| (triple l x c y r) :=
  l.well_formed
  ∧ c.well_formed
  ∧ r.well_formed
  ∧ l.black_height = c.black_height
  ∧ c.black_height = r.black_height
  ∧ c.tree_color = black
| (tree t) := t.well_formed

end
end insert_result

section is_well_formed_theorems
parameters {E:Type _}
local attribute [simp] balanceL balanceR insert_result.well_formed well_formed
  rbtree.tree_color insert_result.black_height black_height
  insert_result.as_tree nat.add_succ
  insert_core

theorem succ_eq_succ (m n :ℕ) : (nat.succ m = nat.succ n) ↔ (m = n) :=
  iff.intro nat.succ.inj (congr_arg nat.succ)

local attribute [simp] succ_eq_succ

theorem well_formed_balanceL_black (l : insert_result E) (x : E) (r : rbtree E)
(l_wf : l.well_formed)
(r_wf : r.well_formed)
(l_ht_eq_r_ht : r.black_height = l.black_height)
: (balanceL black l x r).well_formed  :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc } };
    simp at l_wf l_ht_eq_r_ht;
    simp [*],
end

theorem well_formed_balanceL_red (l : insert_result E) (x : E) (r : rbtree E)
(l_wf : l.well_formed)
(r_wf : r.well_formed)
(l_ht_eq_r_ht : r.black_height = l.black_height)
(r_black : r.tree_color = black)
: (balanceL red l x r).well_formed  :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc } };
    simp at l_wf;
    simp [*],
end

theorem well_formed_balanceR_black (l : rbtree E) (x : E) (r : insert_result E)
(l_wf : l.well_formed)
(r_wf : r.well_formed)
(l_ht_eq_r_ht : l.black_height = r.black_height)
: (balanceR black l x r).well_formed  :=
begin
  cases r with t tl tx tc ty tr;
    try { cases t with rc rl rx rr; try { cases rc } };
    simp at r_wf;
    simp [*],
end

theorem well_formed_balanceR_red (l : rbtree E) (x : E) (r : insert_result E)
(l_wf : l.well_formed)
(r_wf : r.well_formed)
(l_ht_eq_r_ht : l.black_height = r.black_height)
(l_black : l.tree_color = black)
: (balanceR red l x r).well_formed  :=
begin
  cases r with t tl tx tc ty tr;
    try { cases t with rc rl rx rr; try { cases rc } };
    simp at r_wf;
    try { simp [*], },
end

theorem black_height_balanceL_black (l : insert_result E) (x : E) (r : rbtree E)
: (balanceL black l x r).black_height = l.black_height + 1 :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc } };
    simp [*],
end

theorem black_height_balanceL_red (l : rbtree E) (x : E) (r : rbtree E)
: (balanceL red (insert_result.tree l) x r).black_height = l.black_height :=
begin
  cases l with t tl tx tc ty tr;
    try { cases t with lc ll lx lr; try { cases lc } };
    simp [*],
end

theorem black_height_balanceR_black (l : rbtree E) (x : E) (r : insert_result E)
: (balanceR black l x r).black_height = l.black_height + 1 :=
begin
  cases r with t tl tx tc ty tr;
    try { cases t with rc rl rx rr; try { cases rc } };
    simp [*],
end

theorem black_height_balanceR_red (l : rbtree E) (x : E) (r : rbtree E)
: (balanceR red l x (insert_result.tree r)).black_height = l.black_height :=
begin
  cases r with t tl tx tc ty tr;
    try { cases t with rc rl rx rr; try { cases rc } };
    simp [*],
end

theorem well_formed_as_tree (r : insert_result E)
: r.well_formed → r.as_tree.well_formed :=
begin
  intro r_wf,
  cases r with t tl tx tc ty tr;
    try { cases tl with tlc tll tlx tlr; try { cases tlc }, };
    try { simp at r_wf, simp[r_wf], };
    cc,
end

-- To simplify insert_core, we need a restricted definitions that work
-- when the root node of the tree is colored black.  This allows us
-- to make balanceL, balanceR, and insert_core return rbtrees rather
-- that insert_result.
section

def balanceL_black : insert_result E → E → rbtree E → rbtree E
| (insert_result.triple ll lx lc ly lr) x r :=
  bin red (bin black ll lx lc) ly (bin black lr x r)
| (insert_result.tree l) x r := bin black l x r

def balanceR_black : rbtree E → E → insert_result E → rbtree E
| l x (insert_result.triple rl rx rc ry rr) :=
 bin red (bin black l x rl) rx (bin black rc ry rr)
| l x (insert_result.tree r) := bin black l x r

parameters [has_preordering E]

def insert_core_black (y : E) : rbtree E → rbtree E
| empty := bin red empty y empty
| (bin c l x r) :=
  match has_ordering.cmp y x with
  | ordering.lt := balanceL_black (insert_core y l) x r
  | ordering.eq := bin c l y r
  | ordering.gt := balanceR_black l x (insert_core y r)
  end

theorem insert_core_black_eq (y : E) (t : rbtree E)
: t.tree_color = black → insert_core y t = insert_result.tree (insert_core_black y t) :=
begin
  intro isb,
  cases t with c l x r,
  { simp [insert_core_black], },
  { simp at isb,
    destruct (has_ordering.cmp y x); intro cmp_y_x;
      simp [*, insert_core_black],
    { cases (insert_core y l); simp [balanceL_black], },
    { cases (insert_core y r); simp [balanceR_black], },
  },
end
end

parameters [has_preordering E]

local attribute [simp]
  black_height_balanceL_black
  black_height_balanceL_red
  black_height_balanceR_black
  black_height_balanceR_red

theorem black_height_insert_core (y : E) (t : rbtree E)
: t.well_formed → (insert_core y t).black_height = t.black_height :=
begin
  induction t,
  case empty {
    intros,
    simp,
  },
  case bin c l x r l_ind r_ind {
    cases c,
    case red {
      destruct (has_ordering.cmp y x); intro cmp_y_x; simp [cmp_y_x],
      { intros l_wf r_wf l_isb r_isb l_ht_eq,
        simp only [insert_core_black_eq y l l_isb, insert_result.black_height ] at l_ind,
        simp only [*, insert_core_black_eq y l l_isb, black_height_balanceL_red],
      },
      { intros l_wf r_wf l_isb r_isb l_ht_eq,
        simp only [*, insert_core_black_eq y r r_isb, black_height_balanceR_red],
      },
    },
    case black {
      destruct (has_ordering.cmp y x); intro cmp_y_x; simp [cmp_y_x],
      { intros l_wf r_wf l_ht_eq,
        simp only [*],
      },
    }
  },
end

local attribute [simp] black_height_insert_core

theorem well_formed_insert_core (y : E) (t : rbtree E)
: t.well_formed → (insert_core y t).well_formed :=
begin
  induction t,
  case empty {
    intros,
    simp,
  },
  case bin c l x r l_ind r_ind {
    cases c,
    case red {
      destruct (has_ordering.cmp y x);
        intro cmp_y_x;
        simp [cmp_y_x];
        intros,
      { apply well_formed_balanceL_red; simp [*], },
      { simp[*], },
      { apply well_formed_balanceR_red; simp[*], },
    },
    case black {
      destruct (has_ordering.cmp y x);
        intro cmp_y_x;
        simp [cmp_y_x];
        intros,
      { apply well_formed_balanceL_black; simp [*], },
      { simp[*], },
      { apply well_formed_balanceR_black; simp[*], },
    }
  },
end

theorem well_formed_insert (y : E) (t : rbtree E) : t.well_formed
 → (insert y t).well_formed :=
begin
  intros,
  apply well_formed_as_tree,
  apply well_formed_insert_core,
  assumption,
end

end is_well_formed_theorems

end rbtree
end data.containers


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Predicates.
-/
import .util .id .reference .graph .compute_grad
open list

namespace certigrad

def is_downstream (cost : ID) : reference → list node → Prop
| _   [] := false

| tgt (⟨ref, parents, _⟩ :: nodes) :=
  if ref.1 = cost
  then true
  else (tgt ∈ parents ∧ is_downstream ref nodes) ∨ is_downstream tgt nodes

instance decidable_is_downstream (cost : ID) : Π (tgt : reference) (nodes : list node), decidable (is_downstream cost tgt nodes)
| _   [] := decidable.false

| tgt (⟨ref, parents, _⟩ :: nodes) :=
  show decidable (if ref.1 = cost then true else (tgt ∈ parents ∧ is_downstream cost ref nodes) ∨ is_downstream cost tgt nodes), from
  have H₁ : decidable (is_downstream cost ref nodes), from begin apply decidable_is_downstream end,
  have H₂ : decidable (is_downstream cost tgt nodes), from begin apply decidable_is_downstream end,
  by tactic.apply_instance

def all_parents_in_env : Π (inputs : env) (nodes : list node), Prop
| _   [] := true

| inputs (⟨ref, parents, _⟩ :: nodes) :=
  (∀ (parent : reference), parent ∈ parents → env.has_key parent inputs)
  ∧ (∀ (x : T ref.2), all_parents_in_env (env.insert ref x inputs) nodes)

def all_costs_scalars (costs : list ID) : Π (nodes : list node), Prop
| [] := true
| (⟨ref, _, _⟩ :: nodes) := (ref.1 ∈ costs → ref.2 = []) ∧ all_costs_scalars nodes

-- We group the decidable properties
structure well_formed_at (costs : list ID) (nodes : list node) (inputs : env) (tgt : reference) : Prop :=
  (uids : uniq_ids nodes inputs)
  (ps_in_env : all_parents_in_env inputs nodes)
  (costs_scalars : all_costs_scalars costs nodes)
  (m_contains_tgt : env.has_key tgt inputs)
  (tgt_cost_scalar : tgt.1 ∈ costs → tgt.2 = [])

def grads_exist_at : list node → env → reference → Prop
| [] _ _ := true

| (⟨ref, parents, operator.det op⟩ :: nodes) m tgt  :=
  let m' := env.insert ref (op^.f (env.get_ks parents m)) m in
  grads_exist_at nodes m' tgt
  ∧ (tgt ∈ parents → op^.pre (env.get_ks parents m) ∧ grads_exist_at nodes m' ref)

| (⟨ref, parents, operator.rand op⟩ :: nodes) m tgt  :=
  let m' := (λ (y : T ref.2), env.insert ref y m) in
  (tgt ∈ parents → op^.pre (env.get_ks parents m)) ∧ (∀ y, grads_exist_at nodes (m' y) tgt)

def pdfs_exist_at : list node → env → Prop
| [] _ := true

| (⟨ref, parents, operator.det op⟩ :: nodes) m := pdfs_exist_at nodes (env.insert ref (op^.f (env.get_ks parents m)) m )

| (⟨ref, parents, operator.rand op⟩ :: nodes) m :=
  let m' := (λ (y : T ref.2), env.insert ref y m) in
  (op^.pre (env.get_ks parents m)) ∧ (∀ y, pdfs_exist_at nodes (m' y))

-- TODO(dhs): these conditions are really nitty-gritty
noncomputable def can_differentiate_under_integrals (costs : list ID) : list node → env → reference → Prop
| [] _ _ := true

| (⟨ref, parents, operator.det op⟩ :: nodes) inputs tgt  :=
  let inputs' := env.insert ref (op^.f (env.get_ks parents inputs)) inputs in
  can_differentiate_under_integrals nodes inputs' tgt
  ∧ (tgt ∈ parents → can_differentiate_under_integrals nodes (env.insert ref (op^.f (env.get_ks parents inputs)) inputs) ref)

| (⟨ref, parents, operator.rand op⟩ :: nodes) inputs tgt  :=
  let θ : T tgt.2 := env.get tgt inputs in
  let g : T ref.2 → T tgt.2 → ℝ :=
  (λ (x : T ref.2) (θ₀ : T tgt.2),
      E (graph.to_dist (λ (inputs : env), ⟦sum_costs inputs costs⟧)
                       (env.insert ref x (env.insert tgt θ₀ inputs))
                       nodes)
        dvec.head) in
  let next_inputs := (λ (y : T ref.2), env.insert ref y inputs) in
-- Note: these conditions are redundant, but it is convenient to collect all the variations we need in one place
 (T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), rand.op.pdf op (env.get_ks parents (env.insert tgt θ₀ inputs)) x ⬝ g x θ₀) θ

    ∧ (T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), ∇ (λ (θ₁ : T (tgt.snd)), rand.op.pdf op (env.get_ks parents (env.insert tgt θ₁ inputs)) x ⬝ g x θ₁) θ₀) θ
       ∧ T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), ∇ (λ (θ₁ : T (tgt.snd)), rand.op.pdf op (env.get_ks parents (env.insert tgt θ inputs)) x ⬝ g x θ₁) θ₀) θ)

    ∧ (∀ (idx : ℕ), at_idx parents idx tgt →
    T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ inputs)) idx) x ⬝ g x θ) θ)
   ∧ (∀ (idx : ℕ),  at_idx parents idx tgt →
    T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)),
                                         ∇ (λ (θ₀ : T (tgt.snd)), rand.op.pdf op (dvec.update_at θ₀ (env.get_ks parents (env.insert tgt θ inputs)) idx) x ⬝ g x θ) θ₀) θ))
∧ (∀ y, can_differentiate_under_integrals nodes (next_inputs y) tgt)

def all_pdfs_std : Π (nodes : list node), Prop
| [] := true
| (⟨ref, parents, operator.det op⟩ :: nodes) := all_pdfs_std nodes
| (⟨(ref, .(shape)), [], operator.rand (rand.op.mvn_std shape)⟩ :: nodes) := all_pdfs_std nodes
| (⟨(ref, .(shape)), [(parent₁, .(shape)), (parent₂, .(shape))], operator.rand (rand.op.mvn shape)⟩ :: nodes) := false

lemma all_pdfs_std_det : Π (ref : reference) (parents : list reference) (op : det.op parents^.p2 ref.2) (nodes : list node),
  all_pdfs_std (⟨ref, parents, operator.det op⟩ :: nodes) = all_pdfs_std nodes
| (i, s) [] op nodes := rfl
| (i, s) [(i', s')] op nodes := rfl
| (i, s) [(i', s'), (i'', s'')] op nodes := rfl
| (i, s) ((i', s') :: (i'', s'') :: a :: iss) op nodes := rfl

noncomputable def can_diff_under_ints_pdfs_std (costs : list ID) : Π (nodes : list node) (m : env) (tgt : reference), Prop
| [] _ _ := true

| (⟨ref, parents, operator.det op⟩ :: nodes) inputs tgt  :=
  let inputs' := env.insert ref (op^.f (env.get_ks parents inputs)) inputs in
  can_diff_under_ints_pdfs_std nodes inputs' tgt
  ∧ (tgt ∈ parents → can_diff_under_ints_pdfs_std nodes (env.insert ref (op^.f (env.get_ks parents inputs)) inputs) ref)

| (⟨ref, parents, operator.rand op⟩ :: nodes) inputs tgt  :=
  let θ : T tgt.2 := env.get tgt inputs in
  let g : T ref.2 → T tgt.2 → ℝ :=
  (λ (x : T ref.2) (θ₀ : T tgt.2),
      E (graph.to_dist (λ (inputs : env), ⟦sum_costs inputs costs⟧)
                       (env.insert ref x (env.insert tgt θ₀ inputs))
                       nodes)
        dvec.head) in
  let next_inputs := (λ (y : T ref.2), env.insert ref y inputs) in

 (T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), T.mvn_pdf 0 1 x ⬝ g x θ₀) θ
    ∧ T.is_uniformly_integrable_around (λ (θ₀ : T (tgt.snd)) (x : T (ref.snd)), ∇ (λ (θ₁ : T (tgt.snd)), T.mvn_pdf 0 1 x ⬝ g x θ₁) θ₀) θ)
∧ (∀ y, can_diff_under_ints_pdfs_std nodes (next_inputs y) tgt)

end certigrad


import data.real.basic
import data.real.nnreal

theorem exo (f: nnreal -> nnreal):
  (forall x y, (f x) * (f y) = 2 * f (x + y*(f x)))
  -> forall x, f x = 2
:=
  sorry


import adjoin
import subfield_stuff
import linear_algebra.finite_dimensional
import linear_algebra.basic
import data.set.finite
import field_theory.tower
import algebra.gcd_monoid
import field_theory.splitting_field
import field_theory.separable

noncomputable theory
local attribute [instance, priority 100] classical.prop_decidable

/- Some stupid lemmas used below. Maybe some of them are already in mathlib? -/

-- This should go into field_theory/subfield eventually probably
lemma is_subfield.pow_mem {K : Type*} [field K] {a : K} {n : ℤ} {s : set K} [is_subfield s] (h : a ∈ s) : a ^ n ∈ s :=
begin
    by_cases hn : n ≥ 0,
    {   lift n to ℕ using hn,
        exact is_submonoid.pow_mem h, },
    {   rw [(show n = (-1)*(-n), by ring), fpow_mul, fpow_neg a, fpow_one],
        lift -n to ℕ using (show -n ≥ 0, by linarith),
        exact is_submonoid.pow_mem (is_subfield.inv_mem h), },
end

-- Is this really not in mathlib?
/-- If M is an algebra over a field F and x is a nonzero element of F then x as an element of M is also nonzero. -/
lemma ne_zero_of_ne_zero (F M : Type*) [field F] [comm_semiring M] [nontrivial M] [algebra F M]
    {x : F} (hx : x ≠ 0) : algebra_map F M x ≠ 0 :=
begin
    revert hx,
    contrapose!,
    intro h,
    rw ← (algebra_map F M).map_zero at h,
    exact (algebra_map F M).injective h,
end

namespace polynomial

variables (F : Type*) [field F]

lemma gcd_eval_zero (f g : polynomial F) (α : F) (hf : f.eval α = 0) (hg : g.eval α = 0) : (euclidean_domain.gcd f g).eval α = 0 :=
begin
    rw euclidean_domain.gcd_eq_gcd_ab f g,
    rw [polynomial.eval_add,polynomial.eval_mul,polynomial.eval_mul,hf,hg,zero_mul,zero_mul,zero_add],
end

variables {E : Type*} [field E] [algebra F E]

lemma gcd_root_left (f g : polynomial F) (α : E) (hα : (euclidean_domain.gcd f g).eval₂ (algebra_map F E) α = 0) :
f.eval₂ (algebra_map F E) α = 0 :=
begin
    cases euclidean_domain.gcd_dvd_left f g with p hp,
    rw [hp,polynomial.eval₂_mul,hα,zero_mul],
end

lemma gcd_root_right (f g : polynomial F) (α : E) (hα : (euclidean_domain.gcd f g).eval₂ (algebra_map F E) α = 0) :
g.eval₂ (algebra_map F E) α = 0 :=
begin
    cases euclidean_domain.gcd_dvd_right f g with p hp,
    rw [hp,polynomial.eval₂_mul,hα,zero_mul],
end

end polynomial

/- Proof of the primitive element theorem. -/

open finite_dimensional

section
variables (F : Type*) [field F] {E : Type*} [field E] [algebra F E]

/-- Trivial case of the primitive element theorem. -/
lemma primitive_element_trivial (F_eq_E : set.range (algebra_map F E) = (⊤ : set E)) :
    ∃ α : E, F[α] = (⊤ : set E) :=
begin
    use 0,
    ext,
    split,
    exact λ _, trivial,
    rw ← F_eq_E,
    rintros ⟨x, rfl⟩,
    apply adjoin.field_mem,
end

/- Primitive element theorem for finite fields. -/

-- Replaces earlier messy proof, courtesy of Aaron Anderson & Markus Himmel on zulip
/-- A finite dimensional vector space over a finite field is finite. -/
def finite_of_findim_over_finite [fintype F] [hE : finite_dimensional F E] : fintype E :=
    module.fintype_of_fintype (classical.some_spec (finite_dimensional.exists_is_basis_finset F E) : _)

/-- Primitive element theorem assuming E is finite. -/
lemma primitive_element_fin_aux [fintype E] : ∃ α : E, F[α] = (⊤ : set E) :=
begin
    obtain ⟨α, hα⟩ := is_cyclic.exists_generator (units E),
    use α,
    ext,
    refine ⟨λ _, dec_trivial, λ _, _⟩,
    by_cases hx : x = 0,
    {   rw hx,
        exact is_add_submonoid.zero_mem, },
    {   obtain ⟨n, hn⟩ := set.mem_range.mp (hα (units.mk0 x hx)),
        rw (show x = (α : E)^n, by norm_cast at *; simp *),
        exact is_subfield.pow_mem (adjoin_simple_contains_element F ↑α),
    },
end

/-- Primitive element theorem for finite dimensional extension of a finite field. -/
theorem primitive_element_fin [fintype F] [hfd : finite_dimensional F E] :
    ∃ α : E, F[α] = (⊤ : set E) :=
begin
    haveI : fintype E := finite_of_findim_over_finite F,
    exact primitive_element_fin_aux F,
end

end

/- Primitive element theorem for infinite fields. -/

section
variables {F : Type*} [field F] {E : Type*} [field E] (ϕ : F →+* E)

lemma primitive_element_two_aux (α β : E) {f g : polynomial F} [F_inf : infinite F] (hf : f ≠ 0) (hg : g ≠ 0) (f_monic : polynomial.monic f) (g_monic : polynomial.monic g) :
    ∃ c : F, ∀ (α' ∈ (f.map ϕ).roots) (β' ∈ (g.map ϕ).roots), β' ≠ β → ϕ c ≠ -(α' - α)/(β' - β) :=
begin
    let sf := (f.map ϕ).roots,
    let sg := (g.map ϕ).roots,
    let s := {c : E | ∃ (α' ∈ sf) (β' ∈ sg), β' ≠ β ∧ c = -(α' - α)/(β' - β)},
    let s' := ϕ⁻¹' s,
    let r : E → E → E := λ α' β', -(α' - α)/(β' - β),
    have hr : ∀ c ∈ s, ∃ α' β', ((α' ∈ sf) ∧ (β' ∈ sg)) ∧ r α' β' = c :=
    begin
        intros c hc,
        rw set.mem_set_of_eq at hc,
        tauto,
    end,
    have s_fin : s.finite :=
    begin
        refine (set.finite.image (λ z : E × E, r z.1 z.2) (set.finite_mem_finset (sf.product sg))).subset _,
        simpa only [set.subset_def, set.mem_image, prod.exists, finset.mem_product] using hr,
    end,
    have s'_fin : s'.finite := s_fin.preimage ((ring_hom.injective ϕ).inj_on (⇑ϕ ⁻¹' s)),
    obtain ⟨c, hc⟩ := infinite.exists_not_mem_finset s'_fin.to_finset,
    rw [set.finite.mem_to_finset, set.mem_preimage, set.mem_set_of_eq] at hc,
    push_neg at hc,
    exact ⟨c, hc⟩,
end

lemma primitive_element_two_inf_key_aux {β : F} {h : polynomial F} (h_ne_zero : h ≠ 0) (h_sep : h.separable)
(h_root : h.eval β = 0) (h_splits : polynomial.splits ϕ h) (h_roots : ∀ x ∈ (h.map ϕ).roots, x = ϕ β) :
h = (polynomial.C (polynomial.leading_coeff h)) * (polynomial.X - polynomial.C β) :=
begin
    have h_map_separable : (h.map ϕ).separable :=
    begin
        apply polynomial.separable.map,
        exact h_sep,
    end,
    rw polynomial.splits_iff_exists_multiset at h_splits,
    cases h_splits with s hs,
    have s_elements : ∀ x ∈ s, x = ϕ β :=
    begin
        intros x hx,
        have is_root : x ∈ (h.map ϕ).roots,
        rw polynomial.mem_roots,
        dsimp[polynomial.is_root],
        rw polynomial.eval_map,
        rw polynomial.eval₂_eq_eval_map,
        rw hs,
        rw polynomial.eval_mul,
        cases multiset.exists_cons_of_mem hx with y hy,
        rw hy,
        rw multiset.map_cons,
        simp only [polynomial.eval_X, multiset.prod_cons, polynomial.eval_C, zero_mul, polynomial.eval_mul, polynomial.eval_sub, mul_zero, sub_self],
        exact polynomial.map_ne_zero h_ne_zero,
        exact h_roots x is_root,
    end,
    replace s_elements : ∀ x ∈ multiset.map (λ (a : E), polynomial.X - polynomial.C a) s, x = polynomial.X - polynomial.C (ϕ β) :=
    begin
        intros x hx,
        rw multiset.mem_map at hx,
        cases hx with a ha,
        specialize s_elements a ha.1,
        rw s_elements at ha,
        exact ha.2.symm,
    end,
    replace s_elements := multiset.eq_repeat_of_mem s_elements,
    rw s_elements at hs,
    rw multiset.prod_repeat at hs,
    rw multiset.card_map at hs,
    rw hs at h_map_separable,
    have hf : ¬is_unit (polynomial.X - polynomial.C (ϕ β)) :=
    begin
        rw polynomial.is_unit_iff_degree_eq_zero,
        rw polynomial.degree_X_sub_C,
        exact dec_trivial,
    end,
    have map_injective := polynomial.map_injective ϕ ϕ.injective,
    have hn : s.card ≠ 0 :=
    begin
        intro hs_card,
        rw hs_card at hs,
        rw pow_zero at hs,
        rw mul_one at hs,
        rw ←polynomial.map_C at hs,
        replace hs := map_injective hs,
        rw hs at h_root,
        rw polynomial.eval_C at h_root,
        rw polynomial.leading_coeff_eq_zero at h_root,
        exact h_ne_zero h_root,
    end,
    rw (polynomial.separable.of_pow hf hn (polynomial.separable.of_mul_right h_map_separable)).2 at hs,
    rw pow_one at hs,
    apply map_injective,
    rw hs,
    rw polynomial.map_mul,
    rw polynomial.map_C,
    rw polynomial.map_sub,
    rw polynomial.map_X,
    rw polynomial.map_C,
end

end

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E]

lemma primitive_element_two_inf_key (α β : E) [F_sep : is_separable F E]
    (F_inf : infinite F) : ∃ c : F, β ∈ F[α + (algebra_map F E) c * β] :=
begin
    rcases F_sep α with ⟨hα, hf⟩,
    rcases F_sep β with ⟨hβ, hg⟩,
    let f := minimal_polynomial hα,
    let g := minimal_polynomial hβ,
    let f_E := f.map (algebra_map F E),
    let g_E := g.map (algebra_map F E),
    let E' := polynomial.splitting_field g_E,
    let ιFE := algebra_map F E,
    let ιEE' := algebra_map E E',
    let ιFE' := ιEE'.comp(ιFE),
    have key := primitive_element_two_aux ιFE' (ιEE' α) (ιEE' β) (minimal_polynomial.ne_zero hα) (minimal_polynomial.ne_zero hβ) (minimal_polynomial.monic hα) (minimal_polynomial.monic hβ),
    cases key with c hc,
    use c,
    let γ := α+(ιFE c)*β,
    let f' := f_E.comp(polynomial.C γ-(polynomial.C (ιFE c)) * (polynomial.X)),
    let h := euclidean_domain.gcd f' g_E,
    have h_sep : h.separable :=
    begin
        have div := euclidean_domain.gcd_dvd_right f' g_E,
        cases div with p mul,
        dsimp[←h] at mul,
        apply polynomial.separable.of_mul_left,
        rw ←mul,
        exact polynomial.separable.map hg,
    end,
    have h_ne_zero : h ≠ 0 :=
    begin
        intro h_eq_zero,
        rw euclidean_domain.gcd_eq_zero_iff at h_eq_zero,
        apply polynomial.map_monic_ne_zero (minimal_polynomial.monic hβ) h_eq_zero.2,
    end,
    have h_map_separable : (h.map ιEE').separable :=
    begin
        apply polynomial.separable.map,
        exact h_sep,
    end,
    have h_root : h.eval β = 0 :=
    begin
        apply polynomial.gcd_eval_zero,
        rw [polynomial.eval_comp,polynomial.eval_sub,polynomial.eval_mul,polynomial.eval_C,polynomial.eval_C,polynomial.eval_X,add_sub_cancel],
        rw [polynomial.eval_map,←polynomial.aeval_def,minimal_polynomial.aeval],
        rw [polynomial.eval_map,←polynomial.aeval_def,minimal_polynomial.aeval],
    end,
    have h_splits : polynomial.splits (algebra_map E E') h :=
        polynomial.splits_of_splits_of_dvd (algebra_map E E') (polynomial.map_ne_zero (minimal_polynomial.ne_zero hβ)) (polynomial.splitting_field.splits g_E) (euclidean_domain.gcd_dvd_right f' g_E),
    have h_roots : ∀ x ∈ (h.map ιEE').roots, x = algebra_map E E' β :=
    begin
        intros x hx,
        rw polynomial.mem_roots at hx,
        dsimp[polynomial.is_root] at hx,
        rw polynomial.eval_map at hx,
        have f_root : f'.eval₂ (algebra_map E E') x = 0 := polynomial.gcd_root_left E f' g_E x hx,
        simp only [polynomial.eval₂_comp,polynomial.eval₂_map,polynomial.eval₂_sub,polynomial.eval₂_mul,polynomial.eval₂_C,polynomial.eval₂_X] at f_root,
        replace f_root : _ ∈ (f.map ιFE').roots,
        rw polynomial.mem_roots,
        dsimp[polynomial.is_root],
        rw polynomial.eval_map,
        exact f_root,
        exact polynomial.map_ne_zero (minimal_polynomial.ne_zero hα),
        specialize hc _ f_root,
        have g_root : g_E.eval₂ (algebra_map E E') x = 0 := polynomial.gcd_root_right E f' g_E x hx,
        simp only [polynomial.eval₂_map] at g_root,
        replace g_root : _ ∈ (g.map ιFE').roots,
        rw polynomial.mem_roots,
        dsimp[polynomial.is_root],
        rw polynomial.eval_map,
        exact g_root,
        exact polynomial.map_ne_zero (minimal_polynomial.ne_zero hβ),
        specialize hc _ g_root,
        by_contradiction,
        specialize hc a,
        apply hc,
        dsimp[ιEE'],
        rw[neg_sub,ring_hom.map_add,←sub_add,←sub_sub,sub_self,zero_sub,neg_add_eq_sub,ring_hom.map_mul,←mul_sub],
        symmetry,
        apply mul_div_cancel,
        rw sub_ne_zero,
        exact a,
        exact polynomial.map_ne_zero h_ne_zero,
    end,
    replace key := primitive_element_two_inf_key_aux ιEE' h_ne_zero h_sep h_root h_splits h_roots,
    let f_Fγ := (f.map(algebra_map F F[γ])).comp(polynomial.C (adjoin_simple.gen F γ)-(polynomial.C ↑c) * (polynomial.X)),
    let g_Fγ := g.map(algebra_map F F[γ]),
    have composition2 : (algebra_map F[γ] E).comp(algebra_map F F[γ]) = algebra_map F E := by ext;refl,
    have f_map : f_Fγ.map(algebra_map F[γ] E) = f' :=
    begin
        dsimp[f_Fγ,f',f_E],
        rw ←composition2,
        rw ←polynomial.map_map,
        set p := f.map(algebra_map F F[γ]),
        dsimp[←p],
        rw polynomial.map_comp (algebra_map F[γ] E) p (polynomial.C (adjoin_simple.gen F γ)-(polynomial.C ↑c) * (polynomial.X)),
        rw [polynomial.map_sub,polynomial.map_C,adjoin_simple.gen_eq_alpha,polynomial.map_mul,polynomial.map_C,polynomial.map_X],
        refl,
    end,
    have g_map : g_Fγ.map(algebra_map F[γ] E) = g_E :=
    begin
        rw polynomial.map_map,
        rw composition2,
    end,
    dsimp[h] at key,
    rw [←f_map,←g_map] at key,
    have swap : euclidean_domain.gcd (f_Fγ.map(algebra_map F[γ] E)) (g_Fγ.map(algebra_map F[γ] E)) = (euclidean_domain.gcd f_Fγ g_Fγ).map(algebra_map F[γ] E),
    convert polynomial.gcd_map (algebra_map F[γ] E),
    rw swap at key,
    set p := euclidean_domain.gcd f_Fγ g_Fγ,
    set k := (p.map(algebra_map F[γ] E)).leading_coeff,
    dsimp[←k] at key,
    rw mul_sub at key,
    rw ←polynomial.C_mul at key,
    have coeff0 : algebra_map F[γ] E (p.coeff 0) = -(k*β) :=
        by rw [←polynomial.coeff_map,key, polynomial.coeff_sub, polynomial.coeff_C_mul, polynomial.coeff_C_zero, polynomial.coeff_X_zero, mul_zero, zero_sub],
    have coeff1 : algebra_map F[γ] E (p.coeff 1) = k :=
    begin
        rw [←polynomial.coeff_map,key,polynomial.coeff_sub,polynomial.coeff_mul_X,polynomial.coeff_C_zero,polynomial.coeff_C],
        change k - 0 = k,
        rw sub_zero,
    end,
    have k_ne_zero : k≠0 :=
    begin
        intro k_eq_zero,
        rw [polynomial.leading_coeff_eq_zero,←polynomial.map_zero (algebra_map F[γ] E)] at k_eq_zero,
        replace k_eq_zero := polynomial.map_injective (algebra_map F[γ] E) (algebra_map F[γ] E).injective k_eq_zero,
        rw euclidean_domain.gcd_eq_zero_iff at k_eq_zero,
        apply polynomial.map_monic_ne_zero (minimal_polynomial.monic hβ) k_eq_zero.2,
    end,
    have last_step : β = algebra_map F[γ] E (-p.coeff 0 / p.coeff 1) :=
        by rw [division_def,ring_hom.map_mul,ring_hom.map_neg,ring_hom.map_inv,coeff0,coeff1,neg_neg,mul_comm,←mul_assoc,inv_mul_cancel k_ne_zero,one_mul],
    change β = ↑(-p.coeff 0 / p.coeff 1) at last_step,
    have h := subtype.mem (-p.coeff 0 / p.coeff 1),
    rw ←last_step at h,
    exact h,
end

/-- Primitive element theorem for adjoining two elements to an infinite field. -/
lemma primitive_element_two_inf (α β : E) (F_sep : is_separable F E)
    (F_inf : infinite F) :  ∃ γ : E, F[α, β] = F[γ] :=
begin
    obtain ⟨c, β_in_Fγ⟩ := primitive_element_two_inf_key α β F_inf,
    let c' := algebra_map F E c,
    let γ := α + c'*β,
    have γ_in_Fγ : γ ∈ F[γ] := adjoin_simple_contains_element F γ,
    have c_in_Fγ : c' ∈ F[γ] := adjoin.field_mem F {γ} c,
    have cβ_in_Fγ : c'*β ∈ F[γ] := is_submonoid.mul_mem c_in_Fγ β_in_Fγ,
    have α_in_Fγ : α ∈ F[γ] := by rw (show α = γ - c'*β, by simp *);
        exact is_add_subgroup.sub_mem F[γ] γ (c'*β) γ_in_Fγ cβ_in_Fγ,
    have αβ_in_Fγ : {α, β} ⊆ F[γ] := λ x hx, by cases hx; cases hx; assumption,
    have Fαβ_sub_Fγ : F[α, β] ⊆ F[γ] := adjoin_subset' F {α, β} αβ_in_Fγ,
    have α_in_Fαβ : α ∈ F[α, β] := adjoin.set_mem F {α, β} ⟨α, set.mem_insert α {β}⟩,
    have β_in_Fαβ : β ∈ F[α, β] := adjoin.set_mem F {α, β} ⟨β, set.mem_insert_of_mem α rfl⟩,
    have c_in_Fαβ : c' ∈ (F[α, β] : set E) := adjoin.field_mem F {α, β} c,
    have cβ_in_Fαβ : c'*β ∈ F[α, β] := is_submonoid.mul_mem c_in_Fαβ β_in_Fαβ,
    have γ_in_Fαβ : γ ∈ F[α, β] := is_add_submonoid.add_mem α_in_Fαβ cβ_in_Fαβ,
    have Fγ_sub_Fαβ : F[γ] ⊆ F[α, β] := adjoin_simple_subset' F γ γ_in_Fαβ,
    exact ⟨γ, set.subset.antisymm Fαβ_sub_Fγ Fγ_sub_Fαβ⟩,
end

universe u

/-- Primitive element theorem for infinite fields. -/
theorem primitive_element_inf (F E : Type u) [field F] [field E] [algebra F E] (F_sep : is_separable F E) (F_findim: finite_dimensional F E)
    (F_inf : infinite F) (n : ℕ) (hn : findim F E = n) : (∃ α : E, F[α] = (⊤ : set E)) :=
begin
    tactic.unfreeze_local_instances,
    revert F,
    apply n.strong_induction_on,
    clear n,
    intros n ih F hF hFE F_sep F_findim F_inf hn,
    by_cases F_neq_E : set.range (algebra_map F E) = (⊤ : set E),
    {   exact primitive_element_trivial F F_neq_E, },
    {   have : ∃ α : E, α ∉ set.range (algebra_map F E) :=
        begin
            revert F_neq_E,
            contrapose!,
            exact λ h, set.ext (λ x, ⟨λ _, dec_trivial, λ _, h x⟩),
        end,
        rcases this with ⟨α, hα⟩,
        by_cases h : F[α] = (⊤ : set E),
        {   exact ⟨α, h⟩,   },
        {   have Fα_findim : finite_dimensional F[α] E := adjoin_findim_of_findim F α,
            have Fα_le_n : findim F[α] E < n := by rw ← hn; exact adjoin_dim_lt F hα,
            have Fα_inf : infinite F[α] := adjoin_inf_of_inf F {α} F_inf,
            have Fα_sep : is_separable F[α] E := adjoin_separable F {α},
            obtain ⟨β, hβ⟩ := ih (findim F[α] E) Fα_le_n F[α]
                Fα_sep Fα_findim Fα_inf rfl,
            obtain ⟨γ, hγ⟩ := primitive_element_two_inf α β F_sep F_inf,
            rw [adjoin_simple_twice, hγ] at hβ,
            exact ⟨γ, hβ⟩,
        },
    },
end

/- Actual primitive element theorem. -/

/-- Primitive element theorem in same universe. -/
theorem primitive_element_aux (F E : Type u) [field F] [field E] [algebra F E]
(F_sep : is_separable F E)  (F_findim : finite_dimensional F E) :
    (∃ α : E, F[α] = (⊤ : set E)) :=
begin
    by_cases F_finite : nonempty (fintype F),
    exact nonempty.elim F_finite (λ h : fintype F, @primitive_element_fin F _ E _ _ h F_findim),
    exact primitive_element_inf F E F_sep F_findim (not_nonempty_fintype.mp F_finite) (findim F E) rfl,
end

/-- Primitive element theorem in different universes. -/
theorem primitive_element (F_sep : is_separable F E)  (F_findim : finite_dimensional F E) :
    (∃ α : E, F[α] = (⊤ : set E)) :=
begin
    set F' := set.range (algebra_map F E) with hF',
    have F'_sep : is_separable F' E := inclusion.separable F_sep,
    have F'_findim : finite_dimensional F' E := inclusion.finite_dimensional F_findim,
    obtain ⟨α, hα⟩ := primitive_element_aux F' E F'_sep F'_findim,
    exact ⟨α, by simp only [*, adjoin_equals_adjoin_range]⟩,
end


import Mathlib

namespace Option

protected def elim : Option α → β → (α → β) → β
  | (some x), y, f => f x
  | none,     y, f => y

instance : Bind (Option) := ⟨Option.bind⟩

instance : Mem α (Option α) := ⟨λ a b => b = some a⟩

@[simp] theorem mem_def {a : α} {b : Option α} : a ∈ b ↔ b = some a := sorry

lemma ne_none_iff_exists {o : Option α} :
  o ≠ none ↔ ∃ (x : α), some x = o :=
  sorry

lemma bind_eq_bind {f : α → Option β} {x : Option α} :
  x >>= f = x.bind f :=
  rfl

@[simp] theorem bind_eq_some {x : Option α} {f : α → Option β} {b : β} :
  x >>= f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
  sorry

@[simp] theorem bind_eq_none {o : Option α} {f : α → Option β} :
  o >>= f = none ↔ (∀ b a, a ∈ o → b ∉ f a) :=
  sorry

@[simp] theorem some_orelse (a : α) (x : Option α) : (some a <|> x) = some a := sorry

@[simp] theorem orelse_none (x : Option α) : (x <|> none) = x := sorry

@[simp] theorem none_bind {α β} (f : α → Option β) : none >>= f = none := sorry

end Option