Require Import List FMap Lia.
Require Import Common Topology Syntax IndexSupport.
Require Import RqRsLang. Import RqRsNotations.

Require Import Ex.TopoTemplate Ex.RuleTemplate.

Set Implicit Arguments.

Local Open Scope list.
Local Open Scope fmap.

Section RssHolder.
  Variable (dtr: DTree).
  Context `{dv:DecValue} `{oifc: OStateIfc}.

  Definition RsWaiting (cidx: IdxT): OPrec :=
    fun ost orq mins =>
      (orq@[downRq])
        >>=[False]
        (fun rqid => In (rsUpFrom cidx, None) rqid.(rqi_rss)).

  Definition RssFullWithId (msgId: IdxT): OPrec :=
    fun ost orq mins =>
      (orq@[downRq])
        >>=[False]
        (fun rqid => Forall (fun ors => match snd ors with
                                        | Some rs => rs.(msg_id) = msgId
                                        | None => False
                                        end) rqid.(rqi_rss)).

  Definition RssFullOne (msgId: IdxT): OPrec :=
    fun ost orq mins =>
      (orq@[downRq])
        >>=[False]
        (fun rqid =>
           List.length rqid.(rqi_rss) = 1 /\
           Forall (fun ors => match snd ors with
                              | Some rs => rs.(msg_id) = msgId
                              | None => False
                              end) rqid.(rqi_rss)).

  Fixpoint putRs (midx: IdxT) (msg: Msg) (rss: list (IdxT * option Msg)) :=
    match rss with
    | nil => nil
    | rs :: rss' =>
      if idx_dec midx (fst rs)
      then (midx, Some msg) :: rss'
      else rs :: (putRs midx msg rss')
    end.

  Definition addRs (orq: ORq Msg) (midx: IdxT) (msg: Msg) :=
    (orq@[downRq])
      >>=[orq]
      (fun rqid => orq +[downRq <- {| rqi_msg := rqid.(rqi_msg);
                                      rqi_rss := putRs midx msg rqid.(rqi_rss);
                                      rqi_midx_rsb := rqid.(rqi_midx_rsb) |}]).

  Fixpoint retRss (rss: list (IdxT * option Msg)): list (Id Msg) :=
    match rss with
    | nil => nil
    | rs :: rss' =>
      match snd rs with
      | Some rsm => (fst rs, rsm) :: (retRss rss')
      | None => retRss rss'
      end
    end.

  Definition getRss (orq: ORq Msg) :=
    (orq@[downRq]) >>=[nil] (fun rqid => retRss rqid.(rqi_rss)).

  Variables
    (ridx msgId rqId: IdxT)
    (prec: OState -> Prop).

  Variable (cidx: IdxT).

  Definition rsTakeOne :=
    rule[ridx]
    :requires (MsgsFrom [rsUpFrom cidx] /\ MsgIdsFrom [msgId] /\
               DownLockMsgId MRq rqId /\
               RsAccepting /\ RsWaiting cidx)
    :transition
       (do (st --> (msg <-- getFirstMsg st.(msgs);
                    return {{ st.(ost),
                              addRs st.(orq) (rsUpFrom cidx) msg,
                              nil }}))).

  Definition rsRelease (trs: OState ->
                             list (Id Msg) (* incoming messages *) ->
                             Msg (* the original request *) ->
                             IdxT (* response back to *) ->
                             OState * Miv) :=
    rule[ridx]
    :requires (MsgsFrom nil /\ DownLockMsgId MRq rqId /\
               DownLockIdxBack /\ RssFullWithId msgId /\
               fun ost _ _ => prec ost)
    :transition
       (do (st --> (rq <-- getDownLockMsg st.(orq);
                   rsbTo <-- getDownLockIdxBack st.(orq);
                   nst ::= trs st.(ost) (getRss st.(orq)) rq rsbTo;
                    return {{ fst nst,
                              removeRq st.(orq) downRq,
                              [(rsbTo, rsMsg rq.(msg_addr) (snd nst))] }}))).

  Definition rsReleaseOne (trs: OState ->
                                Id Msg (* incoming messages *) ->
                                Msg (* the original request *) ->
                                IdxT (* response back to *) ->
                                OState * Miv) :=
    rule[ridx]
    :requires (MsgsFrom nil /\ DownLockMsgId MRq rqId /\
               DownLockIdxBack /\ RssFullOne msgId /\
               fun ost _ _ => prec ost)
    :transition
       (do (st --> (rq <-- getDownLockMsg st.(orq);
                   rsbTo <-- getDownLockIdxBack st.(orq);
                   nst ::= trs st.(ost) (getFirstIdMsgI (getRss st.(orq))) rq rsbTo;
                    return {{ fst nst,
                              removeRq st.(orq) downRq,
                              [(rsbTo, rsMsg rq.(msg_addr) (snd nst))] }}))).

End RssHolder.

Notation "'rule.rsuo' '[' RIDX ']' ':accepts' MSGID ':holding' RQID ':from' FROM" :=
  (rsTakeOne RIDX MSGID RQID FROM) (at level 5, only parsing).

Notation "'rule.rsr' '[' RIDX ']' ':holding' RQID ':rs-holding' MSGID ':requires' PREC ':transition' TRS" :=
  (rsRelease RIDX MSGID RQID PREC TRS%trs) (at level 5, only parsing).

Notation "'rule.rsro' '[' RIDX ']' ':holding' RQID ':rs-holding' MSGID ':requires' PREC ':transition' TRS" :=
  (rsReleaseOne RIDX MSGID RQID PREC TRS%trs) (at level 5, only parsing).


(************************************************************************)
(* Copyright (c) 2017-2018, Ajay Kumar Eeralla <ae266@mail.missouri.edu>*)
(************************************************************************)

Require Export prop_17.
Require Import Coq.Bool.Bool.
Set Nested Proofs Allowed.
Section lemma148.

  Definition V (b:bool) :=
    match b with
    | false => (V0 (N 0))
    | true => (V1 (N 0))
    end.

  Definition cn (b:bool) :nat :=
    match b with
    | false => 0
    | true => 1
    end.
SearchAbout eqb%bool.
(** abbreviations *)

Definition tau n (m:message) := match n, m with
                                | 1, m => (pi1 m)
                                | 2, m => (pi1 (pi2 m))
                                | 3, m => (pi2 (pi2 m))
                                | _, _ => O
                                end.

Definition d n x := (dec (tau n x) (ske 2)).
Definition pvchecks x := ((pi2 (d 1 x)) #? TWO) & ((pi2 (d 2 x)) #? TWO) & ((pi2 (d 3 x)) #? TWO).
Definition pochecks x := ((tau 3 (d 1 x)) #? THREE) & ((tau 3 (d 2 x)) #? THREE) & ((tau 3 (d 3 x)) #? THREE).

Definition dist x := !((d 1 x) #? (d 2 x)) & !((d 1 x) #? (d 3 x))& ! ((d 2 x) #? (d 3 x)).
Definition isin (x y:message):Bool := (x #? (tau 1 y)) or (x #? (tau 2 y)) or (x #? (tau 3 y)).
Definition bcheck (x y:message):Bool := (isin x ((tau 1 (pi2 (tau 1 y))), ((tau 1 (pi2 (tau 2 y))), (tau 1 (pi2 (tau 3 y)))))).
Definition ncheck (x y:message):Bool := (isin x ((tau 3 (pi2 (tau 1 y))), ((tau 3 (pi2 (tau 2 y))), (tau 3 (pi2 (tau 3 y)))))).

Definition lbl:= |(N 100)|.
Definition label x y := If (x #? (tau 2 (pi2 (tau 1 y)))) then (pi1 (tau 1 y))
                           else  (If (x#? (tau 2 (pi2 (tau 2 y)))) then (pi1 (tau 2 y))
                                                       else (If (x #? (tau 2 (pi2 (tau 3 y)))) then (pi1 (tau 3 y))
                                                             else O)).

Definition bnlcheck( x y z:message):Bool:= (bcheck x z) & (|(label x z)| #? lbl) & (ncheck y z).

Definition mvchecks x (n n':nat) := (dist (x n n')) & (pvchecks (x n n')).

Definition p n x := ( (tau 1 (d n x)), (tau 2 (d n x))).

Definition sotrm x := (shufl (p 1 x) (p 2 x) (p 3 x)).

Definition isink (x y:message):Bool := (x #? (tau 2 (d 1 y))) or (x #? (tau 2 (d 2 y))) or (x #? (tau 2 (d 3 y))).
(** **)
Axiom funcapp_f1m': forall {n n'} f p1 (z z':mylist n) (z1 z1':mylist n'), (z ++ z1) ~ (z' ++ z1') -> ((z ++ z1) ++ [msg (f (ostomsg (getelt_at_pos p1 z1)))]) ~ ((z' ++ z1') ++ [msg (f (ostomsg (getelt_at_pos p1 z1')))]).
Ltac funcapp_f1m'_in g n H:= apply funcapp_f1m' with (f:=g) (p1:=n) in H; unfold getelt_at_pos in H; simpl in H.
Axiom ifmor_ifm: forall f b x y, (f (If b then x else y)) # (If b then (f x) else (f y)).
 Lemma extFuncapp1: forall n b b' x x' y y' (z z': mylist n) g, (z ++ [bol b, msg (If b then x else y)]) ~ (z' ++ [bol b', msg (If b' then x' else y')]) -> (z ++ [bol b, msg (If b then x else y), msg (If b then (g x) else |_)])~ (z' ++ [bol b', msg (If b' then x' else y'), msg (If b' then (g x') else |_)]).

                      Proof. intros.

                             funcapp_f1m'_in g 2 H.

                             simpl.
                             repeat rewrite ifmor_ifm in H.
funcapp_fm_last |_ H; auto.    apply ind_assoc in H; simpl in H.
       apply funcapp_f3bm' with (f:= (ifm_then_else_)) (p1:= 1) (p2:=3) (p3:=4) in H; unfold getelt_at_pos; simpl in H.
       simpl in H.
(********************)

       apply ind_assoc in H; simpl in H.

 do 2  apply restr with (p:= droplastsec) in H; unfold droplastsec in H; simpl in H; simpl; try rewrite Nat.eqb_refl; auto.
 repeat rewrite aply_ifeval_gen in H;auto. Qed.

                      Axiom eqm_cong: forall m1 m2 m3 m4, m1 # m2 -> m3 # m4 -> (eqm m1 m3) ## (eqm m2 m4).
Set Nested Proofs Allowed.
Add Parametric Morphism: (@ eqm) with
    signature EQm ==> EQm ==> EQb as eqm_mor.
Proof.    intros.  rewrite H, H0. reflexivity.  Qed.
Axiom orB_cong: forall b1 b2 b3 b4, b1 ## b2 -> b3 ## b4 -> (IF b1 then TRue else b3) ## (IF b2 then TRue else b4).
Add Parametric Morphism: (@orB) with
      signature EQb ==> EQb ==> EQb as orB_mor.
Proof. intros. apply orB_cong; auto.  Qed.
Lemma rep_first_ballot: forall t t0 t1 : message,
      let v0 := V0 (N 0) in
      let v1 := V1 (N 0) in
      (| v0 |) #? (| v1 |) ## TRue ->
      Fresh [1; 2; 3; 4] [msg t, msg v0, msg v1, msg t0, msg t1] = true ->
      closMylist [msg t] = true ->
      (Datatypes.length (distMvars [msg t0, msg t1]) =? 2)%nat = true ->
      bVarMylist [msg t0, msg t1] = nil ->
      let mvl := [5; 6] in
      mVarMsg t0 = mvl /\ mVarMsg t1 = mvl ->

                 let r0 := (r 1) in
                 let r1 := (r 2) in
                 let k0 := (kc (N 3)) in
                 let k1 := (kc (N 4)) in
                 let c00 := (comm v0 k0) in
                 let c01 := (comm v0 k1) in
                 let c10 := (comm v1 k0) in
                 let c11 := (comm v1 k1) in
                 let b00 := (bl c00 t r0) in
                 let b11 := (bl c11 t r1) in
                 let b10 := (bl c10 t r0) in
                 let b01 := (bl c01 t r0) in
                 let t2 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t0)) in
                 let t3 := ({{ 5 := (bl c00 t r0) }} ({{ 6:=(bl c11 t r1) }} t1)) in
                 let t4 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t0)) in
                 let t5 := ({{ 5 := (bl c10 t r0) }} ({{ 6:=(bl c01 t r1) }} t1)) in
                 let e00 := (enc ((c00, ((ub c00 t r0 t2), (N 0))), TWO) (pke 11) (er 7)) in
                 let e11 := (enc ((c11, ((ub c11 t r1 t3), (N 1))), TWO) (pke 11) (er 8)) in
                 let e10 := (enc ((c10, ((ub c10 t r0 t4), (N 0))), TWO) (pke 11) (er 7)) in
                 let e01 := (enc ((c01, ((ub c01 t r1 t5), (N 1))), TWO) (pke 11) (er 8)) in
                 let pv00 := (c00, ((ub c00 t r0 t2), (N 0))) in
                 let pv11 := (c11, ((ub c11 t r1 t3), (N 1))) in
                 let pv10 := (c10, ((ub c10 t r0 t4), (N 0))) in
                 let pv01 := (c01, ((ub c01 t r1 t5), (N 1))) in
                 let phi02:= [msg b00, msg b11, msg e00, msg e11] in
                 let phi12:= [msg b10, msg b01, msg e10, msg e01] in
                 let fphi02:= f (toListm phi02) in

                 let s0 := (If (! (isin pv00 ((pi1 (d 1 fphi02)), ((pi1 (d 2 fphi02)), (pi1 (d 3 fphi02)))))) then (shufl (pi1 (d 1 fphi02)) (pi1 (d 2 fphi02)) (pi1 (d 3 fphi02))) else O)in

                 let dv0 := (If (dist fphi02) & (pvchecks fphi02) then s0 else |_) in
                 let fphi12:= f (toListm phi12) in
                 let s1 := (If (! (isin pv10 ((pi1 (d 1 fphi12)), ((pi1 (d 2 fphi12)), (pi1 (d 3 fphi12)))))) then (shufl (pi1 (d 1 fphi12)) (pi1 (d 2 fphi12)) (pi1 (d 3 fphi12))) else O)in
                 let dv1 := (If (dist fphi12) & (pvchecks fphi12) then s1 else |_) in
                 let acc00 := (acc c00 t r0 t2) in
                 let acc11 := (acc c11 t r1 t3) in
                 let acc10 := (acc c10 t r0 t4) in
                 let acc01 := (acc c01 t r1 t5) in
                 let phi03:= phi02 ++[msg dv0] in
                 let phi13:= phi12 ++[msg dv1] in
                 let fphi03 := f (toListm phi03) in
                 let l00 := (If (bnlcheck c00 (N 0) fphi03) then (enc ((label c00 fphi03), (k0, THREE)) (pke 11) (er 9)) else O) in
                 let l11 := (If (bnlcheck c11 (N 1) fphi03) then (enc ((label c11 fphi03), (k1, THREE)) (pke 11) (er 10)) else O) in
                 let fphi13 := f (toListm phi13) in
                 let l10 := (If (bnlcheck c10 (N 0) fphi13) then (enc ((label c10 fphi13), (k0, THREE)) (pke 11) (er 9)) else O) in
                 let l01 := (If (bnlcheck c01 (N 1) fphi13) then (enc ((label c01 fphi13), (k1, THREE)) (pke 11) (er 10)) else O) in
                 let phi05:= phi03++[msg l00, msg l11] in
                 let phi15:= phi13++[msg l10, msg l01] in
                 let fphi05 := f (toListm phi05) in
                 let fphi15 := f (toListm phi15) in
                 let do0 := (If (dist fphi05)& (pochecks fphi05)& (((isink k0 fphi05)&(isink k1 fphi05)) or (! ((isink k0 fphi05)or (isink k1 fphi05)))) then (sotrm fphi05) else |_) in
   let do1 := (If (dist fphi15)& (pochecks fphi15)& ((isink k0 fphi15)&(isink k1 fphi15)) (* or (! ((isink k0 fphi15)or (isink k1 fphi15)))) *) then (sotrm fphi15) else |_) in
                 let t0s0 := (If acc00 & acc11 then ((e00, (e11, dv0)), (l00, (l11, do0))) else |_) in
                 let t1s1 := (If acc10 & acc01 then ((e10, (e01, dv1)), (l10, (l01, do1))) else |_) in
                 (occur_name_mylist 100 [msg t, msg t0, msg t1] = false) -> (Fresh (cons 0 nil) [msg t, msg t2, msg t3, msg t4, msg t5] = true) ->
                 [msg b00, msg b11, msg t0s0] ~ [msg b10, msg b01, msg t1s1].

Proof.            intros.
                      unfold t0s0, t1s1, l00, l10, bnlcheck.
                      (** x ~ y **)
                      (**x~ x' and y~y', x' ~ y' **)
                      (** replace the first voters' nonce (N 0) with a fresh nonce (N 20) **)

                      unfold do0, dv0.
                      unfold s0. unfold e00.
Axiom dummy: forall {n} (z z': mylist n), z ~ z'.
pose proof(dummy  [msg b00, msg b11,
   msg
     (If (acc00) & acc11
         then (e00,
              (e11,
              If (dist fphi02) & (pvchecks fphi02)
                 then If ! (isin pv00 (pi1 (d 1 fphi02), (pi1 (d 2 fphi02), pi1 (d 3 fphi02))))
                         then shufl (pi1 (d 1 fphi02)) (pi1 (d 2 fphi02)) (pi1 (d 3 fphi02))
                         else O
                 else |_),
              (l00,
              (l11,
              If (dist fphi05) &
                 (pochecks fphi05) & ((isin k0 fphi05) & (isin k1 fphi05)) or ! ((isin k0 fphi05) or (isin k1 fphi05))
                 then sotrm fphi05
                 else |_)))
         else |_)] (let phi02' := [msg b00, msg b11, msg {(c00, (ub c00 t r0 t2, N 20), TWO) }_ 11 ^^ 7 , msg e11] in
                                          let fphi02':= f (toListm phi02') in
                                          let s0' := (If (! (isin pv00 ((pi1 (d 1 fphi02')), ((pi1 (d 2 fphi02')), (pi1 (d 3 fphi02')))))) then (shufl (pi1 (d 1 fphi02')) (pi1 (d 2 fphi02')) (pi1 (d 3 fphi02'))) else O) in
                                          let dv0' :=  (If (dist fphi02') & (pvchecks fphi02') then s0' else |_) in
                                          let phi03':= phi02' ++ [msg (shufl (pi1 (d 1 fphi02')) (pi1 (d 2 fphi02')) (pi1 (d 3 fphi02')))] in
                                          let fphi03':= f (toListm phi03') in
                                          let l00' := (If (bnlcheck c00 (N 0) fphi03') then (enc ((label c00 fphi03'), (k0, THREE)) (pke 11) (er 9)) else O) in
                                          let l11' := (If (bnlcheck c11 (N 1) fphi03') then (enc ((label c11 fphi03'), (k1, THREE)) (pke 11) (er 10)) else O) in
                                          let phi05':= phi03' ++ [msg l00', msg l11'] in
                                          let fphi05':= f (toListm phi05') in
                                          let do0' := (If (dist fphi05')& (pochecks fphi05')& (((isink k0 fphi05')&(isink k1 fphi05')) or (! ((isink k0 fphi05')or (isink k1 fphi05')))) then (sotrm fphi05') else |_) in
                                          [msg b00, msg b11, msg (If (acc00) & acc11 then ( (enc (c00, (ub c00 t r0 t2, N 20), TWO) (pke 11) (er 9)) , (e11, dv0'), (l00', (l11', do0'))) else |_)])).
 unfold e10.
assert( (let phi02' :=
          [msg b00, msg b11,
          msg {(c00, (ub c00 t r0 t2, N 20), TWO) }_ 11 ^^ 7,
          msg e11] in
         let fphi02' := f (toListm phi02') in
        let s0' :=
          If ! (isin pv00
                  (pi1 (d 1 fphi02'), (pi1 (d 2 fphi02'), pi1 (d 3 fphi02'))))
             then shufl (pi1 (d 1 fphi02')) (pi1 (d 2 fphi02'))
                    (pi1 (d 3 fphi02'))
             else O in
        let dv0' := If (dist fphi02') & (pvchecks fphi02')
                       then s0'
                       else |_ in
        let phi03' :=
          phi02' ++
          [msg
             (shufl (pi1 (d 1 fphi02')) (pi1 (d 2 fphi02'))
                (pi1 (d 3 fphi02')))] in
        let fphi03' := f (toListm phi03') in
        let l00' :=
          If bnlcheck c00 (N 0) fphi03'
             then (enc (label c00 fphi03', (k0, THREE)) (pke 11) (er 9))
             else O in
        let l11' :=
          If bnlcheck c11 (N 1) fphi03'
             then (enc (label c11 fphi03', (k1, THREE)) (pke 11) (er 10))
             else O in
        let phi05' := phi03' ++ [msg l00', msg l11'] in
        let fphi05' := f (toListm phi05') in
        let do0' :=
          If (dist fphi05') &
             (pochecks fphi05') &
             ((isink k0 fphi05') & (isink k1 fphi05')) (*or
             ! ((isink k0 fphi05') or (isink k1 fphi05')) *)
             then sotrm fphi05'
             else |_ in
        [msg b00, msg b11,
        msg
          (If (acc00) & acc11
              then ((enc (c00, (ub c00 t r0 t2, N 20), TWO) (pke 11) (er 9)),
                   (e11, dv0'), (l00', (l11', do0')))
           else |_)]) ~

                      (let phi12' :=
          [msg b10, msg b01,
          msg {(c10, (ub c10 t r0 t4, N 20), TWO) }_ 11 ^^ 7,
          msg e01] in
        let fphi12' := f (toListm phi12') in
        let s1' :=
          If ! (isin pv10
                  (pi1 (d 1 fphi12'), (pi1 (d 2 fphi12'), pi1 (d 3 fphi12'))))
             then shufl (pi1 (d 1 fphi12')) (pi1 (d 2 fphi12'))
                    (pi1 (d 3 fphi12'))
             else O in
        let dv1' := If (dist fphi12') & (pvchecks fphi12')
                       then s1'
                       else |_ in
        let phi13' :=
          phi12' ++
          [msg
             (shufl (pi1 (d 1 fphi12')) (pi1 (d 2 fphi12'))
                (pi1 (d 3 fphi12')))] in
        let fphi13' := f (toListm phi13') in
        let l10' :=
          If bnlcheck c10 (N 0) fphi13'
             then (enc (label c10 fphi13', (k0, THREE)) (pke 11) (er 9))
             else O in
        let l01' :=
          If bnlcheck c10 (N 1) fphi13'
             then (enc (label c10 fphi13', (k1, THREE)) (pke 11) (er 10))
             else O in
        let phi15' := phi13' ++ [msg l10', msg l01'] in
        let fphi15' := f (toListm phi15') in
        let do1' :=
          If (dist fphi15') &
             (pochecks fphi15') &
             ((isink k0 fphi15') & (isink k1 fphi15')) (* or
             ! ((isink k0 fphi15') or (isink k1 fphi15')) *)
             then sotrm fphi15'
             else |_ in
        [msg b10, msg b01,
        msg
          (If (acc10) & acc01
              then ((enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 9)),
                   (e01, dv1'), (l10', (l01', do1')))
           else |_)])).
simpl.
assert( (ncheck (N 0) (f
                                 [b10; b01; (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7)); e01;
                                 shufl (pi1 (d 1 (f [b10; b01; (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7)); e01])))
                                   (pi1 (d 2 (f [b10; b01; (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7)); e01])))
                                   (pi1 (d 3 (f [b10; b01; (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7)); e01])))])) ## FAlse).
unfold ncheck.
unfold isin.

Lemma tau1: forall x y z, (tau 1 (x, (y, z))) # x.
Proof. intros. unfold tau. rewrite proj1; auto. reflexivity.
Qed.
Lemma tau2: forall x y z, (tau 2 (x, (y, z))) # y.
Proof. intros. unfold tau; rewrite proj2, proj1;auto. reflexivity. Qed.
Lemma tau3: forall x y z, (tau 3 (x, (y, z))) # z.
Proof. intros. unfold tau. repeat rewrite proj2; try reflexivity.
Qed.
(*Eval compute in FAlse or TRue. *)
rewrite tau1, tau2, tau3.
Axiom freshneq: forall (n : nat) (m : message),
       ^? (m) = true  -> Fresh (cons n nil) [msg m] = true ->
       ([bol (N n) #? m]) ~ [bol FAlse].
simpl.
pose proof(freshneq 0 (pi2
      (pi2
         (pi2
            (pi1
               (f
                  [b10; b01; (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                  e01;
                  shufl
                    (pi1
                       (d 1
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))
                    (pi1
                       (d 2
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))
                    (pi1
                       (d 3
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))])))))).
simpl in H8.

simpl in H1. rewrite andb_true_iff in H1. inversion H1.
repeat rewrite H9 in H8.
unfold t4, t5 in H8.
 rewrite  clos_sub_vtrm in H8;auto.
 rewrite  clos_sub_vtrm in H8;auto.
repeat rewrite andb_true_r, andb_true_l in H8.
 unfold Fresh in H8, H6.  simpl in H8, H6.
 (** ********)
 assert( occur_name_msg 0 t = false).
destruct (occur_name_msg 0 t). simpl in H6.
inversion H6. reflexivity.
assert( occur_name_msg 0 t2 = false).
destruct (occur_name_msg 0 t2).
simpl in H6. rewrite H11 in H6. simpl in H6. inversion H6. reflexivity.
assert( occur_name_msg 0 t3 = false).
destruct (occur_name_msg 0 t3).
simpl in H6. rewrite H12 in H6. simpl in H6. inversion H6. rewrite H11. reflexivity. reflexivity.
assert( occur_name_msg 0 t4 = false).
destruct (occur_name_msg 0 t4).
simpl in H6. rewrite H11, H12, H13 in H6. simpl in H6. inversion H6. reflexivity.
assert( occur_name_msg 0 t5 = false).
destruct (occur_name_msg 0 t5).
simpl in H6. rewrite H11, H12, H13, H14 in H6. simpl in H6. inversion H6. reflexivity.
fold t4 in H8.
rewrite H11, H14, H15 in H8. simpl in H8.
Axiom consteql: forall x f, const_bol f = true -> [bol x]~[bol f] -> x ## f.
assert( (const_bol FAlse) = true). reflexivity.
apply consteql in H8; auto.
rewrite H8.
(** prove N0 is fresh in tau2 of the decrypted message **)

pose proof(freshneq 0 (pi2
      (pi2
         (pi2
            (pi1
               (pi2 (f
                  [b10; b01; (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                  e01;
                  shufl
                    (pi1
                       (d 1
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))
                    (pi1
                       (d 2
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))
                    (pi1
                       (d 3
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))]))))))).
simpl in H17.

repeat rewrite H9 in H17.
unfold t4, t5 in H17.
 rewrite  clos_sub_vtrm in H17;auto.
 rewrite  clos_sub_vtrm in H17;auto. simpl in H17.
 unfold Fresh in H17; simpl in H17.
 fold t4 in H17.
 rewrite H11, H14, H15 in H17. simpl in H17.

apply consteql in H17; auto.
rewrite H17.
clear H8 H17.

pose proof(freshneq 0 (pi2 (pi2 (pi2 (pi2 (pi2 (f
                  [b10; b01; (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                  e01;
                  shufl
                    (pi1
                       (d 1
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))
                    (pi1
                       (d 2
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))
                    (pi1
                       (d 3
                          (f
                             [b10; b01;
                             (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7));
                             e01])))]))))))).
simpl in H8.
unfold t4, t5 in H8.
 rewrite  clos_sub_vtrm in H8;auto.
 rewrite  clos_sub_vtrm in H8;auto. simpl in H8.
repeat rewrite H9 in H8. simpl in H8.
unfold Fresh in H8; simpl in H8.
fold t4 in H8.
rewrite H11, H14, H15 in H8. simpl in H8.
apply consteql in H8; auto.
rewrite H8; clear H8; auto.
unfold orB.
 repeat rewrite IFFALSE_B. reflexivity.
  (left;inversion H4; unfold distMvars; simpl; try rewrite H17; try rewrite H18; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H17; try rewrite H18; try rewrite H19; try rewrite H11; try rewrite H12; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H17; try rewrite H18; try rewrite H19; try rewrite H11; try rewrite H12; try reflexivity).

(*******************************************)
assert( let x:= (enc (c10, (ub c10 t r0 t4, N 20), TWO) (pke 11) (er 7)) in (bnlcheck c10 (N 0)
                  (f
                     [b10; b01; x; e01;
                     shufl (pi1 (d 1 (f [b10; b01; x; e01])))
                       (pi1 (d 2 (f [b10; b01; x; e01])))
                       (pi1 (d 3 (f [b10; b01; x; e01])))])) ## FAlse).
simpl. unfold bnlcheck.
rewrite H8. repeat rewrite andB_FAlse_r; try reflexivity.
rewrite H9.
rewrite IFFALSE_M.
clear H8 H9.
(********************************************)

assert( let x:= (enc (c00, (ub c00 t r0 t2, N 20), TWO) (pke 11) (er 7)) in  (bnlcheck c00 (N 0)
                    (f
                       [b00; b11; x; e11;
                       shufl (pi1 (d 1 (f [b00; b11; x; e11])))
                         (pi1 (d 2 (f [b00; b11; x; e11])))
                         (pi1 (d 3 (f [b00; b11; x; e11])))])) ## FAlse).
 unfold bnlcheck.
unfold ncheck. unfold isin.
rewrite tau1, tau2, tau3.
pose proof( freshneq 0 (let x:= (enc (c00, (ub c00 t r0 t2, N 20), TWO) (pke 11) (er 7)) in (tau 3 (pi2 (tau 1 (f
                       [b00; b11; x; e11;
                       shufl (pi1 (d 1 (f [b00; b11; x; e11])))
                         (pi1 (d 2 (f [b00; b11; x; e11])))
                         (pi1 (d 3 (f [b00; b11; x; e11])))])))))).
simpl in H8.
unfold t2, t3 in H8.
 rewrite  clos_sub_vtrm in H8;auto.
 rewrite  clos_sub_vtrm in H8;auto. simpl in H8.
simpl in H1.
simpl in H1. rewrite andb_true_iff in H1. inversion H1.
repeat rewrite H9 in H8.
simpl in H8.
unfold Fresh in H8, H6; simpl in H8, H6.
assert( occur_name_msg 0 t = false).
destruct (occur_name_msg 0 t). simpl in H6.
inversion H6. reflexivity.
assert( occur_name_msg 0 t2 = false).
destruct (occur_name_msg 0 t2).
simpl in H6. rewrite H11 in H6. simpl in H6. inversion H6. reflexivity.
assert( occur_name_msg 0 t3 = false).
destruct (occur_name_msg 0 t3).
simpl in H6. rewrite H12 in H6. simpl in H6. inversion H6. rewrite H11. reflexivity. reflexivity.
fold t2 in H8.
rewrite H11, H12, H13 in H8. simpl in H8.
apply consteql in H8; auto; try  (left;inversion H4; unfold distMvars; simpl; try rewrite H16; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
Axiom extcomphid: forall {n} (z z': mylist n), z ~ z'.
(******)
pose proof( freshneq 0 (let x:= (enc (c00, (ub c00 t r0 t2, N 20), TWO) (pke 11) (er 7)) in (tau 3 (pi2 (tau 2 (f
                       [b00; b11; x; e11;
                       shufl (pi1 (d 1 (f [b00; b11; x; e11])))
                             (pi1 (d 2 (f [b00; b11; x; e11])))
                             (pi1 (d 3 (f [b00; b11; x; e11])))])))))).
simpl in H14.
rewrite H9 in H14.
unfold t2, t3 in H14.
 rewrite  clos_sub_vtrm in H14;auto.
 rewrite  clos_sub_vtrm in H14;auto. simpl in H14.
unfold Fresh in H14. simpl in H14.
fold t2 in H14.
rewrite H11, H12, H13 in H14. simpl in H14.
apply consteql in H14; auto; try (left;inversion H4; unfold distMvars; simpl; try rewrite H16; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(*******************************)
pose proof(freshneq 0 (let x:= (enc (c00, (ub c00 t r0 t2, N 20), TWO) (pke 11) (er 7)) in (tau 3 (pi2 (tau 3 (f
                       [b00; b11; x; e11;
                       shufl (pi1 (d 1 (f [b00; b11; x; e11])))
                             (pi1 (d 2 (f [b00; b11; x; e11])))
                             (pi1 (d 3 (f [b00; b11; x; e11])))])))))).
simpl in H15.
rewrite H9 in H15.
unfold t2, t3 in H15.
 rewrite  clos_sub_vtrm in H15;auto.
 rewrite  clos_sub_vtrm in H15;auto. simpl in H15.
unfold Fresh in H15, H6. simpl in H15, H6.
fold t2 in H15.
rewrite H11, H12, H13 in H15. simpl in H15.
apply consteql in H15; auto; try (left; try inversion H4; unfold distMvars; simpl; try rewrite H16; try rewrite H17; try reflexivity).
rewrite H8, H14, H15. unfold orB. repeat rewrite IFFALSE_B. simpl.
repeat rewrite andB_FAlse_r; try reflexivity.
(left;inversion H4; unfold distMvars; simpl; try rewrite H16; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H16;  try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H16;  try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H15;  try rewrite H16; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H9;  try rewrite H10; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity).
(left;inversion H4; unfold distMvars; simpl; try rewrite H9;  try rewrite H10; try rewrite H17; try rewrite H18; try rewrite H19; try reflexivity). rewrite H8.
rewrite IFFALSE_M.
unfold isink.
unfold k0.
(** we need to prove that the attacker cannot compute the commitment key **)
pose proof (ENCCCA2).
Axiom infeasible_comp_ck: forall n t g, (closMsg t) = true ->
                                          (** (distMvars [msg t']) = (cons m nil) ->  I can prove this:Fresh (cons n nil) [msg t, msg t'] = true **) ((g t) #? (kc (N n)))  ## FAlse.
(*** I will prove this later **) unfold b00.
(*Eval compute in b00. *)
Axiom eqm_sym: forall m1 m2, (m1 #? m2) ## (m2 #? m1).
 repeat rewrite eqm_sym with (m1:= (kc (N 3))).
repeat rewrite infeasible_comp_ck with (n:= 3); auto.
unfold orB.
repeat rewrite IFFALSE_B.
repeat rewrite andB_FAlse_l.  repeat rewrite andB_FAlse_r. repeat rewrite IFFALSE_M. simpl.
(** we replace the encryption that emits *)

pose proof(compHid_ext).
apply extcomphid.

 simpl.
simpl in H1;
rewrite andb_true_iff in H1;
inversion H1;
rewrite H10; unfold t4, t5; repeat rewrite clos_sub_vtrm;try left; inversion H4; unfold distMvars; simpl; try rewrite H12; try rewrite H13; try reflexivity.

simpl.
simpl in H1;
rewrite andb_true_iff in H1;
inversion H1;
rewrite H10; unfold t4, t5; repeat rewrite clos_sub_vtrm;try left; inversion H4; unfold distMvars; simpl; try rewrite H12; try rewrite H13; try reflexivity.

simpl.
simpl in H1;
rewrite andb_true_iff in H1;
inversion H1;
rewrite H10; unfold t4, t5; repeat rewrite clos_sub_vtrm;try left; inversion H4; unfold distMvars; simpl; try rewrite H12; try rewrite H13; try reflexivity.

simpl.
simpl in H1;
rewrite andb_true_iff in H1;
inversion H1;
rewrite H10; unfold t2, t3; repeat rewrite clos_sub_vtrm;try left; inversion H4; unfold distMvars; simpl; try rewrite H12; try rewrite H13; try reflexivity.

simpl.
simpl in H1;
rewrite andb_true_iff in H1;
inversion H1;
rewrite H10; unfold t2, t3; repeat rewrite clos_sub_vtrm;try left; inversion H4; unfold distMvars; simpl; try rewrite H12; try rewrite H13; try reflexivity.

simpl.
simpl in H1;
rewrite andb_true_iff in H1;
inversion H1;
rewrite H10; unfold t2, t3; repeat rewrite clos_sub_vtrm;try left; inversion H4; unfold distMvars; simpl; try rewrite H12; try rewrite H13; try reflexivity.
apply extcomphid.
Qed.
End lemma148.


From iris Require Import program_logic.weakestpre.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import invariants gen_heap.

Local Notation "l ↦ v" := (mapsto l (DfracOwn 1) v)
  (at level 20, format "l  ↦  v") : bi_scope.

From st.prelude Require Import big_op_three.

From st.STLCmuVS Require Import lang contexts.
From st.STLCmuST Require Import wkpre lang types contexts.

From st.backtranslations.st_sem Require Import ghost heap_emul.base.
From st.backtranslations.st_sem.correctness.st_le_sem.logrel Require Import lift.
From st Require Import resources.

Section value_relation.

  Context `{Σ : !gFunctors} `{st_le_semΣ_inst : !st_le_semΣ Σ}.

  (* Context `{inG_Σ_auth_nat_to_ag_loc : !inG Σ () } *)
  Context (Δ : list (gname * gname)).

  Fixpoint valrel_typed_gen_pre (Ψ : typeO -n> valO -n> STLCmuVS.lang.valO -n> iPropO Σ) (τ : typeO) : valO -n> STLCmuVS.lang.valO -n> iPropO Σ := λne v v',
    (match τ with
     | TUnit => ⌜ v = (()%Vₛₜ : valO) ⌝ ∧ ⌜ v' = (()%Vₙₒ : STLCmuVS.lang.valO) ⌝
     | TBool => ∃ b : bool, ⌜ v = b ⌝ ∧ ⌜ v' = b ⌝
     | TInt => ∃ z : Z, ⌜ v = z ⌝ ∧ ⌜ v' = z ⌝
     | TProd τ1 τ2 => ∃ v1 v2 v1' v2', ⌜ v = (v1, v2)%Vₛₜ ⌝ ∧ ⌜ v' = (v1' , v2')%Vₙₒ ⌝ ∗ valrel_typed_gen_pre Ψ τ1 v1 v1' ∗ valrel_typed_gen_pre Ψ τ2 v2 v2'
     | TSum τ1 τ2 => ∃ vi vi', (⌜ v = InjLV vi ⌝ ∧ ⌜ v' = STLCmuVS.lang.InjLV vi' ⌝ ∧ valrel_typed_gen_pre Ψ τ1 vi vi') ∨
                              (⌜ v = InjRV vi ⌝ ∧ ⌜ v' = STLCmuVS.lang.InjRV vi' ⌝ ∧ valrel_typed_gen_pre Ψ τ2 vi vi')
     | TArrow τ1 τ2 => □ (∀ w w', valrel_typed_gen_pre Ψ τ1 w w' -∗ lift MaybeStuck (valrel_typed_gen_pre Ψ τ2) (v w) (v' w'))
     | TRec τb => ∃ w w', ⌜ v = FoldV w ⌝ ∧ ⌜ v' = STLCmuVS.lang.FoldV w' ⌝ ∧ ▷ (Ψ τb.[TRec τb/] w w')
     | TVar X => False
     | TSTref ρ τ =>
       match ρ with
       | TVar X =>
         match Δ !! X with
         | Some (γ, γ') => ∃ (i : nat) (l : loc), ⌜ v = l ⌝ ∧ i ↪[γ]□ l ∧ ⌜ v' = i ⌝ ∧
                             inv (nroot .@ γ .@ γ' .@ i) (∃ (w : val) (w' : STLCmuVS.lang.val), i ↪[γ'] w' ∗ l ↦ w ∗ valrel_typed_gen_pre Ψ τ w w')
         | None => False
         end
       | _ => False
       end
     | TST ρ τ' =>
       match ρ with
       | TVar X =>
         match Δ !! X with
         | Some (γ, γ') => ∀ psᵢ : list (prod loc STLCmuVS.lang.val),
             let lsᵢ := psᵢ.*1 in
             let vsᵢ := psᵢ.*2 in
             □ (auth_list γ lsᵢ ∗ auth_list γ' vsᵢ -∗
                          WP RunST v ?{{ w, ∃ (w' : STLCmuVS.lang.val) (psₜ : list (prod loc STLCmuVS.lang.val)),
                                                let lsₜ := psₜ.*1 in
                                                let vsₜ := psₜ.*2 in
                                                auth_list γ lsₜ ∗
                                                auth_list γ' vsₜ ∗
                                                ⌜ rtc STLCmuVS_step (v' (encode vsᵢ)) (encode vsₜ, w')%Vₙₒ ⌝ ∧
                                                valrel_typed_gen_pre Ψ τ' w w'
                                           }}
               )
         | None => True
         end
       | _ => True
       end
     end)%I.

  Definition valrel_typed_gen (Ψ : typeO -n> valO -n> STLCmuVS.lang.valO -n> iPropO Σ) : typeO -n> valO -n> STLCmuVS.lang.valO -n> iPropO Σ := λne τ v v', valrel_typed_gen_pre Ψ τ v v'.

  Instance valrel_typed_gen_contractive : Contractive valrel_typed_gen.
  Proof.
    intros n P1 P2 dl. rewrite /valrel_typed_gen. intro τ. simpl.
    induction τ; try by solve_contractive.
    - intros v v'. simpl. do 6 f_equiv. specialize (IHτ1 a a0). simpl in IHτ1. by rewrite IHτ1.
      rewrite /lift. do 5 f_equiv. specialize (IHτ2 a1 a2). simpl in IHτ2. by rewrite IHτ2.
    - intros v v'. simpl. destruct τ1; try done. clear IHτ1.
      destruct (Δ !! X) as [γ|] eqn:eq; auto.
      f_equiv. f_equiv. intros i. f_equiv. f_equiv. f_equiv. f_equiv. f_equiv. f_equiv. solve_contractive.
  Qed.

  Definition valrel_typed := fixpoint valrel_typed_gen.

  Lemma valrel_typed_unfold τ v1 v2 : valrel_typed τ v1 v2 ≡ valrel_typed_gen (fixpoint valrel_typed_gen) τ v1 v2.
  Proof. do 3 f_equiv. by rewrite -fixpoint_unfold. Qed.
  Lemma valrel_typed_unfold' τ : valrel_typed τ ≡ valrel_typed_gen (fixpoint valrel_typed_gen) τ.
  Proof. intros x x'. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_unfold'': valrel_typed ≡ valrel_typed_gen (fixpoint valrel_typed_gen).
  Proof. intros x. by rewrite valrel_typed_unfold'. Qed.
  Lemma valrel_typed_gen_pre_gen Ψ τ v v' : valrel_typed_gen_pre Ψ τ v v' ≡ valrel_typed_gen Ψ τ v v'.
  Proof. auto. Qed.
  Lemma valrel_typed_gen_pre_gen' Ψ τ : valrel_typed_gen_pre Ψ τ ≡ valrel_typed_gen Ψ τ.
  Proof. intro. intro. auto. Qed.

  Lemma valrel_typed_TUnit_unfold v v' : valrel_typed TUnit v v' ≡ (⌜ v = (()%Vₛₜ : valO) ⌝ ∧ ⌜ v' = (()%Vₙₒ : STLCmuVS.lang.valO) ⌝)%I.
  Proof. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_TBool_unfold v v' : valrel_typed TBool v v' ≡ (∃ b : bool, ⌜ v = b ⌝ ∧ ⌜ v' = b ⌝)%I.
  Proof. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_TInt_unfold v v' : valrel_typed TInt v v' ≡ (∃ z : Z, ⌜ v = z ⌝ ∧ ⌜ v' = z ⌝)%I.
  Proof. by rewrite valrel_typed_unfold. Qed.
  Lemma valrel_typed_TArrow_unfold τ1 τ2 v v' : valrel_typed (TArrow τ1 τ2) v v' ≡ (□ (∀ w w', valrel_typed τ1 w w' -∗ lift MaybeStuck (valrel_typed τ2) (v w) (v' w')))%I.
  Proof.
    rewrite valrel_typed_unfold. rewrite /valrel_typed_gen. simpl.
    f_equiv. f_equiv. intros w. f_equiv. intro w'. f_equiv.
    - rewrite valrel_typed_gen_pre_gen. unfold valrel_typed. rewrite -valrel_typed_unfold. auto.
    - rewrite /lift. f_equiv. simpl. f_equiv. f_equiv. f_equiv. f_equiv.
      by rewrite valrel_typed_unfold.
  Qed.
  Lemma valrel_typed_TSum_unfold τ1 τ2 v v' : valrel_typed (TSum τ1 τ2) v v' ≡ (∃ vi vi', (⌜ v = InjLV vi ⌝ ∧ ⌜ v' = STLCmuVS.lang.InjLV vi' ⌝ ∧ valrel_typed τ1 vi vi') ∨ (⌜ v = InjRV vi ⌝ ∧ ⌜ v' = STLCmuVS.lang.InjRV vi' ⌝ ∧ valrel_typed τ2 vi vi'))%I.
  Proof. rewrite valrel_typed_unfold. simpl. repeat f_equiv; rewrite valrel_typed_gen_pre_gen'; rewrite -valrel_typed_unfold'; auto. Qed.
  Lemma valrel_typed_TProd_unfold τ1 τ2 v v' : valrel_typed (TProd τ1 τ2) v v' ≡ (∃ v1 v2 v1' v2', ⌜ v = (v1, v2)%Vₛₜ ⌝ ∧ ⌜ v' = (v1' , v2')%Vₙₒ ⌝ ∗ valrel_typed τ1 v1 v1' ∗ valrel_typed τ2 v2 v2')%I.
  Proof. rewrite valrel_typed_unfold. simpl. repeat f_equiv; rewrite valrel_typed_gen_pre_gen'; rewrite -valrel_typed_unfold'; auto. Qed.
  Lemma valrel_typed_TRec_unfold τ v v' : valrel_typed (TRec τ) v v' ≡ (∃ w w', ⌜ v = FoldV w ⌝ ∧ ⌜ v' = STLCmuVS.lang.FoldV w' ⌝ ∧ ▷ (valrel_typed τ.[TRec τ/] w w'))%I.
  Proof. rewrite valrel_typed_unfold. auto. Qed.
  Lemma valrel_typed_TVar_unfold X v v' : valrel_typed (TVar X) v v' ≡ False%I.
  Proof. rewrite valrel_typed_unfold. by simpl. Qed.
  Lemma valrel_typed_TSTRef_unfold ρ τ v v' :
    valrel_typed (TSTref ρ τ) v v' ≡
                 (match ρ with
                  | TVar X =>
                    match Δ !! X with
                    | Some (γ, γ') => ∃ (i : nat) (l : loc), ⌜ v = l ⌝ ∧ i ↪[γ]□ l ∧ ⌜ v' = i ⌝ ∧
                                                    inv (nroot .@ γ .@ γ' .@ i) (∃ (w : val) (w' : STLCmuVS.lang.val), i ↪[γ'] w' ∗ l ↦ w ∗ valrel_typed τ w w')
                 | None => False
                  end
                 | _ => False
                  end)%I.
  Proof. rewrite valrel_typed_unfold. simpl. repeat f_equiv. rewrite valrel_typed_gen_pre_gen'; rewrite -valrel_typed_unfold'; auto. Qed.
  Lemma valrel_typed_TST_unfold ρ τ v v' :
    valrel_typed (TST ρ τ) v v' ≡
      (match ρ with
       | TVar X =>
         match Δ !! X with
         | Some (γ, γ') => ∀ psᵢ : list (prod loc STLCmuVS.lang.val),
             let lsᵢ := psᵢ.*1 in
             let vsᵢ := psᵢ.*2 in
             □ (auth_list γ lsᵢ ∗ auth_list γ' vsᵢ -∗
                          WP RunST v ?{{ w, ∃ (w' : STLCmuVS.lang.val) (psₜ : list (prod loc STLCmuVS.lang.val)),
                                                let lsₜ := psₜ.*1 in
                                                let vsₜ := psₜ.*2 in
                                                auth_list γ lsₜ ∗
                                                auth_list γ' vsₜ ∗
                                                ⌜ rtc STLCmuVS_step (v' (encode vsᵢ)) (encode vsₜ, w')%Vₙₒ ⌝ ∧
                                                valrel_typed τ w w'
                                     }}
               )
         | None => True
         end
       | _ => True
       end
      )%I.
  Proof. rewrite valrel_typed_unfold. simpl. repeat f_equiv. rewrite valrel_typed_gen_pre_gen'; rewrite -valrel_typed_unfold'; auto. Qed.

  Global Instance valrel_typed_persistent τ v v' : Persistent (valrel_typed τ v v').
  Proof.
    rewrite /Persistent. revert τ v v'. iLöb as "IHlob". iIntros (τ).
    iInduction τ as [ | | | τ1 τ2 | τ1 τ2 | τ1 τ2 | τ1 τ2 | τb | ρ τ | ρ τ ] "IH";
      iIntros (v v'); try by rewrite valrel_typed_unfold; iIntros "#H".
    - rewrite valrel_typed_TProd_unfold. iIntros "H". iDestruct "H" as (v1 v2 v1' v2') "(-> & -> & H1 & H2)".
      iExists v1, v2, v1', v2'. repeat iSplit; auto. iApply ("IH" with "H1"). iApply ("IH1" with "H2").
    - rewrite valrel_typed_TSum_unfold. iIntros "H". iDestruct "H" as (vi vi') "[(-> & -> & H1) | (-> & -> & H2)]"; iExists vi, vi'.
      + iLeft. repeat iSplit; auto. by iApply ("IH" with "H1").
      + iRight. repeat iSplit; auto. by iApply ("IH1" with "H2").
    - rewrite valrel_typed_TRec_unfold. iIntros "H". iDestruct "H" as (w w') "(-> & -> & H)". iExists w, w'. repeat iSplitL ""; auto.
      iApply bi.later_persistently_1. iNext. by iApply "IHlob".
    - rewrite valrel_typed_TSTRef_unfold. destruct ρ; auto.
      destruct (Δ !! X); auto. destruct p; auto.
    - rewrite valrel_typed_TST_unfold. destruct ρ; auto.
      destruct (Δ !! X); auto. destruct p; auto.
  Qed.

End value_relation.

Section expr_relation.

  Context `{Σ : !gFunctors} `{st_le_semΣ_inst : !st_le_semΣ Σ}.

  Definition exprel_typed (Δ : list (gname * gname)) : typeO -n> exprO -n> STLCmuVS.lang.exprO -n> iPropO Σ :=
    λne τ eᵢ eₛ, lift MaybeStuck (valrel_typed Δ τ) eᵢ eₛ.

  Definition open_exprel_typed (Γ : list type) (e : expr) (e' : STLCmuVS.lang.expr) (τ : type) :=
    ∀ (Δ : list (gname * gname)) (vs : list val) (vs' : list STLCmuVS.lang.val),
      big_sepL3 (fun τ v v' => valrel_typed Δ τ v v') Γ vs vs' ⊢
                exprel_typed Δ τ e.[subst_list_val vs] e'.[STLCmuVS.lang.subst_list_val vs'].

  Lemma open_exprel_typed_nil' τ e e' : open_exprel_typed [] e e' τ → (∀ Δ, ⊢ exprel_typed Δ τ e e').
  Proof. rewrite /open_exprel_typed. iIntros (Hee' Δ). iDestruct (Hee' Δ [] []) as "H". asimpl. by iApply "H". Qed.

  Lemma open_exprel_typed_nil τ e e' : (∀ Δ, ⊢ exprel_typed Δ τ e e') -> open_exprel_typed [] e e' τ.
  Proof. iIntros (Hee' Δ vs vs') "Hvv'". destruct vs, vs'; auto. asimpl. iApply Hee'. Qed.

  Definition ctx_item_rel_typed (Ci : STLCmuST.contexts.ctx_item) (Ci' : STLCmuVS.contexts.ctx_item) Γ τ Γ' τ' :=
    ∀ e e', open_exprel_typed Γ e e' τ → open_exprel_typed Γ' (STLCmuST.contexts.fill_ctx_item Ci e) (STLCmuVS.contexts.fill_ctx_item Ci' e') τ'.

  Definition ctx_rel_typed (C : STLCmuST.contexts.ctx) (C' : STLCmuVS.contexts.ctx) Γ τ Γ' τ' :=
    ∀ e e', open_exprel_typed Γ e e' τ → open_exprel_typed Γ' (STLCmuST.contexts.fill_ctx C e) (STLCmuVS.contexts.fill_ctx C' e') τ'.

End expr_relation.


(*

  Copyright 2014 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.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export arith_props.
Require Import continuity.
Require Import continuity2_2.
Require Import continuity3_2_v2.
Require Export continuity_defs2.
Require Export continuity_defs_ceq.

Lemma comp_force_int_app_F_c {o} :
  forall lib (F f : @CTerm o) x z,
    reduces_toc
      lib
      (force_int_F_c x F f)
      (mkc_integer z)
    -> {b : nat
        & forall (e : CTerm) b',
            b <= b'
            -> reduces_toc
                 lib
                 (force_int_bound_F_c x b' F f e)
                 (mkc_integer z)}.
Proof.
  introv r.
  unfold reduces_toc in r.
  rw @get_cterm_force_int_F_c in r.
  simpl in r.
  apply comp_force_int_app_F in r; exrepnd; eauto with slow.
  exists b.
  introv l.
  pose proof (r0 (get_cterm e) b') as h.
  repeat (autodimp h hyp); eauto with slow.
  { rw @free_vars_cterm; sp. }
  unfold reduces_toc.
  rw @get_cterm_force_int_bound_F_c; auto.
Qed.

Definition agree_upto_c {o} lib b (f g : @CTerm o) :=
  forall (i : Z),
    Z.abs_nat i < b
    -> {v1 : CTerm
       & {v2 : CTerm
        & reduces_toc lib (mkc_apply f (mkc_integer i)) v1
        # reduces_toc lib (mkc_apply g (mkc_integer i)) v2
        # alphaeqc v1 v2}}.

Lemma comp_force_int_app_F3_c_2 {o} :
  forall lib (F f g : @CTerm o) x z b,
    agree_upto_c lib b f g
    -> reduces_toc
         lib
         (force_int_bound_F_c x b F f (mkc_vbot x))
         (mkc_integer z)
    -> reduces_toc
         lib
         (force_int_bound_F_c x b F g (mkc_vbot x))
         (mkc_integer z).
Proof.
  introv agree r.
  allunfold @reduces_toc.
  allrw @get_cterm_force_int_bound_F_c.
  allsimpl.
  apply (comp_force_int_app_F3_2 lib (get_cterm F) (get_cterm f) (get_cterm g)); auto;
  allrw @free_vars_cterm; allsimpl; tcsp; eauto with slow.
  introv j; apply agree in j.
  exrepnd.
  exists (get_cterm v1) (get_cterm v2).
  destruct_cterms.
  allunfold @reduces_toc; allsimpl.
  allunfold @alphaeqc; allsimpl.
  clear agree.
  allapply @closed_if_isprog.
  rw i3.
  rw i2.
  dands; auto.
Qed.

Lemma comp_force_int_app_F2_c {o} :
  forall lib (F g : @CTerm o) x z b,
    reduces_toc
      lib
      (force_int_bound_F_c x b F g (mkc_vbot x))
      (mkc_integer z)
    -> reduces_toc
         lib
         (force_int_F_c x F g)
         (mkc_integer z).
Proof.
  introv r.
  allunfold @reduces_toc.
  allrw @get_cterm_force_int_bound_F_c.
  allrw @get_cterm_force_int_F_c.
  allsimpl.
  apply (comp_force_int_app_F2 lib (get_cterm F) (get_cterm g) x z b); auto;
  allrw @free_vars_cterm; allsimpl; tcsp; eauto with slow.
Qed.

Lemma mkcv_cont1_mkcv_apply {o} :
  forall v (t1 t2 : @CVTerm o [v,v]),
    mkcv_cont1 v (mkcv_apply [v,v] t1 t2)
    = mkcv_apply [v] (mkcv_cont1 v t1) (mkcv_cont1 v t2).
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkcv_cont1_mk_cv {o} :
  forall v (t : @CTerm o),
    mkcv_cont1 v (mk_cv [v,v] t)
    = mk_cv [v] t.
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma mkcv_cont1_mk_cv_app_r {o} :
  forall v (t : @CVTerm o [v]),
    mkcv_cont1 v (mk_cv_app_r [v] [v] t)
    = t.
Proof.
  introv.
  destruct_cterms.
  apply cvterm_eq; simpl; auto.
Qed.

Lemma equality_force_int_f_c_T {o} :
  forall lib (f : @CTerm o) T,
    member lib f (mkc_fun mkc_int T)
    -> equality lib f (force_int_f_c nvarx f) (mkc_fun mkc_int T).
Proof.
  introv m.
  allrw @equality_in_fun; repnd; dands; auto.
  introv e.

  allrw @equality_in_int.
  allunfold @equality_of_int.
  exrepnd; spcast.

  pose proof (m (mkc_integer k) (mkc_integer k)) as h.
  autodimp h hyp.
  { apply equality_in_int.
    exists k.
    dands; spcast; apply computes_to_valc_refl; eauto 3 with slow. }

  eapply equality_respects_cequivc_left;
    [apply implies_cequivc_apply;
      [apply cequivc_refl
      |apply cequivc_sym;
        apply computes_to_valc_implies_cequivc;
        exact e1]
    |].
  eapply equality_respects_cequivc_right;
    [apply implies_cequivc_apply;
      [apply cequivc_refl
      |apply cequivc_sym;
        apply computes_to_valc_implies_cequivc;
        exact e0]
    |].

  clear dependent a.
  clear dependent a'.

  unfold force_int_f_c.
  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;apply cequivc_beta|].
  rw @mkcv_cbv_substc_same.
  unfold force_int_cv.
  rw @mkcv_add_substc.
  rw @mkc_var_substc.
  rw @mkcv_zero_substc.

  eapply equality_respects_cequivc_right;
    [apply simpl_cequivc_mkc_cbv;
      apply cequivc_sym;
      apply cequivc_mkc_add_integer|].
  rw <- Zplus_0_r_reverse.

  eapply equality_respects_cequivc_right;
    [apply cequivc_sym;
      apply reduces_toc_implies_cequivc;
      apply reduces_toc_mkc_cbv_val;
      eauto 3 with slow|].

  rw @mkcv_cont1_mkcv_apply.
  rw @mkcv_apply_substc.
  rw @mkcv_cont1_mk_cv.
  rw @csubst_mk_cv.
  rw @mkcv_cont1_mk_cv_app_r.
  rw @mkc_var_substc.
  auto.
Qed.

Definition agree_upto_red_bc_T {o} lib b (f g : @CTerm o) T :=
  forall (t1 t2 : CTerm) (i : Z),
    reduces_toc lib t1 (mkc_integer i)
    -> reduces_toc lib t2 (mkc_integer i)
    -> Z.abs_nat i < b
    -> equality lib (mkc_apply f t1) (mkc_apply g t2) T.

Definition simple_eq_type {o} lib (T : @CTerm o) :=
  forall a b,
    equality lib a b T
    -> {v1 : CTerm
        & {v2 : CTerm
        & reduces_toc lib a v1
        # reduces_toc lib b v2
        # alphaeqc v1 v2 }}.

Lemma agree_upto_red_bc_T_implies_agree_upto_c {o} :
  forall lib b (f g : @CTerm o) T,
    simple_eq_type lib T
    -> agree_upto_red_bc_T lib b f g T
    -> agree_upto_c lib b f g.
Proof.
  introv spe agree j.
  pose proof (agree (mkc_integer i) (mkc_integer i) i) as h.
  repeat (autodimp h hyp); try (apply reduces_toc_refl).
Qed.

Definition continuous_T {o} lib (F : @CTerm o) T :=
  forall f,
    member lib f (mkc_fun mkc_int T)
    -> {b : nat
        & forall g,
            member lib g (mkc_fun mkc_int T)
            -> agree_upto_red_bc_T lib b f g T
            -> equality_of_int_tt lib (mkc_apply F f) (mkc_apply F g)}.

(*

  F f -> z
  => (* by typing *)
  F (\x.let x:=(x + 0) in f(x)) -> z
  => (* by comp_force_int_app_F *)
  exists b. forall e.
    F (\x.let x:=(let x:=x in if |x|<b then x else e) in f(x)) -> z
    => (* if e cannot get caught, because the 2 functions agree upto b *)
    F (\x.let x:=(let x:=x in if |x|<b then x else e) in g(x)) -> z
    => (* comp_force_int_app_F2 *)
    F (\x.let x:=(x + 0) in g(x)) -> z
    => (* by typing *)
    F g -> z

*)
Lemma continuity_axiom {o} :
  forall lib (F : @CTerm o) T,
    simple_eq_type lib T
    -> member lib F (mkc_fun (mkc_fun mkc_int T) mkc_int)
    -> continuous_T lib F T.
Proof.
  introv spe mT mt.

  assert (member lib (mkc_apply F f) mkc_int) as ma.
  { rw @equality_in_fun in mT; repnd.
    apply mT; auto. }

  (* by typing *)
  assert (equality lib f (force_int_f_c nvarx f) (mkc_fun mkc_int T)) as ea.
  { apply equality_force_int_f_c_T; auto. }

  assert (equality lib  (mkc_apply F f) (mkc_apply F (force_int_f_c nvarx f)) mkc_int) as mb.
  { rw @equality_in_fun in mT; repnd.
    apply mT; auto. }

  apply equality_in_int in mb.
  apply equality_of_int_imp_tt in mb.
  unfold equality_of_int_tt in mb; exrepnd; GC.

  (* 1st step *)
  pose proof (comp_force_int_app_F_c lib F f nvarx k) as step1.
  autodimp step1 hyp.
  { rw @computes_to_valc_iff_reduces_toc in mb0; repnd; auto. }
  destruct step1 as [b step1].

  exists b.
  introv mg agree.

  (* 2nd step *)
  pose proof (comp_force_int_app_F3_c_2 lib F f g nvarx k b) as step2.
  repeat (autodimp step2 hyp).
  { apply agree_upto_red_bc_T_implies_agree_upto_c in agree; auto. }

  (* 3rd step *)
  pose proof (comp_force_int_app_F2_c lib F g nvarx k b) as step3.
  repeat (autodimp step3 hyp).

  (* by typing *)
  assert (equality lib g (force_int_f_c nvarx g) (mkc_fun mkc_int T)) as eb.
  { apply equality_force_int_f_c_T; auto. }

  assert (equality lib (mkc_apply F g) (mkc_apply F (force_int_f_c nvarx g)) mkc_int) as mc.
  { rw @equality_in_fun in mT; repnd.
    apply mT; auto. }

  apply equality_in_int in mc.
  apply equality_of_int_imp_tt in mc.
  unfold equality_of_int_tt in mc; exrepnd; GC.

  assert (computes_to_valc lib (force_int_F_c nvarx F g) (mkc_integer k)) as c.
  { rw @computes_to_valc_iff_reduces_toc; dands; eauto with slow. }

  repeat computes_to_eqval.

  exists k0; dands; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import Lia.
Require Import EquivDec.
Require Import Decidable.
Require Import Utils.
Require Import DataRuntime.
Require Import NNRS.

Section NNRSSize.
  Context {fruntime:foreign_runtime}.

  Fixpoint nnrs_expr_size (n:nnrs_expr) : nat
    := match n with
       | NNRSGetConstant v => 1
       | NNRSVar v => 1
       | NNRSConst d => 1
       | NNRSBinop op n₁ n₂ => S (nnrs_expr_size n₁ + nnrs_expr_size n₂)
       | NNRSUnop op n₁ => S (nnrs_expr_size n₁)
       | NNRSGroupBy g sl e => S (nnrs_expr_size e)
       end.

    Fixpoint nnrs_stmt_size (n:nnrs_stmt) : nat
    := match n with
       | NNRSSeq s₁ s₂ => S (nnrs_stmt_size s₁ + nnrs_stmt_size s₂)
       | NNRSLet v e s => S (nnrs_expr_size e + nnrs_stmt_size s)
       | NNRSLetMut v eo s => S (nnrs_stmt_size s + nnrs_stmt_size s)
       | NNRSLetMutColl _ s₁ s₂ => S (nnrs_stmt_size s₁ + nnrs_stmt_size s₂)
       | NNRSAssign _ e => S (nnrs_expr_size e)
       | NNRSPush _ e => S (nnrs_expr_size e)
       | NNRSFor v n₁ n₂ => S (nnrs_expr_size n₁ + nnrs_stmt_size n₂)
       | NNRSIf n₁ n₂ n₃ => S (nnrs_expr_size n₁ + nnrs_stmt_size n₂ + nnrs_stmt_size n₃)
       | NNRSEither nd vl nl vr nr => S (nnrs_expr_size nd + nnrs_stmt_size nl + nnrs_stmt_size nr)
       end.

    Definition nnrs_size (q:nnrs) : nat :=
      let (n, v) := q in
      nnrs_stmt_size n.

    Lemma nnrs_expr_size_nzero (n:nnrs_expr) : nnrs_expr_size n <> 0.
    Proof.
      induction n; simpl; lia.
    Qed.

    Lemma nnrs_stmt_size_nzero (n:nnrs_stmt) : nnrs_stmt_size n <> 0.
    Proof.
      induction n; simpl; lia.
    Qed.

    Corollary nnrs_size_nzero (q:nnrs) : nnrs_size q <> 0.
    Proof.
      destruct q.
      apply nnrs_stmt_size_nzero.
    Qed.

    Section Core.
      Program Definition nnrs_core_size (q:nnrs_core) : nat
        := nnrs_size q.

      Lemma nnrs_core_size_nzero (q:nnrs_core) :
        nnrs_core_size q <> 0.
      Proof.
        apply nnrs_size_nzero.
      Qed.
    End Core.

End NNRSSize.


(** Infrastructure lemmas and tactic definitions for Fsub.

    Authors: Brian Aydemir and Arthur Chargu\'eraud, with help from
    Aaron Bohannon, Jeffrey Vaughan, and Dimitrios Vytiniotis.

    This file contains a number of definitions, tactics, and lemmas
    that are based only on the syntax of the language at hand.  While
    the exact statements of everything here would change for a
    different language, the general structure of this file (i.e., the
    sequence of definitions, tactics, and lemmas) would remain the
    same.

    Table of contents:
      - #Free variables#
      - #Substitution#
      - #The "gather_atoms" tactic#
      - #Properties of opening and substitution#
      - #Local closure is preserved under substitution#
      - #Automation#
      - #Properties of body_e# *)

Require Export Fsub.Fsub_LetSum_Definitions.

(* ********************************************************************** *)
(** * ## Free variables *)

(** In this section, we define free variable functions.  The functions
    [fv_tt] and [fv_te] calculate the set of atoms used as free type
    variables in a type or expression, respectively.  The function
    [fv_ee] calculates the set of atoms used as free expression
    variables in an expression.  Cases involving binders are
    straightforward since bound variables are indices, not names, in
    locally nameless representation. *)

Fixpoint fv_tt (T : typ) {struct T} : atoms :=
  match T with
  | typ_top => {}
  | typ_bvar J => {}
  | typ_fvar X => {{ X }}
  | typ_arrow T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_all T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  | typ_sum T1 T2 => (fv_tt T1) `union` (fv_tt T2)
  end.

Fixpoint fv_te (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => {}
  | exp_abs V e1  => (fv_tt V) `union` (fv_te e1)
  | exp_app e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_tabs V e1 => (fv_tt V) `union` (fv_te e1)
  | exp_tapp e1 V => (fv_tt V) `union` (fv_te e1)
  | exp_let e1 e2 => (fv_te e1) `union` (fv_te e2)
  | exp_inl e1 => (fv_te e1)
  | exp_inr e1 => (fv_te e1)
  | exp_case e1 e2 e3 => (fv_te e1) `union` (fv_te e2) `union` (fv_te e3)
  end.

Fixpoint fv_ee (e : exp) {struct e} : atoms :=
  match e with
  | exp_bvar i => {}
  | exp_fvar x => {{ x }}
  | exp_abs V e1 => (fv_ee e1)
  | exp_app e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_tabs V e1 => (fv_ee e1)
  | exp_tapp e1 V => (fv_ee e1)
  | exp_let e1 e2 => (fv_ee e1) `union` (fv_ee e2)
  | exp_inl e1 => (fv_ee e1)
  | exp_inr e1 => (fv_ee e1)
  | exp_case e1 e2 e3 => (fv_ee e1) `union` (fv_ee e2) `union` (fv_ee e3)
  end.

(* ********************************************************************** *)
(** * ## Substitution *)

(** In this section, we define substitution for expression and type
    variables appearing in types, expressions, and environments.
    Substitution differs from opening because opening replaces indices
    whereas substitution replaces free variables.  The definitions
    below are relatively simple for two reasons.
      - We are using locally nameless representation, where bound
        variables are represented using indices.  Thus, there is no
        need to rename variables to avoid capture.
      - The definitions below assume that the term being substituted
        in, i.e., the second argument to each function, is locally
        closed.  Thus, there is no need to shift indices when passing
        under a binder. *)

Fixpoint subst_tt (Z : atom) (U : typ) (T : typ) {struct T} : typ :=
  match T with
  | typ_top => typ_top
  | typ_bvar J => typ_bvar J
  | typ_fvar X => if X == Z then U else T
  | typ_arrow T1 T2 => typ_arrow (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_all T1 T2 => typ_all (subst_tt Z U T1) (subst_tt Z U T2)
  | typ_sum T1 T2 => typ_sum (subst_tt Z U T1) (subst_tt Z U T2)
  end.

Fixpoint subst_te (Z : atom) (U : typ) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => exp_fvar x
  | exp_abs V e1 => exp_abs  (subst_tt Z U V)  (subst_te Z U e1)
  | exp_app e1 e2 => exp_app  (subst_te Z U e1) (subst_te Z U e2)
  | exp_tabs V e1 => exp_tabs (subst_tt Z U V)  (subst_te Z U e1)
  | exp_tapp e1 V => exp_tapp (subst_te Z U e1) (subst_tt Z U V)
  | exp_let e1 e2 => exp_let (subst_te Z U e1) (subst_te Z U e2)
  | exp_inl e1 => exp_inl (subst_te Z U e1)
  | exp_inr e1 => exp_inr (subst_te Z U e1)
  | exp_case e1 e2 e3 => exp_case (subst_te Z U e1)
                                  (subst_te Z U e2) (subst_te Z U e3)
  end.

Fixpoint subst_ee (z : atom) (u : exp) (e : exp) {struct e} : exp :=
  match e with
  | exp_bvar i => exp_bvar i
  | exp_fvar x => if x == z then u else e
  | exp_abs V e1 => exp_abs V (subst_ee z u e1)
  | exp_app e1 e2 => exp_app (subst_ee z u e1) (subst_ee z u e2)
  | exp_tabs V e1 => exp_tabs V (subst_ee z u e1)
  | exp_tapp e1 V => exp_tapp (subst_ee z u e1) V
  | exp_let e1 e2 => exp_let (subst_ee z u e1) (subst_ee z u e2)
  | exp_inl e1 => exp_inl (subst_ee z u e1)
  | exp_inr e1 => exp_inr (subst_ee z u e1)
  | exp_case e1 e2 e3 => exp_case (subst_ee z u e1)
                                  (subst_ee z u e2) (subst_ee z u e3)
  end.

Definition subst_tb (Z : atom) (P : typ) (b : binding) : binding :=
  match b with
  | bind_sub T => bind_sub (subst_tt Z P T)
  | bind_typ T => bind_typ (subst_tt Z P T)
  end.

(* ********************************************************************** *)
(** * ## The "[gather_atoms]" tactic *)

(** The Metatheory and MetatheoryAtom libraries define a number of
    tactics for working with cofinite quantification and for picking
    fresh atoms.  To specialize those tactics to this language, we
    only need to redefine the [gather_atoms] tactic, which returns the
    set of all atoms in the current context.

    The definition of [gather_atoms] follows a pattern based on
    repeated calls to [gather_atoms_with].  The one argument to this
    tactic is a function that takes an object of some particular type
    and returns a set of atoms that appear in that argument.  It is
    not necessary to understand exactly how [gather_atoms_with] works.
    If we add a new inductive datatype, say for kinds, to our
    language, then we would need to modify [gather_atoms].  On the
    other hand, if we merely add a new type, say products, then there
    is no need to modify [gather_atoms]; the required changes would be
    made in [fv_tt]. *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  let C := gather_atoms_with (fun x : exp => fv_te x) in
  let D := gather_atoms_with (fun x : exp => fv_ee x) in
  let E := gather_atoms_with (fun x : typ => fv_tt x) in
  let F := gather_atoms_with (fun x : env => dom x) in
  constr:(A `union` B `union` C `union` D `union` E `union` F).

(* ********************************************************************** *)
(** * ## Properties of opening and substitution *)

(** The following lemmas provide useful structural properties of
    substitution and opening.  While the exact statements are language
    specific, we have found that similar properties are needed in a
    wide range of languages.

    Below, we indicate which lemmas depend on which other lemmas.
    Since [te] functions depend on their [tt] counterparts, a similar
    dependency can be found in the lemmas.

    The lemmas are split into three sections, one each for the [tt],
    [te], and [ee] functions.  The most important lemmas are the
    following:
      - Substitution and opening commute with each other, e.g.,
        [subst_tt_open_tt_var].
      - Opening a term is equivalent to opening the term with a fresh
        name and then substituting for that name, e.g.,
        [subst_tt_intro].

    We keep the sections as uniform in structure as possible.  In
    particular, we state explicitly strengthened induction hypotheses
    even when there are more concise ways of proving the lemmas of
    interest. *)

(* ********************************************************************** *)
(** ** Properties of type substitution in types *)

(** The next lemma is the strengthened induction hypothesis for the
    lemma that follows, which states that opening a locally closed
    term is the identity.  This lemma is not otherwise independently
    useful. *)

Lemma open_tt_rec_type_aux : forall T j V i U,
  i <> j ->
  open_tt_rec j V T = open_tt_rec i U (open_tt_rec j V T) ->
  T = open_tt_rec i U T.
Proof with congruence || eauto.
  induction T; intros j V i U Neq H; simpl in *; inversion H; f_equal...
  Case "typ_bvar".
    destruct (j === n)... destruct (i === n)...
Qed.

(** Opening a locally closed term is the identity.  This lemma depends
    on the immediately preceding lemma. *)

Lemma open_tt_rec_type : forall T U k,
  type T ->
  T = open_tt_rec k U T.
Proof with auto.
  intros T U k Htyp. revert k.
  induction Htyp; intros k; simpl; f_equal...
  Case "typ_all".
    unfold open_tt in *.
    pick fresh X.
    apply (open_tt_rec_type_aux T2 0 (typ_fvar X))...
Qed.

(** If a name is fresh for a term, then substituting for it is the
    identity. *)

Lemma subst_tt_fresh : forall Z U T,
   Z `notin` fv_tt T ->
   T = subst_tt Z U T.
Proof with auto.
  induction T; simpl; intro H; f_equal...
  Case "typ_fvar".
    destruct (a == Z)...
    contradict H; fsetdec.
Qed.

(** Substitution commutes with opening under certain conditions.  This
    lemma depends on the fact that opening a locally closed term is
    the identity. *)

Lemma subst_tt_open_tt_rec : forall T1 T2 X P k,
  type P ->
  subst_tt X P (open_tt_rec k T2 T1) =
    open_tt_rec k (subst_tt X P T2) (subst_tt X P T1).
Proof with auto.
  intros T1 T2 X P k WP. revert k.
  induction T1; intros k; simpl; f_equal...
  Case "typ_bvar".
    destruct (k === n); subst...
  Case "typ_fvar".
    destruct (a == X); subst... apply open_tt_rec_type...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero. *)

Lemma subst_tt_open_tt : forall T1 T2 (X:atom) P,
  type P ->
  subst_tt X P (open_tt T1 T2) = open_tt (subst_tt X P T1) (subst_tt X P T2).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_open_tt_rec...
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---here, we're opening the term with a variable.  In
    practice, this lemma seems to be needed as a left-to-right rewrite
    rule, when stated in its current form. *)

Lemma subst_tt_open_tt_var : forall (X Y:atom) P T,
  Y <> X ->
  type P ->
  open_tt (subst_tt X P T) Y = subst_tt X P (open_tt T Y).
Proof with congruence || auto.
  intros X Y P T Neq Wu.
  unfold open_tt.
  rewrite subst_tt_open_tt_rec...
  simpl.
  destruct (Y == X)...
Qed.

(** The next lemma states that opening a term is equivalent to first
    opening the term with a fresh name and then substituting for the
    name.  This is actually the strengthened induction hypothesis for
    the version we use in practice. *)

Lemma subst_tt_intro_rec : forall X T2 U k,
  X `notin` fv_tt T2 ->
  open_tt_rec k U T2 = subst_tt X U (open_tt_rec k (typ_fvar X) T2).
Proof with congruence || auto.
  induction T2; intros U k Fr; simpl in *; f_equal...
  Case "typ_bvar".
    destruct (k === n)... simpl. destruct (X == X)...
  Case "typ_fvar".
    destruct (a == X)... contradict Fr; fsetdec.
Qed.

(** The next lemma is a direct corollary of the immediately preceding
    lemma---the index is specialized to zero.  *)

Lemma subst_tt_intro : forall X T2 U,
  X `notin` fv_tt T2 ->
  open_tt T2 U = subst_tt X U (open_tt T2 X).
Proof with auto.
  intros.
  unfold open_tt.
  apply subst_tt_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of type substitution in expressions *)

(** This section follows the structure of the previous section.  The
    one notable difference is that we require two auxiliary lemmas to
    show that substituting a type in a locally-closed expression is
    the identity. *)

Lemma open_te_rec_expr_aux : forall e j u i P ,
  open_ee_rec j u e = open_te_rec i P (open_ee_rec j u e) ->
  e = open_te_rec i P e.
Proof with congruence || eauto.
  induction e; intros j u i P H; simpl in *; inversion H; f_equal...
Qed.

Lemma open_te_rec_type_aux : forall e j Q i P,
  i <> j ->
  open_te_rec j Q e = open_te_rec i P (open_te_rec j Q e) ->
  e = open_te_rec i P e.
Proof.
  induction e; intros j Q i P Neq Heq; simpl in *; inversion Heq;
    f_equal; eauto using open_tt_rec_type_aux.
Qed.

Lemma open_te_rec_expr : forall e U k,
  expr e ->
  e = open_te_rec k U e.
Proof.
  intros e U k WF. revert k.
  induction WF; intros k; simpl; f_equal; auto using open_tt_rec_type;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_te_rec_expr_aux with (j := 0) (u := exp_fvar x);
    auto
  | unfold open_te in *;
    pick fresh X;
    eapply open_te_rec_type_aux with (j := 0) (Q := typ_fvar X);
    auto
  ].
Qed.

Lemma subst_te_fresh : forall X U e,
  X `notin` fv_te e ->
  e = subst_te X U e.
Proof.
  induction e; simpl; intros; f_equal; auto using subst_tt_fresh.
Qed.

Lemma subst_te_open_te_rec : forall e T X U k,
  type U ->
  subst_te X U (open_te_rec k T e) =
    open_te_rec k (subst_tt X U T) (subst_te X U e).
Proof.
  intros e T X U k WU. revert k.
  induction e; intros k; simpl; f_equal; auto using subst_tt_open_tt_rec.
Qed.

Lemma subst_te_open_te : forall e T X U,
  type U ->
  subst_te X U (open_te e T) = open_te (subst_te X U e) (subst_tt X U T).
Proof with auto.
  intros.
  unfold open_te.
  apply subst_te_open_te_rec...
Qed.

Lemma subst_te_open_te_var : forall (X Y:atom) U e,
  Y <> X ->
  type U ->
  open_te (subst_te X U e) Y = subst_te X U (open_te e Y).
Proof with congruence || auto.
  intros X Y U e Neq WU.
  unfold open_te.
  rewrite subst_te_open_te_rec...
  simpl.
  destruct (Y == X)...
Qed.

Lemma subst_te_intro_rec : forall X e U k,
  X `notin` fv_te e ->
  open_te_rec k U e = subst_te X U (open_te_rec k (typ_fvar X) e).
Proof.
  induction e; intros U k Fr; simpl in *; f_equal;
    auto using subst_tt_intro_rec.
Qed.

Lemma subst_te_intro : forall X e U,
  X `notin` fv_te e ->
  open_te e U = subst_te X U (open_te e X).
Proof with auto.
  intros.
  unfold open_te.
  apply subst_te_intro_rec...
Qed.

(* ********************************************************************** *)
(** ** Properties of expression substitution in expressions *)

(** This section follows the structure of the previous two sections. *)

Lemma open_ee_rec_expr_aux : forall e j v u i,
  i <> j ->
  open_ee_rec j v e = open_ee_rec i u (open_ee_rec j v e) ->
  e = open_ee_rec i u e.
Proof with congruence || eauto.
  induction e; intros j v u i Neq H; simpl in *; inversion H; f_equal...
  Case "exp_bvar".
    destruct (j===n)... destruct (i===n)...
Qed.

Lemma open_ee_rec_type_aux : forall e j V u i,
  open_te_rec j V e = open_ee_rec i u (open_te_rec j V e) ->
  e = open_ee_rec i u e.
Proof.
  induction e; intros j V u i H; simpl; inversion H; f_equal; eauto.
Qed.

Lemma open_ee_rec_expr : forall u e k,
  expr e ->
  e = open_ee_rec k u e.
Proof with auto.
  intros u e k Hexpr. revert k.
  induction Hexpr; intro k; simpl; f_equal; auto*;
  try solve [
    unfold open_ee in *;
    pick fresh x;
    eapply open_ee_rec_expr_aux with (j := 0) (v := exp_fvar x);
    auto
  | unfold open_te in *;
    pick fresh X;
    eapply open_ee_rec_type_aux with (j := 0) (V := typ_fvar X);
    auto
  ].
Qed.

Lemma subst_ee_fresh : forall (x: atom) u e,
  x `notin` fv_ee e ->
  e = subst_ee x u e.
Proof with auto.
  intros x u e; induction e; simpl; intro H; f_equal...
  Case "exp_fvar".
    destruct (a==x)...
    contradict H; fsetdec.
Qed.

Lemma subst_ee_open_ee_rec : forall e1 e2 x u k,
  expr u ->
  subst_ee x u (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_ee x u e2) (subst_ee x u e1).
Proof with auto.
  intros e1 e2 x u k WP. revert k.
  induction e1; intros k; simpl; f_equal...
  Case "exp_bvar".
    destruct (k === n); subst...
  Case "exp_fvar".
    destruct (a == x); subst... apply open_ee_rec_expr...
Qed.

Lemma subst_ee_open_ee : forall e1 e2 x u,
  expr u ->
  subst_ee x u (open_ee e1 e2) =
    open_ee (subst_ee x u e1) (subst_ee x u e2).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_ee_open_ee_rec...
Qed.

Lemma subst_ee_open_ee_var : forall (x y:atom) u e,
  y <> x ->
  expr u ->
  open_ee (subst_ee x u e) y = subst_ee x u (open_ee e y).
Proof with congruence || auto.
  intros x y u e Neq Wu.
  unfold open_ee.
  rewrite subst_ee_open_ee_rec...
  simpl.
  destruct (y == x)...
Qed.

Lemma subst_te_open_ee_rec : forall e1 e2 Z P k,
  subst_te Z P (open_ee_rec k e2 e1) =
    open_ee_rec k (subst_te Z P e2) (subst_te Z P e1).
Proof with auto.
  induction e1; intros e2 Z P k; simpl; f_equal...
  Case "exp_bvar".
    destruct (k === n)...
Qed.

Lemma subst_te_open_ee : forall e1 e2 Z P,
  subst_te Z P (open_ee e1 e2) = open_ee (subst_te Z P e1) (subst_te Z P e2).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_te_open_ee_rec...
Qed.

Lemma subst_te_open_ee_var : forall Z (x:atom) P e,
  open_ee (subst_te Z P e) x = subst_te Z P (open_ee e x).
Proof with auto.
  intros.
  rewrite subst_te_open_ee...
Qed.

Lemma subst_ee_open_te_rec : forall e P z u k,
  expr u ->
  subst_ee z u (open_te_rec k P e) = open_te_rec k P (subst_ee z u e).
Proof with auto.
  induction e; intros P z u k H; simpl; f_equal...
  Case "exp_fvar".
    destruct (a == z)... apply open_te_rec_expr...
Qed.

Lemma subst_ee_open_te : forall e P z u,
  expr u ->
  subst_ee z u (open_te e P) = open_te (subst_ee z u e) P.
Proof with auto.
  intros.
  unfold open_te.
  apply subst_ee_open_te_rec...
Qed.

Lemma subst_ee_open_te_var : forall z (X:atom) u e,
  expr u ->
  open_te (subst_ee z u e) X = subst_ee z u (open_te e X).
Proof with auto.
  intros z X u e H.
  rewrite subst_ee_open_te...
Qed.

Lemma subst_ee_intro_rec : forall x e u k,
  x `notin` fv_ee e ->
  open_ee_rec k u e = subst_ee x u (open_ee_rec k (exp_fvar x) e).
Proof with congruence || auto.
  induction e; intros u k Fr; simpl in *; f_equal...
  Case "exp_bvar".
    destruct (k === n)... simpl. destruct (x == x)...
  Case "exp_fvar".
    destruct (a == x)... contradict Fr; fsetdec.
Qed.

Lemma subst_ee_intro : forall x e u,
  x `notin` fv_ee e ->
  open_ee e u = subst_ee x u (open_ee e x).
Proof with auto.
  intros.
  unfold open_ee.
  apply subst_ee_intro_rec...
Qed.

(* *********************************************************************** *)
(** * ## Local closure is preserved under substitution *)

(** While these lemmas may be considered properties of substitution, we
    separate them out due to the lemmas that they depend on. *)

(** The following lemma depends on [subst_tt_open_tt_var]. *)

Lemma subst_tt_type : forall Z P T,
  type T ->
  type P ->
  type (subst_tt Z P T).
Proof with auto.
  intros Z P T HT HP.
  induction HT; simpl...
  Case "type_fvar".
    destruct (X == Z)...
  Case "type_all".
    pick fresh Y and apply type_all...
    rewrite subst_tt_open_tt_var...
Qed.

(** The following lemma depends on [subst_tt_type],
    [subst_te_open_ee_var], and [sbust_te_open_te_var]. *)

Lemma subst_te_expr : forall Z P e,
  expr e ->
  type P ->
  expr (subst_te Z P e).
Proof with eauto using subst_tt_type.
  intros Z P e He Hp.
  induction He; simpl; auto using subst_tt_type;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton Z);
    intros;
    try rewrite subst_te_open_ee_var;
    try rewrite subst_te_open_te_var;
    instantiate;
    eauto using subst_tt_type
  ].
Qed.

(** The following lemma depends on [subst_ee_open_ee_var] and
    [subst_ee_open_te_var]. *)

Lemma subst_ee_expr : forall z e1 e2,
  expr e1 ->
  expr e2 ->
  expr (subst_ee z e2 e1).
Proof with auto.
  intros z e1 e2 He1 He2.
  induction He1; simpl; auto;
  try solve [
    econstructor;
    try instantiate (1 := L `union` singleton z);
    intros;
    try rewrite subst_ee_open_ee_var;
    try rewrite subst_ee_open_te_var;
    instantiate;
    auto
  ].
  Case "expr_var".
    destruct (x == z)...
Qed.

(* *********************************************************************** *)
(** * ## Properties of [body_e] *)

(** The two kinds of facts we need about [body_e] are the following:
      - How to use it to derive that terms are locally closed.
      - How to derive it from the facts that terms are locally closed.

    Since we use it only in the context of [exp_let] and [exp_sum]
    (see the definition of reduction), those two constructors are the
    only ones we consider below. *)

Lemma expr_let_from_body : forall e1 e2,
  expr e1 ->
  body_e e2 ->
  expr (exp_let e1 e2).
Proof.
  intros e1 e2 H [J1 J2].
  pick fresh y and apply expr_let; auto.
Qed.

Lemma body_from_expr_let : forall e1 e2,
  expr (exp_let e1 e2) ->
  body_e e2.
Proof.
  intros e1 e2 H.
  unfold body_e.
  inversion H; eauto.
Qed.

Lemma expr_case_from_body : forall e1 e2 e3,
  expr e1 ->
  body_e e2 ->
  body_e e3 ->
  expr (exp_case e1 e2 e3).
Proof.
  intros e1 e2 e3 H [J1 J2] [K1 K2].
  pick fresh y and apply expr_case; auto.
Qed.

Lemma body_inl_from_expr_case : forall e1 e2 e3,
  expr (exp_case e1 e2 e3) ->
  body_e e2.
Proof.
  intros e1 e2 e3 H.
  unfold body_e.
  inversion H; eauto.
Qed.

Lemma body_inr_from_expr_case : forall e1 e2 e3,
  expr (exp_case e1 e2 e3) ->
  body_e e3.
Proof.
  intros e1 e2 e3 H.
  unfold body_e.
  inversion H; eauto.
Qed.

Lemma open_ee_body_e : forall e1 e2,
  body_e e1 -> expr e2 -> expr (open_ee e1 e2).
Proof.
  intros e1 e2 [L H] J.
  pick fresh x.
  rewrite (subst_ee_intro x); auto using subst_ee_expr.
Qed.

(* *********************************************************************** *)
(** * ## Automation *)

(** We add as hints the fact that local closure is preserved under
    substitution.  This is part of our strategy for automatically
    discharging local-closure proof obligations. *)

#[export] Hint Resolve subst_tt_type subst_te_expr subst_ee_expr : core.

(** We also add as hints the lemmas concerning [body_e]. *)

#[export] Hint Resolve expr_let_from_body body_from_expr_let : core.
#[export] Hint Resolve expr_case_from_body : core.
#[export] Hint Resolve body_inl_from_expr_case body_inr_from_expr_case : core.
#[export] Hint Resolve open_ee_body_e : core.

(** When reasoning about the [binds] relation and [map], we
    occasionally encounter situations where the binding is
    over-simplified.  The following hint undoes that simplification,
    thus enabling [Hint]s from the MetatheoryEnv library. *)

#[export] Hint Extern 1 (binds _ (?F (subst_tt ?X ?U ?T)) _) =>
  unsimpl (subst_tb X U (F T)) : core.


Require Import VST.floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import hmacdrbg.HMAC_DRBG_algorithms.
Require Import hmacdrbg.spec_hmac_drbg.
Require Import sha.HMAC256_functional_prog.

Fixpoint HMAC_DRBG_update_round (HMAC: list Z -> list Z -> list Z) (provided_data K V: list Z) (round: nat): (list Z * list Z) :=
  match round with
    | O => (K, V)
    | S round' =>
      let (K, V) := HMAC_DRBG_update_round HMAC provided_data K V round' in
      let K := HMAC (V ++ [Z.of_nat round'] ++ provided_data) K in
      let V := HMAC V K in
      (K, V)
  end.

Definition HMAC_DRBG_update_concrete (HMAC: list Z -> list Z -> list Z) (provided_data K V: list Z): (list Z * list Z) :=
  let rounds := match provided_data with
                  | [] => 1%nat
                  | _ => 2%nat
                end in
  HMAC_DRBG_update_round HMAC provided_data K V rounds.

Theorem HMAC_DRBG_update_concrete_correct:
  forall HMAC provided_data K V, HMAC_DRBG_update HMAC provided_data K V = HMAC_DRBG_update_concrete HMAC provided_data K V.
Proof.
  intros.
  destruct provided_data; reflexivity.
Qed.

Definition update_rounds (non_empty_additional: bool): Z :=
  if non_empty_additional then 2 else 1.

Lemma HMAC_DRBG_update_round_incremental:
  forall key V initial_state_abs contents n,
    (key, V) = HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) n ->
    (HMAC256 (V ++ (Z.of_nat n) :: contents) key,
     HMAC256 V (HMAC256 (V ++ (Z.of_nat n) :: contents) key)) =
    HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) (n + 1).
Proof.
  intros.
  rewrite plus_comm.
  simpl.
  rewrite <- H.
  reflexivity.
Qed.

Lemma HMAC_DRBG_update_round_incremental_Z:
  forall key V initial_state_abs contents i,
    0 <= i ->
    (key, V) = HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) (Z.to_nat i) ->
    (HMAC256 (V ++ i :: contents) key,
     HMAC256 V (HMAC256 (V ++ i :: contents) key)) =
    HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) (Z.to_nat (i + 1)).
Proof.
  intros.
  specialize (HMAC_DRBG_update_round_incremental _ _ _ _ _ H0); intros. clear H0.
  rewrite (Z2Nat.id _ H) in H1.
  rewrite Z2Nat.inj_add; try assumption; omega.
Qed.

Lemma update_char add_len contents (HL:add_len = Zlength contents \/ add_len = 0)
       (key1 V0 : list Z) additional reseed_counter entropy_len prediction_resistance V key0
     reseed_interval
    (H : (key1, V0) =
    HMAC_DRBG_update_round HMAC256 (contents_with_add additional add_len contents) key0 V
      (Z.to_nat
         (if
           (negb (Memory.EqDec_val additional nullval) &&
            negb (initial_world.EqDec_Z add_len 0))%bool
          then 2
          else 1))):
hmac256drbgabs_hmac_drbg_update
  (HMAC256DRBGabs key0 V reseed_counter entropy_len prediction_resistance
     reseed_interval) (contents_with_add additional add_len contents) =
HMAC256DRBGabs key1 V0 reseed_counter entropy_len prediction_resistance
  reseed_interval.
Proof. rename key0 into K. rename V0 into VV. rename key1 into KK.
unfold hmac256drbgabs_hmac_drbg_update, HMAC256_DRBG_functional_prog.HMAC256_DRBG_update.
rewrite HMAC_DRBG_update_concrete_correct. unfold HMAC_DRBG_update_concrete, contents_with_add in *; simpl in *.
destruct (Memory.EqDec_val additional nullval); simpl in *.
+ inv H; trivial.
+ destruct (initial_world.EqDec_Z add_len 0).
  -  subst add_len. change (negb (left eq_refl)) with false in *. simpl. simpl in H. inv H; trivial.
  - change (negb (right n0)) with true in *. simpl.
    destruct HL; try omega; subst add_len.
    destruct contents. rewrite Zlength_nil in n0; omega.
    change  (Z.to_nat 2) with 2%nat in H. rewrite <- H; trivial.
Qed.


From stdpp Require Import gmap stringmap.
From melocoton.ml_lang Require Export lang.
From iris.prelude Require Import options.
Import ML_lang.

(* This file contains some metatheory about the heap_lang language,
  which is not needed for verifying programs. *)

(* Adding a binder to a set of identifiers. *)
Local Definition set_binder_insert (x : binder) (X : stringset) : stringset :=
  match x with
  | BAnon => X
  | BNamed f => {[f]} ∪ X
  end.

Lemma dom_binder_insert {T} (m : gmap string T) b v : dom (binder_insert b v m) = set_binder_insert b (dom m).
Proof.
  destruct b; try done.
  unfold binder_insert, set_binder_insert. rewrite dom_insert_L. done.
Qed.

(* Check if expression [e] is closed w.r.t. the set [X] of variable names,
   and that all the values in [e] are closed *)
Fixpoint is_closed_expr (X : stringset) (e : expr) : bool :=
  match e with
  | Val v => is_closed_val v
  | Var x => bool_decide (x ∈ X)
  | Rec f x e => is_closed_expr (set_binder_insert f (set_binder_insert x X)) e
  | UnOp _ e | Fst e | Snd e | InjL e | InjR e | Length e =>
     is_closed_expr X e
  | App e1 e2 | BinOp _ e1 e2 | Pair e1 e2 | AllocN e1 e2 | LoadN e1 e2 =>
     is_closed_expr X e1 && is_closed_expr X e2
  | If e0 e1 e2 | Case e0 e1 e2 | StoreN e0 e1 e2 =>
     is_closed_expr X e0 && is_closed_expr X e1 && is_closed_expr X e2
  | Extern _ ea => forallb (is_closed_expr X) ea
  end
with is_closed_val (v : val) : bool :=
  match v with
  | LitV _ => true
  | RecV f x e => is_closed_expr (set_binder_insert f (set_binder_insert x ∅)) e
  | PairV v1 v2 => is_closed_val v1 && is_closed_val v2
  | InjLV v | InjRV v => is_closed_val v
  end.

Definition is_closed_context (g:gmap string val) := map_Forall (fun a b => is_closed_val b) g.

(* Properties *)
Local Instance set_unfold_elem_of_insert_binder x y X Q :
  SetUnfoldElemOf y X Q →
  SetUnfoldElemOf y (set_binder_insert x X) (Q ∨ BNamed y = x).
Proof. destruct 1; constructor; destruct x; set_solver. Qed.

Lemma is_closed_weaken X Y e : is_closed_expr X e → X ⊆ Y → is_closed_expr Y e.
Proof. revert X Y; induction e; try naive_solver (eauto; set_solver).
       + cbn. intros X Y H2%forallb_True HXY.
         apply forallb_True, Forall_forall. intros x Hx.
         rewrite List.Forall_forall in H. apply H with X.
         3: assumption. 1: now apply elem_of_list_In. rewrite Forall_forall in H2. now apply H2.
Qed.

Lemma is_closed_subst_all X e g :
  is_closed_context g →
  is_closed_expr (dom g ∪ X) e →
  is_closed_expr X (subst_all g e).
Proof with eauto using is_closed_weaken with set_solver.
  revert X g.
  induction e=> X g  HH /= HHyp; destruct_and?; split_and?; simplify_option_eq.
  all: idtac...
  all: repeat match goal with H : ?x ∈ ?l1 ∪ ?l2 |- _ => apply elem_of_union in H; destruct H end.
  - apply elem_of_dom in H as H2. destruct H2 as [k Hrew]; rewrite Hrew. unfold is_closed_context in HH.
    rewrite map_Forall_lookup in HH. eapply HH. by rewrite <- Hrew.
  - destruct (g !! x) eqn:Heq; try naive_solver.
  - cbn. destruct x,f1; cbn; split_and?...
    + apply IHe. 1: unfold is_closed_context in *; now apply map_Forall_delete.
      cbn in HHyp. eapply is_closed_weaken. 1: apply HHyp.
      rewrite dom_delete. intros x [->%elem_of_singleton|H2]%elem_of_union.
      * set_solver.
      * destruct (decide (s = x)) as [->|Hr].
        -- set_solver.
        -- set_solver.
    + apply IHe. 1: unfold is_closed_context in *; now apply map_Forall_delete.
      cbn in HHyp. eapply is_closed_weaken. 1: apply HHyp.
      rewrite dom_delete. intros x [->%elem_of_singleton|H2]%elem_of_union.
      * set_solver.
      * destruct (decide (s = x)) as [->|Hr].
        -- set_solver.
        -- set_solver.
    + apply IHe. 1: unfold is_closed_context in *; now apply map_Forall_delete, map_Forall_delete.
      cbn in HHyp. eapply is_closed_weaken. 1: apply HHyp.
      rewrite dom_delete. intros x [->%elem_of_singleton|H2]%elem_of_union.
      * set_solver.
      * destruct (decide (s = x)) as [->|Hr].
        -- set_solver.
        -- destruct (decide (s0 = x)) as [->|Hr2].
        --- set_solver.
        --- set_solver.
  - rewrite forallb_True.
    rewrite Forall_forall. rewrite Forall_forall in H.
    rewrite forallb_True in HHyp. rewrite Forall_forall in HHyp.
    intros x [xx [<- Hin]]%elem_of_list_In%in_map_iff.
    apply H. 1: now apply elem_of_list_In. 1:easy. eapply HHyp. now apply elem_of_list_In.
Qed.

Lemma is_closed_subst X e y v :
  is_closed_val v →
  is_closed_expr ({[y]} ∪ X) e →
  is_closed_expr X (subst y v e).
Proof.
  intros Hv H. apply is_closed_subst_all. 2: erewrite dom_singleton_L ; exact H.
  unfold is_closed_context. now apply map_Forall_singleton.
Qed.

Lemma is_closed_subst' X e x v :
  is_closed_val v →
  is_closed_expr (set_binder_insert x X) e →
  is_closed_expr X (subst' x v e).
Proof. destruct x; eauto using is_closed_subst. Qed.

Lemma subst_all_is_closed X g e :
  is_closed_expr X e → dom g ∩ X = ∅ → subst_all g e = e.
Proof.
  revert X g. induction e; intros X g;
   rewrite ?bool_decide_spec; rewrite ?andb_True; cbn; intros;
   repeat case_decide; simplify_eq/=; f_equal; intuition eauto with set_solver.
  - destruct (g !! x) eqn:Heq. 2:easy.
    apply elem_of_dom_2 in Heq. set_solver.
  - fold is_closed_expr in *. destruct x,f1; f_equal; intuition eauto with set_solver.
    all: cbn; cbn in H; eapply IHe.
    1,3,5: exact H.
    all: set_solver.
  - fold is_closed_expr in *. erewrite map_ext_in. 1: apply map_id.
    intros ea' Hin. cbn. rewrite Forall_forall in H. apply H with X.
    * now apply elem_of_list_In.
    * rewrite forallb_True in H0. rewrite List.Forall_forall in H0. now apply H0.
    * set_solver.
Qed.

Lemma subst_is_closed X e x es : is_closed_expr X e → x ∉ X → subst x es e = e.
Proof.
  intros H1 H2. eapply subst_all_is_closed. 1: exact H1. set_solver.
Qed.

Lemma subst_is_closed_empty e x v : is_closed_expr ∅ e → subst x v e = e.
Proof. intros. apply subst_is_closed with (∅:stringset); set_solver. Qed.

Lemma subst_all_comp e g1 g2 :
  subst_all g1 (subst_all g2 e) = subst_all (g2 ∪ g1) e.
Proof.
  intros. induction e in g1,g2|-*; simpl; try (f_equal; by auto);
    simplify_option_eq; auto using subst_is_closed_empty with f_equal.
  - destruct (g2 !! x) eqn:Heq2; [|cbn;destruct (g1 !! x) eqn:Heq1].
    + cbn. erewrite lookup_union_Some_l. 2: exact Heq2. easy.
    + erewrite lookup_union_r. 2: easy. rewrite Heq1. easy.
    + erewrite lookup_union_r. 2: easy. rewrite Heq1. easy.
  - destruct x, f1.
    + cbn. auto using subst_is_closed_empty with f_equal.
    + cbn. rewrite delete_union. auto using subst_is_closed_empty with f_equal.
    + cbn. rewrite delete_union. auto using subst_is_closed_empty with f_equal.
    + cbn. do 2 rewrite delete_union. auto using subst_is_closed_empty with f_equal.
  - f_equal. erewrite map_map. apply map_ext_in.
    intros a Ha. rewrite Forall_forall in H. apply H. now apply elem_of_list_In.
Qed.

Lemma subst_subst e x v v' :
  subst x v (subst x v' e) = subst x v' e.
Proof.
  unfold subst. rewrite subst_all_comp. f_equal.
  apply map_eq_iff. intros i. destruct ({[x := v']} !! i) eqn:Heq.
  - erewrite lookup_union_Some_l. 2: exact Heq. easy.
  - rewrite lookup_union_r. 2:easy. apply lookup_singleton_None in Heq.
    apply lookup_singleton_None. easy.
Qed.

Lemma subst_subst' e x v v' :
  subst' x v (subst' x v' e) = subst' x v' e.
Proof. destruct x; simpl; auto using subst_subst. Qed.

Lemma subst_subst_ne e x y v v' :
  x ≠ y → subst x v (subst y v' e) = subst y v' (subst x v e).
Proof.
  intros H. unfold subst. rewrite !subst_all_comp.
  f_equal. apply map_eq_iff. intros i. rewrite !lookup_union.
  destruct ({[y := v']} !! i) eqn:Heq1; destruct ({[x := v]} !! i) eqn:Heq2; cbn.
  2-4: easy.
  exfalso. apply lookup_singleton_Some in Heq1. apply lookup_singleton_Some in Heq2.
  destruct Heq1, Heq2. congruence.
Qed.

Lemma subst_subst_ne' e x y v v' :
  x ≠ y → subst' x v (subst' y v' e) = subst' y v' (subst' x v e).
Proof. destruct x, y; simpl; auto using subst_subst_ne with congruence. Qed.

Lemma subst_all_empty e : subst_all ∅ e = e.
Proof.
  induction e; simplify_map_eq; auto with f_equal.
  + destruct x,f1; cbn. 2,3,4: repeat rewrite delete_empty. all: simplify_map_eq; rewrite ?Hdel; auto with f_equal.
  + rewrite Forall_forall in H. f_equal. erewrite map_ext_in. 1: apply map_id. intros a Ha. cbn. now apply H, elem_of_list_In.
Qed.

Lemma subst_rec' f y e x v :
  x = f ∨ x = y ∨ x = BAnon →
  subst' x v (Rec f y e) = Rec f y e.
Proof. intros. destruct x; simplify_option_eq; try naive_solver. cbn. f_equal.
  destruct H as [<-|[<-|H3]].
  - cbn. destruct y; cbn. all: rewrite <- subst_all_empty; f_equal.
    1: now rewrite delete_singleton. now  rewrite delete_commute delete_singleton delete_empty.
  - cbn. rewrite delete_singleton. destruct f; cbn; try rewrite delete_empty.
    all: apply subst_all_empty.
  - congruence.
Qed.
(*
Lemma subst_rec_ne' f y e x v :
  (x ≠ f ∨ f = BAnon) → (x ≠ y ∨ y = BAnon) →
  subst' x v (Rec f y e) = Rec f y (subst' x v e).
Proof. intros. destruct x; simplify_option_eq; naive_solver. Qed. *)

Lemma bin_op_eval_closed op v1 v2 v' :
  is_closed_val v1 → is_closed_val v2 → bin_op_eval op v1 v2 = Some v' →
  is_closed_val v'.
Proof.
  rewrite /bin_op_eval /bin_op_eval_bool /bin_op_eval_int;
    repeat case_match; by naive_solver.
Qed.

Definition is_closed_ml_function X f := match f with
  MlFun lst expr => is_closed_expr (X ∪ list_to_set
        (flat_map (fun k => match k with BAnon => [] | BNamed l => [l] end) lst)) expr end.

Lemma zip_args_closed a b c : zip_args a b = Some c -> Forall is_closed_val b -> is_closed_context c.
Proof.
  induction b in a,c|-*; intros H1 H2.
  - destruct a as [|[|x] ar]; cbn in *; try congruence.
    assert (c = ∅) as -> by congruence. apply map_Forall_empty.
  - destruct a as [|[|x] ar]; cbn in *; try congruence.
    + eapply IHb. 1: apply H1. eapply Forall_inv_tail, H2.
    + destruct (zip_args ar b) eqn:Heq; cbn in H1; try congruence.
      injection H1. intros <-. apply map_Forall_insert_2.
      1: now apply Forall_inv in H2.
      1: eapply IHb. 1: apply Heq. eapply Forall_inv_tail, H2.
Qed.

(* The stepping relation preserves closedness *)
Lemma head_step_is_closed p e1 σ1 e2 σ2 :
  (forall f e, (p:gmap string ml_function) !! f = Some e → is_closed_ml_function ∅ e) →
  is_closed_expr ∅ e1 →
  map_Forall (λ _ v, is_closed_val v) σ1 →
  head_step p e1 σ1 e2 σ2 →
  is_closed_expr ∅ e2 ∧
  map_Forall (λ _ v, is_closed_val v) σ2.
Proof.
  intros Clp Cl1 Clσ1 STEP.
  induction STEP; simpl in *; split_and!;
    try apply map_Forall_insert_2; try by naive_solver.
  - subst. repeat apply is_closed_subst'; naive_solver.
  - unfold un_op_eval in *. repeat case_match; naive_solver.
  - eapply bin_op_eval_closed; eauto; naive_solver.
  - intros [l' i] v' HH.
    destruct (decide (l = l')) as [->|?].
    { rewrite store_lookup_eq in HH.
      case_bool_decide; simplify_map_eq/=.
      by apply lookup_replicate in HH as (-> & ?). }
    rewrite store_lookup_eq in HH.
    case_bool_decide; simplify_map_eq/=.
    destruct (σ !! l') eqn:Heqo; simplify_map_eq/=.
    apply (Clσ1 (Locoff l' i)).
    rewrite store_lookup_eq; by case_bool_decide; simplify_map_eq/=.
  - intros ℓi v'.
    destruct (decide (ℓi = (l.[i])%L)) as [->|?].
    { rewrite (store_lookup_insert _ l.[i] v) //. congruence. }
    rewrite store_lookup_insert_ne //. intro. by eapply Clσ1.
  - edestruct (zip_args args va) as [σ'|] eqn:Heq. 2: congruence.
    injection H0. intros <-. clear H0.
    eapply is_closed_subst_all.
    1: {rewrite forallb_True in Cl1. rewrite Forall_map in Cl1. cbn in Cl1.
        eapply zip_args_closed. 1: apply Heq. apply Cl1. }
    specialize (Clp _ _ H).
    cbn in Clp.
    assert (forall a b, a = b -> is_closed_expr a e -> is_closed_expr b e) as Happ by (now intros ? ? ->).
    eapply Happ, Clp.
    clear Happ H.
    induction args as [|[|a] ar IH] in Heq,va,σ'|-*; cbn; destruct va; cbn in *; try congruence.
    + injection Heq. intros <-. set_solver.
    + eapply IH. apply Heq.
    + unfold option_map in Heq. specialize (IH va). destruct (zip_args ar va) as [σ''|] eqn:Heq2; last congruence.
      specialize (IH σ'' eq_refl).
      injection Heq. intros <-. set_solver.
Qed.

Lemma subst_all_insert x v vs e :
  subst_all (<[x:=v]>vs) e = subst x v (subst_all (delete x vs) e).
Proof.
  unfold subst. rewrite subst_all_comp. f_equal. apply map_eq_iff.
  intros i. destruct (decide (x = i)) as [->|?].
  + rewrite lookup_insert. rewrite lookup_union_r.
    * now rewrite lookup_singleton.
    * now rewrite lookup_delete.
  + rewrite lookup_insert_ne. 2:easy.
    rewrite lookup_union.
    rewrite lookup_singleton_ne. 2: easy.
    rewrite union_with_right_id.
    now rewrite lookup_delete_ne.
Qed.

Lemma subst_all_binder_insert b v vs e :
  subst_all (binder_insert b v vs) e =
  subst' b v (subst_all (binder_delete b vs) e).
Proof. destruct b; cbn. 1: easy. now rewrite subst_all_insert. Qed.
Lemma subst_all_binder_insert_empty b v e :
  subst_all (binder_insert b v ∅) e = subst' b v e.
Proof. by rewrite subst_all_binder_insert binder_delete_empty subst_all_empty. Qed.

Lemma subst_all_binder_insert_2 b1 v1 b2 v2 vs e :
  subst_all (binder_insert b1 v1 (binder_insert b2 v2 vs)) e =
  subst' b2 v2 (subst' b1 v1 (subst_all (binder_delete b2 (binder_delete b1 vs)) e)).
Proof.
  destruct b1 as [|s1], b2 as [|s2]=> /=; auto using subst_all_insert.
  rewrite subst_all_insert. destruct (decide (s1 = s2)) as [->|].
  - by rewrite delete_idemp subst_subst delete_insert_delete.
  - by rewrite delete_insert_ne // subst_all_insert subst_subst_ne.
Qed.
Lemma subst_all_binder_insert_2_empty b1 v1 b2 v2 e :
  subst_all (binder_insert b1 v1 (binder_insert b2 v2 ∅)) e =
  subst' b2 v2 (subst' b1 v1 e).
Proof.
  by rewrite subst_all_binder_insert_2 !binder_delete_empty subst_all_empty.
Qed.

Lemma subst_all_is_closed_empty e vs : is_closed_expr ∅ e → subst_all vs e = e.
Proof. intros. apply subst_all_is_closed with (∅ : stringset); set_solver. Qed.