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

 Limits in slice bicategory

 Contents:
 1. Final object
 2. Products
 3. Inserters
 4. Equifiers

 *********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Slice.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Products.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.Inserters.
Require Import UniMath.Bicategories.Limits.Equifiers.

Local Open Scope cat.

(**
 1. Final object
 *)
Section FinalSlice.
  Context {B : bicat}
          (b : B).

  Let ι : slice_bicat b.
  Proof.
    refine (b ,, _).
    exact (id₁ b).
  Defined.

  Definition bifinal_1cell_property_slice
    : bifinal_1cell_property ι.
  Proof.
    intros f.
    exact (pr2 f ,, rinvunitor_invertible_2cell _).
  Defined.

  Definition bifinal_2cell_property_slice_eq
             {f : slice_bicat b}
             (α β : f --> ι)
    : pr12 α
      • ((((rinvunitor (pr1 α) • (pr22 α) ^-1) • pr12 β) • runitor (pr1 β)) ▹ id₁ b)
      =
      pr12 β.
  Proof.
    cbn.
    use vcomp_move_R_pM ; [ apply property_from_invertible_2cell | ].
    use (vcomp_lcancel (runitor _)) ; [ is_iso | ].
    refine (_ @ vcomp_runitor _ _ _).
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocr.
    etrans.
    {
      do 3 apply maponpaths_2.
      rewrite <- runitor_triangle.
      rewrite rwhisker_hcomp.
      rewrite <- triangle_l_inv.
      rewrite <- lwhisker_hcomp.
      rewrite runitor_lunitor_identity.
      rewrite !vassocl ;
        refine (maponpaths (λ z, _ • z) (vassocr _ _ _) @ _).
      rewrite lwhisker_vcomp.
      rewrite lunitor_linvunitor.
      rewrite lwhisker_id2.
      rewrite id2_left.
      rewrite rassociator_lassociator.
      apply idpath.
    }
    rewrite id2_left.
    rewrite !vassocl.
    do 2 apply maponpaths.
    rewrite <- runitor_triangle.
    use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
    rewrite runitor_rwhisker.
    rewrite runitor_lunitor_identity.
    apply idpath.
  Qed.

  Definition bifinal_2cell_property_slice
             (f : slice_bicat b)
    : bifinal_2cell_property ι f.
  Proof.
    intros α β.
    simple refine (_ ,, _).
    - exact (rinvunitor _
             • (pr22 α)^-1
             • pr12 β
             • runitor _).
    - exact (bifinal_2cell_property_slice_eq α β).
  Defined.

  Definition bifinal_eq_property_slice
             (f : slice_bicat b)
    : bifinal_eq_property ι f.
  Proof.
    intros α β p q.
    use subtypePath.
    {
      intro.
      apply cellset_property.
    }
    use (vcomp_lcancel (runitor _)) ; [ is_iso | ].
    rewrite <- !vcomp_runitor.
    apply maponpaths_2.
    apply (vcomp_lcancel (pr12 α) (pr22 α)).
    exact (pr2 p @ !(pr2 q)).
  Qed.

  Definition is_bifinal_slice
    : is_bifinal ι.
  Proof.
    refine (_ ,, _).
    - exact bifinal_1cell_property_slice.
    - intro f.
      split.
      + exact (bifinal_2cell_property_slice f).
      + exact (bifinal_eq_property_slice f).
  Defined.

  Definition final_in_slice
    : bifinal_obj (slice_bicat b)
    := ι ,, is_bifinal_slice.
End FinalSlice.

(**
 2. Products
 *)
Section ProductSlice.
  Context {B : bicat}
          {pb x y b : B}
          (f : x --> b)
          (g : y --> b)
          (π₁ : pb --> x)
          (π₂ : pb --> y)
          (γ : invertible_2cell (π₁ · f) (π₂ · g))
          (cone : pb_cone f g := make_pb_cone _ π₁ π₂ γ)
          (Hpb : has_pb_ump cone).

  Definition binprod_cone_in_slice
    : @binprod_cone (slice_bicat b) (x ,, f) (y ,, g).
  Proof.
    use make_binprod_cone.
    - exact (pb ,, π₁ · f).
    - exact (π₁ ,, id2_invertible_2cell (π₁ · f)).
    - exact (π₂ ,, γ).
  Defined.

  Section BinProdUmp1.
    Context (q : @binprod_cone (slice_bicat b) (x,, f) (y,, g)).

    Let other_cone
      : pb_cone f g
      := make_pb_cone
           (pr1 (binprod_cone_obj q))
           (pr1 (binprod_cone_pr1 q))
           (pr1 (binprod_cone_pr2 q))
           (comp_of_invertible_2cell
              (inv_of_invertible_2cell
                 (pr2 (binprod_cone_pr1 q)))
              (pr2 (binprod_cone_pr2 q))).

    Let φ : invertible_2cell
              (pr21 q)
              (pb_ump_mor Hpb other_cone · (π₁ · f))
      := comp_of_invertible_2cell
           (comp_of_invertible_2cell
              (pr2 (binprod_cone_pr1 q))
              (rwhisker_of_invertible_2cell
                 _
                 (inv_of_invertible_2cell
                    (pb_ump_mor_pr1 Hpb other_cone))))
           (rassociator_invertible_2cell _ _ _).

    Definition binprod_1_ump_in_slice_cell_eq
      : pr12 (binprod_cone_pr1 q)
        • ((pb_ump_mor_pr1 Hpb other_cone)^-1 ▹ f)
        • rassociator _ _ _
        • ((pb_ump_mor Hpb other_cone ◃ γ)
        • lassociator _ _ _)
        • (pb_ump_mor_pr2 Hpb other_cone ▹ g)
        =
        pr12 (binprod_cone_pr2 q).
    Proof.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        apply maponpaths_2.
        exact (pb_ump_mor_cell Hpb other_cone).
      }
      cbn.
      rewrite !vassocl.
      rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)).
      rewrite rassociator_lassociator.
      rewrite id2_left.
      rewrite !vassocl.
      rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite !vassocr.
      rewrite vcomp_rinv.
      rewrite id2_left.
      rewrite !vassocl.
      rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)).
      rewrite rassociator_lassociator.
      rewrite id2_left.
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      apply id2_right.
    Qed.

    Definition binprod_1_ump_in_slice_cell
      : binprod_1cell q binprod_cone_in_slice.
    Proof.
      use make_binprod_1cell.
      - simple refine (_ ,, _).
        + exact (pb_ump_mor Hpb other_cone).
        + exact φ.
      - use make_invertible_2cell.
        + simple refine (_ ,, _).
          * exact (pb_ump_mor_pr1 Hpb other_cone).
          * abstract
              (cbn ;
               rewrite lwhisker_id2, id2_left ;
               rewrite !vassocl ;
               rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
               rewrite rassociator_lassociator ;
               rewrite id2_left ;
               rewrite rwhisker_vcomp ;
               rewrite vcomp_linv ;
               rewrite id2_rwhisker ;
               apply id2_right).
        + use is_invertible_2cell_in_slice_bicat.
          apply property_from_invertible_2cell.
      - use make_invertible_2cell.
        + simple refine (_ ,, _).
          * exact (pb_ump_mor_pr2 Hpb other_cone).
          * exact binprod_1_ump_in_slice_cell_eq.
        + use is_invertible_2cell_in_slice_bicat.
          apply property_from_invertible_2cell.
    Defined.
  End BinProdUmp1.

  Definition binprod_1_ump_in_slice
    : binprod_ump_1 binprod_cone_in_slice
    := λ q, binprod_1_ump_in_slice_cell q.

  Section BinProdUmp2.
    Context {h : slice_bicat b}
            {φ ψ : h --> binprod_cone_in_slice}
            (α : φ · binprod_cone_pr1 binprod_cone_in_slice
                 ==>
                 ψ · binprod_cone_pr1 binprod_cone_in_slice)
            (β : φ · binprod_cone_pr2 binprod_cone_in_slice
                 ==>
                 ψ · binprod_cone_pr2 binprod_cone_in_slice).

    Definition binprod_2_ump_in_slice_cell_unique
      : isaprop
          (∑ χ,
           χ ▹ binprod_cone_pr1 binprod_cone_in_slice = α
           ×
           χ ▹ binprod_cone_pr2 binprod_cone_in_slice = β).
    Proof.
      use invproofirrelevance.
      intros χ₁ χ₂.
      use subtypePath.
      {
        intro.
        apply isapropdirprod ; apply cellset_property.
      }
      use eq_2cell_slice.
      use (pb_ump_eq Hpb).
      - exact (pr1 α).
      - exact (pr1 β).
      - cbn.
        pose (r₁ := pr2 α).
        pose (r₂ := pr2 β).
        cbn in r₁, r₂.
        rewrite !lwhisker_id2, !id2_left in r₁.
        use (vcomp_lcancel (pr12 φ)).
        {
          apply property_from_invertible_2cell.
        }
        rewrite !vassocr.
        rewrite !vassocr in r₂.
        refine (maponpaths (λ z, z • _) r₂ @ _) ; clear r₂.
        refine (_ @ maponpaths (λ z, (z • _) • _) (!r₁)) ; clear r₁.
        rewrite !vassocl.
        apply maponpaths.
        rewrite lassociator_rassociator, id2_right.
        rewrite !vassocr.
        rewrite lassociator_rassociator, id2_left.
        apply idpath.
      - exact (maponpaths pr1 (pr12 χ₁)).
      - exact (maponpaths pr1 (pr22 χ₁)).
      - exact (maponpaths pr1 (pr12 χ₂)).
      - exact (maponpaths pr1 (pr22 χ₂)).
    Qed.

    Definition binprod_2_ump_in_slice_cell
      : φ ==> ψ.
    Proof.
      simple refine (_ ,, _).
      - use (pb_ump_cell Hpb _ _ (pr1 α) (pr1 β)) ; cbn.
        abstract
          (pose (r₁ := pr2 α) ;
           pose (r₂ := pr2 β) ;
           cbn in r₁, r₂ ;
           rewrite !lwhisker_id2, !id2_left in r₁ ;
           use (vcomp_lcancel (pr12 φ)) ; [ apply property_from_invertible_2cell | ] ;
           rewrite !vassocr ;
           rewrite !vassocr in r₂ ;
           refine (maponpaths (λ z, z • _) r₂ @ _) ; clear r₂ ;
           refine (_ @ maponpaths (λ z, (z • _) • _) (!r₁)) ; clear r₁ ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite lassociator_rassociator, id2_right ;
           rewrite !vassocr ;
           rewrite lassociator_rassociator, id2_left ;
           apply idpath).
      - abstract
          (cbn ;
           use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ;
           rewrite !vassocl ;
           rewrite <- rwhisker_rwhisker ;
           rewrite (pb_ump_cell_pr1 Hpb) ;
           pose (pr2 α) as r ;
           cbn in r ;
           rewrite !lwhisker_id2, !id2_left in r ;
           rewrite !vassocr ;
           exact r).
    Defined.

    Definition binprod_2_ump_in_slice_cell_pr1
      : binprod_2_ump_in_slice_cell ▹ binprod_cone_pr1 binprod_cone_in_slice
        =
        α.
    Proof.
      unfold binprod_2_ump_in_slice_cell.
      use eq_2cell_slice.
      cbn.
      apply (pb_ump_cell_pr1 Hpb).
    Qed.

    Definition binprod_2_ump_in_slice_cell_pr2
      : binprod_2_ump_in_slice_cell ▹ binprod_cone_pr2 binprod_cone_in_slice
        =
        β.
    Proof.
      unfold binprod_2_ump_in_slice_cell.
      use eq_2cell_slice.
      cbn.
      apply (pb_ump_cell_pr2 Hpb).
    Qed.
  End BinProdUmp2.

  Definition binprod_2_ump_in_slice
    : binprod_ump_2 binprod_cone_in_slice.
  Proof.
    intros h φ ψ α β.
    use iscontraprop1.
    - exact (binprod_2_ump_in_slice_cell_unique α β).
    - refine (binprod_2_ump_in_slice_cell α β ,, _ ,, _).
      + exact (binprod_2_ump_in_slice_cell_pr1 α β).
      + exact (binprod_2_ump_in_slice_cell_pr2 α β).
  Defined.

  Definition binprod_ump_in_slice
    : has_binprod_ump binprod_cone_in_slice.
  Proof.
    split.
    - exact binprod_1_ump_in_slice.
    - exact binprod_2_ump_in_slice.
  Defined.
End ProductSlice.

Definition products_in_slice_bicat
           {B : bicat}
           (pb_B : has_pb B)
           (b : B)
  : has_binprod (slice_bicat b).
Proof.
  intros f₁ f₂.
  exact (_ ,, binprod_ump_in_slice _ _ _ _ _ (pr2 (pb_B _ _ _ (pr2 f₁) (pr2 f₂)))).
Defined.

(**
 3. Inserters

 We construct inserters in the slice bicategory by using both inserters
 and equifiers in the base. We need to take an equifier to guarantee
 that the obtained 2-cell, satisfies a coherency.
 *)
Section InsertersSlice.
  Context {B : bicat}
          (ins_B : has_inserters B)
          (eq_B : has_equifiers B)
          {b : B}
          {h₁ h₂ : slice_bicat b}
          (α β : h₁ --> h₂).

  Let I : B
    := pr1 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)).
  Let p : I --> pr1 h₁
    := pr12 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)).
  Let γ : p · pr1 α ==> p · pr1 β
    := pr122 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)).
  Let I_cone : inserter_cone (pr1 α) (pr1 β)
    := make_inserter_cone I p γ.
  Let HI : has_inserter_ump I_cone
    := pr222 (ins_B (pr1 h₁) (pr1 h₂) (pr1 α) (pr1 β)).

  Let E : B
    := pr1 (eq_B
              I _
              (p · pr2 h₁) (p · pr1 β · pr2 h₂)
              (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂))
              ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))).
  Let p' : E --> I
    := pr12 (eq_B
               I _
               (p · pr2 h₁) (p · pr1 β · pr2 h₂)
               (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂))
               ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))).
  Let path : p' ◃ _ = p' ◃ _
    := pr122 (eq_B
                I _
                (p · pr2 h₁) (p · pr1 β · pr2 h₂)
                (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂))
                ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))).
  Let E_cone : equifier_cone _ _ _ _
    := make_equifier_cone E p' path.
  Let HE : has_equifier_ump E_cone
    := pr222 (eq_B
                I _
                (p · pr2 h₁) (p · pr1 β · pr2 h₂)
                (((p ◃ pr12 α) • lassociator p (pr1 α) (pr2 h₂)) • (γ ▹ pr2 h₂))
                ((p ◃ pr12 β) • lassociator p (pr1 β) (pr2 h₂))).

  Definition inserter_slice
    : slice_bicat b.
  Proof.
    use make_ob_slice.
    - exact E.
    - exact (p' · p · pr2 h₁).
  Defined.

  Definition inserter_slice_pr1
    : inserter_slice --> h₁.
  Proof.
    use make_1cell_slice.
    - exact (p'· p).
    - apply id2_invertible_2cell.
  Defined.

  Definition inserter_slice_cell_cell
    : p' · p · pr1 α ==> p' · p · pr1 β
    := rassociator _ _ _ • (p' ◃ γ) • lassociator _ _ _.

  Definition inserter_slice_cell_homot
    : cell_slice_homot
        (inserter_slice_pr1 · α)
        (inserter_slice_pr1 · β)
        inserter_slice_cell_cell.
  Proof.
    unfold cell_slice_homot, inserter_slice_cell_cell ; cbn.
    rewrite !id2_left.
    rewrite <- !rwhisker_vcomp.
    use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
    rewrite !vassocr.
    rewrite <- !lwhisker_lwhisker.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lassociator_lassociator.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        rewrite id2_left.
        apply idpath.
      }
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite !lwhisker_vcomp.
    rewrite !vassocl.
    etrans.
    {
      apply maponpaths_2.
      rewrite !vassocr.
      apply path.
    }
    rewrite <- !lwhisker_vcomp.
    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    apply lassociator_lassociator.
  Qed.

  Definition inserter_slice_cell
    : inserter_slice_pr1 · α ==> inserter_slice_pr1 · β.
  Proof.
    use make_2cell_slice.
    - exact inserter_slice_cell_cell.
    - exact inserter_slice_cell_homot.
  Defined.

  Let cone : inserter_cone α β
    := make_inserter_cone
         inserter_slice
         inserter_slice_pr1
         inserter_slice_cell.

  Section InserterSliceUMP1.
    Context (q : inserter_cone α β).

    Definition inserter_ump_1_slice_mor_to_ins
      : pr11 q --> I.
    Proof.
      use (inserter_ump_mor HI).
      - exact (pr1 (inserter_cone_pr1 q)).
      - exact (pr1 (inserter_cone_cell q)).
    Defined.

    Definition inserter_ump_1_slice_mor_path
      : inserter_ump_1_slice_mor_to_ins ◃ (((p ◃ pr12 α) • lassociator _ _ _) • (γ ▹ pr2 h₂))
        =
        inserter_ump_1_slice_mor_to_ins ◃ ((p ◃ pr12 β) • lassociator _ _ _).
    Proof.
      rewrite <- !lwhisker_vcomp.
      use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ].
      rewrite !vassocr.
      rewrite !lwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      use (vcomp_lcancel ((inserter_ump_mor_pr1 HI _ _)^-1 ▹ _)) ; [ is_iso | ].
      rewrite !vassocr.
      rewrite !vcomp_whisker.
      rewrite !vassocl.
      use (vcomp_lcancel (pr12 (inserter_cone_pr1 q))).
      {
        apply property_from_invertible_2cell.
      }
      pose (pr2 (inserter_cone_cell q)) as m.
      cbn in m.
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_hcomp.
          rewrite inverse_pentagon_4.
          rewrite <- rwhisker_hcomp.
          rewrite !vassocl.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        apply idpath.
      }
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite lwhisker_hcomp.
          rewrite inverse_pentagon_4.
          rewrite <- rwhisker_hcomp.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      etrans.
      {
        do 3 apply maponpaths_2.
        rewrite !vassocl.
        exact (!m).
      }
      rewrite !vassocl.
      do 3 apply maponpaths.
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !rwhisker_vcomp.
      apply maponpaths.
      use vcomp_move_R_Mp ; [ is_iso | ].
      use vcomp_move_R_Mp ; [ is_iso | ].
      cbn.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        apply (inserter_ump_mor_cell HI).
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      apply id2_left.
    Qed.

    Definition inserter_ump_1_slice_mor_to_eq
      : pr11 q --> E.
    Proof.
      use (equifier_ump_mor HE).
      - exact inserter_ump_1_slice_mor_to_ins.
      - exact inserter_ump_1_slice_mor_path.
    Defined.

    Definition inserter_ump_1_slice_mor_inv2cell
      : invertible_2cell
          (pr21 q)
          (inserter_ump_1_slice_mor_to_eq · (p' · p · pr2 h₁)).
    Proof.
      use make_invertible_2cell.
      - exact (pr12 (inserter_cone_pr1 q)
               • ((inserter_ump_mor_pr1 HI _ _)^-1 ▹ _)
               • ((equifier_ump_mor_pr1 HE _ _)^-1 ▹ _ ▹ _)
               • (rassociator _ _ _ ▹ _)
               • rassociator _ _ _).
      - is_iso.
        apply property_from_invertible_2cell.
    Defined.

    Definition inserter_ump_1_slice_mor
      : q --> cone.
    Proof.
      use make_1cell_slice.
      - exact inserter_ump_1_slice_mor_to_eq.
      - exact inserter_ump_1_slice_mor_inv2cell.
    Defined.

    Definition inserter_ump_1_slice_pr1_cell_cell
      : inserter_ump_1_slice_mor_to_eq · (p' · p)
        ==>
        pr1 (inserter_cone_pr1 q)
      := lassociator _ _ _
         • (equifier_ump_mor_pr1 HE _ _ ▹ _)
         • inserter_ump_mor_pr1 HI _ _.

    Definition inserter_ump_1_slice_pr1_cell_homot
      : cell_slice_homot
          (inserter_ump_1_slice_mor · inserter_slice_pr1)
          (inserter_cone_pr1 q)
          inserter_ump_1_slice_pr1_cell_cell.
    Proof.
      unfold cell_slice_homot, inserter_ump_1_slice_pr1_cell_cell ; cbn.
      rewrite !vassocl.
      refine (_ @ id2_right _).
      apply maponpaths.
      rewrite lwhisker_id2.
      rewrite id2_left.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite rwhisker_vcomp.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      rewrite !rwhisker_vcomp.
      refine (_ @ id2_rwhisker _ _).
      apply maponpaths.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      apply vcomp_linv.
    Qed.

    Definition inserter_ump_1_slice_pr1_cell
      : inserter_ump_1_slice_mor · inserter_slice_pr1
        ==>
        inserter_cone_pr1 q.
    Proof.
      use make_2cell_slice.
      - exact inserter_ump_1_slice_pr1_cell_cell.
      - exact inserter_ump_1_slice_pr1_cell_homot.
    Defined.

    Definition inserter_ump_1_slice_pr1
      : invertible_2cell
          (inserter_ump_1_slice_mor · inserter_slice_pr1)
          (inserter_cone_pr1 q).
    Proof.
      use make_invertible_2cell.
      - exact inserter_ump_1_slice_pr1_cell.
      - use is_invertible_2cell_in_slice_bicat ; cbn.
        unfold inserter_ump_1_slice_pr1_cell_cell.
        is_iso ; apply property_from_invertible_2cell.
    Defined.

    Definition inserter_ump_1_slice_cell
      : (_ ◃ inserter_cone_cell cone)
        • lassociator _ _ _
        • (inserter_ump_1_slice_pr1 ▹ β)
        =
        lassociator _ _ _
        • (inserter_ump_1_slice_pr1 ▹ α)
        • inserter_cone_cell q.
    Proof.
      use eq_2cell_slice.
      cbn ; unfold inserter_ump_1_slice_pr1_cell_cell, inserter_slice_cell_cell ; cbn.
      rewrite <- !lwhisker_vcomp.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_lassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        apply idpath.
      }
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      rewrite lassociator_lassociator.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      do 2 refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        apply (inserter_ump_mor_cell HI).
      }
      rewrite !vassocl.
      apply idpath.
    Qed.
  End InserterSliceUMP1.

  Definition inserter_ump_1_slice
    : has_inserter_ump_1 cone.
  Proof.
    intro q.
    use make_inserter_1cell.
    - exact (inserter_ump_1_slice_mor q).
    - exact (inserter_ump_1_slice_pr1 q).
    - exact (inserter_ump_1_slice_cell q).
  Defined.

  Local Lemma inserter_ump_path_help
        {h : slice_bicat b}
        {u₁ u₂ : h --> cone}
        (ζ : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone)
        (r : rassociator _ _ _
             • (u₁ ◃ inserter_cone_cell cone)
             • lassociator _ _ _
             • (ζ ▹ β)
             =
             (ζ ▹ α)
             • rassociator _ _ _
             • (u₂ ◃ inserter_cone_cell cone)
             • lassociator _ _ _)
    : rassociator _ _ _
      • (_ ◃ inserter_cone_cell I_cone)
      • lassociator _ _ _
      • ((rassociator _ _ _ • pr1 ζ • lassociator _ _ _) ▹ pr1 β)
      =
      (rassociator _ _ _ • pr1 ζ • lassociator _ _ _ ▹ pr1 α)
      • rassociator _ _ _
      • (_ ◃ inserter_cone_cell I_cone)
      • lassociator _ _ _.
  Proof.
    cbn.
    rewrite <- !rwhisker_vcomp.
    rewrite !vassocl.
    pose (r' := maponpaths pr1 r).
    cbn in r'.
    refine (!_).
    etrans.
    {
      do 2 apply maponpaths.
      rewrite rwhisker_hcomp.
      rewrite !vassocr.
      rewrite inverse_pentagon_2.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite <- lassociator_lassociator.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        apply idpath.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      exact (!r').
    }
    rewrite !vassocr.
    do 2 apply maponpaths_2.
    etrans.
    {
      do 2 apply maponpaths_2.
      rewrite rwhisker_hcomp.
      rewrite inverse_pentagon_6.
      rewrite <- lwhisker_hcomp.
      apply idpath.
    }
    rewrite !vassocl.
    apply maponpaths.
    use vcomp_move_R_pM ; [ is_iso | ].
    cbn.
    rewrite !vassocr.
    rewrite <- lwhisker_lwhisker.
    rewrite !vassocl.
    refine (!_).
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- lassociator_lassociator.
      rewrite !vassocl.
      rewrite rwhisker_vcomp.
      rewrite lassociator_rassociator.
      rewrite id2_rwhisker.
      rewrite id2_right.
      apply idpath.
    }
    rewrite !vassocr.
    apply maponpaths_2.
    rewrite !lwhisker_vcomp.
    apply maponpaths.
    unfold inserter_slice_cell_cell.
    rewrite !vassocr.
    rewrite lassociator_rassociator.
    rewrite id2_left.
    apply idpath.
  Qed.

  Section InserterUMP2Slice.
    Context {h : slice_bicat b}
            {u₁ u₂ : h --> cone}
            (ζ : u₁ · inserter_cone_pr1 cone ==> u₂ · inserter_cone_pr1 cone)
            (r : rassociator _ _ _
                 • (u₁ ◃ inserter_cone_cell cone)
                 • lassociator _ _ _
                 • (ζ ▹ β)
                 =
                 (ζ ▹ α)
                 • rassociator _ _ _
                 • (u₂ ◃ inserter_cone_cell cone)
                 • lassociator _ _ _).

    Definition inserter_ump_2_slice_cell_cell
      : pr1 u₁ ==> pr1 u₂.
    Proof.
      use (equifier_ump_cell HE).
      use (inserter_ump_cell HI).
      - exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _).
      - exact (inserter_ump_path_help ζ r).
    Defined.

    Definition inserter_ump_2_slice_cell_homot
      : cell_slice_homot
          u₁ u₂
          inserter_ump_2_slice_cell_cell.
    Proof.
      unfold cell_slice_homot, inserter_ump_2_slice_cell_cell ; cbn.
      use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite !vassocl.
      rewrite <- rwhisker_rwhisker.
      use (vcomp_rcancel (lassociator _ _ _ ▹ _)) ; [ is_iso | ].
      rewrite !vassocl.
      rewrite rwhisker_vcomp.
      rewrite <- rwhisker_rwhisker.
      rewrite (equifier_ump_cell_pr1 HE).
      rewrite (inserter_ump_cell_pr1 HI).
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocr.
      apply maponpaths_2.
      pose (pr2 ζ) as q.
      cbn in q.
      rewrite !lwhisker_id2, !id2_left in q.
      exact q.
    Qed.

    Definition inserter_ump_2_slice_cell
      : u₁ ==> u₂.
    Proof.
      use make_2cell_slice.
      - exact inserter_ump_2_slice_cell_cell.
      - exact inserter_ump_2_slice_cell_homot.
    Defined.

    Definition inserter_ump_2_slice_pr1
      : inserter_ump_2_slice_cell ▹ inserter_slice_pr1 = ζ.
    Proof.
      use eq_2cell_slice ; cbn.
      unfold inserter_ump_2_slice_cell_cell.
      use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite <- rwhisker_rwhisker.
      rewrite (equifier_ump_cell_pr1 HE).
      rewrite (inserter_ump_cell_pr1 HI).
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    Qed.
  End InserterUMP2Slice.

  Definition inserter_ump_2_slice
    : has_inserter_ump_2 cone.
  Proof.
    intros h u₁ u₂ ζ r.
    simple refine (_ ,, _).
    - exact (inserter_ump_2_slice_cell ζ r).
    - exact (inserter_ump_2_slice_pr1 ζ r).
  Defined.

  Definition inserter_ump_eq_slice
    : has_inserter_ump_eq cone.
  Proof.
    intros h u₁ u₂ ζ r φ₁ φ₂ s₁ s₂.
    use eq_2cell_slice.
    use (equifier_ump_eq HE).
    - use (inserter_ump_cell HI).
      + exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _).
      + exact (inserter_ump_path_help ζ r).
    - use (inserter_ump_eq HI).
      + exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _).
      + exact (inserter_ump_path_help ζ r).
      + rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite rwhisker_rwhisker.
        apply maponpaths_2.
        exact (maponpaths pr1 s₁).
      + apply (inserter_ump_cell_pr1 HI).
    - use (inserter_ump_eq HI).
      + exact (rassociator _ _ _ • pr1 ζ • lassociator _ _ _).
      + exact (inserter_ump_path_help ζ r).
      + rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite rwhisker_rwhisker.
        apply maponpaths_2.
        exact (maponpaths pr1 s₂).
      + apply (inserter_ump_cell_pr1 HI).
  Qed.

  Definition inserter_ump_slice
    : has_inserter_ump cone
    := inserter_ump_1_slice ,, inserter_ump_2_slice ,, inserter_ump_eq_slice.
End InsertersSlice.

Definition inserters_in_slice_bicat
           {B : bicat}
           (ins_B : has_inserters B)
           (eq_B : has_equifiers B)
           (b : B)
  : has_inserters (slice_bicat b).
Proof.
  intros h₁ h₂ α β.
  simple refine (_ ,, _ ,, _ ,, _).
  - exact (inserter_slice ins_B eq_B α β).
  - exact (inserter_slice_pr1 ins_B eq_B α β).
  - exact (inserter_slice_cell ins_B eq_B α β).
  - exact (inserter_ump_slice ins_B eq_B α β).
Defined.

(**
 4. Equifiers
 *)
Section EquifierSlice.
  Context {B : bicat}
          (b : B)
          {eq h₁ h₂ : slice_bicat b}
          {f₁ f₂ : h₁ --> h₂}
          (α β : f₁ ==> f₂)
          (e : eq --> h₁)
          (p : e ◃ α = e ◃ β)
          (cone := make_equifier_cone (pr1 eq) (pr1 e) (maponpaths pr1 p))
          (H : has_equifier_ump cone).

  Section EquifierUMP1.
    Context (q : equifier_cone f₁ f₂ α β).

    Definition equifier_ump_1_slice_mor_mor
      : pr11 q --> pr1 eq
      := equifier_ump_mor
           H
           (pr1 (equifier_cone_pr1 q))
           (maponpaths pr1 (equifier_cone_eq q)).

    Definition equifier_ump_1_slice_mor_inv2cell
      : invertible_2cell
          (pr21 q)
          (equifier_ump_1_slice_mor_mor · pr2 eq)
      := comp_of_invertible_2cell
           (pr2 (equifier_cone_pr1 q))
           (inv_of_invertible_2cell
              (comp_of_invertible_2cell
                 (lwhisker_of_invertible_2cell _ (pr2 e))
                 (comp_of_invertible_2cell
                    (lassociator_invertible_2cell _ _ _)
                    (rwhisker_of_invertible_2cell
                       _
                       (equifier_ump_mor_pr1 H _ _))))).

    Definition equifier_ump_1_slice_mor
      : q --> eq.
    Proof.
      use make_1cell_slice.
      - exact equifier_ump_1_slice_mor_mor.
      - exact equifier_ump_1_slice_mor_inv2cell.
    Defined.

    Definition equifier_ump_1_slice_pr1_cell_cell
      : equifier_ump_1_slice_mor_mor · pr1 e ==> pr1 (equifier_cone_pr1 q)
      := equifier_ump_mor_pr1 H _ _.

    Definition equifier_ump_1_slice_pr1_cell_homot
      : cell_slice_homot
          (equifier_ump_1_slice_mor · e)
          (equifier_cone_pr1 q)
          equifier_ump_1_slice_pr1_cell_cell.
    Proof.
      unfold cell_slice_homot ; cbn.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        rewrite rassociator_lassociator.
        apply id2_left.
      }
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      apply id2_right.
    Qed.

    Definition equifier_ump_1_slice_pr1_cell
      : equifier_ump_1_slice_mor · e ==> equifier_cone_pr1 q.
    Proof.
      use make_2cell_slice.
      - exact equifier_ump_1_slice_pr1_cell_cell.
      - exact equifier_ump_1_slice_pr1_cell_homot.
    Defined.

    Definition equifier_ump_1_slice_pr1
      : invertible_2cell
          (equifier_ump_1_slice_mor · e)
          (equifier_cone_pr1 q).
    Proof.
      use make_invertible_2cell.
      - exact equifier_ump_1_slice_pr1_cell.
      - use is_invertible_2cell_in_slice_bicat.
        apply property_from_invertible_2cell.
    Defined.
  End EquifierUMP1.

  Definition equifier_ump_1_in_slice
    : has_equifier_ump_1 (make_equifier_cone eq e p).
  Proof.
    intro q.
    use make_equifier_1cell.
    - exact (equifier_ump_1_slice_mor q).
    - exact (equifier_ump_1_slice_pr1 q).
  Defined.

  Section EquifierUMP2.
    Context {g : slice_bicat b}
            (u₁ u₂ : g --> eq)
            (γ : u₁ · e ==> u₂ · e).

    Definition equifier_ump_2_in_slice_cell_cell
      : pr1 u₁ ==> pr1 u₂
      := equifier_ump_cell H (pr1 γ).

    Definition equifier_ump_2_in_slice_cell_path
      : cell_slice_homot
          u₁ u₂
          equifier_ump_2_in_slice_cell_cell.
    Proof.
      unfold cell_slice_homot.
      unfold equifier_ump_2_in_slice_cell_cell.
      use (vcomp_rcancel ((_ ◃ pr12 e) • lassociator _ _ _)).
      {
        is_iso.
        apply property_from_invertible_2cell.
      }
      refine (_ @ pr2 γ) ; cbn.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- rwhisker_rwhisker.
      do 2 apply maponpaths.
      apply (equifier_ump_cell_pr1 H).
    Qed.

    Definition equifier_ump_2_in_slice_cell
      : u₁ ==> u₂.
    Proof.
      use make_2cell_slice.
      - exact equifier_ump_2_in_slice_cell_cell.
      - exact equifier_ump_2_in_slice_cell_path.
    Defined.

    Definition equifier_ump_2_in_slice_pr1
      : equifier_ump_2_in_slice_cell ▹ e = γ.
    Proof.
      use eq_2cell_slice ; cbn.
      apply (equifier_ump_cell_pr1 H).
    Qed.
  End EquifierUMP2.

  Definition equifier_ump_2_in_slice
    : has_equifier_ump_2 (make_equifier_cone eq e p)
    := λ g u₁ u₂ γ,
       equifier_ump_2_in_slice_cell u₁ u₂ γ
       ,,
       equifier_ump_2_in_slice_pr1 u₁ u₂ γ.

  Definition equifier_ump_eq_in_slice
    : has_equifier_ump_eq (make_equifier_cone eq e p).
  Proof.
    intros g u₁ u₂ γ φ₁ φ₂ q₁ q₂.
    use eq_2cell_slice.
    use (equifier_ump_eq H).
    - exact (pr1 γ).
    - exact (maponpaths pr1 q₁).
    - exact (maponpaths pr1 q₂).
  Qed.

  Definition equifier_ump_in_slice
    : has_equifier_ump (make_equifier_cone eq e p)
    := equifier_ump_1_in_slice
       ,,
       equifier_ump_2_in_slice
       ,,
       equifier_ump_eq_in_slice.
End EquifierSlice.

Definition equifiers_in_slice_bicat
           {B : bicat}
           (ins_B : has_equifiers B)
           (b : B)
  : has_equifiers (slice_bicat b).
Proof.
  intros h₁ h₂ f₁ f₂ α β.
  pose (e := ins_B (pr1 h₁) (pr1 h₂) (pr1 f₁) (pr1 f₂) (pr1 α) (pr1 β)).
  simple refine (make_ob_slice (pr12 e · pr2 h₁)
                 ,,
                 make_1cell_slice _ _
                 ,,
                 _
                 ,,
                 _).
  - exact (pr12 e).
  - apply id2_invertible_2cell.
  - abstract
      (use eq_2cell_slice ; cbn ;
       exact (pr122 e)).
  - apply equifier_ump_in_slice.
    exact (pr222 e).
Defined.


Require Import Setoid Relations Morphisms.

Class Module:=
mkModule
{
T:Set
;inclT:T->Prop
;eqT:T->T->Prop
;addT:T->T->T
;negT:T->T
;zeroT:T
;equiv_eqT:Equivalence eqT
;well_addT:forall a1 a2 b1 b2:T,eqT a1 a2->eqT b1 b2->eqT(addT a1 b1)(addT a2 b2)
;well_negT:forall a1 a2:T,eqT a1 a2->eqT(negT a1)(negT a2)
;well_inclT:forall a1 a2:T,eqT a1 a2->inclT a1->inclT a2
;closed_addT:
forall a b:T,inclT a->inclT b->inclT(addT a b)
;closed_negT:
forall a:T,inclT a->inclT(negT a)
;assoc_addT:
forall a b c:T,eqT(addT(addT a b)c)(addT a(addT b c))
;addT_a_zero:
forall a:T,eqT(addT a zeroT)a
;addT_zero_a:
forall a:T,eqT(addT zeroT a)a
;addT_a_negT:
forall a:T,eqT(addT a (negT a))zeroT
;addT_negT_a:
forall a:T,eqT(addT (negT a) a)zeroT
;eqT_decisive:
forall a b:T,{eqT a b}+{~eqT a b}
;comm_addT:
forall a b:T,eqT (addT a b)(addT b a)
;non_empty:
exists a:T,inclT a
}.
Add Parametric Relation(M:Module):(@T M) (@eqT M)
 reflexivity proved by (@Equivalence_Reflexive _ _ equiv_eqT)
 symmetry proved by (@Equivalence_Symmetric _ _ equiv_eqT)
 transitivity proved by (@Equivalence_Transitive _ _ equiv_eqT)
as ModEquiv.

Class Morph
(MA MB:Module)
:=
mkMorph
{
TA:=(@T MA)
;TB:=(@T MB)
;func:(@T MA)->(@T MB)
;hom_add:forall a1 a2:(@T MA),
(eqT:(@T MB)->(@T MB)->Prop)(addT (func a1)(func a2))(func(addT a1 a2))
;hom_neg:forall a:(@T MA),
eqT(negT (func a))(func(negT a))
;well_func:
forall a1 a2:(@T MA),
eqT a1 a2->eqT (func a1)(func a2)
;closed_func:
forall a:(@T MA),
inclT a->inclT (func a)
}.
Add Parametric Morphism
(M:Module):
addT with signature (eqT==>eqT==>eqT) as well_addT_x.
intros x y H x0 y0.
apply well_addT.
auto.
Qed.
Add Parametric Morphism
(M:Module):
negT with signature (eqT==>eqT) as well_negT_x.
apply well_negT.
Qed.
Add Parametric Morphism
(M:Module):
inclT with signature(eqT==>iff) as well_inclT_x.
intros.
split.
apply well_inclT;auto.
apply well_inclT;symmetry;auto.
Qed.
Add Parametric Morphism
{MA MB:Module}
(f:Morph MA MB):
func  with signature (eqT==>eqT) as well_func_x.
apply well_func.
Qed.

Theorem map_0_to_0
{MA MB:Module}
(f:Morph MA MB):
eqT(func zeroT)zeroT.
destruct f.
rewrite <-(addT_a_negT (zeroT)).
rewrite <-hom_add.
rewrite <-hom_neg.
apply addT_a_negT.
Qed.
Theorem rm_common
(M:Module)
:forall a b c,
eqT(addT b a)(addT c a)->eqT b c.
intros.
rewrite <-addT_a_zero.
rewrite <-(addT_a_zero c).
rewrite <-(addT_a_negT a).
rewrite <-assoc_addT.
rewrite <-assoc_addT.
rewrite H.
reflexivity.
Qed.

Theorem neg_add_add
(M:Module):
forall a b:T,
eqT(negT (addT a b))(addT(negT b)(negT a)).
intros.
apply (rm_common M (addT a b)).
rewrite assoc_addT.
rewrite <-(assoc_addT (negT a)).
rewrite addT_negT_a.
rewrite addT_negT_a.
rewrite addT_zero_a.
rewrite addT_negT_a.
reflexivity.
Qed.
Theorem neg_neg
(M:Module):
forall a:T,
eqT(negT(negT a))a.
intros.
apply (rm_common M (negT a)).
rewrite addT_negT_a.
rewrite addT_a_negT.
reflexivity.
Qed.

Theorem neg_zero
(M:Module):
eqT(negT zeroT)zeroT.
rewrite <-addT_a_zero.
apply addT_negT_a.
Qed.
Theorem incl_zero(M:Module):
inclT zeroT.
generalize non_empty.
intro.
destruct H.
rewrite <-(addT_a_negT x).
apply closed_addT.
apply H.
apply closed_negT.
apply H.
Qed.

Definition NegativeMorph
(M:Module):Morph M M:=
{|
func := fun t : T => negT t;
hom_add := fun a1 a2 : T =>
           trans_sym_co_inv_impl_morphism (Equivalence_PER (ModEquiv M))
             (negT (addT a1 a2)) (addT (negT a2) (negT a1))
             (neg_add_add M a1 a2)
             (trans_co_eq_inv_impl_morphism (ModEquiv_Transitive M)
                (addT (negT a1) (negT a2)) (addT (negT a2) (negT a1))
                (comm_addT (negT a1) (negT a2)) (addT (negT a2) (negT a1))
                (addT (negT a2) (negT a1))
                (eq_proper_proxy T (addT (negT a2) (negT a1)))
                (reflexivity (addT (negT a2) (negT a1))));
hom_neg := fun a : T => reflexivity (negT (negT a));
well_func := well_negT ;
closed_func:=closed_negT
|}.

Definition ZeroMorph
(MA MB:Module)
:Morph MA MB:=
{|
func := fun _ : T => zeroT;
hom_add := fun _ _ : T => addT_a_zero zeroT;
hom_neg := fun _ : T => neg_zero MB;
well_func := fun (a1 a2 : T) (_ : eqT a1 a2) => reflexivity zeroT ;
closed_func:=fun (a:T)(_:inclT a)=>(incl_zero MB)|}
.
Print ZeroMorph.

Notation "[ f , a ]":=(@func _ _ f a) .

Goal
forall MA MB:Module,
forall a:(@T MA),
eqT (@func MA MB (ZeroMorph MA MB) a) (zeroT).
intros.
simpl.
reflexivity.
Qed.

Definition IdentityMorph
(M:Module):Morph M M:=
{|
func := fun t : T => t;
hom_add := fun a1 a2 : T => reflexivity (addT a1 a2);
hom_neg := fun a : T => reflexivity (negT a);
well_func := fun (a1 a2 : T) (H : eqT a1 a2) => H ;
closed_func:=fun(a:T)(H:inclT a)=>H|}
.

Definition CompMorph
{MA MB MC:Module}
(g:Morph MB MC)(f:Morph MA MB):Morph MA MC
:={|
func := fun a : T => [g, [f, a]];
hom_add := fun a1 a2 : T =>
           trans_co_eq_inv_impl_morphism (ModEquiv_Transitive MC)
             (addT [g, [f, a1]] [g, [f, a2]]) [g, addT [f, a1] [f, a2]]
             (hom_add [f, a1] [f, a2]) [g, [f, addT a1 a2]]
             [g, [f, addT a1 a2]] (eq_proper_proxy T [g, [f, addT a1 a2]])
             (trans_co_eq_inv_impl_morphism (ModEquiv_Transitive MC)
                [g, addT [f, a1] [f, a2]] [g, [f, addT a1 a2]]
                (well_func_x_Proper g (addT [f, a1] [f, a2]) [f, addT a1 a2]
                   (hom_add a1 a2)) [g, [f, addT a1 a2]] [g, [f, addT a1 a2]]
                (eq_proper_proxy T [g, [f, addT a1 a2]])
                (reflexivity [g, [f, addT a1 a2]]));
hom_neg := fun a : T =>
           trans_co_eq_inv_impl_morphism (ModEquiv_Transitive MC)
             (negT [g, [f, a]]) [g, negT [f, a]] (hom_neg [f, a])
             [g, [f, negT a]] [g, [f, negT a]]
             (eq_proper_proxy T [g, [f, negT a]])
             (trans_co_eq_inv_impl_morphism (ModEquiv_Transitive MC)
                [g, negT [f, a]] [g, [f, negT a]]
                (well_func_x_Proper g (negT [f, a]) [f, negT a] (hom_neg a))
                [g, [f, negT a]] [g, [f, negT a]]
                (eq_proper_proxy T [g, [f, negT a]])
                (reflexivity [g, [f, negT a]]));
well_func := fun (a1 a2 : T) (H : eqT a1 a2) =>
             well_func [f, a1] [f, a2] (well_func a1 a2 H) ;
closed_func:=fun (a:(@T MA))(H:inclT a)=>(closed_func [f,a] (closed_func a H))
|}
.

Definition isin_kernel
{MA MB:Module}
(f:Morph MA MB)(a:(@T MA)):Prop
:=inclT a/\eqT [f,a] (zeroT:(@T MB)).

Lemma Tmp0:exists a,a=0.
exists 0.
reflexivity.
Qed.
Print Tmp0.
Lemma Tmp1:
exists a:unit,(fun _:unit=>True)a.
exists tt.
auto.
Qed.
Print Tmp1.

Definition ZeroModule:Module:=
{|
T := unit;
inclT := fun _ : unit => True;
eqT := fun _ _ : unit => True;
addT := fun _ _ : unit => tt;
negT := fun _ : unit => tt;
zeroT := tt;
equiv_eqT := {|
             Equivalence_Reflexive := fun _ : unit => I;
             Equivalence_Symmetric := fun (_ _ : unit) (H : True) => H;
             Equivalence_Transitive := fun (_ _ _ : unit) (_ H0 : True) => H0 |};
well_addT := fun (_ _ _ _ : unit) (_ H0 : True) => H0;
well_negT := fun (_ _ : unit) (H : True) => H;
well_inclT := fun (_ _ : unit) (_ H0 : True) => H0;
closed_addT := fun (_ _ : unit) (_ H0 : True) => H0;
closed_negT := fun (_ : unit) (H : True) => H;
assoc_addT := fun _ _ _ : unit => I;
addT_a_zero := fun _ : unit => I;
addT_zero_a := fun _ : unit => I;
addT_a_negT := fun _ : unit => I;
addT_negT_a := fun _ : unit => I;
eqT_decisive := fun _ _ : unit => left (~ True) I;
comm_addT := fun _ _ : unit => I ;
non_empty := ex_intro (fun _:unit=>True) tt I
|}
.

Program Definition KernelModule
{MA MB:Module}
(f:Morph MA MB):Module:=
{|
T := T;
inclT := isin_kernel f;
eqT := eqT;
addT := addT;
negT := negT;
zeroT := zeroT;
equiv_eqT := equiv_eqT;
well_addT := well_addT;
well_negT := well_negT;
well_inclT := _;
closed_addT := _;
closed_negT := _;
assoc_addT := assoc_addT;
addT_a_zero := addT_a_zero;
addT_zero_a := addT_zero_a;
addT_a_negT := addT_a_negT;
addT_negT_a := addT_negT_a;
eqT_decisive := eqT_decisive;
comm_addT := comm_addT ;
non_empty:=_
|}
.
Obligation 1.
unfold isin_kernel in *.
split.
apply (well_inclT a1).
exact H. apply H0.
rewrite <-H.
apply H0.
Qed.
Obligation 2.
unfold isin_kernel in *.
split.
apply (closed_addT a b).
apply H.
apply H0.
rewrite <-hom_add.
destruct H.
rewrite (H1).
destruct H0.
rewrite H2.
apply addT_a_zero.
Qed.
Obligation 3.
unfold isin_kernel in *.
destruct H.
split.
apply closed_negT.
apply H.
rewrite <-hom_neg.
rewrite H0.
apply neg_zero.
Qed.
Obligation 4.
unfold  isin_kernel.
exists zeroT.
split.
apply incl_zero.
apply map_0_to_0.
Qed.
Definition EqualMorph
{MA MB:Module}
(f g:Morph MA MB):Prop:=
forall a:(@T MA),eqT [f,a][g,a].

Definition isin_image
{MA MB:Module}
(f:Morph MA MB)
(b:(@T MB)):Prop:=inclT b/\
exists a:(@T MA),inclT a/\eqT[f,a]b.
Program Definition ImageModule
{MA MB:Module}
(f:Morph MA MB):Module:=
{|
T := T;
inclT := isin_image f;
eqT := eqT;
addT := addT;
negT := negT;
zeroT := zeroT;
equiv_eqT := equiv_eqT;
well_addT := well_addT;
well_negT := well_negT;
well_inclT :=_;
closed_addT := _;
closed_negT := _
               ;
assoc_addT := assoc_addT;
addT_a_zero := addT_a_zero;
addT_zero_a := addT_zero_a;
addT_a_negT := addT_a_negT;
addT_negT_a := addT_negT_a;
eqT_decisive := eqT_decisive;
comm_addT := comm_addT;
non_empty := _|}.

Add Parametric Relation(MA MB:Module):(Morph MA MB) EqualMorph
 reflexivity proved by _
 symmetry proved by _
 transitivity proved by _
as MorphEqual.
unfold Reflexive.
unfold EqualMorph.
reflexivity.
unfold Symmetric.
unfold EqualMorph.
intros.
symmetry;apply H.
unfold Transitive.
unfold EqualMorph.
intros.
rewrite <-H0.
apply H.
Qed.
Check MorphEqual.
unfold Transitive.
unfold EqualMorph.
intros.
rewrite H.
apply H0.
Qed.
unfold Symmetric.
unfold EqualMorph.
intros.
symmetry;apply H.
Qed.

unfold Reflexive.
unfold EqualMorph.
reflexivity.
Qed.

Add Parametric Morphism{MA MB:Module}
:(fun k:Morph MA MB=>(@func _ _ k)) with signature (EqualMorph==>eqT==>eqT) as EqMorph_SameVal.
unfold EqualMorph.
intros.
rewrite H0.
apply H.
Qed.
Theorem CompDef{MA MB MC:Module}
:forall f:Morph MA MB,
forall g:Morph MB MC,
forall a:(@T MA),
eqT [CompMorph g f,a][g,[f,a]].
unfold CompMorph.
reflexivity.
Qed.

Program Definition KernelMorph
{L1 L2 M1 M2:Module}
(f1:Morph L1 L2)
(g1:Morph M1 M2)
(v1:Morph L1 M1)
(v2:Morph L2 M2)
(H:EqualMorph (CompMorph v2 f1)(CompMorph g1 v1))
:Morph (KernelModule f1)(KernelModule g1)
:=mkMorph (KernelModule f1)(KernelModule g1) (@func L1 M1 v1) _ _ _ _.
Obligation 1 of KernelMorph  .

intros.
rewrite <-(@hom_add L1 M1 v1 a1 a2).
reflexivity.
Qed.
Obligation 2 of KernelMorph.
intros.
apply (@hom_neg L1 M1 v1 a).
Qed.
Obligation 3 of KernelMorph.
apply (@well_func L1 M1).
exact H0.
Qed.
Obligation 4 of KernelMorph.
unfold isin_kernel.
intros.
rewrite <-CompDef.
rewrite <-H.
unfold CompMorph;simpl.
split.
apply closed_func.
apply H0.
unfold isin_kernel in H0.

destruct H0.
rewrite H1.
apply map_0_to_0.
Qed.

Print KernelMorph.
Definition MonoMorph
{MA MB:Module}
(f:Morph MA MB):Prop
:=forall a:@T MA,inclT a->eqT [f,a]zeroT->eqT a zeroT.

Theorem KernelMorphMono
{L1 L2 M1 M2:Module}
(f1:Morph L1 L2)
(g1:Morph M1 M2)
(v1:Morph L1 M1)
(v2:Morph L2 M2)
{H:EqualMorph (CompMorph v2 f1)(CompMorph g1 v1)}:
MonoMorph v1->MonoMorph (KernelMorph f1 g1 v1 v2 H).
unfold MonoMorph.
intros.
apply H0.
simpl in H1.
apply H1.
apply H2.
Qed.

Definition exact_3
{MA MB MC:Module}
(f:Morph MA MB)(g:Morph MB MC):Prop:=
forall t:T,
isin_kernel g t<->isin_image f t.

Definition EpiMorph
{MA MB:Module}
(f:Morph MA MB):Prop:=
forall x:(@T MB),inclT x->(exists y:(@T MA),
inclT y/\eqT [f,y]x).

Theorem AB0_Epi{MA MB:Module}:forall f:Morph MA MB,
exact_3 f (ZeroMorph MB ZeroModule)<->EpiMorph f.
intros.
unfold ZeroMorph;
unfold ZeroModule;
unfold exact_3;
simpl.
unfold EpiMorph.
unfold isin_kernel.
simpl.
split.
intros.
destruct (H x).
destruct H1.
split.
apply H0. exact I.
destruct H3.
exists x0.
exact H3.
unfold isin_image.
intros.
split.
intro.
split.
apply H0.
destruct (H t).
apply H0.
exists x.
exact H1.
intro.
split.
apply H0.
auto.
Qed.

Theorem ZeroAB_Mono{MA MB:Module}:forall f:Morph MA MB,
exact_3 (ZeroMorph ZeroModule MA)f<->MonoMorph f.
unfold ZeroMorph;
unfold ZeroModule;
unfold exact_3;
unfold MonoMorph;
simpl.
unfold isin_kernel;
unfold isin_image;
simpl.
intros.
split.
intros.
symmetry.
destruct (H a).
destruct H2.
split. apply H0. apply H1.
destruct H4.
apply H4.
intros.
split.
intros.
split.
apply H0.
split.
apply tt.
split.
auto.
symmetry.
apply (H t).
apply H0.
apply H0.
intros.
split.
apply H0.
SearchAbout and.
destruct (proj2 H0).
rewrite <-(proj2 H1).
apply map_0_to_0.
Qed.
Obligation 1.
unfold isin_image in *.
split.
rewrite <-H.
apply H0.
destruct (proj2 H0).
exists x.
rewrite <-H.
exact H1.
Qed.
Obligation 2.
unfold isin_image in *.
split.
apply (closed_addT a b).
apply H. apply H0.
destruct (proj2 H).
destruct(proj2 H0).
exists (addT x x0).
split.
apply (closed_addT x x0 (proj1 H1)(proj1 H2)).
rewrite <-hom_add.
rewrite (proj2 H1).
rewrite (proj2 H2).
reflexivity.
Qed.
Obligation 3.
unfold isin_image in *.
split.
apply (closed_negT a (proj1 H)).
destruct (proj2 H).
exists (negT x).
split.
apply (closed_negT x (proj1 H0)).
rewrite <-hom_neg.
rewrite (proj2 H0).
reflexivity.
Qed.
Obligation 4.
exists zeroT.
unfold isin_image.
split.
exact (incl_zero MB).
exists zeroT.
split.
apply incl_zero.
apply map_0_to_0.
Qed.

Program Definition
Embed{MA MB:Module}
(f:Morph MA MB):Morph (KernelModule f)MA
:=mkMorph (KernelModule f) MA(fun a=>a) _ _ _ _.
Obligation 1 .
reflexivity.
Defined.
Obligation 2 . reflexivity.
Defined.
Obligation 4. unfold isin_kernel in H.
apply H.
Qed.
Obligations.

Require Import ZArith.
Check Zmod.
Print Zmod.
Print Zdiv_eucl_POS.

Program Definition DirectSum
(MA MB:Module)
:Module
:=
{|
T:=(@T MA)*(@T MB)
;inclT:=(fun t:T*T=>match t with(t1,t2)=>inclT t1/\inclT t2 end)
;eqT:=(fun t u:T*T=>match t with(t1,t2)=>
match u with(u1,u2)=>(eqT t1 u1)/\(eqT t2 u2) end end)
;addT:=(fun t u:T*T=>match t with(t1,t2)=>
match u with(u1,u2)=>(addT t1 u1,addT t2 u2) end end)
;negT:=(fun t:T*T=>match t with(t1,t2)=>(negT t1,negT t2)end)
;zeroT:=(zeroT,zeroT)
;equiv_eqT:=_
;well_addT:=_
;well_negT:=_
;well_inclT:=_
;closed_addT:=_
;closed_negT:=_
;assoc_addT:=_
;addT_a_zero:=_
;addT_zero_a:=_
;addT_a_negT:=_
;addT_negT_a:=_
;eqT_decisive:=_
;comm_addT:=_
;non_empty:=_
|}.
Obligation 1.
split.
unfold Reflexive.
intros.
destruct x as[x1 x2].
split.
reflexivity.
reflexivity.
unfold Symmetric.
intros.
destruct x as[x1 x2].
destruct y as[y1 y2].
split.
symmetry.
exact(proj1 H).
symmetry.
exact(proj2 H).
unfold Transitive.
intros.
destruct x as[x1 x2].
destruct y as[y1 y2].
destruct z as[z1 z2].
split.
transitivity y1.
exact (proj1 H).
exact (proj1 H0).
transitivity y2.
exact (proj2 H).
exact(proj2 H0).
Qed.
Obligation 2.
split.
rewrite H.
rewrite H0.
reflexivity.
rewrite H2.
rewrite H1.
reflexivity.
Qed.

Obligation 3.
split.
rewrite H.
reflexivity.
rewrite H0.
reflexivity.
Qed.
Obligation 4.
split.
rewrite <-H.
exact H0.
rewrite <-H2.
exact H1.
Qed.
Obligations.
Obligation 5.
split.
exact (closed_addT _ _ H H0).
exact (closed_addT _ _ H2 H1).
Qed.
Obligation 6.
split.
exact (closed_negT _ H).
exact (closed_negT _ H0).
Qed.
Obligation 7.
split.
apply assoc_addT.
apply assoc_addT.
Qed.
Obligation 8.
split.
apply addT_a_zero.
apply addT_a_zero.
Qed.

Obligation 9.
split.
apply addT_zero_a.
apply addT_zero_a.
Qed.
Obligation 10.
split.
apply (addT_a_negT t).
apply (addT_a_negT).
Qed.
Obligation 11.
split.
apply addT_negT_a.
apply addT_negT_a.
Qed.
Obligation 12.
generalize (eqT_decisive t1 t);intro.
generalize (eqT_decisive t2 t0);intro.
elim H.
elim H0.
intros.
left.
apply (conj a0 a).
intros.
right.
intro.
elim b.
exact (proj2 H1).
intros.
right.
intro.
elim b.
exact (proj1 H1).
Qed.
Obligation 13.
split.
apply comm_addT.
apply comm_addT.
Qed.

Obligation 14.
exists (zeroT,zeroT).
split.
apply incl_zero.
exact (incl_zero MB).
Qed.

Definition universal(M MA:Module)(p:Morph M MA):Prop:=
forall N:Module,forall f:Morph N MA,
exists g:Morph N M,
EqualMorph f (CompMorph p g).
Definition isomorphic(M1 M2:Module):Prop:=
exists p:Morph M1 M2,MonoMorph p/\EpiMorph p.
Theorem iso2:
forall M1 M2:Module,
isomorphic M1 M2 <->
exists f:Morph M1 M2,
exists g:Morph M2 M1,
EqualMorph (CompMorph g f) (IdentityMorph M1).
intros.
unfold isomorphic.
split.

intro.
destruct H.
destruct H.
exists x.
assert (forall m2:(@T M2),inclT m2->(@T M1)).
unfold EpiMorph in *.
intro m2.
intro.
generalize (H0 m2).
intro.
apply H1 in H2.
refine match H2 return (@T M1) with
ex_intro _ _=>_ end.
exact x0.
refine (mkMorph M2 M1 H1 _ _ _ _).
intros.
rewrite well_addT.
rewrite well_addT.
reflexivity.
reflexivity.
reflexivity.
apply neg_zero.
simpl.
rewrite
auto.

Theorem univ_iso:
forall M1 M2 MA MB:Module,
forall pa1:Morph M1 MA,
forall pb1:Morph M1 MB,
forall pa2:Morph M2 MA,
forall pb2:Morph M2 MB,
universal M1 MA pa1->universal M1 MB pb1->
universal M2 MA pa2->universal M2 MB pb2->
exists h:Morph M1 M2,
MonoMorph h/\EpiMorph h.
unfold universal.

intros.

destruct (H1 M1 pa1).


(* This file has been taken from https://github.com/PrincetonUniversity/VST/blob/master/hmacfcf/HMAC_spec.v *)
(* It has been formatted to fit your repository *)

(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Definition Blist := list bool.

Fixpoint splitVector(A : Set)(n m : nat) : Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0 =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Section HMAC.

  Variable c p : nat.
  Definition b := c + p.

  (* The compression function *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Variable Message : Set.
  Variable splitAndPad : Message -> list (Bvector b).
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  Variable fpad : Bvector c -> Bvector p.
  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x (fpad x)).

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

  Definition HMAC_2K (k : Bvector (b + b)) (m : Message) :=
    GHMAC_2K k (splitAndPad m).

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Bvector b.
  Hypothesis opad_ne_ipad : opad <> ipad.

  Definition GHMAC (k : Bvector b) :=
    GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

  Definition HMAC (k : Bvector b) :=
    HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

End HMAC.


Require Import HoTT.
From HoTT.Categories Require Import
     Functor
     NaturalTransformation
     FunctorCategory.
From GR.bicategories Require Import
     bicategory.equivalence
     bicategory.adjoint
     bicategory.equiv_to_adjequiv
     bicategory.univalent
     bicategory.bicategory_laws
     lax_functor.lax_functor
     lax_functor.weak_equivalence
     lax_transformation.lax_transformation
     modification.modification
     general_category
     lax_functor.examples.yoneda
     lax_functor.examples.representable
     lax_transformation.examples.representable
     modification.examples.composition
     modification.examples.identity
     modification.examples.representable
     modification.examples.representable_id
     modification.examples.representable_comp.
From GR.bicategories.bicategory.examples Require Import
     precat
     cat
     opposite
     pseudo_functors_bicat.

Section YonedaLemma.
  Context `{Univalence}
          {C : BiCategory}.
  Variable (F : PseudoFunctor (op C) PreCat)
           (X : C).

  Definition yoneda_to_presheaf
    : Functor (Pseudo (op C) PreCat⟦representable0 X, F⟧) (F X).
  Proof.
    simple refine (Build_Functor _ _ _ _ _ _).
    - exact (fun η => η.1.1 X (id₁ X)).
    - exact (fun _ _ α => α.1 X (id₁ X)).
    - reflexivity.
    - reflexivity.
  Defined.

  Definition presheaf_to_yoneda_m_d_help₁
             (x : F X)
             {Y₁ Y₂ : C}
             (f : C ⟦ Y₂, Y₁ ⟧)
             {h₁ h₂ : C ⟦Y₁,X⟧}
             (α : h₁ ==> h₂)
    : ((Fcomp₁ F f h₂) x o (F ₁ f) _1 ((F ₂ α) x))%morphism
      =
      ((F ₂ (α ▻ f)) x o (Fcomp₁ F f h₁) x)%morphism.
  Proof.
    pose (equiv_path_natural_transformation _ _ (Fcomp₂ F (id₂ f) α) x) as p.
    cbn in p.
    rewrite <- p ; clear p.
    pose (equiv_path_natural_transformation _ _ (@Fmor₂_id₂ _ _ F _ _ f) ((F ₁ h₂) x)) as p.
    cbn in p.
    rewrite p.
    rewrite left_identity.
    reflexivity.
  Qed.

  Definition presheaf_to_yoneda_m_d_help₂
             (x : F X)
             {Y₁ Y₂ : C}
             (f : C ⟦ Y₂, Y₁ ⟧)
             {h₁ h₂ : C ⟦Y₁,X⟧}
             (α : h₁ ==> h₂)
    : ((Fcomp₁_inv F f h₂) x o (F ₂ (α ▻ f)) x)%morphism
      =
      ((F ₁ f) _1 ((F ₂ α) x) o (Fcomp₁_inv F f h₁) x)%morphism.
  Proof.
    pose (equiv_path_natural_transformation _ _ (Fcomp₁_inv_naturality F (id₂ f) α) x) as p.
    cbn in *.
    rewrite p ; clear p.
    pose (equiv_path_natural_transformation _ _ (@Fmor₂_id₂ _ _ F _ _ f) ((F ₁ h₂) x)) as p.
    cbn in p.
    rewrite p.
    rewrite left_identity.
    reflexivity.
  Qed.

  Definition presheaf_to_yoneda_m_d (x : F X)
    : PseudoTransformation_d (representable0 X) F.
  Proof.
    make_pseudo_transformation.
    - intros Z ; cbn in *.
      exact (apply_functor (F Z) x o Fmor F X Z)%functor.
    - intros Y₁ Y₂ f.
      simple refine (Build_NaturalTransformation _ _ _ _).
      + intros h ; cbn in *.
        exact (Fcomp₁ F f h x).
      + intros h₁ h₂ α.
        exact (presheaf_to_yoneda_m_d_help₁ x f α).
    - intros Y₁ Y₂ f.
      simple refine (Build_NaturalTransformation _ _ _ _).
      + intros h ; cbn.
        exact (Fcomp₁_inv F f h x).
      + intros h₁ h₂ α.
        exact (presheaf_to_yoneda_m_d_help₂ x f α).
  Defined.

  Definition presheaf_to_yoneda_m_is_pseudo (x : F X)
    : is_pseudo_transformation_p (presheaf_to_yoneda_m_d x).
  Proof.
    make_is_pseudo_transformation.
    - intros Y₁ Y₂ f₁ f₂ α.
      apply path_natural_transformation.
      intros f ; cbn in *.
      rewrite identity_of, left_identity, right_identity.
      pose (equiv_path_natural_transformation _ _ (Fcomp₂ F α (id₂ f)) x) as p.
      cbn in p.
      rewrite <- p ; clear p.
      f_ap.
      pose (equiv_path_natural_transformation _ _ (Fmor₂_id₂ F f) x).
      rewrite p.
      cbn.
      rewrite identity_of.
      rewrite right_identity.
      reflexivity.
    - intros Z.
      apply path_natural_transformation.
      intros f ; cbn in *.
      rewrite !left_identity, !right_identity.
      pose (equiv_path_natural_transformation _ _ (F_left_unit_inv_2 F f) x) as p.
      cbn in p.
      rewrite p ; clear p.
      rewrite !right_identity.
      reflexivity.
    - intros Y₁ Y₂ Y₃ f₁ f₂.
      apply path_natural_transformation.
      intros g ; cbn in *.
      rewrite !identity_of, !left_identity, !right_identity.
      pose (equiv_path_natural_transformation _ _ (F_assoc_inv F f₂ f₁ g) x) as p.
      cbn in p.
      rewrite !identity_of, !left_identity, !right_identity in p.
      apply p.
    - intros Y₁ Y₂ f.
      apply path_natural_transformation.
      intros g ; cbn in *.
      apply (equiv_path_natural_transformation _ _ (vcomp_right_inverse (Fcomp₁ F f g)) x).
    - intros Y₁ Y₂ f.
      apply path_natural_transformation.
      intros g ; cbn in *.
      apply (equiv_path_natural_transformation _ _ (vcomp_left_inverse (Fcomp₁ F f g)) x).
  Qed.

  Definition presheaf_to_yoneda_m (x : F X)
    : PseudoTransformation (representable0 X) F
    := Build_PseudoTransformation
         (presheaf_to_yoneda_m_d x)
         (presheaf_to_yoneda_m_is_pseudo x).

  Definition presheaf_to_yoneda_2_d
             {x y : F X}
             (f : Core.morphism (F X) x y)
    : Modification_d (presheaf_to_yoneda_m x) (presheaf_to_yoneda_m y).
  Proof.
    intros Z.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn in *.
      exact (morphism_of (F ₁ h) f).
    - intros h₁ h₂ α ; cbn in *.
      exact (commutes (F ₂ α) _ _ f)^.
  Defined.

  Definition presheaf_to_yoneda_2_is_modification
             {x y : F X}
             (f : Core.morphism (F X) x y)
    : is_modification (presheaf_to_yoneda_2_d f).
  Proof.
    intros Z₁ Z₂ h.
    apply path_natural_transformation.
    intros ϕ ; cbn in *.
    rewrite !identity_of, !left_identity, !right_identity.
    exact (commutes (Fcomp₁ F h ϕ) _ _ f).
  Qed.

  Definition presheaf_to_yoneda_2
             (x y : F X)
             (f : Core.morphism (F X) x y)
    : Modification (presheaf_to_yoneda_m x) (presheaf_to_yoneda_m y)
    := Build_Modification
         (presheaf_to_yoneda_2_d f)
         (presheaf_to_yoneda_2_is_modification f).

  Definition presheaf_to_yoneda_2_comp
             (Y₁ Y₂ Y₃ : F X)
             (h₁ : Core.morphism (F X) Y₁ Y₂)
             (h₂ : Core.morphism (F X) Y₂ Y₃)
    : presheaf_to_yoneda_2 Y₁ Y₃ (h₂ o h₁)%morphism
      =
      comp_modification (presheaf_to_yoneda_2 Y₂ Y₃ h₂) (presheaf_to_yoneda_2 Y₁ Y₂ h₁).
  Proof.
    apply path_modification.
    funext Z.
    apply path_natural_transformation.
    intros ϕ ; cbn.
    apply composition_of.
  Qed.

  Definition presheaf_to_yoneda_2_id
             (Y : F X)
    : presheaf_to_yoneda_2 Y Y 1 = id_modification (presheaf_to_yoneda_m Y).
  Proof.
    apply path_modification.
    funext Z.
    apply path_natural_transformation.
    intros ϕ ; cbn.
    apply identity_of.
  Qed.

  Definition presheaf_to_yoneda
    : Functor (F X) (Pseudo (op C) PreCat⟦representable0 X, F⟧).
  Proof.
    simple refine (Build_Functor _ _ _ _ _ _).
    - exact presheaf_to_yoneda_m.
    - exact presheaf_to_yoneda_2.
    - exact presheaf_to_yoneda_2_comp.
    - exact presheaf_to_yoneda_2_id.
  Defined.

  Definition presheaf_to_yoneda_to_presheaf
    : (NaturalTransformation (yoneda_to_presheaf o presheaf_to_yoneda) 1)%functor.
  Proof.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros x ; cbn.
      exact (Fid_inv F X x).
    - intros x y f.
      cbn in *.
      exact (commutes (Fid_inv F X) x y f).
  Defined.

  Definition presheaf_to_yoneda_to_presheaf_inv
    : (NaturalTransformation 1 (yoneda_to_presheaf o presheaf_to_yoneda))%functor.
  Proof.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros x ; cbn.
      exact (Fid F X x).
    - intros x y f.
      cbn in *.
      exact (commutes (Fid F X) x y f).
  Defined.

  Definition presheaf_to_yoneda_to_presheaf_retr
    : (presheaf_to_yoneda_to_presheaf
         o presheaf_to_yoneda_to_presheaf_inv = 1)%natural_transformation.
  Proof.
    apply path_natural_transformation.
    intros Y ; cbn.
    exact (equiv_path_natural_transformation _ _ (vcomp_left_inverse (Fid F X)) Y).
  Qed.

  Definition presheaf_to_yoneda_to_presheaf_sect
    : (presheaf_to_yoneda_to_presheaf_inv
         o presheaf_to_yoneda_to_presheaf = 1)%natural_transformation.
  Proof.
    apply path_natural_transformation.
    intros Y ; cbn.
    exact (equiv_path_natural_transformation _ _ (vcomp_right_inverse (Fid F X)) Y).
  Qed.

  Global Instance iso_presheaf_to_yoneda_to_presheaf
    : @IsIsomorphism (_ -> _) _ _ presheaf_to_yoneda_to_presheaf.
  Proof.
    simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
    - exact presheaf_to_yoneda_to_presheaf_inv.
    - exact presheaf_to_yoneda_to_presheaf_sect.
    - exact presheaf_to_yoneda_to_presheaf_retr.
  Defined.

  Opaque representable0.

  Definition yoneda_to_presheaf_to_yoneda_m_d_help
             (σ : LaxTransformation (representable0 X) F)
             {Y : op C}
             {h₁ h₂ : (representable0 X).1 Y}
             (α : Core.morphism ((representable0 X).1 Y) h₁ h₂)
    : (((σ.1 Y) _1 (left_unit h₂))
         o laxnaturality_of σ h₂ (id₁ X)
         o (F ₂ α) (σ.1 X (id₁ X))
       =
       ((σ Y) _1 α)
         o ((σ.1 Y) _1 (left_unit h₁)
         o laxnaturality_of σ h₁ (id₁ X)))%morphism.
  Proof.
    pose (equiv_path_natural_transformation _ _ (laxnaturality_natural σ α) (id₁ X)).
    cbn in p.
    unfold bc_whisker_l, bc_whisker_r in p.
    rewrite identity_of in p.
    rewrite <- (right_identity _ _ _ ((F ₂ α) _)).
    rewrite !associativity.
    rewrite p.
    clear p.
    rewrite left_identity.
    rewrite <- !associativity.
    rewrite <- composition_of.
    pose (left_unit_natural α) as p.
    unfold vcomp in p.
    rewrite p.
    rewrite composition_of.
    reflexivity.
  Qed.

  Definition yoneda_to_presheaf_to_yoneda_m_d
             (σ : PseudoTransformation (representable0 X) F)
    : Modification_d (presheaf_to_yoneda (yoneda_to_presheaf σ)).1 σ.
  Proof.
    intros Y.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn.
      exact ((morphism_of (σ.1 Y) (left_unit h))
                o Core.components_of (laxnaturality_of σ h) (id₁ X))%morphism.
    - intros h₁ h₂ α.
      exact (yoneda_to_presheaf_to_yoneda_m_d_help σ α).
  Defined.

  Definition yoneda_to_presheaf_to_yoneda_m_is_modification
             (σ : PseudoTransformation (representable0 X) F)
    : is_modification (yoneda_to_presheaf_to_yoneda_m_d σ).
  Proof.
    intros Y₁ Y₂ f.
    apply path_natural_transformation.
    intros h ; cbn.
    rewrite (Fmor₂_id₂ F).
    rewrite !left_identity.
    rewrite !right_identity.
    pose (equiv_path_natural_transformation _ _ (transformation_assoc σ h f) (id₁ X)) as p.
    cbn in p.
    rewrite !identity_of, !left_identity, !right_identity in p.
    rewrite !associativity.
    rewrite p ; clear p.
    rewrite composition_of.
    rewrite <- !associativity.
    rewrite (commutes (laxnaturality_of σ f)).
    rewrite <- composition_of ; simpl.
    repeat f_ap.
    (* To see what's happening, do
       Transparent representable0.
       simpl.
     *)
    apply left_unit_assoc.
  Qed.

  Definition yoneda_to_presheaf_to_yoneda_m
             (σ : PseudoTransformation (representable0 X) F)
    : Modification (presheaf_to_yoneda (yoneda_to_presheaf σ)).1 σ
    := Build_Modification
         (yoneda_to_presheaf_to_yoneda_m_d σ)
         (yoneda_to_presheaf_to_yoneda_m_is_modification σ).

  Definition yoneda_to_presheaf_to_yoneda
    : (NaturalTransformation (presheaf_to_yoneda o yoneda_to_presheaf) 1)%functor.
  Proof.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - exact yoneda_to_presheaf_to_yoneda_m.
    - intros h₁ h₂ α.
      apply path_modification.
      funext Z.
      apply path_natural_transformation.
      intros g.
      cbn.
      rewrite <- !associativity.
      rewrite (commutes (α.1 Z)).
      rewrite !associativity.
      f_ap.
      pose (equiv_path_natural_transformation _ _ (α.2 X Z g) (id₁ X)) as p.
      cbn in p.
      rewrite !identity_of, !left_identity, !right_identity in p.
      apply p.
  Defined.

  Definition yoneda_to_presheaf_to_yoneda_inv_m_help
             (σ : PseudoTransformation (representable0 X) F)
             (Y : op C)
             {h₁ h₂ : Core.object ((representable0 X) Y)}
             (α : Core.morphism ((representable0 X) Y) h₁ h₂)
    : (((laxnaturality_of σ h₂)^-1 (id₁ X))
         o (σ Y) _1 (left_unit_inv h₂)
         o (σ Y) _1 α
      =
      ((F ₂ α) (σ.1 X (id₁ X)))
        o (((laxnaturality_of σ h₁)^-1 (id₁ X))
             o (σ Y) _1 (left_unit_inv h₁)))%morphism.
  Proof.
    refine (iso_moveR_Mp _ _ _) ; simpl.
    rewrite <- !associativity.
    do 2 refine (iso_moveL_pM _ _ _) ; simpl.
    pose (equiv_path_natural_transformation _ _ (laxnaturality_natural σ α) (id₁ X)).
    cbn in p.
    unfold bc_whisker_l, bc_whisker_r in p.
    rewrite identity_of in p.
    rewrite <- (right_identity _ _ _ ((F ₂ α) _)).
    rewrite !associativity.
    rewrite p ; clear p.
    rewrite left_identity.
    rewrite <- !associativity.
    rewrite <- composition_of.
    pose (left_unit_natural α) as p.
    unfold vcomp in p.
    rewrite <- p.
    rewrite composition_of.
    reflexivity.
  Qed.

  Definition yoneda_to_presheaf_to_yoneda_inv_m_d
             (σ : PseudoTransformation (representable0 X) F)
    : Modification_d σ (presheaf_to_yoneda (yoneda_to_presheaf σ)).1.
  Proof.
    intros Y.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn.
      exact ((Core.components_of (laxnaturality_of σ h)^-1 (id₁ X))
               o morphism_of (σ Y) (left_unit_inv h))%morphism.
    - intros h₁ h₂ α.
      exact (yoneda_to_presheaf_to_yoneda_inv_m_help σ Y α).
  Defined.

  Definition yoneda_to_presheaf_to_yoneda_inv_m_is_modification
             (σ : PseudoTransformation (representable0 X) F)
    : is_modification (yoneda_to_presheaf_to_yoneda_inv_m_d σ).
  Proof.
    intros Y₁ Y₂ f.
    apply path_natural_transformation.
    intros h ; cbn.
    rewrite !identity_of.
    rewrite !left_identity.
    rewrite !right_identity.
    refine (iso_moveR_pM _ _ _). simpl.
    rewrite !associativity.
    do 2 refine (iso_moveL_Mp _ _ _) ; simpl.
    pose (equiv_path_natural_transformation _ _ (transformation_assoc σ h f) (id₁ X)) as p.
    cbn in p.
    rewrite !identity_of, !left_identity, !right_identity in p.
    rewrite p ; clear p.
    rewrite composition_of.
    rewrite <- !associativity.
    rewrite (commutes (laxnaturality_of σ f)).
    rewrite <- composition_of ; simpl.
    repeat f_ap.
    symmetry.
    apply left_unit_assoc.
  Qed.

  Definition yoneda_to_presheaf_to_yoneda_inv_m
             (σ : PseudoTransformation (representable0 X) F)
    : Modification σ (presheaf_to_yoneda (yoneda_to_presheaf σ)).1
    := Build_Modification
         (yoneda_to_presheaf_to_yoneda_inv_m_d σ)
         (yoneda_to_presheaf_to_yoneda_inv_m_is_modification σ).

  Definition yoneda_to_presheaf_to_yoneda_inv
    : (NaturalTransformation 1 (presheaf_to_yoneda o yoneda_to_presheaf))%functor.
  Proof.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - exact yoneda_to_presheaf_to_yoneda_inv_m.
    - intros h₁ h₂ α.
      apply path_modification.
      funext Z.
      apply path_natural_transformation.
      intros g ; cbn.
      rewrite <- !associativity.
      refine (iso_moveR_Mp _ _ _) ; simpl.
      rewrite <- !associativity.
      do 2 refine (iso_moveL_pM _ _ _) ; simpl.
      rewrite (commutes (α.1 Z)).
      rewrite !associativity.
      f_ap.
      pose (equiv_path_natural_transformation _ _ (α.2 X Z g) (id₁ X)) as p.
      cbn in p.
      rewrite !identity_of, !left_identity, !right_identity in p.
      apply p^.
  Defined.

  Definition yoneda_to_presheaf_to_yoneda_retr
    : (yoneda_to_presheaf_to_yoneda
         o yoneda_to_presheaf_to_yoneda_inv = 1)%natural_transformation.
  Proof.
    apply path_natural_transformation.
    intros σ.
    apply path_modification.
    funext Y.
    apply path_natural_transformation.
    intros x ; cbn.
    rewrite !associativity.
    rewrite !(ap (fun z => _ o z)%morphism (associativity _ _ _ _ _ _ _ _)^).
    rewrite iso_component.
    rewrite right_inverse.
    rewrite left_identity.
    rewrite <- composition_of.
    rewrite <- inverse_of_left_unit, right_inverse.
    apply identity_of.
  Qed.

  Definition yoneda_to_presheaf_to_yoneda_sect
    : (yoneda_to_presheaf_to_yoneda_inv
         o yoneda_to_presheaf_to_yoneda = 1)%natural_transformation.
  Proof.
    apply path_natural_transformation.
    intros σ.
    apply path_modification.
    funext Y.
    apply path_natural_transformation.
    intros x ; cbn.
    rewrite !associativity.
    rewrite !(ap (fun z => _ o z)%morphism (associativity _ _ _ _ _ _ _ _)^).
    rewrite <- composition_of.
    rewrite <- inverse_of_left_unit, left_inverse.
    rewrite identity_of, left_identity.
    rewrite iso_component.
    apply left_inverse.
  Qed.

  Global Instance iso_yoneda_to_presheaf_to_yoneda
    : @IsIsomorphism (_ -> _) _ _ yoneda_to_presheaf_to_yoneda.
  Proof.
    simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
    - exact yoneda_to_presheaf_to_yoneda_inv.
    - exact yoneda_to_presheaf_to_yoneda_sect.
    - exact yoneda_to_presheaf_to_yoneda_retr.
  Defined.

  Definition yoneda_lemma
    : @adjoint_equivalence PreCat (Pseudo (op C) PreCat⟦representable0 X,F⟧) (F X).
  Proof.
    simple refine (equiv_to_adjequiv _ _).
    - exact yoneda_to_presheaf.
    - simple refine (@Build_IsEquivalence
                       PreCat
                       _
                       _
                       _
                       presheaf_to_yoneda _ _ _ _).
  Defined.
End YonedaLemma.

Section YonedaLocalEquivalence.
  Context `{Univalence}
          {C : BiCategory}.
  Variable (X Y : C).

  Definition yoneda_to_presheaf_representable_m_d
             (f : C⟦X,Y⟧)
    : Modification_d (yoneda C ₁ f).1 (presheaf_to_yoneda (representable0 Y) X f).1.
  Proof.
    intros Z.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn in *.
      apply id₂.
    - intros ; cbn.
      unfold id₂.
      rewrite left_identity, right_identity.
      reflexivity.
  Defined.

  Definition yoneda_to_presheaf_representable_is_modification
             (f : C⟦X,Y⟧)
    : is_modification (yoneda_to_presheaf_representable_m_d f).
  Proof.
    intros Z₁ Z₂ h.
    apply path_natural_transformation.
    intros q.
    cbn in *.
    unfold id₂, bc_whisker_l, bc_whisker_r.
    rewrite !hcomp_id₂, !left_identity, right_identity.
    reflexivity.
  Qed.

  Definition yoneda_to_presheaf_representable_m
             (f : C⟦X,Y⟧)
    : Modification (yoneda C ₁ f).1 (presheaf_to_yoneda (representable0 Y) X f).1
    := Build_Modification
         (yoneda_to_presheaf_representable_m_d f)
         (yoneda_to_presheaf_representable_is_modification f).

  Definition yoneda_to_presheaf_representable
    : NaturalTransformation (Fmor (yoneda C) X Y) (presheaf_to_yoneda (representable0 Y) X).
  Proof.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - exact yoneda_to_presheaf_representable_m.
    - intros Z₁ Z₂ h.
      apply path_modification.
      funext Z₃.
      apply path_natural_transformation.
      intros g ; cbn.
      rewrite left_identity, right_identity.
      reflexivity.
  Defined.

  (* TODO: slow when reading definition *)
  Definition presheaf_representable_to_yoneda_m_d
             (f : C⟦X,Y⟧)
    : Modification_d (presheaf_to_yoneda (representable0 Y) X f).1 (yoneda C ₁ f).1.
  Proof.
    intros Z.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - intros h ; cbn in *.
      apply id₂.
    - intros ; cbn.
      unfold id₂.
      rewrite left_identity, right_identity.
      reflexivity.
  Defined.

  Definition presheaf_representable_to_yoneda_is_modification
             (f : C⟦X,Y⟧)
    : is_modification (presheaf_representable_to_yoneda_m_d f).
  Proof.
    intros Z₁ Z₂ h.
    apply path_natural_transformation.
    intros q.
    cbn in *.
    unfold id₂, bc_whisker_l, bc_whisker_r.
    rewrite !hcomp_id₂, !left_identity, right_identity.
    reflexivity.
  Qed.

  (* TODO: slow when reading definition *)
  Definition presheaf_representable_to_yoneda_m
             (f : C⟦X,Y⟧)
    := Build_Modification
         (presheaf_representable_to_yoneda_m_d f)
         (presheaf_representable_to_yoneda_is_modification f).

  Definition presheaf_representable_to_yoneda
    : NaturalTransformation (presheaf_to_yoneda (representable0 Y) X) (Fmor (yoneda C) X Y).
  Proof.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - exact presheaf_representable_to_yoneda_m.
    - intros Z₁ Z₂ h.
      apply path_modification.
      funext Z₃.
      apply path_natural_transformation.
      intros g ; cbn.
      rewrite left_identity, right_identity.
      reflexivity.
  Defined.

  Global Instance iso_presheaf_representable_to_yoneda
    : @IsIsomorphism (_ -> _) _ _ presheaf_representable_to_yoneda.
  Proof.
    simple refine (Build_IsIsomorphism _ _ _ _ _ _ _).
    - exact yoneda_to_presheaf_representable.
    - apply path_natural_transformation.
      intros f.
      apply path_modification.
      funext Z.
      apply path_natural_transformation.
      intros g ; cbn.
      apply left_identity.
    - apply path_natural_transformation.
      intros f.
      apply path_modification.
      funext Z.
      apply path_natural_transformation.
      intros g ; cbn.
      apply left_identity.
  Defined.

  Definition yoneda_local_equivalence_help
    : @is_equivalence PreCat _ _ (Fmor (yoneda C) X Y).
  Proof.
    refine (@iso_equiv PreCat
                       (C ⟦ X, Y ⟧)
                       (Pseudo (op C) PreCat ⟦ (yoneda C) X, (yoneda C) Y ⟧)
                       (presheaf_to_yoneda (representable0 Y) X)
                       (Fmor (yoneda C) X Y)
                       _
                       presheaf_representable_to_yoneda
                       _).
    apply (adjoint_equivalence_is_equivalence
             (inv_equivalence (yoneda_lemma (representable0 Y) X))).
  Defined.
End YonedaLocalEquivalence.

Definition yoneda_local_equivalence
           `{Univalence}
           (C : BiCategory)
  : local_equivalence (yoneda C)
  := fun X Y =>
       (@equiv_to_adjequiv _ PreCat _ _
                           (Fmor (yoneda C) X Y)
                           (yoneda_local_equivalence_help X Y)).2.


Require Import Problem List.

Theorem solution : task.
Proof.
  unfold task.
  intro.
  induction t; simpl; intros.
  - specialize (H nil).
    destruct t'; [auto|discriminate].
  - destruct t'; [specialize (H nil); inversion H|].
    rewrite (IHt1 t'1).
    rewrite (IHt2 t'2).
    all: clear IHt1 IHt2.
    * specialize (H nil); simpl in H.
      inversion_clear H; auto.
    * intro.
      specialize (H (true :: i)).
      simpl in H; auto.
    * intro.
      specialize (H (false :: i)).
      simpl in H; auto.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.proposition_12.
Require Export GeoCoq.Elements.OriginalProofs.lemma_samesidesymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_planeseparation.
Require Export GeoCoq.Elements.OriginalProofs.lemma_droppedperpendicularunique.
Require Export GeoCoq.Elements.OriginalProofs.lemma_fiveline.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_07 :
   forall A B C D,
   neq A B -> Cong C A D A -> Cong C B D B -> OS C D A B ->
   eq C D.
Proof.
intros.
assert (nCol A B C) by (conclude_def OS ).
let Tf:=fresh in
assert (Tf:exists F, Perp_at C F A B F) by (conclude proposition_12);destruct Tf as [F];spliter.
rename_H H;
let Tf:=fresh in
assert (Tf:exists H, (Col C F F /\ Col A B F /\ Col A B H /\ Per H F C)) by (conclude_def Perp_at );destruct Tf as [H];spliter.
assert (~ eq C F).
 {
 intro.
 assert (Col A B C) by (conclude cn_equalitysub).
 contradict.
 }
assert (neq F C) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists E, (BetS C F E /\ Cong F E F C)) by (conclude lemma_extension);destruct Tf as [E];spliter.
assert (Cong A C A E).
by cases on (eq A F \/ neq A F).
{
 assert (Cong A E A C) by (conclude cn_equalitysub).
 assert (Cong A C A E) by (conclude lemma_congruencesymmetric).
 close.
 }
{
 assert (neq B A) by (conclude lemma_inequalitysymmetric).
 assert (Col B A F) by (forward_using lemma_collinearorder).
 assert (Col B A H) by (forward_using lemma_collinearorder).
 assert (Col A F H) by (conclude lemma_collinear4).
 assert (Col H F A) by (forward_using lemma_collinearorder).
 assert (Per A F C) by (conclude lemma_collinearright).
 assert (Per C F A) by (conclude lemma_8_2).
 let Tf:=fresh in
 assert (Tf:exists P, (BetS C F P /\ Cong C F P F /\ Cong C A P A /\ neq F A)) by (conclude_def Per );destruct Tf as [P];spliter.
 assert (Cong F E C F) by (forward_using lemma_congruenceflip).
 assert (Cong F E P F) by (conclude lemma_congruencetransitive).
 assert (Cong F E F P) by (forward_using lemma_congruenceflip).
 assert (eq E P) by (conclude lemma_extensionunique).
 assert (Cong C A E A) by (conclude cn_equalitysub).
 assert (Cong A C A E) by (forward_using lemma_congruenceflip).
 close.
 }
(** cases *)
assert (Cong B C B E).
by cases on (eq B F \/ neq B F).
{
 assert (Cong B E B C) by (conclude cn_equalitysub).
 assert (Cong B C B E) by (conclude lemma_congruencesymmetric).
 close.
 }
{
 assert (Col B A F) by (forward_using lemma_collinearorder).
 assert (Col B A H) by (forward_using lemma_collinearorder).
 assert (Col A B F) by (forward_using lemma_collinearorder).
 assert (Col A B H) by (forward_using lemma_collinearorder).
 assert (Col B F H) by (conclude lemma_collinear4).
 assert (Col H F B) by (forward_using lemma_collinearorder).
 assert (Per B F C) by (conclude lemma_collinearright).
 assert (Per C F B) by (conclude lemma_8_2).
 let Tf:=fresh in
 assert (Tf:exists P, (BetS C F P /\ Cong C F P F /\ Cong C B P B /\ neq F B)) by (conclude_def Per );destruct Tf as [P];spliter.
 assert (Cong F E C F) by (forward_using lemma_congruenceflip).
 assert (Cong F E P F) by (conclude lemma_congruencetransitive).
 assert (Cong F E F P) by (forward_using lemma_congruenceflip).
 assert (eq E P) by (conclude lemma_extensionunique).
 assert (Cong C B E B) by (conclude cn_equalitysub).
 assert (Cong B C B E) by (forward_using lemma_congruenceflip).
 close.
 }
(** cases *)
assert (TS C A B E) by (conclude_def TS ).
assert (OS D C A B) by (forward_using lemma_samesidesymmetric).
assert (TS D A B E) by (conclude lemma_planeseparation).
let Tf:=fresh in
assert (Tf:exists G, (BetS D G E /\ Col A B G /\ nCol A B D)) by (conclude_def TS );destruct Tf as [G];spliter.
assert (Cong E A C A) by (forward_using lemma_doublereverse).
assert (Cong A E C A) by (forward_using lemma_congruenceflip).
assert (Cong A E D A) by (conclude lemma_congruencetransitive).
assert (Cong A E A D) by (forward_using lemma_congruenceflip).
assert (Cong A D A E) by (conclude lemma_congruencesymmetric).
assert (Cong B D B C) by (forward_using lemma_doublereverse).
assert (Cong B D B E) by (conclude lemma_congruencetransitive).
assert (Cong A G A G) by (conclude cn_congruencereflexive).
assert (Cong G B G B) by (conclude cn_congruencereflexive).
assert ((eq A B \/ eq A G \/ eq B G \/ BetS B A G \/ BetS A B G \/ BetS A G B)) by (conclude_def Col ).
assert (Cong G D G E).
by cases on (eq A B \/ eq A G \/ eq B G \/ BetS B A G \/ BetS A B G \/ BetS A G B).
{
 assert (~ ~ Cong G D G E).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (Cong A D A E) by (conclude lemma_congruencesymmetric).
 assert (Cong G D G E) by (conclude cn_equalitysub).
 close.
 }
{
 assert (Cong G D G E) by (conclude cn_equalitysub).
 close.
 }
{
 assert (Cong B A B A) by (conclude cn_congruencereflexive).
 assert (Cong A G A G) by (conclude cn_congruencereflexive).
 assert (Cong A D A E) by (conclude lemma_congruencesymmetric).
 assert (Cong D G E G)
  by (pose proof (axiom_5_line B A G D B A G E); auto).
 assert (Cong G D G E) by (forward_using lemma_congruenceflip).
 close.
 }
{
 assert (Cong A B A B) by (conclude cn_congruencereflexive).
 assert (Cong B G B G) by (conclude cn_congruencereflexive).
 assert (Cong D G E G) by (pose proof (axiom_5_line A B G D A B G E); auto).
 assert (Cong G D G E) by (forward_using lemma_congruenceflip).
 close.
 }
{
 assert (Cong A G A G) by (conclude cn_congruencereflexive).
 assert (Cong G B G B) by (conclude cn_congruencereflexive).
 assert (Cong G D G E) by (conclude lemma_interior5).
 close.
 }
(** cases *)
assert (Cong D A E A) by (forward_using lemma_congruenceflip).
assert (eq F G).
by cases on (eq A G \/ neq A G).
{
 assert (BetS E G D) by (conclude axiom_betweennesssymmetry).
 assert (Cong E G D G) by (forward_using lemma_doublereverse).
 assert (Cong E B D B) by (forward_using lemma_doublereverse).
 assert (~ eq G B).
  {
  intro.
  assert (eq A B) by (conclude cn_equalitysub).
  contradict.
  }
 assert (Per E G B) by (conclude_def Per ).
 assert (BetS E F C) by (conclude axiom_betweennesssymmetry).
 assert (Cong E F C F) by (forward_using lemma_doublereverse).
 assert (Cong E B C B) by (forward_using lemma_doublereverse).
 assert (~ eq F B).
  {
  intro.
  assert (Cong A E A D) by (forward_using lemma_congruenceflip).
  assert (neq B A) by (conclude lemma_inequalitysymmetric).
  assert (BetS E A D) by (conclude cn_equalitysub).
  assert (Cong E A D A) by (forward_using lemma_congruenceflip).
  assert (Per E A B) by (conclude_def Per ).
  assert (Per B A E) by (conclude lemma_8_2).
  assert (BetS E B C) by (conclude cn_equalitysub).
  assert (Per E B A) by (conclude_def Per ).
  let Tf:=fresh in
  assert (Tf:exists J, (BetS B A J /\ Cong A J A B)) by (conclude lemma_extension);destruct Tf as [J];spliter.
  assert (Out B A J) by (conclude lemma_ray4).
  assert (Per E B J) by (conclude lemma_8_3).
  assert (Per J B E) by (conclude lemma_8_2).
  assert (Col A B J) by (conclude_def Col ).
  assert (Col B A J) by (forward_using lemma_collinearorder).
  assert (Per B A E) by (conclude lemma_8_2).
  assert (neq A J) by (forward_using lemma_betweennotequal).
  assert (neq J A) by (conclude lemma_inequalitysymmetric).
  assert (Per J A E) by (conclude lemma_collinearright).
  assert (Col J A B) by (forward_using lemma_collinearorder).
  assert (eq A B) by (conclude lemma_droppedperpendicularunique).
  contradict.
  }
 assert (Per E F B) by (conclude_def Per ).
 assert (Per B G E) by (conclude lemma_8_2).
 assert (Per B F E) by (conclude lemma_8_2).
 assert (Col B G F) by (conclude lemma_collinear4).
 assert (eq G F) by (conclude lemma_droppedperpendicularunique).
 assert (eq F G) by (conclude lemma_equalitysymmetric).
 close.
 }
{
 assert (eq F G).
 by cases on (eq A F \/ neq A F).
 {
  assert (neq F B) by (conclude cn_equalitysub).
  assert (Cong E F C F) by (forward_using lemma_congruenceflip).
  assert (Cong E B C B) by (forward_using lemma_doublereverse).
  assert (BetS E F C) by (conclude axiom_betweennesssymmetry).
  assert (Per E F B) by (conclude_def Per ).
  assert (Per B F E) by (conclude lemma_8_2).
  assert (~ eq B G).
   {
   intro.
   assert (eq F A) by (conclude lemma_equalitysymmetric).
   assert (Cong A E A C) by (forward_using lemma_congruenceflip).
   assert (Cong A C A D) by (forward_using lemma_congruenceflip).
   assert (Cong A E A D) by (conclude lemma_congruencetransitive).
   assert (Cong B E B D) by (conclude lemma_congruencesymmetric).
   assert (BetS E G D) by (conclude axiom_betweennesssymmetry).
   assert (BetS E B D) by (conclude cn_equalitysub).
   assert (Cong E B D B) by (forward_using lemma_congruenceflip).
   assert (Cong E A D A) by (conclude lemma_congruencesymmetric).
   assert (neq B A) by (conclude lemma_inequalitysymmetric).
   assert (Per E B A) by (conclude_def Per ).
   assert (Per A B E) by (conclude lemma_8_2).
   assert (BetS E A C) by (conclude cn_equalitysub).
   assert (Per E A B) by (conclude_def Per ).
   assert (Per B A E) by (conclude lemma_8_2).
   let Tf:=fresh in
   assert (Tf:exists K, (BetS A B K /\ Cong B K B A)) by (conclude lemma_extension);destruct Tf as [K];spliter.
   assert (Out A B K) by (conclude lemma_ray4).
   assert (Per E A K) by (conclude lemma_8_3).
   assert (Per K A E) by (conclude lemma_8_2).
   assert (Col B A K) by (conclude_def Col ).
   assert (Col A B K) by (forward_using lemma_collinearorder).
   assert (Per A B E) by (conclude lemma_8_2).
   assert (neq B K) by (forward_using lemma_betweennotequal).
   assert (neq K B) by (conclude lemma_inequalitysymmetric).
   assert (Per K B E) by (conclude lemma_collinearright).
   assert (Col A B K) by (conclude_def Col ).
   assert (Col K B A) by (forward_using lemma_collinearorder).
   assert (eq B A) by (conclude lemma_droppedperpendicularunique).
   assert (neq B A) by (conclude lemma_inequalitysymmetric).
   contradict.
   }
  assert (neq G B) by (conclude lemma_inequalitysymmetric).
  assert (Cong E G D G) by (forward_using lemma_doublereverse).
  assert (Cong E B D B) by (forward_using lemma_doublereverse).
  assert (BetS E G D) by (conclude axiom_betweennesssymmetry).
  assert (Per E G B) by (conclude_def Per ).
  assert (Per B G E) by (conclude lemma_8_2).
  assert (Col F B G) by (conclude cn_equalitysub).
  assert (Col B G F) by (forward_using lemma_collinearorder).
  assert (eq G F) by (conclude lemma_droppedperpendicularunique).
  assert (eq F G) by (conclude lemma_equalitysymmetric).
  close.
  }
 {
  assert (neq F A) by (conclude lemma_inequalitysymmetric).
  assert (Cong E F C F) by (forward_using lemma_doublereverse).
  assert (BetS E F C) by (conclude axiom_betweennesssymmetry).
  assert (Per E F A) by (conclude_def Per ).
  assert (Per A F E) by (conclude lemma_8_2).
  assert (BetS E G D) by (conclude axiom_betweennesssymmetry).
  assert (Cong E G D G) by (forward_using lemma_doublereverse).
  assert (Cong E A D A) by (conclude lemma_congruencesymmetric).
  assert (neq G A) by (conclude lemma_inequalitysymmetric).
  assert (Per E G A) by (conclude_def Per ).
  assert (Per A G E) by (conclude lemma_8_2).
  assert (Col B A F) by (forward_using lemma_collinearorder).
  assert (Col B A G) by (forward_using lemma_collinearorder).
  assert (neq B A) by (conclude lemma_inequalitysymmetric).
  assert (Col A F G) by (conclude lemma_collinear4).
  assert (eq F G) by (conclude lemma_droppedperpendicularunique).
  close.
  }
(** cases *)
 close.
 }
(** cases *)
assert (Cong A F A F) by (conclude cn_congruencereflexive).
assert (Cong B F B F) by (conclude cn_congruencereflexive).
assert (Cong A F A G) by (conclude cn_equalitysub).
assert (Cong B F B G) by (conclude cn_equalitysub).
assert (Cong A B A B) by (conclude cn_congruencereflexive).
assert (Col A F B) by (forward_using lemma_collinearorder).
assert (Cong F B F B) by (conclude cn_congruencereflexive).
assert (Cong F B G B) by (conclude cn_equalitysub).
assert (Cong A C A D) by (forward_using lemma_congruenceflip).
assert (Cong B C B D) by (forward_using lemma_congruenceflip).
assert (Cong A B A B) by (conclude cn_congruencereflexive).
assert (Cong F C G D) by (conclude lemma_fiveline).
assert (Cong F C F D) by (conclude cn_equalitysub).
assert (BetS E F C) by (conclude axiom_betweennesssymmetry).
assert (BetS E G D) by (conclude axiom_betweennesssymmetry).
assert (BetS E F D) by (conclude cn_equalitysub).
assert (Out F D C) by (conclude_def Out ).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (~ eq F D).
 {
 intro.
 assert (Col A B F) by (forward_using lemma_collinearorder).
 assert (Col A B D) by (conclude cn_equalitysub).
 contradict.
 }
assert (Out F D D) by (conclude lemma_ray4).
assert (eq C D) by (conclude lemma_layoffunique).
close.
Qed.

End Euclid.


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

Require Import List Arith Omega Wellfounded Relations.

Require Import base af hwf.

Set Implicit Arguments.

Local Notation "A ⊆ B" := (∀x y, A x y -> B x y).
Local Notation "R ↑ x" := (fun a b => R a b \/ R x a).
Local Notation "R ↓ x" := (fun a b => R a b /\ R b x).

Local Notation "A ∩ B" := (fun x y => A x y /\ B x y).
Local Notation "A ∪ B" := (fun x y => A x y \/ B x y).

Section af_hwf.

  Variable (X : Type).
  Implicit Type (R S : X -> X -> Prop).

  Let af_hwf R : af R -> hwf (fun x y => ~ R y x).
  Proof.
    induction 1 as [ R HR | R HR IHR ].
    * constructor 1; intros; auto.
    * constructor 2; intros x.
      generalize (IHR x); apply hwf_anti.
      tauto.
  Qed.

  Let hwf_af R : (forall x y, R x y \/ ~ R x y) -> hwf R -> af (fun x y => ~ R y x).
  Proof.
    intros H1 H2; revert H2 H1.
    induction 1 as [ R HR | R HR IHR ]; intros H1.
    * constructor 1; intros; auto.
    * constructor 2; intros x.
      eapply af_mono.
      2: apply (IHR x).
      + intros a b; simpl.
        generalize (H1 b a) (H1 a x); tauto.
      + intros a b.
        generalize (H1 a b) (H1 b x); tauto.
  Qed.

  Variables (R : X -> X -> Prop) (HR : forall x y, R x y \/ ~ R x y).

  Theorem af_hwf_eq : af R <-> hwf (fun x y => ~ R y x).
  Proof.
    split; auto.
    intros H.
    eapply af_mono.
    2: apply hwf_af with (2 := H).
    + intros a b; generalize (HR a b); tauto.
    + intros a b; generalize (HR b a); tauto.
  Qed.

  Theorem hwf_af_eq : hwf R <-> af (fun x y => ~ R y x).
  Proof.
    split; auto.
    intros H.
    eapply hwf_anti.
    2: apply af_hwf with (1 := H).
    intros a b; simpl; tauto.
  Qed.

End af_hwf.

Check af_hwf_eq.
Check hwf_af_eq.