Require Export EnvLibA.
Require Export RelLibA.
Require Export PRelLibA.

Require Export Coq.Program.Equality.
Require Import Coq.Init.Specif.
Require Import Coq.Arith.PeanoNat.
Require Import Omega.
Require Import Coq.Lists.List.

Require Import StaticSemA.
Require Import DynamicSemA.
Require Import TRInductA.
Require Import WeakenA.
Require Import TSoundnessA.
Require Import IdModTypeA.
Require Import IdModPip.
Require Import DetermA.
Require Import AbbrevA.
Require Import HoareA.
Require Import THoareA.
Require Import Lib.
Require Import Pip_state.
Require Import Pip_stateLib.
Require Import Coq.Structures.Equalities.
Require Import Coq.Logic.Eqdep.
Import ListNotations.

Module Hoare_Test_FstShadow <: IdModType.

Module FstShadow := THoare IdModP.
Export FstShadow.

Definition Id := FstShadow.Id.
Definition IdEqDec := FstShadow.IdEqDec.
Definition IdEq := FstShadow.IdEq.
Definition W := FstShadow.W.
Definition Loc_PI := FstShadow.Loc_PI.
Definition BInit := FstShadow.BInit.
Definition WP := FstShadow.WP.

(**************************************************)

(****** Hoare logic *)

Notation "{{ P }} fenv >> env >> e {{ Q }}" := (THoareTriple_Eval P Q fenv env e )
(at level 90) : state_scope.

Open Scope state_scope.

Definition wp (P : Value -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  W -> Prop := fun s => forall (v:Value) (s': W),
EClosure fenv env (Conf Exp s e) (Conf Exp s' (Val v)) -> P v s'.

Lemma wpIsPrecondition (P : Value -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  {{ wp P fenv env e }} fenv >> env >> e {{ P }}.
Proof.
unfold THoareTriple_Eval.
intros ftenv tenv k1 k2 t k3 s s' v H1 H2.
unfold wp in H2.
eapply H2.
auto.
Qed.

Lemma weakenEval (P Q : W -> Prop) (R : Value -> W -> Prop) (fenv: funEnv) (env: valEnv) (e : Exp) :
  {{ Q }} fenv >> env >> e {{ R }} -> (forall s, P s -> Q s) -> {{ P }} fenv >> env >> e {{ R }}.
Proof.
intros.
unfold THoareTriple_Eval in *.
intros.
eapply H;
eauto.
Qed.

Definition wpPrms (P : list Value -> W -> Prop) (fenv: funEnv) (env: valEnv) (ps: Prms):
  W -> Prop := fun s => forall (vs: list Value) (s': W),
PrmsClosure fenv env (Conf Prms s ps) (Conf Prms s' (PS (map Val vs))) -> P vs s'.

Lemma wpIsPreconditionPrms (P : list Value -> W -> Prop) (fenv: funEnv) (env: valEnv) (ps: Prms):
  THoarePrmsTriple_Eval (wpPrms P fenv env ps) P fenv env ps.
Proof.
unfold THoarePrmsTriple_Eval.
intros ftenv tenv k1 k2 t k3 s s' v H1 H2.
unfold wpPrms in H2.
eapply H2.
auto.
Qed.

Lemma weakenPrms (P Q : W -> Prop) (R : list Value -> W -> Prop) (fenv: funEnv) (env: valEnv) (ps: Prms):
  THoarePrmsTriple_Eval Q R fenv env ps ->
 (forall s, P s -> Q s) -> THoarePrmsTriple_Eval P R fenv env ps .
Proof.
intros.
unfold THoarePrmsTriple_Eval in *.
intros.
eapply H;
eauto.
Qed.

(******* Program *)

(** getSh1idx : returns first shadow *)

Definition getSh1idx : Exp := Val (cst index sh1idx). (** Return in the original definition *)

(** ReadPhysical -page -index : reads physical address *)

Definition xf_read (p: page) : XFun (option index) (option page) := {|
   b_mod := fun s oi => (s,match oi with |None => None |Some i => readPhysicalInternal p i (memory s) end)
|}.

Instance VT_index : ValTyp index.
Instance VT_option_index : ValTyp (option index).
Instance VT_option_page : ValTyp (option page).

Definition ReadPhysical (p:page) (x:Id) : Exp :=
  Modify (option index) (option page) VT_option_index VT_option_page (xf_read p) (Var x).

(** Succ -index : calculates the successor of an index *)

Definition xf_succ : XFun index (option index) := {|
   b_mod := fun s (idx:index) =>  (s, succIndexInternal idx)
|}.

Definition Succ (x:Id) : Exp :=
  Modify index (option index) VT_index VT_option_index xf_succ (Var x).

(** getFstShadow -page : returns the adress of the 1st shadow *)

(* Bind Approach *)

Definition getFstShadowBind (p:page) : Exp :=
 BindS "x" getSh1idx
           (BindS "y" (Succ "x")
                      (ReadPhysical p "y")
           ).

(* Apply Approch *)

Definition indexType := vtyp index.
Definition optionIndexType := vtyp (option index).

Definition ReadPhysicalQF (p:page) := QF
(FC emptyE [("x",optionIndexType)] (ReadPhysical p "x") (Val (cst (option page) None)) "ReadPhysical" 0).

Definition SuccQF := QF
(FC emptyE [("y",indexType)] (Succ "y") (Val (cst (option index) None)) "Succ" 0).

Definition getFstShadowApply (p:page) :Exp :=
Apply (ReadPhysicalQF p) (PS [
                         Apply SuccQF (PS [getSh1idx])
                      ]).

(*Bind approach & Deep definition of Successor*)

Instance VT_nat : ValTyp nat.
Instance VT_bool : ValTyp bool.

Definition xf_LtDec (n: nat) : XFun nat bool := {|
   b_mod := fun s i => (s,if lt_dec i n then true else false)
|}.

Definition LtDec (x:Id) (n:nat): Exp :=
  Modify nat bool VT_nat VT_bool (xf_LtDec n) (Var x).

Definition xf_prj1 : XFun index nat := {|
   b_mod := fun s (idx:index) => (s,let (i,_) := idx in i)
|}.

Definition prj1 (x:Id) : Exp :=
  Modify index nat VT_index VT_nat xf_prj1 (Var x).

Definition xf_SomeCindex : XFun nat (option index) := {|
   b_mod := fun s i => (s,Some (CIndex i))
|}.

Definition SomeCindex (x:Id) : Exp :=
  Modify nat (option index) VT_nat VT_option_index  xf_SomeCindex (Var x).

Definition SomeCindexQF := QF
(FC emptyE [("i",Nat)] (SomeCindex "i") (Val (cst (option index) None)) "SomeCindex" 0).

Definition xf_SuccD : XFun nat nat := {|
   b_mod := fun s i => (s,S i)
|}.

Definition SuccR (x:Id) : Exp :=
  Modify nat nat VT_nat VT_nat xf_SuccD (Var x).

Definition SuccD (x:Id) :Exp :=
BindS "i" (prj1 x)
          (IfThenElse (LtDec "i" tableSize)
                      (Apply SomeCindexQF
                             (PS[SuccR "i"])
                      )
                      (Val(cst (option index) None))
          ).

Definition getFstShadowBindDeep (p:page) : Exp :=
 BindS "x" getSh1idx
           (BindS "y" (SuccD "x")
                      (ReadPhysical p "y")
           ).

(*Bind approach & Deep definition of Succ with recursive plus function*)

Definition plusR' (f: Id) (x:Id) : Exp :=
      Apply (FVar f) (PS [VLift (Var x)]).

Definition plusR (n:nat) := QF
(FC emptyE [("i",Nat)] (VLift(Var "i")) (BindS "p" (plusR' "plusR" "i") (SuccR "p")) "plusR" n).

Definition SuccRec (x:Id) :Exp :=
BindS "i" (prj1 x)
          (IfThenElse (LtDec "i" tableSize)
                      (Apply SomeCindexQF
                             (PS[Apply (plusR 1)
                                       (PS[VLift(Var "i")])
                                ])
                      )
                      (Val(cst (option index) None))
          ).

Definition getFstShadowBindDeepRec (p:page) : Exp :=
 BindS "x" getSh1idx
           (BindS "y" (SuccRec "x")
                      (ReadPhysical p "y")
           ).

(******* State properties *)

Definition isVA (p:page) (i:index) (s:W): Prop := match (lookup p i (s.(memory)) beqPage beqIndex) with
             |Some (VA _) => True
             |_ => False
             end.

Definition nextEntryIsPP (p:page) (idx:index) (p':Value) (s:W) : Prop:=
match succIndexInternal idx with
| Some i => match lookup p i (memory s) beqPage beqIndex with
                  | Some (PP table) => p' = cst (option page) (Some table)
                  |_ => False
                  end
| _ => False
end.

Definition partitionDescriptorEntry (s:W) :=
forall (p : page),
  In p (getPartitions multiplexer s) -> forall (idx : index),
    (idx = PDidx \/ idx = sh1idx \/ idx = sh2idx \/ idx = sh3idx \/ idx = PPRidx  \/ idx = PRidx ) ->
    idx < tableSize - 1  /\ isVA p idx  s /\ exists (p1:page) , nextEntryIsPP p idx (cst (option page) (Some p1)) s  /\
    (cst page p1) <> (cst page defaultPage).

(******* Useful Lemmas *)

(** about getSh1idx *)

Lemma getSh1idxW (P: Value -> W -> Prop) (fenv: funEnv) (env: valEnv) :
  {{wp P fenv env getSh1idx}} fenv >> env >> getSh1idx {{P}}.
Proof.
apply wpIsPrecondition.
Qed.

Lemma getSh1idxWp P fenv env :
{{P}} fenv >> env >> getSh1idx
{{fun (idxSh1 : Value) (s : state) => P s  /\ idxSh1 = cst index sh1idx }}.
Proof.
eapply weakenEval.
eapply getSh1idxW.
intros.
unfold wp.
intros.
unfold getSh1idx in X.
inversion X;subst.
auto.
inversion X0.
Qed.

Lemma getSh1idxWp' P fenv env :
HoarePrmsTriple_Eval P
(fun (idxSh1 : list Value) (s : state) => P s  /\ idxSh1 = [cst index sh1idx]) fenv env [getSh1idx].
Proof.
unfold HoarePrmsTriple_Eval.
intros.
inversion X;subst.
intuition.
unfold map in H5.
induction vs.
inversion X;subst.
inversion X0;subst.
inversion X2.
inversion X2.
inversion H5;subst.
simpl in *.
destruct vs.
auto.
inversion H2.
inversion X0;subst.
inversion X2.
inversion X2.
Qed.

(** about Succ *)

Lemma succW  (x : Id) (P: Value -> W -> Prop) (v:Value) (fenv: funEnv) (env: valEnv) :
forall (idx:index), {{fun s => idx < (tableSize -1) /\ forall  l : idx + 1 < tableSize ,
    P (cst (option index) (succIndexInternal idx)) s /\ v = cst index idx }}
fenv >> (x,v)::env >> Succ x {{ P }}.
Proof.
intros.
unfold THoareTriple_Eval.
intros.
intuition.
destruct H1 as [H1 H1'].
omega.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H7;subst.
inversion X2;subst.
inversion X3;subst.
inversion H;subst.
destruct IdModP.IdEqDec in H3.
inversion H3;subst.
clear H3 e X3 H XF1.
inversion X1;subst.
inversion X3;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H9.
subst.
unfold b_exec,b_eval,xf_succ,b_mod in *.
simpl in *.
inversion X4;subst.
apply H1.
inversion X5.
inversion X5.
contradiction.
Qed.

Lemma succWp (x:Id) (v:Value) P (fenv: funEnv) (env: valEnv) :
forall (idx:index), {{fun s => P s  /\ idx < tableSize - 1 /\ v=cst index idx}} fenv >> (x,v)::env >> Succ x
{{fun (idxsuc : Value) (s : state) => P s  /\ idxsuc = cst (option index) (succIndexInternal idx) /\ exists i, idxsuc = cst (option index) (Some i)}}.
Proof.
intros.
eapply weakenEval.
eapply succW.
intros.
simpl.
split.
instantiate (1:=idx).
intuition.
intros.
intuition.
destruct idx.
exists (CIndex (i + 1)).
f_equal.
unfold succIndexInternal.
case_eq (lt_dec i tableSize).
intros.
auto.
intros.
contradiction.
Qed.

Lemma succDW  (x : Id) (P: Value -> W -> Prop) (v:Value) (fenv: funEnv) (env: valEnv) :
forall (idx:index), {{fun s => idx < (tableSize -1) /\ forall  l : idx + 1 < tableSize ,
    P (cst (option index) (succIndexInternal idx)) s /\ v = cst index idx }}
fenv >> (x,v)::env >> SuccD x {{ P }}.
Proof.
intros.
unfold THoareTriple_Eval.
intros.
clear k3 t k2 k1 tenv ftenv.
intuition.
destruct H1 as [H1 H1'].
omega.
inversion X;subst.
inversion X0;subst.
inversion X2;subst.
repeat apply inj_pair2 in H7;subst.
inversion X3;subst.
inversion X4;subst.
inversion H;subst.
destruct IdModP.IdEqDec in H3.
inversion H3;subst.
clear H3 e X4 H XF1.
inversion X1;subst.
inversion X4;subst.
inversion X6;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H9.
subst.
unfold xf_prj1 at 3 in X6.
unfold b_exec,b_eval,b_mod in *.
simpl in *.
destruct idx.
inversion X5;subst.
inversion X7;subst.
inversion X8;subst.
inversion X9;subst.
simpl in *.
inversion X11;subst.
inversion X12;subst.
repeat apply inj_pair2 in H7.
subst.
inversion X13;subst.
inversion X14;subst.
inversion H;subst.
clear H X14 XF2.
inversion X10;subst.
inversion X14;subst.
simpl in *.
inversion X16;subst.
inversion X17;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H10.
subst.
unfold xf_LtDec at 3 in X17.
unfold b_exec,b_eval,b_mod in *.
simpl in *.
case_eq (lt_dec i tableSize).
intros.
rewrite H in X17, H1.
inversion X15;subst.
inversion X18;subst.
simpl in *.
inversion X20; subst.
inversion X19;subst.
inversion X21;subst.
simpl in *.
inversion X23;subst.
inversion H10;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X24;subst.
inversion X25;subst.
repeat apply inj_pair2 in H11.
subst.
inversion X26;subst.
inversion X27;subst.
inversion H2;subst.
clear X27 H2 XF3.
inversion X22;subst.
inversion X27;subst.
simpl in *.
inversion X29;subst.
inversion H10;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X30;subst.
inversion X31;subst.
repeat apply inj_pair2 in H11.
repeat apply inj_pair2 in H13.
subst.
unfold xf_SuccD at 3 in X31.
unfold b_exec,b_eval,xf_SuccD,b_mod in *.
simpl in *.
inversion X28;subst.
inversion X32;subst.
simpl in *.
inversion X34;subst.
inversion H10;subst.
destruct vs.
inversion H2.
inversion H2;subst.
destruct vs.
unfold mkVEnv in *.
simpl in *.
inversion X33;subst.
inversion X35;subst.
inversion X37;subst.
simpl in *.
inversion X38;subst.
repeat apply inj_pair2 in H15.
subst.
inversion X39;subst.
inversion X40;subst.
inversion H3;subst.
clear X40 H3 XF4 H5.
inversion X36;subst.
inversion X40;subst.
inversion X42;subst.
simpl in *.
inversion X43;subst.
repeat apply inj_pair2 in H14.
repeat apply inj_pair2 in H16.
subst.
unfold xf_SomeCindex at 3 in X43.
unfold b_exec,b_eval,b_mod in *.
simpl in *.
inversion X41;subst.
inversion X44;subst.
simpl in *.
inversion X46;subst.
inversion X45;subst.
inversion X47;subst.
inversion X48;subst.
assert (Z : S i = i+1).
omega.
rewrite Z.
auto.
inversion X49.
inversion X49.
inversion X47.
inversion X44.
inversion H5.
inversion X35;subst.
inversion X36.
inversion X36.
inversion X35.
inversion X32.
inversion X30.
inversion X24.
repeat apply inj_pair2 in H6.
rewrite H in H6.
inversion H6.
rewrite H in X21.
inversion X21.
intros.
contradiction.
inversion X18.
inversion X9.
inversion X7.
contradiction.
Qed.

Lemma succDWp (x:Id) (v:Value) P (fenv: funEnv) (env: valEnv) :
forall (idx:index), {{fun s => P s  /\ idx < tableSize - 1 /\ v=cst index idx}} fenv >> (x,v)::env >> SuccD x
{{fun (idxsuc : Value) (s : state) => P s  /\ idxsuc = cst (option index) (succIndexInternal idx) /\ exists i, idxsuc = cst (option index) (Some i)}}.
Proof.
intros.
eapply weakenEval.
eapply succDW.
intros.
simpl.
split.
instantiate (1:=idx).
intuition.
intros.
intuition.
destruct idx.
exists (CIndex (i + 1)).
f_equal.
unfold succIndexInternal.
case_eq (lt_dec i tableSize).
intros.
auto.
intros.
contradiction.
Qed.

Lemma succRecW  (x : Id) (P: Value -> W -> Prop) (v:Value) (fenv: funEnv) (env: valEnv) :
forall (idx:index), {{fun s => idx < (tableSize -1) /\ forall  l : idx + 1 < tableSize ,
    P (cst (option index) (succIndexInternal idx)) s /\ v = cst index idx }}
fenv >> (x,v)::env >> SuccRec x {{ P }}.
Proof.
intros.
destruct idx.
simpl.
unfold SuccRec.
eapply BindS_VHTT1.
(** prj1 *)
unfold THoareTriple_Eval.
intros.
instantiate (1:= fun v0 s => {| i := i; Hi := Hi |} < (tableSize -1) /\ forall  l : {| i := i; Hi := Hi |} + 1 < tableSize ,
    P (cst (option index) (succIndexInternal {| i := i; Hi := Hi |})) s /\ v = cst index {| i := i; Hi := Hi |}
            /\ v0 = cst nat i).
destruct H.
destruct H0.
omega.
subst.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H7.
inversion X2;subst.
inversion X3;subst.
inversion H1;subst.
case_eq (IdModP.IdEqDec x x);intros; try contradiction.
rewrite H2 in H3.
inversion H3;subst.
inversion X1;subst.
inversion X4;subst.
repeat apply inj_pair2 in H10.
repeat apply inj_pair2 in H12.
subst.
unfold b_eval, b_exec, xf_prj1, b_mod in *.
simpl in *.
inversion X5;subst.
intuition.
inversion X6.
inversion X6.
intros; simpl.
eapply IfTheElse_VHTT1.
(** LtDec *)
unfold THoareTriple_Eval.
intros.
instantiate (1:= fun v1 s => {| i := i; Hi := Hi |} < (tableSize -1)
            /\ forall  l : {| i := i; Hi := Hi |} + 1 < tableSize ,
                 P (cst (option index) (succIndexInternal {| i := i; Hi := Hi |})) s
            /\ v = cst index {| i := i; Hi := Hi |}
            /\ v0 = cst nat i
            /\ v1 = cst bool (if lt_dec i tableSize then true else false)).
simpl.
split.
intuition.
intros.
destruct H.
destruct H0.
omega.
destruct H1.
subst.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H7.
subst.
inversion X2;subst.
inversion X3;subst.
inversion H1;subst.
clear X3 H1 XF1 k3 k2 k1 t ftenv tenv.
inversion X1;subst.
inversion X3;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H9.
subst.
unfold b_eval, b_exec, xf_LtDec, b_mod in *.
simpl in *.
inversion X4;subst.
intuition.
inversion X5.
inversion X5.
simpl.
eapply Apply_VHTT1.
eapply Prms_VHTT1.
eapply Apply_VHTT1.
eapply Prms_VHTT1.
(* Var i *)
instantiate (1:= fun v1 s => {| i := i; Hi := Hi |} < (tableSize -1)
            /\ forall  l : {| i := i; Hi := Hi |} + 1 < tableSize ,
                 P (cst (option index) (succIndexInternal {| i := i; Hi := Hi |})) s
            /\ v = cst index {| i := i; Hi := Hi |}
            /\ v0 = cst nat i
            /\ v1 = v0).
unfold THoareTriple_Eval.
intros.
destruct H.
split.
intuition.
intros.
destruct H0.
omega.
destruct H1.
destruct H2.
subst.
inversion X;subst.
inversion X0;subst.
inversion X2;subst.
inversion X3;subst.
inversion H1;subst.
inversion X1;subst.
inversion X4;subst.
inversion X5;subst.
intuition.
inversion X6.
inversion X6.
intros.
simpl.
(** PS *)
unfold THoarePrmsTriple_Eval.
intros.
destruct H.
destruct H0.
omega.
destruct H1.
destruct H2.
subst.
case_eq (lt_dec i tableSize); intros; try contradiction.
rewrite H1 in H0.
clear H1 l.
inversion X;subst.
destruct vs; inversion H6.
inversion X;subst.
instantiate (1:= fun vs s => {| i := i; Hi := Hi |} < (tableSize -1)
            /\ forall  l : {| i := i; Hi := Hi |} + 1 < tableSize ,
                 P (cst (option index) (Some (CIndex (i + 1)))) s
            /\ v = cst index {| i := i; Hi := Hi |}
            /\ v0 = cst nat i
            /\ vs = [cst nat i]).
simpl; intuition.
inversion X0.
inversion X0.
intuition.
unfold mkVEnv;simpl.
destruct vs.
unfold THoareTriple_Eval.
intros.
intuition.
destruct H1.
omega.
intuition.
inversion H4.
eapply BindS_VHTT1.
(** plus R' *)
unfold THoareTriple_Eval.
intros.
intuition.
destruct H1.
omega.
intuition.
inversion H4;subst.
clear H4 k3 k2 k1 t tenv ftenv.
inversion X;subst.
inversion X0;subst.
inversion X2;subst.
inversion X3;subst.
inversion H1;subst.
inversion X1;subst.
inversion X4;subst.
inversion H12;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X6;subst.
inversion X7;subst.
inversion X8;subst.
inversion X9;subst.
inversion H2;subst.
clear H1 H2 X3 X9.
inversion X5;subst.
inversion X3;subst.
inversion H11;subst.
destruct vs.
inversion H1.
inversion H1.
inversion X10;subst.
inversion X11;subst.
inversion X9;subst.
inversion X12;subst.
inversion H11;subst.
destruct vs.
inversion H1.
inversion H1;subst.
destruct vs; inversion H4.
clear H4 H11 H12 H1.
inversion X13;subst.
inversion X14;subst.
unfold mkVEnv in *; simpl in *.
inversion X16;subst.
inversion X17;subst.
inversion X18;subst.
inversion H1;subst.
clear X18 H1.
inversion X5;subst.
inversion X18;subst.
inversion H11;subst.
destruct vs.
inversion H1.
inversion H1.
inversion X20;subst.
inversion X21;subst.
inversion X19;subst.
inversion X22;subst.
inversion H11;subst.
destruct vs.
inversion H1.
inversion H1;subst.
destruct vs; inversion H4.
clear H4 H11 H12 H1.
unfold mkVEnv in *; simpl in *.
inversion X23;subst.
inversion X24;subst.
inversion X26;subst.
inversion X27;subst.
inversion X28;subst.
simpl in *.
inversion H1;subst.
clear H1 X28.
inversion X27;subst.
inversion X25;subst.
inversion X29;subst.
inversion X31;subst.
inversion X30;subst.
inversion X32;subst.
inversion X33;subst.
clear X1 X2 X3 X4 X5 X6 X7 X8 X9 X10
      X11 X12 X13 X14 X15 X16 X17 X18 X19 X20
      X21 X22 X23 X24 X25 X26 X27 X28 X29 X30
      X31 X32 X33.
instantiate (1:= fun v2 s => {| i := i; Hi := Hi |} < (tableSize -1)
            /\ forall  l : {| i := i; Hi := Hi |} + 1 < tableSize ,
                 P (cst (option index) (Some (CIndex (i + 1)))) s
            /\ v = cst index {| i := i; Hi := Hi |}
            /\ v0 = cst nat i
            /\ v1 = cst nat i
            /\ vs = []
            /\ v2 = cst nat i).
simpl;intuition.
inversion X34.
inversion X34.
inversion X32.
inversion X24;subst.
inversion X25.
inversion X25.
inversion X24.
inversion X22.
inversion X20.
inversion X14;subst.
inversion X15.
inversion X15.
inversion X14.
inversion X12.
inversion X10.
inversion X6.
(** SuccR *)
intros;simpl.
unfold THoareTriple_Eval.
intros.
clear k3 k2 k1 t tenv ftenv.
intuition.
destruct H1.
omega.
intuition.
subst.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H7.
subst.
inversion X2;subst.
inversion X3;subst.
inversion H1;subst.
clear X3 H1 XF1.
inversion X1;subst.
inversion X3;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H9.
subst.
unfold b_eval, b_exec, xf_SuccD, b_mod in *.
simpl in *.
inversion X4;subst.
instantiate (1:= fun v3 s => {| i := i; Hi := Hi |} < (tableSize -1)
            /\ forall  l : {| i := i; Hi := Hi |} + 1 < tableSize ,
                 P (cst (option index) (Some (CIndex (i + 1)))) s
            /\ v = cst index {| i := i; Hi := Hi |}
            /\ v3 = cst nat (S i)).
intuition.
inversion X5.
inversion X5.
intros; simpl.
(** PS *)
unfold THoarePrmsTriple_Eval.
intros.
destruct H.
destruct H0.
omega.
destruct H1.
subst.
clear k3 k2 k1 pt tenv ftenv.
inversion X;subst.
destruct vs; inversion H6.
inversion X;subst.
instantiate (1:= fun vs s => {| i := i; Hi := Hi |} < (tableSize -1)
            /\ forall  l : {| i := i; Hi := Hi |} + 1 < tableSize ,
                 P (cst (option index) (Some (CIndex (i + 1)))) s
            /\ v = cst index {| i := i; Hi := Hi |}
            /\ vs = [cst nat (S i)]).
simpl; intuition.
inversion X0.
inversion X0.
intros; intuition.
unfold mkVEnv in *.
simpl in *.
destruct vs.
unfold THoareTriple_Eval.
intros.
intuition.
destruct H1.
omega.
intuition.
inversion H3.
(** SomeCindex *)
unfold THoareTriple_Eval.
intros.
destruct H.
destruct H0.
omega.
destruct H1.
inversion H2;subst.
clear H2 k3 k2 k1 t tenv ftenv.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H7.
subst.
inversion X2;subst.
inversion X3;subst.
inversion H1;subst.
clear X3 H1 XF1.
inversion X1;subst.
inversion X3;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H9.
subst.
unfold b_eval,b_exec,xf_SomeCindex,b_mod in *.
simpl in *.
inversion X4;subst.
assert (Succ_trivial : S i = i + 1) by omega.
rewrite Succ_trivial.
auto.
inversion X5.
inversion X5.
(** impossible case *)
unfold THoareTriple_Eval.
intros.
intuition.
destruct H1.
omega.
intuition.
case_eq (lt_dec i tableSize); intros; try contradiction.
rewrite H3 in H4.
unfold cst in H4.
apply inj_pair2 in H4.
inversion H4.
Qed.

(*Proof without Hoare Lemmas

Lemma succRecWByInversion  (x : Id) (P: Value -> W -> Prop) (v:Value) (fenv: funEnv) (env: valEnv) :
forall (idx:index), {{fun s => idx < (tableSize -1) /\ forall  l : idx + 1 < tableSize ,
    P (cst (option index) (succIndexInternal idx)) s /\ v = cst index idx }}
fenv >> (x,v)::env >> SuccRec x {{ P }}.
Proof.
intros.
unfold THoareTriple_Eval.
intros.
clear k3 t k2 k1 tenv ftenv.
intuition.
destruct H1 as [H1 H1'].
omega.
inversion X;subst.
inversion X0;subst.
inversion X2;subst.
repeat apply inj_pair2 in H7;subst.
inversion X3;subst.
inversion X4;subst.
inversion H;subst.
destruct IdModP.IdEqDec in H3;try contradiction.
inversion H3;subst.
clear H3 e X4 H XF1.
inversion X1;subst.
inversion X4;subst.
inversion X6;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H9.
subst.
unfold b_exec,b_eval,xf_prj1, b_mod in *.
simpl in *.
destruct idx.
inversion X5;subst.
inversion X7;subst.
inversion X8;subst.
inversion X9;subst.
simpl in *.
inversion X11;subst.
inversion X12;subst.
repeat apply inj_pair2 in H7.
subst.
inversion X13;subst.
inversion X14;subst.
inversion H;subst.
clear H X14 XF2.
inversion X10;subst.
inversion X14;subst.
simpl in *.
inversion X16;subst.
inversion X17;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H10.
subst.
unfold b_exec,b_eval,xf_LtDec,b_mod in *.
simpl in *.
case_eq (lt_dec i tableSize);intros; try contradiction.
rewrite H in X17,H1.
inversion X15;subst.
inversion X18;subst.
simpl in *.
inversion X20; subst.
clear H6.
inversion X19;subst.
inversion X21;subst.
simpl in *.
inversion X23;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X24;subst.
inversion X25;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X26;subst.
inversion X27;subst.
inversion X28;subst.
inversion X29;subst.
inversion H2;subst.
clear X29 H2.
inversion X22;subst.
inversion X29;subst.
inversion X31;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
simpl in *.
inversion X32;subst.
inversion X33;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
unfold mkVEnv in *.
simpl in *.
inversion X34;subst.
inversion X35;subst.
inversion X30;subst.
inversion X36;subst.
simpl in *.
inversion X38;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X39;subst.
inversion X40;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2;subst.
destruct vs; inversion H5.
unfold mkVEnv in *.
simpl in *.
clear H5 H7 H17 H2.
inversion X37;subst.
inversion X41;subst.
inversion X43;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X44;subst.
inversion X45;subst.
inversion X46;subst.
simpl in *.
inversion X47;subst.
inversion X48;subst.
inversion X49;subst.
inversion H2;subst.
clear X49 H2.
inversion X42;subst.
inversion X49;subst.
inversion X51;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X52;subst.
inversion X53;subst.
inversion X54;subst.
inversion X55;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
simpl in *.
inversion X56;subst.
inversion X57;subst.
inversion X58;subst.
inversion X59;subst.
inversion H2;subst.
clear X59 H2.
inversion X50;subst.
inversion X59;subst.
inversion X61;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
simpl in *.
inversion X62;subst.
inversion X63;subst.
simpl in *.
inversion X64;subst.
inversion X65;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
simpl in *.
inversion X66;subst.
inversion X67;subst.
inversion X60;subst.
inversion X68;subst.
inversion X70;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
simpl in *.
inversion X71;subst.
inversion X72;subst.
inversion X73;subst.
inversion X74;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2;subst.
destruct vs; inversion H5.
unfold mkVEnv in *.
simpl in *.
clear H5 H7 H16 H2.
inversion X69;subst.
inversion X75;subst.
inversion X77;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X78;subst.
inversion X79;subst.
inversion X80;subst.
inversion X81;subst.
simpl in *.
inversion X60;subst.
inversion X82;subst.
inversion X84;subst.
inversion X85;subst.
simpl in *.
inversion X86;subst.
inversion H2;subst.
clear X86 H2.
inversion X83;subst.
inversion X85;subst.
inversion X88;subst.
inversion H2;subst.
clear X88 H2.
inversion X83;subst.
inversion X88;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X89;subst.
inversion X90;subst.
simpl in *.
inversion X91;subst.
inversion X92;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2;subst.
destruct vs; inversion H5.
unfold mkVEnv in *.
simpl in *.
clear H5 H7 H16 H2.
inversion X86;subst.
inversion X93;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X94;subst.
inversion X95;subst.
simpl in *.
inversion X96;subst.
inversion X97;subst.
simpl in *.
inversion X98;subst.
inversion X99;subst.
inversion X100;subst.
inversion H2;subst.
clear X100 H2.
inversion X87;subst.
inversion X100;subst.
inversion X102;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X103;subst.
inversion X104;subst.
inversion X105;subst.
simpl in *.
clear X1 X2 X3 X4 X5 X6 X7 X8 X9 X10
      X11 X12 X13 X14 X15 X16 X17 X18 X19 X20
      X21 X22 X23 X24 X25 X26 X27 X28 X29 X30
      X31 X32 X33 X34 X35 X36 X36 X38 X39 X40
      X41 X42 X43 X44 X45 X46 X47 X48 X49 X50.
inversion X106;subst.
simpl in *.
inversion X1;subst.
inversion X101;subst.
inversion X2;subst.
inversion X4;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X5;subst.
inversion X6;subst.
inversion X7;subst.
simpl in *.
inversion X8;subst.
inversion X3;subst.
inversion X9;subst.
inversion X11;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X12;subst.
inversion X13;subst.
inversion X14;subst.
simpl in *.
inversion X10;subst.
inversion X15;subst.
inversion X17;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X18;subst.
inversion X19;subst.
simpl in *.
inversion X20;subst.
inversion X21;subst.
repeat apply inj_pair2 in H10.
subst.
inversion X22;subst.
simpl in *.
inversion X23;subst.
inversion H2;subst.
clear X23 H2 XF3.
inversion X16;subst.
inversion X23;subst.
inversion X25;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X26;subst.
inversion X27;subst.
inversion X28;subst.
simpl in *.
inversion X29;subst.
repeat apply inj_pair2 in H10.
repeat apply inj_pair2 in H12.
subst.
unfold b_exec,b_eval,xf_SuccD,b_mod in *.
simpl in *.
inversion X16;subst.
inversion X30;subst.
clear X51 X52 X53 X54 X55 X56 X57 X58 X59 X60
      X61 X62 X63 X64 X65 X66 X67 X68 X69 X70
      X71 X72 X73 X74 X75 X76 X77 X78 X79 X80
      X81 X82 X83 X84 X85 X86 X87 X88 X89 X90
      X91 X92 X93 X94 X95 X96 X97 X98 X99 X100
      X101 X102 X103 X104 X105 X106.
inversion X32;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X33;subst.
inversion X34;subst.
simpl in *.
inversion X35;subst.
inversion X36;subst.
repeat apply inj_pair2 in H10.
repeat apply inj_pair2 in H13.
subst.
unfold b_exec,b_eval,b_mod in *.
simpl in *.
inversion X24;subst.
inversion X38;subst.
inversion X40;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X41;subst.
inversion X42;subst.
inversion X43;subst.
inversion X39;subst.
inversion X44;subst.
inversion X46;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X47;subst.
inversion X48;subst.
inversion X39;subst.
inversion X49;subst.
inversion X51;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2.
inversion X52;subst.
inversion X53;subst.
simpl in *.
clear X1 X2 X3 X4 X5 X6 X7 X8 X9 X10
      X11 X12 X13 X14 X15 X16 X17 X18 X19 X20
      X21 X22 X23 X24 X25 X26 X27 X28 X29 X30.
inversion X50;subst.
inversion X1;subst.
inversion X3;subst.
inversion H7;subst.
destruct vs.
inversion H2.
inversion H2;subst.
destruct vs; inversion H5.
unfold mkVEnv in *.
simpl in *.
clear H5 H7 H18 H2.
inversion X2;subst.
inversion X4;subst.
simpl in *.
inversion X5;subst.
inversion X6;subst.
inversion X9;subst.
repeat apply inj_pair2 in H10.
subst.
inversion X10;subst.
inversion X11;subst.
inversion H2;subst.
clear X11 H2 XF5.
inversion X7;subst.
inversion X11;subst.
inversion X12;subst.
repeat apply inj_pair2 in H10.
repeat apply inj_pair2 in H14.
subst.
unfold b_exec,b_eval,xf_SomeCindex,b_mod in *.
simpl in *.
inversion X8;subst.
inversion X13;subst.
inversion X15;subst.
simpl in *.
inversion X14;subst.
inversion X16;subst.
inversion X17;subst.
assert (Z : S i = i+1).
omega.
rewrite Z.
auto.
inversion X18.
inversion X18.
inversion X16.
inversion X13.
inversion X4;subst.
inversion X5.
inversion X5.
inversion X4.
inversion X54.
inversion X52.
inversion X49.
inversion X47.
inversion X44.
inversion X41.
inversion X38.
inversion X33.
inversion X30.
inversion X26.
inversion X18.
inversion X15.
inversion X12.
inversion X9.
inversion X5.
inversion X2.
inversion X103.
inversion X94.
inversion X93;subst.
inversion X94.
inversion X94.
inversion X93.
inversion X89.
inversion X78.
inversion X75;subst.
inversion X76.
inversion X76.
inversion X75.
inversion X71.
inversion X68.
inversion X66.
inversion X62.
inversion X56.
inversion X52.
inversion X44.
inversion X41;subst.
inversion X42.
inversion X42.
inversion X41.
inversion X39.
inversion X36.
inversion X34.
inversion X32.
inversion X26.
inversion X24.
repeat apply inj_pair2 in H6.
rewrite H in H6; inversion H6.
rewrite H in X21; inversion X21.
inversion X18.
inversion X9.
inversion X7.
Qed.
*)

Lemma succRecWp (x:Id) (v:Value) P (fenv: funEnv) (env: valEnv) :
forall (idx:index), {{fun s => P s  /\ idx < tableSize - 1 /\ v=cst index idx}} fenv >> (x,v)::env >> SuccRec x
{{fun (idxsuc : Value) (s : state) => P s  /\ idxsuc = cst (option index) (succIndexInternal idx) /\ exists i, idxsuc = cst (option index) (Some i)}}.
Proof.
intros.
eapply weakenEval.
eapply succRecW.
intros.
simpl.
split.
instantiate (1:=idx).
intuition.
intros.
intuition.
destruct idx.
exists (CIndex (i + 1)).
f_equal.
unfold succIndexInternal.
case_eq (lt_dec i tableSize).
intros.
auto.
intros.
contradiction.
Qed.

Lemma succW' (P: list Value -> W -> Prop)(fenv: funEnv) (env: valEnv) :
forall (idx:index),
THoarePrmsTriple_Eval (fun s => idx < tableSize -1 /\ forall  l : idx + 1 < tableSize ,
    P ([cst (option index) (succIndexInternal idx)]) s ) P
fenv env (PS [Apply SuccQF (PS [Val (cst index idx)])]).
Proof.
intros.
unfold THoarePrmsTriple_Eval.
intros.
clear k3 pt k2 k1 ftenv tenv.
intuition.
inversion X;subst.
destruct vs.
inversion H6.
inversion H6.
inversion X0;subst.
inversion X2;subst.
simpl in *.
inversion H6;subst.
destruct vs0.
inversion H.
inversion H.
induction vs0.
simpl in *.
subst.
clear H13 H H4 H6.
unfold mkVEnv in *.
simpl in *.
inversion X1; subst.
destruct vs.
inversion H6.
inversion H6.
inversion X3; subst.
inversion X5; subst.
simpl in *.
inversion X6; subst.
repeat apply inj_pair2 in H7.
subst.
inversion X7; subst.
inversion X8; subst.
inversion H; subst.
clear X8 H XF1.
inversion X6; subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H11.
subst.
inversion X4; subst.
induction vs.
inversion H6.
inversion H6.
inversion X9; subst.
inversion X11; subst.
simpl in *.
inversion X12; subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H9.
subst.
unfold xf_succ at 2 3 in X12.
unfold b_exec, b_eval, b_mod in X12.
simpl in *.
inversion X10; subst.
destruct vs.
inversion H6.
inversion H6.
inversion X13; subst.
unfold xf_succ, b_exec, b_eval, b_mod in X15.
simpl in *.
inversion X15; subst.
inversion X14; subst.
destruct vs.
inversion H6.
inversion H6;subst.
destruct vs.
apply H1.
omega.
inversion H3.
inversion X16; subst.
inversion X18.
inversion X18.
inversion X16.
inversion X13.
inversion H4.
inversion X3;subst.
inversion X4.
inversion X4.
inversion X3.
Qed.

Lemma succWp' partition P fenv env :
forall vs (idx:index), THoarePrmsTriple_Eval
  (fun (s:W) => P s  /\ partitionDescriptorEntry s /\
                          In partition (getPartitions multiplexer s) /\
      idx < tableSize - 1 /\ vs=[cst index idx])
  (fun vs s =>  P s /\ partitionDescriptorEntry s /\
                          In partition (getPartitions multiplexer s) /\
   (exists i : index, succIndexInternal idx = Some i /\ vs = [cst (option index) (Some i)]))
  fenv env (PS [Apply SuccQF (PS [Val (cst index idx)])]).
Proof.
intros.
eapply weakenPrms.
eapply succW'.
intros.
simpl.
intuition.
exists (CIndex (idx + 1)).
intuition.
unfold succIndexInternal.
destruct idx.
case_eq (lt_dec i tableSize).
intros.
auto.
intros.
contradiction.
f_equal.
f_equal.
unfold succIndexInternal.
destruct idx.
case_eq (lt_dec i tableSize).
intros.
auto.
intros.
contradiction.
Qed.

(******* about readPhysical *)

Lemma readPhysicalW (y:Id) table (v:Value) (P' : Value -> W -> Prop) (fenv: funEnv) (env: valEnv) :
 {{fun s =>  exists idxsucc p1, v = cst (option index) (Some idxsucc)
              /\ readPhysicalInternal table idxsucc (memory s) = Some p1
              /\ P' (cst (option page) (Some p1)) s}}
fenv >> (y,v)::env >> ReadPhysical table y {{P'}}.
Proof.
intros.
unfold THoareTriple_Eval.
intros.
intuition.
destruct H.
destruct H.
intuition.
inversion H0;subst.
clear k3 t k2 k1 ftenv tenv H1.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H7.
subst.
inversion X2;subst.
inversion X3;subst.
inversion H0;subst.
destruct IdEqDec in H3.
inversion H3;subst.
clear H3 e X3 H0 XF1.
inversion X0;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H11.
subst.
inversion X1;subst.
inversion X4;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
subst.
unfold xf_read at 2 in X4.
unfold b_eval,b_exec,b_mod in X4.
simpl in *.
rewrite H in X4.
unfold xf_read,b_eval,b_exec,b_mod in X5.
simpl in *.
rewrite H in X5.
inversion X5;subst.
auto.
inversion X6.
inversion X6.
contradiction.
Qed.

Lemma readPhysicalW' (y:Id) table (vs: list Value) (P' : Value -> W -> Prop) (fenv: funEnv) :
 {{fun s =>  exists idxsucc p1, vs = [cst (option index) (Some idxsucc)]
              /\ readPhysicalInternal table idxsucc (memory s) = Some p1
              /\ P' (cst (option page) (Some p1)) s}}
fenv >> (mkVEnv [(y, optionIndexType)] vs) >> ReadPhysical table y {{P'}}.
Proof.
intros.
unfold THoareTriple_Eval.
intros.
intuition.
destruct H.
destruct H.
intuition.
inversion H0;subst.
unfold mkVEnv in *.
simpl in *.
clear k3 t k2 k1 ftenv tenv H1.
inversion X;subst.
inversion X0;subst.
repeat apply inj_pair2 in H7.
subst.
inversion X2;subst.
inversion X3;subst.
inversion H0;subst.
destruct IdEqDec in H3.
inversion H3;subst.
clear H3 e X3 H0 XF1.
inversion X0;subst.
repeat apply inj_pair2 in H7.
repeat apply inj_pair2 in H11.
subst.
inversion X1;subst.
inversion X4;subst.
repeat apply inj_pair2 in H7.
apply inj_pair2 in H9.
subst.
unfold xf_read at 2 in X4.
unfold b_eval,b_exec,b_mod in X4.
simpl in *.
rewrite H in X4.
unfold xf_read,b_eval,b_exec,b_mod in X5.
simpl in *.
rewrite H in X5.
inversion X5;subst.
auto.
inversion X6.
inversion X6.
contradiction.
Qed.

(******* Hoare Triple *)

(* For Bind Approach *)

Lemma getFstShadowBindH (partition : page) (P : W -> Prop) (fenv: funEnv) (env: valEnv) :
{{fun s => P s  /\ partitionDescriptorEntry s /\ In partition (getPartitions multiplexer s)}}
fenv >> env >> (getFstShadowBind partition)
{{fun sh1 s => P s /\ nextEntryIsPP partition sh1idx sh1 s}}.
Proof.
unfold getFstShadowBind.
eapply BindS_VHTT1.
eapply getSh1idxWp.
simpl; intros.
eapply BindS_VHTT1.
eapply weakenEval.
eapply succWp. simpl.
simpl; intros; intuition.
instantiate (1:=(fun s => P s /\ partitionDescriptorEntry s /\
                          In partition (getPartitions multiplexer s))).
simpl. intuition.
instantiate (1:=sh1idx).
eapply H0 in H3.
specialize H3 with sh1idx.
eapply H3.
auto. auto.
simpl; intros.
eapply weakenEval.
eapply readPhysicalW.
simpl;intros.
intuition.
destruct H3.
exists x.
unfold partitionDescriptorEntry in H1.
apply H1 with partition sh1idx in H4.
clear H1.
intuition.
destruct H5.
exists x0.
intuition.
unfold nextEntryIsPP in H4.
unfold readPhysicalInternal.
subst.
inversion H2.
repeat apply inj_pair2 in H3.
unfold nextEntryIsPP in H5.
rewrite H3 in H5.
destruct (lookup partition x (memory s) beqPage beqIndex).
unfold cst in H5.
destruct v0;try contradiction.
apply inj_pairT2 in H5.
inversion H5.
auto.
unfold isVA in H4.
destruct (lookup partition sh1idx (memory s) beqPage beqIndex) in H2;try contradiction.
auto.
Qed.

(* For Bind Approach with Deep successor function *)

Lemma getFstShadowBindDeepH (partition : page) (P : W -> Prop) (fenv: funEnv) (env: valEnv) :
{{fun s => P s  /\ partitionDescriptorEntry s /\ In partition (getPartitions multiplexer s)}}
fenv >> env >> (getFstShadowBindDeep partition)
{{fun sh1 s => P s /\ nextEntryIsPP partition sh1idx sh1 s}}.
Proof.
unfold getFstShadowBindDeep.
eapply BindS_VHTT1.
eapply getSh1idxWp.
simpl; intros.
eapply BindS_VHTT1.
eapply weakenEval.
eapply succDWp. simpl.
simpl; intros; intuition.
instantiate (1:=(fun s => P s /\ partitionDescriptorEntry s /\
                          In partition (getPartitions multiplexer s))).
simpl. intuition.
instantiate (1:=sh1idx).
eapply H0 in H3.
specialize H3 with sh1idx.
eapply H3.
auto. auto.
simpl; intros.
eapply weakenEval.
eapply readPhysicalW.
simpl;intros.
intuition.
destruct H3.
exists x.
unfold partitionDescriptorEntry in H1.
apply H1 with partition sh1idx in H4.
clear H1.
intuition.
destruct H5.
exists x0.
intuition.
unfold nextEntryIsPP in H4.
unfold readPhysicalInternal.
subst.
inversion H2.
repeat apply inj_pair2 in H3.
unfold nextEntryIsPP in H5.
rewrite H3 in H5.
destruct (lookup partition x (memory s) beqPage beqIndex).
unfold cst in H5.
destruct v0;try contradiction.
apply inj_pairT2 in H5.
inversion H5.
auto.
unfold isVA in H4.
destruct (lookup partition sh1idx (memory s) beqPage beqIndex) in H2;try contradiction.
auto.
Qed.

(*Bind approach & Deep definition of Succ with recursive plus function*)

Lemma getFstShadowBindDeepRecH (partition : page) (P : W -> Prop) (fenv: funEnv) (env: valEnv) :
{{fun s => P s  /\ partitionDescriptorEntry s /\ In partition (getPartitions multiplexer s)}}
fenv >> env >> (getFstShadowBindDeepRec partition)
{{fun sh1 s => P s /\ nextEntryIsPP partition sh1idx sh1 s}}.
Proof.
unfold getFstShadowBindDeep.
eapply BindS_VHTT1.
eapply getSh1idxWp.
simpl; intros.
eapply BindS_VHTT1.
eapply weakenEval.
eapply succRecWp. simpl.
simpl; intros; intuition.
instantiate (1:=(fun s => P s /\ partitionDescriptorEntry s /\
                          In partition (getPartitions multiplexer s))).
simpl. intuition.
instantiate (1:=sh1idx).
eapply H0 in H3.
specialize H3 with sh1idx.
eapply H3.
auto. auto.
simpl; intros.
eapply weakenEval.
eapply readPhysicalW.
simpl;intros.
intuition.
destruct H3.
exists x.
unfold partitionDescriptorEntry in H1.
apply H1 with partition sh1idx in H4.
clear H1.
intuition.
destruct H5.
exists x0.
intuition.
unfold nextEntryIsPP in H4.
unfold readPhysicalInternal.
subst.
inversion H2.
repeat apply inj_pair2 in H3.
unfold nextEntryIsPP in H5.
rewrite H3 in H5.
destruct (lookup partition x (memory s) beqPage beqIndex).
unfold cst in H5.
destruct v0;try contradiction.
apply inj_pairT2 in H5.
inversion H5.
auto.
unfold isVA in H4.
destruct (lookup partition sh1idx (memory s) beqPage beqIndex) in H2;try contradiction.
auto.
Qed.

(* For Apply Approach *)

Lemma getFstShadowApplyH (partition : page) (P : W -> Prop) (fenv: funEnv) (env: valEnv) :
{{fun s => P s  /\ partitionDescriptorEntry s /\ In partition (getPartitions multiplexer s)}}
fenv >> env >> (getFstShadowApply partition)
{{fun sh1 s => P s /\ nextEntryIsPP partition sh1idx sh1 s}}.
Proof.
unfold getFstShadowApply.
eapply Apply_VHTT1.
eapply weakenPrms.
unfold getSh1idx.
eapply succWp'.
simpl; intros.
intuition.
instantiate (1:=P).
auto.
eauto.
eapply H in H2.
specialize H2 with sh1idx.
eapply H2.
auto.
intuition.
eapply weakenEval.
eapply readPhysicalW'.
simpl; intros.
intuition.
destruct H3.
exists x.
unfold partitionDescriptorEntry in H.
apply H with partition sh1idx in H1.
clear H.
intuition.
destruct H5.
exists x0.
intuition.
unfold nextEntryIsPP in H5.
unfold readPhysicalInternal.
rewrite H1 in H5.
destruct (lookup partition x (memory s) beqPage beqIndex).
unfold cst in H5.
destruct v;try contradiction.
apply inj_pairT2 in H5.
inversion H5.
auto.
unfold isVA in H2.
destruct (lookup partition sh1idx (memory s) beqPage beqIndex) in H2;try contradiction.
auto.
Qed.

Lemma getFstShadowApplyH' (partition : page) (P : W -> Prop) (fenv: funEnv) (env: valEnv) :
{{fun s => P s  /\ partitionDescriptorEntry s /\ In partition (getPartitions multiplexer s)}}
fenv >> env >> (getFstShadowApply partition)
{{fun sh1 s => P s /\ nextEntryIsPP partition sh1idx sh1 s}}.
Proof.
unfold getFstShadowApply.
eapply Apply_VHTT1.
eapply Prms_VHTT1.
eapply Apply_VHTT1.
eapply Prms_VHTT1.
eapply getSh1idxWp.
intros; unfold THoarePrmsTriple_Eval; intros;simpl.
inversion X;subst.
destruct vs; inversion H5.
instantiate (1:= fun vs s => P s /\ partitionDescriptorEntry s /\
     In partition (getPartitions multiplexer s) /\ vs = [cst index sh1idx]).
intuition. f_equal. auto.
inversion X0.
intuition.
destruct vs.
unfold THoareTriple_Eval; intros.
intuition. inversion H3.
destruct vs.
Focus 2.
unfold THoareTriple_Eval; intros.
intuition. inversion H3.
unfold mkVEnv. simpl.
eapply weakenEval.
eapply succWp.
simpl; intros.
instantiate (1:= sh1idx).
instantiate (1:= fun s => P s /\
    partitionDescriptorEntry s /\
    In partition (getPartitions multiplexer s)).
simpl. intuition.
eapply H in H1.
specialize H1 with sh1idx.
eapply H1.
auto.
inversion H3; intuition.
intros; simpl.
unfold THoarePrmsTriple_Eval; intros.
inversion X; subst.
destruct vs; inversion H5.
instantiate (1:= fun vs s => P s /\ partitionDescriptorEntry s /\
     In partition (getPartitions multiplexer s)
     /\ (exists i : index,
     succIndexInternal sh1idx = Some i /\ vs = [cst (option index) (Some i)])
    ).
intuition.
destruct H3.
exists x.
intuition.
rewrite H0 in H2.
inversion H2; subst.
repeat apply inj_pair2 in H6.
auto.
f_equal.
auto.
inversion X0.
intuition.
destruct vs.
unfold THoareTriple_Eval; intros.
destruct H as [a [b [c d]]].
destruct d. destruct H.
inversion H0.
destruct vs.
Focus 2.
unfold THoareTriple_Eval; intros.
destruct H as [a [b [c d]]].
destruct d. destruct H.
inversion H0.
unfold mkVEnv; simpl.
eapply weakenEval.
eapply readPhysicalW.
simpl; intros.
intuition.
destruct H3.
exists x.
unfold partitionDescriptorEntry in H.
apply H with partition sh1idx in H1.
clear H.
intuition.
destruct H5.
exists x0.
intuition.
inversion H4;subst. auto.
unfold nextEntryIsPP in H5.
unfold readPhysicalInternal.
rewrite H1 in H5.
destruct (lookup partition x (memory s) beqPage beqIndex).
destruct v0;try contradiction.
unfold cst in H5.
apply inj_pairT2 in H5.
inversion H5.
auto.
unfold isVA in H2.
destruct (lookup partition sh1idx (memory s) beqPage beqIndex) in H2;try contradiction.
auto.
Qed.

End Hoare_Test_FstShadow.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.

(******************************************************************************)
(* Reducibility of configurations number 546 to 549, whose indices in         *)
(* the_configs range over segment [545, 549).                                 *)
(******************************************************************************)

Lemma red545to549 : reducible_in_range 545 549 the_configs.
Proof. CheckReducible. Qed.


(** Typing rules for standard PTS.*)
Require Import PTS_term.
Require Import PTS_red.
Require Import PTS_env.
Require Import PTS_base.
Require Import List.
Require Import Peano_dec.
Require Import Compare_dec.
Require Import Lt Le Gt Plus Minus.

Module ut_typ_mod (X:term_sig) (Y:pts_sig X) (TM: ut_term_mod X) (EM: ut_env_mod X TM) (RM: ut_red_mod X TM).
  Import X Y TM EM RM.

(** Typing judgements:*)
Reserved Notation "Γ ⊢ t : T" (at level 80, t, T at level 30, no associativity) .
Reserved Notation "Γ ⊣ " (at level 80, no associativity).

Inductive wf : Env -> Prop :=
 | wf_nil  : nil ⊣
 | wf_cons : forall Γ A s, Γ ⊢ A : !s -> A::Γ ⊣
where "Γ ⊣" := (wf Γ) : UT_scope
with typ : Env -> Term -> Term -> Prop :=
 | cSort : forall Γ s t, Ax s t -> Γ ⊣ -> Γ  ⊢ !s : !t
 | cVar  : forall Γ A v, Γ ⊣ -> A ↓ v  ⊂ Γ -> Γ ⊢ #v : A
 | cPi   : forall Γ A B s t u, Rel s t u -> Γ ⊢ A : !s -> A::Γ ⊢ B : !t ->
   Γ ⊢  Π(A), B : !u
 | cLa   : forall Γ A B M s1 s2 s3, Rel s1 s2 s3 -> Γ ⊢ A : !s1 ->
   A::Γ ⊢ B : !s2 -> A::Γ ⊢ M : B -> Γ ⊢ λ[A], M : Π(A), B
 | cApp  : forall Γ M N A B , Γ ⊢ M : Π(A), B -> Γ ⊢ N : A -> Γ ⊢ M · N : B[←N]
 | Cnv   : forall Γ M A B s, A ≡ B  -> Γ ⊢ M : A -> Γ ⊢ B : !s -> Γ ⊢ M : B
where "Γ ⊢ t : T" := (typ Γ t T) : UT_scope.

Hint Constructors wf typ.

Open Scope UT_scope.

(* begin hide *)
Scheme typ_ind' := Induction for typ Sort Prop
      with wf_ind' := Induction for wf Sort Prop.

Combined Scheme typ_induc from typ_ind', wf_ind'.
(* end hide *)

(** Basic properties of PTS.
  Context Validity: if a judgment is valid, its context is well-formed.*)
Lemma wf_typ : forall Γ t T, Γ ⊢ t : T -> Γ ⊣.
induction 1; eauto.
Qed.

Hint Resolve wf_typ.

(** Inversion Lemmas , one for each kind of term
  from a typing derivation of some particular term, we can
infer informations about its type and subterms.*)

Lemma gen_sort : forall Γ s T, Γ ⊢ !s : T -> exists t, T ≡ !t /\ Ax s t.
intros. remember !s as S. revert s HeqS. induction H; intros; subst; try discriminate.
injection HeqS; intros; subst; clear HeqS. exists t; intuition.
destruct (IHtyp1 s0) as (t & ? & ?); trivial. exists t; split.
eauto. trivial.
Qed.

Lemma gen_var : forall Γ x A, Γ ⊢ #x : A -> exists A', A ≡ A' /\ A' ↓ x ⊂ Γ .
intros. remember #x as X. revert x HeqX. induction H; intros; subst; try discriminate.
injection HeqX; intros; subst; clear HeqX.
exists A; intuition.
destruct (IHtyp1 x) as (A' & ? & ?); trivial. exists A'; split. eauto. trivial.
Qed.

Lemma gen_pi : forall Γ A B T, Γ ⊢ Π(A),B : T -> exists s1, exists s2, exists s3,
    T ≡ !s3 /\ Rel s1 s2 s3 /\ Γ ⊢ A : !s1  /\ A::Γ ⊢ B : !s2 .
intros. remember (Π(A),B) as P. revert A B HeqP. induction H; intros; subst; try discriminate.
clear IHtyp1 IHtyp2. injection HeqP; intros; subst; clear HeqP.
exists s; exists t; exists u; intuition.
destruct (IHtyp1 A0 B0) as (a & b & c & ? & ? & ? &  ?); trivial. exists a; exists b; exists c; split.
eauto. intuition.
Qed.

Lemma gen_la : forall Γ A M T, Γ ⊢ λ[A],M : T -> exists s1, exists s2, exists s3, exists B,
    T ≡ Π(A), B /\ Rel s1 s2 s3 /\ Γ ⊢ A : !s1 /\ A::Γ ⊢ M : B /\ A::Γ ⊢ B : !s2.
intros. remember (λ[A],M) as L. revert A M HeqL. induction H; intros ; subst; try discriminate.
clear IHtyp1 IHtyp2 IHtyp3. injection HeqL; intros; subst; clear HeqL.
exists s1; exists s2; exists s3; exists B; intuition.
destruct (IHtyp1 A0 M0) as (a & b & c & D &? &? & ? & ? & ?); trivial.
exists a; exists b; exists c; exists D; split. eauto. intuition.
Qed.

Lemma gen_app : forall Γ M N T, Γ ⊢ M · N : T -> exists A, exists B, T ≡ B[← N] /\ Γ ⊢ M : Π(A),B /\ Γ ⊢ N : A.
intros. remember (M·N) as A. revert M N HeqA. induction H; intros; subst; try discriminate.
clear IHtyp1 IHtyp2. injection HeqA; intros; subst; clear HeqA.
exists A; exists B; intuition.
destruct (IHtyp1 M0 N) as (K & L & ? & ?& ?); trivial. exists K; exists L; split.
eauto. intuition.
Qed.

(** Weakening Property: if a judgement is valid, we can insert a well-typed term
  in the context, it will remain valid. This is where the type checking for
  inserting items in a context is done.*)
Theorem weakening: (forall Δ M T, Δ ⊢ M : T -> forall Γ A s n Δ', ins_in_env Γ A n Δ Δ' ->   Γ ⊢ A : !s ->
                 Δ' ⊢ M ↑ 1 # n : T ↑ 1 # n ) /\
(forall Γ, Γ ⊣ -> forall Δ Γ' n A , ins_in_env Δ A n Γ Γ' -> forall s, Δ ⊢ A : !s -> Γ' ⊣).
apply typ_induc; simpl in *; intros.
(*1*)
eauto.
(*2*)
destruct (le_gt_dec n v).
constructor. eapply H; eauto. destruct i as (AA & ?& ?). exists AA; split. rewrite H2.
change (S (S v)) with (1+ S v). rewrite liftP3; simpl; intuition. eapply ins_item_ge. apply H0. trivial. trivial.
constructor. eapply H; eauto.  eapply ins_item_lift_lt. apply H0. trivial. trivial.
(*3*)
econstructor. apply r. eauto. eapply H0. constructor; apply H1. apply H2.
(*4*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
(*5*)
change n with (0+n). rewrite substP1. simpl.
econstructor. eapply H; eauto. eapply H0; eauto.
(*6*)
apply Cnv with (A↑ 1 # n) s; intuition.
eapply H; eauto. eapply H0; eauto.
(* wf *)
inversion H; subst; clear H.
apply wf_cons with s; trivial.
(**)
inversion  H0; subst; clear H0.
apply wf_cons with s0; trivial.
apply wf_cons with s; trivial. change !s with !s ↑ 1 # n0.
eapply H.  apply H6. apply H1.
Qed.

Theorem thinning :
   forall Γ M T A s,
      Γ ⊢ M : T ->
   Γ ⊢ A : !s ->
   A::Γ ⊢ M ↑ 1 : T ↑ 1.
intros.
destruct weakening.
eapply H1. apply H. constructor. apply H0.
Qed.

Theorem thinning_n : forall n Δ Δ',
   trunc n Δ Δ' ->
   forall M T , Δ' ⊢ M : T  -> Δ ⊣ ->
               Δ ⊢ M ↑ n : T ↑ n.
intro n; induction n; intros.
inversion H; subst; clear H.
rewrite 2! lift0; trivial.
inversion H; subst; clear H.
change (S n) with (1+n).
replace (M ↑ (1+n)) with ((M ↑ n )↑ 1) by (apply lift_lift).
replace (T ↑ (1+n)) with ((T ↑ n) ↑ 1) by (apply lift_lift).
inversion H1; subst; clear H1.
apply thinning with s; trivial.
eapply IHn. apply H3. trivial. eauto.
Qed.

(** Substitution Property: if a judgment is valid and we replace a variable by a
  well-typed term of the same type, it will remain valid.*)
(* begin hide *)
Lemma sub_trunc : forall Δ a A n Γ Γ', sub_in_env Δ a A n Γ Γ' -> trunc n Γ' Δ.
induction 1.
apply trunc_O.
apply trunc_S. trivial.
Qed.
(* end hide *)

Theorem substitution : (forall Γ M T , Γ  ⊢ M : T  -> forall Δ P A, Δ  ⊢ P : A ->
 forall Γ' n , sub_in_env Δ P A n Γ Γ' -> Γ ⊣  -> Γ' ⊢ M [ n ←P ]  : T [ n ←P ] ) /\
                       (forall Γ ,  Γ ⊣ -> forall Δ P A n Γ' , Δ ⊢ P : A ->
  sub_in_env  Δ P A n Γ Γ' ->  Γ' ⊣).
apply typ_induc; simpl; intros.
(*1*)
eauto.
(*2*)
destruct lt_eq_lt_dec as [ [] | ].
constructor. eapply H; eauto. eapply nth_sub_item_inf. apply H1. intuition. trivial.
destruct i as (AA & ?& ?). subst. rewrite substP3; intuition.
rewrite <- (nth_sub_eq H1 H4). eapply thinning_n. eapply sub_trunc. apply H1. trivial.
eapply H; eauto. constructor. eapply H; eauto. destruct i as (AA & ? &?). subst.
rewrite substP3; intuition. exists AA; split. replace (S (v-1)) with v. trivial.
rewrite minus_Sn_m. intuition. destruct v. apply lt_n_O in l; elim l. intuition.
eapply nth_sub_sup. apply H1. destruct v. apply lt_n_O in l; elim l. simpl. rewrite <- minus_n_O.
intuition. rewrite <- pred_of_minus. rewrite <- (S_pred v n l). trivial.
(*4*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto.
(*5*)
econstructor. apply r. eapply H; eauto. eapply H0; eauto. eapply H1; eauto.
(*6*)
rewrite subst_travers. econstructor.
replace (n+1) with (S n) by (rewrite plus_comm; trivial). eapply H; eauto.
replace (n+1) with (S n) by (rewrite plus_comm; trivial). eapply H0; eauto.
(*7*)
econstructor.  apply Betac_subst2. apply b. eapply H; eauto. eapply H0; eauto.
(* wf *)
inversion H0.
inversion H1; subst; clear H1. eauto.
econstructor. eapply H. apply H0. trivial. eauto.
Qed.

(** Well-formation of contexts: if a context is valid, every term inside
  is well-typed by a sort.*)
Lemma wf_item : forall Γ A n, A ↓ n ∈ Γ ->
   forall  Γ', Γ ⊣ ->  trunc (S n) Γ Γ' -> exists s, Γ' ⊢ A : !s.
induction 1; intros.
inversion H0; subst; clear H0.
inversion H5; subst; clear H5.
inversion H; subst.
exists s; trivial.
inversion H1; subst; clear H1.
inversion H0; subst.
apply IHitem; trivial. eauto.
Qed.

Lemma wf_item_lift : forall Γ A n ,Γ ⊣  -> A ↓ n ⊂ Γ ->
  exists s,  Γ ⊢ A  : !s.
intros.
destruct H0 as (u & ? & ?).
subst.
assert (exists Γ' , trunc (S n) Γ Γ') by (apply item_trunc with u; trivial).
destruct H0 as (Γ' & ?).
destruct (wf_item Γ u n H1 Γ' H H0) as (t &  ?).
exists t. change !t with (!t ↑(S n)).
eapply thinning_n. apply H0. trivial. trivial.
Qed.

(** Type Correction: if a judgment is valid, the type is either welltyped
  itself, or syntacticaly a sort. This distinction comes from the fact
  that we abstracted the typing of sorts with [Ax] and that they may be some
  untyped sorts (also called top-sorts).*)
Theorem TypeCorrect : forall Γ M T, Γ ⊢ M : T  ->
 (exists s, T = !s) \/ (exists s, Γ ⊢ T : !s).
intros; induction H.
(*1*)
left; exists t; reflexivity.
(*2*)
apply wf_item_lift in H0. right; trivial. trivial.
(*4*)
left; exists u; trivial.
(*5*)
right; exists s3; apply cPi with s1 s2; trivial.
(*6*)
destruct IHtyp1. destruct H1; discriminate. destruct H1 as (u & ?).
apply gen_pi in H1 as (s1 & s2 & s3 & h); decompose [and] h; clear h.
right; exists s2.
change (!s2) with (!s2 [← N]). eapply substitution. apply H5. apply H0. constructor.
eauto.
(*8*)
right; exists s; trivial.
Qed.

End ut_typ_mod.


(* begin hide *)
From Coq Require Import
     RelationClasses
     Morphisms.

From Vellvm Require Import Utils.NoEvent.

From Paco Require Import paco.

From ITree Require Import
     ITree
     ITreeFacts
     Eq.Eqit.

Set Implicit Arguments.
Set Strict Implicit.

Import MonadNotation.
Open Scope monad_scope.

(* end hide *)

(** * Commutation of computations described as [itree]s
  This file develops some theory to justify when two computations described as
  interaction trees can be commuted, i.e. looks for sufficient condition under
  which we have: [t1 ;; t2 ≈ t2 ;; t1].

  We prove the obvious result that it always hold for computations that have no
  effects (E == void1) and computes no meaningful value (R == unit): [trivial_commut].
  While it is not surprising, it is not a completely trivial fact as it must
  account for divergence of either of the computation.

  We also establish more interesting results for computations involving a state.
  These lemmas are currently used in Helix in order to justify that the order of
  iteration of bounded loops over appropriate bodies can be reversed.

*)

Lemma itree_eta_cont : forall {E A B} (t : itree E A) (k : A -> itree E B),
    x <- t;; k x ≅ x <- t;; (fun y => {| _observe := observe (k y) |}) x.
Proof.
  intros.
  eapply eq_itree_clo_bind; [reflexivity | intros ? ? <-].
  rewrite itree_eta at 1; reflexivity.
Qed.

Lemma trivial_commut_gen : forall (t1 t2 t3 t4 : unit -> itree void1 unit),
    (forall x, t1 x ≈ t4 x) ->
    (forall x, t2 x ≈ t3 x) ->
    x <- t1 tt;; t2 x ≈ x <- t3 tt;; t4 x.
Proof.
  cbn.
  einit; ecofix CIH.
  intros * EQ1 EQ2.
  setoid_rewrite (itree_eta (t1 tt)) at 1.
  destruct (observe (t1 tt)) eqn:EQ.
  - rewrite bind_ret_l.
    rewrite <- bind_ret_r at 1.
    ebind; econstructor.
    destruct r; apply EQ2.
    intros [] [] _.
    efinal.
    rewrite <- (EQ1 tt).
    rewrite (itree_eta (t1 tt)), EQ.
    destruct r; reflexivity.
  - rewrite (itree_eta (t3 tt)).
    destruct (observe (t3 tt)) eqn:EQ'.
    + destruct r.
      rewrite bind_ret_l.
      rewrite <- (bind_ret_r (t4 tt)).
      ebind; econstructor.
      rewrite <- EQ1.
      rewrite (itree_eta (t1 tt)), EQ; reflexivity.
      intros [] [] _.
      edrop.
      rewrite EQ2, itree_eta, EQ'.
      reflexivity.
    + rewrite !bind_tau.
      estep.
      ebase; right.
      specialize (CIH (fun _ => t) t2 (fun _ => t0) t4).
      apply CIH.
      intros [].
      rewrite <- EQ1.
      rewrite (itree_eta (t1 tt)), EQ.
      rewrite tau_eutt; reflexivity.
      intros [].
      rewrite EQ2.
      rewrite (itree_eta (t3 tt)), EQ'.
      rewrite tau_eutt; reflexivity.
    + inv e.
  - inv e.
Qed.

Lemma trivial_commut : forall (t t' : unit -> itree void1 unit),
    x <- t tt;; t' x ≈ x <- t' tt;; t x.
Proof.
  intros; apply trivial_commut_gen; intros; reflexivity.
Qed.

From Vellvm Require Import
     Utils.PostConditions.

Require Import Coq.Logic.FunctionalExtensionality.

Lemma eutt_post_bind_het :
  forall (E : Type -> Type) (A : Type) (QQ : A -> A -> Prop) (Q1 Q2 : A -> Prop)
    (t1 t2 : A -> itree E A) (k1 : A -> itree E A) (k2 : A -> itree E A) (a0 : A),
    t1 a0 ⤳ Q1 ->
    t2 a0 ⤳ Q2 ->
    (forall u1 u2, eutt (fun x y => Q1 x /\ Q2 y) (t1 u1) (t2 u2)) ->
    (forall u1 u2 : A, Q1 u1 -> Q2 u2 -> eutt QQ (k1 u1) (k2 u2)) ->
    eutt QQ (x <- t1 a0;; k1 x) (x <- t2 a0;; k2 x).
Proof.
  intros * POST1 POST2 EQ1 EQ2.
  apply eutt_clo_bind with (UU := fun x y => Q1 x /\ Q2 y); [ | intuition].
  apply eutt_conj.
  rewrite has_post_post_strong in POST1.
  rewrite has_post_post_strong in POST2.
  unfold has_post_strong in *.
  eapply eqit_mon; eauto. 2 : apply EQ1. intuition. destruct PR. auto.
  eapply eqit_mon; eauto. 2 : apply EQ1. intuition. destruct PR. auto.
Qed.

(* We can commute computations where each atom coterminates with each other *)
Lemma commut_gen_coterminating_atoms :
  forall {A : Type}
    (Q1 Q2 : A -> Prop) (QQ : A -> A -> Prop) (a0 : A)
    (t1 t2 t3 t4 : A -> itree void1 A),
    (forall x, t1 x ≈ t4 x) ->
    (forall x, t2 x ≈ t3 x) ->
    (t1 a0 ⤳ Q1) ->
    (t3 a0 ⤳ Q2) ->
    (forall a1 a2, eutt (fun x y => Q1 x /\ Q2 y) (t1 a1) (t3 a2)) ->
    (forall a1 a2, Q1 a1 -> Q2 a2 -> eutt QQ (t2 a1) (t4 a2)) ->
    eutt QQ ('a <- t1 a0;; t2 a) ('a <- t3 a0;; t4 a).
Proof.
  cbn.
  einit. ecofix CIH.
  intros * EQ1 EQ2 EQ3 PC1 PC2 H.
  setoid_rewrite (itree_eta (t1 a0)) at 1.
  destruct (observe (t1 a0)) eqn: EQ; [ | | inv e].
  - ebind; econstructor; cycle 1.
    Unshelve. 3 : exact (fun x y => Q1 x /\ Q2 y).
    + intros. destruct H0. efinal.
    + clear H.
      rewrite <- bind_ret_r.
      setoid_rewrite <- bind_ret_r at 4.
      rewrite <- EQ. rewrite <- itree_eta.
      eapply eutt_post_bind_het; eauto.
      intros. eauto. apply eqit_Ret; eauto.
  - rewrite (itree_eta (t3 a0)).
    destruct (observe (t3 a0)) eqn: EQ'; [ | | inv e].
    + ebind; econstructor; cycle 1.
      Unshelve. 3 : exact (fun x y => Q1 x /\ Q2 y).
      * intros. destruct H0. efinal.
      * clear H. rewrite <- bind_ret_r.
        setoid_rewrite <- bind_ret_r at 5.
        rewrite <- EQ. rewrite <- itree_eta.
        rewrite <- EQ'. rewrite <- itree_eta.
        eapply eutt_post_bind_het; eauto.
        intros. apply eqit_Ret; eauto.
    + rewrite !bind_tau.

      assert (t1 a0 ≈ t). rewrite itree_eta. rewrite EQ.
      apply eqit_Tau_l. reflexivity.

      assert (t3 a0 ≈ t0). rewrite itree_eta. rewrite EQ'.
      apply eqit_Tau_l. reflexivity.

      clear CIH0.

      estep.
      ebind; econstructor; cycle 1.

      Unshelve. 3 : exact (fun x y => Q1 x /\ Q2 y).
      * intros. destruct H2. efinal.
      * rewrite <- bind_ret_r.
        setoid_rewrite <- bind_ret_r at 4.
        rewrite <- H0,<- H1.
        eapply eutt_post_bind_het; eauto.
        intros. apply eqit_Ret; eauto.
Qed.

Lemma commut_gen :
  forall {A : Type}
    (Q1 Q2 : A -> Prop) (QQ : A -> A -> Prop)
    (t1 t3 : itree void1 A)
    (t2 t4 : A -> itree void1 A),
    (forall x, Q2 x -> t1 ≈ t4 x) ->
    (forall x, Q1 x -> t2 x ≈ t3) ->
    (t1 ⤳ Q1) ->
    (t3 ⤳ Q2) ->
    (forall a, Q1 a -> t2 a ⤳ (fun x => QQ x a)) ->
    (forall a, Q2 a -> t4 a ⤳ (fun x => QQ a x)) ->
    eutt QQ (a <- t1;; t2 a) (a <- t3;; t4 a).
Proof.
  cbn.
  einit. ecofix CIH.
  intros * EQ1 EQ2 PC1 PC2 F1 F2.
  setoid_rewrite (itree_eta t1) at 1.
  destruct (observe t1) eqn: EQ; [ | | inv e].

  - (* Ret *)
    (* Need this rewriting to reason about co-termination on t2 and t3. *)
    rewrite bind_ret_l. rewrite <- bind_ret_r at 1.

    ebind; econstructor.
    + (* Prefix *)
      Unshelve.
      2 : { exact (fun x y => x = y /\ Q2 x). }
      rewrite EQ2; cycle 1.
      setoid_rewrite (itree_eta t1) in PC1.
      rewrite EQ in PC1. apply eqit_Ret in PC1. auto.
      rewrite has_post_post_strong in PC2.
      apply PC2.
    + (* Continuation. Equate t1 and t4. *)
      intros * [<- HQ]. efinal.
      setoid_rewrite (itree_eta t1) in EQ1.
      rewrite EQ in EQ1. rewrite <- EQ1; auto.
      apply eqit_Ret.
      specialize (F2 _ HQ).
      rewrite <- EQ1 in F2; auto. apply eqit_inv_Ret in F2. auto.

  - (* Tau *)
    rewrite (itree_eta t3).
    destruct (observe t3) eqn: EQ'; [ | | inv e].
    + rewrite bind_ret_l. setoid_rewrite <- bind_ret_r at 5.
      ebind; econstructor.
      * (* Prefix *)
        Unshelve.
        2 : { exact (fun x y => x = y /\ Q1 x). }

        rewrite <- EQ1; cycle 1.
        setoid_rewrite (itree_eta t3) in PC2.
        rewrite EQ' in PC2. apply eqit_Ret in PC2. auto.

        setoid_rewrite (itree_eta t1). setoid_rewrite (itree_eta t1) in PC1.
        rewrite has_post_post_strong in PC1.
        rewrite EQ. apply eqit_Tau. rewrite EQ in PC1.
        apply eqit_inv_Tau_l in PC1.
        apply eqit_inv_Tau_r in PC1.
        apply PC1.

      * (* Continuation. Equate t2 and t3. *)
        intros * [<- HQ]. efinal.
        setoid_rewrite (itree_eta t3) in EQ2.
        rewrite EQ' in EQ2. rewrite EQ2; auto.
        apply eqit_Ret.
        specialize (F1 _ HQ).
        rewrite EQ2 in F1; auto. apply eqit_inv_Ret in F1. auto.

    + rewrite !bind_tau.

      assert (t1 ≈ t). rewrite itree_eta. rewrite EQ.
      apply eqit_Tau_l. reflexivity.

      assert (t3 ≈ t0). rewrite itree_eta. rewrite EQ'.
      apply eqit_Tau_l. reflexivity.

      clear CIH0.

      estep.
      ebase; right.
      eapply CIH; eauto.
      setoid_rewrite <- H. auto.
      setoid_rewrite <- H0. auto.
      rewrite <- H. auto. rewrite <- H0. auto.
Qed.

Lemma eutt_inv_ret_l :
  forall E A Q r t1, eutt (E := E) (fun x y : A => Q x) (Ret r) t1 -> Q r.
Proof.
  intros.
  punfold H.
  unfold eqit_ in H.
  remember (observe (Ret r)) as x.
  revert Heqx .
  induction H; intros EQ; try now inv EQ.
  - apply IHeqitF; auto.
Qed.

Lemma eutt_inv_ret_r :
  forall E A Q r t1, eutt (E := E) (fun x y : A => Q y) t1 (Ret r) -> Q r.
Proof.
  intros.
  punfold H.
  unfold eqit_ in H.
  remember (observe (Ret r)) as x.
  revert Heqx .
  induction H; intros EQ; try now inv EQ.
  - apply IHeqitF; auto.
Qed.

Lemma commut_gen' :
  forall {A : Type}
    (Q1 Q2 : A -> Prop) (QQ : A -> Prop)
    (t1 t3 : itree void1 A)
    (t2 t4 : A -> itree void1 A),
    (forall i, eutt (fun x y => Q1 x /\ Q1 y) t1 (t4 i)) ->
    (forall i, eutt (fun x y => Q2 x /\ Q2 y) t3 (t2 i)) ->
      (forall a, Q1 a -> eutt (fun x y => QQ x /\ QQ y) t3 (t2 a)) ->
      (forall a, Q2 a -> eutt (fun x y => QQ x /\ QQ y) t1 (t4 a)) ->
    eutt (fun x y => QQ x /\ QQ y) (a <- t1 ;; t2 a) (a <- t3 ;; t4 a).
Proof.
  cbn.

  einit. ecofix CIH.
  intros * EQ1 EQ2 * PC1 PC2.
  setoid_rewrite (itree_eta t1) at 1.
  destruct (observe t1) eqn: EQ; [ | | inv e].

  clear CIH0.
  - (* Ret *)
    (* Need this rewriting to reason about co-termination on t2 and t3. *)

    rewrite bind_ret_l.

    setoid_rewrite (itree_eta t1) in EQ1. rewrite EQ in EQ1.

    rewrite <- bind_ret_r.
    ebind. econstructor.
    Unshelve. 3 : exact (fun x y => QQ x /\ Q2 y).

    {
      specialize (EQ1 r).

      apply eutt_conj; cycle 1.
      eapply eqit_mon; auto. 2 : eapply eqit_flip; apply EQ2. intuition. destruct PR. auto.
      eapply eqit_mon; auto.
      2 : eapply eqit_flip; eapply PC1. intros * []; auto.

      setoid_rewrite (itree_eta (t4 r)) in EQ1.
      destruct (observe (t4 r)) eqn: EQ'; [ | | inv e].
      apply eqit_inv_Ret in EQ1. destruct EQ1. auto.

      Set Nested Proofs Allowed.

      eapply eutt_inv_ret_l. eapply eqit_mon; auto.
      2 : eauto.
      intros * []; auto.
    }

    intros * [].

    efinal.

    specialize (EQ1 u2).

    setoid_rewrite (itree_eta (t4 u2)).
    setoid_rewrite (itree_eta (t4 u2)) in EQ1.
    destruct (observe (t4 u2)) eqn: EQ'; [ | | inv e].
    apply eqit_Ret. split; eauto.
    apply eqit_inv_Ret in EQ1. destruct EQ1.
    specialize (PC2 _ H0).
    setoid_rewrite (itree_eta (t4 u2)) in PC2.
    setoid_rewrite (itree_eta t1) in PC2.
    rewrite EQ', EQ in PC2. apply eqit_inv_Ret in PC2. destruct PC2. auto.

    specialize (PC2 _ H0).
    setoid_rewrite (itree_eta t1) in PC2.
    rewrite EQ in PC2.
    setoid_rewrite (itree_eta (t4 u2)) in PC2.
    rewrite EQ' in PC2.

    eapply eqit_mon; auto; cycle 1.
    eapply eqit_trans; cycle 2.
    apply eqit_Ret. Unshelve. 7 : exact (fun x y => QQ x /\ QQ y). cbn. split; auto.
    eapply eutt_inv_ret_l. eapply eqit_mon; auto; cycle 1. eapply PC2.
    intros * []; auto. apply PC2.
    intros * []; auto. destruct REL1, REL2. split; auto.

  - (* Tau *)
    clear CIH0.

    (* specialize (EQ1 i). *)
    setoid_rewrite (itree_eta t3).
    destruct (observe t3) eqn: EQ'; [ | | inv e]; cycle 1.

    + rewrite !bind_tau.

      assert (t1 ≈ t). rewrite itree_eta. rewrite EQ.
      apply eqit_Tau_l. reflexivity.

      assert (t3 ≈ t0). rewrite itree_eta. rewrite EQ'.
      apply eqit_Tau_l. reflexivity.

      estep.

      ebase; right.
      eapply CIH; eauto.
      intros; rewrite <- H; eauto.
      intros; rewrite <- H0; eauto.
      intros; rewrite <- H0; eauto.
      intros; rewrite <- H; eauto.

    + rewrite bind_ret_l.
      setoid_rewrite (itree_eta t1) in EQ1. rewrite EQ in EQ1.

      setoid_rewrite <- bind_ret_r at 5.
      ebind. econstructor.
      Unshelve. 3 : exact (fun x y => Q1 x /\ QQ y).

      apply eutt_conj; cycle 1.
      specialize (PC2 r). setoid_rewrite (itree_eta t1) in PC2.
      rewrite EQ in PC2.
      eapply eqit_mon; auto.
      Unshelve.
      2 : eapply eqit_flip. 2 : unfold flip.
      5 : exact (fun _ x => QQ x). cbn. intros; auto.
      apply eqit_flip. eapply eqit_mon; auto. 2 : eapply PC2.
      intros * []; intuition.

      setoid_rewrite (itree_eta t3) in EQ2.
      rewrite EQ' in EQ2. eapply eutt_inv_ret_l.
      eapply eqit_mon; auto. 2 : eapply EQ2.
      intros * []; eauto.

      eapply eqit_mon; auto; cycle 1.
      apply EQ1. intros * []; auto.

      intros * [].

      efinal.

      specialize (EQ1 u2).
      setoid_rewrite (itree_eta (t2 u1)).
      destruct (observe (t2 u1)) eqn: EQ''; [ | | inv e].
      apply eqit_Ret. split; eauto.
      specialize (EQ2 u1). setoid_rewrite (itree_eta (t2 u1)) in EQ2.
      rewrite EQ'' in EQ2.
      specialize (PC1 _ H).

      setoid_rewrite (itree_eta (t2 u1)) in PC1.
      rewrite EQ'' in PC1. clear EQ2.

      eapply eutt_inv_ret_r. eapply eqit_mon; eauto; cycle 1.
      intros * []; auto.

      specialize (PC1 _ H).
      setoid_rewrite (itree_eta (t2 u1)) in PC1.
      rewrite EQ'' in PC1.
      setoid_rewrite (itree_eta t3) in PC1.
      rewrite EQ' in PC1.

      eapply eqit_mon; auto; cycle 1.
      eapply eqit_trans; cycle 2.
      2 : apply eqit_Ret. Unshelve. 9 : exact (fun x y => QQ x /\ QQ y). 2 : split ; auto.
      2 : {
        eapply eutt_inv_ret_l. eapply eqit_mon; auto; cycle 1. eapply PC1.
        intros * []; auto.
      }
      apply eqit_flip. apply PC1. 2 : auto.
      intros * []; auto. destruct REL1, REL2. split; auto.
Qed.


From ExtLib Require Import
     Structures.Functor
     Structures.Monad.

From CTree Require Import
     Eq.

Import MonadNotation.
Open Scope monad_scope.
Notation BrSF := (BrF true).
Notation BrDF := (BrF false).

Definition brs_elim {E X} (t : ctree E X) : ctree E X :=
	CTree.iter (fun t =>
				        match observe t with
				        | RetF r => ret (inr r)
				        | BrDF n k =>
                    BrD n (fun x => ret (inl (k x)))
				        | BrSF n k =>
                    BrD n (fun x => Step (ret (inl (k x))))
				        | VisF e k => bind (mtrigger _ e) (fun x => ret (inl (k x)))
				        end) t.

Lemma unfold_brs_elim {E X} (t : ctree E X) :
  brs_elim t ≅
  match observe t with
	| RetF r => ret r
	| BrDF n k =>
      BrD n (fun x => Guard (brs_elim (k x)))
	| BrSF n k =>
      BrD n (fun x => Step (Guard (brs_elim (k x))))
	| VisF e k => bind (mtrigger _ e) (fun x => Guard (brs_elim (k x)))
	end.
Proof.
  unfold brs_elim at 1.
  rewrite unfold_iter.
  desobs t; cbn.
  - now rewrite bind_ret_l.
  - unfold mtrigger; rewrite bind_bind, !bind_trigger.
    step; constructor; intros ?.
    rewrite bind_ret_l.
    reflexivity.
  - destruct vis.
    + rewrite bind_br.
      step; constructor; intros ?.
      rewrite bind_Step; step; constructor; intros ?.
      rewrite bind_ret_l.
      step; constructor; auto.
    + rewrite bind_br.
      step; constructor; intros ?.
      rewrite bind_ret_l.
      step; constructor; auto.
Qed.

Lemma trans_brs_elim_inv_strong :
  forall {E X} (t u v : ctree E X) l,
    (v ≅ brs_elim t \/ v ≅ Guard (brs_elim t)) ->
    trans l v u ->
    exists t', trans l t t'
          /\ (u ≅ brs_elim t' \/ u ≅ Guard (brs_elim t')).
Proof.
  intros * EQ TR.
  revert t EQ.
  unfold trans in TR; repeat red in TR.
  dependent induction TR.
  - intros ? [EQ | EQ].
    + rewrite ctree_eta, <- x, unfold_brs_elim in EQ.
      setoid_rewrite (ctree_eta t).
      desobs t; try now step in EQ; inv EQ.
      destruct vis.
      * pose proof equ_br_invT _ _ EQ as [<- _].
        apply equ_br_invE with (x := x0) in EQ .
        rewrite EQ in TR.
        apply trans_step_inv in TR as [EQ' ->].
        eexists; split; eauto.
        etrans.

      * pose proof equ_br_invT _ _ EQ as [<- _].
        apply equ_br_invE with (x := x0) in EQ .
        specialize (IHTR _ _ eq_refl eq_refl).
        edestruct IHTR as (t' & ? & ?); eauto.
        exists t'.
        split.
        eapply trans_brD with (x := x0); eauto.
        eauto.

    + rewrite ctree_eta, <- x in EQ.
      pose proof equ_br_invT _ _ EQ as [-> _].
      apply equ_br_invE with (x := x0) in EQ .
      specialize (IHTR _ _ eq_refl eq_refl).
      edestruct IHTR as (t' & ? & ?); eauto.

  - (* G(t) ≅ BrS k : absurd *)
    intros ? [EQ | EQ].
    + rewrite ctree_eta, <- x1, unfold_brs_elim in EQ.
      desobs t0; try now step in EQ; inv EQ.
      destruct vis; try now step in EQ; inv EQ.
    + rewrite ctree_eta, <- x1 in EQ.
      now step in EQ; inv EQ.

  - (* G(t) ≅ Vis e k : t ≅ Vis e k', k x ≅ Guard (G (k' x)) *)
    intros ? [EQ | EQ].
    + setoid_rewrite (ctree_eta t0).
      rewrite ctree_eta, <- x1, unfold_brs_elim in EQ.
      rewrite (ctree_eta t), x in H.
      clear t x.
      desobs t0; try now step in EQ; inv EQ.
      2:destruct vis; try now step in EQ; inv EQ.
      cbn in *.
      unfold mtrigger in EQ; rewrite bind_trigger in EQ.
      pose proof equ_vis_invT _ _ _ _ EQ; subst.
      pose proof equ_vis_invE _ _ _ _ EQ as [-> EQ'].
      eexists; split.
      etrans.
      rewrite <- ctree_eta in H.
      rewrite <- H.
      rewrite EQ'.
      auto.
    + rewrite ctree_eta, <- x1 in EQ.
      now step in EQ; inv EQ.

  - (* G(t) ≅ Ret x : t ≅ Ret x *)
    intros ? [EQ | EQ].
    + setoid_rewrite (ctree_eta t).
      rewrite ctree_eta, <- x0, unfold_brs_elim in EQ.
      desobs t; try now step in EQ; inv EQ.
      2:destruct vis; try now step in EQ; inv EQ.
      step in EQ; inv EQ.
      eexists; split.
      etrans.
      left.
      rewrite ctree_eta, <- x, unfold_brs_elim.
      cbn.
      rewrite ! brD0_always_stuck.
      reflexivity.
    + rewrite ctree_eta, <- x0 in EQ.
      now step in EQ; inv EQ.
Qed.

Lemma trans_brs_elim_inv :
  forall E X (t u : ctree E X) l,
    trans l (brs_elim t) u ->
    exists t', trans l t t'
          /\ u ~ brs_elim t'.
Proof.
  intros.
  edestruct @trans_brs_elim_inv_strong as (t' & TR & EQ); [|eassumption|].
  left; eauto.
  exists t'; split; auto.
  destruct EQ as [EQ |EQ]; rewrite EQ; auto.
  rewrite sb_guard; auto.
Qed.

Ltac fold_bind :=
  repeat match goal with
           |- context [CTree.subst ?k ?t] => fold (CTree.bind t k)
         end.

#[global] Instance brs_elim_equ E X : Proper (equ eq ==> equ eq) (@brs_elim E X).
Proof.
  do 2 red.
  coinduction ? IH.
  intros * EQ.
  step in EQ.
  rewrite ! unfold_brs_elim.
  cbn*.
  inv EQ; auto.
  - cbn.
    constructor; intros ?.
    fold_bind; rewrite ! bind_ret_l.
    step; constructor; intros _.
    auto.
  - destruct b; cbn.
    all: constructor; intros ?.
    all: repeat (step; constructor; intros ?).
    all: auto.
Qed.

Opaque CTree.bind.
Lemma trans_brs_elim_strong :
  forall E X (t u : ctree E X) l,
    trans l t u ->
    exists u',
      trans l (brs_elim t) u'
      /\ (u' ≅ brs_elim u
         \/ u' ≅ Guard (brs_elim u)).
Proof.
  intros * TR.
  (* revert t EQ. *)
  unfold trans in TR; repeat red in TR.
  dependent induction TR; intros.
  - (* destruct EQ as [EQ | EQ]. *)
    edestruct IHTR as (u' & TR' & EQ'); eauto.
    setoid_rewrite unfold_brs_elim at 1; rewrite <- x.
    exists u'; split.
    eapply trans_brD with (x := x0); [| reflexivity].
    now apply trans_guard.
    auto.
  - setoid_rewrite unfold_brs_elim at 1; rewrite <- x1.
    eexists; split.
    eapply trans_brD with (x := x0); [| reflexivity].
    etrans.
    right.
    step; constructor; intros ?.
    rewrite H.
    rewrite (ctree_eta t0),x,<- ctree_eta.
    auto.
  - setoid_rewrite unfold_brs_elim at 1; rewrite <- x1.
    eexists; split.
    unfold mtrigger, MonadTrigger_ctree; cbn.
    rewrite bind_trigger.
    etrans.
    right.
    step; constructor; intros ?.
    rewrite H.
    rewrite (ctree_eta t0),x,<- ctree_eta.
    auto.
  - setoid_rewrite unfold_brs_elim at 1; rewrite <- x0.
    eexists; split.
    (*
      Why do I need to cbn even if I add:
      Hint Unfold ret Monad_ctree : trans.
     *)
    cbn; etrans.
    left.
    rewrite unfold_brs_elim, <- x; cbn.
    now rewrite ! brD0_always_stuck.
Qed.

Lemma trans_brs_elim :
  forall E X (t u : ctree E X) l,
    trans l t u ->
    exists u',
      trans l (brs_elim t) u'
      /\ u' ~ brs_elim u.
Proof.
  intros * TR.
  edestruct trans_brs_elim_strong as (u' & TR' & EQ'); eauto.
  exists u'; split; auto.
  destruct EQ' as [EQ' | EQ']; rewrite EQ'; auto.
  now rewrite sb_guard.
Qed.

Ltac sret  := apply step_sb_ret.
Ltac svis  := apply step_sb_vis.
Ltac sStep := apply step_sb_step.
Ltac sstep := sret || svis || sStep.

Lemma brs_elim_is_bisimilar {E X} : forall (t : ctree E X),
    brs_elim t ~ t.
Proof.
  coinduction ? IH.
  intros t.
  rewrite (ctree_eta t) at 2.
  rewrite unfold_brs_elim.
  desobs t.
  - now cbn.
  - cbn*.
    unfold mtrigger; rewrite bind_trigger.
    sstep; intros ?.
    rewrite sb_guard.
    apply IH.
  - destruct vis.
    + cbn.
      split; intros ? ? TR.
      * inv_trans.
        subst.
        eexists.
        eapply trans_brS with (x := n0).
        rewrite EQ.
        rewrite sb_guard.
        apply IH.
      * cbn.
        inv_trans; subst.
        eexists.
        eapply trans_brD with (x := n0).
        2:etrans.
        etrans.
        rewrite sb_guard.
        rewrite EQ; apply IH.
    + split.
      * intros ? ? TR.
        cbn.
        inv_trans.
        edestruct trans_brs_elim_inv as (u' & TR' & EQ'); eauto.
        eexists.
        eapply trans_brD with (x := n0); [| reflexivity].
        eassumption.
        rewrite EQ'; auto.
      * cbn; intros ? ? TR.
        inv_trans.
        edestruct trans_brs_elim as (u' & TR' & EQ'); eauto.
        eexists.
        eapply trans_brD with (x := n0); [| reflexivity].
        apply trans_guard.
        eauto.
        rewrite EQ'; auto.
Qed.


Set Implicit Arguments.

Require Import Coq.Lists.List.
Require Import Bag.TotalOrder.
Require Import Bag.Bag2.
Require Import Common.Types.
Require Import FwOF.FwOFSignatures.

Local Open Scope list_scope.
Local Open Scope equiv_scope.
Local Open Scope bag_scope.

Module Make (Atoms_ : ATOMS) <: MACHINE.

  Module Atoms := Atoms_.
  Import Atoms.

  Existing Instances TotalOrder_packet TotalOrder_switchId TotalOrder_portId
    TotalOrder_flowTable TotalOrder_flowMod TotalOrder_fromSwitch
    TotalOrder_fromController.

  (* Field names have two purposes. Coq creates selectors with these names,
     and also uses them to generate variable names in proofs. We spend
     more time in FwOF proofs, so we pick short names here. *)
  Record switch := Switch {
    swId : switchId;
    pts : list portId;
    tbl : flowTable;
    inp : bag (PairOrdering portId_le packet_le);
    outp :  bag (PairOrdering portId_le packet_le);
    ctrlm : bag fromController_le;
    switchm : bag fromSwitch_le
  }.

  (* TODO(arjun): fix *)
  Inductive switch_le : switch -> switch -> Prop :=
  | SwitchLe : forall sw1 sw2,
      switchId_le (swId sw1) (swId sw2) ->
      switch_le sw1 sw2.

  Axiom Instance TotalOrder_switch : TotalOrder switch_le.

  Record dataLink := DataLink {
    src : switchId * portId;
    pks : list packet;
    dst : switchId * portId
  }.

  Record openFlowLink := OpenFlowLink {
    of_to : switchId;
    of_switchm : list fromSwitch;
    of_ctrlm : list fromController
  }.

  Definition observation := (switchId * portId * packet) %type.

  (* NOTE(arjun): Ask me in person why exactly I picked these levels. *)
  Reserved Notation "SwitchStep[ sw ; obs ; sw0 ]"
    (at level 70, no associativity).
  Reserved Notation "ControllerOpenFlow[ c ; l ; obs ; c0 ; l0 ]"
    (at level 70, no associativity).
  Reserved Notation "TopoStep[ sw ; link ; obs ; sw0 ; link0 ]"
    (at level 70, no associativity).
  Reserved Notation "SwitchOpenFlow[ s ; l ; obs ; s0 ; l0 ]"
    (at level 70, no associativity).

  Inductive NotBarrierRequest : fromController -> Prop :=
  | PacketOut_NotBarrierRequest : forall pt pk,
      NotBarrierRequest (PacketOut pt pk)
  | FlowMod_NotBarrierRequest : forall fm,
      NotBarrierRequest (FlowMod fm).

  (** Devices of the same type do not interact in a single
      step. Therefore, we never have to permute the lists below. If we
      instead had just one list of all devices, we would have to worry
      about permuting the list or define symmetric step-rules. *)
  Record state := State {
    switches : bag switch_le;
    links : list dataLink;
    ofLinks : list openFlowLink;
    ctrl : controller
  }.

  Inductive step : state -> option observation -> state -> Prop :=
  | PktProcess : forall swId pts tbl pt pk inp outp ctrlm switchm outp'
                        pksToCtrl,
    process_packet tbl pt pk = (outp', pksToCtrl) ->
    SwitchStep[
      Switch swId pts tbl ({|(pt,pk)|} <+> inp) outp ctrlm switchm;
      Some (swId,pt,pk);
      Switch swId pts tbl inp (from_list outp' <+> outp)
        ctrlm (from_list (map (PacketIn pt) pksToCtrl) <+> switchm)
    ]
  | ModifyFlowTable : forall swId pts tbl inp outp fm ctrlm switchm,
    SwitchStep[
      Switch swId pts tbl inp outp ({|FlowMod fm|} <+> ctrlm) switchm;
      None;
      Switch swId pts (modify_flow_table fm tbl) inp outp ctrlm switchm
    ]
  | SendPacketOut : forall pt pts swId tbl inp outp pk ctrlm switchm,
    SwitchStep[
      Switch swId pts tbl inp outp  ({|PacketOut pt pk|} <+> ctrlm) switchm;
      None;
      Switch swId pts tbl inp ({| (pt,pk) |} <+> outp) ctrlm switchm
    ]
  | SendDataLink : forall swId pts tbl inp pt pk outp ctrlm switchm pks dst,
    TopoStep[
      Switch swId pts tbl inp ({|(pt,pk)|} <+> outp) ctrlm switchm;
      DataLink (swId,pt) pks dst;
      None;
      Switch swId pts tbl inp outp ctrlm switchm;
      DataLink (swId,pt) (pk :: pks) dst
    ]
  | RecvDataLink : forall swId pts tbl inp outp ctrlm switchm src pks pk pt,
    TopoStep[
      Switch swId pts tbl inp outp ctrlm switchm;
      DataLink src  (pks ++ [pk]) (swId,pt);
      None;
      Switch swId pts tbl ({|(pt,pk)|} <+> inp) outp ctrlm switchm;
      DataLink src pks (swId,pt)
    ]
  | Step_controller : forall sws links ofLinks ctrl ctrl',
    controller_step ctrl ctrl' ->
    step (State sws links ofLinks ctrl)
         None
         (State sws links ofLinks ctrl')
  | ControllerRecv : forall ctrl msg ctrl' swId fromSwitch fromCtrl,
    controller_recv ctrl swId msg ctrl' ->
    ControllerOpenFlow[
      ctrl;
      OpenFlowLink swId (fromSwitch ++ [msg]) fromCtrl;
      None;
      ctrl';
      OpenFlowLink swId fromSwitch fromCtrl
    ]
  | ControllerSend : forall ctrl msg ctrl' swId fromSwitch fromCtrl,
    controller_send ctrl ctrl' swId msg ->
    ControllerOpenFlow[
      ctrl ;
      (OpenFlowLink swId fromSwitch fromCtrl);
      None;
      ctrl';
      (OpenFlowLink swId fromSwitch (msg :: fromCtrl)) ]
  | SendToController : forall swId pts tbl inp outp ctrlm msg switchm fromSwitch
      fromCtrl,
    SwitchOpenFlow[
      Switch swId pts tbl inp outp ctrlm ({| msg |} <+> switchm);
      OpenFlowLink swId fromSwitch fromCtrl;
      None;
      Switch swId pts tbl inp outp ctrlm switchm;
      OpenFlowLink swId (msg :: fromSwitch) fromCtrl
    ]
  | RecvBarrier : forall swId pts tbl inp outp switchm fromSwitch fromCtrl
      xid,
    SwitchOpenFlow[
      Switch swId pts tbl inp outp empty switchm;
      OpenFlowLink swId fromSwitch (fromCtrl ++ [BarrierRequest xid]);
      None;
      Switch swId pts tbl inp outp empty
             ({| BarrierReply xid |} <+> switchm);
      OpenFlowLink swId fromSwitch fromCtrl
    ]
  | RecvFromController : forall swId pts tbl inp outp ctrlm switchm
      fromSwitch fromCtrl msg,
    NotBarrierRequest msg ->
    SwitchOpenFlow[
      Switch swId pts tbl inp outp ctrlm switchm;
      OpenFlowLink swId fromSwitch (fromCtrl ++ [msg]);
      None;
      Switch swId pts tbl inp outp ({| msg |} <+> ctrlm) switchm;
      OpenFlowLink swId fromSwitch fromCtrl
    ]
      where
  "ControllerOpenFlow[ c ; l ; obs ; c0 ; l0 ]" :=
    (forall sws links ofLinks ofLinks',
      step (State sws links (ofLinks ++ l :: ofLinks') c)
           obs
           (State sws links (ofLinks ++ l0 :: ofLinks') c0))
    and
  "TopoStep[ sw ; link ; obs ; sw0 ; link0 ]" :=
    (forall sws links links0 ofLinks ctrl,
      step
      (State (({|sw|}) <+> sws) (links ++ link :: links0) ofLinks ctrl)
      obs
      (State (({|sw0|}) <+> sws) (links ++ link0 :: links0) ofLinks ctrl))
    and
  "SwitchStep[ sw ; obs ; sw0 ]" :=
    (forall sws links ofLinks ctrl,
      step
        (State (({|sw|}) <+> sws) links ofLinks ctrl)
        obs
        (State (({|sw0|}) <+> sws) links ofLinks ctrl))
    and
  "SwitchOpenFlow[ sw ; of ; obs ; sw0 ; of0 ]" :=
    (forall sws links ofLinks ofLinks0 ctrl,
      step
        (State (({|sw|}) <+> sws) links (ofLinks ++ of :: ofLinks0) ctrl)
        obs
        (State (({|sw0|}) <+> sws) links (ofLinks ++ of0 :: ofLinks0) ctrl)).

  Definition swPtPks : Type :=
    bag (PairOrdering (PairOrdering switchId_le portId_le)
                      packet_le).

  Definition abst_state := swPtPks.

  Definition transfer (sw : switchId) (ptpk : portId * packet) :=
    match ptpk with
      | (pt,pk) =>
        match topo (sw,pt) with
          | Some (sw',pt') =>
            @singleton _
               (PairOrdering
                  (PairOrdering switchId_le portId_le) packet_le)
               (sw',pt',pk)
          | None => {| |}
        end
    end.

  Definition select_packet_out (sw : switchId) (msg : fromController) :=
    match msg with
      | PacketOut pt pk => transfer sw (pt,pk)
      | _ => {| |}
    end.

  Definition select_packet_in (sw : switchId) (msg : fromSwitch) :=
    match msg with
      | PacketIn pt pk => unions (map (transfer sw) (abst_func sw pt pk))
      | _ => {| |}
    end.

  Definition FlowTableSafe (sw : switchId) (tbl : flowTable) : Prop :=
    forall pt pk forwardedPkts packetIns,
      process_packet tbl pt pk = (forwardedPkts, packetIns) ->
      unions (map (transfer sw) forwardedPkts) <+>
      unions (map (select_packet_in sw) (map (PacketIn pt) packetIns)) =
      unions (map (transfer sw) (abst_func sw pt pk)).

  Inductive NotFlowMod : fromController -> Prop :=
  | NotFlowMod_BarrierRequest : forall n, NotFlowMod (BarrierRequest n)
  | NotFlowMod_PacketOut : forall pt pk, NotFlowMod (PacketOut pt pk).

  Inductive FlowModSafe : switchId -> flowTable -> bag fromController_le -> Prop :=
  | NoFlowModsInBuffer : forall swId tbl ctrlm,
      (forall msg, In msg (to_list ctrlm) -> NotFlowMod msg) ->
      FlowTableSafe swId tbl ->
      FlowModSafe swId tbl ctrlm
  | OneFlowModsInBuffer : forall swId tbl ctrlm f,
      (forall msg, In msg (to_list ctrlm) -> NotFlowMod msg) ->
      FlowTableSafe swId tbl ->
      FlowTableSafe swId (modify_flow_table f tbl) ->
      FlowModSafe swId tbl (({|FlowMod f|}) <+> ctrlm).

  Definition FlowTablesSafe (sws : bag switch_le) : Prop :=
    forall swId pts tbl inp outp ctrlm switchm,
      In (Switch swId pts tbl inp outp ctrlm switchm) (to_list sws) ->
      FlowModSafe swId tbl ctrlm.

  Definition SwitchesHaveOpenFlowLinks (sws : bag switch_le) ofLinks :=
    forall sw,
      In sw (to_list sws) ->
      exists ofLink,
        In ofLink ofLinks /\
        swId sw = of_to ofLink.

End Make.