(***************************************************************************

 Monoidal categories

 In this file, we define the notion of monoidal category. In addition, we
 prove the important laws for monoidal categories.

 The main definition in this file, takes a so-called displayed approach.
 More specifically, we define the notion of a monoidal structure on a
 category. For this notion, we define suitable accessors and we prove the
 laws. Finally, we also provide a bundled notion of monoidal category, which
 is a category together with a monoidal structure for it. The necessary
 accessors and laws are derived from the other notion.

 In this file, we use a whiskered approach. This means that we have two
 operations to tensor with morphisms: a left and a right whiskering. Both of
 these take an object and a morphism as input and they return a morphism as
 output.

 Contents
 1. Monoidal structures
 2. Opposite monoidal category
 3. Equivalences from the tensor and unit
 4. The unitors coincide
 5. Swapping the tensor
 6. More monoidal laws
 7. Bundled approach to monoidal categories

Note: after refactoring on March 10, 2023, the prior Git history of this development is found via
git log -- UniMath/CategoryTheory/Monoidal/MonoidalCategoriesWhiskered.v

 ***************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.Notations.
Require Import UniMath.MoreFoundations.PartA.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.

Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.FullyFaithful.
Require Import UniMath.CategoryTheory.opp_precat.

Local Open Scope cat.

Import BifunctorNotations.

(**
 1. Monoidal structures
 *)
Section A.

(** Data **)
Definition tensor_data (C : category) : UU :=
  bifunctor_data C C C.
Identity Coercion tensorintobifunctor : tensor_data >-> bifunctor_data.

Definition leftunitor_data
           {C : category}
           (T : tensor_data C)
           (I : C)
  : UU
  := ∏ (x : C), C⟦I ⊗_{T} x, x⟧.

Definition leftunitorinv_data
           {C : category}
           (T : tensor_data C)
           (I : C)
  : UU
  := ∏ (x : C), C⟦x, I ⊗_{T} x⟧.

Definition rightunitor_data
           {C : category}
           (T : tensor_data C)
           (I : C)
  : UU
  := ∏ (x : C), C⟦x ⊗_{T} I, x⟧.

Definition rightunitorinv_data
           {C : category}
           (T : tensor_data C)
           (I : C)
  : UU
  := ∏ (x : C), C⟦x, x ⊗_{T} I⟧.

Definition associator_data
           {C : category}
           (T : tensor_data C)
  : UU
  := ∏ (x y z : C), C ⟦(x ⊗_{T} y) ⊗_{T} z, x ⊗_{T} (y ⊗_{T} z)⟧.

Definition associatorinv_data
           {C : category}
           (T : tensor_data C)
  : UU
  := ∏ (x y z : C), C ⟦x ⊗_{T} (y ⊗_{T} z), (x ⊗_{T} y) ⊗_{T} z⟧.

Definition monoidal_data (C : category): UU :=
    ∑ (T : tensor_data C) (I : C),
    (leftunitor_data T I) × (leftunitorinv_data T I) ×
    (rightunitor_data T I) × (rightunitorinv_data T I) ×
    (associator_data T) × (associatorinv_data T).

Definition make_monoidal_data
           {C : category}
           {T : tensor_data C}
           {I : C}
           (lu : leftunitor_data T I)
           (luinv : leftunitorinv_data T I)
           (ru : rightunitor_data T I)
           (ruinv : rightunitorinv_data T I)
           (α : associator_data T)
           (αinv : associatorinv_data T)
  : monoidal_data C
  := (T,,I,,lu,,luinv,,ru,,ruinv,,α,,αinv).

Definition monoidal_tensor_data {C : category} (MD : monoidal_data C) : tensor_data C := pr1 MD.
Coercion monoidal_tensor_data : monoidal_data >-> tensor_data.

Definition monoidal_unit {C : category} (MD : monoidal_data C) : C := pr12 MD.
Notation "I_{ MD }" := (monoidal_unit MD).

Definition monoidal_leftunitordata
           {C : category}
           (MD : monoidal_data C)
  : leftunitor_data MD I_{MD}
  := pr1 (pr22 MD).
Notation "lu_{ MD }" := (monoidal_leftunitordata MD).

Definition monoidal_leftunitorinvdata
           {C : category}
           (MD : monoidal_data C)
  : leftunitorinv_data MD I_{MD}
  := pr12 (pr22 MD).
Notation "luinv_{ MD }" := (monoidal_leftunitorinvdata MD).

Definition monoidal_rightunitordata
           {C : category}
           (MD : monoidal_data C)
  : rightunitor_data MD I_{MD}
  := pr122 (pr22 MD).
Notation "ru_{ MD }" := (monoidal_rightunitordata MD).

Definition monoidal_rightunitorinvdata
           {C : category}
           (MD : monoidal_data C)
  : rightunitorinv_data MD I_{MD}
  := pr1 (pr222 (pr22 MD)).
Notation "ruinv_{ MD }" := (monoidal_rightunitorinvdata MD).

Definition monoidal_associatordata
           {C : category}
           (MD : monoidal_data C)
  : associator_data MD
  := pr12 (pr222 (pr22 MD)).
Notation "α_{ MD }" := (monoidal_associatordata MD).

Definition monoidal_associatorinvdata
           {C : category}
           (MD : monoidal_data C)
  : associatorinv_data MD
  := pr22 (pr222 (pr22 MD)).
Notation "αinv_{ MD }" := (monoidal_associatorinvdata MD).

(** Axioms **)
Definition leftunitor_nat
           {C : category}
           {T : tensor_data C}
           {I : C}
           (lu : leftunitor_data T I)
  : UU
  := ∏ (x y : C), ∏ (f : C ⟦x,y⟧),  I ⊗^{ T}_{l} f · lu y = lu x · f.

Definition leftunitorinv_nat
           {C : category}
           {T : tensor_data C}
           {I : C}
           (luinv : leftunitorinv_data T I)
  : UU
  := ∏ (x y : C), ∏ (f : C ⟦x,y⟧),  luinv x · I ⊗^{ T}_{l} f = f · luinv y.

Definition leftunitor_iso_law
           {C : category}
           {T : tensor_data C}
           {I : C}
           (lu : leftunitor_data T I)
           (luinv : leftunitorinv_data T I)
  : UU
  := ∏ (x : C), is_inverse_in_precat (lu x) (luinv x).

Definition leftunitor_law
           {C : category}
           {T : tensor_data C}
           {I : C}
           (lu : leftunitor_data T I)
           (luinv : leftunitorinv_data T I)
  : UU
  := leftunitor_nat lu × leftunitor_iso_law lu luinv.

Definition leftunitorlaw_nat
            {C : category}
            {T : tensor_data C}
            {I : C}
            {lu : leftunitor_data T I}
            {luinv : leftunitorinv_data T I}
            (lu_law : leftunitor_law lu luinv)
  : leftunitor_nat lu
  := pr1 lu_law.

Definition leftunitorlaw_iso_law
           {C : category}
           {T : tensor_data C}
           {I : C}
           {lu : leftunitor_data T I}
           {luinv : leftunitorinv_data T I}
           (lu_law : leftunitor_law lu luinv)
  : leftunitor_iso_law lu luinv
  := pr2 lu_law.

Definition rightunitor_nat
           {C : category}
           {T : tensor_data C}
           {I : C}
           (ru : rightunitor_data T I)
  : UU
  := ∏ (x y : C), ∏ (f : C ⟦x,y⟧),  f ⊗^{ T}_{r} I · ru y = ru x · f.

Definition rightunitorinv_nat
           {C : category}
           {T : tensor_data C}
           {I : C}
           (ruinv : rightunitorinv_data T I)
  : UU
  := ∏ (x y : C), ∏ (f : C ⟦x,y⟧),  ruinv x · f ⊗^{ T}_{r} I = f · ruinv y.

Definition rightunitor_iso_law
           {C : category}
           {T : tensor_data C}
           {I : C}
           (ru : rightunitor_data T I)
           (ruinv : rightunitorinv_data T I)
  : UU
  := ∏ (x : C), is_inverse_in_precat (ru x) (ruinv x).

Definition rightunitor_law
           {C : category}
           {T : tensor_data C}
           {I : C}
           (ru : rightunitor_data T I)
           (ruinv : rightunitorinv_data T I)
  : UU
  := rightunitor_nat ru × rightunitor_iso_law ru ruinv.

Definition rightunitorlaw_nat
           {C : category}
           {T : tensor_data C}
           {I : C}
           {ru : rightunitor_data T I}
           {ruinv : rightunitorinv_data T I}
           (rul : rightunitor_law ru ruinv)
  : rightunitor_nat ru
  := pr1 rul.

Definition rightunitorlaw_iso_law
           {C : category}
           {T : tensor_data C}
           {I : C}
           {ru : rightunitor_data T I}
           {ruinv : rightunitorinv_data T I}
           (rul : rightunitor_law ru ruinv)
  : rightunitor_iso_law ru ruinv
  := pr2 rul.

Definition associator_nat_leftwhisker
           {C : category}
           {T : tensor_data C}
           (α : associator_data T)
  : UU
  := ∏ (x y z z' : C) (h : C⟦z,z'⟧),
     (α x y z) · (x ⊗^{ T}_{l} (y ⊗^{ T}_{l} h))
     =
     ((x ⊗_{ T} y) ⊗^{ T}_{l} h) · (α x y z').

Definition associator_nat_rightwhisker
           {C : category}
           {T : tensor_data C}
           (α : associator_data T)
  : UU
  := ∏ (x x' y z : C) (f : C⟦x,x'⟧),
     (α x y z) · (f ⊗^{ T}_{r} (y ⊗_{ T} z))
     =
     ((f ⊗^{ T}_{r} y) ⊗^{ T}_{r} z) · (α x' y z).

Definition associator_nat_leftrightwhisker
           {C : category}
           {T : tensor_data C}
           (α : associator_data T)
  : UU
  := ∏ (x y y' z : C) (g : C⟦y,y'⟧),
     (α x y z) · (x ⊗^{ T}_{l} (g ⊗^{ T}_{r} z))
     =
     ((x ⊗^{ T}_{l} g) ⊗^{ T}_{r} z) · (α x y' z).

Definition associator_iso_law
           {C : category}
           {T : tensor_data C}
           (α : associator_data T)
           (αinv : associatorinv_data T)
  : UU
  := ∏ (x y z : C), is_inverse_in_precat (α x y z) (αinv x y z).

Definition associator_law
           {C : category}
           {T : tensor_data C}
           (α : associator_data T)
           (αinv : associatorinv_data T)
  : UU
  := (associator_nat_leftwhisker α) × (associator_nat_rightwhisker α) ×
     (associator_nat_leftrightwhisker α) × (associator_iso_law α αinv).

Definition associatorlaw_natleft
           {C : category}
           {T : tensor_data C}
           {α : associator_data T}
           {αinv : associatorinv_data T}
           (αl : associator_law α αinv)
  : associator_nat_leftwhisker α
  := pr1 αl.

Definition associatorlaw_natright
           {C : category}
           {T : tensor_data C}
           {α : associator_data T}
           {αinv : associatorinv_data T}
           (αl : associator_law α αinv)
  : associator_nat_rightwhisker α
  := pr1 (pr2 αl).

Definition associatorlaw_natleftright
           {C : category}
           {T : tensor_data C}
           {α : associator_data T}
           {αinv : associatorinv_data T}
           (αl : associator_law α αinv)
  : associator_nat_leftrightwhisker α
  := pr1 (pr2 (pr2 αl)).

Definition associatorlaw_iso_law
           {C : category}
           {T : tensor_data C}
           {α : associator_data T}
           {αinv : associatorinv_data T}
           (αl : associator_law α αinv)
  : associator_iso_law α αinv
  := pr2 (pr2 (pr2 αl)).

Definition triangle_identity
           {C : category}
           {T : tensor_data C}
           {I : C}
           (lu : leftunitor_data T I)
           (ru : rightunitor_data T I)
           (α : associator_data T)
  : UU
  := ∏ (x y : C), α x I y · x ⊗^{T}_{l} (lu y) = ru x ⊗^{T}_{r} y.

(** more triangle laws that are redundant in the axiomatisation *)
Definition triangle_identity'
           {C : category}
           {T : tensor_data C}
           {I : C}
           (lu : leftunitor_data T I)
           (α : associator_data T)
  : UU
  := ∏ (x y : C), α I x y · lu (x ⊗_{T} y) = lu x ⊗^{T}_{r} y.

Definition triangle_identity''
           {C : category}
           {T : tensor_data C}
           {I : C}
           (ru : rightunitor_data T I)
           (α : associator_data T)
  : UU
  := ∏ (x y : C), α x y I · x ⊗^{T}_{l} (ru y) = ru (x ⊗_{T} y).

Definition pentagon_identity
           {C : category}
           {T : tensor_data C}
           (α : associator_data T)
  : UU
  := ∏ (w x y z : C),
     ((α w x y) ⊗^{T}_{r} z) · (α w (x⊗_{T} y) z) · (w ⊗^{T}_{l} (α x y z))
     =
     (α (w⊗_{T}x) y z) · (α w x (y ⊗_{T} z)).

Definition monoidal_laws
           {C : category}
           (MD : monoidal_data C)
  : UU
  := is_bifunctor MD
     × (leftunitor_law lu_{MD} luinv_{MD})
     × (rightunitor_law ru_{MD} ruinv_{MD})
     × (associator_law α_{MD} αinv_{MD})
     × (triangle_identity lu_{MD} ru_{MD} α_{MD})
     × (pentagon_identity α_{MD}).

Definition monoidal (C : category) : UU :=
  ∑ (MD : monoidal_data C), (monoidal_laws MD).

Definition monoidal_mondata {C : category} (M : monoidal C) : monoidal_data C := pr1 M.
Coercion monoidal_mondata : monoidal >-> monoidal_data.

Definition monoidal_monlaws {C : category} (M : monoidal C) : monoidal_laws M := pr2 M.

Definition monoidal_tensor_is_bifunctor
           {C : category}
           (M : monoidal C)
  : is_bifunctor M
  := pr12 M.

Coercion monoidal_tensor
         {C : category}
         (M : monoidal C)
  : bifunctor C C C
  := _ ,, monoidal_tensor_is_bifunctor M.

Definition monoidal_leftunitorlaw
           {C : category}
           (M : monoidal C)
  : leftunitor_law lu_{M} luinv_{M}
  := pr12 (monoidal_monlaws M).

Definition monoidal_leftunitornat
           {C : category}
           (M : monoidal C)
  : leftunitor_nat lu_{M}
  := leftunitorlaw_nat (monoidal_leftunitorlaw M).

Definition monoidal_leftunitorisolaw
           {C : category}
           (M : monoidal C)
  : leftunitor_iso_law lu_{M} luinv_{M}
  := leftunitorlaw_iso_law (monoidal_leftunitorlaw M).

Lemma monoidal_leftunitorinvnat
      {C : category}
      (M : monoidal C)
  : leftunitorinv_nat luinv_{M}.
Proof.
  intros x y f.
  apply (z_iso_inv_on_right _ _ _ (_,,_,,monoidal_leftunitorisolaw M x)).
  cbn.
  rewrite assoc.
  apply (z_iso_inv_on_left _ _ _ _ (_,,_,,monoidal_leftunitorisolaw M y)).
  apply pathsinv0, monoidal_leftunitornat.
Qed.

Definition monoidal_rightunitorlaw
           {C : category}
           (M : monoidal C)
  : rightunitor_law ru_{M} ruinv_{M}
  := pr122 (monoidal_monlaws M).

Definition monoidal_rightunitornat
           {C : category}
           (M : monoidal C)
  : rightunitor_nat ru_{M}
  := rightunitorlaw_nat (monoidal_rightunitorlaw M).

Definition monoidal_rightunitorisolaw
           {C : category}
           (M : monoidal C)
  : rightunitor_iso_law ru_{M} ruinv_{M}
  := rightunitorlaw_iso_law (monoidal_rightunitorlaw M).

Lemma monoidal_rightunitorinvnat
      {C : category}
      (M : monoidal C)
  : rightunitorinv_nat ruinv_{M}.
Proof.
  intros x y f.
  apply (z_iso_inv_on_right _ _ _ (_,,_,,monoidal_rightunitorisolaw M x)).
  cbn.
  rewrite assoc.
  apply (z_iso_inv_on_left _ _ _ _ (_,,_,,monoidal_rightunitorisolaw M y)).
  apply pathsinv0, monoidal_rightunitornat.
Qed.

Definition monoidal_associatorlaw
           {C : category}
           (M : monoidal C)
  : associator_law α_{M} αinv_{M}
  := pr1 (pr222 (monoidal_monlaws M)).

Definition monoidal_associatornatleft
           {C : category}
           (M : monoidal C)
  : associator_nat_leftwhisker α_{M}
  := associatorlaw_natleft (monoidal_associatorlaw M).

Definition monoidal_associatornatright
           {C : category}
           (M : monoidal C)
  : associator_nat_rightwhisker α_{M}
  := associatorlaw_natright (monoidal_associatorlaw M).

Definition monoidal_associatornatleftright
           {C : category}
           (M : monoidal C)
  : associator_nat_leftrightwhisker α_{M}
  := associatorlaw_natleftright (monoidal_associatorlaw M).

Definition monoidal_associatorisolaw
           {C : category}
           (M : monoidal C)
  : associator_iso_law α_{M} αinv_{M}
  := associatorlaw_iso_law (monoidal_associatorlaw M).

Lemma associator_nat1
      {C : category}
      (M : monoidal C)
      {x x' y y' z z' : C}
      (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧)
  : (monoidal_associatordata M x y z)
    · ((f ⊗^{M}_{r} (y ⊗_{M} z))
    · (x' ⊗^{M}_{l} ((g ⊗^{M}_{r} z) · (y' ⊗^{M}_{l} h))))
    =
    (((f ⊗^{M}_{r} y)
    · (x' ⊗^{M}_{l} g))  ⊗^{M}_{r} z)
      · ((x' ⊗_{M} y') ⊗^{M}_{l} h) · (monoidal_associatordata M x' y' z').
Proof.
  rewrite assoc.
  rewrite (monoidal_associatornatright M).
  rewrite assoc'.
  etrans. {
    apply cancel_precomposition.
    rewrite (bifunctor_leftcomp M).
    rewrite assoc.
    rewrite (monoidal_associatornatleftright M).
    apply idpath.
  }

  etrans. {
    apply cancel_precomposition.
    rewrite assoc'.
    apply cancel_precomposition.
    apply (monoidal_associatornatleft M).
  }
  rewrite assoc.
  rewrite assoc.
  apply cancel_postcomposition.
  apply pathsinv0.
  rewrite (bifunctor_rightcomp M).
  apply idpath.
Qed.

Lemma associator_nat2
      {C : category}
      (M : monoidal C)
      {x x' y y' z z' : C} (f : C⟦x,x'⟧)
      (g : C⟦y,y'⟧) (h : C⟦z,z'⟧)
  : (monoidal_associatordata M x y z) · (f ⊗^{M} (g ⊗^{M} h))
    =
    ((f ⊗^{M} g) ⊗^{M} h) · (monoidal_associatordata M x' y' z').
Proof.
  intros.
  unfold functoronmorphisms1.
  exact (associator_nat1 M f g h).
Qed.

Definition monoidal_triangleidentity
           {C : category}
           (M : monoidal C)
  : triangle_identity lu_{M} ru_{M} α_{M}
  := pr12 (pr222 (monoidal_monlaws M)).

Definition monoidal_pentagonidentity
           {C : category}
           (M : monoidal C)
  : pentagon_identity α_{M}
  := pr22 (pr222 (monoidal_monlaws M)).

Lemma isaprop_monoidal_laws {C : category} (M : monoidal_data C)
  : isaprop (monoidal_laws M).
Proof.
  repeat (apply isapropdirprod)
  ; repeat (apply impred ; intro)
  ; repeat (try apply C)
  ; repeat (apply isaprop_is_inverse_in_precat).
Qed.

(** Some additional data and properties which one deduces from monoidal categories **)
(* Not the best name though, but here my creativity fails *)
Lemma swap_nat_along_zisos
      {C : category} {x1 x2 y1 y2 : C}
      (p1 : z_iso x1 y1) (p2 : z_iso x2 y2)
  : ∏ (f: C⟦x1,x2⟧) (g : C⟦y1,y2⟧),
    (pr1 p1) · g = f · (pr1 p2) -> g · (inv_from_z_iso p2) = (inv_from_z_iso p1) · f.
Proof.
  intros f g p.
  apply pathsinv0.
  apply z_iso_inv_on_right.
  rewrite assoc.
  apply z_iso_inv_on_left.
  apply p.
Qed.

Lemma leftunitor_nat_z_iso {C : category} (M : monoidal C)
  : nat_z_iso
      (leftwhiskering_functor M I_{M})
      (functor_identity C).
Proof.
  use make_nat_z_iso.
  - use make_nat_trans.
    + exact (λ x, lu_{M} x).
    + exact (λ x y f, monoidal_leftunitornat M x y f).
  - intro x. exists (luinv_{M} x).
    apply (monoidal_leftunitorisolaw M x).
Defined.

Definition rightunitor_nat_z_iso {C : category} (M : monoidal C)
  : nat_z_iso
      (rightwhiskering_functor M I_{M})
      (functor_identity C).
Proof.
  use make_nat_z_iso.
  - use make_nat_trans.
    + exact (λ x, ru_{M} x).
    + exact (λ x y f, monoidal_rightunitornat M x y f).
  - intro x. exists (ruinv_{M} x).
    apply (monoidal_rightunitorisolaw M x).
Defined.

Definition z_iso_from_associator_iso
           {C : category} (M : monoidal C) (x y z : C)
  : z_iso ((x ⊗_{ M} y) ⊗_{ M} z) (x ⊗_{ M} (y ⊗_{ M} z))
  := make_z_iso
       (α_{M} x y z)
       (αinv_{M} x y z)
       (monoidal_associatorisolaw M x y z).

Definition monoidal_associatorinvnatleft
           {C : category}
           (M : monoidal C)
  : ∏ (x y z z' : C) (h : C⟦z,z'⟧),
    (x ⊗^{M}_{l} (y ⊗^{M}_{l} h)) · (αinv_{M} x y z')
    =
    (αinv_{M} x y z) · ((x ⊗_{M} y) ⊗^{M}_{l} h) .
Proof.
  intros x y z z' h.
  apply (swap_nat_along_zisos (z_iso_from_associator_iso M x y z) (z_iso_from_associator_iso M x y z')).
  apply monoidal_associatornatleft.
Qed.

Definition monoidal_associatorinvnatright
           {C : category}
           (M : monoidal C)
  : ∏ (x x' y z: C) (f : C⟦x,x'⟧),
    (f ⊗^{M}_{r} (y ⊗_{M} z)) · (αinv_{M} x' y z)
    =
    (αinv_{M} x y z) · ((f ⊗^{M}_{r} y) ⊗^{M}_{r} z).
Proof.
  intros x x' y z f.
  apply (swap_nat_along_zisos (z_iso_from_associator_iso M x y z) (z_iso_from_associator_iso M x' y z)).
  apply monoidal_associatornatright.
Qed.

Definition monoidal_associatorinvnatleftright
           {C : category}
           (M : monoidal C)
  : ∏ (x y y' z : C) (g : C⟦y,y'⟧),
    (x ⊗^{M}_{l} (g ⊗^{M}_{r} z)) · (αinv_{M} x y' z)
    =
    (αinv_{M} x y z) · ((x ⊗^{M}_{l} g) ⊗^{M}_{r} z).
Proof.
  intros x y y' z g.
  apply (swap_nat_along_zisos (z_iso_from_associator_iso M x y z) (z_iso_from_associator_iso M x y' z)).
  apply monoidal_associatornatleftright.
Qed.

Definition monoidal_associatorinv_nat1
           {C : category}
           (M : monoidal C)
           {x x' y y' z z' : C}
           (f : C⟦x,x'⟧)
           (g : C⟦y,y'⟧)
           (h : C⟦z,z'⟧)
  : ((f ⊗^{M}_{r} (y ⊗_{M} z))
    · (x' ⊗^{M}_{l} ((g ⊗^{M}_{r} z) · (y' ⊗^{M}_{l} h))))
    · (αinv_{M} x' y' z')
    =
    (αinv_{M} x y z)
    · ((((f ⊗^{M}_{r} y)
    · (x' ⊗^{M}_{l} g))  ⊗^{M}_{r} z)
    · ((x' ⊗_{M} y') ⊗^{ M}_{l} h)).
Proof.
  apply (swap_nat_along_zisos
           (z_iso_from_associator_iso M x y z)
           (z_iso_from_associator_iso M x' y' z')
        ).
  unfold z_iso_from_associator_iso.
  unfold make_z_iso.
  unfold make_is_z_isomorphism.
  unfold pr1.
  apply associator_nat1.
Qed.

Lemma monoidal_associatorinv_nat2
      {C : category}
      (M : monoidal C)
      {x x' y y' z z' : C}
      (f : C⟦x,x'⟧) (g : C⟦y,y'⟧) (h : C⟦z,z'⟧)
  : (f ⊗^{M} (g ⊗^{M} h)) · (αinv_{M} x' y' z')
    =
    (αinv_{M} x y z) · ((f ⊗^{M} g) ⊗^{M} h).
Proof.
  intros.
  unfold functoronmorphisms1.
  apply monoidal_associatorinv_nat1.
Qed.

Lemma monoidal_triangle_identity_inv
      {C : category}
      (M : monoidal C)
      (x y : C)
  : x ⊗^{M}_{l} luinv_{M} y · αinv_{M} x I_{ M} y = ruinv_{M} x ⊗^{ M}_{r} y.
Proof.
  apply pathsinv0.
  apply (z_iso_inv_on_left _ _ _ _ ((z_iso_from_associator_iso M _ _ _))).
  cbn.
  set (luiy := make_z_iso _ _ (monoidal_leftunitorisolaw M y)).
  set (luixy := functor_on_z_iso (leftwhiskering_functor M x) luiy).
  set (ruix := make_z_iso _ _ (monoidal_rightunitorisolaw M x)).
  set (ruixy := functor_on_z_iso (rightwhiskering_functor M y) ruix).
  apply pathsinv0.
  apply (z_iso_inv_on_right _ _ _ ruixy).
  apply (z_iso_inv_on_left _ _ _ _ luixy).
  exact (! (monoidal_triangleidentity M) x y).
Qed.

(* another proof of the same law - could be deleted in some future: *)
Lemma monoidal_triangle_identity_inv_alt
      {C : category}
      (M : monoidal C)
      (x y : C)
  : x ⊗^{M}_{l} (luinv_{M} y) · αinv_{M} x I_{M} y  = (ruinv_{M} x) ⊗^{M}_{r} y.
Proof.
  transparent assert (auxiso1 : (z_iso (x ⊗_{ M} y) (x ⊗_{ M} (I_{ M} ⊗_{ M} y)))).
  { exists (x ⊗^{M}_{l} (luinv_{M} y)).
    apply (is_z_iso_leftwhiskering_z_iso M).
    exists (lu_{ M} y).
    split; apply monoidal_leftunitorisolaw. }
  transparent assert (auxiso2 : (z_iso (x ⊗_{ M} y) ((x ⊗_{ M} I_{ M}) ⊗_{ M} y))).
  { exists (ruinv_{ M} x ⊗^{ M}_{r} y).
    apply (is_z_iso_rightwhiskering_z_iso M).
    exists (ru_{ M} x).
    split; apply monoidal_rightunitorisolaw. }
  apply pathsinv0, (z_iso_inv_on_left _ _ _ _ (z_iso_from_associator_iso M _ _ _)).
  apply (z_iso_inv_to_left _ _ _ auxiso2).
  apply (z_iso_inv_to_right _ _ _ _ auxiso1).
  apply pathsinv0, monoidal_triangleidentity.
Qed.

Lemma monoidal_pentagon_identity_inv
      {C : category}
      (M : monoidal C)
      (w x y z : C)
  : w ⊗^{ M}_{l} (αinv_{M} x y z)
    · αinv_{M} w (x ⊗_{ M} y) z
    · αinv_{M} w x y ⊗^{ M}_{r} z
    =
    αinv_{M} w x (y ⊗_{ M} z)
    · αinv_{M} (w ⊗_{ M} x) y z.
Proof.
  apply pathsinv0.
  apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso M _ _ _)).
  unfold z_iso_from_associator_iso.
  unfold make_z_iso.
  unfold make_is_z_isomorphism.
  etrans. { apply (pathsinv0 (id_right _)). }
  apply (z_iso_inv_on_right _ _ _ (z_iso_from_associator_iso M _ _ _)).
  cbn.
  apply pathsinv0.
  etrans. {
   rewrite assoc.
   apply cancel_postcomposition.
   apply (pathsinv0 (monoidal_pentagonidentity M w x y z)).
  }
  etrans. {
    rewrite assoc.
    rewrite assoc.
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    rewrite assoc'.
    apply cancel_precomposition.
    apply (pathsinv0 (bifunctor_leftcomp M _ _ _ _ _ _)).
  }
  etrans. {
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    apply cancel_precomposition.
    apply maponpaths.
    apply (pr2 (z_iso_from_associator_iso M x y z)).
  }
  etrans. {
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    apply cancel_precomposition.
    apply (bifunctor_leftid M).
  }
  etrans. {
    apply cancel_postcomposition.
    apply cancel_postcomposition.
    apply id_right.
  }
  etrans. {
    apply cancel_postcomposition.
    rewrite assoc'.
    apply cancel_precomposition.
    apply (pr2 (z_iso_from_associator_iso M w (x⊗_{M}y) z)).
  }
  etrans. {
    apply cancel_postcomposition.
    apply id_right.
  }
  etrans. {
    apply (pathsinv0 (bifunctor_rightcomp M _ _ _ _ _ _)).
  }
  etrans. {
    apply maponpaths.
    apply (pr2 (pr2 (z_iso_from_associator_iso M w x y))).
  }
  apply (bifunctor_rightid M).
Qed.

End A.

Module MonoidalNotations.
  Notation "I_{ M }" := (monoidal_unit M) : cat.
  Notation "lu_{ M }" := (monoidal_leftunitordata M) : cat.
  Notation "luinv_{ M }" := (monoidal_leftunitorinvdata M) : cat.
  Notation "ru_{ M }" := (monoidal_rightunitordata M) : cat.
  Notation "ruinv_{ M }" := (monoidal_rightunitorinvdata M) : cat.
  Notation "α_{ M }" := (monoidal_associatordata M) : cat.
  Notation "αinv_{ M }" := (monoidal_associatorinvdata M) : cat.
  Notation "lu^{ M }_{ x }" := (monoidal_leftunitordata M x ) : cat.
  Notation "ru^{ M }_{ x }" := ( monoidal_rightunitordata M x ) : cat.
  Notation "α^{ M }_{ x , y , z }" := (monoidal_associatordata M x y z) : cat.
  Notation "luinv^{ M }_{ x }" := (monoidal_leftunitorinvdata M x ) : cat.
  Notation "ruinv^{ M }_{ x }" := ( monoidal_rightunitorinvdata M x ) : cat.
  Notation "αinv^{ M }_{ x , y , z }" := (monoidal_associatorinvdata M x y z) : cat.
End MonoidalNotations.

(**
 2. Opposite monoidal category
 *)
Section OppositeMonoidal.
  Context {C : category} (M : monoidal C).

  Import MonoidalNotations.

  Definition monoidal_opp_tensor_data : bifunctor_data C^op C^op C^op.
  Proof.
    exists (pr11 (monoidal_tensor M)).
    exists (λ x _ _ g, x ⊗^{M}_{l} g).
    exact (λ x _ _ f, f ⊗^{M}_{r} x).
  Defined.

  Lemma monoidal_opp_is_tensor : is_bifunctor monoidal_opp_tensor_data.
  Proof.
    repeat split ; (try (intro ; intros) ; try apply (pr2 (monoidal_tensor M))).
    exact (! bifunctor_equalwhiskers M a2 a1 b2 b1 f g).
  Qed.

  Definition monoidal_opp_tensor : bifunctor C^op C^op C^op
    := monoidal_opp_tensor_data ,, monoidal_opp_is_tensor.

  Definition monoidal_opp_data : monoidal_data C^op.
  Proof.
    exists monoidal_opp_tensor_data.
    exists I_{M}.
    exists luinv_{M}.
    exists lu_{M}.
    exists ruinv_{M}.
    exists ru_{M}.
    exists αinv_{M}.
    exact α_{M}.
  Defined.

  Definition monoidal_opp_laws : monoidal_laws monoidal_opp_data.
  Proof.
    repeat split.
    - intro ; intros.
      apply (bifunctor_leftid M).
    - intro ; intros.
      apply (bifunctor_rightid M).
    - intro ; intros.
      apply (bifunctor_leftcomp M).
    - intro ; intros.
      apply (bifunctor_rightcomp M).
    - intro ; intros.
      exact (!(bifunctor_equalwhiskers M _ _ _ _ f g)).
    - intro ; intros ; apply monoidal_leftunitorinvnat.
    - apply (monoidal_leftunitorisolaw M).
    - apply (monoidal_leftunitorisolaw M).
    - intro ; intros ; apply monoidal_rightunitorinvnat.
    - apply (monoidal_rightunitorisolaw M).
    - apply (monoidal_rightunitorisolaw M).
    - intro ; intros ; apply monoidal_associatorinvnatleft.
    - intro ; intros ; apply monoidal_associatorinvnatright.
    - intro ; intros ; apply monoidal_associatorinvnatleftright.
    - apply (monoidal_associatorisolaw M).
    - apply (monoidal_associatorlaw M).
    - intro ; intros ; apply monoidal_triangle_identity_inv.
    - intros w x y z.
      refine (_ @ monoidal_pentagon_identity_inv M w x y z).
      simpl ; apply assoc.
  Qed.

  Definition monoidal_opp : monoidal C^op
    := monoidal_opp_data ,, monoidal_opp_laws.
End OppositeMonoidal.

(**
 3. Equivalences from the tensor and unit
 *)
Section EquivalenceFromTensorWithUnit.
  Context {C : category} (M : monoidal C).

  Import MonoidalNotations.

  Definition ladjunction_data_from_tensor_with_unit
    : adjunction_data C C.
  Proof.
    exists (leftwhiskering_functor M I_{M}).
    exists (functor_identity C).
    use tpair.
    - apply (nat_z_iso_inv (leftunitor_nat_z_iso M)).
    - apply (leftunitor_nat_z_iso M).
  Defined.

  Definition lequivalence_from_tensor_with_unit
    : equivalence_of_cats C C.
  Proof.
    exists ladjunction_data_from_tensor_with_unit.
    split.
    - intro ; apply (nat_z_iso_inv (leftunitor_nat_z_iso M)).
    - intro ; apply (leftunitor_nat_z_iso M).
  Defined.

  Definition radjunction_data_from_tensor_with_unit
    : adjunction_data C C.
  Proof.
    exists (rightwhiskering_functor M I_{M}).
    exists (functor_identity C).
    use tpair.
    - apply (nat_z_iso_inv (rightunitor_nat_z_iso M)).
    - apply (rightunitor_nat_z_iso M).
  Defined.

  Definition requivalence_from_tensor_with_unit
    : equivalence_of_cats C C.
  Proof.
    exists radjunction_data_from_tensor_with_unit.
    split.
    - intro ; apply (nat_z_iso_inv (rightunitor_nat_z_iso M)).
    - intro ; apply (rightunitor_nat_z_iso M).
  Defined.

  Lemma leftwhiskering_fullyfaithful
    : fully_faithful (leftwhiskering_functor M I_{M}).
  Proof.
    apply fully_faithful_from_equivalence.
    exact (adjointificiation lequivalence_from_tensor_with_unit).
  Defined.

  Lemma rightwhiskering_fullyfaithful
    : fully_faithful (rightwhiskering_functor M I_{M}).
  Proof.
    apply fully_faithful_from_equivalence.
    exact (adjointificiation requivalence_from_tensor_with_unit).
  Defined.

  Lemma leftwhiskering_faithful
    : faithful (leftwhiskering_functor M I_{M}).
  Proof.
    exact (pr2 (fully_faithful_implies_full_and_faithful _ _ _ leftwhiskering_fullyfaithful)).
  Defined.

  Lemma rightwhiskering_faithful
    : faithful (rightwhiskering_functor M I_{M}).
  Proof.
    exact (pr2 (fully_faithful_implies_full_and_faithful _ _ _ rightwhiskering_fullyfaithful)).
  Defined.
End EquivalenceFromTensorWithUnit.

(**
 4. The unitors coincide
 *)
Section UnitorsCoincide.
  Context {C : category} (M : monoidal C).

  Import MonoidalNotations.

  Local Lemma lemma0 (x y : C) :
    ((α_{M} I_{M} I_{M} x) ⊗^{M}_{r} y) · ((I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y) =
    (ru_{M} I_{M} ⊗^{M}_{r} x) ⊗^{M}_{r} y.
  Proof.
    refine (! bifunctor_rightcomp M _ _ _ _ _ _ @ _).
    apply maponpaths.
    apply (monoidal_triangleidentity M I_{M} x).
  Qed.

  Local Lemma lemma1 (x y : C) :
    α_{M} I_{M} (I_{M} ⊗_{M} x) y · (I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y)) =
      ((I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y) · α_{M} I_{M} x y.
  Proof.
    apply monoidal_associatornatleftright.
  Qed.

  Local Lemma lemma2 (x y : C) :
    I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y) = αinv_{M} I_{M} (I_{M} ⊗_{M} x) y · (((I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y) · α_{M} I_{M} x y).
  Proof.
    set (αiso := make_z_iso _ _ (monoidal_associatorisolaw M  I_{ M} (I_{ M} ⊗_{ M} x) y)).
    apply pathsinv0.
    apply (z_iso_inv_on_right _ _ _ αiso).
    apply pathsinv0.
    apply lemma1.
  Qed.

  Local Lemma lemma2' (x y : C) :
    (I_{M} ⊗^{M}_{l} lu_{M} x) ⊗^{M}_{r} y =
      ((αinv_{M} I_{M} I_{M} x) ⊗^{M}_{r} y) · (ru_{M} I_{M} ⊗^{M}_{r} x) ⊗^{M}_{r} y.
  Proof.
    apply pathsinv0.
    set (αiso := make_z_iso _ _ (monoidal_associatorisolaw M  I_{ M} I_{ M} x)).
    set (αisor := functor_on_z_iso (rightwhiskering_functor M y) αiso).
    apply (z_iso_inv_on_right _ _ _ αisor).
    apply pathsinv0.
    apply lemma0.
  Qed.

  Local Lemma lemma3 (x y : C) :
    I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y) =
      αinv_{M} I_{M} (I_{M} ⊗_{M} x) y
        · ((((αinv_{M} I_{M} I_{M} x) ⊗^{M}_{r} y)
        · (ru_{M} I_{M} ⊗^{M}_{r} x) ⊗^{M}_{r} y)
        · α_{M} I_{M} x y).
  Proof.
    refine (lemma2 x y @ _).
    apply maponpaths.
    apply maponpaths_2.
    apply lemma2'.
  Qed.

  Local Lemma right_whisker_with_lunitor' (x y : C)
    : I_{M} ⊗^{M}_{l} (lu_{M} x ⊗^{M}_{r} y)
      =
      I_{M} ⊗^{M}_{l} (α_{M} I_{M} x y · lu_{M} (x ⊗_{M} y)).
  Proof.
    refine (lemma3 x y @ _).
    set (αiso := make_z_iso _ _ (monoidal_associatorisolaw M  I_{ M} (I_{ M} ⊗_{M} x) y)).
    apply (z_iso_inv_on_right _ _ _ αiso).
    set (αiso' := make_z_iso _ _ (monoidal_associatorisolaw M  I_{ M} I_{ M} x)).
    set (αisor := functor_on_z_iso (rightwhiskering_functor M y) αiso').
    etrans. { apply assoc'. }
    apply (z_iso_inv_on_right _ _ _ αisor).
    apply pathsinv0.
    simpl.

    etrans. { apply assoc. }
    etrans.
    {
      apply maponpaths.
      apply (bifunctor_leftcomp M _ _ _ _ _ _).
    }

    etrans. { apply assoc. }
    etrans. {
      apply maponpaths_2.
      apply (monoidal_pentagonidentity M I_{M} I_{M} x y).
    }

    etrans.
    2: {
      apply (associatorlaw_natright (monoidal_associatorlaw M)).
    }

    etrans. { apply assoc'. }
    apply maponpaths.
    apply monoidal_triangleidentity.
  Qed.

  Lemma right_whisker_with_lunitor : triangle_identity' lu_{M} α_{M}.
  Proof.
    intros x y.
    use faithful_reflects_commutative_triangle.
    3: { apply leftwhiskering_faithful. }
    apply pathsinv0.
    refine (right_whisker_with_lunitor' _ _ @ _).
    apply (bifunctor_leftcomp (monoidal_tensor M)).
  Qed.

  Definition monoidal_triangleidentity' := right_whisker_with_lunitor.

  Lemma monoidal_triangle_identity'_inv (x y : C)
  : luinv_{M} (x ⊗_{M} y) · αinv_{M} I_{M} x y = luinv_{M} x ⊗^{M}_{r} y.
  Proof.
    apply pathsinv0.
    apply (z_iso_inv_on_left _ _ _ _ ((z_iso_from_associator_iso M _ _ _))).
    cbn.
    set (luix := make_z_iso _ _ (monoidal_leftunitorisolaw M x)).
    set (luixy := functor_on_z_iso (rightwhiskering_functor M y) luix).
    set (luipxy := make_z_iso _ _ (monoidal_leftunitorisolaw M (x ⊗_{ M} y))).
    apply pathsinv0.
    apply (z_iso_inv_on_right _ _ _ luixy).
    apply (z_iso_inv_on_left _ _ _ _ luipxy).
    exact (! monoidal_triangleidentity' x y).
  Qed.

  Lemma lunitor_preserves_leftwhiskering_with_unit
    : lu^{M}_{I_{ M} ⊗_{M} I_{M}} = I_{M} ⊗^{ M}_{l} lu^{M}_{I_{ M}}.
  Proof.
    apply pathsinv0.
    set (lun := monoidal_leftunitornat M _ _ (lu_{M} (I_{M}))).
    etrans. { apply (! id_right _). }
    etrans.
    2: { apply id_right. }

    etrans. {
      apply maponpaths.
      exact (! pr1 (monoidal_leftunitorisolaw M I_{ M})).
    }
    etrans. { apply assoc. }
    etrans. { apply maponpaths_2 ; exact lun. }
    etrans. { apply assoc'. }
    apply maponpaths.
    apply monoidal_leftunitorisolaw.
  Qed.

  Lemma unitors_coincide_on_unit'
    : lu_{M} I_{M} ⊗^{M}_{r} I_{M} = ru_{M} I_{M} ⊗^{M}_{r} I_{M}.
  Proof.
    refine (! right_whisker_with_lunitor I_{M} I_{M} @ _).
    refine (_ @ monoidal_triangleidentity M I_{M} I_{M}).
    apply maponpaths.
    apply lunitor_preserves_leftwhiskering_with_unit.
  Qed.

  Lemma unitors_coincide_on_unit
    : lu_{M} I_{M} = ru_{M} I_{M}.
  Proof.
    refine (! id_right _ @ _).
    use faithful_reflects_commutative_triangle.
    3: { apply rightwhiskering_faithful. }
    refine (_ @ unitors_coincide_on_unit').
    etrans. {
      apply maponpaths.
      apply bifunctor_rightid.
    }
    apply id_right.
  Qed.

  Corollary unitorsinv_coincide_on_unit
    : luinv_{M} I_{M} = ruinv_{M} I_{M}.
  Proof.
    apply (cancel_z_iso _ _ (lu_{M} I_{M},,(luinv_{M} I_{M},,monoidal_leftunitorisolaw M I_{M}))).
    cbn.
    etrans.
    2: { rewrite unitors_coincide_on_unit.
         apply pathsinv0, (monoidal_rightunitorisolaw M I_{M}). }
    apply (monoidal_leftunitorisolaw M I_{M}).
  Qed.
End UnitorsCoincide.

(* Using the lemma for a different category, hence outside of the section. *)

Section UnitorsCoincideAlternative.
  Import MonoidalNotations.

  Lemma unitorsinv_coincide_on_unit_alt {C : category} (M : monoidal C)
    : luinv_{M} I_{M} = ruinv_{M} I_{M}.
  Proof.
    exact (unitors_coincide_on_unit (monoidal_opp M)).
  Qed.
End UnitorsCoincideAlternative.

(**
 5. Swapping the tensor
 *)
Section MonoidalSwapped.
  Import MonoidalNotations.

  Definition tensor_swapped {V : category} (Mon_V : monoidal V)
    : tensor_data V.
  Proof.
    repeat (use tpair).
    - intros v w.
      exact (w ⊗_{Mon_V} v).
    - intros v w1 w2 f.
      exact (f ⊗^{Mon_V}_{r} v).
    - intros v w1 w2 f.
      exact (v ⊗^{Mon_V}_{l} f).
  Defined.

  Definition monoidal_swapped_data {V : category} (Mon_V : monoidal V)
    : monoidal_data V.
  Proof.
    exists (tensor_swapped Mon_V).
    exists I_{Mon_V}.
    exists (λ v, ru_{Mon_V} v).
    exists (λ v, ruinv_{Mon_V} v).
    exists (λ v, lu_{Mon_V} v).
    exists (λ v, luinv_{Mon_V} v).
    exists (λ v1 v2 v3, αinv_{Mon_V} v3 v2 v1).
    exact (λ v1 v2 v3, α_{Mon_V} v3 v2 v1).
  Defined.

  Lemma monoidal_swapped_laws {V : category} (Mon_V : monoidal V)
    : monoidal_laws (monoidal_swapped_data Mon_V).
  Proof.
    repeat split.
    - intro ; intro ; apply (bifunctor_rightid Mon_V).
    - intro ; intro ; apply (bifunctor_leftid Mon_V).
    - intro ; intros ; apply (bifunctor_rightcomp Mon_V).
    - intro ; intros ; apply (bifunctor_leftcomp Mon_V).
    - intro ; intros ; apply (! bifunctor_equalwhiskers Mon_V _ _ _ _ _ _).
    - intro ; intros ; apply monoidal_rightunitornat.
    - apply monoidal_rightunitorisolaw.
    - apply monoidal_rightunitorisolaw.
    - intro ; intros ; apply monoidal_leftunitornat.
    - apply monoidal_leftunitorisolaw.
    - apply monoidal_leftunitorisolaw.
    - intro ; intros ; apply (! monoidal_associatorinvnatright Mon_V _ _ _ _ _).
    - intro ; intros ; apply (! monoidal_associatorinvnatleft Mon_V _ _ _ _ _).
    - intro ; intros ; apply (! monoidal_associatorinvnatleftright Mon_V _ _ _ _ _).
    - apply monoidal_associatorisolaw.
    - apply monoidal_associatorisolaw.
    - intro ; intros.
      cbn.
      rewrite (! monoidal_triangleidentity Mon_V _ _).
      rewrite assoc.
      rewrite (pr2 (monoidal_associatorisolaw Mon_V _ _ _)).
      apply id_left.
    - intro ; intros ; apply monoidal_pentagon_identity_inv.
  Qed.

  Definition monoidal_swapped {V : category} (Mon_V : monoidal V)
    : monoidal V
    := monoidal_swapped_data Mon_V ,, monoidal_swapped_laws Mon_V.
End MonoidalSwapped.

(**
 6. More monoidal laws
 *)
Section MonoidalLaws.
  Import MonoidalNotations.

  Lemma left_whisker_with_runitor {C : category} (M : monoidal C)
    : triangle_identity'' ru_{M} α_{M}.
  Proof.
    red; intros x y.
    assert (aux := right_whisker_with_lunitor (monoidal_swapped M) y x).
    cbn in aux.
    rewrite <- aux.
    rewrite assoc.
    etrans.
    { apply cancel_postcomposition.
      apply monoidal_associatorisolaw. }
    apply id_left.
  Qed.

  Lemma monoidal_triangle_identity''_inv {C : category} (M : monoidal C) (x y : C)
    : x ⊗^{M}_{l} (ruinv_{M} y) · αinv_{M} x y I_{M} = ruinv_{M} (x ⊗_{M} y).
  Proof.
    apply pathsinv0.
    apply (z_iso_inv_on_left _ _ _ _ ((z_iso_from_associator_iso M _ _ _))).
    cbn.
    set (ruiy := make_z_iso _ _ (monoidal_rightunitorisolaw M y)).
    set (ruiyx := functor_on_z_iso (leftwhiskering_functor M x) ruiy).
    set (ruipxy := make_z_iso _ _ (monoidal_rightunitorisolaw M (x ⊗_{ M} y))).
    apply pathsinv0.
    apply (z_iso_inv_on_right _ _ _ ruipxy).
    apply (z_iso_inv_on_left _ _ _ _ ruiyx).
    exact (! (left_whisker_with_runitor M) x y).
  Qed.
End MonoidalLaws.

(**
 7. Bundled approach to monoidal categories
 *)
(** Accessors and notations for monoidal categories *)
Declare Scope moncat.
Local Open Scope moncat.

Definition monoidal_cat : UU := ∑ (C : category), monoidal C.

Coercion monoidal_cat_to_cat (V : monoidal_cat) : category := pr1 V.
Coercion monoidal_cat_to_monoidal (V : monoidal_cat) : monoidal V := pr2 V.

Definition monoidal_cat_tensor_pt
           {V : monoidal_cat}
           (x y : V)
  : V
  := x ⊗_{ pr2 V } y.

Notation "x ⊗ y" :=  (monoidal_cat_tensor_pt x y) : moncat.

Definition monoidal_cat_tensor_mor
           {V : monoidal_cat}
           {x₁ x₂ y₁ y₂ : V}
           (f : x₁ --> x₂)
           (g : y₁ --> y₂)
  : x₁ ⊗ y₁ --> x₂ ⊗ y₂
  := f ⊗^{ pr2 V } g.

Notation "f #⊗ g" := (monoidal_cat_tensor_mor f g) (at level 31) : moncat.

Section MonoidalCatAccessors.
  Context {V : monoidal_cat}.

  Import MonoidalNotations.

  Definition tensor_id_id
             (x y : V)
    : identity x #⊗ identity y = identity (x ⊗ y).
  Proof.
    apply bifunctor_distributes_over_id.
    - apply (bifunctor_leftid V).
    - apply (bifunctor_rightid V).
  Qed.

  Definition tensor_comp_mor
             {x₁ x₂ x₃ y₁ y₂ y₃ : V}
             (f : x₁ --> x₂) (f' : x₂ --> x₃)
             (g : y₁ --> y₂) (g' : y₂ --> y₃)
    : (f · f') #⊗ (g · g') = f #⊗ g · f' #⊗ g'.
  Proof.
    use bifunctor_distributes_over_comp.
    - apply (bifunctor_leftcomp V).
    - apply (bifunctor_rightcomp V).
    - apply (bifunctor_equalwhiskers V).
  Qed.

  Definition tensor_comp_id_l
             {x y₁ y₂ y₃ : V}
             (g : y₁ --> y₂) (g' : y₂ --> y₃)
    : (identity x) #⊗ (g · g') = (identity x) #⊗ g · (identity x) #⊗ g'.
  Proof.
    rewrite <- tensor_comp_mor.
    rewrite id_left.
    apply idpath.
  Qed.

  Definition tensor_comp_l_id_l
             {x₁ x₂ y₁ y₂ y₃ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂) (g' : y₂ --> y₃)
    : f #⊗ (g · g') = (identity _) #⊗ g · f #⊗ g'.
  Proof.
    rewrite <- tensor_comp_mor.
    rewrite id_left.
    apply idpath.
  Qed.

  Definition tensor_comp_l_id_r
             {x₁ x₂ y₁ y₂ y₃ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂) (g' : y₂ --> y₃)
    : f #⊗ (g · g') = f #⊗ g · (identity _) #⊗ g'.
  Proof.
    rewrite <- tensor_comp_mor.
    rewrite id_right.
    apply idpath.
  Qed.

  Definition tensor_comp_id_r
             {x₁ x₂ x₃ y : V}
             (f : x₁ --> x₂) (f' : x₂ --> x₃)
    : (f · f') #⊗ (identity y) = f #⊗ (identity y) · f' #⊗ (identity y).
  Proof.
    rewrite <- tensor_comp_mor.
    rewrite id_left.
    apply idpath.
  Qed.

  Definition tensor_comp_r_id_l
             {x₁ x₂ x₃ y₁ y₂ : V}
             (f : x₁ --> x₂) (f' : x₂ --> x₃)
             (g : y₁ --> y₂)
    : (f · f') #⊗ g = f #⊗ (identity _) · f' #⊗ g.
  Proof.
    rewrite <- tensor_comp_mor.
    rewrite id_left.
    apply idpath.
  Qed.

  Definition tensor_comp_r_id_r
             {x₁ x₂ x₃ y₁ y₂ : V}
             (f : x₁ --> x₂) (f' : x₂ --> x₃)
             (g : y₁ --> y₂)
    : (f · f') #⊗ g = f #⊗ g · f' #⊗ (identity _).
  Proof.
    rewrite <- tensor_comp_mor.
    rewrite id_right.
    apply idpath.
  Qed.

  Definition tensor_split
             {x₁ x₂ y₁ y₂ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : f #⊗ g = identity _ #⊗ g · f #⊗ identity _.
  Proof.
    refine (_ @ tensor_comp_mor _ _ _ _).
    rewrite id_left, id_right.
    apply idpath.
  Qed.

  Definition tensor_split'
             {x₁ x₂ y₁ y₂ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : f #⊗ g = f #⊗ identity _ · identity _ #⊗ g.
  Proof.
    refine (_ @ tensor_comp_mor _ _ _ _).
    rewrite id_left, id_right.
    apply idpath.
  Qed.

  Definition tensor_swap
             {x₁ x₂ y₁ y₂ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : f #⊗ identity _ · identity _ #⊗ g = identity _ #⊗ g · f #⊗ identity _.
  Proof.
    rewrite <- tensor_split, <- tensor_split'.
    apply idpath.
  Qed.

  Definition tensor_swap'
             {x₁ x₂ y₁ y₂ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
    : identity _ #⊗ g · f #⊗ identity _ = f #⊗ identity _ · identity _ #⊗ g.
  Proof.
    rewrite <- tensor_split, <- tensor_split'.
    apply idpath.
  Qed.

  Definition mon_lunitor
             (x : V)
    : I_{V} ⊗ x --> x
    := monoidal_leftunitordata V x.

  Definition tensor_lunitor
             {x y : V}
             (f : x --> y)
    : identity _ #⊗ f · mon_lunitor y
      =
      mon_lunitor x · f.
  Proof.
    refine (_ @ pr1 (monoidal_leftunitorlaw V) x y f).
    apply maponpaths_2.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (_ @ id_left _).
    apply maponpaths_2.
    apply (bifunctor_rightid V).
  Qed.

  Definition mon_linvunitor
             (x : V)
    : x --> I_{V} ⊗ x
    := monoidal_leftunitorinvdata V x.

  Definition tensor_linvunitor
             {x y : V}
             (f : x --> y)
    : f · mon_linvunitor y
      =
      mon_linvunitor x · identity _ #⊗ f.
  Proof.
    refine (!(monoidal_leftunitorinvnat V x y f) @ _).
    apply maponpaths.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (!(id_left _) @ _).
    apply maponpaths_2.
    refine (!_).
    apply (bifunctor_rightid V).
  Qed.

  Definition mon_lunitor_linvunitor
             (x : V)
    : mon_lunitor x · mon_linvunitor x = identity _.
  Proof.
    exact (pr1 (monoidal_leftunitorisolaw V x)).
  Qed.

  Definition mon_linvunitor_lunitor
             (x : V)
    : mon_linvunitor x · mon_lunitor x = identity _.
  Proof.
    exact (pr2 (monoidal_leftunitorisolaw V x)).
  Qed.

  Definition mon_runitor
             (x : V)
    : x ⊗ I_{V} --> x
    := monoidal_rightunitordata V x.

  Definition tensor_runitor
             {x y : V}
             (f : x --> y)
    : f #⊗ identity _ · mon_runitor y
      =
      mon_runitor x · f.
  Proof.
    refine (_ @ pr1 (monoidal_rightunitorlaw V) x y f).
    apply maponpaths_2.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (_ @ id_right _).
    apply maponpaths.
    apply (bifunctor_leftid V).
  Qed.

  Definition mon_rinvunitor
             (x : V)
    : x --> x ⊗ I_{V}
    := monoidal_rightunitorinvdata V x.

  Definition tensor_rinvunitor
             {x y : V}
             (f : x --> y)
    : f · mon_rinvunitor y
      =
      mon_rinvunitor x · f #⊗ identity _.
  Proof.
    refine (!(monoidal_rightunitorinvnat V x y f) @ _).
    apply maponpaths.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (!(id_right _) @ _).
    apply maponpaths.
    refine (!_).
    apply (bifunctor_leftid V).
  Qed.

  Definition mon_runitor_rinvunitor
             (x : V)
    : mon_runitor x · mon_rinvunitor x = identity _.
  Proof.
    exact (pr1 (monoidal_rightunitorisolaw V x)).
  Qed.

  Definition mon_rinvunitor_runitor
             (x : V)
    : mon_rinvunitor x · mon_runitor x = identity _.
  Proof.
    exact (pr2 (monoidal_rightunitorisolaw V x)).
  Qed.

  Definition mon_lassociator
             (x y z : V)
    : (x ⊗ y) ⊗ z --> x ⊗ (y ⊗ z)
    := α_{ V } x y z.

  Definition tensor_lassociator
             {x₁ x₂ y₁ y₂ z₁ z₂ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
             (h : z₁ --> z₂)
    : (f #⊗ g) #⊗ h · mon_lassociator _ _ _
      =
      mon_lassociator _ _ _ · f #⊗ (g #⊗ h).
  Proof.
    refine (!_).
    apply associator_nat2.
  Qed.

  Definition mon_rassociator
             (x y z : V)
    : x ⊗ (y ⊗ z) --> (x ⊗ y) ⊗ z
    := αinv_{ V } x y z.

  Definition tensor_rassociator
             {x₁ x₂ y₁ y₂ z₁ z₂ : V}
             (f : x₁ --> x₂)
             (g : y₁ --> y₂)
             (h : z₁ --> z₂)
    : f #⊗ (g #⊗ h) · mon_rassociator _ _ _
      =
      mon_rassociator _ _ _ · (f #⊗ g) #⊗ h.
  Proof.
    exact (monoidal_associatorinv_nat2 V f g h).
  Qed.

  Definition mon_lassociator_rassociator
             (x y z : V)
    : mon_lassociator x y z · mon_rassociator x y z = identity _.
  Proof.
    exact (pr1 (monoidal_associatorisolaw V x y z)).
  Qed.

  Definition mon_rassociator_lassociator
             (x y z : V)
    : mon_rassociator x y z · mon_lassociator x y z = identity _.
  Proof.
    exact (pr2 (monoidal_associatorisolaw V x y z)).
  Qed.

  Definition mon_triangle
             (x y : V)
    : mon_runitor x #⊗ identity y
      =
      mon_lassociator x I_{V} y · (identity x #⊗ mon_lunitor y).
  Proof.
    refine (_ @ !(monoidal_triangleidentity V x y) @ _).
    - unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      refine (_ @ id_right _).
      apply maponpaths.
      apply (bifunctor_leftid V).
    - apply maponpaths.
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      refine (!(id_left _) @ _).
      apply maponpaths_2.
      refine (!_).
      apply (bifunctor_rightid V).
  Qed.

  Definition mon_inv_triangle
             (x y : V)
    : identity x #⊗ mon_linvunitor y
      =
      mon_rinvunitor x #⊗ identity y · mon_lassociator x (I_{V}) y.
  Proof.
    refine (!_).
    etrans.
    {
      apply maponpaths_2.
      refine (_ @ !(monoidal_triangle_identity_inv V x y)).
      unfold monoidal_cat_tensor_mor.
      unfold functoronmorphisms1.
      refine (_ @ id_right _).
      apply maponpaths.
      apply (bifunctor_leftid V).
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      apply mon_rassociator_lassociator.
    }
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    rewrite (whiskerscommutes V).
    - apply maponpaths.
      refine (!_).
      apply (bifunctor_rightid V).
    - apply (bifunctor_equalwhiskers V).
  Qed.

  Definition mon_lunitor_triangle
             (x y : V)
    : mon_lassociator (I_{V}) x y · mon_lunitor (x ⊗ y)
      =
      mon_lunitor x #⊗ identity y.
  Proof.
    refine (right_whisker_with_lunitor V x y @ _).
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (!(id_right _) @ _).
    apply maponpaths.
    refine (!_).
    apply (bifunctor_leftid V).
  Qed.

  Definition mon_linvunitor_triangle
             (x y : V)
    : mon_linvunitor x #⊗ identity y · mon_lassociator (I_{V}) x y
      =
      mon_linvunitor (x ⊗ y).
  Proof.
    refine (!(id_right _) @ _).
    etrans.
    {
      apply maponpaths.
      exact (!(mon_lunitor_linvunitor _)).
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      apply mon_lunitor_triangle.
    }
    rewrite !assoc.
    refine (_ @ id_left _).
    apply maponpaths_2.
    rewrite <- tensor_comp_id_r.
    rewrite mon_linvunitor_lunitor.
    apply tensor_id_id.
  Qed.

  Definition mon_runitor_triangle
             (x y : V)
    : mon_rassociator x y (I_{V}) · mon_runitor (x ⊗ y)
      =
      identity x #⊗ mon_runitor y.
  Proof.
    etrans.
    {
      apply maponpaths.
      exact (!(left_whisker_with_runitor V x y)).
    }
    rewrite !assoc.
    etrans.
    {
      apply maponpaths_2.
      apply mon_rassociator_lassociator.
    }
    rewrite id_left.
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    refine (!(id_left _) @ _).
    apply maponpaths_2.
    refine (!_).
    apply (bifunctor_rightid V).
  Qed.

  Definition mon_rinvunitor_triangle
             (x y : V)
    : identity x #⊗ mon_rinvunitor y · mon_rassociator x y (I_{V})
      =
      mon_rinvunitor (x ⊗ y).
  Proof.
    refine (!(id_right _) @ _).
    etrans.
    {
      apply maponpaths.
      exact (!(mon_runitor_rinvunitor _)).
    }
    rewrite !assoc'.
    etrans.
    {
      apply maponpaths.
      rewrite !assoc.
      apply maponpaths_2.
      apply mon_runitor_triangle.
    }
    rewrite !assoc.
    refine (_ @ id_left _).
    apply maponpaths_2.
    rewrite <- tensor_comp_id_l.
    rewrite mon_rinvunitor_runitor.
    apply tensor_id_id.
  Qed.

  Definition mon_runitor_I_mon_lunitor_I
    : mon_runitor (I_{V}) = mon_lunitor (I_{V}).
  Proof.
    refine (!_).
    apply unitors_coincide_on_unit.
  Qed.

  Definition mon_lunitor_I_mon_runitor_I
    : mon_lunitor (I_{V}) = mon_runitor (I_{V}).
  Proof.
    rewrite mon_runitor_I_mon_lunitor_I.
    apply idpath.
  Qed.

  Definition mon_rinvunitor_I_mon_linvunitor_I
    : mon_rinvunitor (I_{V}) = mon_linvunitor (I_{V}).
  Proof.
    cbn.
    refine (!_).
    apply unitorsinv_coincide_on_unit.
  Qed.

  Definition mon_linvunitor_I_mon_rinvunitor_I
    : mon_linvunitor (I_{V}) = mon_rinvunitor (I_{V}).
  Proof.
    rewrite mon_rinvunitor_I_mon_linvunitor_I.
    apply idpath.
  Qed.

  Proposition mon_lassociator_lassociator
              {w x y z : V}
    : mon_lassociator (w ⊗ x) y z
      · mon_lassociator w x (y ⊗ z)
      =
      mon_lassociator w x y #⊗ identity z
      · mon_lassociator w (x ⊗ y) z
      · identity w #⊗ mon_lassociator x y z.
  Proof.
    refine (!(monoidal_pentagonidentity V w x y z) @ _).
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    rewrite (bifunctor_rightid V).
    rewrite (bifunctor_leftid V).
    rewrite !id_left, id_right.
    apply idpath.
  Qed.

  Proposition mon_rassociator_rassociator
              {w x y z : V}
    : mon_rassociator w x (y ⊗ z)
      · mon_rassociator (w ⊗ x) y z
      =
      identity w #⊗ mon_rassociator x y z
      · mon_rassociator w (x ⊗ y) z
      · mon_rassociator w x y #⊗ identity z.
  Proof.
    refine (!(monoidal_pentagon_identity_inv V w x y z) @ _).
    unfold monoidal_cat_tensor_mor.
    unfold functoronmorphisms1.
    rewrite (bifunctor_rightid V).
    rewrite (bifunctor_leftid V).
    rewrite !id_left, id_right.
    apply idpath.
  Qed.

  Definition monoidal_left_tensor_data
             (x : V)
    : functor_data V V.
  Proof.
    use make_functor_data.
    - exact (λ y, x ⊗ y).
    - exact (λ y₁ y₂ f, identity x #⊗ f).
  Defined.

  Proposition is_functor_monoidal_left_tensor
              (x : V)
    : is_functor (monoidal_left_tensor_data x).
  Proof.
    split.
    - intros y ; cbn.
      apply tensor_id_id.
    - intros y₁ y₂ y₃ f g ; cbn.
      apply tensor_comp_id_l.
  Qed.

  Definition monoidal_left_tensor
             (x : V)
    : V ⟶ V.
  Proof.
    use make_functor.
    - exact (monoidal_left_tensor_data x).
    - exact (is_functor_monoidal_left_tensor x).
  Defined.

  Definition monoidal_right_tensor_data
             (y : V)
    : functor_data V V.
  Proof.
    use make_functor_data.
    - exact (λ x, x ⊗ y).
    - exact (λ x₁ x₂ f, f #⊗ identity y).
  Defined.

  Proposition is_functor_monoidal_right_tensor
              (y : V)
    : is_functor (monoidal_right_tensor_data y).
  Proof.
    split.
    - intros x ; cbn.
      apply tensor_id_id.
    - intros x₁ x₂ x₃ f g ; cbn.
      apply tensor_comp_id_r.
  Qed.

  Definition monoidal_right_tensor
             (y : V)
    : V ⟶ V.
  Proof.
    use make_functor.
    - exact (monoidal_right_tensor_data y).
    - exact (is_functor_monoidal_right_tensor y).
  Defined.
End MonoidalCatAccessors.

Definition monoidal_cat_tensor_data
           (V : monoidal_cat)
  : functor_data (category_binproduct V V) V.
Proof.
  use make_functor_data.
  - exact (λ x, pr1 x ⊗ pr2 x).
  - exact (λ x y f, pr1 f #⊗ pr2 f).
Defined.

Proposition is_functor_monoidal_cat_tensor
            (V : monoidal_cat)
  : is_functor (monoidal_cat_tensor_data V).
Proof.
  split.
  - intro x ; cbn.
    apply tensor_id_id.
  - intros x y z f g ; cbn.
    apply tensor_comp_mor.
Qed.

Definition monoidal_cat_tensor
           (V : monoidal_cat)
  : category_binproduct V V ⟶ V.
Proof.
  use make_functor.
  - exact (monoidal_cat_tensor_data V).
  - exact (is_functor_monoidal_cat_tensor V).
Defined.


Require Export Coq.Sorting.Permutation.
Require Export Omega.
Require Export List.
Export ListNotations.
Require Export hetList.
Require Import ZArith.
Open Scope Z_scope.

(*looks nicer in unicode*)
Definition int := Z.

Fixpoint sum (l : list int) : int :=
  match l with
      |hd::tl => hd + sum tl
      |List.nil => 0
  end.

(*split L l1 l2: L is composed of l1 and l2*)
Inductive split : list int -> list int -> list int -> Prop :=
|splitNil : split nil nil nil
|splitConsL : forall a x b1 b2 c,
                split a (b1++b2) c ->
                split (x::a) (b1++x::b2) c
|splitConsR : forall a x b c1 c2,
                split a b (c1++c2) ->
                split (x::a) b (c1++x::c2).

Inductive partition (k:int) (l:list int) : Prop :=
|partition_ : forall (l1 l2 : list int),
                sum l = k * 2 -> split l l1 l2 ->
                sum l1 = k -> sum l2 = k -> partition k l.

(*triple of integers*)
Definition vote : Type := prod (prod int int) int.

Definition add_votes v1 v2 :=
  match v1, v2 with
      |(a,b,c), (d,e,f) => (a+d,b+e,c+f)
  end.

Fixpoint score_votes vs :=
  match vs with
      |v::vs => add_votes v (score_votes vs)
      |nil => (0,0,0)
  end.

(*The convention here is that the first position corresponds to the
**candidate the manipulators want to win << p, a, b >> *)
Inductive p_wins : vote -> Prop :=
|p_wins_ : forall p a b, p > a -> p > b -> p_wins(p, a, b).

(*make a vote of weight 6k*)
Inductive mkVote k : vote -> Prop :=
|favor_a : mkVote k (k*12, k*6, 0)
|favor_b : mkVote k (k*12, 0, k*6).

(*construct a list of votes given a list of weights*)
Inductive mkVotes : list int -> list vote -> Prop :=
|mkVotesNil : mkVotes nil nil
|mkVotesNonNil : forall ks vs k v,
                   mkVotes ks vs -> mkVote k v ->
                   mkVotes (k::ks) (v::vs).

(*base_vote is the vote of the non manipulator.
**weights are the weights of the manipulators*)
Inductive manipulate (base_vote : vote) (weights : list int) : Prop :=
|manipulate_ : forall votes,
                 mkVotes weights votes ->
                 p_wins (score_votes (base_vote::votes)) ->
                 manipulate base_vote weights.

Definition reduce k (l:list int) := ((0,k*18-3,k*18-3), l).

Ltac inv H := inversion H; subst; clear H.

Ltac copy H :=
  match type of H with
      |?x => assert(x) by auto
  end.

Ltac invertHyp :=
  match goal with
      |H:exists x, ?P |- _ => inv H; try invertHyp
      |H:?A /\ ?B |- _ => inv H; try invertHyp
  end.

Theorem sumRemoveMid : forall a b c k, sum (a++b::c) = k ->
                                  sum (a++c) = k - b.
Proof.
  induction a; intros.
  {simpl in *. symmetry in H. apply Zplus_minus_eq in H. auto. }
  {simpl in *. symmetry in H. apply Zplus_minus_eq in H. eapply IHa in H.
   rewrite H. rewrite Z.add_sub_assoc. rewrite Zplus_minus. auto. }
Qed.

Ltac votesEq :=
  match goal with
      | |- (?a,?b,?c)=(?a,?b,?f) =>
        let n := fresh
        in assert(n:c=f) by omega; rewrite n; try votesEq
      | |- (?a,?b,?c)=(?a,?e,?f) =>
        let n := fresh
        in assert(n:b=e) by omega; rewrite n; try votesEq
      | |- (?a,?b,?c)=(?d,?e,?f) =>
        let n := fresh
        in assert(n:a=d) by omega; rewrite n; try votesEq
      | |- _ => eauto
  end.

Theorem mkVotesSum : forall weights l1 l2 k1 k2,
                       sum l1 = k1 -> sum l2 = k2 -> split weights l1 l2 ->
                       exists vs, mkVotes weights vs /\
                             score_votes vs = ((k1+k2)*12, k2*6, k1*6).
Proof.
  intros. genDeps {{ k1; k2 }}. induction H1; intros.
  {simpl in *. subst. exists nil. simpl. repeat constructor. }
  {apply sumRemoveMid in H. eapply IHsplit in H; eauto. invertHyp.
   exists ((x*12,0,x*6)::x0). split. constructor. auto. constructor.
   simpl. rewrite H0. votesEq. }
  {apply sumRemoveMid in H0. eapply IHsplit in H0; eauto. invertHyp.
   exists ((x*12,x*6,0)::x0). split. constructor. auto. constructor.
   simpl. rewrite H0. votesEq. }
Qed.

Theorem score_votes_total : forall vs,
                              exists s1 s2 s3, score_votes vs = (s1,s2,s3).
Proof.
  induction vs.
  {exists 0. exists 0. exists 0. simpl. auto. }
  {destruct a. destruct p. invertHyp. repeat econstructor.
   simpl. rewrite H. auto. }
Qed.

Theorem add_votesSub : forall k1 k2 k3 vs s1 s2 s3,
                         add_votes (k1,k2,k3) vs = (s1,s2,s3) ->
                         vs = (s1-k1,s2-k2,s3-k3).
Proof.
  intros. simpl in *. destruct vs. destruct p. inv H.
  repeat (rewrite <- Z.add_sub_assoc; rewrite Zplus_minus). auto.
Qed.

Definition multOf x k := exists y, y * k = x.

Theorem mustBe24K : forall weights k votes s1 s2 s3,
                 sum weights = k  ->
                 mkVotes weights votes ->
                 score_votes votes = (s1,s2,s3) ->
                 s1  = k * 12 /\ (s2 + s3) * 2 = s1 /\ multOf s2 6 /\ multOf s3 6.
Proof.
  intros. genDeps {{ k; s1; s2; s3 }}. induction H0; intros.
  {simpl in *. inv H1. split; auto. split; auto. unfold multOf.
   split; exists 0; auto. }
  {simpl in *. symmetry in H2. apply Zplus_minus_eq in H2. inv H.
   {apply add_votesSub in H1. eapply IHmkVotes in H1; eauto. invertHyp.
    unfold multOf in *. invertHyp. split. omega. split. omega. split.
    exists (x0+k). omega. exists x. omega. }
   {apply add_votesSub in H1. eapply IHmkVotes in H1; eauto. split. omega. split.
    omega. unfold multOf in *. invertHyp. split. exists x0. omega. exists (x+k). omega. }
  }
Qed.

Ltac solveByInv :=
  match goal with
      |H:_ |- _ => solve[inv H]
  end.

Theorem weightsToVotes : forall votes weights s1 s2 s3,
                  mkVotes weights votes ->
                  score_votes votes = (s1,s2,s3) ->
                  exists l1 l2, split weights l1 l2 /\ sum l1 * 6 = s2 /\ sum l2 * 6 = s3.
Proof.
  intros. genDeps {{ s1; s2; s3 }}. induction H; intros.
  {simpl in H0. inv H0. exists nil. exists nil. split. constructor. auto. }
  {simpl in H1. inv H0.
   {apply add_votesSub in H1. eapply IHmkVotes in H1. invertHyp.
    exists (nil++k::x). exists x0. split. constructor. simpl. auto. simpl.
    split; omega. }
   {apply add_votesSub in H1. eapply IHmkVotes in H1. invertHyp.
     exists x. exists (nil++k::x0). split. constructor. simpl. auto. simpl.
    split; omega. }
  }
Qed.

Theorem veto_npc : forall l k nonManipVote weights,
                     reduce k l = (nonManipVote, weights) -> sum l = k*2 ->
                     (partition k l <-> manipulate nonManipVote weights).
Proof.
  intros. split; intros.
  {unfold reduce in H. inv H. inversion H1. eapply mkVotesSum in H2; eauto.
   invertHyp. econstructor. eauto. simpl. rewrite H3. constructor; omega. }
  {unfold reduce in *. inv H. inv H1.
   assert(exists s1 s2 s3, score_votes votes = (s1,s2,s3)). apply score_votes_total.
   invertHyp. simpl in H2. rewrite H3 in H2. inv H2. copy H0.
   eapply mustBe24K in H1; eauto. invertHyp. unfold multOf in *. invertHyp.
   assert(x1 <= k). omega. assert(x <= k). omega. rewrite <- Z.mul_assoc in H1.
   simpl in H1. assert((x1+x) = k * 2). omega. assert(x1=k /\ x=k). omega. invertHyp.
   eapply weightsToVotes in H; eauto. invertHyp. econstructor; eauto.
   erewrite Z.mul_cancel_r in H; auto.  omega. erewrite Z.mul_cancel_r in H10; auto.
   omega. }
Qed.


Require Import Basic_Notations_Set.
Require Import Basic_Lemmas.
Require Import Relation_Properties.
Require Import Logic.FunctionalExtensionality.

Module main (def : Relation).
Import def.
Module Basic_Lemmas := Basic_Lemmas.main def.
Module Relation_Properties := Relation_Properties.main def.
Import Basic_Lemmas Relation_Properties.

(** %
\section{全域性, 一価性, 写像に関する補題}
\begin{screen}
\begin{lemma}[id\_function]
$id_A :A \rel A$ is a function.
\end{lemma}
\end{screen}
% **)
Lemma id_function {A : eqType}: function_r (Id A).
Proof.
rewrite /function_r/total_r/univalent_r.
rewrite inv_id comp_id_l.
split.
apply inc_refl.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[unit\_function]
$\nabla_{AI} :A \rel I$ is a function.
\end{lemma}
\end{screen}
% **)
Lemma unit_function {A : eqType}: function_r (∇ A i).
Proof.
rewrite /function_r/total_r/univalent_r.
rewrite inv_universal lemma_for_tarski2 unit_identity_is_universal.
split.
apply inc_alpha_universal.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[total\_comp]
Let $\alpha :A \rel B$ and $\beta :B \rel C$ be total relations, then $\alpha \cdot \beta$ is also a total relation.
\end{lemma}
\end{screen}
% **)
Lemma total_comp {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 total_r alpha -> total_r beta -> total_r (alpha ・ beta).
Proof.
rewrite /total_r.
move => H H0.
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ beta).
apply (@inc_trans _ _ _ _ _ H).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_b_ab.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[univalent\_comp]
Let $\alpha :A \rel B$ and $\beta :B \rel C$ be univalent relations, then $\alpha \cdot \beta$ is also a univalent relation.
\end{lemma}
\end{screen}
% **)
Lemma univalent_comp {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 univalent_r alpha -> univalent_r beta -> univalent_r (alpha ・ beta).
Proof.
rewrite /univalent_r.
move => H H0.
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ (alpha #)).
apply (fun H' => @inc_trans _ _ _ _ _ H' H0).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_ab_b.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_comp]
Let $\alpha :A \to B$ and $\beta :B \to C$ be functions, then $\alpha \cdot \beta$ is also a function.
\end{lemma}
\end{screen}
% **)
Lemma function_comp {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 function_r alpha -> function_r beta -> function_r (alpha ・ beta).
Proof.
elim => H H0.
elim => H1 H2.
split.
apply (total_comp H H1).
apply (univalent_comp H0 H2).
Qed.

(** %
\begin{screen}
\begin{lemma}[total\_comp2]
Let $\alpha :A \rel B$, $\beta :B \rel C$ and $\alpha \cdot \beta$ be a total relation, then $\alpha$ is also a total relation.
\end{lemma}
\end{screen}
% **)
Lemma total_comp2 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 total_r (alpha ・ beta) -> total_r alpha.
Proof.
move => H.
apply inc_def1 in H.
rewrite comp_inv cap_comm comp_assoc in H.
rewrite /total_r.
rewrite H.
apply (@inc_trans _ _ _ _ _ (@dedekind _ _ _ _ _ _)).
apply comp_inc_compat.
apply cap_l.
rewrite comp_id_r.
apply cap_r.
Qed.

(** %
\begin{screen}
\begin{lemma}[univalent\_comp2]
Let $\alpha :A \rel B$, $\beta :B \rel C$, $\alpha \cdot \beta$ be a univalent relation and $\alpha^\sharp$ be a total relation, then $\beta$ is a univalent relation.
\end{lemma}
\end{screen}
% **)
Lemma univalent_comp2 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 univalent_r (alpha ・ beta) -> total_r (alpha #) -> univalent_r beta.
Proof.
move => H H0.
apply (fun H' => @inc_trans _ _ _ _ _ H' H).
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ _ alpha).
apply comp_inc_compat_ab_ab'.
rewrite /total_r in H0.
rewrite inv_invol in H0.
apply (comp_inc_compat_b_ab H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[total\_inc]
Let $\alpha :A \rel B$ be a total relation and $\alpha \sqsubseteq \beta$, then $\beta$ is also a total relation.
\end{lemma}
\end{screen}
% **)
Lemma total_inc {A B : eqType} {alpha beta : Rel A B}:
 total_r alpha -> alpha ⊆ beta -> total_r beta.
Proof.
move => H H0.
apply (@inc_trans _ _ _ _ _ H).
apply comp_inc_compat.
apply H0.
apply (@inc_inv _ _ _ _ H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[univalent\_inc]
Let $\alpha :A \rel B$ be a univalent relation and $\beta \sqsubseteq \alpha$, then $\beta$ is also a univalent relation.
\end{lemma}
\end{screen}
% **)
Lemma univalent_inc {A B : eqType} {alpha beta : Rel A B}:
 univalent_r alpha -> beta ⊆ alpha -> univalent_r beta.
Proof.
move => H H0.
apply (fun H' => @inc_trans _ _ _ _ _ H' H).
apply comp_inc_compat.
apply (@inc_inv _ _ _ _ H0).
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_inc]
Let $\alpha , \beta :A \to B$ be functions and $\alpha \sqsubseteq \beta$. Then,
$$
\alpha = \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_inc {A B : eqType} {alpha beta : Rel A B}:
 function_r alpha -> function_r beta -> alpha ⊆ beta -> alpha = beta.
Proof.
move => H H0 H1.
apply inc_antisym.
apply H1.
apply (@inc_trans _ _ _ ((alpha ・ alpha #) ・ beta)).
apply comp_inc_compat_b_ab.
apply H.
move : (@inc_inv _ _ _ _ H1) => H2.
apply (@inc_trans _ _ _ ((alpha ・ beta #) ・ beta)).
apply comp_inc_compat_ab_a'b.
apply comp_inc_compat_ab_ab'.
apply H2.
rewrite comp_assoc.
apply comp_inc_compat_ab_a.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[total\_universal]
If $\nabla_{IB}$ be a total relation, then
$$
\nabla_{AB} \cdot \nabla_{BC} = \nabla_{AC}.
$$
\end{lemma}
\end{screen}
% **)
Lemma total_universal {A B C : eqType}:
 total_r (∇ i B) -> ∇ A B ・ ∇ B C = ∇ A C.
Proof.
move => H.
rewrite -(@lemma_for_tarski2 A B) -(@lemma_for_tarski2 B C).
rewrite comp_assoc -(@comp_assoc _ _ _ _ (∇ i B)).
replace (∇ i B ・ ∇ B i) with (Id i).
rewrite comp_id_l.
apply lemma_for_tarski2.
apply inc_antisym.
rewrite /total_r in H.
rewrite inv_universal in H.
apply H.
rewrite unit_identity_is_universal.
apply inc_alpha_universal.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_rel\_inv\_rel]
Let $\alpha :A \to B$ be function. Then,
$$
\alpha \cdot \alpha^\sharp \cdot \alpha = \alpha.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_rel_inv_rel {A B : eqType} {alpha : Rel A B}:
 function_r alpha -> (alpha ・ alpha #) ・ alpha = alpha.
Proof.
move => H.
apply inc_antisym.
rewrite comp_assoc.
apply comp_inc_compat_ab_a.
apply H.
apply comp_inc_compat_b_ab.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_capP\_distr]
Let $f:A \to B,g:D \to C$ be functions, $\theta :(E \rel F) \to (B \rel C)$ and $P$ : predicate. Then,
$$
f \cdot (\sqcap_{P(\theta)} \theta(\alpha)) \cdot g^\sharp = \sqcap_{P(\alpha)} (f \cdot \theta(\alpha) \cdot g^\sharp).
$$
\end{lemma}
\end{screen}
% **)
Lemma function_capP_distr {A B C D E F : eqType}
 {f : Rel A B} {g : Rel D C} {theta : Rel E F -> Rel B C} {P : Rel E F -> Prop}:
 function_r f -> function_r g ->
 (f ・ (∩_{P} theta)) ・ g # =
 ∩_{P} (fun alpha : Rel E F => (f ・ theta alpha) ・ g #).
Proof.
elim => H H0.
elim => H1 H2.
apply inc_antisym.
apply comp_capP_distr.
apply (@inc_trans _ _ _ (((f ・ f #) ・ ∩_{P} (fun alpha : Rel E F => (f ・ theta alpha) ・ g #)) ・ (g ・ g #))).
apply (@inc_trans _ _ _ ((f ・ f #) ・ (∩_{P} (fun alpha : Rel E F => (f ・ theta alpha) ・ g #)))).
apply (comp_inc_compat_b_ab H).
apply (comp_inc_compat_a_ab H1).
rewrite (@comp_assoc _ _ _ _ _ (f #)) comp_assoc -(@comp_assoc _ _ _ _ _ g) -comp_assoc.
apply comp_inc_compat_ab_a'b.
apply comp_inc_compat_ab_ab'.
apply (@inc_trans _ _ _ (∩_{P} (fun alpha : Rel E F => (f # ・ ((f ・ theta alpha) ・ g #)) ・ g))).
apply comp_capP_distr.
replace (fun alpha : Rel E F => (f # ・ ((f ・ theta alpha) ・ g #)) ・ g) with (fun alpha : Rel E F => ((f # ・ f) ・ theta alpha) ・ (g # ・ g)).
apply inc_capP.
move => beta H3.
apply (@inc_trans _ _ _ ((f # ・ f) ・ theta beta)).
apply (@inc_trans _ _ _ (((f # ・ f) ・ theta beta) ・ (g # ・ g))).
move : beta H3.
apply inc_capP.
apply inc_refl.
apply (comp_inc_compat_ab_a H2).
apply (comp_inc_compat_ab_b H0).
apply functional_extensionality.
move => x.
by [rewrite comp_assoc comp_assoc comp_assoc comp_assoc comp_assoc].
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_cap\_distr, function\_cap\_distr\_l, function\_cap\_distr\_r]
Let $f:A \to B,g:D \to C$ be functions and $\alpha, \beta :B \rel C$. Then,
$$
f \cdot (\alpha \sqcap \beta) \cdot g^\sharp = (f \cdot \alpha \cdot g^\sharp) \sqcap (f \cdot \beta \cdot g^\sharp).
$$
\end{lemma}
\end{screen}
% **)
Lemma function_cap_distr
 {A B C D : eqType} {f : Rel A B} {alpha beta : Rel B C} {g : Rel D C}:
 function_r f -> function_r g ->
 (f ・ (alpha ∩ beta)) ・ g # = ((f ・ alpha) ・ g #) ∩ ((f ・ beta) ・ g #).
Proof.
rewrite (@cap_to_capP _ _ _ _ _ _ id) (@cap_to_capP _ _ _ _ _ _ (fun x => (f ・ x) ・ g #)).
apply function_capP_distr.
Qed.

Lemma function_cap_distr_l
 {A B C : eqType} {f : Rel A B} {alpha beta : Rel B C}:
 function_r f ->
 f ・ (alpha ∩ beta) = (f ・ alpha) ∩ (f ・ beta).
Proof.
move : (@id_function C) => H.
move => H0.
apply (@function_cap_distr _ _ _ _ f alpha beta) in H.
rewrite inv_id comp_id_r comp_id_r comp_id_r in H.
apply H.
apply H0.
Qed.

Lemma function_cap_distr_r
 {B C D : eqType} {alpha beta : Rel B C} {g : Rel D C}:
 function_r g ->
 (alpha ∩ beta) ・ g # = (alpha ・ g #) ∩ (beta ・ g #).
Proof.
move : (@id_function B) => H.
move => H0.
apply (@function_cap_distr _ _ _ _ _ alpha beta g) in H.
rewrite comp_id_l comp_id_l comp_id_l in H.
apply H.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_move1]
Let $\alpha :A \to B$ be a function, $\beta :B \rel C$ and $\gamma :A \rel C$. Then,
$$
\gamma \sqsubseteq \alpha \cdot \beta \Leftrightarrow \alpha^\sharp \cdot \gamma \sqsubseteq \beta.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_move1 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C} {gamma : Rel A C}:
 function_r alpha -> (gamma ⊆ (alpha ・ beta) <-> (alpha # ・ gamma) ⊆ beta).
Proof.
move => H.
split; move => H0.
apply (@inc_trans _ _ _ ((alpha # ・ alpha) ・ beta)).
rewrite comp_assoc.
apply (comp_inc_compat_ab_ab' H0).
apply comp_inc_compat_ab_b.
apply H.
apply (@inc_trans _ _ _ ((alpha ・ alpha #) ・ gamma)).
apply comp_inc_compat_b_ab.
apply H.
rewrite comp_assoc.
apply (comp_inc_compat_ab_ab' H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_move2]
Let $\beta :B \to C$ be a function, $\alpha :A \rel B$ and $\gamma :A \rel C$. Then,
$$
\alpha \cdot \beta \sqsubseteq \gamma \Leftrightarrow \alpha \sqsubseteq \gamma \cdot \beta^\sharp.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_move2 {A B C : eqType} {alpha : Rel A B} {beta : Rel B C} {gamma : Rel A C}:
 function_r beta -> ((alpha ・ beta) ⊆ gamma <-> alpha ⊆ (gamma ・ beta #)).
Proof.
move => H.
split; move => H0.
apply (@inc_trans _ _ _ ((alpha ・ beta) ・ beta #)).
rewrite comp_assoc.
apply comp_inc_compat_a_ab.
apply H.
apply (comp_inc_compat_ab_a'b H0).
apply (@inc_trans _ _ _ ((gamma ・ beta #) ・ beta)).
apply (comp_inc_compat_ab_a'b H0).
rewrite comp_assoc.
apply comp_inc_compat_ab_a.
apply H.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_rpc\_distr]
Let $f:A \to B,g:D \to C$ be functions and $\alpha, \beta :B \rel C$. Then,
$$
f \cdot (\alpha \Rightarrow \beta) \cdot g^\sharp = (f \cdot \alpha \cdot g^\sharp) \Rightarrow (f \cdot \beta \cdot g^\sharp).
$$
\end{lemma}
\end{screen}
% **)
Lemma function_rpc_distr
 {A B C D : eqType} {f : Rel A B} {alpha beta : Rel B C} {g : Rel D C}:
 function_r f -> function_r g ->
 (f ・ (alpha >> beta)) ・ g # = ((f ・ alpha) ・ g #) >> ((f ・ beta) ・ g #).
Proof.
move => H H0.
apply inc_lower.
move => gamma.
split; move => H1.
apply inc_rpc.
apply (function_move2 H0).
apply (function_move1 H).
apply (@inc_trans _ _ _ (((f # ・ gamma) ・ g) ∩ ((f # ・ ((f ・ alpha) ・ g #)) ・ g))).
rewrite -comp_assoc.
apply (fun H' => @inc_trans _ _ _ _ _ H' (@comp_cap_distr_r _ _ _ _ _ _)).
apply comp_inc_compat_ab_a'b.
apply comp_cap_distr_l.
apply (function_move2 H0) in H1.
apply (function_move1 H) in H1.
rewrite -inc_rpc comp_assoc.
apply (@inc_trans _ _ _ _ _ H1).
apply rpc_inc_compat_r.
rewrite comp_assoc comp_assoc comp_assoc -comp_assoc.
apply (@inc_trans _ _ _ (alpha ・ (g # ・ g))).
apply comp_inc_compat_ab_b.
apply H.
apply comp_inc_compat_ab_a.
apply H0.
apply (function_move2 H0).
apply (function_move1 H).
apply inc_rpc.
apply (@inc_trans _ _ _ _ _ (@dedekind _ _ _ _ _ _)).
apply (@inc_trans _ _ _ (f # ・ ((gamma ・ g) ∩ ((f #) # ・ alpha)))).
apply comp_inc_compat_ab_a'b.
apply cap_l.
rewrite inv_invol.
apply (@inc_trans _ _ _ ((f # ・ (gamma ∩ ((f ・ alpha) ・ g #))) ・ g)).
rewrite comp_assoc.
apply comp_inc_compat_ab_ab'.
apply (@inc_trans _ _ _ _ _ (@dedekind _ _ _ _ _ _)).
apply comp_inc_compat_ab_ab'.
apply cap_l.
apply (function_move2 H0).
apply (function_move1 H).
rewrite -inc_rpc -comp_assoc.
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_inv\_rel1, function\_inv\_rel2]
Let $f:A \to B$ be a function. Then,
$$
f^\sharp \cdot f = id_B \sqcap f^\sharp \cdot \nabla_{AA} \cdot f = id_B \sqcap \nabla_{BA} \cdot f.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_inv_rel1 {A B : eqType} {f : Rel A B}:
 function_r f -> f # ・ f = Id B ∩ ((f # ・ ∇ A A) ・ f).
Proof.
move => H.
apply inc_antisym.
apply inc_cap.
split.
apply H.
apply comp_inc_compat_ab_a'b.
apply comp_inc_compat_a_ab.
apply inc_alpha_universal.
apply (@inc_trans _ _ _ (Id B ∩ (∇ B A ・ f))).
apply cap_inc_compat_l.
apply comp_inc_compat_ab_a'b.
apply inc_alpha_universal.
rewrite cap_comm.
apply (@inc_trans _ _ _ _ _ (@dedekind _ _ _ _ _ _)).
rewrite comp_id_l comp_id_r cap_comm inv_universal.
rewrite cap_universal cap_universal.
apply inc_refl.
Qed.

Lemma function_inv_rel2 {A B : eqType} {f : Rel A B}:
 function_r f -> f # ・ f = Id B ∩ (∇ B A ・ f).
Proof.
move => H.
apply inc_antisym.
rewrite (@function_inv_rel1 _ _ _ H).
apply cap_inc_compat_l.
apply comp_inc_compat_ab_a'b.
apply inc_alpha_universal.
rewrite cap_comm.
apply (@inc_trans _ _ _ _ _ (@dedekind _ _ _ _ _ _)).
rewrite comp_id_l comp_id_r cap_comm inv_universal.
rewrite cap_universal cap_universal.
apply inc_refl.
Qed.

(** %
\begin{screen}
\begin{lemma}[function\_dedekind1, function\_dedekind2]
Let $f:A \to B$ be a function, $\mu :C \rel A$ and $\rho :C \rel B$. Then,
$$
(\mu \sqcap \rho \cdot f^\sharp) \cdot f = \mu \cdot f \sqcap \rho \land \rho \cdot f^\sharp \cdot f = \nabla_{CA} \cdot f \sqcap \rho.
$$
\end{lemma}
\end{screen}
% **)
Lemma function_dedekind1
 {A B C : eqType} {f : Rel A B} {mu : Rel C A} {rho : Rel C B}:
 function_r f -> (mu ∩ (rho ・ f #)) ・ f = (mu ・ f) ∩ rho.
Proof.
move => H.
apply inc_antisym.
apply (@inc_trans _ _ _ _ _ (comp_cap_distr_r)).
apply cap_inc_compat_l.
rewrite comp_assoc.
apply comp_inc_compat_ab_a.
apply H.
apply (@inc_trans _ _ _ _ _ (@dedekind _ _ _ _ _ _)).
apply comp_inc_compat_ab_ab'.
apply cap_l.
Qed.

Lemma function_dedekind2 {A B C : eqType} {f : Rel A B} {rho : Rel C B}:
 function_r f -> (rho ・ f #) ・ f = (∇ C A ・ f) ∩ rho.
Proof.
move => H.
move : (@function_dedekind1 _ _ _ f (∇ C A) rho H) => H0.
rewrite cap_comm cap_universal in H0.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[square\_diagram]
In below figure,
$$
f \cdot x = g \cdot y \Leftrightarrow f^\sharp \cdot g \sqsubseteq x \cdot y^\sharp.
$$
$$
\xymatrix{
X \ar@{->}[r]^f \ar@{->}[d]_g & A \ar@{->}[d]^x \\
B \ar@{->}[r]_y & D
}
$$
\end{lemma}
\end{screen}
% **)
Lemma square_diagram {X A B D : eqType}
 {f : Rel X A} {g : Rel X B} {x : Rel A D} {y : Rel B D}:
 function_r f -> function_r g -> function_r x -> function_r y ->
 (f ・ x = g ・ y <-> (f # ・ g) ⊆ (x ・ y #)).
Proof.
move => H H0 H1 H2.
split; move => H3.
rewrite -(function_move1 H) -comp_assoc -(function_move2 H2) H3.
apply inc_refl.
apply Logic.eq_sym.
apply function_inc.
apply (function_comp H0 H2).
apply (function_comp H H1).
rewrite (function_move2 H2) comp_assoc (function_move1 H).
apply H3.
Qed.

(** %
\section{全射, 単射に関する補題}
\begin{screen}
\begin{lemma}[surjection\_comp]
Let $\alpha :A \rel B$ and $\beta :B \rel C$ be surjections, then $\alpha \cdot \beta$ is also a surjection.
\end{lemma}
\end{screen}
% **)
Lemma surjection_comp {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 surjection_r alpha -> surjection_r beta -> surjection_r (alpha ・ beta).
Proof.
rewrite /surjection_r.
elim => H H0.
elim => H1 H2.
split.
apply (function_comp H H1).
rewrite comp_inv.
apply (total_comp H2 H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[injection\_comp]
Let $\alpha :A \rel B$ and $\beta :B \rel C$ be injections, then $\alpha \cdot \beta$ is also an injection.
\end{lemma}
\end{screen}
% **)
Lemma injection_comp {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 injection_r alpha -> injection_r beta -> injection_r (alpha ・ beta).
Proof.
rewrite /injection_r.
elim => H H0.
elim => H1 H2.
split.
apply (function_comp H H1).
rewrite comp_inv.
apply (univalent_comp H2 H0).
Qed.

(** %
\begin{screen}
\begin{lemma}[bijection\_comp]
Let $\alpha :A \rel B$ and $\beta :B \rel C$ be bijections, then $\alpha \cdot \beta$ is also a bijection.
\end{lemma}
\end{screen}
% **)
Lemma bijection_comp {A B C : eqType} {alpha : Rel A B} {beta : Rel B C}:
 bijection_r alpha -> bijection_r beta -> bijection_r (alpha ・ beta).
Proof.
rewrite /bijection_r.
elim => H.
elim => H0 H1.
elim => H2.
elim => H3 H4.
split.
apply (function_comp H H2).
rewrite comp_inv.
split.
apply (total_comp H3 H0).
apply (univalent_comp H4 H1).
Qed.

(** %
\begin{screen}
\begin{lemma}[surjection\_unique1]
Let $e:A \twoheadrightarrow B$ be a surjection, $f:A \to C$ be a function and $e \cdot e^\sharp \sqsubseteq f \cdot f^\sharp$, then there exists a unique function $g:B \to C$ s.t. $f=eg$.
\end{lemma}
\end{screen}
% **)
Lemma surjection_unique1 {A B C : eqType} {e : Rel A B} {f : Rel A C}:
 surjection_r e -> function_r f -> (e ・ e #) ⊆ (f ・ f #) ->
 (exists! g : Rel B C, function_r g /\ f = e ・ g).
Proof.
rewrite /surjection_r/function_r/total_r/univalent_r.
elim.
elim => H H0 H1.
elim => H2 H3 H4.
exists (e # ・ f).
repeat split.
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ f).
apply (@inc_trans _ _ _ _ _ H1).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_b_ab.
apply H2.
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ e).
apply (@inc_trans _ _ _ (f # ・ ((f ・ f #) ・ f))).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_a'b H4).
rewrite comp_assoc -comp_assoc.
apply (fun H' => @inc_trans _ _ _ _ _ H' H3).
apply (comp_inc_compat_ab_a H3).
apply function_inc.
split.
apply H2.
apply H3.
split.
rewrite /total_r.
rewrite comp_inv comp_inv inv_invol.
rewrite -(@comp_assoc _ _ _ _ e) (@comp_assoc _ _ _ _ _ e) (@comp_assoc _ _ _ _ _ f) -(@comp_assoc _ _ _ _ f).
apply (@inc_trans _ _ _ _ _ H).
apply comp_inc_compat_a_ab.
apply (@inc_trans _ _ _ _ _ H2).
apply (comp_inc_compat_a_ab H).
rewrite /univalent_r.
rewrite comp_inv comp_inv inv_invol.
rewrite (@comp_assoc _ _ _ _ _ e) -(@comp_assoc _ _ _ _ e) comp_assoc -(@comp_assoc _ _ _ _ _ _ f).
apply (@inc_trans _ _ _ (f # ・ (((f ・ f #) ・ (f ・ f #)) ・ f))).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_ab_a'b.
apply comp_inc_compat.
apply H4.
apply H4.
rewrite comp_assoc (@comp_assoc _ _ _ _ _ _ f) -(@comp_assoc _ _ _ _ (f #)) -(@comp_assoc _ _ _ _ (f #)) (@comp_assoc _ _ _ _ _ (f #)) -(@comp_assoc _ _ _ _ (f #)).
apply (fun H' => @inc_trans _ _ _ _ _ H' H3).
apply comp_inc_compat_ab_a.
apply (fun H' => @inc_trans _ _ _ _ _ H' H3).
apply (comp_inc_compat_ab_a H3).
rewrite -comp_assoc.
apply (comp_inc_compat_b_ab H).
move => g.
elim.
elim => H5 H6 H7.
replace g with (e # ・ (e ・ g)).
apply f_equal.
apply H7.
rewrite -comp_assoc.
apply inc_antisym.
apply (comp_inc_compat_ab_b H0).
rewrite inv_invol in H1.
apply (comp_inc_compat_b_ab H1).
Qed.

(** %
\begin{screen}
\begin{lemma}[surjection\_unique2]
Let $e:A \twoheadrightarrow B$ be a surjection, $f:A \to C$ be a function and $e \cdot e^\sharp = f \cdot f^\sharp$, then function $e^\sharp f$ is an injection.
\end{lemma}
\end{screen}
% **)
Lemma surjection_unique2 {A B C : eqType} {e : Rel A B} {f : Rel A C}:
 surjection_r e -> function_r f -> (e ・ e #) = (f ・ f #) -> injection_r (e # ・ f).
Proof.
rewrite /surjection_r/injection_r/function_r/total_r/univalent_r.
elim.
elim => H H0 H1.
elim => H2 H3 H4.
repeat split.
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ f).
apply (@inc_trans _ _ _ _ _ H1).
apply comp_inc_compat_ab_ab'.
apply comp_inc_compat_b_ab.
apply H2.
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ e).
rewrite H4.
rewrite comp_assoc -comp_assoc.
apply (fun H' => @inc_trans _ _ _ _ _ H' H3).
apply (comp_inc_compat_ab_a H3).
rewrite inv_invol comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ f).
rewrite -H4.
rewrite comp_assoc -comp_assoc.
apply (fun H' => @inc_trans _ _ _ _ _ H' H0).
apply comp_inc_compat_ab_a.
apply H0.
Qed.

(** %
\begin{screen}
\begin{lemma}[injection\_unique1]
Let $m:B \rightarrowtail A$ be an injection, $f:C \to A$ be a function and $f^\sharp \cdot f \sqsubseteq m^\sharp \cdot m$, then there exists a unique function $g:C \to B$ s.t. $f=gm$.
\end{lemma}
\end{screen}
% **)
Lemma injection_unique1 {A B C : eqType} {m : Rel B A} {f : Rel C A}:
 injection_r m -> function_r f -> (f # ・ f) ⊆ (m # ・ m) ->
 (exists! g : Rel C B, function_r g /\ f = g ・ m).
Proof.
rewrite /injection_r/function_r/total_r/univalent_r.
elim.
elim => H H0 H1.
elim => H2 H3 H4.
exists (f ・ m #).
repeat split.
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ _ m).
apply (@inc_trans _ _ _ (f ・ ((f # ・ f) ・ f #))).
rewrite comp_assoc -comp_assoc.
apply (@inc_trans _ _ _ _ _ H2).
apply (comp_inc_compat_a_ab H2).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_a'b H4).
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ _ f).
apply (fun H' => @inc_trans _ _ _ _ _ H' H1).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_b H3).
rewrite comp_assoc.
apply Logic.eq_sym.
apply function_inc.
split.
rewrite /total_r.
rewrite comp_inv comp_inv inv_invol.
apply (@inc_trans _ _ _ _ _ H2).
apply comp_inc_compat.
apply (@inc_trans _ _ _ (f ・ (f # ・ f))).
rewrite -comp_assoc.
apply (comp_inc_compat_b_ab H2).
apply (comp_inc_compat_ab_ab' H4).
apply (@inc_trans _ _ _ ((f # ・ f) ・ f #)).
rewrite comp_assoc.
apply (comp_inc_compat_a_ab H2).
apply (comp_inc_compat_ab_a'b H4).
rewrite /univalent_r.
rewrite comp_inv comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ _ f).
apply (fun H' => @inc_trans _ _ _ _ _ H' H0).
apply comp_inc_compat_ab_a.
apply (fun H' => @inc_trans _ _ _ _ _ H' H3).
apply (comp_inc_compat_ab_a H0).
split.
apply H2.
apply H3.
apply (comp_inc_compat_ab_a H0).
move => g.
elim.
elim => H5 H6 H7.
rewrite H7 comp_assoc.
apply inc_antisym.
rewrite inv_invol in H1.
apply (comp_inc_compat_ab_a H1).
apply (comp_inc_compat_a_ab H).
Qed.

(** %
\begin{screen}
\begin{lemma}[injection\_unique2]
Let $m:B \rightarrowtail A$ be an injection, $f:C \to A$ be a function and $f^\sharp \cdot f = m^\sharp \cdot m$, then function $f \cdot m^\sharp$ is a surjection.
\end{lemma}
\end{screen}
% **)
Lemma injection_unique2 {A B C : eqType} {m : Rel B A} {f : Rel C A}:
 injection_r m -> function_r f -> (f # ・ f) = (m # ・ m) -> surjection_r (f ・ m #).
Proof.
rewrite /surjection_r/injection_r/function_r/total_r/univalent_r.
elim.
elim => H H0 H1.
elim => H2 H3 H4.
repeat split.
rewrite comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ _ m).
apply (@inc_trans _ _ _ (f ・ ((f # ・ f) ・ f #))).
rewrite comp_assoc -comp_assoc.
apply (@inc_trans _ _ _ _ _ H2).
apply (comp_inc_compat_a_ab H2).
apply comp_inc_compat_ab_ab'.
rewrite H4.
apply inc_refl.
rewrite comp_inv comp_assoc -(@comp_assoc _ _ _ _ _ f).
apply (fun H' => @inc_trans _ _ _ _ _ H' H1).
apply comp_inc_compat_ab_ab'.
apply (comp_inc_compat_ab_b H3).
rewrite inv_invol comp_inv inv_invol comp_assoc -(@comp_assoc _ _ _ _ _ f).
apply (@inc_trans _ _ _ _ _ H).
apply comp_inc_compat_ab_ab'.
rewrite H4 comp_assoc.
apply (comp_inc_compat_a_ab H).
Qed.

(** %
\begin{screen}
\begin{lemma}[bijection\_inv]
Let $\alpha :A \rel B$, $\beta :B \rel A$, $\alpha \cdot \beta = id_A$ and $\beta \cdot \alpha = id_B$, then $\alpha$ and $\beta$ are bijections and $\beta = \alpha^\sharp$.
\end{lemma}
\end{screen}
% **)
Lemma bijection_inv {A B : eqType} {alpha : Rel A B} {beta : Rel B A}:
 alpha ・ beta = Id A -> beta ・ alpha = Id B -> bijection_r alpha /\ bijection_r beta /\ beta = alpha #.
Proof.
move => H H0.
move : (@id_function A) => H1.
move : (@id_function B) => H2.
assert (bijection_r alpha /\ bijection_r beta).
assert (total_r alpha /\ total_r (alpha #) /\ total_r beta /\ total_r (beta #)).
repeat split.
apply (@total_comp2 _ _ _ _ beta).
rewrite H.
apply H1.
apply (@total_comp2 _ _ _ _ (beta #)).
rewrite -comp_inv H0 inv_id.
apply H2.
apply (@total_comp2 _ _ _ _ alpha).
rewrite H0.
apply H2.
apply (@total_comp2 _ _ _ _ (alpha #)).
rewrite -comp_inv H inv_id.
apply H1.
repeat split.
apply H3.
apply (@univalent_comp2 _ _ _ beta).
rewrite H0.
apply H2.
apply H3.
apply H3.
apply (@univalent_comp2 _ _ _ (beta #)).
rewrite -comp_inv H inv_id.
apply H1.
rewrite inv_invol.
apply H3.
apply H3.
apply (@univalent_comp2 _ _ _ alpha).
rewrite H.
apply H1.
apply H3.
apply H3.
apply (@univalent_comp2 _ _ _ (alpha #)).
rewrite -comp_inv H0 inv_id.
apply H2.
rewrite inv_invol.
apply H3.
split.
apply H3.
split.
apply H3.
rewrite -(@comp_id_r _ _ beta) -(@comp_id_l _ _ (alpha #)).
rewrite -H0 comp_assoc.
apply f_equal.
apply inc_antisym.
apply H3.
rewrite comp_inv_inv -inv_inc_move inv_id.
apply H3.
Qed.

(** %
\begin{screen}
\begin{lemma}[bijection\_inv\_corollary]
Let $\alpha :A \rel B$ be a bijection, then $\alpha^\sharp$ is also a bijection.
\end{lemma}
\end{screen}
% **)
Lemma bijection_inv_corollary {A B : eqType} {alpha : Rel A B}:
 bijection_r alpha -> bijection_r (alpha #).
Proof.
move : (@bijection_inv _ _ alpha (alpha #)) => H.
move => H0.
rewrite /bijection_r/function_r/total_r/univalent_r in H0.
rewrite inv_invol in H0.
apply H.
apply inc_antisym.
apply H0.
apply H0.
apply inc_antisym.
apply H0.
apply H0.
Qed.

(** %
\section{有理性から導かれる系}
\begin{screen}
\begin{lemma}[rationality\_corollary1]
Let $u :A \rel A$ and $u \sqsubseteq id_A$. Then,
$$
\exists R, \exists j:R \rightarrowtail A, u = j^\sharp \cdot j.
$$
\end{lemma}
\end{screen}
% **)
Lemma rationality_corollary1 {A : eqType} {u : Rel A A}:
 u ⊆ Id A -> exists (R : eqType)(j : Rel R A), injection_r j /\ u = j # ・ j.
Proof.
move : (rationality _ _ u).
elim => R.
elim => f.
elim => g.
elim => H.
elim => H0.
elim => H1 H2 H3.
exists R.
exists f.
assert (g = f).
apply (function_inc H0 H).
apply (@inc_trans _ _ _ ((f ・ f #) ・ g)).
apply comp_inc_compat_b_ab.
apply H.
rewrite comp_assoc -H1.
apply (comp_inc_compat_ab_a H3).
rewrite H4 in H1.
rewrite H4 cap_idem in H2.
split.
split.
apply H.
rewrite /univalent_r.
rewrite inv_invol H2.
apply inc_refl.
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[rationality\_corollary2]
Let $f :A \to B$ be a function. Then,
$$
\exists e:A \twoheadrightarrow R, \exists m:R \rightarrowtail B, f = e \cdot m.
$$
\end{lemma}
\end{screen}
% **)
Lemma rationality_corollary2 {A B : eqType} {f : Rel A B}:
 function_r f -> exists (R : eqType)(e : Rel A R)(m : Rel R B), surjection_r e /\ injection_r m.
Proof.
elim => H H0.
move : (@rationality_corollary1 _ (f # ・ f) H0).
elim => R.
elim => m.
elim => H1 H2.
exists R.
exists (f ・ m #).
exists m.
split.
apply (injection_unique2 H1 (conj H H0) H2).
apply H1.
Qed.

(** %
\begin{screen}
\begin{lemma}[axiom\_of\_subobjects]
Let $u :A \rel A$ and $u \sqsubseteq id_A$. Then,
$$
\exists R, \exists j:R \to A, j^\sharp \cdot j = u \land j \cdot j^\sharp = id_R.
$$
\end{lemma}
\end{screen}
% **)
Lemma axiom_of_subobjects {A : eqType} {u : Rel A A}:
 u ⊆ Id A -> exists (R : eqType)(j : Rel R A), j # ・ j = u /\ j ・ j # = Id R.
Proof.
move => H.
elim (rationality_corollary1 H) => R.
elim => j H0.
exists R.
exists j.
split.
apply Logic.eq_sym.
apply H0.
apply inc_antisym.
replace (j ・ j #) with ((j #) # ・ j #).
apply H0.
by [rewrite inv_invol].
apply H0.
Qed.

End main.


(* ea *)

Inductive Z_3 : Set :=
  | n : Z_3
  | a : Z_3
  | b : Z_3.

Definition ope (x:Z_3) (y:Z_3) :=
  match x , y with
  | n , y => y
  | x , n => x
  | a , b => n
  | b , a => n
  | a , a => b
  | b , b => a
  end.

Definition inve (x:Z_3) :=
  match x with
  | n => n
  | a => b
  | b => a
  end.

Theorem Z_3_eq_dec_mod : forall (x y: Z_3), x = y \/ x <> y.
Proof.
  induction x, y.
  left.
  reflexivity.
  right.
  discriminate.

  right.
  discriminate.
  right.
  discriminate.
  left.
  reflexivity.
  right.
  discriminate.
  right.
  discriminate.
  right.
  discriminate.
  left.
  reflexivity.
Qed.

(* hf *)

Theorem Z_3_eq_dec_mod_v2 : forall (x y: Z_3), x = y \/ x <> y.
Proof.
  induction x, y; auto.
  right; discriminate.
  right; discriminate.
  right; discriminate.
  right; discriminate.
  right; discriminate.
  right; discriminate.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
Proof.  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    *
      rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      -
        rewrite 3 drop_Nil. reflexivity.
    * simpl. lfind.  reflexivity.
Admitted.

Theorem theorem0 : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  +
    rewrite 2 drop_Cons_assoc. reflexivity.
  +
    rewrite 3 drop_Nil. reflexivity.
Qed.


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import Arith Lia Wellfounded List Extraction.

From Undecidability.Shared.Libs.DLW.Wf Require Import acc_irr.

Set Implicit Arguments.

Section measure_rect.

  Variable (X : Type) (m : X -> nat) (P : X -> Type).

  Hypothesis F : forall x, (forall x', m x' < m x -> P x') -> P x.

  Arguments F : clear implicits.

  Let R x y := m x < m y.

  (* R is WF when all elements are accessible *)

  Let Rwf : forall x : X, Acc R x.
  Proof.
    apply wf_inverse_image with (f := m), lt_wf.
  Qed.

  (* Structural decrease on the Acc predicate and no
      singleton elimination here because the Acc predicated
      is pattern matched (by destruct) in Prop context *)

  Let Fix_F : forall x : X, Acc R x -> P x.
  Proof.
    refine(
      fix Fix_F x (H : Acc R x) { struct H } :=
         F x (fun x' (H' : R x' x) => Fix_F x' _)
    ).
    destruct H as [ G ].
    apply G. (* structural decrease here *)
    trivial.
  Defined.

  (* To evaluate @Fix_F x A, the recursive argument must reduce to a
      term headed with an inductive constructor *)

  Let Fix_F_fix x A :
        @Fix_F x A = F x (fun y H => Fix_F (Acc_inv A H)).
  Proof. destruct A; reflexivity. Qed.

  Definition measure_rect x : P x := Fix_F (Rwf x).

  (* To establish the fixpoint equation for measure_rect, we need
      to assume that the functional F is extensional because we do not
      use the FunExt axiom *)

  Hypothesis F_ext : forall x f g, (forall y H, f y H = g y H) -> F x f = F x g.

  (* Another proof method here that in StdLib, using the characterisation
      of Acc irrelevant functionals *)

  Let Fix_F_Acc_irr : forall x f g, @Fix_F x f = Fix_F g.
  Proof.
    apply Acc_irrelevance.
    intros; apply F_ext; auto.
  Qed.

  Theorem measure_rect_fix x :
          measure_rect x = @F x (fun y _ => measure_rect y).
  Proof.
    unfold measure_rect; rewrite Fix_F_fix.
    apply F_ext.
    intros; apply Fix_F_Acc_irr.
  Qed.

End measure_rect.

Tactic Notation "induction" "on" hyp(x) "as" ident(IH) "with" "measure" uconstr(f) :=
   pattern x; revert x; apply measure_rect with (m := fun x => f); intros x IH.

Extraction Inline measure_rect.

Section measure_double_rect.

  Variable (X Y : Type) (m : X -> Y -> nat) (P : X -> Y -> Type).

  Hypothesis F : (forall x y, (forall x' y', m x' y' < m x y -> P x' y') -> P x y).

  Let m' (c : X * Y) := match c with (x,y) => m x y end.

  Let R c d := m' c < m' d.

  Let Rwf : well_founded R.
  Proof.
    apply wf_inverse_image with (f := m'), lt_wf.
  Qed.

  Section measure_double_rect_paired.

    Let Q c := match c with (x,y) => P x y end.

    Theorem measure_double_rect_paired x y : P x y.
    Proof.
      change (Q (x,y)).
      generalize (x,y); clear x y; intros c.

      induction on c as IH with measure (m' c).
      destruct c as (x,y); apply F.
      intros ? ?; apply (IH (_,_)).
    Defined.

  End measure_double_rect_paired.

  Section measure_double_rect.

    Let Fix_F_2 : forall x y, Acc R (x,y) -> P x y.
    Proof.
      refine (fix Fix_F_2 x y H { struct H } :=
           @F x y (fun x' y' H' => Fix_F_2 x' y' _)
      ).
      destruct H as [ H ]; unfold R in H at 1.
      apply H. (* structural decrease here *)
      apply H'.
    Defined.

    Let Fix_F_2_fix x y H :
        @Fix_F_2 x y H = F (fun x' y' H' => Fix_F_2 (@Acc_inv _ _ _ H (x',y') H')).
    Proof. destruct H; reflexivity. Qed.

    Definition measure_double_rect x y : P x y := Fix_F_2 (Rwf (_,_)).

    Hypothesis F_ext : forall x y f g, (forall x' y' H, f x' y' H = g x' y' H)
                                      -> @F x y f = F g.

    Let Fix_F_2_paired c (A : Acc R c) : P (fst c) (snd c).
    Proof. destruct c; simpl; apply Fix_F_2; trivial. Defined.

    Let Fix_F_2_paired_Acc_irr : forall c f g, @Fix_F_2_paired c f
                                              = Fix_F_2_paired   g.
    Proof.
       apply Acc_irrelevance.
       intros (x,y) f g IH; apply F_ext.
       intros x' y' ?; apply (@IH (x',y')).
    Qed.

    Let Fix_F_2_Acc_irr x y f g : @Fix_F_2 x y f = Fix_F_2 g.
    Proof.
      intros; apply (@Fix_F_2_paired_Acc_irr (x,y)); trivial.
    Qed.

    Theorem measure_double_rect_fix x y :
             measure_double_rect x y = @F x y (fun x' y' _ => measure_double_rect x' y').
    Proof.
      unfold measure_double_rect; rewrite Fix_F_2_fix.
      apply F_ext.
      intros; apply Fix_F_2_Acc_irr.
    Qed.

  End measure_double_rect.

End measure_double_rect.

Tactic Notation "paired" "induction" "on" hyp(x) hyp(y) "as" ident(IH) "with" "measure" uconstr(f) :=
   pattern x, y; revert x y; apply measure_double_rect_paired with (m := fun x y => f); intros x y IH.

Tactic Notation "induction" "on" hyp(x) hyp(y) "as" ident(IH) "with" "measure" uconstr(f) :=
   pattern x, y; revert x y; apply measure_double_rect with (m := fun x y => f); intros x y IH.

Extraction Inline measure_double_rect measure_double_rect_paired.