(* Interprteting the Intermediate Representation *)

Require Import common.
Require Import Integers.
Require Import Events.
Require Import IR.
Require Import monad.
Require Import primitives.
Require Import Errors.

Definition eval_reg (r:reg) (rm:reg_map) : res int :=
  try_op (PTree.get r rm) "Unassigned register".

Definition int_of_bool (b:bool) : int :=
  if b then Int.one else Int.zero.

(* matches the semantics of the Omod operation *)
Definition eval_mod (n1 n2:int) : res int :=
  if Int.eq n2 Int.zero || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone
  then Error ((MSG "Undefined Modulo")::nil)
  else OK (Int.mods n1 n2).

Definition eval_expr (e:expr) (rm:reg_map): res int :=
  match e with
  | BIN b o1 o2 =>
    do v1 <- eval_reg o1 rm;
      do v2 <- eval_reg o2 rm;
      match b with
      | bplus => OK (Int.add v1 v2)
      | bneg => OK (Int.sub v1 v2)
      | bmul => OK (Int.mul v1 v2)
      | beq => OK (int_of_bool (Int.eq v1 v2))
      | blt => OK (int_of_bool (Int.lt v1 v2))
      | bmod => eval_mod v1 v2
      end
  | UNA u o1 =>
    do v <- eval_reg o1 rm;
      match u with
      | uneg => OK (Int.neg v)
      | ueqzero => OK (int_of_bool (Int.eq v Int.zero))
      | uplus i => OK (Int.add v i)
      | umul i => OK (Int.mul v i)
      | ueq i => OK (int_of_bool (Int.eq v i))
      end
  | ZAR z =>
    match z with
    | zconst i => OK i
    end
  end.

Fixpoint eval_list_reg (lr:list reg) (rm:reg_map): res (list int) :=
  match lr with
  | nil => OK nil
  | r::lr' => do v <- eval_reg r rm;
              do lv <- eval_list_reg lr' rm;
              OK (v::lv)
  end.

(* Might be deprecated since the Call expects a reg list, not an expr list *)
Fixpoint eval_list (le:list expr) (rm:reg_map): res (list int) :=
  match le with
  | nil => OK nil
  | ex::le' => do v <- eval_expr ex rm;
                 do lv <- eval_list le' rm;
                 OK (v::lv)
  end.

Fixpoint init_regs (valist:list int) (params:list reg): res reg_map :=
  match valist with
  | nil => match params with
           | nil => OK empty_regmap
           | _ => Error ((MSG "Not enough arguments")::nil)
           end
  | val::valist' => match params with
                   | nil => Error ((MSG "Too many arguments")::nil)
                   | par::params' => do rm' <- init_regs valist' params';
                                       OK (rm' # par <- val)
                    end
  end.

Definition bool_of_int (i:int) : bool :=
  match (Int.intval i) with
  | 0 => false
  | _ => true
  end.

(* Creating a new Register Mapping from a Varmap *)
Fixpoint update_regmap (vm:varmap) (rm:reg_map): res reg_map :=
  match vm with
  | nil => OK empty_regmap
  | (r,e)::vm' =>
    do v <- eval_expr e rm;
      do rm' <- update_regmap vm' rm;
      OK (rm' # r <- v)
  end.

Definition ir_int_step (is:ir_state) : free (trace * itret checkpoint ir_state) :=
  match is with
    (v, pc, rm) =>
    do i <<- try_option ((ver_code v) # pc) "No instruction to execute";
      match i with
      | Nop next =>
        fret (E0, Halt (v, next, rm))

      | IPrint e next =>
        do res <<- fret' (eval_expr e rm);
          fret (print_event res, Halt (v, next, rm))

      | Op r ex next =>
        do res <<- fret' (eval_expr ex rm);
          fret (E0, Halt (v, next, rm # r <- res))

      | Cond r tr fl =>
        do guard <<- fret' (eval_reg r rm);
          match (bool_of_int guard) with
          | true => fret (E0, Halt (v, tr, rm))
          | false => fret (E0, Halt (v, fl, rm))
          end

      | Call fid args retreg next =>
        do _ <<- fprim(Prim_PushIRSF (retreg, v, next, rm));
          do argvals <<- fret' (eval_list_reg args rm);
          fret (E0, Done (C_Call (ir_call fid argvals)))

      | Return ex =>
        do retval <<- fret' (eval_expr ex rm);
          fret (E0, Done (C_Return (ir_ret retval)))

      | MemSet adreg valreg next =>
        do ad <<- fret' (eval_reg adreg rm);
          do val <<- fret' (eval_reg valreg rm);
          do _ <<- fprim(Prim_MemSet ad val);
          fret (E0, Halt (v, next, rm))

      | MemGet dstreg adreg next =>
        do ad <<- fret' (eval_reg adreg rm);
          do res <<- fprim(Prim_MemGet ad);
          fret (E0, Halt (v, next, rm # dstreg <- res))

      | Assume guard (ftgt, ltgt) vm next =>
        do guard <<- fret' (eval_expr guard rm);
          match (bool_of_int guard) with
          | true => fret (E0, Halt (v, next, rm)) (* we pass the test, going to next label *)
          | false =>
            do newrm <<- fret' (update_regmap vm rm);
              fret (E0, Done (C_Deopt (ir_deopt ftgt ltgt newrm)))
          end
      | Anchor (ftgt, ltgt) vm next =>
          (* Anchors are just used temporary by the middle-end but should never be executed by the JIT *)
          ferror ((MSG "Anchor should not be executed")::nil)
      end
  end.

Definition ir_step (is:ir_state) : free (trace * synchro_state) :=
  do (t,r) <<- ir_int_step is;
    fret (t,
        match r with
        | Halt is => Halt_IR is
        | Done cp => synchro_of cp
        end).

(* A fueled loop *)
(* deprecated. we only take single steps (fuel=1) in our JIT now to make the proof easier *)
Fixpoint ir_int_loop (is:ir_state) (fuel:nat) : free (trace * synchro_state) :=
  match fuel with
  | O => fret (E0, Halt_IR is)
  | Datatypes.S f =>
    do (t1, synchro) <<- ir_step is;
      match synchro with
      | Halt_IR is' => do (t2, is'') <<- ir_int_loop is' f;
                     fret (t1 ++ t2, is'')
      | S_Call _ => fret (t1, synchro)
      | S_Return _ => fret (t1, synchro)
      | S_Deopt _ => fret (t1, synchro)
      | EOE _ => fret (t1, synchro)
      | Halt_ASM _ _ => ferror (Errors.MSG "Unexpected ASM state"::nil)
      | Halt_RTL _ _ => ferror (Errors.MSG "Unexpected RTL state"::nil)
      | Halt_Block _ => ferror (Errors.MSG "Unexpected RTLblock state"::nil)
      end
  end.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2004                                *)
(*                              LaBRI                                   *)
(************************************************************************)
Set Implicit Arguments.
Require Export struct_ex.
Require Export derivedRulesNatDed.

Section cross_dep.

Variables  I (* composition modes *)
           J (* unary modes *)
           A (* atomic formulaes*)
           W (* set of terminals: words *)
           : Set.

 Variables (eqdecI :eqdec I)
           (eqdecJ :eqdec J)
           (eqdecA :eqdec A)
           (eqdecW :eqdec W).
 Variable R : extension I J.

Fixpoint distDiam (i0:I)(j0:J)(ct:context I J A W){struct ct}:context I J A W :=
match ct with
|Comma i t1 t2=> match (eqdecI i i0) with
                 |left _=> Comma i (distDiam i0 j0 t1) (distDiam i0 j0 t2)
                 |right _ => (TDiamond j0 ct)
               end
|others =>  (TDiamond j0 ct)
end.

Fixpoint transformCont (ct:context I J A W)(i0 i1:I)(j0 j1:J){struct ct}:context I J A W:=
match ct with
 |Comma i t1 t2 =>match (eqdecI i i1) with
                 |left _=> (Comma i t1 (transformCont t2 i0 i1 j0 j1))
                 |right _ =>match (eqdecI i i0)with
                            |left _ => (Comma i (distDiam i0 j0 t1) (distDiam i0 j0 t2))
                            |right _ => (TDiamond j1 ct)

                             end
                end
| res _ _=> (TDiamond j0 ct)
|others => (TDiamond j1 ct)
end.

Definition repDistribute:forall(i0:I)(j0 :J)(Gamma:context I J A W) ,
               in_extension (KDiam i0 j0) R ->
               replaceNTimesExt eqdecI eqdecJ R (TDiamond j0 Gamma) (distDiam i0 j0 Gamma).
 intros.
 elim Gamma; intros.
 constructor 1.
 simpl in |- *.
 case (eqdecI i i0).
 intro; subst.
 eapply replNPermut.
 eexact H.
 eapply replExtMono;eauto.
 econstructor.
 constructor 1.
 apply KDiam_rw.
 constructor.
 intro.
 constructor 1.
 simpl in |- *.
 constructor.
Defined.

Definition repTransform:forall(i0 i1:I)(j0 j1:J)(Gamma:context I J A W) ,
              in_extension (K2Diam i1 j1) R ->
              in_extension (incDiam I j1 j0) R ->
              in_extension (KDiam i0 j0) R ->
              replaceNTimesExt eqdecI eqdecJ R (TDiamond j1 Gamma) (transformCont Gamma i0 i1 j0 j1).

 intros.
 elim Gamma; intros.
 econstructor 2.
 eexact H0.
 constructor 1.
 econstructor 2.
 constructor 1.
 apply incDiam_rw.
 constructor.
 simpl in |- *.
 case (eqdecI i i1).
 intros.
 subst.
 eapply replNPermut.
 eexact H.
 eapply replaceExtMonoLeft.
 eauto.
 econstructor.
 constructor.
 apply K2Diam_rw.
 constructor.
 intro.
 case (eqdecI i i0).
 intro.
 subst.
 assert (distDiam i0 j0 (Comma i0 c c0)=Comma i0 (distDiam i0 j0 c) (distDiam i0 j0 c0)).
 simpl.
 case (eqdecI i0 i0).
 auto.
 intro H4; elim H4.
 auto.
 rewrite <- H4.
 eapply replNPermut.
 eexact H0.
 eapply repDistribute.
 auto.
 econstructor.
 constructor.
 apply incDiam_rw.
 constructor.
 intro.
 constructor 1.
 simpl.
 constructor 1.
Defined.

Definition cross_depend:forall (i0 i1:I)(j0 j1:J)(B:Form I J A)(Gamma:context I J A W),
                          in_extension (K2Diam i1 j1) R ->
                          in_extension (incDiam I j1 j0) R ->
                          in_extension (KDiam i0 j0) R ->
                          natded eqdecI eqdecJ R (transformCont Gamma i0 i1 j0 j1) B ->
                          natded eqdecI eqdecJ R (TDiamond j1 Gamma) B.
intros.
eapply repExtnatDed.
apply repTransform;eauto.
auto.
Defined.

End cross_dep.


(** Quite complicated, I will come back to it later *)
Set Implicit Arguments.

Module Trace.
  Inductive t (A : Type) : Type :=
  | one : A -> t A
  | next : A -> t A -> t A.

  Definition head A (tr : t A) : A :=
    match tr with
    | one s => s
    | next s _ => s
    end.

  Fixpoint append A (tr1 : list A) (tr2 : t A) : t A :=
    match tr1 with
    | nil => tr2
    | cons s tr1 => next s (append tr1 tr2)
    end.
End Trace.

Infix "::" := Trace.next.
Infix "++" := Trace.append.

Module Spec.
  Definition t S A := Trace.t S -> A -> Prop.

  Definition true S A : t S A := fun _ _ => True.
End Spec.

Module M.
  Inductive t (S : Type) (A : Type) (P : Spec.t S A) (tr : Trace.t S) : Type :=
  | new :
    ((exists tr' x, P (tr' ++ tr) x) ->
      {s : S & (({x : A | P (s :: tr) x} + (forall tr', t P (tr' ++ s :: tr))) % type)})
    -> t P tr.

  Definition open S A (P : Spec.t S A) tr (x : t P tr) :=
    match x with
    | new _ x => x
    end.
End M.

Definition bind (S A B : Type) (Px : Spec.t S A) (Pf : Spec.t S B)
  (x : forall tr, M.t Px tr) (f : A -> forall tr, M.t Pf tr) : forall (tr : Trace.t S), M.t (Spec.true (A := B)) tr.
    refine (fun tr =>
      M.new tr (fun pre =>
        match M.open (x tr) pre with
        | existT _ s (inl (exist _ x post)) => existT _ s (inr (fun tr' => M.open (f x _) _))
        | existT _ s (inr x) => _
        end)).


Require Import VST.floyd.proofauto.
Require Import VST.progs.even.
Instance CompSpecs : compspecs.
Proof. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Definition odd_spec :=
 DECLARE _odd
  WITH z : Z, b: unit
  PRE [ _n OF tuint]
    PROP(0 <= z <= Int.max_signed) LOCAL(temp _n (Vint (Int.repr z))) SEP()
  POST [ tint ]
    PROP() LOCAL(temp ret_temp (Vint (if Z.odd z then Int.one else Int.zero))) SEP().

Definition even_spec :=
 DECLARE _even
  WITH z : Z
  PRE [ _n OF tuint]
    PROP(0 <= z <= Int.max_signed) LOCAL(temp _n (Vint (Int.repr z))) SEP()
  POST [ tint ]
    PROP() LOCAL(temp ret_temp (Vint (if Z.even z then Int.one else Int.zero))) SEP().

Definition main_spec :=
 DECLARE _main
  WITH z : Z, v : val
  PRE [ ] PROP() LOCAL() SEP ()
  POST [ tint ]
    PROP() LOCAL(temp ret_temp (Vint (if Z.even 42 then Int.one else Int.zero))) SEP().


Require Import Bool.
Require Import RelationClasses.

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

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

From PromisingLib Require Import Event.

Set Implicit Arguments.

Global Program Instance option_rel_PreOrder A R `{@PreOrder A R}: PreOrder (option_rel R).
Next Obligation.
Proof.
  ii. destruct x; ss. refl.
Qed.
Next Obligation.
Proof.
  ii. destruct x, y, z; ss. etrans; eauto.
Qed.

Definition get_machine_event (e: ProgramEvent.t): MachineEvent.t :=
  match e with
  | ProgramEvent.syscall e => MachineEvent.syscall e
  | ProgramEvent.failure => MachineEvent.failure
  | _ => MachineEvent.silent
  end.

Definition is_atomic_event (e: ProgramEvent.t): bool :=
  match e with
  | ProgramEvent.silent | ProgramEvent.failure => false
  | ProgramEvent.syscall _ | ProgramEvent.fence _ _ => true
  | ProgramEvent.read _ _ ord => Ordering.le Ordering.plain ord
  | ProgramEvent.write _ _ ord => Ordering.le Ordering.plain ord
  | ProgramEvent.update _ _ _ ordr ordw =>
    Ordering.le Ordering.plain ordr && Ordering.le Ordering.plain ordw
  end.

Definition is_accessing (e: ProgramEvent.t): option (Loc.t * Const.t) :=
  match e with
  | ProgramEvent.silent | ProgramEvent.failure | ProgramEvent.syscall _ | ProgramEvent.fence _ _ => None
  | ProgramEvent.read l v _ | ProgramEvent.write l v _ | ProgramEvent.update l _ v _ _ => Some (l, v)
  end.

Definition is_updating (e: ProgramEvent.t): bool :=
  match e with
  | ProgramEvent.update _ _ _ _ _ => true
  | _ => false
  end.

Definition is_release (e: ProgramEvent.t): bool :=
  match e with
  | ProgramEvent.syscall _ => true
  | ProgramEvent.silent | ProgramEvent.failure | ProgramEvent.read _ _ _ => false
  | ProgramEvent.fence _ ord | ProgramEvent.write _ _ ord | ProgramEvent.update _ _ _ _ ord => Ordering.le Ordering.strong_relaxed ord
  end.

Definition is_acquire (e: ProgramEvent.t): bool :=
  match e with
  | ProgramEvent.syscall _ => true
  | ProgramEvent.silent | ProgramEvent.failure | ProgramEvent.write _ _ _ => false
  | ProgramEvent.read _ _ ord | ProgramEvent.update _ _ _ ord _ => Ordering.le Ordering.acqrel ord
  | ProgramEvent.fence ordr ordw => Ordering.le Ordering.seqcst ordw || Ordering.le Ordering.acqrel ordr
  end.

Definition is_syscall (e: ProgramEvent.t): bool :=
  match e with
  | ProgramEvent.syscall _ => true
  | _ => false
  end.

Module Perm.
  Variant t: Type :=
  | low
  | high
  .

  Definition meet (p0 p1: t): t :=
    match p0, p1 with
    | high, high => high
    | _, _ => low
    end.

  Definition join (p0 p1: t): t :=
    match p0, p1 with
    | low, low => low
    | _, _ => high
    end.

  Definition le (p0 p1: t): bool :=
    match p0, p1 with
    | low, _ => true
    | _, high => true
    | _, _ => false
    end.

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
  Proof.
    ii. destruct x; ss.
  Qed.
  Next Obligation.
  Proof.
    ii. destruct x, y, z; ss.
  Qed.

  Lemma meet_le_l p0 p1:
    le (meet p0 p1) p0.
  Proof.
    destruct p0, p1; ss.
  Qed.

  Lemma meet_le_r p0 p1:
    le (meet p0 p1) p1.
  Proof.
    destruct p0, p1; ss.
  Qed.

  Lemma meet_spec p0 p1 p
        (LE0: le p p0)
        (LE1: le p p1)
    :
      le p (meet p0 p1).
  Proof.
    destruct p, p0, p1; ss.
  Qed.

  Lemma meet_mon_l p0 p1 p
        (LE: le p0 p1)
    :
      le (meet p0 p) (meet p1 p).
  Proof.
    destruct p, p0, p1; ss.
  Qed.

  Lemma meet_mon_r p0 p1 p
        (LE: le p0 p1)
    :
      le (meet p p0) (meet p p1).
  Proof.
    destruct p, p0, p1; ss.
  Qed.

  Lemma join_ge_l p0 p1:
    le p0 (join p0 p1).
  Proof.
    destruct p0, p1; ss.
  Qed.

  Lemma join_ge_r p0 p1:
    le p1 (join p0 p1).
  Proof.
    destruct p0, p1; ss.
  Qed.

  Lemma join_spec p0 p1 p
        (LE0: le p0 p)
        (LE1: le p1 p)
    :
      le (join p0 p1) p.
  Proof.
    destruct p, p0, p1; ss.
  Qed.

  Lemma join_mon_l p0 p1 p
        (LE: le p0 p1)
    :
      le (join p0 p) (join p1 p).
  Proof.
    destruct p, p0, p1; ss.
  Qed.

  Lemma join_mon_r p0 p1 p
        (LE: le p0 p1)
    :
      le (join p p0) (join p p1).
  Proof.
    destruct p, p0, p1; ss.
  Qed.
End Perm.

Module Perms.
  Definition t := Loc.t -> Perm.t.

  Definition meet (p0 p1: t): t :=
    fun loc => Perm.meet (p0 loc) (p1 loc).

  Definition join (p0 p1: t): t :=
    fun loc => Perm.join (p0 loc) (p1 loc).

  Definition update (loc: Loc.t) (p: Perm.t) (ps: t): t :=
    fun loc' => if Loc.eq_dec loc loc' then p else ps loc'.

  Definition acquired (p: t) (p_acq: t): Loc.t -> bool :=
    fun loc => Perm.le (p_acq loc) (p loc).

  Definition le (p0 p1: t): Prop :=
    forall loc, Perm.le (p0 loc) (p1 loc).

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
  Proof.
    ii. refl.
  Qed.
  Next Obligation.
  Proof.
    ii. etrans; eauto.
  Qed.

  Lemma meet_le_l p0 p1:
    le (meet p0 p1) p0.
  Proof.
    ii. eapply Perm.meet_le_l; eauto.
  Qed.

  Lemma meet_le_r p0 p1:
    le (meet p0 p1) p1.
  Proof.
    ii. eapply Perm.meet_le_r; eauto.
  Qed.

  Lemma meet_spec p0 p1 p
        (LE0: le p p0)
        (LE1: le p p1)
    :
      le p (meet p0 p1).
  Proof.
    ii. eapply Perm.meet_spec; eauto.
  Qed.

  Lemma meet_mon_l p0 p1 p
        (LE: le p0 p1)
    :
      le (meet p0 p) (meet p1 p).
  Proof.
    ii. eapply Perm.meet_mon_l; eauto.
  Qed.

  Lemma meet_mon_r p0 p1 p
        (LE: le p0 p1)
    :
      le (meet p p0) (meet p p1).
  Proof.
    ii. eapply Perm.meet_mon_r; eauto.
  Qed.

  Lemma join_ge_l p0 p1:
    le p0 (join p0 p1).
  Proof.
    ii. eapply Perm.join_ge_l; eauto.
  Qed.

  Lemma join_ge_r p0 p1:
    le p1 (join p0 p1).
  Proof.
    ii. eapply Perm.join_ge_r; eauto.
  Qed.

  Lemma join_spec p0 p1 p
        (LE0: le p0 p)
        (LE1: le p1 p)
    :
      le (join p0 p1) p.
  Proof.
    ii. eapply Perm.join_spec; eauto.
  Qed.

  Lemma join_mon_l p0 p1 p
        (LE: le p0 p1)
    :
      le (join p0 p) (join p1 p).
  Proof.
    ii. eapply Perm.join_mon_l; eauto.
  Qed.

  Lemma join_mon_r p0 p1 p
        (LE: le p0 p1)
    :
      le (join p p0) (join p p1).
  Proof.
    ii. eapply Perm.join_mon_r; eauto.
  Qed.
End Perms.

Module Flag.
  Definition t := bool.

  Definition meet (f0 f1: t): t := andb f0 f1.

  Definition join (f0 f1: t): t := orb f0 f1.

  Definition minus (f0 f1: t): t :=
    match f1 with
    | true => false
    | false => f0
    end.

  Definition le (f0 f1: t): bool := implb f0 f1.

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
  Proof.
    ii. destruct x; ss.
  Qed.
  Next Obligation.
  Proof.
    ii. destruct x, y, z; ss.
  Qed.

  Lemma meet_le_l f0 f1:
    le (meet f0 f1) f0.
  Proof.
    destruct f0, f1; ss.
  Qed.

  Lemma meet_le_r f0 f1:
    le (meet f0 f1) f1.
  Proof.
    destruct f0, f1; ss.
  Qed.

  Lemma meet_spec f0 f1 f
        (LE0: le f f0)
        (LE1: le f f1)
    :
      le f (meet f0 f1).
  Proof.
    destruct f, f0, f1; ss.
  Qed.

  Lemma meet_mon_l f0 f1 f
        (LE: le f0 f1)
    :
      le (meet f0 f) (meet f1 f).
  Proof.
    destruct f, f0, f1; ss.
  Qed.

  Lemma meet_mon_r f0 f1 f
        (LE: le f0 f1)
    :
      le (meet f f0) (meet f f1).
  Proof.
    destruct f, f0, f1; ss.
  Qed.

  Lemma join_ge_l f0 f1:
    le f0 (join f0 f1).
  Proof.
    destruct f0, f1; ss.
  Qed.

  Lemma join_ge_r f0 f1:
    le f1 (join f0 f1).
  Proof.
    destruct f0, f1; ss.
  Qed.

  Lemma join_spec f0 f1 f
        (LE0: le f0 f)
        (LE1: le f1 f)
    :
      le (join f0 f1) f.
  Proof.
    destruct f, f0, f1; ss.
  Qed.

  Lemma join_mon_l f0 f1 f
        (LE: le f0 f1)
    :
      le (join f0 f) (join f1 f).
  Proof.
    destruct f, f0, f1; ss.
  Qed.

  Lemma join_mon_r f0 f1 f
        (LE: le f0 f1)
    :
      le (join f f0) (join f f1).
  Proof.
    destruct f, f0, f1; ss.
  Qed.

  Lemma minus_mon_l f0 f1 f
        (LE: le f1 f0)
    :
      le (minus f1 f) (minus f0 f).
  Proof.
    destruct f, f0, f1; ss.
  Qed.

  Lemma minus_mon_r f0 f1 f
        (LE: le f1 f0)
    :
      le (minus f f0) (minus f f1).
  Proof.
    destruct f, f0, f1; ss.
  Qed.
End Flag.

Module Flags.
  Definition t := Loc.t -> Flag.t.

  Definition top: t := fun _ => true.

  Definition bot: t := fun _ => false.

  Definition is_empty (f: t): Prop := forall loc, f loc = false.

  Definition update (loc: Loc.t) (f: Flag.t) (fs: t): t :=
    fun loc' => if Loc.eq_dec loc' loc then f else (fs loc').

  Definition add (loc: Loc.t) (f: t): t :=
    fun loc' => if Loc.eq_dec loc' loc then true else (f loc').

  Definition sub (loc: Loc.t) (f: t): t :=
    fun loc' => if Loc.eq_dec loc' loc then false else (f loc').

  Definition sub_opt (loc: option Loc.t) (f: t): t :=
    match loc with
    | Some loc => sub loc f
    | None => f
    end.

  Definition meet (f0 f1: t): t :=
    fun loc => Flag.meet (f0 loc) (f1 loc).

  Definition join (f0 f1: t): t :=
    fun loc => Flag.join (f0 loc) (f1 loc).

  Definition minus (f0 f1: t): t :=
    fun loc => Flag.minus (f0 loc) (f1 loc).

  Definition le (f0 f1: t): Prop :=
    forall loc, Flag.le (f0 loc) (f1 loc).

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
  Proof.
    ii. refl.
  Qed.
  Next Obligation.
  Proof.
    ii. etrans; eauto.
  Qed.

  Lemma top_spec f:
    le f top.
  Proof.
    ii. destruct f; ss.
  Qed.

  Lemma bot_spec f:
    le bot f.
  Proof.
    ii. destruct f; ss.
  Qed.

  Lemma meet_le_l f0 f1:
    le (meet f0 f1) f0.
  Proof.
    ii. eapply Flag.meet_le_l; eauto.
  Qed.

  Lemma meet_le_r f0 f1:
    le (meet f0 f1) f1.
  Proof.
    ii. eapply Flag.meet_le_r; eauto.
  Qed.

  Lemma meet_spec f0 f1 f
        (LE0: le f f0)
        (LE1: le f f1)
    :
      le f (meet f0 f1).
  Proof.
    ii. eapply Flag.meet_spec; eauto.
  Qed.

  Lemma meet_mon_l f0 f1 f
        (LE: le f0 f1)
    :
      le (meet f0 f) (meet f1 f).
  Proof.
    ii. eapply Flag.meet_mon_l; eauto.
  Qed.

  Lemma meet_mon_r f0 f1 f
        (LE: le f0 f1)
    :
      le (meet f f0) (meet f f1).
  Proof.
    ii. eapply Flag.meet_mon_r; eauto.
  Qed.

  Lemma join_ge_l f0 f1:
    le f0 (join f0 f1).
  Proof.
    ii. eapply Flag.join_ge_l; eauto.
  Qed.

  Lemma join_ge_r f0 f1:
    le f1 (join f0 f1).
  Proof.
    ii. eapply Flag.join_ge_r; eauto.
  Qed.

  Lemma join_spec f0 f1 f
        (LE0: le f0 f)
        (LE1: le f1 f)
    :
      le (join f0 f1) f.
  Proof.
    ii. eapply Flag.join_spec; eauto.
  Qed.

  Lemma join_mon_l f0 f1 f
        (LE: le f0 f1)
    :
      le (join f0 f) (join f1 f).
  Proof.
    ii. eapply Flag.join_mon_l; eauto.
  Qed.

  Lemma join_mon_r f0 f1 f
        (LE: le f0 f1)
    :
      le (join f f0) (join f f1).
  Proof.
    ii. eapply Flag.join_mon_r; eauto.
  Qed.

  Lemma join_top_l f: join f top = top.
  Proof.
    extensionality x.
    unfold join, top; ss.
    unfold Flag.join. destruct (f x); ss.
  Qed.

  Lemma join_top_r f: join f top = top.
  Proof.
    extensionality x.
    unfold join, top; ss.
    unfold join. destruct (f x); ss.
  Qed.

  Lemma minus_mon_l f0 f1 f
        (LE: le f1 f0)
    :
      le (minus f1 f) (minus f0 f).
  Proof.
    ii. eapply Flag.minus_mon_l; eauto.
  Qed.

  Lemma minus_mon_r f0 f1 f
        (LE: le f1 f0)
    :
      le (minus f f0) (minus f f1).
  Proof.
    ii. eapply Flag.minus_mon_r; eauto.
  Qed.
End Flags.

Module ValueMap.
  Definition t := Loc.t -> Const.t.

  Definition write (loc: Loc.t) (v: Const.t) (vs: t): t :=
    fun loc' => if Loc.eq_dec loc' loc then v else (vs loc').

  Definition read (loc: Loc.t) (vs: t) := vs loc.

  Definition acquire (cond: Loc.t -> bool) (vs_acq: t) (vs: t): t :=
    fun loc => if (cond loc) then (vs loc) else (vs_acq loc).

  Definition le (vs0 vs1: t): Prop :=
    forall loc, Const.le (vs0 loc) (vs1 loc).

  Global Program Instance le_PreOrder: PreOrder le.
  Next Obligation.
  Proof.
    ii. refl.
  Qed.
  Next Obligation.
  Proof.
    ii. etrans; eauto.
  Qed.
End ValueMap.

Module SeqMemory.
  Record t :=
    mk {
        value_map: ValueMap.t;
        flags: Flags.t;
      }.

  Definition read (loc: Loc.t) (m: t): Const.t :=
    ValueMap.read loc m.(value_map).

  Definition write (loc: Loc.t) (v: Const.t) (m: t): t :=
    mk (ValueMap.write loc v m.(value_map))
       (Flags.update loc true m.(flags))
  .

  Variant acquire (cond: Loc.t -> bool) (v_acq: ValueMap.t):
    forall (m_before: t) (f: Flags.t) (m_after: t), Prop :=
  | acquire_intro
      m
    :
      acquire
        cond
        v_acq
        m
        (m.(flags))
        (mk (ValueMap.acquire cond v_acq m.(value_map)) m.(flags))
  .

  Variant release:
    forall (m: t) (f_rel: Flags.t) (v_rel: ValueMap.t) (m_after: t), Prop :=
  | release_intro
      m
    :
      release
        m
        (m.(flags))
        (m.(value_map))
        (mk m.(value_map) Flags.bot)
  .

  Variant update:
    forall
      (loc: Loc.t) (v_new: Const.t)
      (m_before: t)
      (v: Const.t) (f: Flag.t)
      (m_after: t), Prop :=
  | update_intro
      m loc v_new
    :
      update
        loc
        v_new
        m
        (m.(value_map) loc)
        (m.(flags) loc)
        (mk (ValueMap.write loc v_new m.(value_map))
            (Flags.update loc false m.(flags)))
  .
End SeqMemory.

Module Oracle.
  Record input :=
    mk_input {
        in_access: option (Loc.t * Const.t * Flag.t);
        in_acquire: option (unit);
        in_release: option (unit);
      }.

  Record output :=
    mk_output {
        out_access: option (Perm.t);
        out_acquire: option (Perms.t * ValueMap.t);
        out_release: option (Perms.t);
      }.

  Definition wf_input (e: ProgramEvent.t) (i: input): Prop :=
    (<<UPDATE: forall loc,
        ((exists v_old f_old, i.(in_access) = Some (loc, v_old, f_old)) <-> exists v_new, is_accessing e = Some (loc, v_new))>>) /\
    (<<ACQUIRE: is_some i.(in_acquire) <-> is_acquire e>>) /\
    (<<RELEASE: is_some i.(in_release) <-> is_release e>>)
  .

  Definition wf_output (e: ProgramEvent.t) (o: output): Prop :=
    (<<UPDATE: is_some o.(out_access) <-> is_accessing e>>) /\
    (<<ACQUIRE: is_some o.(out_acquire) <-> is_acquire e>>) /\
    (<<RELEASE: is_some o.(out_release) <-> is_release e>>)
  .

  Definition in_access_le (i0 i1: (Loc.t * Const.t * Flag.t)): Prop :=
    match i0, i1 with
    | (l0, v0, f0), (l1, v1, f1) =>
      (<<LOC: l0 = l1>>) /\ (<<VAL: Const.le v0 v1>>) /\
      (<<FLAG: Flag.le f0 f1>>)
    end.

  Definition in_acquire_le (i0 i1: unit): Prop := i0 = i1.

  Definition in_release_le (i0 i1: unit): Prop := i0 = i1.

  Definition input_le (i0 i1: input): Prop :=
    (<<ACCESS: option_rel in_access_le i0.(in_access) i1.(in_access)>>) /\
    (<<ACQUIRE: option_rel in_acquire_le i0.(in_acquire) i1.(in_acquire)>>) /\
    (<<RELEASE: option_rel in_release_le i0.(in_release) i1.(in_release)>>)
  .

  Global Program Instance in_access_le_PreOrder: PreOrder in_access_le.
  Next Obligation.
  Proof.
    ii. unfold in_access_le. des_ifs. splits; refl.
  Qed.
  Next Obligation.
  Proof.
    ii. unfold in_access_le in *. des_ifs. des. splits; etrans; eauto.
  Qed.

  Global Program Instance in_acquire_le_PreOrder: PreOrder in_acquire_le.

  Global Program Instance in_release_le_PreOrder: PreOrder in_release_le.

  Global Program Instance input_le_PreOrder: PreOrder input_le.
  Next Obligation.
  Proof.
    ii. unfold input_le. splits; refl.
  Qed.
  Next Obligation.
  Proof.
    ii. unfold input_le in *. des. splits; etrans; eauto.
  Qed.

  Record t :=
    mk {
        _t: Type;
        _step: ProgramEvent.t -> input -> output -> _t -> _t -> Prop;
        _o: _t;
      }.

  Variant step: forall (pe: ProgramEvent.t) (i: input) (o: output) (o0 o1: t), Prop :=
  | step_intro
      pe i o
      _t (_step: ProgramEvent.t -> input -> output -> _t -> _t -> Prop)
      (x0 x1: _t)
      (STEP: _step pe i o x0 x1)
    :
      step pe i o (@mk _t _step x0) (@mk _t _step x1)
  .

  Definition progress pe o0: Prop :=
    forall i (WF: wf_input pe i),
    exists o o1, (<<STEP: step pe i o o0 o1>>) /\ (<<WF: wf_output pe o>>).

  Variant _wf (wf: t -> Prop): t -> Prop :=
  | wf_intro
      (o0: t)
      (WF: forall pe i o o1 (STEP: step pe i o o0 o1),
          (<<INPUT: wf_input pe i>>) /\
          (<<OUTPUT: wf_output pe o>>) /\
          (<<ORACLE: wf o1>>))
      (LOAD: forall loc ord, exists val,
            progress (ProgramEvent.read loc val ord) o0 /\
            forall valw ordw, progress (ProgramEvent.update loc val valw ord ordw) o0)
      (STORE: forall loc ord val,
          progress (ProgramEvent.write loc val ord) o0)
      (FENCE: forall ordr ordw,
          progress (ProgramEvent.fence ordr ordw) o0)
      (SYSCALL: forall e, progress (ProgramEvent.syscall e) o0)
    :
      _wf wf o0
  .

  Lemma wf_mon: monotone1 _wf.
  Proof.
    ii. inv IN. econs; eauto. i.
    exploit WF; eauto. i. des. splits; auto.
  Qed.
  #[export] Hint Resolve wf_mon: paco.

  Definition wf := paco1 _wf bot1.
End Oracle.

Module SeqEvent.
  Record input :=
    mk_input {
        in_access: option (Loc.t * Const.t * Flag.t * Const.t);
        in_acquire: option (Flags.t);
        in_release: option (ValueMap.t * Flags.t);
      }.

  Definition in_access_written (i: option (Loc.t * Const.t * Flag.t * Const.t)): Flags.t :=
    match i with
    | Some (loc, _, true, _) => Flags.add loc Flags.bot
    | _ => Flags.bot
    end.

  Definition in_release_written (i: option (ValueMap.t * Flags.t)): Flags.t :=
    match i with
    | Some (_, f) => f
    | _ => Flags.bot
    end.

  Definition written (i: input): Flags.t :=
    Flags.join (in_access_written i.(in_access)) (in_release_written i.(in_release)).

  Definition get_oracle_input (i: input): Oracle.input :=
    Oracle.mk_input
      (option_map (fun '(loc, v_old, f, v_new) => (loc, v_old, f)) i.(in_access))
      (option_map (fun _ => tt) i.(in_acquire))
      (option_map (fun _ => tt) i.(in_release))
  .

  Variant in_access_match: forall (d0 d1: Flags.t) (i_src i_tgt: option (Loc.t * Const.t * Flag.t * Const.t)), Prop :=
  | in_access_match_none
      d0 d1
      (FLAG: Flags.le d0 d1)
    :
      in_access_match d0 d1 None None
  | in_access_match_some
      d0 d1
      l v_src v_tgt f_src f_tgt v_new_src v_new_tgt
      (VAL: Const.le v_tgt v_src)
      (FLAG: Flag.le (Flag.join f_tgt (d0 l)) f_src)
      (DEFERRED: forall loc (LOC: loc <> l), Flag.le (d0 loc) (d1 loc))
    :
      in_access_match d0 d1 (Some (l, v_src, f_src, v_new_src)) (Some (l, v_tgt, f_tgt, v_new_tgt))
  .

  Variant in_acquire_match: forall (d0 d1: Flags.t) (i_src i_tgt: option (Flags.t)), Prop :=
  | in_acquire_match_none
      d0 d1
      (FLAG: Flags.le d0 d1)
    :
      in_acquire_match d0 d1 None None
  | in_acquire_match_some
      d0 d1
      f_src f_tgt
      (FLAG: Flags.le (Flags.join f_tgt d0) f_src)
    :
      in_acquire_match d0 d1 (Some f_src) (Some f_tgt)
  .

  Variant in_release_match: forall (d0 d1: Flags.t) (i_src i_tgt: option (ValueMap.t * Flags.t)), Prop :=
  | in_release_match_none
      d0 d1
      (FLAG: Flags.le d0 d1)
    :
      in_release_match d0 d1 None None
  | in_release_match_some
      d0 d1
      v_src v_tgt f_src f_tgt
      (VAL: forall loc (UNDEFERRED: d1 loc = false), Const.le (v_tgt loc) (v_src loc))
      (DEFERRED: Flags.le (Flags.join f_tgt d0) (Flags.join f_src d1))
    :
      in_release_match d0 d1 (Some (v_src, f_src)) (Some (v_tgt, f_tgt))
  .

  Variant input_match (d0 d3: Flags.t) (i_src i_tgt: input): Prop :=
  | input_match_intro
      d1 d2
      (ACCESS: in_access_match d0 d1 i_src.(in_access) i_tgt.(in_access))
      (ACQUIRE: in_acquire_match d1 d2 i_src.(in_acquire) i_tgt.(in_acquire))
      (RELEASE: in_release_match d2 d3 i_src.(in_release) i_tgt.(in_release))
    :
      input_match d0 d3 i_src i_tgt
  .

  Lemma in_access_match_mon d_before0 d_before1 d_after0 d_after1
        i_src i_tgt
        (MATCH: in_access_match d_before1 d_after0 i_src i_tgt)
        (BEFORE: Flags.le d_before0 d_before1)
        (AFTER: Flags.le d_after0 d_after1)
    :
      in_access_match d_before0 d_after1 i_src i_tgt.
  Proof.
    inv MATCH; econs; eauto.
    { etrans; eauto. etrans; eauto. }
    { etrans; eauto. eapply Flag.join_mon_r. eauto. }
    { i. transitivity (d_before1 loc); auto. transitivity (d_after0 loc); auto. }
  Qed.

  Lemma in_acquire_match_mon d_before0 d_before1 d_after0 d_after1
        i_src i_tgt
        (MATCH: in_acquire_match d_before1 d_after0 i_src i_tgt)
        (BEFORE: Flags.le d_before0 d_before1)
        (AFTER: Flags.le d_after0 d_after1)
    :
      in_acquire_match d_before0 d_after1 i_src i_tgt.
  Proof.
    inv MATCH; econs; eauto.
    { etrans; eauto. etrans; eauto. }
    { etrans; eauto. eapply Flags.join_mon_r. eauto. }
  Qed.

  Lemma in_release_match_mon d_before0 d_before1 d_after0 d_after1
        i_src i_tgt
        (MATCH: in_release_match d_before1 d_after0 i_src i_tgt)
        (BEFORE: Flags.le d_before0 d_before1)
        (AFTER: Flags.le d_after0 d_after1)
    :
      in_release_match d_before0 d_after1 i_src i_tgt.
  Proof.
    inv MATCH; econs; eauto.
    { etrans; eauto. etrans; eauto. }
    { i. eapply VAL; eauto. specialize (AFTER loc).
      destruct (d_after0 loc), (d_after1 loc); ss. }
    { transitivity (Flags.join f_tgt d_before1).
      { eapply Flags.join_mon_r; eauto. }
      etrans; eauto.
      { eapply Flags.join_mon_r; eauto. }
    }
  Qed.

  Lemma input_match_mon d_before0 d_before1 d_after0 d_after1 i_src i_tgt
        (MATCH: input_match d_before1 d_after0 i_src i_tgt)
        (DBEFORE: Flags.le d_before0 d_before1)
        (DAFTER: Flags.le d_after0 d_after1)
    :
      input_match d_before0 d_after1 i_src i_tgt.
  Proof.
    inv MATCH. econs.
    { eapply in_access_match_mon; eauto. refl. }
    { eapply in_acquire_match_mon; eauto; refl. }
    { eapply in_release_match_mon; eauto. refl. }
  Qed.

  Lemma in_access_match_bot d i
    :
      in_access_match Flags.bot d i i.
  Proof.
    destruct i as [[[[] ?] ?]|]; econs; eauto; ss.
    { refl. }
    { eapply Flag.join_spec; eauto. refl. }
  Qed.

  Lemma in_acquire_match_bot d i
    :
      in_acquire_match Flags.bot d i i.
  Proof.
    destruct i as [|]; econs; eauto; ss.
    { eapply Flags.join_spec; eauto; ss. refl. }
  Qed.

  Lemma in_release_match_bot d i
    :
      in_release_match Flags.bot d i i.
  Proof.
    destruct i as [[]|]; econs; eauto; ss.
    { i. refl. }
    { eapply Flags.join_mon_r. ss. }
  Qed.

  Lemma input_match_bot d i
    :
      input_match Flags.bot d i i.
  Proof.
    econs.
    { eapply in_access_match_bot. }
    { eapply in_acquire_match_bot. }
    { eapply in_release_match_bot. }
  Qed.

  Definition wf_input (e: ProgramEvent.t) (i: input): Prop :=
    (<<UPDATE: forall loc v_new,
        ((exists v_old f_old, i.(in_access) = Some (loc, v_old, f_old, v_new)) <-> (is_accessing e = Some (loc, v_new)))>>) /\
    (<<ACQUIRE: is_some i.(in_acquire) <-> is_acquire e>>) /\
    (<<RELEASE: is_some i.(in_release) <-> is_release e>>)
  .

  (* Lemma wf_input_event_le e0 e1 i *)
  (*       (EVENT: ProgramEvent.le e0 e1) *)
  (*   : *)
  (*     wf_input e0 i <-> wf_input e1 i. *)
  (* Proof. *)
  (*   unfold wf_input. destruct e0, e1; ss; des; clarify. *)
  (*   { split; i; des; splits; i; split; eauto. *)
  (*     { i. eapply UPDATE in H. des. inv H. eauto. } *)
  (*     { i. eapply UPDATE. des. inv H. eauto. } *)
  (*     { i. eapply UPDATE in H. des. inv H. eauto. } *)
  (*     { i. eapply UPDATE. des. inv H. eauto. } *)
  (*   } *)
  (*   { split; i; des; splits; i; split; eauto. *)
  (*     { i. eapply UPDATE in H. des. inv H. eauto. } *)
  (*     { i. eapply UPDATE. des. inv H. eauto. } *)
  (*     { i. eapply UPDATE in H. des. inv H. eauto. } *)
  (*     { i. eapply UPDATE. des. inv H. eauto. } *)
  (*   } *)
  (* Qed. *)

  Variant step_update:
    forall (i: option (Loc.t * Const.t * Flag.t * Const.t)) (o: option (Perm.t))
           (p0: Perms.t) (m0: SeqMemory.t) (p1: Perms.t) (m1: SeqMemory.t), Prop :=
  | step_update_none
      p m
    :
      step_update
        None None
        p m p m
  | step_update_some
      loc v f p_new v_new
      p0 m0 p1 m1
      (PERM: p1 = Perms.update loc p_new p0)
      (MEM: SeqMemory.update loc v_new m0 v f m1)
    :
      step_update
        (Some (loc, v, f, v_new)) (Some (p_new))
        p0 m0 p1 m1
  .

  Variant step_acquire:
    forall (i: option (Flags.t)) (o: option (Perms.t * ValueMap.t))
           (p0: Perms.t) (m0: SeqMemory.t) (p1: Perms.t) (m1: SeqMemory.t), Prop :=
  | step_acquire_none
      p m
    :
      step_acquire
        None None
        p m p m
  | step_acquire_some
      p_acq v_acq f
      p0 m0 p1 m1
      (PERM: p1 = Perms.join p0 p_acq)
      (MEM: SeqMemory.acquire (Perms.acquired p0 p_acq) v_acq m0 f m1)
    :
      step_acquire
        (Some f) (Some (p_acq, v_acq))
        p0 m0 p1 m1
  .

  Variant step_release:
    forall (i: option (ValueMap.t * Flags.t)) (o: option Perms.t)
           (p0: Perms.t) (m0: SeqMemory.t) (p1: Perms.t) (m1: SeqMemory.t), Prop :=
  | step_release_none
      p m
    :
      step_release
        None None
        p m p m
  | step_release_some
      p_rel v_rel f_rel
      p0 m0 p1 m1
      (PERM: p1 = Perms.meet p0 p_rel)
      (MEM: SeqMemory.release m0 f_rel v_rel m1)
    :
      step_release
        (Some (v_rel, f_rel)) (Some p_rel)
        p0 m0 p1 m1
  .

  Variant step:
    forall (i: input) (o: Oracle.output)
           (p0: Perms.t) (m0: SeqMemory.t) (p1: Perms.t) (m1: SeqMemory.t), Prop :=
  | step_intro
      i o p0 m0 p1 m1 p2 m2 p3 m3
      (UPD: step_update i.(in_access) o.(Oracle.out_access) p0 m0 p1 m1)
      (ACQ: step_acquire i.(in_acquire) o.(Oracle.out_acquire) p1 m1 p2 m2)
      (REL: step_release i.(in_release) o.(Oracle.out_release) p2 m2 p3 m3)
    :
      step i o p0 m0 p3 m3
  .

  Lemma step_update_match i_src i_tgt d0 d1 o p0 m0 p1 m1
        (STEP: step_update i_src o p0 m0 p1 m1)
        (MATCH: in_access_match d0 d1 i_src i_tgt)
    :
      in_access_match (Flags.join d0 m0.(SeqMemory.flags)) (Flags.join d1 m1.(SeqMemory.flags)) i_src i_tgt.
  Proof.
    inv STEP.
    { inv MATCH. econs; eauto. eapply Flags.join_mon_l. auto. }
    inv MEM. ss. inv MATCH. econs; eauto.
    { unfold Flags.join. destruct f_tgt, (d0 loc), (SeqMemory.flags m0 loc); ss. }
    { i. unfold Flags.join, Flags.update. des_ifs.
      eapply Flag.join_mon_l. auto. }
  Qed.

  Lemma step_acquire_match i_src i_tgt d0 d1 o p0 m0 p1 m1
        (STEP: step_acquire i_src o p0 m0 p1 m1)
        (MATCH: in_acquire_match d0 d1 i_src i_tgt)
    :
      in_acquire_match (Flags.join d0 m0.(SeqMemory.flags)) (Flags.join d1 m1.(SeqMemory.flags)) i_src i_tgt.
  Proof.
    inv STEP.
    { inv MATCH. econs; eauto. eapply Flags.join_mon_l. auto. }
    inv MEM. ss. inv MATCH. econs; eauto.
    eapply Flags.join_spec.
    { etrans; eauto. eapply Flags.join_ge_l. }
    { eapply Flags.join_spec; eauto.
      { etrans; eauto. eapply Flags.join_ge_r. }
      { refl. }
    }
  Qed.

  Lemma step_release_match i_src i_tgt d0 d1 o p0 m0 p1 m1
        (STEP: step_release i_src o p0 m0 p1 m1)
        (MATCH: in_release_match d0 d1 i_src i_tgt)
    :
      in_release_match (Flags.join d0 m0.(SeqMemory.flags)) (Flags.join d1 m1.(SeqMemory.flags)) i_src i_tgt.
  Proof.
    inv STEP.
    { inv MATCH. econs; eauto. eapply Flags.join_mon_l. auto. }
    inv MEM. ss. inv MATCH. econs; eauto.
    { i. eapply VAL; eauto.
      unfold Flags.join in UNDEFERRED. destruct (d1 loc); ss. }
    { eapply Flags.join_spec.
      { etrans; [eapply Flags.join_ge_l|]. etrans; [eauto|].
        eapply Flags.join_spec.
        { eapply Flags.join_ge_l. }
        { etrans; [|eapply Flags.join_ge_r]. eapply Flags.join_ge_l. }
      }
      { eapply Flags.join_spec.
        { etrans; [eapply Flags.join_ge_r|]. etrans; [eauto|].
          eapply Flags.join_spec.
          { eapply Flags.join_ge_l. }
          { etrans; [|eapply Flags.join_ge_r]. eapply Flags.join_ge_l. }
        }
        { eapply Flags.join_ge_l. }
      }
    }
  Qed.

  Lemma step_input_match i_src i_tgt d0 d1 o p0 m0 p1 m1
        (STEP: step i_src o p0 m0 p1 m1)
        (MATCH: input_match d0 d1 i_src i_tgt)
    :
      input_match (Flags.join d0 m0.(SeqMemory.flags)) (Flags.join d1 m1.(SeqMemory.flags)) i_src i_tgt.
  Proof.
    inv STEP. inv MATCH. econs.
    { eapply step_update_match; eauto. }
    { eapply step_acquire_match; eauto. }
    { eapply step_release_match; eauto. }
  Qed.

  Lemma step_update_inj
        p m
        i1 o1 p1 m1
        i2 o2 p2 m2
        (STEP1: step_update i1 o1 p m p1 m1)
        (STEP2: step_update i2 o2 p m p2 m2)
        (INPUT: forall loc1 v_old1 f1 v_new1
                  loc2 v_old2 f2 v_new2
                  (IN1: i1 = Some (loc1, v_old1, f1, v_new1))
                  (IN2: i2 = Some (loc2, v_old2, f2, v_new2)),
            loc1 = loc2 /\ v_new1 = v_new2)
        (OUTPUT: o1 = o2):
    i1 = i2 /\ p1 = p2 /\ m1 = m2.
  Proof.
    subst. inv STEP1; inv STEP2; ss.
    exploit INPUT; eauto. i. des. subst.
    inv MEM. inv MEM0. ss.
  Qed.

  Lemma step_acquire_inj
        p m
        i1 o1 p1 m1
        i2 o2 p2 m2
        (STEP1: step_acquire i1 o1 p m p1 m1)
        (STEP2: step_acquire i2 o2 p m p2 m2)
        (OUTPUT: o1 = o2):
    i1 = i2 /\ p1 = p2 /\ m1 = m2.
  Proof.
    subst. inv STEP1; inv STEP2; ss.
    inv MEM. inv MEM0. ss.
  Qed.

  Lemma step_release_inj
        p m
        i1 o1 p1 m1
        i2 o2 p2 m2
        (STEP1: step_release i1 o1 p m p1 m1)
        (STEP2: step_release i2 o2 p m p2 m2)
        (OUTPUT: o1 = o2):
    i1 = i2 /\ p1 = p2 /\ m1 = m2.
  Proof.
    subst. inv STEP1; inv STEP2; ss.
    inv MEM. inv MEM0. ss.
  Qed.

  Lemma step_inj
        p m
        i1 o1 p1 m1
        i2 o2 p2 m2
        (STEP1: step i1 o1 p m p1 m1)
        (STEP2: step i2 o2 p m p2 m2)
        (INPUT: forall loc1 v_old1 f1 v_new1
                  loc2 v_old2 f2 v_new2
                  (IN1: i1.(in_access) = Some (loc1, v_old1, f1, v_new1))
                  (IN2: i2.(in_access) = Some (loc2, v_old2, f2, v_new2)),
            loc1 = loc2 /\ v_new1 = v_new2)
        (OUTPUT: o1 = o2):
    i1 = i2 /\ p1 = p2 /\ m1 = m2.
  Proof.
    destruct i1, i2. inv STEP1. inv STEP2. ss.
    exploit step_update_inj; [exact UPD|exact UPD0|..]; eauto. i. des. subst.
    exploit step_acquire_inj; [exact ACQ|exact ACQ0|..]; eauto. i. des. subst.
    exploit step_release_inj; [exact REL|exact REL0|..]; eauto. i. des. subst. ss.
  Qed.

  Lemma step_update_inj_perms
        p
        i1 o1 m1 p1 m1'
        i2 o2 m2 p2 m2'
        (STEP1: step_update i1 o1 p m1 p1 m1')
        (STEP2: step_update i2 o2 p m2 p2 m2')
        (INPUT: forall loc1 v_old1 f1 v_new1
                  loc2 v_old2 f2 v_new2
                  (IN1: i1 = Some (loc1, v_old1, f1, v_new1))
                  (IN2: i2 = Some (loc2, v_old2, f2, v_new2)),
            loc1 = loc2)
        (OUTPUT: o1 = o2):
    p1 = p2.
  Proof.
    subst. inv STEP1; inv STEP2; ss.
    exploit INPUT; eauto. i. des. subst.
    inv MEM. inv MEM0. ss.
  Qed.

  Lemma step_acquire_inj_perms
        p
        i1 o1 m1 p1 m1'
        i2 o2 m2 p2 m2'
        (STEP1: step_acquire i1 o1 p m1 p1 m1')
        (STEP2: step_acquire i2 o2 p m2 p2 m2')
        (OUTPUT: o1 = o2):
    p1 = p2.
  Proof.
    subst. inv STEP1; inv STEP2; ss.
  Qed.

  Lemma step_release_inj_perms
        p
        i1 o1 m1 p1 m1'
        i2 o2 m2 p2 m2'
        (STEP1: step_release i1 o1 p m1 p1 m1')
        (STEP2: step_release i2 o2 p m2 p2 m2')
        (OUTPUT: o1 = o2):
    p1 = p2.
  Proof.
    subst. inv STEP1; inv STEP2; ss.
  Qed.

  Lemma step_inj_perms
        p
        i1 o1 m1 p1 m1'
        i2 o2 m2 p2 m2'
        (STEP1: step i1 o1 p m1 p1 m1')
        (STEP2: step i2 o2 p m2 p2 m2')
        (INPUT: forall loc1 v_old1 f1 v_new1
                  loc2 v_old2 f2 v_new2
                  (IN1: i1.(in_access) = Some (loc1, v_old1, f1, v_new1))
                  (IN2: i2.(in_access) = Some (loc2, v_old2, f2, v_new2)),
            loc1 = loc2)
        (OUTPUT: o1 = o2):
    p1 = p2.
  Proof.
    destruct i1, i2. inv STEP1. inv STEP2. ss.
    exploit step_update_inj_perms; [exact UPD|exact UPD0|..]; eauto. i. subst.
    exploit step_acquire_inj_perms; [exact ACQ|exact ACQ0|..]; eauto. i. subst.
    exploit step_release_inj_perms; [exact REL|exact REL0|..]; eauto.
  Qed.
End SeqEvent.

Module SeqState.
Section LANG.
  Variable lang: language.

  Record t :=
    mk {
        state: lang.(Language.state);
        memory: SeqMemory.t;
      }.

  Variant na_local_step (p: Perms.t):
    forall (e: MachineEvent.t)
           (pe: ProgramEvent.t)
           (m0: SeqMemory.t)
           (m1: SeqMemory.t), Prop :=
  | na_local_step_silent
      m
    :
      na_local_step
        p
        (MachineEvent.silent) (ProgramEvent.silent)
        m m
  | na_local_step_read
      m
      loc val ord
      (ORD: Ordering.le ord Ordering.na)
      (VAL: Perm.le Perm.high (p loc) -> Const.le val (SeqMemory.read loc m))
    :
      na_local_step
        p
        (MachineEvent.silent) (ProgramEvent.read loc val ord)
        m m
  | na_local_step_write
      m0 m1 e
      loc val ord
      (ORD: Ordering.le ord Ordering.na)
      (MEM: SeqMemory.write loc val m0 = m1)
      (PERM: e = if Perm.le Perm.high (p loc) then MachineEvent.silent else MachineEvent.failure)
    :
      na_local_step
        p
        e (ProgramEvent.write loc val ord)
        m0 m1
  | na_local_step_failure
      m
    :
      na_local_step
        p
        (MachineEvent.failure) (ProgramEvent.failure)
        m m
  | na_local_step_update
      m
      loc valr valw ordr ordw
      (ORD: __guard__(Ordering.le ordr Ordering.na \/ Ordering.le ordw Ordering.na))
    :
      na_local_step
        p
        (MachineEvent.failure) (ProgramEvent.update loc valr valw ordr ordw)
        m m
  .

  Variant na_step (p: Perms.t): MachineEvent.t -> t -> t -> Prop :=
  | na_step_intro
      st0 st1 m0 m1 e pe
      (LANG: lang.(Language.step) pe st0 st1)
      (LOCAL: na_local_step p e pe m0 m1)
    :
      na_step p e (mk st0 m0) (mk st1 m1)
  .

  Variant na_opt_step (p: Perms.t): MachineEvent.t -> t -> t -> Prop :=
  | na_opt_step_some
      e st0 st1
      (STEP: na_step p e st0 st1)
    :
      na_opt_step p e st0 st1
  | na_opt_step_none
      st0
    :
      na_opt_step p MachineEvent.silent st0 st0
  .

  Variant na_local_step_determ (p: Perms.t):
    forall (e: MachineEvent.t)
           (pe: ProgramEvent.t)
           (m0: SeqMemory.t)
           (m1: SeqMemory.t), Prop :=
  | na_local_step_determ_silent
      m
    :
      na_local_step_determ
        p
        (MachineEvent.silent) (ProgramEvent.silent)
        m m
  | na_local_step_determ_read
      m
      loc val ord
      (ORD: Ordering.le ord Ordering.na)
      (PERM: Perm.le Perm.high (p loc) -> val = SeqMemory.read loc m)
      (NPERM: Perm.le (p loc) Perm.low -> val = Const.undef)
    :
      na_local_step_determ
        p
        (MachineEvent.silent) (ProgramEvent.read loc val ord)
        m m
  | na_local_step_determ_write
      m0 m1 e
      loc val ord
      (ORD: Ordering.le ord Ordering.na)
      (MEM: SeqMemory.write loc val m0 = m1)
      (PERM: e = if Perm.le Perm.high (p loc) then MachineEvent.silent else MachineEvent.failure)
    :
      na_local_step_determ
        p
        e (ProgramEvent.write loc val ord)
        m0 m1
  | na_local_step_determ_failure
      m
    :
      na_local_step_determ
        p
        (MachineEvent.failure) (ProgramEvent.failure)
        m m
  | na_local_step_determ_update
      m
      loc valr valw ordr ordw
      (ORD: __guard__(Ordering.le ordr Ordering.na \/ Ordering.le ordw Ordering.na))
    :
      na_local_step_determ
        p
        (MachineEvent.failure) (ProgramEvent.update loc valr valw ordr ordw)
        m m
  .

  Variant na_step_determ (p: Perms.t): MachineEvent.t -> t -> t -> Prop :=
  | na_step_determ_intro
      st0 st1 m0 m1 e pe
      (LANG: lang.(Language.step) pe st0 st1)
      (LOCAL: na_local_step_determ p e pe m0 m1)
    :
      na_step_determ p e (mk st0 m0) (mk st1 m1)
  .
End LANG.
End SeqState.

Module SeqThread.
Section LANG.
  Variable lang: language.
  Variable state_step:
    Perms.t -> MachineEvent.t -> SeqState.t lang -> SeqState.t lang -> Prop.

  Record t :=
    mk {
        state: SeqState.t lang;
        perm: Perms.t;
        oracle: Oracle.t;
      }.

  Variant na_step:
    forall (e: MachineEvent.t) (th0: t) (th1: t), Prop :=
  | na_step_intro
      p o e st0 st1
      (STEP: state_step p e st0 st1)
    :
      na_step e (mk st0 p o) (mk st1 p o)
  .

  Lemma na_state_steps_na_steps p o st0 st1
        (STEPS: rtc (state_step p MachineEvent.silent) st0 st1)
    :
      rtc (na_step MachineEvent.silent) (mk st0 p o) (mk st1 p o).
  Proof.
    induction STEPS.
    - refl.
    - econs; eauto. econs; eauto.
  Qed.

  Variant at_step:
    forall (e: ProgramEvent.t) (i: SeqEvent.input) (o: Oracle.output)
           (th0: t) (th1: t), Prop :=
  | at_step_intro
      e0 e1 i0 i1 o
      st0 st1 p0 p1 o0 o1 m0 m1
      (LANG: lang.(Language.step) e1 st0 st1)
      (ATOMIC: is_atomic_event e1)
      (EVENT: ProgramEvent.le e0 e1)
      (INPUT: Oracle.input_le i0 (SeqEvent.get_oracle_input i1))
      (ORACLE: Oracle.step e0 i0 o o0 o1)
      (MEM: SeqEvent.step i1 o p0 m0 p1 m1)
      (INPUT: SeqEvent.wf_input e1 i1)
    :
      at_step e1 i1 o (mk (SeqState.mk _ st0 m0) p0 o0) (mk (SeqState.mk _ st1 m1) p1 o1)
  .

  Definition failure (th0: t): Prop :=
    exists th1, (<<FAILURE: na_step MachineEvent.failure th0 th1>>).

  Inductive steps: forall
      (tr: list (ProgramEvent.t * SeqEvent.input * Oracle.output))
      (th0 th1: t), Prop :=
  | steps_base
      th
    :
      steps [] th th
  | steps_na_step
      tr th0 th1 th2
      (STEP: na_step MachineEvent.silent th0 th1)
      (STEPS: steps tr th1 th2)
    :
      steps tr th0 th2
  | steps_at_step
      e i o tr th0 th1 th2
      (STEP: at_step e i o th0 th1)
      (STEPS: steps tr th1 th2)
    :
      steps ((e, i, o)::tr) th0 th2
  .

  Inductive writing_trace: forall
      (tr: list (ProgramEvent.t * SeqEvent.input * Oracle.output))
      (w: Flags.t), Prop :=
  | writing_trace_base
    :
      writing_trace [] Flags.bot
  | writing_trace_cons
      tr e i o w
      (TRACE: writing_trace tr w)
      (UPDATE: ~ is_updating e)
      (ACQUIRE: ~ is_acquire e)
    :
      writing_trace ((e, i, o)::tr) (Flags.join (SeqEvent.written i) w)
  .

  (* Lemma writing_trace_mon d0 d1 tr w *)
  (*       (DEFERRED: Flags.le d0 d1) *)
  (*       (WRITING: writing_trace d1 tr w) *)
  (*   : *)
  (*     writing_trace d0 tr w. *)
  (* Proof. *)
  (*   revert d0 DEFERRED. induction WRITING. *)
  (*   { econs 1. } *)
  (*   { econs 2. *)
  (*     { eapply IHWRITING. eapply Flags.minus_mon_l; eauto. } *)
  (*     { eauto. } *)
  (*     { i. eapply ACCESS in SOME. des; auto. *)
  (*       specialize (DEFERRED loc). destruct (d loc), (d0 loc); ss. auto. } *)
  (*   } *)
  (* Qed. *)
End LANG.
End SeqThread.

Section SIMULATION.
Section LANG.
  Variable lang_src: language.
  Variable lang_tgt: language.
  Variable sim_terminal: forall (st_src:(Language.state lang_src)) (st_tgt:(Language.state lang_tgt)), Prop.

  Definition sim_seq_terminal_case
             (p0: Perms.t) (d0: Flags.t)
             (st_src0: SeqState.t lang_src)
             (st_tgt0: SeqState.t lang_tgt): Prop :=
    forall (TERMINAL_TGT: lang_tgt.(Language.is_terminal) st_tgt0.(SeqState.state)),
    exists st_src1,
      (<<STEPS: rtc (SeqState.na_step p0 MachineEvent.silent) st_src0 st_src1>>) /\
      (<<TERMINAL_SRC: lang_src.(Language.is_terminal) st_src1.(SeqState.state)>>) /\
      (<<TERMINAL: sim_terminal st_src1.(SeqState.state) st_tgt0.(SeqState.state)>>) /\
      (<<VALUE: ValueMap.le st_tgt0.(SeqState.memory).(SeqMemory.value_map) st_src1.(SeqState.memory).(SeqMemory.value_map)>>) /\
      (<<FLAG: Flags.le (Flags.join d0 st_tgt0.(SeqState.memory).(SeqMemory.flags)) st_src1.(SeqState.memory).(SeqMemory.flags)>>)
  .

  Definition sim_seq_na_step_case
             (sim_seq:
                forall
                  (p0: Perms.t) (d0: Flags.t)
                  (st_src0: SeqState.t lang_src)
                  (st_tgt0: SeqState.t lang_tgt), Prop)
             (p0: Perms.t) (d0: Flags.t)
             (st_src0: SeqState.t lang_src)
             (st_tgt0: SeqState.t lang_tgt): Prop :=
    forall st_tgt1 e (STEP_TGT: SeqState.na_step p0 e st_tgt0 st_tgt1),
    exists st_src1 st_src2,
      (<<STEPS: rtc (SeqState.na_step p0 MachineEvent.silent) st_src0 st_src1>>) /\
      (<<STEP: SeqState.na_opt_step p0 e st_src1 st_src2>>) /\
      (<<SIM: sim_seq p0 d0 st_src2 st_tgt1>>)
  .

  Definition sim_seq_at_step_case
             (sim_seq:
                forall
                  (p0: Perms.t) (d0: Flags.t)
                  (st_src0: SeqState.t lang_src)
                  (st_tgt0: SeqState.t lang_tgt), Prop)
             (p0: Perms.t) (d0: Flags.t)
             (st_src0: SeqState.t lang_src)
             (st_tgt0: SeqState.t lang_tgt): Prop :=
    forall st_tgt1 e_tgt
           (STEP_TGT: lang_tgt.(Language.step) e_tgt st_tgt0.(SeqState.state) st_tgt1)
           (ATOMIC: is_atomic_event e_tgt),
    exists st_src1 st_src2 e_src,
      (<<STEPS: rtc (SeqState.na_step p0 MachineEvent.silent) st_src0 st_src1>>) /\
      (<<STEP: lang_src.(Language.step) e_src st_src1.(SeqState.state) st_src2>>) /\
      (<<EVENT: ProgramEvent.le e_tgt e_src>>) /\
      (<<SIM: forall i_tgt o p1 mem_tgt
                     (INPUT: SeqEvent.wf_input e_tgt i_tgt)
                     (OUTPUT: Oracle.wf_output e_tgt o)
                     (STEP_TGT: SeqEvent.step i_tgt o p0 st_tgt0.(SeqState.memory) p1 mem_tgt),
          exists i_src mem_src d1,
            (<<STEP_SRC: SeqEvent.step i_src o p0 st_src1.(SeqState.memory) p1 mem_src>>) /\
            (<<MATCH: SeqEvent.input_match d0 d1 i_src i_tgt>>) /\
            (<<INPUT: SeqEvent.wf_input e_src i_src>>) /\
            (<<SIM: sim_seq p1 d1
                            (SeqState.mk _ st_src2 mem_src)
                            (SeqState.mk _ st_tgt1 mem_tgt)>>)>>)
  .

  Definition sim_seq_partial_case
             (p0: Perms.t) (d0: Flags.t)
             (st_src0: SeqState.t lang_src)
             (st_tgt0: SeqState.t lang_tgt): Prop :=
    forall o (WF: Oracle.wf o),
    exists th tr w,
      (<<STEPS: SeqThread.steps (@SeqState.na_step _) tr (SeqThread.mk st_src0 p0 o) th>>) /\
      (<<TRACE: SeqThread.writing_trace tr w>>) /\
      ((<<FLAGS: Flags.le (Flags.join d0 st_tgt0.(SeqState.memory).(SeqMemory.flags)) (Flags.join w th.(SeqThread.state).(SeqState.memory).(SeqMemory.flags))>>) \/ (<<FAILURE: SeqThread.failure (@SeqState.na_step _) th>>))
  .

  Definition sim_seq_failure_case
             (p0: Perms.t)
             (st_src0: SeqState.t lang_src): Prop :=
    forall o (WF: Oracle.wf o),
    exists th tr w,
      (<<STEPS: SeqThread.steps (@SeqState.na_step _) tr (SeqThread.mk st_src0 p0 o) th>>) /\
      (<<TRACE: SeqThread.writing_trace tr w>>) /\
      (<<FAILURE: SeqThread.failure (@SeqState.na_step _) th>>)
  .

  Lemma sim_seq_partial_imm p d st_src st_tgt
        (FLAGS: Flags.le (Flags.join d st_tgt.(SeqState.memory).(SeqMemory.flags)) st_src.(SeqState.memory).(SeqMemory.flags))
    :
      sim_seq_partial_case p d st_src st_tgt.
  Proof.
    ii. esplits; [econs 1|econs|]; eauto.
  Qed.
End LANG.

Section SIM.
  Variant _sim_seq
          (sim_seq:
             forall
               (lang_src: language) (lang_tgt: language)
               (sim_terminal: forall (st_src:(Language.state lang_src)) (st_tgt:(Language.state lang_tgt)), Prop)
               (p0: Perms.t) (d0: Flags.t)
               (st_src0: SeqState.t lang_src)
               (st_tgt0: SeqState.t lang_tgt), Prop)
          (lang_src: language) (lang_tgt: language)
          (sim_terminal: forall (st_src:(Language.state lang_src)) (st_tgt:(Language.state lang_tgt)), Prop)
          (p0: Perms.t) (d0: Flags.t)
          (st_src0: SeqState.t lang_src)
          (st_tgt0: SeqState.t lang_tgt): Prop :=
  | sim_seq_normal
      (TERMINAL: sim_seq_terminal_case sim_terminal p0 d0 st_src0 st_tgt0)
      (NASTEP: sim_seq_na_step_case (sim_seq _ _ sim_terminal) p0 d0 st_src0 st_tgt0)
      (ATSTEP: sim_seq_at_step_case (sim_seq _ _ sim_terminal) p0 d0 st_src0 st_tgt0)
      (PARTIAL: sim_seq_partial_case p0 d0 st_src0 st_tgt0)
  | sim_seq_failure
      (FAILURE: sim_seq_failure_case p0 st_src0)
  .

  Variant sim_seq_weak
          (sim_seq:
             forall
               (lang_src: language) (lang_tgt: language)
               (sim_terminal: forall (st_src:(Language.state lang_src)) (st_tgt:(Language.state lang_tgt)), Prop)
               (p0: Perms.t) (d0: Flags.t)
               (st_src0: SeqState.t lang_src)
               (st_tgt0: SeqState.t lang_tgt), Prop)
          (lang_src: language) (lang_tgt: language)
          (sim_terminal: forall (st_src:(Language.state lang_src)) (st_tgt:(Language.state lang_tgt)), Prop)
          (p0: Perms.t) (d0: Flags.t)
          (st_src0: SeqState.t lang_src)
          (st_tgt0: SeqState.t lang_tgt): Prop :=
  | sim_seq_weak_normal
      (TERMINAL: sim_seq_terminal_case sim_terminal p0 d0 st_src0 st_tgt0)
      (NASTEP: sim_seq_na_step_case (sim_seq _ _ sim_terminal) p0 d0 st_src0 st_tgt0)
      (ATSTEP: sim_seq_at_step_case (sim_seq _ _ sim_terminal) p0 d0 st_src0 st_tgt0)
  | sim_seq_weak_failure
      (FAILURE: sim_seq_failure_case p0 st_src0)
  .

  Definition sim_seq := paco7 _sim_seq bot7.
  Arguments sim_seq: clear implicits.

  Lemma sim_seq_mon: monotone7 _sim_seq.
  Proof.
    ii. inv IN.
    { econs 1; eauto.
      { ii. exploit NASTEP; eauto. i. des. esplits; eauto. }
      { ii. exploit ATSTEP; eauto. i. des. esplits; eauto.
        i. hexploit SIM; eauto. i. des. esplits; eauto. }
    }
    { econs 2; eauto. }
  Qed.
  Lemma sim_seq_weak_mon: monotone7 sim_seq_weak.
  Proof.
    ii. inv IN.
    { econs 1; eauto.
      { ii. exploit NASTEP; eauto. i. des. esplits; eauto. }
      { ii. exploit ATSTEP; eauto. i. des. esplits; eauto.
        i. exploit SIM; eauto. i. des. esplits; eauto.
      }
    }
    { econs 2; eauto. }
  Qed.

  Lemma sim_seq_failure_imm lang_src lang_tgt sim_terminal
        p0 d st_src0 st_tgt0 st_src1
        (FAILURE: SeqState.na_step p0 MachineEvent.failure st_src0 st_src1)
    :
      @sim_seq lang_src lang_tgt sim_terminal p0 d st_src0 st_tgt0.
  Proof.
    pfold. right. red. i. esplits; [econs 1|econs|].
    red. esplits. econs. eauto.
  Qed.

  Definition sim_seq_all lang_src lang_tgt sim_terminal
             (st_src: lang_src.(Language.state)) (st_tgt: lang_tgt.(Language.state)): Prop :=
    forall p m,
      @sim_seq
        _ _
        sim_terminal
        p Flags.bot
        (SeqState.mk _ st_src m)
        (SeqState.mk _ st_tgt m).
End SIM.
End SIMULATION.
Arguments sim_seq [_] [_] _ _ _.
#[export] Hint Resolve sim_seq_mon: paco.
#[export] Hint Resolve sim_seq_weak_mon: paco.
#[export] Hint Resolve cpn7_wcompat: paco.

Arguments sim_seq_all [lang_src] [lang_tgt] sim_terminal st_src st_tgt.

Lemma sim_seq_all_refl lang (prog: lang.(Language.state))
  :
    @sim_seq_all _ _ eq prog prog.
Proof.
  ii. generalize (@SeqState.mk lang prog m). revert p. clear prog m.
  pcofix CIH. pfold. econs.
  { ii. esplits; eauto.
    { refl. }
    { refl. }
  }
  { ii. esplits; eauto.
    { econs; eauto. }
  }
  { ii. esplits; eauto.
    { refl. }
    { i. esplits; eauto. eapply SeqEvent.input_match_bot. }
  }
  { ii. esplits; eauto.
    { econs. }
    { econs. }
    { left. ss. refl. }
  }
Qed.

Lemma sim_seq_all_mon lang_src lang_tgt
      (prog_src: lang_src.(Language.state)) (prog_tgt: lang_tgt.(Language.state))
      (sim_terminal0 sim_terminal1: lang_src.(Language.state) -> lang_tgt.(Language.state) -> Prop)
      (SIM: sim_seq_all sim_terminal0 prog_src prog_tgt)
      (LE: sim_terminal0 <2= sim_terminal1)
  :
    sim_seq_all sim_terminal1 prog_src prog_tgt.
Proof.
  ii. specialize (SIM p m). revert SIM.
  generalize Flags.bot (@SeqState.mk _ prog_src m) (@SeqState.mk _ prog_tgt m).
  revert p m. pcofix CIH. i.
  pfold. punfold SIM. inv SIM.
  { econs 1.
    { ii. exploit TERMINAL; eauto. i. des. esplits; eauto. }
    { ii. exploit NASTEP; eauto. i. des. pclearbot. esplits; eauto. }
    { ii. exploit ATSTEP; eauto. i. des. esplits; eauto.
      i. hexploit SIM; eauto. i. des. pclearbot. esplits; eauto.
    }
    { auto. }
  }
  { econs 2; eauto. }
Qed.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq tuple fintype.
Require Import ZArith zint.
Require Export Setoid Relation_Definitions.

Require Import WhileLang TrfState.

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

Definition ident := positive.

Open Scope Z_scope.

Definition okSC_idx : Z := (-1).
Definition clSC_idx : Z := (-2).
Definition crSC_idx : Z := (-3).

Definition okSC (s:trfState) : Z := sc s (-1).
Definition clSC (s:trfState) : Z := sc s (-2).
Definition crSC (s:trfState) : Z := sc s (-3).
Definition leakSC (s:trfState) (i:Z) : Z := sc s i.

Section SCtrf.

Variable ops: opSig.

Record LeakSpec :=
 { lFun :> @LeakFun ops
 ; preleak: expr ops -> seq (expr ops)
 ; preleak_ren: forall f e,
     preleak (ren_expr f e) = map (ren_expr f) (preleak e)
 ; preleak_prod: forall s1 s2 e,
     (leak_expr preleak s1 e == leak_expr preleak s2 e)
     = (leak_expr lFun s1 e == leak_expr lFun s2 e)
 }.

Variable lspec: LeakSpec.

Definition ok_lvalue: lvalue ops := Var xH.
Definition okSC_lvalue := ArrCell xH (@Const ops okSC_idx).
Definition clSC_lvalue := ArrCell xH (@Const ops clSC_idx).
Definition crSC_lvalue := ArrCell xH (@Const ops crSC_idx).
Definition leakSC_lvalue (e: expr ops) : lvalue ops := ArrCell xH e.
Definition ok_expr: expr ops := ValOf ok_lvalue.
Definition okSC_expr: expr ops := ValOf okSC_lvalue.
Definition clSC_expr: expr ops := ValOf clSC_lvalue.
Definition crSC_expr: expr ops := ValOf crSC_lvalue.
Definition leakSC_expr (e: expr ops) : expr ops := ValOf (leakSC_lvalue e).

Definition initSC: cmd ops :=
 Seq (Assign okSC_lvalue (Const 1))
     (Seq (Assign clSC_lvalue (Const 0))
          (Assign crSC_lvalue (Const 0))).

Definition okSC_upd (e: expr ops) : cmd ops :=
 Assign okSC_lvalue (And okSC_expr e).
Definition clSC_inc : cmd ops :=
 Assign clSC_lvalue (Minus clSC_expr (Const (-1))).
Definition crSC_inc : cmd ops :=
 Assign crSC_lvalue (Minus crSC_expr (Const (-1))).

(** registers the (pre)leakage of an expression *)

Definition regVal (e: expr ops) : cmd ops :=
 Seq (Assign (leakSC_lvalue clSC_expr) e) clSC_inc.

(** checks the (pre)leakage of an expression against registered one *)

Definition chkVal (e: expr ops) : cmd ops :=
 Seq (okSC_upd (Equal (leakSC_expr crSC_expr) e)) crSC_inc.

Fixpoint procLeak (side:bool) (l: seq (expr ops)) : cmd ops :=
 match l, side with
 | [::], _ => @Skip ops
 | e::es, false => Seq (regVal e) (procLeak side es)
 | e::es, true => Seq (chkVal e) (procLeak side es)
 end.

Fixpoint mirror (side:bool) (c: cmd ops) {struct c} : cmd ops :=
 match c with
 | Skip => @Skip ops
 | Assert e => Assert (ren_expr side e)
 | Assume e => Assume (ren_expr side e)
 | Assign x e => Seq (Seq (procLeak side (preleak lspec (ren_expr side (ValOf x))))
                          (procLeak side (preleak lspec (ren_expr side e))))
                     (Assign (ren_lvalue side x) (ren_expr side e))
 | Seq c1 c2 => Seq (mirror side c1) (mirror side c2)
 | If b c1 c2 => Seq (Seq (procLeak side (preleak lspec (ren_expr side b)))
                          (procLeak side [:: IsTrue (ren_expr side b)]))
                     (If (ren_expr side b) (mirror side c1) (mirror side c2))
 | While b c1 =>
    Seq (Seq (procLeak side (preleak lspec (ren_expr side b)))
             (procLeak side [:: IsTrue (ren_expr side b)]))
        (While (ren_expr side b)
               (Seq (mirror side c1)
                    (Seq (procLeak side (preleak lspec (ren_expr side b)))
                         (procLeak side [:: IsTrue (ren_expr side b)]))))
 end.

Definition selfComp (c: cmd ops) : cmd ops :=
 Seq (Seq initSC (Seq (mirror false c) (mirror true c)))
     (okSC_upd (Equal clSC_expr crSC_expr)).

Fixpoint matchLeak side (st:trfState) (start:Z) (l: seq Z) :=
 match l with
 | [::] => start == (if side then crSC st else clSC st)
 | (x::xs) => (x==leakSC st start) && (matchLeak side st (start+1) xs)
 end.

Inductive mirror1_spec : seq Z -> trfState -> trfState -> Prop :=
 | mirror1_nil: forall st, mirror1_spec [::] st st
 | mirror1_cons: forall x xs st st',
     mirror1_spec xs (mkTrfSt (ok st) (upd (upd (leakSC st) (clSC st) x)
                                           clSC_idx (clSC st + 1))) st' ->
     mirror1_spec (x::xs) st st'.

Inductive mirror2_spec : seq Z -> trfState -> trfState -> Prop :=
 | mirror2_nil: forall st, mirror2_spec [::] st st
 | mirror2_cons: forall x xs st st',
     mirror2_spec xs (mkTrfSt (ok st)
                              (upd (upd (leakSC st) okSC_idx
                                        (if x==leakSC st crSC_idx
                                         then okSC st
                                         else 0))
                                   crSC_idx (crSC st + 1))) st' ->
     mirror2_spec (x::xs) st st'.

(*
mirror1_spec_cat:
mirror1_spec l1 st1 st2 -> mirror1_spec l2 st2 st3 ->
mirror1_spec (l1++l2) st1 st3.

procLeak1_spec:

exists ll,
 eval_cmd lspec (joinState (s1,s2,st))
   (procLeak false (preleak lspec (ren_expr false e)))
   ll (joinState (s1,s2,updLeakL st (leak_expr lspec (ren_expr false e))))
                        ========

Fixpoint updLeakL st l :=
 match l with
 | [::] => st
 | (x::xs) =>
    updLeakL (mkTrfSt (ok st) (upd (upd (leakSC st) (clSC st) x)
                                   clSC_idx (clSC st + 1)))
             xs
 end.
*)

Lemma mirror1_sound: forall c s1 s2 st l1 s1',
 eval_cmd lspec s1 c l1 (Some s1') ->
 exists ll st',
  eval_cmd lspec (joinState (s1,s2,st)) (mirror false c) ll
                 (Some (joinState (s1',s2,st')))
  /\ mirror1_spec l1 st st'.
Proof.
move => c s1 s2 st l1 s1' /eval_cmd_feval [n H].
elim: n s1 s1' l1 c H => //.
move => n IH s1 s1' l1 [|e|e|x e|c1 c2|b c1 c2|b c] /=.
- (* Skip *)
  admit.
- (* Assume *)
  admit.
- (* Assert *)
  admit.
- (* Assign *)
  move => [<- <-].
  admit.
- (* Seq *)
  admit.
- (* If *)
  admit.
- (* While *)
  admit.
Qed.

Lemma mirror1_complete: forall c s1 s2 st l1 ll s',
 eval_cmd lspec (joinState (s1,s2,st)) (mirror false c) ll
                (Some s') ->
 mirror1_spec l1 st (splitState s').2 ->
 eval_cmd lspec s1 c l1 (Some (splitState s').1.1).
Proof.
admit (*
move => c s1 s2 st l1 s1' /eval_cmd_feval [n H].
elim: n s1 s1' l1 c H => //.
move => n IH s1 s1' l1 [|e|e|x e|c1 c2|b c1 c2|b c] /=.
- (* Skip *)
  admit.
- (* Assume *)
  admit.
- (* Assert *)
  admit.
- (* Assign *)
  move => [<- <-].
  admit.
- (* Seq *)
  admit.
- (* If *)
  admit.
- (* While *)
  admit.
*).
Qed.

Lemma mirror2_sound: forall c s1 s2 st l2 s2',
 eval_cmd lspec s2 c l2 (Some s2') ->
 exists ll st',
  eval_cmd lspec (joinState (s1,s2,st)) (mirror true c) ll
                 (Some (joinState (s1,s2',st')))
  /\ mirror2_spec l2 st st'.
Proof.
move => c s1 s2 st l2 s2' /eval_cmd_feval [n H].
elim: n s2 s2' l2 c H => //.
move => n IH s2 s2' l2 [|e|e|x e|c1 c2|b c1 c2|b c] /=.
- (* Skip *)
  admit.
- (* Assume *)
  admit.
- (* Assert *)
  admit.
- (* Assign *)
  move => [<- <-].
  admit.
- (* Seq *)
  admit.
- (* If *)
  admit.
- (* While *)
  admit.
Qed.

Lemma mirror2_complete: forall c s1 s2 st l2 ll s',
 eval_cmd lspec (joinState (s1,s2,st)) (mirror true c) ll
                (Some s') ->
 mirror2_spec l2 st (splitState s').2 ->
 eval_cmd lspec s2 c l2 (Some (splitState s').1.2).
Proof.
admit (*
move => c s1 s2 st l1 s1' /eval_cmd_feval [n H].
elim: n s1 s1' l1 c H => //.
move => n IH s1 s1' l1 [|e|e|x e|c1 c2|b c1 c2|b c] /=.
- (* Skip *)
  admit.
- (* Assume *)
  admit.
- (* Assert *)
  admit.
- (* Assign *)
  move => [<- <-].
  admit.
- (* Seq *)
  admit.
- (* If *)
  admit.
- (* While *)
  admit.
*).
Qed.

Theorem selfComp_sound1':
 forall n (c:cmd ops) ts (s1 s1' s2 s2': State) l1 l2,
 feval_cmd lspec n c s1 = Some (Some s1',l1) ->
 feval_cmd lspec n c s2 = Some (Some s2',l2) ->
 exists s' l',
  [/\ eval_cmd lspec (joinState (s1,s2,ts)) (selfComp c) l'
                     (Some s'),
      eqstate s1' (splitState s').1.1
    & eqstate s2' (splitState s').1.2 ].
Proof.
elim => //= n IH.
move => [|e|e|x e|c1 c2|b c1 c2|b c] ts s1 s1' s2 s2' l1 l2 /=.
- move=> [<- El1] [<- El2]; rewrite /selfComp.
  admit.
- admit.
- admit.
- admit.
- admit.
- admit.
- admit.
Qed.

Theorem selfComp_sound1:
 forall (c:cmd ops) ts (s1 s1' s2 s2': State) l1 l2,
 eval_cmd lspec s1 c l1 (Some s1') ->
 eval_cmd lspec s2 c l2 (Some s2') ->
 exists s' l',
  [/\ eval_cmd lspec (joinState (s1,s2,ts)) (selfComp c) l'
                     (Some s'),
      eqstate s1' (splitState s').1.1
    & eqstate s2' (splitState s').1.2 ].
Proof.
rewrite /selfComp => c ts s1 s1' s2 s2' l1 l2
 /eval_cmd_feval [n1 H1] /eval_cmd_feval [n2 H2].
apply selfComp_sound1' with (maxn n1 n2) l1 l2.
 apply feval_cmd_weak with n1 => //.
 by apply leq_maxl.
apply feval_cmd_weak with n2 => //.
by apply leq_maxr.
Qed.

Theorem selfComp_complete:
 forall (c:cmd ops) ts1 (s11 s12 s2: State) l1 l2 l',
 eval_cmd lspec (joinState (s11,s12,ts1)) (selfComp c) l' (Some s2) ->
 [/\ eval_cmd lspec s11 c l1 (Some (splitState s2).1.1),
     eval_cmd lspec s12 c l2 (Some (splitState s2).1.2)
   & l1==l2 = (eval_expr s2 okSC_expr != 0)].
Admitted.

Theorem selfComp_sound2:
 forall (c:cmd ops) ts ts' (s1 s1' s2 s2': State) l1 l2 l',
 eval_cmd lspec s1 c l1 (Some s1') ->
 eval_cmd lspec s2 c l2 (Some s2') ->
 eval_cmd lspec (joinState (s1,s2,ts)) (selfComp c) l'
                (Some (joinState (s1',s2',ts'))) ->
 l1==l2 = (eval_expr (joinState (s1',s2',ts')) okSC_expr != 0).
Proof.
move=> c ts ts' s1 s1' s2 s2' l1 l2 ll H1 H2
 /eval_cmd_feval [n H].
move: (selfComp_sound1 ts H1 H2) => [s' [l' [HH Es1 Es2]]].
move: (HH).
apply selfComp_complete with (l1:=l1) (l2:=l2) in HH.
move: HH => [HH1 HH2 HH3] HH.
admit (* determinism *).
Qed.

Theorem selfComp_imgN:
 forall (c:cmd ops) s ll,
   eval_cmd lspec s (selfComp c) ll None ->
   (exists l1, eval_cmd lspec (splitState s).1.1 c l1 None)
   \/ (exists l2, eval_cmd lspec (splitState s).1.2 c l2 None).
Proof.
rewrite /selfComp => c s ll
 /eval_cmd_SeqNI [/eval_cmd_SeqNI [H|H]|[s' [l1 [l2 [H1 H2]]]]];
 last first.
  admit (* absurd H2 *).
 admit (* main case *).
admit (* absurd H *).
Qed.

End SCtrf.

Arguments ok_lvalue [ops].
Arguments okSC_lvalue [ops].
Arguments clSC_lvalue [ops].
Arguments crSC_lvalue [ops].
Arguments leakSC_lvalue [ops] _.
Arguments ok_expr [ops].
Arguments okSC_expr [ops].
Arguments clSC_expr [ops].
Arguments crSC_expr [ops].
Arguments leakSC_expr [ops] _.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Deterministic
        Typing.

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

Lemma eq_type: forall A,
 (A = t_dyn) \/ ~(A = t_dyn).
Proof.
  introv.
  inductions A;
  try solve[left;
  reflexivity];
  try solve[right;
  unfold not; intros H;
  inverts* H].
Qed.

Lemma Tred_value: forall v v' A,
  value v->
  TypedReduce v A (e_exp v') ->
  value v'.
Proof.
  introv Val Red.
  inductions Red; eauto.
  - apply value_dyn; eauto.
    inverts H.
    inverts H1.
    inverts Val; inverts* H2.
    eapply value_fanno; eauto.
    reflexivity.
    eapply value_fanno; eauto.
    reflexivity.
    eapply value_fanno; eauto.
    reflexivity.
    eapply value_fanno; eauto.
    reflexivity.
  - inverts Val.
    inverts H.
    inverts H4.
    inverts* H5.
    inverts* H0.
    rewrite <- H5 in H2.
    inverts H2.
  - inverts* Val.
Qed.

Theorem tred_progress: forall v A,
 value v -> Typing nil v Chk A -> (exists v', (TypedReduce v A (e_exp v'))) \/ (TypedReduce v A (e_blame)).
Proof.
  introv val sim. gen A.
  inductions val; intros.
  - inverts sim. inverts H.
    inductions A; simpl in H0; inverts H0.
    left.
    exists*.
    left.
    exists*.
  - inverts sim. inverts H.
    inductions A; simpl in H0; inverts H0.
    left.
    exists.
    eapply TReduce_abs.
    apply S_arr.
    apply H4.
    apply H6.
    reflexivity.
    left.
    exists.
    eapply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    simpl; unfold not; intros.
    inverts H.
    split.
    simpl; unfold not; intros.
    inverts H.
    simpl; eauto.
  - inverts sim. inverts H.
    inductions A; simpl in H0; inverts H0.
    left.
    exists.
    eapply TReduce_abs.
    apply S_arr.
    apply H4.
    apply H6.
    reflexivity.
    left.
    exists.
    eapply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    simpl; unfold not; intros.
    inverts H.
    split.
    simpl; unfold not; intros.
    inverts H.
    simpl; eauto.
  - inverts sim. inverts H0.
    inductions A0; simpl in H1; inverts H1.
    left.
    exists.
    eapply TReduce_abs.
    apply S_arr.
    apply H4.
    apply H6.
    reflexivity.
    left.
    destruct (eq_type A).
    destruct (eq_type B).
    subst*.
    exists.
    eapply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    simpl; unfold not; intros.
    inverts H2.
    split.
    simpl; unfold not; intros.
    inverts H2.
    simpl; eauto.
    eauto.
    exists.
    eapply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    simpl; unfold not; intros.
    inverts H1.
    split.
    simpl; unfold not; intros.
    inverts H1.
    simpl; eauto.
    eauto.
  - inverts sim. inverts H0.
    inductions A0; simpl in H1; inverts H1.
    left.
    exists.
    eapply TReduce_abs.
    apply S_arr.
    apply H5.
    apply H7.
    reflexivity.
    destruct (eq_type A).
    destruct (eq_type B).
    subst*.
    left.
    exists.
    eapply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    simpl; unfold not; intros.
    inverts H2.
    split.
    simpl; unfold not; intros.
    inverts H2.
    simpl; eauto.
    eauto.
    left.
    exists.
    eapply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    simpl; unfold not; intros.
    inverts H1.
    split.
    simpl; unfold not; intros.
    inverts H1.
    simpl; eauto.
    eauto.
  - inductions A.
    + inverts val; inverts H.
      left.
      exists.
      eapply TReduce_vany; eauto.
      right.
      eapply TReduce_blame; eauto.
      simpl. unfold not; intros.
      inverts H.
      right.
      eapply TReduce_blame; eauto.
      simpl. unfold not; intros.
      inverts H.
    + destruct (eq_type A1).
      destruct (eq_type A2).
      subst.
      inverts val; inverts H.
      right.
      eapply TReduce_blame; eauto.
      simpl. unfold not; intros.
      inverts H.
      left.
      exists.
      eapply TReduce_vany; eauto.
      left.
      exists.
      eapply TReduce_vany; eauto.
      inverts val; inverts H.
      right.
      eapply TReduce_blame; eauto.
      simpl. unfold not; intros.
      inverts H.
      left.
      exists.
      eapply TReduce_dyna; eauto.
      unfold FLike.
     split.
     simpl; unfold not; intros.
     inverts H.
     split.
     simpl; unfold not; intros.
     inverts H.
     simpl; eauto.
     simpl; eauto.
     simpl. eauto.
      left.
      exists.
      eapply TReduce_dyna; eauto.
      unfold FLike.
     split.
     simpl; unfold not; intros.
     inverts H.
     split.
     simpl; unfold not; intros.
     inverts H.
     simpl; eauto.
     simpl; eauto.
     simpl. eauto.
      inverts H.
      right.
      eapply TReduce_blame; eauto.
      simpl. unfold not; intros.
      inverts H.
      rewrite <- H4 in H2.
      inverts* H2.
      rewrite <- H4 in H2.
      inverts* H2.
      left.
      exists.
      eapply TReduce_dyna; eauto.
      unfold FLike.
     split.
     simpl; unfold not; intros.
     inverts H.
     split.
     simpl; unfold not; intros.
     inverts H.
     apply H0. reflexivity.
     eauto.
     rewrite <- H2.
     eauto.
    + left. exists.
      eapply TReduce_dd; eauto.
      apply value_lc; eauto.
Qed.

Lemma TypedReduce_sim: forall v A r B,
    value v -> TypedReduce v A r -> Typing nil v Inf B -> sim B A.
Proof with auto.
  introv Val Red Typ.
  gen B.
  lets Red': Red.
  inductions Red; introv Typ;
  lets Lc : Typing_regular_1 Typ;
  try solve [constructor*];
  try solve [inverts* Typ].
  forwards*: principle_inf Typ.
  rewrite H1 in H0.
  rewrite H0.
  auto.
Qed.

Lemma TypedReduce_preservation: forall v A v' B,
    value v -> TypedReduce v A (e_exp v') -> Typing nil v Chk B -> Typing nil v' Inf A.
Proof with auto.
  introv Val Red Typ'.
  gen B.
  lets Red': Red.
  inductions Red; introv Typ;
  lets Lc : Typing_regular_1 Typ;
  try solve [constructor*];
  try solve [inverts* Typ].
  + apply Typ_anno; eauto.
    inverts* Typ.
    forwards*: principle_inf H1.
    rewrite H0 in H3.
    rewrite <- H3 in H1.
    eapply Typ_sim.
    apply H1.
    auto.
  + apply Typ_anno; eauto.
    inverts* Typ.
    inverts* H0.
  + inverts* Typ.
    apply Typ_anno; eauto.
    forwards*: principle_inf H0.
    rewrite H2 in H.
    eapply Typ_sim; eauto.
    apply Typ_anno; eauto.
    eapply Typ_sim; eauto.
    inverts* H.
  + inverts* Typ.
    inverts* H1.
    inverts* H5.
    inverts Val.
    forwards*: principle_inf H1.
    apply Typ_anno; eauto.
    eapply Typ_sim; eauto.
    rewrite H4 in H0.
    auto.
  + inverts* Typ.
    inverts* H.
    inverts* Val.
    inverts* H3.
    forwards*: principle_inf H.
    rewrite H3.
    auto.
Qed.

Theorem preservation : forall e e' dir A,
    Typing nil e dir A ->
    step e (e_exp e') ->
    Typing nil e' dir A.
Proof.
  introv Typ Red. gen A dir.
  inductions Red; intros.
  - inductions E; unfold fill in *.
  + inverts Typ.
    forwards*: IHRed H3.
    inverts H0.
    forwards*: IHRed H5.
  + inverts Typ.
    forwards*: IHRed H6.
    inverts H0.
    forwards*: IHRed H6.
  + inverts Typ.
    forwards*: IHRed H5.
    inverts H0.
    forwards*: IHRed H4.
  - inverts Typ.
    inverts H5.
    pick fresh y.
    apply Typ_anno.
    rewrite (subst_exp_intro y); eauto.
    eapply typing_c_subst_simpl; eauto.
    forwards*: TypedReduce_preservation H1.
    inverts H2. inverts H7.
    pick fresh x.
    eapply Typ_sim.
    apply Typ_anno.
    rewrite (subst_exp_intro x); eauto.
    eapply typing_c_subst_simpl; eauto.
    forwards*: TypedReduce_preservation H1.
    auto.
  - inverts Typ.
    forwards*: TypedReduce_preservation H0.
    inverts H2.
    forwards*: TypedReduce_preservation H0.
  - inverts Typ.
    forwards*: TypedReduce_preservation H7.
    inverts H4.
    apply Typ_addl; eauto.
    inverts H1.
    inverts H6.
    eapply Typ_sim.
    apply Typ_addl; eauto.
    auto.
  - inverts Typ.
    forwards*: TypedReduce_preservation H0.
    inverts H4.
    apply Typ_lit; eauto.
    inverts H1.
    inverts H6.
    eapply Typ_sim.
    apply Typ_lit; eauto.
    auto.
  - inverts Typ.
    forwards*: TypedReduce_preservation H0.
    inverts H5.
    inverts H9.
    inverts H.
    inverts H4.
    apply Typ_anno; eauto.
    apply Typ_sim with (A:= B); eauto.
    apply Typ_app with (A := A2); eauto.
    apply Typ_sim with (A := A1); eauto.
    apply BA_AB; auto.
    forwards*: principle_inf H3.
    rewrite H in H10.
    inverts H10.
    inverts H2.
    forwards*: TypedReduce_preservation H0.
    inverts H.
    inverts H7.
    inverts H11.
    inverts H4.
    apply Typ_sim with (A:= A1); eauto.
    apply Typ_anno; eauto.
    apply Typ_sim with (A:= B); eauto.
    apply Typ_app with (A := A3); eauto.
    apply Typ_sim with (A := A2); eauto.
    apply BA_AB; auto.
    forwards*: principle_inf H.
    rewrite H4 in H10.
    inverts H10.
Qed.

Theorem preservation_multi_step : forall t t' dir  T,
    Typing nil t dir T ->
    t ->** (e_exp t') ->
    Typing nil t' dir T.
Proof.
  introv Typ Red.
  inductions Red; eauto.
  lets*: preservation Typ H.
Qed.

Lemma sim_decidable:forall A B,
sim A B \/ ~ (sim A B).
Proof.
  introv.
  gen A.
  inductions B; intros; eauto.
  - inductions A; eauto.
    right.
    unfold not;
    intros.
    inverts* H.
  - inductions A; eauto.
    right.
    unfold not;
    intros.
    inverts* H.
    forwards*: IHB1 A1.
    forwards*: IHB2 A2.
    destruct H.
    destruct H0.
    left.
    eauto.
    right.
    unfold not;
    intros.
    inverts* H1.
    destruct H0.
    right.
    unfold not;
    intros.
    inverts* H1.
    right.
    unfold not;
    intros.
    inverts* H1.
Qed.

Lemma TypedReduce_progress: forall v A,
    value v -> Typing [] v Chk A -> exists r, TypedReduce v A r.
Proof.
  intros v A Val Typ. gen A.
  inductions Val; intros.
  - inverts Typ.
    inverts H.
    inductions A; inverts H0; eauto.
  - inverts Typ.
    inverts H.
    inductions A; inverts H0; eauto.
    exists.
    apply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    unfold not; intros H;
    inverts* H.
    split.
    unfold not; intros H;
    inverts* H.
    eauto.
  - inverts Typ.
    inverts H.
    inductions A; inverts H0; eauto.
    exists.
    apply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    unfold not; intros H;
    inverts* H.
    split.
    unfold not; intros H;
    inverts* H.
    eauto.
  - inverts Typ.
    inverts H0.
    inductions A0; inverts H1; eauto.
    destruct (eq_type A).
    destruct (eq_type B).
    subst*.
    exists.
    apply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H2.
    split.
    unfold not; intros H2;
    inverts* H2.
    eauto.
    exists.
    apply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H1.
    split.
    unfold not; intros H2;
    inverts* H2.
    eauto.
  - inverts Typ.
    inverts H0.
    inductions A0; inverts H1; eauto.
    destruct (eq_type A).
    destruct (eq_type B).
    subst*.
    exists.
    apply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H2.
    split.
    unfold not; intros H2;
    inverts* H2.
    eauto.
    exists.
    apply TReduce_anyd; eauto.
    simpl.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H1.
    split.
    unfold not; intros H2;
    inverts* H2.
    eauto.
  - inverts Typ.
    inverts H0.
    inverts H4.
    inductions A; eauto.
    inverts* Val; inverts* H.
    exists.
    apply TReduce_vany; eauto.
    exists.
    apply TReduce_blame; eauto.
    simpl.
    unfold not; intros.
    inverts H.
    exists.
    apply TReduce_blame; eauto.
    simpl.
    unfold not; intros.
    inverts H.
    inverts* Val; inverts* H.
    exists.
    apply TReduce_blame; eauto.
    simpl.
    unfold not; intros.
    inverts H.
    destruct (eq_type A1).
    destruct (eq_type A2).
    subst.
    exists.
    apply TReduce_vany; eauto.
    exists.
    apply TReduce_dyna; eauto.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H5.
    split.
    unfold not; intros;
    inverts* H5.
    eauto.
    simpl. eauto.
    exists.
    apply TReduce_dyna; eauto.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H4.
    split.
    unfold not; intros;
    inverts* H4.
    eauto.
    simpl. eauto.
    destruct (eq_type A1).
    destruct (eq_type A2).
    subst.
    exists.
    apply TReduce_vany; eauto.
    exists.
    apply TReduce_dyna; eauto.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H6.
    split.
    unfold not; intros;
    inverts* H6.
    eauto.
    simpl. eauto.
    exists.
    apply TReduce_dyna; eauto.
    unfold FLike.
    split.
    unfold not; intros.
    inverts* H5.
    split.
    unfold not; intros;
    inverts* H5.
    eauto.
    simpl. eauto.
    exists.
    apply TReduce_dd; eauto.
    apply value_lc; auto.
Qed.

Theorem progress : forall e dir T,
    Typing nil e dir T ->
    value e \/ (exists r, step e r).
Proof.
  introv Typ. lets Typ': Typ.
  inductions Typ;
      lets Lc  : Typing_regular_1 Typ';
      try solve [left*];
      try solve [right*].
  - Case "var".
    inverts* H0.
  - right. inverts Lc.
    lets* [Val1 | [e1' Red1]]: IHTyp1.
    lets* [Val2 | [e2' Red2]]: IHTyp2.
    inverts* Typ1;
    try solve [ inverts Val1 ].
    +
      forwards*: TypedReduce_progress Typ2.
      destruct H.
      inductions x.
      exists.
      apply Step_beta; eauto.
      exists. apply Step_betap; eauto.
    + forwards*: TypedReduce_progress Typ2.
      destruct H.
      inductions x.
      inverts Typ2.
      inverts Val2;
      inverts H0; inverts H3.
      exists. apply Step_add; eauto. inverts H. inverts H7.
      inverts H0. inverts H7.
      inverts H6 ; inverts H7.
      exists. apply Step_add; eauto.
      apply TReduce_vany; eauto.
      exists. apply Step_addp; eauto.
    + forwards*: TypedReduce_progress Typ2.
      destruct H.
      inductions x.
      inverts Typ2.
      inverts Val2;
      inverts H0; inverts H3.
      exists. apply Step_addl; eauto. inverts H. inverts H7.
      inverts H0. inverts H7.
      inverts H6 ; inverts H7.
      exists. apply Step_addl; eauto.
      apply TReduce_vany; eauto.
      exists. apply Step_addlp; eauto.
    + forwards*: TypedReduce_progress Typ2.
      destruct H0.
      inductions x.
      exists. apply Step_abeta; eauto.
      exists. apply Step_abetap; eauto.
    + inductions e2'.
      assert(fill ((appCtxR e1)) e2 = e_app e1 e2); eauto.
      rewrite <- H.
      exists. apply do_step; eauto.
      assert(fill ((appCtxR e1)) e2 = e_app e1 e2); eauto.
      rewrite <- H.
      exists. apply blame_step; eauto.
    + inductions e1'.
      assert(fill ((appCtxL e2)) e1 = e_app e1 e2); eauto.
      rewrite <- H.
      exists. apply do_step; eauto.
      assert(fill ((appCtxL e2)) e1 = e_app e1 e2); eauto.
      rewrite <- H.
      exists. apply blame_step; eauto.
  - Case "anno".
    inverts* Lc.
    destruct~ IHTyp as [ Val | [t' Red]].
    + SCase "e_anno v A".
      forwards*: TypedReduce_progress Typ.
      destruct H.
      inverts* H.
      * right. exists.
        apply Step_annov; eauto.
        unfold not; intros nt;
        inverts* nt.
      * right. exists.
        apply Step_annov; eauto.
        unfold not; intros nt;
        inverts* nt.
        inverts* H2.
      * right. exists.
        apply Step_annov; eauto.
        unfold not; intros nt;
        inverts* nt.
        inverts* H1.
        inverts* H4.
        inverts* H5.
        rewrite <- H4 in H2.
        inverts H2.
        rewrite <- H4 in H1.
        exfalso.
        apply H1.
        reflexivity.
      * right. exists.
        apply Step_annov; eauto.
        unfold not; intros nt;
        inverts* nt.
        inverts* H5.
        inverts* H4.
      * right. exists.
        apply Step_annov; eauto.
        unfold not; intros nt;
        inverts* nt.
        inverts* H3.
        inverts* H2.
      * right. exists.
        apply Step_annov; eauto.
        unfold not; intros nt;
        inverts* nt.
        inverts* H4.
    + right.
      induction t'.
      *
        assert(fill ((annoCtx A)) e = e_anno e A); eauto.
        rewrite <- H.
        exists. apply do_step; eauto.
      *
        assert(fill ((annoCtx A)) e = e_anno e A); eauto.
        rewrite <- H.
        exists. apply blame_step; eauto.
  - forwards*: IHTyp Typ.
Qed.


Add LoadPath "vst".
Require Import CpdtTactics.
Require Import Types.
Require Import Language.
Require Export ProgramLogic.
Require Import Subst.
Require Import List.
Import ListNotations.
Require Import Coq.Unicode.Utf8.

Set Implicit Arguments.

Open Scope logic.

Definition sep_base (x:expr) (t:base_type) : assert :=
  EX v : (base_of_type t), (fun s => !!(eval s x = (val_of_base t v))) && emp.

Fixpoint sep_pred (p:reft_prop) : assert :=
  match p with
    | tt_r  => TT
    | rel_r e1 o e2 =>
      match o with
        | eq_brel => (fun s => !!(eval s e1 = eval s e2))
      end
    | not_r p => (sep_pred p) --> FF
    | and_r p1 p2 => sep_pred p1 && sep_pred p2
    | or_r p1 p2 => sep_pred p1 || sep_pred p2
  end && emp.

Definition sep_ty (x:expr) (t:reft_type) : assert :=
  match t with
  | mkReft_type b p => sep_base x b && (sep_pred (subst (subst_one ν x) p))
  end && emp.

Fixpoint sep_env (Γ : type_env) : assert :=
  match Γ with
    | nil => TT
    | (x,t) :: Γ' => sep_ty (var_e x) t && sep_env Γ'
  end && emp.

Fixpoint sep_heap (Σ : heap_env) : assert :=
  match Σ with
    | nil => emp
    | (L n, (x, t))::Σ' =>
      (eval_to (var_e (V n)) (int_v 0 )
               || (emapsto (var_e (V n)) (var_e x)
                   * sep_ty (var_e x) t)) * sep_heap Σ'
  end.

Fixpoint sep_guards (Δ : guards) : assert :=
  match Δ with
    | nil => TT
    | p :: Δ' => sep_pred p && sep_guards Δ'
  end && emp.

Definition sep_schema (f:pname) (s:stmt) (S:proc_schema) : procspec :=
  match S with
    | mkSchema xs ts hi ho (x, t) =>
      (f, mkProc xs x [] s,
          sep_env (combine xs ts) * TT,
          sep_ty (var_e x) t * TT)
  end.

Fixpoint sep_proc_env (Φ : proc_env) : procspecs :=
  match Φ with
    | nil => nil
    | (f,(s,t)) :: Φ' => sep_schema f s t :: sep_proc_env Φ'
  end.

Definition disj_subst Γ (θ : var -> expr) :=
  θ ν = (var_e ν) /\ forall x, var_in x Γ -> θ x = (var_e x).

Lemma sep_base_pure :
  forall x t,
    pure (sep_base x t).
Proof.
  intros.
  unfold pure.
  unfold sep_base.
  rewrite <- exp_andp1.
  apply andp_left2.
  apply derives_refl.
Qed.

Lemma sep_pred_pure :
  forall p,
    pure (sep_pred p).
Proof.
  intros.
  unfold pure.
  destruct p;
  unfold sep_pred; fold sep_pred; apply andp_left2; apply derives_refl.
Qed.

Lemma sep_ty_pure :
  forall x t,
    pure (sep_ty x t).
Proof.
  intros.
  unfold pure, sep_ty.
  destruct t.
  repeat apply andp_left1.
  apply sep_base_pure.
Qed.

Lemma sep_env_pure :
  forall g,
    pure (sep_env g).
Proof.
  intros.
  unfold pure.
  destruct g.
  apply andp_left2. apply derives_refl.
  unfold sep_env. fold sep_env.
  apply andp_left2. apply derives_refl.
Qed.

Lemma sep_guard_pure :
  forall g,
    pure (sep_guards g).
Proof.
  intros.
  unfold pure, sep_guards.
  destruct g.
  normalize.
  apply andp_left2.
  apply derives_refl.
Qed.