(** introduces monoidal actions in a bicategorical setting

    This lifts to bicategories the view on actions as put forward in G. Janelidze and G.M. Kelly: A Note on Actions of a Monoidal Category, Theory and Applications of Categories, Vol. 9, 2001, No. 4, pp 61-91.
    The strength notion for the morphisms between actions is taken from
    B. Ahrens, R. Matthes and A. Mörtberg: Implementing a category-theoretic framework for typed abstract syntax, Proceedings CPP'22.

Authors: Ralph Matthes and Kobe Wullaert 2022
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.WhiskeredDisplayedBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.Monoidal.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.TotalMonoidal.
Require Import UniMath.CategoryTheory.Monoidal.Displayed.MonoidalSections.
Require Import UniMath.Bicategories.MonoidalCategories.EndofunctorsWhiskeredMonoidal.

Require Import UniMath.Bicategories.MonoidalCategories.WhiskeredMonoidalFromBicategory.
Require Import UniMath.Bicategories.MonoidalCategories.ActionBasedStrongFunctorsWhiskeredMonoidal.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.Core.Invertible_2cells.

Import Bicat.Notations.
Import BifunctorNotations.
Import DisplayedBifunctorNotations.

Local Open Scope cat.
Section FixMoncatAndBicat.

  Context {V : category}.
  Context (Mon_V : monoidal V).

  Notation "X ⊗ Y" := (X ⊗_{ Mon_V } Y).

  Context (B : bicat).

  Definition disp_actionbicat_disp_mor {a0 a0' : B}
  {FA : V ⟶ category_from_bicat_and_ob a0}
  (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA)
  {FA' : V ⟶ category_from_bicat_and_ob a0'}
  (FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0') FA')
  (G : B ⟦ a0, a0' ⟧): UU :=
    ∑ δ : parameterized_distributivity_bicat_nat G,
                param_distr_bicat_triangle_eq Mon_V FAm FA'm G δ ×
                  param_distr_bicat_pentagon_eq Mon_V FAm FA'm G δ.

  Lemma disp_actionbicat_disp_mor_eq {a0 a0' : B}
  {FA : V ⟶ category_from_bicat_and_ob a0}
  {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA}
  {FA' : V ⟶ category_from_bicat_and_ob a0'}
  {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0') FA'}
  {G : B ⟦ a0, a0' ⟧}
  (pm1 pm2: disp_actionbicat_disp_mor FAm FA'm G):
    pr1 pm1 = pr1 pm2 -> pm1 = pm2.
  Proof.
    intro Hyp.
    apply subtypePath.
    - intro δ. apply isapropdirprod.
      + apply isaprop_param_distr_bicat_triangle_eq.
      + apply isaprop_param_distr_bicat_pentagon_eq.
    - exact Hyp.
  Qed.

  Definition disp_actionbicat_disp_ob_mor : disp_cat_ob_mor B.
  Proof.
    use tpair.
    - intro a0.
      exact (∑ FA: functor V (category_from_bicat_and_ob a0),
                fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA).
    - intros a0 a0' [FA FAm] [FA' FA'm] G.
      exact (disp_actionbicat_disp_mor FAm FA'm G).
  Defined.

  Definition disp_actionbicat_disp_id_nat_trans
  {a : B}
  {FA : V ⟶ category_from_bicat_and_ob a}
  (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a) FA):
    H(V:=V)(FA':=FA) (id₁ a) ⟹ H'(FA:=FA) (id₁ a).
  Proof.
    use make_nat_trans.
    * intro v. cbn. exact (lunitor _ • rinvunitor _).
    * abstract ( intros v w f;
                 cbn;
                 rewrite vassocr;
                 rewrite vcomp_lunitor;
                 do 2 rewrite vassocl;
                 apply maponpaths;
                 apply pathsinv0, (rhs_right_inv_cell _ _ _ (is_invertible_2cell_runitor _));
                 rewrite vassocl;
                 rewrite vcomp_runitor;
                 rewrite vassocr;
                 rewrite rinvunitor_runitor;
                 apply id2_left ).
  Defined.

  Lemma disp_actionbicat_disp_id_triangle {a : B}
  {FA : V ⟶ category_from_bicat_and_ob a}
  (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a) FA):
    param_distr_bicat_triangle_eq Mon_V FAm FAm (id₁ a) (disp_actionbicat_disp_id_nat_trans FAm).
  Proof.
    red; cbn.
    rewrite vassocr.
    rewrite vcomp_lunitor.
    do 2 rewrite vassocl.
    rewrite lunitor_id_is_left_unit_id.
    apply maponpaths.
    apply pathsinv0, (rhs_right_inv_cell _ _ _ (is_invertible_2cell_runitor _)).
    rewrite vassocl.
    apply pathsinv0, (rhs_left_inv_cell _ _ _ (is_invertible_2cell_lunitor _)).
    rewrite vcomp_runitor.
    rewrite lunitor_id_is_left_unit_id.
    apply idpath.
  Qed.

  Lemma disp_actionbicat_disp_id_pentagon {a : B}
    {FA : V ⟶ category_from_bicat_and_ob a}
    (FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a) FA):
    param_distr_bicat_pentagon_eq Mon_V FAm FAm (id₁ a) (disp_actionbicat_disp_id_nat_trans FAm).
  Proof.
    red; cbn.
    intros v w.
    unfold param_distr_bicat_pentagon_eq_body, param_distr_bicat_pentagon_eq_body_RHS.
    cbn.
    etrans.
    { rewrite vassocl. apply maponpaths. rewrite vassocr. apply maponpaths_2.
      apply vcomp_lunitor. }
    etrans.
    { repeat rewrite vassocr. apply idpath. }
    apply pathsinv0, (rhs_right_inv_cell _ _ _ (is_invertible_2cell_runitor _)).
    etrans.
    { rewrite !vassocl. (* instead of repeat rewrite vassocl - hint by Niels van der Weide *) apply idpath. }
    rewrite vcomp_runitor.
    repeat rewrite vassocr. apply maponpaths_2.
    (* now pure bicategorical reasoning *)
    rewrite <- rwhisker_vcomp.
    rewrite <- lwhisker_vcomp.
    rewrite <- runitor_triangle.
    rewrite <- lunitor_triangle.
    etrans.
    2: { rewrite vassocr.
         rewrite rassociator_lassociator.
         apply pathsinv0, id2_left. }
    etrans.
    { repeat rewrite vassocr. apply maponpaths_2.
      repeat rewrite vassocl. rewrite lassociator_rassociator.
      rewrite id2_right. apply idpath. }
    repeat rewrite vassocl.
    etrans.
    { do 4 apply maponpaths.
      rewrite lwhisker_vcomp.
      rewrite rinvunitor_runitor.
      apply lwhisker_id2. }
    rewrite id2_right.
    etrans.
    2: { apply id2_right. }
    apply maponpaths.
    rewrite lunitor_lwhisker.
    rewrite rwhisker_vcomp.
    rewrite rinvunitor_runitor.
    apply id2_rwhisker.
  Qed.

  Definition disp_actionbicat_disp_comp_nat_trans_data {a0 a1 a2 : B}
      {g1 : B ⟦ a0, a1 ⟧}
      {g2 : B ⟦ a1, a2 ⟧}
      {FA : V ⟶ category_from_bicat_and_ob a0}
      {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA}
      {FA' : V ⟶ category_from_bicat_and_ob a1}
      {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'}
      {FA'' : V ⟶ category_from_bicat_and_ob a2}
      {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''}
      (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1)
      (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2):
    nat_trans_data (H(V:=V)(FA':=FA'') (g1 · g2)) (H'(FA:=FA) (g1 · g2)).
  Proof.
    intro v. cbn.
    exact (rassociator g1 g2 (FA'' v)
             • ((g1 ◃ (pr1 Hyp2 v))
             • ((lassociator g1 (FA' v) g2
             • ((pr1 Hyp1 v) ▹ g2) : g1 · H' g2 v ==> FA v · g1 · g2)
             • rassociator (FA v) g1 g2))).
    (* refine (vcomp2 _ _).
       { apply rassociator. }
       refine (vcomp2 _ _).
       { apply lwhisker.
       apply Hyp2. }
       refine (vcomp2 _ _).
       2: { apply rassociator. }
       cbn.
       refine (vcomp2 _ _).
       { apply lassociator. }
       apply rwhisker.
       apply Hyp1. *)
  Defined.

  Lemma disp_actionbicat_disp_comp_is_nat_trans {a0 a1 a2 : B}
    {g1 : B ⟦ a0, a1 ⟧}
    {g2 : B ⟦ a1, a2 ⟧}
    {FA : V ⟶ category_from_bicat_and_ob a0}
    {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA}
    {FA' : V ⟶ category_from_bicat_and_ob a1}
    {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'}
    {FA'' : V ⟶ category_from_bicat_and_ob a2}
    {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''}
    (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1)
    (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2):
    is_nat_trans _ _ (disp_actionbicat_disp_comp_nat_trans_data Hyp1 Hyp2).
  Proof.
    intros v w f. unfold disp_actionbicat_disp_comp_nat_trans_data.
    cbn; rewrite vassocr.

    rewrite (! lwhisker_lwhisker_rassociator _ _ _ _ _ _ _ _ _).
    rewrite vassocr.
    etrans. {
      apply maponpaths_2.
      rewrite vassocl.
      apply maponpaths.
      exact (lwhisker_vcomp g1  (g2 ◃ # FA'' f) (pr1 Hyp2 w)).
    }

    etrans.
    2: {
      rewrite !vassocr.
      rewrite vassocl.
      apply maponpaths.
      apply rwhisker_rwhisker_alt.
    }

    rewrite !vassocl.
    apply maponpaths.
    rewrite !vassocr.
    apply maponpaths_2.
    etrans. {
      apply maponpaths_2.
      apply maponpaths_2.
      apply maponpaths.
      exact (pr21 Hyp2 v w f).
    }
    etrans.
    2: {
      rewrite vassocl.
      apply maponpaths.
      rewrite rwhisker_vcomp.
      apply maponpaths.
      exact (pr21 Hyp1 v w f).
    }

    cbn.
    rewrite (! lwhisker_vcomp _ _ _).

    do 3 rewrite vassocl.
    apply maponpaths.
    rewrite vassocr.
    etrans.
    2: {
      rewrite (! rwhisker_vcomp _ _ _).
      rewrite vassocr.
      apply idpath.
    }
    apply maponpaths_2.
    apply rwhisker_lwhisker.
  Qed.

  Definition disp_actionbicat_disp_comp_nat_trans {a0 a1 a2 : B}
    {g1 : B ⟦ a0, a1 ⟧}
    {g2 : B ⟦ a1, a2 ⟧}
    {FA : V ⟶ category_from_bicat_and_ob a0}
    {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA}
    {FA' : V ⟶ category_from_bicat_and_ob a1}
    {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'}
    {FA'' : V ⟶ category_from_bicat_and_ob a2}
    {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''}
    (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1)
    (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2):
    parameterized_distributivity_bicat_nat(V:=V)(FA:=FA)(FA':=FA'') (g1 · g2) :=
    _,, disp_actionbicat_disp_comp_is_nat_trans Hyp1 Hyp2.

  Lemma disp_actionbicat_disp_comp_triangle {a0 a1 a2 : B}
    {g1 : B ⟦ a0, a1 ⟧}
    {g2 : B ⟦ a1, a2 ⟧}
    {FA : V ⟶ category_from_bicat_and_ob a0}
    {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA}
    {FA' : V ⟶ category_from_bicat_and_ob a1}
    {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'}
    {FA'' : V ⟶ category_from_bicat_and_ob a2}
    {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''}
    (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1)
    (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2):
    param_distr_bicat_triangle_eq Mon_V FAm FA''m (g1 · g2) (disp_actionbicat_disp_comp_nat_trans Hyp1 Hyp2).
  Proof.
    red; cbn.
    unfold disp_actionbicat_disp_comp_nat_trans_data.
    assert (aux1 := pr12 Hyp1).
    assert (aux2 := pr12 Hyp2).
    apply param_distr_bicat_triangle_eq_variant0_follows in aux1.
    apply param_distr_bicat_triangle_eq_variant0_follows in aux2.
    red in aux1, aux2; cbn in aux1, aux2.
    rewrite aux1, aux2.
    clear Hyp1 Hyp2 aux1 aux2.
    unfold param_distr_bicat_triangle_eq_variant0_RHS.
    repeat rewrite <- lwhisker_vcomp.
    repeat rewrite <- rwhisker_vcomp.
    etrans.
    { repeat rewrite lassocr.
      apply maponpaths.
      repeat rewrite vassocr.
      rewrite lwhisker_lwhisker_rassociator.
      apply idpath. }
    etrans.
    { repeat rewrite vassocr.
      do 10 apply maponpaths_2.
      rewrite lwhisker_vcomp.
      apply maponpaths.
      apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservesunitstrongly FA''m)). }
    cbn.
    rewrite lwhisker_id2.
    rewrite id2_left.
    etrans.
    { repeat rewrite vassocl.
      do 3 apply maponpaths.
      repeat rewrite vassocr.
      do 5 apply maponpaths_2.
      apply rwhisker_lwhisker. }
    etrans.
    { repeat rewrite vassocr.
      do 4 apply maponpaths_2.
      repeat rewrite vassocl.
      do 4 apply maponpaths.
      rewrite rwhisker_vcomp.
      rewrite lwhisker_vcomp.
      do 2 apply maponpaths.
      apply (z_iso_inv_after_z_iso (_,,fmonoidal_preservesunitstrongly FA'm)). }
    cbn.
    rewrite lwhisker_id2.
    rewrite id2_rwhisker.
    rewrite id2_right.
    etrans.
    { repeat rewrite vassocl.
      rewrite rwhisker_rwhisker_alt.
      apply idpath. }
    repeat rewrite vassocr.
    apply maponpaths_2.
    (* now pure bicategorical reasoning *)
    rewrite <- runitor_triangle.
    apply (rhs_right_inv_cell _ _ _ (is_invertible_2cell_lunitor _)).
    rewrite <- lunitor_triangle.
    repeat rewrite vassocr.
    etrans.
    { apply maponpaths_2.
      repeat rewrite vassocl.
      rewrite rassociator_lassociator.
      rewrite id2_right.
      apply idpath. }
    etrans.
    { repeat rewrite vassocl.
      rewrite rwhisker_vcomp.
      rewrite linvunitor_lunitor.
      rewrite id2_rwhisker.
      rewrite id2_right.
      apply idpath. }
    etrans.
    2: { apply id2_right. }
    repeat rewrite vassocl.
    do 2 apply maponpaths.
    rewrite runitor_rwhisker.
    rewrite lwhisker_vcomp.
    rewrite linvunitor_lunitor.
    apply lwhisker_id2.
  Qed.

  Lemma disp_actionbicat_disp_comp_pentagon {a0 a1 a2 : B}
    {g1 : B ⟦ a0, a1 ⟧}
    {g2 : B ⟦ a1, a2 ⟧}
    {FA : V ⟶ category_from_bicat_and_ob a0}
    {FAm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a0) FA}
    {FA' : V ⟶ category_from_bicat_and_ob a1}
    {FA'm : fmonoidal Mon_V (monoidal_from_bicat_and_ob a1) FA'}
    {FA'' : V ⟶ category_from_bicat_and_ob a2}
    {FA''m : fmonoidal Mon_V (monoidal_from_bicat_and_ob a2) FA''}
    (Hyp1 : disp_actionbicat_disp_mor FAm FA'm g1)
    (Hyp2 : disp_actionbicat_disp_mor FA'm FA''m g2):
    param_distr_bicat_pentagon_eq Mon_V FAm FA''m (g1 · g2) (disp_actionbicat_disp_comp_nat_trans Hyp1 Hyp2).
  Proof.
    intros v w.
    red; cbn.
    unfold param_distr_bicat_pentagon_eq_body_RHS,
      disp_actionbicat_disp_comp_nat_trans, disp_actionbicat_disp_comp_nat_trans_data.
    set (aux1 := pr22 Hyp1 v w).
    set (aux2 := pr22 Hyp2 v w).
    apply param_distr_bicat_pentagon_eq_body_variant_follows in aux1.
    apply param_distr_bicat_pentagon_eq_body_variant_follows in aux2.
    red in aux1, aux2; cbn in aux1, aux2.
    rewrite aux1, aux2.
    clear aux1 aux2.
    unfold param_distr_bicat_pentagon_eq_body_variant_RHS, param_distr_bicat_pentagon_eq_body_RHS.
    induction Hyp1 as [δ1 [trieq1 pentaeq1]].
    induction Hyp2 as [δ2 [trieq2 pentaeq2]].
    cbn.
    clear trieq1 trieq2 pentaeq1 pentaeq2.
    repeat rewrite rwhisker_vcomp.
    repeat rewrite <- lwhisker_vcomp.
    etrans.
    { repeat rewrite vassocl.
      apply maponpaths.
      repeat rewrite vassocr.
      do 10 apply maponpaths_2.
      apply pathsinv0, lwhisker_lwhisker_rassociator. }
    etrans.
    { repeat rewrite vassocl.
      do 2 apply maponpaths.
      repeat rewrite vassocr.
      do 9 apply maponpaths_2.
      etrans.
      { rewrite lwhisker_vcomp.
        apply maponpaths.
        rewrite lwhisker_vcomp.
        apply maponpaths.
        apply (pr2 (fmonoidal_preservestensorstrongly FA''m v w)). }
      cbn.
      rewrite lwhisker_id2.
      apply lwhisker_id2.
    }
    rewrite id2_left.
    etrans.
    { repeat rewrite vassocr.
      apply idpath. }
    apply pathsinv0.
    apply (vcomp_move_L_Vp _ _ _ (is_invertible_2cell_lassociator _ _ _)).
    etrans.
    { repeat rewrite vassocl.
      do 8 apply maponpaths.
      apply pathsinv0, rwhisker_rwhisker. }
    repeat rewrite <- rwhisker_vcomp.
    repeat rewrite vassocr.
    apply maponpaths_2.
    etrans.
    2: { do 5 apply maponpaths_2.
         repeat rewrite vassocl.
         do 7 apply maponpaths.
         etrans.
         2: { rewrite vassocr.
              apply maponpaths_2.
              apply pathsinv0, rwhisker_lwhisker. }
         rewrite vassocl.
         apply maponpaths.
         rewrite rwhisker_vcomp.
         apply maponpaths.
         rewrite lwhisker_vcomp.
         apply maponpaths.
         apply pathsinv0, (pr2 (fmonoidal_preservestensorstrongly FA'm v w)). }
    cbn.
    rewrite lwhisker_id2.
    rewrite id2_rwhisker.
    rewrite id2_right.
    (* the equation is now free from the preservation of the tensor by the given strong monoidal functors;
       both sides of the equation are chains of 13 two-cells *)
    etrans.
    2: { repeat rewrite vassocl.
         do 6 apply maponpaths.
         repeat rewrite vassocr.
         do 4 apply maponpaths_2.
         apply pathsinv0, lassociator_lassociator. }
    etrans.
    { repeat rewrite vassocl.
      do 4 apply maponpaths.
      repeat rewrite vassocr.
      do 6 apply maponpaths_2.
      apply rassociator_rassociator. }
    (* both sides of the equation are chains of 12 two-cells *)
    etrans.
    2: { repeat rewrite vassocr.
         do 10 apply maponpaths_2.
         apply rassociator_rassociator. }
    repeat rewrite vassocl.
    apply maponpaths.
    etrans.
    2: { repeat rewrite vassocr.
         do 8 apply maponpaths_2.
         etrans.
         2: { apply maponpaths_2.
              rewrite vassocl.
              etrans.
              2: { apply maponpaths.
                   rewrite lwhisker_vcomp.
                   apply maponpaths.
                   apply pathsinv0, rassociator_lassociator. }
              rewrite lwhisker_id2.
              apply pathsinv0, id2_right. }
         apply pathsinv0, rwhisker_lwhisker_rassociator.
    }
    repeat rewrite vassocl.
    apply maponpaths.
    (* two occurrences of [δ2] vanished *)
    etrans.
    { apply maponpaths.
      repeat rewrite vassocr.
      do 5 apply maponpaths_2.
      rewrite rwhisker_rwhisker_alt.
        rewrite vassocl.
        rewrite lwhisker_lwhisker_rassociator.
        rewrite vassocl.
        apply maponpaths.
        rewrite vassocr.
        apply maponpaths_2.
        apply vcomp_whisker. }
    etrans.
    2: { do 2 apply maponpaths.
         repeat rewrite vassocr.
         do 3 apply maponpaths_2.
         rewrite lwhisker_lwhisker.
         rewrite vassocl.
         rewrite rwhisker_rwhisker.
         apply idpath.
    }
    assert (Haux: (lassociator g1 (FA' v) g2 ▹ FA'' w) • rassociator (g1 · FA' v) g2 (FA'' w) =
                    rassociator g1 (FA' v · g2) (FA'' w) • (g1 ◃ rassociator (FA' v) g2 (FA'' w)) • lassociator g1 (FA' v) (g2 · FA'' w)).
    { etrans.
      2: { rewrite vassocl.
           apply inverse_pentagon_2. }
      apply maponpaths_2.
      apply pathsinv0, hcomp_identity_right. }
    etrans.
    { repeat rewrite vassocr.
      do 8 apply maponpaths_2.
      apply Haux. }
    clear Haux.
    repeat rewrite vassocl.
    do 5 apply maponpaths.
    (* two occurrences of [δ1] and [δ2] vanished
       ten two-cells remain, one occurrence of [δ1] on both sides *)
    assert (Haux2: rassociator (FA v) g1 (FA' w · g2) • (FA v ◃ lassociator g1 (FA' w) g2) =
                     lassociator (FA v · g1) (FA' w) g2 • ((rassociator (FA v) g1 (FA' w) ▹ g2) • rassociator (FA v) (g1 · FA' w) g2)).
    { rewrite <- hcomp_identity_right.
      etrans.
      2: { apply inverse_pentagon_4. }
      rewrite hcomp_identity_left.
      apply idpath.
    }
    etrans.
    { repeat rewrite vassocr.
      do 4 apply maponpaths_2.
      exact Haux2. }
    clear Haux2.
    repeat rewrite vassocl.
    do 2 apply maponpaths.
    etrans.
    { repeat rewrite vassocr.
      do 3 apply maponpaths_2.
      apply rwhisker_lwhisker_rassociator. }
    repeat rewrite vassocl.
    apply maponpaths.
    (* no more [δ1] nor [δ2] *)
    etrans.
    { repeat rewrite vassocr.
      apply maponpaths_2.
      rewrite vassocl.
      apply pathsinv0, inverse_pentagon_2. }
    rewrite vassocl.
    rewrite rassociator_lassociator.
    rewrite hcomp_identity_right.
    apply id2_right.
  Qed.

  Definition disp_actionbicat_disp_id_comp : disp_cat_id_comp B disp_actionbicat_disp_ob_mor.
  Proof.
    split.
    - intros a [FA FAm].
      use tpair.
      + exact (disp_actionbicat_disp_id_nat_trans FAm).
      + split; [apply disp_actionbicat_disp_id_triangle | apply disp_actionbicat_disp_id_pentagon]; assumption.
    - intros a0 a1 a2 g1 g2 [FA FAm] [FA' FA'm] [FA'' FA''m] Hyp1 Hyp2. cbn in Hyp1, Hyp2.
      exists (disp_actionbicat_disp_comp_nat_trans Hyp1 Hyp2).
      + split; [apply disp_actionbicat_disp_comp_triangle | apply disp_actionbicat_disp_comp_pentagon]; assumption.
  Defined.

  Definition disp_actionbicat_disp_catdata : disp_cat_data B
    := (disp_actionbicat_disp_ob_mor,,disp_actionbicat_disp_id_comp).

  Definition bidisp_actionbicat_disp_2cell_eq_body
    {a a' : B}
    {f1 f2 : B ⟦ a, a' ⟧}
    (η : f1 ==> f2)
    (FA : V ⟶ category_from_bicat_and_ob a)
    (FA' : V ⟶ category_from_bicat_and_ob a')
    (δ1 : parameterized_distributivity_bicat_nat f1)
    (δ2 : parameterized_distributivity_bicat_nat f2)
    (v : V): UU
    := δ1 v • (FA v ◃ η) = (η ▹ FA' v) • δ2 v.

  Lemma isaprop_bidisp_actionbicat_disp_2cell_eq_body
    {a a' : B}
    {f1 f2 : B ⟦ a, a' ⟧}
    (η : f1 ==> f2)
    (FA : V ⟶ category_from_bicat_and_ob a)
    (FA' : V ⟶ category_from_bicat_and_ob a')
    (δ1 : parameterized_distributivity_bicat_nat f1)
    (δ2 : parameterized_distributivity_bicat_nat f2)
    (v : V): isaprop (bidisp_actionbicat_disp_2cell_eq_body η FA FA' δ1 δ2 v).
  Proof.
    apply B.
  Qed.

  Definition bidisp_actionbicat_disp_2cell_struct : disp_2cell_struct disp_actionbicat_disp_ob_mor.
  Proof.
    intros a a' f1 f2 η [FA FAm] [FA' FA'm] [δ1 [tria1 penta1]] [δ2 [tria2 penta2]].
    exact (∏ v: V, bidisp_actionbicat_disp_2cell_eq_body η FA FA' δ1 δ2 v).
  Defined.

  Lemma isaprop_bidisp_actionbicat_disp_2cell_struct
    {a a' : B}
    {f1 f2 : B ⟦ a, a' ⟧}
    (η : f1 ==> f2)
    {M : disp_actionbicat_disp_catdata a}
    {M' : disp_actionbicat_disp_catdata a'}
    (FM1 : M -->[ f1] M')
    (FM2 : M -->[ f2] M'):
    isaprop (bidisp_actionbicat_disp_2cell_struct a a' f1 f2 η M M' FM1 FM2).
  Proof.
    apply impred.
    intro v.
    apply isaprop_bidisp_actionbicat_disp_2cell_eq_body.
  Qed.

  Definition bidisp_actionbicat_disp_prebicat_1_id_comp_cells
    :  disp_prebicat_1_id_comp_cells B
    := (disp_actionbicat_disp_catdata,, bidisp_actionbicat_disp_2cell_struct).

  Ltac aux_bidisp_actionbicat_disp_prebicat_ops :=
      intros; red; cbn;
      unfold bidisp_actionbicat_disp_2cell_struct, bidisp_actionbicat_disp_2cell_eq_body;
      intro v;
      unfold disp_actionbicat_disp_comp_nat_trans, disp_actionbicat_disp_comp_nat_trans_data;
      cbn; show_id_type.

  Definition actionbicat_ax2 : UU :=
  (∏ (a b c d : B) (f : B ⟦ a, b ⟧) (g : B ⟦ b, c ⟧) (h : B ⟦ c, d ⟧)
  (w : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a)
  (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b)
  (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c)
  (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells d) (ff : w -->[ f] x)
  (gg : x -->[ g] y) (hh : y -->[ h] z),
  disp_2cells (rassociator f g h) (ff ;; gg ;; hh) (ff ;; (gg ;; hh)))
 × (∏ (a b c d : B) (f : B ⟦ a, b ⟧) (g : B ⟦ b, c ⟧) (h : B ⟦ c, d ⟧)
    (w : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a)
    (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b)
    (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c)
    (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells d) (ff : w -->[ f] x)
    (gg : x -->[ g] y) (hh : y -->[ h] z),
    disp_2cells (lassociator f g h) (ff ;; (gg ;; hh)) (ff ;; gg ;; hh))
   × (∏ (a b : B) (f g h : B ⟦ a, b ⟧) (r : f ==> g) (s : g ==> h)
      (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a)
      (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b) (ff : x -->[ f] y)
      (gg : x -->[ g] y) (hh : x -->[ h] y),
      disp_2cells r ff gg → disp_2cells s gg hh → disp_2cells (r • s) ff hh)
     × (∏ (a b c : B) (f : B ⟦ a, b ⟧) (g1 g2 : B ⟦ b, c ⟧) (r : g1 ==> g2)
        (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a)
        (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b)
        (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c) (ff : x -->[ f] y)
        (gg1 : y -->[ g1] z) (gg2 : y -->[ g2] z),
        disp_2cells r gg1 gg2 → disp_2cells (f ◃ r) (ff ;; gg1) (ff ;; gg2))
       × (∏ (a b c : B) (f1 f2 : B ⟦ a, b ⟧) (g : B ⟦ b, c ⟧) (r : f1 ==> f2)
          (x : bidisp_actionbicat_disp_prebicat_1_id_comp_cells a)
          (y : bidisp_actionbicat_disp_prebicat_1_id_comp_cells b)
          (z : bidisp_actionbicat_disp_prebicat_1_id_comp_cells c) (ff1 : x -->[ f1] y)
          (ff2 : x -->[ f2] y) (gg : y -->[ g] z),
         disp_2cells r ff1 ff2 → disp_2cells (r ▹ g) (ff1 ;; gg) (ff2 ;; gg)).

  Context (ax2 : actionbicat_ax2).

  Lemma bidisp_actionbicat_disp_prebicat_ops :
    disp_prebicat_ops bidisp_actionbicat_disp_prebicat_1_id_comp_cells.
  Proof.
    split; [| split; [| split ; [| split ; [| split]]]].
    (*repeat split; intros; red ; cbn;
      unfold bidisp_actionbicat_disp_2cell_struct, bidisp_actionbicat_disp_2cell_eq_body;
      intro v;
      unfold disp_actionbicat_disp_comp_nat_trans, disp_actionbicat_disp_comp_nat_trans_data;
      cbn; show_id_type. *)
    - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite lwhisker_id2. rewrite id2_right.
      rewrite id2_rwhisker. apply pathsinv0, id2_left.
    - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite <- rwhisker_vcomp.
      etrans.
      { repeat rewrite vassocl. do 5 apply maponpaths.
        apply 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.
      apply (lhs_left_invert_cell _ _ _ (is_invertible_2cell_rassociator _ _ _)).
      cbn.
      apply pathsinv0, lunitor_triangle.
    - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite <- lwhisker_vcomp.
      etrans.
      {
        repeat rewrite vassocl.
        do 5 apply maponpaths.
        apply runitor_triangle.
      }

      etrans. {
        do 2 apply maponpaths.
        rewrite vassocr.
        apply maponpaths_2.
        apply rinvunitor_triangle.
      }
      rewrite vcomp_runitor.
      etrans. {
        do 2 apply maponpaths.
        rewrite vassocr.
        rewrite rinvunitor_runitor.
        apply id2_left.
      }
      rewrite vassocr.
      apply maponpaths_2.
      apply lunitor_lwhisker.
    - aux_bidisp_actionbicat_disp_prebicat_ops. etrans.
      2: {
        do 3 apply maponpaths.
        apply maponpaths_2.
        rewrite <- rwhisker_vcomp.
        rewrite vassocr.
        apply maponpaths_2.
        apply (! lunitor_triangle _ _ _ _ _ _).
      }
      etrans.
      2: {
        do 2 apply maponpaths.
        rewrite vassocr.
        apply maponpaths_2.
        rewrite vassocr.
        apply maponpaths_2.
        apply (! vcomp_lunitor _ _ _).
      }

      rewrite vassocr.
      rewrite <- linvunitor_assoc.
      rewrite !vassocr.
      rewrite linvunitor_lunitor.
      rewrite id2_left.
      rewrite vassocl.
      apply maponpaths.
      rewrite (! hcomp_identity_right _ _ _ _).
      rewrite (! hcomp_identity_left _ _ _ _).
      apply triangle_r_inv.
    - aux_bidisp_actionbicat_disp_prebicat_ops. rewrite <- lwhisker_vcomp.
      etrans.
      2: {
        apply maponpaths.
        rewrite vassocr.
        apply maponpaths_2.
        rewrite vassocr.
        apply maponpaths_2.
        apply (! lunitor_lwhisker _ _).
      }
      (* Search (lassociator _ _ (id₁ _)). *)
      etrans.
      2: {
        apply maponpaths.
        rewrite vassocl.
        apply maponpaths.
        rewrite vassocr.
        apply maponpaths_2.
        rewrite vassocr.
        apply maponpaths_2.
        apply (! rinvunitor_triangle  _ _ _ _ _ _).
      }
      rewrite vassocr.
      rewrite rwhisker_vcomp.
      rewrite rinvunitor_runitor.
      rewrite id2_rwhisker.
      rewrite id2_left.
      rewrite left_unit_inv_assoc.
      rewrite vassocr.
      apply maponpaths_2.
      rewrite rinvunitor_natural.
      apply maponpaths.
      apply hcomp_identity_right.
    - exact ax2.

  (* probably not useful for 10th goal after splitting:
      induction x as [FA FAm].
      induction y as [FA' FA'm].
      induction f' as [δ [tria penta]].
      cbn.
      red in tria, penta. unfold param_distr_bicat_pentagon_eq_body in penta.
      (* assert (δnat := pr2 δ). red in δnat.
      unfold H, H' in δnat. cbn in δnat.
      rewrite hcomp_identity_left in δnat; rewrite hcomp_identity_right in δnat. *)
       *)

  Qed.

  Definition bidisp_actionbicat_disp_prebicat_data : disp_prebicat_data B
    := (bidisp_actionbicat_disp_prebicat_1_id_comp_cells,, bidisp_actionbicat_disp_prebicat_ops).

  Definition bidisp_actionbicat_disp_prebicat_laws : disp_prebicat_laws bidisp_actionbicat_disp_prebicat_data.
  Proof.
    repeat split; intro; intros; apply isaprop_bidisp_actionbicat_disp_2cell_struct.
  Qed.

  Definition bidisp_actionbicat_disp_prebicat : disp_prebicat B
    := (bidisp_actionbicat_disp_prebicat_data,,bidisp_actionbicat_disp_prebicat_laws).

  Definition bidisp_actionbicat_disp_bicat : disp_bicat B.
  Proof.
    refine (bidisp_actionbicat_disp_prebicat,, _).
    intros a a' f1 f2 η M M' FM1 FM2.
    apply isasetaprop.
    apply isaprop_bidisp_actionbicat_disp_2cell_struct.
  Defined.

  Lemma actionbicat_disp_2cells_isaprop : disp_2cells_isaprop bidisp_actionbicat_disp_bicat.
  Proof.
    red.
    intros.
    apply isaprop_bidisp_actionbicat_disp_2cell_struct.
  Qed.

  Definition bicatactionbicat : bicat := total_bicat bidisp_actionbicat_disp_bicat.

  Lemma actionbicat_disp_locally_groupoid : disp_locally_groupoid bidisp_actionbicat_disp_bicat.
  Proof.
    red. intros a a' f1 f2 ηinvertible [FA FAm] [FA' FA'm] [δ1 [tria1 penta1]] [δ2 [tria2 penta2]] is2cell.
    use tpair.
    - red. cbn. red. intro v. red.
      transparent assert (invertible1 : (invertible_2cell (FA v · f2) (FA v · f1))).
      { use make_invertible_2cell.
        - exact (FA v ◃ ηinvertible ^-1).
        - is_iso. }
      transparent assert (invertible2 : (invertible_2cell (f2 · FA' v) (f1 · FA' v))).
      { use make_invertible_2cell.
        - exact (ηinvertible ^-1 ▹ FA' v).
        - is_iso. }
      apply (lhs_right_invert_cell _ _ _ invertible1).
      rewrite vassocl.
      apply pathsinv0, (lhs_left_invert_cell _ _ _ invertible2).
      exact (is2cell v).
    - split; apply isaprop_bidisp_actionbicat_disp_2cell_struct.
  Qed.

End FixMoncatAndBicat.


From stdpp Require Import numbers list.

(* models the less than operator *)
Structure Comparator (A : Type) := {
  compare : A -> A -> bool;
  transitive : forall a b c, compare a b -> compare b c -> compare a c;
  irreflexive : forall a, ~compare a a;
  asymmetry : forall a b, compare a b -> ~compare b a;
  connected : forall a b, a <> b -> compare a b \/ compare b a;
  equalityExcludedMiddle : forall a b : A, a = b \/ a <> b; (* not true generally *)
}.

Lemma negativelyTransitive {A : Type} (comparator : Comparator A) : forall a b c, ~(compare _ comparator a b) -> ~(compare _ comparator b c) -> ~(compare _ comparator a c).
Proof.
  intros a b c h1 h2 h3.
  pose proof transitive _ comparator a c b h3 as h.
  epose proof connected _ comparator b c _ as h4.
  destruct h4; tauto.
  Unshelve.
  intro h4. rewrite h4 in h1. tauto.
Qed.

Lemma lessThanOrEqual {A : Type} (comparator : Comparator A) : forall a b, ~(compare _ comparator a b) <-> a = b \/ compare _ comparator b a.
Proof.
  intros.
  pose proof connected _ comparator a b.
  split; intros; pose proof equalityExcludedMiddle _ comparator a b as hSplit; pose proof asymmetry _ comparator a b; pose proof irreflexive _ comparator a; pose proof irreflexive _ comparator b; destruct hSplit as [hSplit | hSplit]; try rewrite hSplit; tauto.
Qed.


From compcert Require Export Clightdefs.
Require Export VST.veric.base.
Require Export VST.veric.SeparationLogic.
Require Export VST.msl.Extensionality.
Require Export compcert.lib.Coqlib.
Require Export VST.msl.Coqlib2 VST.veric.coqlib4 VST.floyd.coqlib3.
Require Export VST.floyd.functional_base.
Import LiftNotation.

Lemma is_int_dec i s v: {is_int i s v} + {~ is_int i s v}.
Proof. destruct v; simpl; try solve [right; intros N; trivial].
destruct i.
+ destruct s.
    * destruct (zle Byte.min_signed (Int.signed i0)); [| right; omega].
      destruct (zle (Int.signed i0) Byte.max_signed). left; omega. right; omega.
    * destruct (zle (Int.unsigned i0) Byte.max_unsigned). left; omega. right; omega.
+ destruct s.
    * destruct (zle (-32768) (Int.signed i0)); [| right; omega].
      destruct (zle (Int.signed i0) 32767). left; omega. right; omega.
    * destruct (zle (Int.unsigned i0) 65535). left; omega. right; omega.
+ left; trivial.
+ destruct (Int.eq_dec i0 Int.zero); subst. left; left; trivial.
    destruct (Int.eq_dec i0 Int.one); subst. left; right; trivial.
    right. intros N; destruct N; contradiction.
Defined.

Lemma tc_val_dec t v: {tc_val t v} + {~ tc_val t v}.
Proof. destruct t; simpl.
+ right; intros N; trivial.
+ apply is_int_dec.
+ apply is_long_dec.
+ destruct f. apply is_single_dec. apply is_float_dec.
+ destruct ((eqb_type t Tvoid &&
    eqb_attr a
      {| attr_volatile := false; attr_alignas := Some log2_sizeof_pointer |})%bool).
  apply is_pointer_or_integer_dec.
  apply is_pointer_or_null_dec.
+ apply is_pointer_or_null_dec.
+ apply is_pointer_or_null_dec.
+ apply isptr_dec.
+ apply isptr_dec.
Defined.

Lemma sem_add_pi_ptr:
   forall {cs: compspecs}  t p i si,
    isptr p ->
    match si with
    | Signed => Int.min_signed <= i <= Int.max_signed
    | Unsigned => 0 <= i <= Int.max_unsigned
    end ->
    Cop.sem_add_ptr_int cenv_cs t si p (Vint (Int.repr i)) = Some (offset_val (sizeof t * i) p).
Proof.
  intros. destruct p; try contradiction.
  unfold offset_val, Cop.sem_add_ptr_int.
  unfold Cop.ptrofs_of_int, Ptrofs.of_ints, Ptrofs.of_intu, Ptrofs.of_int.
  f_equal. f_equal. f_equal.
  destruct si; rewrite <- ptrofs_mul_repr;  f_equal.
  rewrite Int.signed_repr by omega; auto.
  rewrite Int.unsigned_repr by omega; auto.
Qed.
Hint Rewrite @sem_add_pi_ptr using (solve [auto with norm]) : norm.

Lemma sem_cast_i2i_correct_range: forall sz s v,
  is_int sz s v -> sem_cast_i2i sz s v = Some v.
Proof.
  intros.
  destruct sz, s, v; try solve [inversion H]; simpl;
  f_equal; f_equal; try apply sign_ext_inrange; try apply zero_ext_inrange; eauto.
  + simpl in H; destruct H; subst; reflexivity.
  + simpl in H; destruct H; subst; reflexivity.
Qed.
Hint Rewrite sem_cast_i2i_correct_range using (solve [auto with norm]) : norm.

Lemma sem_cast_neutral_ptr:
  forall p, isptr p -> sem_cast_pointer p = Some p.
Proof. intros. destruct p; try contradiction; reflexivity. Qed.
Hint Rewrite sem_cast_neutral_ptr using (solve [auto with norm]): norm.

Lemma sem_cast_neutral_Vint: forall v,
  sem_cast_pointer (Vint v) = Some (Vint v).
Proof.
  intros. reflexivity.
Qed.
Hint Rewrite sem_cast_neutral_Vint : norm.

Definition isVint v := match v with Vint _ => True | _ => False end.

Lemma is_int_is_Vint: forall i s v, is_int i s v -> isVint v.
Proof. intros.
 destruct i,s,v; simpl; intros; auto.
Qed.

Lemma is_int_I32_Vint: forall s v, is_int I32 s (Vint v).
Proof.
intros.
hnf. auto.
Qed.
Hint Resolve is_int_I32_Vint.

Lemma sem_cast_neutral_int: forall v,
  isVint v ->
  sem_cast_pointer v = Some v.
Proof.
destruct v; simpl; intros; try contradiction; auto.
Qed.

Hint Rewrite sem_cast_neutral_int using
  (auto;
   match goal with H: is_int ?i ?s ?v |- isVint ?v => apply (is_int_is_Vint i s v H) end) : norm.

Lemma sizeof_tuchar: forall {cs: compspecs}, sizeof tuchar = 1%Z.
Proof. reflexivity. Qed.
Hint Rewrite @sizeof_tuchar: norm.

Hint Rewrite Z.mul_1_l Z.mul_1_r Z.add_0_l Z.add_0_r Z.sub_0_r : norm.

Hint Rewrite eval_id_same : norm.
Hint Rewrite eval_id_other using solve [clear; intro Hx; inversion Hx] : norm.
Hint Rewrite Int.sub_idem Int.sub_zero_l  Int.add_neg_zero : norm.
Hint Rewrite Ptrofs.sub_idem Ptrofs.sub_zero_l  Ptrofs.add_neg_zero : norm.

Lemma eval_expr_Etempvar:
  forall {cs: compspecs}  i t, eval_expr (Etempvar i t) = eval_id i.
Proof. reflexivity.
Qed.
Hint Rewrite @eval_expr_Etempvar : eval.

Lemma eval_expr_binop: forall {cs: compspecs}  op a1 a2 t, eval_expr (Ebinop op a1 a2 t) =
          `(eval_binop op (typeof a1) (typeof a2)) (eval_expr a1) (eval_expr a2).
Proof. reflexivity. Qed.
Hint Rewrite @eval_expr_binop : eval.

Lemma eval_expr_unop: forall {cs: compspecs} op a1 t, eval_expr (Eunop op a1 t) =
          lift1 (eval_unop op (typeof a1)) (eval_expr a1).
Proof. reflexivity. Qed.
Hint Rewrite @eval_expr_unop : eval.

Hint Resolve  eval_expr_Etempvar.

Lemma eval_expr_Etempvar' : forall {cs: compspecs}  i t, eval_id i = eval_expr (Etempvar i t).
Proof. intros. symmetry; auto.
Qed.
Hint Resolve  @eval_expr_Etempvar'.

Hint Rewrite Int.add_zero  Int.add_zero_l Int.sub_zero_l : norm.
Hint Rewrite Ptrofs.add_zero  Ptrofs.add_zero_l Ptrofs.sub_zero_l : norm.

Lemma eval_var_env_set:
  forall i t j v (rho: environ), eval_var i t (env_set rho j v) = eval_var i t rho.
Proof. reflexivity. Qed.
Hint Rewrite eval_var_env_set : norm.

Lemma eval_expropt_Some: forall {cs: compspecs}  e, eval_expropt (Some e) = `Some (eval_expr e).
Proof. reflexivity. Qed.
Lemma eval_expropt_None: forall  {cs: compspecs} , eval_expropt None = `None.
Proof. reflexivity. Qed.
Hint Rewrite @eval_expropt_Some @eval_expropt_None : eval.

Lemma deref_noload_tarray:
  forall ty n, deref_noload (tarray ty n) = (fun v => v).
Proof.
 intros. extensionality v. reflexivity.
Qed.
Hint Rewrite deref_noload_tarray : norm.

Lemma deref_noload_Tarray:
  forall ty n a, deref_noload (Tarray ty n a) = (fun v => v).
Proof.
 intros. extensionality v. reflexivity.
Qed.
Hint Rewrite deref_noload_Tarray : norm.

Lemma flip_lifted_eq:
  forall (v1: environ -> val) (v2: val),
    `eq v1 `(v2) = `(eq v2) v1.
Proof.
intros. unfold_lift. extensionality rho. apply prop_ext; split; intro; auto.
Qed.
Hint Rewrite flip_lifted_eq : norm.

Lemma isptr_is_pointer_or_null:
  forall v, isptr v -> is_pointer_or_null v.
Proof. intros. destruct v; inv H; simpl; auto.
Qed.
Hint Resolve isptr_is_pointer_or_null.

Definition add_ptr_int  {cs: compspecs}  (ty: type) (v: val) (i: Z) : val :=
           eval_binop Cop.Oadd (tptr ty) tint v (Vint (Int.repr i)).

Lemma add_ptr_int_offset:
  forall  {cs: compspecs}  t v n,
  repable_signed (sizeof t) ->
  repable_signed n ->
  add_ptr_int t v n = offset_val (sizeof t * n) v.
Abort. (* broken in CompCert 2.7 *)

Lemma typed_false_cmp:
  forall op i j ,
   typed_false tint (force_val (sem_cmp op tint tint (Vint i) (Vint j))) ->
   Int.cmp (negate_comparison op) i j = true.
Proof.
intros.
unfold sem_cmp in H.
unfold Cop.classify_cmp in H. simpl in H.
rewrite Int.negate_cmp.
unfold both_int, force_val, typed_false, strict_bool_val, sem_cast, classify_cast, tint in H.
destruct Archi.ptr64 eqn:Hp; simpl in H.
destruct (Int.cmp op i j); inv H; auto.
destruct (Int.cmp op i j); inv H; auto.
Qed.

Lemma typed_true_cmp:
  forall op i j,
   typed_true tint (force_val (sem_cmp op tint tint (Vint i) (Vint j))) ->
   Int.cmp op i j = true.
Proof.
intros.
unfold sem_cmp in H.
unfold Cop.classify_cmp in H. simpl in H.
unfold both_int, force_val, typed_false, strict_bool_val, sem_cast, classify_cast, tint in H.
destruct Archi.ptr64 eqn:Hp; simpl in H.
destruct (Int.cmp op i j); inv H; auto.
destruct (Int.cmp op i j); inv H; auto.
Qed.

Definition Zcmp (op: comparison) : Z -> Z -> Prop :=
 match op with
 | Ceq => eq
 | Cne => (fun i j => i<>j)
 | Clt => Z.lt
 | Cle => Z.le
 | Cgt => Z.gt
 | Cge => Z.ge
 end.

Lemma int_cmp_repr:
 forall op i j, repable_signed i -> repable_signed j ->
   Int.cmp op (Int.repr i) (Int.repr j) = true ->
   Zcmp op i j.
Proof.
intros.
unfold Int.cmp, Int.eq, Int.lt in H1.
replace (if zeq (Int.unsigned (Int.repr i)) (Int.unsigned (Int.repr j))
             then true else false)
 with (if zeq i j then true else false) in H1.
2:{
destruct (zeq i j); destruct (zeq (Int.unsigned (Int.repr i)) (Int.unsigned (Int.repr j)));
 auto.
subst. contradiction n; auto.
clear - H H0 e n.
apply Int.signed_repr in H. rewrite Int.signed_repr_eq in H.
apply Int.signed_repr in H0; rewrite Int.signed_repr_eq in H0.
contradiction n; clear n.
repeat rewrite Int.unsigned_repr_eq in e.
 match type of H with
           | context [if ?a then _ else _] => destruct a
           end;
 match type of H0 with
           | context [if ?a then _ else _] => destruct a
           end; omega.
}
unfold Zcmp.
rewrite (Int.signed_repr _ H) in H1; rewrite (Int.signed_repr _ H0) in H1.
repeat match type of H1 with
           | context [if ?a then _ else _] => destruct a
           end; try omegaContradiction;
 destruct op; auto; simpl in *; try discriminate; omega.
Qed.

Lemma typed_false_cmp_repr:
  forall op i j,
   repable_signed i -> repable_signed j ->
   typed_false tint (force_val (sem_cmp op tint tint
                              (Vint (Int.repr i))
                              (Vint (Int.repr j)) )) ->
   Zcmp (negate_comparison op) i j.
Proof.
 intros.
 apply typed_false_cmp in H1.
 apply int_cmp_repr; auto.
Qed.

Lemma typed_true_cmp_repr:
  forall op i j,
   repable_signed i -> repable_signed j ->
   typed_true tint (force_val (sem_cmp op tint tint
                              (Vint (Int.repr i))
                              (Vint (Int.repr j)) )) ->
   Zcmp op i j.
Proof.
 intros.
 apply typed_true_cmp in H1.
 apply int_cmp_repr; auto.
Qed.

Ltac intcompare H :=
 (apply typed_false_cmp_repr in H || apply typed_true_cmp_repr in H);
   [ simpl in H | auto; unfold repable_signed, Int.min_signed, Int.max_signed in *; omega .. ].

Lemma isptr_deref_noload:
 forall t p, access_mode t = By_reference -> isptr (deref_noload t p) = isptr p.
Proof.
intros.
unfold deref_noload. rewrite H. reflexivity.
Qed.
Hint Rewrite isptr_deref_noload using reflexivity : norm.

Definition headptr (v: val): Prop :=
  exists b,  v = Vptr b Ptrofs.zero.

Lemma headptr_isptr: forall v,
  headptr v -> isptr v.
Proof.
  intros.
  destruct H as [b ?].
  subst.
  hnf; auto.
Qed.
Hint Resolve headptr_isptr.

Lemma headptr_offset_zero: forall v,
  headptr (offset_val 0 v) <->
  headptr v.
Proof.
  split; intros.
  + destruct H as [b ?]; subst.
    destruct v; try solve [inv H].
    simpl in H.
    remember (Ptrofs.add i (Ptrofs.repr 0)).
    inversion H; subst.
    rewrite Ptrofs.add_zero in H2; subst.
    hnf; eauto.
  + destruct H as [b ?]; subst.
    exists b.
    reflexivity.
Qed.

(* Equality proofs for all constants from the Compcert Int, Int64, Ptrofs modules: *)

Lemma typed_false_ptr:
  forall {t a v},  typed_false (Tpointer t a) v -> v=nullval.
Proof.
unfold typed_false, strict_bool_val, nullval; simpl; intros.
destruct Archi.ptr64 eqn:Hp;
destruct v; try discriminate; f_equal.
first [pose proof (Int64.eq_spec i Int64.zero);
          destruct (Int64.eq i Int64.zero)
       | pose proof (Int.eq_spec i Int.zero);
         destruct (Int.eq i Int.zero)];
      subst; auto; discriminate.
Qed.

Lemma typed_true_ptr:
  forall {t a v},  typed_true (Tpointer t a) v -> isptr v.
Proof.
unfold typed_true, strict_bool_val; simpl; intros.
destruct v; try discriminate; simpl; auto;
destruct Archi.ptr64; try discriminate;
 revert H; simple_if_tac; intros; discriminate.
Qed.

Lemma int_cmp_repr':
 forall op i j, repable_signed i -> repable_signed j ->
   Int.cmp op (Int.repr i) (Int.repr j) = false ->
   Zcmp (negate_comparison op) i j.
Proof.
intros.
apply int_cmp_repr; auto.
rewrite Int.negate_cmp.
rewrite H1; reflexivity.
Qed.

Lemma typed_false_of_bool:
 forall x, typed_false tint (Val.of_bool x) -> (x=false).
Proof.
unfold typed_false; simpl.
unfold strict_bool_val, Val.of_bool; simpl.
destruct x; simpl; intros; [inversion H | auto].
Qed.

Lemma typed_true_of_bool:
 forall x, typed_true tint (Val.of_bool x) -> (x=true).
Proof.
unfold typed_true; simpl.
unfold strict_bool_val, Val.of_bool; simpl.
destruct x; simpl; intros; [auto | inversion H].
Qed.

Lemma typed_false_tint:
 Archi.ptr64=false ->
 forall v, typed_false tint v -> v=nullval.
Proof.
intros.
 hnf in H0. destruct v; inv H0.
 destruct (Int.eq i Int.zero) eqn:?; inv H2.
 apply int_eq_e in Heqb. subst.
 inv H; reflexivity.
Qed.

Lemma typed_false_tlong:
 Archi.ptr64=true ->
 forall v, typed_false tlong v -> v=nullval.
Proof.
intros. unfold nullval. rewrite H.
 hnf in H0. destruct v; inv H0.
pose proof (Int64.eq_spec i Int64.zero).
 destruct (Int64.eq i Int64.zero); inv H2.
reflexivity.
Qed.

Lemma typed_true_e:
 forall t v, typed_true t v -> v<>nullval.
Proof.
intros.
 intro Hx. subst.
 hnf in H. unfold nullval, strict_bool_val in H.
 destruct Archi.ptr64, t; discriminate.
Qed.

Lemma typed_false_tint_Vint:
  forall v, typed_false tint (Vint v) -> v = Int.zero.
Proof.
intros.
unfold typed_false, strict_bool_val in H. simpl in H.
pose proof (Int.eq_spec v Int.zero).
destruct (Int.eq v Int.zero); auto. inv H.
Qed.

Lemma typed_true_tint_Vint:
  forall v, typed_true tint (Vint v) -> v <> Int.zero.
Proof.
intros.
unfold typed_true, strict_bool_val in H. simpl in H.
pose proof (Int.eq_spec v Int.zero).
destruct (Int.eq v Int.zero); auto. inv H.
Qed.

Lemma typed_true_tlong_Vlong:
  forall v, typed_true tlong (Vlong v) -> v <> Int64.zero.
Proof.
intros.
unfold typed_true, strict_bool_val in H. simpl in H.
pose proof (Int64.eq_spec v Int64.zero).
destruct (Int64.eq v Int64.zero); auto. inv H.
Qed.

Ltac intro_redundant_prop :=
  (* do it in this complicated way because the proof will come out smaller *)
match goal with |- ?P -> _ =>
  ((assert P by immediate; fail 1) || fail 1) || intros _
end.

Ltac fancy_intro aggressive :=
 match goal with
 | |- ?P -> _ => match type of P with Prop => idtac end
 | |- ~ _ => idtac
 end;
 let H := fresh in
 intro H;
 try simple apply ptr_eq_e in H;
 try simple apply Vint_inj in H;
 try match type of H with
 | tc_val _ _ => unfold tc_val in H; try change (eqb_type _ _) with false in H; cbv iota in H
 end;
 match type of H with
 | ?P => clear H;
              match goal with H': P |- _ => idtac end (* work around bug number 6998 in Coq *)
             + (((assert (H:P) by (clear; immediate); fail 1) || fail 1) || idtac)
                (* do it in this complicated way because the proof will come out smaller *)
 | ?x = ?y => constr_eq aggressive true;
                     first [subst x | subst y
                             | is_var x; rewrite H
                             | is_var y; rewrite <- H
                             | idtac]
 | headptr (_ ?x) => let Hx1 := fresh "HP" x in
                     let Hx2 := fresh "P" x in
                       rename H into Hx1;
                       pose proof headptr_isptr _ Hx1 as Hx2
 | headptr ?x => let Hx1 := fresh "HP" x in
                 let Hx2 := fresh "P" x in
                   rename H into Hx1;
                   pose proof headptr_isptr _ Hx1 as Hx2
 | isptr ?x => let Hx := fresh "P" x in rename H into Hx
 | is_pointer_or_null ?x => let Hx := fresh "PN" x in rename H into Hx
 | typed_false _ _ =>
        first [simple apply typed_false_of_bool in H
               | apply typed_false_tint_Vint in H
               | apply (typed_false_tint (eq_refl _)) in H
               | apply (typed_false_tlong (eq_refl _)) in H
               | apply typed_false_ptr in H
               | idtac ]
 | typed_true _ _ =>
        first [simple apply typed_true_of_bool in H
               | apply typed_true_tint_Vint in H
               | apply typed_true_tlong_Vlong in H
(*  This one is not portable 32/64 bits
                | apply (typed_true_e tint) in H
*)
               | apply typed_true_ptr in H
               | idtac ]
 (* | locald_denote _ _ => hnf in H *)
 | _ => try solve [discriminate H]
 end.

Ltac fancy_intros aggressive :=
 repeat match goal with
  | |- (_ <= _ < _) -> _ => fancy_intro aggressive
  | |- (_ < _ <= _) -> _ => fancy_intro aggressive
  | |- (_ <= _ <= _) -> _ => fancy_intro aggressive
  | |- (_ < _ < _) -> _ => fancy_intro aggressive
  | |- (?A /\ ?B) -> ?C => apply (@and_ind A B C) (* For some reason "apply and_ind" doesn't work the same *)
  | |- _ -> _ => fancy_intro aggressive
  end.

Ltac fold_types :=
 fold noattr tuint tint tschar tuchar;
 repeat match goal with
 | |- context [Tpointer ?t noattr] =>
      change (Tpointer t noattr) with (tptr t)
 | |- context [Tarray ?t ?n noattr] =>
      change (Tarray t n noattr) with (tarray t n)
 end.

Ltac fold_types1 :=
  match goal with |- _ -> ?A =>
  let a := fresh "H" in set (a:=A); fold_types; subst a
  end.

Lemma is_int_Vbyte: forall c, is_int I8 Signed (Vbyte c).
Proof.
intros. simpl. normalize. rewrite Int.signed_repr by rep_omega. rep_omega.
Qed.
Hint Resolve is_int_Vbyte.


Require Import syntax.
Require Import partial.
Require Import namesAndTypes.

Import ConcreteEverything.

Section MethodsAndFields.
  Variable P : Program.

  Require Import Coq.Lists.List.

(* Module MethodsAndFields (ct: ClassTable). *)

  (* Parameter CT : list ClassDecl. *)
  (* Maybe change to method name? *)

  Definition method : class -> MethodName_type -> MethDecl -> Prop :=
    fun _ _ _ => classDecls P = nil.

  Definition mtype C m md
             (witn: method C m md) :=
    retType md.

  Definition mbody C m md
             (witn: method C m md) :=
    methodBody md.

  Definition mparam C m md
             (witn: method C m md) :=
    argName md.

  Definition class_name_methods : class -> list MethDecl :=
    fun _ => match classDecls P with
               | nil => nil
               | _ => nil
             end.

  Definition fld : class -> FieldName_type -> Prop :=
    fun _ _ => classDecls P = nil.

  Definition ftype : forall C f,
                       fld C f -> class :=
    fun C _ _ => C.
  (*   destruct (ant.fn.constructFresh nil). *)
  (*   auto. *)
  (* Defined. *)

  Definition fields : class -> list FieldName_type -> Prop.
  Admitted.

  Definition fieldsList : class -> list FieldName_type.
  Admitted.
  Theorem fieldsListIsFields :
    forall C,
      fields C (fieldsList C).
  Admitted.

  Theorem fld_in_flds C f fields_lst:
    fld C f ->
    fields C fields_lst ->
    In f fields_lst.
  Admitted.

  Definition subclass : class -> class -> Prop :=
    fun _ _ => classDecls P = nil.

  Theorem method_subclass C D m md :
    method D m md ->
    subclass C D ->
    method C m md.
    admit.
  Admitted.

  Theorem subclass_refl C :
    subclass C C.
    admit.
  Admitted.

  Theorem subclass_trans C D E:
    subclass C D -> subclass D E -> subclass C E.
    admit.
  Admitted.

  Theorem field_subclass C D f :
    fld D f ->
    subclass C D ->
    fld C f.
    admit.
  Admitted.

  Theorem ftype_subclass C D f (f_witn: fld D f)
          (sub_witn: subclass C D):
    ftype D f f_witn = ftype C f (field_subclass C D f f_witn sub_witn).
    admit.
  Admitted.

  Theorem unique_ftype C f (f_witn1 f_witn2: fld C f) :
    ftype C f f_witn1 = ftype C f f_witn2.
    admit.
  Admitted.

  Inductive subtype : typecheck_type -> typecheck_type -> Type :=
  | classSub : forall C D, subclass C D -> subtype (typt_class C) (typt_class D)
  | boxSub : forall C D, subclass C D -> subtype (typt_box C) (typt_box D)
  | allSub : forall sigma, subtype sigma typt_all.

  Lemma subtype_and_subclass_lemma C' C :
    subtype (typt_class C') (typt_class C) ->
    subclass C' C.
    intro X.
  Admitted.

  Print subtype_and_subclass_lemma.

  Definition ocap : class -> Prop.
  Admitted.

  Theorem ocap_dec : forall C, ocap C \/ ~ (ocap C).
  Admitted.

  Fixpoint lookup_l (c: class) (l: list ClassDecl) : option ClassDecl :=
    match l with
      | nil => None
      | cd :: cds => if class_eq_dec c (cls cd)
                     then (Some cd)
                     else (lookup_l c cds)
    end.

  Definition lookup (c: class) : option ClassDecl :=
    lookup_l c (classDecls P).

End MethodsAndFields.


From mathcomp Require Import all_ssreflect zify.
From CoTypes Require Export coProj.
Require Import Paco.paco.

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

Let eqs := (coLocal.eqs, coGlobal.eqs).

Require Import Program.
From Equations Require Import Equations.

Variant part_ofF (p : ptcp) (R : gType -> Prop)  : gType -> Prop :=
| po2_msg a u g0 : comp_dir p a -> part_ofF p R (GMsg a u g0)
| po2_msg2 a u g0 : R g0 -> part_ofF p R (GMsg a u g0)
| po2_branch a gs : comp_dir p a -> part_ofF p R (GBranch a gs)
| po2_branch2 a g gs : In g gs -> R g ->  part_ofF p R (GBranch a gs).
Hint Constructors part_ofF.

Notation part_ofFU := (fun p => ApplyF1 full_unf \o part_ofF p).

Inductive part_of2 (p : ptcp) : gType -> Prop :=
| part_of2C g : part_ofFU p (part_of2 p) g -> part_of2 p g.
Hint Constructors part_of2.

Lemma part_of2_ind2
     : forall (p : ptcp) (P : gType -> Prop),
       (forall (a : action) (u : value) (g0 g' : gType), comp_dir p a -> full_unf g' = (GMsg a u g0) -> P g') ->
       (forall (a : action) (u : value) (g0 g' : gType), ~ comp_dir p a -> part_of2 p g0 -> P g0 -> full_unf g' = (GMsg a u g0) -> P g') ->
       (forall (a : action) (g' : gType)  (gs : seq gType), comp_dir p a -> full_unf g' = GBranch a gs -> P g') ->
       (forall (a : action) (g g' : gType) (gs : seq gType),  ~ comp_dir p a -> In g gs -> part_of2 p g -> P g -> full_unf g' = GBranch a gs -> P g') ->
       forall g : gType, part_of2 p g -> P g.
Proof.
intros.  move : g H3. fix IH 2. intros. destruct H3. inv H3.
inv H4.
apply/H. eauto. eauto.
destruct (comp_dir p a) eqn:Heqn.
apply/H. 2 : eauto. comp_disc.
apply/H0. 4 : eauto. comp_disc. done. auto.
apply/H1. 2 : eauto. done.
destruct (comp_dir p a) eqn:Heqn.
apply/H1. 2 : eauto. comp_disc.
apply/H2. 5 : eauto. comp_disc. eauto. eauto. apply/IH. auto.
Qed.

Lemma part_of2_unf : forall p e, part_of2 p e -> part_of2 p (full_unf e).
Proof. intros. inv H. inv H0. con. con. rewrite full_unf_idemp //=.
Qed.

Lemma part_of2_unf2 : forall p e, part_of2 p (full_unf e) -> part_of2 p e.
Proof. intros. inv H. inv H0. con. con. rewrite full_unf_idemp in H1=>//=.
Qed.

Lemma part_of2_iff : forall p g, part_of2 p g <-> part_of2 p (full_unf  g).
Proof. intros. split. apply/part_of2_unf. apply/part_of2_unf2.
Qed.

Lemma not_part2_msg : forall p a v g, ~ part_of2 p (GMsg a v g) -> ~ part_of2 p g.
Proof.
intros. intro.  apply/H. con.  con. constructor 2. done.
Qed.

Lemma not_part2_msg2 : forall p a v g, ~ part_of2 p (GMsg a v g) -> ~ comp_dir p a.
Proof.
intros. intro.  apply/H. con. con. con. eauto.
Qed.

Lemma not_part2_branch : forall p a g (gs : seq gType), ~ part_of2 p (GBranch a gs) -> In g gs -> ~ part_of2 p g.
Proof.
intros. intro.  apply/H. con. con. rewrite /full_unf /=. eauto.
Qed.

Lemma not_part2_branch2 : forall p a (gs : seq gType), ~ part_of2 p (GBranch a gs) -> ~ comp_dir p a.
Proof.
intros. intro.  apply/H. con. con. con. eauto.
Qed.

Hint Resolve not_part2_msg not_part2_msg2  not_part2_branch  not_part2_branch2.

Variant part_of_allF (p : ptcp) (R : gType -> Prop)  : gType -> Prop :=
| poa2_msg a u g0 : comp_dir p a -> part_of_allF p R (GMsg a u g0)
| poa2_msg2 a u g0 : R g0 -> part_of_allF p R (GMsg a u g0)
| poa2_branch a gs : comp_dir p a -> part_of_allF p R (GBranch a gs)
| poa2_branch2 a gs : (forall g, In g gs -> R g) ->  part_of_allF p R (GBranch a gs).
Hint Constructors part_of_allF.

Notation part_of_allFU := (fun p => ApplyF1 full_unf \o part_of_allF p).

Inductive part_of_all2 (p : ptcp) : gType -> Prop :=
| part_of_allC g : part_of_allFU p (part_of_all2 p) g -> part_of_all2 p g.
Hint Constructors part_of_all2.

Lemma part_of_all2_ind2
     : forall (p : ptcp) (P : gType -> Prop),
       (forall (a : action) (u : value) (g0 g' : gType), comp_dir p a -> full_unf g' = (GMsg a u g0) -> P g') ->
       (forall (a : action) (u : value) (g0 g' : gType), ~ comp_dir p a -> part_of_all2 p g0 -> P g0 -> full_unf g' = (GMsg a u g0) -> P g') ->
       (forall (a : action) (g' : gType)  (gs : seq gType), comp_dir p a -> full_unf g' = GBranch a gs -> P g') ->
       (forall (a : action) (g' : gType) (gs : seq gType),  ~ comp_dir p a -> (forall g, In g gs -> part_of_all2 p g) -> (forall g, In g gs -> part_of_all2 p g -> P g) -> full_unf g' = GBranch a gs -> P g') ->
       forall g : gType, part_of_all2 p g -> P g.
Proof.
intros.  move : g H3. fix IH 2. intros. destruct H3. inv H3.
inv H4.
apply/H. eauto. eauto.
destruct (comp_dir p a) eqn:Heqn.
apply/H. 2 : eauto. comp_disc.
apply/H0. 4 : eauto. comp_disc. done. auto.
apply/H1. 2 : eauto. done.
destruct (comp_dir p a) eqn:Heqn.
apply/H1. 2 : eauto. comp_disc.
apply/H2. 4 : eauto. comp_disc. clear H5. Guarded.
intros.  apply/H6. apply H5. intros. apply IH. apply H6. apply H7.
Qed.

Lemma part_of_all2_unf : forall p e, part_of_all2 p e -> part_of_all2 p (full_unf e).
Proof. intros. inv H. inv H0. con. con. rewrite full_unf_idemp //=.
Qed.

Lemma part_of_all2_unf2 : forall p e, part_of_all2 p (full_unf e) -> part_of_all2 p e.
Proof. intros. inv H. inv H0. con. con. rewrite full_unf_idemp in H1=>//=.
Qed.

Lemma part_of_all2_iff : forall p g, part_of_all2 p g <-> part_of_all2 p (full_unf  g).
Proof. intros. split. apply/part_of_all2_unf. apply/part_of_all2_unf2.
Qed.

Lemma not_part_all2_msg : forall p a v g, ~ part_of_all2 p (GMsg a v g) -> ~ part_of_all2 p g.
Proof.
intros. intro.  apply/H. con.  con. constructor 2. done.
Qed.

Lemma not_part_all2_msg2 : forall p a v g, ~ part_of_all2 p (GMsg a v g) -> ~ comp_dir p a.
Proof.
intros. intro.  apply/H. con. con. con. eauto.
Qed.

Lemma not_part_all2_branch2 : forall p a (gs : seq gType), ~ part_of_all2 p (GBranch a gs) -> ~ comp_dir p a.
Proof.
intros. intro.  apply/H. con. con. con. eauto.
Qed.

Hint Resolve not_part_all2_msg not_part_all2_msg2    not_part_all2_branch2.

(*Using (forall x , In x .... generates a stronger induction principle*)

Inductive project_gen (p : ptcp) (R : gType ->  lType -> Prop) : gType -> lType -> Prop :=
 | project_msg_s g0 a e0 u d : comp_dir p a = Some d ->
                                  R g0 e0 -> project_gen p R (GMsg a u g0) (EMsg d (action_ch a) u e0) (*Assumption does not have to build something*)
 | project_msg_n g0 a e0 u : comp_dir p a = None ->
                                 R g0 e0 -> part_of_all2 p g0 ->  project_gen p R (GMsg a u g0) e0(*assumption has to build something*)
 | project_gen_branch_f (gs : seq gType) (es : seq lType) a d :  comp_dir p a = Some d -> size gs = size es ->
                                        (forall p, In p (zip gs es) ->  R p.1 p.2 ) -> project_gen p R (GBranch a gs) (EBranch d (action_ch a) es)
 | project_gen_branch_o g (gs : seq gType)  a e : comp_dir p a = None -> In g gs ->  (*We need list to be non -empty otherweise it projects to anything*)
                                    (forall g', In g' gs ->  part_of_all2 p g' /\  R g' e) ->  project_gen p R (GBranch a gs) e
 | project_gen_end g : ~ part_of2 p g -> gInvPred g -> project_gen p R g EEnd. (*Need to preserve that all projectable g's satisfy gInvPred g*)
Hint Constructors project_gen.

Notation UnfProj := (ApplyF full_unf full_eunf).

Definition Project g p e := paco2 (UnfProj \o (project_gen p)) bot2 g e.

Lemma project_gen_mon p: monotone2 (project_gen p).
Proof.
move => x0 x1. intros. induction IN;try done.
con;eauto. con;eauto. con;eauto. econstructor;eauto.
intros. ssa. move/H1 : H2.  ssa. apply/LE. move/H1 : H2. ssa. con.
done. done.
Qed.

Hint Resolve project_gen_mon : paco.

Lemma part_of2_or_end : forall p g e r, paco2 (UnfProj \o project_gen p) r g e -> part_of_all2 p g \/ full_eunf e = EEnd.
Proof.
intros. punfold H. inv H;eauto.  rewrite part_of_all2_iff.
inv H0.
left. con.  con. con. comp_disc.
left. con. con. constructor 2. done.
left. repeat con.  comp_disc.
left. con. con. econstructor 4.
intros. move/H4 : H5. ssa.
auto.
Qed.

Lemma ICpart_of1 : forall p g gc, part_of2 p g -> gUnravel2 g gc -> part_of p gc.
Proof.
intros.
elim/part_of2_ind2 : H gc H0;intros.
punfold H1. inv H1. rewrite H0 in H2. inv H2. eauto.
punfold H3. inv H3. rewrite H2 in H4. inv H4. pclearbot. eauto.
punfold H1. inv H1. rewrite H0 in H2. inv H2. eauto.
punfold H4. inv H4. rewrite H3 in H5. inv H5. Check In_zip.
move : (@In_zip _ _ g0 gs ecs H0 H8)=>[]. ssa.
econstructor 4. eauto. forallApp H10 H7. case=>//=.  eauto.
Qed.

Lemma ICpart_of2 : forall p gc g, part_of p gc -> gUnravel2 g gc -> part_of2 p g.
Proof.
intros.
elim/part_of_ind2 : H g H0;intros.
punfold H0. inv H0. con. con. inv H1. eauto.
punfold H2. inv H2. inv H3. pclearbot. con. con.
rewrite -H4. constructor 2. eauto.
punfold H0. inv H0. con. con. inv H1. eauto.
punfold H3. inv H3. con. con. inv H4. injt. Check In_zip2.
move : (@In_zip2 _ _ g es gs H0 H8)=>[]. ssa.
forallApp H9 H7. case=>[] //=.  eauto.
Qed.

Lemma ICpart_of_iff : forall p g gc,  gUnravel2 g gc  ->  part_of2 p g <-> part_of p gc.
Proof. intros. split;intros. apply/ICpart_of1. eauto. eauto.
apply/ICpart_of2. eauto. eauto.
Qed.

Lemma ICpart_of_all1 : forall p g gc, part_of_all2 p g -> gUnravel2 g gc -> part_of_all p gc.
Proof.
intros.
elim/part_of_all2_ind2 : H gc H0;intros.
punfold H1. inv H1. rewrite H0 in H2. inv H2. eauto.
punfold H3. inv H3. rewrite H2 in H4. inv H4. pclearbot. eauto.
punfold H1. inv H1. rewrite H0 in H2. inv H2. eauto.
punfold H3. inv H3. rewrite H2 in H4. inv H4.
econstructor 4. intros.
move : (@In_zip2 _ _ g0 gs ecs H5 H7)=>[]. ssa.

 apply/H1. eauto. apply/H0. done. forallApp H9 H8. case=>[] //=.
Qed.

Lemma ICpart_of_all2 : forall p gc g, part_of_all p gc -> gUnravel2 g gc -> part_of_all2 p g.
Proof.
intros.
elim/part_of_all_ind : H g H0;intros.
punfold H0. inv H0. con. con. inv H1. eauto.
punfold H1. inv H1. inv H2. pclearbot. con. con. rewrite -H3.
constructor 2. eauto.
punfold H0. inv H0. inv H1. con. con. rewrite -H2. econstructor. done.
punfold H1. inv H1. con. con. inv H2. injt. econstructor 4.
intros.
move: (@In_zip _ _ g0 es gs H4 H6)=>[].  ssa. apply/H0.  eauto.
forallApp H7 H8. case=>[] //=.
Qed.

Lemma ICpart_of_all2_iff : forall p g gc,  gUnravel2 g gc  ->  part_of_all2 p g <-> part_of_all p gc.
Proof. intros. split;intros. apply/ICpart_of_all1. eauto. done.
apply/ICpart_of_all2. eauto. done.
Qed.

Lemma unravel_finite : forall g gc, g << (UnfgUnravel \o gUnravel2_gen) >> gc -> Finite gc.
Proof.
pcofix CIH. intros.
punfold H0. inv H0. pfold. inv H;pclearbot.  con. eauto.
con. apply/ForallP=> x xIn. right. Check In_zip2.
move : (@In_zip2 _ _ x es ecs xIn H2)=>[]. ssa. forallApp H3 H5.  case=>[] //=.
eauto. con.
Qed.

Lemma gInvPred_msg : forall a u g0, gInvPred (GMsg a u g0) -> gInvPred g0.
Proof.
intros. punfold H. inv H. inv H0. pclearbot. done.
Qed.

Lemma gInvPred_branch : forall a g gs, gInvPred (GBranch a gs) -> In g gs ->  gInvPred g.
Proof.
intros. punfold H. inv H. inv H1. forallApp H3 H0. case=>[] //=.
Qed.

Hint Resolve gInvPred_msg gInvPred_branch.

Lemma Project_not_part : forall g p, Project g p EEnd  ->  ~  part_of2 p g.
Proof. intros. intro.
elim/part_of2_ind2 : H0 H;intros. punfold H1. inv H1.  rewrite H0 in H2. inv H2;try comp_disc.
apply/H3. con. con. con. done.
punfold H3. inv H3. rewrite H2 in H4. inv H4;pclearbot;try comp_disc.
apply/H1. pfold. con. con. rewrite -part_of2_iff. eauto.
rewrite -gInvPred_unf_iff. eauto.
punfold H1. inv H1. rewrite H0 in H2. inv H2. comp_disc.
apply/H3. con. con. con. done.
punfold H4. inv H4. rewrite H3 in H5. inv H5;try comp_disc;pclearbot.
move/H11 : H0. ssa. pclearbot. move : H6.  cbn. move/H2. done.
apply/H2. pfold. con. con. rewrite -part_of2_iff. eauto.
rewrite -gInvPred_unf_iff. eauto.
Qed.

Lemma ICProject : forall p g e gc ec, Project g p e -> gUnravel2 g gc -> lUnravel2 e ec -> CProject gc p ec.
Proof.
move => p. pcofix CIH. intros. apply part_of2_or_end in H0 as Hor.
destruct Hor.
punfold H0. inv H0;clear H0.
punfold H1. inv H1;clear H1.
punfold H2. inv H2;clear H2.
elim/part_of_all2_ind2 : H H3 gc ec H0 H1;intros.
- rewrite H0 in H3,H1,H2. inv H1;clear H1;pclearbot.
  inv H3;try comp_disc;pclearbot;eauto.
  rewrite -H7 in H2. inv H2;pclearbot. pfold. eauto.
  rewrite -H1 in H2. inv H2. pfold. apply/cproject_gen_end.
  rewrite -ICpart_of_iff;eauto. pfold. con. con. eauto.
  pfold.  con. left. apply/unravel_finite. eauto.
- rewrite H2 in H3,H4. inv H3; try comp_disc;pclearbot.
  inv H4;clear H4;pclearbot. pfold. con=>//=. left. apply/H1.
  punfold H11. inv H11. rewrite full_eunf_idemp //= in H4.
  punfold H13. inv H13. done. done.  apply/ICpart_of_all2_iff;eauto.
  rewrite -H6 in H5. inv H5. pfold. apply cproject_gen_end.
  rewrite -ICpart_of_iff;eauto. pfold. con. done.
  apply/unravel_finite. pfold. con. eauto. instantiate (1 := GMsg a u g0). done.
- rewrite H0 in H1,H2,H3. inv H1. inv H3;pclearbot; try comp_disc.
  rewrite -H7 in H2. inv H2. pfold. con=>//=. lia.
  suff : Forall (fun p0 =>  upaco2 (cproject_gen p) r p0.1 p0.2) (zip ecs ecs0).
  move/ForallP. done.
  clear H1 H3 H2 H7 H0.
  have : Forall (fun p0 =>  upaco2 (UnfProj \o project_gen p) bot2 p0.1 p0.2) (zip gs es).
  apply/ForallP. eauto. clear H11.
  elim : gs ecs es ecs0 H6 H10 H14 H8 H15.
  case=>//=. case=> //=. case=>//=.
  move => a0 l IH. case=>//=. move => a1 l0.  case=>//=.
  move => a2 l1. case=>//=. move => a3 l2. move=> [] Heq [] Heq0 [] Heq1.
  intros. inv H8. inv H15. inv x. pclearbot. simpl in *. con;eauto.
  rewrite -H4 in H2. inv H2. pfold. apply/cproject_gen_end.
  rewrite -ICpart_of_iff;eauto. pfold. con. eauto.
  apply/unravel_finite. pfold. con. instantiate (1 := GBranch a gs). done.
- rewrite H2 in H3,H4. inv H4;clear H4.
  inv H3;try comp_disc;try done.
  pfold.
  move : (@In_zip _ _ g0 gs ecs H9 H8)=>[]. ssa.
  econstructor=>//=. eauto. clear H9 H4 H6.
  apply/ForallP. clear H7.
have : forall g : gType,
       In g gs ->
       forall (gc : gcType) (ec : lcType),
       gUnravel2_gen (upaco2 (UnfgUnravel \o gUnravel2_gen) bot2) (full_unf g) gc ->
       lUnravel2_gen (upaco2 (UnflUnravel \o lUnravel2_gen) bot2) (full_eunf e) ec -> gc <<( r) (cproject_gen p) >> ec.
  intros. apply/H1;eauto. move/H12 : H4. ssa. pclearbot. punfold H9. inv H9.
  rewrite full_eunf_idemp in H11. done. clear H1. clear H12.
  move/ForallP. clear H2 H3.  move/ForallP : H0.
  elim : gs ecs H8 H10.
  case=>//=. move=> a0 l IH. case=>//=. move=> a1 l0 [] Heq Hfor Hfor2 Hfor3. inv Hfor. inv Hfor2. inv Hfor3. pclearbot. simpl in *. con;eauto.  ssa. apply/ICpart_of_all2_iff;eauto. left. apply/H7;eauto.
  punfold H2. inv H2. done.

  rewrite -H4 in H5. inv H5. pfold. apply/cproject_gen_end.
  rewrite -ICpart_of_iff;eauto. pfold. con. con=>//=.
  apply/unravel_finite. pfold. con. instantiate (1 := GBranch a gs). con=>//=.
- punfold H0. inv H0. punfold H2.  inv H2. rewrite H in H3,H4.  inv H4.
  pfold. con.
  inv H0.
  have : Project g p EEnd. pfold. con. simpl.  cbn. rewrite -H. done.
  intros. rewrite -ICpart_of_iff;eauto. apply/Project_not_part. done.
  apply/unravel_finite. eauto.
Qed.

Lemma Project_unfg : forall g p e r, paco2  (UnfProj \o project_gen p) r (full_unf g) e -> paco2  (UnfProj \o project_gen p) r  g e.
Proof.
intros. punfold H. inv H. pfold. con. rewrite full_unf_idemp in H0. done.
Qed.

Lemma Project_eunf : forall g p e r, paco2  (UnfProj \o project_gen p) r g (full_eunf e) -> paco2  (UnfProj \o project_gen p) r  g e.
Proof.
intros. punfold H. inv H. pfold. con. rewrite full_eunf_idemp in H0. done.
Qed.

Lemma Project_eunf2 : forall g p e r, paco2  (UnfProj \o project_gen p) r g e -> paco2  (UnfProj \o project_gen p) r  g (full_eunf e).
Proof.
intros. punfold H. inv H. pfold. con. rewrite full_eunf_idemp //=.
Qed.

Lemma gUnravel2_Rol : forall g gc, gUnravel2 g gc -> gInvPred g.
Proof.
pcofix CIH. intros. punfold H0. inv H0. pfold. con. inv H;pclearbot.
con. eauto. con;eauto. apply/ForallP=> x xIn. eauto. right.
move : (@In_zip _ _ x es ecs xIn H2)=>[]. ssa.
forallApp H3 H5. case=>[] //=. ssa. eauto.
con.
Qed.

Lemma gUnravel2_iff : forall e ec r,  e <<( r) (UnfgUnravel \o gUnravel2_gen) >> ec <-> (full_unf e) <<( r) (UnfgUnravel \o gUnravel2_gen) >> ec.
Proof. intros. split;intros. punfold H. inv H. pfold. con. rewrite full_unf_idemp. done.
punfold H. inv H. pfold. con. rewrite full_unf_idemp in H0. done.
Qed.

Lemma lUnravel2_iff : forall e ec r,  e <<( r) (UnflUnravel \o lUnravel2_gen) >> ec <-> (full_eunf e) <<( r) (UnflUnravel \o lUnravel2_gen) >> ec.
Proof. intros. split;intros. punfold H. inv H. pfold. con. rewrite full_eunf_idemp. done.
punfold H. inv H. pfold. con. rewrite full_eunf_idemp in H0. done.
Qed.

Ltac pc := pclearbot.

Lemma In_zip_and : forall (A B : Type) (a : A) (b : B) l0 l1, In (a,b) (zip l0 l1) -> In a l0 /\ In b l1.
Proof.
move => A B a b. elim. case=>//=.
move => a0 l IH. case=>//=.
intros. destruct H. inv H. auto. move/IH : H. ssa.
Qed.

Lemma CIProject : forall p g e gc ec, CProject gc p ec -> gUnravel2 g gc -> lUnravel2 e ec -> Project g p e.
Proof.
move => p. pcofix CIH. intros. apply part_of_or_end in H0 as H0'. destruct H0'.
elim/part_of_all_ind2 : H ec g e H0 H1 H2;intros.
- punfold H1. inv H1;clear H1.
  punfold H0. inv H0;pclearbot;try comp_disc.  punfold H2. inv H2. inv H1;pclearbot.
  inv H3. pfold. con. rewrite -H5 -H4. con=>//=. right. pclearbot. eauto.
  punfold H2. inv H2. apply/Project_eunf. inv H5. pfold. con. con.
  rewrite ICpart_of_iff;eauto. pfold. con. rewrite full_unf_idemp. done.
  rewrite -gInvPred_unf_iff. apply/gUnravel2_Rol. pfold.  con. eauto.
- punfold H3. inv H3. apply/Project_unfg. inv H5;pc.
  punfold H2. inv H2;try comp_disc;pc.
  pfold. con. con=>//=. left. apply/H1;eauto. rewrite -lUnravel2_iff.   eauto.
  apply/ICpart_of_all2_iff;eauto.
  punfold H4. inv H4. apply/Project_eunf. inv H10.
  pfold. con. apply/project_gen_end. rewrite ICpart_of_iff;eauto.
  rewrite /full_unf /=.  eauto.
  pfold. con. con. left. done. cbn. apply/gUnravel2_Rol. pfold. con. con. eauto.
- punfold H1. inv H1. apply/Project_unfg. inv H3.
  punfold H0. inv H0;try comp_disc;pclearbot. injt. punfold H2. inv H2.
  apply/Project_eunf. inv H5. injt. pfold. con. con=>//=. lia.
  apply/ForallP. move/ForallP : H12. clear H6 H2 H0 H5 H1 H3 H4.
  elim : es ecs es0 es1 H7 H10 H14 H8 H16.
  case=>//=. case=>//=. case=>//=. move => a0 l IH. case=>//=.
  move => a1 l0 [] //=.  move => a2 l1 [] //=.
  move => a3 l2 [] Heq [] Heq0 [] Heq1. intros. inv H8. inv H16. inv H12. pclearbot.
  simpl in *. con;eauto.
  punfold H2. inv H2. apply/Project_eunf. inv H9. pfold. con. apply/project_gen_end.
  rewrite ICpart_of_iff;eauto. rewrite -gUnravel2_iff. pfold.  con. con. lia. done.
  rewrite -gInvPred_unf_iff. apply/gUnravel2_Rol. pfold. con. con. 2 : eauto. eauto.
- punfold H3. inv H3.  apply/Project_unfg. inv H5. injt.
  punfold H2. inv H2;pclearbot;try comp_disc. injt.
   have :  forall g : gcType,
       In g gs ->
       forall (ec : lcType) (g0 : gType) (e : lType),
       CProject g p ec -> gUnravel2 g0 g -> lUnravel2 e ec -> g0 <<( r) (UnfProj \o project_gen p) >> e.
  intros. apply/H1;eauto. clear H1 => H1.
  move : (@In_zip2 _ _ g0 es gs H12 H9)=>[]. ssa.
  pfold. con. econstructor=>//=. eauto.
  ssa. move : (@In_zip _ _ g' es gs H13 H9)=>[].  ssa.
  apply/ICpart_of_all2_iff;eauto.  forallApp H10 H16. case=>[]//=.
  left. apply/Project_eunf2. (*apply In_zip_and in H8. ssa. *)
  move : (@In_zip _ _ g' es gs H13 H9)=>[].  ssa.
  apply/H1. apply/H15.  all : eauto.
  move/H14 : H15. ssa. pclearbot. done.
  forallApp H10 H16. case=>[] //=. punfold H4. inv H4.
  apply/Project_eunf. inv H11. pfold. con. apply/project_gen_end.
  cbn. rewrite ICpart_of_iff;eauto. pfold. con. con=>//=.
  cbn. apply/gUnravel2_Rol. pfold. con. con. 2 : eauto. lia.
- subst. pfold. con. punfold H2. inv H2. inv H. con.
  rewrite ICpart_of_iff. apply/CProject_not_part. eauto.
  rewrite -gUnravel2_iff //=.
  apply/gUnravel2_Rol. rewrite -gUnravel2_iff. eauto.
Qed.

Let rwd := (etocoind'_eq, etocoind_eq, gtocoind'_eq, gtocoind_eq).
Ltac seq := rewrite ?eqs -?rwd.
Ltac seq_in H := rewrite ?eqs -?rwd in H.

Lemma Project_gtree : forall p g e, Project g p e -> gUnravel2 g (gtocoind g).
Proof.
move => p. pcofix CIH. intros. punfold H0. inv H0. rewrite gtocoind_full_unf. apply/gUnravel2_iff.  inv H;seq.
pfold. con. con. pclearbot.  eauto.
pfold. con.
con. pclearbot.  eauto.
pfold. con. con. rewrite size_map=>//=.
move/ForallP : H5. clear H2 H1. elim : gs es H4. case=>//=.
move => a0 l IH. case=>//=. move => a1 l0 [] Heq. intros. inv H5. pclearbot. simpl in *.
con;eauto.
pfold. con. con. rewrite size_map //=.
move/ForallP : H4. clear H2 H1 H3. elim : gs.
simpl. done. move => a0 l IH HH. inv HH. ssa.  pclearbot. con;eauto.
rewrite -gtocoind_full_unf.  rewrite -gUnravel2_iff.
apply/paco2_mon.
apply/gInvPred_iff. rewrite gInvPred_unf_iff. done. done.
Qed.

Lemma Project_etree : forall p g e, Project g p e -> lUnravel2 e (etocoind e).
Proof.
move => p. pcofix CIH. intros. apply part_of2_or_end in H0 as H0'.
destruct H0'.
elim/part_of_all2_ind2 : H e H0;intros.
punfold H1. inv H1. rewrite H0 in H2. rewrite etocoind_full_eunf.  apply/lUnravel2_iff. inv H2;pclearbot;try comp_disc.
pfold. seq.  con. con. eauto. pfold. con. seq. con.
apply/H1. punfold H3. inv H3. rewrite H2 in H4. inv H4;pclearbot ;try comp_disc.
apply/Project_eunf. done. pfold. con. rewrite -H5. con. rewrite -part_of2_iff. eauto.
rewrite -gInvPred_unf_iff.  eauto.
punfold H1. inv H1. rewrite H0 in H2. rewrite etocoind_full_eunf.  apply/lUnravel2_iff. inv H2;pclearbot;try comp_disc.
pfold. seq.  con. con. rewrite size_map //=.
move/ForallP : H8. clear H5 H0 H2. elim : gs es H7. case=>//=.
move => a0 l IH. case=>//=. move => a1 l0 [] Heq. intros. inv H8. pclearbot. simpl in *.
con;eauto.
seq. pfold. con. con.
punfold H3. inv H3. rewrite H2 in H4. rewrite etocoind_full_eunf. apply/lUnravel2_iff. inv H4;pclearbot;try comp_disc.
rewrite -lUnravel2_iff. rewrite -etocoind_full_eunf. apply/H1. eauto. eauto.
move/H10 : H8. ssa. pclearbot. apply/Project_eunf. done.
seq. pfold. con. con.
rewrite etocoind_full_eunf. apply/lUnravel2_iff. rewrite H. seq. pfold. con. con.
Qed.

Lemma ICProject_iff : forall g p e, Project g p e <-> exists gc ec, gUnravel2 g gc /\ lUnravel2 e ec /\ CProject gc p ec.
Proof.
intros. split. intros. exists (gtocoind g). exists (etocoind e). ssa.
apply/Project_gtree;eauto.
apply/Project_etree;eauto.
apply/ICProject;eauto. apply/Project_gtree;eauto. apply/Project_etree;eauto.
case=> x []. intros. ssa. apply/CIProject;eauto.
Qed.