From mathcomp
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From fcsl
Require Import pred.
From scilla
Require Import Automata2.
From scilla
Require Import options.

Section Crowdfunding.
(* Encoding of the Crowdfunding contract from the Scilla whitepaper *)

(******************************************************
contract Crowdfunding
 (owner     : address,
  max_block : uint,
  goal      : uint)

(* Mutable state description *)
{
  backers : address => uint = [];
  funded  : boolean = false;
}

(* Transition 1: Donating money *)
transition Donate
  (sender : address, value : uint, tag : string)
  (* Simple filter identifying this transition *)
  if tag == "donate" =>

  bs <- & backers;
  blk <- && block_number;
  let nxt_block = blk + 1 in
  if max_block <= nxt_block
  then send (<to -> sender, amount -> 0,
	      tag -> main,
	      msg -> "deadline_passed">, MT)
  else
    if not (contains(bs, sender))
    then let bs1 = put(sbs, ender, value) in
         backers := bs1;
         send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "ok">, MT)
    else send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "already_donated">, MT)

(* Transition 2: Sending the funds to the owner *)
transition GetFunds
  (sender : address, value : uint, tag : string)
  (* Only the owner can get the money back *)
  if (tag == "getfunds") && (sender == owner) =>
  blk <- && block_number;
  bal <- & balance;
  if max_block < blk
  then if goal <= bal
       then funded := true;
            send (<to -> owner, amount -> bal,
                   tag -> "main", msg -> "funded">, MT)
       else send (<to -> owner, amount -> 0,
                   tag -> "main", msg -> "failed">, MT)
  else send (<to -> owner, amount -> 0, tag -> "main",
   	      msg -> "too_early_to_claim_funds">, MT)

(* Transition 3: Reclaim funds by a backer *)
transition Claim
  (sender : address, value : uint, tag : string)
  if tag == "claim" =>
  blk <- && block_number;
  if blk <= max_block
  then send (<to -> sender, amount -> 0, tag -> "main",
              msg -> "too_early_to_reclaim">, MT)
  else bs <- & backers;
       bal <- & balance;
       if (not (contains(bs, sender))) || funded ||
          goal <= bal
       then send (<to -> sender, amount -> 0,
                   tag -> "main",
	           msg -> "cannot_refund">, MT)
       else
       let v = get(bs, sender) in
       backers := remove(bs, sender);
       send (<to -> sender, amount -> v, tag -> "main",
              msg -> "here_is_your_money">, MT)

 *******************************************************)

Record crowdState := CS {
   owner_mb_goal : address * nat * value;
   backers : seq (address * value);
   funded : bool;
}.

(* Administrative setters/getters *)
Definition get_owner cs : address := (owner_mb_goal cs).1.1.
Definition get_goal cs : value := (owner_mb_goal cs).2.
Definition get_max_block cs : nat := (owner_mb_goal cs).1.2.

Definition set_backers cs bs : crowdState :=
  CS (owner_mb_goal cs) bs (funded cs).

Definition set_funded cs f : crowdState :=
  CS (owner_mb_goal cs) (backers cs) f.

(* Parameters *)
Variable init_owner : address.
Variable init_max_block : nat.
Variable init_goal : value.

(* Initial state *)
Definition init_state := CS (init_owner, init_max_block, init_max_block) [::] false.

(*********************************************************)
(********************* Transitions ***********************)
(*********************************************************)

(* Transition 1 *)
(*
transition Donate
  (sender : address, value : uint, tag : string)
  (* Simple filter identifying this transition *)
  if tag == "donate" =>

  bs <- & backers;
  blk <- && block_number;
  let nxt_block = blk + 1 in
  if max_block <= nxt_block
  then send (<to -> sender, amount -> 0,
	      tag -> main,
	      msg -> "deadline_passed">, MT)
  else
    if not (contains(bs, sender))
    then let bs1 = put(sbs, ender, value) in
         backers := bs1;
         send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "ok">, MT)
    else send (<to -> sender,
                amount -> 0,
	        tag -> "main",
	        msg -> "already_donated">, MT)
 *)

(* Definition of the protocol *)
Variable crowd_addr : address.

Notation tft := (trans_fun_type crowdState).
Definition ok_msg := [:: (0, [:: 1])].
Definition no_msg := [:: (0, [:: 0])].

Definition donate_tag := 1.
Definition donate_fun : tft := fun id bal s m bc =>
  if method m == donate_tag then
    let bs := backers s in
    let nxt_block := block_num bc + 1 in
    let from := sender m in
    if get_max_block s <= nxt_block
    then (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else if all [pred e | e.1 != from] bs
         (* new backer *)
         then let bs' := (from, val m) :: bs in
              let s'  := set_backers s bs' in
              (s', Some (Msg 0 crowd_addr from 0 ok_msg))
         else (s, Some (Msg 0 crowd_addr from 0 no_msg))
  else (s, None).

Definition donate := CTrans donate_tag donate_fun.

(* Transition 2: Sending the funds to the owner *)
(*
transition GetFunds
  (sender : address, value : uint, tag : string)
  (* Only the owner can get the money back *)
  if (tag == "getfunds") && (sender == owner) =>
  blk <- && block_number;
  bal <- & balance;
  if max_block < blk
  then if goal <= bal
       then funded := true;
            send (<to -> owner, amount -> bal,
                   tag -> "main", msg -> "funded">, MT)
       else send (<to -> owner, amount -> 0,
                   tag -> "main", msg -> "failed">, MT)
  else send (<to -> owner, amount -> 0, tag -> "main",
   	      msg -> "too_early_to_claim_funds">, MT)
 *)

Definition getfunds_tag := 2.
Definition getfunds_fun : tft := fun id bal s m bc =>
  let: from := sender m in
  if (method m == getfunds_tag) && (from == (get_owner s)) then
    let blk := block_num bc + 1 in
    if (get_max_block s < blk)
    then if get_goal s <= bal
         then let s' := set_funded s true in
              (s', Some (Msg bal crowd_addr from 0 ok_msg))
         else (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else (s, Some (Msg 0 crowd_addr from 0 no_msg))
  else (s, None).

Definition get_funds := CTrans getfunds_tag getfunds_fun.

(* Transition 3: Reclaim funds by a backer *)
(*
transition Claim
  (sender : address, value : uint, tag : string)
  if tag == "claim" =>
  blk <- && block_number;
  if blk <= max_block
  then send (<to -> sender, amount -> 0, tag -> "main",
              msg -> "too_early_to_reclaim">, MT)
  else bs <- & backers;
       bal <- & balance;
       if (not (contains(bs, sender))) || funded ||
          goal <= bal
       then send (<to -> sender, amount -> 0,
                   tag -> "main",
	           msg -> "cannot_refund">, MT)
       else
       let v = get(bs, sender) in
       backers := remove(bs, sender);
       send (<to -> sender, amount -> v, tag -> "main",
              msg -> "here_is_your_money">, MT)
*)

Definition claim_tag := 3.
Definition claim_fun : tft := fun id bal s m bc =>
  let: from := sender m in
  if method m == claim_tag then
    let blk := block_num bc in
    if blk <= get_max_block s
    then
      (* Too early! *)
      (s, Some (Msg 0 crowd_addr from 0 no_msg))
    else let bs := backers s in
         if [|| funded s | get_goal s <= bal]
         (* Cannot reimburse: campaign suceeded *)
         then (s, Some (Msg 0 crowd_addr from 0 no_msg))
         else let n := seq.find [pred e | e.1 == from] bs in
              if n < size bs
              then let v := nth 0 (map snd bs) n in
                   let bs' := filter [pred e | e.1 != from] bs in
                   let s'  := set_backers s bs' in
                   (s', Some (Msg v crowd_addr from 0 ok_msg))
              else
                (* Didn't back or already claimed *)
                (s, None)
  else (s, None).

Definition claim := CTrans claim_tag claim_fun.

Program Definition crowd_prot : Protocol crowdState :=
  @CProt _ crowd_addr 0 init_state [:: donate; get_funds; claim] _.

Lemma crowd_tags : tags crowd_prot = [:: 1; 2; 3].
Proof. by []. Qed.

Lemma find_leq {A : eqType} (p : pred (A * nat)) (bs : seq (A * nat)) :
  nth 0 [seq i.2 | i <- bs] (seq.find p bs) <= sumn [seq i.2 | i <- bs].
Proof.
elim: bs=>//[[a w]]bs/=Gi; case:ifP=>_/=; first by rewrite leq_addr.
by rewrite (leq_trans Gi (leq_addl w _)).
Qed.

(***********************************************************)
(**             Correctness properties                    **)
(***********************************************************)

(************************************************************************

1. The contract always has sufficient balance to reimburse everyone,
unless it's successfully finished its campaign:

The "funded" flag is set only if the campaign goals were reached, then
all money goes to owner. Otherwise, the contract keeps all its money
intact.

Perhaps, we should make it stronger, adding a temporal property that
one's reimbursement doesn't change.

************************************************************************)

Definition balance_backed (st: cstate crowdState) : Prop :=
  (* If the campaign not funded... *)
  ~~ (funded (state st)) ->
  (* the contract has enough funds to reimburse everyone. *)
  sumn (map snd (backers (state st))) <= balance st.

Lemma sufficient_funds_safe : safe crowd_prot balance_backed.
Proof.
apply: safe_ind=>[|[id bal s]bc m M Hi]//.
rewrite crowd_tags !inE in M.
(* Get the exact transitions and start struggling... *)
rewrite /= /apply_prot; case/orP: M; [|case/orP]=>/eqP M; rewrite M/=.

(* Donate transition *)
rewrite /donate_fun M eqxx.
case: ifP=>/=_; [move=> {}/Hi Hi|].
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>/=_; move=> {}/Hi Hi; last first.
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
by rewrite subn0 /balance_backed/= in Hi *; rewrite addnC leq_add2r.

(* Get funds transition. *)
rewrite /getfunds_fun M eqxx.
case: ifP=>//=_; case:ifP=>//=_;[|move=> {}/Hi Hi]; last first.
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>//=_; move=> {}/Hi Hi.
by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).

(* Claim funds back *)
rewrite /claim_fun M eqxx.
case: ifP=>//=_; [move=> {}/Hi Hi|].
- by rewrite subn0; apply: (leq_trans Hi (leq_addr (val m) bal)).
case: ifP=>//=X.
- case/orP: X; first by rewrite /balance_backed/==>->.
  by move=>_/Hi Z; rewrite subn0; apply: (leq_trans Z (leq_addr (val m) bal)).
case: ifP=>//=G/=; move=> {}/Hi /= Hi.
rewrite addnC.
have H1: nth 0 [seq i.2 | i <- backers s]
             (seq.find [pred e | e.1 == sender m] (backers s)) <=
         sumn [seq i.2 | i <- backers s] by apply: find_leq.
move: (leq_trans H1 Hi)=> H2.
rewrite -(addnBA _ H2); clear H2.
suff H3: sumn [seq i.2 | i <- backers s & [pred e | e.1 != sender m] i] <=
         bal - nth 0 [seq i.2 | i <- backers s]
                   (seq.find [pred e | e.1 == sender m] (backers s)).
- by apply: (leq_trans H3 (leq_addl (val m) _ )).
clear M.
suff H2: sumn [seq i.2 | i <- backers s & [pred e | e.1 != sender m] i] <=
         sumn [seq i.2 | i <- backers s] -
         nth 0 [seq i.2 | i <- backers s] (seq.find [pred e | e.1 == sender m] (backers s)).
- by apply: (leq_trans H2); apply: leq_sub.
clear Hi H1 X G bc bal id crowd_addr init_goal init_max_block init_owner.
move: (backers s)=>bs{s}.
elim:bs=>//[[a v]] bs/= Hi/=; case:ifP; last first.
- move/negbT; case: ifP=>//= _ _; rewrite addnC -addnBA//subnn addn0.
  clear Hi; elim: bs=>//={a v}[[a v]]bs/=.
  case:ifP=>//=_ H; first by rewrite leq_add2l.
  by rewrite (leq_trans H (leq_addl _ _)).
move/negbTE=>->/={a}; rewrite -(leq_add2l v) in Hi.
by rewrite addnBA in Hi; last by apply: find_leq.
Qed.

(***********************************************************************)
(******           Proving temporal properties                     ******)
(***********************************************************************)

(* Contribution of backer b is d is recorded in the `backers` *)
Definition donated b (d : value) st :=
  (filter [pred e | e.1 == b] (backers (state st))) == [:: (b, d)].

(* b doesn't claim its funding back *)
Definition no_claims_from b (q : bstate * message) := sender q.2 != b.

(************************************************************************

2. The following lemma shows that the donation record is going to be
preserved by the protocol since the moment it's been contributed, as
long, as no messages from the corresponding backer b is sent to the
contract. This guarantees that the contract doesn't "drop" the record
about someone's donations.

In conjunctions with sufficient_funds_safe (proved above) this
guarantees that, if the campaign isn't funded, there is always a
necessary amount on the balance to reimburse each backer, in the case
of failure of the campaign.

************************************************************************)

Lemma donation_preserved (b : address) (d : value):
  since_as_long crowd_prot (donated b d)
                (fun _ s' => donated b d s') (no_claims_from b).
Proof.
(* This is where we would need a temporal logic, but, well.. *)
(* Let's prove it out of the definition. *)
elim=>[|[bc m] sc Hi]st st' P R; first by rewrite /reachable'=>/=Z; subst st'.
rewrite /reachable'/==>E.
apply: (Hi (post (step_prot crowd_prot st bc m))); last 2 first; clear Hi.
- by move=>q; move:(R q)=>{R}-R G; apply: R; apply/In_cons; right.
- rewrite E; set st1 := (step_prot crowd_prot st bc m); clear E R P.
  by case: sc st1=>//=[[bc' m']] sc st1/=.
clear E.
have N: sender m != b.
- suff B: no_claims_from b (bc, m) by [].
  by apply: R; apply/In_cons; left.
case M: (method m \in tags crowd_prot); last first.
- by move/negbT: M=>M; rewrite (bad_tag_step bc st M).
case: st P=>id a s; rewrite /donated/==>D.
case/orP: M; [|case/orP;[| rewrite orbC]]=>/eqP T;
rewrite /apply_prot T/=.
- rewrite /donate_fun T/=; case: ifP=>//_; case: ifP=>//_/=.
  by move/negbTE: N=>->.
- by rewrite /getfunds_fun T/=; case: ifP=>//_; case: ifP=>//_; case:ifP.
rewrite /claim_fun T/=; case:ifP=>//_; case: ifP=>//_; case: ifP=>//=X.
rewrite -filter_predI/=; move/eqP:D=><-; apply/eqP.
elim: (backers s)=>//=x xs Hi; rewrite Hi; clear Hi.
case B: (x.1 == b)=>//=.
by move/eqP: B=>?; subst b; move/negbTE: N; rewrite eq_sym=>/negbT=>->.
Qed.

(************************************************************************

3. The final property: if the campaign has failed (goal hasn't been
reached and the deadline has passed), every registered backer can get
its donation back.

TODO: formulate and prove it.

************************************************************************)

Lemma can_claim_back b d st bc:
  (* We have donated, so the contract holds that state *)
  donated b d st ->
  (* Not funded *)
  ~~(funded (state st)) ->
  (* Balance is small: not reached the goal *)
  balance st < (get_goal (state st)) ->
  (* Block number exceeds the set number *)
  get_max_block (state st) < block_num bc ->
  (* Can emit message from b *)
  exists (m : message),
    sender m == b /\
    out (step_prot crowd_prot st bc m) = Some (Msg d crowd_addr b 0 ok_msg).
Proof.
move=>D Nf Nb Nm.
exists (Msg 0 b crowd_addr claim_tag [::]); split=>//.
rewrite /step_prot.
case: st D Nf Nb Nm =>id bal s/= D Nf Nb Nm.
rewrite /apply_prot/=/claim_fun/=leqNgt Nm/= leqNgt Nb/=.
rewrite /donated/= in D.
move/negbTE: Nf=>->/=; rewrite -(has_find [pred e | e.1 == b]) has_filter.
move/eqP: D=>D; rewrite D/=.
congr (Some _); congr (Msg _ _ _ _ _).
elim: (backers s) D=>//[[a w]]bs/=; case:ifP; first by move/eqP=>->{a}/=_; case.
by move=>X Hi H; move/Hi: H=><-.
Qed.

(************************************************************************

4. Can we have a logic that allows to express all these properties
declaratively? Perhaps, we could do it in TLA?

(This is going to be our future work.)

************************************************************************)

End Crowdfunding.


From Undecidability Require Import TM.Util.TM_facts TM.Util.Relations.
From Undecidability.L Require Import LM_heap_def UnfoldClos Programs.
From Undecidability.L Require Import LambdaDepth.

Set Default Proof Using "Type".
Require Import FunInd.

Lemma lookup_el H alpha x c: lookup H alpha x = Some c -> exists beta, Some (c,beta) el H.
Proof.
  induction x in alpha, c|-*.
  all:cbn. all:destruct nth_error as [[[] | ]| ] eqn:eq.
  all:intros [= eq'].
  1:subst.
  all:eauto using nth_error_In.
Qed.

Definition boundHeap (H:Heap) maxPro maxVar maxDepth:=
  (forall a P beta, Some ((a,P),beta) el H ->
    sizeP P <= maxPro /\ a <= length H /\ beta <= length H /\ lambdaDepthP 1 P <= maxDepth/\ largestVarP P <= maxVar ).

Definition unfoldTailRecStep_sizes (H:Heap) maxPro maxVar maxDepth: list (HClos * nat) -> Prop :=
  fun stack =>
    forall a P k, ((a,P),k) el stack
      -> sizeP P <= maxPro
      /\ a <= length H
      /\ largestVarP P <= maxVar
      /\ lambdaDepthP k P <= maxDepth + 1.

Lemma unfoldTailRecStep_sizes_correct' H maxPro maxVar maxDepth a k s P s' stack stack' res fuel :
  boundHeap H maxPro maxVar maxDepth
  -> LM_heap_correct.unfolds H a k s s'
  -> ARS.pow (fun a b => inl b = unfoldTailRecStep H a) fuel ((a,compile s++P,k)::stack,res) stack'
  -> (sizeP (compile s++P) <= maxPro /\ a <= length H /\ largestVarP (compile s++P) <= maxVar /\ lambdaDepthP k ((compile s++P)) <= maxDepth)
  -> (unfoldTailRecStep_sizes H maxPro maxVar maxDepth stack)
  -> (exists fuel', fuel' < fuel /\
      ARS.pow (fun a b => inl b = unfoldTailRecStep H a) fuel' ((a,P,k)::stack,rev (compile s')++res) stack')
     \/ unfoldTailRecStep_sizes H maxPro maxVar maxDepth (fst stack').
Proof.
  intros HH.
  revert a k s P s' stack stack' res.
  induction fuel as [fuel IH] using lt_wf_ind.
  intros ? ? ? ? ? ? ? ? Hunf HR Hhd Htl.
  destruct fuel as [|fuel].
  {hnf in HR. subst stack'. cbn [fst]in *. right. intros ? ? ? [[= <- <- <-]|]. all:now eauto. }
  change (S fuel) with (1+fuel) in *. eapply pow_add in HR as (stack''&Hstep%(rcomp_1)&HR).
  symmetry in Hstep.
  induction Hunf in P,stack,Hstep,Hhd,Htl|-*. 1-3:cbn in Hstep.
  - destruct (Nat.leb_spec k n). now exfalso;nia.
    injection Hstep as [= <-]. left. eauto.
  - destruct (Nat.leb_spec k n). 2: now exfalso;nia.
    rewrite H1 in Hstep. injection Hstep as [= <-]. inv H2. inv Hunf.
    destruct (lookup_el H1) as (?&Hel). hnf in HH. specialize HH with (1:= Hel) as (?&?&?&?&?).
    specialize IH with (2:= H5) (P:=[]) as IH'. rewrite app_nil_r in IH'. specialize IH' with (2:=HR) as [(fuel'&?&IH')|IH'].
    + nia.
    + specialize (lambdaDepthP_min 1 (compile s0)). repeat simple apply conj;try nia.
    + hnf. intros ? ? ? [[= <- <- <-]|]. 2:now eauto.
      specialize (lambdaDepthP_min k P).
      cbn - [max] in Hhd|-*. repeat simple apply conj;try nia.
    + destruct fuel' as [|fuel'].
      {
        hnf in IH'. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-] | [[= <- <- <-]| ]].
        3:now eauto. { cbn. unfold sizeP in *. nia. }
        cbn - [max] in Hhd|-*. unfold sizeP, largestVarP in *. specialize (lambdaDepthP_min k P). repeat simple apply conj;try nia.
      }
      change (S fuel') with (1+fuel') in *. eapply pow_add in IH' as (stack''&Hstep%(rcomp_1)&IH').
      cbn in Hstep. injection Hstep as [=->].
      destruct fuel' as [|fuel'].
      {
        hnf in IH'. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-]| ].
        2:now eauto.
        cbn - [max] in Hhd|-*. unfold sizeP, largestVarP in *. specialize (lambdaDepthP_min k P). repeat simple apply conj;try nia.
      }
      change (S fuel') with (1+fuel') in *. eapply pow_add in IH' as (stack''&Hstep%(rcomp_1)&IH').
      cbn in Hstep. injection Hstep as [=->].
      cbn. autorewrite with list;cbn. left;eexists;split. 2:eassumption. nia.
    +now right.
  - injection Hstep as [= <-]. cbn in Hhd. rewrite <- app_assoc in HR,Hhd.
    specialize IH with (2:=Hunf) (3:=HR) as [(fuel'&?&IH')|IH'].
    + nia.
    + cbn in Hhd|-*. unfold sizeP,largestVarP. nia.
    + easy.
    + cbn in Hhd|-*. autorewrite with list in Hhd|-*. rewrite lambdaDepthP_compile', maxl_app in Hhd. cbn - [max]in Hhd|-*.
      destruct fuel' as [|fuel'].
      {
        hnf in IH'. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-]| ].
        2:now eauto.
        cbn - [max] in Hhd|-*. unfold sizeP in *. repeat simple apply conj;try nia.
      }
      change (S fuel') with (1+fuel') in *. eapply pow_add in IH' as (stack''&Hstep%(rcomp_1)&IH').
      cbn in Hstep. injection Hstep as [=->].
      left;do 2 eexists. 2:eassumption. nia.
    + easy.
  - cbn [compile] in Hstep,Hhd. rewrite <- !app_assoc in Hstep,Hhd.
    edestruct IHHunf1  as [(fuel'&?&IH')|IH']. 3:eassumption.
    1,2,4:easy.
    cbn in Hhd|-*. unfold sizeP,largestVarP in Hhd. autorewrite with list in Hhd|-*.
    rewrite !lambdaDepthP_compile', !maxl_app in Hhd. cbn - [max]in Hhd|-*.
    specialize IH with (3:=IH') as [(fuel''&?&IH'')|IH'']. 2:eassumption.
    + nia.
    + cbn in Hhd|-*. unfold sizeP,largestVarP in Hhd|-*. autorewrite with list. rewrite !lambdaDepthP_compile', !maxl_app;cbn.
      repeat simple apply conj;try nia.
    + easy.
    + destruct fuel'' as [|fuel''].
      {
        hnf in IH''. subst stack'. right. hnf;cbn. intros ? ? ? [[= <- <- <-]| ].
        2:now eauto.
        cbn - [max] in Hhd|-*. unfold sizeP in *. repeat simple apply conj;try nia.
      }
      change (S fuel'') with (1+fuel'') in *. eapply pow_add in IH'' as (stack'''&Hstep'%(rcomp_1)&IH''').
      cbn in Hstep. injection Hstep' as [=->].
      left;do 2 eexists. 2:eassumption. nia.
    + easy.
Qed.

Lemma unfoldTailRecStep_sizes_correct H maxPro maxVar maxDepth a k s s' stack' res fuel :
  boundHeap H maxPro maxVar maxDepth
  -> LM_heap_correct.unfolds H a k s s'
  -> ARS.pow (fun a b => inl b = unfoldTailRecStep H a) fuel ([(a,compile s,k)],res) stack'
  -> sizeP (compile s) <= maxPro /\ a <= length H /\ LargestVar.largestVar s<= maxVar /\ k + lambdaDepth s <= maxDepth
  -> unfoldTailRecStep_sizes H maxPro maxVar maxDepth (fst stack').
Proof.
  intros H1 H2 H3 ?.
  edestruct unfoldTailRecStep_sizes_correct' with (P:=@nil Tok) (1:=H1) (2:=H2)as [(fuel'&?&H')|H'].
  -rewrite app_nil_r. eassumption.
  -rewrite app_nil_r. rewrite lambdaDepthP_compile, largestVar_compile. easy.
  -easy.
  -destruct fuel'.
   { hnf in H'. subst stack';cbn. hnf. intros ? ? ? [[= <- <- <-]|[]];cbn. unfold sizeP in *. nia. }
   change (S fuel') with (1+fuel') in *. eapply pow_add in H' as (stack''&Hstep%(rcomp_1)&H').
   cbn in Hstep. injection Hstep as [=->].
   destruct fuel'.
   +hnf in H'. subst stack';cbn. hnf. easy.
   +exfalso.  change (S fuel') with (1+fuel') in *. eapply pow_add in H' as (stack''&Hstep%(rcomp_1)&_). easy.
  -easy.
Qed.

From Undecidability.L.AbstractMachines Require Import SizeAnalysisStep SubtermProperty.

Lemma abstractMachine_boundHeap k s a s0 H :
  ARS.pow step k (LM_heap_def.init s) ([], [(a, compile s0)], H) ->
  boundHeap H (sizeP (compile s)) (LargestVar.largestVar s) (lambdaDepth s).
Proof.
  intros H'. unfold boundHeap. intros ? ? ? HH.
  specialize subterm_property with (1:=H') as (_&_&Hsub). specialize Hsub with (1:=HH) as (?&?&tmp);cbn in tmp;subst P.
  specialize size_clos with (1:=H') as (_&Hlength). easy. specialize Hlength with (1:=HH) as (?&?&?&?).
  repeat simple apply conj;try eassumption.
  -apply lambdaDepth_subterm in H0 as <-. cbn. now rewrite lambdaDepthP_compile.
  -now rewrite <- largestVar_compile.
Qed.

Lemma abstractMachine_boundRes k s a s0 H :
  ARS.pow step k (LM_heap_def.init s) ([], [(a, compile s0)], H) ->
  sizeP (compile s0) <= sizeP (compile s) /\
  a <= | H | /\
  LargestVar.largestVar s0 <= LargestVar.largestVar s /\
  1 + lambdaDepth s0 <= lambdaDepth s.
Proof.
  intros H'.
  specialize subterm_property with (1:=H') as (_&Hsub&_). specialize Hsub as (?&?&tmp). now left.
  apply compile_inj in tmp as <-.
  specialize size_clos with (1:=H') as (Hlength&_). easy. specialize Hlength as (?&?&?). now left.
  repeat simple apply conj;try eassumption.
  -now rewrite <- !largestVar_compile.
  -apply lambdaDepth_subterm in H0 as <-. cbn. easy.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require int.MinMax.

(* Why3 assumption *)
Inductive list (a:Type) {a_WT:WhyType a} :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Axiom list_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (list a).
Existing Instance list_WhyType.
Implicit Arguments Nil [[a] [a_WT]].
Implicit Arguments Cons [[a] [a_WT]].

(* Why3 assumption *)
Fixpoint infix_plpl {a:Type} {a_WT:WhyType a}(l1:(list a)) (l2:(list
  a)) {struct l1}: (list a) :=
  match l1 with
  | Nil => l2
  | (Cons x1 r1) => (Cons x1 (infix_plpl r1 l2))
  end.

Axiom Append_assoc : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((infix_plpl l (Nil :(list a))) = l).

(* Why3 assumption *)
Fixpoint length {a:Type} {a_WT:WhyType a}(l:(list a)) {struct l}: Z :=
  match l with
  | Nil => 0%Z
  | (Cons _ r) => (1%Z + (length r))%Z
  end.

Axiom Length_nonnegative : forall {a:Type} {a_WT:WhyType a}, forall (l:(list
  a)), (0%Z <= (length l))%Z.

Axiom Length_nil : forall {a:Type} {a_WT:WhyType a}, forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil :(list a))).

Axiom Append_length : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)), ((length (infix_plpl l1
  l2)) = ((length l1) + (length l2))%Z).

(* Why3 assumption *)
Fixpoint mem {a:Type} {a_WT:WhyType a}(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil => False
  | (Cons y r) => (x = y) \/ (mem x r)
  end.

Axiom mem_append : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l1:(list
  a)) (l2:(list a)), (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x
  l2)).

Axiom mem_decomp : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (l:(list
  a)), (mem x l) -> exists l1:(list a), exists l2:(list a),
  (l = (infix_plpl l1 (Cons x l2))).

Axiom map : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, Type.
Parameter map_WhyType : forall (a:Type) {a_WT:WhyType a}
  (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Existing Instance map_WhyType.

Parameter get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.

Parameter set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).

Axiom Select_eq : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (m:(map a b)), forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) ->
  ((get (set m a1 b1) a2) = b1).

Axiom Select_neq : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (m:(map a b)), forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).

Parameter const: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  b -> (map a b).

Axiom Const : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (b1:b) (a1:a), ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Inductive datatype  :=
  | TYunit : datatype
  | TYint : datatype
  | TYbool : datatype .
Axiom datatype_WhyType : WhyType datatype.
Existing Instance datatype_WhyType.

(* Why3 assumption *)
Inductive value  :=
  | Vvoid : value
  | Vint : Z -> value
  | Vbool : bool -> value .
Axiom value_WhyType : WhyType value.
Existing Instance value_WhyType.

(* Why3 assumption *)
Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .
Axiom operator_WhyType : WhyType operator.
Existing Instance operator_WhyType.

Axiom mident : Type.
Parameter mident_WhyType : WhyType mident.
Existing Instance mident_WhyType.

Axiom mident_decide : forall (m1:mident) (m2:mident), (m1 = m2) \/
  ~ (m1 = m2).

(* Why3 assumption *)
Inductive ident  :=
  | mk_ident : Z -> ident .
Axiom ident_WhyType : WhyType ident.
Existing Instance ident_WhyType.

(* Why3 assumption *)
Definition ident_index(v:ident): Z := match v with
  | (mk_ident x) => x
  end.

Parameter result: ident.

Axiom ident_decide : forall (m1:ident) (m2:ident), (m1 = m2) \/ ~ (m1 = m2).

(* Why3 assumption *)
Inductive term  :=
  | Tvalue : value -> term
  | Tvar : ident -> term
  | Tderef : mident -> term
  | Tbin : term -> operator -> term -> term .
Axiom term_WhyType : WhyType term.
Existing Instance term_WhyType.

(* Why3 assumption *)
Fixpoint var_occurs_in_term(x:ident) (t:term) {struct t}: Prop :=
  match t with
  | (Tvalue _) => False
  | (Tvar i) => (x = i)
  | (Tderef _) => False
  | (Tbin t1 _ t2) => (var_occurs_in_term x t1) \/ (var_occurs_in_term x t2)
  end.

(* Why3 assumption *)
Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla
  | Flet : ident -> term -> fmla -> fmla
  | Fforall : ident -> datatype -> fmla -> fmla .
Axiom fmla_WhyType : WhyType fmla.
Existing Instance fmla_WhyType.

(* Why3 assumption *)
Inductive expr  :=
  | Evalue : value -> expr
  | Ebin : expr -> operator -> expr -> expr
  | Evar : ident -> expr
  | Ederef : mident -> expr
  | Eassign : mident -> expr -> expr
  | Eseq : expr -> expr -> expr
  | Elet : ident -> expr -> expr -> expr
  | Eif : expr -> expr -> expr -> expr
  | Eassert : fmla -> expr
  | Ewhile : expr -> fmla -> expr -> expr .
Axiom expr_WhyType : WhyType expr.
Existing Instance expr_WhyType.

(* Why3 assumption *)
Definition type_value(v:value): datatype :=
  match v with
  | Vvoid => TYunit
  | (Vint int) => TYint
  | (Vbool bool1) => TYbool
  end.

(* Why3 assumption *)
Inductive type_operator : operator -> datatype -> datatype
  -> datatype -> Prop :=
  | Type_plus : (type_operator Oplus TYint TYint TYint)
  | Type_minus : (type_operator Ominus TYint TYint TYint)
  | Type_mult : (type_operator Omult TYint TYint TYint)
  | Type_le : (type_operator Ole TYint TYint TYbool).

(* Why3 assumption *)
Definition type_stack  := (list (ident* datatype)%type).

Parameter get_vartype: ident -> (list (ident* datatype)%type) -> datatype.

Axiom get_vartype_def : forall (i:ident) (pi:(list (ident* datatype)%type)),
  match pi with
  | Nil => ((get_vartype i pi) = TYunit)
  | (Cons (x, ty) r) => ((x = i) -> ((get_vartype i pi) = ty)) /\
      ((~ (x = i)) -> ((get_vartype i pi) = (get_vartype i r)))
  end.

(* Why3 assumption *)
Definition type_env  := (map mident datatype).

(* Why3 assumption *)
Inductive type_term : (map mident datatype) -> (list (ident* datatype)%type)
  -> term -> datatype -> Prop :=
  | Type_value : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:value), (type_term sigma pi (Tvalue v)
      (type_value v))
  | Type_var : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:ident) (ty:datatype), ((get_vartype v pi) = ty) ->
      (type_term sigma pi (Tvar v) ty)
  | Type_deref : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:mident) (ty:datatype), ((get sigma v) = ty) ->
      (type_term sigma pi (Tderef v) ty)
  | Type_bin : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t1:term) (t2:term) (op:operator) (ty1:datatype)
      (ty2:datatype) (ty:datatype), (type_term sigma pi t1 ty1) ->
      ((type_term sigma pi t2 ty2) -> ((type_operator op ty1 ty2 ty) ->
      (type_term sigma pi (Tbin t1 op t2) ty))).

(* Why3 assumption *)
Inductive type_fmla : (map mident datatype) -> (list (ident* datatype)%type)
  -> fmla -> Prop :=
  | Type_term : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t:term), (type_term sigma pi t TYbool) ->
      (type_fmla sigma pi (Fterm t))
  | Type_conj : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fand f1 f2)))
  | Type_neg : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f:fmla), (type_fmla sigma pi f) -> (type_fmla sigma
      pi (Fnot f))
  | Type_implies : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (f1:fmla) (f2:fmla), (type_fmla sigma pi f1) ->
      ((type_fmla sigma pi f2) -> (type_fmla sigma pi (Fimplies f1 f2)))
  | Type_let : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (t:term) (f:fmla) (ty:datatype),
      (type_term sigma pi t ty) -> ((type_fmla sigma (Cons (x, ty) pi) f) ->
      (type_fmla sigma pi (Flet x t f)))
  | Type_forall1 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYint)
      pi) f) -> (type_fmla sigma pi (Fforall x TYint f))
  | Type_forall2 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYbool)
      pi) f) -> (type_fmla sigma pi (Fforall x TYbool f))
  | Type_forall3 : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (f:fmla), (type_fmla sigma (Cons (x, TYunit)
      pi) f) -> (type_fmla sigma pi (Fforall x TYunit f)).

(* Why3 assumption *)
Inductive type_expr : (map mident datatype) -> (list (ident* datatype)%type)
  -> expr -> datatype -> Prop :=
  | Type_Evalue : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:value), (type_expr sigma pi (Evalue v)
      (type_value v))
  | Type_Evar : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:ident) (ty:datatype), ((get_vartype v pi) = ty) ->
      (type_expr sigma pi (Evar v) ty)
  | Type_Ederef : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (v:mident) (ty:datatype), ((get sigma v) = ty) ->
      (type_expr sigma pi (Ederef v) ty)
  | Type_Ebinop : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (e1:expr) (e2:expr) (op:operator) (ty1:datatype)
      (ty2:datatype) (ty:datatype), (type_expr sigma pi e1 ty1) ->
      ((type_expr sigma pi e2 ty2) -> ((type_operator op ty1 ty2 ty) ->
      (type_expr sigma pi (Ebin e1 op e2) ty)))
  | Type_seq : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (e1:expr) (e2:expr) (ty:datatype), (type_expr sigma pi
      e1 TYunit) -> ((type_expr sigma pi e2 ty) -> (type_expr sigma pi
      (Eseq e1 e2) ty))
  | Type_assigns : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:mident) (e:expr) (ty:datatype), ((get sigma
      x) = ty) -> ((type_expr sigma pi e ty) -> (type_expr sigma pi
      (Eassign x e) TYunit))
  | Type_if : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (t:expr) (e1:expr) (e2:expr) (ty:datatype),
      (type_expr sigma pi t TYbool) -> ((type_expr sigma pi e1 ty) ->
      ((type_expr sigma pi e2 ty) -> (type_expr sigma pi (Eif t e1 e2) ty)))
  | Type_assert : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (p:fmla), (type_fmla sigma pi p) -> (type_expr sigma
      pi (Eassert p) TYbool)
  | Type_while : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (guard:expr) (body:expr) (inv:fmla) (ty:datatype),
      (type_fmla sigma pi inv) -> ((type_expr sigma pi guard TYbool) ->
      ((type_expr sigma pi body ty) -> (type_expr sigma pi (Ewhile guard inv
      body) ty)))
  | Type_Elet : forall (sigma:(map mident datatype)) (pi:(list (ident*
      datatype)%type)) (x:ident) (e1:expr) (e2:expr) (ty1:datatype)
      (ty2:datatype), (type_expr sigma pi e1 ty1) -> ((type_expr sigma
      (Cons (x, ty1) pi) e2 ty2) -> (type_expr sigma pi (Elet x e1 e2) ty2)).

(* Why3 assumption *)
Definition env  := (map mident value).

(* Why3 assumption *)
Definition stack  := (list (ident* value)%type).

Parameter get_stack: ident -> (list (ident* value)%type) -> value.

Axiom get_stack_def : forall (i:ident) (pi:(list (ident* value)%type)),
  match pi with
  | Nil => ((get_stack i pi) = Vvoid)
  | (Cons (x, v) r) => ((x = i) -> ((get_stack i pi) = v)) /\ ((~ (x = i)) ->
      ((get_stack i pi) = (get_stack i r)))
  end.

Axiom get_stack_eq : forall (x:ident) (v:value) (r:(list (ident*
  value)%type)), ((get_stack x (Cons (x, v) r)) = v).

Axiom get_stack_neq : forall (x:ident) (i:ident) (v:value) (r:(list (ident*
  value)%type)), (~ (x = i)) -> ((get_stack i (Cons (x, v) r)) = (get_stack i
  r)).

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = Vvoid)
  end.

(* Why3 assumption *)
Fixpoint eval_term(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (t:term) {struct t}: value :=
  match t with
  | (Tvalue v) => v
  | (Tvar id) => (get_stack id pi)
  | (Tderef id) => (get sigma id)
  | (Tbin t1 op t2) => (eval_bin (eval_term sigma pi t1) op (eval_term sigma
      pi t2))
  end.

Axiom eval_bool_term : forall (sigma:(map mident value)) (pi:(list (ident*
  value)%type)) (sigmat:(map mident datatype)) (pit:(list (ident*
  datatype)%type)) (t:term), (type_term sigmat pit t TYbool) ->
  exists b:bool, ((eval_term sigma pi t) = (Vbool b)).

(* Why3 assumption *)
Fixpoint eval_fmla(sigma:(map mident value)) (pi:(list (ident* value)%type))
  (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term sigma pi t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla sigma pi f1) /\ (eval_fmla sigma pi f2)
  | (Fnot f1) => ~ (eval_fmla sigma pi f1)
  | (Fimplies f1 f2) => (eval_fmla sigma pi f1) -> (eval_fmla sigma pi f2)
  | (Flet x t f1) => (eval_fmla sigma (Cons (x, (eval_term sigma pi t)) pi)
      f1)
  | (Fforall x TYint f1) => forall (n:Z), (eval_fmla sigma (Cons (x,
      (Vint n)) pi) f1)
  | (Fforall x TYbool f1) => forall (b:bool), (eval_fmla sigma (Cons (x,
      (Vbool b)) pi) f1)
  | (Fforall x TYunit f1) => (eval_fmla sigma (Cons (x, Vvoid) pi) f1)
  end.

Parameter msubst_term: term -> mident -> ident -> term.

Axiom msubst_term_def : forall (t:term) (r:mident) (v:ident),
  match t with
  | ((Tvalue _)|(Tvar _)) => ((msubst_term t r v) = t)
  | (Tderef x) => ((r = x) -> ((msubst_term t r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((msubst_term t r v) = t))
  | (Tbin t1 op t2) => ((msubst_term t r v) = (Tbin (msubst_term t1 r v) op
      (msubst_term t2 r v)))
  end.

Parameter subst_term: term -> ident -> ident -> term.

Axiom subst_term_def : forall (t:term) (r:ident) (v:ident),
  match t with
  | ((Tvalue _)|(Tderef _)) => ((subst_term t r v) = t)
  | (Tvar x) => ((r = x) -> ((subst_term t r v) = (Tvar v))) /\
      ((~ (r = x)) -> ((subst_term t r v) = t))
  | (Tbin t1 op t2) => ((subst_term t r v) = (Tbin (subst_term t1 r v) op
      (subst_term t2 r v)))
  end.

(* Why3 assumption *)
Definition fresh_in_term(id:ident) (t:term): Prop := ~ (var_occurs_in_term id
  t).

Axiom fresh_in_binop : forall (t:term) (t':term) (op:operator) (v:ident),
  (fresh_in_term v (Tbin t op t')) -> ((fresh_in_term v t) /\
  (fresh_in_term v t')).

(* Why3 assumption *)
Fixpoint fresh_in_fmla(id:ident) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm e) => (fresh_in_term id e)
  | ((Fand f1 f2)|(Fimplies f1 f2)) => (fresh_in_fmla id f1) /\
      (fresh_in_fmla id f2)
  | (Fnot f1) => (fresh_in_fmla id f1)
  | (Flet y t f1) => (~ (id = y)) /\ ((fresh_in_term id t) /\
      (fresh_in_fmla id f1))
  | (Fforall y ty f1) => (~ (id = y)) /\ (fresh_in_fmla id f1)
  end.

(* Why3 assumption *)
Fixpoint subst(f:fmla) (x:ident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x v))
  | (Fand f1 f2) => (Fand (subst f1 x v) (subst f2 x v))
  | (Fnot f1) => (Fnot (subst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x v) (subst f2 x v))
  | (Flet y t f1) => (Flet y (subst_term t x v) (subst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (subst f1 x v))
  end.

(* Why3 assumption *)
Fixpoint msubst(f:fmla) (x:mident) (v:ident) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (msubst_term e x v))
  | (Fand f1 f2) => (Fand (msubst f1 x v) (msubst f2 x v))
  | (Fnot f1) => (Fnot (msubst f1 x v))
  | (Fimplies f1 f2) => (Fimplies (msubst f1 x v) (msubst f2 x v))
  | (Flet y t f1) => (Flet y (msubst_term t x v) (msubst f1 x v))
  | (Fforall y ty f1) => (Fforall y ty (msubst f1 x v))
  end.

Axiom subst_fresh_term : forall (t:term) (x:ident) (v:ident),
  (fresh_in_term x t) -> ((subst_term t x v) = t).

Axiom subst_fresh : forall (f:fmla) (x:ident) (v:ident), (fresh_in_fmla x
  f) -> ((subst f x v) = f).

Axiom eval_msubst_term : forall (e:term) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:mident) (v:ident), (fresh_in_term v e) ->
  ((eval_term sigma pi (msubst_term e x v)) = (eval_term (set sigma x
  (get_stack v pi)) pi e)).

Axiom eval_msubst : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (x:mident) (v:ident), (fresh_in_fmla v f) ->
  ((eval_fmla sigma pi (msubst f x v)) <-> (eval_fmla (set sigma x
  (get_stack v pi)) pi f)).

Axiom eval_swap_term : forall (t:term) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (l:(list (ident* value)%type)) (id1:ident)
  (id2:ident) (v1:value) (v2:value), (~ (id1 = id2)) -> ((eval_term sigma
  (infix_plpl l (Cons (id1, v1) (Cons (id2, v2) pi))) t) = (eval_term sigma
  (infix_plpl l (Cons (id2, v2) (Cons (id1, v1) pi))) t)).

Axiom eval_swap_term_2 : forall (t:term) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (id1:ident) (id2:ident) (v1:value) (v2:value),
  (~ (id1 = id2)) -> ((eval_term sigma (Cons (id1, v1) (Cons (id2, v2) pi))
  t) = (eval_term sigma (Cons (id2, v2) (Cons (id1, v1) pi)) t)).

Axiom eval_swap : forall (f:fmla) (sigma:(map mident value)) (pi:(list
  (ident* value)%type)) (l:(list (ident* value)%type)) (id1:ident)
  (id2:ident) (v1:value) (v2:value), (~ (id1 = id2)) -> ((eval_fmla sigma
  (infix_plpl l (Cons (id1, v1) (Cons (id2, v2) pi))) f) <-> (eval_fmla sigma
  (infix_plpl l (Cons (id2, v2) (Cons (id1, v1) pi))) f)).

(* Why3 goal *)
Theorem eval_swap_2 : forall (f:fmla) (id1:ident) (id2:ident) (v1:value)
  (v2:value), (~ (id1 = id2)) -> forall (sigma:(map mident value)) (pi:(list
  (ident* value)%type)), (eval_fmla sigma (Cons (id1, v1) (Cons (id2, v2)
  pi)) f) <-> (eval_fmla sigma (Cons (id2, v2) (Cons (id1, v1) pi)) f).
intros f id1 id2 v1 v2 h1 sigma pi.
assert (h: ((eval_fmla sigma
  (infix_plpl Nil (Cons (id1, v1) (Cons (id2, v2) pi))) f) <-> (eval_fmla sigma
  (infix_plpl Nil (Cons (id2, v2) (Cons (id1, v1) pi))) f))).
apply eval_swap; auto.
simpl in h; auto.
Qed.


Set Implicit Arguments.

Require Import Platform.Cito.Syntax.
Require Import Coq.Strings.String.

Definition Optimizer := Stmt -> string -> Stmt.

Definition compose (f g : Optimizer) : Optimizer := fun s r => g (f s r) r.

Require Import Platform.Cito.ADT.

Module Make (Import E : ADT).

  Require Import Platform.Cito.Semantics.
  Module Import SemanticsMake := Semantics.Make E.

  Section TopSection.

    Definition PreserveRunsTo (opt : Optimizer) :=  forall ret fs s v v', RunsTo fs (opt s ret) v v' -> exists vs', RunsTo fs s v (vs', snd v') /\ Locals.sel vs' ret = Locals.sel (fst v') ret.

    Definition PreserveSafe (opt : Optimizer) := forall fs s v, Safe fs s v -> forall ret, Safe fs (opt s ret) v.

    Require Import Platform.Cito.GetLocalVars.
    Require Import Platform.Cito.Depth.
    Require Import Bedrock.IL.

    Definition PreserveGoodSize (opt : Optimizer) :=
      forall stmt argvars retvar,
        let size s := List.length (get_local_vars s argvars retvar) + depth s in
        goodSize (size stmt) ->
        goodSize (size (opt stmt retvar)).

    Require Import Platform.Cito.CompileStmtSpec.
    Require Import Coq.Lists.List.

    Definition PreserveSynReq (opt : Optimizer) :=
      forall stmt argvars retvar,
        let vars s := argvars ++ get_local_vars s argvars retvar in
        let stmt' := opt stmt retvar in
        syn_req (vars stmt) (depth stmt) stmt ->
        syn_req (vars stmt') (depth stmt') stmt'.

    Definition GoodOptimizer opt :=
      PreserveRunsTo opt /\
      PreserveSafe opt /\
      PreserveGoodSize opt /\
      PreserveSynReq opt.

    Require Import Platform.Cito.GoodFunc.
    Require Import Platform.Cito.SyntaxFunc.
    Definition PreserveGoodSize' (opt : Optimizer) :=
      forall f,
        GoodFunc f ->
        let s := opt (Body f) (RetVar f) in
        goodSize (length (get_local_vars s (ArgVars f) (RetVar f)) + depth s).

    Definition PreserveSynReq' (opt : Optimizer) :=
      forall f,
        GoodFunc f ->
        let s := opt (Body f) (RetVar f) in
        syn_req (ArgVars f ++ get_local_vars s (ArgVars f) (RetVar f)) (depth s) s.

    Lemma GoodOptimizer_Safe : forall opt, GoodOptimizer opt -> PreserveSafe opt.
      unfold GoodOptimizer; intuition.
    Qed.

    Lemma GoodOptimizer_RunsTo : forall opt, GoodOptimizer opt -> PreserveRunsTo opt.
      unfold GoodOptimizer; intuition.
    Qed.

    Require Import Platform.Cito.GeneralTactics.

    Lemma GoodFunc_GoodOptimizer_goodSize : forall opt, GoodOptimizer opt -> PreserveGoodSize' opt.
      unfold GoodOptimizer.
      intros.
      openhyp.
      unfold PreserveGoodSize'.
      unfold PreserveGoodSize in *.
      intros.
      simpl in *.
      eapply H1; eauto.
      destruct H3; openhyp; eauto.
    Qed.

    Lemma GoodFunc_GoodOptimizer_syn_req : forall opt, GoodOptimizer opt -> PreserveSynReq' opt.
      unfold GoodOptimizer.
      intros.
      openhyp.
      unfold PreserveSynReq'.
      unfold PreserveSynReq in *.
      intros.
      simpl in *.
      eapply H2; eauto.
      eapply GoodFunc_syn_req; eauto.
    Qed.

    Lemma PreserveRunsTo_trans : forall a b, PreserveRunsTo a -> PreserveRunsTo b -> PreserveRunsTo (compose a b).
      unfold PreserveRunsTo, compose; intros.
      eapply H0 in H1; eauto; openhyp.
      eapply H in H1; eauto; openhyp.
      descend; intuition eauto.
    Qed.

    Lemma PreserveSafe_trans : forall a b, PreserveSafe a -> PreserveSafe b -> PreserveSafe (compose a b).
      unfold PreserveSafe, compose; intros.
      eauto.
    Qed.

    Lemma PreserveGoodSize_trans : forall a b, PreserveGoodSize a -> PreserveGoodSize b -> PreserveGoodSize (compose a b).
      unfold PreserveGoodSize, compose; intros.
      eauto.
    Qed.

    Lemma PreserveSynReq_trans : forall a b, PreserveSynReq a -> PreserveSynReq b -> PreserveSynReq (compose a b).
      unfold PreserveSynReq, compose; intros.
      eauto.
    Qed.

    Lemma GoodOptimizer_trans :
      forall a b,
        GoodOptimizer a ->
        GoodOptimizer b ->
        GoodOptimizer (compose a b).
    Proof.
      unfold GoodOptimizer; intros.
      openhyp.
      split.
      eapply PreserveRunsTo_trans; eauto.
      split.
      eapply PreserveSafe_trans; eauto.
      split.
      eapply PreserveGoodSize_trans; eauto.
      eapply PreserveSynReq_trans; eauto.
    Qed.

  End TopSection.

End Make.


Require Import String.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import EffPure.
Require Import EffState.
Require Import EffExcept.
Require Import Ref.
Require Import Exception.
Require Import ESoundES.

Open Scope string_scope.

Section Test_Section.

  Definition D := RefType :+: UnitType.

  Definition E := RefE :+: (ExceptE D).

  Definition V := StuckValue :+: UnitValue :+: LocValue.

  Variable MT : Set -> Set.
  Context `{Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable ME : Set -> Set.
  Context `{StateM_ME : StateM ME (list (Value V))}.
  Context {Exception_ME : Exception ME Datatypes.unit}.
  Context {Reasonable_ME : Reasonable_Monad ME}.

  Definition WFV := (WFValue_Unit D V _) ::+:: (WFValue_Loc D V _).

  Instance DType_Env_CE : ConsExtensionC (list (DType D)). eauto with typeclass_instances. Defined.
  Instance DType_Env_WFE : WF_EnvC V (list (DType D)). apply (DType_Env_WFE _ _ WFV). Defined.

  Definition WFVM :=
    (WFValueM_base D V MT ME (list (DType D)) WFV) ::+::
    (WFValueM_State D V MT ME _) ::+::
    (WFValueM_Except D V MT ME _).

  Instance typeof_alg : forall T : Set, FAlgebra TypeofName T (typeofR D MT) E.
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

  Instance eval_alg : forall T : Set, FAlgebra EvalName T (evalMR V ME) E.
  Proof.
    intros; eauto 150 with typeclass_instances.
  Defined.

    Context {ME_eq_dec' : forall (A : Set) (mte : ME A) (env : list (Value V)),
      (exists a, exists env',
        put env >> mte = put env' >> return_ a) \/
      (exists env', put env >> mte = put env' >> throw tt)}.
    Context {put_catch : forall (A : Set) (env : list (Value V)) e h,
      put env >>= (fun _ => catch (A := A) e h) = catch (put env >>= fun _ => e) h}.
    Context {Put_Exception_Disc :
      forall (A B : Set) (a : A) (mb : ME B) env n,
        (put env >>= fun _ => return_ a) <> mb >>= fun _ => throw n}.
    Context {put_throw : forall (A B : Set) (env env' : list (Value V)) t,
      put env >>= (fun _ => throw t (A := A)) = put env' >>= (fun _ => throw t) ->
      put env >>= (fun _ => throw t (A := B)) = put env' >>= (fun _ => throw t)}.

  Theorem eval_Sound :
    forall (e : Exp E) Sigma (T : DType D)
      (env : list (Value V)),
      WF_Environment D V _ WFV Sigma env Sigma ->
      fmap (@proj1_sig _ _) (typeof D E MT (proj1_sig e)) = return_ (proj1_sig T) ->
      (exists v : Value V, exists env', exists Sigma',
        (put env) >> evalM (evalM_E := eval_alg) V E ME (proj1_sig e) = put env' >> return_ (M := ME) v /\
        WFValueC D V _ WFV Sigma' v T) \/
      (exists t, exists env', exists Sigma',
        put env >> evalM (evalM_E := eval_alg) V E ME (proj1_sig e) = put env' >> throw t
        /\ WF_Environment D V _ WFV Sigma' env' Sigma'
        /\ (forall n T, lookup Sigma n = Some T -> lookup Sigma' n = Some T)).
  Proof.
    apply eval_Except_State_Sound with (WFVM' := WFVM).
    eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
    intros; repeat apply @P2Algebra_Plus.
    eapply Ref_eval_soundness'' with (WFV := WFV);
      eauto 250 with typeclass_instances.
    eapply Except_eval_soundness';
      eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
    eauto 250 with typeclass_instances.
  Qed.

  Eval compute in ("Soundness for 'Ref :+: Exceptions ' Proven!").

End Test_Section.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import AllInRel Util Map Envs Exp IL Annotation Coherence DecSolve.
Require Import Liveness.Liveness Restrict Delocation Indexwise.

Set Implicit Arguments.
Unset Printing Records.

Local Hint Extern 1 =>
match goal with
  [ H : annotation _ _ |- annotation _ _ ] => inv H; eassumption
end.

Lemma trs_dec DL s ans_lv ans
  : {trs DL s ans_lv ans} +
    {~ trs DL s ans_lv ans}.
Proof.
  revert DL ans_lv ans.
  sind s.
  time (destruct s; destruct ans; try solve [dec_right]; destruct ans_lv; try solve [dec_right]).
  + destruct a; [ | dec_right];
      destruct (IH s (ltac:(eauto))
                   (restr (getAnn ans_lv \ singleton x) ⊝  DL) ans_lv ans);
      [| dec_right].
    dec_solve.
  + destruct a; [| dec_right];
    destruct (IH s1 (ltac:(eauto)) DL ans_lv1 ans1); [| dec_right];
    destruct (IH s2 (ltac:(eauto)) DL ans_lv2 ans2); [| dec_right].
    dec_solve.
  + destruct (get_dec DL (counted l)) as [[[G'|]]|];[| dec_right | dec_right];
      destruct a; [| dec_right];
        dec_solve.
  + destruct a;[| dec_right].
    dec_solve.
  + ensure (length F = length a);
    ensure (length F = length sa);
    ensure(length F = length sa0).
    destruct (IH s (ltac:(eauto)) (Some ⊝ (getAnn ⊝ sa0) \\ app (A:=var) ⊜ (fst ⊝ F) a ++ DL)
                 ans_lv ans);[| dec_right].
    edestruct (indexwise_R4_dec
                 (R:=fun lvs Zs Za' ans' =>
                       trs (restr (getAnn lvs \ of_list (fst Zs ++ Za'))
                                     ⊝ (Some ⊝ (getAnn ⊝ sa0) \\ app (A:=var) ⊜ (fst ⊝ F) a ++ DL))
                           (snd Zs) lvs ans')
                 (LA:=sa0)
                 (LB:=F)
                 (LC:=a)
                 (LD:=sa)); intros; eauto.
    hnf; intros. eapply IH; eauto.
    dec_solve. dec_right.
Defined.

Instance trs_dec_inst DL s lv Y
: Computable (trs DL s lv Y).
Proof.
  hnf; eauto using trs_dec.
Defined.


Require Import String.
Require Import List.
Require Import Sets.Ensembles.

Import ListNotations.

Parameter bytes: Type.

(* Agents *)

Inductive agent :=
    | Peer : nat -> agent
    | Attacker : agent.

Definition eqb (A B: agent) :=
    match A, B with
        | Peer i, Peer j => Nat.eqb i j
        | Attacker, Attacker => true
        | _, _ => false
    end.

Lemma refl_eqb:
    forall A, eqb A A = true.
Admitted.

(* Messages *)

Variant public :=
    | Literal : bytes -> public
    | Agent : agent -> public
    | PC : nat -> public
    | TagSend : public
    | TagAccept : public
    | TagChallengeRequest : public
    | TagChallengeReply : public.

Variant private :=
    | Nonce : nat -> private
    | Index : string -> private.

Inductive msg :=
    | Tuple : list msg -> msg
    | MAC : msg -> msg
    | Atom : public + private -> msg.

(* Le prédicat inductif 'analz' permet de générer un ensemble de message à partir d'un ensemble de message de départ.
    - tout message appartenant à l'ensemble de départ est analysé
    - si un message analysé est un tuple, alors on peut analyser tout les sous messages de ce tuple
    - il n'y a pas d'autres prédicat récursif donc ces deux règles suffisent
    - les prédicats unitaires peuvent être analysé du moment qu'ils sont présent dans un Tuple grâce à la deuxième règle
    - on ne peut pas analyser le contenu d'un MAC *)

Inductive analz (H: Ensemble msg) (X: msg): Prop :=
    | analz_init: In msg H X -> analz H X
    | analz_tuple Xs: analz H (Tuple Xs) -> List.In X Xs -> analz H X.

(* Le prédicat inductif 'synth' permet de générer un ensemble de message synthétisables à partir de messages de départ.
    - tout message de départ est synthétisable
    - n'importe quel message de type Public est synthétisable
    - un tuple est synthétisable lorsque tout les messages qui le compose le sont
    - un mac d'un message synthétisable est synthétisable *)

Inductive synth (H: Ensemble msg): Ensemble msg :=
    | synth_init X: In msg H X -> synth H X
    | synth_public p: synth H (Atom (inl p))
    | synth_tuple Xs: (forall X, List.In X Xs -> synth H X) -> synth H (Tuple Xs).

Lemma not_synth_MAC:
    forall H X, ~ (H (MAC X)) -> ~ synth H (MAC X).
Proof.
    intros H X. intros HnotMAC Hsynth.
    inversion Hsynth. subst. apply HnotMAC. apply H0.
Qed.

Lemma can_send_MAC:
    forall H X, synth H (MAC X) -> H (MAC X).
Proof.
    intros H X. intro Hsynth.
    inversion Hsynth. subst. auto.
Qed.

(* Events *)

Variant visibility :=
    | Publicly  : agent ->  agent -> visibility
    | Privately :           agent -> visibility.

Record event := E { mode: visibility ; payload: msg }.

Definition publicly A B msg := E (Publicly A B) msg.
Definition privately A msg := E (Privately A) msg.

Definition format_index B index := Tuple [Atom (inl (Agent B)) ; Atom (inr (Index index))].
Definition format_Accept A B pkt index pc := Tuple [Atom (inl TagAccept) ;
    Atom (inl (Agent A)) ; Atom (inl (Agent B)) ; Atom (inl (Literal pkt)) ;
    Atom (inr (Index index)) ; Atom (inl (PC pc))].
Definition format_ChallengeAccept A B n0 index pc := Tuple [Atom (inl TagAccept) ;
    Atom (inl (Agent A)) ; Atom (inl (Agent B)) ; Atom (inr (Nonce n0)) ;
    Atom (inr (Index index)) ; Atom (inl (PC pc))].

Definition privately_reset A B index := privately A (format_index B index).
Definition privately_Accept A B pkt index pc :=
    privately A (format_Accept A B pkt index pc).
Definition privately_ChallengeAccept A B n0 index pc :=
    privately A (format_ChallengeAccept A B n0 index pc).

Definition format_Send pkt index pc := Tuple [Atom (inl TagSend) ; Atom (inl (Literal pkt)) ;
    Atom (inr (Index index)) ; Atom (inl (PC pc))].
Definition format_ChallengeRequest n0 := Tuple [Atom (inl TagChallengeRequest) ; Atom (inr (Nonce n0))].
Definition format_ChallengeReply n0 index pc := Tuple [Atom (inl TagChallengeReply) ;
    Atom (inr (Nonce n0)) ; Atom (inr (Index index)) ; Atom (inl (PC pc))].

Definition format_MAC src dest msg :=
    Tuple [ msg ; MAC ( Tuple [ Atom (inl (Agent src)) ; Atom (inl (Agent dest)) ; msg ] ) ].

Definition format_MAC_Send src dest pkt index pc :=
    format_MAC src dest (format_Send pkt index pc).
Definition format_MAC_ChallengeRequest src dest n0 :=
    format_MAC src dest (format_ChallengeRequest n0).
Definition format_MAC_ChallengeReply src dest n0 index pc :=
    format_MAC src dest (format_ChallengeReply n0 index pc).

Definition publicly_Send A B pkt index pc :=
    publicly A B (format_MAC_Send A B pkt index pc).
Definition publicly_ChallengeRequest A B n0 :=
    publicly A B (format_MAC_ChallengeRequest A B n0).
Definition publicly_ChallengeReply A B n0 index pc :=
    publicly A B (format_MAC_ChallengeReply A B n0 index pc).

Definition capture := list event.

Parameter index_seed: agent -> string.
Inductive init_state: agent -> Ensemble msg :=
    | init_state_index: forall A s, init_state A (format_index A s).

Inductive knows: agent -> capture -> Ensemble msg :=
    | knows_init A m: init_state A m -> knows A [] m
    | knows_attacker A B X evs: knows Attacker ( publicly A B X :: evs ) X
    | knows_privately A X evs: knows A ( privately A X :: evs ) X
    | knows_publicly A B X evs: knows A ( publicly A B X :: evs ) X
    | knows_later A e evs m: knows A evs m -> knows A ( e :: evs ) m.

Definition fresh_index B evs index := not ( analz (knows B evs) (Atom (inr (Index index))) ).
Definition fresh_nonce A evs n0 := not ( analz (knows A evs) (Atom (inr (Nonce n0))) ).

Parameters A B: agent.
Definition evs_ex := [ publicly_ChallengeRequest A B 42].
Lemma f:
    fresh_nonce A evs_ex 42 -> False.
Proof.
    unfold fresh_nonce. intro H. apply H.
    unfold evs_ex. unfold publicly_ChallengeRequest.
    unfold format_ChallengeRequest.
    apply analz_tuple with (Xs := [Atom (inl TagChallengeRequest) ; Atom (inr (Nonce 42))]) ; try firstorder.
    apply analz_tuple with (Xs := [Tuple [Atom (inl TagChallengeRequest) ; Atom (inr (Nonce 42)) ] ;
        MAC (Tuple [Atom (inl (Agent A)) ; Atom (inl (Agent B)) ; Tuple [ Atom (inl TagChallengeRequest) ; Atom (inr (Nonce 42))]])]) ; try firstorder.
    apply analz_init. unfold In. apply knows_publicly.
Qed.

Lemma fB:
    fresh_nonce B evs_ex 42.
Proof.
    unfold fresh_nonce. unfold evs_ex.
    intro H. inversion H.
    (* premier lemme : analz Empty_set = Empty_set
        deuxième lemme : knows B evs_ex = Empty_set *)
Admitted.

Definition unique (ev: event) evs :=
    ~ List.In ev evs \/ (exists pre suff, evs = pre ++ ev :: suff
                        /\ ~ List.In ev pre /\ ~ List.In ev suff).

Record local_state := LS {
        _PC: agent -> option nat ;
        _index: agent -> option string ;
        _nonce: agent -> nat -> bool
    }.
Definition global_state := agent -> local_state.

Definition lookup_PC (sigma: global_state) A B := (sigma A).(_PC) B.
Definition lookup_index (sigma: global_state) A B := (sigma A).(_index) B.
(* Definition test_nonce (sigma: global_state) A B n := (sigma A).(_nonce) B n. *)

Definition update_PC (sigma: global_state) A B new_pc :=
    fun A' =>
        if eqb A' A then
            let update_new_PC B' := if eqb B' B then Some new_pc
                        else (sigma A).(_PC) B'
            in
            LS update_new_PC (sigma A).(_index) (sigma A).(_nonce)
        else sigma A'.

Definition update_index (sigma: global_state) A B new_index :=
    fun A' =>
        if eqb A' A then
            let update_new_index B' := if eqb B' B then Some new_index
                        else (sigma A).(_index) B'
            in
            LS (sigma A).(_PC) update_new_index (sigma A).(_nonce)
        else sigma A'.

Definition update_PC_index (sigma: global_state) A B new_pc new_index :=
    update_index (update_PC sigma A B new_pc) A B new_index.

Definition set_nonce (sigma: global_state) A B new_nonce b :=
    fun A' =>
        if eqb A' A then
            let set_new_nonce B' := if eqb B' B then
                            (fun n =>  if Nat.eqb n new_nonce then b else (sigma A).(_nonce) B n)
                        else (sigma A).(_nonce) B'
            in
            LS (sigma A).(_PC) (sigma A).(_index) set_new_nonce
        else sigma A'.

Definition init_global_state (seed: agent -> string): global_state :=
    fun A => LS
        ( fun B => if eqb A B then Some 0 else None )
        ( fun B => (if eqb A B then Some (seed A) else None) )
        ( fun _ _ => false ).

(* Definition saved_index sigma A B index := Some index = lookup_index sigma A B.
Definition saved_PC sigma A B pc := Some pc = lookup_PC sigma A B. *)

Definition is_privately_reset A B ev := exists ix, ev = privately_reset A B ix.
Definition is_publicly_Send A ev := exists B pkt ix pc, ev = publicly_Send A B pkt ix pc.
Definition is_publicly_ChallengeRequest A B ev := exists n0, ev = publicly_ChallengeRequest A B n0.
Definition is_privately_ChallengeAccept A B ev := exists n ix pc, ev = privately_ChallengeAccept A B n ix pc.
Definition is_privately_Accept A B ev := exists pkt ix pc, ev = privately_Accept A B pkt ix pc.

Inductive local_index (A B: agent) (ix: string): capture -> Prop :=
    | local_index_init:
        init_state A (format_index B ix) ->
        local_index A B ix []
    | local_index_now_reset evs:
        local_index A B ix ( privately_reset A B ix :: evs )
    | local_index_now_ChallengeReply evs n0 pc:
        local_index A B ix ( publicly_ChallengeReply A B n0 ix pc :: evs )
    | local_index_later ev evs:
        ~ is_privately_reset A B ev ->
        ~ is_publicly_ChallengeRequest A B ev ->
        local_index A B ix evs ->
        local_index A B ix (ev :: evs).

Inductive saved_index (A B: agent) (ix: string): capture -> Prop :=
    | saved_index_now evs n0 pc:
        saved_index A B ix ( privately_ChallengeAccept A B n0 ix pc :: evs )
    | saved_index_later ev evs:
        ~ is_privately_ChallengeAccept A B ev ->
        saved_index A B ix evs ->
        saved_index A B ix (ev :: evs).

Inductive local_PC (A B: agent): nat -> capture -> Prop :=
    | local_PC_init:
        local_PC A B 0 []
    | local_PC_now_reset evs ix:
        local_PC A B 0 ( privately_reset A B ix :: evs )
    | local_PC_now_Send evs pc pkt ix pc':
        local_PC A B pc evs ->
        local_PC A B (pc + 1) ( publicly_Send A B pkt ix pc' :: evs )
    | local_PC_later ev evs pc:
        ~ is_privately_reset A A ev ->
        ~ is_publicly_Send A ev ->
        local_PC A B pc evs ->
        local_PC A B pc (ev :: evs).

Inductive saved_PC (A B: agent): nat -> capture -> Prop :=
    | saved_PC_now_ChallengeAccept evs n0 ix pc:
        saved_PC A B pc ( privately_ChallengeAccept A B n0 ix pc :: evs )
    | saved_PC_now_Accept evs pkt ix pc:
        saved_PC A B (pc + 1) ( privately_Accept A B pkt ix pc :: evs )
    | saved_PC_later ev evs pc:
        ~ is_privately_ChallengeAccept A B ev ->
        ~ is_privately_Accept A B ev ->
        saved_PC A B pc evs ->
        saved_PC A B pc (ev :: evs).

Inductive nonce_inflight (A B: agent) (n0: nat): capture -> Prop :=
    | nonce_inflight_now evs:
        nonce_inflight A B n0 ( publicly_ChallengeRequest A B n0 :: evs )
    | nonce_inflight_later_ChallengeAccept evs n1 ix pc:
        n0 <> n1 ->
        nonce_inflight A B n0 evs ->
        nonce_inflight A B n0 ( privately_ChallengeAccept A B n1 ix pc :: evs )
    | nonce_inflight_later ev evs:
        ~ is_publicly_ChallengeRequest A B ev ->
        ~ is_privately_ChallengeAccept A B ev ->
        nonce_inflight A B n0 evs ->
        nonce_inflight A B n0 (ev :: evs).

Inductive Network: (*global_state ->*) capture -> Prop :=
    | Network_Attack: forall (* sigma *) evs X B,
        Network (* sigma *) evs ->
        synth (analz (knows Attacker evs)) X ->
        Network (* sigma *) ( publicly Attacker B X :: evs )

    | Network_init: (*forall sigma,
        sigma = init_global_state index_seed ->*)
        Network (* sigma *) []

    | Network_local_reset: forall (* sigma *) evs A B index_B (* sigma1 sigma2 *),
        Network (* sigma *) evs ->
        fresh_index B evs index_B ->
        (* sigma1 = update_index sigma B B index_B ->
        sigma2 = update_PC sigma1 B B 0 -> *)
        Network (* sigma2 *) ( privately_reset B A index_B :: evs )

    (* Fix me: miss Network_saved_reset*)

    | Network_Send: forall (* sigma *) evs A B pkt index_B pc_B (* sigma1 *),
        Network (* sigma *) evs ->
        local_index B A index_B evs ->
        local_PC B A pc_B evs ->
        (* sigma1 = update_PC sigma B B (pc_B + 1) ->*)
        Network (* sigma1 *) ( publicly_Send B A pkt index_B pc_B :: evs )

    | Network_Accept: forall (* sigma *) evs A B B' index_B pc_B pkt pc (* sigma1 *),
        Network (* sigma *) evs ->
        List.In (publicly B' A (format_MAC_Send B A pkt index_B pc_B)) evs ->
        saved_index A B index_B evs ->
        saved_PC A B pc evs -> pc < pc_B ->
        (* sigma1 = update_PC sigma A B pc_B -> *)
        Network (* sigma1 *) ( privately_Accept A B pkt index_B pc_B :: evs )

    | Network_ChallengeRequest: forall (* sigma *) evs A B n0 (* sigma1 *),
        Network (* sigma *) evs ->
        fresh_nonce A evs n0 ->
        (* sigma1 = set_nonce sigma A B n0 true -> *)
        Network (* sigma1 *)
            ( publicly_ChallengeRequest A B n0 :: evs )

    | Network_ChallengeReply: forall (* sigma *) evs A A' B n0 index_B (* sigma1 sigma2 *),
        Network (* sigma *) evs ->
        List.In (publicly A' B (format_MAC_ChallengeRequest A B n0)) evs ->
        (* test_nonce sigma B A n0 = false ->*)
        fresh_index B evs index_B ->
        (*sigma1 = update_index sigma B B index_B ->
        sigma2 = update_PC sigma1 B B 0 -> *)
        Network (* sigma2 *)
            ( publicly_ChallengeReply B A n0 index_B 0 :: evs )

    | Network_ChallengeAccept: forall (* sigma *) evs A B B' n0 index_B pc_B (* sigma1 sigma2 sigma3 *),
        Network (* sigma *) evs ->
        List.In (publicly_ChallengeRequest A B n0) evs ->
        List.In (publicly B' A (format_MAC_ChallengeReply B A n0 index_B pc_B)) evs ->
        nonce_inflight A B n0 evs ->
        (* sigma1 = update_index sigma A B index_B ->
        sigma2 = update_PC sigma1 A B pc_B ->
        sigma3 = set_nonce sigma2 A B n0 false -> *)
        Network (* sigma3 *)
            ( privately_ChallengeAccept A B n0 index_B pc_B :: evs ).

Axiom R: capture -> capture -> Prop.
Definition leq_capture (evs evs': capture) := exists pre, evs' = pre ++ evs.

Lemma R_cons:
    forall ev evs,
        Network (ev :: evs) ->
        R evs (ev :: evs).
Admitted.

Lemma R_leq:
    forall evs evs',
        leq_capture evs evs' ->
        Network evs' ->
        R evs evs'.
Admitted.

Lemma R_proj:
    forall A B evs evs' ix ix' pc pc',
        R evs evs' ->
        saved_index A B ix evs ->
        saved_PC A B pc evs ->
        saved_index A B ix' evs' ->
        saved_PC A B pc' evs' ->
        ix = ix' ->
        pc <= pc'.
Admitted.

(*Lemma invariant_init:
    forall sigma sigma' evs,
        Network sigma evs ->
        Network sigma' evs ->
        R_sigma sigma sigma'.
Proof.
    (*
        On procède par induction sur evs :
        - soit on bump par 1 le pc dans sigma et sigma' donc ok
        - soit on change l'indice, si les nouveaux indices sont égaux, alors les pc sont aussi égaux,
                sinon on a bien la relation R
        - soit on ne touche à rien
    *)
Admitted.*)

(*Lemma invariant:
    forall sigma sigma' evs evs',
        Network sigma evs ->
        leq_capture evs evs' ->
        Network sigma' evs' ->
        R_sigma sigma sigma'.
Proof.
    (*
        On procède par induction sur le prefixe pre.
        - Dans le cas de la liste vide, on s'attend à sigma = sigma'
    *)
Admitted.*)

Lemma stability:
    forall ev evs,
        Network evs ->
        List.In ev evs ->
        exists evs',
            leq_capture (ev :: evs') evs
            /\ Network (ev :: evs').
Admitted.

Lemma Accept_Inversion:
forall evs A B pkt index pc,
    Network evs ->
    List.In (privately_Accept A B pkt index pc) evs ->
    exists pc',
        List.In (publicly_Send B A pkt index pc) evs
        /\ saved_index A B index evs
        /\ saved_PC A B pc' evs /\ pc' < pc.
Admitted.

Lemma Accept_unicity:
    forall evs A B pkt index_B pc_B,
        Network ( privately_Accept A B pkt index_B pc_B :: evs ) ->
        ~ (List.In ( privately_Accept A B pkt index_B pc_B ) evs).
Proof.
    intros evs A B pkt index_B pc_B. intros Hnetwork HIn.
    assert ( exists pc',
        List.In (publicly_Send B A pkt index_B pc_B) evs
        /\ saved_index A B index_B evs
        /\ saved_PC A B pc' evs /\ pc' < pc_B ) as (pc1 & ? & ? & ? & ?). admit.
    assert ( exists pc' evs',
        leq_capture (privately_Accept A B pkt index_B pc_B :: evs') evs
        /\ List.In (publicly_Send B A pkt index_B pc_B) evs'
        /\ saved_index A B index_B evs'
        /\ saved_PC A B pc' evs' /\ pc' < pc_B ) as (pc' & evs' & ? & ? & ? & ? & ?). admit.
    assert ( saved_index A B index_B (privately_Accept A B pkt index_B pc_B :: evs') ). admit.
    assert ( saved_PC A B pc_B (privately_Accept A B pkt index_B pc_B :: evs') ). admit.
    assert ( R (privately_Accept A B pkt index_B pc_B :: evs') evs ).
    apply R_leq. auto. admit.
    assert ( pc_B <= pc1 ). eapply R_proj ; eauto. SearchAbout ( ?x < ?y ) .
    eapply Lt.le_not_lt ; eauto.
Admitted.

(* Théorèmes montrant que les prédicats Network_Send, Network_reset et Network_ChallengeRequest peuvent toujours se faire *)

Lemma Send_always_possible:
    forall evs A B,
        Network evs ->
        (exists index, local_index A B index evs)
        /\ (exists pc, local_PC A B pc evs).
Proof.
    (*intros sigma evs B. intro Hnetwork. induction Hnetwork.
    - assumption.
    - unfold init_global_state in H. split.
        * unfold saved_index. unfold lookup_index. subst.
            exists (index_seed B). simpl. rewrite refl_eqb. reflexivity.
        * unfold saved_PC. unfold lookup_PC. subst.
            exists 0. simpl. rewrite refl_eqb. reflexivity.
    -*)
Admitted.

Theorem can_Send:
    forall evs A B pkt,
        Network evs ->
        exists evs' index pc,
            Network evs'
            /\ List.In (publicly_Send B A pkt index pc) evs'
            /\ (exists pre, evs' = pre ++ evs).
Proof.
    intros evs A B pkt. intro Hnetwork.
    pose proof (Send_always_possible evs B A Hnetwork) as ([index Hindex] & [pc Hpc]).
    eexists. exists index. exists pc. split.
    - eapply Network_Send ; eauto.
    - split ; try firstorder.
        exists [publicly_Send B A pkt index pc]. auto.
Qed.

(* Network_reset est peut être redondant, on commente donc le théorème et le lemme associé
Lemma reset_always_possible:
    forall sigma evs B, Network sigma evs -> (exists index, fresh_index B evs index).
Admitted.

Theorem can_reset:
    forall sigma evs B, Network sigma evs ->
        exists sigma1 evs' index,
            Network sigma1 evs'
            /\ List.In (privately_reset B index) evs'
            /\ (exists pre, evs' = pre ++ evs).
Admitted.
*)

Lemma ChallengeRequest_always_possible:
    forall evs A,
        Network evs ->
        exists n0, fresh_nonce A evs n0.
Admitted.

Theorem can_Challenge:
    forall evs A B,
        Network evs ->
        exists evs' n0,
            Network evs'
            /\ List.In (publicly_ChallengeRequest A B n0) evs'
            /\ (exists pre, evs' = pre ++ evs).
Proof.
    intros evs A B. intro Hnetwork.
    pose proof (ChallengeRequest_always_possible evs A Hnetwork) as [n0 Hn0].
    eexists. exists n0. split.
    - eapply Network_ChallengeRequest ; eauto.
    - split ; try firstorder.
        exists [publicly_ChallengeRequest A B n0]. auto.
Qed.

Theorem liveness:
    forall evs A B pkt,
        Network evs ->
        exists evs' index pc,
            Network evs'
            /\ List.In (publicly_Send B A pkt index pc) evs'
            /\ List.In (privately_Accept A B pkt index pc) evs'
            /\ (exists pre, evs' = pre ++ evs).
Proof.
    intros evs A B pkt. intro Hnetwork.
    (*assert ( HsavedIndex : (exists index, saved_index sigma A B index)
        \/ lookup_index sigma A B = None ). apply saved_index_dec.
    destruct HsavedIndex as [(index, HsavedIndex) | HnotIndex].
    - assert ( HsavedPC : (exists pc, saved_PC sigma A B pc)
            \/ lookup_PC sigma A B = None ). apply saved_PC_dec.
        destruct HsavedPC as [(pc, HsavedPC) | HnotPC].
        + assert ( HcanSend : exists sigma' evs' index' pc',
                        Network sigma' evs'
                        /\ List.In (publicly_Send B A pkt index' pc') evs'
                        /\ exists pre, evs' = pre ++ evs ).
            eapply can_Send ; eauto.
    *)
    (* Pour démontrer ce théorème il y a 2 cas possibles :
        cas 1 : les conditions sont réunies pour accepter une requête
            alors pre = [ privately_Accept ... ; publicly_Send ... ]
        cas 2 : au moins une des conditions n'est pas valide
            alors pre = [ privately_Accept ... ; publicly_Send ... ;
                            privately_reset ... ; publicly_ChallengeReply ... ;
                            privately_nonce ... ; publicly_ChallengeRequest ... ]
    Dans le cas 2, il faut montrer que la procédure de Challenge / Reply permet de réunir les conditions
        pour accepter la requête.
    Ces deux cas sont les seuls à montrer car ChallengeRequest et Send peuvent toujours se faire :
        il s'agit des theoremes can_ChallengeRequest et can_Send *)
Admitted.

(* Théorèmes de spoofing *)

(* Fix me: this is not actually spoofing
Theorem spoofing_Accept:
    forall evs A B pkt index pc,
        Network evs ->
        List.In (privately_Accept A B pkt index pc) evs ->
        exists evs',
            Network evs'
            /\ List.In (privately_Accept A B pkt index pc) evs'
            /\ List.In (publicly Attacker A (format_MAC_Send B A pkt index pc)) evs'.
Proof.
    intros evs A B pkt index pc. intros Hnetwork HIn.
    assert (exists pc',
                List.In ( publicly_Send B A pkt index pc ) evs
                /\ saved_index A B index evs
                /\ saved_PC A B pc' evs /\ pc' < pc )
            as
            [pc' (HinSend & (HsavedIndex & (HsavedPC & HorderPC)))].
    + eapply Accept_Inversion ; eauto.
    + eexists. split.
        - eapply Network_Accept ; eauto.
        - split.
            * eapply in_eq.
            * apply in_cons. eapply insert_attack ; eauto.
Qed.*)

(* Théorèmes d'unicité des événements *)

Lemma compatibiliy_knows_in: forall evs A B X,
    List.In (publicly A B X) evs -> knows Attacker evs X.
Proof.
    intros evs A B X. intro HIn.
    apply in_split in HIn as [l1 [l2 HIn]]. subst.
    induction l1.
    - simpl. apply knows_attacker.
    - rewrite <- app_comm_cons. apply knows_later. assumption.
Qed.

Theorem replay: forall evs A B X,
    Network evs ->
    List.In (publicly A B X) evs ->
    forall C, Network ( publicly Attacker C X :: evs ).
Proof.
    intros evs A B X. intros Hnetwork HIn. intro C.
    apply Network_Attack ; try auto.
    apply synth_init. unfold In. apply analz_init. unfold In.
    eapply compatibiliy_knows_in. eauto.
Qed.

Lemma distinct_index_PC_dec:
    forall (index index': string) (pc pc': nat),
        (index = index' /\ pc = pc') \/ (index <> index' \/ pc <> pc').
Admitted.

Theorem safety:
    forall evs index pc A B pkt,
        Network evs ->
        unique ( privately_Accept A B pkt index pc ) evs.
Proof.
    intros evs index pc A B pkt. intro Hnetwork.
    unfold unique. induction Hnetwork.
    - destruct IHHnetwork as [HnotIn | [pre [suff (Hevs & (HnotInPre & HnotInSuff))]]].
        * left. apply not_in_cons. split ; easy.
        * right. exists (publicly Attacker B0 X :: pre). exists suff. split.
            + rewrite <- app_comm_cons. apply f_equal. assumption.
            + split ; try easy. apply not_in_cons. split ; easy.
    - auto.
    - destruct IHHnetwork as [HnotIn | [pre [suff (Hevs & (HnotInPre & HnotInSuff))]]].
        * left. apply not_in_cons. split ; easy.
        * right. exists (privately_reset B0 A0 index_B :: pre). exists suff. split.
            + rewrite <- app_comm_cons. apply f_equal. assumption.
            + split ; try easy. apply not_in_cons. split ; easy.
    - destruct IHHnetwork as [HnotIn | [pre [suff (Hevs & (HnotInPre & HnotInSuff))]]].
        * left. apply not_in_cons. split ; easy.
        * right. exists (publicly_Send B0 A0 pkt0 index_B pc_B :: pre). exists suff. split.
            + rewrite <- app_comm_cons. apply f_equal. assumption.
            + split ; try easy. apply not_in_cons. split ; easy.
    - assert ( Hdiscriminate : (index = index_B /\ pc = pc_B) \/ (index <> index_B \/ pc <> pc_B) ).
        apply distinct_index_PC_dec. destruct Hdiscriminate as [(HindexEq & HpcEq) | Hdistinct].
        * assert ( HeqAccept : privately_Accept A0 B0 pkt0 index_B pc_B =
                                privately_Accept A B pkt index pc). admit.
            right. exists []. exists evs. simpl. split.
            + f_equal. subst. assumption.
            + split ; try easy. rewrite <- HeqAccept. eapply Accept_unicity. eapply Network_Accept ; eauto.
        * assert ( HdistinctAccept : privately_Accept A B pkt index pc <>
                                    privately_Accept A0 B0 pkt0 index_B pc_B ). admit.
            destruct IHHnetwork as [HnotIn | [pre [suff (Hin & HnotInPre & HnotInSuff)]]].
            + left. apply not_in_cons. split ; assumption.
            + right. exists (privately_Accept A0 B0 pkt0 index_B pc_B :: pre). exists suff. split.
                ++ rewrite <- app_comm_cons. apply f_equal. assumption.
                ++ split ; try easy. apply not_in_cons. split ; assumption.
    - destruct IHHnetwork as [HnotIn | [pre [suff (Hevs & (HnotInPre & HnotInSuff))]]].
        * left. apply not_in_cons. split ; try easy.
            apply not_in_cons. split ; easy.
        * right. exists (privately_nonce A0 n0 :: publicly_ChallengeRequest A0 B0 n0 :: pre).
            exists suff. split.
            + rewrite <- app_comm_cons. rewrite <- app_comm_cons. apply f_equal. apply f_equal. assumption.
            + split ; try easy. apply not_in_cons. split ; try easy.
                apply not_in_cons. split ; easy.
    - destruct IHHnetwork as [HnotIn | [pre [suff (Hevs & (HnotInPre & HnotInSuff))]]].
        * left. apply not_in_cons. split ; try easy.
            apply not_in_cons. split ; easy.
        * right. exists (privately_reset B0 A0 index_B :: publicly_ChallengeReply B0 A0 n0 index_B 0 :: pre).
            exists suff. split.
            + rewrite <- app_comm_cons. rewrite <- app_comm_cons. apply f_equal. apply f_equal. assumption.
            + split ; try easy. apply not_in_cons. split ; try easy.
                apply not_in_cons. split ; easy.
Admitted.

(* Théorèmes d'authenticité *)

Lemma in_inv:
    forall {A} (a b: A) (l: list A), List.In a (b :: l) -> a <> b -> List.In a l.
Admitted.

Theorem Send_authenticity:
    forall evs A A' B B' pkt index pc,
        Network evs ->
        List.In (publicly A' B' (format_MAC_Send A B pkt index pc)) evs ->
        List.In (publicly_Send A B pkt index pc) evs.
Proof.
    intros evs A A' B B' pkt index pc. intros Hnetwork HIn.
    induction Hnetwork ; try easy.
    - (* Dans le cas de Network_Attack, on doit discriminer sur X,
            - si X = format_MAC_Send A B pkt index pc alors, comme on a
                synth (analz (knows Attacker evs)) X, on a, par définition de knows_attacker
                    List.In (publicly A B X) evs.
                Ainsi, on a List.In (publicly A B (format_MAC_Send A B pkt index pc)) evs.
                D'où le résultat pour ce cas.
            - sinon, on a alors
                    publicly A' B' (format_MAC_Send A B pkt index pc) <> publicly Attacker B0 X
                et donc on applique l'hypothèse de récurrence
        *)
        admit.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - (* Dans le cas de Network_Send, on doit discriminer sur l'égalité des couples (index, index_B)
        et (pc, pc_B). En effet, il peut très bien y avoir d'autres messages échangés sur le réseau.
        Dans le cas où les deux couples sont égaux, on est dans le cas où le message que l'on souhaite ajouter
        avec Network_Send est celui qui nous intéresse.
        Dans le cas où au moins l'un des deux couples est différent, on est dans le cas d'un autre message,
        on applique alors l'hypothèse de récurrence *)
        assert ( Hdiscriminate : (index = index_B /\ pc = pc_B) \/ (index <> index_B \/ pc <> pc_B) ).
        apply distinct_index_PC_dec. destruct Hdiscriminate as [(HindexEq & HpcEq) | Hdistinct].
        * assert ( HeqSend : publicly_Send A B pkt index pc =
                                publicly_Send B0 A0 pkt0 index_B pc_B). admit.
            rewrite <- HeqSend. apply in_eq.
        * assert ( HdistinctSend : publicly_Send A B pkt index pc <>
                                publicly_Send B0 A0 pkt0 index_B pc_B). admit.
            apply in_cons. apply IHHnetwork. apply in_inv in HIn ; try easy. admit.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - apply in_cons. apply in_cons. apply IHHnetwork. apply in_inv in HIn ; try easy.
        apply in_inv in HIn ; easy.
    - apply in_cons. apply in_cons. apply IHHnetwork. apply in_inv in HIn ; try easy.
        apply in_inv in HIn ; easy.
Admitted.

Theorem ChallengeRequest_authenticity:
    forall evs A A' B B' n0,
        Network evs ->
        List.In (publicly A' B' (format_MAC_ChallengeRequest A B n0)) evs ->
        List.In (publicly_ChallengeRequest A B n0) evs.
Proof.
    intros evs A A' B B' n0. intros Hnetwork HIn.
    induction Hnetwork ; try easy.
    - admit.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - apply in_cons. assert ( Hdiscriminate : (n0 = n1) \/ (n0 <> n1) ). admit.
        destruct Hdiscriminate as [HeqNonce | HdistinctNonce].
        * rewrite <- HeqNonce. assert ( HeqChallRequest : publicly_ChallengeRequest A B n0 =
                                    publicly_ChallengeRequest A0 B0 n0 ). admit.
            rewrite <- HeqChallRequest. apply in_eq.
        * assert ( HdistinctChallReq : publicly_ChallengeRequest A B n0 <>
                                        publicly_ChallengeRequest A0 B0 n1 ). admit.
            apply in_cons. apply IHHnetwork. apply in_inv in HIn ; try easy.
            apply in_inv in HIn ; try easy. admit.
    - apply in_cons. apply in_cons. apply IHHnetwork. apply in_inv in HIn ; try easy.
        apply in_inv in HIn ; easy.
Admitted.

Theorem ChallengeReply_authenticity:
    forall evs A A' B B' n0 index pc,
        Network evs ->
        List.In (publicly A' B' (format_MAC_ChallengeReply A B n0 index pc)) evs ->
        List.In (publicly_ChallengeReply A B n0 index pc) evs.
Proof.
    intros evs A A' B B' n0 index pc. intros Hnetwork HIn.
    induction Hnetwork ; try easy.
    - admit.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - apply in_cons. apply IHHnetwork. apply in_inv in HIn ; easy.
    - apply in_cons.  apply IHHnetwork. apply in_inv in HIn ; try easy.
    - apply in_cons. assert ( Hdiscriminate : (n0 = n1) \/ (n0 <> n1) ). admit.
        destruct Hdiscriminate as [HeqNonce | HdistinctNonce].
        * rewrite <- HeqNonce. assert ( HeqChallReply : publicly_ChallengeReply A B n0 index pc =
                                                        publicly_ChallengeReply B0 A0 n0 index_B 0 ). admit.
            rewrite <- HeqChallReply. apply in_eq.
        * assert ( HdistinctChallRep : publicly_ChallengeReply A B n0 index pc <>
                                        publicly_ChallengeReply B0 A0 n1 index_B 0 ). admit.
            apply in_cons. apply IHHnetwork. apply in_inv in HIn ; try easy.
            apply in_inv in HIn ; try easy. admit.
Admitted.