Require Import Coq.Sets.Ensembles.
Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Equivalence.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.lib.Bisimulation.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.ModalLogic.Model.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.ModalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.Extensions.Semantics.SemanticStable.
Require Logic.PropositionalLogic.Semantics.Trivial.
Require Logic.ModalLogic.Semantics.Kripke.
Require Logic.GeneralLogic.Semantics.Kripke.
Require Logic.MinimumLogic.Semantics.Kripke.
Require Logic.PropositionalLogic.Semantics.Kripke.
Require Logic.ModalLogic.Semantics.Flat.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Logic.SeparationLogic.Semantics.FlatSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import ModalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Module Sound_Trivial.

Import Logic.PropositionalLogic.Semantics.Trivial.
Import Logic.MinimumLogic.Semantics.Trivial.
Import Logic.ModalLogic.Semantics.Kripke.

Lemma sound_impp_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R: SS.Relation (Kworlds M)} {SM: Semantics L MD} {tminSM: TrivialMinimumSemantics L MD SM} {tpSM: TrivialPropositionalSemantics L MD SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x --> y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  unfold Kdenotation in *; simpl in *.
  rewrite !(app_same_set (denote_impp _ _)).
  unfold Semantics.impp; simpl.
  specialize (H _ _ H1).
  specialize (H0 _ _ H1).
  tauto.
Qed.

Lemma sound_andp_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R: SS.Relation (Kworlds M)} {SM: Semantics L MD} {tpSM: TrivialPropositionalSemantics L MD SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x && y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  unfold Kdenotation in *; simpl in *.
  rewrite !(app_same_set (denote_andp _ _)).
  unfold Semantics.andp; simpl.
  specialize (H _ _ H1).
  specialize (H0 _ _ H1).
  tauto.
Qed.

Lemma sound_orp_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R: SS.Relation (Kworlds M)} {SM: Semantics L MD} {tpSM: TrivialPropositionalSemantics L MD SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x || y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  unfold Kdenotation in *; simpl in *.
  rewrite !(app_same_set (denote_orp _ _)).
  unfold Semantics.orp; simpl.
  specialize (H _ _ H1).
  specialize (H0 _ _ H1).
  tauto.
Qed.

Lemma sound_falsep_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R: SS.Relation (Kworlds M)} {SM: Semantics L MD} {tpSM: TrivialPropositionalSemantics L MD SM} {stableSM: SemanticStable L MD M SM}:
  semantic_stable falsep.
Proof.
  intros.
  rewrite denote_stable.
  unfold Semantics.stable.
  intros.
  unfold Kdenotation.
  rewrite !(app_same_set denote_falsep).
  reflexivity.
Qed.

Lemma sound_stable_proper_iffp {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R: SS.Relation (Kworlds M)} {SM: Semantics L MD} {tminSM: TrivialMinimumSemantics L MD SM} {tpSM: TrivialPropositionalSemantics L MD SM} {stableSM: SemanticStable L MD M SM}:
  forall x y,
    (forall m, KRIPKE: M, m |= x <--> y) ->
    (semantic_stable x <-> semantic_stable y).
Proof.
  intros.
  rewrite !denote_stable.
  unfold Semantics.stable.
  assert (forall m, Kdenotation M x m <-> Kdenotation M y m).
  + intros m.
    specialize (H m).
    unfold iffp in H; rewrite sat_andp, !sat_impp in H.
    destruct H.
    tauto.
  + split; intros HH ? ? H1;
    specialize (HH _ _ H1).
    - rewrite !H0 in HH.
      auto.
    - rewrite !H0.
      auto.
Qed.

Lemma sound_boxp_stable {L: Language} {minL: MinimumLanguage L} {mL: ModalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KM.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {R1_bis: Bisimulation SS.Krelation KM.Krelation} {SM: Semantics L MD} {kmSM: KripkeModalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x: expr,
    semantic_stable x -> semantic_stable (boxp x).
Proof.
  intros.
  rewrite denote_stable in H |- *.
  unfold Semantics.stable in *.
  intros.
  rewrite !(app_same_set (denote_boxp _)).
  unfold Semantics.boxp; simpl.
  split.
  + pose proof bis_r _ _ H0.
    intros.
    specialize (H1 _ H3).
    destruct H1 as [m0 [? ?]].
    specialize (H2 _ H1).
    specialize (H _ _ H4).
    tauto.
  + pose proof bis_l _ _ H0.
    intros; rename n0 into m0.
    specialize (H1 _ H3).
    destruct H1 as [n0 [? ?]].
    specialize (H2 _ H1).
    specialize (H _ _ H4).
    tauto.
Qed.

Lemma sound_boxp_absorb_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KM.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {R1_incl: Inclusion KM.Krelation SS.Krelation} {SM: Semantics L MD} {tminSM: TrivialMinimumSemantics L MD SM} {tpSM: TrivialPropositionalSemantics L MD SM} {kmSM: KripkeModalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x: expr,
    semantic_stable x ->
    (forall (m: Kworlds M), KRIPKE: M, m |= x --> boxp x).
Proof.
  intros.
  rewrite sat_impp, sat_boxp.
  intros.
  rewrite denote_stable in H.
  unfold Semantics.stable in H.
  apply including in H1.
  specialize (H _ _ H1).
  tauto.
Qed.

End Sound_Trivial.

Module Sound_KripkeIntuitionistic.

Import Logic.GeneralLogic.Semantics.Kripke.
Import Logic.MinimumLogic.Semantics.Kripke.
Import Logic.PropositionalLogic.Semantics.Kripke.
Import Logic.ModalLogic.Semantics.Flat.
Import Logic.SeparationLogic.Semantics.FlatSemantics.

Lemma sound_impp_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {R1_bis: Bisimulation SS.Krelation KI.Krelation} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x --> y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  rewrite !(app_same_set (denote_impp _ _)).
  unfold Semantics.impp; simpl.
  split.
  + pose proof bis_r _ _ H1.
    intros.
    specialize (H2 _ H4).
    destruct H2 as [m0 [? ?]].
    specialize (H3 _ H2).
    specialize (H _ _ H6).
    specialize (H0 _ _ H6).
    tauto.
  + pose proof bis_l _ _ H1.
    intros.
    rename n0 into m0.
    specialize (H2 _ H4).
    destruct H2 as [n0 [? ?]].
    specialize (H3 _ H2).
    specialize (H _ _ H6).
    specialize (H0 _ _ H6).
    tauto.
Qed.

Lemma sound_andp_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x && y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  rewrite !(app_same_set (denote_andp _ _)).
  unfold Semantics.andp; simpl.
  specialize (H _ _ H1).
  specialize (H0 _ _ H1).
  tauto.
Qed.

Lemma sound_orp_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x || y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  rewrite !(app_same_set (denote_orp _ _)).
  unfold Semantics.orp; simpl.
  specialize (H _ _ H1).
  specialize (H0 _ _ H1).
  tauto.
Qed.

Lemma sound_falsep_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  semantic_stable falsep.
Proof.
  intros.
  rewrite denote_stable.
  unfold Semantics.stable.
  intros.
  rewrite !(app_same_set denote_falsep).
  reflexivity.
Qed.

Lemma sound_stable_proper_iffp {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {po_R: PreOrder KI.Krelation} {R2: SS.Relation (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x y,
    (forall m, KRIPKE: M, m |= x <--> y) ->
    (semantic_stable x <-> semantic_stable y).
Proof.
  intros.
  rewrite !denote_stable.
  unfold Semantics.stable.
  assert (forall m, Kdenotation M x m <-> Kdenotation M y m).
  + intros m.
    specialize (H m).
    unfold iffp in H; rewrite sat_andp, !sat_impp in H.
    destruct H.
    split; intros.
    - apply (H m); auto.
      reflexivity.
    - apply (H0 m); auto.
      reflexivity.
  + split; intros HH ? ? H1;
    specialize (HH _ _ H1).
    - rewrite !H0 in HH.
      auto.
    - rewrite !H0.
      auto.
Qed.

Lemma sound_boxp_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: KM.Relation (Kworlds M)} {R3: SS.Relation (Kworlds M)} {R2_bis: Bisimulation SS.Krelation KM.Krelation} {SM: Semantics L MD} {fmSM: FlatModalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x: expr,
    semantic_stable x -> semantic_stable (boxp x).
Proof.
  intros.
  rewrite denote_stable in H |- *.
  unfold Semantics.stable in *.
  intros.
  rewrite !(app_same_set (denote_boxp _)).
  unfold Semantics.boxp; simpl.
  split.
  + pose proof bis_r _ _ H0.
    intros.
    specialize (H1 _ H3).
    destruct H1 as [m0 [? ?]].
    specialize (H2 _ H1).
    specialize (H _ _ H4).
    tauto.
  + pose proof bis_l _ _ H0.
    intros.
    rename n0 into m0.
    specialize (H1 _ H3).
    destruct H1 as [n0 [? ?]].
    specialize (H2 _ H1).
    specialize (H _ _ H4).
    tauto.
Qed.

Lemma sound_boxp_absorb_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {mL: ModalLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: KM.Relation (Kworlds M)} {R3: SS.Relation (Kworlds M)} {R2_incl: Inclusion KM.Krelation SS.Krelation} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {fmSM: FlatModalSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x: expr,
    semantic_stable x ->
    (forall (m: Kworlds M), KRIPKE: M, m |= x --> boxp x).
Proof.
  intros.
  rewrite sat_impp.
  intros.
  rewrite sat_boxp.
  intros.
  rewrite denote_stable in H.
  unfold Semantics.stable in H.
  apply including in H2.
  specialize (H _ _ H2).
  tauto.
Qed.

Lemma sound_sepcon_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {sepconL: SepconLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {J: Join (Kworlds M)} {SAbis: SeparationAlgebraBisStable (Kworlds M)} {SM: Semantics L MD} {fsepconSM: SepconSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x * y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  rewrite !(app_same_set (denote_sepcon _ _)).
  unfold WeakSemantics.sepcon; simpl.
  pose proof split_bis_stable _ _ H1.
  split; intros.
  + destruct H2 as [? _].
    destruct H3 as [m1 [m2 [? [? ?]]]].
    specialize (H2 _ _ H3).
    destruct H2 as [n1 [n2 [? [? ?]]]].
    exists n1, n2.
    specialize (H _ _ H6).
    specialize (H0 _ _ H7).
    tauto.
  + destruct H2 as [_ ?].
    destruct H3 as [n1 [n2 [? [? ?]]]].
    specialize (H2 _ _ H3).
    destruct H2 as [m1 [m2 [? [? ?]]]].
    exists m1, m2.
    specialize (H _ _ H6).
    specialize (H0 _ _ H7).
    tauto.
Qed.

Lemma sound_wand_stable {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {wandL: WandLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {J: Join (Kworlds M)} {SAbis: SeparationAlgebraBisStable (Kworlds M)} {SM: Semantics L MD} {fwandSM: WandSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x y: expr,
    semantic_stable x -> semantic_stable y -> semantic_stable (x -* y).
Proof.
  intros.
  rewrite denote_stable in H, H0 |- *.
  unfold Semantics.stable in *.
  intros.
  rewrite !(app_same_set (denote_wand _ _)).
  unfold WeakSemantics.wand; simpl.
  pose proof extend_bis_stable _ _ H1.
  split.
  + intros ? n1 n2 ? ?.
    destruct H2 as [_ ?].
    specialize (H2 _ _ H4).
    destruct H2 as [m1 [m2 [? [? ?]]]].
    specialize (H3 _ _ H2).
    specialize (H0 _ _ H7).
    specialize (H _ _ H6).
    tauto.
  + intros ? m1 m2 ? ?.
    destruct H2 as [? _].
    specialize (H2 _ _ H4).
    destruct H2 as [n1 [n2 [? [? ?]]]].
    specialize (H3 _ _ H2).
    specialize (H0 _ _ H7).
    specialize (H _ _ H6).
    tauto.
Qed.

Lemma sound_stable_andp_sepcon1 {L: Language} {minL: MinimumLanguage L} {pL: PropositionalLanguage L} {sepconL: SepconLanguage L} {MD: Model} {kMD: KripkeModel MD} {M: Kmodel} {R1: KI.Relation (Kworlds M)} {R2: SS.Relation (Kworlds M)} {J: Join (Kworlds M)} {SAabs: SeparationAlgebraAbsorbStable (Kworlds M)} {SM: Semantics L MD} {kiSM: KripkeIntuitionisticSemantics L MD M SM} {kminSM: KripkeMinimumSemantics L MD M SM} {kpSM: KripkePropositionalSemantics L MD M SM} {fsepconSM: SepconSemantics L MD M SM} {stableSM: SemanticStable L MD M SM}:
  forall x y z, semantic_stable x ->
    forall m: Kworlds M, KRIPKE: M, m |= (x && y) * z <--> x && (y * z).
Proof.
  intros.
  unfold iffp.
  rewrite sat_andp, !sat_impp.
  split; intros.
  + clear m H0.
    rewrite sat_andp, sat_sepcon.
    rewrite sat_sepcon in H1.
    destruct H1 as [n1 [n2 [? [? ?]]]].
    rewrite sat_andp in H1.
    destruct H1.
    destruct (SA_absorb_stable _ _ _ H0) as [m1 [m2 [? [? [? [? ?]]]]]].
    apply (sat_mono _ _ _ H7) in H1.
    apply (sat_mono _ _ _ H7) in H3.
    apply (sat_mono _ _ _ H8) in H2.
    rewrite denote_stable in H.
    rewrite (H _ _ H5) in H1.
    split; auto.
    exists m1, m2; auto.
  + clear m H0.
    rewrite sat_sepcon.
    rewrite sat_andp, sat_sepcon in H1.
    destruct H1 as [? [n1 [n2 [? [? ?]]]]].
    destruct (SA_absorb_stable _ _ _ H1) as [m1 [m2 [? [? [? [? ?]]]]]].
    apply (sat_mono _ _ _ H7) in H2.
    apply (sat_mono _ _ _ H8) in H3.
    rewrite denote_stable in H.
    rewrite <- (H _ _ H5) in H0.
    exists m1, m2.
    split; [| split]; auto.
    rewrite sat_andp.
    auto.
Qed.

End Sound_KripkeIntuitionistic.


(***************************************************************************
 Properties of the bicat of pseudofunctors

 In this file, we study some properties of the bicategory of pseudofunctors.
 We look at the following properties:
 1. Being locally groupoidal
 2. Terminal objects
 3. Initial objects
 ***************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Constant.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Products.
Import Products.Notations.

Local Open Scope cat.

(** 1. Locally groupoidal *)
Section FixALocallyGrpd.
  Context (B₁ : bicat)
          {B₂ : bicat}
          (HB₂ : locally_groupoid B₂).

  Definition locally_groupoid_psfunctor_bicat
    : locally_groupoid (psfunctor_bicat B₁ B₂).
  Proof.
    intros F G α β m.
    use make_is_invertible_modification.
    intro x.
    apply HB₂.
  Defined.
End FixALocallyGrpd.

(** 2. Final objects *)
Section FixAFinal.
  Context (B₁ : bicat)
          (B₂ : bicat)
          (f : bifinal_obj B₂).

  Definition final_psfunctor
    : psfunctor_bicat B₁ B₂
    := constant _ (pr1 f).

  Definition final_psfunctor_1cell_data
             (F : psfunctor B₁ B₂)
    : pstrans_data F final_psfunctor.
  Proof.
    use make_pstrans_data.
    - exact (λ x, is_bifinal_1cell_property (pr2 f) (F x)).
    - intros x y g.
      apply (is_bifinal_invertible_2cell_property (pr2 f)).
  Defined.

  Definition final_psfunctor_1cell_is_pstrans
             (F : psfunctor B₁ B₂)
    : is_pstrans (final_psfunctor_1cell_data F).
  Proof.
    repeat split ; intros ; apply (is_bifinal_eq_property (pr2 f)).
  Qed.

  Definition final_psfunctor_1cell
             (F : psfunctor B₁ B₂)
    : pstrans F final_psfunctor.
  Proof.
    use make_pstrans.
    - exact (final_psfunctor_1cell_data F).
    - exact (final_psfunctor_1cell_is_pstrans F).
  Defined.

  Definition final_psfunctor_2cell_data
             {F : psfunctor B₁ B₂}
             (α β : pstrans F final_psfunctor)
    : modification_data α β
    := λ x, is_bifinal_2cell_property (pr2 f) _ (α x) (β x).

  Definition final_psfunctor_2cell_is_modification
             {F : psfunctor B₁ B₂}
             (α β : pstrans F final_psfunctor)
    : is_modification (final_psfunctor_2cell_data α β).
  Proof.
    intros x y g.
    apply (is_bifinal_eq_property (pr2 f)).
  Qed.

  Definition final_psfunctor_2cell
             {F : psfunctor B₁ B₂}
             (α β : pstrans F final_psfunctor)
    : modification α β.
  Proof.
    use make_modification.
    - exact (final_psfunctor_2cell_data α β).
    - exact (final_psfunctor_2cell_is_modification α β).
  Defined.

  Definition final_psfunctor_eq
             {F : psfunctor B₁ B₂}
             {α β : pstrans F final_psfunctor}
             (m₁ m₂ : modification α β)
    : m₁ = m₂.
  Proof.
    use modification_eq.
    intro.
    apply (is_bifinal_eq_property (pr2 f)).
  Qed.

  Definition psfunctor_bifinal
    : bifinal_obj (psfunctor_bicat B₁ B₂).
  Proof.
    simple refine (_ ,, _).
    - exact final_psfunctor.
    - use make_is_bifinal.
      + exact final_psfunctor_1cell.
      + exact @final_psfunctor_2cell.
      + exact @final_psfunctor_eq.
  Defined.
End FixAFinal.

(** 3. Initial objects *)
Section FixAnInitial.
  Context (B₁ : bicat)
          (B₂ : bicat)
          (i : biinitial_obj B₂).

  Definition initial_psfunctor
    : psfunctor_bicat B₁ B₂
    := constant _ (pr1 i).

  Definition initial_psfunctor_1cell_data
             (F : psfunctor B₁ B₂)
    : pstrans_data initial_psfunctor F.
  Proof.
    use make_pstrans_data.
    - exact (λ x, is_biinitial_1cell_property (pr2 i) (F x)).
    - intros x y g.
      apply (is_biinitial_invertible_2cell_property (pr2 i)).
  Defined.

  Definition initial_psfunctor_1cell_is_pstrans
             (F : psfunctor B₁ B₂)
    : is_pstrans (initial_psfunctor_1cell_data F).
  Proof.
    repeat split ; intros ; apply (is_biinitial_eq_property (pr2 i)).
  Qed.

  Definition initial_psfunctor_1cell
             (F : psfunctor B₁ B₂)
    : pstrans initial_psfunctor F.
  Proof.
    use make_pstrans.
    - exact (initial_psfunctor_1cell_data F).
    - exact (initial_psfunctor_1cell_is_pstrans F).
  Defined.

  Definition initial_psfunctor_2cell_data
             {F : psfunctor B₁ B₂}
             (α β : pstrans initial_psfunctor F)
    : modification_data α β
    := λ x, is_biinitial_2cell_property (pr2 i) _ (α x) (β x).

  Definition initial_psfunctor_2cell_is_modification
             {F : psfunctor B₁ B₂}
             (α β : pstrans initial_psfunctor F)
    : is_modification (initial_psfunctor_2cell_data α β).
  Proof.
    intros x y g.
    apply (is_biinitial_eq_property (pr2 i)).
  Qed.

  Definition initial_psfunctor_2cell
             {F : psfunctor B₁ B₂}
             (α β : pstrans initial_psfunctor F)
    : modification α β.
  Proof.
    use make_modification.
    - exact (initial_psfunctor_2cell_data α β).
    - exact (initial_psfunctor_2cell_is_modification α β).
  Defined.

  Definition initial_psfunctor_eq
             {F : psfunctor B₁ B₂}
             {α β : pstrans initial_psfunctor F}
             (m₁ m₂ : modification α β)
    : m₁ = m₂.
  Proof.
    use modification_eq.
    intro.
    apply (is_biinitial_eq_property (pr2 i)).
  Qed.

  Definition psfunctor_biinitial
    : biinitial_obj (psfunctor_bicat B₁ B₂).
  Proof.
    simple refine (_ ,, _).
    - exact initial_psfunctor.
    - use make_is_biinitial.
      + exact initial_psfunctor_1cell.
      + exact @initial_psfunctor_2cell.
      + exact @initial_psfunctor_eq.
  Defined.
End FixAnInitial.

(*
This is WIP. It is commented out, because it needs refactoring

Section FixProducts.
  Context (B₁ : bicat)
          (B₂ : bicat_with_binprod).

  Section BinprodPSFunctor.
    Context (F G : psfunctor B₁ B₂).

    Definition binprod_psfunctor_data
      : psfunctor_data B₁ B₂.
    Proof.
      use make_psfunctor_data.
      - exact (λ z, F z ⊗ G z).
      - exact (λ x y f, #F f ⊗₁ #G f).
      - exact (λ x y f g α, ##F α ⊗₂ ##G α).
      - exact (λ b,
               (pair_1cell_id_id_invertible B₂ (F b) (G b))^-1
               • psfunctor_id F b ⊗₂ psfunctor_id G b).
      - exact (λ b₁ b₂ b₃ f g,
               pair_1cell_comp _ (#F f) (#F g) (#G f) (#G g)
               • psfunctor_comp F f g ⊗₂ psfunctor_comp G f g).
    Defined.

    Definition binprod_psfunctor_laws
      : psfunctor_laws binprod_psfunctor_data.
    Proof.
      repeat split.
      - intros b₁ b₂ f ; cbn.
        rewrite !psfunctor_id2.
        rewrite pair_2cell_id_id.
        apply idpath.
      - intros b₁ b₂ f g h α β ; cbn.
        rewrite !psfunctor_vcomp.
        rewrite !pair_2cell_comp.
        apply idpath.
      - intros b₁ b₂ f ; cbn.
        use binprod_ump_2cell_unique_alt.
        + apply (pr2 B₂).
        + pose (psfunctor_lunitor F f) as Fid.
          pose (psfunctor_lunitor G f) as Gid.
          apply TODO.
        + apply TODO.
      - intros b₁ b₂ f ; cbn.
        use binprod_ump_2cell_unique_alt.
        + apply (pr2 B₂).
        + rewrite <- !lwhisker_vcomp.
          rewrite <- !rwhisker_vcomp.
          rewrite !vassocl.
          refine (!_).
          etrans.
          {
            do 2 apply maponpaths.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                apply binprod_ump_2cell_pr1.
              }
              etrans.
              {
                apply maponpaths_2.
                apply binprod_ump_2cell_pr1.
              }
              rewrite !vassocl.
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                rewrite !vassocr.
                rewrite vcomp_linv.
                rewrite id2_left.
                apply idpath.
              }
              rewrite !vassocr.
              rewrite lwhisker_vcomp.
              apply idpath.
            }
            etrans.
            {
              apply maponpaths_2.
              apply binprod_ump_2cell_pr1.
            }
            rewrite !vassocl.
            etrans.
            {
              do 5 apply maponpaths.
              rewrite !vassocr.
              rewrite vcomp_linv.
              rewrite id2_left.
              apply idpath.
            }
            apply idpath.
          }
          etrans.
          {
            rewrite !vassocr.
            do 6 apply maponpaths_2.
            rewrite !vassocl.
            rewrite <- rwhisker_lwhisker_rassociator.
            rewrite !vassocr.
            rewrite <- rwhisker_lwhisker_rassociator.
            rewrite !vassocl.
            apply maponpaths.
            etrans.
            {
              do 2 apply maponpaths.
              apply binprod_ump_2cell_pr1.
            }
            etrans.
            {
              apply maponpaths_2.
              apply maponpaths.
              apply binprod_ump_2cell_pr1.
            }
            rewrite lwhisker_vcomp.
            apply maponpaths.
            rewrite !vassocl.
            do 2 apply maponpaths.
            rewrite !vassocr.
            rewrite vcomp_linv.
            rewrite id2_left.
            apply idpath.
          }
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite lwhisker_vcomp.
            rewrite !vassocl.
            rewrite vcomp_linv.
            rewrite id2_right.
            etrans.
            {
              apply maponpaths_2.
              rewrite <- !lwhisker_vcomp.
              apply idpath.
            }
            rewrite !vassocl.
            do 2 apply maponpaths.
            rewrite !vassocr.
            rewrite lwhisker_lwhisker.
            rewrite !vassocl.
            etrans.
            {
              apply maponpaths.
              rewrite !vassocr.
              rewrite <- vcomp_whisker.
              rewrite !vassocl.
              apply maponpaths.
              rewrite !vassocr.
              rewrite <- lwhisker_lwhisker_rassociator.
              rewrite !vassocl.
              apply maponpaths.
              rewrite !vassocr.
              rewrite lwhisker_vcomp.
              apply maponpaths_2.
              apply maponpaths.
              rewrite !vassocr.
              exact (!(psfunctor_runitor F f)).
            }
            etrans.
            {
              do 2 apply maponpaths.
              rewrite !vassocr.
              rewrite runitor_triangle.
              apply idpath.
            }
            etrans.
            {
              apply maponpaths.
              rewrite !vassocr.
              rewrite vcomp_runitor.
              apply idpath.
            }
            rewrite !vassocr.
            rewrite <- runitor_triangle.
            rewrite !vassocr.
            rewrite lassociator_rassociator.
            rewrite id2_left.
            rewrite !vassocl.
            rewrite vcomp_rinv.
            apply id2_right.
          }
          rewrite !lwhisker_vcomp.
          rewrite rinvunitor_runitor.
          rewrite id2_right.
          apply lunitor_lwhisker.
        + rewrite <- !lwhisker_vcomp.
          rewrite <- !rwhisker_vcomp.
          rewrite !vassocl.
          refine (!_).
          etrans.
          {
            do 2 apply maponpaths.
            etrans.
            {
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                apply binprod_ump_2cell_pr2.
              }
              etrans.
              {
                apply maponpaths_2.
                apply binprod_ump_2cell_pr2.
              }
              rewrite !vassocl.
              apply maponpaths.
              etrans.
              {
                apply maponpaths.
                rewrite !vassocr.
                rewrite vcomp_linv.
                rewrite id2_left.
                apply idpath.
              }
              rewrite !vassocr.
              rewrite lwhisker_vcomp.
              apply idpath.
            }
            etrans.
            {
              apply maponpaths_2.
              apply binprod_ump_2cell_pr2.
            }
            rewrite !vassocl.
            etrans.
            {
              do 5 apply maponpaths.
              rewrite !vassocr.
              rewrite vcomp_linv.
              rewrite id2_left.
              apply idpath.
            }
            apply idpath.
          }
          etrans.
          {
            rewrite !vassocr.
            do 6 apply maponpaths_2.
            rewrite !vassocl.
            rewrite <- rwhisker_lwhisker_rassociator.
            rewrite !vassocr.
            rewrite <- rwhisker_lwhisker_rassociator.
            rewrite !vassocl.
            apply maponpaths.
            etrans.
            {
              do 2 apply maponpaths.
              apply binprod_ump_2cell_pr2.
            }
            etrans.
            {
              apply maponpaths_2.
              apply maponpaths.
              apply binprod_ump_2cell_pr2.
            }
            rewrite lwhisker_vcomp.
            apply maponpaths.
            rewrite !vassocl.
            do 2 apply maponpaths.
            rewrite !vassocr.
            rewrite vcomp_linv.
            rewrite id2_left.
            apply idpath.
          }
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite lwhisker_vcomp.
            rewrite !vassocl.
            rewrite vcomp_linv.
            rewrite id2_right.
            etrans.
            {
              apply maponpaths_2.
              rewrite <- !lwhisker_vcomp.
              apply idpath.
            }
            rewrite !vassocl.
            do 2 apply maponpaths.
            rewrite !vassocr.
            rewrite lwhisker_lwhisker.
            rewrite !vassocl.
            etrans.
            {
              apply maponpaths.
              rewrite !vassocr.
              rewrite <- vcomp_whisker.
              rewrite !vassocl.
              apply maponpaths.
              rewrite !vassocr.
              rewrite <- lwhisker_lwhisker_rassociator.
              rewrite !vassocl.
              apply maponpaths.
              rewrite !vassocr.
              rewrite lwhisker_vcomp.
              apply maponpaths_2.
              apply maponpaths.
              rewrite !vassocr.
              exact (!(psfunctor_runitor G f)).
            }
            etrans.
            {
              do 2 apply maponpaths.
              rewrite !vassocr.
              rewrite runitor_triangle.
              apply idpath.
            }
            etrans.
            {
              apply maponpaths.
              rewrite !vassocr.
              rewrite vcomp_runitor.
              apply idpath.
            }
            rewrite !vassocr.
            rewrite <- runitor_triangle.
            rewrite !vassocr.
            rewrite lassociator_rassociator.
            rewrite id2_left.
            rewrite !vassocl.
            rewrite vcomp_rinv.
            apply id2_right.
          }
          rewrite !lwhisker_vcomp.
          rewrite rinvunitor_runitor.
          rewrite id2_right.
          apply lunitor_lwhisker.
      - intros b₁ b₂ b₃ b₄ f g h ; cbn.
        apply TODO.
      - intros b₁ b₂ b₃ f g₁ g₂ α ; cbn.
        apply TODO.
      - intros b₁ b₂ b₃ f g₁ g₂ α ; cbn.
        apply TODO.
    Qed.

    Definition binprod_psfunctor_invertible_2cells
      : invertible_cells binprod_psfunctor_data.
    Proof.
      split ; cbn.
      - intros b.
        is_iso.
        + use binprod_ump_2cell_invertible.
          * is_iso.
          * is_iso.
        + use binprod_ump_2cell_invertible.
          * is_iso.
            ** apply property_from_invertible_2cell.
            ** apply psfunctor_id.
          * is_iso.
            ** apply property_from_invertible_2cell.
            ** apply psfunctor_id.
      - intros b₁ b₂ b₃ f g.
        is_iso.
        + apply pair_1cell_comp_invertible.
        + use binprod_ump_2cell_invertible.
          * is_iso.
            ** apply property_from_invertible_2cell.
            ** apply psfunctor_comp.
          * is_iso.
            ** apply property_from_invertible_2cell.
            ** apply psfunctor_comp.
    Defined.

    Definition binprod_psfunctor
      : psfunctor B₁ B₂.
    Proof.
      use make_psfunctor.
      - exact binprod_psfunctor_data.
      - exact binprod_psfunctor_laws.
      - exact binprod_psfunctor_invertible_2cells.
    Defined.

    Definition binprod_psfunctor_pr1_data
      : pstrans_data binprod_psfunctor F.
    Proof.
      use make_pstrans_data.
      - exact (λ x, π₁).
      - cbn.
        simple refine (λ x y f, _).
        use inv_of_invertible_2cell.
        apply pair_1cell_pr1.
    Defined.

    Definition binprod_psfunctor_pr1_is_pstrans
      : is_pstrans binprod_psfunctor_pr1_data.
    Proof.
      repeat split.
      - intros b₁ b₂ f g α ; cbn.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
        rewrite pair_2cell_pr1.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      - intros b ; cbn.
        rewrite <- rwhisker_vcomp.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          apply binprod_ump_2cell_pr1.
        }
        rewrite !vassocr.
        etrans.
        {
          do 2 apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            rewrite !vassocl.
            rewrite linvunitor_lunitor.
            apply id2_right.
          }
          apply runitor_rinvunitor.
        }
        rewrite id2_left.
        use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
        rewrite pair_2cell_pr1.
        rewrite !vassocl.
        apply maponpaths.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      - intros b₁ b₂ b₃ f g ; cbn.
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          do 6 apply maponpaths.
          apply pair_2cell_pr1.
        }
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite !vassocl.
        do 4 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          apply binprod_ump_2cell_pr1.
        }
        rewrite !vassocr.
        rewrite lassociator_rassociator, id2_left.
        rewrite !vassocl.
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        apply id2_left.
    Qed.

    Definition binprod_psfunctor_pr1
      : pstrans binprod_psfunctor F.
    Proof.
      use make_pstrans.
      - exact binprod_psfunctor_pr1_data.
      - exact binprod_psfunctor_pr1_is_pstrans.
    Defined.

    Definition binprod_psfunctor_pr2_data
      : pstrans_data binprod_psfunctor G.
    Proof.
      use make_pstrans_data.
      - exact (λ x, π₂).
      - cbn.
        simple refine (λ x y f, _).
        use inv_of_invertible_2cell.
        apply pair_1cell_pr2.
    Defined.

    Definition binprod_psfunctor_pr2_is_pstrans
      : is_pstrans binprod_psfunctor_pr2_data.
    Proof.
      repeat split.
      - intros b₁ b₂ f g α ; cbn.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        use vcomp_move_R_Mp ; [ is_iso | ] ; cbn.
        rewrite pair_2cell_pr2.
        rewrite !vassocl.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      - intros b ; cbn.
        rewrite <- rwhisker_vcomp.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          apply binprod_ump_2cell_pr2.
        }
        rewrite !vassocr.
        etrans.
        {
          do 2 apply maponpaths_2.
          etrans.
          {
            apply maponpaths_2.
            rewrite !vassocl.
            rewrite linvunitor_lunitor.
            apply id2_right.
          }
          apply runitor_rinvunitor.
        }
        rewrite id2_left.
        use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
        rewrite pair_2cell_pr2.
        rewrite !vassocl.
        apply maponpaths.
        rewrite vcomp_linv.
        rewrite id2_right.
        apply idpath.
      - intros b₁ b₂ b₃ f g ; cbn.
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          do 6 apply maponpaths.
          apply pair_2cell_pr2.
        }
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite !vassocl.
        do 4 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          apply binprod_ump_2cell_pr2.
        }
        rewrite !vassocr.
        rewrite lassociator_rassociator, id2_left.
        rewrite !vassocl.
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        apply id2_left.
    Qed.

    Definition binprod_psfunctor_pr2
      : pstrans binprod_psfunctor G.
    Proof.
      use make_pstrans.
      - exact binprod_psfunctor_pr2_data.
      - exact binprod_psfunctor_pr2_is_pstrans.
    Defined.

    Definition psfunctor_binprod_cone
      : binprod_cone F G.
    Proof.
      use make_binprod_cone.
      - exact binprod_psfunctor.
      - exact binprod_psfunctor_pr1.
      - exact binprod_psfunctor_pr2.
    Defined.

    Definition pstrans_pair_data
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : pstrans_data H binprod_psfunctor.
    Proof.
      use make_pstrans_data.
      - exact (λ x, ⟨ α x , β x ⟩).
      - intros x y f ; simpl.
        use make_invertible_2cell.
        + exact (precomp_prod_1cell _ _ _ _
                 • ⟪ lassociator _ _ _
                     • (prod_1cell_pr1 _ _ _ ▹ _)
                     • psnaturality_of α f
                   ,
                     lassociator _ _ _
                     • (prod_1cell_pr2 _ _ _ ▹ _)
                     • psnaturality_of β f
                   ⟫
                 • (precomp_prod_1cell_invertible _ _ _ _)^-1).
        + is_iso.
          * apply precomp_prod_1cell_invertible.
          * use binprod_ump_2cell_invertible.
            ** is_iso ; apply property_from_invertible_2cell.
            ** is_iso ; apply property_from_invertible_2cell.
    Defined.

    Definition pstrans_pair_is_pstrans
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : is_pstrans (pstrans_pair_data α β).
    Proof.
      repeat split.
      - intros b₁ b₂ f g τ ; cbn.
        use binprod_ump_2cell_unique_alt.
        + apply (pr2 B₂).
        + apply TODO.
        + apply TODO.
      - intros b ; cbn.
        use binprod_ump_2cell_unique_alt.
        + apply (pr2 B₂).
        + rewrite <- !lwhisker_vcomp.
          rewrite <- !rwhisker_vcomp.
          use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker.
          rewrite runitor_rwhisker.
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths_2.
            apply maponpaths.
            apply binprod_ump_2cell_pr1.
          }
          rewrite <- !lwhisker_vcomp.
          rewrite !vassocl.
          apply maponpaths.
          etrans.
          {
            do 2 apply maponpaths.
            rewrite !vassocr.
            rewrite <- rwhisker_lwhisker.
            rewrite !vassocl.
            etrans.
            {
              apply maponpaths_2.
              apply maponpaths.
              apply binprod_ump_2cell_pr1.
            }
            rewrite !vassocl.
            apply maponpaths.
            etrans.
            {
              apply maponpaths.
              apply maponpaths_2.
              apply binprod_ump_2cell_pr1.
            }
            rewrite !vassocr.
            rewrite lassociator_rassociator.
            rewrite id2_left.
            rewrite !vassocl.
            rewrite binprod_ump_2cell_pr1.
            etrans.
            {
              do 2 apply maponpaths.
              apply maponpaths_2.
              apply binprod_ump_2cell_pr1.
            }
            rewrite !vassocl.
            apply maponpaths.
            rewrite !vassocr.
            rewrite vcomp_linv.
            rewrite id2_left.
            rewrite !vassocl.
            etrans.
            {
              do 3 apply maponpaths.
              rewrite !vassocr.
              rewrite vcomp_linv.
              rewrite id2_left.
              apply idpath.
            }
            rewrite pstrans_id_alt.
            rewrite !vassocl.
            apply idpath.
          }
          etrans.
          {
            do 2 apply maponpaths.
            rewrite !vassocr.
            rewrite lwhisker_vcomp.
            rewrite !vassocl.
            rewrite vcomp_linv.
            rewrite id2_right.
            rewrite <- lwhisker_vcomp.
            etrans.
            {
              refine (vassocr _ _ _ @ _).
              apply maponpaths_2.
              rewrite !vassocl.
              rewrite lwhisker_lwhisker.
              apply idpath.
            }
            rewrite !vassocl.
            etrans.
            {
              do 2 apply maponpaths.
              do 2 refine (vassocr _ _ _ @ _).
              apply maponpaths_2.
              rewrite <- vcomp_whisker.
              rewrite !vassocl.
              rewrite lwhisker_vcomp.
              rewrite vcomp_rinv.
              rewrite lwhisker_id2.
              apply id2_right.
            }
            apply idpath.
          }
          do 3 refine (vassocr _ _ _ @ _).
          etrans.
          {
            do 2 apply maponpaths_2.
            rewrite !vassocl.
            rewrite lwhisker_vcomp.
            rewrite vcomp_linv.
            rewrite lwhisker_id2.
            apply id2_right.
          }
          rewrite rinvunitor_triangle.
          use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ].
          rewrite !vassocl.
          rewrite lassociator_rassociator.
          rewrite id2_right.
          rewrite rwhisker_rwhisker_alt.
          rewrite vcomp_whisker.
          rewrite !vassocr.
          apply maponpaths_2.
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite vcomp_runitor.
            rewrite !vassocl.
            apply maponpaths.
            rewrite !vassocr.
            rewrite linvunitor_natural.
            rewrite <- lwhisker_hcomp.
            rewrite !vassocl.
            rewrite lwhisker_vcomp.
            rewrite vcomp_rinv.
            rewrite lwhisker_id2.
            apply id2_right.
          }
          rewrite !vassocr.
          rewrite rinvunitor_runitor.
          rewrite id2_left.
          rewrite linvunitor_assoc.
          apply idpath.
        + apply TODO.
      - intros b₁ b₂ f g τ ; cbn.
        use binprod_ump_2cell_unique_alt.
        + apply (pr2 B₂).
        + apply TODO.
        + apply TODO.
    Time Qed.

    Definition pstrans_pair
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : pstrans H binprod_psfunctor.
    Proof.
      use make_pstrans.
      - exact (pstrans_pair_data α β).
      - exact (pstrans_pair_is_pstrans α β).
    Defined.

    Definition pstrans_pair_pr1_data
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : invertible_modification_data
          (comp_pstrans
             (pstrans_pair α β)
             binprod_psfunctor_pr1)
          α
      := λ x, prod_1cell_pr1 _ (α x) (β x).

    Definition pstrans_pair_pr1_is_modification
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : is_modification (pstrans_pair_pr1_data α β).
    Proof.
      intros x y f.
      simpl.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply prod_2cell_pr1.
        }
        apply maponpaths.
        apply maponpaths_2.
        apply binprod_ump_2cell_pr1.
      }
      rewrite !vassocl.
      etrans.
      {
        do 11 apply maponpaths.
        rewrite !vassocr.
        etrans.
        {
          apply maponpaths_2.
          apply lassociator_rassociator.
        }
        apply id2_left.
      }
      etrans.
      {
        do 9 apply maponpaths.
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        apply id2_right.
      }
      rewrite vcomp_linv.
      rewrite id2_right.
      rewrite !vassocr.
      apply maponpaths_2.
      refine (_ @ id2_left _).
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        apply maponpaths_2.
        apply binprod_ump_2cell_pr1.
      }
      rewrite !vassocl.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        apply id2_left.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        apply id2_left.
      }
      apply rassociator_lassociator.
    Qed.

    Definition pstrans_pair_pr1
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : invertible_modification
          (comp_pstrans
             (pstrans_pair α β)
             binprod_psfunctor_pr1)
          α.
    Proof.
      use make_invertible_modification.
      - exact (pstrans_pair_pr1_data α β).
      - exact (pstrans_pair_pr1_is_modification α β).
    Defined.

    Definition pstrans_pair_pr2_data
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : invertible_modification_data
          (comp_pstrans
             (pstrans_pair α β)
             binprod_psfunctor_pr2)
          β
      := λ x, prod_1cell_pr2 _ (α x) (β x).

    Definition pstrans_pair_pr2_is_modification
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : is_modification (pstrans_pair_pr2_data α β).
    Proof.
      intros x y f.
      simpl.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        etrans.
        {
          apply maponpaths_2.
          apply prod_2cell_pr2.
        }
        apply maponpaths.
        apply maponpaths_2.
        apply binprod_ump_2cell_pr2.
      }
      rewrite !vassocl.
      etrans.
      {
        do 11 apply maponpaths.
        rewrite !vassocr.
        etrans.
        {
          apply maponpaths_2.
          apply lassociator_rassociator.
        }
        apply id2_left.
      }
      etrans.
      {
        do 9 apply maponpaths.
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        apply id2_right.
      }
      rewrite vcomp_linv.
      rewrite id2_right.
      rewrite !vassocr.
      apply maponpaths_2.
      refine (_ @ id2_left _).
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        apply maponpaths_2.
        apply binprod_ump_2cell_pr2.
      }
      rewrite !vassocl.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_linv.
        apply id2_left.
      }
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite vcomp_linv.
        rewrite lwhisker_id2.
        apply id2_left.
      }
      apply rassociator_lassociator.
    Qed.

    Definition pstrans_pair_pr2
               {H : psfunctor B₁ B₂}
               (α : pstrans H F)
               (β : pstrans H G)
      : invertible_modification
          (comp_pstrans
             (pstrans_pair α β)
             binprod_psfunctor_pr2)
          β.
    Proof.
      use make_invertible_modification.
      - exact (pstrans_pair_pr2_data α β).
      - exact (pstrans_pair_pr2_is_modification α β).
    Defined.

    Definition prod_modification_data
               {H : psfunctor B₁ B₂}
               {α β : pstrans H binprod_psfunctor}
               (m : modification
                      (α · binprod_cone_pr1 psfunctor_binprod_cone)
                      (β · binprod_cone_pr1 psfunctor_binprod_cone))
               (n : modification
                      (α · binprod_cone_pr2 psfunctor_binprod_cone)
                      (β · binprod_cone_pr2 psfunctor_binprod_cone))
      : modification_data α β.
    Proof.
      intro x.
      use binprod_ump_2cell.
      - apply (pr2 B₂).
      - exact (m x).
      - exact (n x).
    Defined.

    Definition prod_modification_is_modification
               {H : psfunctor B₁ B₂}
               {α β : pstrans H binprod_psfunctor}
               (m : modification
                      (α · binprod_cone_pr1 psfunctor_binprod_cone)
                      (β · binprod_cone_pr1 psfunctor_binprod_cone))
               (n : modification
                      (α · binprod_cone_pr2 psfunctor_binprod_cone)
                      (β · binprod_cone_pr2 psfunctor_binprod_cone))
      : is_modification (prod_modification_data m n).
    Proof.
      intros x y f.
      use binprod_ump_2cell_unique_alt.
      - apply (pr2 B₂).
      - unfold prod_modification_data.
        rewrite <- !rwhisker_vcomp.
        use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ].
        simpl.
        rewrite !vassocl.
        rewrite <- rwhisker_lwhisker_rassociator.
        etrans.
        {
          do 3 apply maponpaths.
          apply binprod_ump_2cell_pr1.
        }
        pose (q := modnaturality_of m _ _ f).
        simpl in q.
        use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
        use (vcomp_lcancel (_ ◃  (pair_1cell_pr1 B₂ (# F f) (# G f)) ^-1)) ; [ is_iso | ].
        use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ].
        rewrite !vassocr.
        refine (q @ _) ; clear q.
        rewrite !vassocr.
        do 2 apply maponpaths_2.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          rewrite rwhisker_rwhisker.
          apply idpath.
        }
        rewrite !vassocr.
        apply maponpaths_2.
        etrans.
        {
          rewrite !vassocl.
          rewrite <- vcomp_whisker.
          apply idpath.
        }
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite <- rwhisker_rwhisker_alt.
        apply maponpaths_2.
        apply maponpaths.
        apply binprod_ump_2cell_pr1.
      - unfold prod_modification_data.
        rewrite <- !rwhisker_vcomp.
        use (vcomp_rcancel (rassociator _ _ _)) ; [ is_iso | ].
        simpl.
        rewrite !vassocl.
        rewrite <- rwhisker_lwhisker_rassociator.
        etrans.
        {
          do 3 apply maponpaths.
          apply binprod_ump_2cell_pr2.
        }
        pose (q := modnaturality_of n _ _ f).
        simpl in q.
        use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
        use (vcomp_lcancel (_ ◃  (pair_1cell_pr2 B₂ (# F f) (# G f)) ^-1)) ; [ is_iso | ].
        use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ].
        rewrite !vassocr.
        refine (q @ _) ; clear q.
        rewrite !vassocr.
        do 2 apply maponpaths_2.
        rewrite !vassocl.
        refine (!_).
        etrans.
        {
          do 2 apply maponpaths.
          rewrite rwhisker_rwhisker.
          apply idpath.
        }
        rewrite !vassocr.
        apply maponpaths_2.
        etrans.
        {
          rewrite !vassocl.
          rewrite <- vcomp_whisker.
          apply idpath.
        }
        rewrite !vassocr.
        apply maponpaths_2.
        rewrite <- rwhisker_rwhisker_alt.
        apply maponpaths_2.
        apply maponpaths.
        apply binprod_ump_2cell_pr2.
    Qed.

    Definition prod_modification
               {H : psfunctor B₁ B₂}
               {α β : pstrans H binprod_psfunctor}
               (m : modification
                      (α · binprod_cone_pr1 psfunctor_binprod_cone)
                      (β · binprod_cone_pr1 psfunctor_binprod_cone))
               (n : modification
                      (α · binprod_cone_pr2 psfunctor_binprod_cone)
                      (β · binprod_cone_pr2 psfunctor_binprod_cone))
      : modification α β.
    Proof.
      use make_modification.
      - exact (prod_modification_data m n).
      - exact (prod_modification_is_modification m n).
    Defined.

    Definition psfunctor_binprod_ump
      : has_binprod_ump psfunctor_binprod_cone.
    Proof.
      use make_binprod_ump.
      - intro q.
        use make_binprod_1cell.
        + exact (pstrans_pair (binprod_cone_pr1 q) (binprod_cone_pr2 q)).
        + exact (pstrans_pair_pr1 (binprod_cone_pr1 q) (binprod_cone_pr2 q)).
        + exact (pstrans_pair_pr2 (binprod_cone_pr1 q) (binprod_cone_pr2 q)).
      - intros q α β m n.
        exact (prod_modification m n).
      - abstract
          (intros H α β m n ;
           use modification_eq ;
           intros x ;
           apply binprod_ump_2cell_pr1).
      - abstract
          (intros H α β m n ;
           use modification_eq ;
           intros x ;
           apply binprod_ump_2cell_pr2).
      - abstract
          (intro ; intros ;
           use modification_eq ;
           intros x ;
           pose (modcomponent_eq γpr1 x) as p₁ ;
           pose (modcomponent_eq γpr2 x) as p₂ ;
           pose (modcomponent_eq δpr1 x) as p₃ ;
           pose (modcomponent_eq δpr2 x) as p₄ ;
           use (binprod_ump_2cell_unique
                  _
                  (pr111 α x)
                  (pr111 β x)
                  _ _
                  p₁ p₂ p₃ p₄) ;
           apply (pr2 B₂)).
    Defined.
  End BinprodPSFunctor.

  Definition psfunctor_has_binprod
    : has_binprod (psfunctor_bicat B₁ B₂).
  Proof.
    intros F G.
    simple refine (_ ,, _).
    - exact (psfunctor_binprod_cone F G).
    - exact (psfunctor_binprod_ump F G).
  Defined.
End FixProducts.
 *)


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import syntax_ott
               rules_inf
               Typing
               Subtyping_inversion.

(* TypedReduce *)
(*
Fixpoint top_value (A:typ) : exp :=
  match A with
  | t_prod A1 A2 => e_pair (top_value A1) (top_value A2)
  | _ => e_top
  end.

Lemma TypedReduce_ord_toplike_normal : forall (v v': exp) (A : typ),
    ord A -> topLike A -> TypedReduce v A v' -> v' = top_value A.
 *)

Lemma TypedReduce_ord_toplike_normal : forall (v v': exp) (A : typ),
    ord A -> topLike A -> TypedReduce v A v' -> v' = e_top.
Proof.
  introv H1 H2 Red.
  induction~ Red; try solve_false.
Qed.

Lemma TypedReduce_toplike :
  forall A, topLike A ->
            forall (v1 v2 v1' v2' : exp), TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.
Proof.
  intros A Typ.
  induction Typ;
    introv Red1 Red2.
  - forwards~: TypedReduce_ord_toplike_normal Red1.
    forwards~: TypedReduce_ord_toplike_normal Red2.
    subst*.
  - inverts~ Red1; try solve_false;
      inverts~ Red2; try solve_false.
    forwards: IHTyp1 H2 H3.
    forwards: IHTyp2 H4 H6.
    subst*.
  - forwards~: TypedReduce_ord_toplike_normal Red1.
    forwards~: TypedReduce_ord_toplike_normal Red2.
    subst*.
  - forwards~: TypedReduce_ord_toplike_normal Red1.
    forwards~: TypedReduce_ord_toplike_normal Red2.
    subst*.
Qed.

Lemma TypedReduce_sub: forall v v' A B,
    value v -> TypedReduce v A v' -> Typing nil v Inf B -> sub B A.
Proof.
  introv Val Red Pt. gen B.
  induction Red; intros;
    try solve [auto_sub];
    try solve [inverts~ Pt; auto_sub];
    (* merge *)
    inverts~ Val; inverts~ Pt.
Qed.

Lemma disjoint_val_consistent: forall A B v1 v2,
    disjointSpec A B -> value v1 -> value v2 -> Typing nil v1 Inf A -> Typing nil v2 Inf B -> consistencySpec v1 v2.
Proof.
  intros A B v1 v2 Dis Val1 Val2 Typ1 Typ2.
  unfold consistencySpec.
  introv Red1 Red2.
  forwards* Sub1': TypedReduce_sub Red1.
  forwards* Sub2': TypedReduce_sub Red2.
  subst.
  assert (Top: topLike A0). {
    unfold disjointSpec in Dis.
    apply~ Dis.
  }
  forwards*: TypedReduce_toplike Top Red1 Red2.
Qed.


Require Import Bmc.Basic.
Require Import Bmc.Example.

Require Import SMTC.Tactic.
Require Import SMTC.Integers.

Set SMT Solver "z3".
Set SMT Debug.
(*Unset SMT Debug.*)

Axiom by_smt : forall P : Prop, P.

(*Definition naive_post_conj (I : prop) (T : trans) (P : prop) (k : nat) : Prop :=
  safety_nth_conj I T P (S k).
*)

Goal naive_post_conj ex1_I ex1_T ex1_P 0.
Proof.
  unfold ex1_I; unfold ex1_T; unfold ex1_P.
  unfold naive_post_conj.
  unfold safety_nth_conj.
  unfold prop_nth_init_conj.
  unfold path.
  unfold nth.
  unfold sseq.
  unfold state.
  repeat rewrite -> Nat.add_0_l;
  repeat rewrite -> Nat.add_0_r.
  split.
  - intros.
    smt solve; apply by_smt.
  - intros.
    smt solve; apply by_smt.
Qed.

Goal naive_post_conj ex2_I ex2_T ex2_P 1.
Proof.
  unfold ex2_I; unfold ex2_T; unfold ex2_P.
  unfold naive_post_conj, safety_nth_conj, prop_nth_init_conj, path, nth, sseq, state.
  repeat rewrite -> Nat.add_0_l;
  repeat rewrite -> Nat.add_0_r.
  repeat split; intros; smt solve; apply by_smt.
Qed.

Goal naive_post_conj ex3_I ex3_T ex3_P 6.
Proof.
  unfold ex3_I; unfold ex3_T; unfold ex3_P.
  unfold naive_post_conj, safety_nth_conj, prop_nth_init_conj, path, nth, sseq, state.
  repeat rewrite -> Nat.add_0_l;
  repeat rewrite -> Nat.add_0_r.
  repeat split; intros; smt solve; apply by_smt.
Qed.

(* eof *)


(**

This file describes the representation and properties of inner-heap predicates.

Author: Bowen Zhang.

Date : 2021.07.24
*)

Set Implicit Arguments.
From SLF (* TLC *) Require Export LibCore TLCbuffer.
From SLF (* CBS *) Require Export Language.

(*** =========== Definition of inner-heap predicates =====================  ***)

(** Core file-heap predicates, and their associated notations:
    - [\f[]] denotes the empty file-heap predicate
    - [\f[P]] denotes a pure file fact
    - [p ~f~> v] denotes a singleton file-heap
    - [H1 \f* H2] denotes the file-heap predicates separating conjunction
    - [\existsf x, H] denotes an existential (about file)
    - [\forallf x, H] denotes a universal (about file)
*)

(** Core block-heap predicates, and their associated notations:
    - [\b[]] denotes the empty block-heap predicate
    - [\b[P]] denotes a pure block fact
    - [p ~b~> v] denotes a singleton block-heap
    - [H1 \b* H2] denotes the block-heap predicates separating conjunction
    - [\existsb x, H] denotes an existential (about block)
    - [\forallb x, H] denotes a universal (about block)
*)

Definition hbprop := heapb -> Prop.
Definition hfprop := heapf -> Prop.

Implicit Types P : Prop.
Implicit Types Hb : hbprop.
Implicit Types Hf : hfprop.
Implicit Types Qb : val->hbprop.
Implicit Types Qf : val->hfprop.

(*** =============================================== ***)
Definition hbempty : hbprop :=
  fun h => (h = Fmap.empty).

Definition hfempty : hfprop :=
  fun h => (h = Fmap.empty).

Notation "\b[]" := (hbempty)
  (at level 0) : hprop_scope.
Notation "\f[]" := (hfempty)
  (at level 0) : hprop_scope.

(* singleton *)

Definition hbsingle (bp:bloc) (ll:list int) : hbprop :=
  fun h => (h = Fmap.single bp ll /\ bp <> bnull).

Definition hfsingle (fp:floc) (lb:list bloc) : hfprop :=
  fun h => (h = Fmap.single fp lb /\ fp <> fnull).

Notation "bp '~b~>' ll" := (hbsingle bp ll) (at level 32) : hprop_scope.
Notation "fp '~f~>' lb" := (hfsingle fp lb) (at level 32) : hprop_scope.

(* sep star *)

Definition hbstar (H1 H2 : hbprop) : hbprop :=
  fun h => exists h1 h2, H1 h1
                              /\ H2 h2
                              /\ Fmap.disjoint h1 h2
                              /\ h = Fmap.union h1 h2.

Definition hfstar (H1 H2 : hfprop) : hfprop :=
  fun h => exists h1 h2, H1 h1
                              /\ H2 h2
                              /\ Fmap.disjoint h1 h2
                              /\ h = Fmap.union h1 h2.

Notation "H1 '\b*' H2" := (hbstar H1 H2)
  (at level 41, right associativity) : hprop_scope.
Notation "H1 '\f*' H2" := (hfstar H1 H2)
  (at level 41, right associativity) : hprop_scope.

Notation "Q \b*+ H" := (fun x => hbstar (Q x) H)
  (at level 40) : hprop_scope.

Notation "Q \f*+ H" := (fun x => hfstar (Q x) H)
  (at level 40) : hprop_scope.

(* sep exists *)
Definition hbexists {A:Type} (J:A->hbprop) : hbprop :=
  fun h => exists x, J x h.

Definition hfexists {A:Type} (J:A->hfprop) : hfprop :=
  fun h => exists x, J x h.

Notation "'\existsb' x1 .. xn , H" :=
  (hbexists (fun x1 => .. (hbexists (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\existsb' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

Notation "'\existsf' x1 .. xn , H" :=
  (hfexists (fun x1 => .. (hfexists (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\existsf' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

(* sep forall *)

Definition hbforall {A : Type} (J : A -> hbprop) : hbprop :=
  fun h => forall x, J x h.

Definition hfforall {A : Type} (J : A -> hfprop) : hfprop :=
  fun h => forall x, J x h.

Notation "'\forallb' x1 .. xn , H" :=
  (hbforall (fun x1 => .. (hbforall (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\forallb' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

Notation "'\forallf' x1 .. xn , H" :=
  (hfforall (fun x1 => .. (hfforall (fun xn => H)) ..))
  (at level 39, x1 binder, H at level 50, right associativity,
   format "'[' '\forallf' '/ '  x1  ..  xn , '/ '  H ']'") : hprop_scope.

(* sep pure *)
Open Scope hprop_scope.

Definition hbpure (P:Prop) : hbprop :=
  \existsb (p:P), \b[].

Definition hfpure (P:Prop) : hfprop :=
  \existsf (p:P), \f[].

Notation "\b[ P ]" := (hbpure P)
  (at level 0, format "\b[ P ]") : hprop_scope.

Notation "\f[ P ]" := (hfpure P)
  (at level 0, format "\f[ P ]") : hprop_scope.

(* ================================================================= *)
(** ** Basic properties of Inner-heap predicates operators *)

(* ----------------------------------------------------------------- *)
(** *** Tactic for automation *)

Hint Extern 1 (_ = _ :> heap) => fmap_eq.

Import Fmap.DisjointHints.

Tactic Notation "fmap_disjoint_pre" :=
  subst; rew_disjoint; jauto_set.

Hint Extern 1 (Fmap.disjoint _ _) => fmap_disjoint_pre.

(* ----------------------------------------------------------------- *)
(** the entailment relation *)

Definition hbimpl (H1 H2:hbprop) : Prop :=
  forall h, H1 h -> H2 h.
Definition hfimpl (H1 H2:hfprop) : Prop :=
  forall h, H1 h -> H2 h.

Notation "H1 =b=> H2" := (hbimpl H1 H2) (at level 55) : hprop_scope.
Notation "H1 =f=> H2" := (hfimpl H1 H2) (at level 55) : hprop_scope.

Definition qbimpl {A} (Q1 Q2:A->hbprop) : Prop :=
  forall (v:A), Q1 v =b=> Q2 v.
Definition qfimpl {A} (Q1 Q2:A->hfprop) : Prop :=
  forall (v:A), Q1 v =f=> Q2 v.

Notation "Q1 =b==> Q2" := (qbimpl Q1 Q2) (at level 55) : hprop_scope.
Notation "Q1 =f==> Q2" := (qfimpl Q1 Q2) (at level 55) : hprop_scope.

(*------the order relation in the set of inner-heap predicate--------*)
(* refl *)
Lemma hbimpl_refl : forall H,
  H =b=> H.
Proof using. introv M. auto. Qed.

Lemma hfimpl_refl : forall H,
  H =f=> H.
Proof using. introv M. auto. Qed.

Hint Resolve hbimpl_refl.
Hint Resolve hfimpl_refl.

(* trans *)

Lemma hbimpl_trans : forall H2 H1 H3,
  (H1 =b=> H2) ->
  (H2 =b=> H3) ->
  (H1 =b=> H3).
Proof using. introv M1 M2. unfolds* hbimpl. Qed.

Lemma hfimpl_trans : forall H2 H1 H3,
  (H1 =f=> H2) ->
  (H2 =f=> H3) ->
  (H1 =f=> H3).
Proof using. introv M1 M2. unfolds* hfimpl. Qed.

Lemma hbimpl_trans_r : forall H2 H1 H3,
   H2 =b=> H3 ->
   H1 =b=> H2 ->
   H1 =b=> H3.
Proof using. introv M1 M2. applys* hbimpl_trans M2 M1. Qed.

Lemma hfimpl_trans_r : forall H2 H1 H3,
   H2 =f=> H3 ->
   H1 =f=> H2 ->
   H1 =f=> H3.
Proof using. introv M1 M2. applys* hfimpl_trans M2 M1. Qed.

(* antisym *)

Lemma hbimpl_antisym : forall H1 H2,
  (H1 =b=> H2) ->
  (H2 =b=> H1) ->
  (H1 = H2).
Proof using. introv M1 M2. applys pred_ext_1. intros h. iff*. Qed.

Lemma hfimpl_antisym : forall H1 H2,
  (H1 =f=> H2) ->
  (H2 =f=> H1) ->
  (H1 = H2).
Proof using. introv M1 M2. applys pred_ext_1. intros h. iff*. Qed.

Lemma hbprop_op_comm : forall (op:hbprop->hbprop->hbprop),
  (forall H1 H2, op H1 H2 =b=> op H2 H1) ->
  (forall H1 H2, op H1 H2 = op H2 H1).
Proof using. introv M. intros. applys hbimpl_antisym; applys M. Qed.

Lemma hfprop_op_comm : forall (op:hfprop->hfprop->hfprop),
  (forall H1 H2, op H1 H2 =f=> op H2 H1) ->
  (forall H1 H2, op H1 H2 = op H2 H1).
Proof using. introv M. intros. applys hfimpl_antisym; applys M. Qed.

Lemma qbimpl_refl : forall A (Q:A->hbprop),
   Q =b==> Q.
Proof using. intros. unfolds*. Qed.

Lemma qfimpl_refl : forall A (Q:A->hfprop),
   Q =f==> Q.
Proof using. intros. unfolds*. Qed.

Hint Resolve qbimpl_refl.
Hint Resolve qfimpl_refl.

(*++++++++++ Some properties +++++++++++++*)
(* ----------------------------------------------------------------- *)
(** *** Properties of [hempty] *)

Lemma hb_empty_intro :
  \b[] hb_empty.
Proof using. unfolds*. Qed.

Lemma hb_empty_inv : forall h,
  \b[] h ->
  h = hb_empty.
Proof using. auto. Qed.

Lemma hf_empty_intro :
  \f[] hf_empty.
Proof using. unfolds*. Qed.

Lemma hf_empty_inv : forall h,
  \f[] h ->
  h = hf_empty.
Proof using. auto. Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hstar] *)

Lemma hbstar_intro : forall (H1 H2:hbprop) h1 h2,
  H1 h1 ->
  H2 h2 ->
  Fmap.disjoint h1 h2 ->
  (H1 \b* H2) (Fmap.union h1 h2).
Proof using. intros. exists~ h1 h2. Qed.

Lemma hbstar_inv : forall H1 H2 h,
  (H1 \b* H2) h ->
  exists h1 h2, H1 h1 /\ H2 h2 /\ Fmap.disjoint h1 h2 /\ h = Fmap.union h1 h2.
Proof using. introv M. applys M. Qed.

Lemma hfstar_intro : forall (H1 H2:hfprop) h1 h2,
  H1 h1 ->
  H2 h2 ->
  Fmap.disjoint h1 h2 ->
  (H1 \f* H2) (Fmap.union h1 h2).
Proof using. intros. exists~ h1 h2. Qed.

Lemma hfstar_inv : forall H1 H2 h,
  (H1 \f* H2) h ->
  exists h1 h2, H1 h1 /\ H2 h2 /\ Fmap.disjoint h1 h2 /\ h = Fmap.union h1 h2.
Proof using. introv M. applys M. Qed.

Lemma hbstar_comm : forall H1 H2,
   H1 \b* H2 = H2 \b* H1.
Proof using.
  applys hbprop_op_comm. unfold hbprop, hbstar. intros H1 H2.
  intros h (h1&h2&M1&M2&D&U). rewrite~ Fmap.union_comm_of_disjoint in U.
  exists* h2 h1.
Qed.

Lemma hfstar_comm : forall H1 H2,
   H1 \f* H2 = H2 \f* H1.
Proof using.
  applys hfprop_op_comm. unfold hbprop, hfstar. intros H1 H2.
  intros h (h1&h2&M1&M2&D&U). rewrite~ Fmap.union_comm_of_disjoint in U.
  exists* h2 h1.
Qed.

Lemma hbstar_assoc : forall H1 H2 H3,
  (H1 \b* H2) \b* H3 = H1 \b* (H2 \b* H3).
Proof using.
  intros H1 H2 H3. applys hbimpl_antisym; intros h.
  { intros (h'&h3&(h1&h2&M3&M4&D'&U')&M2&D&U). subst h'.
    exists h1 (h2 \+ h3). splits~. { applys* hbstar_intro. } rewrite~ union_assoc in U. }
  { intros (h1&h'&M1&(h2&h3&M3&M4&D'&U')&D&U). subst h'.
    exists (h1 \+ h2) h3. splits~. { applys* hbstar_intro. } rewrite <- union_assoc in U. auto. }
Qed.

Lemma hfstar_assoc : forall H1 H2 H3,
  (H1 \f* H2) \f* H3 = H1 \f* (H2 \f* H3).
Proof using.
  intros H1 H2 H3. applys hfimpl_antisym; intros h.
  { intros (h'&h3&(h1&h2&M3&M4&D'&U')&M2&D&U). subst h'.
    exists h1 (h2 \+ h3). splits~. { applys* hfstar_intro. } rewrite~ union_assoc in U. }
  { intros (h1&h'&M1&(h2&h3&M3&M4&D'&U')&D&U). subst h'.
    exists (h1 \+ h2) h3. splits~. { applys* hfstar_intro. } rewrite <- union_assoc in U. auto. }
Qed.

Lemma hbstar_hempty_l : forall H,
  \b[] \b* H = H.
Proof using.
  intros. applys hbimpl_antisym; intros h.
  { intros (h1&h2&M1&M2&D&U). forwards E: hb_empty_inv M1. subst.
    rewrite~ Fmap.union_empty_l. }
  { intros M. exists hb_empty h. splits~. { applys hb_empty_intro. } rewrite~ union_empty_l. }
Qed.

Lemma hfstar_hempty_l : forall H,
  \f[] \f* H = H.
Proof using.
  intros. applys hfimpl_antisym; intros h.
  { intros (h1&h2&M1&M2&D&U). forwards E: hf_empty_inv M1. subst.
    rewrite~ Fmap.union_empty_l. }
  { intros M. exists hf_empty h. splits~. { applys hf_empty_intro. } rewrite~ union_empty_l. }
Qed.

Lemma hbstar_hempty_r : forall (H:hbprop),
  H \b* \b[] = H.
Proof using.
  applys neutral_r_of_comm_neutral_l. applys~ hbstar_comm. applys~ hbstar_hempty_l.
Qed.

Lemma hfstar_hempty_r : forall (H:hfprop),
  H \f* \f[] = H.
Proof using.
  applys neutral_r_of_comm_neutral_l. applys~ hfstar_comm. applys~ hfstar_hempty_l.
Qed.

Lemma hbimpl_frame_l : forall (H2 H1 H1':hbprop) ,
  H1 =b=> H1' ->
  (H1 \b* H2) =b=> (H1' \b* H2).
Proof using. introv W (h1&h2&?). exists* h1 h2. Qed.

Lemma hfimpl_frame_l : forall (H2 H1 H1':hfprop) ,
  H1 =f=> H1' ->
  (H1 \f* H2) =f=> (H1' \f* H2).
Proof using. introv W (h1&h2&?). exists* h1 h2. Qed.

Lemma hbimpl_frame_r : forall H1 H2 H2',
  H2 =b=> H2' ->
  (H1 \b* H2) =b=> (H1 \b* H2').
Proof using.
  introv M. do 2 rewrite (@hbstar_comm H1). applys~ hbimpl_frame_l.
Qed.

Lemma hfimpl_frame_r : forall H1 H2 H2',
  H2 =f=> H2' ->
  (H1 \f* H2) =f=> (H1 \f* H2').
Proof using.
  introv M. do 2 rewrite (@hfstar_comm H1). applys~ hfimpl_frame_l.
Qed.

Lemma hbimpl_frame_lr : forall H1 H1' H2 H2',
  H1 =b=> H1' ->
  H2 =b=> H2' ->
  (H1 \b* H2) =b=> (H1' \b* H2').
Proof using.
  introv M1 M2. applys hbimpl_trans. applys~ hbimpl_frame_l M1. applys~ hbimpl_frame_r.
Qed.

Lemma hfimpl_frame_lr : forall H1 H1' H2 H2',
  H1 =f=> H1' ->
  H2 =f=> H2' ->
  (H1 \f* H2) =f=> (H1' \f* H2').
Proof using.
  introv M1 M2. applys hfimpl_trans. applys~ hfimpl_frame_l M1. applys~ hfimpl_frame_r.
Qed.

Lemma hbimpl_hstar_trans_l : forall H1 H2 H3 H4,
  H1 =b=> H2 ->
  H2 \b* H3 =b=> H4 ->
  H1 \b* H3 =b=> H4.
Proof using.
  introv M1 M2. applys hbimpl_trans M2. applys hbimpl_frame_l M1.
Qed.

Lemma hfimpl_hstar_trans_l : forall H1 H2 H3 H4,
  H1 =f=> H2 ->
  H2 \f* H3 =f=> H4 ->
  H1 \f* H3 =f=> H4.
Proof using.
  introv M1 M2. applys hfimpl_trans M2. applys hfimpl_frame_l M1.
Qed.

Lemma hbimpl_hstar_trans_r : forall H1 H2 H3 H4,
  H1 =b=> H2 ->
  H3 \b* H2 =b=> H4 ->
  H3 \b* H1 =b=> H4.
Proof using.
  introv M1 M2. applys hbimpl_trans M2. applys hbimpl_frame_r M1.
Qed.

Lemma hfimpl_hstar_trans_r : forall H1 H2 H3 H4,
  H1 =f=> H2 ->
  H3 \f* H2 =f=> H4 ->
  H3 \f* H1 =f=> H4.
Proof using.
  introv M1 M2. applys hfimpl_trans M2. applys hfimpl_frame_r M1.
Qed.

Lemma hbstar_hexists : forall A (J:A->hbprop) H,
  (hbexists J) \b* H = hbexists (fun x => (J x) \b* H).
Proof using.
  intros. applys hbimpl_antisym; intros h.
  { intros (h1&h2&(x&M1)&M2&D&U). exists~ x h1 h2. }
  { intros (x&(h1&h2&M1&M2&D&U)). exists h1 h2. splits~. { exists~ x. } }
Qed.

Lemma hfstar_hexists : forall A (J:A->hfprop) H,
  (hfexists J) \f* H = hfexists (fun x => (J x) \f* H).
Proof using.
  intros. applys hfimpl_antisym; intros h.
  { intros (h1&h2&(x&M1)&M2&D&U). exists~ x h1 h2. }
  { intros (x&(h1&h2&M1&M2&D&U)). exists h1 h2. splits~. { exists~ x. } }
Qed.

Lemma hbstar_hforall : forall H A (J:A->hbprop),
  (hbforall J) \b* H =b=> hbforall (J \b*+ H).
Proof using.
  intros. intros h M. destruct M as (h1&h2&M1&M2&D&U). intros x. exists~ h1 h2.
Qed.

Lemma hfstar_hforall : forall H A (J:A->hfprop),
  (hfforall J) \f* H =f=> hfforall (J \f*+ H).
Proof using.
  intros. intros h M. destruct M as (h1&h2&M1&M2&D&U). intros x. exists~ h1 h2.
Qed.

(* ----------------------------------------------------------------- *)
(** ***  Properties of [hpure] *)

Lemma hbpure_intro : forall P,
  P ->
  \b[P] hb_empty.
Proof using. introv M. exists M. unfolds*. Qed.

Lemma hfpure_intro : forall P,
  P ->
  \f[P] hf_empty.
Proof using. introv M. exists M. unfolds*. Qed.

Lemma hbpure_inv : forall P h,
  \b[P] h ->
  P /\ h = hb_empty.
Proof using. introv (p&M). split~. Qed.

Lemma hfpure_inv : forall P h,
  \f[P] h ->
  P /\ h = hf_empty.
Proof using. introv (p&M). split~. Qed.

Lemma hbstar_hpure : forall P H h,
  (\b[P] \b* H) h = (P /\ H h).
Proof using.
  intros. apply prop_ext. unfold hbpure.
  rewrite hbstar_hexists. rewrite* hbstar_hempty_l.
  iff (p&M) (p&M). { split~. } { exists~ p. }
Qed.

Lemma hfstar_hpure : forall P H h,
  (\f[P] \f* H) h = (P /\ H h).
Proof using.
  intros. apply prop_ext. unfold hfpure.
  rewrite hfstar_hexists. rewrite* hfstar_hempty_l.
  iff (p&M) (p&M). { split~. } { exists~ p. }
Qed.

Lemma hbstar_hpure_iff : forall P H h,
  (\b[P] \b* H) h <-> (P /\ H h).
Proof using. intros. rewrite* hbstar_hpure. Qed.

Lemma hfstar_hpure_iff : forall P H h,
  (\f[P] \f* H) h <-> (P /\ H h).
Proof using. intros. rewrite* hfstar_hpure. Qed.

Lemma hbimpl_hstar_hpure_r : forall P H H',
  P ->
  (H =b=> H') ->
  H =b=> (\b[P] \b* H').
Proof using. introv HP W. intros h K. rewrite* hbstar_hpure. Qed.

Lemma hfimpl_hstar_hpure_r : forall P H H',
  P ->
  (H =f=> H') ->
  H =f=> (\f[P] \f* H').
Proof using. introv HP W. intros h K. rewrite* hfstar_hpure. Qed.

Lemma hbpure_inv_hempty : forall P h,
  \b[P] h ->
  P /\ \b[] h.
Proof using.
  introv M. rewrite <- hbstar_hpure. rewrite~ hbstar_hempty_r.
Qed.

Lemma hfpure_inv_hempty : forall P h,
  \f[P] h ->
  P /\ \f[] h.
Proof using.
  introv M. rewrite <- hfstar_hpure. rewrite~ hfstar_hempty_r.
Qed.

Lemma hbpure_intro_hempty : forall P h,
  \b[] h ->
  P ->
  \b[P] h.
Proof using.
  introv M N. rewrite <- (hbstar_hempty_l \b[P]).
  rewrite hbstar_comm. rewrite~ hbstar_hpure.
Qed.

Lemma hfpure_intro_hempty : forall P h,
  \f[] h ->
  P ->
  \f[P] h.
Proof using.
  introv M N. rewrite <- (hfstar_hempty_l \f[P]).
  rewrite hfstar_comm. rewrite~ hfstar_hpure.
Qed.

Lemma hbimpl_hempty_hpure : forall P,
  P ->
  \b[] =b=> \b[P].
Proof using. introv HP. intros h Hh. applys* hbpure_intro_hempty. Qed.

Lemma hfimpl_hempty_hpure : forall P,
  P ->
  \f[] =f=> \f[P].
Proof using. introv HP. intros h Hh. applys* hfpure_intro_hempty. Qed.

Lemma hbimpl_hstar_hpure_l : forall P H H',
  (P -> H =b=> H') ->
  (\b[P] \b* H) =b=> H'.
Proof using.
  introv W Hh. rewrite hbstar_hpure in Hh. applys* W.
Qed.

Lemma hfimpl_hstar_hpure_l : forall P H H',
  (P -> H =f=> H') ->
  (\f[P] \f* H) =f=> H'.
Proof using.
  introv W Hh. rewrite hfstar_hpure in Hh. applys* W.
Qed.

Lemma hbempty_eq_hpure_true :
  \b[] = \b[True].
Proof using.
  applys hbimpl_antisym; intros h M.
  { applys* hbpure_intro_hempty. }
  { forwards*: hbpure_inv_hempty M. }
Qed.

Lemma hfempty_eq_hpure_true :
  \f[] = \f[True].
Proof using.
  applys hfimpl_antisym; intros h M.
  { applys* hfpure_intro_hempty. }
  { forwards*: hfpure_inv_hempty M. }
Qed.

Lemma hbfalse_hstar_any : forall H,
  \b[False] \b* H = \b[False].
Proof using.
  intros. applys hbimpl_antisym; intros h; rewrite hbstar_hpure; intros M.
  { false*. } { lets: hbpure_inv_hempty M. false*. }
Qed.

Lemma hffalse_hstar_any : forall H,
  \f[False] \f* H = \f[False].
Proof using.
  intros. applys hfimpl_antisym; intros h; rewrite hfstar_hpure; intros M.
  { false*. } { lets: hfpure_inv_hempty M. false*. }
Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hexists] *)

Lemma hbexists_intro : forall A (x:A) (J:A->hbprop) h,
  J x h ->
  (hbexists J) h.
Proof using. intros. exists~ x. Qed.

Lemma hfexists_intro : forall A (x:A) (J:A->hfprop) h,
  J x h ->
  (hfexists J) h.
Proof using. intros. exists~ x. Qed.

Lemma hbexists_inv : forall A (J:A->hbprop) h,
  (hbexists J) h ->
  exists x, J x h.
Proof using. intros. destruct H as [x H]. exists~ x. Qed.

Lemma hfexists_inv : forall A (J:A->hfprop) h,
  (hfexists J) h ->
  exists x, J x h.
Proof using. intros. destruct H as [x H]. exists~ x. Qed.

Lemma hbimpl_hexists_l : forall A H (J:A->hbprop),
  (forall x, J x =b=> H) ->
  (hbexists J) =b=> H.
Proof using. introv W. intros h (x&Hh). applys* W. Qed.

Lemma hbimpl_hexists_r : forall A (x:A) H J,
  (H =b=> J x) ->
  H =b=> (hbexists J).
Proof using. introv W. intros h. exists x. apply~ W. Qed.

Lemma hfimpl_hexists_l : forall A H (J:A->hfprop),
  (forall x, J x =f=> H) ->
  (hfexists J) =f=> H.
Proof using. introv W. intros h (x&Hh). applys* W. Qed.

Lemma hfimpl_hexists_r : forall A (x:A) H J,
  (H =f=> J x) ->
  H =f=> (hfexists J).
Proof using. introv W. intros h. exists x. apply~ W. Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hforall] *)

Lemma hbforall_intro : forall A (J:A->hbprop) h,
  (forall x, J x h) ->
  (hbforall J) h.
Proof using. introv M. applys* M. Qed.

Lemma hfforall_intro : forall A (J:A->hfprop) h,
  (forall x, J x h) ->
  (hfforall J) h.
Proof using. introv M. applys* M. Qed.

Lemma hbforall_inv : forall A (J:A->hbprop) h,
  (hbforall J) h ->
  forall x, J x h.
Proof using. introv M. applys* M. Qed.

Lemma hfforall_inv : forall A (J:A->hfprop) h,
  (hfforall J) h ->
  forall x, J x h.
Proof using. introv M. applys* M. Qed.

Lemma hbimpl_hforall_r : forall A (J:A->hbprop) H,
  (forall x, H =b=> J x) ->
  H =b=> (hbforall J).
Proof using. introv M. intros h Hh x. apply~ M. Qed.

Lemma hbimpl_hforall_l : forall A x (J:A->hbprop) H,
  (J x =b=> H) ->
  (hbforall J) =b=> H.
Proof using. introv M. intros h Hh. apply~ M. Qed.

Lemma hfimpl_hforall_r : forall A (J:A->hfprop) H,
  (forall x, H =f=> J x) ->
  H =f=> (hfforall J).
Proof using. introv M. intros h Hh x. apply~ M. Qed.

Lemma hfimpl_hforall_l : forall A x (J:A->hfprop) H,
  (J x =f=> H) ->
  (hfforall J) =f=> H.
Proof using. introv M. intros h Hh. apply~ M. Qed.

Lemma hbforall_specialize : forall A (x:A) (J:A->hbprop),
  (hbforall J) =b=> (J x).
Proof using. intros. applys* hbimpl_hforall_l x. Qed.

Lemma hfforall_specialize : forall A (x:A) (J:A->hfprop),
  (hfforall J) =f=> (J x).
Proof using. intros. applys* hfimpl_hforall_l x. Qed.

(* ----------------------------------------------------------------- *)
(** *** Properties of [hsingle] *)

Lemma hbsingle_intro : forall p (v:list int),
  p <> bnull ->
  (p ~b~> v) (Fmap.single p v).
Proof using. introv N. hnfs*. Qed.

Lemma hfsingle_intro : forall p (v:list bloc),
  p <> fnull ->
  (p ~f~> v) (Fmap.single p v).
Proof using. introv N. hnfs*. Qed.

Lemma hfsingle_inv: forall p (v:list bloc) h,
  (p ~f~> v) h ->
  h = Fmap.single p v /\ p <> fnull.
Proof using. auto. Qed.

Lemma hbsingle_inv: forall p (v:list int) h,
  (p ~b~> v) h ->
  h = Fmap.single p v /\ p <> bnull.
Proof using. auto. Qed.

Lemma hbsingle_not_null : forall p (v:list int),
  (p ~b~> v) =b=> (p ~b~> v) \b* \b[p <> bnull].
Proof using.
  introv. intros h (K&N). rewrite hbstar_comm, hbstar_hpure.
  split*. subst. applys* hbsingle_intro.
Qed.

Lemma hfsingle_not_null : forall p (v:list bloc),
  (p ~f~> v) =f=> (p ~f~> v) \f* \f[p <> fnull].
Proof using.
  introv. intros h (K&N). rewrite hfstar_comm, hfstar_hpure.
  split*. subst. applys* hfsingle_intro.
Qed.

Lemma hbstar_hsingle_same_loc : forall p (v1 v2:list int),
  (p ~b~> v1) \b* (p ~b~> v2) =b=> \b[False].
Proof using.
  intros. unfold hbsingle. intros h (h1&h2&E1&E2&D&E). false.
  subst. applys* Fmap.disjoint_single_single_same_inv.
Qed.

Lemma hfstar_hsingle_same_loc : forall p (v1 v2:list bloc),
  (p ~f~> v1) \f* (p ~f~> v2) =f=> \f[False].
Proof using.
  intros. unfold hfsingle. intros h (h1&h2&E1&E2&D&E). false.
  subst. applys* Fmap.disjoint_single_single_same_inv.
Qed.
Arguments hbstar_hsingle_same_loc : clear implicits.
Arguments hfstar_hsingle_same_loc : clear implicits.


Load AS_Exec.

Definition instruction_sequence : list instruction :=
[
inst_pushscope;
inst_constructsuper (Int.repr (0));
inst_pushbyte (Int.repr 2147483648);
inst_pushbyte (Int.repr 2147483648);
inst_add;
inst_returnvoid
].

Definition instruction_sequence1 : list instruction :=
[
inst_pushscope;
inst_constructsuper (Int.repr (0));
inst_pushbyte (Int.repr (3));
inst_pushbyte (Int.repr (4));
inst_add;
inst_returnvoid
].

Definition instruction_sequence2 : list instruction :=
[
inst_pushscope;
inst_constructsuper (Int.repr (0));
inst_pushbyte (Int.repr (Z.neg 2147483648));
inst_pushbyte (Int.repr (Z.neg 2147483648));
inst_add;
inst_returnvoid
].

Eval compute in startExec instruction_sequence (createState (null) 0 (data (Int.repr 0) false false) (data (Int.repr 0) false true) (data (Int.repr 0) false true) (data (Int.repr 0) false true)).
Eval compute in startExec instruction_sequence1 (createState (null) 0 (data (Int.repr 0) false false) (data (Int.repr 0) false true) (data (Int.repr 0) false true) (data (Int.repr 0) false true)).
Eval compute in startExec instruction_sequence2 (createState (null) 0 (data (Int.repr 0) false false) (data (Int.repr 0) false true) (data (Int.repr 0) false true) (data (Int.repr 0) false true)).