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

 Preservation of equifiers by right biadjoints

 ******************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.CategoryTheory.Subcategory.FullEquivalences.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.Properties.
Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.Limits.Equifiers.

Local Open Scope cat.

Section BiadjunctionPreservation.
  Context {B₁ B₂ : bicat}
          {L : psfunctor B₁ B₂}
          (R : left_biadj_data L).

  Section PreserveEquifiers.
    Context {y₁ y₂ : B₂}
            {f g : y₁ --> y₂}
            {α β : f ==> g}
            {e : equifier_cone f g α β}
            (He : has_equifier_ump e).

    Definition preserve_equifiers_R_path
               {x : B₁}
               (h : L x --> y₁)
               (p : h ◃ α = h ◃ β)
      : biadj_unit R x · # R h ◃ ## R α
        =
        biadj_unit R x · # R h ◃ ## R β.
    Proof.
      pose (maponpaths
              (λ z, psfunctor_comp _ _ _ • ##R z)
              p)
        as q.
      cbn -[psfunctor_comp] in q.
      rewrite !psfunctor_lwhisker in q.
      use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite <- !lwhisker_lwhisker.
      apply maponpaths_2.
      apply maponpaths.
      use (vcomp_rcancel (psfunctor_comp R h g)).
      {
        apply property_from_invertible_2cell.
      }
      exact q.
    Qed.

    Definition right_biadj_preserves_equifiers_nat_trans_cell
               {x : B₁}
               (h : x --> R e)
      : biadj_unit R x · # R (# L h · biadj_counit R e · equifier_cone_pr1 e)
        ==>
        h · # R (equifier_cone_pr1 e)
      := (_ ◃ ((psfunctor_comp R _ _)^-1
               • ((psfunctor_comp R _ _)^-1 ▹ _)))
         • lassociator _ _ _
         • (lassociator _ _ _ ▹ _)
         • (((psnaturality_of (biadj_unit R) h) ▹ _) ▹ _)
         • rassociator _ _ _
         • rassociator _ _ _
         • (_ ◃ (lassociator _ _ _
                 • ((linvunitor _
                 • (_ ◃ (_ ◃ (linvunitor _ • (_ ◃ rinvunitor _))))
                 • invertible_modcomponent_of (biadj_triangle_r R) e) ▹ _)
                 • lunitor _)).

    Definition right_biadj_preserves_equifiers_commute_data
               (x : B₁)
      : nat_trans_data
          (biadj_left_hom R x e
           ∙ to_universal_equifier_cat e (L x)
           ∙ full_sub_category_functor
               (λ (h : hom (L x) y₁),
                make_hProp
                  (h ◃ α = h ◃ β)
                  (cellset_property _ _ _ _))
               (λ (h : hom x (R y₁)),
                make_hProp
                  (h ◃ ## R α = h ◃ ## R β)
                  (cellset_property _ _ _ _))
               (biadj_right_hom R x y₁)
               preserve_equifiers_R_path)
          (to_universal_equifier_cat (psfunctor_equifier_cone R e) x)
      := λ h, right_biadj_preserves_equifiers_nat_trans_cell h ,, tt.

    Definition right_biadj_preserves_equifiers_commute_is_nat_trans
               (x : B₁)
      : is_nat_trans
          _ _
          (right_biadj_preserves_equifiers_commute_data x).
    Proof.
      intros h₁ h₂ ζ.
      use subtypePath.
      {
        intro.
        apply isapropunit.
      }
      cbn.
      unfold right_biadj_preserves_equifiers_nat_trans_cell.
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        rewrite lwhisker_vcomp.
        etrans.
        {
          apply maponpaths.
          assert (## R ((## L ζ ▹ biadj_counit R e) ▹ equifier_cone_pr1 e)
                  • (psfunctor_comp R _ _)^-1
                  =
                  (psfunctor_comp R _ _)^-1
                  • (## R (## L ζ ▹ biadj_counit R e) ▹ # R (equifier_cone_pr1 e)))
            as H.
          {
            use vcomp_move_R_Mp ; [ is_iso | ].
            rewrite !vassocl.
            use vcomp_move_L_pM ; [ is_iso | ].
            exact (psfunctor_rwhisker
                     R
                     (equifier_cone_pr1 e)
                     (## L ζ ▹ biadj_counit R e)).
          }
          exact H.
        }
        rewrite <- lwhisker_vcomp.
        apply idpath.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        rewrite lwhisker_vcomp.
        rewrite rwhisker_vcomp.
        etrans.
        {
          do 2 apply maponpaths.
          assert (## R (## L ζ ▹ biadj_counit R e)
                  • ( psfunctor_comp R _ _)^-1
                  =
                  (psfunctor_comp R _ _)^-1
                  • (## R (## L ζ) ▹ # R (biadj_counit R e)))
            as H.
          {
            use vcomp_move_R_Mp ; [ is_iso | ].
            rewrite !vassocl.
            use vcomp_move_L_pM ; [ is_iso | ].
            exact (psfunctor_rwhisker R (biadj_counit R e) (##L ζ)).
          }
          exact H.
        }
        rewrite <- rwhisker_vcomp.
        rewrite <- lwhisker_vcomp.
        apply idpath.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply rwhisker_lwhisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (rwhisker_vcomp _ _ _ @ _).
        etrans.
        {
          apply maponpaths.
          apply rwhisker_lwhisker.
        }
        exact (!(rwhisker_vcomp _ _ _)).
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (rwhisker_vcomp _ _ _ @ _).
        etrans.
        {
          apply maponpaths.
          refine (rwhisker_vcomp _ _ _ @ _).
          etrans.
          {
            apply maponpaths.
            exact (psnaturality_natural (biadj_unit R) _ _ _ _ ζ).
          }
          cbn.
          exact (!(rwhisker_vcomp _ _ _)).
        }
        exact (!(rwhisker_vcomp _ _ _)).
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply rwhisker_rwhisker_alt.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply rwhisker_rwhisker_alt.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      apply vcomp_whisker.
    Qed.

    Definition right_biadj_preserves_equifiers_commute
               (x : B₁)
      : biadj_left_hom R x e
        ∙ to_universal_equifier_cat e (L x)
        ∙ full_sub_category_functor
            (λ (h : hom (L x) y₁),
             make_hProp
               (h ◃ α = h ◃ β)
               (cellset_property _ _ _ _))
            (λ (h : hom x (R y₁)),
             make_hProp
               (h ◃ ## R α = h ◃ ## R β)
               (cellset_property _ _ _ _))
            (biadj_right_hom R x y₁)
            preserve_equifiers_R_path
        ⟹
        to_universal_equifier_cat (psfunctor_equifier_cone R e) x.
    Proof.
      use make_nat_trans.
      - exact (right_biadj_preserves_equifiers_commute_data x).
      - exact (right_biadj_preserves_equifiers_commute_is_nat_trans x).
    Defined.

    Definition right_biadj_preserves_equifiers_commute_is_nat_z_iso
               (x : B₁)
      : is_nat_z_iso (right_biadj_preserves_equifiers_commute x).
    Proof.
      intro h.
      use is_iso_full_sub.
      use is_inv2cell_to_is_z_iso.
      cbn.
      unfold right_biadj_preserves_equifiers_nat_trans_cell.
      is_iso.
      - apply property_from_invertible_2cell.
      - apply property_from_invertible_2cell.
    Defined.

    Definition preserve_equifiers_L_path
               {x : B₁}
               (h : x --> R y₁)
               (p : h ◃ ## R α = h ◃ ## R β)
      : # L h · biadj_counit R y₁ ◃ α
        =
        # L h · biadj_counit R y₁ ◃ β.
    Proof.
      pose (maponpaths
              (λ z, psfunctor_comp _ _ _ • ##L z • (psfunctor_comp _ _ _)^-1)
              p)
        as q.
      cbn -[psfunctor_comp] in q.
      rewrite !psfunctor_lwhisker in q.
      rewrite !vassocl in q.
      rewrite !vcomp_rinv in q.
      rewrite !id2_right in q.
      use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
      rewrite <- !lwhisker_lwhisker.
      apply maponpaths_2.
      use (vcomp_rcancel (_ ◃ psnaturality_of (biadj_counit R) g)).
      {
        is_iso.
        apply property_from_invertible_2cell.
      }
      rewrite !lwhisker_vcomp.
      etrans.
      {
        apply maponpaths.
        exact (psnaturality_natural (biadj_counit R) _ _ _ _ α).
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        exact (psnaturality_natural (biadj_counit R) _ _ _ _ β).
      }
      refine (!_).
      cbn.
      rewrite <- !lwhisker_vcomp.
      apply maponpaths.
      use (vcomp_rcancel (lassociator _ _ _)).
      {
        is_iso.
      }
      rewrite !rwhisker_lwhisker.
      do 2 apply maponpaths.
      exact q.
    Qed.
  End PreserveEquifiers.

  Definition right_biadj_preserves_equifiers
             (HB₁ : is_univalent_2_1 B₁)
             (HB₂ : is_univalent_2_1 B₂)
    : preserves_equifiers R.
  Proof.
    intros y₁ y₂ f g α β e He.
    use universal_equifier_cone_has_ump.
    intro x.
    use nat_iso_adj_equivalence_of_cats.
    - exact (biadj_left_hom R x e
             ∙ to_universal_equifier_cat e (L x)
             ∙ full_sub_category_functor
                 (λ (h : hom (L x) y₁),
                  make_hProp
                    (h ◃ α = h ◃ β)
                    (cellset_property _ _ _ _))
                 (λ (h : hom x (R y₁)),
                  make_hProp
                    (h ◃ ## R α = h ◃ ## R β)
                    (cellset_property _ _ _ _))
                 (biadj_right_hom R x y₁)
                 preserve_equifiers_R_path).
    - exact (right_biadj_preserves_equifiers_commute x).
    - exact (right_biadj_preserves_equifiers_commute_is_nat_z_iso x).
    - use comp_adj_equivalence_of_cats.
      + use comp_adj_equivalence_of_cats.
        * exact (biadj_hom_equiv R x e).
        * apply (make_is_universal_equifier_cone HB₂ _ He).
      + use full_sub_category_adj_equivalence.
        * exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₁)).
        * exact preserve_equifiers_L_path.
  Defined.
End BiadjunctionPreservation.


Require Import
        Fiat.Computation
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.BaseFormats.

Definition composeIf {S T}
           {cache : Cache}
           {monoid : Monoid T}
           (formatT : FormatM S T)
           (formatE : FormatM S T)
  := Union_Format (Vector.cons _ formatT _ (Vector.cons _ formatE _ (Vector.nil _))).

Notation "'Either' t 'Or' e " :=
  (composeIf t e) : format_scope.

Lemma composeIf_format_correct
      {S V T}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_invT P_invE : (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_invT P /\ P_invE P))
      (monoid : Monoid T)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (view : S -> V -> Prop)
      (ICompb : T -> bool)
      (formatT formatE : FormatM S T)
      (decodeT decodeE : DecodeM (V * T) T)
      (view_formatT view_formatE : FormatM V T)
      (decodeT_pf :
         cache_inv_Property P P_invT
         -> CorrectDecoder
              monoid
              Source_Predicate
              View_Predicate
              view
              formatT decodeT P
              view_formatT)
      (decodeE_pf :
         cache_inv_Property P P_invE
         -> CorrectDecoder
              monoid Source_Predicate
              View_Predicate
              view
              formatE decodeE P
              view_formatE)
      (ICompb_OKT : forall data bin env xenv ext,
          Source_Predicate data
          -> formatT data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = true)
      (ICompb_OKE : forall data bin env xenv ext,
          Source_Predicate data
          -> formatE data env ↝ (bin, xenv)
          -> ICompb (mappend bin ext) = false)
  : CorrectDecoder
      monoid
      Source_Predicate
      View_Predicate
      view
      (composeIf formatT formatE)
      (fun (b : T) (env : CacheDecode) =>
         If ICompb b Then
            decodeT b env
            Else
            decodeE b env
      ) P
      (composeIf view_formatT view_formatE).
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm com_pf.
    unfold composeIf, Union_Format, Bind2 in com_pf.
      rewrite unfold_computes in com_pf; destruct_ex.
      revert H; pattern x; apply IterateBoundedIndex.Iterate_Ensemble_BoundedIndex_equiv; simpl.
      constructor; intros; [ | constructor; eauto].
    - erewrite ICompb_OKT; eauto.
      eapply (decodeT_pf (proj1 P_inv_pf)) with (ext := ext) in H; eauto.
      destruct_ex; split_and.
      simpl; eexists _, _; intuition eauto.
      unfold composeIf, Union_Format.
      apply unfold_computes; eexists Fin.F1; simpl; eauto.
    - intros; erewrite ICompb_OKE; eauto.
      eapply (decodeE_pf (proj2 P_inv_pf)) with (ext := ext) in H; eauto.
      destruct_ex; split_and.
      simpl; eexists _, _; intuition eauto.
      unfold composeIf, Union_Format.
      apply unfold_computes; eexists (Fin.FS Fin.F1); simpl; eauto.
  }
  { intros.
    destruct (ICompb t) eqn : IComp_v ; simpl in *.
    - eapply decodeT_pf in H1; intuition eauto.
      destruct_ex; intuition; eexists _, _;
        unfold composeIf; intuition eauto.
      unfold Union_Format; apply unfold_computes; eexists (Fin.F1); simpl; eauto.
    - eapply decodeE_pf in H1; intuition eauto.
      destruct_ex; intuition; eexists _, _;
        unfold composeIf; intuition eauto.
      unfold Union_Format; apply unfold_computes; eexists (Fin.FS Fin.F1); simpl; eauto.
  }
Qed.

Lemma composeIf_format_correct'
      {S V T}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {P_invT P_invE P_invS: (CacheDecode -> Prop) -> Prop}
      (P_inv_pf : cache_inv_Property P (fun P => P_invT P /\ P_invE P /\ P_invS P))
      (monoid : Monoid T)
      (Source_Predicate : S -> Prop)
      (View_Predicate : V -> Prop)
      (view : S -> V -> Prop)
      (formatT formatE : FormatM S T)
      (subformat : FormatM S T)
      (decodeT decodeE : DecodeM (V * T) T)
      (decodeB : DecodeM (bool * T) T)
      (view_formatT view_formatE : FormatM V T)
      (decodeT_pf :
         cache_inv_Property P P_invT
         -> CorrectDecoder
              monoid
              Source_Predicate
              View_Predicate
              view
              formatT decodeT P
              view_formatT)
      (decodeE_pf :
         cache_inv_Property P P_invE
         -> CorrectDecoder
              monoid Source_Predicate
              View_Predicate
              view
              formatE decodeE P
              view_formatE)
      (decodeB_pf :
         cache_inv_Property P P_invS
         -> CorrectRefinedDecoder
              monoid
              Source_Predicate
              (fun bs => True)
              (fun s bs => True)
              (composeIf formatT formatE)
              subformat
              decodeB P
              (fun bs env t => (forall s t' env', Source_Predicate s ->
                                          (formatT s env (mappend (fst t) t', env') -> bs = true)
                                          /\ (formatE s env (mappend (fst t) t', env') -> bs = false)))
           /\ Prefix_Format _ (composeIf formatT formatE) subformat)
  : CorrectDecoder
      monoid
      Source_Predicate
      View_Predicate
      view
      (composeIf formatT formatE)
      (fun (t : T) (env : CacheDecode) =>
         `(b, _, _) <- decodeB t env;
           If b Then decodeT t env
              Else decodeE t env
      ) P
      (composeIf view_formatT view_formatE).
Proof.
  unfold cache_inv_Property in *; split.
  { intros env env' xenv data bin ext ? env_pm pred_pm com_pf.
    generalize com_pf; intro.
    subst.
    unfold composeIf, Union_Format, Bind2 in com_pf0.
    rewrite unfold_computes in com_pf0; destruct_ex.
    revert H; pattern x; apply IterateBoundedIndex.Iterate_Ensemble_BoundedIndex_equiv; simpl.
    constructor; intros; [ | constructor; eauto].
    -  eapply (proj2 (decodeB_pf (proj2 (proj2 P_inv_pf)))) in com_pf; eauto;
         destruct_ex; split_and; intros.
       subst.
       eapply H0 in H2; eauto.
       destruct_ex; split_and.
       rewrite <- mappend_assoc.
       rewrite H2; simpl.
       rewrite unfold_computes in H5.
       rewrite (proj1 (proj1 H5 _ _ _ pred_pm) H); simpl.
       eapply decodeT_pf in H;
         destruct_ex; split_and.
       rewrite mappend_assoc.
       rewrite H9; eexists _, _; intuition eauto.
       unfold composeIf, Union_Format; apply unfold_computes;
         exists Fin.F1; simpl; eauto.
      eauto.
      eauto.
      eauto.
      eauto.
    - eapply (proj2 (decodeB_pf (proj2 (proj2 P_inv_pf)))) in com_pf; eauto;
         destruct_ex; split_and; intros.
       subst.
       eapply H in H1; eauto.
       destruct_ex; split_and.
       rewrite <- mappend_assoc.
       rewrite H1; simpl.
       rewrite unfold_computes in H7.
       rewrite (proj2 (proj1 H7 _ _ _ pred_pm) H4); simpl.
       eapply decodeE_pf in H4; destruct_ex; split_and.
       rewrite mappend_assoc.
       rewrite H9; eexists _, _; intuition eauto.
       unfold composeIf, Union_Format; apply unfold_computes;
         exists (Fin.FS Fin.F1); simpl; eauto.
      eauto.
      eauto.
      eauto.
      eauto.
  }
  { intros.
    destruct (decodeB t env') as [ [ [? ?] ? ] | ] eqn: ? ;
      simpl in *; try discriminate.
    destruct b; simpl in *.
    - eapply decodeT_pf in H1.
      split_and; destruct_ex; intuition eauto; subst.
      eexists _, _; intuition eauto.
      unfold composeIf, Union_Format; apply unfold_computes;
        exists Fin.F1; simpl; eauto.
      intuition.
      eauto.
      intuition.
    - eapply decodeE_pf in H1.
      split_and; destruct_ex; intuition eauto; subst.
      eexists _, _; intuition eauto.
      unfold composeIf, Union_Format; apply unfold_computes;
        exists (Fin.FS Fin.F1); simpl; eauto.
      intuition.
      eauto.
      intuition.
  }
Qed.

Lemma composeIf_format_inj1
      {S T} {cache : Cache}
      (monoid : Monoid T)
      s env t env'
      (formatT formatE : FormatM S T)
  : formatT s env ∋ (t, env') ->
    composeIf formatT formatE s env ∋ (t, env').
Proof.
  intros. unfold composeIf, Union_Format.
  rewrite unfold_computes.
  exists Fin.F1. eauto.
Qed.

Lemma composeIf_format_inj2
      {S T} {cache : Cache}
      (monoid : Monoid T)
      s env t env'
      (formatT formatE : FormatM S T)
  : formatE s env ∋ (t, env') ->
    composeIf formatT formatE s env ∋ (t, env').
Proof.
  intros. unfold composeIf, Union_Format.
  rewrite unfold_computes.
  exists (Fin.FS Fin.F1). eauto.
Qed.

Lemma composeIf_format_elim
      {S T} {cache : Cache}
      (monoid : Monoid T)
      s env t env'
      (formatT formatE : FormatM S T)
  : composeIf formatT formatE s env ∋ (t, env') ->
    formatT s env ∋ (t, env') \/ formatE s env ∋ (t, env').
Proof.
  unfold composeIf, Union_Format.
  rewrite unfold_computes. intros [? ?].
  revert H. apply (Fin.caseS' x). eauto. clear x.
  intros x. apply (Fin.caseS' x). eauto. clear x.
  intros x. apply Fin.case0; auto.
Qed.

Lemma composeIf_subformat_correct_prefix
      {S T}
      {cache : Cache}
      (monoid : Monoid T)
      (formatT formatE : FormatM S T)
      (subformatT subformatE : FormatM S T)
      (subformat_OK1 : Prefix_Format monoid formatT subformatT)
      (subformat_OK2 : Prefix_Format monoid formatE subformatE)
  : Prefix_Format monoid (composeIf formatT formatE) (composeIf subformatT subformatE).
Proof.
  unfold Prefix_Format in *; intros.
  apply composeIf_format_elim in H. destruct H.
  edestruct subformat_OK1; eauto. destruct_ex.
  eexists _, _, _; intuition eauto. eauto using composeIf_format_inj1.
  edestruct subformat_OK2; eauto. destruct_ex.
  eexists _, _, _; intuition eauto. eauto using composeIf_format_inj2.
Qed.

Lemma composeIf_subformat_correct_low
      {S T}
      {cache : Cache}
      {P  : CacheDecode -> Prop}
      {monoid : Monoid T}
      {richmonoid : RichMonoidOpt monoid}
      (Source_Predicate : S -> Prop)
      (formatT formatE : FormatM S T)
      (subformat : FormatM S T)
      (decodeB : DecodeM (bool * T) T)
      (decodeB_OK : forall env env' xenv s t ext,
          P env' ->
          Equiv env env' ->
          Source_Predicate s ->
          subformat s env ∋ (t, xenv) ->
          exists v xenv', decodeB (mappend t ext) env' = Some (v, ext, xenv') /\
                   Equiv xenv xenv' /\ P xenv')
      (decodeB_OK' : forall env env' xenv' v t t',
          Equiv env env' ->
          P env' ->
          decodeB t env' = Some (v, t', xenv') ->
          P xenv' /\
          exists t'' xenv,
            (forall s t1 xenv,
                Source_Predicate s ->
                (formatT s env ∋ (mappend t'' t1, xenv) -> v = true) /\
                (formatE s env ∋ (mappend t'' t1, xenv) -> v = false)) /\
            t = mappend t'' t' /\ Equiv xenv xenv')
  : CorrectRefinedDecoder
      monoid
      Source_Predicate
      (fun bs => True)
      (fun s bs => True)
      (composeIf formatT formatE)
      subformat
      decodeB P
      (fun bs env t => (forall s t' env',
                        Source_Predicate s ->
                        (formatT s env (mappend (fst t) t', env') -> bs = true)
                        /\ (formatE s env (mappend (fst t) t', env') -> bs = false))).
Proof.
  split; intros. {
    edestruct decodeB_OK; eauto. destruct_conjs.
    eexists _, _; intuition eauto.
    rewrite unfold_computes; repeat split; simpl; intros;
      rewrite <- unfold_computes in H7;
      edestruct decodeB_OK' with (env:=env); eauto; destruct_conjs;
        apply mappend_inj in H12; subst; eapply H11; eauto.
  } {
    edestruct decodeB_OK' with (env:=env); eauto. destruct_conjs. subst. intuition eauto.
    eexists _, _. rewrite unfold_computes; simpl.
    intuition eauto 1; rewrite <- unfold_computes in H8; eapply H5; eauto.
  }
Qed.

Lemma EquivFormat_ComposeIf {S T}
      {cache : Cache}
      {monoid : Monoid T}
  : forall (format1 format1' format2 format2' : FormatM S T),
    EquivFormat format1 format1'
    -> EquivFormat format2 format2'
    -> EquivFormat (composeIf format1 format2)
                   (composeIf format1' format2').
Proof.
  unfold composeIf, Union_Format; split; intros; intros ? ? ;
    rewrite unfold_computes in H1; destruct_ex; intros;
      rewrite unfold_computes; exists x;
        revert H1; pattern x; apply IterateBoundedIndex.Iterate_Ensemble_BoundedIndex_equiv; simpl;
          repeat (apply IterateBoundedIndex.Build_prim_and; intros); eauto; simpl.
  apply H; apply H1.
  apply H0; apply H1.
  apply H; apply H1.
  apply H0; apply H1.
Qed.

Lemma refineEquiv_ComposeIf {S T}
      {cache : Cache}
      {monoid : Monoid T}
  : forall (format1 format1' format2 format2' : FormatM S T),
    (forall s env, refineEquiv (format1 s env) (format1' s env))
    -> (forall s env, refineEquiv (format2 s env) (format2' s env))
    -> (forall s env,
           refineEquiv (composeIf format1 format2 s env)
                       (composeIf format1' format2' s env)).
Proof.
  intros; eapply EquivFormat_ComposeIf; eauto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall O A B C Bprime : Universe, ((wd_ O A /\ (wd_ O Bprime /\ (wd_ O C /\ (wd_ A B /\ (wd_ B Bprime /\ (wd_ A Bprime /\ (wd_ A C /\ (wd_ O B /\ (col_ O A B /\ (col_ A B C /\ (col_ O A Bprime /\ col_ A Bprime C))))))))))) -> col_ O Bprime B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj22synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (mult lv1 lv2)) (plus lv0 (mult lv1 lv2))).
Admitted.
QuickChick conj22synthconj3.


Require Import Arith.
Require Import Omega.
Require Import String.
Require Import List.
Import ListNotations.

Require Import OrderedType OrderedTypeEx.
Require FMapList.
Require FMapFacts.

(* ffs there is no standard instance for this *)
Require Import string_as_ot.

Require Import ast.

(* ************************************************************ *)
(* ************************************************************ *)
(*                                                              *)
(*                            varmap                            *)
(*                                                              *)
(* ************************************************************ *)
(* ************************************************************ *)

(*
 * This is not a Map but a wrapper around one. You can't make
 * an OrderedType instance for Var because Var carries a type
 * around with it.
 *)

Definition var_id (x: var) :=
   match x with
   | mkvar _ id => id
   end.

Definition varidtype := nat.

(*
Module StringMap := FMapList.Make String_as_OT.
Module StringMapFacts := FMapFacts.WFacts_fun String_as_OT StringMap.
Module StringMapProperties := FMapFacts.WProperties_fun String_as_OT StringMap.

Definition StringMap_union {t} (m1 m2: StringMap.t t) :=
   StringMap.fold (@StringMap.add t) m2
      (StringMap.fold (@StringMap.add t) m1 (@StringMap.empty t)).

Lemma StringMap_union_correct:
   forall t (k: string) (m1 m2: StringMap.t t),
   (StringMap.In k m1 \/ StringMap.In k m2) <->
      StringMap.In k (StringMap_union m1 m2).
Proof.
Admitted.

Definition VarMap := StringMap.t.
Definition VarMap_empty := StringMap.empty.
Definition VarMap_add {t} {t2} (k: var t) (v: t2) m := StringMap.add (var_id k) v m.
Definition VarMap_union {t} m1 m2 := @StringMap_union t m1 m2.
Definition VarMapDisjoint := StringMapProperties.Disjoint.
Definition VarMapIn {t} {t2} (k: var t) (m: StringMap.t t2) :=
   StringMap.In (var_id k) m.
Definition VarMapMapsTo {t} {t2} (k: var t) (v: t2) (m: StringMap.t t2) :=
   StringMap.MapsTo (var_id k) v m.
*)

Module NatMap := FMapList.Make Nat_as_OT.
Module NatMapFacts := FMapFacts.WFacts_fun Nat_as_OT NatMap.
Module NatMapProperties := FMapFacts.WProperties_fun Nat_as_OT NatMap.

Definition NatMap_union {t} (m1 m2: NatMap.t t) :=
   NatMap.fold (@NatMap.add t) m2
      (NatMap.fold (@NatMap.add t) m1 (@NatMap.empty t)).

Lemma NatMap_union_correct:
   forall t (k: nat) (m1 m2: NatMap.t t),
   (NatMap.In k m1 \/ NatMap.In k m2) <->
      NatMap.In k (NatMap_union m1 m2).
Proof.
Admitted.

Definition VarMap := NatMap.t.
Definition VarMap_empty := NatMap.empty.
Definition VarMap_add {t} k (v: t) m := NatMap.add (var_id k) v m.
Definition VarMap_union {t} m1 m2 := @NatMap_union t m1 m2.
Definition VarMapDisjoint := NatMapProperties.Disjoint.
Definition VarMapIn {t} k (m: NatMap.t t) := NatMap.In (var_id k) m.
Definition VarMapMapsTo {t} (k: var) (v: t) (m: NatMap.t t) :=
   NatMap.MapsTo (var_id k) v m.


(*===========================================================================
  Test the performance of bits operations
  ===========================================================================*)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple.
Require Import bitsrep bitsops bitsopsprops.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import ssralg.
Open Scope ring_scope.

Definition n' := Eval cbv in 31.
Definition n := n'.+1.

Example ex:BITS n := #59 + #23 *+ 3.

Definition c := Eval compute in @fromZ n 12345.

Example incTest :=
  toZ (n:=n') (iter 500 (iter 200 (@incB n)) c).

Example addTest :=
  toZ (n:=n') (iter 200 (iter 200 (@addB n c)) c).

Example mulTest :=
  toZ (n:=n') (iter 10 (iter 20 (@mulB n c)) c).

(* We can do around 70,000 increments a second *)
Time Compute incTest.

(* We can do around 5,000 adds a second *)
Time Compute addTest.

(* We can do around 50 multiplications a second *)
Time Compute mulTest.

(* Compare against compcert
Add LoadPath "Compcert\compcert-1.10\lib".
Require Import Integers.

Example auxIncTest :=
  let v := Int.repr 12345 in
  Int.unsigned (iter 100 (iter 200 (fun x => Int.add x (Int.repr 1))) v).

Example auxAddTest :=
  let v := Int.repr 12345 in
  Int.unsigned (iter 100 (iter 200 (fun x => Int.add x v)) v).

Time Compute auxIncTest.
Time Compute auxAddTest.
*)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D M : Universe, ((wd_ A C /\ (wd_ B D /\ (wd_ M D /\ (wd_ M A /\ (wd_ A B /\ (wd_ B C /\ (wd_ M C /\ (wd_ B M /\ (col_ A M C /\ (col_ B M D /\ (col_ D A C /\ col_ M A D))))))))))) -> col_ M A B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable r_ : Universe -> Prop.
Variable goal_ : Prop.
Variable dom_ : Universe -> Prop.

Variable x_ : Universe.

Variable initial_model_1 : (dom_ x_ /\ r_ x_).
Variable goal_r_2 : (forall X : Universe, (r_ X -> goal_)).

Theorem exist_3 : goal_.
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import BaremoreHandler.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition smc_mark_realm_spec (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 addr =>
      rely is_int64 addr;
      rely (Z.land (r_scr_el3 (cpu_regs (priv adt))) SCR_WORLD_MASK =? SCR_REALM_WORLD);
      let gidx := __addr_to_gidx addr in
      rely is_gidx gidx;
      when adt == query_oracle adt;
      rely prop_dec ((gpt_lk (share adt)) @ gidx = None);
      rely prop_dec ((gpt (share adt)) @ gidx = false);
      let e := EVT CPU_ID (ACQ_GPT gidx) in
      let e' := EVT CPU_ID (REL_GPT gidx true) in
      Some adt {log: e' :: e :: (log adt)} {share: (share adt) {gpt: (gpt (share adt)) # gidx == true}}
           {priv: (priv adt) {cpu_regs: (cpu_regs (priv adt)) {r_x0: 0} {r_x1: addr} {r_esr_el3: ESR_EC_SMC}}}
    end.

End Spec.