Require Import
        FJ.Base
        FJ.Syntax
        FJ.Typing.Wellformedness.WellformedExp
        FJ.Tactics.

(* well formed definitions for declarations *)

Section WF.

  Variable CT : ClassTable.

  Inductive WellFormedFormalArg : FormalArg -> Prop :=
    WFFormalArg
    : forall n C CD, M.MapsTo C CD CT ->
                     WellFormedFormalArg (mkFormalArg n C).

  Inductive WellFormedField : Field -> Prop :=
    WFField
    : forall n C CD, M.MapsTo C CD CT ->
                     WellFormedField (mkField n C).

  Inductive WellFormedConstructor : Constructor -> Prop :=
    WFConstructor
    : forall C args sups inis CD,
      M.MapsTo C CD CT ->
      Forall WellFormedFormalArg args ->
      WellFormedConstructor (mkConstructor C args sups inis).

  Inductive WellFormedMethod : Method -> Prop :=
    WFMethod
    : forall C m args nodup e CD,
      M.MapsTo C CD CT ->
      Forall WellFormedFormalArg args ->
      WellFormedExp CT e ->
      WellFormedMethod (mkMethod C m args nodup e).

  Inductive WellFormedClass : ClassDecl -> Prop :=
    WFClass : forall C D fs K ms CD DD,
      M.MapsTo C CD CT ->
      M.MapsTo D DD CT ->
      Forall WellFormedField (values fs) ->
      WellFormedConstructor K ->
      Forall WellFormedMethod (values ms) ->
      WellFormedClass (mkClassDecl C D fs K ms).
End WF.

  Hint Constructors
       WellFormedFormalArg
       WellFormedField
       WellFormedConstructor
       WellFormedMethod
       WellFormedClass.

Section DEC.
  Variable CT : ClassTable.

  Definition WellFormedFormalArgDec
    : forall fa, {WellFormedFormalArg CT fa} + {~ WellFormedFormalArg CT fa}.
    refine (fun fa =>
               match fa return {WellFormedFormalArg CT fa} + {~ WellFormedFormalArg CT fa} with
               | mkFormalArg n C =>
                 match MapsToDec C CT with
                 | !! => No
                 | [|| CD ||] => Yes
                 end
               end).
    simpl in * ; eauto.
    intro H ; inverts H ; try map_solver.
  Defined.

  Definition WellFormedFieldDec
    : forall fd, {WellFormedField CT fd} + {~ WellFormedField CT fd}.
    refine (fun fa =>
               match fa return {WellFormedField CT fa} + {~ WellFormedField CT fa} with
               | mkField n C =>
                 match MapsToDec C CT with
                 | !! => No
                 | [|| CD ||] => Yes
                 end
               end) ; simpl in * ; eauto ; try (intro H ; inverts* H) ; try map_solver.
  Defined.

  Definition WellFormedConstructorDec
    : forall K, {WellFormedConstructor CT K} + {~ WellFormedConstructor CT K}.
    refine (fun K =>
              match K return {WellFormedConstructor CT K} + {~ WellFormedConstructor CT K} with
              | mkConstructor C args sups inis =>
                match MapsToDec C CT with
                | [|| CD ||] =>
                  match Forall_dec WellFormedFormalArgDec args with
                  | Yes => Yes
                  | No  => No
                  end
                | !! => No
                end
              end) ; simpl in * ; eauto ; try (intro H ; inverts* H) ; try map_solver.
  Defined.

  Definition WellFormedMethodDec
    : forall M, {WellFormedMethod CT M} + {~ WellFormedMethod CT M}.
    refine (fun M =>
              match M return {WellFormedMethod CT M} + {~ WellFormedMethod CT M} with
              | mkMethod C m args nodup e =>
                match MapsToDec C CT with
                | !! => No
                | [|| CD ||] =>
                  match Forall_dec WellFormedFormalArgDec args with
                  | No => No
                  | Yes =>
                    match WellFormedExpDec CT e with
                    | Yes => Yes
                    | No  => No
                    end
                  end
                end
              end) ; simpl in * ; try (intro H ; inverts H) ; try map_solver ; eauto.
  Defined.

  Definition WellFormedClassDec
    : forall CD, {WellFormedClass CT CD} + {~ WellFormedClass CT CD}.
    refine (fun CD =>
              match CD return {WellFormedClass CT CD} + {~ WellFormedClass CT CD} with
              | mkClassDecl C D fs K ms =>
                match MapsToDec C CT with
                | !! => No
                | [|| CD1 ||] =>
                  match MapsToDec D CT with
                  | !! => No
                  | [|| DD ||] =>
                    match Forall_dec WellFormedFieldDec (values fs) with
                    | No => No
                    | Yes =>
                      match WellFormedConstructorDec K with
                      | No => No
                      | Yes =>
                        match Forall_dec WellFormedMethodDec (values ms) with
                        | Yes => Yes
                        | No  => No
                        end
                      end
                    end
                  end
                end
              end) ; simpl in * ; try (intro H ; inverts* H) ; eauto ; try map_solver.
  Defined.

End DEC.


(* correct failure of injection/discriminate on types whose inductive
   status derives from the substitution of an argument *)

Inductive t : nat -> Type :=
| M : forall n: nat, nat -> t n.

Lemma eq_t : forall n n' m m',
   existT (fun B : Type => B) (t n) (M n m) =
   existT (fun B : Type => B) (t n') (M n' m') -> True.
Proof.
  intros.
  injection H.
  intro Ht.
  exact I.
Qed.

Lemma eq_t' : forall n n' : nat,
   existT (fun B : Type => B) (t n) (M n 0) =
   existT (fun B : Type => B) (t n') (M n' 1) -> True.
Proof.
  intros.
  discriminate H || exact I.
Qed.


(** *** Going into the opposite direction of [UniMath.Bicategories.Core.Examples.BicategoryFromWhiskeredMonoidal] *)
(** We fix a bicategory and an object of it and construct the (whiskered) monoidal category of endomorphisms.

Written by Ralph Matthes in 2019, adapted in 2022.

 *)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.
Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Unitors.

Local Open Scope cat.

Section Monoidal_Cat_From_Bicat.

Local Open Scope bicategory_scope.
Import Bicat.Notations.
Import MonoidalNotations.

Context {C : bicat}.
Context (c0: ob C).

Definition precategory_data_from_bicat_and_ob: precategory_data.
Proof.
  use make_precategory_data.
  - use make_precategory_ob_mor.
    + exact (C⟦c0,c0⟧).
    + apply prebicat_cells.
  - intro c; apply id2.
  - intros a b c; apply vcomp2.
Defined.

Lemma is_precategory_data_from_prebicat_and_ob: is_precategory precategory_data_from_bicat_and_ob.
Proof.
  use make_is_precategory.
  - intros a b f; apply id2_left.
  - intros a b f; apply id2_right.
  - intros a b c d f g h; apply vassocr.
  - intros a b c d f g h; apply pathsinv0; apply vassocr.
Qed.

Definition precategory_from_bicat_and_ob: precategory := _,, is_precategory_data_from_prebicat_and_ob.

Lemma has_homsets_precategory_from_bicat_and_ob: has_homsets precategory_from_bicat_and_ob.
Proof.
  red. intros.
  apply (cellset_property(C:=C)).
Qed.

Definition category_from_bicat_and_ob: category := precategory_from_bicat_and_ob ,, has_homsets_precategory_from_bicat_and_ob.

Local Notation EndC := category_from_bicat_and_ob.

Definition tensor_data_from_bicat_and_ob: bifunctor_data category_from_bicat_and_ob category_from_bicat_and_ob category_from_bicat_and_ob.
Proof.
  use make_bifunctor_data.
  - intros a b. exact (a · b).
  - intros a b1 b2 β. exact (lwhisker _ β).
  - intros b a1 a2 α. exact (rwhisker _ α).
Defined.

(** we explicitly do not opacify the following definition: *)
Definition tensor_laws_from_bicat_and_ob: is_bifunctor tensor_data_from_bicat_and_ob.
Proof.
  red; repeat split; red; cbn.
  - apply lwhisker_id2.
  - intros; apply id2_rwhisker.
  - intros; apply pathsinv0, lwhisker_vcomp.
  - intros; apply pathsinv0, rwhisker_vcomp.
  - intros; apply vcomp_whisker.
Defined.

Definition tensor_from_bicat_and_ob
  : bifunctor category_from_bicat_and_ob category_from_bicat_and_ob category_from_bicat_and_ob
  := make_bifunctor tensor_data_from_bicat_and_ob tensor_laws_from_bicat_and_ob.

Definition monoidal_data_from_bicat_and_ob: monoidal_data category_from_bicat_and_ob.
Proof.
  use make_monoidal_data.
  - exact tensor_data_from_bicat_and_ob.
  - exact (id₁ c0).
  - red; intros; apply lunitor.
  - red; intros; apply linvunitor.
  - red; intros; apply runitor.
  - red; intros; apply rinvunitor.
  - red; intros; apply rassociator.
  - red; intros; apply lassociator.
Defined.

Local Definition MD := monoidal_data_from_bicat_and_ob.

Local Lemma leftunitor_law_from_bicat_and_ob: leftunitor_law lu_{MD} luinv_{MD}.
Proof.
  split; red; cbn.
  - apply vcomp_lunitor.
  - apply is_invertible_2cell_lunitor.
Qed.

Local Lemma rightunitor_law_from_bicat_and_ob: rightunitor_law ru_{MD} ruinv_{MD}.
Proof.
  split; red; cbn.
  - apply vcomp_runitor.
  - apply is_invertible_2cell_runitor.
Qed.

Local Lemma associator_law_from_bicat_and_ob: associator_law α_{MD} αinv_{MD}.
Proof.
  repeat split; try red; cbn.
  - apply lwhisker_lwhisker_rassociator.
  - intros; apply pathsinv0, rwhisker_rwhisker_alt.
  - apply rwhisker_lwhisker_rassociator.
  - apply is_invertible_2cell_rassociator.
  - apply is_invertible_2cell_rassociator.
Qed.

Local Lemma triangle_identity_from_bicat_and_ob: triangle_identity lu_{MD} ru_{MD} α_{MD}.
Proof.
  red; cbn. apply lunitor_lwhisker.
Qed.

(** the next two lemmas only for illustration that the extra triangle laws are already available in bicategories *)
Local Lemma triangle_identity'_from_bicat_and_ob: triangle_identity' lu_{MD} α_{MD}.
Proof.
  red; intros x y; cbn. rewrite <- lunitor_triangle. rewrite vassocr. rewrite rassociator_lassociator. apply id2_left.
Qed.

Local Lemma triangle_identity''_from_bicat_and_ob: triangle_identity'' ru_{MD} α_{MD}.
Proof.
  red; intros x y; cbn. apply runitor_triangle.
Qed.

Local Lemma pentagon_identity_from_bicat_and_ob: pentagon_identity α_{MD}.
Proof.
  red; cbn. apply rassociator_rassociator.
Qed.

Definition monoidal_from_bicat_and_ob: monoidal category_from_bicat_and_ob.
Proof.
  exists monoidal_data_from_bicat_and_ob.
  exists (pr2 (tensor_from_bicat_and_ob)).
  exists leftunitor_law_from_bicat_and_ob.
  exists rightunitor_law_from_bicat_and_ob.
  exists associator_law_from_bicat_and_ob.
  exists triangle_identity_from_bicat_and_ob.
  exact pentagon_identity_from_bicat_and_ob.
Defined.

End Monoidal_Cat_From_Bicat.


Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import BoolMap.
Require Import Promises.
Require Import Cell.
Require Import Memory.
Require Import Global.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import SimMemory.

Set Implicit Arguments.

Variant sim_global (gl_src gl_tgt: Global.t): Prop :=
| sim_global_intro
    (SC: TimeMap.le (Global.sc gl_src) (Global.sc gl_tgt))
    (PROMISES: Global.promises gl_src = Global.promises gl_tgt)
    (MEMORY: sim_memory (Global.memory gl_src) (Global.memory gl_tgt))
.
#[export] Hint Constructors sim_global: core.

Global Program Instance sim_global_PreOrder: PreOrder sim_global.
Next Obligation.
  ii. destruct x. econs; refl.
Qed.
Next Obligation.
  ii. destruct x, y, z. inv H. inv H0. ss. subst.
  econs; ss; etrans; eauto.
Qed.

Lemma init_sim_global: sim_global Global.init Global.init.
Proof. refl. Qed.

Lemma sim_global_cap gl_src gl_tgt
      (GL: sim_global gl_src gl_tgt)
      (GL_WF_SRC: Global.wf gl_src)
      (GL_WF_TGT: Global.wf gl_tgt)
  :
  sim_global (Global.cap_of gl_src) (Global.cap_of gl_tgt).
Proof.
  inv GL. econs; eauto. ss.
  eapply sim_memory_cap; eauto.
  { eapply Memory.cap_of_cap. }
  { eapply Memory.cap_of_cap. }
  { eapply GL_WF_SRC. }
  { eapply GL_WF_TGT. }
Qed.


Require Import ExtLib.Core.RelDec.

Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.RTac.RTac.
Require Import MirrorCore.Subst.FMapSubst.
Require Import MirrorCore.Lambda.ExprSubst.
Require Import MirrorCore.Lambda.ExprUnify_simul.
Require MirrorCore.syms.SymEnv.
Require MirrorCore.syms.SymSum.

Require Import MirrorCharge.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BaseFunc.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.SetoidRewrite.Base.
Require Import MirrorCharge.SetoidRewrite.ILSetoidRewrite.
Require Import MirrorCharge.PullConjunct.ILPullConjunct.

Require Import Charge.Logics.ILogic.

Set Implicit Arguments.
Set Strict Implicit.

Section PullConjunct.
  Context (typ func : Type).
  Context {HIL : ILogicFunc typ func} {HB : BaseFunc typ func}.
  Context {RelDec_func : RelDec (@eq (expr typ func))}.
  Context {target : expr typ func -> bool}.
  Context {RType_typ : RType typ}.
  Context {Typ2_typ : Typ2 RType_typ Fun}.
  Context {Typ0_typ : Typ0 RType_typ Prop}.
  Context {RSym_func : RSym func}.
  Context {ilogic : forall t : typ, option (ILogicOps (typD t))}.
Check setoid_rewrite.
  Definition pull_conjunct vars :=
	setoid_rewrite vars _ fEntails rw_fail (il_rewrite_respects typ func ilogic) (il_pull_conjunct target).

  Definition PULLCONJUNCTL : rtac typ (expr typ func) :=
    fun tus tvs lus lvs c s e =>
      match e with
        | App (App f L) R =>
          match ilogicS f with
	        | Some (ilf_entails l) =>
	        	match pull_conjunct (getVars c) l L with
	        	  | Some (e', _) => More s (GGoal (mkEntails l e' R))
	        	  | _ => More s (GGoal e)
	        	end
	        | _ => More s (GGoal e)
	      end
        | _ => More s (GGoal e)
      end.

End PullConjunct.

Implicit Arguments PULLCONJUNCTL [[HIL] [HB] [RelDec_func] [RType_typ] [Typ2_typ] [Typ0_typ] [RSym_func]].