 (*

  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 continuity_type.
Require Export per_props_set.
Require Export per_props_union.
Require Export per_props_nat.
Require Export alphaeq3.

(* n:Nat -> (Nat_n -> Nat) -> (Nat + Unit) *)
Definition modulus_fun_type {o} : @CTerm o :=
  mkc_function
    mkc_tnat
    nvarx
    (mkcv_fun
       [nvarx]
       (mkcv_fun [nvarx] (mkcv_natk [nvarx] (mkc_var nvarx)) (mkcv_tnat [nvarx]))
       (mk_cv [nvarx] (mkc_union mkc_tnat mkc_unit))).

Definition strong_continuous {o} lib (F : @CTerm o) :=
  {M : CTerm
    & member lib M modulus_fun_type
    # forall (f : CTerm),
        member lib f nat2nat
        -> {n : nat
            & equality lib
                       (mkc_apply2 M (mkc_nat n) f)
                       (mkc_inl (mkc_apply F f))
                       (mkc_union mkc_tnat mkc_unit)
            # (forall (m : nat),
                 inhabited_type lib (mkc_assert (mkc_isl (mkc_apply2 M (mkc_nat m) f)))
                 -> m = n)}}.

(**

  [strong_continuous] should be derivable from [simple_strong_continuous]
  using [M' n f = primrec(n, M n f, \i.\r.if isl(M i f) then inr() else r)]
  to instantiate [strong_continuous] and
  where [M] comes from [simple_strong_continuous].

*)
Definition simple_strong_continuous {o} lib (F : @CTerm o) :=
  {M : CTerm
    & member lib M modulus_fun_type
    # forall (f : CTerm),
        member lib f nat2nat
        -> {n : nat
            & equality lib
                       (mkc_apply2 M (mkc_nat n) f)
                       (mkc_inl (mkc_apply F f))
                       (mkc_union mkc_tnat mkc_unit) }}.

Definition agree_upto_red_bc_nat {o} lib b (f g : @CTerm o) :=
  forall (t1 t2 : CTerm) (i : nat),
    reduces_toc lib t1 (mkc_nat i)
    -> reduces_toc lib t2 (mkc_nat i)
    -> i < b
    -> equality_of_int_tt lib (mkc_apply f t1) (mkc_apply g t2).

Lemma agree_upto_red_bc_nat_implies_equal_in_natk2nat {o} :
  forall lib b (f g : @CTerm o),
    member lib f nat2nat
    -> member lib g nat2nat
    -> agree_upto_red_bc_nat lib b f g
    -> equality lib f g (natk2nat (mkc_nat b)).
Proof.
  introv mf mg agree.
  unfold natk2nat.
  apply equality_in_fun; dands.
  - apply type_mkc_natk.
    exists (Z.of_nat b); spcast.
    rw @mkc_nat_eq.
    apply computes_to_valc_refl; eauto with slow.
  - intro inh; apply type_tnat.
  - introv e.
    apply equality_in_natk in e; exrepnd; spcast.
    apply computes_to_valc_isvalue_eq in e3; eauto with slow.
    rw @mkc_nat_eq in e3; ginv.
    assert (m < b) as l by omega; clear e1.
    apply equality_in_tnat.
    unfold equality_of_nat.

    unfold agree_upto_red_bc_nat in agree.
    pose proof (agree a a' m) as h; repeat (autodimp h hyp); eauto 3 with slow.
    unfold equality_of_int_tt in h; exrepnd.

    allrw @equality_in_fun; repnd; GC.
    pose proof (mf a a) as k1; autodimp k1 hyp.
    { apply equality_in_tnat; unfold equality_of_nat.
      exists m; dands; spcast; auto. }
    pose proof (mg a' a') as k2; autodimp k2 hyp.
    { apply equality_in_tnat; unfold equality_of_nat.
      exists m; dands; spcast; auto. }
    allrw @equality_in_tnat; allunfold @equality_of_nat; exrepnd; GC; spcast.
    allrw @mkc_nat_eq.
    computes_to_eqval.

    exists k0.
    allrw @mkc_nat_eq; dands; spcast; auto.
Qed.

Definition continuous_nat {o} lib (F : @CTerm o) :=
  forall f,
    member lib f nat2nat
    -> {b : nat
        & forall g,
            member lib g nat2nat
            -> agree_upto_red_bc_nat lib b f g
            -> equality_of_int_tt lib (mkc_apply F f) (mkc_apply F g)}.

Lemma strong_continuous_implies_continuous {o} :
  forall lib (F : @CTerm o),
    strong_continuous lib F -> continuous_nat lib F.
Proof.
  introv cont.
  unfold strong_continuous in cont.
  unfold continuous_nat.
  destruct cont as [M cont]; destruct cont as [mM cont].
  introv mf.
  applydup cont in mf; exrepnd.

  exists n.
  introv mg agree.

  applydup cont in mg; exrepnd.
  clear cont.

  pose proof (agree_upto_red_bc_nat_implies_equal_in_natk2nat lib n f g) as e.
  repeat (autodimp e hyp).
  unfold modulus_fun_type in mM.
  apply equality_in_function2 in mM; repnd; clear mM0.

  pose proof (mM (mkc_nat n) (mkc_nat n)) as ap.
  autodimp ap hyp.
  { apply equality_in_tnat; unfold equality_of_nat.
    exists n; dands; spcast; apply computes_to_valc_refl; eauto with slow. }
  eapply alphaeqc_preserving_equality in ap;[|apply mkcv_fun_substc].
  allrw @csubst_mk_cv.
  eapply alphaeqc_preserving_equality in ap;
    [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
      apply mkcv_fun_substc].
  allrw @mkcv_tnat_substc.
  eapply alphaeqc_preserving_equality in ap;
    [|apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
      apply alphaeqc_mkc_fun;[|apply alphaeqc_refl];
      apply mkcv_natk_substc].
  allrw @mkc_var_substc.
  fold (@natk2nat o (mkc_nat n)) in ap.

  apply equality_in_fun in ap; repnd.
  clear ap0 ap1.
  pose proof (ap f g e) as equn.

  allrw <- @mkc_apply2_eq.
  assert (equality
            lib
            (mkc_apply2 M (mkc_nat n) g)
            (mkc_inl (mkc_apply F f))
            (mkc_union mkc_tnat mkc_unit)) as e2.
  { eapply equality_trans;[apply equality_sym;exact equn|auto]. }

  apply implies_isl_in_bool in e2.
  eapply equality_respects_cequivc_right in e2;
    [|eapply computes_to_valc_inl_implies_cequivc_isl_tt;
       apply computes_to_valc_refl;
       apply iscvalue_mkc_inl].

  apply equality_tt_in_bool_implies_cequiv in e2; spcast.

  pose proof (mg1 n) as k.
  autodimp k hyp.
  { spcast.
    eapply inhabited_type_cequivc;
      [apply cequivc_mkc_assert;apply cequivc_sym; exact e2|].
    eapply inhabited_type_cequivc;
      [apply cequivc_sym;apply mkc_assert_tt|].
    apply inhabited_type_mkc_unit. }
  subst n0.

  assert (equality
            lib
            (mkc_inl (mkc_apply F f))
            (mkc_inl (mkc_apply F g))
            (mkc_union mkc_tnat mkc_unit)) as eap.
  { eapply equality_trans;[apply equality_sym; exact mf0|].
    eapply equality_trans;[exact equn|]; auto. }

  apply equality_mkc_inl_implies in eap.
  apply equality_in_tnat in eap.
  apply equality_of_nat_implies_equality_of_int in eap.
  apply equality_of_int_imp_tt in eap; auto.
Qed.

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


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

(** * HElGamal.v : Semantic security of the Hashed ElGamal encryption scheme
   in the Random Oracle Model *)

Set Implicit Arguments.

Require Import SemHElGamal.

(** TODO: Move this somewhere else *)
Lemma CGK_eqb_refl : forall k v, (@CGK.eqb k v v) = true.
Proof.
 intros k v; generalize (CGK.eqb_spec v v); case (CGK.eqb v v).
 trivial.
 intro H; elim H; trivial.
Qed.

Lemma CGK_eqb_sym : forall k v1 v2,
 @CGK.eqb k v1 v2 <-> @CGK.eqb k v2 v1.
Proof.
 intros k v1 v2.
 split;
  generalize (CGK.eqb_spec v1 v2); generalize (CGK.eqb_spec v2 v1);
  case (CGK.eqb v1 v2); case (CGK.eqb v2 v1);
  intros H1 H2; trivial.
 elim H1; symmetry; trivial.
 elim H2; symmetry; trivial.
Qed.

Lemma is_true_CGK_eqb : forall k v1 v2,
 @CGK.eqb k v1 v2 <-> v1 = v2.
Proof.
 split; intros.
 generalize (CGK.eqb_spec v1 v2); rewrite H; trivial.
 rewrite H; apply CGK_eqb_refl.
Qed.

Lemma modus_ponens : forall k (m:Mem.t k) e1 e2,
 E.eval_expr (e1 ==> e2) m ->
 E.eval_expr e1 m ->
 E.eval_expr e2 m.
Proof.
 intros.
 unfold E.eval_expr, O.eval_op in H, H0; simpl in H, H0.
 rewrite H0 in H; trivial.
Qed.
(* TODO : This lemma is eval_expr_eq *)
Lemma eval_eq : forall k (m:Mem.t k) (t:T.type) e1 e2,
 @E.eval_expr k t e1 m = E.eval_expr e2 m <->
 E.eval_expr (e1 =?= e2) m.
Proof.
 intros; unfold E.eval_expr, O.eval_op; simpl.
 split.
 intro H; rewrite H.
 apply Ti_eqb_refl.
 intros H.
 rewrite is_true_Ti_eqb in H.
 apply H.
Qed.

Section PR_RANDOM_DOM.

 Variable c : cmd.
 Variable t1 : T.type.
 Variable t2 : T.type.

 Variable e : E.expr t1.
 Variable n : nat -> nat.

 Variable i : Var.var T.Nat.
 Variable x : Var.var t1.
 Variable L : Var.var (T.List (T.Pair t1 t2)).

 Variable E : env.

 Hypothesis fv_x : ~Vset.mem x (fv_expr e).
 Hypothesis fv_i : ~Vset.mem i (fv_expr e).

 Let c' := c ++ [ i <$- [0..Elen L]; x <- Efst (Enth {i, L}) ].

 Close Scope nat_scope.

 Lemma Pr_random_dom : forall k (m:Mem.t k),
  ([1/]1+pred (n k)) * Pr E c m (EP k (Elen L <! (n k)) [&&] EP k (e in_dom L)) <=
  Pr E c' m (EP k (x =?= e)).
 Proof.
  intros; unfold Pr, c'.
  rewrite <- (mu_stable_mult _ _ _), deno_app_elim.
  apply mu_monotonic; intro m'.
  rewrite deno_cons_elim, Mlet_simpl, deno_random_elim.
  unfold charfun, restr, EP, andP, andb, fone, fmult.
  case_eq (@E.eval_expr _ T.Bool (Elen L <! n k) m');
   case_eq (@E.eval_expr _ T.Bool (e in_dom L) m'); Usimpl; trivial.
  simpl E.eval_expr; unfold O.eval_op; simpl T.app_op.
  intros Hin Hlen.
  apply leb_complete in Hlen; simpl in Hlen.
  apply is_true_existsb in Hin; destruct Hin as [a [Hin Heq] ].
  simpl in Hin.
  destruct (In_nth_inv _ (T.default k (T.Pair t1 t2)) _ Hin) as [j [Hlt Hnth] ].
  rewrite <- (@sum_support_in _ _ j).
  simpl; rewrite seq_length; unfold O.eval_op; simpl.
  apply Unth_anti_mon; omega.
  apply le_In_seq; simpl; unfold O.eval_op; simpl in Hlt |- *; auto with arith.

  rewrite deno_assign_elim.
  rewrite Mem.get_upd_same.
  simpl; unfold O.eval_op; simpl; mem_upd_simpl.
  rewrite (@depend_only_fv_expr _ _ _ _ m').
  apply is_true_Ti_eqb in Heq; rewrite Heq, Hnth, Ti_eqb_refl; trivial.

  intros ? y Hy.
  repeat rewrite Mem.get_upd_diff; trivial.
  intro H; rewrite H in fv_i; tauto.
  intro H; rewrite H in fv_x; tauto.
 Qed.

End PR_RANDOM_DOM.

(** ** CDH assumption *)
Section CDH_ASSUMPTION.

 (** The CDH assumption says that any efficient adversary [C] has a
    negligible chance of outputting [g^xy] given [g^x] and [g^y],
    where [x] and [y] are uniformly sampled.
 *)

 Variables x y : Var.var T.Nat.
 Variable L : Var.var (T.List (T.Pair (T.User Group) (T.User Bitstring))).
 Variable z : Var.var (T.User Group).

 Variable Cname : positive.

 Notation Local C := (Proc.mkP Cname
   (T.User Group :: T.User Group :: nil)
   (T.User Group)).

 Definition CDH :=
  [
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   z <c- C with {g^x, g^y}
  ].

 Definition CDH_advantage E k (m:Mem.t k) :=
  Pr E CDH m (EP k (z =?= g^(x *! y))).

 Axiom CDH_assumption : forall (m:forall k, Mem.t k) E,
  x <> y ->
  Var.is_local x ->
  Var.is_local y ->
  lossless E (proc_body E C) ->
  PPT_proc E C ->
  negligible (fun k => CDH_advantage E (m k)).

End CDH_ASSUMPTION.

Open Scope positive_scope.

(** ** Global Variables *)

Notation L   := (Var.Gvar (T.List (T.Pair (T.User Group) (T.User Bitstring))) 1).
Notation Lam := (Var.Gvar (T.User Group) 2).
Notation hp  := (Var.Gvar (T.User Bitstring) 3).
Notation bad := (Var.Gvar T.Bool 4).
Notation L'   := (Var.Gvar (T.List (T.Pair (T.User Group) (T.User Bitstring))) 5).

(** *** Global variables shared between the adversary, the oracles and
  the game *)
Definition Gcomm := Vset.empty.

(** Global variable shared between [A] and [A'] *)
Notation g_a := (Var.Gvar T.Nat 5).

Definition Gadv := Vset.singleton g_a.

(** ** Local variables *)

(** Integer variables *)
Notation x := (Var.Lvar T.Nat 11).
Notation y := (Var.Lvar T.Nat 12).

(** Bitstrings *)
Notation h := (Var.Lvar (T.User Bitstring) 21).
Notation r := (Var.Lvar (T.User Bitstring) 22).
Notation v := (Var.Lvar (T.User Bitstring) 23).

(** Group elements *)
Notation alpha  := (Var.Lvar (T.User Group) 31).
Notation beta   := (Var.Lvar (T.User Group) 32).
Notation lambda := (Var.Lvar (T.User Group) 33).

(** Messages *)
Notation mm := (Var.Lvar (T.Pair (T.User Bitstring) (T.User Bitstring)) 41).
Notation mb := (Var.Lvar (T.User Bitstring) 42).

(** Bits *)
Notation b  := (Var.Gvar T.Bool 51).
Notation b' := (Var.Lvar T.Bool 52).

(** ** Procedures *)
Notation Hash := (Proc.mkP 1
 (T.User Group :: nil)
 (T.User Bitstring)).

Notation A    := (Proc.mkP 2
 (T.User Group :: nil)
 (T.Pair (T.User Bitstring) (T.User Bitstring))).

Notation A'   := (Proc.mkP 3
 (T.User Group :: T.User Group :: T.User Bitstring :: nil)
 T.Bool).

Notation B    := (Proc.mkP 4
 (T.User Group :: T.User Group :: nil)
 (T.User Group)).

Close Scope positive_scope.

(** ** Adversary and proof *)
Section ADVERSARY_AND_PROOF.

 Variable env_adv : env.

 (** *** Specification of the adversary *)
 Definition A_params : var_decl (Proc.targs A) := dcons _ alpha (dnil _).

 Variable A_body : cmd.

 (** [A] returns a pair of messages *)
 Variable A_ret : E.expr (T.Pair (T.User Bitstring) (T.User Bitstring)).

 Definition A'_params : var_decl (Proc.targs A') :=
  dcons _ alpha (dcons _ beta (dcons _ v (dnil _))).

 Variable A'_body : cmd.

 (** [A'] returns a guess for [b], a boolean *)
 Variable A'_ret : E.expr T.Bool.

 Definition Hash_params : var_decl (Proc.targs Hash) := dcons _ lambda (dnil _).

 Definition Hash_ret := r.

 Definition makeEnv (Hash_body:cmd) :=
  let EHash := add_decl env_adv Hash Hash_params (refl_equal true)
   Hash_body Hash_ret in
  let EA    := add_decl EHash A A_params (refl_equal true) A_body A_ret in
   add_decl EA A' A'_params (refl_equal true) A'_body A'_ret.

 (** Initial game *)
 Definition G0 :=
  [
   L <- Nil _;
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   mm <c- A with {g^x};
   b <$- {0,1};
   If b then [ mb <- Efst mm ] else [ mb <- Esnd mm ];
   h <c- Hash with {g^(x *! y)};
   v <- h |x| mb;
   b' <c- A' with {g^x, g^y, v}
  ].

 Definition Hash0_body :=
  [
   If !(lambda in_dom L) then
    [
     r <$- {0,1}^k;
     L <- (lambda | r) |::| L
    ]
   else
    [
     r <- L[{lambda}]
    ]
  ].

 Definition E0 := makeEnv Hash0_body.

 (** The set of oracles that can be called by [A] and [A'] *)
 Definition PrOrcl := PrSet.singleton (BProc.mkP Hash).

 (** Private procedures, not accessible to the adversary *)
 Definition PrPriv := PrSet.singleton (BProc.mkP B).

 (** The adversary is well-formed in [E0], i.e. it only reads or writes
    variables it has access to, and only calls oracles and its own procedures *)
 Hypothesis A_wf  : WFAdv PrOrcl PrPriv Gadv Gcomm E0 A.
 Hypothesis A'_wf : WFAdv PrOrcl PrPriv Gadv Gcomm E0 A'.

 (** The adversary runs in PPT provided the hash oracle does *)
 Hypothesis A_PPT : forall E,
  Eq_adv_decl PrOrcl PrPriv E0 E ->
  (forall O, PrSet.mem O PrOrcl -> PPT_proc E (BProc.p_name O)) ->
  PPT_proc E A.

 Hypothesis A'_PPT : forall E,
  Eq_adv_decl PrOrcl PrPriv E0 E ->
  (forall O, PrSet.mem O PrOrcl -> PPT_proc E (BProc.p_name O)) ->
  PPT_proc E A'.

 (** The adversary is lossless (i.e. it always terminates) provided
    the hash oracle is lossless *)
 Hypothesis A_lossless : forall E,
  Eq_adv_decl PrOrcl PrPriv E0 E ->
  (forall O, PrSet.mem O PrOrcl -> lossless E (proc_body E (BProc.p_name O))) ->
  lossless E A_body.

 Hypothesis A'_lossless : forall E,
  Eq_adv_decl PrOrcl PrPriv E0 E ->
  (forall O, PrSet.mem O PrOrcl -> lossless E (proc_body E (BProc.p_name O))) ->
  lossless E A'_body.

 Lemma EqAD : forall H_body1 H_body2,
  Eq_adv_decl PrOrcl PrPriv (makeEnv H_body1) (makeEnv H_body2).
 Proof.
  unfold Eq_adv_decl, proc_params, proc_body, proc_res, makeEnv; intros.
  generalize (BProc.eqb_spec (BProc.mkP A) (BProc.mkP f)).
  destruct (BProc.eqb (BProc.mkP A) (BProc.mkP f)); intros.
  inversion H1; simpl; auto.
  generalize (BProc.eqb_spec (BProc.mkP A') (BProc.mkP f)).
  destruct (BProc.eqb (BProc.mkP A') (BProc.mkP f)); intros.
  inversion H2; simpl; auto.
  repeat rewrite add_decl_other_mk; try tauto; intro Heq;
   apply H; rewrite <- Heq; vm_compute; trivial.
 Qed.

 Lemma EqOP : forall H_body1 H_body2,
  Eq_orcl_params PrOrcl (makeEnv H_body1) (makeEnv H_body2).
 Proof.
  unfold Eq_orcl_params,makeEnv; intros.
  unfold PrOrcl in H.
  apply PrSet.singleton_complete in H; inversion H; simpl.
  vm_compute; trivial.
 Qed.

 Lemma A_wf_E : forall H_body,
  WFAdv PrOrcl PrPriv Gadv Gcomm (makeEnv H_body) A.
 Proof.
  intros; apply WFAdv_trans with (5:=A_wf); unfold E0; try discriminate.
  apply EqOP.
  apply EqAD.
 Qed.

 Lemma A'_wf_E : forall H_body,
  WFAdv PrOrcl PrPriv Gadv Gcomm (makeEnv H_body) A'.
 Proof.
  intros; apply WFAdv_trans with (5:=A'_wf); try discriminate.
  apply EqOP.
  apply EqAD.
 Qed.

 (** Helper functions to construct the information used by tactics *)
 Definition iEiEi Hbody Hr Hr' :=
  let E := makeEnv Hbody in
  let Aloss := @A_lossless E (EqAD _ _) in
  let A'loss := @A'_lossless E (EqAD _ _) in
  let piH := add_refl_info_rm Hash Hr Hr' (empty_info E E) in
  let piA := add_adv_info_lossless (EqAD _ _) (A_wf_E _) Aloss Aloss piH in
   add_adv_info_lossless (EqAD _ _) (A'_wf_E _) A'loss A'loss piA.

 Definition iEiEj Hbody Hbody' I O
  (Hequiv:EqObsInv trueR I (makeEnv Hbody) Hbody (makeEnv Hbody') Hbody' O) :=
  let E := makeEnv Hbody in
  let E' := makeEnv Hbody' in
  let Aloss := @A_lossless E (EqAD _ _) in
  let A'loss := @A'_lossless E (EqAD _ _)  in
  let Aloss' := @A_lossless E' (EqAD _ _)  in
  let A'loss' := @A'_lossless E' (EqAD _ _)  in
  let piH := add_info Hash Vset.empty Vset.empty (empty_info E E') Hequiv in
  let piA := add_adv_info_lossless (EqAD _ _) (A_wf_E _) Aloss Aloss' piH in
   add_adv_info_lossless (EqAD _ _) (A'_wf_E _) A'loss A'loss' piA.

 (** Game one *)
 Definition G1 :=
  [
   hp <$- {0,1}^k;
   L <- Nil _;
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   Lam <- g^(x *! y);
   mm <c- A with {g^x};
   b <$- {0,1};
   If b then [ mb <- Efst mm ] else [ mb <- Esnd mm ];
   h <c- Hash with {Lam};
   v <- h |x| mb;
   b' <c- A' with {g^x, g^y, v}
  ].

  Definition G1' :=
  [
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   Lam <- g^(x *! y);
   L <- Nil _;
   hp <$- {0,1}^k;
   mm <c- A with {g^x};
   b <$- {0,1};
   If b then [ mb <- Efst mm ] else [ mb <- Esnd mm ];
   h <c- Hash with {Lam};
   v <- h |x| mb;
   b' <c- A' with {g^x, g^y, v}
  ].

 Definition Hash1'_body :=
  [
   If !(lambda in_dom L) then
   [
    If Lam =?= lambda then
     [
      r <- hp
     ]
    else
     [
      r <$- {0,1}^k
     ];
    L <- (lambda | r) |::| L
   ]
   else [
    r <- L[{lambda}]
   ]
  ].

 Definition Hash1_body :=
  [
   If !(lambda in_dom L) then
   [
    If Lam =?= lambda then
     [
      bad <- true; r <- hp
     ]
    else
     [
      r <$- {0,1}^k
     ];
    L <- (lambda | r) |::| L
   ]
   else [
    r <- L[{lambda}]
   ]
  ].

 Definition E1'  := makeEnv Hash1'_body.
 Definition E1  := makeEnv Hash1_body.

 Definition iE0E0   := iEiEi Hash0_body Vset.empty Vset.empty.
 Definition iE1E1   := iEiEi Hash1_body Vset.empty Vset.empty.

 Definition I_H := Vset.add lambda (Vset.add Lam (Vset.singleton L)).
 Definition O_H := Vset.add r (Vset.singleton L).

 Lemma Hash1'_Hash1 :
  EqObsInv trueR (Vset.add hp I_H)
  E1' Hash1'_body
  E1  Hash1_body
  (Vset.add hp O_H).
 Proof.
  deadcode;eqobs_in.
 Qed.

 Definition iE1'E1  := iEiEj Hash1'_Hash1.
 Definition iE1'E1' := iEiEi Hash1'_body Vset.empty Vset.empty.
 (* On doit pouvoir le faire automatiquement i.e sans la preuve Hash1'_Hash1*)

 Definition S:=
  [ If !(Lam in_dom L) then [hp <$- {0,1}^k] else [hp <- L[{Lam}] ] ].

 Definition XS:= Vset.add hp (Vset.add Lam (Vset.singleton L)).

 Lemma Modify_S : forall E, Modify E XS S.
 Proof.
  intros E;compute_assertion X t (modify (refl1_info (empty_info E E)) (Vset.add Lam (Vset.singleton L)) S).
  refine (modify_correct _ _ _ X).
 Qed.

 Lemma EqObs_S : EqObs XS E0 S E1' S XS.
 Proof. eqobs_in. Qed.

 Lemma XS_global : forall x : VarP.Edec.t, Vset.mem x XS -> Var.is_global x.
 Proof.
  unfold XS;intros x;repeat rewrite VsetP.add_spec;intros [H0 | [H0 | H0 ] ];
  try (rewrite <- H0;trivial).
  apply Vset.singleton_complete in H0;rewrite <- H0;trivial.
 Qed.

 Lemma swap_equiv : equiv Meq E0 (proc_body E0 Hash ++ S) E1' (S ++ proc_body E1' Hash) Meq.
 Proof.
  union_mod;auto with *.
  apply equiv_strengthen with (kreq_mem (Vset.add lambda (Vset.add L (Vset.singleton Lam)))).
  intros k m1 m2 Heq;rewrite Heq;apply req_mem_refl.
  apply EqObs_trans with (E2 := E0) (c2:= (L' <- L)::(proc_body E0 Hash ++ S));
   [deadcode;eqobs_in | ].
  apply EqObs_trans with (E2 := E1') (c2:= (L' <- L)::(S ++ proc_body E1' Hash));
   [ | deadcode;eqobs_in].
  apply equiv_cons with (req_mem_rel (Vset.add L' (Vset.add lambda (Vset.add L (Vset.singleton Lam))))
                            (EP1 (L =?= L'))).
  eqobsrel_tail;unfold implMR;simpl;unfold O.eval_op;simpl;intros.
  change (E.eval_expr (L =?= L) m1);rewrite <- eval_eq;trivial.
  ep_eq L L'.
  unfold EP1;intros k m1 m2 (Heq, H1);rewrite <- (eval_eq m1 L L') in H1.
  split;[trivial | transitivity (E.eval_expr L m1)].
  apply depend_only_fv_expr;apply req_mem_sym;apply req_mem_weaken with (2:= Heq);vm_compute;trivial.
  transitivity (E.eval_expr L' m1);[trivial | ].
  apply depend_only_fv_expr;apply req_mem_weaken with (2:= Heq);vm_compute;trivial.
  cp_test (lambda in_dom L').
  ep_eq_l L L';[unfold EP1;intros k m1 m2 ((_,H),_);rewrite eval_eq;trivial | ].
  swap;eqobs_in.
  cp_test (Lam in_dom L').
  ep_eq (Lam =?= lambda) false.
  unfold req_mem_rel, andR, EP1, EP2, notR; intros k m1 m2 H;decompose [and] H;clear H.
  split;refine (not_true_is_false _ _).
  rewrite <- (eval_eq m1 Lam lambda);intros Heq;apply H2.
  generalize H3 Heq;clear H3 Heq;simpl;unfold O.eval_op;simpl; intros H3 Heq;rewrite <- Heq;trivial.
  rewrite <- (eval_eq m2 Lam lambda);intros Heq;apply H5.
  generalize H6 Heq;clear H6 Heq;simpl;unfold O.eval_op;simpl; intros H6 Heq;rewrite <- Heq;trivial.
  swap;eqobs_in.
  cp_test (Lam =?=lambda).
  alloc_l r hp;ep;eqobs_in.
  swap;eqobs_in.
 Qed.

 Definition swi_H :=
  add_sw_info S XS Vset.empty E0 E1' (Modify_S E0) (Modify_S E1') EqObs_S
  XS_global (fun t f => None) _ Hash swap_equiv.

 Definition swi : forall (tg : SemHElGamal.T.type) (g_ : Proc.proc tg),
  option (sw_info S XS Vset.empty E0 E1' tg g_).
  assert (swi_A : forall (tg : SemHElGamal.T.type) (g_ : Proc.proc tg), option (sw_info S XS Vset.empty E0 E1' tg g_)).
    refine (add_sw_info_Adv S XS Vset.empty E0 E1' (Modify_S E0) (Modify_S E1')
           EqObs_S XS_global swi_H _ A PrOrcl PrPriv Gadv Gcomm _ _);[ apply EqAD | trivial].
  refine (add_sw_info_Adv S XS Vset.empty E0 E1' (Modify_S E0) (Modify_S E1')
           EqObs_S XS_global swi_A _ A' PrOrcl PrPriv Gadv Gcomm _ _);[ apply EqAD | trivial].
 Defined.

 Lemma EqObs_G0_G1 : EqObs Gadv E0 G0 E1 G1 (fv_expr (b =?= b')).
 Proof.
  unfold G0, G1;match goal with
  |- EqObs _ _ (?i1::?i2::?i3::?c) _ (?ihp::_::_::_::?iLam::_) _ =>
     apply EqObs_trans with E0 ([i2;i3;iLam;i1]++(c++S));
     [deadcode iE0E0;swap iE0E0;eqobs_in iE0E0 |
      apply EqObs_trans with E1' ([i2;i3;iLam;i1]++(S++c));
      [ | ep iE1'E1;swap iE1'E1;eqobs_in iE1'E1]
     ]
  end.
  apply equiv_app with (kreq_mem (Vset.add x (Vset.add y (Vset.add Lam (Vset.add L Gadv))))).
  eqobs_in.
  match goal with
  |- equiv _ _ _ _ ?c _ => apply equiv_trans_eq_mem_l with (E1':= E1') (c1':= c) (P1:=trueR) end.
  apply equiv_strengthen with Meq;[intros k0 m1 m2 (H, _);trivial | ].
  apply check_swap_c_correct with (pi:= swi) (I:=Vset.empty).
   apply Modify_S.
   apply Modify_S.
   apply EqObs_S.
   vm_compute; trivial.
  eqobs_in iE1'E1'.
  red;intros;red;trivial.
 Qed.

 (** Game two *)
 Definition G2 :=
  [
   bad <- false;
   hp <$- {0,1}^k;
   L <- Nil _;
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   Lam <- g^(x *! y);
   mm <c- A with {g^x};
   b <$- {0,1};
   If b then [ mb <- Efst mm ] else [ mb <- Esnd mm ];
   h <- hp;
   v <- h |x| mb;
   b' <c- A' with {g^x, g^y, v}
  ].

 Definition Hash2_body :=
  [
   If Lam =?= lambda then
    [
     r <- hp
    ]
   else
    [
     If !(lambda in_dom L) then
      [
       r <$- {0,1}^k;
       L <- (lambda | r) |::| L
      ]
     else
      [
       r <- L[{lambda}]
      ]
    ]
  ].

 Definition E2 := makeEnv Hash2_body.

 Definition I2 :=
  EP1 ((Lam in_dom L) ==> (L[{Lam}] =?= hp)) /-\
  eq_assoc_except Lam L.

 Lemma dec_I2 : decMR I2.
 Proof.
  unfold I2; auto.
 Qed.

 Lemma dep_I2 : depend_only_rel I2
  (Vset.union (fv_expr ((Lam in_dom L) ==> (L[{Lam}] =?= hp)))
    (Vset.add Lam (Vset.singleton L)))
  (Vset.union Vset.empty (Vset.singleton L)).
 Proof.
  unfold I2; auto.
 Qed.

 Definition eE1E2 : eq_inv_info I2 E1 E2.
  refine (@empty_inv_info _ _ _ dep_I2 _ dec_I2 _ _).
  vm_compute; trivial.
 Defined.

 Lemma Hash1_Hash2 :
  EqObsInv I2
  (Vset.add hp (Vset.add Lam (Vset.singleton lambda)))
  E1 Hash1_body
  E2 Hash2_body
  (Vset.add r (Vset.singleton hp)).
 Proof.
  unfold Hash2_body, Hash1_body.
  cp_test (Lam =?= lambda).
  ep_eq lambda Lam.
  intros k m1 m2 (_,(H1,H2));split;symmetry;repeat rewrite eval_eq;trivial.
  cp_test_l (Lam in_dom L).

  ep_eq_l (L[{Lam}]) hp.
  unfold I2, req_mem_rel, andR, EP1, EP2; intros.
  decompose [and] H; clear H.
  rewrite eval_eq; apply modus_ponens with (e1:=Lam in_dom L); auto.
  eqobs_in eE1E2;unfold implMR, andR; tauto.

  rewrite proj1_MR, proj1_MR.
  unfold I2;eqobsrel_tail;
   unfold implMR, andR; simpl; unfold O.eval_op; simpl; unfold O.assoc; simpl.
  intros; rewrite CGK_eqb_refl; simpl.
  split;[rewrite Veqb_refl; trivial | intros r Hdiff].
  decompose [and] H;clear H.
  destruct (H3 _ Hdiff);clear H3.
  rewrite <- is_true_CGK_eqb in Hdiff;apply not_true_is_false in Hdiff;rewrite Hdiff.
  simpl;split;trivial.

  cp_test (lambda in_dom L).
  unfold I2;intros k m1 m2 ((H0,(W1,W2)), (H2, H3)).
  unfold notR, EP1 in H2; rewrite <- (eval_eq m1 Lam lambda) in H2; apply sym_not_eq in H2.
  destruct (W2 _ H2) as (W3,_);clear W2 H2.
  assert (E.eval_expr lambda m1 = E.eval_expr lambda m2).
    apply depend_only_fv_expr;apply req_mem_weaken with (2:= H0);vm_compute;trivial.
  generalize W3;rewrite H at 2;trivial.

  eapply equiv_strengthen; [ | apply equiv_assign].
  unfold req_mem_rel, upd_para, andR; intros.
  decompose [and] H; clear H; split.
  unfold kreq_mem;match goal with
  |- _{! _ <-- ?x1!} =={_} _{! _ <-- ?x2!} => replace x2 with x1
  end.
  apply req_mem_update.
  apply req_mem_weaken with (2:=H0); vm_compute; trivial.
  unfold notR, EP1 in H2;rewrite <- (eval_eq m1 Lam lambda) in H2;apply sym_not_eq in H2.
  destruct H4 as (W1, W2);destruct (W2 _ H2).
  assert (E.eval_expr lambda m1 = E.eval_expr lambda m2).
    apply depend_only_fv_expr;apply req_mem_weaken with (2:= H0);vm_compute;trivial.
  generalize H1;rewrite H4 at 2;trivial.
  apply (@dep_I2 k m1 m2);trivial.
  apply req_mem_upd_disjoint;vm_compute;trivial.
  apply req_mem_upd_disjoint;vm_compute;trivial.

  unfold I2;eqobsrel_tail;
    unfold implMR, andR; simpl; unfold O.eval_op; simpl; unfold O.assoc; simpl.
  intros k m1 m2 H v _;decompose [and] H;clear H.
  unfold notR, EP1 in H3;generalize H3;simpl;unfold O.eval_op;simpl;intros W.
  apply not_true_is_false in W;rewrite W;split;[exact H1 | ].
  intros r Hdiff;generalize (H4 _ Hdiff);simpl;unfold O.eval_op, O.assoc;simpl;intros (W1,W2).
  replace (m2 lambda) with (m1 lambda);
   [ | apply H0;trivial].
  split;[rewrite W1;trivial| ].
  destruct (CGK.eqb r (m1 lambda));trivial.
 Qed.

 Definition hE1E2 := add_info Hash Vset.empty Vset.empty eE1E2 Hash1_Hash2.

 Definition iE1E2inv :=
  add_adv_info_lossless (EqAD _ _) (A'_wf_E _)
  (@A'_lossless _ (EqAD _ _))
  (@A'_lossless _ (EqAD _ _))
  (add_adv_info_lossless (EqAD _ _) (A_wf_E _)
   (@A_lossless _ (EqAD _ _))
   (@A_lossless _ (EqAD _ _))
   hE1E2).

 Definition iE2E2 := iEiEi Hash2_body Vset.empty Vset.empty.

 Lemma EqObs_G1_G2 : EqObs Gadv E1 G1 E1 G2 (fv_expr (b =?= b')).
 Proof.
  unfold G1, G2.
  match goal with
  |- EqObs ?I ?E1 (?i1::?i2::?i3::?i4::?i5::?c1)
              ?E2 (?i0::?i1::?i2::?i3::?i4::?i5::?c2) ?Q =>
     change (EqObs I E1 ((i1::i2::i3::i4::i5::nil) ++ c1)
                     E2 ((i0::i1::i2::i3::i4::i5::nil) ++ c2) Q)
  end.
  set (I:= (Vset.add L (Vset.add hp (Vset.add x (Vset.add y (Vset.add Lam Gadv)))))).
  set (O:= fv_expr (b =?= b')).
  apply equiv_app with (req_mem_rel I (EP1 (L =?= Nil _))).
  unfold I2; eqobsrel_tail;
   simpl; unfold O.eval_op; simpl; unfold implMR; simpl; intuition.
  match goal with
  |- equiv _ _ ?c _ _ _ =>
     apply equiv_trans with (P1:=req_mem_rel I I2) (Q1:= kreq_mem O) (Q2:= kreq_mem O)
     (E2:= E2) (c2:=c) end.
  auto using dec_I2.
  intros k m1 m2 (H1, H2);split.
  apply req_mem_trans with m2;[ | apply req_mem_sym];trivial.
  generalize H2;unfold EP1.
  rewrite <- (eval_eq m1 L (Nil _)).
  unfold I2, eq_assoc_except, EP1, EP2, andR;simpl;unfold O.eval_op;simpl;intros Heq;rewrite Heq;auto.
  apply req_mem_trans.
  eqobs_in iE1E2inv.
  match goal with
  |- equiv _ _ _ _ ?c _ =>
     apply equiv_trans with (P1:=kreq_mem I) (Q1:= kreq_mem O) (Q2:= kreq_mem O)
     (E2:= E2) (c2:=c) end.
  auto using dec_I2.
  intros k m1 m2 _;apply req_mem_refl.
  apply req_mem_trans.
  sinline_l iE2E2 Hash;eqobs_in iE2E2.
  apply equiv_sym_transp.
  apply equiv_strengthen with (req_mem_rel I I2).
  intros k m1 m2 (H1, H2);split;[apply req_mem_sym;trivial | ].
  generalize H2;unfold EP1.
  rewrite <- (eval_eq m2 L (Nil _)).
  unfold I2, eq_assoc_except, EP1, EP2, andR;simpl;unfold O.eval_op;simpl;intros Heq.
  rewrite <- (H1 _ L), Heq;auto.
  apply equiv_weaken with (kreq_mem O);[exact (@req_mem_sym O) | ].
  eqobs_in iE1E2inv.
 Qed.

 (** Game three *)
 Definition G3 := G2.

 Definition Hash3_body :=
  [
   If !(lambda in_dom L) then
   [
    If Lam =?= lambda then
     [
      bad <- true; r <$- {0,1}^k
     ]
    else
     [
      r <$- {0,1}^k
     ];
    L <- (lambda | r) |::| L
   ]
   else [
    r <- L[{lambda}]
   ]
  ].

 Definition E3 := makeEnv Hash3_body.

 Definition iE3E3 := iEiEi Hash3_body Vset.empty Vset.empty.

 Definition upto_info : upto_info bad E1 E3 :=
  add_adv_upto_info
   (add_adv_upto_info
    (add_upto_info (empty_upto_info bad _ _) Hash)
    (EqAD _ _) (EqOP _ _) (A_wf_E _))
   (EqAD _ _) (EqOP _ _) (A'_wf_E _).

 Lemma Pr_G2_G3 : forall k (m:Mem.t k),
  Uabs_diff (Pr E1 G2 m (EP k (b =?= b'))) (Pr E3 G3 m (EP k (b =?= b'))) <=
  Pr E3 G3 m (EP k bad).
 Proof.
  intros.
  unfold G3, G2, Pr.
  setoid_rewrite deno_cons_elim.
  setoid_rewrite Mlet_simpl.
  setoid_rewrite deno_assign_elim.
  apply upto_bad_Uabs_diff with upto_info;
   [ | | apply is_lossless_correct with (refl1_info iE3E3)];
  vm_compute; trivial.
 Qed.

 Definition I3 := EP1 (bad ==> (Lam in_dom L)).

 Lemma dec_I3 : decMR I3.
 Proof.
  unfold I3; auto.
 Qed.

 Lemma dep_I3 : depend_only_rel I3
  (fv_expr (bad ==> (Lam in_dom L)))
  Vset.empty.
 Proof.
  unfold I3; auto.
 Qed.

 Definition eE3E3 : eq_inv_info I3 E3 E3.
  refine (@empty_inv_info _ _ _ dep_I3 _ dec_I3 _ _).
  vm_compute; trivial.
 Defined.

 Lemma Hash3_inv :
  EqObsInv I3
  (Vset.add hp (Vset.add bad (Vset.add L (Vset.add Lam (Vset.singleton lambda)))))
  E3 Hash3_body
  E3 Hash3_body
  (Vset.add r (Vset.add bad (Vset.add L (Vset.singleton hp)))).
 Proof.
  unfold Hash3_body.
  cp_test (lambda in_dom L).
  eqobs_in eE3E3; unfold implMR, andR; tauto.
  cp_test (Lam =?= lambda).
  ep_eq lambda Lam.
  intros k m1 m2 (_, (H1,H2));split;symmetry;rewrite eval_eq;trivial.
  unfold I3; eqobsrel_tail; unfold implMR, EP1, andR;
   simpl; unfold O.eval_op; simpl.
  intros k m1 m2 [ _ [_ [ [H _] _] ] ].
  rewrite CGK_eqb_refl; trivial.

  unfold I3; eqobsrel_tail; unfold implMR, andR, EP1, notR;
   simpl; unfold O.eval_op; simpl;intros k m1 m2 H;decompose [and] H;clear H;intros.
  rewrite not_is_true_false in H1;rewrite H1;trivial.
 Qed.

 Definition hE3E3 := add_info Hash Vset.empty Vset.empty eE3E3 Hash3_inv.

 Definition iE3E3inv :=
  add_adv_info_lossless (EqAD _ _) (A'_wf_E _)
  (@A'_lossless _ (EqAD _ _))
  (@A'_lossless _ (EqAD _ _))
  (add_adv_info_lossless (EqAD _ _) (A_wf_E _)
   (@A_lossless _ (EqAD _ _))
   (@A_lossless _ (EqAD _ _))
   hE3E3).

 Lemma Pr_G3_bad : forall k (m:Mem.t k),
  Pr E3 G3 m (EP k bad) <= Pr E3 G3 m (EP k (Lam in_dom L)).
 Proof.
  intros; unfold G3, G2, Pr.
  eapply equiv_deno_le with (req_mem_rel Gadv trueR) (req_mem_rel (Vset.add Lam (Vset.add bad (Vset.singleton L))) I3).
  eqobs_tl iE3E3inv.
  unfold I3; eqobsrel_tail; unfold implMR, andR;
   simpl; unfold O.eval_op; trivial.
  intros m1 m2 [H Hin]; unfold charfun, restr, EP, fone.
  rewrite <- depend_only_fv_expr_subset with (2:=H);
   unfold Vset.subset; trivial.
  case_eq (E.eval_expr bad m1); intro;[ | trivial].
  rewrite modus_ponens with (e1:=bad); trivial.
  unfold req_mem_rel, andR, trueR; auto.
 Qed.

 (** Game four *)
 Definition G4 :=
  [
   L <- Nil _;
   x <$- [0..q-!1];
   y <$- [0..q-!1];
   Lam <- g^(x *! y);
   mm <c- A with {g^x};
   b <$- {0,1};
   If b then [mb <- Efst (mm)] else [mb <- Esnd (mm)];
   v <$- {0,1}^k;
   hp <- v |x| mb;
   b' <c- A' with {g^x, g^y, v}
  ].

 Definition Hash4_body := Hash0_body.

 Definition E4 := makeEnv Hash4_body.

 Definition iE4E4 := iEiEi Hash4_body Vset.empty Vset.empty.

 Lemma Pr_G4 : forall k (m:Mem.t k),
  Pr E4 G4 m (EP k (b =?= b')) == [1/2].
 Proof.
  intros.
  transitivity (Pr E4 (G4 ++ [b <$- {0,1}]) m (EP k (b =?= b'))).
  apply EqObs_Pr with Gadv.
  swap iE4E4; deadcode iE4E4; eqobs_in iE4E4.
  apply Pr_sample_bool; [discriminate | ].
  apply is_lossless_correct with (refl1_info iE4E4); vm_compute; trivial.
 Qed.

 Lemma Hash3_Hash4 :
  EqObsInv trueR (Vset.add lambda (Vset.singleton L))
  E3 Hash3_body
  E4 Hash4_body
  (Vset.add r (Vset.add lambda (Vset.singleton L))).
 Proof.
  unfold Hash3_body, Hash4_body, Hash0_body.
  cp_test (lambda in_dom L);[eqobs_in | ].
  cp_test_l (Lam =?= lambda);[ | eqobs_in].
  ep_eq_l Lam lambda.
  intros k m1 m2 [_ H]; rewrite eval_eq; trivial.
  deadcode; eqobs_in.
 Qed.

 Definition iE3E4 := iEiEj Hash3_Hash4.

 Lemma EqObs_G3_G4 : EqObs Gadv E3 G3 E4 G4 (Vset.add L (Vset.add Lam (fv_expr (b =?=b')))).
 Proof.
  unfold G4, G3, G2.
  apply EqObs_trans with E4
   [
     L <- E.Cnil (T.Pair (T.User Group) (T.User Bitstring));
     x <$- [0..q -! 1];
     y <$- [0..q -! 1];
     Lam <- g ^ (x *! y);
     mm <c- A with {g ^ x};
     b <$- {0,1};
     If b then [mb <- Efst (mm)] else [mb <- Esnd (mm)];
     hp <$- {0,1}^k;
     v <- hp |x| mb;
     b' <c- A' with {g ^ x, g ^ y, v}
   ].
  ep; swap iE3E4.
  eqobs_tl iE3E4.
  deadcode; eqobs_in.

  eqobs_ctxt iE4E4.
  union_mod.
  eapply equiv_sub; [ | | apply opt_sampling; discriminate].
  simpl; intros; apply req_mem_weaken with (2:=H); red; trivial.
  simpl; intros; apply req_mem_weaken with (2:=H); red; trivial.
 Qed.

 (** Game five *)
 Notation i := (Var.Lvar T.Nat 20).
 Notation z := (Var.Lvar (T.User Group) 40).
 Notation gamma := (Var.Lvar (T.User Group) 50).

 Definition G5 := CDH x y z 4.

 (** The adversary against list CDH *)

 Definition B_body :=
  [
   L <- Nil _;
   mm <c- A with {alpha};
   v <$- {0,1}^k;
   b' <c- A' with {alpha, beta, v}
 ] ++
 [ i <$- [0..Elen L]; gamma <- Efst (Enth {i, L}) ].

 Definition B_params : var_decl (Proc.targs B) :=
  dcons _ alpha (dcons _ beta (dnil _)).

 Definition B_ret := gamma.

 Definition E5 := add_decl E4 B B_params (refl_equal true) B_body B_ret.

 Lemma EqAD_5 : Eq_adv_decl PrOrcl PrPriv E5 E5.
 Proof.
  unfold Eq_adv_decl; auto.
 Qed.

 Lemma EqAD_05 : Eq_adv_decl PrOrcl PrPriv E0 E5.
 Proof.
  unfold Eq_adv_decl, E0, E5, E4, makeEnv, proc_params, proc_body, proc_res.
  intros.
  generalize (BProc.eqb_spec (BProc.mkP A') (BProc.mkP f)).
  destruct (BProc.eqb (BProc.mkP A') (BProc.mkP f)); intros.
  inversion H1; simpl; auto.
  generalize (BProc.eqb_spec (BProc.mkP A) (BProc.mkP f)).
  destruct (BProc.eqb (BProc.mkP A) (BProc.mkP f)); intros.
  inversion H2; simpl; auto.
  repeat rewrite add_decl_other_mk; try tauto.
  intro Heq; apply H; rewrite <- Heq; vm_compute; trivial.
  intro Heq; apply H0; rewrite <- Heq; vm_compute; trivial.
  intro Heq; apply H; rewrite <- Heq; vm_compute; trivial.
 Qed.

 Definition iE4E5 :=
  let Aloss := @A_lossless E4 (EqAD _ _) in
  let A'loss := @A'_lossless E4 (EqAD _ _) in
  let Aloss' := @A_lossless E5 EqAD_05 in
  let A'loss' := @A'_lossless E5 EqAD_05 in
  let piH := add_refl_info Hash (empty_info E4 E5) in
  let piA := add_adv_info_lossless EqAD_05 (A_wf_E _) Aloss Aloss' piH in
   add_adv_info_lossless EqAD_05 (A'_wf_E _) A'loss A'loss' piA.

 Definition B_advantage := CDH_advantage x y z 4 E5.

 (** The adversary makes at most qH queries to the hash oracle *)
 Variable qH : nat -> nat.

 Hypothesis range_G4 : forall k (m:Mem.t k),
  range (EP k (Elen L <! qH k)) ([[G4]] E4 m).

 Close Scope bool_scope.

 Lemma EP_and : forall k e1 e2,
  (EP k e1) [&&] (EP k e2) == EP k (e1 && e2).
 Proof.
  trivial.
 Qed.

 Lemma security_bound : forall k (m:Mem.t k),
  [1/]1+pred (qH k) *  Uabs_diff (Pr E0 G0 m (EP k (b =?= b'))) [1/2] <=
  B_advantage m.
 Proof.
  intros.
  set (G4':=
   [
    L <- Nil _;
    x <$- [0..q -! 1];
    y <$- [0..q -! 1];
    mm <c- A with {g^x};
    v <$- {0,1}^k;
    b' <c- A' with {g^x, g^y, v}
    ]).
  assert (Uabs_diff (Pr E0 G0 m (EP k (b =?= b'))) [1/2] <=
   Pr E4 G4' m ((EP k ((Elen L <! qH k) && (g^(x *! y) in_dom L))))).
  eapply Ole_trans; [apply Oeq_le | eapply Ole_trans; [apply (Pr_G2_G3 m) | ] ].
  apply Uabs_diff_morphism.
  apply EqObs_Pr with Gadv.
  apply EqObs_trans with (1:=EqObs_G0_G1); apply EqObs_G1_G2.
  rewrite <- (Pr_G4 m); symmetry.
  apply EqObs_Pr with Gadv; apply equiv_weaken with (2:=EqObs_G3_G4).
  intros k0 m1 m2 H; apply req_mem_weaken with (2:=H); vm_compute; trivial.
  eapply Ole_trans; [apply Pr_G3_bad | ].
  apply Ole_trans with (Pr E4 G4 m (EP k (Lam in_dom L))).
  apply EqObs_Pr with Gadv.
  apply EqObs_sym.
  apply equiv_weaken with (2:=EqObs_G3_G4).
  intros k0 m1 m2 H; apply req_mem_weaken with (2:=H); vm_compute; trivial.
  rewrite (Pr_range _ _ (range_G4 m)).

  rewrite EP_and.
  apply Oeq_le.
  rewrite (Pr_d_eq _ _ _ b); symmetry; rewrite (Pr_d_eq _ _ _ b).
  apply EqObs_Pr with Gadv.
  ep iE4E4; deadcode iE4E4; eqobs_in iE4E4.

  rewrite H.
  eapply Ole_trans.
  apply (Pr_random_dom G4' (g^(x *! y)) qH i z L E4);
   apply not_is_true_false; trivial.
  apply EqObs_Pr with Gadv.
  apply EqObs_sym.
  sinline_r iE4E5 B; swap iE4E5; eqobs_in iE4E5.
 Qed.

 Definition pi : PPT_info E5 :=
  PPT_add_adv_infob EqAD_05 A'_PPT
   (PPT_add_adv_infob EqAD_05 A_PPT
    (PPT_add_info (PPT_empty_info E5) Hash)).

 Lemma semantic_security : forall m,
  negligible (fun k => [1/]1+pred (qH k) * Uabs_diff (Pr E0 G0 (m k) (EP k (b =?= b'))) [1/2]).
 Proof.
  intro m.
  apply negligible_le_stable with
   (fun k => CDH_advantage x y z 4%positive E5 (m k)).
  intro; apply security_bound.
  apply CDH_assumption.
  discriminate.
  trivial.
  trivial.
  apply is_lossless_correct with (refl2_info iE4E5); vm_compute; trivial.
  PPT_proc_tac pi.
 Qed.

End ADVERSARY_AND_PROOF.


Require Import
        Coq.Strings.Ascii
        Coq.Strings.String
        Coq.Numbers.BinNums
        Fiat.Common
        Fiat.Computation.Notations
        Fiat.BinEncoders.Env.Common.Specs
        Fiat.BinEncoders.Env.Common.WordFacts.

Inductive ASN1_Simple : Set :=
| ASN_Boolean : ASN1_Simple (* Universal 1 *)
| ASN_Null : ASN1_Simple (* Universal 5 *)
| ASN_Integer : ASN1_Simple (* Universal 2 *)
| ASN_Enum : (* Universal 10 *)
    list nat (* Codes *)
    -> ASN1_Simple
| ASN_BitString : ASN1_Simple (* Universal 3 *)
| ASN_OctetString : ASN1_Simple (* Universal 4 *)
| ASN_NumericString : ASN1_Simple (* Universal 18*)
| ASN_PrintableString : ASN1_Simple (* Universal 19 *)
| ASN_IA5String : ASN1_Simple. (* Universal 22 *)

Inductive ASN1_Simple_Modifier : Set :=
| ASN_Size_Fixed : nat -> ASN1_Simple_Modifier
| ASN_Size_Range : nat -> nat -> ASN1_Simple_Modifier
| ASN_None : ASN1_Simple_Modifier.

Definition ASN1_Simple_denote (desc : ASN1_Simple) : Set :=
  match desc with
  | ASN_Boolean => bool
  | ASN_Null => unit
  | ASN_Integer => Z
  | ASN_Enum n => Fin.t (length n)
  | ASN_BitString => list bool
  | ASN_OctetString => list (word 8)
  | ASN_NumericString => string
  | ASN_PrintableString => string
  | ASN_IA5String => string
  end.

Inductive ASN1_Structured : Set :=
| ASN_Sequence : list ASN1_Sequence_Element -> ASN1_Structured
| ASN_Choice : list ASN1_Type -> ASN1_Structured
| ASN_Sequence_Of : ASN1_Type -> ASN1_Structured

with ASN1_Sequence_Element : Set :=
     | Normal_Sequence_Element :
         ASN1_Type -> ASN1_Sequence_Element
     | Optional_Sequence_Element :
         ASN1_Type -> ASN1_Sequence_Element
     | Default_Sequence_Element :
         forall (desc : ASN1_Simple),
           ASN1_Simple_Modifier
           -> ASN1_Simple_denote desc
           -> ASN1_Sequence_Element

with ASN1_Type : Set :=
     | ASN_Simple : ASN1_Simple -> ASN1_Simple_Modifier -> ASN1_Type
     | ASN_Structured : ASN1_Structured -> ASN1_Type.

Coercion ASN_Structured : ASN1_Structured >-> ASN1_Type.

Definition ASN_Simple_UnModified (desc : ASN1_Simple) : ASN1_Type :=
  ASN_Simple desc ASN_None.
Coercion ASN_Simple_UnModified : ASN1_Simple >-> ASN1_Type.

Fixpoint ASN1_Structured_denote (desc : ASN1_Structured) : Set :=
  match desc with
  | ASN_Sequence l =>
    (fix ASN1_Sequence_denote (descs : list ASN1_Sequence_Element) {struct descs} : Set :=
       match descs with
       | Normal_Sequence_Element desc :: descs' =>
         (ASN1_Type_denote desc) * (ASN1_Sequence_denote descs')
       | Optional_Sequence_Element desc :: descs' =>
         option (ASN1_Type_denote desc) * (ASN1_Sequence_denote descs')
       | Default_Sequence_Element desc _ _ :: descs' =>
         (ASN1_Simple_denote desc) * (ASN1_Sequence_denote descs')
       | [ ] => unit
       end)%type l
  | ASN_Choice l =>
    (fix ASN1_Choice_denote (descs : list ASN1_Type) {struct descs} : Set :=
       match descs with
       | desc :: descs' => (ASN1_Type_denote desc) + (ASN1_Choice_denote descs')
       | [ ] => unit
       end)%type l
  | ASN_Sequence_Of desc' => list (ASN1_Type_denote desc')
  end

with ASN1_Type_denote (desc : ASN1_Type) : Set :=
       match desc with
       | ASN_Simple desc' mod => ASN1_Simple_denote desc'
       | ASN_Structured desc' => ASN1_Structured_denote desc'
       end.

Section ASN1_Format.

  Require Import
          Bedrock.Word.

  Require Import
          Fiat.Common.EnumType
          Fiat.BinEncoders.Env.Lib2.WordOpt
          Fiat.BinEncoders.Env.Lib2.EnumOpt
          Fiat.BinEncoders.Env.Lib2.Bool
          Fiat.BinEncoders.Env.Lib2.NatOpt
          Fiat.BinEncoders.Env.Lib2.FixStringOpt
          Fiat.BinEncoders.Env.Common.ComposeOpt.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {transformer : Transformer B}.
  Context {transformerUnit : QueueTransformerOpt transformer bool}.

  Import Coq.Vectors.VectorDef.VectorNotations.

  Definition Tag_Classes :=
    ["Universal"; "Application"; "Context-Specific"; "Private"]%string.

  Definition Tag_Class_Codes :=
    [WO~0~0; WO~0~1; WO~1~0; WO~1~1].

  Definition Tag_Class := EnumType Tag_Classes.

  Definition ASN1_Format_Tag
           (tag : Tag_Class)
           (primitive : bool)
           (identifier : nat)
    : CacheEncode -> Comp (B * CacheEncode) :=
          encode_enum_Spec Tag_Class_Codes tag
    ThenC encode_word_Spec (WS primitive WO)
    ThenC (If (NPeano.ltb identifier 31) Then
              encode_nat_Spec 5 identifier
              Else (encode_nat_Spec 31 identifier
              ThenC (* TODO: Put actual high-tag formating rule here. *)
              encode_nat_Spec 5 identifier))
    DoneC.

  Definition ASN1_Format_Definite_Length
             (length : nat)
    : CacheEncode -> Comp (B * CacheEncode) :=
    If (NPeano.ltb length 127) Then
       encode_nat_Spec 8 length
    Else
       (encode_word_Spec WO~1 (* Set highest bit to 1 *)
       ThenC encode_nat_Spec (S (NPeano.div (NPeano.log2 length) 8)) 7
       ThenC encode_nat_Spec length (S (NPeano.div (NPeano.log2 length) 8) * 8))
       DoneC.

  Fixpoint ASN1_Format_Simple_DER
         (desc : ASN1_Simple)
  : ASN1_Simple_denote desc -> CacheEncode -> Comp (B * CacheEncode) :=
  match desc return
        ASN1_Simple_denote desc
        -> CacheEncode
        -> Comp (B * CacheEncode) with
  | ASN_Boolean =>
    fun data =>
      ASN1_Format_Tag Fin.F1 false 1
    ThenC ASN1_Format_Definite_Length 1
    ThenC encode_word_Spec (if data then natToWord 8 255 else natToWord 8 0)
    DoneC

  | ASN_Null =>
    fun data =>
      ASN1_Format_Tag Fin.F1 false 5
    ThenC ASN1_Format_Definite_Length 0
    DoneC

  | ASN_Integer => fun data => encode_word_Spec (natToWord 1 10) (* TODO *)
  | ASN_Enum n => fun data => encode_word_Spec (natToWord 1 10) (* TODO *)
  | ASN_BitString => fun data => encode_word_Spec (natToWord 1 10) (* TODO *)
  | ASN_OctetString => fun data => encode_word_Spec (natToWord 1 10) (* TODO *)
  | ASN_NumericString => fun data => encode_word_Spec (natToWord 1 10) (* TODO *)
  | ASN_PrintableString => fun data => encode_word_Spec (natToWord 1 10) (* TODO *)
  | ASN_IA5String =>
    fun data =>
      ASN1_Format_Tag Fin.F1 false 22
    ThenC ASN1_Format_Definite_Length (String.length data)
    ThenC encode_string_Spec data
    DoneC
  end.

End ASN1_Format.

Arguments ASN1_Format_Definite_Length _ _ / . (* Always simplify this format*)
Arguments ASN1_Format_Tag _ _ / . (* Always simplify this format*)

Section ASN1_Decoder_Example.

  Require Import
          Fiat.BinEncoders.Env.Lib2.NoCache
          Fiat.BinEncoders.Env.Automation.Solver
          Fiat.BinEncoders.Env.BinLib.AlignedByteString
          Fiat.BinEncoders.Env.BinLib.AlignWord
          Fiat.BinEncoders.Env.BinLib.AlignedDecoders.

  Instance ByteStringQueueTransformer : Transformer ByteString :=
    ByteStringQueueTransformer.

  Example Simple_Format : ASN1_Simple :=
    ASN_IA5String.

  Ltac normalize_Compose Transformer :=
    eapply SetoidMorphisms.refine_refineEquiv_Proper;
    [ unfold flip;
      repeat first
             [ etransitivity; [ apply refineEquiv_compose_compose with (transformer := Transformer) | idtac ]
             | etransitivity; [ apply refineEquiv_compose_Done with (transformer := Transformer) | idtac ]
             | apply refineEquiv_under_compose with (transformer := Transformer) ];
      intros; first [reflexivity | higher_order_reflexivity]
    | reflexivity | ].

  Add Parametric Morphism
      (E B : Type) (transformer : Transformer B)
    : (@compose E B transformer)
      with signature
      (pointwise_relation _ (@refine (B * E)))
        ==> (pointwise_relation _ (@refine (B * E)))
        ==> (@eq E)
        ==> (@refine (B * E))
        as refine_compose.
  Proof.
    unfold pointwise_relation, compose, Bind2; intros.
    setoid_rewrite H; setoid_rewrite H0; reflexivity.
  Qed.

  Lemma refine_compose_compose
     : forall (E B : Type) (transformer : Transformer B) (encode1 encode2 encode3 : E -> Comp (B * E)) (ctx : E),
      refine (((encode1 ThenC encode2) ThenC encode3) ctx) ((encode1 ThenC encode2 ThenC encode3) ctx).
  Proof.
    unfold pointwise_relation; intros.
    apply refineEquiv_compose_compose.
  Qed.

  Lemma refine_ThenC_beta_reduce
    : forall (E B : Type) (transformer : Transformer B) (encode1 encode2 : E -> Comp (B * E)) (ctx : E),
      refine ((encode1 ThenC (fun ctx' => encode2 ctx')) ctx)
             ((encode1 ThenC encode2) ctx).
  Proof.
    intros; reflexivity.
  Qed.

  Lemma refine_If_Then_Else_beta_reduce
    : forall (E B : Type) (transformer : Transformer B) (encode1 encode2 : E -> Comp (B * E)) (ctx : E) b,
      refine ((If b Then encode1 Else encode2) ctx)
             (If b Then encode1 ctx Else encode2 ctx).
  Proof.
    intros; destruct b; reflexivity.
  Qed.

  Lemma refine_If_Then_Else_ThenC
    : forall (E B : Type) (transformer : Transformer B) (encode1 encode2 encode3 : E -> Comp (B * E)) (ctx : E) b,
      refine (((If b Then encode1 Else encode2) ThenC encode3) ctx)
             (If b Then ((encode1 ThenC encode3) ctx) Else ((encode2 ThenC encode3) ctx)).
  Proof.
    intros; destruct b; reflexivity.
  Qed.

  Corollary AlignedEncodeNat
            {numBytes}
    : forall (n : nat) ce ce' (c : _ -> Comp _) (v : Vector.t _ numBytes),
      refine (c (addE ce 8)) (ret (build_aligned_ByteString v, ce'))
      -> refine (((encode_nat_Spec 8 (transformerUnit := ByteString_QueueTransformerOpt) n)
                    ThenC c) ce)
                (ret (build_aligned_ByteString (Vector.cons _ (natToWord 8 n) _ v), ce')).
  Proof.
    unfold encode_nat_Spec; cbv beta; intros.
    rewrite <- AlignedEncodeChar; eauto.
    reflexivity.
  Qed.

  Definition Variational_Vector
             {numBytesT numBytesE}
             (b : bool)
             (vT : Vector.t Core.char numBytesT)
             (vE : Vector.t Core.char numBytesE)
    : Vector.t Core.char (If b Then numBytesT Else numBytesE) :=
    match b return
          Vector.t Core.char (If b Then numBytesT Else numBytesE)
    with
    | true => vT
    | false => vE
    end.

  Lemma AlignedEncode_If_Then_Else
            {numBytesT numBytesE}
    : forall (b : bool) ctx ctxT ctxE
             (vT : Vector.t Core.char numBytesT)
             (vE : Vector.t Core.char numBytesE)
             (encode1 encode2 : CacheEncode -> Comp (_ * CacheEncode)),
      (b = true
       -> refine (encode1 ctx) (ret (build_aligned_ByteString vT, ctxT)))
      -> (b = false
          -> refine (encode2 ctx) (ret (build_aligned_ByteString vE, ctxE)))
      -> refine (If b Then (encode1 ctx) Else (encode2 ctx))
                (ret (build_aligned_ByteString (Variational_Vector b vT vE)

                      , If b Then ctxT Else ctxE)).
  Proof.
    destruct b; simpl; intros; eauto.
  Qed.

  Lemma build_aligned_ByteString_id {B}
    : forall ctx : B,
      refine (ret (ByteString_id, ctx))
             (ret (build_aligned_ByteString (Vector.nil _), ctx)).
  Proof.
    intros; replace ByteString_id
             with (build_aligned_ByteString (Vector.nil _)).
    reflexivity.
    eapply ByteString_f_equal;
      instantiate (1 := eq_refl _); reflexivity.
  Qed.

  Definition Correct_simple_encoder
    : { simple_encoder : _ &
                         forall (t : ASN1_Simple_denote Simple_Format),
                           NPeano.Nat.ltb (String.length t) 127 = true
                           -> refine (ASN1_Format_Simple_DER Simple_Format t ())
                     (ret (simple_encoder t)) }.
  Proof.
    simpl; eexists; intros.
    unfold encode_nat_Spec at 1, encode_enum_Spec; simpl.
    eapply SetoidMorphisms.refine_refineEquiv_Proper;
      [ unfold flip;
        repeat first
               [ etransitivity; [ apply refineEquiv_compose_compose with (transformer := ByteStringQueueTransformer) | idtac ]
               | etransitivity; [ apply refineEquiv_compose_Done with (transformer := ByteStringQueueTransformer) | idtac ]
               | apply refineEquiv_under_compose with (transformer := ByteStringQueueTransformer) ];
        intros; higher_order_reflexivity
      | reflexivity | ];
      rewrite refine_ThenC_beta_reduce.
    rewrite (@CollapseEncodeWord _ test_cache); simpl; eauto.
    rewrite !refine_ThenC_beta_reduce.
    rewrite (@CollapseEncodeWord _ test_cache); simpl; eauto.
    rewrite !refine_ThenC_beta_reduce.
    eapply (@AlignedEncodeChar test_cache); eauto.
    rewrite refine_If_Then_Else_ThenC.
    eapply AlignedEncode_If_Then_Else; intros.
    eapply (@AlignedEncodeNat _).
    eapply (@encode_string_aligned_ByteString test_cache); eauto.
    apply build_aligned_ByteString_id.
    congruence.
    Grab Existential Variables.
    exact ().
    apply Vector.nil.
  Defined.

  Arguments natToWord : simpl never.

  Definition byte_aligned_simple_encoder
             (t :  ASN1_Simple_denote Simple_Format)
    := Eval simpl in (projT1 Correct_simple_encoder t).

  Print byte_aligned_simple_encoder.

End ASN1_Decoder_Example.

Section ASN1_Example.
  (* Suppose a company owns several sales outlets linked to a central *)
  (* warehouse where stocks are maintained and deliveries start from. The *)
  (* company requires that its protocol have the following features: *)
  (* 1) the orders are collected locally at the sales outlets ; *)
  (* 2) they are transmitted to the warehouse, where the delivery *)
  (*    procedure should be managed ; *)
  (* 3) an account of the delivery must be sent back to the sales outlets *)
  (*    for following through the client's order. *)
  (* Example taken from: http://www.itu.int/en/ITU-T/asn1/Pages/introduction.aspx. *)

  (* Item-code ::= NumericString(SIZE (7)) *)
  Definition ItemCode : ASN1_Type :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 7).

  (* Label ::= PrintableString(SIZE (1..30)) *)
  Definition Label : ASN1_Type :=
    ASN_Simple ASN_PrintableString (ASN_Size_Range 1 30).

  (* Quantity ::= CHOICE {
   unites        INTEGER,
   millimetres   INTEGER,
   milligrammes  INTEGER
} *)

  Definition Quantity : ASN1_Type :=
    ASN_Choice [ASN_Simple_UnModified ASN_Integer;
                  ASN_Simple_UnModified ASN_Integer;
                  ASN_Simple_UnModified ASN_Integer].

  (* Cents ::= INTEGER *)
  Definition Cents : ASN1_Type := ASN_Integer.

  (* Order-number ::= NumericString(SIZE (12)) *)
  Definition Order_Number : ASN1_Type :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 12).

  (* Delivery-line ::= SEQUENCE {item      Item-code,
                            quantity  Quantity *)
  Definition Delivery_Line : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element ItemCode;
                    Normal_Sequence_Element Quantity].

  (*Delivery-report ::= SEQUENCE {
  order-code  Order-number,
  delivery    SEQUENCE OF Delivery-line
} *)

  Definition Delivery_Report : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Number;
                    Normal_Sequence_Element (ASN_Structured (ASN_Sequence_Of Delivery_Line))].

  (* Date ::= NumericString(SIZE (8)) -- MMDDYYYY *)
  Definition Date : ASN1_Type  :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 8).

  (* default-country PrintableString ::= "France" *)
  Definition Default_Country : ASN1_Type_denote ASN_PrintableString := "France"%string.

  (* Client ::= SEQUENCE {
  name      PrintableString(SIZE (1..20)),
  street    PrintableString(SIZE (1..50)) OPTIONAL,
  postcode  NumericString(SIZE (5)),
  town      PrintableString(SIZE (1..30)),
  country   PrintableString(SIZE (1..20)) DEFAULT default-country
  } *)
  Definition Client : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 20));
                    Optional_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 50));
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 5));
                    Normal_Sequence_Element (ASN_Simple ASN_PrintableString (ASN_Size_Range 1 30));
                    Default_Sequence_Element ASN_PrintableString (ASN_Size_Range 1 20) Default_Country].

  (* Card-type ::= ENUMERATED {
  cb(0), visa(1), eurocard(2), diners(3), american-express(4)} *)
  Definition Card_Type : ASN1_Type :=
    ASN_Enum [ 0; 1; 2; 3; 4].

  (* Credit-card ::= SEQUENCE {
  type         Card-type,
  number       NumericString(SIZE (20)),
  expiry-date  NumericString(SIZE (6))-- MMYYYY --
  }*)
  Definition Credit_Card : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Card_Type;
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 20));
                    Normal_Sequence_Element (ASN_Simple ASN_NumericString (ASN_Size_Fixed 6))
                 ].

  (* Payment-method ::= CHOICE {
  check        NumericString(SIZE (15)),
  credit-card Credit-card,
  cash         NULL
} *)
  Definition Payment_Method : ASN1_Type :=
    ASN_Choice [ASN_Simple ASN_NumericString (ASN_Size_Fixed 8);
                  Credit_Card;
                  ASN_Simple ASN_Null ASN_None].

  (* Order-header ::= SEQUENCE {
  number   Order-number,
  date     Date,
  client   Client,
  payment  Payment-method
} *)
  Definition Order_Header : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Number;
                    Normal_Sequence_Element Date;
                    Normal_Sequence_Element Client;
                    Normal_Sequence_Element Payment_Method].

  (* Item-code ::= NumericString(SIZE (7)) *)
  Definition Item_Code : ASN1_Type  :=
    ASN_Simple ASN_NumericString (ASN_Size_Fixed 7).

  (* Order-line ::= SEQUENCE {
  item-code  Item-code,
  label      Label,
  quantity   Quantity,
  price      Cents
} *)
  Definition Order_Line : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Item_Code;
                    Normal_Sequence_Element Label;
                    Normal_Sequence_Element Quantity;
                    Normal_Sequence_Element Cents].

  (* Order ::= SEQUENCE {header  Order-header,
                    items   SEQUENCE OF Order-line
} *)
  Definition Order : ASN1_Type :=
    ASN_Sequence [Normal_Sequence_Element Order_Header;
                    Normal_Sequence_Element (ASN_Sequence_Of Order_Line)].

  (*
PDU ::= CHOICE {
  question
    CHOICE {question1  Order,
            question2  Item-code,
            question3  Order-number,
            ...},
  answer
    CHOICE {answer1  Delivery-report,
            answer2  Quantity,
            answer3  Delivery-report,
            ...}
} *)

  Definition PDU : ASN1_Type :=
    ASN_Choice [ASN_Structured (ASN_Choice [Order; Item_Code; Order_Number]);
                  ASN_Structured (ASN_Choice [Delivery_Report; Quantity; Delivery_Report])
               ].

End ASN1_Example.


From cap_machine Require Export rules_StoreU rules_binary_base.
From iris.base_logic Require Export invariants gen_heap.
From iris.program_logic Require Export weakestpre ectx_lifting.
From iris.proofmode Require Import tactics.
From iris.algebra Require Import frac.

Section cap_lang_spec_rules.
  Context `{cfgSG Σ, MachineParameters, invG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types σ : cap_lang.state.
  Implicit Types a b : Addr.
  Implicit Types r : RegName.
  Implicit Types w : Word.
  Implicit Types reg : gmap RegName Word.
  Implicit Types ms : gmap Addr Word.

  Ltac iFailStep_alt fail_type :=
    iMod (exprspec_mapsto_update _ _ (fill _ (Instr Failed)) with "Hown Hj") as "[Hown Hj]";
    iMod ("Hclose" with "[Hown]") as "_";
    [iNext;iExists _,_;iFrame;iPureIntro;eapply rtc_r;eauto;prim_step_from_exec|];
    try (iExists (FailedV),_,_; iFrame;iModIntro;iFailCore fail_type).

  Lemma step_storeU Ep K
     pc_p pc_g pc_b pc_e pc_a
     rdst rsrc offs w wsrc mem regs :
   decodeInstrW w = StoreU rdst offs rsrc →
   isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
   regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
   regs_of (StoreU rdst offs rsrc) ⊆ dom _ regs →
   mem !! pc_a = Some w →
   word_of_argument regs rsrc = Some wsrc ->
   match regs !! rdst with
   | None => True
   | Some (inl _) => True
   | Some (inr (p, g, b, e, a)) =>
     match z_of_argument regs offs with
       | None => True
       | Some zoffs => match verify_access (StoreU_access b e a zoffs) with
                      | None => True
                      | Some a' => if isU p && canStoreU p a' wsrc then
                                    match mem !! a' with
                                    | None => False
                                    | Some w => True
                                    end
                                  else True
                      end
       end
   end ->

   nclose specN ⊆ Ep →

   spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ (▷ [∗ map] a↦w ∈ mem, a ↣ₐ w) ∗ (▷ [∗ map] k↦y ∈ regs, k ↣ᵣ y)
   ={Ep}=∗ ∃ retv regs' mem', ⤇ fill K (of_val retv) ∗ ⌜ StoreU_spec regs rdst offs rsrc regs' mem mem' retv ⌝ ∗ ([∗ map] a↦w ∈ mem', a ↣ₐ w)∗ ([∗ map] k↦y ∈ regs', k ↣ᵣ y).
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs Hmem_pc Hwsrc HaStore Hnclose) "(#Hinv & Hj & >Hmem & >Hmap)".
    iDestruct "Hinv" as (ρ) "Hinv". rewrite /spec_inv.
    iInv specN as ">Hinv'" "Hclose". iDestruct "Hinv'" as (e [σr σm]) "[Hown %] /=".
    iDestruct (regspec_heap_valid_inclSepM with "Hown Hmap") as %Hregs.
    iDestruct (spec_expr_valid with "[$Hown $Hj]") as %Heq; subst e.

    (* Derive necessary register values in r *)
    pose proof (lookup_weaken _ _ _ _ HPC Hregs).
    specialize (indom_regs_incl _ _ _ Dregs Hregs) as Hri. unfold regs_of in Hri.
    feed destruct (Hri rdst) as [rdstv [Hrdst' Hrdst'']]. by set_solver+.
    pose proof (regs_lookup_eq _ _ _ Hrdst') as Hrdst'''.
    (* Derive the PC in memory *)
    iDestruct (memspec_heap_valid_inSepM _ _ _ _ pc_a with "Hown Hmem") as %Hma; eauto.
    specialize (normal_always_step (σr,σm)) as [c [ σ2 Hstep]].
    eapply step_exec_inv in Hstep; eauto.

    simpl in Hrdst'', Hma. option_locate_mr σm σr.
    assert (Hstep':=Hstep). rewrite /exec /reg in Hstep.
    assert ((σr, σm).1 = σr) as Heq;auto. rewrite Heq in Hstep. clear Heq.
    rewrite Hσrrdst in Hstep.

    destruct rdstv as [zdst| [[[[p g] b] e] a] ].
    { inv Hstep. iFailStep_alt StoreU_fail_const. }

     (* destruct (isU p) eqn:HisU; cycle 1. *)
     (* { simpl in Hstep. inv Hstep. iFailWP "Hφ" StoreU_fail_perm1. } *)

     assert (Hwsrc': match rsrc with
                     | inl n => inl n
                     | inr rsrc =>
                       match reg (σr, σm) !! rsrc with
                       | Some w => w
                       | None => inl 0%Z
                       end
                     end = wsrc).
     { destruct rsrc; simpl in Hwsrc; inv Hwsrc; auto.
       simpl. feed destruct (Hri r) as [aa [HA HB]]. by set_solver+.
       rewrite HB; congruence. }
     rewrite Hwsrc' in Hstep.

     (* destruct (canStoreU p a wsrc) eqn:HcanStoreU; cycle 1. *)
     (* { simpl in Hstep. inversion Hstep. *)
     (*   iFailWP "Hφ" StoreU_fail_perm2. } *)

     assert (Hzofargeq: z_of_argument σr offs = z_of_argument regs offs).
     { rewrite /z_of_argument; destruct offs; auto.
       feed destruct (Hri r) as [? [?]]. by set_solver+.
       rewrite H4 H5; auto. }
     rewrite Hzofargeq in Hstep.

     Local Opaque verify_access.
     Local Opaque exec.
     simpl in Hstep. destruct (z_of_argument regs offs) as [zoffs|] eqn:Hoffs; cycle 1.
     { inv Hstep. iFailStep_alt StoreU_fail_offs_arg. }

     destruct (verify_access (StoreU_access b e a zoffs)) as [a'|] eqn:Hverify; cycle 1.
     { inv Hstep. iFailStep_alt StoreU_fail_verify_access. }

     destruct (isU p) eqn:HisU; cycle 1.
     { simpl in Hstep. inv Hstep. iFailStep_alt StoreU_fail_perm1. }

     destruct (canStoreU p a' wsrc) eqn:HcanStoreU; cycle 1.
     { simpl in Hstep. inv Hstep. iFailStep_alt StoreU_fail_perm2. }

     rewrite Hrdst' HisU Hverify HcanStoreU /= in HaStore.
     destruct (mem !! a') as [wa|]eqn:Ha; try (inv HaStore; fail).

     destruct (addr_eq_dec a a').
     { subst a'. destruct (a + 1)%a as [a'|] eqn:Hap1; cycle 1.
       { inv Hstep. iFailStep_alt StoreU_fail_incrPC1. }

       iMod ((memspec_heap_update_inSepM _ _ _ a) with "Hown Hmem") as "[Hown Hmem]"; eauto.

       destruct (incrementPC (<[rdst:=inr (p, g, b, e, a')]> regs)) eqn:Hincr; cycle 1.
       { assert _ as Hincr' by (eapply (incrementPC_overflow_mono (<[rdst:=_]> regs) (<[rdst:=_]> σr) Hincr _ _)).
         rewrite incrementPC_fail_updatePC in Hstep; eauto.
         inv Hstep. simpl.
         iMod (exprspec_mapsto_update _ _ (fill K (Instr Failed)) with "Hown Hj") as "[Hown Hj]".
         iMod ((regspec_heap_update_inSepM _ _ _ rdst) with "Hown Hmap") as "[Hown Hmap]"; eauto.
         iFailStep_alt StoreU_fail_incrPC2. }

       destruct (incrementPC_success_updatePC _ σm _ Hincr) as (p1 & g1 & b1 & e1 & a1 & a_pc1 & HPC'' & Ha_pc' & HuPC & -> & ?).
       eapply updatePC_success_incl in HuPC. 2: by eapply insert_mono.
       instantiate (1 := <[a:=wsrc]> σm) in HuPC.
       rewrite HuPC in Hstep. inversion Hstep; clear Hstep; subst c σ2. cbn.
       iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hown Hj") as "[Hown Hj]".
       iMod ((regspec_heap_update_inSepM _ _ _ rdst) with "Hown Hmap") as "[Hown Hmap]"; eauto.
       iMod ((regspec_heap_update_inSepM _ _ _ PC) with "Hown Hmap") as "[Hown Hmap]"; eauto.
       rewrite <- Hwsrc'. iExists (NextIV),_,_. iFrame.
       iMod ("Hclose" with "[Hown]") as "_".
       { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
         apply verify_access_spec in Hverify as (? & ? & ? & ?). simpl. rewrite Hwsrc'.
         prim_step_from_exec. }
       iModIntro. iPureIntro. apply verify_access_spec in Hverify as (? & ? & ? & ?). econstructor; eauto.
       - repeat split;eauto.
       - rewrite Hwsrc'. auto.
       - destruct (addr_eq_dec a a); try congruence.
         rewrite Hap1. auto. }

     iMod ((memspec_heap_update_inSepM _ _ _ a') with "Hown Hmem") as "[Hown Hmem]"; eauto.

     destruct (incrementPC regs) eqn:Hincr; cycle 1.
     { assert _ as Hincr' by (eapply (incrementPC_overflow_mono regs σr Hincr _ _)).
       rewrite incrementPC_fail_updatePC in Hstep; eauto.
       inv Hstep. simpl.
       iFailStep_alt StoreU_fail_incrPC3. }

     destruct (incrementPC_success_updatePC regs (<[a':=wsrc]> σm) _ Hincr) as (p1 & g1 & b1 & e1 & a1 & a_pc1 & HPC'' & Ha_pc' & HuPC & -> & ?).
     eapply updatePC_success_incl in HuPC; eauto.
     instantiate (1 := <[a':=wsrc]> σm) in HuPC.
     rewrite HuPC in Hstep.
     inversion Hstep; clear Hstep; subst c σ2. cbn.
     iMod ((regspec_heap_update_inSepM _ _ _ PC) with "Hown Hmap") as "[Hown Hmap]"; eauto.
     iMod (exprspec_mapsto_update _ _ (fill K (Instr NextI)) with "Hown Hj") as "[Hown Hj]".
     rewrite <- Hwsrc'. iExists (NextIV),_,_. iFrame.
     iMod ("Hclose" with "[Hown]") as "_".
     { iNext. iExists _,_;iFrame. iPureIntro. eapply rtc_r;eauto.
       apply verify_access_spec in Hverify as (? & ? & ? & ?). simpl. rewrite Hwsrc'.
       prim_step_from_exec. }
     iPureIntro. apply verify_access_spec in Hverify as (? & ? & ? & ?). econstructor; eauto.
     { repeat split;eauto. }
     { rewrite Hwsrc'. reflexivity. }
     { destruct (addr_eq_dec a a'); try congruence; auto. }

     Unshelve. all: eauto.
     { destruct (reg_eq_dec PC rdst).
       - subst rdst. rewrite lookup_insert. eauto.
       - rewrite lookup_insert_ne; eauto. }
     { eapply insert_mono; eauto. }
   Qed.

  Lemma step_storeU_alt Ep K
     pc_p pc_g pc_b pc_e pc_a
     rdst rsrc offs w mem regs :
   decodeInstrW w = StoreU rdst offs rsrc →
   isCorrectPC (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
   regs !! PC = Some (inr ((pc_p, pc_g), pc_b, pc_e, pc_a)) →
   regs_of (StoreU rdst offs rsrc) ⊆ dom _ regs →
   mem !! pc_a = Some w →
   allow_storeU_map_or_true rdst rsrc offs regs mem  ->

   nclose specN ⊆ Ep →

   spec_ctx ∗ ⤇ fill K (Instr Executable) ∗ (▷ [∗ map] a↦w ∈ mem, a ↣ₐ w) ∗ (▷ [∗ map] k↦y ∈ regs, k ↣ᵣ y)
   ={Ep}=∗ ∃ retv regs' mem', ⤇ fill K (of_val retv) ∗ ⌜ StoreU_spec regs rdst offs rsrc regs' mem mem' retv ⌝ ∗ ([∗ map] a↦w ∈ mem', a ↣ₐ w)∗ ([∗ map] k↦y ∈ regs', k ↣ᵣ y).
  Proof.
    iIntros (Hinstr Hvpc HPC Dregs Hmem_pc HaStore Hnclose) "(#Hinv & Hj & >Hmem & >Hmap)".
    apply allow_storeU_map_or_true_match in HaStore as (wsrc & Hwsrc & HaStore).
    iApply (step_storeU with "[$Hmem $Hmap $Hj]");eauto.
  Qed.

End cap_lang_spec_rules.


Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretationDefinitions.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.Fix.
Require Import Fiat.Parsers.ContextFreeGrammar.Fix.FromAbstractInterpretation.

Module DataflowInput.
  Section input_data.
    Context {Char : Type}.

    Record t :=
      { T : Type;
        fpdata : grammar_fixedpoint_lattice_data T;
        aidata : AbstractInterpretation (Char:=Char) }.
  End input_data.
  Global Arguments t : clear implicits.
End DataflowInput.

Module DataflowOutput.
  Definition t {Char} d G
    := @fold_grammar_data Char (DataflowInput.T d) (DataflowInput.fpdata d) (DataflowInput.aidata d) G.

  Section output_data.
    Context {Char : Type}
            {d : DataflowInput.t Char}
            {G : pregrammar' Char}
            (v : t d G).

    Definition t_data := Eval hnf in @fgd_fold_grammar _ _ _ _ _ v.
    Definition t_correct : Morphisms.pointwise_relation _ eq (lookup_state t_data) (lookup_state (fold_grammar G _))
      := fgd_fold_grammar_correct.
  End output_data.
  Coercion t_data : t >-> aggregate_state.
End DataflowOutput.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Recognition of tail calls. *)

Require Import Coqlib.
Require Import Maps.
Require Import Compopts.
Require Import AST.
Require Import Registers.
Require Import Op.
Require Import RTL.
Require Import Conventions.

(** An [Icall] instruction that stores its result in register [rreg]
  can be turned into a tail call if:
- its successor is a [Ireturn None] or [Ireturn (Some rreg)] instruction;
- the stack block of the current function is empty: [stacksize = 0].

If the current function had a non-empty stack block, it could be that
the called function accesses it, for instance if a pointer into the
stack block is passed as an argument.  In this case, it would be
semantically incorrect to deallocate the stack block before the call,
as [Itailcall] does.  Therefore, the optimization can only be performed if
the stack block of the current function is empty, in which case it makes
no semantic difference to deallocate it before or after the call.

Another complication is that the [Ireturn] instruction does not, in general,
follow immediately the [Icall] instruction: the RTL code generator
can have inserted moves and no-ops between these instructions.
The general pattern we recognize is therefore:
<<
       r1 <- call(....)
       nop
       r2 <- r1
       r3 <- r2
       return r3
>>
The [is_return] function below recognizes this pattern.
*)

Fixpoint is_return (n: nat) (f: function) (pc: node) (rret: reg)
                   {struct n}: bool :=
  match n with
  | O => false
  | S n' =>
      match f.(fn_code)!pc with
      | Some(Ireturn None) => true
      | Some(Ireturn (Some r)) => Reg.eq r rret
      | Some(Inop s) => is_return n' f s rret
      | Some(Iop op args dst s) =>
          match is_move_operation op args with
          | None => false
          | Some src =>
              if Reg.eq rret src
              then is_return n' f s dst
              else false
          end
      | _ => false
      end
  end.

(** To ensure termination, we bound arbitrarily the number of iterations
of the [is_return] function: we look ahead for a nop/move/return of length
at most [niter] instructions. *)

Definition niter := 5%nat.

(** The code transformation is straightforward: call instructions
  followed by an appropriate nop/move/return sequence become
  tail calls; other instructions are unchanged.

  To ensure that the resulting RTL code is well typed, we
  restrict the transformation to the cases where a tail call is
  allowed by the calling conventions, and where the result signatures
  match. *)

Definition transf_instr (f: function) (pc: node) (instr: instruction) :=
  match instr with
  | Icall sig ros args res s =>
      if is_return niter f s res
      && tailcall_is_possible sig
      && opt_typ_eq sig.(sig_res) f.(fn_sig).(sig_res)
      then Itailcall sig ros args
      else instr
  | _ => instr
  end.

(** A function is transformed only if its stack block is empty,
  as explained above.  Moreover, we can turn tail calls off
  using a compilation option. *)

Definition transf_function (f: function) : function :=
  if zeq f.(fn_stacksize) 0 && eliminate_tailcalls tt
  then RTL.transf_function (transf_instr f) f
  else f.

Definition transf_fundef (fd: fundef) : fundef :=
  AST.transf_fundef transf_function fd.

Definition transf_program (p: program) : program :=
  transform_program transf_fundef p.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype seq.
Require Import ZArith_ext String_ext ssrnat_ext seq_ext.
Require Import machine_int.
Import MachineInt.
Require Import C_types C_types_fp C_value C_expr C_seplog C_pp.

Local Open Scope C_types_scope.
Local Open Scope string_scope.

Module pointer_test.

Module C_Env <: CENV.
Definition g := \wfctxt{ \O \}.
Definition sigma : g.-env := ("i", ityp: uint) :: ("p" , :* (ityp: uint)) ::
  ("q" , :* (ityp: uchar)) :: nil.
Definition uniq_vars : uniq (unzip1 sigma) := Logic.eq_refl.
End C_Env.

Module Import C_m := C_Seplog_f C_Env.
Local Open Scope C_cmd_scope.

Check ("i" <-* %"p").

End pointer_test.

Module struct_test.

Definition tg := mkTag "a".
Definition flds : Ctxt.v :=
  ("f", ityp uchar) :: ("g", ityp ulong) :: ("h", ptyp (ptyp (styp tg))) :: nil.
Definition g := \wfctxt{ "a" |> flds \, \O \}.
Definition a := g.-typ: styp tg.
Definition an_array_type := g.-typ: atyp 42 Logic.eq_refl tg.

Eval compute in (sizeof a).
Eval compute in (sizeof an_array_type).

Definition sigma : g.-env := @get_fields g tg.
Eval compute in (field_address 0 "f" (ityp: uchar) sigma Logic.eq_refl).
Eval compute in (field_address 0 "g" (ityp: ulong) sigma Logic.eq_refl).
Eval compute in (field_address 0 "h" (:* (:* (g.-typ: styp tg))) sigma Logic.eq_refl).

(* *)

End struct_test.

Module array_in_struct.

Definition tg := mkTag "a".
Definition bad_flds := ("f", atyp 5 (refl_equal _) tg) :: nil.
(*Definition g := \wfctxt \{ "a" |> bad_flds \, \O \}.*)

Definition boxed_int_tg := mkTag "bint".
Definition boxed_int_fld := ("bint_", ityp sint) :: nil.
Definition flds := ("f", atyp 5 Logic.eq_refl boxed_int_tg) :: nil.
Definition g := \wfctxt{ "a" |> flds \, "bint" |> boxed_int_fld \, \O \}.
Definition astruct := g.-typ: styp tg.

Eval compute in (sizeof astruct).

End array_in_struct.

Module two_self_referential_structs.

(**

example p.151 from "C A Reference Manual" 5th Edition, Samuel P. Harbison III, Guy L. Steele Jr. 2002

{ struct cell ;
  struct header { struct cell   *first; ...};
  struct cell   { struct header *head;  ...};
}

*)

Definition cell_tg := mkTag "cell".
Definition header_tg := mkTag "header".
Definition cell_flds := ("data", ityp uchar) :: ("head", ptyp (styp header_tg)) :: nil.
Definition header_flds := ("first", ptyp (styp cell_tg)) :: nil.
Definition g := \wfctxt{ "cell" |> cell_flds \, "header" |> header_flds \, \O \}.
(* NB: \wfctxt will fail without pointers *)
Definition cell := g.-typ: styp cell_tg.
Definition header := g.-typ: styp header_tg.

Time Eval compute in sizeof cell.
Time Eval compute in sizeof header.

Goal (sizeof cell = 1 + 3 + 4)%nat. by []. Qed.
Goal (sizeof header = 4)%nat. by []. Qed.

Eval compute in (typ_to_string (styp cell_tg) "" "").
Eval compute in (typ_to_string_rec g cell "" "").

End two_self_referential_structs.


Require Import VST.floyd.proofauto.
Require Import Core.Core Core.Notations Core.Tactics.
Require Import Exec.Ber_tlv_tag_serialize
        Exec.Ber_tlv_length_serialize.

Open Scope Z.

Definition der_write_TL tag len size constructed :=
  let (tl, t) := tag_serialize tag (Int.repr size) in
  let (ll, l) := length_serialize len (Int.repr (if eq_dec size 0 then size else size - t)) in
  let ls := if eq_dec constructed 0%int
            then tl ++ ll
            else (upd_Znth 0 tl (Znth 0 tl or (Int.repr 32))%int) ++ ll in
  if ((t =? -1) || (32 <? t))%bool
  then ([], -1)
  else if l =? -1
       then ([], -1)
       else let s := l + t in
            if 32 <? s
            then ([], -1)
            else (ls, s).

Lemma tag_serialize_bounds : forall t l, -1 <= snd (tag_serialize t l) <= 6.
  { unfold tag_serialize.
    intros.
    cbn.
    repeat break_if; autorewrite with norm; try nia. }
Qed.

Lemma length_serialize_bounds :
  forall t l, -1 <= snd (length_serialize t l) <= 6.
  { unfold length_serialize.
    intros.
    cbn.
    repeat break_if; autorewrite with norm; try nia. }
Qed.

Lemma der_write_TL_serialize_sum :
  forall t l s c,
    let (tls, tl) := tag_serialize t (Int.repr s)  in
    let (lls, ll) := length_serialize l (Int.repr (if eq_dec s 0 then s else s - tl)) in
    tl <> -1 ->
    ll <> -1 ->
    tl <= 32 ->
    tl + ll <= 32 ->
    c = 0%int ->
    der_write_TL t l s c = (tls ++ lls, tl + ll).
Proof.
  intros.
  repeat break_let.
  unfold der_write_TL.
  intros Z Z0 Z32 Zplus C.
  erewrite Heqp.
  erewrite Heqp0.
  repeat break_if; try destruct_orb_hyp;
  repeat Zbool_to_Prop; try nia.
  intuition.
  intuition.
  congruence.
  congruence.
Qed.

Lemma der_write_TL_serialize_sum_c :
  forall t l s c,
     let (tls, tl) := tag_serialize t (Int.repr s)  in
    let (lls, ll) := length_serialize l (Int.repr (if eq_dec s 0 then s else s - tl)) in
    tl <> -1 ->
    ll <> -1 ->
    tl <= 32 ->
    tl + ll <= 32 ->
    c <> 0%int ->
    der_write_TL t l s c = ((upd_Znth 0 tls (Znth 0 tls or (Int.repr 32))%int) ++ lls, tl + ll).
Proof.
  intros.
  repeat break_let.
  unfold der_write_TL.
  intros Z Z0 Z32 Zplus C.
  erewrite Heqp.
  erewrite Heqp0.
  repeat break_if; try destruct_orb_hyp;
  repeat Zbool_to_Prop; try rep_omega;
  try erewrite e in C;
  try congruence;
  intuition.
Qed.

Definition Z_of_val v :=
  match v with
  | Vptr b i => Ptrofs.unsigned i
  | _ => 0
  end.


Require Import FP.Classes.
Require Import FP.CoreClasses.
Require Import FP.DerivingMonad.Core.

Class DM_IdxFunctorI (T:Type -> Type -> Type) (U:Type -> Type -> Type) :=
  { DM_Idx_T_F_Eqv :> forall {I} `{! Eqv I }, F_Eqv (T I)
  ; DM_Idx_T_F_PER_WF :> forall {I} `{! Eqv I ,! PER_WF I }, F_PER_WF (T I)
  ; DM_Idx_U_F_Eqv :> forall {I} `{! Eqv I }, F_Eqv (U I)
  ; DM_Idx_U_F_PER_WF :> forall {I} `{! Eqv I ,! PER_WF I }, F_PER_WF (U I)
  ; DM_Idx_U_Monad :> forall {I}, Monad (U I)
  ; DM_Idx_U_MonadWF :> forall {I} `{! Eqv I ,! PER_WF I }, MonadWF (U I)
  }.

Class DM_IdxFunctorI' T U := { dm_idx_functor_i : DM_IdxFunctorI T U }.

Module Type DM_IdxFunctor_Arg.
  Local Existing Instance dm_idx_functor_i.

  Parameter T : Type -> Type -> Type.
  Parameter U : Type -> Type -> Type.
  Parameter to : forall {I A}, T I A -> U I A.
  Parameter from : forall {I A}, U I A -> T I A.
  Parameter _DM_IdxFunctorI : DM_IdxFunctorI' T U.
  Parameter IR_from_eqv :
    forall {I A} `{! Eqv I ,! PER_WF I ,! Eqv A ,! PER_WF A },
    InjectionRespect (U I A) (T I A) from eqv eqv.
  Parameter II_to_from_eqv :
    forall {I A} `{! Eqv I ,! PER_WF I ,! Eqv A ,! PER_WF A },
    InjectionInverse (T I A) (U I A) to from eqv.
  Parameter II_from_from_eqv :
    forall {I A} `{! Eqv I ,! PER_WF I ,! Eqv A ,! PER_WF A },
    InjectionInverse (U I A) (T I A) from to eqv.
  Parameter Proper_to_eqv :
    forall {I A} `{! Eqv I ,! PER_WF I ,! Eqv A ,! PER_WF A },
    Proper eqv (@to I A).
  Parameter Proper_from_eqv :
    forall {I A} `{! Eqv I ,! PER_WF I ,! Eqv A ,! PER_WF A },
    Proper eqv (@from I A).
End DM_IdxFunctor_Arg.

Module DM_IdxFunctor (M:DM_IdxFunctor_Arg).
  Local Existing Instance dm_idx_functor_i.

  Import M.
  Arguments T / _ _ .
  Arguments U / _ _ .
  Arguments to {I A} / _ .
  Arguments from {I A} / _ .

  Section I.
    Context {I:Type}.

    Section Monad.
      Global Instance _Monad : Monad (T I) := Deriving_Monad_Bijection (@to I) (@from I).

      Context `{! Eqv I ,! PER_WF I }.

      Global Instance _MonadWF : MonadWF (T I) := Deriving_MonadWF_Bijection (@to I) (@from I).
    End Monad.

    Section Applicative.
      Global Instance _Applicative : Applicative (T I) := Deriving_Applicative_Monad.

      Context `{! Eqv I ,! PER_WF I }.

      Global Instance _ApplicativeWF : ApplicativeWF (T I).
      Proof.
        apply Deriving_ApplicativeWF_MonadWF ; intros.
        - unfold fret ; simpl ; logical_eqv.
        - unfold fapply ; simpl ; logical_eqv.
      Qed.
    End Applicative.

    Section Functor.
      Global Instance _Functor : Functor (T I) := Deriving_Functor_Applicative.

      Context `{! Eqv I ,! PER_WF I }.

      Global Instance _FunctorWF : FunctorWF (T I).
      Proof.
        apply Deriving_FunctorWF_ApplicativeWF ; intros.
        unfold fmap ; simpl ; logical_eqv.
      Qed.
    End Functor.

    Section Pointed.
      Global Instance _Pointed : Pointed (T I) := Deriving_Pointed_Applicative.

      Context `{! Eqv I ,! PER_WF I }.

      Global Instance _PointedWF : PointedWF (T I).
      Proof.
        apply Deriving_PointedWF_ApplicativeWF ; intros.
        unfold point ; simpl ; logical_eqv.
      Qed.
    End Pointed.

  End I.
End DM_IdxFunctor.

Class DMError_IdxFunctorI
    (T:Type -> Type -> Type) (U:Type -> Type -> Type)
    `{! forall {I} `{! Eqv I }, F_Eqv (U I)
     ,! forall {I} `{! Eqv I ,! PER_WF I }, F_PER_WF (U I)
     ,! forall {I}, Monad (U I)
     } :=
  { DMError_Idx_U_MonadCatch : forall {I}, MonadCatch I (U I)
  ; DMError_Idx_U_MonadCatchWF : forall {I} `{! Eqv I ,! PER_WF I}, MonadCatchWF I (U I)
  }.

Module Type DMError_IdxFunctor_Arg.
  Local Existing Instance dm_idx_functor_i.

  Include DM_IdxFunctor_Arg.
  Parameter _DMError_IdxFunctorI : DMError_IdxFunctorI T U.
End DMError_IdxFunctor_Arg.

Module DMError_IdxFunctor (M:DMError_IdxFunctor_Arg).
  Local Existing Instance dm_idx_functor_i.
  Local Existing Instance DMError_Idx_U_MonadCatch.
  Local Existing Instance DMError_Idx_U_MonadCatchWF.

  Import M.
  Module DM := DM_IdxFunctor M.
  Import DM.

  Arguments T / _ _ .
  Arguments U / _ _ .
  Arguments to {I A} / _ .
  Arguments from {I A} / _ .

  Section MonadError.
    Context {I:Type} `{! Eqv I ,! PER_WF I }.

    Global Instance _MonadCatch : MonadCatch I (T I) := deriving_MonadCatch_Bijection (@to I) (@from I).
    Global Instance _MonadCatchWF : MonadCatchWF I (T I).
    Proof.
      apply (deriving_MonadCatchWF_Bijection (@to I) (@from I)) ; intros.
      - unfold mret at 1 ; simpl ; logical_eqv.
      - unfold mbind at 1 ; simpl ; logical_eqv.
    Qed.
  End MonadError.
End DMError_IdxFunctor.


Require Export SystemFR.StrictPositivity.
Require Export SystemFR.StrictPositivityLemmas.
Require Export SystemFR.Trees.
Require Export SystemFR.Syntax.
Require Export SystemFR.Tactics.
Require Export SystemFR.SizeLemmas.
Require Export SystemFR.NoTypeFVar.

Require Export SystemFR.SubstitutionLemmas.
Require Export SystemFR.ErasedTermLemmas.
Require Export SystemFR.FVLemmas.
Require Export SystemFR.FVLemmasLists.

Require Export SystemFR.AssocList.

Require Import Coq.Lists.List.

Require Import Psatz.

Opaque strictly_positive.

Lemma strictly_positive_subst_aux:
  forall n T lterms vars,
    type_nodes T < n ->
    pclosed_mapping lterms type_var ->
    twfs lterms 0 ->
    is_erased_type T ->
    strictly_positive T vars ->
    strictly_positive (psubstitute T lterms term_var) vars.
Proof.
  induction n; destruct T; repeat step || destruct_tag || simp_spos; try lia;
    eauto using no_type_fvar_subst;
    eauto with lia.
  right; exists X; steps; eauto using pfv_in_subst.
  rewrite substitute_topen2; steps.
  apply_any; repeat step || autorewrite with bsize in * || apply is_erased_type_topen;
    eauto with lia.
Qed.

Lemma strictly_positive_subst:
  forall T lterms vars,
    pclosed_mapping lterms type_var ->
    twfs lterms 0 ->
    is_erased_type T ->
    strictly_positive T vars ->
    strictly_positive (psubstitute T lterms term_var) vars.
Proof.
  eauto using strictly_positive_subst_aux.
Qed.


Require Export assetmapping_spl_int.
Require Export maps_proofs.
Require Export maps_inst.
Require Export maps_int.
Require Export maps_def.
Require Export assetmapping_spl_def.
Require Import Coq.Lists.ListSet.
Require Import Coq.Arith.Arith.
Require Import Coq.Init.Specif.
Require Export Coq.Lists.List.
Import Maps.
Import AssetMappingSPL.

Program Instance Ins_AssetMapping: AssetMapping Asset AssetName AM :=
{
  assetRef      := assetRef_func;
  wfProduct     := wfProduct_ind;
  aMR           := aMR_func;
  my_set_union  := my_set_union_func;
}.
Next Obligation.
  {(*assetRefinementReflexivity*)
   apply assetRefinementReflexivity_axiom.
} Qed.
Next Obligation.
 { (*assetRefinementTranstivity*)
  generalize H H0. apply assetRefinementTranstivity_axiom.
} Qed.
Next Obligation.
 { (*asRefCompositional*)
assert (H3: assetRef_func S1 S2 /\ wfProduct_ind (my_set_union_func S1 aSet)).
 split.
 + apply H.
 + apply H0.
 + generalize H3.
  apply asRefCompositional_axiom.
} Qed.
Next Obligation. { (*assetMappingRefinement*)
  generalize H0. apply assetMappingRefinement_axiom. split.
    + apply H.
    + apply H1.
} Qed.