(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

   Lemmas about static semantics context well formedness.
*)
Set Implicit Arguments.
Require Export LanguageModuleDef.
Require Export CpdtTactics.
Require Export TacticNotations.
Require Export Tacticals.
Require Export AlphaConversion.
Require Export StaticSemanticsKindingAndContextWellFormednessLemmas.
Require Export StaticSemanticsKindingLemmas.

Lemma WFU_t_implies_K_nil_A:
  forall (t : Tau) (e : EVP.E.Var) (p : Path)  (u' : Upsilon),
    WFU (U.ctxt (e, p) t u') ->
    K ddot t A.
Proof.
  destruct t; intros; try solve[inversion H; try assumption].
Qed.

Lemma WFU_strengthening:
 forall (u u' : Upsilon),
   U.extends u u' = true ->
   WFU u' ->
   WFU u.
Proof.
(*
  intros u u' ext WFUu'.
  induction WFUu'; intros; try solve[crush].
  apply U.empty_extends_only_empty in ext; subst.
  constructor.

  apply U.extends_r_weak in ext; try assumption.
  pose proof ext as ext'.
  apply IHWFUu' in ext; try assumption.
  assert (Z: WFU (U.ctxt (x, p) tau u0)).
  constructor; try assumption.
  apply WFU_implies_nodup in Z; try assumption.
  (* almost but no cigar I'd say. *)
  case_eq(U.map u (x, p)); intros.
  admit.
  reflexivity.
*)
  intros u.
  induction u; intros; try solve[crush].
Admitted.

Lemma WFD_WFDG_implies_K_d_t_A:
  forall d g x tau,
    WFD d ->
    WFDG d g ->
    G.map g x = Some tau ->
    K d tau A.
Proof.
 intros d g x tau WFDder WFDGder.
 induction WFDGder; intros; try solve[crush].
 unfold G.map in H1.
 fold G.map in H1.
 case_eq(G.K_eq x x0); intros; rewrite H2 in H1.
 inversion H1; subst; try assumption.
 apply IHWFDGder in WFDder; try assumption.
 inversion WFDder; subst.
 apply IHWFDGder in H0; try assumption.
 apply K_weakening with (d:= d); try assumption.
 pose proof H5 as H5'.
 apply WFD_implies_nodup in H5'.
 apply D.extends_r_str; try assumption.
 apply D.extends_refl; try assumption.
 unfold D.nodup.
 fold D.nodup.
 rewrite H3.
 assumption.
Qed.

Lemma WFDG_g_strengthening:
  forall (g g' : Gamma),
    G.extends g g' = true ->
    forall (d : Delta),
      WFD d ->
      WFDG d g' ->
      WFDG d g.
Proof.
  (* closer no cigar. *)
  intros g.
  induction g; intros; try solve[crush].

  pose proof H as H'.
  apply G.extends_l_str in H.
  apply IHg with (d:= d) in H; try assumption.
  constructor; try assumption.
  admit. (* H' WFDG g' should imply k is not in there. *)
  apply WFD_WFDG_implies_K_d_t_A with (g:= (G.ctxt k t g)) (x:= k); try assumption.
  constructor; try assumption.
  admit.
  admit.
  unfold G.map.
  fold G.map.
  rewrite G.K.beq_t_refl.
  reflexivity.
Admitted.

(* by extends induction
  intros g g'.
  functional induction (G.extends g g'); intros; try solve[crush].
  apply IHb with (d:= d) in H; try assumption.
  constructor; try assumption.
  admit. (* Stuck dang it. *)
  apply WFD_WFDG_implies_K_d_t_A with (g:= c') (x:= k); try assumption.
  apply G.T.beq_t_eq in e1; subst; try assumption.
*)

(* By  WFDG induction

  intros d g' WFDGder g ext.
  induction WFDGder; try solve[crush]; intros.

  apply G.empty_extends_only_empty in ext.
  subst.
  constructor; try assumption.

  apply G.extends_r_weak in ext; try assumption.
  apply IHwfdgdg' in ext; try assumption.
  apply WFDG_implies_nodup in wfdgdg'.
  unfold G.nodup.
  fold G.nodup.
  rewrite H; try assumption.
  admit. (* perhaps stuck. *)
  apply IHwfdgdg' in ext.
  constructor; try assumption.
Qed.

*)

Lemma WFD_strengthening:
 forall (d d' : Delta),
   WFD (d ++ d') ->
   WFD d.
Proof.
   intros.
   induction d.
  Case "d=[]".
   constructor.
  Case "a :: d'".
   inversion H.
   apply IHd in H3.
   constructor.
   AdmitAlphaConversion.
   assumption.
Qed.

(* used. *)
Lemma WFDG_d_strengthening:
  forall (d d' : Delta) (g  : Gamma),
    WFDG (d ++ d') g ->
    WFDG d g.
Proof.
  intros d d' g WFDGder.
  induction WFDGder.
  Case "g = []".
   constructor.
  Case "[(x,tau] ++ g".
   constructor.
   AdmitAlphaConversion.
   admit. (* induction wrong, d0 instead of d. *)
   assumption.
   admit.
Qed.

Lemma WFDG_strengthening:
  forall (d d' : Delta) (g g' : Gamma),
    WFDG (d ++ d') (g ++ g') ->
    WFDG d g.
Proof.
  intros.
  apply WFDG_d_strengthening in H.
  apply WFDG_g_strengthening in H.
  assumption.
Qed.

(* Is this really true? *)
Lemma WFC_strengthening:
  forall (d d': Delta) (u u' : Upsilon) (g g': Gamma),
    WFC (d ++ d') (u ++ u') (g ++ g') ->
    WFC d u g.
Proof.
  intros d d' u u' g g' WFCder.
  apply (WFC_ind
           (fun (d : Delta) (u : Upsilon) (g : Gamma) =>
              WFC (d ++ d') (u ++ u') (g ++ g') ->
              WFC d u g)).
  intros.
  Case "WFC d0 u0 g0".
   constructor; try assumption.
  Case "WFC d u g".
   inversion WFCder.
   crush.
   apply WFD_strengthening in H; try assumption.
   apply WFU_strengthening in H1; try assumption.
   apply WFDG_strengthening in H0; try assumption.
   constructor; try assumption.
   assumption.
Qed.

(* Too much work to do it this way. *)
Lemma WFC_strengthening_right:
  forall (d d': Delta) (u u' : Upsilon) (g g': Gamma),
    WFC (d ++ d') (u ++ u') (g ++ g') ->
    WFC d' u' g'.
Proof.
Admitted.

(* This one might be true and needed. Might needs extendedbyG.
  Heck might need both extended bys. *)
Lemma WFDG_g_weakening:
  forall (d : Delta) (g: Gamma),
    WFDG d g ->
    forall (g' : Gamma),
      WFDG d g' ->
      WFDG d (g ++ g').
Proof.
  intros d g WFDGder.
  induction g.
  Case "g = []".
   intros.
   rewrite app_nil_l.
   assumption.
  Case "a :: g".
   intros.
   SCase "((x, tau) :: g) ++ g'".
    destruct a.
    rewrite cons_is_append_singleton.
    rewrite <- app_assoc.
    constructor; try assumption.
    AdmitAlphaConversion.
    inversion WFDGder; try assumption.
    crush.
    inversion WFDGder; try assumption.
    inversion WFDGder; try assumption.
    inversion WFDGder; try assumption.
    inversion WFDGder; try assumption.
    crush.
    (* in a loop so good sign I need to strengthen the theorem. *)
 Admitted.

Lemma WFDG_g_weakening_2:
  forall (g : Gamma) (x : EVar) (t : Tau),
    ExtendedByG g ([(x,t)] ++ g) ->
    forall (d : Delta),
      WFDG d g ->
      WFDG d ([(x,t)] ++ g).
Proof.
  (* Lost on all induction and all cases. *)
Admitted.

Lemma WFU_weakening:
  forall (u : Upsilon),
    WFU u ->
    forall (u' : Upsilon),
      WFU u' ->
      WFU (u ++ u').
Admitted.


From stdpp Require Import prelude.
From sets Require Import Ensemble.
From AML Require Import Signature.
From AML.Syntax Require Import Pattern.
From AML.Proofs Require Import ProofSystem Theorems.
From AML.Semantics Require Import Validity Tautology GlobalSemanticConsequence.
From AML.Semantics Require Import StrongSemanticConsequence.

Section sec_strong_soundness.

Context
  `{signature}
  `{Set_ Pattern PatternSet}
  .

Lemma strong_soundness (Γ : PatternSet) (ϕ : Pattern) :
  Γ ⊢ₛ ϕ -> Γ ⊧ₛ ϕ.
Proof.
  induction 1 as [| | ϕ Hax | | ? ? Hpremise].
  - intros A e a Ha.
    unfold PatternValuation.set_pattern_valuation,
      PropositionalPatternValuation.set_propositional_pattern_valuation in Ha.
    rewrite elem_of_filtered_intersection in Ha.
    by apply Ha.
  - by apply valid_set_strong_semantic_consequence_any,
      tautology_valid.
  - inversion Hax as [| | | | | ? ? ? Hx | ? ? ? Hx | ? ? Hpos Hfree | |].
    + apply valid_set_strong_semantic_consequence_any.
      by apply valid_evar_sub0_rename_ex.
    + apply valid_set_strong_semantic_consequence_any.
      pose proof (Hiff := valid_iff_app_bot_l ϕ0).
      by apply valid_iff_alt_classic in Hiff as [].
    + apply valid_set_strong_semantic_consequence_any.
      pose proof (Hiff := valid_iff_app_bot_r ϕ0).
      by apply valid_iff_alt_classic in Hiff as [].
    + apply valid_set_strong_semantic_consequence_any.
      pose proof (Hiff := valid_iff_app_or_l ϕ0 ψ χ).
      by apply valid_iff_alt_classic in Hiff as [].
    + apply valid_set_strong_semantic_consequence_any.
      pose proof (Hiff := valid_iff_app_or_r ϕ0 ψ χ).
      by apply valid_iff_alt_classic in Hiff as [].
    + apply valid_set_strong_semantic_consequence_any.
      pose proof (Hiff := valid_iff_app_ex_l x ϕ0 ψ Hx).
      by apply valid_iff_alt_classic in Hiff as [].
    + apply valid_set_strong_semantic_consequence_any.
      pose proof (Hiff := valid_iff_app_ex_r x ϕ0 ψ Hx).
      by apply valid_iff_alt_classic in Hiff as [].
    + apply valid_set_strong_semantic_consequence_any.
      pose proof (Hiff := valid_iff_svar_sub0_mu X ϕ0 Hpos Hfree).
      by apply valid_iff_alt_classic in Hiff as [].
    + apply valid_set_strong_semantic_consequence_any.
      by apply valid_ex_x.
    + apply valid_set_strong_semantic_consequence_any.
      by unshelve eapply singleton_valiable_rule.
  - inversion X; subst.
    by apply set_strong_mp with ϕ.
  - by inversion Hpremise.
Qed.

End sec_strong_soundness.


Require Import ExtLib.Core.Type.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Proper.

Set Implicit Arguments.
Set Strict Implicit.

Global Instance RelDec_eq_unit : RelDec (@eq unit) :=
{ rel_dec := fun _ _ => true }.
Global Instance RelDec_Correct_eq_unit : RelDec_Correct RelDec_eq_unit.
  constructor. destruct x; destruct y; auto; simpl. intuition.
Qed.

Global Instance type_unit : type unit :=
{ equal := fun _ _ => True
; proper := fun _ => True
}.

Global Instance typeOk_N : typeOk type_unit.
Proof.
  constructor; compute; auto.
Qed.

Global Instance proper_tt (x : unit) : proper x.
Proof.
  exact I.
Qed.


Require Import Bool.
Require Import RelationClasses.
Require Import List.
Require Import Program.

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

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

From PromisingLib Require Import Event.

Require Import Sequential.
Require Import SeqLib.

Set Implicit Arguments.

#[export] Hint Resolve Oracle.wf_mon: paco.

Ltac existT_elim1 :=
  match goal with
  | H: existT _ ?T1 ?v1 = existT _ ?T2 ?v2 |- _ =>
    match T1 with
    | T2 => apply EqdepTheory.inj_pair2 in H
    | _ => assert (T1 = T2) by (apply EqdepFacts.eq_sigT_fst in H; ss);
          subst T2
    end
  end.

Ltac existT_elim := repeat existT_elim1.

Ltac splitsH :=
  repeat match goal with
         | [H: ?a /\ ?b |- _] => inv H
         end; unnw.

(* TODO: move to simple.v *)

Lemma wf_input_oracle_wf_input
      e i
      (WF: SeqEvent.wf_input e i):
  Oracle.wf_input e (SeqEvent.get_oracle_input i).
Proof.
  unfold SeqEvent.wf_input, Oracle.wf_input in *. splitsH.
  destruct i. ss. splits.
  - split; i; des.
    + destruct in_access; ss. destruct p as [[[]]]. inv H0.
      specialize (H loc t2). des. eauto.
    + specialize (H loc v_new). des.
      exploit H5; eauto. intros x. des. rewrite x. ss. eauto.
  - rewrite <- H1. destruct in_acquire; ss.
  - rewrite <- H2. destruct in_release; ss.
Qed.

(** oracle_le *)

Variant _oracle_le (oracle_le: Oracle.t -> Oracle.t -> Prop): Oracle.t -> Oracle.t -> Prop :=
| oracle_le_intro
    lhs rhs
    (LE: forall e i o lhs1 (STEP: Oracle.step e i o lhs lhs1),
      exists rhs1, (<<STEP: Oracle.step e i o rhs rhs1>>) /\
              (<<LE1: oracle_le lhs1 rhs1>>)):
  _oracle_le oracle_le lhs rhs.

Lemma oracle_le_mon: monotone2 _oracle_le.
Proof.
  ii. inv IN. econs. i. exploit LE0; eauto. i. des. eauto.
Qed.
#[export] Hint Resolve oracle_le_mon: paco.

Definition oracle_le := paco2 _oracle_le bot2.
Arguments oracle_le: clear implicits.

Lemma oracle_le_refl orc: oracle_le orc orc.
Proof.
  revert orc. pcofix CIH. i.
  pfold. econs. i. esplits; eauto.
Qed.

Lemma oracle_le_trans
      orc1 orc2 orc3
      (LE1: oracle_le orc1 orc2)
      (LE2: oracle_le orc2 orc3):
  oracle_le orc1 orc3.
Proof.
  revert orc1 orc2 orc3 LE1 LE2. pcofix CIH. i.
  pfold. econs. i.
  punfold LE1. inv LE1. punfold LE2. inv LE2.
  exploit LE; eauto. i. des.
  exploit LE0; eauto. i. des.
  esplits; eauto.
  inv LE1; try done. inv LE2; try done.
  right. eapply CIH; eauto.
Qed.

Global Program Instance oracle_le_PreOrder: PreOrder oracle_le.
Next Obligation.
  ii. revert x. pcofix CIH. i.
  pfold. econs. i. esplits; eauto.
Qed.
Next Obligation.
  ii. revert x y z H H0. pcofix CIH. i.
  pfold. econs. i.
  punfold H0. inv H0. punfold H1. inv H1.
  exploit LE; eauto. i. des.
  exploit LE0; eauto. i. des.
  esplits; eauto.
  inv LE1; try done. inv LE2; try done.
  right. eapply CIH; eauto.
Qed.

Lemma oracle_le_steps
      lang step tr (st1: SeqState.t lang) p1 orc1 orc1' st2 p2 orc2
      (ORACLE: oracle_le orc1 orc1')
      (STEPS: SeqThread.steps step tr
                              (SeqThread.mk st1 p1 orc1)
                              (SeqThread.mk st2 p2 orc2)):
  exists orc2',
    SeqThread.steps step tr
                    (SeqThread.mk st1 p1 orc1')
                    (SeqThread.mk st2 p2 orc2').
Proof.
  remember (SeqThread.mk st1 p1 orc1) as th1.
  remember (SeqThread.mk st2 p2 orc2) as th2.
  revert st1 p1 orc1 orc1' st2 p2 orc2 ORACLE Heqth1 Heqth2.
  dependent induction STEPS; i; subst.
  { inv Heqth2. esplits. econs 1. }
  { inv STEP. exploit IHSTEPS; eauto. i. des.
    esplits. econs 2; eauto. econs. ss.
  }
  { inv STEP. punfold ORACLE. inv ORACLE.
    exploit LE; eauto. i. des. inv LE1; try done.
    exploit IHSTEPS; try eapply H; eauto. intros x. des.
    esplits. econs 3; try exact x. econs; eauto.
  }
Qed.

Lemma wf_in_access_some
      (i: option (Loc.t * Const.t * Flag.t * Const.t)) e
      (WF: forall loc v_new,
          ((exists v_old f_old, i = Some (loc, v_old, f_old, v_new)) <->
             (is_accessing e = Some (loc, v_new)))):
  i <-> is_accessing e.
Proof.
  destruct i; ss.
  - destruct p as [[[]]]. destruct (WF t t2).
    exploit H; eauto. intros x. rewrite x. ss.
  - destruct e; ss.
    + destruct (WF loc val). exploit H0; eauto. i. des. ss.
    + destruct (WF loc val). exploit H0; eauto. i. des. ss.
    + destruct (WF loc valw). exploit H0; eauto. i. des. ss.
Qed.

Lemma oracle_wf_in_access_some
      (i: option (Loc.t * Const.t * Flag.t)) e
      (WF: forall loc, (exists v_old f_old, i = Some (loc, v_old, f_old)) <->
                    (exists v_new, is_accessing e = Some (loc, v_new))):
  i <-> is_accessing e.
Proof.
  destruct i; ss.
  - destruct p as [[]]. destruct (WF t).
    exploit H; eauto. intros x. des. rewrite x. ss.
  - destruct e; ss.
    + destruct (WF loc). exploit H0; eauto. i. des. ss.
    + destruct (WF loc). exploit H0; eauto. i. des. ss.
    + destruct (WF loc). exploit H0; eauto. i. des. ss.
Qed.

Definition oracle_simple_output (i: Oracle.input): Oracle.output :=
  let 'Oracle.mk_input acc acq rel := i in
  Oracle.mk_output
    (if is_some acc then Some Perm.low else None)
    (if is_some acq then Some (fun _ => Perm.low, fun _ => Const.undef) else None)
    (if is_some rel then Some (fun _ => Perm.low) else None).

Lemma oracle_simple_output_wf
      pe i
      (WF: Oracle.wf_input pe i):
  Oracle.wf_output pe (oracle_simple_output i).
Proof.
  unfold Oracle.wf_input, Oracle.wf_output in *. splitsH.
  apply oracle_wf_in_access_some in H.
  rewrite <- H, <- H1, <- H2.
  destruct i. ss. splits.
  - destruct in_access; ss.
  - destruct in_acquire; ss.
  - destruct in_release; ss.
Qed.

(** dummy_oracle *)

Definition dummy_oracle_step
           (_t: Type) (pe: ProgramEvent.t) (i: Oracle.input) (o: Oracle.output) (orc0 orc1: _t): Prop :=
  Oracle.wf_input pe i /\ o = oracle_simple_output i.

Definition dummy_oracle: Oracle.t := Oracle.mk (@dummy_oracle_step unit) tt.

Lemma dummy_oracle_wf: Oracle.wf dummy_oracle.
Proof.
  pcofix CIH. pfold. econs; ii.
  - inv STEP. existT_elim. subst. inv STEP0. splits; ss.
    + apply oracle_simple_output_wf; ss.
    + right. destruct x2. ss.
  - exists Const.undef. split; ii.
    + esplits; try eapply oracle_simple_output_wf; eauto.
      econs. econs; eauto.
    + esplits; try eapply oracle_simple_output_wf; eauto.
      econs. econs; eauto.
  - esplits; try eapply oracle_simple_output_wf; eauto.
    econs. econs; eauto.
  - esplits; try eapply oracle_simple_output_wf; eauto.
    econs. econs; eauto.
  - esplits; try eapply oracle_simple_output_wf; eauto.
    econs. econs; eauto.
    Unshelve.
    all: ss.
Qed.

(** oracle_of_trace *)

Definition oracle_similar_input_access (i1 i2: option (Loc.t * Const.t * Flag.t)): bool :=
  match i1, i2 with
  | Some (loc1, _, _), Some (loc2, _, _) => Loc.eqb loc1 loc2
  | None, None => true
  | _, _ => false
  end.

Definition oracle_similar_input (i1 i2: Oracle.input): bool :=
  andb (oracle_similar_input_access i1.(Oracle.in_access) i2.(Oracle.in_access))
       (andb (eqb (is_some i1.(Oracle.in_acquire)) (is_some i2.(Oracle.in_acquire)))
             (eqb (is_some i1.(Oracle.in_release)) (is_some i2.(Oracle.in_release)))).

Global Program Instance oracle_similar_input_Equivalence: Equivalence oracle_similar_input.
Next Obligation.
  ii. destruct x. destruct in_access.
  - destruct p as [[]]. unfold oracle_similar_input, oracle_similar_input_access. ss.
    rewrite Loc.eqb_refl. destruct in_acquire, in_release; ss.
  - destruct in_acquire, in_release; ss.
Qed.
Next Obligation.
  ii. destruct x, y. unfold oracle_similar_input in *. ss.
  inv H. etrans; eauto.
  repeat rewrite andb_true_iff in *. des. splits.
  - destruct in_access0, in_access; ss.
    + destruct p as [[]], p0 as [[]].
      rewrite Loc.eqb_eq in *. congr.
    + destruct p as [[]]. ss.
  - destruct in_acquire, in_acquire0; ss.
  - destruct in_release, in_release0; ss.
Qed.
Next Obligation.
  ii. destruct x, y, z. unfold oracle_similar_input in *. ss.
  inv H. inv H0. etrans; eauto.
  repeat rewrite andb_true_iff in *. des. splits.
  - destruct in_access, in_access0, in_access1; ss.
    + destruct p as [[]], p1 as [[]], p0 as [[]].
      rewrite Loc.eqb_eq in *. congr.
    + destruct p0 as [[]]. ss.
  - destruct in_acquire, in_acquire0; ss.
  - destruct in_release, in_release0; ss.
Qed.

Lemma input_match_similar
      d0 d1 i_src i_tgt
      (MATCH: SeqEvent.input_match d0 d1 i_src i_tgt):
  oracle_similar_input (SeqEvent.get_oracle_input i_src) (SeqEvent.get_oracle_input i_tgt).
Proof.
  inv MATCH. unfold oracle_similar_input in *.
  destruct i_src, i_tgt. ss.
  inv ACCESS; inv ACQUIRE; inv RELEASE; ss; rewrite Loc.eqb_refl; ss.
Qed.

Lemma input_le_similar
      i0 i1
      (LE: Oracle.input_le i0 i1):
  oracle_similar_input i0 i1.
Proof.
  destruct i0, i1.
  unfold Oracle.input_le, oracle_similar_input in *. ss. des.
  etrans; eauto.
  repeat rewrite andb_true_iff. splits.
  - destruct in_access, in_access0; ss.
    destruct p as [[]], p0 as [[]]; ss. des. subst. apply Loc.eqb_refl.
  - destruct in_acquire, in_acquire0; ss.
  - destruct in_release, in_release0; ss.
Qed.

Lemma oracle_similar_input_loc
      i1 i2
      loc1 v1 f1
      loc2 v2 f2
      (SIMILAR: oracle_similar_input i1 i2)
      (IN1: i1.(Oracle.in_access) = Some (loc1, v1, f1))
      (IN2: i2.(Oracle.in_access) = Some (loc2, v2, f2)):
  loc1 = loc2.
Proof.
  destruct i1, i2; ss. subst.
  unfold oracle_similar_input, oracle_similar_input_access in *. ss.
  inv SIMILAR. apply andb_prop in H0. des.
  rewrite Loc.eqb_eq in H0. ss.
Qed.

Definition oracle_output_of_event
           (i: Oracle.input) (o: Oracle.output) (i_src: Oracle.input): Oracle.output :=
  if oracle_similar_input i i_src
  then o
  else oracle_simple_output i_src.

Definition reading_value_of (e: ProgramEvent.t): option Const.t :=
  match e with
  | ProgramEvent.read _ v _
  | ProgramEvent.update _ v _ _ _ => Some v
  | _ => None
  end.

Definition eq_reading_value (e1 e2: ProgramEvent.t): Prop :=
  match reading_value_of e1, reading_value_of e2 with
  | Some v1, Some v2 => v1 = v2
  | _, _ => True
  end.

Global Program Instance eq_reading_value_Reflexive: Reflexive eq_reading_value.
Next Obligation.
  ii. destruct x; ss.
Qed.

Global Program Instance eq_reading_value_Symmetric: Symmetric eq_reading_value.
Next Obligation.
  ii. destruct x, y; ss; inv H; ss.
Qed.

Variant oracle_step_of_event (e: ProgramEvent.t) (i: Oracle.input) (o: Oracle.output) (orc: Oracle.t):
  forall (pe: ProgramEvent.t) (i: Oracle.input) (o: Oracle.output) (orc0 orc1: option orc.(Oracle._t)), Prop :=
| oracle_step_of_event_None
    e' i' o'
    (EVENT: eq_reading_value e e')
    (INPUT: Oracle.wf_input e' i')
    (OUT: o' = oracle_output_of_event i o i'):
    oracle_step_of_event e i o orc e' i' o' None (Some orc.(Oracle._o))
| oracle_step_of_event_Some
    e' i' o' orc0 orc1
    (STEP: orc.(Oracle._step) e' i' o' orc0 orc1):
    oracle_step_of_event e i o orc e' i' o' (Some orc0) (Some orc1)
.

Definition oracle_of_event
           (e: ProgramEvent.t) (i: Oracle.input) (o: Oracle.output) (orc: Oracle.t): Oracle.t :=
  Oracle.mk (oracle_step_of_event e i o orc) None.

Fixpoint oracle_of_trace_aux
         (tr: list (ProgramEvent.t * SeqEvent.input * Oracle.output)) (orc: Oracle.t): Oracle.t :=
  match tr with
  | [] => orc
  | (e, i, o) :: tr =>
    oracle_of_event e (SeqEvent.get_oracle_input i) o (oracle_of_trace_aux tr orc)
  end.

Definition oracle_of_trace tr orc_init := oracle_of_trace_aux tr orc_init.

Inductive oracle_follows_trace (orc0: Oracle.t):
  forall (tr: list (ProgramEvent.t * SeqEvent.input * Oracle.output)) (orc: Oracle.t), Prop :=
| oracle_follows_trace_nil
    orc
    (LE1: oracle_le orc orc0)
    (LE2: oracle_le orc0 orc):
    oracle_follows_trace orc0 [] orc
| oracle_follows_trace_cons
    e i o tr orc1
    (SOUND: forall e' i' o' orc2
              (STEP: Oracle.step e' i' o' orc1 orc2),
        (<<EVENT: eq_reading_value e e'>>) /\
        (oracle_similar_input (SeqEvent.get_oracle_input i) i' ->
         (<<OUTPUT: o' = o>>) /\
         (<<FOLLOWS: oracle_follows_trace orc0 tr orc2>>)))
    (COMPLETE: forall e' i'
                 (EVENT: eq_reading_value e e')
                 (INPUT: oracle_similar_input (SeqEvent.get_oracle_input i) i')
                 (WF_INPUT: Oracle.wf_input e' i'),
        exists orc2,
          (<<STEP: Oracle.step e' i' o orc1 orc2>>)):
    oracle_follows_trace orc0 ((e, i, o) :: tr) orc1
.

Lemma option_oracle_follows
      orc0 tr orc e i o
      (FOLLOWS: oracle_follows_trace orc0 tr orc):
  oracle_follows_trace
    orc0 tr (Oracle.mk (oracle_step_of_event e i o orc) (Some orc.(Oracle._o))).
Proof.
  destruct orc. ss.
  generalize _o at 1.
  revert _o i o FOLLOWS.
  induction tr; i.
  { inv FOLLOWS. econs.
    - clear LE2. revert orc0 _o _o0 LE1.
      pcofix CIH. i. pfold. econs. i.
      inv STEP. existT_elim. subst. inv STEP0. ss.
      punfold LE1. inv LE1. exploit LE.
      { econs. eauto. }
      i. des. inv LE1; try done.
      exploit CIH; eauto. i.
      esplits; eauto.
    - clear LE1. revert orc0 _o _o0 LE2.
      pcofix CIH. i. pfold. econs. i.
      punfold LE2. inv LE2. exploit LE; eauto. i. des.
      inv LE1; try done.
      inv STEP0. existT_elim. subst.
      exploit CIH; eauto. i.
      esplits.
      { econs. econs. eauto. }
      right. eauto.
  }
  inv FOLLOWS. econs; i.
  - inv STEP. existT_elim. subst. inv STEP0.
    exploit SOUND.
    { econs; eauto. }
    intros x. des. split; ss. i.
    exploit x0; eauto. i. des. subst. splits; ss.
    eapply IHtr; eauto.
  - exploit COMPLETE; eauto. i. des. inv STEP. existT_elim. subst.
    esplits. econs. econs. eauto.
Qed.

Lemma oracle_of_trace_follows tr orc_init:
  oracle_follows_trace orc_init tr (oracle_of_trace tr orc_init).
Proof.
  induction tr.
  { econs; ss; apply oracle_le_refl. }
  destruct a as [[e i] o]. econs; i.
  - inv STEP. existT_elim. subst. inv STEP0.
    unfold oracle_output_of_event. condtac; ss. splits; ss. i.
    split; ss. eapply option_oracle_follows. auto.
  - esplits. unfold oracle_of_trace. ss. econs. econs; eauto.
    unfold oracle_output_of_event. condtac; ss.
Qed.

Definition wf_trace tr: Prop :=
  Forall (fun x => match x with
                | (e, i, o) => SeqEvent.wf_input e i /\ Oracle.wf_output e o
                end) tr.

Lemma oracle_similar_input_fields
      i1 i2
      (SIMILAR: oracle_similar_input i1 i2):
  (i1.(Oracle.in_access) <-> i2.(Oracle.in_access)) /\
  (i1.(Oracle.in_acquire) <-> i2.(Oracle.in_acquire)) /\
  (i1.(Oracle.in_release) <-> i2.(Oracle.in_release)).
Proof.
  destruct i1, i2. ss.
  unfold oracle_similar_input in *. inv SIMILAR.
  repeat rewrite andb_true_iff in *. des.
  apply eqb_prop in H1, H2. rewrite H1, H2. splits; ss.
  destruct in_access, in_access0; ss.
  destruct p as [[]]. ss.
Qed.

Lemma oracle_output_of_event_wf
      e i o e' i'
      (WF_INPUT: Oracle.wf_input e i)
      (WF_OUTPUT: Oracle.wf_output e o)
      (WF: Oracle.wf_input e' i'):
  Oracle.wf_output e' (oracle_output_of_event i o i').
Proof.
  unfold oracle_output_of_event. condtac; cycle 1.
  { apply oracle_simple_output_wf. ss. }
  unfold Oracle.wf_input, Oracle.wf_output in *.
  exploit oracle_similar_input_fields; eauto. i. splitsH.
  splits; cycle 1.
  { rewrite H7. rewrite <- H10. rewrite H1. ss. }
  { rewrite H8. rewrite <- H11. rewrite H2. ss. }
  apply oracle_wf_in_access_some in H0, H6.
  rewrite H3. rewrite <- H6. rewrite H. ss.
Qed.

Lemma option_oracle_wf
      orc e i o
      (WF: Oracle.wf orc):
  Oracle.wf (Oracle.mk (oracle_step_of_event e i o orc) (Some orc.(Oracle._o))).
Proof.
  destruct orc. ss.
  generalize _o at 1. revert _o WF.
  pcofix CIH. i. punfold WF. inv WF.
  pfold. econs; i.
  { inv STEP. existT_elim. subst. inv STEP0. ss.
    exploit WF0; [econs; eauto|]. i. des. splits; ss.
    inv ORACLE; try done. right. eauto.
  }
  { clear - LOAD.
    specialize (LOAD loc ord). des. exists val. split; ii.
    - exploit LOAD; eauto. i. des.
      inv STEP. existT_elim. subst.
      esplits; eauto. econs. econs. eauto.
    - exploit LOAD0; eauto. i. des.
      inv STEP. existT_elim. subst.
      esplits; eauto. econs. econs. eauto.
  }
  { clear - STORE.
    ii. exploit STORE; eauto. i. des.
    inv STEP. existT_elim. subst.
    esplits; eauto. econs. econs. eauto.
  }
  { clear - FENCE.
    ii. exploit FENCE; eauto. i. des.
    inv STEP. existT_elim. subst.
    esplits; eauto. econs. econs. eauto.
  }
  { clear - SYSCALL.
    ii. exploit SYSCALL; eauto. i. des.
    inv STEP. existT_elim. subst.
    esplits; eauto. econs. econs. eauto.
  }
Qed.

Lemma oracle_of_trace_wf
      tr orc_init
      (TRACE: wf_trace tr)
      (INIT: Oracle.wf orc_init):
  Oracle.wf (oracle_of_trace tr orc_init).
Proof.
  revert TRACE. induction tr; i; ss.
  destruct a as [[e i] o]. inv TRACE. des.
  exploit IHtr; eauto. i. clear IHtr.
  pfold. econs; i.
  { unfold oracle_of_trace in *. ss.
    inv STEP. existT_elim. subst. inv STEP0. splits; ss.
    { eapply oracle_output_of_event_wf; eauto.
      apply wf_input_oracle_wf_input; eauto.
    }
    left. apply option_oracle_wf. auto.
  }
  { destruct (reading_value_of e) as [v|] eqn:READING.
    - exists v. split; ii.
      + esplits.
        * econs. econs; eauto. destruct e; ss; inv READING; ss.
        * eapply oracle_output_of_event_wf; eauto.
          apply wf_input_oracle_wf_input. ss.
      + esplits.
        * econs. econs; eauto. destruct e; ss; inv READING; ss.
        * eapply oracle_output_of_event_wf; eauto.
          apply wf_input_oracle_wf_input. ss.
    - exists Const.undef. split; ii.
      + esplits.
        * econs. econs; eauto. destruct e; ss.
        * eapply oracle_output_of_event_wf; eauto.
          apply wf_input_oracle_wf_input. ss.
      + esplits.
        * econs. econs; eauto. destruct e; ss.
        * eapply oracle_output_of_event_wf; eauto.
          apply wf_input_oracle_wf_input. ss.
  }
  { ii. esplits.
    - econs. econs; eauto. destruct e; ss.
    - eapply oracle_output_of_event_wf; eauto.
      apply wf_input_oracle_wf_input. ss.
  }
  { ii. esplits.
    - econs. econs; eauto. destruct e; ss.
    - eapply oracle_output_of_event_wf; eauto.
      apply wf_input_oracle_wf_input. ss.
  }
  { ii. esplits.
    - econs. econs; eauto. destruct e; ss.
    - eapply oracle_output_of_event_wf; eauto.
      apply wf_input_oracle_wf_input. ss.
  }
Qed.

(** add_oracle *)

Inductive add_oracle_t (_t: Type): Type :=
| add_oracle_init (orc: _t)
| add_oracle_orc (orc: _t)
.

Variant add_oracle_step (e: ProgramEvent.t) (i: Oracle.input) (o: Oracle.output)
        (_t: Type) (step: ProgramEvent.t -> Oracle.input -> Oracle.output -> _t -> _t -> Prop):
  forall (e: ProgramEvent.t) (i: Oracle.input) (o: Oracle.output)
    (orc0 orc1: add_oracle_t _t), Prop :=
| add_oracle_step_init_event
    orc0:
    add_oracle_step e i o step e i o (add_oracle_init orc0) (add_oracle_orc orc0)
| add_oracle_step_init_orc
    e' i' o' orc0 orc1
    (STEP: step e' i' o' orc0 orc1):
    add_oracle_step e i o step e' i' o' (add_oracle_init orc0) (add_oracle_orc orc1)
| add_oracle_step_orc
    e' i' o' orc0 orc1
    (STEP: step e' i' o' orc0 orc1):
    add_oracle_step e i o step e' i' o' (add_oracle_orc orc0) (add_oracle_orc orc1)
.

Definition add_oracle
           (e: ProgramEvent.t) (i: Oracle.input) (o: Oracle.output) (orc: Oracle.t): Oracle.t :=
  Oracle.mk (add_oracle_step e i o orc.(Oracle._step)) (add_oracle_init orc.(Oracle._o)).

Lemma add_oracle_orc_le e i o _t step orc:
  oracle_le (Oracle.mk (@add_oracle_step e i o _t step) (add_oracle_orc orc)) (Oracle.mk step orc).
Proof.
  revert orc. pcofix CIH. i. pfold. econs. i.
  inv STEP. existT_elim. subst. inv STEP0. esplits.
  - econs. eauto.
  - right. ss.
Qed.

Lemma add_oracle_spec
      e i o orc_init
      e' i' o' orc0 orc1
      (ORACLE: orc0 = add_oracle e i o orc_init)
      (STEP: Oracle.step e' i' o' orc0 orc1):
  (e' = e /\ i' = i /\ o' = o /\ oracle_le orc1 orc_init) \/
  (exists orc_init1,
      (<<STEP: Oracle.step e' i' o' orc_init orc_init1>>) /\
      (<<LE: oracle_le orc1 orc_init1>>)).
Proof.
  subst. inv STEP. existT_elim. subst. inv STEP0.
  - left. splits; ss.
    destruct orc_init. ss. eapply add_oracle_orc_le; eauto.
  - right. destruct orc_init. ss. esplits.
    + econs. eauto.
    + eapply add_oracle_orc_le; eauto.
Qed.

Lemma add_oracle_init_progress
      e i o _t step orc
      e'
      (PROGRESS: Oracle.progress e' (Oracle.mk step orc)):
  Oracle.progress e' (Oracle.mk (@add_oracle_step e i o _t step) (add_oracle_init orc)).
Proof.
  unfold Oracle.progress in *. i.
  exploit PROGRESS; eauto. i. des.
  inv STEP. existT_elim. subst.
  esplits; eauto. econs. econs. eauto.
Qed.

Lemma add_oracle_orc_progress
      e i o _t step orc
      e'
      (PROGRESS: Oracle.progress e' (Oracle.mk step orc)):
  Oracle.progress e' (Oracle.mk (@add_oracle_step e i o _t step) (add_oracle_orc orc)).
Proof.
  unfold Oracle.progress in *. i.
  exploit PROGRESS; eauto. i. des.
  inv STEP. existT_elim. subst.
  esplits; eauto. econs. econs. eauto.
Qed.

Lemma add_oracle_orc_wf
      e i o _t step orc
      (WF: Oracle.wf (Oracle.mk step orc)):
  Oracle.wf (Oracle.mk (@add_oracle_step e i o _t step) (add_oracle_orc orc)).
Proof.
  revert orc WF. pcofix CIH. i.
  punfold WF. inv WF.
  pfold. econs; i; eauto using add_oracle_orc_progress.
  - inv STEP. existT_elim. subst. inv STEP0.
    exploit WF0; [econs; eauto|]. i. des.
    inv ORACLE; try done. splits; auto.
  - specialize (LOAD loc ord). des. exists val.
    split; i; apply add_oracle_orc_progress; ss.
Qed.

Lemma add_oracle_wf
      e i o orc_init
      (WF_INPUT: Oracle.wf_input e i)
      (WF_OUTPUT: Oracle.wf_output e o)
      (WF: Oracle.wf orc_init):
  Oracle.wf (add_oracle e i o orc_init).
Proof.
  destruct orc_init.
  dup WF. punfold WF. inv WF.
  pfold. econs; i; eauto using add_oracle_init_progress.
  { inv STEP. existT_elim. subst. inv STEP0.
    - splits; auto. left. apply add_oracle_orc_wf. ss.
    - exploit WF1; [econs; eauto|]. i. des.
      inv ORACLE; try done. splits; ss.
      left. eapply add_oracle_orc_wf. ss.
  }
  { specialize (LOAD loc ord). des. exists val.
    split; i; eapply add_oracle_init_progress; ss.
  }
Qed.

Lemma nil_steps_any_oracle
      lang step st1 p1 orc1 st2 p2 orc2 orc
      (STEPS: SeqThread.steps step [] (@SeqThread.mk lang st1 p1 orc1) (SeqThread.mk st2 p2 orc2)):
  orc1 = orc2 /\
  SeqThread.steps step [] (SeqThread.mk st1 p1 orc) (SeqThread.mk st2 p2 orc).
Proof.
  dependent induction STEPS; ss.
  - split; ss. econs.
  - destruct th1.
    exploit IHSTEPS; eauto. i. des.
    inv STEP. splits; ss.
    econs 2; eauto. econs. ss.
Qed.

Lemma steps_cons_inv
      lang step e i o tr st1 p1 orc1 th4
      (STEPS: SeqThread.steps step ((e, i, o) :: tr)
                              (@SeqThread.mk lang st1 p1 orc1) th4):
  exists st2 th3,
    (<<NASTEPS: SeqThread.steps step [] (SeqThread.mk st1 p1 orc1) (SeqThread.mk st2 p1 orc1)>>) /\
    (<<ATSTEP: SeqThread.at_step e i o (SeqThread.mk st2 p1 orc1) th3>>) /\
    (<<STEPS: SeqThread.steps step tr th3 th4>>).
Proof.
  dependent induction STEPS; ss.
  - destruct th1. inv STEP.
    exploit IHSTEPS; eauto. i. des.
    esplits; eauto. econs 2; eauto. econs. ss.
  - esplits; eauto. econs 1.
Qed.

Lemma steps_app
      lang step tr1 tr2 (th1 th2 th3: SeqThread.t lang)
      (STEPS1: SeqThread.steps step tr1 th1 th2)
      (STEPS2: SeqThread.steps step tr2 th2 th3):
  SeqThread.steps step (tr1 ++ tr2) th1 th3.
Proof.
  induction STEPS1; ss.
  - econs 2; eauto.
  - econs 3; eauto.
Qed.

Lemma add_oracle_steps_inv
      lang step e i o orc tr st1 p1 orc1 st2 p2 orc2
      (ORACLE: oracle_le orc1 (add_oracle e i o orc))
      (STEPS: SeqThread.steps step tr
                              (@SeqThread.mk lang st1 p1 orc1)
                              (SeqThread.mk st2 p2 orc2)):
  (exists orc2',
      SeqThread.steps step tr
                      (SeqThread.mk st1 p1 orc)
                      (SeqThread.mk st2 p2 orc2')) \/
  (exists e' i' o' tr',
      (<<TRACE: tr = (e', i', o') :: tr'>>) /\
      (<<EVENT: ProgramEvent.le e e'>>) /\
      (<<INPUT: Oracle.input_le i (SeqEvent.get_oracle_input i')>>) /\
      (<<OUTPUT: o' = o>>)).
Proof.
  destruct tr.
  { left. exploit nil_steps_any_oracle; eauto. i. des. esplits; eauto. }
  destruct p as [[e' i'] o'].
  exploit steps_cons_inv; eauto. i. des. clear STEPS.
  inv ATSTEP.
  punfold ORACLE. inv ORACLE. exploit LE; eauto. i. des. inv LE1; ss.
  exploit add_oracle_spec; eauto. i. des; subst.
  { right. esplits; eauto. }
  left.
  exploit oracle_le_steps; try exact STEPS0.
  { eapply oracle_le_trans; eauto. }
  i. des. exists orc2'.
  replace ((e', i', o') :: tr) with ([] ++ (e', i', o') :: tr).
  eapply steps_app.
  { eapply nil_steps_any_oracle; eauto. }
  econs 3; eauto; ss.
  econs; eauto. ss.
Qed.

Definition oracle_input_of_event (e: ProgramEvent.t) (m: SeqMemory.t): Oracle.input :=
  Oracle.mk_input
    (match is_accessing e with
     | Some (loc, _) => Some (loc, m.(SeqMemory.value_map) loc, m.(SeqMemory.flags) loc)
     | None => None
     end)
    (if is_acquire e then Some () else None)
    (if is_release e then Some () else None)
.

Lemma oracle_input_of_event_wf e m:
  Oracle.wf_input e (oracle_input_of_event e m).
Proof.
  unfold Oracle.wf_input. splits; ss; try by des_ifs.
  ss. des_ifs; split; i; des; inv H; eauto.
Qed.


Require Export sem_lab.
Require Export absop_rules.
Import os_ucos_h.

Open Scope code_scope.

Lemma sem_H_get_none:
  forall els eid,
    EcbMod.get els eid = None ->
    ~(exists n wls, EcbMod.get els eid = Some (abssem n, wls)).
  intros.
  unfold not.
  intros.
  destruct H0.
  destruct H0.
  rewrite H in H0.
  tryfalse.
Qed.

Ltac mytac :=
  heat; jeauto2.

Lemma eventsearch_after_get_H:
  forall p ectrl1 a b ectrl2 msgqls1 msgq msgqls2 mqls tcbls  qid mqls1 mqls' mq mqls2,
    length ectrl1 = length msgqls1 ->
    ECBList_P p Vnull
              (ectrl1 ++ ((a,b)::nil) ++ ectrl2)
              (msgqls1 ++ (msgq::nil) ++ msgqls2)
              mqls tcbls ->
    ECBList_P p (Vptr qid) ectrl1 msgqls1 mqls1 tcbls ->
    EcbMod.join mqls1 mqls' mqls ->
    EcbMod.joinsig qid mq mqls2 mqls' ->
    EcbMod.get mqls qid = Some mq.
  intros.
  apply ecblist_p_decompose in H0; auto.
  mytac.

  assert (x1 = Vptr qid /\ x = mqls1).
    eapply ecblist_p_eqh with (ecbls:=mqls); eauto.
    EcbMod.solve_map.
    EcbMod.solve_map.

  mytac.
  lets Hx:EcbMod.join_joinsig_get H2 H3.
  auto.
Qed.

Lemma semacc_eventtype_neq_sem:
  forall s P p ectrl1 a b ectrl2 msgqls1 msgq msgqls2 mqls tcbls  qid mqls1 mqls' mq mqls2 t,
    s |= AEventData a msgq ** P ->
    RLH_ECBData_P msgq mq ->
    length ectrl1 = length msgqls1 ->
    ECBList_P p Vnull
              (ectrl1 ++ ((a,b)::nil) ++ ectrl2)
              (msgqls1 ++ (msgq::nil) ++ msgqls2)
              mqls tcbls ->
    ECBList_P p (Vptr qid) ectrl1 msgqls1 mqls1 tcbls ->
    EcbMod.join mqls1 mqls' mqls ->
    EcbMod.joinsig qid mq mqls2 mqls' ->
    V_OSEventType a = Some (Vint32 t) ->
    Int.eq t ($ OS_EVENT_TYPE_SEM) = false ->
    s |= AEventData a msgq **
         [| ~ exists n wls, EcbMod.get mqls qid = Some (abssem n, wls)|] ** P.
  intros.
  assert (EcbMod.get mqls qid = Some mq).
    eapply eventsearch_after_get_H; eauto.

  unfold AEventData in *.
  destruct msgq eqn:Hmsgq.
  sep split in H.
  sep auto.
  unfold RLH_ECBData_P in H0.
  destruct mq; destruct e eqn:Hmq; tryfalse.
  unfold not; intros; mytac; tryfalse.

  sep split in H.
  rewrite H9 in H6.
  inverts H6.
  rewrite Int.eq_true in H7.
  tryfalse.

  sep split in H.
  sep auto.
  unfold RLH_ECBData_P in H0.
  destruct mq; destruct e eqn:Hmq; tryfalse.
  unfold not; intros; mytac; tryfalse.

  sep split in H.
  sep auto.
  unfold RLH_ECBData_P in H0.
  destruct mq; destruct e eqn:Hmq; tryfalse.
  unfold not; intros; mytac; tryfalse.
Qed.

Lemma semacc_triangle_sem:
  forall s P a msgq mq n,
    s |= AEventData a msgq ** P ->
    RLH_ECBData_P msgq mq ->
    V_OSEventType a = Some (V$OS_EVENT_TYPE_SEM) ->
    V_OSEventCnt a = Some (Vint32 n) ->
    s |= AEventData a msgq **
         [| exists wls, msgq = DSem n /\ mq = (abssem n, wls) |] ** P.
  intros.
  sep pauto.
  unfold AEventData in *.
  destruct msgq eqn:Hmsgq; sep split in H.
  rewrite H1 in H4; tryfalse.

  unfold RLH_ECBData_P in H0.
  destruct mq; destruct e eqn:Hmq; tryfalse.
  rewrite H2 in H4. inverts H4.
  inverts H0.
  exists w.
  auto.

  rewrite H1 in H3; tryfalse.

  rewrite H1 in H3; tryfalse.
Qed.

Lemma semacc_ltu_trans:
  forall x y,
    Int.ltu Int.zero x = true ->
    Int.ltu x y = true ->
    Int.ltu (Int.sub x Int.one) y = true.
  int auto.
  int auto.
Qed.

Lemma semacc_compose_EcbList_P:
  forall p qid a b tcbls i n x2 x3 vn msgq mq ectrl1 msgqls1 mqls1 ectrl2 msgqls2 mqls2 mqls' mqls,
    R_ECB_ETbl_P qid (a,b) tcbls ->
    a = (V$OS_EVENT_TYPE_SEM :: Vint32 i :: Vint32 n :: x2 :: x3 :: vn :: nil) ->
    RLH_ECBData_P msgq mq ->
    ECBList_P p (Vptr qid) ectrl1 msgqls1 mqls1 tcbls ->
    ECBList_P vn Vnull ectrl2 msgqls2 mqls2 tcbls ->
    EcbMod.joinsig qid mq mqls2 mqls' ->
    EcbMod.join mqls1 mqls' mqls ->
    ECBList_P p Vnull (ectrl1 ++ ((a,b)::nil) ++ ectrl2)
              (msgqls1 ++ (msgq::nil) ++ msgqls2)
              mqls tcbls.
  intros.
  subst.
  eapply ecblist_p_compose; eauto.
  simpl.
  eexists; splits; eauto.
  do 3 eexists; splits; eauto.
  unfolds; simpl; auto.
Qed.

(************************************** from post *****************************)

Lemma sem_eventtype_neq_sem:
   forall s P a msgq mq t,
    s |= AEventData a msgq ** P ->
    RLH_ECBData_P msgq mq ->
    V_OSEventType a = Some (Vint32 t) ->
    Int.eq t ($ OS_EVENT_TYPE_SEM) = false ->
    s |= AEventData a msgq **
         [| (~ exists n wls, mq = (abssem n, wls)) |] ** P.
  intros.

  unfold AEventData in *.
  destruct msgq eqn:Hmsgq.
  sep split in H.
  sep auto.
  unfold RLH_ECBData_P in H0.
  destruct mq; destruct e eqn:Hmq; tryfalse.
  unfold not; intros; mytac; tryfalse.

  sep split in H.
  rewrite H3 in H1.
  inverts H1.
  rewrite Int.eq_true in H2.
  tryfalse.

  sep split in H.
  sep auto.
  unfold RLH_ECBData_P in H0.
  destruct mq; destruct e eqn:Hmq; tryfalse.
  unfold not; intros; mytac; tryfalse.

  sep split in H.
  sep auto.
  unfold RLH_ECBData_P in H0.
  destruct mq; destruct e eqn:Hmq; tryfalse.
  unfold not; intros; mytac; tryfalse.
Qed.

Lemma  Mutex_owner_set: forall x y z t, (~exists aa bb cc, t = (absmutexsem aa bb, cc))->   RH_TCBList_ECBList_MUTEX_OWNER x y ->  RH_TCBList_ECBList_MUTEX_OWNER (EcbMod.set x z t) y.
Proof.
    intros.
    unfold RH_TCBList_ECBList_MUTEX_OWNER in *.
    intros.
    assert ( eid = z \/ eid <> z).
    tauto.
    elim H2; intros.
    subst eid.
    rewrite EcbMod.set_a_get_a in H1.
    inverts H1.
    false.
    apply H.
    eauto.
    go.

    rewrite EcbMod.set_a_get_a' in H1.
    eapply H0; eauto.
    go.
Qed.

Lemma  Mutex_owner_hold_for_set_tcb: forall x y pcur a b c,  RH_TCBList_ECBList_MUTEX_OWNER x y ->  RH_TCBList_ECBList_MUTEX_OWNER x (TcbMod.set y pcur (a, b, c)).
Proof.
    intros.
    unfold   RH_TCBList_ECBList_MUTEX_OWNER  in *.
    intros.
    assert ( pcur = tid  \/ pcur <> tid ) by tauto.
    elim H1; intros.
    subst pcur.
    rewrite TcbMod.set_a_get_a; auto.
    eauto.
    go.
    rewrite TcbMod.set_a_get_a'; auto.
    eapply H; eauto.
    go.
Qed.

Definition semcre_RL_Tbl_init_prop:
  RL_Tbl_Grp_P INIT_EVENT_TBL (Vint32 Int.zero).
Proof.
  unfolds.
  intros.
  splits.
  intros.
  inverts H1.
  split.
  simpl in H0.
  intros.
  destruct H.
  lets Hex : nat8_des H2 H0.
  auto.
  intros.
  rewrite Int.and_zero_l.
  auto.
  inverts H1.
  split.
  rewrite Int.and_zero_l.
  intros.
  apply leftmoven in H.
  unfold Int.zero in H1.
  tryfalse.
  simpl in H0.
  lets Hesx : nat8_des H H0.
  intros.
  unfold Int.zero in Hesx.
  int auto.
  remember (zlt 0 (Int.unsigned v)) as Hb.
  destruct Hb;
  tryfalse.
  assert (Int.unsigned v = 0).
  subst v.
  apply unsigned_zero.
  omega.
Qed.

Lemma semcre_ECBList_P:
  forall mqls tcbls ct sid ecbls p l i v1,
    RH_TCBList_ECBList_P mqls tcbls ct ->
    get mqls sid = None ->
    ECBList_P p Vnull l ecbls mqls tcbls ->
    ECBList_P (Vptr sid) Vnull
              ((V$OS_EVENT_TYPE_SEM
                 :: Vint32 Int.zero :: Vint32 i :: Vnull :: v1 :: p :: nil,
                INIT_EVENT_TBL) :: l) (DSem i :: ecbls)
               (set mqls sid (abssem i, nil))
               tcbls.
Proof.
  intros.
  unfolds.
  fold ECBList_P.
  eexists.
  split; eauto.
  split.
  unfolds.
  split.
  unfolds.
  destruct H as (Ha1 & Ha2 & Ha3 & Ha4).
  splits.
  unfolds.
  intros.
  usimpl H2.

  unfolds.
  intros.
  unfolds in H.
  mytac.
  simpl in H5.
  lets Hres : prio_prop  H H7; eauto.
  assert (∘(Int.unsigned (Int.shru ($ prio) ($ 3))) < 8)%nat.
  eapply Z_le_nat; eauto.
  split; auto.
  apply Int.unsigned_range_2.
  remember (∘(Int.unsigned (Int.shru ($ prio) ($ 3)))) as  Heq.
  assert (x1=Int.zero) by (eapply nat8_des;eauto).
  subst x1.
  apply int_land_zero in H6; tryfalse.

  unfolds.
  intros.
  usimpl H2.

  unfolds.
  intros.
  usimpl H2.

  destruct H as (Ha1 & Ha2 & Ha3 & Ha4).
  split.
  unfolds.
  splits.
  unfolds.
  intros.
  destruct Ha1 as (Hab & Hac).
  lets Hre : Hac H.
  destruct Hre as (xx & yy & wt & Hec & Hin).
  change ((fun x => x = None) (get mqls sid)) in H0.
  rewrite Hec in H0.
  tryfalse.

  unfolds.
  intros.
  destruct Ha2 as (Hab & Hac).
  lets Hre : Hac H.
  destruct Hre as (xx  & wt & Hec & Hin).
  change ((fun x => x = None) (get mqls sid)) in H0.
  rewrite Hec in H0.
  tryfalse.

  unfolds.
  intros.
  destruct Ha3 as (Hab & Hac).
  lets Hre : Hac H.
  destruct Hre as (xx  & wt & Hec & Hin).
  change ((fun x => x = None) (get mqls sid)) in H0.
  rewrite Hec in H0.
  tryfalse.

  unfolds.
  intros.
  destruct Ha4 as (Hab & Hac).
  apply Hac in H.
  destruct H as (n1 & n2  & wt & Hec & Hed).
  change ((fun x => x = None) (get mqls sid)) in H0.
  rewrite Hec in H0.
  tryfalse.

  unfolds.
  branch 2.
  simpl;auto.
  do 3 eexists.
  unfold V_OSEventListPtr.
  simpl nth_val .
  splits; eauto.
  instantiate (1:= (abssem i, nil)).
  eapply ecbmod_get_sig_set; eauto.
  unfolds.
  splits.
  auto.
  unfolds.
  split; intros; [reflexivity | tryfalse].
Qed.

Ltac tryfalse' :=
  repeat match goal with
           | H1: get ?x ?t = None, H2: get ?x ?t = Some _ |- _ =>
             change ((fun y => y = None) (get x t)) in H1;
             rewrite H2 in H1
           | H1: get ?x ?t = Some ?v1, H2: get ?x ?t = Some ?v2 |- _ =>
             change ((fun y => y = Some v1) (get x t)) in H1;
             rewrite H2 in H1
         end;
  tryfalse.

Lemma semcre_RH_TCBList_ECBList_P:
  forall v'37 x i v'38 v'40,
    get v'37 x = None ->
    RH_TCBList_ECBList_P v'37 v'38 v'40 ->
    RH_TCBList_ECBList_P
      (set v'37 x (abssem i, nil))
      v'38 v'40.
Proof.
  intros.
  unfolds.
  unfolds in H0.
  destruct H0 as (Ha1 & Ha2 & Ha3 & Ha4).
  split.

  destruct Ha1.
  unfolds.
  split.
  intros.
  rewrite set_sem in H2.
  destruct (dec x eid).
  destruct H2.
  inverts H2.
  lets Hres : H0 H2.
  eauto.
  intros.
  lets Hres : H1 H2.
  mytac.
  assert (eid = x \/ eid <> x) by tauto.
  destruct H5.
  subst.
  tryfalse'.
  rewrite set_sem.
  destruct (dec x eid); tryfalse.
  destruct (dec x x); tryfalse.
  eauto.

  split.
  destruct Ha2.
  unfolds.
  split.
  intros.
  rewrite set_sem in H2.
  destruct (dec x eid).
  destruct H2.
  inverts H2.
  simpl in H3; tryfalse.
  eapply H0; eauto.
  intros.
  rewrite set_sem.
  lets Hres : H1 H2.
  destruct Hres as (n&wls& Hec & Hin).
  remember (dec x eid) as Hbool.
  destruct Hbool.
  apply eq_sym in HeqHbool.
  subst x.
  tryfalse'.
  do 2 eexists; splits; eauto.

  split.
  destruct Ha3.
  unfolds.
  split.
  intros.
  rewrite set_sem in H2.
  destruct (dec x eid).
  destruct H2.
  inverts H2.
  lets Hres : H0 H2.
  eauto.
  intros.
  lets Hres : H1 H2.
  mytac.
  assert (eid = x \/ eid <> x) by tauto.
  destruct H5.
  subst.
  tryfalse'.
  rewrite set_sem.
  destruct (dec x eid); tryfalse.
  eauto.

  destruct Ha4.
  unfolds.
  split.
  intros.
  rewrite set_sem in H2.
  destruct (dec x eid).
  destruct H2.
  inverts H2.
  lets Hres : H0 H2.
  eauto.

  split; intros.

  destruct H1 as (H1 & H1').
  lets Hres : H1 H2.
  mytac.
  assert (eid = x \/ eid <> x) by tauto.
  destruct H5.
  subst.
  tryfalse'.
  rewrite set_sem.
  destruct (dec x eid); tryfalse; eauto.

  destruct H1 as (H1 & H1').
  eapply Mutex_owner_set.
  unfold not.
  intros.
  mytac.
  tryfalse'.
  auto.
Qed.

(** move to join_lib **)
Lemma map_join_get_none':
  forall (A B T : Type) (PermMap : PermMap A B T)
    (x y z : T) (t : A) v,
    join x y z ->
    get x t = None ->
    get y t = v ->
    get z t = v.
  intros.
  assert (get z t = get y t) by jeauto2.
  subst.
  auto.
Qed.

Lemma semcre_ecblist_star_not_inh :
    forall v'28 v'24  eid  v'27 v'37 v'38 s vl P,
      ECBList_P v'24 Vnull v'28 v'27 v'37 v'38 ->
      s |= Astruct eid OS_EVENT vl  **
        evsllseg v'24 Vnull v'28 v'27  ** P ->
      get v'37 eid = None.
Proof.
  inductions v'28;intros.
  simpl in H; mytac.
  unfold ECBList_P in H.
  fold ECBList_P in H.
  mytac.
  destruct v'27.
  tryfalse.
  destruct a.
  mytac.
  unfold evsllseg in H0.
  fold evsllseg in H0.
  sep normal in H0.
  sep destruct H0.
  sep split in H0.
  rewrite H in H5.
  inverts H5.
  sep lower 2%nat in H0.
  sep lower 3%nat in H0.
  sep lower 1%nat in H0.
  lets Hrs : IHv'28 H4 H0.
  unfold AEventNode in H0.
  unfold AOSEvent in H0.
  unfold node in H0.
  sep normal in H0.
  sep destruct H0.
  sep split in H0.
  mytac.
  inverts H5.
  sep lift 3%nat in H0.
  lets Hs : astruct_neq_ptr H0.
  intro Hf.
  unfolds in Hf.
  destruct Hf as [Hx | Hf].
  mytac.
  tryfalse.
  destruct Hf.
  mytac.
  tryfalse.
  tryfalse.
  intro Hf.
  unfolds in Hf.
  destruct Hf as [Hx | Hf].
  mytac.
  tryfalse.
  destruct Hf.
  mytac.
  tryfalse.
  tryfalse.
  unfold TcbJoin in H2.
  eapply map_join_get_none'; jeauto2.
Qed.

Lemma sempend_ltu_ass1:
  forall x, Int.ltu x x = false.
  int auto.
Qed.

Lemma sempend_ltu_ass2:
  Int.ltu Int.zero Int.one = true.
  int auto.
Qed.

Lemma join_prop2_my':
  forall m1 m2 m12 b1 prio st msg m3 ma3 m4 msg',
    join m1 m2 m12 ->
    TcbJoin (b1, Int.zero) (prio, st, msg) m3 ma3 ->
    join m4 ma3 m2 ->
    join m1
         (set m2 (b1, Int.zero) (prio, rdy, msg'))
         (set m12 (b1, Int.zero) (prio, rdy, msg')).
Proof.
  unfold TcbJoin.
  intros.
  eapply my_join_sig_abc.
  unfold usePerm; simpl; auto.
  eapply H1.
  trivial.
  unfold joinsig.
  eapply H0.
Qed.

Lemma statsem_and_not_statsem_eq_rdy : Int.eq ($ OS_STAT_SEM&ᵢInt.not ($ OS_STAT_SEM)) ($ OS_STAT_RDY) = true.
Proof.
  unfold OS_STAT_SEM, OS_STAT_RDY.
  unfold Int.not.
  unfold Int.xor.
  unfold Z.lxor.
  int auto.
  compute.
  split; intros; tryfalse.
  int auto.
  compute.
  intro; tryfalse.
  compute.
  intro; tryfalse.
  compute.
  split; intros; tryfalse.
Qed.


Require Import Coqlib.
Require Import Asm.
Require Import Integers.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.

(*TODO: Replace with newer version*)
Ltac prep_r :=
  T0 _destruct state_bits;
    NP0 app_new step_fwd_exec step_fwd; eauto;
  repeat break_and;
  P0 _clear step_through;
  P0 _clear step_fwd;
  P0 _clear current_fn;
  NP app_new mem_eq_match_metadata_r MemEq.mem_eq.

Ltac step_l :=
    NP1 app_new step_through_current_instr step_through;
    NP1 app_new step_through_current_fn step_through; [ | simpl; eauto ];
    (step_l_str || step_l_jmp);
    break_and; compute_skipz; P1 _simpl step_through; try break_and;
    NP1 app_new step_fwd_transf_block step_fwd.

(*
movl  %eax, %ecx
leal  -1(%ecx), %eax
testl %ecx, %ecx
=>
testl %eax, %eax
leal  -1(%eax), %eax
*)
Definition neg_one := (Int.repr (-1)).
Definition peep_test_then_lea_example :=
  Pmov_rr ECX EAX ::
  Plea EAX (Addrmode (Some ECX) None (inl neg_one)) ::
  Ptest_rr ECX ECX ::
  nil.

Section TEST_THEN_LEA.

  Variable concrete : code.
  Variable r1 r2 : ireg.
  Hypothesis r1_r2_neq : r1 <> r2.

  Definition peep_test_then_lea_defs : rewrite_defs :=
    {|
      fnd :=
        Pmov_rr r2 r1 ::
                Plea r1 (Addrmode (Some r2) None (inl neg_one)) ::
                Ptest_rr r2 r2 ::
                nil
      ; rpl :=
        Ptest_rr r1 r1 ::
                 Plea r1 (Addrmode (Some r1) None (inl neg_one)) ::
                 Pnop ::
                 nil
      ; lv_in := PC :: IR r1 :: nil
      ; lv_out := PC :: IR r1 :: flags
      ; clobbered := IR r2 :: nil
    |}.

    Lemma peep_test_then_lea_selr :
    StepEquiv.step_through_equiv_live (fnd peep_test_then_lea_defs) (rpl peep_test_then_lea_defs) (lv_in peep_test_then_lea_defs) (lv_out peep_test_then_lea_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    step_l.
    prep_r.
    step_r.
    step_r.
    step_r.
    finish_r.
    prep_eq.
    split.
    2: eq_mem_tac.
    intros.
    P0 _clear current_block.
    P0 _clear MemoryAxioms.match_metadata.
    P0 _clear no_ptr_mem.
    P0 _clear no_ptr_regs.
    break_or.
    repeat find_rewrite_goal.
    simpl.
    repeat (simpl_exec; try break_match; try congruence);
            repeat (state_inv); try opt_inv; preg_simpl.
    unfold Val.add.
    simpl.
    repeat find_rewrite_goal.
    f_equal.
    break_or.
    repeat (simpl_and_clear; try break_match; try congruence);
            repeat (state_inv); try opt_inv; preg_simpl.
    unfold Val.add.
    subst m0 m1 a1 a0 m.
    clear_taut.
    subst r0.
    preg_simpl.
    unfold Val.add.
    subst.
    preg_simpl.
    break_match_sm; simpl; intros;
    try break_match; try congruence.
    f_equal.
    P0 _simpl val_eq.
    inv_vint.
    f_equal.
    P0 _simpl val_eq.
    assumption.

    simpl_and_clear.

    assert (In reg flags) by (simpl; auto).

    repeat rewrite nextinstr_flags by assumption.
    rewrite Pregmap.gso.
    repeat rewrite nextinstr_flags by assumption.

    eapply val_eq_compare_ints; eauto.
    eapply val_eq_and; eauto.
    3: simpl; auto.
    subst_max.
    preg_simpl.
    assumption.
    subst_max.
    preg_simpl.
    assumption.
    subst m m1 m0.
    eauto.
    simpl in *.
    repeat break_or_reg; congruence.
  Qed.

  Definition peep_test_then_lea_proofs : rewrite_proofs :=
    {|
      defs := peep_test_then_lea_defs
      ; selr := peep_test_then_lea_selr
    |}.

  Definition peep_test_then_lea :
    concrete = fnd peep_test_then_lea_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite peep_test_then_lea_defs peep_test_then_lea_proofs.
  Qed.

End TEST_THEN_LEA.

Definition peep_test_then_lea_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_test_then_lea p.
  unfold peep_test_then_lea_defs in p.
  simpl in p.
  specialize (p c).
  do 3 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat peep_test_then_lea_example.
  set_instr_eq i0 1%nat peep_test_then_lea_example.
  set_instr_eq i1 2%nat peep_test_then_lea_example.
  set_ireg_eq rd0 r1.
  set_ireg_eq r0 r2.
  set_ireg_eq r2 rd.
  set_ireg_neq r1 rd.
  set_addrmode_eq a (Addrmode (Some rd) None (inl neg_one)).
  specialize (p _ _ n eq_refl). exact (Some p).
Defined.

Definition test_then_lea (c : code) : list StepEquiv.rewrite :=
  collect (map peep_test_then_lea_rewrite (ParamSplit.matched_pat peep_test_then_lea_example c)).


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From PFPL Require Import PartialMap_Set.
From PFPL Require Import Definitions.
From PFPL Require Import Lemmas_Vars.
From PFPL Require Import Lemmas_Rename.
From PFPL Require Import Lemmas_Same_Structure.
From PFPL Require Import Lemmas_AlphaEquiv.
From PFPL Require Import Lemmas_Rename.
From PFPL Require Import Lemmas_FreshRename.
From PFPL Require Import Lemmas_Rename_FreshRename.
From PFPL Require Import Lemmas_FreshRename_AlphaEquiv.
From PFPL Require Import Lemmas_Subst.

Lemma rename_vs_subst : forall e e' x y z,
  (x =? y) = false ->
  (x =? z) = false ->
  free_vars e' y = false ->
  rename (subst' e' x e) y z = subst' e' x (rename e y z).
Proof.
  induction e; intros; simpl.
  - reflexivity.
  - reflexivity.
  - case_eq (x0 =? x); intro X0X.
    + apply Nat.eqb_eq in X0X. subst.
      rewrite Nat.eqb_sym. rewrite H.
      simpl. rewrite Nat.eqb_refl.
      symmetry.
      apply rename_non_existant_free. assumption.
    + simpl. case_eq (y =? x); intro YX.
      * apply Nat.eqb_eq in YX. subst.
        simpl. rewrite H0. reflexivity.
      * simpl. rewrite X0X. reflexivity.
  - f_equal.
    apply IHe1. assumption. assumption. assumption.
    apply IHe2. assumption. assumption. assumption.
  - f_equal.
    apply IHe1. assumption. assumption. assumption.
    apply IHe2. assumption. assumption. assumption.
  - f_equal.
    apply IHe1. assumption. assumption. assumption.
    apply IHe2. assumption. assumption. assumption.
  - f_equal.
    apply IHe. assumption. assumption. assumption.
  - case_eq (x0 =? x); intro X0X.
    + apply Nat.eqb_eq in X0X. subst.
      rewrite Nat.eqb_sym. rewrite H.
      simpl. rewrite Nat.eqb_refl.
      rewrite Nat.eqb_sym. rewrite H.
      f_equal.
      apply IHe1. assumption. assumption. assumption.
    + simpl. case_eq (y =? x); intro YX.
      * apply Nat.eqb_eq in YX. subst.
        simpl. rewrite H.
        f_equal.
        apply IHe1. assumption. assumption. assumption.
      * simpl. rewrite X0X. f_equal.
        apply IHe1. assumption. assumption. assumption.
        apply IHe2. assumption. assumption. assumption.
Qed.

Lemma subst'_vs_rename : forall e e' x x',
  all_vars e x' = false ->
  (subst' e' x e) = (subst' e' x' (rename e x x')).
Proof.
  induction e; intros e' z z' A; simpl.
  - reflexivity.
  - reflexivity.
  - destruct (z =? x); simpl.
    rewrite Nat.eqb_refl. reflexivity.
    simpl in A. unfold singletonSet in A.
    rewrite Nat.eqb_sym. destruct (x =? z').
    discriminate. reflexivity.
  - simpl in A. unfold unionSet in A.
    apply orb_false_iff in A. destruct A as [A A'].
    f_equal; [apply IHe1 | apply IHe2]; auto.
  - simpl in A. unfold unionSet in A.
    apply orb_false_iff in A. destruct A as [A A'].
    f_equal; [apply IHe1 | apply IHe2]; auto.
  - simpl in A. unfold unionSet in A.
    apply orb_false_iff in A. destruct A as [A A'].
    f_equal; [apply IHe1 | apply IHe2]; auto.
  - simpl in A. f_equal. apply IHe. auto.
  - simpl in A. unfold unionSet in A.
    apply orb_false_iff in A. destruct A as [A A'].
    unfold updateSet in A'.
    case_eq (x =? z'); intro XZ'; rewrite XZ' in A'.
    discriminate.
    case_eq (z =? x); intro ZX.
    + apply Nat.eqb_eq in ZX. subst z.
      simpl. rewrite Nat.eqb_sym. rewrite XZ'.
      f_equal. auto.
      apply subst_non_free_var.
      apply not_in_expr_not_free. auto.
    + simpl. rewrite Nat.eqb_sym. rewrite XZ'.
      f_equal. auto. apply IHe2. auto.
Qed.


Require Import Lia.
Require Import RelationClasses.

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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
Require Import Time.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.
Require Import Progress.
Require Import Behavior.

Require Import AMemory.
Require Import ALocal.
Require Import AThread.

Require Import APF.
Require Import PF.

Lemma promise_apromise
  :
    Memory.promise <9= AMemory.promise.
Proof.
  i. inv PR; econs; eauto.
Qed.

Lemma write_awrite
  :
    Memory.write <10= AMemory.write.
Proof.
  i. inv PR; econs; eauto.
  eapply promise_apromise; eauto.
Qed.

Lemma program_step_aprogram_step
  :
    Thread.program_step <4= AThread.program_step.
Proof.
  i. inv PR. inv LOCAL.
  - econs; eauto.
  - econs; eauto.
  - inv LOCAL0. econs; eauto. econs; eauto.
    econs; eauto. eapply write_awrite; eauto.
  - inv LOCAL2. econs; eauto. econs; eauto.
    econs; eauto. eapply write_awrite; eauto.
  - econs; eauto.
  - econs; eauto.
  - econs; eauto.
Qed.

Lemma thread_step_athread_step
  :
    Thread.step_allpf <4= AThread.step_allpf.
Proof.
  i. inv PR. inv STEP.
  - inv STEP0. inv LOCAL. econs; eauto. econs; eauto.
    econs; eauto. econs; eauto. eapply promise_apromise; eauto.
  - econs. econs 2. eapply program_step_aprogram_step; eauto.
Qed.

Lemma thread_steps_athread_steps lang
  :
    rtc (tau (@Thread.step_allpf lang)) <2= rtc (tau (@AThread.step_allpf lang)).
Proof.
  eapply rtc_implies. i. inv H. econs; eauto.
  eapply thread_step_athread_step; eauto.
Qed.

Lemma program_steps_aprogram_steps lang
  :
    rtc (tau (@Thread.program_step lang)) <2= rtc (tau (@AThread.program_step lang)).
Proof.
  eapply rtc_implies. i. inv H. econs; eauto.
  eapply program_step_aprogram_step; eauto.
Qed.

Lemma pfstep_apfstep:
  PFConfiguration.step <4= APFConfiguration.step.
Proof.
  ii. inv PR.
  eapply program_steps_aprogram_steps in STEPS.
  eapply program_step_aprogram_step in STEP.
  econs; eauto.
Qed.

Record shorter (mem_src mem_tgt: Memory.t): Prop :=
  shorter_intro
    {
      shorter_get: forall loc to from msg (GET: Memory.get loc to mem_tgt = Some (from, msg)),
        exists from', (<<GET: Memory.get loc to mem_src = Some (from', msg)>>);

      shorter_get_iff: forall loc to from' msg (GET: Memory.get loc to mem_src = Some (from', msg)),
          exists from msg, (<<GET: Memory.get loc to mem_tgt = Some (from, msg)>>) /\
                           (<<TS: Time.le from from'>>) /\
                           (<<ATTATCH:
                              forall (BLANK: Memory.get loc from' mem_src = None),
                                Time.lt from from'>>);
    }
.

Lemma shorter_write mem_src0 mem_tgt0 loc from to val released prom1 mem_tgt1 kind
      (WRITE: AMemory.write Memory.bot mem_tgt0 loc from to val released prom1 mem_tgt1 kind)
      (SHORT: shorter mem_src0 mem_tgt0)
  :
    exists from' mem_src1,
      (<<WRITE: Memory.write Memory.bot mem_src0 loc from' to val released prom1 mem_src1 kind>>) /\
      (<<SHORT: shorter mem_src1 mem_tgt1>>).
Proof.
  exploit APFConfiguration.write_no_promise; eauto. i. des. clarify.
  inv WRITE. inv PROMISE. exists (Time.middle from to).
  assert (WF: (<<MSG_WF: Message.wf (Message.full val released)>>) /\
              (<<TO: Time.lt from to>>) /\
              (<<DISJOINT: forall to2 from2 msg2
                                  (GET: Memory.get loc to2 mem_tgt0 = Some (from2, msg2)),
                  Interval.disjoint (from, to) (from2, to2)>>)).
  { inv MEM. inv ADD. splits; auto. } des.
  exploit (@Memory.add_exists mem_src0 loc (Time.middle from to) to (Message.full val released)).
  { ii. inv LHS. inv RHS. ss.
    eapply shorter_get_iff in GET2; eauto. des.
    eapply DISJOINT; eauto.
    - instantiate (1:=x). econs; ss. etrans.
      + eapply Time.middle_spec; eauto.
      + eauto.
    - econs; ss. eapply TimeFacts.le_lt_lt; eauto.
  }
  { eapply Time.middle_spec; eauto. }
  { ss. }
  intros [mem_src1 ADD].
  exploit (Memory.add_exists_le).
  { eapply Memory.bot_le. }
  { eapply ADD. } intros [prom0' ADDPROM].
  exploit Memory.remove_exists.
  { eapply Memory.add_get0. eapply ADDPROM. } intros [prom1 REMOVEPROM].

  exists mem_src1. split.
  - econs.
    + econs; eauto; i; clarify.
      dup GET. eapply shorter_get_iff in GET; eauto. des.
      dup GET1. eapply shorter_get in GET1; eauto. des. clarify.
      eapply DISJOINT; eauto.
      * instantiate (1:=to). econs; ss. refl.
      * econs; ss.
        { eapply ATTATCH; eauto.
          eapply Memory.add_get0 in ADD. des. clarify. }
        { eapply Memory.get_ts in GET. des; auto.
          - clarify. refl.
          - left. auto. }
    + exploit MemoryFacts.add_remove_eq; eauto. i. clarify.

  - econs.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits. eapply Memory.add_get0; eauto.
      * guardH o. dup GET. eapply shorter_get in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits.
        { eapply Memory.add_get0; eauto. }
        { left. eapply Time.middle_spec; eauto. }
        { i. eapply Time.middle_spec; eauto. }
      * guardH o. dup GET. eapply shorter_get_iff in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
        esplits; eauto.
        i. eapply ATTATCH. destruct (Memory.get loc0 from' mem_src0) eqn:GET3; auto.
        destruct p. eapply Memory.add_get1 in GET3; eauto. clarify.
Qed.

Lemma shorter_update mem_src0 mem_tgt0 loc from to val released prom1 mem_tgt1 kind
      (WRITE: AMemory.write Memory.bot mem_tgt0 loc from to val released prom1 mem_tgt1 kind)
      ts msg
      (READ: Memory.get loc from mem_tgt0 = Some (ts, msg))
      (SHORT: shorter mem_src0 mem_tgt0)
  :
    exists mem_src1,
      (<<WRITE: Memory.write Memory.bot mem_src0 loc from to val released prom1 mem_src1 kind>>) /\
      (<<SHORT: shorter mem_src1 mem_tgt1>>).
Proof.
  exploit APFConfiguration.write_no_promise; eauto. i. des. clarify.
  inv WRITE. inv PROMISE.
  assert (WF: (<<MSG_WF: Message.wf (Message.full val released)>>) /\
              (<<TO: Time.lt from to>>) /\
              (<<DISJOINT: forall to2 from2 msg2
                                  (GET: Memory.get loc to2 mem_tgt0 = Some (from2, msg2)),
                  Interval.disjoint (from, to) (from2, to2)>>)).
  { inv MEM. inv ADD. splits; auto. } des.
  exploit (@Memory.add_exists mem_src0 loc from to (Message.full val released)).
  { ii. inv LHS. inv RHS. ss.
    eapply shorter_get_iff in GET2; eauto. des.
    eapply DISJOINT; eauto.
    - instantiate (1:=x). econs; ss.
    - econs; ss. eapply TimeFacts.le_lt_lt; eauto.
  }
  { ss. }
  { ss. }
  intros [mem_src1 ADD].
  exploit (Memory.add_exists_le).
  { eapply Memory.bot_le. }
  { eapply ADD. } intros [prom0' ADDPROM].
  exploit Memory.remove_exists.
  { eapply Memory.add_get0. eapply ADDPROM. } intros [prom1 REMOVEPROM].

  exists mem_src1. split.
  - econs.
    + econs; eauto; i; clarify.
      dup GET. eapply shorter_get_iff in GET; eauto. des.
      dup GET1. eapply shorter_get in GET1; eauto. des. clarify.
      eapply DISJOINT; eauto.
      * instantiate (1:=to). econs; ss. refl.
      * econs; ss.
        { eapply ATTATCH; eauto.
          eapply Memory.add_get0 in ADD. des. clarify. }
        { eapply Memory.get_ts in GET. des; auto.
          - clarify. refl.
          - left. auto. }
    + exploit MemoryFacts.add_remove_eq; eauto. i. clarify.
  - econs.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits. eapply Memory.add_get0; eauto.
      * guardH o. dup GET. eapply shorter_get in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
    + i. dup GET. erewrite Memory.add_o in GET; eauto. des_ifs.
      * ss. des. clarify. esplits.
        { eapply Memory.add_get0; eauto. }
        { refl. }
        { i. eapply shorter_get in READ; eauto. des.
          eapply Memory.add_get1 in GET; eauto. clarify. }
      * guardH o. dup GET. eapply shorter_get_iff in GET; cycle 1; eauto. des.
        eapply Memory.add_get1 in GET2; eauto.
        esplits; eauto.
        i. eapply ATTATCH. destruct (Memory.get loc0 from' mem_src0) eqn:GET3; auto.
        destruct p. eapply Memory.add_get1 in GET3; eauto. clarify.
Qed.

Lemma shorter_program_step lang th_src th_tgt th_tgt' st st' v v' prom' sc sc'
      mem_tgt mem_tgt' mem_src e_tgt
      (STEP: AThread.program_step e_tgt th_tgt th_tgt')
      (SHORT: shorter mem_src mem_tgt)
      (TH_SRC: th_src = Thread.mk lang st (Local.mk v Memory.bot) sc mem_src)
      (TH_TGT0: th_tgt = Thread.mk lang st (Local.mk v Memory.bot) sc mem_tgt)
      (TH_TGT1: th_tgt' = Thread.mk lang st' (Local.mk v' prom') sc' mem_tgt')
  :
    exists mem_src' e_src,
      (<<STEP: Thread.program_step
                 e_src th_src
                 (Thread.mk lang st' (Local.mk v' prom') sc' mem_src')>>) /\
      (<<SHORT: shorter mem_src' mem_tgt'>>) /\
      (<<EVENT: ThreadEvent.get_machine_event e_tgt = ThreadEvent.get_machine_event e_src>>)
.
Proof.
  inv STEP. clarify. inv LOCAL.
  - esplits; eauto. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto. econs; eauto.
    eapply shorter_get in GET; eauto. des. econs; eauto.
  - inv LOCAL0. ss. clarify.
    exploit shorter_write; eauto. i. des. exists mem_src1.
    esplits; eauto.
    + econs; eauto; ss.
    + ss.
  - inv LOCAL1. inv LOCAL2. clarify.
    dup GET. eapply shorter_get in GET; eauto. des.
    exploit shorter_update; eauto. i. des. exists mem_src1.
    esplits; eauto. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto.
  - esplits; eauto. inv LOCAL0. ss. clarify. econs; eauto.
Qed.

Lemma shorter_program_steps lang th_src th_tgt th_tgt' st st' v v' prom' sc sc'
      mem_tgt mem_tgt' mem_src
      (STEPS: rtc (tau (@AThread.program_step lang)) th_tgt th_tgt')
      (SHORT: shorter mem_src mem_tgt)
      (TH_SRC: th_src = Thread.mk lang st (Local.mk v Memory.bot) sc mem_src)
      (TH_TGT0: th_tgt = Thread.mk lang st (Local.mk v Memory.bot) sc mem_tgt)
      (TH_TGT1: th_tgt' = Thread.mk lang st' (Local.mk v' prom') sc' mem_tgt')
  :
    exists mem_src',
      (<<STEPS: rtc (tau (@Thread.program_step lang))
                    th_src
                    (Thread.mk lang st' (Local.mk v' prom') sc' mem_src')>>) /\
      (<<SHORT: shorter mem_src' mem_tgt'>>)
.
Proof.
  ginduction STEPS.
  - i. clarify. esplits; eauto.
  - i. clarify. inv H. destruct y. destruct local.
    exploit shorter_program_step; eauto. i. des.
    exploit PFConfiguration.program_step_no_promise; eauto. i. ss. clarify.
    exploit IHSTEPS; eauto. i. des. esplits; eauto.
    econs; eauto. econs; eauto. rewrite <- EVENT. auto.
Qed.

Inductive sim_apf_pf: Configuration.t -> Configuration.t -> Prop :=
| sim_apf_pf_intro
    c_src c_tgt
    ths sc mem_src mem_tgt
    (SRC: c_src = Configuration.mk ths sc mem_src)
    (TGT: c_tgt = Configuration.mk ths sc mem_tgt)
    (PROMISESRC: ~ Configuration.has_promise c_src)
    (PROMISETGT: ~ Configuration.has_promise c_tgt)
    (MEMORY: shorter mem_src mem_tgt)
  :
    sim_apf_pf c_src c_tgt
.

Lemma sim_apf_pf_step c_tgt0 c_tgt1 c_src0 tid e
      (SIM: sim_apf_pf c_src0 c_tgt0)
      (STEP: APFConfiguration.step tid e c_tgt0 c_tgt1)
  :
    exists c_src1,
      (<<STEP: PFConfiguration.step tid e c_src0 c_src1>>) /\
      (<<SIM: sim_apf_pf c_src1 c_tgt1>>).
Proof.
  inv SIM. dup STEP. inv STEP. ss. destruct e2. destruct lc1, local, lc3.
  exploit APFConfiguration.no_promise_spec; eauto. i. ss. clarify.
  exploit shorter_program_steps; eauto. i. des.
  exploit APFConfiguration.program_steps_no_promise; eauto. i. ss. clarify.
  exploit shorter_program_step; eauto. i. des.
  assert (STEPSRC: PFConfiguration.step
                     (ThreadEvent.get_machine_event e_src) e
                     (Configuration.mk ths sc mem_src)
                     (Configuration.mk (IdentMap.add e (existT _ lang st3, Local.mk tview1 promises1) ths) sc3 mem_src'0)).
  { econs; eauto. }
  rewrite EVENT. esplits; eauto. econs; eauto.
  - eapply PFConfiguration.configuration_step_no_promise in STEPSRC; eauto.
  - eapply APFConfiguration.configuration_step_no_promise in STEP0; eauto.
Qed.

Lemma sim_apf_pf_init s
  :
    sim_apf_pf (Configuration.init s) (Configuration.init s).
Proof.
  econs; ss.
  - ii. inv H. ss. unfold Threads.init in FIND.
    erewrite IdentMap.Properties.F.map_o in *.
    unfold option_map, Local.init in *. des_ifs. ss. erewrite Memory.bot_get in GET. clarify.
  - ii. inv H. ss. unfold Threads.init in FIND.
    erewrite IdentMap.Properties.F.map_o in *.
    unfold option_map, Local.init in *. des_ifs. ss. erewrite Memory.bot_get in GET. clarify.
  - econs; i.
    + unfold Memory.init, Memory.get in *. erewrite Cell.init_get in *.
      des_ifs. esplits; eauto.
    + unfold Memory.init, Memory.get in *. erewrite Cell.init_get in *.
      des_ifs. esplits; eauto.
      * refl.
      * i. erewrite Cell.init_get in *. des_ifs.
Qed.

Lemma sim_apf_pf_terminal c_src c_tgt
      (SIM: sim_apf_pf c_src c_tgt)
      (TERMINAL: Configuration.is_terminal c_tgt)
  :
    Configuration.is_terminal c_src.
Proof.
  inv SIM. ii. eauto.
Qed.

Lemma sim_apf_pf_adequacy c_src c_tgt
      (SIM: sim_apf_pf c_src c_tgt)
  :
    behaviors APFConfiguration.step c_tgt <1=
    behaviors PFConfiguration.step c_src.
Proof.
  i. ginduction PR; i.
  - econs 1. eapply sim_apf_pf_terminal; eauto.
  - exploit sim_apf_pf_step; eauto. i. des. econs 2; eauto.
  - exploit sim_apf_pf_step; eauto. i. des. econs 3; eauto.
  - exploit sim_apf_pf_step; eauto. i. des. econs 4; eauto.
Qed.

Theorem apf_pf_equiv s
  :
    behaviors APFConfiguration.step (Configuration.init s) <1=
    behaviors PFConfiguration.step (Configuration.init s).
Proof.
  eapply sim_apf_pf_adequacy.
  eapply sim_apf_pf_init; auto.
Qed.

Theorem apf_pf_equiv2 c
  :
    behaviors PFConfiguration.step c <1=
    behaviors APFConfiguration.step c.
Proof.
  eapply le_step_behavior_improve; eauto.
  i. eapply pfstep_apfstep; eauto.
Qed.


From iris.program_logic Require Import language ectxi_language ectx_language lifting.
From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From st.STLCmuST Require Import lang.

Section wkpre_lemmas.

  Context `{Σ : !gFunctors}.
  Context `{irisGS_inst : !irisGS STLCmuST_lang Σ}.

  Lemma wp_bind' (K : list ectx_item) s E e Φ :
    WP e @ s; E {{ v, WP fill K (of_val v) @ s; E {{ Φ }} }} ⊢ WP fill K e @ s; E {{ Φ }}.
  Proof. iApply wp_bind. Qed.

  Lemma wp_pure_step_later {s : stuckness} {E : coPset} e1 e2 Φ (H : pure_step e1 e2) :
    ▷ WP e2 @ s ; E {{Φ}} ⊢ WP e1 @ s ; E {{Φ}}.
  Proof. iIntros "He2". iApply (wp_pure_step_later _ _ _ _ True 1). intros t. by apply nsteps_once. auto. auto. Qed.

End wkpre_lemmas.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
(*Require Import depoolContract.Lib.CommonCommon.*)
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

Require Export depoolContract.Scenarios.Projections.Round_Steps.States.
Require Export depoolContract.Scenarios.Common.RotateRoundsCondition.
Require Export depoolContract.Scenarios.Common.RoundDefinitions.
Require Export depoolContract.Scenarios.Common.unfreezeCondition.

Section Round_Steps_conditions.

Variable ticktockCalled : Prop.
Variable constructorCalled : Prop.
Variable terminatorCalled : Prop.
Variable onSuccessToRecoverStakeCalled : Prop.
Variable onFailToRecoverStakeCalled : Prop.
Variable onStakeRejectCalled : Prop.
Variable onStakeAcceptCalled : Prop.
Variable participateInElectionsCalled : Prop.
Variable completeRoundWithChunkCalled : Prop.
Variable queryId elector stakeAt chunkSize : Z.
Variable bounceExternal : Prop.
Variable functionId process_new_stakeId recover_stakeId decodedRoundId : Z.

Definition generateRoundCalled (l : Ledger) :=
    constructorCalled \/ rotate_round_conditions_full l ticktockCalled.

Definition projection_round_steps_constructor_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    generateRoundCalled l.

Definition projection_round_steps_constructor_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_PrePooling.

Definition projection_round_steps_constructor_fake0_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
        constructorCalled.

Definition projection_round_steps_constructor_fake0_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_fake0_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Pooling.

Definition projection_round_steps_constructor_fake1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
        constructorCalled.

Definition projection_round_steps_constructor_fake1_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_fake1_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_constructor_fake2_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
        constructorCalled.

Definition projection_round_steps_constructor_fake2_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    roundIn nl nr /\
    ~ roundIn ol nr /\
    projection_round_steps_constructor_fake2_condition ol or /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_prepool_completing_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_PrePooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 < RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_prepool_completing_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_prepool_completing_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_prepool_completed_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_PrePooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 = RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_prepool_completed_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_prepool_completed_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_prepool_pooling_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = roundPre0 l /\
    poolClosed l = false /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_PrePooling.

Definition projection_round_steps_prepool_pooling_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
        projection_round_steps_prepool_pooling_condition ol or /\
        roundIn nl nr /\
        getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Pooling.

Definition projection_round_steps_pooling_completing_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 < RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_pooling_completing_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_completing_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_pooling_completed_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = roundPre0 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    ownerOrSelfCall l /\
    poolClosed l = false /\
    0 = RoundsBase_ι_Round_ι_participantQty r.

Definition projection_round_steps_pooling_completed_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_completed_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_pooling_waiting_unfreeze_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round0 l /\
    poolClosed l = false /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    stakeSum (validatorStake l r) < m_validatorAssurance l.

Definition projection_round_steps_pooling_waiting_unfreeze_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_waiting_unfreeze_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_pooling_waiting_validator_request_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round0 l /\
    poolClosed l = false /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Pooling /\
    m_validatorAssurance l <= stakeSum (validatorStake l r).

Definition projection_round_steps_pooling_waiting_validator_request_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_pooling_waiting_validator_request_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_validator_request_completing1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    terminatorCalled /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest /\
    ownerOrSelfCall l /\
    poolClosed l = false.

Definition projection_round_steps_waiting_validator_request_completing1_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_request_completing1_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_validator_request_completing2_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_validator_request_completing2_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_request_completing2_condition ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_validator_request_waiting_if_stake_accepted_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    participateInElectionsCalled /\
    onlyValidatorContract l /\
    poolClosed l = false /\
    checkDePoolBalance l (msgValue l) (balance l) /\
    stakeAt = RoundsBase_ι_Round_ι_supposedElectedAt r /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_validator_request_waiting_if_stake_accepted_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_request_waiting_if_stake_accepted_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request0_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    bounceExternal /\
    functionId = process_new_stakeId /\
    RoundsBase_ι_Round_ι_id r = decodedRoundId /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request0_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_stake_accepted_waiting_validator_request0_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    onStakeRejectCalled /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    r = round1 l /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_request1_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_stake_accepted_waiting_validator_request1_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidatorRequest.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_start_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    onStakeAcceptCalled /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    r = round1 l /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfStakeAccepted.

Definition projection_round_steps_waiting_if_stake_accepted_waiting_validator_start_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_stake_accepted_waiting_validator_start_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_reward1_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> currentValidator l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> prevValidator l /\
    validationStart l + RoundsBase_ι_Round_ι_stakeHeldFor r + ELECTOR_UNFREEZE_LAG l <= now l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_reward1_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_start_waiting_reward1_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_validator_start_waiting_reward2_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> currentValidator l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r <> prevValidator l /\
    validationStart l + RoundsBase_ι_Round_ι_stakeHeldFor r + ELECTOR_UNFREEZE_LAG l <= now l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_reward2_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_start_waiting_reward2_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_validator_start_waiting_if_validator_win_elections_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round1 l /\
    RoundsBase_ι_Round_ι_vsetHashInElectionPhase r = prevValidator l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_validator_start_waiting_if_validator_win_elections_move
    (ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_validator_start_waiting_if_validator_win_elections_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_validator_start_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    bounceExternal /\
    functionId = recover_stakeId /\
    RoundsBase_ι_Round_ι_id r = decodedRoundId /\
    r = round1 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_validator_start_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_validator_win_elections_waiting_validator_start_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingValidationStart.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_unfreeze_condition
(l : Ledger) (r : RoundsBase_ι_Round) :=
    (onSuccessToRecoverStakeCalled \/ onFailToRecoverStakeCalled) /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    roundIn l r /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections.

Definition projection_round_steps_waiting_if_validator_win_elections_waiting_unfreeze_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_if_validator_win_elections_waiting_unfreeze_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_condition1
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r = RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_move1
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_waiting_reward_condition1
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_condition2
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r = RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_waiting_reward_move2
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_waiting_reward_condition2
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_unfreeze_completing_condition1
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 < RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completing_move1
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completing_condition1
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_unfreeze_completing_condition2
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 < RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completing_move2
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completing_condition2
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_waiting_unfreeze_completed_condition1
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    rotate_round_conditions_full l ticktockCalled /\
    r = round1 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 = RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completed_move1
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completed_condition1
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_waiting_unfreeze_completed_condition2
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    updateRoundsCalled l ticktockCalled /\
    r = round2 l /\
    shouldBeUnfrozen l r /\
    RoundsBase_ι_Round_ι_completionReason r <> RoundsBase_ι_CompletionReasonP_ι_Undefined /\
    0 = RoundsBase_ι_Round_ι_participantQty r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_unfreeze_completed_move2
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_unfreeze_completed_condition2
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

Definition projection_round_steps_waiting_rewards_waiting_unfreeze_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    bounceExternal /\
    functionId = recover_stakeId /\
    RoundsBase_ι_Round_ι_id r = decodedRoundId /\
    r = round2 l /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_rewards_waiting_unfreeze_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_rewards_waiting_unfreeze_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze.

Definition projection_round_steps_waiting_rewards_completing_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    (onSuccessToRecoverStakeCalled \/ onFailToRecoverStakeCalled) /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    roundIn l r /\
    msgSender l = RoundsBase_ι_Round_ι_proxy r /\
    elector = RoundsBase_ι_Round_ι_elector r /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_WaitingReward.

Definition projection_round_steps_waiting_rewards_completing_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_waiting_rewards_completing_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_completing_completed_condition
    (l : Ledger) (r : RoundsBase_ι_Round) :=
    completeRoundWithChunkCalled /\
    selfCall l /\
    RoundsBase_ι_Round_ι_id r = queryId /\
    r = round2 l /\
    Z.of_nat (length (RoundsBase_ι_Round_ι_stakes r)) <= chunkSize /\
    getProjectionRoundStepState r = RoundsBase_ι_RoundStepP_ι_Completing.

Definition projection_round_steps_completing_completed_move
(ol nl : Ledger) (or nr : RoundsBase_ι_Round) :=
    projection_round_steps_completing_completed_condition
        ol or /\
    roundIn nl nr /\
    getProjectionRoundStepState nr = RoundsBase_ι_RoundStepP_ι_Completed.

End Round_Steps_conditions.


Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.BasicFacts.
Require Import UFO.Rel.Monotone.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Require Import UFO.Lang.Sig.
Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Static.
Require Import UFO.Lang.StaticFacts.
Set Implicit Arguments.

Section section_ccompat_tm_op.

Context (EV LV : Set).
Context (Ξ : XEnv EV LV).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (N : it ∅ EV LV ∅ 𝕄) (E : eff ∅ EV LV ∅) (ℓ : lbl LV ∅).

Lemma ccompat_tm_op n ξ₁ ξ₂ t₁ t₂ :
n ⊨ 𝓣⟦ Ξ ⊢ (ty_it N ℓ) # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ →
n ⊨ 𝓣⟦ Ξ ⊢ (ty_ms (it_msig N) ℓ) # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (tm_op t₁) (tm_op t₂).
Proof.
intro H.
change (tm_op t₁) with (ktx_plug (ktx_op ktx_hole) t₁).
change (tm_op t₂) with (ktx_plug (ktx_op ktx_hole) t₂).
eapply plug0 with (Ta := ty_it N ℓ).
+ intro ; simpl ; auto.
+ intro ; simpl ; auto.
+ iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
  iintro v₁ ; iintro v₂ ; iintro Hv.
  simpl ktx_plug.
  simpl 𝓥_Fun in Hv.
  idestruct Hv as m₁ Hv ; idestruct Hv as m₂ Hv.
  idestruct Hv as X₁ Hv ; idestruct Hv as X₂ Hv.
  idestruct Hv as Hv Hm ; idestruct Hm as HX Hm.
  ielim_prop Hv ; destruct Hv ; subst v₁ v₂.

  eapply 𝓣_step_r.
  { apply step_op. }
  eapply 𝓣_step_l.
  { apply step_op. }
  later_shift.

  apply 𝓥_unroll in Hm.
  apply 𝓥_in_𝓣.
  apply Hm.
+ apply postfix_refl.
+ apply postfix_refl.
+ apply H.
Qed.

End section_ccompat_tm_op.

Section section_compat_tm_op.
Context (n : nat).
Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (N : it ∅ EV LV ∅ 𝕄) (E : eff ∅ EV LV ∅) (ℓ : lbl LV ∅).

Lemma compat_tm_op t₁ t₂ :
n ⊨ ⟦ Ξ Γ ⊢ t₁ ≼ˡᵒᵍ t₂ : (ty_it N ℓ) # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (tm_op t₁) ≼ˡᵒᵍ (tm_op t₂) : (ty_ms (it_msig N) ℓ) # E ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
simpl subst_tm.
apply ccompat_tm_op.
iespecialize Ht.
ispecialize Ht ; [ eassumption | ].
ispecialize Ht ; [ eassumption | ].
ispecialize Ht ; [ eassumption | ].
ispecialize Ht ; [ eassumption | ].
apply Ht.
Qed.

Lemma compat_ktx_op T' E' K₁ K₂ :
n ⊨ ⟦ Ξ Γ ⊢ K₁ ≼ˡᵒᵍ K₂ : T' # E' ⇢ (ty_it N ℓ) # E ⟧ →
n ⊨ ⟦ Ξ Γ ⊢ (ktx_op K₁) ≼ˡᵒᵍ (ktx_op K₂) : T' # E' ⇢ (ty_ms (it_msig N) ℓ) # E⟧.
Proof.
intro HK.
iintro ξ₁ ; iintro ξ₂ ;
iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ;
iintro γ₁ ; iintro γ₂.
iintro Hξ ; iintro Hδ ; iintro Hρ ; iintro Hγ.
iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
iintro t₁ ; iintro t₂ ; iintro Ht.
iespecialize HK.
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ispecialize HK ; [ eassumption | ].
ielim_vars HK ; [ | eassumption | eassumption ].
iespecialize HK.
ispecialize HK ; [ eassumption | ].
simpl ktx_plug.
apply ccompat_tm_op.
apply HK.
Qed.

End section_compat_tm_op.


Set Universe Polymorphism.
Module Foo.
  Definition T : sigT (fun x => x).
  Proof.
    exists Set.
    abstract exact nat.
  Defined.
End Foo.
Module Bar.
  Include Foo.
End Bar.
Definition foo := eq_refl : Foo.T = Bar.T.