(* Mohamed Sami Cherif, with Narjes Jomaa and Paolo Torrini
   Universite' Lille-1 - CRIStAL-CNRS
*)
(* verification of the getFstShadow invariant *)

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.

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

Open Scope state_scope.

(******* 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 IfThenElse_VHTT1. *)
HoareTac.
(** 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.

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 *)

Ltac HoareTac1 :=
  unfold ReadPhysicalQF; unfold SuccQF; HoareTac.

(* 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. *)
HoareTac1.
eapply getSh1idxWp.
simpl; intros.
(* eapply BindS_VHTT1. *)
HoareTac1.
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. *)
HoareTac1.
eapply getSh1idxWp.
simpl; intros.
(* eapply BindS_VHTT1. *)
HoareTac1.
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 getFstShadowBindDeepRec.
(* eapply BindS_VHTT1. *)
HoareTac1.
eapply getSh1idxWp.
simpl; intros.
(* eapply BindS_VHTT1. *)
HoareTac1.
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. *)
  HoareTac1.
  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.
*)
  repeat HoareTac1.
  eapply getSh1idxWp.
  instantiate (1:= fun vs s => P s /\ partitionDescriptorEntry s /\
     In partition (getPartitions multiplexer s) /\ vs = [cst index sh1idx]).
  intros; unfold THoarePrmsTriple_Eval; intros; simpl.
  inversion X; subst.
  destruct vs; inversion H5.
  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.

(*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.
*)


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

Require Export EqObsRelDec.

Set Implicit Arguments.

Module Make (SemO:SEM_OPT).

 Module EQRD := EqObsRelDec.Make SemO.
 Export EQRD.

 Section TRIPLES.

  Variable k : nat.
  Variable E : env.

  Definition triple c (f g:Mem.t k -> U) := forall m, mu ([[c]] E m) g <= f m.

  Local Notation "'[|' c '|]' g '<~' f" := (triple c f g) (at level 50).

  Lemma triple_EqObs : forall I O c c' f g,
   depend_only_f f I ->
   depend_only_f g O ->
   EqObs I E c E c' O ->
   [| c'|] g <~ f ->
   [| c |] g <~ f.
  Proof.
   red; intros.
   eapply Ole_trans; [ | apply H2].
   apply Oeq_le; apply EqObs_deno with I O; trivial.
  Qed.

  Lemma triple_ass : forall t (x:Var.var t) e f,
   [| [x <- e] |] f <~ (fun m => f (m{!x <-- E.eval_expr e m!})).
  Proof.
   red; intros; rewrite deno_assign_elim; trivial.
  Qed.

  Lemma triple_ass_dep : forall t (x:Var.var t) e f X,
   depend_only_f f X ->
   ~Vset.mem x X ->
   [| [x <- e] |] f <~ f.
  Proof.
   red; intros; rewrite deno_assign_elim.
   rewrite <- (H m); trivial.
   apply not_is_true_false in H0.
   apply req_mem_upd_disjoint; trivial.
  Qed.

  Lemma triple_rand : forall t (x:Var.var t) s f,
   [| [x <$- s] |] f <~
   (fun m => sum_dom (T.default _ _) (E.eval_support s m)
    (fun v => f (m{!x <-- v!}))).
  Proof.
   red; intros; rewrite deno_random_elim; trivial.
  Qed.

  Lemma triple_rand_dep : forall t (x:Var.var t) s f X,
   depend_only_f f X ->
   ~Vset.mem x X ->
   [| [x <$- s] |] f <~ f.
  Proof.
   red; intros; rewrite deno_random_elim.
   apply Oeq_le.
   transitivity (mu (sum_support (T.default _ _) (E.eval_support s m))
    (fun v => f m)).
   symmetry; apply sum_support_stable_eq.
   intros; apply H.
   apply req_mem_upd_disjoint; trivial.
   apply not_is_true_false in H0; trivial.
   apply sum_support_const.
   apply E.eval_support_nil.
  Qed.

  Lemma triple_nil : forall (f g:Mem.t k -o> U),
   g <= f ->
   [| nil |] g <~ f.
  Proof.
   red; intros; rewrite deno_nil_elim; auto.
  Qed.

  Lemma triple_app : forall c1 c2 f g h,
   [| c1 |] g <~ f ->
   [| c2 |] h <~ g ->
   [| c1 ++ c2 |] h <~ f.
  Proof.
   red; intros; rewrite deno_app_elim.
   transitivity (mu ([[ c1 ]] E m) g); auto.
  Qed.

  Lemma triple_cons : forall i c f g h,
   [| [i] |] g <~ f ->
   [| c |] h <~ g ->
   [| i::c |] h <~ f.
  Proof.
   intros; change (i::c) with ([i]++c); apply triple_app with g; trivial.
  Qed.

  Lemma triple_cond : forall (e:E.expr T.Bool) c1 c2 f g,
   [| c1 |] g <~ f ->
   [| c2 |] g <~ f ->
   [| [If e then c1 else c2] |] g <~ f.
  Proof.
   red; intros; rewrite deno_cond_elim.
   generalize (H m) (H0 m).
   case (E.eval_expr e m); auto.
  Qed.

  Lemma triple_strengthen : forall (f f':Mem.t k -o> U) g c,
   f' <= f ->
   [| c |] g <~ f' ->
   [| c |] g <~ f.
  Proof.
   red; intros.
   transitivity (f' m); auto.
  Qed.

  Lemma triple_weaken : forall (f g g':Mem.t k -o> U) c,
   g <= g' ->
   [| c |] g' <~ f ->
   [| c |] g  <~ f.
  Proof.
   red; intros.
   transitivity (mu ([[ c ]] E m) g'); auto.
  Qed.

  Lemma triple_false : forall g c,
   [| c |] g <~ fone _.
  Proof.
   red; intros; trivial.
  Qed.

  Lemma triple_true : forall f c,
   [| c |] (fzero _) <~ f.
  Proof.
   red; intros; rewrite mu_zero; trivial.
  Qed.

  Lemma triple_while : forall (e:E.expr T.Bool) c f,
   [| c |] f <~ f ->
   [| [while e do c] |] f <~ f.
  Proof.
   unfold triple; intros.
   rewrite deno_while_unfold_elim.
   assert (Hind:forall n, [| unroll_while e c n |] f <~ f).
   clear m; induction n; simpl.

   apply triple_cond; apply triple_nil; trivial.

   apply triple_cond.
   apply triple_app with f; trivial.
   apply triple_nil; trivial.

   apply lub_le; intros n.
   eapply Ole_trans; [ | eapply (Hind n m) ].
   unfold unroll_while_sem; simpl.
   refine (mu_monotonic _ _ _ _); intro m0.
   case (negP (E.eval_expr e) m0); trivial.
  Qed.

  Lemma triple_call : forall t (p:Proc.proc t) f g (x:Var.var t) la X Y,
   [| proc_body E p |] g <~ f ->
   depend_only_f f X ->
   depend_only_f g Y ->
   (forall x, Vset.mem x X -> Var.is_global x) ->
   (forall x, Vset.mem x Y -> Var.is_global x) ->
   ~Vset.mem x X ->
   ~Vset.mem x Y ->
   [| [x <c- p with la] |] g <~ f.
  Proof.
   unfold triple; intros; rewrite deno_call_elim.
   generalize (H (init_mem E p la m)).
   transitivity (f (init_mem E p la m)).
   eapply Ole_trans; [ | apply H ].
   apply mu_monotonic; intro m'.
   apply Oeq_le; apply H1.
   red; intros.
   rewrite return_mem_global; [trivial | | auto].
   intros Heq; apply H5; generalize H7; inversion Heq; trivial.
   apply Oeq_le; apply H0.
   red; intros; apply init_mem_global; auto.
  Qed.

  Section ADVERSARY.

   Variables PrOrcl PrPriv : PrSet.t.
   Variables Gadv Gcomm :Vset.t.
   Variable f : Mem.t k -> U.
   Variable X : Vset.t.

   Hypothesis Gadv_disj : Vset.disjoint X Gadv.

   Hypothesis X_global : forall x, Vset.mem x X -> Var.is_global x.

   Hypothesis X_depend_only: depend_only_f f X.

   Hypothesis triple_orcl: forall t (p:Proc.proc t),
    PrSet.mem (BProc.mkP p) PrOrcl ->
    [| proc_body E p |] f <~ f.

   Lemma triple_adv : forall ca I O,
    WFAdv_c PrOrcl PrPriv Gadv Gcomm E I ca O ->
    (forall x, Vset.mem x I -> Var.is_local x) ->
    [| ca |] f <~ f.
   Proof.
    intros ca I O H; induction H using WFAdv_c_prop with
     (P := fun I c O (H: WFAdv_c PrOrcl PrPriv Gadv Gcomm E I c O) =>
      (forall x, Vset.mem x I -> Var.is_local x) -> triple c f f)
     (P0 := fun I i O (H:WFAdv_i PrOrcl PrPriv Gadv Gcomm E I i O) =>
      (forall x, Vset.mem x I -> Var.is_local x) -> triple [i] f f);
     intros; trivial.
    apply triple_nil; intro; auto.
    apply triple_cons with f.
    apply IHWFAdv_c; trivial.
    apply IHWFAdv_c0; intros; trivial.
    apply WFAdv_i_local with PrOrcl PrPriv Gadv Gcomm E I i IO; auto.

    apply triple_ass_dep with X; trivial.
    apply LS.WFWrite_not_mem with Gadv I; auto; destruct x; trivial.

    apply triple_rand_dep with X; trivial.
    apply LS.WFWrite_not_mem with Gadv I; auto; destruct x; trivial.

    apply triple_cond; auto.
    apply triple_while; auto.

    (* Oracle *)
    apply triple_call with X X; auto.
    apply LS.WFWrite_not_mem with Gadv I; auto; destruct x; trivial.
    apply LS.WFWrite_not_mem with Gadv I; auto; destruct x; trivial.

    (* Adv *)
    apply triple_call with X X; auto.
    apply IHWFAdv_c; intros (t0, x0) H3.
    apply  Vset_of_var_decl_ind with
     (P:=fun t (x:Var.var t) => Var.is_local x) (lv:=proc_params E f0); trivial.
    intros; change (Var.vis_local x1).
    apply proc_params_local with E t f0; trivial.
    apply LS.WFWrite_not_mem with Gadv I; auto; destruct x; trivial.
    apply LS.WFWrite_not_mem with Gadv I; auto; destruct x; trivial.
   Qed.

   Lemma triple_adv_Call : forall t (x:Var.var t) (A:Proc.proc t) la,
     WFAdv PrOrcl PrPriv Gadv Gcomm E A ->
     ~Vset.mem x X ->
     (forall x, Vset.mem x (Vset_of_var_decl (proc_params E A)) -> Var.is_local x) ->
     [| [x <c- A with la] |] f <~ f.
   Proof.
    intros t x A la [O [H H0] ] Hx Hparams m.
    rewrite deno_call_elim.
    assert (H1:[| proc_body E A |] f <~ f).
     apply triple_adv with (Vset_of_var_decl (proc_params E A)) O; trivial.

    transitivity (mu ([[ proc_body E A]] E (init_mem E A la m)) f).
    apply mu_le_compat; trivial.
    apply ford_le_intro; intro m'.
    apply Oeq_le; apply X_depend_only.
    intros ? y Hy; apply return_mem_global.
    intro Heq; elim Hx; rewrite Heq; trivial.
    apply X_global; trivial.

    transitivity (f (init_mem E A la m)).
    apply H1.
    apply Oeq_le; apply X_depend_only.
    intros ? y Hy; apply init_mem_global.
    apply X_global; trivial.
   Qed.

  End ADVERSARY.

  Section INFO.

   Variable f : Mem.t k -> U.

   Record failure_info : Type :=
    {
     fail_dep : Vset.t;
     fail_dep_correct : depend_only_f f fail_dep;
     fail_dep_global : forall x, Vset.mem x fail_dep -> Var.is_global x;
     fail_info_b : forall t, Proc.proc t -> bool;
     fail_info_spec : forall t (p:Proc.proc t),
      fail_info_b p -> [| proc_body E p |] f <~ f
    }.

   Section DEC.

    Variable fi : failure_info.

    Definition check_fail_base (bi:I.baseInstr) : bool :=
     match bi with
      | I.Assign t x e => negb (Vset.mem x (fail_dep fi))
      | I.Random t x d => negb (Vset.mem x (fail_dep fi))
     end.

    Open Scope bool_scope.

    Fixpoint check_fail_i (i:I.instr) : bool :=
     match i with
      | I.Instr bi => check_fail_base bi
      | I.Cond e c1 c2 => forallb check_fail_i c1 && forallb check_fail_i c2
      | I.While e c => forallb check_fail_i c
      | I.Call t x f args => fail_info_b fi f && negb (Vset.mem x (fail_dep fi))
     end.

    Definition check_fail (c:cmd) := forallb check_fail_i c.

    Lemma check_fail_correct : forall c,
     check_fail c ->
     [| c |] f <~ f.
    Proof.
     induction c using I.cmd_ind with
      (Pi := fun i => check_fail_i i -> [| [i] |] f <~ f);simpl;intros.
     destruct i;
      [apply triple_ass_dep with (fail_dep fi) |
       apply triple_rand_dep with (fail_dep fi) ];
      auto using fail_dep_correct;simpl in H;rewrite <- is_true_negb;trivial.
     destruct (if_and _ _ H); apply triple_cond; auto.
     apply triple_while; auto.
     destruct (if_and _ _ H).
     apply triple_call with (fail_dep fi) (fail_dep fi).
     apply fail_info_spec with fi; trivial.
     apply fail_dep_correct.
     apply fail_dep_correct.
     apply fail_dep_global.
     apply fail_dep_global.
     rewrite <- is_true_negb; trivial.
     rewrite <- is_true_negb; trivial.
     apply triple_nil; trivial.
     generalize H; case_eq (check_fail_i i).
     intros; apply triple_cons with f; auto.
     intros; discriminate.
    Qed.

   End DEC.

   Definition empty_fi (D:Vset.t) (H:depend_only_f f D)
    (H0: forall x, Vset.mem x D -> Var.is_global x) : failure_info.
   intros; apply Build_failure_info with D (fun _ _ => false); trivial.
   intros; discriminate.
   Defined.

   Definition add_fi (fi:failure_info) t (p:Proc.proc t)  (H:[| proc_body E p |] f <~ f) : failure_info.
   intros; destruct fi.
   apply Build_failure_info with fail_dep0 (fun tg g => if (Proc.eqb p g) then true else fail_info_b0 tg g);trivial.
   abstract (intros;case_eq (Proc.eqb p p0);intros;
    [assert (W:= Proc.eqb_spec_dep p p0);rewrite H1 in W;inversion W;simpl;trivial
     |rewrite H1 in H0;eauto]).
   Defined.

   Definition add_fi_refl (fi:failure_info) t (p:Proc.proc t) : failure_info.
   intros; case_eq (check_fail fi (proc_body E p)); intros; [ | apply fi].
   exact (add_fi fi p (check_fail_correct fi _ H)).
   Defined.

   Definition add_fi_adv (fi:failure_info) t (p:Proc.proc t)
    (PrOrcl PrPriv : PrSet.t) (Gadv Gcomm : Vset.t) (H:WFAdv PrOrcl PrPriv Gadv Gcomm E p): failure_info.
   intros; set (F:=fun g => fail_info_b fi (BProc.p_name g)).
   case_eq (PrSet.forallb F PrOrcl);intros;[ | exact fi].
   case_eq (Vset.disjoint (fail_dep fi) Gadv);intros;[ | exact fi].
   assert (W:[| proc_body E p |] f <~ f).
   abstract (destruct fi; simpl in *;
    destruct H as (O,(H3,H2));
     eapply triple_adv; eauto;
      [intros;apply fail_info_spec0;
       apply PrSet.forallb_correct with (2:= H0) (3:= H);
        intros x y Heq;rewrite Heq;trivial
       |intros (t0,x0) H4;apply  Vset_of_var_decl_ind with
        (P:=fun t (x:Var.var t) => Var.is_local x) (lv:=proc_params E p); trivial;
         intros; change (Var.vis_local x); apply proc_params_local with E _ p; trivial]).
   exact (add_fi fi p W).
   Defined.

  End INFO.

  Section FEL.

   Variable e : E.expr T.Nat.
   Variable q : nat.
   Variable F : Mem.t k -> bool.

   Let sum_k_p k p (f:nat -> U) := (sigma (fun n => f (p - S n)) (p - k))%nat.

   Lemma sum_k_p_S : forall k p f,
    (k < p)%nat ->
    sum_k_p k p f == f k + sum_k_p (S k) p f.
   Proof.
    intros; unfold sum_k_p.
    replace (p - k0)%nat with (S (p - (S k0)))%nat by omega.
    rewrite sigma_S.
    replace (p - S (p - S k0))%nat with k0 by omega.
    trivial.
   Qed.

   Lemma sigma_minus : forall m f,
    sigma f m == sigma (fun n => f (m - S n))%nat m.
   Proof.
    induction m; intros.
    rewrite sigma_0; trivial.
    rewrite sigma_S, sigma_S_lift.
    replace (S m - 1)%nat with m; [ | omega].
    apply Uplus_eq_compat; [trivial | ].
    rewrite IHm; apply sigma_eq_compat; intros.
    replace (m - S k0)%nat with (S m - S (S k0))%nat; [trivial | omega].
   Qed.

   Definition failure_inv h (m:Mem.t k) : U :=
    if leb (E.eval_expr e m) q
     then charfun F m + charfun (negP F) m * sum_k_p (E.eval_expr e m) q h
     else 0.

   Section ORACLE.

    Variable body : cmd.
    Variable h : nat -> U.
    Variable P : Mem.t k -> bool.

    Let f := failure_inv h.

    Hypothesis Hbody: forall (m:Mem.t k),
     F m = false -> mu ([[body]] E m) (charfun F) <= h (E.eval_expr e m).

    Hypothesis range_true : forall (m:Mem.t k),
     P m = false ->
     range (fun m' => F m' = F m /\ E.eval_expr e m' = E.eval_expr e m)
     ([[body]] E m).

    Hypothesis range_false : forall (m:Mem.t k),
     P m = true ->
     range (fun m' => E.eval_expr e m < E.eval_expr e m')%nat ([[body]] E m).

    Lemma triple_oracle : [|body|] f <~ f.
    Proof.
     intro m; unfold f, failure_inv, charfun, restr, fone, negP, negb.
     case_eq (P m); intro HP.

     (* P m = true *)
     case (le_lt_dec q (E.eval_expr e m)); intro Hlt.

     (* e >= q *)
     rewrite (range_le (range_false HP) _ (fzero _)).
     rewrite mu_zero; trivial.
     intros; rewrite leb_correct_conv; [trivial | omega].

     (* e < q *)
     rewrite leb_correct; [ | omega].
     case_eq (F m); intro HF; repeat Usimpl; [trivial | ].
     rewrite (range_le (range_false HP) _
      (fplus (charfun F)
       (fmult (sum_k_p (S (E.eval_expr e m)) q h) (charfun (negP F))))).
     rewrite (@mu_stable_plus _ _ _), (mu_stable_mult _ _), (Hbody HF).
     rewrite Ule_mult_right, <- sum_k_p_S; trivial.

     intro m'; unfold charfun, restr, finv, fmult, negP, negb, fone.
     case (F m'); repeat Usimpl; trivial.

     intros m' He; unfold fplus, fmult, charfun, restr, negP, negb, fone.
     case (leb (E.eval_expr e m') q); [ | trivial].
     repeat Usimpl; apply sigma_incr; omega.

     (* P = false *)
     setoid_rewrite (range_le (range_true HP) _ (fcte  _ _)).
     rewrite mu_cte; apply Ule_mult_right.
     intros m' [H H0]; rewrite H, H0; trivial.
    Qed.

   End ORACLE.

   Lemma failure_event : forall (m:Mem.t k) c h,
    [| c |] (failure_inv h) <~ failure_inv h ->
    F m = false ->
    E.eval_expr e m = O ->
    Pr E c m (F [&&] EP k (e <=! q)) <= sigma h q.
   Proof.
    intros m c h H HF He.
    eapply Ole_trans; [eapply Ole_trans; [ | apply (H m)] | ].
    apply mu_le_compat; [trivial | ].
    intros m'.
    unfold failure_inv, EP, charfun, restr, andP, andb, negP, negb, fone.
    simpl; unfold O.eval_op; simpl.
    case (leb (E.eval_expr e m') q); case (F m'); trivial.
    unfold failure_inv, charfun, restr, negP, negb, fone, sum_k_p.
    rewrite He, HF, <- minus_n_O, leb_correct; [Usimpl | omega].
    rewrite <- sigma_minus; trivial.
   Qed.

   Lemma failure_event_const : forall (m:Mem.t k) c a,
    [| c |] (failure_inv (fcte _ a)) <~ failure_inv (fcte _ a) ->
    F m = false ->
    E.eval_expr e m = O ->
    Pr E c m (F [&&] EP k (e <=! q)) <= q */ a.
   Proof.
    intros; eapply Ole_trans; [apply (failure_event H); trivial | ].
    clear H; induction q.
    rewrite sigma_0; trivial.
    rewrite sigma_S, Nmult_S, IHn; trivial.
   Qed.

   Lemma failure_event_mult : forall (m:Mem.t k) c a,
    [| c |] (failure_inv (fun n => n */ a)) <~ failure_inv (fun n => n */ a) ->
    F m = false ->
    E.eval_expr e m = O ->
    Pr E c m (F [&&] EP k (e <=! q)) <= (q-1)*q */ [1/2]*a.
   Proof.
    intros; eapply Ole_trans; [apply (failure_event H); trivial | ].
    clear H; induction q.
    rewrite sigma_0; trivial.
    rewrite sigma_S, IHn.
    setoid_replace (n */ a) with (2 * n */ [1/2] * a).
    rewrite <- plus_Nmult_distr.
    apply Nmult_le_compat_left.
    match goal with |- _ ?a ?b => replace a with b end; trivial.
    destruct n; simpl; [trivial | rewrite <- minus_n_O; ring].
    rewrite mult_comm, Nmult_mult_assoc, Nmult_Unth_simpl_left; trivial.
   Qed.

  End FEL.

 End TRIPLES.

End Make.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Pierre-Yves Strub, 2009-04-09
- Frederic Blanqui, 2009-11-02 (matches_dom)

Matching algorithm for ATerms.
*)

(**********************************************************************)
From Coq Require Import Peano_dec Bool.
From Coq Require OrderedTypeEx FMapAVL.
From CoLoR Require Import LogicUtil EqUtil NatUtil VecUtil ATerm ASubstitution
  FSetUtil FMapUtil ListUtil.
From CoLoR Require AVariables.

Module VSF := AVariables.VarSetUtil.XSetFacts.
Module VS  := AVariables.XSet.

Module VM := FMapAVL.Make (OrderedTypeEx.Nat_as_OT).
Module VMU := FMapUtil.Make VM.
Module VMF := VMU.XMapFacts.

(**********************************************************************)
Set   Implicit Arguments.
Unset Strict Implicit.

(**********************************************************************)
Section Matching.
  Variable Sig : Signature.

  Notation term      := (@ATerm.term Sig).
  Notation terms     := (@vector term).
  Notation vars      := (@AVariables.vars Sig).
  Notation vars_list := (@AVariables.vars_list Sig).
  Notation vars_vec  := (@AVariables.vars_vec Sig _).

  Notation matching  := (VM.t term) (only parsing).

  Notation beq_term  := (@beq_term Sig).
  Notation beq_terms := (fun x y => beq_vec beq_term x y).

  Notation "x =X y"   := (NatUtil.beq_nat x y) (at level 70, no associativity).
  Notation "f =S g"   := (@beq_symb Sig f g)   (at level 70, no associativity).
  Notation "t =T u"   := (beq_term t u)        (at level 70, no associativity).
  Notation "ts =V us" := (beq_terms ts us)     (at level 70, no associativity).

  Local Coercion is_true b := b = true.
  Local Hint Unfold is_true : core.

  Definition exmatch (m : matching) (x : variable) (t : term) :=
  match VM.find x m with
  | None   => Some (VM.add x t m)
  | Some u => if t =T u then Some m else None
  end.

  Fixpoint matches_r (u t : term) (m : matching) : option matching :=
  match u, t with
  | Var y   , _        => exmatch m y t
  | Fun g us, Fun f ts => if f =S g then Vfold2 m matches_r us ts else None
  | _       , _        => None
  end.

  Notation "\unopt_ ( x ) v" :=
    (match v with Some v' => v' | None => x end)
    (at level 8, v at level 36, x at level 50, format "\unopt_ ( x )  v").

  Definition subst_of_matching (m : matching) :=
    fun (x : variable) => \unopt_(Var x) (VM.find x m).

  Notation "\S ( θ )" := (subst_of_matching θ) (format "\S ( θ )").

  Definition matches (u t : term) :=
  match matches_r u t VM.empty with
  | None   => None
  | Some m => Some \S(m)
  end.

  Notation "t ! θ" := (@sub Sig θ t) (at level 15).

  (********************************************************************)
  Lemma subst_of_matchingE :
    forall x m v, VM.find x m = Some v -> \S(m) x = v.
  Proof.
    by intros x m v H; unfold subst_of_matching; rewrite H.
  Qed.

  (********************************************************************)
  Lemma vmap_eqb : forall x y, VMF.eqb x y = (x =X y).
  Proof.
    intros x y; unfold VMF.eqb; unfold VMF.eq_dec.
    case_eq (eq_nat_dec x y); intros Hxy Hxydep.
      by sym; apply (proj2 (beq_nat_ok x y)).
      case_eq (x =X y); intros Hxyb.
        by elim (Hxy (proj1 (beq_nat_ok x y) Hxyb)).
        refl.
  Qed.

  (********************************************************************)
  (** Induction principle for [matches_r] when result is [Some _] **)
  Section MatchInd.
    Variable P  : term -> term -> matching -> matching -> Prop.
    Variable Ps : forall nt nu,
      terms nt -> terms nu -> matching -> matching -> Prop.

    Hypothesis Hvar :
      forall x t θ θ', exmatch θ x t = Some θ' -> P (Var x) t θ θ'.

    Hypothesis Hfun :
      forall f g ts us θ θ',
           Vfold2 θ matches_r ts us = Some θ'
        -> Ps ts us θ θ'
        -> f = g
        -> P (Fun f ts) (Fun g us) θ θ'.

    Hypothesis Hnil :
      forall θ, Ps Vnil Vnil θ θ.

    Hypothesis Hcns :
      forall t nt (ts : terms nt) u nu (us : terms nu) θ θ' Ω,
           matches_r t u Ω = Some θ'
        -> P t u Ω θ'
        -> Vfold2 θ matches_r ts us = Some Ω
        -> Ps ts us θ Ω
        -> Ps (Vcons t ts) (Vcons u us) θ θ'.

    Notation "\matchesP" :=
      (forall u t θ θ', matches_r u t θ = Some θ' -> P u t θ θ').
    Notation "\matchesPs" :=
      (forall nu (us : terms nu) nt (ts : terms nt) θ θ',
        Vfold2 θ matches_r us ts = Some θ' -> Ps us ts θ θ').

    Lemma matches_some_ind : \matchesP /\ \matchesPs.
    Proof.
      apply term_ind_comb.
      (* var *)
      hyp.
      (* fun *)
      intros g us Hus t θ θ' Hθθ'; destruct t as [y|f ts]; try discr.
      simpl in Hθθ'; case_eq (f =S g); intros Hfg; rewrite Hfg in Hθθ';
        try discr.
      by apply Hfun; auto; rewrite (proj1 beq_symb_ok Hfg).
      (* nil *)
      intros nt ts θ θ'; destruct ts as [|t nt ts]; try discr.
      by inversion_clear 1; apply Hnil.
      (* cons *)
      intros u nu us Hu Hus nt ts θ θ'.
      destruct ts as [|t nt ts]; try discr; simpl Vfold2.
      case_eq (Vfold2 θ matches_r us ts); try discr; intros Ω HθΩ HΩθ'.
      by apply Hcns with Ω; auto.
    Qed.
  End MatchInd.

  (********************************************************************)
  Section VarMin.
    Lemma exmatches_var_min :
      forall y t θ θ', exmatch θ y t = Some θ' ->
        forall x, VM.mem x θ' = VM.mem x θ || (y =X x).
    Proof.
      intros y t θ θ'; unfold exmatch; case_eq (VM.find y θ).
        intros v H; case (t =T v); intros Htu; try discr.
        inversion_clear Htu in H; intros x; case_eq (y =X x); intros Hxy.
          by rewrite <- (proj1 (beq_nat_ok _ _) Hxy), VMF.mem_find_b, H.
          by rewrite orb_false_r.

        intros Hymem H x; inversion_clear H in Hymem; case_eq (y =X x).
          intros Hxy; rewrite (proj1 (beq_nat_ok _ _) Hxy),
            VMF.add_b, orb_comm; unfold VMF.eqb; unfold VMF.eq_dec.
          by rewrite (eq_nat_dec_refl x).
          intros Hxy; rewrite VMF.add_b.
          by rewrite orb_comm, vmap_eqb, Hxy.
    Qed.

    Notation "\matches_var_min" :=
      (forall u t θ θ', matches_r u t θ = Some θ' ->
        forall x, VM.mem x θ' = VM.mem x θ || VS.mem x (vars u)).

    Notation "\nmatches_var_min" :=
      (forall nu (us : terms nu) nt (ts : terms nt) θ θ',
        Vfold2 θ matches_r us ts = Some θ'
        -> forall x, VM.mem x θ' = VM.mem x θ || VS.mem x (vars_vec us)).

    Lemma matches_var_min_comb :  \matches_var_min /\ \nmatches_var_min.
    Proof.
      apply matches_some_ind.
      (* var *)
      simpl; intros y t θ θ' H x.
      by rewrite VSF.singleton_b, vmap_eqb; eapply exmatches_var_min; eauto.
      (* fun *)
      by intros f _ ts _ θ θ' _ H _ x; rewrite AVariables.vars_fun.
      (* nil *)
      by intros θ x; simpl; rewrite VSF.empty_b, orb_false_r.
      (* cons *)
      intros u nu us _ _ _ θ θ' Ω _ HΩθ' _ HθΩ x.
      simpl; rewrite VSF.union_b, (HΩθ' x), (HθΩ x).
      by case (VM.mem x θ); simpl; try rewrite orb_comm.
    Qed.

    Lemma matches_var_minP : \matches_var_min.
    Proof. exact (proj1 matches_var_min_comb). Qed.

    Lemma nmatches_var_minP : \nmatches_var_min.
    Proof. exact (proj2 matches_var_min_comb). Qed.
  End VarMin.

  Lemma matches_var_minadded :
    forall u t m m', matches_r u t m = Some m' ->
      forall x, VM.mem x m = false -> VM.mem x m' -> VS.mem x (vars u).
  Proof.
    intros u t m m' H x Hmem₁ Hmem₂.
    by rewrite (matches_var_minP H) in Hmem₂; rewrite Hmem₁ in Hmem₂.
  Qed.

  (********************************************************************)
  Section MatchMon.
    Lemma exmatch_mon :
      forall θ θ' x t, exmatch θ x t = Some θ' ->
        forall y, VM.mem y θ -> VM.find y θ = VM.find y θ'.
    Proof.
      intros θ θ' x t; unfold exmatch; case_eq (VM.find x θ).
        by intros u H; case (t =T u); intros I; inversion_clear I.

        intros H I; inversion_clear I; intros y Hyθ.
        sym; apply VMF.add_neq_o; intros Hxy; subst y.
        rewrite VMF.mem_find_b in Hyθ; rewrite H in Hyθ.
        discr.
    Qed.

    Notation "\matches_mon" :=
      (forall u t θ θ', matches_r u t θ = Some θ' ->
        forall x, VM.mem x θ -> VM.find x θ = VM.find x θ').

    Notation "\nmatches_mon" :=
      (forall nu (us : terms nu) nt (ts : terms nt) θ θ',
        Vfold2 θ matches_r us ts = Some θ'
        -> forall x, VM.mem x θ -> VM.find x θ = VM.find x θ').

    Lemma matches_mon_comb : \matches_mon /\ \nmatches_mon.
    Proof.
      apply matches_some_ind; auto.
        by intros x t θ θ'; apply exmatch_mon.

        intros _ _ _ _ _ _ θ θ' Ω _ HΩθ' _ HθΩ x Hx.
        trans (VM.find x Ω); [by apply HθΩ | idtac].
        apply HΩθ'; unfold is_true; rewrite <- Hx;
          rewrite !VMF.mem_find_b.
        by rewrite (HθΩ x Hx).
    Qed.

    Lemma matches_monP : \matches_mon.
    Proof. exact (proj1 matches_mon_comb). Qed.

    Lemma nmatches_monP : \nmatches_mon.
    Proof. exact (proj2 matches_mon_comb). Qed.
  End MatchMon.

  (********************************************************************)
  Lemma matches_submon :
    forall u t θ,
      u ! \S(θ) = t ->
      (forall x, VS.mem x (vars u) -> VM.mem x θ) ->
      forall u' t' θ', matches_r u' t' θ = Some θ' -> u ! \S(θ') = t.
  Proof.
    intros u t θ Hsub Hdom u' t' θ' Hθθ'; subst t.
    apply sub_eq; intros x Hx; unfold subst_of_matching.
    rewrite (matches_monP Hθθ'); try refl.
    by apply Hdom; unfold is_true; apply (proj1 (AVariables.in_vars_mem _ _)).
  Qed.

  Lemma nmatches_submon :
    forall nu (us : terms nu) nt (ts : terms nt) θ,
      (Vmap (sub \S(θ)) us) =V ts ->
      (forall x, VS.mem x (vars_vec us) -> VM.mem x θ) ->
      forall u t θ', matches_r u t θ = Some θ' ->
        (Vmap (sub \S(θ')) us) =V ts.
  Proof.
    induction us as [|u nu us IH]; destruct ts as [|t nt ts]; try discr.
    (* nil *)
    intros; refl.
    (* cons *)
    intros θ Heq Hmem u' t' θ' Hθθ'; simpl in Heq |- *.
    elim (proj1 (andb_true_iff _ _) Heq); intros Htu Hts_uts.
    unfold is_true; apply (proj2 (andb_true_iff _ _)); split.
      apply (proj2 (beq_term_ok _ _)); apply matches_submon with θ u' t'.
        by apply (proj1 (beq_term_ok _ _)).
        by intros x Hx; apply Hmem; simpl; rewrite VSF.union_b, Hx, orb_true_l.
        hyp.

      apply IH with θ u' t'; try hyp.
        by intros x Hx; apply Hmem; simpl; rewrite VSF.union_b, Hx, orb_true_r.
  Qed.

  (********************************************************************)
  Section MatchCorrectness.
    Notation "\matches_correct" :=
      (forall u t θ θ', matches_r u t θ = Some θ' -> u ! \S(θ') = t).

    Notation "\nmatches_correct" :=
      (forall nu (us : terms nu) nt (ts : terms nt) θ θ',
        Vfold2 θ matches_r us ts = Some θ' -> (Vmap (sub \S(θ')) us) =V ts).

    Lemma matches_r_correct : \matches_correct /\ \nmatches_correct.
    Proof.
      apply matches_some_ind.
      (* var *)
      intros y u θ θ'; simpl; unfold exmatch; case_eq (VM.find y θ).
        intros v Hv; case_eq (u =T v); intros Htv I;
          inversion_clear I in Hv.
        unfold subst_of_matching; rewrite Hv; simpl.
        by sym; apply (proj1 (beq_term_ok _ _)).
        intros _ I; inversion I as [Hadd]; clear I.
        by unfold subst_of_matching; rewrite VMF.add_eq_o.
      (* fun *)
      intros f g ts us _ θ _ Hveq Hfg.
      apply (proj1 (beq_term_ok _ _)); rewrite sub_fun, beq_fun.
      by rewrite Hveq, andb_true_r; apply (proj2 beq_symb_ok).
      (* nil *)
      intros θ; simpl; refl.
      (* cons *)
      intros t nt ts u nu us θ θ' Ω HΩθ IHΩθ HθΩ IHθΩ; simpl.
      rewrite <- IHΩθ, (beq_refl (@beq_term_ok Sig)), andb_true_l.
      eapply nmatches_submon with Ω t u; try hyp; intros x Hx.
      by unfold is_true; rewrite (nmatches_var_minP HθΩ), Hx, orb_true_r.
    Qed.

    Lemma matches_correct : forall u t θ, matches u t = Some θ -> u ! θ = t.
    Proof.
      intros u t θ; unfold matches.
      case_eq (matches_r u t VM.empty); try discr; intros Ω HΩ.
      inversion_clear 1; apply (proj1 matches_r_correct) with VM.empty.
      hyp.
    Qed.
  End MatchCorrectness.

  (********************************************************************)
  Section MatchCompletness.
    Definition compose (m : matching) (θ : variable -> term) :=
      fun (x : variable) => \unopt_(θ x) (VM.find x m).

    Notation "m ⊕ θ" := (compose m θ) (at level 40, no associativity).

    Lemma composeI : forall x m θ, VM.find x m = None -> (m ⊕ θ) x = θ x.
    Proof.
      by intros x m θ H; unfold compose; rewrite H.
    Qed.

    Lemma composeE : forall x m v θ, VM.find x m = Some v -> (m ⊕ θ) x = v.
    Proof.
      by intros x m v θ Hfind; unfold compose; rewrite Hfind.
    Qed.

    Notation "\matches_complete" :=
      (forall u t m, (exists θ, u ! (m ⊕ θ) = t) -> matches_r u t m <> None).

    Notation "\nmatches_complete" :=
      (forall nu (us : terms nu) nt (ts : terms nt) m,
        (exists θ, (Vmap (sub (m ⊕ θ)) us) =V ts) ->
        Vfold2 m matches_r us ts <> None).

    Lemma matches_extend_compatP :
      forall u t m m', matches_r u t m = Some m' ->
        forall θ, u ! (m ⊕ θ) = t -> forall x, (m ⊕ θ) x = (m' ⊕ θ) x.
    Proof.
      intros u t m m' H θ Hθ x; unfold compose.
      case_eq (VM.find x m); case_eq (VM.find x m').
        (* some/some*)
        intros v₂ Hv₂ v₁ Hv₁; rewrite <- (matches_monP H) in Hv₂.
        congruence. by rewrite VMF.mem_find_b, Hv₁.
        (* none/some *)
        intros Hm' v Hv; rewrite <- (matches_monP H) in Hm'.
        congruence. by rewrite VMF.mem_find_b, Hv.
        (* some/none *)
        intros v Hv Hm; rewrite <- (composeI θ Hm).
        rewrite <- (subst_of_matchingE Hv).
        apply subeq_inversion with u.
          by rewrite (proj1 matches_r_correct _ _ _ _ H).
          apply (proj2 (AVariables.in_vars_mem _ _)).
          apply (matches_var_minadded H); rewrite VMF.mem_find_b.
          by rewrite Hm. by rewrite Hv.
        (* none/none *)
        refl.
    Qed.

    Lemma nmatches_extend_compatP :
      forall nu (us : terms nu) nt (ts : terms nt) m m',
        Vfold2 m matches_r us ts = Some m' ->
        forall θ, Vmap (sub (m ⊕ θ)) us =V ts ->
          forall x, (m ⊕ θ) x = (m' ⊕ θ) x.
    Proof.
      induction us as [|u nu us IH]; destruct ts as [|t nt ts];
        intros m₁ m₂; try discr.
        (* nil/nil *)
        by simpl; intros H; inversion_clear H.
        (* some/some *)
        simpl; case_eq (Vfold2 m₁ matches_r us ts); try discr.
        intros m H₁ H₂ θ H x; elim (proj1 (andb_true_iff _ _) H).
        intros Hu Hus; trans ((m ⊕ θ) x).
          by apply (IH _ _ _ _ H₁).

          apply (matches_extend_compatP H₂).
          rewrite <- (proj1 (beq_term_ok _ _) Hu).
          by apply sub_eq; intros y _; sym; apply (IH _ _ _ _ H₁).
    Qed.

    Lemma matches_r_complete : \matches_complete /\ \nmatches_complete.
    Proof.
      apply term_ind_comb.
        (* var *)
        intros x t m H; elim H; simpl; unfold compose.
        case_eq (VM.find x m);
          [intros mx Hfind _ Ht | intros Hfind _ _];
          unfold exmatch; rewrite Hfind; try done.
        by rewrite (proj2 (beq_term_ok _ _) (sym_eq Ht)); discr.

        (* fun *)
        intros g us IH t m H; destruct t as [x|f nt];
          elim H; intros θ Hθ; rewrite sub_fun in Hθ; try discr.
        inversion_clear Hθ; simpl; rewrite (beq_refl (@beq_symb_ok Sig)).
        apply IH; exists θ; rewrite beq_vec_refl; try done.
        by apply beq_term_ok.

        (* nil *)
        destruct ts as [|t nt ts]; intros m H; simpl.
          by discr.
          by elim H; intros θ Hθ; simpl in Hθ.

        (* cons *)
        intros u nu us IH IHs; destruct ts as [|t nt ts]; intros m H.
          by elim H; intros θ Hθ; simpl in Hθ.

          elim H; intros θ Hθ; simpl in Hθ.
          case (proj1 (andb_true_iff _ _) Hθ); intros Hu Hus.
          simpl; case_eq (Vfold2 m matches_r us ts).
            intros m' Hm'; apply IH; exists θ.
            rewrite <- (proj1 (beq_term_ok _ _) Hu).
            apply sub_eq; intros x _; sym.
            by apply nmatches_extend_compatP with _ us _ ts.

            intros Hfold _; eapply IHs; [idtac | ehyp].
            by exists θ.
    Qed.

    Lemma matches_complete :
      forall u t θ, u!θ = t -> matches u t <> None.
    Proof.
      intros u t θ H; unfold matches.
      case_eq (matches_r u t VM.empty).
        by intros; discr.
        intros Habd _; eapply (proj1 matches_r_complete); [idtac|ehyp].
        exists θ; rewrite <- H; apply sub_eq; intros x _.
        by unfold compose; rewrite VMF.empty_o.
    Qed.

    Lemma matches_complete_ext :
      forall u t θ, u!θ = t ->
        exists Ω,
          (  matches u t = Some Ω
          /\ forall x, VS.mem x (vars u) -> θ x = Ω x).
    Proof.
      intros u t θ H; case_eq (matches u t).
        intros Ω HΩ; exists Ω; split; [refl | idtac].
        intros x Hxu; apply subeq_inversion with u.
          by rewrite H; sym; apply matches_correct.
          by apply (proj2 (AVariables.in_vars_mem _ _)).
        intros Habs; elim (matches_complete H Habs).
    Qed.
  End MatchCompletness.

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

  Lemma matches_r_dom : forall u t m m' x, matches_r u t m = Some m' ->
    ~In x (ATerm.vars u) -> VM.mem x m' = VM.mem x m.
  Proof.
    cut ((forall u t m m', matches_r u t m = Some m' ->
    forall x, ~In x (ATerm.vars u) -> VM.mem x m' = VM.mem x m)
    /\ (forall nu (us : terms nu) nt (ts : terms nt) m m',
      Vfold2 m matches_r us ts = Some m' ->
      forall x, ~In x (ATerm.vars_vec us) -> VM.mem x m' = VM.mem x m)).
    intuition. eapply H0. apply H. hyp. apply matches_some_ind.
    (* Var *)
    simpl. intuition. unfold exmatch in H.
    destruct (VM.find (elt:=term) x θ).
    revert H. case (beq_term t t0); intro. inversion H. refl. discr.
    inversion H. rewrite VMF.add_b. rewrite vmap_eqb. change (x<>x0) in H1.
    rewrite <- (beq_ko beq_nat_ok) in H1. rewrite H1. refl.
    (* Fun *)
    intros. apply H0. rewrite vars_fun in H2. hyp.
    (* Vnil *)
    refl.
    (* Vcons *)
    simpl. intros. rewrite notin_app in H3. destruct H3.
    trans (VM.mem (elt:=term) x Ω). apply H0. hyp. apply H2. hyp.
  Qed.

  Lemma matches_dom : forall u t s x,
    matches u t = Some s -> ~In x (ATerm.vars u) -> s x = Var x.
  Proof.
    intros u t s x. unfold matches.
    case_eq (matches_r u t VM.empty).
    intros t0 H H0 H1. inversion H0.
    ded (matches_r_dom H H1). rewrite VMF.empty_a in H2.
    unfold subst_of_matching. revert H2. rewrite VMF.mem_find_b.
    destruct (VM.find x t0). discr. refl. discr.
  Qed.

End Matching.


(*  This file contains structural lemmas about well-formedness of annotated
    phrases and their ranges, associated automation, the `events` relation
    --a denotational semantics for phrase events, and lemmas/automation related
    to `events` *)

Require Import Defs Eqb_Evidence.
Require Import Preamble More_lists StructTactics.

Require Import Compare_dec Coq.Program.Tactics.
Require Import PeanoNat.

Require Import Lia.

Require Import List.
Import List.ListNotations.

Require Export Term_Defs Anno_Term_Defs.

(*
Set Nested Proofs Allowed.
*)

Lemma wfr_lseq_pieces: forall r t1 t2,
    well_formed_r_annt (alseq r t1 t2) ->
    well_formed_r_annt t1 /\ well_formed_r_annt t2.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Lemma wfr_at_pieces: forall t r p,
    well_formed_r_annt (aatt r p t) ->
    well_formed_r_annt t.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Lemma wfr_bseq_pieces: forall r s t1 t2,
    well_formed_r_annt (abseq r s t1 t2) ->
    well_formed_r_annt t1 /\ well_formed_r_annt t2.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Lemma wfr_bpar_pieces: forall r s t1 t2,
    well_formed_r_annt (abpar r s t1 t2) ->
    well_formed_r_annt t1 /\ well_formed_r_annt t2.
Proof.
  intros.
  inversion H.
  tauto.
Defined.

Ltac do_wf_pieces :=
  match goal with
  | [H: well_formed_r_annt (alseq _ _ _ ) |- _] =>
    (edestruct wfr_lseq_pieces; eauto)
  | [H: well_formed_r_annt (aatt _ _?t) |- _] =>
    assert (well_formed_r_annt t)
      by (eapply wfr_at_pieces; eauto)
  | [H: well_formed_r_annt (abseq _ _ _ _) |- _] =>
    (edestruct wfr_bseq_pieces; eauto)
  | [H: well_formed_r_annt (abpar _ _ _ _) |- _] =>
    (edestruct wfr_bpar_pieces; eauto)
  end.

Lemma well_formed_range_r:
  forall t,
    well_formed_r_annt t ->
    snd (range t) = fst (range t) + esize t.
Proof.
    induction t;
    try (intros H; simpl; inv H; simpl;
         repeat find_apply_hyp_hyp; lia).
Defined.

Lemma esize_nonempty: forall t, esize t > 0.
Proof.
  intros.
  induction t; intros;
    try (destruct a);
    (cbn; lia).
Defined.

Lemma wf_mono: forall t,
    well_formed_r_annt t ->
    snd (range t) > fst (range t).
Proof.
  intros.
  rewrite well_formed_range_r.
  pose (esize_nonempty t).
  lia.
  eauto.
Defined.

Ltac do_mono :=
  (* let asdff := eapply anno_mono; eauto in *)
  match goal with
  | [H: anno _ ?x _ _ = Some (?y,_) |- _] => assert_new_proof_by (y > x) ltac:(eapply anno_mono; eauto)
  end.

Lemma asp_lrange_irrel: forall a i a0 a1 n n',
    anno (asp a) i = (n, a0) ->
    anno (asp a) i = (n',a1) ->
    a0 = a1.
Proof.
  intros.
  destruct a; ff.
Defined.

(** This predicate specifies when a term, a place, and some initial
    evidence is related to an event.  In other words, it specifies the
    set of events associated with a term, a place, and some initial
    evidence. *)

Inductive events: AnnoTerm -> Plc -> Evidence -> Ev -> Prop :=
| evtsnull:
    forall r i p e,
      fst r = i ->
      events (aasp r NULL) p e (null i p)
| evtscpy:
    forall r i p e,
      fst r = i ->
      events (aasp r CPY) p e (copy i p)
| evtsusm:
    forall i r p e sp fwd ps,
      fst r = i ->
      events (aasp r (ASPC sp fwd ps)) p e (umeas i p ps (sp_ev sp e))
| evtssig:
    forall r i p e,
      fst r = i ->
      events (aasp r SIG) p e (umeas i p sig_params e) (* (sign i p e) *)
| evtshsh:
    forall r i p e,
      fst r = i ->
      events (aasp r HSH) p e (umeas i p hsh_params e) (* (hash i p e) *)
| evtsenc:
    forall r i p q e,
      fst r = i ->
      events (aasp r (ENC q)) p e (umeas i p (enc_params q) e) (* (hash i p e) *)
| evtsattreq:
    forall r q t i p e,
      fst r = i ->
      events (aatt r q t) p e (req i p q (unanno t) e)
| evtsatt:
    forall r q t ev p e,
      events t q e ev ->
      events (aatt r q t) p e ev
| evtsattrpy:
    forall r q t i p e,
      snd r = S i ->
      events (aatt r q t) p e (rpy i p q (aeval t q e))
| evtslseql:
    forall r t1 t2 ev p e,
      events t1 p e ev ->
      events (alseq r t1 t2) p e ev
| evtslseqr:
    forall r t1 t2 ev p e,
      events t2 p (aeval t1 p e) ev ->
      events (alseq r t1 t2) p e ev

| evtsbseqsplit:
    forall r i s e t1 t2 p,
      fst r = i ->
      events (abseq r s t1 t2) p e (Term_Defs.split i p)
| evtsbseql:
    forall r s e t1 t2 ev p,
      events t1 p (splitEv_T_l s e) ev ->
      events (abseq r s t1 t2) p e ev
| evtsbseqr:
    forall r s e t1 t2 ev p,
      events t2 p (splitEv_T_r s e) ev ->
      events (abseq r s t1 t2) p e ev
| evtsbseqjoin:
    forall r i s e t1 t2 p,
      snd r = S i ->
      events (abseq r s t1 t2) p e (join i p)

| evtsbparsplit:
    forall r i s e t1 t2 p,
      fst r = i ->
      events (abpar r s t1 t2) p e
             (Term_Defs.split i p)
| evtsbparl:
    forall r s e t1 t2 ev p,
      events t1 p (splitEv_T_l s e) ev ->
      events (abpar r s t1 t2) p e ev
| evtsbparr:
    forall r s e t1 t2 ev p,
      events t2 p (splitEv_T_r s e) ev ->
      events (abpar r s t1 t2) p e ev
| evtsbparjoin:
    forall r i s e t1 t2 p,
      snd r = S i ->
      events (abpar r s t1 t2) p e
             (join i  p).
#[export] Hint Constructors events : core.

Ltac inv_events :=
  match goal with
  | [H:events (?C _) _ _ _ |- _] => inv H
  end.

Ltac inv_wfr :=
  match goal with
  | [H: well_formed_r_annt _ |- _] => inv H
  end.

Lemma events_range:
  forall t v p e,
    well_formed_r_annt t ->
    events t p e v ->
    fst (range t) <= ev v < snd (range t).
Proof.
  intros t v p e H H0.
  pose proof H as G.
  apply well_formed_range_r in G.
  rewrite G.
  clear G.
  induction H0;
    try (inv_wfr; simpl in *; auto;
         repeat find_apply_hyp_hyp;
         repeat (find_apply_lem_hyp well_formed_range_r); lia).
Defined.

Lemma at_range:
  forall x r i,
    S (fst r) = fst x ->
    snd r = S (snd x) ->
    fst r <= i < snd r ->
    i = fst r \/
    fst x <= i < snd x \/
    i = snd x.
Proof.
  intros.
  pose proof lt_dec i (S (fst r)) as G.
  destruct G as [G|G]; [left; lia| right].
  pose proof lt_dec i (snd x) as F.
  destruct F as [F|F]; [left; lia| right].
  lia.
Qed.

Lemma lin_range:
  forall x y i,
    snd x = fst y ->
    fst x <= i < snd y ->
    fst x <= i < snd x \/
    fst y <= i < snd y.
Proof.
  intros.
  pose proof lt_dec i (snd x) as G.
  destruct G; lia.
Qed.

Lemma bra_range:
  forall x y r i,
    S (fst r) = fst x ->
    snd x = fst y ->
    snd r = S (snd y) ->
    fst r <= i < snd r ->
    i = fst r \/
    fst x <= i < snd x \/
    fst y <= i < snd y \/
    i = snd y.
Proof.
  intros.
  pose proof lt_dec i (S (fst r)) as G.
  destruct G as [G|G]; [left; lia| right].
  pose proof lt_dec i (snd x) as F.
  destruct F as [F|F]; [left; lia| right].
  pose proof lt_dec i (snd y) as E.
  destruct E; lia.
Qed.

Ltac dest_range :=
  match goal with
  | [H: (nat * nat) |- _] => destruct H
  end.

Ltac do_lin_range :=
  match goal with
  | [H: snd _ = fst _,
        H': fst _ <= ?n < snd _
     |- _] =>
    apply lin_range with (i:=n) in H; eauto
  end.

Ltac do_bra_range :=
  match goal with
  | [H: snd _ = fst _,
        H': fst ?x <= ?n < snd ?x
     |- _] =>
    apply bra_range with (i:=n) (r:=x) in H; eauto
  end.

(** Properties of events. *)

Lemma events_range_event:
  forall t p i e,
    well_formed_r_annt t ->
    fst (range t) <= i < snd (range t) ->
    exists v, events t p e v /\ ev v = i.
Proof.
  intros t p i e H; revert i; revert p; revert e.
  induction H; intros; simpl in *.
  - destruct x; try destruct a; eapply ex_intro; split; auto;
      (*destruct r as [j k];*) simpl in *; try lia.
    (*
    + admit.
    + *)

  - find_eapply_lem_hyp at_range; eauto.
    repeat destruct_disjunct; subst; eauto.
    (* + eapply ex_intro; split; auto. *)

    find_eapply_hyp_hyp.
    (*apply IHwell_formed with (p:=p) in H2. *)
    destruct_conjs.
    eauto.
  -
    do_lin_range;
      eauto;
      repeat destruct_disjunct;
      try lia;
      try (find_eapply_hyp_hyp; eauto;
           destruct_conjs;
           eauto).
  -
    do_bra_range;
      eauto;
      repeat destruct_disjunct; subst;
        try lia;
        try (find_eapply_hyp_hyp; eauto;
             destruct_conjs;
             eauto; tauto).

    + eapply ex_intro; split; try (auto; eauto;tauto).
    + eapply ex_intro; split; try (eauto; auto; tauto).

  -
    do_bra_range;
      eauto;
      repeat destruct_disjunct; subst;
        try lia;
        try (find_eapply_hyp_hyp; eauto;
             destruct_conjs;
             eauto; tauto).

    + eapply ex_intro; split; auto.
    + eapply ex_intro; split; eauto.
Qed.

Ltac events_event_range :=
  repeat match goal with
         | [ H: events _ _ _ _ |- _ ] =>
           apply events_range in H; auto
         end; lia.

Ltac aba :=
  match goal with
  | [H: events _ _ _ _, H': events _ _ _ _ |- _] => inv H; inv H'
  end.

Ltac wfr :=
  match goal with
  | [H': well_formed_r_annt ?HH |- _] => pose_new_proof (well_formed_range_r HH H')
  end.

Lemma events_injective:
  forall t p e v1 v2,
    well_formed_r_annt t ->
    events t p e v1 ->
    events t p e v2 ->
    ev v1 = ev v2 ->
    v1 = v2.
Proof.
  intros.
  generalizeEverythingElse H.
  induction H; intros;
    try (
        repeat wfr;
        aba; simpl in *; subst; auto;
        try (events_event_range; tauto);
        try (find_eapply_hyp_hyp; eauto);
        eauto).
Qed.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_tacs.
Require Export sequents_equality.

Lemma lsubstc_mk_void {o} :
  forall w s c, @lsubstc o mk_void w s c = mkc_void.
Proof.
  introv; apply cterm_eq; simpl.
  unfold csubst; unflsubst; simpl; autorewrite with slow; auto.
Qed.
Hint Rewrite @lsubstc_mk_void : slow.

Lemma void_in_uni {p} :
  forall lib i, @member p lib mkc_void (mkc_uni i).
Proof.
  introv.
  rewrite mkc_void_eq_mkc_false.
  rw @mkc_false_eq.
  apply mkc_approx_equality_in_uni; tcsp.
Qed.
Hint Resolve void_in_uni : slow.

(*
   H |- Void = Void in Type(i)

     By voidEquality
 *)
Definition rule_void_equality {o}
           (H : @bhyps o)
           (i : nat) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_member mk_void (mk_uni i))))
    []
    [].

Lemma rule_void_equality_true3 {o} :
  forall lib (H : @bhyps o) (i : nat),
    rule_true3 lib (rule_void_equality H i).
Proof.
  intros.
  unfold rule_void_equality, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs hyps.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destseq; allsimpl; proof_irr; GC.

  assert (wf_csequent (H) ||- (mk_conclax (mk_member mk_void (mk_uni i)))) as wfc.
  { unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  pose proof (teq_and_member_if_member lib (mk_uni i) mk_void s1 s2 H wT wt ct ct0 cT cT0) as q.
  rw <- @member_member_iff.
  lsubst_tac.
  autorewrite with slow in *.
  apply q; auto.
  { apply tequality_mkc_uni. }
  clear dependent s1; clear dependent s2.
  introv hf sim.
  lsubst_tac; autorewrite with slow.
  apply void_in_uni.
Qed.

(*
   H, x : Void, J |- C

     By voidElimination
 *)
Definition rule_void_elimination {o}
           (H J : @bhyps o)
           (C : NTerm)
           (x : NVar) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x mk_void) ++ J) (mk_conclax C))
    []
    [].

Lemma rule_void_elimination_true {o} :
  forall lib (H J : @bhyps o) C x,
    rule_true lib (rule_void_elimination H J C x).
Proof.
  intros.
  unfold rule_void_elimination, rule_true, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs hyps.

  (* We prove the well-formedness of things *)
  destseq; allsimpl; proof_irr; GC.

  assert (closed_extract (snoc H (mk_hyp x mk_void) ++ J) (mk_conclax C)) as ce.
  { unfold closed_extract; simpl; apply covered_axiom. }

  exists ce.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  clear eqh.
  apply similarity_app in sim; exrepnd; subst.
  apply similarity_snoc in sim5; exrepnd; subst; allsimpl.
  autorewrite with slow in *.
  apply equality_in_void in sim2; tcsp.
Qed.