Set Implicit Arguments.
Unset Strict Implicit.

Require Import basics.
Require Import enat.
Require Import allen.
Require Import signal.
Require Import borders.
Require Import compare.
Require Import reactives.

Section extend.

Ltac G x := generalize x.

Ltac BAD := intros BAD; inversion BAD.

Ltac INC_CMP CV1 CV2 :=
  intros I J (LL,RR);
  apply (inc_allen_by_comp2 (CV1 _ _ LL) (CV2 _ _ RR)).

Ltac RINC_CMP CV1 CV2 :=
  intros I J (LL,RR);
  apply (inc_allen_by_comp2 (CV1 _ _ LL) (CV2 _ _ RR)).

(* eq_pred *)

Definition eq_pred (f g:(allen -> Prop)) := forall I, (f I)<->(g I).

(*
 * filter
 *)
Definition filter (f:(allen -> Prop)) (p:sig) : sig :=
 fun t => (exists I, (tas t I p) /\ (f I)).

Lemma eq_pred_eq_filter (f g:(allen -> Prop)) (p:sig) :
 (eq_pred f g) -> (eq_sig (filter f p) (filter g p)).
intros EQ t.
split;intros (I,(tIp,fI));exists I;split;auto.
- rewrite <- (EQ I); auto.
- rewrite (EQ I); auto.
Qed.

Lemma filter_follow_changes (F:allen->Prop) (p:sig) (t:nat) :
 (p t) ->
 (p (S t)) ->
 ((filter F p) t) ->
 ((filter F p) (S t)).
intros Pt PSt (I,((tI,Ip),FI)).
exists I.
split;[split|];auto.
apply (in_allen_in_sig__on_succ (tas_def tI Ip) PSt).
Qed.

Lemma filter_unfollow_changes (F:allen->Prop) (p:sig) (t:nat) :
 (p t) ->
 (p (S t)) ->
 ((filter F p) (S t)) ->
 ((filter F p) t).
intros Pt PSt (I,((StI,Ip),FI)).
exists I.
split;[split|];auto.
apply (in_allen_in_sig__on_prev (tas_def StI Ip) Pt).
Qed.

Lemma continuous___same_filter (F:allen->Prop) (p:sig) (t:nat) :
 (p t) ->
 (p (S t)) ->
 (((filter F p) t) <-> ((filter F p) (S t))).
intros Pt PSt.
split; [ apply (filter_follow_changes Pt PSt)
       | apply (filter_unfollow_changes Pt PSt)].
Qed.

Lemma inc_sig_filter (F:allen->Prop) (p:sig) : (inc_sig (filter F p) p).
intros t (I,(tIp,_)).
apply (tas_p tIp).
Qed.

Lemma filter_in_sig (p:sig) (f:allen->Prop) (I:allen) :
 (in_sig I p) ->
 (f I) ->
 (in_sig I (filter f p)).
intros IInp FI.
split;[|split].
- case_eq (left I); auto; intros pli LI.
  intros (II,((pliInII,IIInp),FII)).
  G (previous_left_out IInp LI). apply not_not.
  apply (tas_p (tas_def pliInII IIInp)).
- case_eq (right I); auto; intros ri RI.
  intros (II,((pliInII,IIInp),FII)).
  apply (bounded_right_out IInp RI).
  apply (tas_p (tas_def pliInII IIInp)).
- intros t tInI; exists I; split; auto; split; auto.
Qed.

Lemma inc_sig_filters (f g:(allen -> Prop)) (p:sig) :
 (forall I, (f I) -> (g I)) ->
 (inc_sig (filter f p) (filter g p)).
intros INC t (I,(tIp,FI)).
exists I. split;[auto|].
apply (INC I FI).
Qed.

Lemma inc_sig_allen_filter (F:allen->Prop) (p:sig) :
 (inc_sig_allen (filter F p) p).
intros I IInEx.
G IInEx; intros (A,(B,C)).
split;[|split].
- case_eq (left I); auto.
  intros l LI Pl.
  rewrite LI in A.
  apply A.
  G (in_left IInEx); rewrite LI; intros AS.
  rewrite continuous___same_filter;[ auto | auto | ].
  apply (inc_sig_filter AS).
- case_eq (right I); auto.
  intros r RI Pr.
  rewrite RI in B.
  apply B.
  G (previous_right RI); intros (pr,PRI).
  rewrite PRI.
  rewrite PRI in RI.
  rewrite PRI in Pr.
  G (previous_right_in IInEx RI); intros BP.
  rewrite <- continuous___same_filter;[auto | | auto ].
  apply (inc_sig_filter BP).
- intros t tInI.
  apply (inc_sig_filter (C _ tInI)).
Qed.

Lemma in_sig_filter (p:sig) (f:allen->Prop) (I:allen) :
 (in_sig I (filter f p)) ->
 (safe_allen_fun f) ->
 (f I).
intros IInF SF.
G (in_left IInF). intros (J,((lJ,Jp),FJ)).
G (inc_sig_allen_filter IInF); intros IInp.
G (tas_uniq (tas_def lJ Jp) (tas_def (in_allen_left I) IInp)); intros EQA.
apply (SF _ _ EQA FJ).
Qed.

Lemma tas_filter_tas_arg (F:allen->Prop) (p:sig) (I:allen) (t:nat) :
 (tas t I (filter F p)) ->
 (tas t I p).
intros (tInI,IInF).
split;[auto|].
apply (inc_sig_allen_filter IInF).
Qed.

Lemma filter_tas (p:sig) (f:allen->Prop) (I:allen) (t:nat):
 (tas t I p) ->
 (f I) ->
 (tas t I (filter f p)).
intros tIp FI.
apply (tas_def (tas_allen tIp) (filter_in_sig (tas_sig tIp) FI)).
Qed.

Lemma not_filter (f g:(allen -> Prop)) (p:sig) :
 (safe_allen_fun f) ->
 (inc_sig (or_sig (filter (fun I => ~(f I)) p) (not_sig p))
          (not_sig (filter f p)) ).
intros SF t [(I,(tIp,NF))|Np].
- apply all_not_not_ex.
  intros II.
  apply or_not_not_and.
  G (pcheck (tas t II p)). intros [EQ|NEQ]; [right|left;auto].
  G NF; apply ncontra.
  apply (SF _ _ (eq_allen_sym (tas_uniq tIp EQ))).
- G Np; apply ncontra.
  apply inc_sig_filter.
Qed.

(*
 * EXTEND
 *)
Definition extend (R:(allen -> allen -> Prop)) (p q:sig) : sig :=
 (filter (fun I => (exists J, (in_sig J q) /\ (R I J))) p).

Lemma inc_sig_extend_left (R:allen->allen->Prop) (p q:sig) :
 (inc_sig (extend R p q) p).
apply inc_sig_filter.
Qed.

Lemma contra_extend (R1 R2:(allen -> allen -> Prop)) (p q:sig) (t:nat) :
 (safe_allen_relation R2) ->
 (inclusive_relation R1) ->
 (inclusive_relation R2) ->
 (forall I J, (R1 I J) -> (R2 I J) -> False) ->
 (extend R1 p q t) ->
 (extend R2 p q t) ->
 False.
intros SF INC1 INC2 IMP (I,(tIp,(J,(Jq,R1IJ)))) (II,(tIIp,(JJ,(JJq,R2IJ)))).
G (inc_allen_in_allen (INC1 _ _ R1IJ) (tas_allen tIp)). intros tJ.
G (inc_allen_in_allen (INC2 _ _ R2IJ) (tas_allen tIIp)). intros tJJ.
G (tas_uniq tIIp tIp). intros III.
G (tas_uniq (tas_def tJJ JJq) (tas_def tJ Jq)). intros JJJ.
apply (IMP _ _ R1IJ (SF _ _ _ _ III JJJ R2IJ)).
Qed.

(* should be used for all inclusive relation *)
Lemma ext_inc (R:(allen -> allen -> Prop)) (p q:sig) (t:nat) :
 (extend R p q t) ->
 (inclusive_relation R) ->
 (exists I, (tas t I p) /\ (exists J, (tas t J q) /\ (R I J))).
intros (I,(tIp,(J,(JInq,RIJ)))) INC.
exists I. split;[auto|].
exists J. split;[|auto].
split;[|auto].
apply (inc_allen_in_allen (INC _ _ RIJ) (tas_allen tIp)).
Qed.

Lemma inc_sig_not_extend (f:(allen -> allen -> Prop)) (p q:sig) :
 (inc_sig (not_sig p) (not_sig (extend f p q))).
apply inc_sig_not.
apply inc_sig_filter.
Qed.

End extend.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool eqtype seq.
Require Import Init_ext ZArith_ext seq_ext uniq_tac.
Require Import machine_int multi_int encode_decode integral_type.
Import MachineInt.
Require Import mips_bipl mips_seplog mips_tactics mips_syntax mips_mint.
Import mips_bipl.expr_m.
Require Import simu.
Import simu.simu_m.
Require Import copy_s_u_prg copy_s_u_triple copy_s_u_termination.

Local Open Scope machine_int_scope.
Local Open Scope heap_scope.
Local Open Scope assoc_scope.
Local Open Scope uniq_scope.
Local Open Scope asm_expr_scope.

Lemma copy_s_u_safe_termination a0 a1 a2 a3 rk ry y rx x d :
  uniq(x, y) ->  uniq(rk, rx, ry, a0, a1, a2, a3, r0) ->
  safe_termination
  (fun st s h => state_mint (x |=> signed (Z.abs_nat (u2Z ([rk ]_ s))) rx \U+
      (y |=> unsign rk ry \U+ d s)) st s h)
  (copy_s_u rk rx ry a0 a1 a2 a3).
Proof.
move=> Hvars Hnodup.
rewrite /safe_termination => st s h st_s_h.
case: (copy_s_u_termination s h _ _ _ _ _ _ _ Hnodup) => si Hsi.
move: (proj1 st_s_h x (signed (Z.abs_nat (u2Z ([rk ]_ s))) rx)).
rewrite assoc.get_union_sing_eq.
move/(_ (refl_equal _)).
case=> len ptr U ru_fit encU ptr_fit HU.
case: encU => u1 u2 u3 u4.
move: (proj1 st_s_h y (unsign rk ry)).
rewrite assoc.get_union_sing_neq; last by Uniq_neq.
rewrite assoc.get_union_sing_eq.
case/(_ (refl_equal _)) => rx_fit Hx HX.
move: (copy_s_u_triple _ _ _ _ _ _ _ Hnodup U (Z2ints 32 (Z.abs_nat (u2Z ([rk ]_ s)))
               ([ y ]_ st)%pseudo_expr) (Z.abs_nat (u2Z ([rk ]_ s))) u1).
rewrite size_Z2ints.
move/(_ (refl_equal _) len ptr ptr_fit _ rx_fit) => hoare_triple.
apply constructive_indefinite_description'.
move: (triple_exec_precond _ _ _ hoare_triple _ _ _ Hsi
  (heap.dom (heap_mint (signed (Z.abs_nat (u2Z ([rk ]_ s))) rx) s h \U
  heap_mint (unsign rk ry) s h))).
apply.
split; first reflexivity.
split; first by rewrite Z_of_nat_Zabs_nat //; exact: min_u2Z.
suff : h |P|
        (heap.dom (heap_mint (signed (Z.abs_nat (u2Z ([rk ]_ s))) rx) s h \U
            heap_mint (unsign rk ry) s h)) =
       heap_mint (signed (Z.abs_nat (u2Z ([rk ]_ s))) rx) s h \U
                 heap_mint (unsign rk ry) s h.
  move=> ->.
  apply assert_m.con_cons => //.
  apply (proj2 st_s_h x y) => //; by [Uniq_neq | assoc_get_Some | assoc_get_Some].
rewrite -heap.incluE.
apply heap_prop_m.inclu_union.
exact: heap_inclu_heap_mint_signed.
exact: heap_inclu_heap_mint_unsign.
Qed.


Require Import msl.seplog.
Require Import msl.base.
Require Import msl.ageable.
Require Import msl.sepalg.
Require Import msl.age_sepalg.
Require Import msl.predicates_hered.
Require Import msl.predicates_sl.
Require Import msl.subtypes.
Require Import msl.subtypes_sl.
Require Import msl.predicates_rec.
Require Import msl.contractive.
Require msl.normalize.

Local Open Scope logic.

Instance algNatDed (T: Type){agT: ageable T} : NatDed (pred T).
  apply (mkNatDed _
                    predicates_hered.andp
                    predicates_hered.orp
                    (@predicates_hered.exp _ _)
                    (@predicates_hered.allp _ _)
                    predicates_hered.imp predicates_hered.prop
                    (@predicates_hered.derives _ _)).
 apply pred_ext.
 apply derives_refl.
 apply derives_trans.
 apply andp_right.
 apply andp_left1.
 apply andp_left2.
 apply orp_left.
 apply orp_right1.
 apply orp_right2.
 intros ? ?; apply @exp_right.
 intros ? ?; apply @exp_left.
 intros ? ?; apply @allp_left.
 intros ? ?; apply @allp_right.
 apply imp_andp_adjoint.
 repeat intro. eapply H; eauto. hnf; auto.
 repeat intro. hnf; auto.
 repeat intro. specialize (H a (necR_refl _)). simpl in H. auto.
 repeat intro. specialize (H b). simpl in H. auto.
Defined.

Instance algSepLog (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
      @SepLog (pred T) (algNatDed T).
 apply (mkSepLog _ (algNatDed T) predicates_sl.emp predicates_sl.sepcon
            predicates_sl.wand predicates_sl.ewand).
 apply sepcon_assoc.
 apply sepcon_comm.
 intros. pose proof (wand_sepcon_adjoint P Q R). simpl. rewrite H; split; auto.
 intros; simpl. apply predicates_hered.pred_ext; simpl.
          intros ? [w1 [w2 [? [? [? ?]]]]];  split; auto. exists w1; exists w2; repeat split; auto.
          intros ? [? [w1 [w2 [? [? ?]]]]];  exists w1; exists w2; repeat split; auto.
 intros; intro; apply sepcon_derives; auto.
 intros; simpl; apply ewand_sepcon; auto.
 intros; simpl. apply ewand_TT_sepcon; auto.
 intros; simpl. intros w [w1 [w2 [? [? ?]]]]. exists w1,w2; repeat split; auto. exists w2; exists w; repeat split; auto.
  intros; simpl. apply ewand_conflict; auto.
Defined.

Instance algClassicalSep (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{CancT: Canc_alg T}{AgeT: Age_alg T}:
     @ClassicalSep (pred T) (algNatDed T)(algSepLog T).
 constructor; intros. simpl. apply predicates_sl.sepcon_emp.
Qed.

Definition Triv := predicates_hered.pred nat.
Instance TrivNatDed: NatDed Triv := algNatDed nat.
Instance TrivSeplog: SepLog Triv := @algSepLog nat _ _ _ _ (asa_nat).
Instance TrivClassical: ClassicalSep Triv := @algClassicalSep _ _ _ _ _ _ asa_nat.
Instance TrivIntuitionistic: IntuitionisticSep Triv.
 constructor. intros. hnf. intros. destruct H as [w1 [w2 [? [? _]]]].
 destruct H; subst; auto.
Qed.

Instance algIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}
                {AgeT: Age_alg T}:
         @Indir (pred T) (algNatDed T).
 apply (mkIndir _ _ (box laterM)); intros; simpl in *.
 apply @predicates_hered.now_later.
 apply @predicates_hered.axiomK.
 apply @predicates_hered.later_allp.
 simpl. intros; apply @box_ex.
  simpl. intros; apply @later_ex; auto.
 apply @predicates_hered.later_imp.
 apply @predicates_hered.loeb; auto.
Defined.

Instance TrivIndir: Indir Triv := @algIndir nat _ _ _ _ asa_nat.

Section SL2. Import msl.seplog.

Class RecIndir (A: Type) {NA: NatDed A}{IA: Indir A} := mkRecIndir {
  fash : A -> Triv;
  unfash : Triv -> A;
  HORec : forall {X} (f: (X -> A) -> (X -> A)), X -> A;
  unfash_fash:  forall P: A, unfash (fash P) |-- P;
  fash_K: forall P Q, fash (P --> Q) |-- fash P --> fash Q;
  fash_derives: forall P Q, P |-- Q -> fash P |-- fash Q;
  unfash_derives:  forall P Q,  P |-- Q -> unfash P |-- unfash Q;
  later_fash:  forall P, later (fash P) = fash (later P);
  later_unfash:  forall P, later (unfash P) = unfash (later P);
  fash_andp: forall P Q, fash (P && Q) = fash P && fash Q;
  unfash_allp:  forall {B} (P: B -> Triv), unfash (allp P) = ALL x:B, unfash (P x);  subp_allp: forall G B (X Y:B -> A),  (forall x:B, G |-- fash (imp (X x) (Y x))) ->  G |-- fash (imp (allp X) (allp Y));
  subp_exp: forall G B (X Y:B -> A),  (forall x:B, G |-- fash (imp (X x) (Y x))) ->  G |-- fash (imp (exp X) (exp Y));
  subp_e: forall (P Q : A), TT |-- fash (P --> Q) -> P |-- Q;
  subp_i1: forall P (Q R: A), unfash P && Q |-- R -> P |-- fash (Q --> R);
 fash_TT: forall G, G |-- fash TT;
  HOcontractive: forall {X: Type} (f: (X -> A) -> (X -> A)), Prop :=
         fun {X} f => forall P Q,  (ALL x:X, later (fash (P x <--> Q x))) |-- (ALL x:X, fash (f P x <--> f Q x));
  HORec_fold_unfold : forall X (f: (X -> A) -> (X -> A)) (H: HOcontractive f), HORec f = f (HORec f)
}.

Definition HOnonexpansive {A}{NA: NatDed A}{IA: Indir A}{RA: RecIndir A}
        {X: Type} (f: (X -> A) -> (X -> A)) :=
         forall P Q: X -> A,  (ALL x:X, fash (P x <--> Q x)) |-- (ALL x:X, fash (f P x <--> f Q x)).
End SL2.

Notation "'#' e" := (fash e) (at level 30, right associativity): logic.
Notation "'!' e" := (unfash e) (at level 30, right associativity): logic.
Notation "P '>=>' Q" := (# (P --> Q)) (at level 55, right associativity) : logic.
Notation "P '<=>' Q" := (# (P <--> Q)) (at level 57, no associativity) : logic.

Definition algRecIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @RecIndir (pred T) (algNatDed T) (algIndir T).
 apply (mkRecIndir _ _ _ subtypes.fash subtypes.unfash HoRec.HORec); intros; simpl.
 repeat intro. do 3 red in H. apply H; auto.
 apply @subtypes.fash_K.
 apply @subtypes.fash_derives; auto.
 intros ? ?. do 3 red in H0. apply H in H0. apply H0.
 apply @subtypes.later_fash; auto.
 apply @subtypes.later_unfash.
 apply @subtypes.fash_and.
 apply pred_ext; repeat intro; do 3 red in H; apply (H b); auto.
 apply @subtypes.subp_allp; auto.
 eapply @subtypes.subp_exp; auto.
 eapply @subtypes.subp_e; eauto.
 eapply @subtypes.subp_i1; eauto.
 repeat intro; hnf; auto.
 intros. apply HoRec.HORec_fold_unfold; auto.
Defined.

Instance TrivRecIndir: RecIndir Triv := algRecIndir nat.

Section SL3. Import msl.seplog.

Lemma fash_triv: forall P: Triv, fash P = P.
Proof.
 intros.
 apply pred_ext; intros ? ?.
 eapply H. unfold level; simpl.  unfold natLevel; auto.
 hnf; intros. eapply pred_nec_hereditary; try eapply H.
 apply nec_nat. auto.
Qed.

Class SepRec  (A: Type) {NA: NatDed A}{SA: SepLog A}{IA: Indir A}{RA: RecIndir A} := mkSepRec {
  unfash_sepcon_distrib: forall (P: Triv) (Q R: A),
                 andp (unfash P) (sepcon Q R) = sepcon (andp (unfash P) Q) (andp (unfash P) R)
}.

End SL3.

Instance algSepIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @SepIndir (pred T) (algNatDed T) (algSepLog T) (algIndir T).
 apply mkSepIndir; simpl.
 apply @predicates_sl.later_sepcon; auto.
 apply @predicates_sl.later_wand; auto.
 apply @predicates_sl.later_ewand; auto.
Qed.

Instance algSepRec (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @SepRec (pred T) (algNatDed T) (algSepLog T) (algIndir T)(algRecIndir T).
constructor.
 intros; simpl. apply subtypes_sl.unfash_sepcon_distrib.
Qed.

Instance algCorableSepLog (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @CorableSepLog (pred T) (algNatDed T) (algSepLog T).
  apply mkCorableSepLog with (corable := corable.corable).
  + apply corable.corable_prop.
  + apply corable.corable_andp.
  + apply corable.corable_orp.
  + apply corable.corable_imp.
  + intros; apply corable.corable_allp; auto.
  + intros; apply corable.corable_exp; auto.
  + apply corable.corable_sepcon.
  + apply corable.corable_wand.
  + intros; simpl.
    apply corable.corable_andp_sepcon1; auto.
Defined.

Instance algCorableIndir (T: Type) {agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T} :
         @CorableIndir (pred T) (algNatDed T) (algSepLog T) (algCorableSepLog T) (algIndir T).
  unfold CorableIndir; simpl.
  apply corable.corable_later.
Defined.


From PetitC Require Import Ids Values TypedTree Memory Output InbuiltFunc InbuiltFuncSemantics.
Import TypedTree.

From Coq Require Import ZArith Lists.List.
Import ListNotations.
Open Scope Z_scope.

Fixpoint assoc {X : Type} (id : func_id) (assoc_list : list (func_id * X)) : option X :=
  match assoc_list with
  | (id', x)::tail => if (id' =? id)%nat
                      then Some x
                      else assoc id tail
  | []             => None
  end.

Definition write_goes_wrong (mem : memory) (ptr : ptr_value) : Prop :=
  ~exists val st', write mem ptr val st'.

Definition read_goes_wrong (mem : memory) (ptr : ptr_value) : Prop :=
  ~exists val, read mem ptr val.

Definition allocate_var (mem : memory) (var_ptrs : VarIdMap.t ptr_value)
    (id : var_id) : memory * VarIdMap.t ptr_value :=
  let (ptr, mem') := allocate_stack mem in
  (mem', VarIdMap.add id ptr var_ptrs).

Inductive allocate_vars : memory -> VarIdMap.t ptr_value -> list var_id ->
                          memory -> VarIdMap.t ptr_value -> Prop :=

  | AVNil : forall mem var_ptrs,
      allocate_vars mem var_ptrs [] mem var_ptrs

  | AVCons : forall mem mem' mem'' var_ptrs var_ptrs' var_ptrs'' id ids_tail,
        allocate_vars mem var_ptrs ids_tail mem' var_ptrs' ->
        (mem'', var_ptrs'') = allocate_var mem' var_ptrs' id ->
      allocate_vars mem var_ptrs (id::ids_tail)mem'' var_ptrs''.

Inductive assign_var (var_ptrs : VarIdMap.t ptr_value) :
      memory -> var_id -> value -> memory -> Prop :=
  | AssignVar : forall mem id ptr val mem',
        VarIdMap.find id var_ptrs = Some ptr ->
        write mem ptr val mem' ->
      assign_var var_ptrs mem id val mem'.

Inductive assign_vars (var_ptrs : VarIdMap.t ptr_value) :
      memory -> list var_id -> list value -> memory -> Prop :=

  | AssignVarsNil : forall mem,
      assign_vars var_ptrs mem [] [] mem

  | AssignVarsCons : forall mem mem' mem'' id val ids vals,
        assign_vars var_ptrs mem ids vals mem' ->
        assign_var var_ptrs mem' id val mem'' ->
      assign_vars var_ptrs mem (id::ids) (val::vals) mem''.

Inductive call_var_ptrs_and_mem : VarIdMap.t ptr_value -> memory -> list var_id -> list value ->
                                  VarIdMap.t ptr_value -> memory -> Prop :=
  | CVITPAS : forall var_ptrs var_ptrs' mem mem' mem'' var_ids vals,
        allocate_vars mem var_ptrs var_ids mem' var_ptrs' ->
        assign_vars var_ptrs' mem' var_ids vals mem'' ->
      call_var_ptrs_and_mem var_ptrs mem var_ids vals var_ptrs' mem''.

Inductive expr_context : (annotated_expr -> annotated_expr) -> Prop :=
  | CHole :
      expr_context (fun e => e)
  | CCast ctx ty ty' ty'' :
        expr_context ctx ->
      expr_context (fun e => Cast ty ty' (ctx e) <: ty'')
  | CLvalue ctx ty :
        lvalue_context ctx ->
      expr_context (fun e => LValue (ctx e) <: ty)
  | CAddressOf ctx ty :
        lvalue_context ctx ->
      expr_context (fun e => AddressOf (ctx e) <: ty)
  | CBinOpLeft binop ctx ty expr :
        expr_context ctx ->
      expr_context (fun e => BinOp binop (ctx e) expr <: ty)
  | CBinOpRight binop ctx ty ty' value :
        expr_context ctx ->
      expr_context (fun e => BinOp binop (Const value <: ty) (ctx e) <: ty')
  | CNot ctx ty :
        expr_context ctx ->
      expr_context (fun e => Not (ctx e) <: ty)
  | CIncrOrDecr incr_or_decr pre_or_post ctx ty :
        lvalue_context ctx ->
      expr_context (fun e => IncrOrDecr ty incr_or_decr pre_or_post (ctx e) <: ty)
  | CAssignLeft ctx expr ty :
        lvalue_context ctx ->
      expr_context (fun e => Assign (ctx e) expr <: ty)
  | CAssignRight ctx ptr ty ty' complete_ty :
        expr_context ctx ->
      expr_context (fun e =>
        Assign (Dereference (Const ptr <: ty) <l: complete_ty)
               (ctx e)
        <: ty'
      )
  | CCall ctx func_id ty :
        list_expr_context ctx ->
      expr_context (fun e => Call func_id (ctx e) <: ty)
  | CCallInbuilt ctx inbuilt_func ty :
        list_expr_context ctx ->
      expr_context (fun e => CallInbuilt inbuilt_func (ctx e) <: ty)

with lvalue_context : (annotated_expr -> annotated_lvalue) -> Prop :=
  | CDereference ctx complete_ty :
      expr_context ctx ->
    lvalue_context (fun e => Dereference (ctx e) <l: complete_ty)

with list_expr_context : (annotated_expr -> list_annotated_expr) -> Prop :=
  | CHead ctx tail :
        expr_context ctx ->
      list_expr_context (fun e => LAECons (ctx e) tail)
  | CTail ctx value ty :
        list_expr_context ctx ->
      list_expr_context (fun e => LAECons (Const value <: ty) (ctx e)).

Scheme expr_context_mutual_ind := Minimality for expr_context Sort Prop
with lvalue_context_mutual_ind := Minimality for lvalue_context Sort Prop
with list_expr_context_mutual_ind := Minimality for list_expr_context Sort Prop.

Definition bool_to_value (b : bool) : value :=
  if b then IntValue one_int_value else IntValue zero_int_value.

Inductive cast_reduction : rich_type -> value -> rich_type -> value  -> Prop :=
  | CRSame value rich_ty ty :
        Some ty = of_rich rich_ty ->
        can_have_type value ty ->
      cast_reduction rich_ty     value
                     rich_ty     value
  | CRIntToBool int_value :
      cast_reduction RInt       (IntValue int_value)
                     RBool      (bool_to_value (negb (Z.eqb (int_value_to_Z int_value) 0)))
  | CRBoolToInt int_value :
      cast_reduction RBool      (IntValue int_value)
                     RInt       (IntValue int_value)
  | CRHeapPtrToBool ty ptr :
      cast_reduction (RPtr ty)  (PtrValue ptr)
                     RBool      (bool_to_value (negb (ptr_value_beq ptr NullPtr)))
  | CRPtrToPtr ptr ty ty' :
      cast_reduction (RPtr ty)  (PtrValue ptr)
                     (RPtr ty') (PtrValue ptr).

Definition cast_reduction_goes_wrong
    (ty_from : rich_type) (val_from : value) (ty_to : rich_type) : Prop :=
  ~exists val_to, cast_reduction ty_from val_from ty_to val_to.

Inductive int_arith_binop_reduction : int_arith_binop -> Z -> Z -> Z -> Prop :=
  | IABRPlusIntInt n m :
      int_arith_binop_reduction PlusIntInt n m (n + m)
  | IABRMinusIntInt n m :
      int_arith_binop_reduction MinusIntInt n m (n - m)
  | IABRTimes n m :
      int_arith_binop_reduction Times n m (n * m)
  | IABRDiv n m :
      m <> 0%Z -> (* division and modulo by zero is undefined behavior *)
      int_arith_binop_reduction Div n m (Z.abs n / Z.abs m * Z.sgn n * Z.sgn n)
  | IABRMod n m :
      m <> 0%Z ->
      int_arith_binop_reduction Mod n m ((Z.abs n mod Z.abs m) * Z.sgn n * Z.sgn m).

Inductive comparison_reduction : comparison -> Z -> Z -> bool -> Prop :=
  | CRBEq n m : comparison_reduction Eq n m (n =? m)%Z
  | CRBLt n m : comparison_reduction Lt n m (n <? m)%Z.

Inductive binop_reduction : binop -> value -> value -> value -> Prop :=
  | BRIntArithBinop (op : int_arith_binop) (lhs rhs result : int_value) :
        int_arith_binop_reduction op (int_value_to_Z lhs)
                                     (int_value_to_Z rhs)
                                     (int_value_to_Z result) ->
      binop_reduction (IntArithBinop op) (IntValue lhs) (IntValue rhs) (IntValue result)

  | BRComparisonInt (comp : comparison) (lhs rhs : int_value) (result : bool) :
        comparison_reduction comp (int_value_to_Z lhs) (int_value_to_Z rhs) result ->
      binop_reduction (Comparison comp) (IntValue lhs) (IntValue rhs) (bool_to_value result)

  | BRComparisonPtr (comp : comparison) (lhs rhs : ptr_value) (lhs_offset rhs_offset : offset)
                    (result : bool) :
        has_offset lhs lhs_offset ->
        has_offset rhs rhs_offset ->
        same_block lhs rhs ->
        comparison_reduction comp lhs_offset rhs_offset result ->
      binop_reduction (Comparison comp) (PtrValue lhs) (PtrValue rhs) (bool_to_value result)

  | BRPlusPtrInt (lhs : ptr_value) (rhs : int_value) (result : ptr_value)
                 (lhs_offset result_offset : offset) :
        has_offset lhs lhs_offset ->
        has_offset result result_offset ->
        same_block lhs result ->
        lhs_offset + Z.of_nat word_size * int_value_to_Z rhs = result_offset ->
      binop_reduction PlusPtrInt (PtrValue lhs) (IntValue rhs) (PtrValue result)

  | BRPlusIntPtr (lhs : int_value) (rhs result : ptr_value) (rhs_offset result_offset : offset) :
        has_offset rhs rhs_offset ->
        has_offset result result_offset ->
        same_block rhs result ->
        Z.of_nat word_size * int_value_to_Z lhs + rhs_offset = result_offset ->
      binop_reduction PlusPtrInt (IntValue lhs) (PtrValue rhs) (PtrValue result)

  | BRMinusPtrInt (lhs : ptr_value) (rhs : int_value) (result : ptr_value)
                  (lhs_offset result_offset : offset) :
        has_offset lhs lhs_offset ->
        has_offset result result_offset ->
        same_block lhs result ->
        lhs_offset * Z.of_nat word_size * int_value_to_Z rhs = result_offset ->
      binop_reduction MinusPtrInt (PtrValue lhs) (IntValue rhs) (PtrValue result)

  | BRMinusPtrPtr (lhs rhs : ptr_value) (result : int_value) (lhs_offset rhs_offset : offset) :
        has_offset lhs lhs_offset ->
        has_offset rhs rhs_offset ->
        lhs_offset - rhs_offset = Z.of_nat word_size * int_value_to_Z result ->
      binop_reduction MinusPtrPtr (PtrValue lhs) (PtrValue rhs) (IntValue result).

Definition binop_reduction_goes_wrong (op : binop) (lhs rhs : value) : Prop :=
  ~exists result, binop_reduction op lhs rhs result.

Inductive short_circuit_reduction_first : short_circuit_op -> bool -> bool -> Prop :=
  | SCRFFalseAnd : short_circuit_reduction_first And false false
  | SCRFTrueOr   : short_circuit_reduction_first Or  true  true.

Inductive short_circuit_reduction_second : short_circuit_op -> bool -> bool -> bool -> Prop :=
  | SCRSTrueAnd (b : bool) : short_circuit_reduction_second And true  b b
  | SCRSFalseOr (b : bool) : short_circuit_reduction_second Or  false b b.

Definition to_plus_or_minus_one (iod : incr_or_decr) : Z :=
  match iod with
  | Incr => 1
  | Decr => -1
  end.

Inductive incr_or_decr_reduction : incr_or_decr -> rich_type -> value -> value -> Prop :=
  | IRInt (incr_or_decr : incr_or_decr) (before after : int_value) :
        (int_value_to_Z after = int_value_to_Z before + to_plus_or_minus_one incr_or_decr)%Z ->
      incr_or_decr_reduction incr_or_decr RInt
        (IntValue before)
        (IntValue after)

  | IRIncrPtr (incr_or_decr : incr_or_decr) (block_id : block_id) (offset : offset) (ty : rich_type) :
      incr_or_decr_reduction incr_or_decr (RPtr ty)
        (PtrValue (HeapPtr block_id offset))
        (PtrValue (HeapPtr block_id
                           (offset + Z.of_nat word_size * to_plus_or_minus_one incr_or_decr) % Z))

  | IRIncrBool : forall (b : bool),
      incr_or_decr_reduction Incr RBool
        (bool_to_value b)
        (bool_to_value true)

  | IRDecrBool : forall (b : bool),
      incr_or_decr_reduction Decr (RBool)
        (bool_to_value b)
        (bool_to_value (negb b)).

Section ExprHeadReduction.

Variable (var_ptrs : VarIdMap.t ptr_value).

Inductive expr_head_reduction : (memory * output) * annotated_expr ->
                                (memory * output) * annotated_expr -> Prop :=

  | HRCast (state : memory * output) (val val' : value) (ty ty' : rich_type) :
        cast_reduction ty val ty' val' ->
      expr_head_reduction
        (state, Cast ty ty' (Const val <: ty) <: ty')
        (state, Const val' <: ty')

  | HRAddressOf (state : memory * output) (ptr : ptr_value) (ty : rich_type) :
      expr_head_reduction
        (state, AddressOf (Dereference (Const (PtrValue ptr) <: RPtr ty) <l: ty) <: RPtr ty)
        (state, Const (PtrValue ptr) <: RPtr ty)

  | HRBinOp (state : memory * output) (op : binop) (lhs rhs result : value)
            (lhs_ty rhs_ty result_ty : rich_type) :
        binop_reduction op lhs rhs result ->
      expr_head_reduction
        (state, BinOp op (Const lhs <: lhs_ty) (Const rhs <: rhs_ty) <: result_ty)
        (state, Const result <: result_ty)

  | HRShortCircuitFirst (state : memory * output) (op : short_circuit_op) (lhs : bool)
                        (rhs : annotated_expr) (result : bool) :
        short_circuit_reduction_first op lhs result ->
      expr_head_reduction
        (state, ShortCircuit op (Const (bool_to_value lhs) <: RBool) rhs <: RBool)
        (state, Const (bool_to_value result) <: RBool)

  | HRShortCircuitSecond (state : memory * output) (op : short_circuit_op) (lhs rhs result : bool) :
        short_circuit_reduction_second op lhs rhs result ->
      expr_head_reduction
        (state, ShortCircuit op (Const (bool_to_value lhs) <: RBool)
                                       (Const (bool_to_value rhs) <: RBool) <: RBool)
        (state, Const (bool_to_value result) <: RBool)

  | HRNot state (b : bool) :
      expr_head_reduction
        (state, Not (Const (bool_to_value b) <: RBool) <: RBool)
        (state, Const (bool_to_value (negb b)) <: RBool)

  | HRIncrOrDecr (mem mem' : memory) (out : output) (iod : incr_or_decr) (pop : pre_or_post)
                 (ptr : ptr_value) (before after : value) (ty : rich_type) :
        incr_or_decr_reduction iod ty before after ->
        read mem ptr before ->
        write mem ptr after mem' ->
      expr_head_reduction
        ((mem,  out), (IncrOrDecr ty iod pop
                                  (Dereference (Const (PtrValue ptr) <: RPtr ty) <l: ty)) <: ty)
        ((mem', out), Const (match pop with | Pre => after | Post => before end) <: ty)

  | HRAssign (mem mem' : memory) (out : output) (ptr : ptr_value) (val : value) (ty : rich_type) :
        write mem ptr val mem' ->
      expr_head_reduction
        ((mem,  out), (Assign (Dereference (Const (PtrValue ptr) <: RPtr ty) <l: ty)
                         (Const val <: ty) <: ty))
        ((mem', out), Const val <: ty)

  (* calls are not reduced here, they are reduced by continuation_step *)

  | HRInbuiltFunc (func : inbuilt_func) (mem mem' : memory) (out out' : output)
                  (args : list value) (arg_tys : list rich_type)
                  (returned : option value) (return_ty : rich_type) :
        inbuilt_func_step func args returned mem out mem' out' ->
        length args = length arg_tys ->
      expr_head_reduction
        ((mem,  out),  CallInbuilt func
                          (list_to_list_annotated_expr
                            (map (fun '(val, ty) => Const val <: ty)
                                 (combine args arg_tys)))
                          <: return_ty)
        ((mem', out'), (match returned with
                           | Some val => Const val
                           | None     => Unit end)
                          <: return_ty)

  | HRVar (state : memory * output) (var_id : var_id) (ptr : ptr_value) (ty : rich_type) :
        VarIdMap.find var_id var_ptrs = Some ptr ->
      expr_head_reduction
        (state, LValue (Var var_id <l: ty) <: ty)
        (state, LValue (Dereference (Const (PtrValue ptr) <: RPtr ty) <l: ty) <: ty).

End ExprHeadReduction.

(* Inductive expr_head_reduction_goes_wrong : memory * output * annotated_expr -> Prop :=
  | HRWBinop : forall state op lhs_val lhs_ty rhs_val rhs_ty result_ty,
        binop_reduction_goes_wrong op lhs_ty lhs_val rhs_ty rhs_val ->
      expr_head_reduction_goes_wrong
        (state, BinOp op (Const lhs_val <: lhs_ty) (Const rhs_val <: rhs_ty) <: result_ty)

  | HRWAssign : forall state value value ty,
        write_mem_goes_wrong state value ->
      expr_head_reduction_goes_wrong
        (state,  (Assign (Dereference (Const (PtrValue value) <: RPtr ty) <l: ty)
                         (Const value <: ty) <: ty)). *)

Inductive continuation_after_cmd : Type :=
  | KStop
      (* do the command, then stop *)
  | KSeq (c : cmd) (k : continuation_after_cmd)
      (* do the command, then do [i], then do [k] *)
  | KWhileAfterCmd (e : annotated_expr) (c : cmd) (k : continuation_after_cmd)
      (* do the command as if in the body of the while, then do [while (e) { c }],
         then do [k] *)
  | KCall (ctx : annotated_expr -> annotated_expr)
          (caller_var_ptrs : VarIdMap.t ptr_value)
          (k : continuation_after_expr)
      (* reduce the command until its [return const],
         then do [ContinuedExpr (ctx const) k] *)

with continuation_after_expr : Type :=
  | KExpr (k : continuation_after_cmd)
      (* evaluate the expression, discard its result, then do [k] *)
  | KIf (c_then c_else : cmd) (k : continuation_after_cmd)
      (* evaluate the expression,
         do [c_then] if it evaluates to true or [c_else] if it evaluates to false,
         then do [k] *)
  | KWhileAfterExpr (e : annotated_expr) (c : cmd) (k : continuation_after_cmd)
      (* evaluate the expression,
         do [while (e) { c }] without evaluating the conditing for the first time
                              using the result of the expression instead,
         then do [k] *).

Inductive continued : Type :=
  | ContinuedExpr : annotated_expr -> continuation_after_expr -> continued
  | ContinuedCmd : cmd -> continuation_after_cmd -> continued.

Section ContinuedStep.

Variable (funcs : list (func_id * func)).

Inductive continued_step : VarIdMap.t ptr_value * (memory * output) * continued ->
                           VarIdMap.t ptr_value * (memory * output) * continued -> Prop :=

  | CSSkipSeq var_ptrs state cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd Skip (KSeq cmd cont))
        (var_ptrs, state,  ContinuedCmd cmd cont)

  | CSSkipWhileAfterCmd var_ptrs state expr cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd Skip (KWhileAfterCmd expr cmd cont))
        (var_ptrs, state,  ContinuedCmd Skip (KSeq (While expr cmd) cont))

  | CSSeq var_ptrs state cmd1 cmd2 cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd (Seq cmd1 cmd2) cont)
        (var_ptrs, state,  ContinuedCmd cmd1 (KSeq cmd2 cont))

  | CSExpr var_ptrs state expr cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd (Expr expr) cont)
        (var_ptrs, state,  ContinuedExpr expr (KExpr cont))

  | CSIf var_ptrs state expr cmd_then cmd_else cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd (If expr cmd_then cmd_else) cont)
        (var_ptrs, state,  ContinuedExpr expr (KIf cmd_then cmd_else cont))

  | CSWhile var_ptrs state expr cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd (While expr cmd) cont)
        (var_ptrs, state,  ContinuedExpr expr (KWhileAfterExpr expr cmd cont))

  | CSBreakSeq var_ptrs state cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd Break (KSeq cmd cont))
        (var_ptrs, state,  ContinuedCmd Break cont)

  | CSBreakWhile var_ptrs state expr cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd Break (KWhileAfterCmd expr cmd cont))
        (var_ptrs, state,  ContinuedCmd Skip cont)

  | CSContinueSeq var_ptrs state cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd Continue (KSeq cmd cont))
        (var_ptrs, state,  ContinuedCmd Continue cont)

  | CSContinueWhile var_ptrs state expr cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedCmd Continue (KWhileAfterCmd expr cmd cont))
        (var_ptrs, state,  ContinuedCmd (While expr cmd) cont)

      (* we capitalize the E and R at the end of calle and caller so they are harder to confuse *)
  | CSReturn var_ptrs_calleE var_ptrs_calleR state val ty ctx cont :
      continued_step
        (var_ptrs_calleE, state, ContinuedCmd (Return (Const val <: ty))
                                                     (KCall ctx var_ptrs_calleR cont))
        (var_ptrs_calleR, state, ContinuedExpr (ctx (Const val <: ty)) cont)

  | CSExprConst var_ptrs state val ty cont :
      continued_step
        (var_ptrs, state,  ContinuedExpr (Const val <: ty) (KExpr cont))
        (var_ptrs, state,  ContinuedCmd Skip cont)

  | CSExprIf var_ptrs state bool cmd_then cmd_else cont :
      continued_step
        (var_ptrs, state,  ContinuedExpr (Const (bool_to_value bool) <: RBool)
                                              (KIf cmd_then cmd_else cont))
        (var_ptrs, state,  ContinuedCmd (if bool then cmd_then else cmd_else) cont)

  | CSExprWhile var_ptrs state bool expr cmd cont :
      continued_step
        (var_ptrs, state,  ContinuedExpr  (Const (bool_to_value bool) <: RBool)
                                               (KWhileAfterExpr expr cmd cont))
        (var_ptrs, state,  if bool
                                then ContinuedCmd cmd (KWhileAfterCmd expr cmd cont)
                                else ContinuedCmd Skip cont)

  | CSExprHeadReduction var_ptrs state state' ctx expr expr' cont :
        expr_context ctx ->
        expr_head_reduction var_ptrs (state, expr) (state', expr') ->
      continued_step
        (var_ptrs, state,  ContinuedExpr (ctx expr) cont)
        (var_ptrs, state', ContinuedExpr (ctx expr') cont)

      (* we capitalize the E and R at the end of calle and caller so they are harder to confuse *)
  | CSExprCall var_ptrs_calleE var_ptrs_calleR mem mem' out func func_id arg_vals ctx cont :
        assoc func_id funcs = Some func ->
        expr_context ctx ->
        let sig := f_signature func in
        length arg_vals = length (fs_arg_rich_types sig) ->
        let arg_exprs := list_to_list_annotated_expr
          (map (fun '(val, ty) => Const val <: ty)
               (combine arg_vals (fs_arg_rich_types sig))) in
        let call_expr := (Call func_id arg_exprs <: fs_rich_return_type sig) in
        call_var_ptrs_and_mem var_ptrs_calleR mem (f_arg_var_ids func) arg_vals
                              var_ptrs_calleE mem' ->
      continued_step
        (var_ptrs_calleR, (mem,  out),  ContinuedExpr (ctx call_expr) cont)
        (var_ptrs_calleE, (mem', out), ContinuedCmd (f_body func)
                                                      (KCall ctx var_ptrs_calleR cont)).

End ContinuedStep.

(* Inductive continued_step_goes_wrong : IdMap.t value * state * continued -> Prop :=
  | CSWExprHeadReduction : forall var_ptrs state ctx expr cont,
        expr_context ctx ->
        expr_head_reduction_goes_wrong (state, expr) ->
      continued_step_goes_wrong
        (var_ptrs, state,  ContinuedExpr (ctx expr) cont). *)


Require Import Coq.omega.Omega.
Require Import Crypto.Util.FixCoqMistakes.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Wf.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.ContextDefinitions.
Require Import Crypto.Compilers.Named.NameUtil.
Require Import Crypto.Compilers.Named.NameUtilProperties.
Require Import Crypto.Compilers.Named.ContextProperties.
Require Import Crypto.Compilers.Named.ContextProperties.Tactics.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SpecializeBy.

Section with_context.
  Context {base_type_code Name var} (Context : @Context base_type_code Name var)
          (base_type_code_dec : DecidableRel (@eq base_type_code))
          (Name_dec : DecidableRel (@eq Name))
          (ContextOk : ContextOk Context).

  Local Notation find_Name := (@find_Name base_type_code Name Name_dec).
  Local Notation find_Name_and_val := (@find_Name_and_val base_type_code Name base_type_code_dec Name_dec).

  Hint Rewrite (@find_Name_and_val_default_to_None _ base_type_code_dec _ Name_dec) using congruence : ctx_db.
  Hint Rewrite (@find_Name_and_val_different _ base_type_code_dec _ Name_dec) using assumption : ctx_db.
  Hint Rewrite (@find_Name_and_val_wrong_type _ base_type_code_dec _ Name_dec) using congruence : ctx_db.
  Hint Rewrite (@snd_split_onames_skipn base_type_code Name) : ctx_db.

  Local Ltac misc_oname_t_step :=
    match goal with
    | [ H : oname_list_unique (List.skipn _ _) -> _ |- _ ]
      => specialize (fun pf => H (@oname_list_unique_skipn _ _ _ pf))
    | [ H : ((_, _) = (_, _))%core -> _ |- _ ]
      => specialize (fun a b => H (f_equal2 (@pair _ _) a b))
    | [ H : ?x = (_,_)%core -> _ |- _ ]
      => rewrite (surjective_pairing x) in H;
           specialize (fun a b => H (f_equal2 (@pair _ _) a b))
    end.

  Lemma split_onames_find_Name
        {n T N ls ls'}
        (H : split_onames _ ls = (Some N, ls')%core)
    : (exists t, @find_Name n T N = Some t)
      <-> List.In (Some n) (List.firstn (CountLets.count_pairs T) ls).
  Proof using Type.
    revert dependent ls; intro ls; revert ls ls'; induction T; intros ls ls' H;
      [ | | specialize (IHT1 (fst N) ls (snd (split_onames T1 ls)));
            specialize (IHT2 (snd N) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ];
      repeat first [ misc_oname_t_step
                   | t_step
                   | progress split_iff
                   | progress specialize_by (eexists; eauto)
                   | solve [ eauto using In_skipn, In_firstn ]
                   | match goal with
                     | [ H : List.In ?x (List.firstn ?n ?ls) |- List.In ?x (List.firstn (?n + ?m) ?ls) ]
                       => apply (In_firstn n); rewrite firstn_firstn by omega
                     | [ H : _ |- _ ] => first [ rewrite firstn_skipn_add in H
                                               | rewrite firstn_firstn in H by omega ]
                     | [ H : List.In ?x' (List.firstn (?n + ?m) ?ls) |- List.In ?x' (List.firstn ?m (List.skipn ?n ?ls)) ]
                       => apply (In_firstn_skipn_split n) in H
                     end ].
  Qed.

  Lemma split_onames_find_Name_Some_unique_iff
        {n T N ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
    : (exists t, @find_Name n T N = Some t)
      <-> List.In (Some n) ls /\ ~List.In (Some n) ls'.
  Proof using Type.
    rewrite (split_onames_find_Name (ls':=ls') (ls:=ls)) by assumption.
    rewrite (surjective_pairing (split_onames _ _)) in H.
    rewrite fst_split_onames_firstn, snd_split_onames_skipn in H.
    inversion_prod; subst.
    split; [ split | intros [? ?] ]; eauto using In_firstn, oname_list_unique_specialize.
    match goal with
    | [ H : List.In (Some _) ?ls |- _ ]
      => is_var ls;
           eapply In_firstn_skipn_split in H; destruct_head' or; eauto; exfalso; eauto
    end.
  Qed.

  Lemma split_onames_find_Name_Some_unique
        {t n T N ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
        (Hfind : @find_Name n T N = Some t)
    : List.In (Some n) ls /\ ~List.In (Some n) ls'.
  Proof using Type.
    eapply split_onames_find_Name_Some_unique_iff; eauto.
  Qed.

  Lemma flatten_binding_list_find_Name_and_val_unique
        {var' t n T N V v ls ls'}
        (Hls : oname_list_unique ls)
        (H : split_onames _ ls = (Some N, ls')%core)
    : @find_Name_and_val var' t n T N V None = Some v
      <-> List.In (existT (fun t => (Name * var' t)%type) t (n, v)) (Wf.flatten_binding_list N V).
  Proof using Type.
    revert dependent ls; intro ls; revert ls ls'; induction T; intros ls ls' Hls H;
      [ | | specialize (IHT1 (fst N) (fst V) ls (snd (split_onames T1 ls)));
            specialize (IHT2 (snd N) (snd V) (snd (split_onames T1 ls)) (snd (split_onames (T1 * T2) ls))) ];
      repeat first [ find_Name_and_val_default_to_None_step
                   | progress simpl in *
                   | rewrite List.in_app_iff
                   | misc_oname_t_step
                   | t_step
                   | progress split_iff
                   | lazymatch goal with
                     | [ H : find_Name ?n ?x = Some ?t, H' : find_Name_and_val ?t' ?n ?X ?V None = Some ?v |- _ ]
                       => apply find_Name_and_val_find_Name_Some in H'
                     | [ H : find_Name ?n ?x = Some ?t, H' : find_Name ?n ?x' = Some ?t' |- _ ]
                       => let apply_in_tac H :=
                              (eapply split_onames_find_Name_Some_unique in H;
                               [ | | apply path_prod_uncurried; split; [ eassumption | simpl; reflexivity ] ];
                               [ | solve [ eauto using oname_list_unique_firstn, oname_list_unique_skipn ] ]) in
                          first [ constr_eq x x'; fail 1
                                | apply_in_tac H; apply_in_tac H' ]
                     end ].
  Qed.

  Lemma fst_split_mnames__flatten_binding_list__find_Name
        (MName : Type) (force : MName -> option Name)
        {var' t n T N V v} {ls : list MName}
        (Hs : fst (split_mnames force T ls) = Some N)
        (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list (var2:=var') N V))
    : find_Name n N = Some t.
  Proof.
    revert dependent ls; induction T;
      [ | | specialize (IHT1 (fst N) (fst V));
            specialize (IHT2 (snd N) (snd V)) ];
      repeat first [ misc_oname_t_step
                   | t_step
                   | match goal with
                     | [ H : _ |- _ ] => first [ rewrite snd_split_mnames_skipn in H
                                               | rewrite List.in_app_iff in H ]
                     | [ H : context[fst (split_mnames _ _ ?ls)] |- _ ]
                       => is_var ls; rewrite (@fst_split_mnames_firstn _ _ _ _ _ ls) in H
                     end ].
  Abort.

  Lemma fst_split_mnames__find_Name__flatten_binding_list
        (MName : Type) (force : MName -> option Name)
        {var' t n T N V v default} {ls : list MName}
        (Hs : fst (split_mnames force T ls) = Some N)
        (Hfind : find_Name n N = Some t)
        (HN : List.In (existT _ t (n, v)%core) (Wf.flatten_binding_list N V))
    : @find_Name_and_val var' t n T N V default = Some v.
  Proof.
    revert default; revert dependent ls; induction T;
      [ | | specialize (IHT1 (fst N) (fst V));
            specialize (IHT2 (snd N) (snd V)) ];
      repeat first [ find_Name_and_val_default_to_None_step
                   | rewrite List.in_app_iff in *
                   | t_step ].
  Abort.
End with_context.


Require Import IOA.
Require Import Network.
Require Import Simulation.
Require Import CounterSpec.
Require Import CounterRegister.
Require Import Automation.
Require Import Misc.
Require Import ListOps.

Require Import List.
Import ListNotations.

Module CounterNetworked.

  Import CounterSpec.Api.
  Import CounterRegister.CounterRegister.

  (* counter built on top of register, but connected by
     network. basically a copy of CounterRegister, but uses Network *)

  Inductive Address := CounterAddr | RegisterAddr.

  Lemma Address_eq_dec : forall (a a' : Address),
      {a = a'} + {a <> a'}.
  Proof.
    decide equality.
  Defined.

  Definition Message := Register_API.

  Lemma Message_eq_dec : forall (m m' : Message),
      {m = m'} + {m <> m'}.
  Proof.
    repeat (decide equality).
  Defined.

  Definition CRNetwork : AutomatonDef (Network_API Address Message) :=
    Network _ _ Address_eq_dec Message_eq_dec.

  Definition Register_API_N : Type := Network_API Address Message.

  Definition CRNetwork_actions : Type := Network_actions Address Message.

  Definition Register_transition (st : Register_state) (act : Register_API_N) (st' : Register_state) : Prop :=
    match act with
    | Recv CounterAddr (Reg_Set n) RegisterAddr => (fst st = Reg_Ready /\ st' = (Reg_Setting, n)) \/
                                                   (fst st <> Reg_Ready /\ st' = st)
    | Send RegisterAddr Reg_Set_Done CounterAddr => fst st = Reg_Setting /\ st' = (Reg_Ready, snd st)
    | Recv CounterAddr Reg_Get_Request RegisterAddr => (fst st = Reg_Ready /\ st' = (Reg_Getting, snd st)) \/
                                                       (fst st <> Reg_Ready /\ st' = st)
    | Send RegisterAddr (Reg_Get_Response n) CounterAddr => st = (Reg_Getting, n) /\ st' = (Reg_Ready, n)
    | Send _ _ _ => False
    | Recv _ _ _ => st' = st (* input-enabled *)
    end.

  Definition Register : AutomatonDef Register_API_N :=
    mkAutomatonDef
      _
      Register_state
      EmptySet
      Register_init
      (liftExternal Register_transition).

  Goal in_traces Register
       [
         Recv CounterAddr Reg_Get_Request RegisterAddr;
           Send RegisterAddr (Reg_Get_Response 0) CounterAddr;
           Recv CounterAddr (Reg_Set 3) RegisterAddr;
           Send RegisterAddr Reg_Set_Done CounterAddr
       ].
  Proof.
    eexists ((_, _)); eexists ((_, _)); split; [hnf; eauto |].
    repeat (eapply Step_External; simpl; eauto).
  Qed.

  Definition Counter_action_type : Type := Counter_API + Register_API_N.

  Definition Counter_transition (st : Counter_state) (act : Counter_action_type) (st' : Counter_state) : Prop :=
    match act with
    | inl Reset => (fst st = DReady /\ st' = (DResetting1, snd st)) \/
                   (fst st <> DReady /\ st' = st)
    | inr (Send CounterAddr (Reg_Set n) RegisterAddr) =>
      match (fst st) with
      | DResetting1 => n = 0 /\ st' = (DResetting2, snd st)
      | DIncrementing3 => n = snd st /\ st' = (DIncrementing4, snd st)
      | _ => False
      end
    | inr (Recv RegisterAddr Reg_Set_Done CounterAddr) =>
      match (fst st) with
      | DResetting2 => st' = (DResetting3, snd st)
      | DIncrementing4 => st' = (DIncrementing5, snd st)
      | _ => st' = st
      end
    | inl Reset_Done => fst st = DResetting3 /\ st' = (DReady, snd st)
    | inl Increment => (fst st = DReady /\ st' = (DIncrementing1, snd st)) \/
                       (fst st <> DReady /\ st' = st)
    | inr (Send CounterAddr Reg_Get_Request RegisterAddr) =>
      match (fst st) with
      | DIncrementing1 => st' = (DIncrementing2, snd st)
      | DReading1 => st' = (DReading2, snd st)
      | _ => False
      end
    | inr (Recv RegisterAddr (Reg_Get_Response n) CounterAddr) =>
      match (fst st) with
      | DIncrementing2 => st' = (DIncrementing3, S n)
      | DReading2 => st' = (DReading3, n)
      | _ => st' = st
      end
    | inl Increment_Done => fst st = DIncrementing5 /\ st' = (DReady, snd st)
    | inl Read_Request => (fst st = DReady /\ st' = (DReading1, snd st)) \/
                          (fst st <> DReady /\ st' = st)
    | inl (Read_Response n) => st = (DReading3, n) /\ st' = (DReady, n)
    | inr (Recv _ _ _) => st' = st
    | inr (Send _ _ _) => False
    end.

  Definition Counter : AutomatonDef _ :=
    mkAutomatonDef
      _
      Counter_state
      EmptySet
      Counter_init
      (liftExternal Counter_transition).

  Definition Counter_Register : AutomatonDef (Counter_API + Register_API_N) :=
    compose
      Counter
      Register
      _
      (fun act => match act with
                  | inl act_ctr => Some act
                  | inr (Recv _ _ CounterAddr) => Some act
                  | inr (Send CounterAddr _ _) => Some act
                  | inr _ => None
                  end)
      (fun act => match act with
                  | inr act_net => match act_net with
                                   | Recv _ _ RegisterAddr => Some act_net
                                   | Send RegisterAddr _ _ => Some act_net
                                   | _ => None
                                   end
                  | _ => None
                  end).

  Definition Counter_Register_Networked : AutomatonDef (Counter_API + Register_API_N) :=
    compose
      Counter_Register
      CRNetwork
      (Counter_API + Network_API Address Message)
      (fun act => Some act)
      (fun act => match act with
                  | inr act_net => Some act_net
                  | _ => None
                  end).

  Definition Counter_Register_Networked_external : AutomatonDef Counter_API :=
    rename
      Counter_Register_Networked
      Counter_API
      (fun act_ctr => inl act_ctr)
      Register_API_N
      (fun act_reg => inr act_reg).

  Goal in_traces Counter_Register_Networked_external
       [
         Increment;
           Increment_Done
       ].
  Proof.
    (* a horrible, messy proof that should be automated *)
    unfold in_traces.
    eexists ((_, _), nil).
    eexists; split; [cbv; auto | ].
    estep_ext_break; [cbv; auto |].
    estep_int_break (inr (Send CounterAddr Reg_Get_Request RegisterAddr)); [cbv; eauto |].
    estep_int_break (inr (Recv CounterAddr Reg_Get_Request RegisterAddr));
      [simpl; intuition; destruct (Address_eq_dec _ _); destruct (Message_eq_dec); destruct (Address_eq_dec _ _); try congruence; intuition | ].
    estep_int_break (inr (Send RegisterAddr (Reg_Get_Response 0) CounterAddr)); [cbv; eauto |].
    estep_int_break (inr (Recv RegisterAddr (Reg_Get_Response 0) CounterAddr)); [cbv; eauto |].
    estep_int_break (inr (Send CounterAddr (Reg_Set 1) RegisterAddr)); [cbv; eauto |].
    estep_int_break (inr (Recv CounterAddr (Reg_Set 1) RegisterAddr));
      [simpl; intuition; destruct (Address_eq_dec _ _); destruct (Message_eq_dec); destruct (Address_eq_dec _ _); try congruence; intuition | ].
    estep_int_break (inr (Send RegisterAddr Reg_Set_Done CounterAddr)); [cbv; eauto |].
    estep_int_break (inr (Recv RegisterAddr Reg_Set_Done CounterAddr)); [cbv; eauto |].
    estep_ext_break; [cbv; auto |].
    eauto.
  Qed.

  Ltac in_single :=
    match goal with
    | [ H : In _ [?x] |- _ ] => inversion H; clear H; shallow
    end.

  Ltac packet_eq :=
    match goal with
    | [ H : mkPacket _ _ _ = mkPacket _ _ _ |- _ ] => inversion H; clear H; subst
    end.

  Theorem counter_register_networked_correct :
    refines Counter_Register_Networked_external CounterSpec.Blocking.Spec.
  Proof.
    apply refines_trans with (intermediate := Counter_Register_System_external); auto using counter_register_system_correct.
    apply forward_simulation with
    (f := fun
           (st_net : StateType Counter_Register_Networked_external)
           (st_dist : StateType Counter_Register_System_external) =>
           let pkts := snd st_net in
           let net_ctr := fst (fst st_net) in
           let net_reg := snd (fst st_net) in
           let net_ctr_pc := fst net_ctr in
           let net_ctr_val := snd net_ctr in
           let net_reg_pc := fst net_reg in
           let net_reg_val := snd net_reg in
           let dist_ctr := fst st_dist in
           let dist_reg := snd st_dist in
           let dist_ctr_pc := fst dist_ctr in
           let dist_ctr_val := snd dist_ctr in
           let dist_reg_pc := fst dist_reg in
           let dist_reg_val := snd dist_reg in

           (* this is probably too detailed reasoning about network state... *)
           match dist_ctr_pc with
           | DReady => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           | DIncrementing1 => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           | DIncrementing2 => net_ctr_pc = DIncrementing2 /\
                               dist_reg_pc = Reg_Getting /\
                               net_ctr_val = dist_ctr_val /\
                               net_reg_val = dist_reg_val /\
                               ((pkts = [mkPacket CounterAddr Reg_Get_Request RegisterAddr] /\ net_reg_pc = Reg_Ready) \/
                                (pkts = nil /\ net_reg_pc = Reg_Ready) \/
                                (pkts = nil /\ net_reg_pc = Reg_Getting) \/
                                (pkts = [mkPacket RegisterAddr (Reg_Get_Response net_reg_val) CounterAddr] /\ net_reg_pc = Reg_Ready))
           | DIncrementing3 => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           | DIncrementing4 => net_ctr_pc = DIncrementing4 /\
                               dist_reg_pc = Reg_Setting /\
                               net_ctr_val = dist_ctr_val /\
                               dist_reg_val = dist_ctr_val /\
                               ((pkts = [mkPacket CounterAddr (Reg_Set net_ctr_val) RegisterAddr] /\ net_reg_pc = Reg_Ready) \/
                                (pkts = nil /\ net_reg_pc = Reg_Ready) \/
                                (pkts = nil /\ net_reg_pc = Reg_Setting /\ net_reg_val = net_ctr_val) \/
                                (pkts = [mkPacket RegisterAddr Reg_Set_Done CounterAddr] /\ net_reg_pc = Reg_Ready /\ net_reg_val = net_ctr_val) \/
                                (pkts = nil /\ net_reg_pc = Reg_Ready /\ net_reg_val = net_ctr_val))
           | DIncrementing5 => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           | DResetting1 => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           | DResetting2 => net_ctr_pc = DResetting2 /\
                            dist_reg_pc = Reg_Setting /\
                            net_ctr_val = dist_ctr_val /\
                            dist_reg_val = 0 /\
                            ((pkts = [mkPacket CounterAddr (Reg_Set 0) RegisterAddr] /\ net_reg_pc = Reg_Ready) \/
                             (pkts = nil /\ net_reg_pc = Reg_Ready) \/
                             (pkts = nil /\ net_reg_pc = Reg_Setting /\ net_reg_val = 0) \/
                             (pkts = [mkPacket RegisterAddr Reg_Set_Done CounterAddr] /\ net_reg_pc = Reg_Ready /\ net_reg_val = 0) \/
                             (pkts = nil /\ net_reg_pc = Reg_Ready /\ net_reg_val = 0))
           | DResetting3 => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           | DReading1 => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           | DReading2 => net_ctr_pc = DReading2 /\
                          dist_reg_pc = Reg_Getting /\
                          net_ctr_val = dist_ctr_val /\
                          net_reg_val = dist_reg_val /\
                          ((pkts = [mkPacket CounterAddr Reg_Get_Request RegisterAddr] /\ net_reg_pc = Reg_Ready) \/
                           (pkts = nil /\ net_reg_pc = Reg_Ready) \/
                           (pkts = nil /\ net_reg_pc = Reg_Getting) \/
                           (pkts = [mkPacket RegisterAddr (Reg_Get_Response net_reg_val) CounterAddr] /\ net_reg_pc = Reg_Ready))
           | DReading3 => net_ctr = dist_ctr /\ net_reg = dist_reg /\ dist_reg_pc = Reg_Ready /\ pkts = nil
           end
    ).
    split.
    - intros s1 Hstart.
      destruct s1 as [[[ic_pc ic_v] [ir_pc ir_v]] msgs].
      inversion Hstart as [[Hc Hr] Hn].
      inversion Hc; inversion Hr; inversion Hn; simpl in *.
      eexists; ebreak_compstate; cbv; intuition.
    - intros s1' s1 act1 s2' Hstep Hrel.
      simpl in Hstep; unfold Rename_transition in Hstep.
      destruct act1 as [[[[[] | []] | inact] | ract] | cact].
      + (* drop *)
        destruct inact.
        simpl in Hrel.
        destruct s1' as [[[s1'_cpc s1'_cv] [s1'_rpc s1'_rv]] s1'_msgs];
          destruct s1 as [[[s1_cpc s1_cv] [s1_rpc s1_rv]] s1_msgs];
          destruct s2' as [[s2'_cpc s2'_cv] [s2'_rpc s2'_rv]];
          simpl in *.
        destruct s2'_cpc eqn:H;
          try solve [inversion Hstep as [[? [Hx ?]] ?]; intuition; subst; inversion Hx];
          exists ((s2'_cpc, s2'_cv), (s2'_rpc, s2'_rv)).
        all:
          destruct Hrel;
          explode;
          subst;
          simpl;
          auto.
        all:
          split; [| solve [econstructor; eauto]];
          explode;
          subst;
          intuition;
          cleanup;
          subst;
          match goal with
          | [ H : In _ [] |- _ ] => solve [inversion H]
          | [ H : In _ _ |- _ ] => destruct H as [H | H]; [rewrite H | solve by inversion]
          end;
          eauto using remove_one_only.
      + (* send/recv *)
        destruct s1' as [[[s1'_cpc s1'_cv] [s1'_rpc s1'_rv]] s1'_msgs];
          destruct s1 as [[[s1_cpc s1_cv] [s1_rpc s1_rv]] s1_msgs];
          destruct s2' as [[s2'_cpc s2'_cv] [s2'_rpc s2'_rv]].
        destruct ract as [src m dst | src m dst].
        * (* send *)
          destruct src; destruct dst; destruct m; simpl in *; try solve [intuition].
          -- destruct s1'_cpc; destruct s1'_rpc; try tauto;
               destruct s2'_cpc; cleanup; try congruence.
             ++ eexists ((DResetting2, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto.
                ** eapply Step_Internal with (int := inr (Reg_Set _)); [| eapply Step_None];
                     eauto; simpl; intuition.
             ++ eexists ((DIncrementing4, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto.
                ** eapply Step_Internal with (int := inr (Reg_Set _)); [| eapply Step_None];
                     eauto; simpl; intuition.
          -- destruct s1'_cpc; destruct s1'_rpc; try tauto;
               destruct s2'_cpc; cleanup; try congruence.
             ++ eexists ((DIncrementing2, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto.
                ** eapply Step_Internal with (int := inr (Reg_Get_Request)); [| eapply Step_None];
                     eauto; simpl; intuition.
             ++ eexists ((DReading2, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto.
                ** eapply Step_Internal with (int := inr (Reg_Get_Request)); [| eapply Step_None];
                     eauto; simpl; intuition.
          -- destruct s1'_cpc; destruct s1'_rpc; try tauto;
               destruct s2'_cpc;
               cleanup;
               try congruence;
               repeat break_or;
               try solve [intuition; congruence];
               cleanup.
             ++ eexists ((DResetting2, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto 10.
                ** subst; simpl; eauto.
             ++ eexists ((DIncrementing4, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto 10.
                ** subst; simpl; eauto.
          -- destruct s1'_cpc; destruct s1'_rpc; try tauto;
               destruct s2'_cpc;
               cleanup;
               try congruence;
               repeat break_or;
               try solve [intuition; congruence];
               cleanup.
             ++ eexists ((DIncrementing2, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto.
                ** subst; simpl; eauto.
             ++ eexists ((DReading2, _), (_, _)).
                simpl; split.
                ** repeat split; subst; eauto.
                ** subst; simpl; eauto.
        * (* recv *)
          destruct src; destruct dst; destruct m; simpl in *;
            try solve [exfalso; destruct s2'_cpc; cleanup; repeat break_or; cleanup; subst; shallow].
          -- destruct s2'_cpc; cleanup; repeat break_or; cleanup; subst; shallow.
             ++ in_single; packet_eq;
                  eexists ((DResetting2, _), (_, _)); split.
                ** repeat split; eauto 10.
                ** simpl; eauto.
             ++ in_single; packet_eq;
                  eexists ((DIncrementing4, _), (_, _)); split.
                ** repeat split; eauto 10 using remove_one_only.
                ** simpl; eauto.
          -- destruct s2'_cpc; cleanup; repeat break_or; cleanup; subst; shallow.
             ++ in_single; packet_eq.
                eexists ((DIncrementing2, _), (_, _)); split.
                ** repeat split; eauto 10.
                ** simpl; eauto.
             ++ in_single; packet_eq.
                eexists ((DReading2, _), (_, _)); split.
                ** repeat split; eauto 10.
                ** simpl; eauto.
          -- destruct s2'_cpc; cleanup; repeat break_or; cleanup; subst; shallow.
             ++ in_single; packet_eq.
                eexists ((DResetting3, _), (_, _)); split.
                ** repeat split; simpl; eauto 10.
                ** eapply Step_Internal with (int := inr (Reg_Set_Done)); [| eapply Step_None];
                     eauto; simpl; intuition.
             ++ in_single; packet_eq.
                eexists ((DIncrementing5, _), (_, _)); split.
                ** repeat split; simpl; eauto 10.
                ** eapply Step_Internal with (int := inr (Reg_Set_Done)); [| eapply Step_None];
                     eauto; simpl; intuition.
          -- destruct s2'_cpc; cleanup; repeat break_or; cleanup; subst; shallow.
             ++ in_single; packet_eq.
                eexists ((DIncrementing3, _), (_, _)); split.
                ** repeat split; eauto using remove_one_only; simpl; eauto.
                ** eapply Step_Internal with (int := inr (Reg_Get_Response _)); [| eapply Step_None];
                     eauto; simpl; intuition.
             ++ in_single; packet_eq.
                eexists ((DReading3, _), (_, _)); split.
                ** repeat split; eauto using remove_one_only; simpl; eauto.
                ** eapply Step_Internal with (int := inr (Reg_Get_Response _)); [| eapply Step_None];
                     eauto; simpl; intuition.
      + (* counter API *)
        destruct s1' as [[[s1'_cpc s1'_cv] [s1'_rpc s1'_rv]] s1'_msgs];
          destruct s1 as [[[s1_cpc s1_cv] [s1_rpc s1_rv]] s1_msgs];
          destruct s2' as [[s2'_cpc s2'_cv] [s2'_rpc s2'_rv]];
          simpl in *.
        eexists ((s1_cpc, s2'_cv), (s2'_rpc, s2'_rv)). (* identical, only thing that could change is counter pc *)
        destruct s1'_cpc eqn:Hc1cpc; destruct s2'_cpc eqn:Hs2cpc; try solve [exfalso; cleanup; congruence];
          destruct cact eqn:Hcact; cleanup; subst; cleanup; simpl in *; try congruence;
            try break_or; shallow; cleanup; subst; intuition;
              eapply Step_External; eauto; simpl; eauto.
  Qed.

End CounterNetworked.


(*
 * Coq code for "Using XCAP to Certify Realistic System Code: Machine Context Management"
 *
 * XCAP common definition and lemma library
 *
 * (for Coq version 8.0pl2)
 *)

Require Import ZArith.
Require Import axiom.
Require Import Map.
Require Import Mapt.
Require Import tm.
Require Import mathlib.
Require Import propx.
Require Import propxlib.
Require Import seplogic.
Require Import seplib.
Require Import List.
Require Import tylist.
Require Import xcap.

Definition reg4 L bx si di bp sp : RegFile -> PropX L := fun R =>
  << R ebx = bx /\ R esi = si /\ R edi = di /\ R ebp = bp /\ R esp = sp >>.

Definition reg6 L bx cx dx si di bp sp : RegFile -> PropX L := fun R =>
  << R ebx = bx /\ R ecx = cx /\ R edx = dx /\ R esi = si /\ R edi = di /\ R ebp = bp /\ R esp = sp >>.

Definition _Fn6p L args bx cx dx si di bp sp ss ret apre apost : State -> PropX L :=
  fun S : State => let (HR, F) := S in let (H, R) := HR in
    reg6 _ bx cx dx si di bp sp R
      ./\ star (stack _ sp ss (ret :: args))
         (star apre
               (fun H => (extv _ _ (eq_rect _ _
                                   (Lift _ _ (var tO _ H)
                                   ./\ codeptr _ ret
                                     (fun S' => let (HR', F') := S' in let (H', R') := HR' in
                                     Ex retv. reg6 _ bx cx dx si di bp (sp+4) R' ./\ << R' eax = retv>>
                                          ./\ star (stack _ (sp+4) (ss+4) args)
                                             (star (fun H => Shift _ _ (eq_rect _ _ (apost retv H)
                                                            _ (eq_tplus_tO_tail _)) _)
                                                   (fun H => Lift _ _ (var tO _ H))) H'))
                                  _ (tylist.eq_tplus_tO _))))) H.

Notation "'Fn6p' a1 , a2 '{Aux' : ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, a2, bx, cx, dx, si, di, bp, sp, ss, ret.
     extv _ _ (eq_rect _ _
                          (_Fn6p _ (a1::a2::nil) bx cx dx si di bp sp ss ret apre (fun retv => apost) S)
                          _ (tylist.eq_tplus_tO _))) (at level 110, only parsing).

Definition _Fn L args fs fvs bx si di bp sp ss ret apre apost : State -> PropX L :=
  fun S : State => match S with ((H, R), F) =>
    reg4 L bx si di bp sp R ./\ << 0 <= ss-fs >>
      ./\ (extv _ _ (eq_rect _ _
              ((star (stack _ sp ss (fvs ++ (ret :: args)))
               (star (fun H => Shift _ _ (eq_rect _ _ (apre H) _ (eq_tplus_tO_tail _)) _)
                     (fun H => Lift _ _ (var tO _ H))) H) ./\
                               codeptr _ ret
                                     (fun S' => match S' with ((H',R'),F') =>
                                     Ex retv. reg4 _ bx si di bp (sp+4+4*Z_of_nat (length fvs)) R' ./\ << 0 <= ss - fs >> ./\ << R' eax = retv>>
                                          ./\ star (stack _ (sp+4+4*Z_of_nat (length fvs)) (ss+4+4*Z_of_nat (length fvs)) args)
                                             (star (fun H => Shift _ _ (eq_rect _ _ (apost retv H)
                                                            _ (eq_tplus_tO_tail _)) _)
                                                   (fun H => Lift _ _ (var tO _ H))) H'
                                                end))
                                  _ (tylist.eq_tplus_tO _)))
                   end.

Definition _Fn6 L args fs fvs bx cx dx si di bp sp ss ret apre apost : State -> PropX L :=
  fun S : State => match S with ((H, R), F) =>
    reg6 L bx cx dx si di bp sp R ./\ << 0 <= ss - fs >>
      ./\ (extv _ _ (eq_rect _ _
              ((star (stack _ sp ss (fvs ++ (ret :: args)))
               (star (fun H => Shift _ _ (eq_rect _ _ (apre H) _ (eq_tplus_tO_tail _)) _)
                     (fun H => Lift _ _ (var tO _ H))) H) ./\
                               codeptr _ ret
                                     (fun S' => match S' with ((H',R'),F') =>
                                     Ex retv. reg6 _ bx cx dx si di bp (sp+4+4*Z_of_nat (length fvs)) R' ./\ << 0 <= ss - fs >> ./\ << R' eax = retv>>
                                          ./\ star (stack _ (sp+4+4*Z_of_nat (length fvs)) (ss+4+4*Z_of_nat (length fvs)) args)
                                             (star (fun H => Shift _ _ (eq_rect _ _ (apost retv H)
                                                            _ (eq_tplus_tO_tail _)) _)
                                                   (fun H => Lift _ _ (var tO _ H))) H'
                                                end))
                                  _ (tylist.eq_tplus_tO _)))
                   end.

Notation "'Fn' '{Aux' : ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex bx, si, di, bp, sp, ss, ret.
     _Fn _ nil fs nil bx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S) (at level 110, only parsing).

Notation "'Fn' a1 '{Aux' : ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, bx, si, di, bp, sp, ss, ret.
     _Fn _ (a1::nil) fs nil bx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S) (at level 110, only parsing).

Notation "'Fn' a1 , a2 '{Aux' : ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, a2, bx, si, di, bp, sp, ss, ret.
     _Fn _ (a1::a2::nil) fs nil bx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S) (at level 110, only parsing).

Notation "'Fnp' a1 '{Aux' : x1 ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, x1, bx, si, di, bp, sp, ss, ret.
     extv _ _ (eq_rect _ _
    (_Fn _ (a1::nil) fs nil bx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S)
            _ (tylist.eq_tplus_tO _))) (at level 110, only parsing).

Notation "'Fnp' a1 , a2 '{Aux' : x1 ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, a2, x1, bx, si, di, bp, sp, ss, ret.
     extv _ _ (eq_rect _ _
    (_Fn _ (a1::a2::nil) fs nil bx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S)
            _ (tylist.eq_tplus_tO _))) (at level 110, only parsing).

Notation "'Fnp' a1 , a2 '{Aux' : ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, a2, bx, si, di, bp, sp, ss, ret.
     extv _ _ (eq_rect _ _
    (_Fn _ (a1::a2::nil) fs nil bx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S)
            _ (tylist.eq_tplus_tO _))) (at level 110, only parsing).

Notation "'Fnp' a1 , a2 , a3 , a4 , a5 '{Aux' : ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, a2, a3, a4, a5, bx, si, di, bp, sp, ss, ret.
     extv _ _ (eq_rect _ _
    (_Fn _ (a1::a2::a3::a4::a5::nil) fs nil bx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S)
            _ (tylist.eq_tplus_tO _))) (at level 110, only parsing).

Notation "'Fn6' '{Aux' : ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex bx, cx, dx, si, di, bp, sp, ss, ret.
     _Fn6 _ nil fs nil bx cx dx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S) (at level 110, only parsing).

Notation "'Fn6' '{Aux' : ; 'Local' : [ fs ] , f1 ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex f1, bx, cx, dx, si, di, bp, sp, ss, ret.
     _Fn6 _ nil fs (f1::nil) bx cx dx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S) (at level 110, only parsing).

Notation "'Fn6' '{Aux' : ; 'Local' : [ fs ] , f1 , f2 ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex f1, f2, bx, cx, dx, si, di, bp, sp, ss, ret.
     _Fn6 _ nil fs (f1::f2::nil) bx cx dx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S) (at level 110, only parsing).

Notation "'Fn6p_' a1 , a2 '{Aux' : ; 'Local' : [ fs ] ; 'Pre' : apre ; 'Post' : apost }" :=
  (fun S : State => Ex a1, a2, bx, cx, dx, si, di, bp, sp, ss, ret.
     extv _ _ (eq_rect _ _
    (_Fn6 _ (a1::a2::nil) fs nil bx cx dx si di bp sp ss ret
           (match S with ((_,r),f) => apre end)
           (fun retv => apost) S)
            _ (tylist.eq_tplus_tO _))) (at level 110, only parsing).

Lemma wfjmpr' : forall Si a r,
                (a ==> fun S => extv _ _ (eq_rect _ _
                                  (codeptr _ (_R S r) (var _ _) ./\ var _ _ S)
                                  _ (eq_tplus_tO _)))
                                            -> WFiseq Si a (instr (jmp (reg r))).
intros. apply wfjmpr. unfold Itp. intros. generalize (H _ _ H0). clear H. intro.
destv H a'. simpl in H. dest H. destv H a''. simpl in H. dest H. des H2.
apply ok_extv_i with a''. simpl. splitx. auto. generalize (H2 S). clear H2. intro.
des H2. rewrite <- shift_subst_eq in H2. auto.
Qed.

Lemma wfret'   : forall Si a,
                (a ==> (fun S => Ex fret.
                                   <<Map.lookup (_H S) (_R S esp) fret>> ./\
                                  extv _ _ (eq_rect _ _
                                  (codeptr _ fret (var _ _) ./\
                                   Ex s'.
                                     <<Next pop' S s'>> ./\ var _ _ s')
                                  _ (eq_tplus_tO _))))
                                            -> WFiseq Si a (instr ret).
intros. apply wfret. unfold Itp. intros. destruct S. destruct p.
generalize (H _ _ H0). clear H. intro. destv H fret. dest H. simpl in H1.
destv H1 a'. simpl in H1. dest H1. destv H1 a''. simpl in H1. dest H1.
des H3.
existsx fret. splitx. auto. simpl. apply ok_extv_i with a''. simpl. splitx.
auto. destv H2 S'. dest H2. existsx S'. splitx; auto.
generalize (H3 S'). clear H3. intro H3. des H3.
rewrite <- shift_subst_eq in H3. auto.
Qed.

Lemma wfweak : forall Si a a' I, (a ==> a') -> (Si |-{a'} I) -> (Si |-{a} I).
intros. apply InstrSeqWeakening with Si a'; auto.
unfold subseteq. intro. destruct (Si a0); auto.
Qed.

Lemma WFret : forall Si a fs, Si |-{ (Fn6 {Aux : ; Local : [fs] ;
  Pre:  a;
  Post: a}) } (instr ret).
Opaque star codeptr ptoanyn.
intros. apply wfret. unfold Itp. intros. destruct S; destruct p.
do 9 (dest H). dest H. dest H0. dest H1. simpl in H1.
dest H1. generalize H1; clear H1; rwsubst; intros.
rewrite <- shift_subst_eq_fun in H1.
replace (fun h:Heap => x8 h) with x8 in H1; try apply ext_eq; auto.
Transparent codeptr.
simpl in H2.
existsx x7. splitx. dest H. destruct H3. destruct H4. destruct H5. destruct H6.
destruct H7. rewrite H8. propx.
generalize H1; clear H1; apply lookup_star_lookup. apply stack_lookup_0.
dest H2. simpl in H2. existsx x9. simpl. dest H2. splitx; auto.
existsx (h, updR r esp (x5 + 4), e). splitx.
propx. dest H. destruct H4. destruct H5. destruct H6.
destruct H7. destruct H8.
apply stp_pop'; rewrite H9.
generalize H1; clear H1; apply star_imp_prop. unfold stack. simpl.
intros. generalize (star_sym _ _ _ _ H1); clear H1; apply star_imp_prop; intro.
apply star_imp_prop; intros. dest H1. unfold Dword. omega.
unfold uR, updR. split; auto. intros. rewrite beq_rneq_false; auto.
des H3. generalize (H3 (h, updR r esp (x5+4), e)); clear H3; intros.
apply ok_imp_e with
       (Subst tO State
            (Subst (tS State tO) Heap
               (Shift (tS Heap tO) tO
                  (Ex retv
                   . reg6 (tS Heap tO) x x0 x1 x2 x3 x4 (x5 + 4 + 0) (updR r esp (x5 + 4))
                     ./\ << 0 <= x6 - fs >>
                         ./\ << updR r esp (x5 + 4) eax = retv >>
                             ./\ star (stack (tS Heap tO) (x5 + 4 + 0) (x6 + 4 + 0) nil)
                                   (star (fun H : Heap => Shift tO tO (a H) Heap) (fun H : Heap => var tO Heap H)) h) State)
               (fun x : Heap => Shift tO tO (x8 x) State)) x9); auto.
clear H3. simpl. existsx (r eax). splitx. propx. unfold updR. simpl.
dest H. destruct H3. destruct H4. destruct H5. destruct H6. destruct H7.
repeat (split; auto). symmetry. apply Zplus_0_r.
splitx; auto. splitx. propx. tauto.
rwshift (tS Heap tO) tO. do 2 rwsubst.
rewrite <- shift_subst_eq_2_fun'. rewrite <- shift_subst_eq_fun.
generalize H1; clear H1; apply star_imp; auto.
intro. intro. replace (x5+4+0) with (x5+4); try (symmetry; apply Zplus_0_r).
replace (x6+4+0) with (x6+4); try (symmetry; apply Zplus_0_r).
apply stack_return.
Qed.

(* add esp, 8
   ret
*)
Lemma WFret8 : forall Si a fs,
  Si |-{ (Fn6 {Aux : ; Local : [fs], f1, f2 ;
            Pre:  a;
            Post: a}) } iseq (add esp (word 8))
                             (instr ret).
Opaque star codeptr ptoanyn.
intros.
apply wfiseq with (Fn6 {Aux : ; Local : [fs+8] ;
  Pre:  a;
  Post: a}).
unfold Itp. intros. destruct S; destruct p.
destv H f1. destv H f2.
destv H bx. destv H cx. destv H dx. destv H si. destv H di. destv H bp.
destv H sp. destv H ss. destv H retp. dest H.
dest H0. destv H1 aprv. simpl in H1. dest H1.
generalize H1; clear H1; rwsubst; intros. rewrite <- shift_subst_eq_fun in H1.
dest H. destruct H3. destruct H4. destruct H5. destruct H6. destruct H7.
existsx (h, updR r esp (sp+8),
  fun f => match f with cf => Zlt_bool (sp + 8) 0
                      | zf => Zeq_bool (sp + 8) 0 end). splitx.
propx. apply stp_add; simpl; rewrite H8.
unfold stack in H1. simpl in H1.
generalize (star_sym _ _ _ _ H1); clear H1; intros.
generalize (star_assoc_R _ _ _ _ _ H1); clear H1; intros.
generalize (star_assoc_R _ _ _ _ _ H1); clear H1; intros.
generalize (star_assoc_R _ _ _ _ _ H1); clear H1; intros.
generalize (star_sym _ _ _ _ H1); clear H1.
apply star_imp_prop. intro. replace (sp +4 +4) with (sp+8); try ring.
apply star_imp_prop. intros. dest H1. unfold Dword. omega.
unfold uR, updR. split; auto. intros. rewrite beq_rneq_false; auto.
unfold CalcF; auto.
existsx bx. existsx cx. existsx dx. existsx si. existsx di. existsx bp.
existsx (sp+8). existsx (ss+8). existsx retp. unfold _Fn6.
splitx; auto. unfold reg6, updR. simpl. propx. tauto.
splitx. replace (ss +8-(fs+8)) with (ss-fs); try ring; auto.
existsx aprv. simpl. splitx; auto. rwsubst. rewrite <- shift_subst_eq_fun.
generalize H1; clear H1; apply star_imp; auto. intros.
replace (sp+8) with (sp+4+4); try ring.
replace (ss+8) with (ss+4+4); try ring.
apply stack_return with f2.
apply stack_return with f1; auto.
replace (sp+8+4+0) with (sp+4+8); try ring.
replace (ss+8+4+0) with (ss+4+8); try ring.
replace (ss+8-(fs+8)) with (ss-fs); try ring.
auto.
apply WFret.
Qed.


Require Import Charge.Logics.ILogic.
Require Import Charge.Logics.Later.
Require Import Charge.Logics.ILEmbed.
Require Import Charge.Open.OpenILogic.
Require Import Charge.Open.Subst.

Require Import Java.Language.Lang.
Require Import Java.Language.Program.

Require Import Java.Semantics.OperationalSemantics.
Require Import Java.Semantics.AxiomaticSemantics.

Require Import Java.Logic.SpecLogic.
Require Import Java.Logic.AssertionLogic.

Require Import ExtLib.Data.PreFun.
Require Import ExtLib.Structures.Applicative.

Require Import MirrorCharge.Java.Reify.

Set Implicit Arguments.
Set Strict Implicit.

Local Instance Applicative_Fun A : Applicative (Fun A) :=
{ pure := fun _ x _ => x
; ap := fun _ _ f x y => (f y) (x y)
}.

Lemma pull_exists {A} {P : A -> sasn} c Q G
	(H : forall x, G |-- {[P x]} c {[Q]}) :
	G |-- {[lexists P]} c {[Q]}.
Proof.
  rewrite <- exists_into_precond2.
  apply lforallR. apply H.
Qed.
Print sasn.
Lemma eq_to_subst x (e : stack -> val) (P Q : sasn)
    (H : apply_subst P (subst1 e x) |-- apply_subst Q (subst1 e x)) :
	embed (ap_eq [stack_get x, e]) //\\ P |-- Q.
Proof.

  admit.
Qed.

Lemma ent_left_exists {A} (P : sasn) (Q : A -> sasn)
	(H : exists x, P |-- Q x) :
	P |-- lexists Q.
Proof.
  admit.
Qed.

Lemma rule_seq c1 c2 (P Q R : sasn) G
      (Hc1 : G |-- {[P]} c1 {[Q]})
      (Hc2 : G |-- {[Q]} c2 {[R]}) :
  G |-- {[P]} cseq c1 c2 {[R]}.
Proof.
  apply rule_seq with Q; assumption.
Qed.

Lemma rule_skip P Q G : P |-- Q -> G |-- {[P]} cskip {[Q]}.
Proof.
  intros.
  eapply roc_post; [eapply rule_skip | apply H].
Qed.

Lemma rule_skip2 P G :(* P |-- Q -> *)G |-- {[P]} cskip {[P]}.
Proof.
  apply rule_skip. reflexivity.
Qed.

Lemma rule_if (e : dexpr) c1 c2 (P Q : sasn) G
      (Hc1 : G |-- {[(@embed (@vlogic Lang.var val) sasn _
                      (ap_eq [eval e, pure (vbool true)])) //\\ P]} c1 {[Q]})
      (Hc2 : G |-- {[(@embed (@vlogic Lang.var _) sasn _
                      (ap_eq [eval (E_not e), pure (vbool true)])) //\\ P]} c2 {[Q]}) :
  G |-- {[P]} cif e c1 c2 {[Q]}.
Proof.
  reify_imp (G |-- {[P]} cif e c1 c2 {[Q]}).
  eapply rule_if; unfold vlogic_eval, Open.liftn, Open.lift; simpl in *;
  	[apply Hc1|apply Hc2].
Qed.

Require Import Charge.Logics.BILogic.

  Lemma rule_read_fwd (x y : Lang.var) (f : field) (e : stack -> val) (P Q : sasn) (G : spec)
    (HP : P |-- ap_pointsto [y, f, e])
    (HQ : Exists v : val, (embed (ap_eq [stack_get x, apply_subst e (subst1 (pure (T := Fun stack) v) x)])) //\\
    					      (apply_subst P (subst1 (pure (T := Fun stack) v) x)) |-- Q) :
    G |-- {[ P ]} cread x y f {[ Q ]}.
  Proof.
    pose proof @rule_read_fwd x y f e P.
    unfold Open.liftn, Open.lift, open_eq, stack_get, Open.var_expr in *; simpl in *.
    rewrite <- HQ , <- H; [apply ltrueR | apply HP].
  Qed.

  Lemma rule_write_fwd (x : Lang.var) (f : field) (e : dexpr) G (P Q F : sasn) (e' : stack -> val)
        (HP : P |-- ap_pointsto [x, f, e'] ** F)
        (HQ : ap_pointsto [x, f, eval e] ** F |-- Q) :
    G |-- ({[ P ]} cwrite x f e {[ Q ]}).
  Proof.
     pose proof @rule_write_frame G P F x f e' e. unfold Open.liftn, Open.lift, open_eq, stack_get, Open.var_expr in *; simpl in *.
	 rewrite <- HQ, H.
	 unfold stack. unfold pointsto. unfold eval.

	 setoid_rewrite <- sepSPC1 at 2.
	 reflexivity.
	 rewrite HP.
	 setoid_rewrite <- sepSPC1 at 2.
	 reflexivity.
  Qed.

  Lemma rule_assign_fwd (x : Lang.var) (e : dexpr) G P :
    G |-- {[ P ]} cassign x e {[ Exists v : val,
                                 embed (ap_eq [stack_get x,
                                               apply_subst (eval e) (subst1 (pure (T := Fun stack) v) x)]) //\\
    							   (apply_subst P (subst1 (pure (T := Fun stack) v) x)) ]}.
  Proof.
    pose proof @rule_assign_fwd G P.
    apply H. reflexivity.
  Qed.

  Lemma rule_alloc_fwd (x : Lang.var) (C : class) (G : spec) (P Q : sasn) (fields : list field) (Pr : Program)
	(Heq : G |-- prog_eq Pr)
	(Hf : field_lookup Pr C fields)
	(Hent : Exists p : val, embed (ap_typeof [stack_get x, C]) //\\
	                                            embed (ap_eq [stack_get x, pure p]) //\\
	                                            fold_right (fun f P => ap_pointsto [x, f, pure null] ** P)
	                                                    (apply_subst P (subst1 (pure (T := Fun stack) p) x)) fields |-- Q) :
	G |-- {[ P ]} calloc x C {[ Q ]}.
  Proof.
  	admit.
  Qed.

Check apply_subst.
  Lemma rule_static_complete (x : Lang.var) C (m : String.string) (es : list dexpr) (ps : list String.string) (r : Lang.var) G
    (P Q F Pm Qm : sasn)
    (HSpec : G |-- |> method_spec C m ps r Pm Qm)
    (HPre: P |-- apply_subst Pm (substl_trunc (zip ps (@map _ (stack -> val) eval es))) ** F)
    (HLen: length ps = length es) :
          G |-- {[ P ]} cscall x C m es {[ Exists v:val, apply_subst Qm (substl_trunc (zip (@cons String.string r ps)
                                     (@cons (stack -> val) (stack_get x)
                                      (@map (stack -> val) _ (fun e => apply_subst e (subst1 (pure (T := Fun stack) v) x))
                                          (@map dexpr (stack -> val) eval es))))) **
                           apply_subst F (subst1 (pure (T := Fun stack) v) x)]}.
Proof.
	admit.
Qed.

Lemma rule_dynamic_complete (x y : Lang.var) (m : String.string) (es : list dexpr) (ps : list String.string) C (r : Lang.var) G
    (P Q F Pm Qm : sasn)
    (HSpec : G |-- |> method_spec C m ps r Pm Qm)
    (HPre: P |-- (embed (ap_typeof [stack_get y, C]) //\\
                  apply_subst Pm (substl_trunc (zip ps (@map _ (stack -> val) eval (E_var y :: es))))) **
                 F)
    (HPost : Exists v:val, embed (ap_typeof [apply_subst (stack_get y) (subst1 (pure (T := Fun stack) v) x), C]) //\\
                    apply_subst Qm (substl_trunc (zip (@cons String.string r ps)
                    (@cons (stack -> val) (stack_get x) (@cons (stack -> val) (apply_subst (stack_get y) (subst1 (pure (T := Fun stack) v) x))
			        (@map (stack -> val) _ (fun e => apply_subst e (subst1 (pure (T := Fun stack) v) x))
			        (@map dexpr (stack -> val) eval es)))))) **
                    apply_subst F (subst1 (pure (T := Fun stack) v) x) |-- Q)
    (HLen: length ps = length (E_var y :: es)) :
           G |-- {[ P ]} cdcall x y m es {[ Q ]}.
Proof.
    eapply rule_dcall_forward.
    eassumption.
    rewrite HPre.
    reflexivity.
    assumption.
    rewrite <- HPost.
    reflexivity.
Qed.