Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Limits.Pullbacks.

Local Open Scope cat.

Section Functions.
  Context {B : bicat_with_pb}.

  Definition pb_obj
             {b₁ b₂ b₃ : B}
             (f : b₁ --> b₃)
             (g : b₂ --> b₃)
    : B
    := pr1 (pr2 B _ _ _ f g).

  Local Notation "f '/≃' g" := (pb_obj f g) (at level 40).

  Definition pb_pr1
             {b₁ b₂ b₃ : B}
             (f : b₁ --> b₃)
             (g : b₂ --> b₃)
    : f /≃ g --> b₁
    := pb_cone_pr1 (pr1 (pr2 B _ _ _ f g)).

  Local Notation "'π₁'" := (pb_pr1 _ _).

  Definition pb_pr2
             {b₁ b₂ b₃ : B}
             (f : b₁ --> b₃)
             (g : b₂ --> b₃)
    : f /≃ g --> b₂
    := pb_cone_pr2 (pr1 (pr2 B _ _ _ f g)).

  Local Notation "'π₂'" := (pb_pr2 _ _).

  Definition pb_cell
             {b₁ b₂ b₃ : B}
             (f : b₁ --> b₃)
             (g : b₂ --> b₃)
    : invertible_2cell (π₁ · f) (π₂ · g)
    := pb_cone_cell (pr1 (pr2 B _ _ _ f g)).

  Definition pb_obj_has_pb_ump
             {b₁ b₂ b₃ : B}
             (f : b₁ --> b₃)
             (g : b₂ --> b₃)
    : has_pb_ump (make_pb_cone (f /≃ g) π₁ π₂ (pb_cell f g))
    := pr2 (pr2 B _ _ _ f g).

  Definition mor_to_pb_obj
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             (h₁ : a --> b₁)
             (h₂ : a --> b₂)
             (γ : invertible_2cell (h₁ · f) (h₂ · g))
    : a --> f /≃ g.
  Proof.
    pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g).
    exact (pb_ump_mor (pr2 (pr2 B _ _ _ f g)) q).
  Defined.

  Local Notation "h₁ ⊗[ γ ] h₂" := (mor_to_pb_obj h₁ h₂ γ) (at level 10).

  Definition mor_to_pb_obj_pr1
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             (h₁ : a --> b₁)
             (h₂ : a --> b₂)
             (γ : invertible_2cell (h₁ · f) (h₂ · g))
    : invertible_2cell (h₁ ⊗[ γ ] h₂ · π₁) h₁.
  Proof.
    pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g).
    exact (pb_ump_mor_pr1 (pr2 (pr2 B _ _ _ f g)) q).
  Defined.

  Definition mor_to_pb_obj_pr2
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             (h₁ : a --> b₁)
             (h₂ : a --> b₂)
             (γ : invertible_2cell (h₁ · f) (h₂ · g))
    : invertible_2cell (h₁ ⊗[ γ ] h₂ · π₂) h₂.
  Proof.
    pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g).
    exact (pb_ump_mor_pr2 (pr2 (pr2 B _ _ _ f g)) q).
  Defined.

  Definition mor_to_pb_obj_cell
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             (h₁ : a --> b₁)
             (h₂ : a --> b₂)
             (γ : invertible_2cell (h₁ · f) (h₂ · g))
    : (h₁ ⊗[ γ ] h₂) ◃ pb_cell f g
      =
      lassociator _ _ _
                  • (mor_to_pb_obj_pr1 h₁ h₂ γ ▹ f)
                  • γ
                  • ((mor_to_pb_obj_pr2 h₁ h₂ γ)^-1 ▹ g)
                  • rassociator _ _ _.
  Proof.
    pose (q := make_pb_cone a h₁ h₂ γ : pb_cone f g).
    exact (pb_ump_mor_cell (pr2 (pr2 B _ _ _ f g)) q).
  Defined.

  Definition cell_to_pb_obj_homot
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             {h₁ h₂ : a --> f /≃ g}
             (α : h₁ · π₁ ==> h₂ · π₁)
             (β : h₁ · π₂ ==> h₂ · π₂)
    : UU
    := (h₁ ◃ pb_cell f g)
         • lassociator _ _ _
         • (β ▹ g)
         • rassociator _ _ _
       =
       lassociator _ _ _
                   • (α ▹ f)
                   • rassociator _ _ _
                   • (h₂ ◃ pb_cell f g).

  Definition cell_to_pb_obj
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             {h₁ h₂ : a --> f /≃ g}
             (α : h₁ · π₁ ==> h₂ · π₁)
             (β : h₁ · π₂ ==> h₂ · π₂)
             (p : cell_to_pb_obj_homot α β)
    : h₁ ==> h₂
    := pb_ump_cell
         (pr2 (pr2 B _ _ _ f g))
         h₁ h₂
         α β
         p.

  Definition cell_to_pb_obj_pr1
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             {h₁ h₂ : a --> f /≃ g}
             (α : h₁ · π₁ ==> h₂ · π₁)
             (β : h₁ · π₂ ==> h₂ · π₂)
             (p : cell_to_pb_obj_homot α β)
    : cell_to_pb_obj α β p ▹ π₁ = α.
  Proof.
    exact (pb_ump_cell_pr1
             (pr2 (pr2 B _ _ _ f g))
             h₁ h₂
             α β
             p).
  Qed.

  Definition cell_to_pb_obj_pr2
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             {h₁ h₂ : a --> f /≃ g}
             (α : h₁ · π₁ ==> h₂ · π₁)
             (β : h₁ · π₂ ==> h₂ · π₂)
             (p : cell_to_pb_obj_homot α β)
    : cell_to_pb_obj α β p ▹ π₂ = β.
  Proof.
    exact (pb_ump_cell_pr2
             (pr2 (pr2 B _ _ _ f g))
             h₁ h₂
             α β
             p).
  Qed.

  Definition eq_to_pb_obj
             {a b₁ b₂ b₃ : B}
             {f : b₁ --> b₃}
             {g : b₂ --> b₃}
             {h₁ h₂ : a --> f /≃ g}
             {φ ψ : h₁ ==> h₂}
             {p : cell_to_pb_obj_homot (φ ▹ π₁) (φ ▹ π₂)}
             (φψpr1 : φ ▹ π₁ = ψ ▹ π₁)
             (φψpr2 : φ ▹ π₂ = ψ ▹ π₂)
    : φ = ψ
    := pb_ump_eq
         (pr2 (pr2 B _ _ _ f g))
         h₁ h₂
         (φ ▹ π₁) (φ ▹ π₂)
         p
         φ ψ
         (idpath _) (idpath _)
         (!φψpr1) (!φψpr2).

  Definition help_pb_on_1cell
             {b₁ b₂ c₂ b₃ : B}
             (f : b₁ --> b₃)
             {g₁ : b₂ --> b₃}
             {g₂ : c₂ --> b₃}
             {h : b₂ --> c₂}
             (β : invertible_2cell g₁ (h · g₂))
    : invertible_2cell (π₁ · f) (π₂ · h · g₂)
    := comp_of_invertible_2cell
         (pb_cell f g₁)
         (comp_of_invertible_2cell
            (lwhisker_of_invertible_2cell
               _
               β)
            (lassociator_invertible_2cell _ _ _)).

  Definition pb_on_1cell
             {b₁ b₂ c₂ b₃ : B}
             (f : b₁ --> b₃)
             {g₁ : b₂ --> b₃}
             {g₂ : c₂ --> b₃}
             {h : b₂ --> c₂}
             (β : invertible_2cell g₁ (h · g₂))
    : f /≃ g₁ --> f /≃ g₂.
  Proof.
    simple refine (_ ⊗[ _ ] _).
    - exact π₁.
    - exact (π₂ · h).
    - exact (help_pb_on_1cell f β).
  Defined.

  Local Notation "f /≃₁ β" := (pb_on_1cell f β) (at level 40).

  Definition pb_on_1cell_pr1
             {b₁ b₂ c₂ b₃ : B}
             (f : b₁ --> b₃)
             {g₁ : b₂ --> b₃}
             {g₂ : c₂ --> b₃}
             {h : b₂ --> c₂}
             (β : invertible_2cell g₁ (h · g₂))
    : invertible_2cell (f /≃₁ β · π₁) π₁.
  Proof.
    apply mor_to_pb_obj_pr1.
  Defined.

  Definition pb_on_1cell_pr2
             {b₁ b₂ c₂ b₃ : B}
             (f : b₁ --> b₃)
             {g₁ : b₂ --> b₃}
             {g₂ : c₂ --> b₃}
             {h : b₂ --> c₂}
             (β : invertible_2cell g₁ (h · g₂))
    : invertible_2cell (f /≃₁ β · π₂) (π₂ · h).
  Proof.
    apply mor_to_pb_obj_pr2.
  Defined.

  Definition pb_on_1cell_cell
             {b₁ b₂ c₂ b₃ : B}
             (f : b₁ --> b₃)
             {g₁ : b₂ --> b₃}
             {g₂ : c₂ --> b₃}
             {h : b₂ --> c₂}
             (β : invertible_2cell g₁ (h · g₂))
    : f /≃₁ β ◃ pb_cell f g₂
      =
      lassociator _ _ _
      • (pb_on_1cell_pr1 f β ▹ f)
      • pb_cell f g₁
      • (π₂ ◃ β)
      • lassociator _ _ _
      • ((pb_on_1cell_pr2 f β)^-1 ▹ g₂)
      • rassociator _ _ _.
  Proof.
    pose (mor_to_pb_obj_cell
            π₁ (π₂ · h)
            (comp_of_invertible_2cell
               (pb_cell f g₁)
               (comp_of_invertible_2cell
                  (lwhisker_of_invertible_2cell
                     _
                     β)
                  (lassociator_invertible_2cell _ _ _)))).
    cbn in p.
    refine (p @ _).
    rewrite !vassocl.
    apply idpath.
  Qed.

  Section PBOn2Cell.
    Context {b₁ b₂ c₂ b₃ : B}
            (f : b₁ --> b₃)
            {g₁ : b₂ --> b₃}
            {g₂ : c₂ --> b₃}
            {h₁ h₂ : b₂ --> c₂}
            {β₁ : invertible_2cell g₁ (h₁ · g₂)}
            {β₂ : invertible_2cell g₁ (h₂ · g₂)}
            {α : h₁ ==> h₂}
            (p : β₁ • (α ▹ g₂) = β₂).

    Let k₁ : f /≃₁ β₁ · π₁ ==> f /≃₁ β₂ · π₁
      := pb_on_1cell_pr1 _ _ • (pb_on_1cell_pr1 _ _)^-1.

    Let k₂ : f /≃₁ β₁ · π₂ ==> f /≃₁ β₂ · π₂
      := pb_on_1cell_pr2 _ _ • (π₂ ◃ α) • (pb_on_1cell_pr2 _ _)^-1.

    Lemma pb_on_2cell_homot
      : cell_to_pb_obj_homot k₁ k₂.
    Proof.
      unfold cell_to_pb_obj_homot, k₁, k₂.
      rewrite pb_on_1cell_cell.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      do 2 apply maponpaths.
      etrans.
      {
        do 3 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rassociator_lassociator.
          rewrite id2_left.
          rewrite !vassocl.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocl.
      rewrite pb_on_1cell_cell.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- rwhisker_lwhisker.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite lwhisker_vcomp.
      apply maponpaths.
      exact (!p).
    Qed.

    Definition pb_on_2cell
      : f /≃₁ β₁ ==> f /≃₁ β₂.
    Proof.
      use cell_to_pb_obj.
      - exact k₁.
      - exact k₂.
      - exact pb_on_2cell_homot.
    Defined.

    Definition pb_on_2cell_pr1
      : pb_on_2cell ▹ π₁ = k₁.
    Proof.
      apply cell_to_pb_obj_pr1.
    Qed.

    Definition pb_on_2cell_pr2
      : pb_on_2cell ▹ π₂ = k₂.
    Proof.
      apply cell_to_pb_obj_pr2.
    Qed.
  End PBOn2Cell.

  Local Notation "f /≃₂ p" := (pb_on_2cell f p) (at level 40).

  Section PBOnId.
    Context {a b₁ b₂ : B}
            (f : b₁ --> b₂)
            (g : a --> b₂).

    Let k₁ : id₁ (f /≃ g) · π₁ ==> f /≃₁ linvunitor_invertible_2cell g · π₁
      := lunitor _ • (pb_on_1cell_pr1 _ _)^-1.

    Let k₂ : id₁ (f /≃ g) · π₂ ==> f /≃₁ linvunitor_invertible_2cell g · π₂
      := lunitor _ • rinvunitor _ • (pb_on_1cell_pr2 _ _)^-1.

    Lemma pb_1cell_on_id_homot
      : cell_to_pb_obj_homot k₁ k₂.
    Proof.
      unfold cell_to_pb_obj_homot, k₁, k₂.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      pose (pb_on_1cell_cell f (linvunitor_invertible_2cell g)) as p.
      cbn in p.
      rewrite p.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite lunitor_triangle.
      rewrite <- vcomp_lunitor.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- lunitor_triangle.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite lwhisker_hcomp.
      rewrite triangle_l_inv.
      rewrite <- rwhisker_hcomp.
      apply idpath.
    Qed.

    Definition pb_1cell_on_id
      : id₁ (f /≃ g) ==> f /≃₁ linvunitor_invertible_2cell g.
    Proof.
      use cell_to_pb_obj.
      - exact k₁.
      - exact k₂.
      - exact pb_1cell_on_id_homot.
    Defined.

    Definition pb_1cell_on_id_pr1
      : pb_1cell_on_id ▹ π₁ = k₁.
    Proof.
      apply cell_to_pb_obj_pr1.
    Qed.

    Definition pb_1cell_on_id_pr2
      : pb_1cell_on_id ▹ π₂ = k₂.
    Proof.
      apply cell_to_pb_obj_pr2.
    Qed.
  End PBOnId.

  Section PBOnComp.
    Context {a₁ a₂ a₃ b₁ b₂ : B}
            (f : b₁ --> b₂)
            {g₁ : a₁ --> b₂}
            {g₂ : a₂ --> b₂}
            {g₃ : a₃ --> b₂}
            {h₁ : a₁ --> a₂}
            {h₂ : a₂ --> a₃}
            (α : invertible_2cell g₁ (h₁ · g₂))
            (β : invertible_2cell g₂ (h₂ · g₃)).

    Let γ : invertible_2cell g₁ (h₁ · h₂ · g₃)
      := comp_of_invertible_2cell
           α
           (comp_of_invertible_2cell
              (lwhisker_of_invertible_2cell _ β)
              (lassociator_invertible_2cell _ _ _)).

    Let k₁ : f /≃₁ α · (f /≃₁ β) · π₁ ==> f /≃₁ γ · π₁
      := rassociator _ _ _
                     • (_ ◃ pb_on_1cell_pr1 _ _)
                     • pb_on_1cell_pr1 _ _
                     • (pb_on_1cell_pr1 _ _)^-1.
    Let k₂ : f /≃₁ α · (f /≃₁ β) · π₂ ==> f /≃₁ γ · π₂
      := rassociator _ _ _
                     • (_ ◃ pb_on_1cell_pr2 _ _)
                     • lassociator _ _ _
                     • (pb_on_1cell_pr2 _ _ ▹ _)
                     • rassociator _ _ _
                     • (pb_on_1cell_pr2 _ _)^-1.

    Lemma pb_1cell_on_comp_homot
      : cell_to_pb_obj_homot k₁ k₂.
    Proof.
      unfold cell_to_pb_obj_homot, k₁, k₂.
      rewrite <- !rwhisker_vcomp.
      rewrite (pb_on_1cell_cell f γ).
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite !vassocr.
      rewrite <- lwhisker_lwhisker.
      rewrite <- lassociator_lassociator.
      rewrite (pb_on_1cell_cell f β).
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        do 6 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        do 4 apply maponpaths_2.
        rewrite !vassocl.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        rewrite id2_right.
        apply idpath.
      }
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite rassociator_lassociator.
        rewrite lwhisker_id2.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        rewrite id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_lassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      cbn.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      do 2 (use vcomp_move_R_Mp ; [ is_iso | ] ; cbn).
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 4 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rassociator_rassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite <- vcomp_whisker.
        rewrite !vassocl.
        rewrite <- lwhisker_lwhisker_rassociator.
        apply idpath.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite (pb_on_1cell_cell f α).
      rewrite !vassocl.
      do 3 apply maponpaths.
      refine (_ @ id2_right _).
      apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      apply lassociator_rassociator.
    Qed.

    Definition pb_1cell_on_comp
      : f /≃₁ α · (f /≃₁ β) ==> f /≃₁ γ.
    Proof.
      use cell_to_pb_obj.
      - exact k₁.
      - exact k₂.
      - exact pb_1cell_on_comp_homot.
    Defined.

    Definition pb_1cell_on_comp_pr1
      : pb_1cell_on_comp ▹ π₁ = k₁.
    Proof.
      apply cell_to_pb_obj_pr1.
    Qed.

    Definition pb_1cell_on_comp_pr2
      : pb_1cell_on_comp ▹ π₂ = k₂.
    Proof.
      apply cell_to_pb_obj_pr2.
    Qed.
  End PBOnComp.

  Definition pb_2cell_on_id
             {a₁ a₂ b₁ b₂ : B}
             {f : b₁ --> b₂}
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {h : a₁ --> a₂}
             (α : invertible_2cell g₁ (h · g₂))
             (p : α • (id₂ h ▹ g₂) = α)
    : f /≃₂ p = id₂ _.
  Proof.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite vcomp_whisker.
      apply maponpaths.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    - rewrite pb_on_2cell_pr1, id2_rwhisker.
      apply vcomp_rinv.
    - rewrite pb_on_2cell_pr2, id2_rwhisker, lwhisker_id2.
      rewrite id2_right.
      apply vcomp_rinv.
  Qed.

  Definition pb_on_2cell_coh
             {a₁ a₂ b₁ b₂ : B}
             {f : b₁ --> b₂}
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {h₁ h₂ : a₁ --> a₂}
             (α : invertible_2cell g₁ (h₁ · g₂))
             (β : invertible_2cell g₁ (h₂ · g₂))
             (γ : h₁ ==> h₂)
             (p : α • (γ ▹ _) = β)
    : (pb_on_1cell_pr1 f α)^-1 • (f /≃₂ p ▹ π₁)
      =
      (pb_on_1cell_pr1 f β)^-1.
  Proof.
    cbn.
    rewrite pb_on_2cell_pr1.
    rewrite !vassocr.
    rewrite vcomp_linv.
    rewrite id2_left.
    apply idpath.
  Qed.

  Definition pb_1cell_on_id_coh
             {a b₁ b₂ : B}
             (f : b₁ --> b₂)
             (g : a --> b₂)
    : linvunitor π₁ • (pb_1cell_on_id f g ▹ π₁)
      =
      (pb_on_1cell_pr1 f (linvunitor_invertible_2cell g))^-1.
  Proof.
    cbn.
    rewrite pb_1cell_on_id_pr1.
    rewrite !vassocr.
    rewrite linvunitor_lunitor.
    rewrite id2_left.
    apply idpath.
  Qed.

  Definition pb_1cell_on_comp_coh
             {a₁ a₂ a₃ b₁ b₂ : B}
             (f : b₁ --> b₂)
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {g₃ : a₃ --> b₂}
             {h₁ : a₁ --> a₂}
             {h₂ : a₂ --> a₃}
             (α : invertible_2cell g₁ (h₁ · g₂))
             (β : invertible_2cell g₂ (h₂ · g₃))
    : (pb_on_1cell_pr1 f α)^-1
                           • ((f /≃₁ α ◃ (pb_on_1cell_pr1 f β)^-1)
                                • lassociator (f /≃₁ α) (f /≃₁ β) π₁)
                           • (pb_1cell_on_comp f α β ▹ π₁)
      =
      (pb_on_1cell_pr1
         f
         (comp_of_invertible_2cell
            α
            (comp_of_invertible_2cell
               (lwhisker_of_invertible_2cell h₁ β)
               (lassociator_invertible_2cell _ _ _)))) ^-1.
  Proof.
    rewrite pb_1cell_on_comp_pr1.
    rewrite !vassocl.
    etrans.
    {
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      rewrite !vassocl.
      apply idpath.
    }
    etrans.
    {
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite lwhisker_id2.
      rewrite id2_left.
      apply idpath.
    }
    rewrite !vassocr.
    rewrite vcomp_linv.
    apply id2_left.
  Qed.

  Definition pb_2cell_on_comp
             {a₁ a₂ b₁ b₂ : B}
             (f : b₁ --> b₂)
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {h₁ h₂ h₃ : a₁ --> a₂}
             {α : invertible_2cell g₁ (h₁ · g₂)}
             {β : invertible_2cell g₁ (h₂ · g₂)}
             {γ : invertible_2cell g₁ (h₃ · g₂)}
             (δ₁ : h₁ ==> h₂)
             (p : α • (δ₁ ▹ g₂) = β)
             (δ₂ : h₂ ==> h₃)
             (q : β • (δ₂ ▹ g₂) = γ)
             (r : α • ((δ₁ • δ₂) ▹ g₂) = γ)
    : f /≃₂ r = f /≃₂ p • f /≃₂ q.
  Proof.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite lassociator_rassociator.
      rewrite id2_right.
      rewrite <- vcomp_whisker.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    - rewrite <- rwhisker_vcomp.
      rewrite !pb_on_2cell_pr1.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_linv.
      rewrite id2_left.
      apply idpath.
    - rewrite <- rwhisker_vcomp.
      rewrite !pb_on_2cell_pr2.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      do 2 apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_linv.
      rewrite id2_left.
      apply idpath.
  Qed.

  Definition pb_2cell_on_lunitor
             {a₁ a₂ b₁ b₂ : B}
             (f : b₁ --> b₂)
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {h : a₁ --> a₂}
             (α : invertible_2cell g₁ (h · g₂))
             (p : comp_of_invertible_2cell
                    (linvunitor_invertible_2cell g₁)
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell (id₁ a₁) α)
                       (lassociator_invertible_2cell (id₁ a₁) h g₂))
                    • (lunitor h ▹ g₂)
                  = α)
    : lunitor (f /≃₁ α)
      =
      (pb_1cell_on_id f g₁ ▹ f /≃₁ α)
        • pb_1cell_on_comp f (linvunitor_invertible_2cell g₁) α
        • f /≃₂ p.
  Proof.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite vcomp_whisker.
      apply maponpaths.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      rewrite pb_on_2cell_pr1, pb_1cell_on_comp_pr1.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
      rewrite !vassocl.
      rewrite vcomp_linv.
      rewrite id2_right.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite pb_1cell_on_id_pr1.
      rewrite !vassocl.
      rewrite vcomp_linv.
      rewrite id2_right.
      rewrite vcomp_lunitor.
      rewrite !vassocr.
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      rewrite id2_left.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      rewrite pb_on_2cell_pr2, pb_1cell_on_comp_pr2.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      do 2 (use vcomp_move_L_Mp ; [ is_iso | ] ; cbn).
      rewrite !vassocl.
      rewrite vcomp_linv.
      rewrite id2_right.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite pb_1cell_on_id_pr2.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      rewrite !vassocr.
      use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
      rewrite !vassocl.
      rewrite lunitor_lwhisker.
      rewrite rwhisker_vcomp.
      rewrite rinvunitor_runitor.
      rewrite id2_rwhisker.
      rewrite id2_right.
      rewrite lunitor_triangle.
      rewrite vcomp_lunitor.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- lunitor_triangle.
      rewrite !vassocr.
      rewrite rassociator_lassociator.
      apply id2_left.
  Qed.

  Definition pb_2cell_on_runitor
             {a₁ a₂ b₁ b₂ : B}
             (f : b₁ --> b₂)
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {h : a₁ --> a₂}
             (α : invertible_2cell g₁ (h · g₂))
             (p : comp_of_invertible_2cell
                    α
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell
                          h
                          (linvunitor_invertible_2cell g₂))
                       (lassociator_invertible_2cell h (id₁ a₂) g₂))
                    • (runitor h ▹ g₂)
                  = α)
    : runitor (f /≃₁ α)
      =
      (f /≃₁ α ◃ pb_1cell_on_id f g₂)
        • pb_1cell_on_comp f α (linvunitor_invertible_2cell g₂)
        • f /≃₂ p.
  Proof.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite vcomp_whisker.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      rewrite !vassocl.
      apply maponpaths.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocr.
      rewrite lassociator_rassociator.
      rewrite id2_left.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite pb_on_2cell_pr1, pb_1cell_on_comp_pr1.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        apply id2_left.
      }
      rewrite vcomp_rinv.
      rewrite id2_right.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      rewrite pb_1cell_on_id_pr1.
      rewrite lwhisker_vcomp.
      rewrite !vassocl.
      rewrite vcomp_linv.
      rewrite id2_right.
      rewrite lunitor_lwhisker.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite pb_on_2cell_pr2, pb_1cell_on_comp_pr2.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        do 6 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite runitor_triangle.
        rewrite <- vcomp_runitor.
        apply idpath.
      }
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite vcomp_rinv.
        rewrite id2_rwhisker.
        apply id2_left.
      }
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite pb_1cell_on_id_pr2.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      }
      rewrite <- runitor_triangle.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite lwhisker_vcomp.
      rewrite !vassocl.
      rewrite rinvunitor_runitor.
      rewrite id2_right.
      rewrite lunitor_lwhisker.
      apply idpath.
  Qed.

  Definition pb_2cell_on_lassociator
             {a₁ a₂ a₃ a₄ b₁ b₂ : B}
             (f : b₁ --> b₂)
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {g₃ : a₃ --> b₂}
             {g₄ : a₄ --> b₂}
             {h₁ : a₁ --> a₂}
             {h₂ : a₂ --> a₃}
             {h₃ : a₃ --> a₄}
             (α : invertible_2cell g₁ (h₁ · g₂))
             (β : invertible_2cell g₂ (h₂ · g₃))
             (γ : invertible_2cell g₃ (h₃ · g₄))
             (p : comp_of_invertible_2cell
                    α
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell
                          h₁
                          (comp_of_invertible_2cell
                             β
                             (comp_of_invertible_2cell
                                (lwhisker_of_invertible_2cell h₂ γ)
                                (lassociator_invertible_2cell h₂ h₃ g₄))))
                       (lassociator_invertible_2cell h₁ (h₂ · h₃) g₄))
                    • (lassociator h₁ h₂ h₃ ▹ g₄)
                  =
                  comp_of_invertible_2cell
                    (comp_of_invertible_2cell
                       α
                       (comp_of_invertible_2cell
                          (lwhisker_of_invertible_2cell h₁ β)
                          (lassociator_invertible_2cell h₁ h₂ g₃)))
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell (h₁ · h₂) γ)
                       (lassociator_invertible_2cell (h₁ · h₂) h₃ g₄)))
    : (f /≃₁ α ◃ pb_1cell_on_comp f β γ)
        • pb_1cell_on_comp f α _
        • f /≃₂ p
      =
      lassociator _ _ _
                  • (pb_1cell_on_comp f α β ▹ _)
                  • pb_1cell_on_comp f _ γ.
  Proof.
    cbn in p.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        rewrite lassociator_rassociator.
        apply id2_right.
      }
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      etrans.
      {
        rewrite !pb_1cell_on_comp_pr1, !pb_on_2cell_pr1.
        rewrite !vassocl.
        etrans.
        {
          do 4 apply maponpaths.
          rewrite !vassocr.
          rewrite vcomp_linv.
          apply id2_left.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite pb_1cell_on_comp_pr1.
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_vcomp.
          rewrite !vassocl.
          rewrite vcomp_linv.
          rewrite id2_right.
          apply idpath.
        }
        apply idpath.
      }
      rewrite pb_1cell_on_comp_pr1.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker_alt.
        apply idpath.
      }
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite pb_1cell_on_comp_pr1.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      rewrite <- lwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      rewrite rassociator_rassociator.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite pb_on_2cell_pr2, !pb_1cell_on_comp_pr2.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 6 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        apply id2_left.
      }
      etrans.
      {
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        rewrite pb_1cell_on_comp_pr2.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite pb_1cell_on_comp_pr2.
        rewrite !vassocr.
        rewrite !rwhisker_vcomp.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      }
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      do 2 (use vcomp_move_L_pM ; [ is_iso | ] ; cbn).
      rewrite !vassocr.
      rewrite lassociator_lassociator.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        rewrite !vassocl.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      apply maponpaths.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      rewrite lassociator_lassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite !vassocr.
      rewrite <- rassociator_rassociator.
      rewrite !vassocl.
      rewrite lwhisker_vcomp.
      rewrite rassociator_lassociator.
      rewrite lwhisker_id2.
      rewrite id2_right.
      apply idpath.
  Qed.

  Definition pb_2cell_on_lwhisker
             {a₁ a₂ a₃ b₁ b₂ : B}
             (f : b₁ --> b₂)
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {g₃ : a₃ --> b₂}
             {h₁ : a₁ --> a₂}
             {h₂ h₃ : a₂ --> a₃}
             (α : invertible_2cell g₁ (h₁ · g₂))
             {β₁ : invertible_2cell g₂ (h₂ · g₃)}
             {β₂ : invertible_2cell g₂ (h₃ · g₃)}
             {γ : h₂ ==> h₃}
             (p : β₁ • (γ ▹ g₃) = β₂)
             (q : comp_of_invertible_2cell
                    α
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell h₁ β₁)
                       (lassociator_invertible_2cell h₁ h₂ g₃))
                    •
                    ((h₁ ◃ γ) ▹ g₃)
                  =
                  comp_of_invertible_2cell
                    α
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell h₁ β₂)
                       (lassociator_invertible_2cell h₁ h₃ g₃)))
    : pb_1cell_on_comp f α β₁ • f /≃₂ q
      =
      (f /≃₁ α ◃ f /≃₂ p) • pb_1cell_on_comp f α β₂.
  Proof.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        rewrite lassociator_rassociator.
        apply id2_right.
      }
      rewrite !vassocr.
      rewrite rwhisker_rwhisker.
      rewrite !vassocl.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      rewrite vcomp_whisker.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite pb_on_2cell_pr1, !pb_1cell_on_comp_pr1.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite pb_on_2cell_pr1.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite lwhisker_vcomp.
      rewrite vcomp_linv.
      rewrite lwhisker_id2.
      rewrite id2_left.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_linv.
      apply id2_left.
    - rewrite <- !rwhisker_vcomp.
      rewrite pb_on_2cell_pr2, !pb_1cell_on_comp_pr2.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite pb_on_2cell_pr2.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite !lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite <- lwhisker_lwhisker_rassociator.
      apply maponpaths.
      rewrite !vassocr.
      rewrite vcomp_linv.
      rewrite id2_left.
      apply idpath.
  Qed.

  Definition pb_2cell_on_rwhisker
             {a₁ a₂ a₃ b₁ b₂ : B}
             (f : b₁ --> b₂)
             {g₁ : a₁ --> b₂}
             {g₂ : a₂ --> b₂}
             {g₃ : a₃ --> b₂}
             {h₁ h₂ : a₁ --> a₂}
             {h₃ : a₂ --> a₃}
             {α₁ : invertible_2cell g₁ (h₁ · g₂)}
             {α₂ : invertible_2cell g₁ (h₂ · g₂)}
             (β : invertible_2cell g₂ (h₃ · g₃))
             {γ : h₁ ==> h₂}
             (p : α₁ • (γ ▹ g₂) = α₂)
             (q : comp_of_invertible_2cell
                    α₁
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell h₁ β)
                       (lassociator_invertible_2cell h₁ h₃ g₃))
                    • ((γ ▹ h₃) ▹ g₃)
                  =
                  comp_of_invertible_2cell
                    α₂
                    (comp_of_invertible_2cell
                       (lwhisker_of_invertible_2cell h₂ β)
                       (lassociator_invertible_2cell h₂ h₃ g₃)))
    : pb_1cell_on_comp f α₁ β • f /≃₂ q
      =
      (f /≃₂ p ▹ f /≃₁ β) • pb_1cell_on_comp f α₂ β.
  Proof.
    use eq_to_pb_obj.
    - unfold cell_to_pb_obj_homot.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        apply id2_left.
      }
      refine (!_).
      etrans.
      {
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        rewrite lassociator_rassociator.
        apply id2_right.
      }
      rewrite vcomp_whisker.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite pb_on_2cell_pr1, !pb_1cell_on_comp_pr1.
      rewrite !vassocr.
      rewrite rwhisker_rwhisker_alt.
      apply maponpaths_2.
      rewrite !vassocl.
      apply maponpaths.
      rewrite vcomp_linv.
      rewrite id2_right.
      rewrite !vassocr.
      rewrite vcomp_whisker.
      rewrite pb_on_2cell_pr1.
      rewrite !vassocl.
      apply maponpaths.
      rewrite vcomp_linv.
      rewrite id2_right.
      apply idpath.
    - rewrite <- !rwhisker_vcomp.
      rewrite pb_on_2cell_pr2, !pb_1cell_on_comp_pr2.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite rwhisker_rwhisker_alt.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        apply id2_left.
      }
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      rewrite <- rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !rwhisker_vcomp.
      apply maponpaths.
      rewrite pb_on_2cell_pr2.
      rewrite !vassocl.
      rewrite vcomp_linv.
      rewrite id2_right.
      apply idpath.
  Qed.
End Functions.

Module Notations.
  Notation "f '/≃' g" := (pb_obj f g) (at level 40).
  Notation "'π₁'" := (pb_pr1 _ _).
  Notation "'π₂'" := (pb_pr2 _ _).
  Notation "h₁ ⊗[ γ ] h₂" := (mor_to_pb_obj h₁ h₂ γ) (at level 10).
  Notation "f /≃₁ β" := (pb_on_1cell f β) (at level 40).
  Notation "f /≃₂ p" := (pb_on_2cell f p) (at level 40).
End Notations.


Require Import Bool Arith.

Require Import List.
Import ListNotations.

Parameter V : Type.
Parameter dec : V -> V -> bool.
Parameter dec_spec :
  forall x y : V, reflect (x = y) (dec x y).

Notation "x =? y" := (dec x y) (at level 70).

Inductive Formula : Type :=
    | Var : V -> Formula
    | FFalse : Formula
    | Impl : Formula -> Formula -> Formula
    | Or : Formula -> Formula -> Formula
    | And : Formula -> Formula -> Formula.

Definition Not (P : Formula) : Formula := Impl P FFalse.
Definition Iff (P Q : Formula) : Formula :=
  And (Impl P Q) (Impl Q P).
Definition FTrue : Formula := Impl FFalse FFalse.

Definition Context : Type := list Formula.

Inductive Proves : Context -> Formula -> Prop :=
    | Ax :
        forall (C : Context) (P : Formula),
          Proves (P :: C) P
    | FFalseE :
        forall (C : Context) (P : Formula),
          Proves C FFalse -> Proves C P
    | ImplI :
        forall (C : Context) (P Q : Formula),
          Proves (P :: C) Q -> Proves C (Impl P Q)
    | ImplE :
        forall (C : Context) (P Q : Formula),
          Proves C (Impl P Q) -> Proves C P -> Proves C Q
    | AndI :
        forall (C : Context) (P Q : Formula),
          Proves C P -> Proves C Q -> Proves C (And P Q)
    | AndEL :
        forall (C : Context) (P Q : Formula),
          Proves C (And P Q) -> Proves C P
    | AndER :
        forall (C : Context) (P Q : Formula),
          Proves C (And P Q) -> Proves C Q
    | OrIL :
        forall (C : Context) (P Q : Formula),
          Proves C P -> Proves C (Or P Q)
    | OrIR :
        forall (C : Context) (P Q : Formula),
          Proves C Q -> Proves C (Or P Q)
    | OrE :
        forall (C : Context) (P Q R : Formula),
          Proves (P :: C) R -> Proves (Q :: C) R -> Proves C (Or P Q) ->
            Proves C R.

#[global] Hint Constructors Proves : core.

Lemma weakening :
  forall (C : Context) (F : Formula),
    Proves C F -> forall R : Formula, Proves (R :: C) F.
Proof.
  induction 1; intros; auto.
    admit.
Admitted.

Fixpoint subst (F : Formula) (x : V) (P : Formula) : Formula :=
match F with
    | Var y => if x =? y then P else Var y
    | FFalse => FFalse
    | Impl F1 F2 => Impl (subst F1 x P) (subst F2 x P)
    | Or F1 F2 => Or (subst F1 x P) (subst F2 x P)
    | And F1 F2 => And (subst F1 x P) (subst F2 x P)
end.

Fixpoint csubst (C : Context) (x : V) (P : Formula) : Context :=
match C with
    | [] => []
    | F :: C' => subst F x P :: csubst C' x P
end.

(*
Lemma Proves_subst :
  forall (C : Context) (F : Formula),
    Proves C F -> forall (R : Formula) (x : V),
      Proves (csubst C x R) (subst F x R).
Proof.
  induction 1; cbn; intros; eauto.
Qed.
*)

Lemma ImplI' :
  forall (C : Context) (P Q : Formula),
    (In P C -> Proves C Q) -> Proves C (Impl P Q).
Proof.
  intros C P Q H. apply ImplI.
Abort.

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

(* Definitely too hard. *)
Lemma consistent :
  forall C : Context,
    ~ Proves C FFalse.
Proof.
Abort.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e384m79x2e376m1_12limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import
  HoTT.Classes.interfaces.abstract_algebra.

Generalizable Variables A B.

Global Instance Empty_lt : Lt@{Set Set} Empty.
Proof. intros []. Defined.

Global Instance Unit_lt : Lt@{Set Set} Unit := fun _ _ => Empty.

Global Instance empty_tricho : Trichotomy@{Set Set Set} (_:Lt Empty).
Proof.
intros [].
Qed.

Global Instance unit_tricho : Trichotomy@{Set Set Set} (_:Lt Unit).
Proof.
intros [] [];auto.
Defined.

Section contents.

Context `{Alt : Lt@{Set Set} A} `{Blt : Lt@{Set Set} B}.

Global Instance sum_lt : Lt@{Set Set} (A |_| B) | 2
  := fun s1 s2 =>
  match s1, s2 with
  | inl a1, inl a2 => a1 < a2
  | inr b1, inr b2 => b1 < b2
  | inl _, inr _ => Unit
  | inr _, inl _ => Empty
  end.

Global Instance sum_tricho `{!Trichotomy@{Set Set Set} Alt} `{!Trichotomy@{Set Set Set} Blt}
  : Trichotomy@{Set Set Set} sum_lt.
Proof.
hnf. intros [a1|b1] [a2|b2];simpl.
- destruct (trichotomy _ a1 a2) as [?|[?|?]];auto.
- auto.
- auto.
- destruct (trichotomy _ b1 b2) as [?|[?|?]];auto.
Defined.

End contents.


Require Import ZArith.
Require Import hddivsteps_base.

Lemma example590 : ZMap.Empty (N.iter 590 (processDivstep 0x101c840faed222b9ef3bfe933011b277f84ee3d3f6dc8b496d8cd75b8315afec2) state0).
Proof.
apply ZMap.is_empty_2.
vm_cast_no_check (refl_equal true).
Time Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e511m481_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


(** *** direct sums

    Recall that X is a family of objects in a category, and the map from the
    sum to the product is an isomorphism, then the sum is called a direct sum. *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import
        UniMath.Foundations.Sets
        UniMath.Combinatorics.FiniteSets
        UniMath.CategoryTheory.RepresentableFunctors.Representation
        UniMath.CategoryTheory.RepresentableFunctors.Precategories.
Require UniMath.CategoryTheory.RepresentableFunctors.RawMatrix.
Local Open Scope cat.

Definition identity_matrix {C:category} (h:ZeroMaps C)
           {I} (d:I -> ob C) (dec : isdeceq I) : ∏ i j, Hom C (d j) (d i).
Proof.
  intros. induction (dec i j) as [ eq | ne ].
  { induction eq. apply identity. }
  { apply h. }
Defined.

Definition identity_map {C:category} (h:ZeroMaps C)
           {I} {d:I -> ob C} (dec : isdeceq I)
           (B:Sum d) (D:Product d)
      : Hom C (universalObject B) (universalObject D).
Proof.
  intros. apply RawMatrix.from_matrix. apply identity_matrix.
  - assumption.
  - assumption.
Defined.

(* Record DirectSum {C:category} (h:ZeroMaps C) I (dec : isdeceq I) (c : I -> ob C) := *)
(*   make_DirectSum { *)
(*       ds : C; *)
(*       ds_pr : ∏ i, Hom C ds (c i); *)
(*       ds_in : ∏ i, Hom C (c i) ds; *)
(*       ds_id : ∏ i j, ds_pr i ∘ ds_in j = identity_matrix h c dec i j; *)
(*       ds_isprod : ∏ c, isweq (λ f : Hom C c ds, λ i, ds_pr i ∘ f); *)
(*       ds_issum  : ∏ c, isweq (λ f : Hom C ds c, λ i, f ∘ ds_in i) }. *)

Section A.

Context {C:category} (h:ZeroMaps C) I (dec : isdeceq I) (c : I -> ob C).

Definition DirectSum : Type := (*  *)
  ∑
    (ds : C)
    (ds_pr : ∏ i, Hom C ds (c i))
    (ds_in : ∏ i, Hom C (c i) ds)
    (ds_id : ∏ i j, ds_pr i ∘ ds_in j = identity_matrix h c dec i j)
    (ds_isprod : ∏ c, isweq (λ f : Hom C c ds, λ i, ds_pr i ∘ f)),
  (* ds_issum : *) ∏ c, isweq (λ f : Hom C ds c, λ i, f ∘ ds_in i).
Definition ds (x:DirectSum) := pr1 x.
Definition ds_pr (x:DirectSum) := pr12 x.
Definition ds_in (x:DirectSum) := pr122 x.
Definition ds_id (x:DirectSum) := pr122 (pr2 x).
Definition ds_isprod (x:DirectSum) := pr122 (pr22 x).
Definition ds_issum (x:DirectSum) := pr222 (pr22 x).
Definition make_DirectSum ds ds_pr ds_in ds_id ds_isprod ds_issum : DirectSum
  := ds,, ds_pr,, ds_in,, ds_id,, ds_isprod,, ds_issum.

End A.

Definition toDirectSum {C:category} (h:ZeroMaps C) {I} (dec : isdeceq I) (d:I -> ob C)
           (B:Sum d) (D:Product d)
           (is: is_iso (identity_map h dec B D)) : DirectSum h I dec d.
Proof.
  intros. set (id := identity_map h dec B D).
  refine (make_DirectSum h I dec d (universalObject D)
                         (λ i, pr_ D i)
                         (λ i, id ∘ in_ B i) _ _ _).
  { intros. exact (RawMatrix.from_matrix_entry_assoc D B (identity_matrix h d dec) i j). }
  { intros. exact (pr2 (universalProperty D c)). }
  { intros.
    assert (b : (λ (f : Hom C (universalObject D) c) (i : I), (f ∘ id) ∘ in_ B i)
             = (λ (f : Hom C (universalObject D) c) (i : I), f ∘ (id ∘ in_ B i))).
    { apply funextsec; intros f. apply funextsec; intros i. apply assoc. }
    destruct b.
    exact (twooutof3c (λ f, f ∘ id)
                      (λ g i, g ∘ in_ B i)
                      (iso_comp_right_isweq (id,,is) c)
                      (pr2 (universalProperty B c))). }
Defined.
Definition FiniteDirectSums (C:category) :=
             ∑ h : ZeroMaps C,
             ∏ I : FiniteSet,
             ∏ d : I -> ob C,
               DirectSum h I (isfinite_isdeceq I (pr2 I)) d.


(* (c) Copyright Microsoft Corporation and Inria.                       *)
(* You may distribute this file under the terms of the CeCILL-B license *)
Require Import ssreflect ssrbool ssrfun eqtype ssrnat fintype finset.
Require Import fingroup perm morphism.

(******************************************************************************)
(* Group automorphisms and characteristic subgroups.                          *)
(* Unlike morphisms on a group G, which are functions of type gT -> rT, with  *)
(* a canonical structure of dependent type {morphim G >-> rT}, automorphisms  *)
(* are permutations of type {perm gT} contained in Aut G : {set {perm gT}}.   *)
(* This lets us use the finGroupType of {perm gT}. Note also that while       *)
(* morphisms on G are undefined outside G, automorphisms have their support   *)
(* in G, i.e., they are the identity ouside G.                                *)
(* Definitions:                                                               *)
(*    Aut G (or [Aut G]) == the automorphism group of G.                      *)
(*             [Aut G]%G == the group structure for Aut G.                    *)
(*            autm AutGa == the morphism on G induced by a, given             *)
(*                          AutGa : a \in Aut G.                              *)
(*       perm_in injf fA == the permutation with support B in induced by f,   *)
(*                          given injf : {in A &, injective f} and            *)
(*                          fA : f @: A \subset A.                            *)
(*           aut injf fG == the automorphism of G induced by the morphism f,  *)
(*                          given injf : 'injm f and fG : f @* G \subset G.   *)
(*    Aut_isom injf sDom == the injective homomorphism that maps Aut G to     *)
(*                          Aut (f @* G), with f : {morphism D >-> rT} and    *)
(*                          given injf: 'injm f and sDom : G \subset D.       *)
(*              conjgm G == the conjugation automorphism on G.                *)
(*             H \char G == H is a characteristic subgroup of G.              *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import GroupScope.

(***********************************************************************)
(* A group automorphism, defined as a permutation on a subset of a     *)
(* finGroupType that respects the morphism law.                        *)
(* Here perm_on is used as a closure rule for the set A.               *)
(***********************************************************************)

Section Automorphism.

Variable gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Types a b : {perm gT}.

Definition Aut A := [set a | perm_on A a & morphic A a].

Lemma Aut_morphic A a : a \in Aut A -> morphic A a.
Proof. by case/setIdP. Qed.

Lemma out_Aut A a x : a \in Aut A -> x \notin A -> a x = x.
Proof. by case/setIdP=> Aa _; exact: out_perm. Qed.

Lemma eq_Aut A : {in Aut A &, forall a b, {in A, a =1 b} -> a = b}.
Proof.
move=> a g Aa Ag /= eqag; apply/permP=> x.
by have [/eqag // | /out_Aut out] := boolP (x \in A); rewrite !out.
Qed.

(* The morphism that is represented by a given element of Aut A. *)

Definition autm A a (AutAa : a \in Aut A) := morphm (Aut_morphic AutAa).
Lemma autmE A a (AutAa : a \in Aut A) : autm AutAa = a.
Proof. by []. Qed.

Canonical autm_morphism A a aM := Eval hnf in [morphism of @autm A a aM].

Section AutGroup.

Variable G : {group gT}.

Lemma Aut_group_set : group_set (Aut G).
Proof.
apply/group_setP; split=> [|a b].
  by rewrite inE perm_on1; apply/morphicP=> ? *; rewrite !permE.
rewrite !inE => /andP[Ga aM] /andP[Gb bM]; rewrite perm_onM //=.
apply/morphicP=> x y Gx Gy; rewrite !permM (morphicP aM) //.
by rewrite (morphicP bM) ?perm_closed.
Qed.

Canonical Aut_group := group Aut_group_set.

Variable (a : {perm gT}) (AutGa : a \in Aut G).
Notation f := (autm AutGa).
Notation fE := (autmE AutGa).

Lemma injm_autm : 'injm f.
Proof. apply/injmP; apply: in2W; exact: perm_inj. Qed.

Lemma ker_autm : 'ker f = 1. Proof. by move/trivgP: injm_autm. Qed.

Lemma im_autm : f @* G = G.
Proof.
apply/setP=> x; rewrite morphimEdom (can_imset_pre _ (permK a)) inE.
by have:= AutGa; rewrite inE => /andP[/perm_closed <-]; rewrite permKV.
Qed.

Lemma Aut_closed x : x \in G -> a x \in G.
Proof. by move=> Gx; rewrite -im_autm; exact: mem_morphim. Qed.

End AutGroup.

Lemma Aut1 : Aut 1 = 1.
Proof.
apply/trivgP/subsetP=> a /= AutGa; apply/set1P.
apply: eq_Aut (AutGa) (group1 _) _ => _ /set1P->.
by rewrite -(autmE AutGa) morph1 perm1.
Qed.

End Automorphism.

Arguments Scope Aut [_ group_scope].
Notation "[ 'Aut' G ]" := (Aut_group G)
  (at level 0, format "[ 'Aut'  G ]") : Group_scope.
Notation "[ 'Aut' G ]" := (Aut G)
  (at level 0, only parsing) : group_scope.

Prenex Implicits Aut autm.

(* The permutation function (total on the underlying groupType) that is the *)
(* representant of a given morphism f with domain A in (Aut A).             *)

Section PermIn.

Variables (T : finType) (A : {set T}) (f : T -> T).

Hypotheses (injf : {in A &, injective f}) (sBf : f @: A \subset A).

Lemma perm_in_inj : injective (fun x => if x \in A then f x else x).
Proof.
move=> x y /=; wlog Ay: x y / y \in A.
  by move=> IH eqfxy; case: ifP (eqfxy); [symmetry | case: ifP => //]; auto.
rewrite Ay; case: ifP => [Ax | nAx def_x]; first exact: injf.
by case/negP: nAx; rewrite def_x (subsetP sBf) ?mem_imset.
Qed.

Definition perm_in := perm perm_in_inj.

Lemma perm_in_on : perm_on A perm_in.
Proof.
by apply/subsetP=> x; rewrite inE /= permE; case: ifP => // _; case/eqP.
Qed.

Lemma perm_inE : {in A, perm_in =1 f}.
Proof. by move=> x Ax; rewrite /= permE Ax. Qed.

End PermIn.

(* properties of injective endomorphisms *)

Section MakeAut.

Variables (gT : finGroupType) (G : {group gT}) (f : {morphism G >-> gT}).
Implicit Type A : {set gT}.

Hypothesis injf : 'injm f.

Lemma morphim_fixP A : A \subset G -> reflect (f @* A = A) (f @* A \subset A).
Proof.
rewrite /morphim => sAG; have:= eqEcard (f @: A) A.
rewrite (setIidPr sAG) card_in_imset ?leqnn ?andbT  => [<-|]; first exact: eqP.
move/injmP: injf; apply: sub_in2; exact/subsetP.
Qed.

Hypothesis Gf : f @* G = G.

Lemma aut_closed : f @: G \subset G.
Proof. by rewrite -morphimEdom; exact/morphim_fixP. Qed.

Definition aut := perm_in (injmP _ injf) aut_closed.

Lemma autE : {in G, aut =1 f}.
Proof. exact: perm_inE. Qed.

Lemma morphic_aut : morphic G aut.
Proof. by apply/morphicP=> x y Gx Gy /=; rewrite !autE ?groupM // morphM. Qed.

Lemma Aut_aut : aut \in Aut G.
Proof. by rewrite inE morphic_aut perm_in_on. Qed.

Lemma imset_autE A : A \subset G -> aut @: A = f @* A.
Proof.
move=> sAG; rewrite /morphim (setIidPr sAG).
apply: eq_in_imset; apply: sub_in1 autE; exact/subsetP.
Qed.

Lemma preim_autE A : A \subset G -> aut @^-1: A = f @*^-1 A.
Proof.
move=> sAG; apply/setP=> x; rewrite !inE permE /=.
by case Gx: (x \in G) => //; apply/negP=> Ax; rewrite (subsetP sAG) in Gx.
Qed.

End MakeAut.

Implicit Arguments morphim_fixP [gT G f].
Prenex Implicits aut morphim_fixP.

Section AutIsom.

Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}).

Hypotheses (injf : 'injm f) (sGD : G \subset D).
Let domG := subsetP sGD.

Lemma Aut_isom_subproof a :
  {a' | a' \in Aut (f @* G) & a \in Aut G -> {in G, a' \o f =1 f \o a}}.
Proof.
set Aut_a := autm (subgP (subg [Aut G] a)).
have aDom: 'dom (f \o Aut_a \o invm injf) = f @* G.
  rewrite /dom /= morphpre_invm -morphpreIim; congr (f @* _).
  by rewrite [_ :&: D](setIidPl _) ?injmK ?injm_autm ?im_autm.
have [af [def_af ker_af _ im_af]] := domP _ aDom.
have inj_a': 'injm af by rewrite ker_af !injm_comp ?injm_autm ?injm_invm.
have im_a': af @* (f @* G) = f @* G.
  by rewrite im_af !morphim_comp morphim_invm // im_autm.
pose a' := aut inj_a' im_a'; exists a' => [|AutGa x Gx]; first exact: Aut_aut.
have Dx := domG Gx; rewrite /= [a' _]autE ?mem_morphim //.
by rewrite def_af /= invmE // autmE subgK.
Qed.

Definition Aut_isom a := s2val (Aut_isom_subproof a).

Lemma Aut_Aut_isom a : Aut_isom a \in Aut (f @* G).
Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed.

Lemma Aut_isomE a : a \in Aut G -> {in G, forall x, Aut_isom a (f x) = f (a x)}.
Proof. by rewrite /Aut_isom; case: (Aut_isom_subproof a). Qed.

Lemma Aut_isomM : {in Aut G &, {morph Aut_isom: x y / x * y}}.
Proof.
move=> a b AutGa AutGb.
apply: (eq_Aut (Aut_Aut_isom _)); rewrite ?groupM ?Aut_Aut_isom // => fx.
case/morphimP=> x Dx Gx ->{fx}.
by rewrite permM !Aut_isomE ?groupM /= ?permM ?Aut_closed.
Qed.
Canonical Aut_isom_morphism := Morphism Aut_isomM.

Lemma injm_Aut_isom : 'injm Aut_isom.
Proof.
apply/injmP=> a b AutGa AutGb eq_ab'; apply: (eq_Aut AutGa AutGb) => x Gx.
by apply: (injmP _ injf); rewrite ?domG ?Aut_closed // -!Aut_isomE //= eq_ab'.
Qed.

End AutIsom.

Section InjmAut.

Variables (gT rT : finGroupType) (G D : {group gT}) (f : {morphism D >-> rT}).

Hypotheses (injf : 'injm f) (sGD : G \subset D).
Let domG := subsetP sGD.

Lemma im_Aut_isom : Aut_isom injf sGD @* Aut G = Aut (f @* G).
Proof.
apply/eqP; rewrite eqEcard; apply/andP; split.
  by apply/subsetP=> _ /morphimP[a _ AutGa ->]; exact: Aut_Aut_isom.
have inj_isom' := injm_Aut_isom (injm_invm injf) (morphimS _ sGD).
rewrite card_injm ?injm_Aut_isom // -(card_injm inj_isom') ?subset_leq_card //.
apply/subsetP=> a /morphimP[a' _ AutfGa' def_a].
by rewrite -(morphim_invm injf sGD) def_a Aut_Aut_isom.
Qed.

Lemma Aut_isomP : isom (Aut G) (Aut (f @* G)) (Aut_isom injf sGD).
Proof. by apply/isomP; split; [exact: injm_Aut_isom | exact: im_Aut_isom]. Qed.

Lemma injm_Aut : Aut (f @* G) \isog Aut G.
Proof. by rewrite isog_sym (isom_isog _ _ Aut_isomP). Qed.

End InjmAut.

(* conjugation automorphism *)

Section ConjugationMorphism.

Variable gT : finGroupType.
Implicit Type A : {set gT}.

Definition conjgm of {set gT} := fun x y : gT => y ^ x.

Lemma conjgmE A x y : conjgm A x y = y ^ x. Proof. by []. Qed.

Canonical conjgm_morphism A x :=
  @Morphism _ _ A (conjgm A x) (in2W (fun y z => conjMg y z x)).

Lemma morphim_conj A x B : conjgm A x @* B = (A :&: B) :^ x.
Proof. by []. Qed.

Variable G : {group gT}.

Lemma injm_conj x : 'injm (conjgm G x).
Proof. by apply/injmP; apply: in2W; exact: conjg_inj. Qed.

Lemma conj_isom x : isom G (G :^ x) (conjgm G x).
Proof. by apply/isomP; rewrite morphim_conj setIid injm_conj. Qed.

Lemma conj_isog x : G \isog G :^ x.
Proof. exact: isom_isog (conj_isom x). Qed.

Lemma norm_conjg_im x : x \in 'N(G) -> conjgm G x @* G = G.
Proof. by rewrite morphimEdom; exact: normP. Qed.

Lemma norm_conj_isom x : x \in 'N(G) -> isom G G (conjgm G x).
Proof. by move/norm_conjg_im/restr_isom_to/(_ (conj_isom x))->. Qed.

Definition conj_aut x := aut (injm_conj _) (norm_conjg_im (subgP (subg _ x))).

Lemma norm_conj_autE : {in 'N(G) & G, forall x y, conj_aut x y = y ^ x}.
Proof. by move=> x y nGx Gy; rewrite /= autE //= subgK. Qed.

Lemma conj_autE : {in G &, forall x y, conj_aut x y = y ^ x}.
Proof. by apply: sub_in11 norm_conj_autE => //; exact: subsetP (normG G). Qed.

Lemma conj_aut_morphM : {in 'N(G) &, {morph conj_aut : x y / x * y}}.
Proof.
move=> x y nGx nGy; apply/permP=> z /=; rewrite permM.
case Gz: (z \in G); last by rewrite !permE /= !Gz.
by rewrite !norm_conj_autE // (conjgM, memJ_norm, groupM).
Qed.

Canonical conj_aut_morphism := Morphism conj_aut_morphM.

Lemma ker_conj_aut : 'ker conj_aut = 'C(G).
Proof.
apply/setP=> x; rewrite inE; case nGx: (x \in 'N(G)); last first.
  by symmetry; apply/idP=> cGx; rewrite (subsetP (cent_sub G)) in nGx.
rewrite 2!inE /=; apply/eqP/centP=> [cx1 y Gy | cGx].
  by rewrite /commute (conjgC y) -norm_conj_autE // cx1 perm1.
apply/permP=> y; case Gy: (y \in G); last by rewrite !permE Gy.
by rewrite perm1 norm_conj_autE // conjgE -cGx ?mulKg.
Qed.

Lemma Aut_conj_aut A : conj_aut @* A \subset Aut G.
Proof. by apply/subsetP=> _ /imsetP[x _ ->]; exact: Aut_aut. Qed.

End ConjugationMorphism.

Arguments Scope conjgm [_ group_scope].
Prenex Implicits conjgm conj_aut.

Reserved Notation "G \char H" (at level 70).

(* Characteristic subgroup *)

Section Characteristicity.

Variable gT : finGroupType.
Implicit Types A B : {set gT}.
Implicit Types G H K L : {group gT}.

Definition characteristic A B :=
  (A \subset B) && [forall f in Aut B, f @: A \subset A].

Infix "\char" := characteristic.

Lemma charP H G :
  reflect [/\ H \subset G
            & forall f : {morphism G >-> gT},
               'injm f -> f @* G = G -> f @* H = H]
          (H \char G).
Proof.
apply: (iffP andP) => [] [sHG chHG]; split=> //.
  move=> f injf Gf; apply/morphim_fixP=> //.
  by have:= forallP chHG (aut injf Gf); rewrite Aut_aut imset_autE.
apply/forallP=> f; apply/implyP=> Af; have injf := injm_autm Af.
move/(morphim_fixP injf _ sHG): (chHG _ injf (im_autm Af)).
by rewrite /morphim (setIidPr _).
Qed.

(* Characteristic subgroup properties : composition, relational properties *)

Lemma char1 G : 1 \char G.
Proof. by apply/charP; split=> [|f _ _]; rewrite (sub1G, morphim1). Qed.

Lemma char_refl G : G \char G.
Proof. exact/charP. Qed.

Lemma char_trans H G K : K \char H -> H \char G -> K \char G.
Proof.
case/charP=> sKH chKH; case/charP=> sHG chHG.
apply/charP; split=> [|f injf Gf]; first exact: subset_trans sHG.
rewrite -{1}(setIidPr sKH) -(morphim_restrm sHG) chKH //.
  rewrite ker_restrm; move/trivgP: injf => ->; exact: subsetIr.
by rewrite morphim_restrm setIid chHG.
Qed.

Lemma char_norms H G : H \char G -> 'N(G) \subset 'N(H).
Proof.
case/charP=> sHG chHG; apply/normsP=> x /normP Nx.
have:= chHG [morphism of conjgm G x] => /=.
by rewrite !morphimEsub //=; apply; rewrite // injm_conj.
Qed.

Lemma char_sub A B : A \char B -> A \subset B.
Proof. by case/andP. Qed.

Lemma char_norm_trans H G A : H \char G -> A \subset 'N(G) -> A \subset 'N(H).
Proof. by move/char_norms=> nHnG nGA; exact: subset_trans nHnG. Qed.

Lemma char_normal_trans H G K : K \char H -> H <| G -> K <| G.
Proof.
move=> chKH /andP[sHG nHG].
by rewrite /normal (subset_trans (char_sub chKH)) // (char_norm_trans chKH).
Qed.

Lemma char_normal H G : H \char G -> H <| G.
Proof. by move/char_normal_trans; apply; apply/andP; rewrite normG. Qed.

Lemma char_norm H G : H \char G -> G \subset 'N(H).
Proof. by case/char_normal/andP. Qed.

Lemma charI G H K : H \char G -> K \char G -> H :&: K \char G.
Proof.
case/charP=> sHG chHG; case/charP=> _ chKG.
apply/charP; split=> [|f injf Gf]; first by rewrite subIset // sHG.
rewrite morphimGI ?(chHG, chKG) //; exact: subset_trans (sub1G H).
Qed.

Lemma charMgen G H K : H \char G -> K \char G -> H <*> K \char G.
Proof.
case/charP=> sHG chHG; case/charP=> sKG chKG.
apply/charP; split=> [|f injf Gf]; first by rewrite gen_subG subUset sHG.
by rewrite morphim_gen ?(morphimU, subUset, sHG, chHG, chKG).
Qed.

Lemma charM G H K : H \char G -> K \char G -> H * K \char G.
Proof.
move=> chHG chKG; rewrite -norm_joinEl ?charMgen //.
exact: subset_trans (char_sub chHG) (char_norm chKG).
Qed.

Lemma lone_subgroup_char G H :
  H \subset G -> (forall K, K \subset G -> K \isog H -> K \subset H) ->
  H \char G.
Proof.
move=> sHG Huniq; apply/charP; split=> // f injf Gf; apply/eqP.
have{injf} injf: {in H &, injective f}.
  by move/injmP: injf; apply: sub_in2; exact/subsetP.
have fH: f @* H = f @: H by rewrite /morphim (setIidPr sHG).
rewrite eqEcard {2}fH card_in_imset ?{}Huniq //=.
  by rewrite -{3}Gf morphimS.
rewrite isog_sym; apply/isogP.
exists [morphism of restrm sHG f] => //=; first exact/injmP.
by rewrite morphimEdom fH.
Qed.

End Characteristicity.

Arguments Scope characteristic [_ group_scope group_scope].
Notation "H \char G" := (characteristic H G) : group_scope.

Section InjmChar.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).

Hypothesis injf : 'injm f.

Lemma injm_char (G H : {group aT}) :
  G \subset D -> H \char G -> f @* H \char f @* G.
Proof.
move=> sGD /charP[sHG charH].
apply/charP; split=> [|g injg gfG]; first exact: morphimS.
have /domP[h [_ ker_h _ im_h]]: 'dom (invm injf \o g \o f) = G.
  by rewrite /dom /= -(morphpreIim g) (setIidPl _) ?injmK // gfG morphimS.
have hH: h @* H = H.
  apply: charH; first by rewrite ker_h !injm_comp ?injm_invm.
  by rewrite im_h !morphim_comp gfG morphim_invm.
rewrite /= -{2}hH im_h !morphim_comp morphim_invmE morphpreK //.
by rewrite (subset_trans _ (morphimS f sGD)) //= -{3}gfG !morphimS.
Qed.

End InjmChar.

Section CharInjm.

Variables (aT rT : finGroupType) (D : {group aT}) (f : {morphism D >-> rT}).
Hypothesis injf : 'injm f.

Lemma char_injm (G H : {group aT}) :
  G \subset D -> H \subset D -> (f @* H \char f @* G) = (H \char G).
Proof.
move=> sGD sHD; apply/idP/idP; last exact: injm_char.
by move/(injm_char (injm_invm injf)); rewrite !morphim_invm ?morphimS // => ->.
Qed.

End CharInjm.

Unset Implicit Arguments.


From Coq Require Import List.

Import ListNotations.

Module RemoveProperties.

  Lemma not_in_remove_same {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x : A):
    ~ In x l -> remove eq_dec x l = l.
  Proof.
    induction l.
    + auto.
    + intros Hnotin. cbn in *.
      destruct (eq_dec x a); intuition; congruence.
  Qed.

    Lemma not_in_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A):
    ~ In x l -> ~ In x (remove eq_dec y l).
  Proof.
    induction l.
    + auto.
    + intros Hnotin. cbn in *.
      destruct (eq_dec y a); cbn in *; intuition; auto.
  Qed.

  Lemma remove_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A) :
    ~ In x (remove eq_dec y (remove eq_dec x l)).
  Proof.
    induction l; auto; simpl in *.
    destruct (eq_dec x a); subst; intuition; simpl in *.
    destruct (eq_dec y a); subst; intuition; simpl in *.
    intuition; simpl in *.
  Qed.

  Lemma In_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A) :
    x <> y -> In x (remove eq_dec y l) -> In x l.
  Proof.
    induction l; intros Hneq Hin; auto; simpl in *.
    subst. destruct (eq_dec y a); subst; cbn in *; auto; intuition; auto.
  Qed.

  Lemma neq_not_removed {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x y : A) :
    x <> y -> In x l -> In x (remove eq_dec y l).
  Proof.
    induction l; intros Hneq Hin; auto; simpl in *.
    destruct Hin.
    + subst. destruct (eq_dec y x); subst; cbn; auto; try congruence.
    + destruct (eq_dec y a); cbn; auto.
  Qed.

  #[local]
  Hint Constructors NoDup : hints.
  #[local]
  Hint Resolve In_remove remove_In not_in_remove_same not_in_remove remove_remove neq_not_removed : hints.

  Fixpoint remove_all {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (to_remove : list A) (xs : list A) :=
    match to_remove with
    | [] => xs
    | x :: tl => remove eq_dec x (remove_all eq_dec tl xs)
    end.

  Lemma remove_all_In {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (to_remove : list A) (xs : list A) :
    Forall (fun x => ~ In x (remove_all eq_dec to_remove xs)) to_remove.
  Proof.
    revert dependent xs.
    induction to_remove; simpl; auto.
    constructor; eauto with hints.
    unshelve eapply (@Forall_impl _ _ _ _ _ (IHto_remove xs)).
    intros x H HH.
    apply (not_in_remove _ _ _ _ H HH).
  Qed.

  Lemma In_remove_all {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (to_remove : list A) (xs : list A) (x : A):
    ~ (In x to_remove) -> In x (remove_all eq_dec to_remove xs) -> In x xs.
  Proof.
    induction to_remove; cbn in *; intuition; eauto with hints.
  Qed.

  Lemma remove_all_not_in_to_remove {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (to_remove : list A) (xs : list A) (x : A):
    ~ (In x to_remove) -> In x xs -> In x (remove_all eq_dec to_remove xs).
  Proof.
    intros H1 H2.
    induction to_remove; cbn in *; intuition; eauto with hints.
  Qed.

  Lemma NoDup_remove {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l : list A) (x : A) :
    NoDup l -> NoDup (remove eq_dec x l).
  Proof.
    induction l; intros H0; auto; simpl.
    inversion H0; destruct (eq_dec x a); subst; intuition; simpl in *; eauto with hints.
  Qed.

  #[local]
  Hint Resolve NoDup_remove : hints.
  #[local]
  Hint Resolve In_remove : hints.

  Lemma remove_extensional {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l1 l2 : list A) (y : A) :
    (forall x, In x l1 <-> In x l2 ) -> (forall x, In x (remove eq_dec y l1) <-> In x (remove eq_dec y l2)).
  Proof.
    intros H x.
    split.
    + intros Hin.
      destruct (eq_dec x y); subst.
      * exfalso. apply (remove_In _ _ _ Hin).
      * destruct (H x); intuition; eauto with hints.
    + intros Hin.
      destruct (eq_dec x y); subst.
      * exfalso. apply (remove_In _ _ _ Hin).
      * destruct (H x); intuition; eauto with hints.
  Qed.

End RemoveProperties.


Require Import ProofIrrelevance Setoid.
Require Export SpecializedCategory.
Require Import Common StructureEquality.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section Category.
  Context `{C : @SpecializedCategory obj}.

  (* [m'] is the inverse of [m] if both compositions are
     equivalent to the relevant identity morphisms. *)
  (* [Definitions] don't get sort-polymorphism :-(  *)
  Definition IsInverseOf1 (s d : C) (m : C.(Morphism) s d) (m' : C.(Morphism) d s) : Prop :=
    Compose m' m = Identity s.
  Definition IsInverseOf2 (s d : C) (m : C.(Morphism) s d) (m' : C.(Morphism) d s) : Prop :=
    Compose m m' = Identity d.

  Global Arguments IsInverseOf1 / _ _ _ _.
  Global Arguments IsInverseOf2 / _ _ _ _.

  Definition IsInverseOf {s d : C} (m : C.(Morphism) s d) (m' : C.(Morphism) d s) : Prop := Eval simpl in
    @IsInverseOf1 s d m m' /\ @IsInverseOf2 s d m m'.

  Lemma IsInverseOf_sym s d m m' : @IsInverseOf s d m m' -> @IsInverseOf d s m' m.
    firstorder.
  Qed.

  (* As per David's comment, everything is better when we supply a witness rather
     than an assertion.  (In particular the [exists m' -> m'] transformation is only
     permissible for [m' : Prop].  Trying it on other with
       refine match H with
                | ex_intro x x0 => _ x x0
              end
     gives
       Error:
       Incorrect elimination of "H" in the inductive type "ex":
       the return type has sort "Type" while it should be "Prop".
       Elimination of an inductive object of sort Prop
       is not allowed on a predicate in sort Type
       because proofs can be eliminated only to build proofs.
     ) *)
  (* [Record]s are [Inductive] and get sort-polymorphism *)
  Section IsomorphismOf.
    (* A morphism is an isomorphism if it has an inverse *)
    Record IsomorphismOf {s d : C} (m : C.(Morphism) s d) := {
      IsomorphismOf_Morphism :> C.(Morphism) s d := m;
      Inverse : C.(Morphism) d s;
      LeftInverse : Compose Inverse m = Identity s;
      RightInverse : Compose m Inverse = Identity d
    }.

    Hint Resolve RightInverse LeftInverse : category.
    Hint Resolve RightInverse LeftInverse : morphism.

    Definition IsomorphismOf_sig2 {s d : C} (m : C.(Morphism) s d) (i : @IsomorphismOf s d m) :
      { m' | Compose m' m = Identity s & Compose m m' = Identity d }.
      exists (Inverse i);
        [ apply LeftInverse | apply RightInverse ].
    Defined.

    Definition IsomorphismOf_sig {s d : C} (m : C.(Morphism) s d) := { m' | Compose m' m = Identity s & Compose m m' = Identity d }.

    Global Identity Coercion Isomorphism_sig : IsomorphismOf_sig >-> sig2.

    Definition sig2_IsomorphismOf {s d : C} (m : C.(Morphism) s d) (i : @IsomorphismOf_sig s d m) :
      @IsomorphismOf s d m.
      exists (proj1_sig i);
        [ apply (proj2_sig i) | apply (proj3_sig i) ].
    Defined.

    Global Coercion IsomorphismOf_sig2 : IsomorphismOf >-> sig2.
    Global Coercion sig2_IsomorphismOf : IsomorphismOf_sig >-> IsomorphismOf.

    Definition IsomorphismOf_Identity (c : C) : IsomorphismOf (Identity c).
      exists (Identity _); auto with morphism.
    Defined.

    Definition InverseOf {s d : C} (m : C.(Morphism) s d) (i : IsomorphismOf m) : IsomorphismOf (Inverse i).
      exists (i : Morphism C _ _); auto with morphism.
    Defined.

    Definition ComposeIsomorphismOf {s d d' : C} {m1 : C.(Morphism) d d'} {m2 : C.(Morphism) s d} (i1 : IsomorphismOf m1) (i2 : IsomorphismOf m2) :
      IsomorphismOf (Compose m1 m2).
      exists (Compose (Inverse i2) (Inverse i1));
      abstract (
          simpl; compose4associativity;
          destruct i1, i2; simpl;
          repeat (rewrite_hyp; autorewrite with morphism);
          trivial
        ).
    Defined.
  End IsomorphismOf.

  Section Isomorphism.
    Record Isomorphism (s d : C) := {
      Isomorphism_Morphism : C.(Morphism) s d;
      Isomorphism_Of :> IsomorphismOf Isomorphism_Morphism
    }.

    Global Coercion Build_Isomorphism : IsomorphismOf >-> Isomorphism.
  End Isomorphism.

  Section IsIsomorphism.
    Definition IsIsomorphism {s d : C} (m : C.(Morphism) s d) : Prop :=
      exists m', IsInverseOf m m'.

    Lemma IsomrphismOf_IsIsomorphism {s d : C} (m : C.(Morphism) s d) : IsomorphismOf m -> IsIsomorphism m.
      intro i; hnf.
      exists (Inverse i);
        destruct i; simpl;
        split;
        assumption.
    Qed.

    Lemma IsIsomorphism_IsomrphismOf {s d : C} (m : C.(Morphism) s d) : IsIsomorphism m -> exists _ : IsomorphismOf m, True.
      intro i; destruct_hypotheses.
      destruct_exists; trivial.
      eexists; eassumption.
    Qed.
  End IsIsomorphism.

  Section Isomorphic.
    Definition Isomorphic (s d : C) : Prop :=
      exists (m : C.(Morphism) s d) (m' : C.(Morphism) d s), IsInverseOf m m'.

    Lemma Isomrphism_Isomorphic s d : Isomorphism s d -> Isomorphic s d.
      intro i; destruct i as [ m i ].
      exists m.
      apply IsomrphismOf_IsIsomorphism; assumption.
    Qed.

    Lemma Isomorphic_Isomorphism s d : Isomorphic s d -> exists _ : Isomorphism s d, True.
      intro i; destruct_hypotheses.
      destruct_exists; trivial.
      repeat esplit; eassumption.
    Qed.

    Local Ltac t_iso' := intros;
      repeat match goal with
               | [ i : Isomorphic _ _ |- _ ] => destruct (Isomorphic_Isomorphism i) as [ ? [] ] ; clear i
               | [ |- Isomorphic _ _ ] => apply Isomrphism_Isomorphic
             end.

    Local Ltac t_iso:= t_iso';
      repeat match goal with
               | [ i : Isomorphism _ _ |- _ ] => unique_pose (Isomorphism_Of i); try clear i
               | [ |- Isomorphism _ _ ] => eapply Build_Isomorphism
             end.

    Hint Resolve @IsomorphismOf_Identity @InverseOf @ComposeIsomorphismOf : category morphism.
    Local Hint Extern 1 => eassumption.

    Lemma Isomorphic_refl c : Isomorphic c c.
      t_iso.
      apply IsomorphismOf_Identity.
    Qed.

    Lemma Isomorphic_sym s d : Isomorphic s d -> Isomorphic d s.
      t_iso.
      eauto with morphism.
      Grab Existential Variables.
      eauto with morphism.
    Qed.

    Lemma Isomorphic_trans s d d' : Isomorphic s d -> Isomorphic d d' -> Isomorphic s d'.
      t_iso.
      apply @ComposeIsomorphismOf;
        eauto with morphism.
    Qed.

    Global Add Parametric Relation : _ Isomorphic
      reflexivity proved by Isomorphic_refl
      symmetry proved by Isomorphic_sym
      transitivity proved by Isomorphic_trans
        as Isomorphic_rel.
  End Isomorphic.

  (* XXX TODO: Automate this better. *)
  Lemma iso_is_epi s d (m : _ s d) : IsIsomorphism m -> IsEpimorphism (C := C) m.
    destruct 1 as [ x [ i0 i1 ] ]; intros z m1 m2 e.
    transitivity (Compose m1 (Compose m x)); [ rewrite_hyp; autorewrite with morphism | ]; trivial.
    transitivity (Compose m2 (Compose m x)); [ repeat rewrite <- Associativity | ]; rewrite_hyp; autorewrite with morphism; trivial.
  Qed.

  (* XXX TODO: Automate this better. *)
  Lemma iso_is_mono s d (m : _ s d) : IsIsomorphism m -> IsMonomorphism (C := C) m.
    destruct 1 as [ x [ i0 i1 ] ]; intros z m1 m2 e.
    transitivity (Compose (Compose x m) m1); [ rewrite_hyp; autorewrite with morphism | ]; trivial.
    transitivity (Compose (Compose x m) m2); [ repeat rewrite Associativity | ]; rewrite_hyp; autorewrite with morphism; trivial.
  Qed.
End Category.

Hint Resolve @RightInverse @LeftInverse @IsomorphismOf_Identity @ComposeIsomorphismOf : category morphism.

Ltac eapply_by_compose H :=
  match goal with
    | [ |- @eq (@Morphism ?obj ?mor ?C) _ _ ] => eapply (H obj mor C)
    | [ |- @Compose ?obj ?mor ?C _ _ _ _ _ = _ ] => eapply (H obj mor C)
    | [ |- _ = @Compose ?obj ?mor ?C _ _ _ _ _ ] => eapply (H obj mor C)
    | _ => eapply H
    | [ C : @SpecializedCategory ?obj ?mor |- _ ] => eapply (H obj mor C)
    | [ C : ?T |- _ ] => match eval hnf in T with | @SpecializedCategory ?obj ?mor => eapply (H obj mor C) end
  end.

Ltac solve_isomorphism := destruct_hypotheses;
  solve [ eauto ] ||
    match goal with
      | [ _ : Compose ?x ?x' = Identity _ |- IsIsomorphism ?x ] => solve [ exists x'; hnf; eauto ]
      | [ _ : Compose ?x ?x' = Identity _ |- Isomorphism ?x ] => solve [ exists x'; hnf; eauto ]
      | [ _ : Compose ?x ?x' = Identity _ |- IsomorphismOf ?x ] => solve [ exists x'; hnf; eauto ]
      | [ _ : Compose ?x ?x' = Identity _ |- context[Compose ?x _ = Identity _] ] => solve [ try exists x'; hnf; eauto ]
    end.

(* [eapply] the theorem to get a pre/post composed mono/epi, then find the right one by looking
   for an [Identity], then solve the requirement that it's an isomorphism *)
Ltac post_compose_to_identity :=
  eapply_by_compose iso_is_epi;
  [ | repeat rewrite AssociativityNoEvar by noEvar; find_composition_to_identity; rewrite RightIdentity ];
  [ solve_isomorphism | ].
Ltac pre_compose_to_identity :=
  eapply_by_compose iso_is_mono;
  [ | repeat rewrite <- AssociativityNoEvar by noEvar; find_composition_to_identity; rewrite LeftIdentity ];
  [ solve_isomorphism | ].

Section CategoryObjects1.
  Context `(C : @SpecializedCategory obj).

  Definition UniqueUpToUniqueIsomorphism' (P : C.(Object) -> Prop) : Prop :=
    forall o, P o -> forall o', P o' -> exists m : C.(Morphism) o o', IsIsomorphism m /\ is_unique m.

  Definition UniqueUpToUniqueIsomorphism (P : C.(Object) -> Type) :=
    forall o, P o -> forall o', P o' -> { m : C.(Morphism) o o' | IsIsomorphism m & is_unique m }.

  Section terminal.
    (* A terminal object is an object with a unique morphism from every other object. *)
    Definition IsTerminalObject' (o : C) : Prop :=
      forall o', exists! m : C.(Morphism) o' o, True.

    Definition IsTerminalObject (o : C) :=
      forall o', { m : C.(Morphism) o' o | is_unique m }.

    Record TerminalObject :=
      {
        TerminalObject_Object' : obj;
        TerminalObject_Morphism : forall o, Morphism C o TerminalObject_Object';
        TerminalObject_Property : forall o, is_unique (TerminalObject_Morphism o)
      }.

    Definition TerminalObject_Object : TerminalObject -> C := TerminalObject_Object'.

    Global Coercion TerminalObject_Object : TerminalObject >-> Object.

    Definition TerminalObject_IsTerminalObject (o : TerminalObject) : IsTerminalObject o
      := fun o' => exist _ (TerminalObject_Morphism o o') (TerminalObject_Property o o').

    Definition IsTerminalObject_TerminalObject o : IsTerminalObject o -> TerminalObject
      := fun H => @Build_TerminalObject o (fun o' => proj1_sig (H o')) (fun o' => proj2_sig (H o')).

    Global Coercion TerminalObject_IsTerminalObject : TerminalObject >-> IsTerminalObject.
    Global Coercion IsTerminalObject_TerminalObject : IsTerminalObject >-> TerminalObject.
  End terminal.

  Section initial.
    (* An initial object is an object with a unique morphism from every other object. *)
    Definition IsInitialObject' (o : C) : Prop :=
      forall o', exists! m : C.(Morphism) o o', True.

    Definition IsInitialObject (o : C) :=
      forall o', { m : C.(Morphism) o o' | is_unique m }.

    Record InitialObject :=
      {
        InitialObject_Object' :> obj;
        InitialObject_Morphism : forall o, Morphism C InitialObject_Object' o;
        InitialObject_Property : forall o, is_unique (InitialObject_Morphism o)
      }.

    Definition InitialObject_Object : InitialObject -> C := InitialObject_Object'.

    Global Coercion InitialObject_Object : InitialObject >-> Object.

    Definition InitialObject_IsInitialObject (o : InitialObject) : IsInitialObject o
      := fun o' => exist _ (InitialObject_Morphism o o') (InitialObject_Property o o').

    Definition IsInitialObject_InitialObject o : IsInitialObject o -> InitialObject
      := fun H => @Build_InitialObject o (fun o' => proj1_sig (H o')) (fun o' => proj2_sig (H o')).

    Global Coercion InitialObject_IsInitialObject : InitialObject >-> IsInitialObject.
    Global Coercion IsInitialObject_InitialObject : IsInitialObject >-> InitialObject.
  End initial.
End CategoryObjects1.

Arguments UniqueUpToUniqueIsomorphism {_ C} P.
Arguments IsInitialObject' {_ C} o.
Arguments IsInitialObject {_ C} o.
Arguments IsTerminalObject' {_ C} o.
Arguments IsTerminalObject {_ C} o.

Section CategoryObjects2.
  Context `(C : @SpecializedCategory obj).

  Ltac unique := hnf; intros; specialize_all_ways; destruct_sig;
    unfold is_unique, unique, uniqueness in *;
      repeat (destruct 1);
      repeat match goal with
               | [ x : _ |- _ ] => exists x
             end; eauto with category; try split; try solve [ etransitivity; eauto with category ].

  (* The terminal object is unique up to unique isomorphism. *)
  Theorem TerminalObjectUnique : UniqueUpToUniqueIsomorphism (IsTerminalObject (C := C)).
    unique.
  Qed.

  (* The initial object is unique up to unique isomorphism. *)
  Theorem InitialObjectUnique : UniqueUpToUniqueIsomorphism (IsInitialObject (C := C)).
    unique.
  Qed.
End CategoryObjects2.


From FOL.Incompleteness Require Import utils.

From Undecidability.Synthetic Require Import Definitions.
From Undecidability.Synthetic Require Import ReducibilityFacts MoreReducibilityFacts.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

(* * Abstract incompleteness *)
(* ** Formal systems *)

Record FS (S : Type) (neg : S -> S) : Type :=
  mkFS { fprv : S -> Prop
       ; P_semi_decidable : semi_decidable fprv
       ; consistent : forall s, fprv s -> fprv (neg s) -> False }.
Arguments FS : clear implicits.

Arguments consistent {S neg} _ _ _ _.

Notation "fs ⊢F s" := (fs.(fprv) s) (at level 30).
Notation "fs ⊬F s" := (~fs.(fprv) s) (at level 30).

Definition extension {S : Type} {neg : S -> S} (fs1 fs2 : FS S neg) :=
  forall s, fs1 ⊢F s -> fs2 ⊢F s.

Section facts.
  Context {S : Type} {neg : S -> S} (fs : FS S neg).

  (* Properties of formal systems *)
  Definition complete := forall s, fs ⊢F s \/ fs ⊢F neg s.
  Definition independent s := fs ⊬F s /\ fs ⊬F neg s.

  (* Representability properties *)
  Definition weakly_represents (P : nat -> Prop) (r : nat -> S) :=
    forall x, P x <-> fs ⊢F r x.
  Definition sound (P : nat -> Prop) (r : nat -> S) :=
    forall x, fs ⊢F r x -> P x.
  Definition strongly_separates (P1 P2 : nat -> Prop) (r : nat -> S) :=
    (forall x, P1 x -> fs ⊢F r x) /\
    (forall x, P2 x -> fs ⊢F neg (r x)).

  (* Refutability is semi decidable *)
  Lemma refutable_semi_decidable : semi_decidable (fun s => fs ⊢F neg s).
  Proof.

    eapply semi_decidable_red. 2: apply fs.(P_semi_decidable).
    exists neg. firstorder.
  Qed.

  (* There is a function agreeing with provability *)
  Theorem is_provable : exists f : S -\ bool,
    (forall s, fs ⊢F s <-> f s ▷ true) /\
    (forall s, fs ⊢F neg s <-> f s ▷ false).
  Proof.
    apply enumerable_separable.
    - apply fs.(consistent).
    - apply fs.(P_semi_decidable).
    - apply refutable_semi_decidable.
  Qed.

  (* Provability is decidable in complete formal systems *)
  Lemma complete_decidable : complete -> decidable fs.(fprv).
  Proof.
    intros complete. destruct is_provable as [f Hf].
    assert (forall x, exists b, f x ▷ b) as Htotal.
    { intros x. destruct (complete x) as [H|H].
      - exists true. now apply Hf.
      - exists false. now apply Hf. }
    exists (fun x => projT1 (totalise Htotal x)).
    intros x. destruct totalise as [[] Hb]; split; cbn.
    - easy.
    - intros _. now apply Hf.
    - intros H%Hf. eapply part_functional; eassumption.
    - discriminate.
  Qed.

End facts.


Require Export
        Rupicola.Lib.Api
        Rupicola.Lib.Arrays
        Rupicola.Lib.Loops
        Rupicola.Lib.WordNotations
        Rupicola.Examples.Net.IPChecksum.Spec.
Require Import
        bedrock2.FE310CSemantics
        coqutil.Word.Naive
        coqutil.Map.SortedListWord.
#[export]
Existing Instances Word.Naive.word Word.Naive.word32_ok SortedListWord.map SortedListWord.ok.
Notation word := word32.

Coercion co_word_of_Z := word.of_Z (word := word).
Coercion co_word_of_byte (b: byte) : word := word_of_byte b.
#[export] Hint Unfold co_word_of_Z co_word_of_byte : compiler_cleanup.

Definition ip_checksum_upd (chk16: word) (b0 b1: byte) :=
  let/n w16 := b0 |w (b1 <<w 8) in
  let/n chk17 := chk16 +w w16 in
  let/n chk16 := (chk17 &w 0xffff) +w (chk17 >>w 16) in
  chk16.

(* TODO: make a variant that accumulate carries until the end *)
Definition ip_checksum_impl (bs: list byte) : word :=
  let/n chk16 := 0xffff in

  (* Main loop *)
  let/n chk16 :=
    nd_ranged_for_all
      0 (Z.of_nat (List.length bs) / 2)
      (fun chk16 idx =>
         let/n b0 := ListArray.get bs (2 * idx) in
         let/n b1 := ListArray.get bs (2 * idx + 1) in
         let/n chk16 := ip_checksum_upd chk16 b0 b1 in
         chk16) chk16 in

  (* Final iteration *)
  let/n chk16 := if Z.odd (Z.of_nat (List.length bs)) then
                  let/n b0 := ListArray.get bs (Z.of_nat (List.length bs) - 1) in
                  ip_checksum_upd chk16 b0 (Byte.x00)
                else chk16 in

  let/n chk16 := (~w chk16) &w 0xffff in
  chk16.

Section Properties.
  Lemma nat_div2_spec n:
    ((n = 2 * (n / 2) /\ n mod 2 = 0) \/
     (n = 2 * (n / 2) + 1 /\ n mod 2 = 1))%nat.
  Proof.
    pose proof Nat.mod_bound_pos n 2 ltac:(lia) ltac:(lia).
    pose proof (Nat_mod_eq' n 2 ltac:(lia)).
    assert ((n mod 2 = 0) \/ (n mod 2 = 1))%nat as [Heq | Heq] by lia;
      rewrite Heq in *; lia.
  Qed.

  Lemma nd_ranged_for_all_combine2 {A} (f: A -> byte -> byte -> A) (bs: list byte) n acc:
    (n >= length bs)%nat ->
    (let acc := nd_ranged_for_all
                 0 (Z.of_nat n / 2)
                 (fun acc idx =>
                    f acc
                      (ListArray.get bs (2 * idx))
                      (ListArray.get bs (2 * idx + 1)))
                 acc in
     if Z.odd (Z.of_nat n) then f acc (ListArray.get bs (Z.of_nat n - 1)) default
     else acc) =
      (nd_ranged_for_all
         0 (Z.of_nat (Nat.div_up n 2))
         (fun acc idx =>
            f acc
              (ListArray.get bs (2 * idx))
              (ListArray.get bs (2 * idx + 1)))
         acc).
  Proof.
    intros.
    rewrite Nat.div_up_eqn by lia.
    rewrite Nat2Z.inj_add.
    rewrite <- !fold_left_as_nd_ranged_for_all.
    rewrite (z_range_app 0 (Z.of_nat (n / 2)) (_ + _)) by lia.
    rewrite fold_left_app.
    rewrite Nat2Z.inj_div.
    set (fold_left _ (z_range 0 _) _) as prefix.
    rewrite z_range_add, Nat2Z.id.
    rewrite Nat2Z_inj_odd, Natodd_mod.
    destruct (nat_div2_spec n) as [(Heq, ->) | (Heq, ->)];
      cbn [Nat.eqb negb z_range' List.fold_left].
    - reflexivity.
    - rewrite <- Nat2Z.inj_div.
      f_equal.
      + f_equal; lia.
      + unfold ListArray.get, cast, Convertible_Z_nat; rewrite nth_overflow by lia;
          reflexivity.
  Qed.

  Definition word_onec_add16 w1 w2 :=
    let sum := word.add (word := word) w1 w2 in
    word.add (word.and sum (word.of_Z 65535)) (word.sru sum (word.of_Z 16)).

  Lemma word_unsigned_onec_add w1 w2:
    let z1 := word.unsigned w1 in
    let z2 := word.unsigned w2 in
    0 <= z1 < 2 ^ 16 ->
    0 <= z2 < 2 ^ 16 ->
    word.unsigned (word_onec_add16 w1 w2) =
    onec_add16 z1 z2.
  Proof.
    intros; unfold onec_add16, word_onec_add16.
    pose proof Z_land_leq_right (z1 + z2) 0xffff ltac:(lia) ltac:(lia).
    pose proof Z_shiftr_add_carry 16 16 z1 z2 ltac:(lia) ltac:(lia) ltac:(lia).

    all: subst z1 z2.
    repeat (rewrite ?word.unsigned_add, ?word.unsigned_and_nowrap;
            rewrite ?word.unsigned_sru_shamtZ by lia;
            rewrite ?word.unsigned_of_Z_nowrap, ?word.Z_land_wrap_l by lia).
    rewrite_strat (repeat (innermost word.wrap_small)).

    all: lia.
  Qed.

  Lemma word_unsigned_onec_add' z1 z2:
    0 <= z1 < 2 ^ 16 ->
    0 <= z2 < 2 ^ 16 ->
    onec_add16 z1 z2 =
    word.unsigned (word_onec_add16 (word.of_Z z1) (word.of_Z z2)).
  Proof.
    intros; rewrite word_unsigned_onec_add;
      rewrite !word.unsigned_of_Z_nowrap; try lia.
  Qed.

  Lemma word_morph_onec_add z1 z2:
    0 <= z1 < 2 ^ 16 ->
    0 <= z2 < 2 ^ 16 ->
    word.of_Z (onec_add16 z1 z2) = word_onec_add16 (word.of_Z z1) (word.of_Z z2).
  Proof.
    pose proof onec_add16_loose_bounds z1 z2.
    intros; apply word.unsigned_inj;
      rewrite word_unsigned_onec_add;
      rewrite !word.unsigned_of_Z_nowrap; try lia.
  Qed.

  Lemma ip_checksum_impl_ok bs:
    ip_checksum_impl bs = word.of_Z (ip_checksum bs).
  Proof.
    unfold ip_checksum, ip_checksum_impl, nlet, co_word_of_byte, co_word_of_Z.
    rewrite nd_ranged_for_all_combine2 by lia.
    rewrite <- fold_left_as_nd_ranged_for_all.
    rewrite word.morph_and, word.morph_not.
    erewrite fold_left_push_fn
      with (f' := fun w z => word_onec_add16 w (word.of_Z z))
           (P := fun x => in_bounds 16 x); cycle 1.
    { intros.
      eapply onec_add16_bounds; try eassumption.
      eapply (In_map_combine_in_bounds 2); eassumption || lia. }
    { intros * Hin%(In_map_combine_in_bounds 2 ltac:(lia)) Ha0.
      eapply word_morph_onec_add; eassumption. }
    { red; lia. }
    { rewrite (copying_fold_left_as_ranged_fold_left _ (List.map _ _)).
      rewrite map_length, length_chunk by lia.
      do 2 f_equal; apply fold_left_Proper; try reflexivity; []. {
        intros * Hin%z_range_sound.
        unfold ip_checksum_upd, nlet, co_word_of_byte, co_word_of_Z.
        rewrite nth_error_nth' with (d := le_combine [default; default])
          by (rewrite map_length, length_chunk; lia).
        rewrite !map_nth, le_combine_nth_chunk by lia.
        cbn [le_combine seq List.map].
        rewrite word.morph_or, Z.lor_0_r, word.morph_shiftl by lia.
        unfold word_onec_add16, ListArray.get, cast, Convertible_Z_nat.
        repeat (lia || f_equal).
      }
    }
  Qed.

  Lemma ip_checksum_impl_ok' bs:
    ip_checksum bs = word.unsigned (ip_checksum_impl bs).
  Proof.
    rewrite ip_checksum_impl_ok, word.unsigned_of_Z_nowrap.
    - reflexivity.
    - pose proof ip_checksum_bounds bs; lia.
  Qed.
End Properties.


Require Import causal_def.
Require Import preliminaries.

Instance evenat : EventSet nat :=
{ precedence := lt
; synchronisation := eq
}.
Proof.
  - split.
    + unfold Irreflexive. apply lt_irrefl.
    + unfold Transitive. apply lt_trans.
  - constructor.
    + unfold Reflexive. reflexivity.
    + unfold Transitive. intros * Exy Eyz.
      rewrite Exy. rewrite Eyz. reflexivity.
    + unfold Symmetric. intros * Exy. rewrite Exy. reflexivity.
  - intros * Exx' Eyy' Lxy. rewrite Exx' in Lxy. rewrite Eyy' in Lxy.
    assumption.
Defined.

Lemma Botnat_ininat : forall n : nat, Bot nat n = ininat n.
Proof.
  intro. pose (H := Extensionality_Ensembles nat). apply H.
  constructor; compute; intros m H1; elim H1.
  - intro H2. destruct H2 as [| n'].
    + constructor 2. constructor.
    + assert (H3 : m <= S m). constructor 2. constructor.
      pose (H4 := le_trans m (S m) n'). pose (H5 := H4 H3 H2).
      constructor 2. assumption.
  - intro H2. rewrite H2. constructor.
  - right. reflexivity.
  - intros k H2 H3. left. elim H3; intro H4.
    + constructor 2. assumption.
    + rewrite H4. constructor.
Qed.

Instance caunat : Causet nat.
Proof.
  constructor.
  - intro. exists (S x). simpl. apply le_n.
  - intro. rewrite Botnat_ininat. apply fin_ininat.
Defined.


Require Import Coq.Lists.List.

Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedFix.

Opaque reducible_values.

Lemma annotated_reducible_fix_strong_induction:
  forall Θ Γ ts T n y p,
    ~(n ∈ fv_context Γ) ->
    ~(y ∈ fv_context Γ) ->
    ~(p ∈ fv_context Γ) ->
    ~(n ∈ fv T) ->
    ~(n ∈ fv ts) ->
    ~(y ∈ fv T) ->
    ~(y ∈ fv ts) ->
    ~(p ∈ fv T) ->
    ~(p ∈ fv ts) ->
    ~(n ∈ Θ) ->
    ~(y ∈ Θ) ->
    ~(p ∈ Θ) ->
    NoDup (n :: y :: p :: nil) ->
    wf (erase_term ts) 1 ->
    wf T 1 ->
    subset (fv T) (support Γ) ->
    subset (fv ts) (support Γ) ->
    is_annotated_type T ->
    is_annotated_term ts ->
    cbv_value (erase_term ts) ->
    [[ Θ;
        (p, T_equiv (fvar y term_var) (tfix T ts)) ::
        (y, T_forall (T_refine T_nat (binary_primitive Lt (lvar 0 term_var) (fvar n term_var))) T) ::
        (n, T_nat) ::
        Γ ⊨
        open 0 (open 1 ts (fvar n term_var)) (fvar y term_var) :
        open 0 T (fvar n term_var) ]]
    ->
    [[ Θ; Γ ⊨ tfix T ts : T_forall T_nat T ]].
Proof.
  intros; apply open_reducible_fix_strong_induction with n y p;
    repeat step || erase_open ||
           (rewrite (open_none (erase_term ts)) in * by auto) ||
           (rewrite erase_type_shift in *);
    side_conditions.
Qed.