Require Export Normal.
Require Export BuildTac.

Set Implicit Arguments.

Unset Strict Implicit.

(* *********************************************************************** *)
(*                                  SEMANTICS                              *)
(* *********************************************************************** *)
Parameter scale : forall (k:nat), R.
Variable scale_pos: forall k, (0 < scale k)%R.

Inductive uop : Type := .

Inductive usupport_ (T_type:Type)
 (T_Z:T_type) (E_expr:T_type ->Type) : T_type -> Type :=
 | Gaussian : forall (i:E_expr T_Z), @usupport_ _ T_Z E_expr T_Z.

Module Sem <: SEM.

(** * User-defined type module *)
Module UT <: UTYPE.

 Definition t := Empty_set.

 Definition eqb (x y:t) := true.

 Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
 Proof.
  intros x; case x.
 Qed.

 Definition eq_dec (x y:t) : {x = y} + {True}.
  intros; case x; case y.
 Defined.

 Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
 Proof.
  intros x; case x.
 Qed.

 Definition interp (k:nat) (t0:t) : Type := Datatypes.unit.

 Definition size k (t0:t) (_:interp k t0) := S O.

 Definition default k (t0:t) : interp k t0 := tt.

 Definition default_poly (t0:t) := pcst 1.

 Lemma size_positive : forall k t0 (x:interp k t0), (0 < size x)%nat.
 Proof.
  intros; unfold size; auto with arith.
 Qed.

 Lemma default_poly_spec : forall k (t0:t),
  (size (default k t0) <= peval (default_poly t0) k)%nat.
 Proof.
  intros; unfold size, default, default_poly.
  rewrite pcst_spec; trivial.
 Qed.

 Definition i_eqb k t (_:interp k t) (_:interp k t) := true.

 Lemma i_eqb_spec : forall k t (x y:interp k t),
  if i_eqb x y then x = y else x <> y.
 Proof.
  intros; unfold i_eqb; case x; case y; trivial.
 Qed.

End UT.

Module T := MakeType UT.

(** * Module for user-defined operators *)
Module Uop <: UOP UT T.

 Definition t := uop.

 Definition eqb (o1 o2:t) : bool := true.

 Lemma eqb_spec :  forall x y, if eqb x y then x = y else x <> y.
 Proof.
  destruct x; destruct y; simpl.
 Qed.

 Definition targs (op : t) : list T.type := nil.

 Definition tres (op: t) : T.type := T.Unit.

 Definition interp_op (k:nat) (op:t) : T.type_op k (targs op) (tres op) :=
  match op as op0 return T.type_op k (targs op0) (tres op0) with
   |
  end.

 Implicit Arguments interp_op [k].

 Definition cinterp_op (k:nat) (op:t) : T.ctype_op k (targs op) (tres op) :=
  match op as op0 return T.ctype_op k (targs op0) (tres op0) with
   |
   end.

 Implicit Arguments cinterp_op [k].

 Definition eval_op k
  (op:t) (args:dlist (T.interp k) (targs op)) : T.interp k (tres op) :=
  @T.app_op k (targs op) (tres op) (interp_op op) args.

 Definition ceval_op k
  (op:t) (args:dlist (T.interp k) (targs op)) : T.interp k (tres op) * nat :=
  @T.capp_op k (targs op) (tres op) (cinterp_op op) args.

 Lemma ceval_op_spec : forall k op args,
  @eval_op k op args = fst (@ceval_op k op args).
 Proof.
  intros k o args; destruct o; simpl in args;
   T.dlist_inversion args; subst; simpl; trivial.
 Qed.

End Uop.

Module Var := MakeVar UT T.

Module Proc := MakeProc UT T.

Module O := MakeOp UT T Uop.

Module Mem := MakeMem UT T Var.

Module E := MakeExpr UT T Var Mem Uop O.

Module US <: USUPPORT UT T Var Mem Uop O E.

 Module VarP := MkEqBool_Leibniz_Theory Var.
 Module Vset := MkListSet VarP.Edec.

 Definition usupport := usupport_ T.Zt E.expr .

 Definition eval k t (s:usupport t) (m:Mem.t k) : Distr (T.interp k t) :=
  match s with
   | Gaussian a => Normal (scale k) (E.eval_expr a m)
  end.

 Definition ceval k t (s:usupport t) (m:Mem.t k) : Distr (T.interp k t) * nat :=
  match s with
   |  Gaussian a => (Normal (scale k) (E.eval_expr a m), T.size k T.Zt (E.eval_expr a m))
  end.

 Lemma ceval_spec : forall k t (s:usupport t) (m:Mem.t k),
  eval s m = fst (ceval s m).
 Proof.
  intros; case s; intros; simpl; trivial.
 Qed.

 (** TODO: add to EXPR *)
 Fixpoint fv_expr_rec (t:T.type) (res:Vset.t) (e:E.expr t) {struct e} : Vset.t :=
  match e with
   | E.Ecte _ _ => res
   | E.Evar t x => Vset.add x res
   | E.Eop op args => dfold_left fv_expr_rec args res
   | E.Eexists t x e1 e2 =>
     Vset.union
     (Vset.remove x (fv_expr_rec Vset.empty e1))
     (fv_expr_rec res e2)
   | E.Eforall t x e1 e2 =>
     Vset.union
     (Vset.remove x (fv_expr_rec Vset.empty e1))
     (fv_expr_rec res e2)
   | E.Efind t x e1 e2 =>
     Vset.union
     (Vset.remove x (fv_expr_rec Vset.empty e1))
     (fv_expr_rec res e2)
  end.

 Definition fv_expr t := @fv_expr_rec t Vset.empty.

 Let req_mem k X (m1 m2:Mem.t k) :=
  forall t (x:Var.var t), Vset.mem x X -> m1 x = m2 x.

 Lemma req_mem_weaken : forall k X X',
  Vset.subset X X' -> forall (m m':Mem.t k), req_mem X' m m' -> req_mem X m m'.
 Proof.
  unfold req_mem; intros; eauto using Vset.subset_correct.
 Qed.

 Let depend_only_distr (X:Vset.t) t (s:usupport t) :=
  forall k (m1 m2:Mem.t k),
   req_mem X m1 m2 -> eval s m1 = eval s m2.

 Let depend_only (X:Vset.t) t (e:E.expr t) :=
  forall k (m1 m2:Mem.t k), req_mem X m1 m2 -> E.eval_expr e m1 = E.eval_expr e m2.

 Axiom depend_only_fv_expr : forall t (e:E.expr t), depend_only (fv_expr e) e.

 Definition fv_distr t (s:usupport t) : Vset.t :=
  match s with
   | Gaussian a => (fv_expr a)
  end.

 Lemma depend_only_fv_distr : forall t (s:usupport t),
  depend_only_distr (fv_distr s) s.
 Proof.
  intros t s k m1 m2 Hm.
  destruct t; destruct s; simpl in *;
   ((rewrite (depend_only_fv_expr Hm); trivial) || trivial).
 Qed.

 Lemma lossless_support : forall k t (s:usupport t) (m:Mem.t k),
  mu (eval s m) (fun _ => 1)%U == 1%U.
 Proof.
  intros; destruct s.
  apply (Normal_lossless _ _).
 Qed.

 Lemma discrete_support : forall k t (s:usupport t) (m:Mem.t k),
  is_Discrete (eval s m).
 Proof.
  intros; destruct s; simpl.
  apply Normal_Discrete.
 Qed.

 Definition eqb (t1 t2:T.type) (s1:usupport t1) (s2:usupport t2) : bool :=
  match s1, s2 with
  | Gaussian a, Gaussian a' => E.eqb a a'
  end.

 Lemma eqb_spec_dep :  forall t1 (e1 : usupport t1) t2 (e2:usupport t2),
  if eqb e1 e2 then eq_dep T.type usupport t1 e1 t2 e2
  else ~eq_dep T.type usupport t1 e1 t2 e2.
 Proof.
  intros t1 u1 t2 u2; destruct u1; destruct u2; simpl.
  generalize (E.eqb_spec i i0); destruct (E.eqb i i0); intros; simpl;
   intros; subst; trivial; intro W; inversion W; tauto.
 Qed.

 Lemma eqb_spec : forall t (e1 e2:usupport t),
  if eqb e1 e2 then e1 = e2 else e1 <> e2.
 Proof.
  intros t e1 e2.
  generalize (eqb_spec_dep e1 e2).
  case (eqb e1 e2); intro H.
  apply T.eq_dep_eq; trivial.
  intro Heq; apply H; rewrite Heq; constructor.
 Qed.

End US.

Module DE := MakeDExpr UT T Var Mem Uop O E US.

Module I := MakeInstr UT T Var Proc Uop O Mem E US DE.

Module SemI := SemInstr.Make UT T Var Proc Uop O Mem E US DE I.

Export SemI.

 Notation "{ x , .. , y }" :=
  (@dcons T.type E.expr _ _ x ..
   (@dcons T.type E.expr _ _ y (@dnil T.type E.expr)) ..).

 (* Boolean expressions *)
 Notation "'!' x"   := (E.Eop O.Onot { x }) (at level 60).
 Notation "x && y"  := (E.Eop O.Oand {x,  y}).
 Notation "x || y"  := (E.Eop O.Oor {x, y}).
 Notation "x ==> y" := (E.Eop O.Oimp {x, y}).
 Notation "b '?' x '?:' y" := (E.Eop (O.Oif _) {b, x, y}) (at level 60).

 (* pair expressions *)
 Notation "'Efst' p" := (E.Eop (O.Ofst _ _) { p }) (at level 0).
 Notation "'Esnd' p" := (E.Eop (O.Osnd _ _) { p }) (at level 0).
 Notation "'(' x '|' y ')'" := (E.Eop (O.Opair _ _) {x,  y} ).

 (* sum expressions *)
 Notation "'Inl' x" := (E.Eop (O.Oinl _ _) { x }) (at level 60).
 Notation "'Inr' x" := (E.Eop (O.Oinr _ _) { x }) (at level 60).
 Notation "'Isl' x" := (E.Eop (O.Oisl _ _) { x }) (at level 60).
 Notation "'Projl' x" := (E.Eop (O.Oprojl _ _) { x }) (at level 60).
 Notation "'Projr' x" := (E.Eop (O.Oprojr _ _) { x }) (at level 60).

 (* option expressions *)
 Notation "'none' t" := (E.Ecte (E.Cnone t)) (at level 0).
 Notation "'some' x" := (E.Eop (O.Osome _) { x }) (at level 60).
 Notation "'IsSome' x" := (E.Eop (O.Oissome _) { x }) (at level 60).
 Notation "'Proj' x" := (E.Eop (O.Oprojo _) { x }) (at level 60).

 (* list expressions *)
 Notation "'Nil' t" := (E.Ecte (E.Cnil t)) (at level 0).
 Notation "x '|::|' y" :=
  (E.Eop (O.Ocons _) {x, y}) (at level 60, right associativity).
 Notation "'Etail' p" := (E.Eop (O.Otl _) {p}) (at level 40).
 Notation "'Ehead' p" := (E.Eop (O.Ohd _) {p}) (at level 40).
 Notation "'Elen' p" := (E.Eop (O.Olength _) {p}) (at level 40).
 Notation "x |++| l" :=
  (E.Eop (O.Oappend _) {x,l}) (at level 60, right associativity).

 (* association lists *)
 Notation "x 'in_dom' y" := (E.Eop (O.Oin_dom _ _) {x, y}) (at level 60).
 Notation "x 'in_range' y" := (E.Eop (O.Oin_range _ _) {x, y}) (at level 60).
 Notation "y '[{' x '}]'" := (E.Eop (O.Oimg _ _) {x, y}) (at level 59).
 Notation "l '.[{' x '<<-' v '}]'" :=
   (E.Eop (O.Oupd _ _) {x,v,l}) (at level 50).

 (* nat expressions *)
 Notation "x '+!' y"  := (E.Eop O.Oadd {x, y}) (at level 50, left associativity).
 Notation "x '*!' y"  := (E.Eop O.Omul {x, y}) (at level 40, left associativity).
 Notation "x '-!' y"  := (E.Eop O.Osub {x, y}) (at level 50, left associativity).
 Notation "x '<=!' y" := (E.Eop O.Ole {x, y}) (at level 50).
 Notation "x '<!' y"  := (E.Eop O.Olt {x, y}) (at level 50).

 (* Z expressions *)
 Notation "x '+Z' y"   := (E.Eop O.OZadd {x, y}) (at level 50, left associativity).
 Notation "x '*Z' y"   := (E.Eop O.OZmul {x, y}) (at level 40, left associativity).
 Notation "x '-Z' y"   := (E.Eop O.OZsub {x, y}) (at level 50, left associativity).
 Notation "x '<=Z' y"  := (E.Eop O.OZle {x, y}) (at level 50).
 Notation "x '<Z' y"   := (E.Eop O.OZlt {x, y}) (at level 50).
 Notation "x '>=Z' y"  := (E.Eop O.OZge {x, y}) (at level 50).
 Notation "x '>Z' y"   := (E.Eop O.OZgt {x, y}) (at level 50).
 Notation "'oppZ' x"   := (E.Eop O.OZopp {x}) (at level 40).
 Notation "x '/Z' y"   := (E.Eop O.OZdiv {x, y}) (at level 50).
 Notation "x 'modZ' y" := (E.Eop O.OZmod {x, y}) (at level 50).
 Notation "x 'powZ' y" := (E.Eop O.OZpow {x, y}) (at level 50).

 (* equality *)
 Notation "x '=?=' y" := (E.Eop (O.Oeq_ _) {x, y}) (at level 70, no associativity).

 (* distribution expressions *)
 Notation "'{0,1}'" := DE.Dbool.
 Notation "'[0..' e ']'" := (DE.Dnat e)%nat.
 Notation "'[' e1 ',,' e2 ']'" := (DE.DZ e1 e2)%nat.
 Notation "'Norm' a" := (DE.Duser (@Gaussian  _ _ E.expr a)) (at level 60).

End Sem.

(** Semantics with optimizations *)
Module Entries.

 Module SemO <: SEM_OPT.

  Module Sem := Sem.
  Export Sem.

  Definition simpl_op (op : Uop.t) :
   E.args (Uop.targs op) -> E.expr (Uop.tres op) :=
   match op as op0 return E.args (Uop.targs op0) -> E.expr (Uop.tres op0) with
    | op => fun args => E.Eop (O.Ouser op) args
   end.

  Implicit Arguments simpl_op [].

  Lemma simpl_op_spec : forall k op args (m:Mem.t k),
   E.eval_expr (simpl_op op args) m = E.eval_expr (E.Eop (O.Ouser op) args) m.
  Proof.
   intros; simpl; trivial.
  Qed.

 End SemO.

 Module BP := BaseProp.Make SemO.Sem.

End Entries.

Module Ent := Entries.

Module Tactics := BuildTac.Make Ent.
Export Tactics.

(* *********************************************************************** *)
(*                             GAUSSIAN MECHANISM                          *)
(* *********************************************************************** *)
Section GAUSSIAN_MECHANISM.

 Variable delta: nat -o> U.
 Variable epsilon: nat -> R.
 Hypothesis eps_pos: forall k, (0 <= epsilon k)%R.

 Variable E1 E2 : env.
 Variable a1 : Var.var T.Zt.
 Variable a2 : Var.var T.Zt.
 Variable r : Var.var T.Zt.

 Let Z_Gt := fun (L:R) (z:Z) => if Rlt_dec L (IZR z) then 1%U else D0.

 Let Pre  k (m1 m2:Mem.t k) :=
   let t := IZR (m1 a1 - m2 a2)%Z in
   let alpha := ((scale k * epsilon k - Rsqr t) / (2 * Rabs t))%R in
      (mu (Normal (scale k) 0%Z) (Z_Gt alpha) <= delta k)%tord.

 Lemma Gaussian_Mech:
  eequiv Pre
  E1 [ r <$- Norm  a1 ]
  E2 [ r <$- Norm  a2 ]
  (kreq_mem {{r}}) (fun k => exp (epsilon k)) delta.
 Proof.
  intros.
  apply eequiv_weaken with Pre (EP_eq_expr r r)
    (fun k => exp (epsilon k))  delta; trivial.
  unfold EP_eq_expr; intros k m1 m2 Hm t v Hv;
   Vset_mem_inversion Hv; subst; auto.
  refine (@eequiv_random_discr _ _ _ _ _ _ _ _ _ delta _ _);
    [ auto | ].
  intro k; rewrite <-exp_0; apply exp_monotonic; trivial.
  unfold Pre; intros k m1 m2 H.
  eapply Normal_dist; [ | intro z; apply (cover_dec  (Z_eq_dec z)) | | ].
    apply scale_pos.
    rewrite <-exp_0; apply exp_monotonic; trivial.
    rewrite ln_exp; exact H.
 Qed.

End GAUSSIAN_MECHANISM.


Require Import Syntax.
Require Import Eval.
Require Import Environment.
Require Import Monads.Monad.
Require Import Monads.State.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.

Open Scope monad.
(* Open Scope list_scope. *)

(* Open Scope string_scope. *)

Definition states_to_block (ss: list statement) : block := List.fold_right BlockCons BlockEmpty ss.

Fixpoint lookup_state (states: list State.state) (name: string) : option State.state :=
  match states with
  | List.nil => None
  | s :: states' => if String.eqb name (State.name s) then Some s else lookup_state states' name
  end.

Definition step (p: Parser.parser) (start: string) : env_monad string :=
  match lookup_state (Parser.states p) start with
  | Some nxt =>
    let* _ := eval_statement (BlockStatement (states_to_block (State.statements nxt))) in
      eval_transition (State.transition nxt)
  | None     => state_fail Internal
  end.

(* TODO: formalize progress with respect to a header, such that if the parser
  always makes forward progress then there exists a fuel value for which
  the parser either rejects or accepts (or errors, but not due to lack of fuel)
*)
Fixpoint step_trans (p: Parser.parser) (fuel: nat) (start: string) : env_monad unit :=
  match fuel with
  | 0   => state_fail Internal (* TODO: add a separate exception for out of fuel? *)
  | S x => let* state' := step p start in
    match state' with
    | "accept"    => mret tt
    | "reject"    => state_fail Reject
    | name    => step_trans p x name
    end
  end.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import LibEx.
Require Import ListEx.
Require Import Config.
Require Import Data.
Require Import Monad.

Require Import Nandv2.

Definition ecc_chunk := chunk ECC_IN_OOB_SIZE.

Definition MDATA_IN_OOB_SIZE := 4.

Definition oob_mdata_chunk := chunk MDATA_IN_OOB_SIZE.

Program Definition make_oob_chunk (md: oob_mdata_chunk) (ecc: ecc_chunk) : oob_chunk.
Admitted.

Program Definition read_data_with_ecc (d: data_chunk) (ecc: ecc_chunk) : data_chunk.
Admitted.

Program Definition get_ecc_from_oob_chunk (oob: oob_chunk) : ecc_chunk.
Admitted.

Program Definition get_mdata_from_oob_chunk (oob: oob_chunk) : oob_mdata_chunk.
Admitted.

(* *********** OOB operations for BFTL ************* *)

Inductive page_state_in_oob : Set :=
  | ps_oob_unprogrammed : page_state_in_oob
  | ps_oob_mlog : page_state_in_oob
  | ps_oob_mdata : page_state_in_oob
  | ps_oob_data (off: page_off) : page_state_in_oob.

Program Definition read_page_state_from_oob (md: oob_mdata_chunk) : page_state_in_oob.
Admitted.

Program Definition write_page_state_to_oob (pso: page_state_in_oob) : oob_mdata_chunk.
Admitted.

Program Definition ubi_read_page (c: chip) (pbn: block_no) (loc: page_off)
   : result (prod data_chunk page_state_in_oob).
Admitted.

Program Definition ubi_write_page (c: chip) (pbn: block_no) (loc: page_off) (d: data_chunk) (ps: page_state_in_oob)
   : result chip.
Admitted.

Program Definition ubi_erase_block (c: chip) (pbn: block_no) : result chip.
Admitted.


(* ** Consistency *)

From Undecidability.FOL Require Import Syntax.Facts Deduction.FragmentNDFacts Syntax.Theories.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
From Undecidability Require Import Shared.Libs.PSL.Vectors.Vectors Shared.Libs.PSL.Vectors.VectorForall.
Import ListAutomationNotations.

Section Consistency.
  Context {Σf : funcs_signature} {Σp : preds_signature}.
  Context {HdF : eq_dec Σf} {HdP : eq_dec Σp}.
  Context {HeF : enumerable__T Σf} {HeP : enumerable__T Σp}.

  Definition consistent (T : theory) := ~ T ⊢TC ⊥.
  Definition consistent_max T := consistent T /\ forall f, consistent (T ⋄ f) -> f ∈ T.

  Lemma consistent_prv T phi :
    consistent T -> T ⊢TC phi -> consistent (T ⋄ phi).
  Proof.
    intros HT Hphi. intros Hpsi2. now apply HT, (prv_T_remove Hphi).
  Qed.

  Lemma consistency_inheritance T1 T2 :
    consistent T2 -> T1 ⊑ T2 -> consistent T1.
  Proof.
    intros H H2 H3. now eapply H, Weak_T, H2.
  Qed.

  Fact consistent_neg T phi :
    consistent T -> (¬ phi) ∈ T -> ~ phi ∈ T.
  Proof.
    intros HT H H2. apply HT.
    use_theory [phi; ¬ phi]. 1: intros a [<-|[<-|[]]]; easy.
    eapply IE; apply Ctx; eauto.
  Qed.

  Fact consistent_neg2 T phi :
    consistent T -> (T ⋄ phi) ⊢TC ⊥ -> consistent (T ⋄ (¬ phi)).
  Proof.
    intros HT H. now apply consistent_prv, prv_T_impl.
  Qed.

  Fact consistent_max_out T phi :
    consistent_max T -> ~ phi ∈ T -> ~ consistent (T ⋄ phi).
  Proof.
    intros []; intuition.
  Qed.

  Lemma consistent_max_impl T phi psi :
    consistent_max T -> (phi → psi ∈ T <-> (phi ∈ T -> psi ∈ T)).
  Proof.
    intros; split; destruct H as [H1 H2].
    - intros H H'. apply H2. apply consistent_prv; try assumption.
      use_theory [phi; phi → psi]. 1: intros a [<-|[<-|[]]]; easy.
      eapply IE; apply Ctx; eauto.
    - intros H. apply H2. intros (A & HA1 & HA2) % prv_T_impl.
      apply H1. apply (prv_T_remove (phi := psi)).
      + apply elem_prv, H, H2, consistent_prv. assumption. use_theory A.
        eapply IE. 1: eapply Pc. apply II, Exp. eapply IE; [eapply Weak; [apply HA2| intros a Ha; now right]|]. apply Ctx; now left.
      + use_theory (psi :: A). 1: intros a [<-|Ha]; cbv; eauto.
        eapply IE; [eapply Weak; [apply HA2| intros a Ha; now right]|]. apply II,Ctx; right; now left.
  Qed.

  Section Classical.
    Hypothesis XM : forall X, X \/ ~ X.
    Ltac indirect := match goal with
                      | [ |- ?H ] => destruct (XM H); [assumption | exfalso]
                    end.

    Lemma inconsistent T phi :
      ~ consistent (T ⋄ phi) -> T ⋄ phi ⊢TC ⊥.
    Proof.
      destruct (XM (T ⋄ phi ⊢TC ⊥)); tauto.
    Qed.

    Lemma consistent_max_out2 T phi :
      consistent_max T -> ~ phi ∈ T -> (¬ phi) ∈ T.
    Proof.
      intros [HT1 HT2] H2. now apply consistent_max_out, inconsistent, consistent_neg2, HT2 in H2.
    Qed.
  End Classical.
End Consistency.


Set Implicit Arguments.

Section ADTValue.

  Variable ADTValue : Type.

  Require Import Coq.Lists.List.

  Require Import Bedrock.Platform.Cito.WordMap.
  Import WordMap.
  Require Import Bedrock.Platform.Cito.WordMapFacts.
  Import FMapNotations.
  Open Scope fmap_scope.

  Require Import Bedrock.Platform.Cito.GeneralTactics4.

  Arguments empty {_}.

  Require Import Bedrock.Platform.Cito.SemanticsUtil.

  Definition make_heap' := fold_right (fun x m => @store_pair ADTValue m x) empty.

  Definition no_clash A (p1 p2 : A * Value ADTValue) :=
    match snd p1, snd p2 with
      | ADT _, ADT _ => (fst p1 <> fst p2)%type
      | _, _ => True
    end.

  Definition no_clash_ls A p := List.Forall (@no_clash A p).

  Definition not_in_heap elt w (v : Value ADTValue) (h : WordMap.t elt) :=
    match v with
      | SCA _ => True
      | ADT _ => ~ WordMap.In w h
    end.

  Require Import Coq.Setoids.Setoid.

  Add Morphism (@store_pair ADTValue) with signature Equal ==> eq ==> Equal as store_pair_Equal_m.
  Proof.
    intros st1 st2 Heq [w v].
    unfold store_pair.
    destruct v.
    eauto.
    simpl.
    rewrite Heq.
    reflexivity.
  Qed.

  Add Parametric Morphism elt : (@not_in_heap elt) with signature eq ==> eq ==> Equal ==> iff as not_in_heap_Equal_m.
  Proof.
    intros w v st1 st2 Heq.
    destruct v; simpl in *.
    intuition.
    rewrite Heq.
    intuition.
  Qed.
  Require Import Bedrock.Word.

  Lemma store_pair_comm p1 p2 h : no_clash p1 p2 -> store_pair (store_pair h p1) p2 == store_pair (store_pair h p2) p1.
  Proof.
    intros Hnc.
    intros p.
    destruct p1 as [w1 v1].
    destruct p2 as [w2 v2].
    unfold store_pair.
    simpl.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; eauto.
    unfold no_clash in *.
    simpl in *.
    destruct (weq p w2) as [? | Hne2].
    {
      subst.
      rewrite add_eq_o by eauto.
      rewrite add_neq_o by eauto.
      rewrite add_eq_o by eauto.
      eauto.
    }
    rewrite add_neq_o by eauto.
    destruct (weq p w1) as [? | Hne1].
    {
      subst.
      rewrite add_eq_o by eauto.
      rewrite add_eq_o by eauto.
      eauto.
    }
    rewrite add_neq_o by eauto.
    rewrite add_neq_o by eauto.
    rewrite add_neq_o by eauto.
    eauto.
  Qed.

  Definition DisjointPtrs A := List.ForallOrdPairs (@no_clash A).

  Require Import Bedrock.Memory.

  Definition disjoint_ptrs_ls (p : W * Value ADTValue) (pairs : list (W * Value ADTValue)):=
    match (snd p) with
      | SCA _ => True
      | ADT _ => ~ List.In (fst p) (List.map fst (List.filter (fun p => is_adt (snd p)) pairs))
    end.

  Require Import Bedrock.Platform.Cito.Semantics.

  Lemma disjoint_ptrs_cons_elim' pairs : forall p, disjoint_ptrs (p :: pairs) -> disjoint_ptrs_ls p pairs /\ disjoint_ptrs pairs.
  Proof.
    induction pairs; simpl; intros [w1 v1] H.
    {
      split.
      unfold disjoint_ptrs_ls; simpl.
      destruct v1; intuition.
      unfold disjoint_ptrs; simpl.
      econstructor.
    }
    destruct a as [w2 v2]; simpl in *.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; simpl in *; try solve [unfold disjoint_ptrs, disjoint_ptrs_ls in *; simpl in *; eauto].
    {
      inversion H; subst; clear H.
      split; eauto.
    }
    {
      inversion H; subst; clear H.
      split; eauto.
    }
  Qed.

  Lemma disjoint_ptrs_ls_no_clash_ls pairs : forall p, disjoint_ptrs_ls p pairs -> no_clash_ls p pairs.
  Proof.
    induction pairs; simpl; intros [w1 v1] H.
    {
      econstructor.
    }
    destruct a as [w2 v2]; simpl in *.
    destruct v1 as [? | a1]; destruct v2 as [? | a2]; simpl in *; eauto.
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *.
      econstructor.
      eauto.
      eapply Forall_forall.
      intuition.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *.
      econstructor.
      eauto.
      eapply Forall_forall.
      intuition.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *; simpl in *.
      econstructor; simpl in *.
      eauto.
      eapply (IHpairs (w1, ADT a1)); eauto.
    }
    {
      unfold disjoint_ptrs_ls, no_clash_ls, no_clash in *; simpl in *.
      intuition.
      econstructor; simpl in *.
      eauto.
      eapply (IHpairs (w1, ADT a1)); eauto.
    }
  Qed.
  Require Import Bedrock.Platform.Cito.GeneralTactics.

  Lemma disjoint_ptrs_cons_elim pairs : forall p, disjoint_ptrs (p :: pairs) -> no_clash_ls p pairs /\ disjoint_ptrs pairs.
    intros p H.
    eapply disjoint_ptrs_cons_elim' in H.
    openhyp.
    split; eauto.
    eapply disjoint_ptrs_ls_no_clash_ls; eauto.
  Qed.

  Lemma disjoint_ptrs_DisjointPtrs ls : disjoint_ptrs ls -> DisjointPtrs ls.
  Proof.
    induction ls; simpl; intros H.
    {
      econstructor.
    }
    eapply disjoint_ptrs_cons_elim in H.
    openhyp.
    econstructor; eauto.
    eapply IHls; eauto.
  Qed.

  Lemma no_clash_ls_not_in_heap pairs : forall w v, no_clash_ls (w, v) pairs -> not_in_heap w v (make_heap' pairs).
  Proof.
    induction pairs; simpl; intros w v H.
    {
      destruct v; simpl.
      eauto.
      intros Hin.
      eapply empty_in_iff in Hin.
      eauto.
    }
    inversion H; subst.
    destruct a as [w' v'].
    destruct v as [? | a]; simpl in *.
    { eauto. }
    unfold store_pair.
    destruct v' as [? | a']; simpl in *.
    {
      eapply IHpairs in H3.
      simpl in *.
      eauto.
    }
    unfold no_clash in H2; simpl in *.
    intros Hin.
    eapply add_in_iff in Hin.
    destruct Hin as [Hin | Hin].
    {
      subst; intuition.
    }
    eapply IHpairs in H3.
    simpl in *.
    intuition.
  Qed.

  Arguments store_pair {_} _ _.

  Lemma fold_left_store_pair_comm pairs : forall w v h1 h2, no_clash_ls (w, v) pairs -> h2 == store_pair h1 (w, v) -> fold_left store_pair pairs h2 == store_pair (fold_left store_pair pairs h1) (w, v).
  Proof.
    induction pairs; simpl; intros w v h1 h2 Hnin Hh.
    rewrite Hh; reflexivity.
    destruct a as [w' v'].
    inversion Hnin; subst.
    eapply IHpairs; eauto.
    rewrite Hh.
    rewrite store_pair_comm by eauto.
    reflexivity.
  Qed.

  Lemma make_heap_make_heap' pairs : disjoint_ptrs pairs -> make_heap pairs == make_heap' pairs.
  Proof.
    induction pairs; simpl; intros Hdisj.
    reflexivity.
    unfold make_heap in *.
    simpl.
    destruct a as [w v].
    eapply disjoint_ptrs_cons_elim in Hdisj.
    destruct Hdisj as [Hnin Hdisj].
    rewrite <- IHpairs by eauto.
    eapply fold_left_store_pair_comm; eauto.
    reflexivity.
  Qed.

  Add Morphism (@Semantics.word_adt_match ADTValue) with signature Equal ==> eq ==> iff as word_adt_match_Equal_m.
  Proof.
    intros st1 st2 Heq [w v].
    unfold Semantics.word_adt_match.
    simpl.
    destruct v.
    {
      intuition.
    }
    rewrite Heq.
    intuition.
  Qed.

  Lemma mapsto_make_heap'_intro pairs :
    disjoint_ptrs pairs ->
    forall k (v : ADTValue),
      List.In (k, ADT v) pairs ->
      find k (make_heap' pairs) = Some v.
  Proof.
    induction pairs; intros Hdisj k v Hk; simpl in *.
    {
      intuition.
    }
    eapply disjoint_ptrs_cons_elim in Hdisj.
    destruct Hdisj as [Hnc Hdisj].
    destruct a as [k' v']; simpl in *.
    unfold store_pair in *; simpl in *.
    destruct Hk as [Hk | Hk].
    {
      inject Hk.
      rewrite add_eq_o in * by eauto.
      eauto.
    }
    destruct v' as [w | v']; simpl in *.
    {
      eapply IHpairs; eauto.
    }
    destruct (weq k k') as [? | Hne]; subst.
    {
      eapply no_clash_ls_not_in_heap in Hnc.
      unfold not_in_heap in *.
      eapply IHpairs in Hk; eauto.
      contradict Hnc.
      eapply find_Some_in; eauto.
    }
    rewrite add_neq_o in * by eauto.
    eapply IHpairs in Hk; eauto.
  Qed.

  Lemma mapsto_make_heap'_elim pairs :
    disjoint_ptrs pairs ->
    forall k (v : ADTValue),
      find k (make_heap' pairs) = Some v ->
      List.In (k, ADT v) pairs.
  Proof.
    induction pairs; intros Hdisj k v Hk; simpl in *.
    {
      rewrite empty_o in *.
      discriminate.
    }
    eapply disjoint_ptrs_cons_elim in Hdisj.
    destruct Hdisj as [Hnc Hdisj].
    destruct a as [k' v']; simpl in *.
    unfold store_pair in *; simpl in *.
    destruct v' as [w | v']; simpl in *.
    {
      unfold store_pair in *; simpl in *.
      right.
      eapply IHpairs; eauto.
    }
    destruct (weq k k') as [? | Hne]; subst.
    {
      rewrite add_eq_o in * by eauto.
      inject Hk.
      left; eauto.
    }
    rewrite add_neq_o in * by eauto.
    eapply IHpairs in Hk; eauto.
  Qed.

  Lemma mapsto_make_heap'_iff pairs :
    disjoint_ptrs pairs ->
    forall k (v : ADTValue),
      List.In (k, ADT v) pairs <->
      find k (make_heap' pairs) = Some v.
  Proof.
    intros Hdisj k v; split; intros H.
    - eapply mapsto_make_heap'_intro; eauto.
    - eapply mapsto_make_heap'_elim; eauto.
  Qed.

  Arguments word_scalar_match {ADTValue} _.

  Require Bedrock.Platform.Cito.Inv. (* for preventing bad universe unification *)

  Lemma DisjointPtrs_good_scalars_forall_word_adt_match : forall pairs h, DisjointPtrs pairs -> List.Forall word_scalar_match pairs -> List.Forall (word_adt_match (fold_left store_pair pairs h)) pairs.
  Proof.
    induction pairs; simpl; try solve [intuition].
    intros h Hdisj H.
    inversion H; subst.
    inversion Hdisj; subst.
    destruct a as [w v]; simpl in *.
    econstructor.
    {
      rewrite fold_left_store_pair_comm; try reflexivity; trivial. (* this [rewrite] will incorrectly unify universes in >= 8.5 without the [Require Bedrock.Platform.Cito.Inv.] *)
      unfold word_adt_match.
      unfold Semantics.word_adt_match.
      unfold word_scalar_match in *.
      simpl in *.
      destruct v; simpl in *; trivial.
      unfold store_pair; simpl.
      rewrite add_eq_o by eauto.
      eauto.
    }
    eapply IHpairs; eauto.
  Qed.

  Lemma disjoint_ptrs_good_scalars_good_inputs pairs :
    @disjoint_ptrs ADTValue pairs ->
    good_scalars pairs ->
    good_inputs (make_heap pairs) pairs.
  Proof.
    intros Hdisj Hgs.
    split; eauto.
    eapply DisjointPtrs_good_scalars_forall_word_adt_match; eauto.
    eapply disjoint_ptrs_DisjointPtrs; eauto.
  Qed.

  Lemma good_inputs_add addr (a : ADTValue) h : ~ In addr h -> good_inputs (add addr a h) ((addr, ADT a) :: nil).
  Proof.
    intros Hnin.
    unfold good_inputs.
    unfold Semantics.good_inputs.
    unfold Semantics.disjoint_ptrs.
    unfold Semantics.word_adt_match.
    simpl.
    split.
    - repeat econstructor; simpl.
      rewrite add_eq_o by eauto.
      eauto.
    - repeat econstructor; eauto.
  Qed.

  Local Open Scope fmap_scope.

  Lemma good_inputs_make_heap_submap h pairs :
    good_inputs (ADTValue := ADTValue) h pairs ->
    make_heap pairs <= h.
  Proof.
    intros Hgi.
    destruct Hgi as [Hforall Hdisj].
    unfold good_inputs in *.
    intros k1 v Hk1.
    rewrite make_heap_make_heap' in * by eauto.
    eapply mapsto_make_heap'_iff in Hk1; eauto.
    eapply Forall_forall in Hforall; eauto.
    unfold word_adt_match in *.
    simpl in *.
    eauto.
  Qed.

  Lemma forall_word_adt_match_good_scalars : forall h pairs, List.Forall (word_adt_match h) pairs -> List.Forall (@word_scalar_match ADTValue) pairs.
    intros.
    eapply Locals.Forall_weaken.
    2 : eassumption.
    intros.
    destruct x.
    unfold word_adt_match, Semantics.word_adt_match, word_scalar_match in *; simpl in *.
    destruct v; simpl in *; intuition.
  Qed.

  Require Import ListFacts3.

  Lemma core_eq_func_eq f1 (H1 : is_no_dup (FuncCore.ArgVars f1) = true) f2 (H2 : is_no_dup (FuncCore.ArgVars f2) = true) : f1 = f2 -> {| Fun := f1; NoDupArgVars := H1 |} = {| Fun := f2; NoDupArgVars := H2 |}.
  Proof.
    intros.
    subst.
    f_equal.
    Require Import BoolFacts.
    eapply bool_irre.
  Qed.

End ADTValue.


(******************************************************************************)
(** * Definition of the Power memory model *)
(******************************************************************************)
From hahn Require Import Hahn.
Require Import Events.
Require Import Execution.

Set Implicit Arguments.

Section Power_fences.

Variable G : execution.

Notation "'E'" := (acts_set G).
Notation "'lab'" := (lab G).
Notation "'sb'" := (sb G).
Notation "'rf'" := (rf G).
Notation "'co'" := (co G).
Notation "'rmw'" := (rmw G).
Notation "'data'" := (data G).
Notation "'addr'" := (addr G).
Notation "'ctrl'" := (ctrl G).
(* Notation "'ctrli'" := (ctrli G). *)
Notation "'deps'" := (deps G).
Notation "'fre'" := (fre G).
Notation "'rfe'" := (rfe G).
Notation "'coe'" := (coe G).
Notation "'rfi'" := (rfi G).
Notation "'fri'" := (fri G).
Notation "'fr'" := (fr G).

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).

Notation "'F^lwsync'" := (F ∩₁ (fun a => is_true (is_ra lab a))).
Notation "'F^sync'" := (F ∩₁ (fun a => is_true (is_sc lab a))).

Implicit Type WF : Wf G.

Definition sync := ⦗RW⦘ ⨾ sb ⨾ ⦗F^sync⦘ ⨾ sb ⨾ ⦗RW⦘.
Definition lwsync := (⦗RW⦘ ⨾ sb ⨾ ⦗F^lwsync⦘ ⨾ sb ⨾ ⦗RW⦘) \ (fun x y => W x /\ R y).
Definition fence := sync ∪ lwsync.

(******************************************************************************)
(** ** Relations in graph *)
(******************************************************************************)

Lemma wf_syncE WF: sync ≡ ⦗E⦘ ⨾ sync ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold sync.
rewrite (wf_sbE) at 1 2.
basic_solver 42.
Qed.

Lemma wf_lwsyncE WF: lwsync ≡ ⦗E⦘ ⨾ lwsync ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold lwsync.
rewrite (wf_sbE) at 1 2.
basic_solver 42.
Qed.

Lemma wf_fenceE WF: fence ≡ ⦗E⦘ ⨾ fence ⨾ ⦗E⦘.
Proof using.
split; [|basic_solver].
unfold fence.
rewrite (wf_syncE WF) at 1.
rewrite (wf_lwsyncE WF) at 1.
basic_solver 42.
Qed.

(******************************************************************************)
(** ** Domains and codomains  *)
(******************************************************************************)

Lemma wf_syncD WF: sync ≡ ⦗RW⦘ ⨾ sync ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfold sync.
basic_solver 42.
Qed.

Lemma wf_lwsyncD WF: lwsync ≡ ⦗RW⦘ ⨾ lwsync ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfold lwsync.
basic_solver 42.
Qed.

Lemma wf_fenceD WF: fence ≡ ⦗RW⦘ ⨾ fence ⨾ ⦗RW⦘.
Proof using.
split; [|basic_solver].
unfold fence.
rewrite (wf_syncD WF) at 1.
rewrite (wf_lwsyncD WF) at 1.
basic_solver 42.
Qed.

(******************************************************************************)
(** ** Properties *)
(******************************************************************************)

Lemma sync_in_sb : sync ⊆ sb.
Proof using.
unfold sync; generalize (@sb_trans G); basic_solver.
Qed.

Lemma lwsync_alt : lwsync ≡
  ⦗R⦘ ⨾ sb ⨾ ⦗F^lwsync⦘ ⨾ sb ⨾ ⦗RW⦘ ∪ ⦗W⦘ ⨾ sb ⨾ ⦗F^lwsync⦘ ⨾ sb ⨾ ⦗W⦘.
Proof using.
unfold lwsync.
split.
by apply inclusion_minus_l; basic_solver 12.
by unfolder; ins; desf; splits; eauto 10; intro; type_solver.
Qed.

Lemma lwsync_in_sb : lwsync ⊆ sb.
Proof using.
rewrite lwsync_alt.
generalize (@sb_trans G); basic_solver.
Qed.

Lemma fence_in_sb : fence ⊆ sb.
Proof using.
unfold fence.
rewrite sync_in_sb, lwsync_in_sb.
basic_solver.
Qed.

Lemma sync_sb_w_in_sync WF : sync ⨾ sb ⨾ ⦗W⦘ ⊆ sync.
Proof using.
unfold sync.
generalize (@sb_trans G).
basic_solver 20.
Qed.

Lemma sync_fri_in_sync WF : sync ⨾ fri ⊆ sync.
Proof using.
rewrite (wf_friD WF).
ie_unfolder.
generalize (sync_sb_w_in_sync WF).
basic_solver 12.
Qed.

Lemma lwsync_sb_w_in_lwsync WF : lwsync ⨾ sb ⨾ ⦗W⦘ ⊆ lwsync.
Proof using.
rewrite lwsync_alt.
generalize (@sb_trans G).
basic_solver 20.
Qed.

Lemma lwsync_fri_in_lwsync WF : lwsync ⨾ fri ⊆ lwsync.
Proof using.
rewrite (wf_friD WF).
ie_unfolder.
generalize (lwsync_sb_w_in_lwsync WF).
basic_solver 12.
Qed.

Lemma fence_sb_w_in_fence WF : fence ⨾ sb ⨾ ⦗W⦘ ⊆ fence ⨾ ⦗W⦘.
Proof using.
unfold fence.
generalize (sync_sb_w_in_sync WF) (lwsync_sb_w_in_lwsync WF).
basic_solver 12.
Qed.

Lemma fence_fri_in_fence WF : fence ⨾ fri ⊆ fence.
Proof using.
unfold fence.
generalize (sync_fri_in_sync WF) (lwsync_fri_in_lwsync WF).
basic_solver 12.
Qed.

Lemma RW_sb_sync_in_sync : ⦗RW⦘ ⨾ sb ⨾ sync ⊆ sync.
Proof using.
unfold sync.
generalize (@sb_trans G).
basic_solver 12.
Qed.

Lemma RW_sb_lwsync_in_lwsync : ⦗RW⦘ ⨾ sb ⨾ lwsync ⨾ ⦗W⦘ ⊆ lwsync.
Proof using.
rewrite lwsync_alt.
generalize (@sb_trans G).
basic_solver 20.
Qed.

Lemma RW_sb_fence_in_fence WF: ⦗RW⦘ ⨾ sb ⨾ fence ⨾ ⦗W⦘ ⊆ fence.
Proof using.
unfold fence.
generalize (RW_sb_sync_in_sync) (RW_sb_lwsync_in_lwsync).
basic_solver 12.
Qed.

Lemma RW_sb_F_sb_W_in_fence : ⦗RW⦘ ⨾ sb ⨾ ⦗F^lwsync⦘ ⨾ sb ⨾ ⦗W⦘ ⊆ fence.
Proof using.
unfold fence; rewrite lwsync_alt.
basic_solver 20.
Qed.

Lemma R_sb_F_sb_RW_in_fence : ⦗R⦘ ⨾ sb ⨾ ⦗F^lwsync⦘ ⨾ sb ⨾ ⦗RW⦘ ⊆ fence.
Proof using.
unfold fence; rewrite lwsync_alt.
basic_solver 12.
Qed.

Proposition sync_trans : transitive sync.
Proof using.
unfold sync.
apply transitiveI.
arewrite_id ⦗F^sync⦘ at 2; rels.
arewrite_id ⦗RW⦘ at 2; rels.
generalize (@sb_trans G).
basic_solver 42.
Qed.

Proposition lwsync_trans : transitive lwsync.
Proof using.
apply transitiveI.
rewrite lwsync_alt at 2.
arewrite_id !⦗F^lwsync⦘; rels.
sin_rewrite !(rewrite_trans (@sb_trans G)).
arewrite_id ⦗W⦘ at 1; rels.
rewrite lwsync_alt.
arewrite_id ⦗RW⦘ at 1; rels.
relsf.
rewrite !seqA.
arewrite_false (⦗W⦘ ⨾ ⦗R⦘).
by type_solver.
rels.
arewrite_id ⦗R⦘ at 2; rels.
arewrite_id ⦗W⦘ at 3; rels.
sin_rewrite !(rewrite_trans (@sb_trans G)).
basic_solver 12.
Qed.

Proposition lwsync_sync : lwsync ⨾ sync ⊆ sync.
Proof using.
unfold lwsync, sync.
arewrite_id ⦗F^lwsync⦘.
generalize (@sb_trans G).
basic_solver 42.
Qed.

Proposition sync_lwsync : sync ⨾ lwsync ⊆ sync.
Proof using.
unfold lwsync, sync.
arewrite_id ⦗F^lwsync⦘.
generalize (@sb_trans G).
basic_solver 42.
Qed.

Proposition fence_trans : transitive fence.
Proof using.
unfold fence.
apply transitiveI.
relsf.
sin_rewrite !(rewrite_trans sync_trans).
sin_rewrite !(rewrite_trans lwsync_trans).
sin_rewrite lwsync_sync.
sin_rewrite sync_lwsync.
basic_solver 12.
Qed.

Lemma rf_fence_W_in_fence WF: rf^? ⨾ fence ⨾ ⦗W⦘ ⊆ rfe^? ⨾ fence ⨾ ⦗W⦘.
Proof using.
rewrite (dom_l (wf_rfD WF)) at 1.
rewrite (@rfi_union_rfe G) at 1.
arewrite(rfi ⊆ sb).
generalize (RW_sb_fence_in_fence WF).
basic_solver 42.
Qed.

End Power_fences.


From iris.proofmode Require Import tactics.
From iris.algebra Require Import auth excl.
From iris.base_logic.lib Require Import invariants.
From intensional.heap_lang Require Import lifting proofmode notation.
From intensional.heap_lang Require Import adequacy.
From intensional.examples Require Import stdpp_extra tactics.
Set Default Proof Using "Type".
Implicit Types t : list val.

(** ** Enforcing a well-bracketing protocol (Section 5.3) *)

(** *** Separation logic specification *)

Definition withRes_spec `{!heapG Σ} (locked: iProp Σ) (unlocked: val → iProp Σ) (withRes: val): iProp Σ :=
  ∀ P Q (f: val),
    {{{ locked ∗ P ∗
        (∀ (y x: val), {{{ unlocked y ∗ P }}} f x {{{ RET #(); unlocked y ∗ Q }}})
    }}}
      withRes f
    {{{ RET #(); locked ∗ Q }}}.

Definition op_spec `{!heapG Σ} (locked: iProp Σ) (unlocked: val → iProp Σ) (op: val): iProp Σ :=
  ∀ (x y: val), {{{ unlocked y }}} op x {{{ RET #(); unlocked y }}}.

Definition bfilelib_spec `{!heapG Σ} (P0: iProp Σ) (lib: val): iProp Σ :=
  ∃ (locked: iProp Σ) (unlocked: val → iProp Σ),
  □ (P0 -∗ locked) ∗
  match lib with
  | (withRes, op)%V =>
    withRes_spec locked unlocked withRes ∗
    op_spec locked unlocked op
  | _ => False
  end.

(** *** The trace property [bfile_trace]: "clients only use the operation after having acquired the resource and before releasing it". *)

Section Trace.

Inductive op_trace : list val → Prop :=
| op_trace_nil : op_trace []
| op_trace_call t :
    op_trace t →
    op_trace (t ++ [(#"call:op", #())%V; (#"ret:op", #())%V]).

Inductive withRes_trace : list val → Prop :=
| withRes_trace_nil : withRes_trace []
| withRes_trace_call t t_op f :
    withRes_trace t →
    op_trace t_op →
    withRes_trace (t ++ [(#"call:withRes", f)%V; (#"call", f)%V]
                     ++ t_op
                     ++ [(#"ret", f)%V; (#"ret:withRes", f)%V]).

Definition bfile_trace t :=
  ∃ t', t `prefix_of` t' ∧ withRes_trace t'.

(* *** *)

Definition trace1 t f :=
  ∃ t', withRes_trace t' ∧ t = t' ++ [(#"call:withRes", f)%V].

Definition trace2 t (f:val) :=
  ∃ t' t_op, withRes_trace t'
           ∧ op_trace t_op
           ∧ t = t' ++ [(#"call:withRes", f)%V; (#"call", f)%V] ++ t_op.

Definition trace3 t (f: val) :=
  ∃ t' t_op, withRes_trace t'
           ∧ op_trace t_op
           ∧ t = t' ++ [(#"call:withRes", f)%V; (#"call", f)%V]
                    ++ t_op
                    ++ [(#"ret", f)%V].

End Trace.

(** *** Definition and correctness of the wrapper code *)

Module Wrap.
Section S.
Context {Σ: gFunctors}.
Context `{heapG Σ}.
Context (N: namespace).

Context (locked_impl: iProp Σ) (unlocked_impl: val → iProp Σ).
Context (withRes_impl op_impl : val).

Definition withRes : val :=
  λ: "f",
    Emit (#"call:withRes", "f") ;;
    withRes_impl (λ: "x",
      Emit (#"call", "f") ;; "f" "x" ;; Emit (#"ret", "f")
    ) ;;
    Emit (#"ret:withRes", "f").

Definition op : val :=
  λ: "x",
    Emit (#"call:op", #()) ;;
    op_impl "x" ;;
    Emit (#"ret:op", #()).

Definition T0 : iProp Σ :=
  ∃ t, trace_is t ∗ trace_inv N bfile_trace ∗ ⌜ withRes_trace t ⌝.

Definition T1 f : iProp Σ :=
  ∃ t, trace_is t ∗ trace_inv N bfile_trace ∗ ⌜ trace1 t f ⌝.

Definition T2 f : iProp Σ :=
  ∃ t, trace_is t ∗ trace_inv N bfile_trace ∗ ⌜ trace2 t f ⌝.

Definition T3 f : iProp Σ :=
  ∃ t, trace_is t ∗ trace_inv N bfile_trace ∗ ⌜ trace3 t f ⌝.

Definition unlocked (x: val) : iProp Σ :=
  ∃ (y z:val), ⌜x = (y, z)%V⌝ ∗ unlocked_impl y ∗ T2 z.

Definition locked : iProp Σ :=
  locked_impl ∗ T0.

Lemma withRes_correct :
  withRes_spec locked_impl unlocked_impl withRes_impl -∗
  withRes_spec locked unlocked withRes.
Proof.
  iIntros "#spec" (P Q f φ) "!> (Hl & HP & #HS) Hφ".
  iDestruct "Hl" as "(Hl & Ht0)". iDestruct "Ht0" as (t) "(Ht & #Hi & %)".
  iMod (trace_is_inv with "Ht Hi") as "[Ht %]".
  unfold withRes. wp_pures. wp_bind (Emit _).
  iApply (wp_emit with "[$Ht $Hi]"); eauto.
  { eexists. split. 2: eapply withRes_trace_call.
    by apply prefix_app, prefix_cons, prefix_nil.
    auto. constructor. }
  iIntros "!> Ht". wp_pures. wp_bind (withRes_impl _).
  iApply ("spec" $! (P ∗ T1 f)%I (Q ∗ T3 f)%I with "[$Hl $HP Ht]").
  { iSplitL "Ht".
    { iExists _. iFrame "Hi ∗". iPureIntro. unfold trace1. go. }
    iIntros (y x ψ) "!> (Hu & [HP Ht1]) Hψ". wp_pures. wp_bind (Emit _).
    iDestruct "Ht1" as (t') "(Ht' & _ & Ht1)". iDestruct "Ht1" as %Ht1.
    iApply (wp_emit with "[$Ht' $Hi]"); eauto.
    { destruct Ht1 as [t'' [? ->]]. eexists. split. 2: eapply withRes_trace_call.
      rewrite -app_assoc. apply prefix_app, prefix_cons, prefix_cons, prefix_nil.
      eauto. constructor. }
    iIntros "!> Ht'". wp_pures. wp_bind (f _).
    iApply ("HS" $! (y, f)%V with "[Hu Ht' $HP]").
    { iExists _, _. iSplitR. done. iFrame. iExists _. iFrame "Hi ∗". iPureIntro.
      destruct Ht1 as [t'' [? ->]]. exists t'', []. repeat split; eauto. constructor.
      by list_simplifier. }
    iIntros "!> [Hu HQ]". wp_pures. iDestruct "Hu" as (y' z) "(% & Hy & Ht2)".
    simplify_eq. iDestruct "Ht2" as (t'') "(Ht'' & _ & Ht2)". iDestruct "Ht2" as %Ht2.
    destruct Ht2 as [t''' [t_op (? & ? & ->)]].
    iApply (wp_emit with "[$Ht'' $Hi]"); eauto.
    { eexists. split. 2: eapply withRes_trace_call. rewrite -app_assoc. cbn.
      apply prefix_app, prefix_cons, prefix_cons, prefix_app, prefix_cons, prefix_nil.
      all: eauto. }
    iIntros "!> Ht'''". iApply "Hψ". iFrame. iExists _. iFrame "Hi ∗".
    iPureIntro. exists t''', t_op. repeat split; eauto. by list_simplifier. }
  iIntros "!> (Hl & HQ & Ht3)". iDestruct "Ht3" as (t') "(Ht' & _ & Ht3)".
  iDestruct "Ht3" as %Ht3. destruct Ht3 as [t'' [t_op (? & ? & ->)]].
  wp_pures. iApply (wp_emit with "[$Ht' $Hi]"); eauto.
  { eexists. split. reflexivity. rewrite -!app_assoc. constructor; eauto. }
  iIntros "!> Ht". iApply "Hφ". iFrame. iExists _. iFrame "Hi ∗". iPureIntro.
  rewrite -!app_assoc. constructor; eauto.
Qed.

Lemma op_correct :
  op_spec locked_impl unlocked_impl op_impl -∗
  op_spec locked unlocked op.
Proof.
  iIntros "#spec" (x y φ) "!> Hu Hφ". iDestruct "Hu" as (y' z ->) "(Hu & Ht2)".
  iDestruct "Ht2" as (t) "(Ht & #Hi & Ht2)". iDestruct "Ht2" as %Ht2.
  unfold op. wp_pures. wp_bind (Emit _).
  destruct Ht2 as [t' [t_op (? & ? & ->)]].
  iApply (wp_emit with "[$Ht $Hi]"); eauto.
  { eexists. split. 2: eapply withRes_trace_call. rewrite -!app_assoc.
    apply prefix_app, prefix_cons, prefix_cons.
    3: apply op_trace_call. rewrite -app_assoc.
    apply prefix_app, prefix_cons, prefix_nil. all: eauto. }
  iIntros "!> Ht". wp_pures. wp_bind (op_impl _).
  iApply ("spec" with "Hu"). iIntros "!> Hu". wp_pures.
  iApply (wp_emit with "[$Ht $Hi]"); eauto.
  { eexists. split. 2: eapply withRes_trace_call.
    3: apply op_trace_call; eauto. rewrite -!app_assoc.
    repeat first [ apply prefix_app | apply prefix_cons | apply prefix_nil ].
    eauto. }
  iIntros "!> Ht". iApply "Hφ". iExists _, _. iSplitR. done. iFrame.
  iExists _. iFrame "Hi ∗". iPureIntro. exists t'. eexists. split; [eauto|].
  split. apply op_trace_call; eauto. by list_simplifier.
Qed.

End S.

(** Wrapping code for an entire library *)
Definition lib (lib_impl: val): val :=
  match lib_impl with
  | (withRes_impl, op_impl)%V =>
    (withRes withRes_impl, op op_impl)
  | _ => #()
  end.

(** Correctness of the library wrapper *)
Lemma correct `{!heapG Σ} N P0 (lib_impl: val):
  bfilelib_spec P0 lib_impl -∗
  bfilelib_spec (P0 ∗ trace_is [] ∗ trace_inv N bfile_trace) (lib lib_impl).
Proof.
  iIntros "S". iDestruct "S" as (locked_impl unlocked_impl) "(#H0 & S)".
  repeat case_match; eauto. iDestruct "S" as "(? & ?)".
  unfold bfilelib_spec.
  iExists (locked N locked_impl), (unlocked N unlocked_impl). repeat iSplit.
  { iIntros "!> (HP0 & ? & #Hi)". iDestruct ("H0" with "HP0") as "?". iFrame.
    iExists _. iFrame "Hi ∗". iPureIntro. constructor. }
  iApply withRes_correct; eauto.
  iApply op_correct; eauto.
Qed.

End Wrap.

(** *** Adequacy *)

Definition bfilelibN := nroot .@ "bfilelib".
Definition empty_state : state := Build_state ∅ [] ∅.

(** The trace property [bfile_trace] is satisfied at every step of the execution
    at the level of the operational semantics. *)
Lemma wrap_bfilelib_correct (e: val → expr) (lib: val):
  (∀ `(heapG Σ), ⊢ bfilelib_spec True lib) →
  (∀ `(heapG Σ), ⊢ ∀ P lib, bfilelib_spec P lib -∗ {{{ P }}} e lib {{{ v, RET v; True }}}) →
  ∀ σ' e',
    rtc erased_step ([(#();; e (Wrap.lib lib))%E], empty_state) (e', σ') →
    bfile_trace (trace σ').
Proof.
  set (Σ := #[invΣ; gen_heapΣ loc val; traceΣ; proph_mapΣ proph_id (val * val)]).
  intros Hlib Hctx σ' e' Hsteps.
  eapply (@module_invariance Σ (HeapPreG Σ _ _ _ _)
                             bfilelibN (@bfilelib_spec Σ) True e #() (Wrap.lib lib)
                             bfile_trace empty_state).
  { cbn. exists []. split; eauto; constructor. }
  { iIntros (? ? ?) "?". by iApply Hctx. }
  { iIntros (? _) "!>". iApply wp_value; eauto. }
  { iIntros (?). iApply Wrap.correct. iApply Hlib. }
  eauto.
Qed.


(* --------------------------------------------------------------------
 * Copyright (c) - 2006--2012 - IMDEA Software Institute
 * Copyright (c) - 2006--2012 - Inria
 * Copyright (c) - 2006--2012 - Microsoft Coprporation
 *
 * Distributed under the terms of the CeCILL-B-V1 license
 * -------------------------------------------------------------------- *)

(** * Extension.v : An user-defined extension to pWHILE, including
operators corresponding to a permutation and its inverse *)

Require Export PPT.
Require Export BuildTac2.
Require Import Bitstrings.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope nat_scope.

Module Type TRAPDOOR_PERM.

 Parameter k0 : nat -> nat.
 Parameter k1 : nat -> nat.
 Parameter n  : nat -> nat.

 Parameter k_spec : forall k, k = n k + k0 k + k1 k.

 (** * Trapdoor permutation and its inverse *)

 Definition Bvectork k :=
  ((Bvector (n k) *  Bvector (k1 k)) * Bvector (k0 k))%type.

 Parameter f : forall k, Bvectork k -> Bvectork k.

 Parameter finv : forall k, Bvectork k -> Bvectork k.

 Parameter f_spec : forall k (x:Bvectork k), finv (f x) = x.

 Parameter finv_spec : forall k (y:Bvectork k), f (finv y) = y.

 Parameter cost_f : polynomial.
 Parameter cost_finv : nat -> nat.

 (** Maximum number of queries made to the G oracle *)
 Parameter qG_poly : polynomial.

 (** Maximum number of queries made to the H oracle *)
 Parameter qH_poly : polynomial.

 (** Maximum number of queries made to the decryption oracle *)
 Parameter qD_poly : polynomial.

End TRAPDOOR_PERM.

Module Entries (TP:TRAPDOOR_PERM).

 Inductive ut_ : Type :=
 | Bitstring_n
 | Bitstring_k0
 | Bitstring_k1.

 (** * User-defined type module *)
 Module Ut <: UTYPE.

  Definition t := ut_.

  Definition eqb (t1 t2 :t) :=
   match t1, t2 with
   | Bitstring_n,   Bitstring_n   => true
   | Bitstring_k0,  Bitstring_k0  => true
   | Bitstring_k1,  Bitstring_k1  => true
   | _, _ => false
   end.

  Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
  Proof.
   simpl; destruct x; destruct y; simpl;
    trivial; discriminate.
  Qed.

  Definition eq_dec (x y:t) : {x = y} + {True} :=
   match x as x0 return {x0 = y} + {True} with
   | Bitstring_n =>
     match y as y0 return {Bitstring_n = y0} + {True} with
     | Bitstring_n => left _ (refl_equal _)
     | _ => right _ I
     end
   | Bitstring_k0 =>
     match y as y0 return {Bitstring_k0 = y0} + {True} with
     | Bitstring_k0 => left _ (refl_equal _)
     | _ => right _ I
     end
   | Bitstring_k1 =>
     match y as y0 return {Bitstring_k1 = y0} + {True} with
     | Bitstring_k1 => left _ (refl_equal _)
     | _ => right _ I
     end
   end.

  Lemma eq_dec_r : forall x y i, eq_dec x y = right _ i -> x <> y.
  Proof.
   destruct x; destruct y; simpl; intros; discriminate.
  Qed.

  Import TP.

  Definition len k (t0:t) :=
   match t0 with
   | Bitstring_n   => n k
   | Bitstring_k0  => k0 k
   | Bitstring_k1  => k1 k
   end.

  Definition interp k (t0:t) :=
   Bvector (len k t0).

  Definition size k (t0:t) (_:interp k t0) :=
   S (len k t0).

  Definition default k (t0:t) : interp k t0 :=
   Bvect_false (len k t0).

  Definition default_poly (t0:t) :=
   pplus (pcst 1) pvar.

  Lemma size_positive : forall k (t0:t) x, 0 < @size k t0 x.
  Proof.
   intros k t0 x; unfold size; auto with arith.
  Qed.

  Lemma len_le : forall k t0, len k t0 <= k.
  Proof.
   intros k; assert (W:=k_spec k); destruct t0; simpl; omega.
  Qed.

  Lemma default_poly_spec : forall k (t0:t),
   @size k t0 (default k t0) <= peval (default_poly t0) k.
  Proof.
   intros k t0.
   unfold size, default, default_poly.
   rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
   simpl; apply le_n_S; apply len_le.
  Qed.

  Definition i_eqb k t (x1 x2:interp k t) := Veqb x1 x2.

  Lemma i_eqb_spec : forall k t (x y:interp k t),
   if i_eqb x y then x = y else x <> y.
  Proof.
   intros; refine (Veqb_spec _ _).
  Qed.

 End Ut.

 Module T := MakeType Ut.

 Inductive usupport_ (Ut:Type) (Ttype:Type) (Tuser:Ut -> Ttype): Ttype -> Type :=
 | Usupport : forall t, usupport_ Tuser (Tuser t).

 Module US <: USUPPORT Ut T.

  Definition usupport := usupport_ T.User.

  Definition eval k t (s:usupport t) : list (T.interp k t) :=
   match s in usupport_ _ t0 return list (T.interp k t0) with
   | Usupport bst => bs_support (Ut.len k bst)
   end.

  Definition ceval k t (s:usupport t) : list (T.interp k t) * nat :=
   (eval k s, 1%nat).

  Lemma eval_usupport_nil : forall k t (s:usupport t), eval k s <> nil.
  Proof.
   destruct s; refine (@bs_support_not_nil _).
  Qed.

  Lemma ceval_spec : forall k t (s:usupport t), eval k s = fst (ceval k s).
  Proof.
   trivial.
  Qed.

  Definition eqb (t1 t2:T.type) (s1:usupport t1) (s2:usupport t2) : bool :=
   T.eqb t1 t2.

  Lemma eqb_spec_dep : forall t1 (e1 : usupport t1) t2 (e2:usupport t2),
   if eqb e1 e2 then eq_dep T.type usupport t1 e1 t2 e2
   else ~eq_dep T.type usupport t1 e1 t2 e2.
  Proof.
   intros.
   destruct e1; destruct e2; unfold eqb.
   generalize (T.eqb_spec (T.User t) (T.User t0));
    destruct (T.eqb (T.User t) (T.User t0)); intros.
   injection H; clear H; intros; subst; trivial.
   intros Heq; apply H; inversion Heq; trivial.
  Qed.

  Lemma eqb_spec : forall t (e1 e2:usupport t),
   if eqb e1 e2 then e1 = e2 else e1 <> e2.
  Proof.
   intros t e1 e2.
   generalize (eqb_spec_dep e1 e2).
   case (eqb e1 e2); intro H.
   apply T.eq_dep_eq; trivial.
   intro Heq; apply H; rewrite Heq; constructor.
  Qed.

 End US.

 Inductive Uop : Type :=
 | Oapp_f : Uop
 | Oapp_f_inv : Uop
 | OqG : Uop
 | OqH : Uop
 | OqD : Uop
 | Oxor : Ut.t -> Uop
 | Ozero : Uop
 | Oone : Uop.

 Module UOp <: UOP Ut T.

  Definition t := Uop.

  Definition eqb (o1 o2:t) : bool :=
   match o1, o2 with
   | Oapp_f, Oapp_f
   | Oapp_f_inv, Oapp_f_inv
   | OqG, OqG
   | OqH, OqH
   | OqD, OqD
   | Ozero, Ozero => true
   | Oone, Oone => true
   | Oxor t1, Oxor t2 => Ut.eqb t1 t2
   | _, _ => false
   end.

   Lemma eqb_spec : forall x y, if eqb x y then x = y else x <> y.
   Proof.
    intros x y; case x; case y; simpl; trivial; intros;
    try (intro; discriminate).
    generalize (Ut.eqb_spec t1 t0); destruct (Ut.eqb t1 t0); intros.
    rewrite H; trivial.
    intro H1; apply H; inversion H1; trivial.
   Qed.

   Definition Tnk1 := T.Pair (T.User Bitstring_n) (T.User Bitstring_k1).
   Definition Tk := T.Pair Tnk1 (T.User Bitstring_k0).

   Definition targs (op:t) : list T.type :=
    match op with
    | Oapp_f => Tk :: nil
    | Oapp_f_inv => Tk :: nil
    | OqG | OqH | OqD | Ozero | Oone => nil
    | Oxor t => T.User t :: T.User t :: nil
    end.

   Definition tres (op:t) : T.type :=
    match op with
    | Oapp_f => Tk
    | Oapp_f_inv => Tk
    | OqG | OqH | OqD => T.Nat
    | Ozero => T.User Bitstring_k1
    | Oone => T.User Bitstring_n
    | Oxor t => T.User t
    end.

   Import TP.

   Definition interp_op (k:nat) (op:t) : T.type_op k (targs op) (tres op) :=
    match op as op0 return T.type_op k (targs op0) (tres op0) with
    | Oapp_f => @f k
    | Oapp_f_inv => @finv k
    | OqG => peval qG_poly k
    | OqH => peval qH_poly k
    | OqD => peval qD_poly k
    | Oxor t => BVxor (Ut.len k t)
    | Ozero => Bvect_false (k1 k)
    | Oone => Bvect_true (n k)
    end.

   Implicit Arguments interp_op [k].

   Definition cinterp_op (k:nat) (op:t) : T.ctype_op k (targs op) (tres op) :=
    match op as op0 return T.ctype_op k (targs op0) (tres op0) with
    | Oapp_f => fun v => (@f k v, peval cost_f k)
    | Oapp_f_inv => fun v => (@finv k v, cost_finv k)
    | OqG => (peval qG_poly k, 1)
    | OqH => (peval qH_poly k, 1)
    | OqD => (peval qD_poly k, 1)
    | Oxor t => fun v1 v2 => (BVxor (Ut.len k t) v1 v2, Ut.len k t)
    | Ozero => (Bvect_false (k1 k), 1)
    | Oone => (Bvect_true (n k), 1)
    end.

   Implicit Arguments cinterp_op [k].

   Definition eval_op k
    (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) :=
    @T.app_op k (targs op) (tres op) (interp_op op) args.

   Definition ceval_op k
    (op:t) (args: dlist (T.interp k) (targs op)) : T.interp k (tres op) * nat :=
    @T.capp_op k (targs op) (tres op) (cinterp_op op) args.

   Lemma ceval_op_spec : forall k op args,
    @eval_op k op args = fst (@ceval_op k op args).
   Proof.
    intros k o args; destruct o; simpl in args;
    T.dlist_inversion args; rewrite Heq; trivial.
   Qed.

 End UOp.

 Export TP.

 (** Semantics with optimizations *)
 Module SemO <: SEM_OPT.

  Module Sem := MakeSem.Make Ut T UOp US.
  Import Sem.

  (* The trapdoor permutation and its inverse *)
  Notation "'{0,1}^k0'" := (E.Duser (Usupport T.User Bitstring_k0)).
  Notation "'{0,1}^n'" := (E.Duser (Usupport T.User Bitstring_n)).
  Notation "'{0,1}^k1'" := (E.Duser (Usupport T.User Bitstring_k1)).

  Notation " x '|x|' y " := (E.Eop (O.Ouser (Oxor _)) {x, y}) (at level 50, left associativity).
  Notation "'ap_f' x" := (E.Eop (O.Ouser Oapp_f) {x}) (at level 40).
  Notation "'ap_finv' x" := (E.Eop (O.Ouser Oapp_f_inv) {x}) (at level 40).
  Notation "'qG'" := (E.Eop (O.Ouser OqG) (dnil _)).
  Notation "'qH'" := (E.Eop (O.Ouser OqH) (dnil _)).
  Notation "'qD'" := (E.Eop (O.Ouser OqD) (dnil _)).
  Notation zero_k1 := (E.Eop (O.Ouser Ozero) (dnil _)).
  Notation one_n := (E.Eop (O.Ouser Oone) (dnil _)).

  Definition simpl_op (op:Uop.t) (args:E.args (Uop.targs op)) :=
   E.Eop (O.Ouser op) args.

  Implicit Arguments simpl_op [].

  Lemma simpl_op_spec : forall k op args (m:Mem.t k),
   E.eval_expr (simpl_op op args) m = E.eval_expr (E.Eop (O.Ouser op) args) m.
  Proof.
   trivial.
  Qed.

 End SemO.

 Module BP := BaseProp.Make SemO.Sem.

 Module Uppt.

  Import BP.
  Import SemO.

  Implicit Arguments T.size [k t].

  (** PPT expression *)
  Definition PPT_expr (t:T.type) (e:E.expr t)
   (F:polynomial -> polynomial)
   (G:polynomial -> polynomial) : Prop :=
   forall k (m:Mem.t k) p,
    (forall t (x:Var.var t),
     BP.Vset.mem x (BP.fv_expr e) -> T.size (m x) <= peval p k)  ->
    let (v,n) := E.ceval_expr e m in
     T.size v <= peval (F p) k /\
     n <= peval (G p) k.

   (** PPT support *)
   Definition PPT_support t (s:E.support t)
   (F:polynomial -> polynomial)
   (G:polynomial -> polynomial) : Prop :=
   forall k (m:Mem.t k) p,
    (forall t (x:Var.var t),
     BP.Vset.mem x (BP.fv_distr s) -> T.size (m x) <= peval p k)  ->
    let (l,n) := E.ceval_support s m in
     (forall v, In v l -> T.size v <= peval (F p) k) /\
     n <= peval (G p) k.

   Definition utsize : UT.t -> nat := fun _ => 1.

   Definition utsize_default_poly : nat -> polynomial :=
    fun _ => pplus (pcst 1) pvar.

   Lemma utsize_default_poly_spec : forall r ut,
    utsize ut <= r ->
    forall k, UT.size (UT.default k ut) <= peval (utsize_default_poly r) k.
   Proof.
    intros r ut _ k.
    simpl.
    unfold UT.default, UT.size, utsize_default_poly.
    rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
    simpl; apply le_n_S; apply Ut.len_le.
   Qed.

   Definition uop_poly (o:Uop.t) : bool :=
    match o with
    | Oapp_f_inv => false
    | _ => true
    end.

   Lemma uop_poly_spec : forall o (la:dlist E.expr (O.targs (O.Ouser o))),
    uop_poly o ->
    (forall t (e:E.expr t), @DIn _ E.expr _ e _ la ->
     exists F, exists G, PPT_expr e F G) ->
    exists F, exists G, PPT_expr (E.Eop (O.Ouser o) la) F G.
   Proof.
    intros o la H Hla.
    destruct o; simpl.

    (* Oapp_f *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    destruct (Hla _ x) as [F1 [G1 H1] ].
    left; trivial.
    exists (fun _ => pplus (pcst 5) pvar).
    exists (fun p => pplus (cost_f) (G1 p)).
    simpl; split.
    unfold T.size, UT.size, UOp.Tk, UOp.Tnk1; rewrite pplus_spec, pcst_spec, pvar_spec; trivial.
    simpl;assert (W:= k_spec k);omega.
    simpl; rewrite pplus_spec.
    generalize (H1 k m p); clear H1.
    case_eq (E.ceval_expr x m); simpl.
    intros i n0 Heqi Hi.
    destruct Hi.
    intros; apply H0; simpl.
    apply Vset.subset_correct with (fv_expr x); [ | trivial].
    unfold fv_expr; simpl; auto with set.
    rewrite plus_0_r; trivial.
    omega.

    discriminate H.

    (* OqG *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => pplus (pcst 1) qG_poly).
    exists (fun _ => pcst 1).
    simpl; split.
    rewrite pplus_spec, pcst_spec; case (peval qG_poly k).
    trivial.
    intro n0; apply le_trans with (S n0); [apply size_nat_le | ]; auto with arith.
    rewrite pcst_spec; trivial.

    (* OqH *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => pplus (pcst 1) qH_poly).
    exists (fun _ => pcst 1).
    simpl; split.
    rewrite pplus_spec, pcst_spec; case (peval qH_poly k).
    trivial.
    intro n0; apply le_trans with (S n0); [apply size_nat_le | ]; auto with arith.
    rewrite pcst_spec; trivial.

    (* OqD *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => pplus (pcst 1) qD_poly).
    exists (fun _ => pcst 1).
    simpl; split.
    rewrite pplus_spec, pcst_spec; case (peval qD_poly k).
    trivial.
    intro n0; apply le_trans with (S n0); [apply size_nat_le | ]; auto with arith.
    rewrite pcst_spec; trivial.

    (* Oxor *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    destruct (Hla _ x) as [F1 [G1 H1] ].
    left; trivial.
    destruct (Hla _ x0) as [F2 [G2 H2] ].
    right; left; trivial.
    exists (fun _ => pplus (pcst 1) pvar).
    exists (fun p => pplus (pplus (pcst 1) pvar) (pplus (G1 p) (G2 p))).
    simpl; split.
    exact (UT.default_poly_spec k t).

    generalize (H1 k m p) (H2 k m p); clear H1 H2.
    simpl.
    case_eq (E.ceval_expr x m); simpl.
    case_eq (E.ceval_expr x0 m); simpl.
    intros i n1 Heqi i0 n0 Heqi0 Hi Hi0.
    destruct Hi.
    intros; apply H0; simpl.
    apply Vset.subset_correct with (fv_expr x); [ | trivial].
    unfold fv_expr; simpl.
    apply fv_expr_rec_subset.
    destruct Hi0.
    intros; apply H0; simpl.
    apply Vset.subset_correct with (fv_expr x0); [ | trivial].
    unfold fv_expr at 2; simpl.
    fold (fv_expr_extend x0 (fv_expr_rec Vset.empty x)).
    rewrite union_fv_expr_spec.
    apply VsetP.subset_union_l.

    rewrite pplus_spec, pplus_spec, pplus_spec,  pcst_spec, pvar_spec.
    apply plus_le_compat; auto.
    apply le_trans with k.
    exact (Ut.len_le k t).
    auto with arith.
    rewrite plus_0_r; apply plus_le_compat; trivial.

    (* Ozero *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => pplus (pcst 1) pvar).
    exists (fun _ => pcst 1).
    simpl; split.
    rewrite pplus_spec, pcst_spec.
    trivial.
    rewrite pvar_spec.
    unfold T.size, Ut.size; simpl.
    apply le_n_S.
    rewrite k_spec; omega.
    rewrite pcst_spec; trivial.

    (* Oone *)
    T.dlist_inversion la.
    rewrite Heq in Hla |- *.
    exists (fun _ => pplus (pcst 1) pvar).
    exists (fun _ => pcst 1).
    simpl; split.
    rewrite pplus_spec, pcst_spec.
    trivial.
    rewrite pvar_spec.
    unfold T.size, Ut.size; simpl.
    apply le_n_S.
    rewrite k_spec; omega.
    rewrite pcst_spec; trivial.
   Qed.

   Definition usupport_poly t (us:US.usupport t) : bool :=
    match us with
    | Usupport _ => true
    end.

   Lemma usupport_poly_spec : forall t (us:US.usupport t),
    usupport_poly us ->
    exists F, exists G, PPT_support (E.Duser us) F G.
   Proof.
    intros t us; destruct us; intros _.
    exists (fun _ => pplus (pcst 1) pvar).
    exists (fun _ => pcst 1).
    intros k m p Hm.
    simpl; split.
    intros; exact (UT.default_poly_spec k t).
    rewrite pcst_spec; trivial.
   Qed.

 End Uppt.

End Entries.

Declare Module TP : TRAPDOOR_PERM.
Module Ent := Entries TP.

Module Tactics := BuildTac2.Make Ent.
Export Tactics.


From sflib Require Import sflib.
From Paco Require Import paco.
From ITree Require Import ITree.
From Fairness Require Import
  ITreeLib WFLib Axioms pind LPCM Mod Linking ModSim ModSimAux ModSimNat AddWorld.

Import Lia.
Import Mod.
Import RelationClasses.

Section ADD_COMM.

  Definition conv {id1 id2 wf} (m_tgt : @imap (ident_tgt (id_sum id2 id1)) wf) :
    @imap (id_sum id1 id2) wf :=
    fun i =>
      match i with
      | inl i => m_tgt (inr (inr i))
      | inr i => m_tgt (inr (inl i))
      end.

End ADD_COMM.

Section IMAP_OPERATIONS.

  Context {id_ctx id_src id_tgt : ID}.
  Context {wf_src : WF}.

  Definition sum_wf wf1 wf2 := {| wf := sum_lt_well_founded (wf wf1) (wf wf2) |}.

  Definition pick_ctx
    (IM_TGT : @imap (ident_tgt (id_sum id_ctx id_tgt)) nat_wf)
    : @imap id_ctx nat_wf := fun i => IM_TGT (inr (inl i)).

  Definition chop_ctx
    (ths : TIdSet.t)
    (IM_TGT : @imap (ident_tgt (id_sum id_ctx id_tgt)) nat_wf)
    : @imap (ident_tgt id_tgt) nat_wf:=
    fun i => match i with
          | inl i => if NatMapP.F.In_dec ths i then IM_TGT (inl i) else 0
          | inr i => IM_TGT (inr (inr i))
          end.

  Definition add_ctx
    (im_ctx : imap id_ctx nat_wf)
    (im_src : imap id_src wf_src)
    : forall i, (sum_wf wf_src nat_wf).(T)
    := fun i => match i with
             | inl i => inr (im_ctx i)
             | inr i => inl (im_src i)
             end.

  Lemma pick_ctx_fair_thread IM_TGT0 IM_TGT1 m
    (FAIR : fair_update IM_TGT0 IM_TGT1 (prism_fmap inlp m))
    : pick_ctx IM_TGT0 = pick_ctx IM_TGT1.
  Proof.
    extensionalities i. specialize (FAIR (inr (inl i))). ss.
  Qed.

  Lemma chop_ctx_fair_ctx ths_usr IM_TGT0 IM_TGT1 m
    (FAIR : fair_update IM_TGT0 IM_TGT1 (prism_fmap inrp (prism_fmap inlp m)))
    : chop_ctx ths_usr IM_TGT0 = chop_ctx ths_usr IM_TGT1.
  Proof.
    extensionalities i. destruct i as [i|i]; ss.
    - specialize (FAIR (inl i)). ss. des_ifs.
    - specialize (FAIR (inr (inr i))). ss.
  Qed.

  Lemma chop_ctx_fair_thread1 ths ths_ctx ths_usr tid IM_TGT0 IM_TGT1
    (PARTITION : NatMapP.Partition ths ths_ctx ths_usr)
    (TID_CTX : NatMap.In tid ths_ctx)
    (FAIR : fair_update IM_TGT0 IM_TGT1 (prism_fmap inlp (tids_fmap tid ths)))
    : fair_update (chop_ctx ths_usr IM_TGT0) (chop_ctx ths_usr IM_TGT1) (prism_fmap inlp (tids_fmap_all ths_usr)).
  Proof.
    ii. unfold prism_fmap in *; ss. destruct i as [i|i]; ss.
    - specialize (FAIR (inl i)). ss. destruct (tids_fmap_all ths_usr i) eqn:E; ss.
      + unfold tids_fmap_all, tids_fmap in FAIR, E. destruct (NatMapP.F.In_dec ths_usr i); ss.
        assert (NatMap.In i ths). (* i ∈ ths_usr ⊂ ths *)
        { eapply Partition_In_right in PARTITION; eauto. }
        assert (i <> tid). (* ths_ctx ∩ ths_usr = ∅, i ∈ ths_usr, tid ∈ ths_ctx *)
        { ii. subst. destruct PARTITION. eapply H0. eauto. }
        des_ifs.
      + unfold tids_fmap_all, tids_fmap in FAIR, E. des_ifs.
    - specialize (FAIR (inr (inr i))). ss.
  Qed.

  Lemma chop_ctx_fair_thread2 ths ths_usr tid IM_TGT0 IM_TGT1
    (LE : KeySetLE ths_usr ths)
    (FAIR : fair_update IM_TGT0 IM_TGT1 (prism_fmap inlp (tids_fmap tid ths)))
    : fair_update (chop_ctx ths_usr IM_TGT0) (chop_ctx ths_usr IM_TGT1) (prism_fmap inlp (tids_fmap tid ths_usr)).
  Proof.
    ii. unfold prism_fmap in *; ss. destruct i as [i|i]; ss.
    - specialize (FAIR (inl i)); ss. destruct (NatMapP.F.In_dec ths_usr i).
      + pose proof (LE _ i0). unfold tids_fmap in *. des_ifs.
      + unfold tids_fmap in *. des_ifs.
    - specialize (FAIR (inr (inr i))); ss.
  Qed.

End IMAP_OPERATIONS.

Section SIM_REFLEXIVE.

  Context {A S_src S_tgt : Type}.
  Context {J K_src K_tgt : Type}.
  Context {l_src : Lens.t S_src A}.
  Context {l_tgt : Lens.t S_tgt A}.
  Context {p_src : Prism.t K_src J}.
  Context {p_tgt : Prism.t K_tgt J}.

  Variable I : @shared S_src S_tgt K_src K_tgt nat_wf nat_wf -> Unit -> Prop.

  Hypothesis I_update_thread :
    forall ths im_src im_tgt st_src st_tgt w,
      I (ths, im_src, im_tgt, st_src, st_tgt) w ->
        forall ths' w', I (ths', im_src, im_tgt, st_src, st_tgt) w'.

  Hypothesis I_update_state :
    forall ths im_src im_tgt st_src st_tgt w,
      I (ths, im_src, im_tgt, st_src, st_tgt) w ->
      Lens.view l_src st_src = Lens.view l_tgt st_tgt /\
        forall st st_src' st_tgt' w',
          st_src' = Lens.set l_src st st_src ->
          st_tgt' = Lens.set l_tgt st st_tgt ->
          I (ths, im_src, im_tgt, st_src', st_tgt') w'.

  Hypothesis I_update_imap :
    forall ths im_src im_tgt st_src st_tgt w,
      I (ths, im_src, im_tgt, st_src, st_tgt) w ->
      Lens.view (prisml p_src) im_src = Lens.view (prisml (inrp ⋅ p_tgt)%prism) im_tgt /\
        forall im im_src' im_tgt' w',
          im_src' = Lens.set (prisml p_src) im im_src ->
          im_tgt' = Lens.set (prisml (inrp ⋅ p_tgt)%prism) im im_tgt ->
          I (ths, im_src', im_tgt', st_src, st_tgt) w'.

  Hypothesis I_update_imap_thread_id :
    forall ths im_src im_tgt st_src st_tgt w,
      I (ths, im_src, im_tgt, st_src, st_tgt) w ->
      forall im im_tgt' w',
        im_tgt' = Lens.set (prisml inlp) im im_tgt ->
        I (ths, im_src, im_tgt', st_src, st_tgt) w'.

  Lemma I_update_imap_fair
    ths im_src im_tgt st_src st_tgt w
    fm im_src' im_tgt' w'
    (FAIR : fair_update im_tgt im_tgt' (prism_fmap (inrp ⋅ p_tgt)%prism fm))
    (SRC : im_src' = Lens.set (prisml p_src) (Lens.view (prisml (inrp ⋅ p_tgt)%prism) im_tgt') im_src)
    (INV : I (ths, im_src, im_tgt, st_src, st_tgt) w)
    : I (ths, im_src', im_tgt', st_src, st_tgt) w'.
  Proof.
    eapply I_update_imap.
    - eapply INV.
    - eapply SRC.
    - extensionalities i. specialize (FAIR i). destruct i; ss.
      unfold prism_fmap in FAIR. cbn in FAIR. cbn. destruct (Prism.preview p_tgt k) eqn: Heq; ss.
      eapply Prism.review_preview in Heq. subst. des_ifs.
  Qed.

  Lemma I_update_imap_thread_id_fair
    ths im_src im_tgt st_src st_tgt w
    fm im_tgt' w'
    (FAIR : fair_update im_tgt im_tgt' (prism_fmap inlp fm))
    (INV : I (ths, im_src, im_tgt, st_src, st_tgt) w)
    : I (ths, im_src, im_tgt', st_src, st_tgt) w'.
  Proof.
    eapply I_update_imap_thread_id.
    - eapply INV.
    - extensionalities i. specialize (FAIR i). destruct i; ss.
  Qed.

  Tactic Notation "hspecialize" hyp(H) "with" uconstr(x) :=
    apply (_equal_f _ _ _ _ x) in H.

  Section LSIM.

    Variable R : Type.
    Variable RR : R -> R -> Unit -> shared S_src S_tgt K_src K_tgt nat_wf nat_wf -> Prop.

    Hypothesis I_RR_compatible :
      forall r ths im_src im_tgt st_src st_tgt w w',
        I (ths, im_src, im_tgt, st_src, st_tgt) w ->
        RR r r w' (ths, im_src, im_tgt, st_src, st_tgt).

    Lemma lsim_refl :
      forall tid (itr : itree (programE J A) R)
        fs ft r_ctx ths im_src im_tgt st_src st_tgt
        (INV : I (ths, im_src, im_tgt, st_src, st_tgt) tt),
        lsim I tid RR fs ft r_ctx
          (map_event (plmap p_src l_src) itr)
          (map_event (plmap p_tgt l_tgt) itr)
          (ths, im_src, im_tgt, st_src, st_tgt).
    Proof.
      clear I_update_thread.
      intro tid. ginit. gcofix CIH. i.
      destruct_itree itr.
      - rewrite ! map_event_ret.
        gstep. eapply pind9_fold. eapply lsim_ret. eauto.
      - rewrite ! map_event_tau.
        gstep.
        eapply pind9_fold. eapply lsim_tauL. split; ss.
        eapply pind9_fold. eapply lsim_tauR. split; ss.
        eapply pind9_fold. eapply lsim_progress.
        gbase. eapply CIH; eauto.
      - rewrite ! map_event_vis, <- ! bind_trigger. gstep.
        destruct e as [[[e|e]|e]|e]; destruct e.
        + eapply pind9_fold. eapply lsim_chooseR. i. esplit; ss.
          eapply pind9_fold. eapply lsim_chooseL. exists x. esplit; ss.
          eapply pind9_fold. eapply lsim_progress.
          gbase. eapply CIH; eauto.
        + eapply pind9_fold. eapply lsim_fairR. i. esplit; ss.
          eapply pind9_fold. eapply lsim_fairL.
          exists (Lens.set (prisml p_src) (Lens.view (prisml (inrp ⋅ p_tgt)%prism) im_tgt1) im_src). split.
          { eapply I_update_imap in INV. des. ii.
            unfold prism_fmap; cbn. destruct (Prism.preview p_src i) eqn: Heq; ss.
            eapply Prism.review_preview in Heq; subst.
            hspecialize INV with j. cbn in INV. rewrite INV.
            specialize (FAIR (Prism.review (inrp ⋅ p_tgt)%prism j)). cbn in FAIR.
            unfold prism_fmap in FAIR. rewrite Prism.preview_review in FAIR; ss.
          }
          split; ss.
          eapply pind9_fold. eapply lsim_progress.
          gbase. des. eapply CIH.
          { rewrite <- prism_fmap_compose in FAIR. eapply I_update_imap_fair; eauto. }
        + eapply pind9_fold. eapply lsim_observe. i.
          gbase. eapply CIH; eauto.
        + eapply pind9_fold. eapply lsim_UB.
        + eapply pind9_fold. eapply lsim_sync; eauto using Unit_wf. i.
          gbase. eapply CIH.
          { eapply I_update_imap_thread_id_fair; eauto. }
        + eapply pind9_fold. eapply lsim_tidR. esplit; ss.
          eapply pind9_fold. eapply lsim_tidL. esplit; ss.
          eapply pind9_fold. eapply lsim_progress.
          gbase. eapply CIH; eauto.
        + eapply pind9_fold. eapply lsim_call. i.
          gbase. eapply CIH; eauto.
        + eapply pind9_fold. eapply lsim_rmwL. esplit; ss.
          eapply pind9_fold. eapply lsim_rmwR. esplit; ss.
          eapply pind9_fold. eapply lsim_progress.
          eapply I_update_state in INV. des. rewrite INV.
          gbase. eapply CIH; eauto.
          Unshelve. all: ss.
    Qed.

  End LSIM.

  Lemma local_sim_refl R (itr : itree (programE J A) R) :
    local_sim I eq (map_event (plmap p_src l_src) itr) (map_event (plmap p_tgt l_tgt) itr).
  Proof.
    ii. exists tt, tt. splits; eauto using Unit_wf.
    { eapply I_update_imap_thread_id_fair; eauto. }
    i.
    assert (INV_CIH : I (ths, im_src1, im_tgt3, st_src2, st_tgt2) tt).
    { eapply I_update_imap_thread_id_fair; eauto. }
    eapply lsim_refl; eauto.
    i. ss. esplits; eauto using Unit_wf.
    Unshelve. all: exact tt.
  Qed.

End SIM_REFLEXIVE.

Section ADD_RIGHT_MONO_SIM.

  Context {M1 M2_src M2_tgt : Mod.t}.
  Context {wf_src : WF}.
  Context `{world : URA.t}.

  Variable I : shared (state M2_src) (state M2_tgt) (ident M2_src) (ident M2_tgt) wf_src nat_wf -> world -> Prop.

  Definition lift_ma :=
    fun (x : @shared
            (ModAdd M1 M2_src).(state) (ModAdd M1 M2_tgt).(state)
            (ModAdd M1 M2_src).(ident) (ModAdd M1 M2_tgt).(ident)
            (sum_wf wf_src nat_wf) nat_wf)
      (r : URA.prod threadsRA world)
    => let '(ths, IM_SRC, IM_TGT, st_src, st_tgt) := x in
      exists im_src0 ths_ctx0 ths_usr0,
        let im_ctx0 := pick_ctx IM_TGT in
        let im_tgt0 := chop_ctx ths_usr0 IM_TGT in
        IM_SRC = add_ctx im_ctx0 im_src0
        /\ NatMapP.Partition ths ths_ctx0 ths_usr0
        /\ fst r = global_th ths_ctx0 ths_usr0
        /\ fst st_src = fst st_tgt
        /\ lifted I (ths_usr0, im_src0, im_tgt0, snd st_src, snd st_tgt) (snd r).

  Opaque lifted threadsRA URA.prod.

  Lemma lift_ma_local_sim_ub R_src R_tgt (RR : R_src -> R_tgt -> Prop) ktr_src itr_tgt
    : local_sim lift_ma RR (Vis (inl1 (inl1 (inl1 Undefined))) ktr_src) itr_tgt.
  Proof.
    (* treat as if tid ∈ ths_ctx *)
    intros ths IM_SRC0 IM_TGT0 st_src0 st_tgt0 [r_sha_th0 r_sha_w0] [r_ctx_th0 r_ctx_w0] INV0_0 tid ths0 THS0 VALID0_0 IM_TGT1 TID_TGT.
    simpl in INV0_0. des. subst r_sha_th0. unfold_prod VALID0_0.
    assert (CTX_TGT : pick_ctx IM_TGT0 = pick_ctx IM_TGT1).
    { extensionalities i. specialize (TID_TGT (inr (inl i))). ss. }
    assert (USR_TGT : chop_ctx ths_usr0 IM_TGT0 = chop_ctx ths_usr0 IM_TGT1).
    { extensionalities i. destruct i as [i|i].
      - specialize (TID_TGT (inl i)). unfold prism_fmap in *; ss. des_ifs. exfalso.
        eapply inv_add_new in THS0. des. eapply THS0.
        eapply Partition_In_right in INV0_1. eapply INV0_1.
        ss.
      - specialize (TID_TGT (inr (inr i))). ss.
    }
    exists (global_th (TIdSet.add tid ths_ctx0) ths_usr0, r_sha_w0), (local_th_context tid, URA.unit). splits.
    { exists im_src0, (TIdSet.add tid ths_ctx0), ths_usr0. splits; ss.
      - subst. rewrite CTX_TGT. ss.
      - eauto using NatMapP.Partition_sym, Partition_add.
      - rewrite USR_TGT in INV0_4. ss.
    }
    { unfold_prod. split.
      - eapply inv_add_new in THS0. des; subst. eapply global_th_alloc_context.
        + eauto.
        + eapply inv_add_new. split; ss.
          ii. eapply THS0. eapply (Partition_In_left INV0_1). ss.
        + ii. eapply THS0. eapply (Partition_In_right INV0_1). ss.
      - rewrite URA.unit_id. eauto.
    }
    i. pfold. eapply pind9_fold. rewrite <- bind_trigger. econs.
  Qed.

  Lemma lift_ma_local_sim_ctx R (itr : itree _ R)
    : local_sim lift_ma eq (map_event (emb_l M1 M2_src) itr) (map_event (emb_l M1 M2_tgt) itr).
  Proof.
    (* tid ∈ ths_ctx *)
    intros ths IM_SRC0 IM_TGT0 st_src0 st_tgt0 [r_sha_th0 r_sha_w0] [r_ctx_th0 r_ctx_w0] INV0_0 tid ths0 THS0 VALID0_0 IM_TGT1 TID_TGT.
    simpl in INV0_0. des. subst r_sha_th0. unfold_prod VALID0_0.
    assert (CTX_TGT : pick_ctx IM_TGT0 = pick_ctx IM_TGT1).
    { extensionalities i. specialize (TID_TGT (inr (inl i))). ss. }
    assert (USR_TGT : chop_ctx ths_usr0 IM_TGT0 = chop_ctx ths_usr0 IM_TGT1).
    { extensionalities i. destruct i as [i|i].
      - specialize (TID_TGT (inl i)). unfold prism_fmap in *; ss. des_ifs. exfalso.
        eapply inv_add_new in THS0. des. eapply THS0.
        eapply Partition_In_right in INV0_1. eapply INV0_1.
        ss.
      - specialize (TID_TGT (inr (inr i))). ss.
    }
    exists (global_th (TIdSet.add tid ths_ctx0) ths_usr0, r_sha_w0), (local_th_context tid, URA.unit). splits.
    { exists im_src0, (TIdSet.add tid ths_ctx0), ths_usr0. splits; ss.
      - subst. rewrite CTX_TGT. ss.
      - eauto using NatMapP.Partition_sym, Partition_add.
      - rewrite USR_TGT in INV0_4. ss.
    }
    { unfold_prod. split.
      - eapply inv_add_new in THS0. des; subst. eapply global_th_alloc_context.
        + eauto.
        + eapply inv_add_new. split; ss.
          ii. eapply THS0. eapply (Partition_In_left INV0_1). ss.
        + ii. eapply THS0. eapply (Partition_In_right INV0_1). ss.
      - rewrite URA.unit_id. eauto.
    }
    intros ths1 IM_SRC1 IM_TGT2 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0.
    intros IM_TGT2' TGT fs ft.
    simpl in INV1_0. des. subst r_sha_th1. unfold_prod VALID1_0.
    unfold emb_l, emb_r.
    assert (INV : lift_ma (ths1, IM_SRC1, IM_TGT2', st_src1, st_tgt1) (global_th ths_ctx1 ths_usr1, r_sha_w1)).
    { ss. exists im_src1, ths_ctx1, ths_usr1. splits; ss.
      - eapply pick_ctx_fair_thread in TGT. rewrite <- TGT. ss.
      - eapply shared_rel_wf_lifted; eauto.
        eapply chop_ctx_fair_thread1; eauto.
        eapply local_th_context_in_context; eauto.
    }
    clear - INV VALID1_0 VALID1_1. move itr after tid.
    rename
      ths1 into ths0, ths_ctx1 into ths_ctx0, ths_usr1 into ths_usr0,
      IM_SRC1 into IM_SRC0, IM_TGT2' into IM_TGT0, st_src1 into st_src0, st_tgt1 into st_tgt0,
      r_sha_w1 into r_sha_w0, r_ctx_th1 into r_ctx_th0, r_ctx_w1 into r_ctx_w0,
      INV into INV0, VALID1_0 into VALID_TH0, VALID1_1 into VALID_W0.
    revert_until tid. ginit. gcofix CIH. i.
    destruct_itree itr; [| | destruct e as [[[]|]|] ].
    - rewrite ! map_event_ret.
      gstep. eapply pind9_fold. econs. ss.
      exists (NatSet.remove tid ths0), (URA.unit, URA.unit), (global_th (NatSet.remove tid ths_ctx0) ths_usr0, r_sha_w0).
      splits; ss.
      { unfold_prod. split.
        - eapply global_th_dealloc_context; eauto.
        - eauto.
      }
      { des. inversion INV2. subst ths_ctx1 ths_usr1. exists im_src0, (NatSet.remove tid ths_ctx0), ths_usr0. splits; ss.
        eapply local_th_context_in_context in VALID_TH0.
        eauto using NatMapP.Partition_sym, Partition_remove.
      }
    - rewrite ! map_event_tau.
      gstep.
      eapply pind9_fold. econs. split; ss.
      eapply pind9_fold. econs. split; ss.
      eapply pind9_fold. econs.
      gfinal. left. eapply CIH; eauto.
    - rewrite ! map_event_vis.
      rewrite <- 2 bind_trigger.
      gstep. destruct e; ss.
      + eapply pind9_fold. eapply lsim_chooseR. i. esplit; ss.
        eapply pind9_fold. eapply lsim_chooseL. exists x. esplit; ss.
        eapply pind9_fold. eapply lsim_progress.
        gfinal. left. eapply CIH; eauto.
      + eapply pind9_fold. eapply lsim_fairR. intros IM_TGT1 FAIR. esplit; ss.
        eapply pind9_fold. eapply lsim_fairL.
        des. inversion INV2. subst ths_ctx1 ths_usr1. exists (add_ctx (pick_ctx IM_TGT1) im_src0). split.
        { subst. ii. destruct i; ss.
          specialize (FAIR (inr (inl i))). unfold pick_ctx. ss.
          unfold prism_fmap in *. ss. des_ifs.
          + econs. ss.
          + f_equal. ss.
        }
        split; ss.
        eapply pind9_fold. eapply lsim_progress.
        gfinal. left. des. eapply CIH; eauto.
        { esplits; eauto. eapply chop_ctx_fair_ctx in FAIR. rewrite <- FAIR. ss. }
      + eapply pind9_fold. eapply lsim_observe. i.
        gfinal. left. eapply CIH; eauto.
      + eapply pind9_fold. eapply lsim_UB.
    - rewrite ! map_event_vis. simpl.
      rewrite <- 2 bind_trigger.
      gstep. destruct c.
      + eapply pind9_fold. eapply lsim_sync.
        { eapply INV0. }
        { instantiate (1 := (local_th_context tid, ε)). unfold_prod. split; ss. }
        intros ths1 IM_SRC1 IM_TGT1 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0 IM_TGT1' TGT.
        simpl in INV1_0. des. subst r_sha_th1. rename im_src0 into im_src1. unfold_prod VALID1_0.
        gfinal. left. eapply CIH; eauto.
        { exists im_src1, ths_ctx1, ths_usr1. ss. splits; ss.
          - eapply pick_ctx_fair_thread in TGT. rewrite <- TGT. ss.
          - eapply shared_rel_wf_lifted; eauto.
            eapply chop_ctx_fair_thread1; eauto.
            eapply local_th_context_in_context; eauto.
        }
      + eapply pind9_fold. eapply lsim_tidR. esplit; ss.
        eapply pind9_fold. eapply lsim_tidL. esplit; ss.
        eapply pind9_fold. eapply lsim_progress.
        gfinal. left. eapply CIH; eauto.
    - rewrite ! map_event_vis. ss.
      rewrite <- 2 bind_trigger.
      destruct c. gstep. eapply pind9_fold. eapply lsim_call.
      i. gfinal. left. eapply CIH; eauto.
    - destruct s.
      rewrite ! map_event_vis. ss.
      rewrite <- 2 bind_trigger.
      gstep.
      eapply pind9_fold. eapply lsim_rmwL. esplit; ss.
      eapply pind9_fold. eapply lsim_rmwR. esplit; ss.
      eapply pind9_fold. eapply lsim_progress.
      gbase. des. destruct st_src0, st_tgt0; ss. subst.
      eapply CIH; eauto. esplits; eauto.
  Qed.

  Lemma lift_ma_local_sim_usr R_src R_tgt (RR : R_src -> R_tgt -> Prop) itr_src itr_tgt
    (SIM : local_sim (lifted I) RR itr_src itr_tgt)
    : local_sim lift_ma RR (map_event (emb_r M1 M2_src) itr_src) (map_event (emb_r M1 M2_tgt) itr_tgt).
  Proof.
    (* tid ∈ ths_usr *)
    intros ths IM_SRC0 IM_TGT0 st_src0 st_tgt0 [r_sha_th0 r_sha_w0] [r_ctx_th0 r_ctx_w0] INV0_0 tid ths0 THS0 VALID0_0. i.
    simpl in INV0_0. des. subst r_sha_th0. unfold_prod VALID0_0.
    move SIM at bottom.
    assert (THS0' : TIdSet.add_new tid ths_usr0 (TIdSet.add tid ths_usr0)).
    { eapply inv_add_new. split; ss. eapply inv_add_new in THS0. des.
      eapply Partition_In_right in INV0_1. eauto.
    }
    assert (TID_TGT' : fair_update (chop_ctx ths_usr0 IM_TGT0) (chop_ctx (NatSet.add tid ths_usr0) im_tgt1) (prism_fmap inlp (fun i => if Nat.eq_dec i tid then Flag.success else Flag.emp))).
    { ii. destruct i as [i|i]; ss.
      - specialize (TID_TGT (inl i)). unfold prism_fmap in *; ss. destruct (Nat.eq_dec i tid); ss.
        assert (H : tid <> i) by lia.
        eapply NatMapP.F.add_neq_in_iff with (m := ths_usr0) (e := tt) in H.
        des_ifs; tauto.
      - specialize (TID_TGT (inr (inr i))). des_ifs.
    }
    specialize (SIM ths_usr0 im_src0 (chop_ctx ths_usr0 IM_TGT0) (snd st_src0) (snd st_tgt0) r_sha_w0 r_ctx_w0 INV0_4 tid (NatSet.add tid ths_usr0) THS0' VALID0_1 (chop_ctx (NatSet.add tid ths_usr0) im_tgt1) TID_TGT').
    destruct SIM as [r_sha_w1 [r_own_w1 [INV_USR [VALID_USR SIM]]]].
    exists (global_th ths_ctx0 (NatSet.add tid ths_usr0), r_sha_w1), (local_th_user tid, r_own_w1). splits.
    { eapply inv_add_new in THS0. des. subst.
      ss. esplits; ss.
      - instantiate (1 := im_src0). extensionalities i. destruct i; ss.
        specialize (TID_TGT (inr (inl i))). ss.
        unfold pick_ctx. f_equal. ss.
      - eapply Partition_add; eauto.
        eapply inv_add_new; eauto.
      - eapply INV_USR.
    }
    { unfold_prod. split.
      - eapply global_th_alloc_user; eauto.
        eapply inv_add_new in THS0. des. ii. eapply THS0.
        eapply Partition_In_left in INV0_1. eapply INV0_1. ss.
      - eauto.
    }
    intros ths2 IM_SRC2 IM_TGT2 st_src2 st_tgt2 [r_sha_th2 r_sha_w2] [r_ctx_th2 r_ctx_w2] INV2_0 VALID2_0 IM_TGT2' TGT fs ft.
    simpl in INV2_0. destruct INV2_0 as [im_src2 [ths_ctx2 [ths_usr2 INV2_0]]]. des. subst r_sha_th2. unfold_prod VALID2_0.
    assert (TGT' : @fair_update _ nat_wf (chop_ctx ths_usr2 IM_TGT2) (chop_ctx ths_usr2 IM_TGT2') (prism_fmap inlp (tids_fmap tid ths_usr2))).
    { eapply chop_ctx_fair_thread2.
      - eapply Partition_In_right in INV2_1. eapply INV2_1.
      - eauto.
    }
    specialize (SIM ths_usr2 im_src2 (chop_ctx ths_usr2 IM_TGT2) (snd st_src2) (snd st_tgt2) r_sha_w2 r_ctx_w2 INV2_4 VALID2_1 (chop_ctx ths_usr2 IM_TGT2') TGT' fs ft).
    unfold emb_r.

    eapply pick_ctx_fair_thread in TGT. rewrite TGT in INV2_0.
    clear - INV2_0 INV2_1 INV2_3 VALID2_0 VALID2_1 SIM.
    move tid before I.
    rename
      ths2 into ths0, ths_ctx2 into ths_ctx0, ths_usr2 into ths_usr0,
      im_src2 into im_src0, IM_SRC2 into IM_SRC0, IM_TGT2' into IM_TGT0, st_src2 into st_src0, st_tgt2 into st_tgt0,
      r_sha_w2 into r_sha_w0, r_ctx_th2 into r_ctx_th0, r_ctx_w2 into r_ctx_w0, r_own_w1 into r_own_w0,
      INV2_0 into INV0, INV2_1 into INV1, INV2_3 into INV2, VALID2_0 into VALID_TH0, VALID2_1 into VALID_W0.
    revert_until tid. ginit. gcofix CIH. i. gstep. punfold SIM.
    match type of SIM with pind9 _ _ _ _ ?RR _ _ _ _ _ ?SHA => remember RR as RR_MEM; remember SHA as SHA_MEM end.
    revert RR ths0 ths_ctx0 ths_usr0 st_src0 st_tgt0 r_sha_w0 r_own_w0 r_ctx_th0 im_src0 IM_SRC0 IM_TGT0 INV0 INV1 INV2 VALID_TH0 VALID_W0 HeqRR_MEM HeqSHA_MEM.
    pattern R_src, R_tgt, RR_MEM, fs, ft, r_ctx_w0, itr_src, itr_tgt, SHA_MEM.
    revert R_src R_tgt RR_MEM fs ft r_ctx_w0 itr_src itr_tgt SHA_MEM SIM.
    eapply pind9_acc. intros rr DEC IH R_src R_tgt RR_MEM fs ft r_ctx_w0 itr_src itr_tgt SHA_MEM. i.
    clear DEC. subst RR_MEM SHA_MEM.
    eapply pind9_unfold in PR; eauto with paco. eapply pind9_fold. inv PR.
    - clear - LSIM VALID_TH0 VALID_W0 INV1 INV2.
      rewrite ! map_event_ret. econs.
      ss. des. subst.
      exists (NatMap.remove tid ths0), (URA.unit, r_own), (global_th ths_ctx0 (NatMap.remove tid ths_usr0), r_shared).
      splits; ss.
      + unfold_prod. split.
        * eapply global_th_dealloc_user; eauto.
        * ss.
      + esplits; ss.
        * eapply local_th_user_in_user in VALID_TH0.
          eapply Partition_remove; eauto.
        * eapply lifted_drop_imap; eauto.
          { i. destruct i as [i|i]; ss.
            - assert (i = tid \/ tid <> i) by lia. destruct H.
              + pose proof NatMap.remove_1 H (m := ths_usr0). des_ifs; unfold le; ss; lia.
              + pose proof (@NatMapP.F.remove_neq_in_iff _ ths_usr0 tid i H). des_ifs; try tauto; reflexivity.
            - des_ifs. left. ss.
          }
    - rewrite ! map_event_tau. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs.
      des. destruct LSIM. exists x. split; ss. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs.
    - rewrite ! map_event_trigger. econs.
      des. destruct LSIM0. exists (add_ctx (pick_ctx IM_TGT0) im_src1). splits.
      { clear - FAIR. ii. destruct i as [i|i]; ss.
        unfold prism_fmap; ss. specialize (FAIR i). des_ifs.
        - econs. ss.
        - f_equal. ss.
      }
      split; ss. eapply IH; eauto.
    - rewrite ! map_event_tau. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs. i. specialize (LSIM x). split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs. split; ss.
      destruct LSIM. eapply IH; eauto.
    - rewrite ! map_event_trigger. econs. intros IM_TGT1 FAIR. split; ss.
      assert (FAIR' : fair_update (chop_ctx ths_usr0 IM_TGT0) (chop_ctx ths_usr0 IM_TGT1) (prism_fmap inrp f)).
      { ii. destruct i as [i|i]; ss.
        - specialize (FAIR (inl i)). ss. des_ifs.
        - specialize (FAIR (inr (inr i))). ss.
      }
      specialize (LSIM (chop_ctx ths_usr0 IM_TGT1) FAIR').
      destruct LSIM. eapply IH; eauto.
      + extensionalities i. destruct i; ss. f_equal.
        specialize (FAIR (inr (inl i))). ss.
    - rewrite ! map_event_trigger. econs. i. specialize (LSIM ret). pclearbot.
      gfinal. left. eapply CIH; eauto.
    - rewrite ! map_event_trigger. econs. i. specialize (LSIM ret). pclearbot.
      gfinal. left. eapply CIH; eauto.
    - match goal with [ |- __lsim _ _ _ _ _ _ _ _ _ (map_event ?EMB _) _ ] => set EMB as emb end.
      rewrite ! map_event_trigger.
      eapply lsim_yieldL. split; ss.
      replace (trigger Yield) with (trigger (emb unit (subevent unit Yield))) by ss.
      rewrite <- ! map_event_trigger.
      destruct LSIM. eapply IH; eauto.
    - match goal with [ |- __lsim _ _ _ _ _ _ _ _ (map_event ?EMB _) _ _ ] => set EMB as emb end.
      rewrite ! map_event_trigger.
      eapply lsim_yieldR.
      { instantiate (1 := (global_th ths_ctx0 ths_usr0, r_shared)).
        ss. exists im_src0, ths_ctx0, ths_usr0. splits; ss.
      }
      { instantiate (1 := (local_th_user tid, r_own)). unfold_prod. split; ss. }
      intros ths1 IM_SRC1 IM_TGT1 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0 IM_TGT2 TGT.
      split; ss. des. unfold_prod VALID1_0.
      assert (TGT' : fair_update (chop_ctx ths_usr1 IM_TGT1) (chop_ctx ths_usr1 IM_TGT2) (prism_fmap inlp (tids_fmap tid ths_usr1))).
      { ii. unfold prism_fmap. destruct i as [i|i]; ss.
        - eapply Partition_In_right in INV1_1. specialize (INV1_1 i). specialize (TGT (inl i)). unfold prism_fmap in *; ss.
          unfold tids_fmap in *. destruct (Nat.eq_dec i tid); ss. des_ifs.
          exfalso. tauto.
        - specialize (TGT (inr (inr i))). ss.
      }
      specialize (LSIM ths_usr1 im_src1 (chop_ctx ths_usr1 IM_TGT1) (snd st_src1) (snd st_tgt1) r_sha_w1 r_ctx_w1 INV1_4 VALID1_1 (chop_ctx ths_usr1 IM_TGT2) TGT').
      replace (trigger Yield) with (trigger (emb unit (subevent unit Yield))) by ss.
      rewrite <- ! map_event_trigger.
      destruct LSIM. eapply IH; eauto.
      + subst. extensionalities i. destruct i as [i|i]; ss. f_equal.
        specialize (TGT (inr (inl i))). ss.
      + subst. ss.
    - rewrite ! map_event_trigger. eapply lsim_sync.
      { instantiate (1 := (global_th ths_ctx0 ths_usr0, r_shared)).
        ss. exists im_src0, ths_ctx0, ths_usr0. splits; ss.
      }
      { instantiate (1 := (local_th_user tid, r_own)). unfold_prod. split; ss. }
      intros ths1 IM_SRC1 IM_TGT1 st_src1 st_tgt1 [r_sha_th1 r_sha_w1] [r_ctx_th1 r_ctx_w1] INV1_0 VALID1_0 IM_TGT2 TGT.
      ss. des. unfold_prod VALID1_0.
      assert (TGT' : fair_update (chop_ctx ths_usr1 IM_TGT1) (chop_ctx ths_usr1 IM_TGT2) (prism_fmap inlp (tids_fmap tid ths_usr1))).
      { ii. destruct i as [i|i]; ss.
        - eapply Partition_In_right in INV1_1. specialize (INV1_1 i). specialize (TGT (inl i)). unfold prism_fmap in *; ss.
          unfold tids_fmap in *. destruct (Nat.eq_dec i tid); ss. des_ifs.
          exfalso. tauto.
        - specialize (TGT (inr (inr i))). ss.
      }
      specialize (LSIM ths_usr1 im_src1 (chop_ctx ths_usr1 IM_TGT1) (snd st_src1) (snd st_tgt1) r_sha_w1 r_ctx_w1 INV1_4 VALID1_1 (chop_ctx ths_usr1 IM_TGT2) TGT').
      pclearbot. gfinal. left. eapply CIH; eauto.
      + subst. extensionalities i. destruct i as [i|i]; ss. f_equal.
        specialize (TGT (inr (inl i))). ss.
      + subst. ss.
    - econs. pclearbot. gfinal. left. eapply CIH; eauto.
  Qed.

End ADD_RIGHT_MONO_SIM.

Section MODADD_THEOREM.

  Theorem ModAdd_comm M1 M2 : ModSim.mod_sim (ModAdd M1 M2) (ModAdd M2 M1).
  Proof.
    Local Opaque Unit.
    pose proof Unit_wf.
    pose (I := fun (x : @shared
                       (ModAdd M1 M2).(state) (ModAdd M2 M1).(state)
                       (ModAdd M1 M2).(ident) (ModAdd M2 M1).(ident)
                       nat_wf nat_wf)
                 (w : Unit)
               => let '(ths, m_src, m_tgt, st_src, st_tgt) := x in
                 fst st_src = snd st_tgt
                 /\ snd st_src = fst st_tgt
                 /\ (forall i, m_src (inl i) = m_tgt (inr (inr i)))
                 /\ (forall i, m_src (inr i) = m_tgt (inr (inl i)))
         ).
    constructor 1 with nat_wf nat_wf Unit.
    - econs. exact 0.
    - i. exists (S o0). ss.
    (* - i. exists (conv im_tgt). exists tt. ss. *)
    - i.
      exists I. split.
      { exists (conv im_tgt). exists tt. ss. }
      destruct M1 as [state1 ident1 st_init1 funs1].
      destruct M2 as [state2 ident2 st_init2 funs2].
      ss. unfold add_funs. ss.
      i. destruct (funs1 fn), (funs2 fn).
      + ii. exists tt, tt. splits; ss.
        { des. splits; ss.
          - i. specialize (TID_TGT (inr (inr i))). specialize (INV1 i). ss. rewrite TID_TGT. ss.
          - i. specialize (TID_TGT (inr (inl i))). specialize (INV2 i). ss. rewrite TID_TGT. ss.
        }
        i. pfold. eapply pind9_fold. rewrite <- bind_trigger. econs.
      + eapply local_sim_refl.
        * firstorder.
        * firstorder.
          -- subst; destruct st_src, st_tgt; ss.
          -- subst; destruct st_src, st_tgt; ss.
        * firstorder.
          -- cbn. extensionalities i. specialize (H2 i). ss.
          -- subst. ss.
          -- subst. cbn. specialize (H3 i). ss.
        * firstorder.
          -- subst. cbn. specialize (H3 i). ss.
          -- subst. cbn. specialize (H4 i). ss.
      + eapply local_sim_refl.
        * firstorder.
        * firstorder.
          -- subst; destruct st_src, st_tgt; ss.
          -- subst; destruct st_src, st_tgt; ss.
        * firstorder.
          -- cbn. extensionalities i. specialize (H3 i). ss.
          -- subst. cbn. specialize (H2 i). ss.
          -- subst. ss.
        * firstorder.
          -- subst. cbn. specialize (H3 i). ss.
          -- subst. cbn. specialize (H4 i). ss.
      + eauto.
  Qed.

  Theorem ModAdd_right_mono M1 M2_src M2_tgt :
    ModSim.mod_sim M2_src M2_tgt ->
    ModSim.mod_sim (ModAdd M1 M2_src) (ModAdd M1 M2_tgt).
  Proof.
    i. eapply modsim_nat_modsim_exist in H. inv H.
    (* econs. *)
    econstructor 1 with (world:=URA.prod threadsRA world).
    (* pose (I' := @lift_ma M1 M2_src M2_tgt _ _ I). *)
    (* constructor 1 with _ _ _ I'. *)
    { instantiate (1:=nat_wf). econs. exact 0. }
    { i. exists (S o0). ss. }
    intro IM_TGT. specialize (init (chop_ctx NatSet.empty IM_TGT)). des.
    pose (I' := @lift_ma M1 M2_src M2_tgt _ _ I). exists I'.
    pose (pick_ctx IM_TGT) as im_ctx.
    split.
    { exists (add_ctx im_ctx im_src), (global_th NatSet.empty NatSet.empty, r_shared). ss. split.
      - exists im_src. exists NatSet.empty, NatSet.empty. splits; ss.
        + eapply Partition_empty.
        + exists (chop_ctx NatSet.empty IM_TGT). split; ss. ii. left. ss.
      - unfold_prod. split; ss. rewrite URA.unfold_wf. econs; ss. eapply Disjoint_empty.
    }
    rename init0 into funs0.
    i. specialize (funs0 fn args).
    unfold ModAdd, add_funs; ss. des_ifs.
    - eapply lift_ma_local_sim_ub.
    - eapply lift_ma_local_sim_ctx.
    - eapply lift_ma_local_sim_usr.
      eapply local_sim_clos_trans in funs0; cycle 1. { econs. exact 0. }
      eapply local_sim_wft_mono with (wft_lt := lt (wf_clos_trans nat_wf)). { i. econs. ss. }
      eapply funs0.
  Qed.

End MODADD_THEOREM.