(* A simple symmetric encryption scheme based on a pseudorandom function, and a proof that the scheme is secure according to IND-CPA. *)

Set Implicit Arguments.

Require Import FCF.
Require Import PRF.
Require Import Encryption.

Opaque evalDist.
Opaque getSupport.

Local Open Scope nat_scope.
Local Open Scope type_scope.
Local Open Scope list_scope.

Section PRF_Encryption_concrete.

  Variable eta : nat.

  Definition Key := Bvector eta.
  Definition Plaintext := Bvector eta.
  Definition Ciphertext := Bvector eta * Bvector eta.

  Variable f : Bvector eta -> Bvector eta -> Bvector eta.

  Definition PRFE_KeyGen :=
    {0, 1} ^ eta.

  Definition PRFE_Encrypt (k : Key )(p : Plaintext) :=
    r <-$ {0, 1} ^ eta;
    pad <- f k r;
    ret (r, p xor pad).

  Definition PRFE_Decrypt (k : Key)(c : Ciphertext) :=
    r <- fst c;
    pad <- f k r;
    (snd c) xor pad.

  Theorem PRF_Encrypt_correct :
    forall k p c,
      In c (getSupport (PRFE_Encrypt k p)) ->
      PRFE_Decrypt k c = p.

    intuition.
    unfold PRFE_Encrypt, PRFE_Decrypt in *.
    repeat simp_in_support.

    simpl.
    rewrite BVxor_assoc.
    rewrite BVxor_same_id.
    rewrite BVxor_id_r.
    intuition.
  Qed.

  Section PRF_Encryption_IND_CPA_concrete.

    Variable State : Set.
    Hypothesis State_EqDec : EqDec State.
    Variable A1 : OracleComp Plaintext Ciphertext (Plaintext * Plaintext * State).
    Variable A2 : State -> Ciphertext -> OracleComp Plaintext Ciphertext bool.

    Hypothesis A1_wf : well_formed_oc A1.
    Hypothesis A2_wf : forall x y, well_formed_oc (A2 x y).

    Variable q1 q2 : nat.
    Hypothesis A1_qam : queries_at_most A1 q1.
    Hypothesis A2_qam : forall s c, queries_at_most (A2 s c) q2.

    Definition PRFE_EncryptOracle := EncryptOracle PRFE_Encrypt _.

    Local Open Scope nat_scope.

    (* Step 1: Inline some definitions and simplify. *)
    Definition G1 :=
      key <-$ PRFE_KeyGen;
      [b, _] <-$2
      (
        [p0, p1, s_A] <--$3 A1;
        b <--$$ {0, 1};
        pb <- if b then p1 else p0;
        c <--$$ PRFE_Encrypt key pb;
        b' <--$ (A2 s_A c);
        $ ret (eqb b b')
      )
      _ _
      (PRFE_EncryptOracle key) tt;
      ret b.

    Theorem G1_equiv :
      Pr[IND_CPA_SecretKey_G PRFE_KeyGen PRFE_Encrypt A1 A2 _] == Pr[G1].
      reflexivity.

    Qed.

    (* Step 2 : Replace the PRF with a random function. *)

    Definition PRFE_RandomFunc := @randomFunc (Bvector eta) (Bvector eta) ({0,1}^eta) _.

    Definition RF_Encrypt s p :=
      r <-$ {0, 1} ^ eta;
      [pad, s] <-$2 PRFE_RandomFunc s r;
      ret (r, p xor pad, s).

    Definition G2 :=
      [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
      [p0, p1, s_A] <-3 a;
      b <-$ {0, 1};
      pb <- if b then p1 else p0;
        [c, o] <-$2 RF_Encrypt o pb;
        [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt o;
        ret (eqb b b').

    (* To prove this step, we put the game in the form of a computation that access the PRF as an oracle.  This allows us to apply the PRF definition. *)

    Definition PRFE_Encrypt_OC (x : unit)(p : Plaintext) : OracleComp (Bvector eta) (Bvector eta) (Ciphertext * unit) :=
        r <--$$ {0, 1} ^ eta;
        pad <--$ OC_Query _ r;
        $ (ret (r, p xor pad, tt)).

    Definition PRF_A : OracleComp (Bvector eta) (Bvector eta) bool :=
      [a, n] <--$2 OC_Run _ _ _ A1 PRFE_Encrypt_OC tt;
      [p0, p1, s_A] <-3 a;
      b <--$$ {0, 1};
      pb <- if b then p1 else p0;
      r <--$$ {0, 1} ^ eta;
      pad <--$ OC_Query _ r;
      c <- (r, pb xor pad);
      z <--$ OC_Run  _ _ _ (A2 s_A c) PRFE_Encrypt_OC n;
      [b', _] <-2 z;
      $ ret (eqb b b').

    (* Later we will need to reason about the cost of PRF_A, so we make an equivalent procedure without some of the complications. *)
    Definition PRF_A' :=
      z <--$
      OC_Run _ _ _ A1 PRFE_Encrypt_OC tt;
      b <--$$
      (m <-$ { 0 , 1 }^1; ret Vector.hd m);
      r <--$$ { 0 , 1 }^eta;
      pad <--$ OC_Query (Vector.t bool eta) r;
      z0 <--$
      OC_Run _ _ _ (A2 (snd (fst z)) (r,
        (if b then  (snd (fst (fst z)))  else (fst (fst (fst z))))
        xor pad)) PRFE_Encrypt_OC (snd z);
       $ ret eqb b (fst z0).

    Theorem PRF_A'_equiv :
      forall (S : Set)(eqds : EqDec S)(o : S -> (Bvector eta) -> Comp ((Bvector eta) * S)) s x,
      evalDist (PRF_A _ _ o s) x == evalDist (PRF_A' _ _ o s) x.

      intuition.
      unfold PRF_A, PRF_A'.

      do 5 (comp_simp; simpl;
      comp_skip; try eapply eqRat_refl).
      comp_simp; simpl.
      comp_simp.
      intuition.

    Qed.

    Definition f_oracle(k : Bvector eta)(x : unit)(v : Bvector eta) :=
      ret (f k v, tt).

    Theorem Ciphertext_inh :
      Ciphertext.

      apply (oneVector eta, oneVector eta).

    Qed.
    Hint Resolve Ciphertext_inh : inhabited.

    Theorem PRFE_EncryptOracle_spec : forall a x2 x,
       comp_spec
     (fun (y1 : Ciphertext * unit) (y2 : Ciphertext * (unit * unit)) =>
      fst y1 = fst y2 /\ snd y1 = fst (snd y2))
     (PRFE_EncryptOracle x (fst x2) a)
     (p <-$
      (PRFE_Encrypt_OC (fst x2) a) unit unit_EqDec (f_oracle x) (snd x2);
      ret (fst (fst p), (snd (fst p), snd p))).

      intuition.
      unfold PRFE_EncryptOracle, EncryptOracle, PRFE_Encrypt.
      simpl.

      prog_inline_l.
      do 2 prog_inline_r.
      comp_skip.
      prog_simp.
      unfold f_oracle.
      do 2 (prog_inline_r;
      prog_simp).
      eapply comp_spec_ret.
      simpl.
      intuition.

    Qed.

    Theorem RF_EncryptOracle_spec : forall a x2,
      comp_spec
      (fun (y1 : Ciphertext * list (Bvector eta * Bvector eta))
        (y2 : Ciphertext * (unit * list (Bvector eta * Bvector eta))) =>
        fst y1 = fst y2 /\ snd y1 = snd (snd y2)) (RF_Encrypt (snd x2) a)
      (p <-$
        (PRFE_Encrypt_OC (fst x2) a) (list (Bvector eta * Bvector eta))
        (list_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta)))
        PRFE_RandomFunc (snd x2); ret (fst (fst p), (snd (fst p), snd p))).

      intuition.
      unfold RF_Encrypt, PRFE_RandomFunc, randomFunc.
      simpl.
      do 2 prog_inline_r.
      comp_skip.
      prog_simp.
      prog_inline_r.
      comp_skip.
      prog_inline_r.
      prog_simp.
      eapply comp_spec_ret.
      simpl.
      intuition.

    Qed.

    Theorem G1_PRF_A_equiv :
      Pr[G1] == Pr[k <-$ {0, 1}^ eta; [b, _] <-$2 PRF_A _ _ (f_oracle k) tt; ret b].

      Opaque PRFE_Encrypt_OC.

      unfold G1, PRF_A, PRFE_KeyGen.
      comp_skip.

      simpl.
      inline_first.

      eapply comp_spec_impl_eq.
      eapply (@comp_spec_seq _ _
        (fun a1 a2 => fst a1 = fst a2 /\ snd a1 = fst (snd a2))); eauto with inhabited.

      eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ (fun a b => a = fst b)).
      trivial.
      intuition.
      subst.

      eapply PRFE_EncryptOracle_spec.
      intuition.
      destruct b2.
      simpl in *.
      subst.

      prog_simp.
      simpl.

      do 2 prog_inline_l.
      do 2 prog_inline_r.
      comp_skip.
      prog_simp.

      unfold PRFE_Encrypt.
      do 3 prog_inline_l.
      do 2 (prog_inline_r; prog_simp).
      comp_skip.
      prog_simp.

      unfold f_oracle.
      prog_inline_l.
      do 3 (prog_inline_r; prog_simp).

      eapply comp_spec_seq; eauto with inhabited.
      eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _
        (fun a b => a = fst b)).
      trivial.
      intuition.
      subst.

      eapply PRFE_EncryptOracle_spec.
      intuition.
      destruct b4; simpl in *; subst.

      prog_simp.
      simpl.
      prog_inline_l; prog_simp.
      prog_inline_r; prog_simp.
      eapply comp_spec_ret.
      intuition.

    Qed.

    Theorem G1_PRF_A'_equiv :
      Pr[k <-$ {0, 1}^ eta; [b, _] <-$2 PRF_A _ _ (f_oracle k) tt; ret b] ==
      Pr[k <-$ {0, 1}^ eta; [b, _] <-$2 PRF_A' _ _ (f_oracle k) tt; ret b].

      intuition.
      comp_skip.
      comp_skip.
      eapply PRF_A'_equiv.

    Qed.

    Theorem G2_PRF_A_equiv :
      Pr[G2] == Pr[[b, _] <-$2 PRF_A _ _ PRFE_RandomFunc nil; ret b].

      unfold G2, PRF_A.
      simpl.
      inline_first.

      eapply comp_spec_impl_eq.
      eapply (@comp_spec_seq _ _
        (fun a1 a2 => fst a1 = fst a2 /\ snd a1 = snd (snd a2))); eauto with inhabited.

      eapply comp_spec_consequence.
      eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ (fun a b => a = snd b)).
      trivial.
      intuition.
      subst.

      eapply RF_EncryptOracle_spec.
      intuition.
      intuition.
      prog_simp.
      simpl.

      do 2 prog_inline_r.
      comp_skip.
      unfold RF_Encrypt at 1.
      prog_simp.
      prog_inline_l.
      do 2 prog_inline_r.
      comp_skip.
      prog_simp.
      simpl in *.
      subst.

      prog_inline_l.
      prog_inline_r.
      comp_skip.
      inversion H3; clear H3; subst.
      do 2 prog_inline_r.
      eapply comp_spec_seq; eauto with inhabited.
      eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ (fun x y => x = snd y)).
      trivial.
      intuition.
      subst.

      eapply RF_EncryptOracle_spec.
      intuition.
      prog_simp.
      simpl.
      prog_inline_r.
      simpl.
      prog_simp.
      eapply comp_spec_ret.
      simpl in *.
      intuition.
      subst.
      intuition.
      subst; intuition.

    Qed.

    Theorem G2_PRF_A'_equiv :
      Pr[[b, _] <-$2 PRF_A _ _ PRFE_RandomFunc nil; ret b] ==
      Pr[[b, _] <-$2 PRF_A' _ _ PRFE_RandomFunc nil; ret b].

      intuition.
      comp_skip.
      eapply PRF_A'_equiv.

    Qed.

    Theorem G1_G2_close : |Pr[G1] - Pr[G2]| == PRF_Advantage ({0, 1}^eta) ({0, 1}^eta) f _ _ PRF_A'.
      rewrite G1_PRF_A_equiv.
      rewrite G1_PRF_A'_equiv.
      rewrite G2_PRF_A_equiv.
      rewrite G2_PRF_A'_equiv.
      reflexivity.
    Qed.

    (* Step 3 : replace the PRF output with random value *)
    (* This is identical to G2 as long as the adversary does not encounter the encryption nonce during a query. *)

    Definition G3 :=
    [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
    [p0, p1, s_A] <-3 a;
    b <-$ {0, 1};
    pb <- if b then p1 else p0;
      r <-$ {0, 1}^eta;
      pad <-$ {0, 1}^eta;
      c <- (r, pb xor pad);
      [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt o;
      ret (eqb b b').

    (* start with G2 and move the challenge encryption sampling to the front. *)
    Definition G2_1 :=
      r <-$ {0, 1}^eta;
      [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
      [p0, p1, s_A] <-3 a;
      b <-$ {0, 1};
      pb <- if b then p1 else p0;
        [pad, o] <-$2 PRFE_RandomFunc o r;
        c <- (r, pb xor pad);
        [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt o;
        ret (eqb b b').

    Theorem G2_1_equiv :
      Pr[G2] == Pr[G2_1].

      unfold G2, G2_1.

      do 2 (comp_swap_r; comp_skip; comp_simp).
      unfold RF_Encrypt.
      do 2(inline_first; comp_skip; comp_simp).
      intuition.
    Qed.

    (* We will modify the procedure one adversary call at a time.  Start with the first one. *)
    (* make the bad event visible. *)
    Definition G2_2 :=
      r <-$ {0, 1}^eta;
      [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
      bad <- if (arrayLookup _ o r) then true else false;
      [p0, p1, s_A] <-3 a;
      b <-$ {0, 1};
      pb <- if b then p1 else p0;
        [pad, o] <-$2 PRFE_RandomFunc o r;
        c <- (r, pb xor pad);
        [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt o;
        ret (eqb b b', bad).

    Theorem G2_1_2_equiv :
      Pr[G2_1] == Pr[x <-$ G2_2; ret fst x].

      unfold G2_1, G2_2.

      do 5 (inline_first; comp_skip; comp_simp).
      simpl; intuition.
    Qed.

    (* When r is not in the domain of the random function, we can sample the pad randomly, then add it to the function. *)

    Definition G2_3 :=
      r <-$ {0, 1}^eta;
      [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
      bad <- if (arrayLookup _ o r) then true else false;
      [p0, p1, s_A] <-3 a;
      b <-$ {0, 1};
      pb <- if b then p1 else p0;
        pad <-$ {0, 1}^ eta;
        c <- (r, pb xor pad);
        [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt ((r, pad) :: o);
        ret (eqb b b', bad).

    Local Open Scope rat_scope.

    Theorem RF_Encrypt_wf :
      forall s a,
        well_formed_comp (RF_Encrypt s a).

      intuition.
      unfold RF_Encrypt.
      wftac.
      eapply randomFunc_wf.
      wftac.
    Qed.

    Hint Resolve RF_Encrypt_wf : wftac.

    Theorem G2_2_3_eq_until_bad :
      forall z,
        evalDist G2_2 (z, false) == evalDist G2_3 (z, false).

      intuition.
      unfold G2_2, G2_3.

      do 3 (comp_skip; comp_simp).
      unfold PRFE_RandomFunc, randomFunc.
      case_eq (arrayLookup (Bvector_EqDec eta) l x ); intuition.
      comp_simp.

      comp_irr_r; wftac.

      comp_irr_l; wftac.
      eapply oc_comp_wf; intuition.

      comp_irr_r; wftac.
      eapply oc_comp_wf; intuition.

      comp_simp.

      Transparent evalDist.
      Transparent getSupport.
      dist_compute.

      inline_first.
      comp_skip.

    Qed.

    Theorem G2_2_3_badness_same :
      Pr[x <-$ G2_2; ret (snd x)] == Pr[x <-$ G2_3; ret (snd x)].

      unfold G2_2, G2_3.

      do 3 (inline_first; comp_skip; comp_simp).

      comp_inline_l.
      comp_irr_l; wftac.
      eapply randomFunc_wf; wftac.

      comp_inline_r.
      comp_irr_r; wftac.

      comp_simp.
      comp_inline_l.
      comp_irr_l; wftac.
      eapply oc_comp_wf; intuition.

      comp_inline_r.
      comp_irr_r; wftac.
      eapply oc_comp_wf; intuition.

      comp_simp.
      simpl.
      intuition.

    Qed.

    (* provide a simplified form of the same with the same probability of badness. *)
    Definition G2_2_bad :=
      [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
      ls <- fst (split o);
      r <-$ {0, 1}^eta;
      ret if (in_dec (EqDec_dec _) r ls) then true else false.

    Theorem arrayLookup_In_split :
      forall (A B : Set)(eqda : EqDec A)(ls : list (A * B))(a : A)(b : B),
        arrayLookup _ ls a = Some b ->
        In a (fst (split ls)).

      induction ls; intuition; simpl in *.
      discriminate.
      case_eq (eqb a a0); intuition.
      rewrite H0 in H.
      inversion H; clear H; subst.

      rewrite eqb_leibniz in H0.
      subst.
      remember (split ls) as x.
      destruct x.
      simpl.
      intuition.

      rewrite H0 in H.
      remember (split ls) as x.
      destruct x.
      simpl.
      right.
      eapply IHls.
      eauto.

    Qed.

    Theorem arrayLookup_not_In_split :
      forall (A B : Set)(eqda : EqDec A)(ls : list (A * B))(a : A),
        arrayLookup _ ls a = None ->
        ~In a (fst (split ls)).

      induction ls; intuition; simpl in *.
      case_eq (eqb a a0); intuition;
      rewrite H1 in H.
      discriminate.

      remember (split ls) as x.
      destruct x.
      simpl in *.
      intuition; subst.
      rewrite eqb_refl in H1.
      discriminate.
      eauto.
    Qed.

    Theorem G2_2_bad_equiv :
      Pr[x <-$ G2_2; ret snd x] == Pr[G2_2_bad].

      rewrite G2_2_3_badness_same.

      unfold G2_3, G2_2_bad.
      inline_first.
      comp_at comp_inline leftc 1%nat.
      comp_swap_l.
      comp_skip.
      comp_simp.
      comp_skip.
      do 3 (comp_inline_l;
      comp_irr_l; wftac).
      eapply oc_comp_wf; intuition.

      comp_simp.
      eapply evalDist_ret_eq; simpl.
      case_eq (arrayLookup (Bvector_EqDec eta) l x); intuition;
      destruct (in_dec (EqDec_dec (Bvector_EqDec eta)) x (fst (split l))); intuition.
      exfalso.
      eauto using arrayLookup_In_split.

      exfalso.
      eapply (@arrayLookup_not_In_split _ _ (Bvector_EqDec eta)).
      eauto.
      trivial.

    Qed.

    Require Import RndInList.

    Theorem G2_2_bad_small : Pr[x <-$ G2_2; ret snd x] <= q1 / (2 ^ eta).

      rewrite G2_2_bad_equiv.
      unfold G2_2_bad.
      comp_irr_l.
      eapply oc_comp_wf; intuition.
      comp_simp.

      Theorem RF_Encrypt_length_incr :
        forall a b c d,
          In (a, b) (getSupport (RF_Encrypt c d)) ->
          (length b <= 1 + length c)%nat.

        intuition.
        unfold RF_Encrypt in *.
        repeat simp_in_support.
        destruct x0.
        repeat simp_in_support.
        unfold PRFE_RandomFunc, randomFunc in *.
        destruct (arrayLookup (Bvector_EqDec eta) c x); repeat simp_in_support;
        simpl in *; omega.

      Qed.

      assert (length l <= q1)%nat.
      eapply qam_count;
      eauto.
      eapply RF_Encrypt_length_incr.
      simpl; intuition.

      eapply RndInList_prob.
      rewrite split_length_l.
      trivial.
    Qed.

    Theorem G2_2_3_close :
      forall z,
      | evalDist (x <-$ G2_2; ret fst x) z - evalDist (x <-$ G2_3; ret fst x) z | <=
         q1 / (2 ^ eta).

      intuition.
      eapply leRat_trans.
      eapply fundamental_lemma_h.
      eapply G2_2_3_badness_same.
      eapply G2_2_3_eq_until_bad.
      eapply G2_2_bad_small.
    Qed.

    (* Now switch the the second adversary call *)

    (* for this part we need an oracle that makes the bad event visible *)
    Definition RF_Encrypt_bad (x : Bvector eta)(z : list (Bvector eta * Bvector eta) * bool) (p : Bvector eta):=
      [s, bad] <-2 z;
      r <-$ { 0 , 1 }^eta;
      z <-$ PRFE_RandomFunc s r;
      [pad, s0]<-2 z;
      ret (r, p xor pad, (s0, bad || eqb x r)).

    Definition G2_4 :=
      r <-$ {0, 1}^eta;
      [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
      [p0, p1, s_A] <-3 a;
      b <-$ {0, 1};
      pb <- if b then p1 else p0;
        pad <-$ {0, 1}^ eta;
        c <- (r, pb xor pad);
        [b', o] <-$2 (A2 s_A c) _ _ (RF_Encrypt_bad r) ((r, pad) :: o, false);
        ret (eqb b b', (snd o)).

    Theorem G2_3_4_equiv :
      Pr[x <-$ G2_3; ret fst x] == Pr[x <-$ G2_4; ret fst x].

      unfold G2_3, G2_4.

       do 4 (inline_first; comp_skip; comp_simp).

      inline_first.
      eapply comp_spec_impl_eq.
      eapply comp_spec_seq; eauto with inhabited.
      eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ (fun a b => a = fst b)); intuition.
      destruct x3; simpl in *; subst.
      unfold RF_Encrypt.
      clear H2.
      comp_skip.
      comp_skip.
      eapply comp_spec_ret; simpl in *; intuition.

      intuition.
      simpl in *; subst.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.
    Qed.

     (* When this procedure doesn't go bad, we can remove the challenge pad from the function. *)
    Definition G2_5 :=
      r <-$ {0, 1}^eta;
      [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
      [p0, p1, s_A] <-3 a;
      b <-$ {0, 1};
      pb <- if b then p1 else p0;
        pad <-$ {0, 1}^ eta;
        c <- (r, pb xor pad);
        [b', o] <-$2 (A2 s_A c) _ _ (RF_Encrypt_bad r) (o, false);
        ret (eqb b b', snd o).

    Theorem RF_Encrypt_bad_preserved :
      forall a c d e f g h,
        In (a, (c, d)) (getSupport (RF_Encrypt_bad e (f, g) h)) ->
        g = true ->
        d = true.

      intuition.
      unfold RF_Encrypt_bad in *.
      repeat simp_in_support.
      destruct x0.
      repeat simp_in_support.
      eapply orb_true_l.

    Qed.

    Theorem G2_4_5_eq_until_bad :
      forall z,
        evalDist G2_4 (z, false) == evalDist G2_5 (z, false).

      intuition.
      unfold G2_4, G2_5.
      do 4 (comp_skip; comp_simp).

      eapply comp_spec_impl_eq.
      eapply comp_spec_seq; eauto with inhabited.
      eapply (@oc_comp_spec_eq_until_bad _ _ _ _ _ _ _ _ _ _ _ _ _
        (fun a => snd a) (fun a => snd a)
        (fun a b => forall z,  z <> x -> arrayLookup _ (fst a) z = arrayLookup _ (fst b) z)).

      Theorem RF_Encrypt_bad_wf :
        forall x a b,
          well_formed_comp (RF_Encrypt_bad x a b).

        intuition.
        unfold RF_Encrypt_bad; wftac.
        eapply randomFunc_wf; wftac.

      Qed.

      intuition.
      apply RF_Encrypt_bad_wf.
      intuition.
      apply RF_Encrypt_bad_wf.

      (* Prove that as long as the procedures don't go bad, the invariant holds *)
      intuition.
      simpl in H5; subst.

      (* TODO: mako this a theorem *)
      unfold RF_Encrypt_bad, PRFE_RandomFunc, randomFunc.
      comp_skip.
      case_eq (eqb x b); intuition.

      prog_irr_l.
      destruct (arrayLookup (Bvector_EqDec eta) a b); wftac.
      prog_irr_r.
      destruct (arrayLookup (Bvector_EqDec eta) a0 b); wftac.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.
      rewrite orb_true_r in H10.
      discriminate.
      rewrite orb_true_r in H10.
      discriminate.

      case_eq (arrayLookup (Bvector_EqDec eta) a b); intuition.
      rewrite <- H4.
      simpl.
      rewrite H8.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.
      intuition; subst.
      rewrite eqb_refl in H7.
      discriminate.

      rewrite <- H4.
      simpl.
      rewrite H8.
      prog_inline_l.
      prog_inline_r.
      comp_skip.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.
      case_eq (eqbBvector z0 b); intuition.
      intuition. subst.
      rewrite eqb_refl in H7.
      discriminate.
      intuition.

      (* Prove that once the oracle goes bad, it stays bad. *)
      eapply RF_Encrypt_bad_preserved.
      eapply H5.
      trivial.

      intuition.
      eapply RF_Encrypt_bad_preserved.
      eapply H5.
      trivial.

      (* prove that the invariant holds on the initial state *)
      intuition.
      simpl.
      case_eq (eqbBvector z0 x); intuition.
      apply eqbBvector_sound in H5; intuition.

      (* prove that the bad events are the same *)
      trivial.

      intuition.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intros.
      destruct p1; simpl in *; subst.
      intuition.
      inversion H6; clear H6; subst.
      intuition.
      subst.
      trivial.
      inversion H6; clear H6; subst.
      intuition.
      subst.
      trivial.

      Grab Existential Variables.
      eauto.
    Qed.

    Theorem G2_4_5_badness_same :
      Pr[x <-$ G2_4; ret (snd x)] == Pr[x <-$ G2_5; ret (snd x)].

      unfold G2_4, G2_5.
      do 4 (inline_first; comp_skip; comp_simp).
      inline_first.

      inline_first.

      eapply comp_spec_impl_eq.
      eapply comp_spec_seq; eauto with inhabited.

      eapply (@oc_comp_spec_eq_until_bad _ _ _ _ _ _ _ _ _ _ _ _ _
        (fun a => snd a) (fun a => snd a)
        (fun a b => forall z,  z <> x -> arrayLookup _ (fst a) z = arrayLookup _ (fst b) z)).
      intuition.
      eapply RF_Encrypt_bad_wf.
      intuition.
      eapply RF_Encrypt_bad_wf.

      intuition.
      simpl in *; subst.
      clear H2.
      comp_skip.
      (* The theorem from before would be helpful here *)
      unfold PRFE_RandomFunc, randomFunc.
      case_eq (eqbBvector x b); intuition.

      prog_irr_l.
      destruct (arrayLookup (Bvector_EqDec eta) a b); wftac.
      prog_irr_r.
      destruct ( arrayLookup (Bvector_EqDec eta) a0 b); wftac.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.
      rewrite orb_true_r in H9.
      discriminate.
      rewrite orb_true_r in H9.
      discriminate.

      case_eq (arrayLookup (Bvector_EqDec eta) a b); intuition.
      rewrite <- H4.
      rewrite H7.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.
      intuition; subst.
      rewrite eqbBvector_complete in H6.
      discriminate.
      rewrite <- H4.
      rewrite H7.
      prog_inline_l.
      prog_inline_r.
      comp_skip.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.
      case_eq (eqbBvector z b); intuition.
      intuition; subst.
      rewrite eqbBvector_complete in H6.
      discriminate.

      intros.
      destruct c.
      destruct b.
      eapply RF_Encrypt_bad_preserved .
      eauto.
      trivial.

      intros.
      destruct c.
      destruct b.
      eapply RF_Encrypt_bad_preserved .
      eauto.
      trivial.

      intuition.
      simpl.
      case_eq ( eqbBvector z x); intuition.
      apply eqbBvector_sound in H5; intuition.

      trivial.

      intuition.
      prog_simp.
      clear H2.
      eapply comp_spec_ret; simpl in *; intuition.
      subst.
      trivial.
      destruct p1; simpl in *.
      subst; intuition.

      Grab Existential Variables.
      eauto.
    Qed.

    Theorem G2_4_bad_small : Pr[x <-$ G2_4; ret snd x] <= q2 / (2 ^ eta).

      unfold G2_4.
      inline_first;
      comp_irr_l; wftac.
      inline_first;
      comp_irr_l; wftac.
      eapply oc_comp_wf; intuition.
      comp_simp.
      dist_inline_l.
      comp_irr_l; wftac.
      comp_inline_l; comp_irr_l; wftac.
      comp_inline_l.

      assert ( Pr
   [a <-$
    (A2 s (x, (if x0 then p0 else p) xor x1))
      (list (Bvector eta * Bvector eta) * bool)%type
      (pair_EqDec
         (list_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta)))
         bool_EqDec) (RF_Encrypt_bad x) ((x, x1) :: l, false);
    x2 <-$ ([b', o]<-2 a; ret (eqb x0 b', snd o)); ret snd x2 ]  ==
    Pr
   [a <-$
    (A2 s (x, (if x0 then p0 else p) xor x1))
      (list (Bvector eta * Bvector eta) * bool)%type
      (pair_EqDec
         (list_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta)))
         bool_EqDec) (RF_Encrypt_bad x) ((x, x1) :: l, false);
   ret (snd (snd a))] ).

      comp_skip.
      comp_simp.
      simpl.
      intuition.
      rewrite H4.
      clear H4.

      eapply leRat_trans.

      eapply RndInAdaptive_prob; eauto.

      Theorem RF_Encrypt_bad_prob :
        forall x (a : list (Bvector eta * Bvector eta)) (b : Plaintext),
          (Pr  [d <-$ RF_Encrypt_bad x (a, false) b; ret snd (snd d) ] <= 1 / (2 ^ eta))%rat.

        intuition.
        unfold RF_Encrypt_bad.

        assert ( Pr
   [d <-$
    (r <-$ { 0 , 1 }^eta;
     z <-$ PRFE_RandomFunc a r;
     [pad, s0]<-2 z; ret (r, b xor pad, (s0, false || eqb x r)));
    ret snd (snd d) ] ==
    Pr
   [r <-$ { 0 , 1 }^eta;
     ret eqb x r] ).

        inline_first.
        comp_skip.
        inline_first.
        comp_irr_l.
        eapply randomFunc_wf; wftac.
        comp_simp.
        simpl; intuition.

        rewrite H. clear H.
        (* dist_compute isn't working for some reason *)
        simpl.
        rewrite (@sumList_exactly_one _ x).
        rewrite eqbBvector_complete.
        destruct (EqDec_dec bool_EqDec true true ); intuition.
        rewrite ratMult_1_r.
        eapply leRat_refl.
        eapply getAllBvectors_NoDup.
        eapply in_getAllBvectors.
        intuition.
        destruct ( EqDec_dec bool_EqDec (eqbBvector x b0) true); intuition.
        apply eqbBvector_sound in e; subst; intuition.
        eapply ratMult_0_r.
      Qed.

      intros.
      destruct a.
      simpl in H4; subst.
      eapply RF_Encrypt_bad_prob.

      intuition.
      eapply RF_Encrypt_bad_preserved.
      eauto.
      trivial.

      eapply eqRat_impl_leRat.
      rewrite <- ratMult_num_den.
      eapply eqRat_terms.
      omega.
      unfold posnatMult, natToPosnat, posnatToNat.
      omega.
    Qed.

    Theorem G2_4_5_close :
      forall z,
      | evalDist (x <-$ G2_4; ret fst x) z - evalDist (x <-$ G2_5; ret fst x) z | <=
        q2 / (2 ^ eta).

      intuition.
      eapply leRat_trans.
      eapply fundamental_lemma_h.
      eapply G2_4_5_badness_same.
      eapply G2_4_5_eq_until_bad.
      eapply G2_4_bad_small.
    Qed.

    Theorem G2_5_G3_equiv :
      Pr[x <-$ G2_5; ret fst x] == Pr[G3].

      unfold G2_5, G3.
      intuition.
      inline_first.
      comp_at comp_inline leftc 1%nat.
      comp_swap_l.
      comp_skip.
      comp_simp.
      comp_swap_r.
      comp_skip.
      comp_inline_l.
      comp_skip.
      inline_first; comp_skip.
      inline_first.
      eapply comp_spec_impl_eq.
      eapply comp_spec_seq; eauto with inhabited.
      eapply (@oc_comp_spec_eq _ _ _ _ _ _ _ _ _ _ _ _ _ _ (fun a b => fst a = b)); intuition.
      simpl in *; subst.
      unfold RF_Encrypt.
      comp_skip.
      comp_skip.
      eapply comp_spec_ret; simpl in *; intuition.

      intuition.
      simpl in *; subst.
      prog_simp.
      eapply comp_spec_ret; simpl in *; intuition.

    Qed.

   Theorem G2_G3_close :
    | Pr[G2] - Pr[G3] | <= q1 / (2 ^ eta) + q2 / (2 ^ eta).

     rewrite G2_1_equiv.
     rewrite G2_1_2_equiv.
     eapply ratDistance_le_trans.
     eapply G2_2_3_close.
     rewrite G2_3_4_equiv.
     rewrite <- G2_5_G3_equiv.
     eapply G2_4_5_close.
   Qed.

   (* Step 4 : apply one-time pad argument to replace ciphertext with random values *)
   Require Import OTP.

   Definition G4 :=
    [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
    [p0, p1, s_A] <-3 a;
    b <-$ {0, 1};
    pb <- if b then p1 else p0;
      r <-$ {0, 1}^eta;
      pad <-$ {0, 1}^eta;
      c <- (r, pad);
      [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt o;
      ret (eqb b b').

    (* Put the game into the form expected by the argument. *)
    Definition G3_1 :=
    [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
    [p0, p1, s_A] <-3 a;
    b <-$ {0, 1};
    pb <- if b then p1 else p0;
      r <-$ {0, 1}^eta;
      pad <-$ (x <-$ {0, 1}^eta; ret (pb xor x));
      c <- (r, pad);
      [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt o;
      ret (eqb b b').

    Theorem G3_G3_1_equiv:
      Pr[G3] == Pr[G3_1].

      unfold G3, G3_1.

      repeat (comp_simp;
        inline_first;
        comp_skip).
    Qed.

    Theorem G3_1_G4_equiv:
      Pr[G3_1] == Pr[G4].

      unfold G3_1, G4.
      do 4 (comp_skip;
      comp_simp).
      apply xor_OTP_eq.
      reflexivity.
    Qed.

    Theorem G3_G4_equiv :
      Pr[G3] == Pr[G4].

      rewrite G3_G3_1_equiv.
      eapply G3_1_G4_equiv.

    Qed.

    (* Step 5: Move the coin toss to the end to produce a game that that the adversary obviously wins with probability 1/2. *)
    Definition G5 :=
    [a, o] <-$2 A1 _ _ (RF_Encrypt) nil;
    [p0, p1, s_A] <-3 a;
    r <-$ {0, 1}^eta;
    pad <-$ {0, 1}^eta;
    c <- (r, pad);
    [b', o] <-$2 (A2 s_A c) _ _ RF_Encrypt o;
    b <-$ {0, 1};
    ret (eqb b b').

    Theorem G4_G5_equiv :
      Pr[G4] == Pr[G5].

      unfold G4, G5.
      do 3 (comp_skip; comp_simp; comp_swap_l).
      comp_skip; comp_simp.
      reflexivity.
    Qed.

    (* Show that the probability of the adversary winning G5 is 1/2 *)
    Theorem G5_one_half :
      Pr[G5] == 1/2.

      unfold G5.

      comp_irr_l.
      eapply oc_comp_wf; intuition.

      comp_simp.

      do 3 (comp_irr_l; wftac).
      eapply oc_comp_wf; intuition.

      comp_simp.

      Transparent evalDist.
      Transparent getSupport.

      dist_compute.

      Opaque evalDist.
      Opaque getSupport.

    Qed.

    Theorem PRFE_IND_CPA_concrete :
      IND_CPA_SecretKey_Advantage PRFE_KeyGen PRFE_Encrypt A1 A2 _ <=
      PRF_Advantage ({0, 1}^eta) ({0, 1}^eta) f _ _ PRF_A' +
      (q1 / 2^eta + q2 / 2^eta).

      unfold IND_CPA_SecretKey_Advantage.
      rewrite G1_equiv.
      eapply ratDistance_le_trans.
      eapply eqRat_impl_leRat.
      eapply G1_G2_close.

      eapply leRat_trans.
      eapply ratDistance_le_trans.
      eapply G2_G3_close.
      eapply eqRat_impl_leRat.
      rewrite <- ratIdentityIndiscernables.
      rewrite G3_G4_equiv.
      rewrite G4_G5_equiv.
      eapply G5_one_half.
      eapply eqRat_impl_leRat.
      symmetry.
      eapply ratAdd_0_r.
    Qed.

    (* Concrete cost of executing the constructed adversary *)
    Require Import WC_PolyTime.
    Context `{function_cost_model}.
    Local Open Scope nat_scope.

    Variable A1_cost : nat -> nat.
    Hypothesis A1_cost_correct : oc_cost cost (comp_cost cost) A1 A1_cost.
    Variable A2_cost_1 : nat.
    Hypothesis A2_cost_1_correct : cost (fun p => A2 (fst p) (snd p)) A2_cost_1.
    Variable A2_cost_2 : nat -> nat.
    Hypothesis A2_cost_correct : forall x y, oc_cost cost (comp_cost cost) (A2 x y) A2_cost_2.

    Theorem PRF_A'_cost :
      oc_cost cost (comp_cost cost) PRF_A'
       (fun x => (A1_cost (x + (5 * eta))) + (A2_cost_2 (x + (5 * eta))) +
        x + 5 * A2_cost_1 + 6 + 7 * eta).

      unfold PRF_A'.

      eapply oc_cost_le.

      costtac.
      eauto.

      Theorem PRFE_Encrypt_OC_cost_1 :
        cost PRFE_Encrypt_OC 0.

        Transparent PRFE_Encrypt_OC.
        unfold PRFE_Encrypt_OC.
        eapply cost_const.
      Qed.

      Theorem PRFE_Encrypt_OC_cost_2 :
        forall x, cost (PRFE_Encrypt_OC x) (2 * eta).

        intuition.
        Transparent PRFE_Encrypt_OC.
        unfold PRFE_Encrypt_OC.
        eapply cost_le.
        eapply cost_compose_binary; costtac.
        eapply cost_uncurry_1.
        eapply cost_compose_binary; costtac.
        eapply cost_uncurry_1.
        eapply cost_compose_unary; costtac.
        eapply cost_compose_unary; costtac.
        eapply cost_compose_binary; costtac.
        eapply cost_compose_binary; costtac.
        eapply cost_compose_binary; costtac.
        eapply cost_uncurry_1.
        eapply cost_BVxor.
        intuition.
        eapply cost_uncurry_2.
        eapply cost_BVxor.

        omega.

      Qed.

      Theorem PRFE_Encrypt_OC_oc_cost :
         forall (x : unit) (y : Bvector eta),
           oc_cost cost (comp_cost cost) (PRFE_Encrypt_OC x y) (fun x => x + 3*eta).

        intuition.
        eapply oc_cost_le.
        unfold PRFE_Encrypt_OC.
        costtac.
        eapply cost_compose_binary; costtac.
        eapply cost_uncurry_1.
        eapply cost_compose_unary; costtac.
        eapply cost_compose_unary; costtac.
        eapply cost_compose_binary; costtac.
        eapply cost_compose_binary; costtac.
        eapply cost_uncurry_2.
        eapply cost_BVxor.
        intuition.
        costtac.

        eapply cost_compose_unary; costtac.
        eapply cost_compose_unary; costtac.
        eapply cost_compose_binary; costtac.
        eapply cost_uncurry_2.
        eapply cost_BVxor.
        eapply cost_pair_2.
        intuition.
        costtac.

        intuition.
      Qed.

      eapply PRFE_Encrypt_OC_cost_1.
      eapply PRFE_Encrypt_OC_cost_2.
      eapply PRFE_Encrypt_OC_oc_cost.

      costtac.
      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_1.
      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_1.
      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_1.
      eapply cost_compose_binary; costtac.

      eapply (@cost_compose _ _ _ _ _
        (fun a => (snd (fst (fst (fst a)))))
        (fun (a : Plaintext * Plaintext * State * unit * bool * Bvector eta *
            Vector.t bool eta) => (OC_Run
        unit_EqDec
        (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta)
        (A2 (snd (fst (fst (fst (fst a)))))
           (snd (fst a),
           (if snd (fst (fst a))
            then snd (fst (fst (fst (fst (fst a)))))
            else fst (fst (fst (fst (fst (fst a)))))) xor
           snd a))
        PRFE_Encrypt_OC ))
        ); costtac.

      eapply (@cost_compose_unary _ _ _ _ _
        (fun a : (Plaintext * Plaintext * State * unit * bool * Bvector eta *
            Vector.t bool eta) => (A2 (snd (fst (fst (fst (fst a)))))
           (snd (fst a),
           (if snd (fst (fst a))
            then snd (fst (fst (fst (fst (fst a)))))
            else fst (fst (fst (fst (fst (fst a)))))) xor
           snd a)))

        (fun x =>
           OC_Run unit_EqDec
        (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta) x PRFE_Encrypt_OC)
        ).

      eapply cost_compose_binary; costtac.
      eapply cost_compose_binary; costtac.
      eapply cost_compose_binary; costtac.
      eapply cost_if_bool; costtac.
      eapply cost_uncurry_1.
      eapply cost_BVxor.
      eapply cost_uncurry_2.
      eapply cost_BVxor.

      eapply cost_uncurry_1.
      eauto.
      eapply cost_uncurry_2.
      eauto.

      eapply (@cost_compose _ _ _ _ _
        (fun x => _)
        ( OC_Run unit_EqDec
        (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta))
        ); costtac.

      eapply cost_OC_Run_1.
      intuition.
      eapply cost_OC_Run_2.
      intuition.
      eapply cost_OC_Run_3.

      eapply cost_uncurry_1.
      eapply cost_compose_unary; costtac.
      eapply cost_compose_binary; costtac.

      eapply cost_uncurry_1.
      eapply cost_eqb_bool.
      eapply cost_uncurry_2.
      eapply cost_eqb_bool.

      intuition.
      costtac.
      eapply cost_vec_head.
      intuition.
      costtac.

      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_1.
      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_1.
      eapply cost_compose_binary; costtac.
      simpl.

      eapply (@cost_compose _ _ _ _ _
        (fun a => _)
        (fun a0 : bool * Bvector eta * Vector.t bool eta =>
      OC_Run unit_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta)
        (A2 b0 (snd (fst a0), (if fst (fst a0) then b1 else a) xor snd a0))
        PRFE_Encrypt_OC)

        ); costtac.

      eapply (@cost_compose _ _ _ _ _
        (fun a => _)
        (fun a0 : bool * Bvector eta * Vector.t bool eta =>
      OC_Run unit_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta)
        (A2 b0 (snd (fst a0), (if fst (fst a0) then b1 else a) xor snd a0)))

        ); costtac.

      eapply cost_compose_binary; costtac.
      eapply cost_compose_binary; costtac.
      eapply cost_if_bool; costtac.
      eapply cost_uncurry_1.
      eapply cost_BVxor.
      intuition.
      eapply cost_uncurry_2.
      eapply cost_BVxor.
      eapply cost_uncurry_2.
      eauto.
      eapply cost_OC_Run_1.
      intuition.
      eapply cost_OC_Run_2.
      intuition.
      eapply cost_OC_Run_3.
      eapply cost_uncurry_1.
      eapply cost_compose_unary; costtac.
      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_1.
      eapply cost_eqb_bool.
      intuition.
      eapply cost_uncurry_2.
      eapply cost_eqb_bool.

      intuition.
      costtac.
      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_1.
      eapply cost_compose_binary; costtac.
      simpl.

      eapply (@cost_compose _ _ _ _ _
        (fun a => _)
        (fun a0 : Bvector eta * Vector.t bool eta =>
      OC_Run unit_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta)
        (A2 b0 (fst a0, (if y then b1 else a) xor snd a0)) PRFE_Encrypt_OC)
        ); costtac.

      eapply (@cost_compose _ _ _ _ _
        (fun a => _)
        (fun a0 : Bvector eta * Vector.t bool eta =>
      OC_Run unit_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta)
        (A2 b0 (fst a0, (if y then b1 else a) xor snd a0)))
        ); costtac.

      eapply cost_compose_binary; costtac.
      eapply cost_uncurry_2.
      eapply cost_BVxor.
      eapply cost_uncurry_2.
      eauto.
      eapply cost_OC_Run_1.
      intuition.
      eapply cost_OC_Run_2.
      intuition.
      eapply cost_OC_Run_3.

      intuition.
      costtac.
      eapply cost_compose_binary; costtac.
      simpl.
      eapply (@cost_compose _ _ _  _ _
        (fun a => _)
         (fun a0 : Vector.t bool eta =>
      OC_Run unit_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta) (A2 b0 (y0, (if y then b1 else a) xor a0))
        PRFE_Encrypt_OC)
        ); costtac.

      eapply (@cost_compose _ _ _  _ _
        (fun a => _)
         (fun a0 : Vector.t bool eta =>
      OC_Run unit_EqDec (pair_EqDec (Bvector_EqDec eta) (Bvector_EqDec eta))
        (Bvector_EqDec eta) (A2 b0 (y0, (if y then b1 else a) xor a0))
        )
        ); costtac.

      eapply cost_uncurry_2.
      eapply cost_BVxor.
      eapply cost_pair_2.
      eapply cost_uncurry_2.
      eauto.
      eapply cost_OC_Run_1.
      intuition.
      eapply cost_OC_Run_2.
      intuition.
      eapply cost_OC_Run_3.
      intuition.
      costtac.
      simpl.
      eauto.

      eapply PRFE_Encrypt_OC_cost_1.
      eapply PRFE_Encrypt_OC_cost_2.
      eapply PRFE_Encrypt_OC_oc_cost.

      eapply cost_uncurry_2.
      eapply cost_eqb_bool.

      intuition.
      costtac.

      intuition.

      simpl.
      repeat rewrite plus_0_r.

      (* omega can't handle the functions -- remove them *)
      assert (A1_cost (eta + eta + (x + (eta + (eta + eta)))) =
        A1_cost (x + (eta + (eta + (eta + (eta + eta)))))).
      f_equal; omega.
      rewrite H0.
      clear H0.
      remember ( A1_cost (x + (eta + (eta + (eta + (eta + eta)))))) as t1.
      assert (A2_cost_2 (eta + eta + (x + (eta + (eta + eta)))) =
        A2_cost_2 (x + (eta + (eta + (eta + (eta + eta)))))).
      f_equal; omega.
      rewrite H0.
      clear H0.
      remember (A2_cost_2 (x + (eta + (eta + (eta + (eta + eta)))))) as t2.
      omega.
    Qed.

  End PRF_Encryption_IND_CPA_concrete.

End PRF_Encryption_concrete.

Require Import Asymptotic.

Section PRF_Encryption.

  Context `{function_cost_model}.

  Local Open Scope nat_scope.

  Variable f : forall n, Bvector n -> Bvector n -> Bvector n.

  Section PRF_Encryption_IND_CPA.

    Variable State : nat -> Set.
    Variable A1 : forall n, OracleComp (Plaintext n) (Ciphertext n) (Plaintext n * Plaintext n * State n).
    Variable A2 : forall n, State n -> Ciphertext n -> OracleComp (Plaintext n) (Ciphertext n) bool.

    Hypothesis A1_admissible :
      admissible_oc cost _ _ _ A1.

    Hypothesis A2_admissible :
      admissible_oc_func_2 cost _ _ _ _ _ A2.

    Theorem PRFE_Encrypt_OC_poly_time :
      poly_time_nonuniform_oc_func_2 cost _ _ _ _ _ PRFE_Encrypt_OC.

      unfold poly_time_nonuniform_oc_func_2.
      exists (fun x o => o + 3*x).
      exists (fun x => 2 * x).
      intuition.

      eapply polynomial_plus; intuition.
      eapply polynomial_mult.
      eapply polynomial_const.
      eapply polynomial_ident.

      eapply polynomial_mult.
      eapply polynomial_const.
      eapply polynomial_ident.

      eapply cost_le.
      eapply cost_curry.
      eapply (PRFE_Encrypt_OC_cost_1 n).
      eapply (@PRFE_Encrypt_OC_cost_2 n); eauto.
      omega.

      eapply PRFE_Encrypt_OC_oc_cost; intuition.

    Qed.

    Theorem PRFE_Encrypt_wf :
       forall n x (y : Bvector n), well_formed_oc (PRFE_Encrypt_OC x y).

      intuition.
      econstructor.
      econstructor.
      wftac.
      intuition.
      econstructor.
      econstructor.
      intuition.
      econstructor.
      wftac.

    Qed.

    Theorem PRF_A'_wf :
      forall n, well_formed_oc (PRF_A' (A1 n) (@A2 n)).

      intuition.
      econstructor.
      econstructor.
      eapply A1_admissible.
      eapply PRFE_Encrypt_wf.
      intuition.
      econstructor.
      econstructor.
      wftac.
      intuition.
      econstructor.
      econstructor.
      wftac.
      intuition.
      econstructor.
      econstructor.
      intuition.
      econstructor.
      econstructor.
      simpl.
      eapply A2_admissible.
      intuition.
      eapply PRFE_Encrypt_wf.
      intuition.
      econstructor.
      wftac.

    Qed.

    Theorem PRF_A'_poly_time :
      poly_time_nonuniform_oc cost _ _ _ (fun n => PRF_A' (A1 n) (@A2 n)).

      intuition.
      unfold PRF_A'.
      unfold poly_time_nonuniform_oc.

      destruct (PRFE_Encrypt_OC_poly_time).
      destruct H0.
      unfold admissible_oc in *.
      unfold admissible_oc_func_2 in *.
      intuition.
      destruct H0.
      destruct H2.
      destruct H2.
      intuition.

      exists (fun x o : nat =>
     x1 x (o + 5 * x) + x2 x (o + 5 * x) + o + 5 * (x3 x) + 6 +
     7 * x).

      intuition.
      eapply polynomial_plus.
      eapply polynomial_plus.
      eapply polynomial_plus.
      eapply polynomial_plus.
      eapply polynomial_plus.
      eapply H6.
      eapply polynomial_plus; intuition.
      eapply polynomial_mult.
      eapply polynomial_const.
      eapply polynomial_ident.
      eapply H0.
      eapply polynomial_plus; intuition.
      eapply polynomial_mult.
      eapply polynomial_const.
      eapply polynomial_ident.
      intuition.
      eapply polynomial_mult.
      eapply polynomial_const.
      intuition.
      eapply polynomial_const.
      eapply polynomial_mult.
      eapply polynomial_const.
      eapply polynomial_ident.

      eapply oc_cost_le.
      eapply PRF_A'_cost;
      eauto.
      eapply H12.
      intuition.
      eapply H12.
      intuition.

    Qed.

    Theorem PRF_A'_poly_queries :
      polynomial_queries_oc _ _ _
      (fun n  => PRF_A' (A1 n) (@A2 n)).

      unfold admissible_oc, admissible_oc_func_2 in *.
      intuition.
      destruct H5.
      destruct H6.
      intuition.
      exists (fun n => x n + (1 + x0 n)).
      intuition.
      eapply polynomial_plus; intuition.
      eapply polynomial_plus; intuition.
      eapply polynomial_const.

      eapply qam_le.
      econstructor.
      econstructor.
      eauto.
      intuition.

      Theorem PRFE_Encrypt_OC_qam :
        forall n x (y : Bvector n), queries_at_most (PRFE_Encrypt_OC x y) 1.

        intuition.
        unfold PRFE_Encrypt_OC.
        econstructor.
        econstructor.
        econstructor.
        intuition.
        econstructor.
        econstructor.
        intuition.
        econstructor.

        omega.

      Qed.

      eapply PRFE_Encrypt_OC_qam.

      intuition.
      econstructor.
      econstructor.
      econstructor.
      intuition.
      econstructor.
      econstructor.
      intuition.
      econstructor.
      econstructor.
      intuition.
      econstructor.
      econstructor.
      econstructor.
      eapply H8.
      eapply le_refl.
      eapply le_refl.
      intuition.
      eapply PRFE_Encrypt_OC_qam.
      intuition.
      econstructor.

      omega.

    Qed.

    Theorem PRF_A'_admissible :
      admissible_oc cost _ _ _ (fun n => PRF_A' (A1 n) (@A2 n)).

      unfold admissible_oc.
      intuition.
      eapply PRF_A'_wf.
      eapply PRF_A'_poly_time.
      eapply PRF_A'_poly_queries.

    Qed.

  End PRF_Encryption_IND_CPA.

  Theorem PRFE_IND_CPA :
    PRF _ _ _ Rnd Rnd f _ _ (admissible_oc cost) ->
    IND_CPA_SecretKey (fun n => pair_EqDec (Bvector_EqDec n) (Bvector_EqDec n))
    PRFE_KeyGen (fun n => PRFE_Encrypt (@f n))
    (admissible_oc cost)
    (admissible_oc_func_2 cost).

    unfold IND_CPA_SecretKey.
    intuition.

    destruct H1.
    destruct H2.
    intuition.
    unfold polynomial_queries_oc, polynomial_queries_oc_func_2 in *.
    destruct H7.
    destruct H8.
    intuition.

    eapply negligible_le.
    intuition.
    eapply PRFE_IND_CPA_concrete.
    eauto.
    eauto.
    eauto.
    eauto.
    eauto.

    eapply negligible_plus.
    eapply H0.
    apply PRF_A'_admissible; eauto.

    unfold admissible_oc; intuition.
    econstructor; eauto.
    unfold admissible_oc_func_2; intuition.
    econstructor; eauto.

    eapply negligible_plus.
    eapply negligible_poly_num; intuition.
    eapply negligible_poly_num; intuition.
  Qed.

  Print Assumptions PRFE_IND_CPA.

End PRF_Encryption.


Require Import ZArith Lia Basics RelationClasses.
Require Import Flocq.IEEE754.Binary Flocq.Core.Defs Flocq.Core.Zaux.
Require Import ASN1FP.Aux.StructTactics ASN1FP.Aux.Option.

Open Scope Z.

Section Flocq_bounded_IEEE.

  Let log2 := log_inf.
  Let digits := compose Z.succ log2.

  Lemma digits2_pos_log2 (m : positive) :
    Z.pos (Digits.digits2_pos m) = Z.succ (log2 m).
  Proof.
    induction m; simpl; try (rewrite Pos2Z.inj_succ, IHm); reflexivity.
  Qed.

  Lemma digits2_pos_digits (m : positive) :
    Z.pos (Digits.digits2_pos m) = digits m.
  Proof.
    unfold digits, compose.
    apply digits2_pos_log2.
  Qed.

  (** ** Flocq's Binary.bounded rewritten in a form close to IEEE-754 *)
  Lemma bounded_unfolded (prec emax : Z)
        (prec_gt_0 : Flocq.Core.FLX.Prec_gt_0 prec) (Hmax : (prec < emax)%Z)
        (m : positive) (e : Z) :
    bounded prec emax m e = true
    <->
    or
      (digits m < prec /\ e = 3 - emax - prec)
      (digits m = prec /\ 3 - emax - prec <= e <= emax - prec).
  Proof.
    unfold FLX.Prec_gt_0, bounded, canonical_mantissa, FLT.FLT_exp in *.
    rewrite Bool.andb_true_iff, Z.leb_le, <-Zeq_is_eq_bool, digits2_pos_digits.
    remember (3 - emax - prec) as emin.
    split; intro.
    all: destruct (Z_lt_le_dec (digits m + e - prec) emin).
    all: try rewrite Z.max_r in * by lia.
    all: try rewrite Z.max_l in * by lia.
    all: lia.
  Qed.

  Lemma shl_align_fexp_works_iff (prec emax : Z) (m : positive) (e : Z) :
    let emin := 3 - emax - prec in
    shl_align_fexp prec emax m e <> (m, e)
    <->
    (emin < e /\ digits m + e - prec < emin) \/ (digits m < prec /\ emin <= digits m + e - prec).
  Proof.
    intro.
    unfold shl_align_fexp, shl_align, FLT.FLT_exp.
    rewrite digits2_pos_digits.
    replace (3 - emax - prec) with emin by reflexivity.
    destruct (Z_lt_le_dec (digits m + e - prec) emin).
    all: try rewrite Z.max_r in * by lia.
    all: try rewrite Z.max_l in * by lia.
    all: split.
    all: break_match.
    all: try (intros T; contradict T; reflexivity).
    all: try lia.
    all: intro H; destruct H as [H1 | H1]; destruct H1 as [H1 H2].
    all: intro H; tuple_inversion.
    all: try lia.
    rewrite H3 in H4.
    lia.
  Qed.

  Lemma shl_align_fexp_bad (prec emax : Z) (m : positive) (e : Z) :
    (prec <= digits m)
     ->
    shl_align_fexp prec emax m e = (m, e).
  Proof.
    unfold shl_align_fexp, shl_align, FLT.FLT_exp.
    rewrite digits2_pos_digits.
    destruct (Z_lt_le_dec (digits m + e - prec) (3 - emax - prec)).
    all: try rewrite Z.max_r in * by lia.
    all: try rewrite Z.max_l in * by lia.
    all: break_match; try reflexivity; try lia.
  Qed.

End Flocq_bounded_IEEE.

Section normalization.

  (* a basic float - a pair of two integers - mantissa and exponent *)
  Let float := float radix2.
  Let Float := Float radix2.

  Definition not_zero (f : float) := (Fnum f) <> 0.

  Definition valid_float (prec emax : Z) (f : float) :=
    match (Fnum f) with
    | Z0 => true
    | Z.pos m => bounded prec emax m (Fexp f)
    | Z.neg m => bounded prec emax m (Fexp f)
    end.

  Definition float_eq (f1 : float) (f2 : float) : Prop :=
    let '(m1, e1) := (Fnum f1, Fexp f1) in
    let '(m2, e2) := (Fnum f2, Fexp f2) in
    or
      (e2 <= e1 /\ m2 = m1 * 2 ^ (e1 - e2))
      (e1 <= e2 /\ m1 = m2 * 2 ^ (e2 - e1)).

  Lemma float_eq_refl : Reflexive float_eq.
  Proof.
    unfold Reflexive; intro f.
    unfold float_eq; left.
    replace (Fexp f - Fexp f) with 0.
    all: lia.
  Qed.

  Lemma float_eq_sym : Symmetric float_eq.
  Proof.
    unfold Symmetric, float_eq.
    intros; destruct H; auto.
  Qed.

  Lemma Zpow_divide (b p1 p2 : Z) :
    0 < b ->
    0 <= p1 <= p2 ->
    (b ^ p1 | b ^ p2).
  Proof.
    intros B P.
    rewrite <-Z.mod_divide by (apply Z.pow_nonzero; lia).
    replace p2 with ((p2 - p1) + p1) by lia.
    rewrite Z.pow_add_r by lia.
    apply Z_mod_mult.
  Qed.

  Lemma float_eq_trans : Transitive float_eq.
  Proof.
    unfold Transitive.
    destruct x as [mx ex], y as [my ey], z as [mz ez].
    unfold float_eq.
    clear float Float.
    simpl.
    intros XY YZ.
    destruct XY as [XY | XY]; destruct YZ as [YZ | YZ].
    all: destruct XY as [EXY MXY]; destruct YZ as [EYZ MYZ]; subst.
    - left; split; [lia |].
      rewrite <-Z.mul_assoc.
      rewrite <-Z.pow_add_r; try lia.
      replace (ex - ey + (ey - ez)) with (ex - ez) by lia.
      reflexivity.
    - destruct (Z.eq_dec ex ez); subst.
      + (* ex = ez *)
        apply Z.mul_reg_r in MYZ.
        subst; left; split; [lia |].
        rewrite Z.sub_diag; lia.
        generalize (Z.pow_pos_nonneg 2 (ez - ey)); lia.
      + destruct (Z_lt_le_dec ex ez).
        * (* ex < ez *)
          rename MYZ into H.
          assert (H1 : ey <= ex < ez) by lia; clear EXY EYZ n l.
          right; split; [lia |].
          apply f_equal with (f := fun x => Z.div x (2 ^ (ex - ey))) in H.
          rewrite Z_div_mult in H;
            [| generalize (Z.pow_pos_nonneg 2 (ex - ey)); lia].
          subst.
          rewrite Z.divide_div_mul_exact;
            [| apply Z.pow_nonzero; lia | apply Zpow_divide; lia].
          replace (ez - ey) with ((ez - ex) + (ex - ey)) by lia.
          rewrite Z.pow_add_r by lia.
          rewrite Z.div_mul by (apply Z.pow_nonzero; lia).
          reflexivity.
        * (* ez < ex *)
          rename MYZ into H.
          assert (H1: ey <= ez < ex) by lia; clear EXY EYZ n l.
          left; split; [lia |].
          apply f_equal with (f := fun x => Z.div x (2 ^ (ez - ey))) in H.
          rewrite Z_div_mult in H;
            [| generalize (Z.pow_pos_nonneg 2 (ez - ey)); lia].
          subst.
          rewrite Z.divide_div_mul_exact;
            [| apply Z.pow_nonzero; lia | apply Zpow_divide; lia].
          replace (ex - ey) with ((ex - ez) + (ez - ey)) by lia.
          rewrite Z.pow_add_r by lia.
          rewrite Z.div_mul by (apply Z.pow_nonzero; lia).
          reflexivity.
    - destruct (Z.eq_dec ex ez); subst.
      + (* ex = ez *)
        left; split; [lia |].
        rewrite Z.sub_diag; lia.
      + destruct (Z_lt_le_dec ex ez).
        * (* ex < ez *)
          assert (H : ex < ez <= ey) by lia; clear EXY EYZ n l.
          right; split; [lia |].
          rewrite <-Z.mul_assoc.
          rewrite <-Z.pow_add_r by lia.
          replace (ey - ez + (ez - ex)) with (ey - ex) by lia.
          reflexivity.
        * (* ez < ex *)
          assert (H: ez < ex <= ey) by lia; clear EXY EYZ n l.
          left; split; [lia |].
          rewrite <-Z.mul_assoc.
          rewrite <-Z.pow_add_r by lia.
          replace (ey - ex + (ex - ez)) with (ey - ez) by lia.
          reflexivity.
    - right; split; [lia |].
      rewrite <-Z.mul_assoc.
      rewrite <-Z.pow_add_r; try lia.
      replace (ez - ey + (ey - ex)) with (ez - ex) by lia.
      reflexivity.
  Qed.

  Definition float_eq_equivalence :=
    Build_Equivalence float_eq float_eq_refl float_eq_sym float_eq_trans.

  Lemma not_zero_eq (f1 f2 : float) :
    not_zero f1 ->
    float_eq f1 f2 ->
    not_zero f2.
  Proof.
    unfold not_zero, float_eq.
    destruct f1 as [m1 e1], f2 as [m2 e2]; simpl.
    intros NZ1 H.
    destruct H; destruct H as [H1 H2]; subst.
    - assert (0 < 2 ^ (e1 - e2)) by (apply Z.pow_pos_nonneg; lia).
      apply Z.neq_mul_0.
      lia.
    - intros H; contradict NZ1.
      subst; reflexivity.
  Qed.

  (** * converting between floats in the same cohort *)

  (* increase a given float's exponent by `de` *)
  Definition inc_e (f : float) (de : positive) : option float :=
    let '(m, e) := (Fnum f, Fexp f) in
    let rm := two_power_pos de in
    if (Zmod m rm =? 0)
    then Some (Float (m / two_power_pos de) (e + Z.pos de))
    else None.

  (* decrese a given float's exponent by `de` *)
  Definition dec_e (f : float) (de : positive) : float :=
    let '(m, e) := (Fnum f, Fexp f) in
    let rm := two_power_pos de in
    Float (m * two_power_pos de) (e - Z.pos de).

  (* shift (up or down) the exponent by de *)
  Definition shift_e (f : float) (de : Z) : option float :=
    match de with
    | Z0 => Some f
    | Z.pos pde => inc_e f pde
    | Z.neg nde => Some (dec_e f nde)
    end.

  (* set exponent to a given one *)
  Definition set_e (f : float) (e : Z) : option float :=
    shift_e f (e - Fexp f).

  Lemma inc_e_correct (f1 : float) (de : positive) {f2 : float} :
    inc_e f1 de = Some f2 ->
    Fexp f2 = Fexp f1 + Z.pos de.
  Proof.
    unfold inc_e.
    intro; break_match; inversion H; clear H.
    reflexivity.
  Qed.

  Lemma dec_e_correct (f : float) (de : positive) :
    Fexp (dec_e f de) = Fexp f - Z.pos de.
  Proof. reflexivity. Qed.

  Lemma shift_e_correct (f1 : float) (de : Z) {f2 : float} :
    shift_e f1 de = Some f2 ->
    Fexp f2 = Fexp f1 + de.
  Proof.
    unfold shift_e; intro; break_match; inversion H; clear H.
    lia.
    apply inc_e_correct; assumption.
    apply dec_e_correct.
  Qed.

  Lemma set_e_correct (f1 : float) (e : Z) {f2 : float} :
    set_e f1 e = Some f2 ->
    Fexp f2 = e.
  Proof.
    unfold set_e.
    intro H.
    apply shift_e_correct in H.
    lia.
  Qed.

  (* increasing/decreasing/setting an exponent preserves the float's value *)
  Lemma inc_e_eq (f1 : float) (de : positive) {f2 : float} :
    inc_e f1 de = Some f2 ->
    float_eq f1 f2.
  Proof.
    intros.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    unfold inc_e in H; break_match; inversion H; clear H.
    unfold float_eq.
    simpl in *.
    right.
    replace (e1 + Z.pos de - e1) with (Z.pos de) by lia.
    rewrite <-two_power_pos_equiv.
    remember (two_power_pos de) as rm.
    rewrite Z.eqb_eq in Heqb.
    rewrite Z.mul_comm.
    rewrite <-Z_div_exact_2 with (b := rm); try auto.
    rewrite two_power_pos_equiv in Heqrm.
    assert (0 < 2 ^ Z.pos de).
    apply Z.pow_pos_nonneg.
    all: try lia.
    subst rm.
    rewrite two_power_pos_equiv.
    generalize (Z.pow_pos_nonneg 2 (Z.pos de)).
    lia.
  Qed.

  Lemma dec_e_eq (f : float) (de : positive) :
    float_eq f (dec_e f de).
  Proof.
    destruct f as [m e].
    unfold dec_e, float_eq.
    simpl.
    left.
    replace (e - (e - Z.pos de)) with (Z.pos de) by lia.
    rewrite two_power_pos_equiv.
    split.
    lia.
    reflexivity.
  Qed.

  Lemma shift_e_eq (f1 : float) (de : Z) {f2 : float} :
    shift_e f1 de = Some f2 ->
    float_eq f1 f2.
  Proof.
    destruct de; simpl.
    - intro H; inversion H; apply float_eq_refl.
    - apply inc_e_eq.
    - intro H; inversion H; apply dec_e_eq.
  Qed.

  Lemma set_e_eq (f1 : float) (e : Z) {f2 : float} :
    set_e f1 e = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold set_e.
    apply shift_e_eq.
  Qed.

  (** exponent can always be decreased *)
  Lemma can_decrease_exponent (f : float) (e : Z) :
    e < Fexp f ->
    set_e f e <> None.
  Proof.
    unfold set_e, shift_e.
    destruct f as [fm fe]; simpl; intro.
    break_match; try lia.
    discriminate.
  Qed.

  (* binary digits of m, disregarding the sign *)
  Definition digits (m : Z) := Z.log2 (Z.abs m) + 1.

  Lemma digits_mul_pow2 (m : Z) (d : positive) :
    m <> 0 -> digits (m * two_power_pos d) = digits m + Z.pos d.
  Proof.
    intro.
    rewrite two_power_pos_equiv.
    unfold digits.
    rewrite Z.abs_mul, Z.abs_pow.
    replace (Z.abs 2) with 2 by reflexivity.
    remember (Z.abs m) as pm; remember (Z.pos d) as pd.
    rewrite Z.log2_mul_pow2.
    all: lia.
  Qed.

  Lemma Zabs_div_exact (a b : Z) :
    b <> 0 ->
    a mod b = 0 ->
    Z.abs (a / b) = Z.abs a / Z.abs b.
  Proof.
    intros B AMB.
    apply Zmod_divides in AMB; [| assumption ].
    destruct AMB as [c AMB].
    rewrite AMB at 1.
    apply f_equal with (f := Z.abs) in AMB.
    rewrite Z.abs_mul in AMB.
    rewrite AMB.
    rewrite Z.mul_comm. rewrite Z.div_mul.
    rewrite Z.mul_comm. rewrite Z.div_mul.
    all: lia.
  Qed.

  Lemma digits_div_pow2 (m : Z) (d : positive) :
    m <> 0 ->
    m mod two_power_pos d = 0 ->
    digits (m / two_power_pos d) = digits m - Z.pos d.
  Proof.
    intros M H.
    unfold digits.
    rewrite Zabs_div_exact.
    rewrite two_power_pos_equiv in *.
    rewrite Z.abs_pow.
    remember (Z.abs m) as pm; remember (Z.pos d) as pd.
    apply Zmod_divides in H; destruct H.
    subst m.
    rewrite Z.abs_mul, Z.abs_pow in Heqpm.
    replace (Z.abs 2) with 2 in * by reflexivity.
    subst pm.
    remember (Z.abs x) as px.
    rewrite Z.mul_comm.
    rewrite Z.div_mul.
    rewrite Z.log2_mul_pow2.
    all: subst.
    all: try lia.
    destruct (Z.eq_dec x 0); subst; lia.
    destruct (Z.eq_dec (2 ^ Z.pos d) 0); [ rewrite e in M; lia | assumption ].
    assert (m mod 2 ^ Z.pos d < 2 ^ Z.pos d); try lia.
    apply Zmod_pos_bound.
    apply Z.pow_pos_nonneg; lia.
    rewrite two_power_pos_equiv; generalize (Z.pow_pos_nonneg 2 (Z.pos d)); lia.
  Qed.

  (** ** correspondence between shifting the exponent and the number of digits of the mantissa *)

  Definition inc_digits_m := dec_e.
  Definition dec_digits_m := inc_e.
  Definition shift_digits_m (f : float) (ddm : Z) := shift_e f (- ddm).
  Definition set_digits_m (f : float) (dm : Z) := shift_digits_m f (dm - digits (Fnum f)).

  Lemma inc_digits_m_correct (f : float) (ddm : positive) :
    not_zero f ->
    digits (Fnum (inc_digits_m f ddm)) = digits (Fnum f) + Z.pos ddm.
  Proof.
    unfold inc_digits_m, dec_e; simpl.
    apply digits_mul_pow2.
  Qed.

  Lemma dec_digits_m_correct (f1 : float) (ddm : positive) {f2 : float} :
    not_zero f1 ->
    dec_digits_m f1 ddm = Some f2 ->
    digits (Fnum f2) = digits (Fnum f1) - Z.pos ddm.
  Proof.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    unfold dec_digits_m, inc_e.
    simpl; intros M H.
    break_match; inversion H; clear H.
    rewrite Z.eqb_eq in Heqb.
    apply digits_div_pow2; assumption.
  Qed.

  Lemma shift_digits_m_correct (f1 : float) (ddm : Z) {f2 : float} :
    Fnum f1 <> 0 ->
    shift_digits_m f1 ddm = Some f2 ->
    digits (Fnum f2) = digits (Fnum f1) + ddm.
  Proof.
    unfold shift_digits_m, shift_e.
    simpl; intros M H.
    break_match; inversion H; clear H; subst.
    - lia.
    - replace inc_e with dec_digits_m in H1 by reflexivity.
      replace ddm with (Z.neg p) by lia.
      apply dec_digits_m_correct; assumption.
    - replace dec_e with inc_digits_m in Heqz by reflexivity.
      replace ddm with (Z.pos p) by lia.
      apply inc_digits_m_correct; assumption.
  Qed.

  Lemma set_digits_m_correct (f1 : float) (dm : Z) {f2 : float} :
    not_zero f1 ->
    set_digits_m f1 dm = Some f2 ->
    digits (Fnum f2) = dm.
  Proof.
    intros M H.
    unfold set_digits_m in H.
    apply shift_digits_m_correct in H; [| assumption].
    rewrite H.
    lia.
  Qed.

  Lemma inc_digits_m_eq (f : float) (ddm : positive) :
    float_eq f (inc_digits_m f ddm).
  Proof.
    unfold inc_digits_m.
    apply dec_e_eq.
  Qed.

  Lemma dec_digits_m_eq (f1 : float) (ddm : positive) {f2 : float} :
    dec_digits_m f1 ddm = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold dec_digits_m.
    apply inc_e_eq.
  Qed.

  Lemma shift_digits_m_eq (f1 : float) (ddm : Z) {f2 : float} :
    shift_digits_m f1 ddm = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold shift_digits_m.
    apply shift_e_eq.
  Qed.

  Lemma set_digits_m_eq (f1 : float) (dm : Z) {f2 : float} :
    set_digits_m f1 dm = Some f2 ->
    float_eq f1 f2.
  Proof.
    unfold set_digits_m.
    apply shift_digits_m_eq.
  Qed.

  Definition normalize_float (prec emax : Z) (f : float) (NZ : not_zero f) : option float :=
    let emin := 3 - emax - prec in
    match set_e f emin with
      | None => None
      | Some f1 => if digits (Fnum f1) <=? prec
                   then Some f1
                   else match set_digits_m f prec with
                       | None => None
                       | Some f2 => if andb
                                         (emin <=? Fexp f2)
                                         (Fexp f2 <=? emax - prec)
                                    then Some f2
                                    else None
                       end
    end.

  Lemma exponent_unique_fnum (f1 f2 : float) :
    float_eq f1 f2 ->
    Fexp f1 = Fexp f2 ->
    Fnum f1 = Fnum f2.
  Proof.
    unfold float_eq.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    simpl; intros H E; destruct H; destruct H as [T H]; clear T; subst.
    all: rewrite Z.sub_diag; simpl; lia.
  Qed.

  Lemma exponent_unique (f1 f2 : float) :
    float_eq f1 f2 ->
    Fexp f1 = Fexp f2 ->
    f1 = f2.
  Proof.
    intros.
    copy_apply (exponent_unique_fnum f1 f2 H) H0.
    destruct f1, f2; simpl in *.
    subst; reflexivity.
  Qed.

  Lemma digits_m_unique_fexp (f1 f2 : float) :
    not_zero f1 ->
    float_eq f1 f2 ->
    digits (Fnum f1) = digits (Fnum f2) ->
    Fexp f1 = Fexp f2.
  Proof.
    intros NZ1 H.
    assert (NZ2 : not_zero f2) by apply (not_zero_eq f1 f2 NZ1 H).
    unfold float_eq in *.
    destruct f1 as [m1 e1], f2 as [m2 e2].
    simpl in *; intro DM; destruct H; destruct H as [H1 H2]; subst.
    all: destruct (Z.eq_dec e1 e2); try assumption.
    - assert (e2 < e1) by lia; clear H1 n.
      apply Zcompare_Gt in H.
      apply Zcompare_Gt_spec in H; destruct H as [de H].
      replace (e1 - e2) with (Z.pos de) in DM by lia.
      rewrite <-two_power_pos_equiv in DM.
      rewrite digits_mul_pow2 in DM by assumption.
      contradict DM; lia.
    - assert (e1 < e2) by lia; clear H1 n.
      apply Zcompare_Gt in H.
      apply Zcompare_Gt_spec in H; destruct H as [de H].
      replace (e2 - e1) with (Z.pos de) in DM by lia.
      rewrite <-two_power_pos_equiv in DM.
      rewrite digits_mul_pow2 in DM by assumption.
      contradict DM; lia.
  Qed.

  Lemma digits_m_unique (f1 f2 : float) :
    not_zero f1 ->
    float_eq f1 f2 ->
    digits (Fnum f1) = digits (Fnum f2) ->
    f1 = f2.
  Proof.
    intros.
    copy_apply (digits_m_unique_fexp f1 f2 H H0) H1.
    apply exponent_unique; assumption.
  Qed.

  Fact digits_Zpos_log_inf (p : positive) :
  digits (Z.pos p) = Z.succ (log_inf p).
  Proof.
    unfold digits, Z.abs.
    rewrite <-Zlog2_log_inf.
    reflexivity.
  Qed.

  Fact digits_Zneg_log_inf (p : positive) :
  digits (Z.neg p) = Z.succ (log_inf p).
  Proof.
    unfold digits, Z.abs.
    rewrite <-Zlog2_log_inf.
    reflexivity.
  Qed.

  Lemma valid_float_closed_form (prec emax : Z) (f : float) (NZ : not_zero f)
        (prec_gt_0 : FLX.Prec_gt_0 prec) (Hmax : prec < emax) :
    let emin := 3 - emax - prec in
    let '(m, e) := (Fnum f, Fexp f) in
      valid_float prec emax f = true
      <->
      or
        (digits m < prec /\ e = emin)
        (digits m = prec /\ emin <= e <= emax - prec).
  Proof.
    destruct f as [m e].
    intro.
    unfold FLX.Prec_gt_0 in prec_gt_0.
    unfold valid_float.
    simpl.
    destruct m.
    - (* Z0 *)
      unfold not_zero in NZ; simpl in NZ.
      contradict NZ.
      reflexivity.
    - (* Zpos *)
      rewrite bounded_unfolded by assumption;
        rewrite digits_Zpos_log_inf;
        unfold compose.
      split; intros H; destruct H; auto.
    - (* Zneg *)
      rewrite bounded_unfolded by assumption.
        rewrite digits_Zneg_log_inf;
        unfold compose.
      split; intros H; destruct H; auto.
  Qed.

  Lemma not_None_iff_exists_Some {A : Type} {x : option A} :
    x <> None <-> exists y, x = Some y.
  Proof.
    split; intro.
    - destruct x.
      + exists a; reflexivity.
      + contradict H; reflexivity.
    - destruct H; subst; discriminate.
  Qed.

  Lemma float_eq_trans_l (f1 f2 f3 : float) :
    float_eq f1 f2 ->
    float_eq f1 f3 ->
    float_eq f2 f3.
  Proof.
    intros EQ12 EQ13.
    apply float_eq_sym in EQ12.
    apply float_eq_trans with (y := f1);
      assumption.
  Qed.

  Lemma float_eq_trans_r (f1 f2 f3 : float) :
    float_eq f2 f1 ->
    float_eq f3 f1 ->
    float_eq f2 f3.
  Proof.
    intros EQ12 EQ13.
    apply float_eq_sym in EQ13.
    apply float_eq_trans with (y := f1);
      assumption.
  Qed.

  Lemma float_eq_set_e (f1 f2 : float) :
    float_eq f1 f2 ->
    set_e f1 (Fexp f2) = Some f2.
  Proof.
    intro.
    destruct set_e eqn:SE.
    - (* if successful, then equal *)
      copy_apply set_e_eq SE; rename H0 into H1.
      apply set_e_correct in SE.
      apply (float_eq_trans_l f1 f f2 H1) in H.
      apply (exponent_unique f f2 H) in SE.
      subst; reflexivity.
    - (* always successful *)
      exfalso.
      unfold float_eq, set_e, shift_e, inc_e, dec_e in *.
      destruct f1 as [m1 e1], f2 as [m2 e2]; simpl in *.
      repeat break_match; try discriminate.
      clear SE; rename Heqb into H1.
      apply Z.eqb_neq in H1.
      destruct H; destruct H as [E M]; [lia |]; subst.
      rewrite two_power_pos_equiv in H1.
      rewrite Z.mod_mul in H1; auto.
      generalize (Z.pow_pos_nonneg 2 (Z.pos p)); lia.
  Qed.

  Lemma float_eq_set_digits_m (f1 f2 : float) :
    not_zero f1 ->
    float_eq f1 f2 ->
    set_digits_m f1 (digits (Fnum f2)) = Some f2.
  Proof.
    intros NZ1 H.
    assert (NZ2 : not_zero f2) by apply (not_zero_eq f1 f2 NZ1 H).
    destruct set_digits_m eqn:SDM.
    - (* if successful, then equal *)
      copy_apply set_digits_m_eq SDM; rename H0 into H1.
      apply set_digits_m_correct in SDM; auto.
      apply (float_eq_trans_l f1 f f2 H1) in H.
      assert (NZ: not_zero f) by (apply not_zero_eq with (f1 := f1); assumption).
      apply (digits_m_unique f f2 NZ H) in SDM.
      subst; reflexivity.
    - (* always successful *)
      exfalso.
      unfold float_eq, set_digits_m, shift_digits_m, shift_e, inc_e, dec_e in *.
      destruct f1 as [m1 e1], f2 as [m2 e2]; simpl in *.
      repeat break_match; try discriminate.
      clear SDM; rename Heqb into H1.
      apply Z.eqb_neq in H1.
      destruct H; destruct H as [E M]; subst.
      + destruct (Z.eq_dec e1 e2).
        replace (e1 - e2) with 0 in Heqz by lia;
          rewrite Z.mul_1_r in Heqz; lia.
        assert (e2 < e1) by lia; clear E n.
        apply Zcompare_Gt in H.
        apply Zcompare_Gt_spec in H; destruct H.
        replace (e1 - e2) with (Z.pos x) in *.
        rewrite <-two_power_pos_equiv in *.
        rewrite digits_mul_pow2 in Heqz.
        lia.
        auto.
      + destruct (Z.eq_dec e1 e2).
        replace (e2 - e1) with 0 in Heqz by lia;
          rewrite Z.mul_1_r in Heqz; lia.
        assert (e1 < e2) by lia; clear E n.
        apply Zcompare_Gt in H.
        apply Zcompare_Gt_spec in H; destruct H.
        replace (e2 - e1) with (Z.pos x) in *.
        rewrite <-two_power_pos_equiv in *.
        rewrite digits_mul_pow2 in Heqz.
        assert (x = p) by lia; subst.
        rewrite two_power_pos_equiv in H1.
        rewrite Z.mod_mul in H1; auto.
        generalize (Z.pow_pos_nonneg 2 (Z.pos p)); lia.
        auto.
  Qed.

  Lemma set_e_definition (f1 : float) (e : Z) {f2 : float} :
    set_e f1 e = Some f2 <->
    float_eq f1 f2 /\ Fexp f2 = e.
  Proof.
    split; intro.
    - split.
      apply (set_e_eq f1 e H). apply (set_e_correct f1 e H).
    - destruct H as [EQ FEXP].
      subst.
      apply (float_eq_set_e f1 f2 EQ).
  Qed.

  Lemma set_digits_m_definition (f1 : float) (dm : Z) {f2 : float} :
    not_zero f1 ->
    set_digits_m f1 dm = Some f2 <->
    float_eq f1 f2 /\ digits (Fnum f2) = dm.
  Proof.
    intros NZ1.
    split; intro.
    - split.
      apply (set_digits_m_eq f1 dm H).
      apply (set_digits_m_correct f1 dm NZ1 H).
    - destruct H as [EQ FEXP].
      subst.
      apply (float_eq_set_digits_m f1 f2 NZ1 EQ).
  Qed.

  Theorem normalize_correct (prec emax : Z) (f : float) (NZ : not_zero f)
        (prec_gt_0 : FLX.Prec_gt_0 prec) (Hmax : prec < emax) :
    match (normalize_float prec emax f NZ) with
    | Some nf => (float_eq f nf) /\ (valid_float prec emax nf = true)
    | None => forall (xf : float),
        float_eq f xf -> valid_float prec emax xf = false
    end.
  Proof.
    unfold FLX.Prec_gt_0 in prec_gt_0.
    break_match. rename f0 into nf.
    - (* successful normalization - equal and valid? *)
      unfold normalize_float in Heqo.
      repeat break_match; inversion Heqo; subst.
      + (* subnormal *)
        split.
        * (* same float? *)
          apply set_e_eq with (e := 3 - emax - prec).
          assumption.
        * (* valid float? *)
          apply Z.leb_le in Heqb.
          rewrite valid_float_closed_form.
          apply set_e_correct in Heqo0.
          lia.
          apply not_zero_eq with (f1 := f). assumption.
          apply set_e_eq in Heqo0. assumption.
          unfold FLX.Prec_gt_0; lia.
          assumption.
      + (* normal *)
        split.
        * (* same float? *)
          apply set_digits_m_eq with (dm := prec).
          assumption.
        * (* valid float? *)
          apply andb_prop in Heqb0; destruct Heqb0 as [H1 H2].
          apply Z.leb_le in H1; apply Z.leb_le in H2.
          rewrite valid_float_closed_form.
          right.
          apply set_e_correct in Heqo0.
          apply set_digits_m_correct in Heqo1.
          lia.
          assumption.
          apply not_zero_eq with (f1 := f). assumption.
          apply set_digits_m_eq in Heqo1. assumption.
          unfold FLX.Prec_gt_0; lia.
          assumption.
    - (* unsuccesful normalization - impossible to normalize? *)
      intros xf H.
      apply Bool.not_true_is_false.
      intros V.
      assert (XNZ: not_zero xf) by apply (not_zero_eq f xf NZ H).
      rewrite valid_float_closed_form in V by assumption.
      destruct V as [V | V]; destruct V as [D E].
      + (* xf is subnormal *)
        unfold normalize_float in Heqo.
        repeat break_match; try discriminate; clear Heqo.
        all: rewrite <-E in Heqo0.
        all: rewrite float_eq_set_e in Heqo0 by assumption.
        all: inversion Heqo0; subst.
        all: rewrite Z.leb_gt in Heqb; lia.
      + (* xf is normal *)
        unfold normalize_float in Heqo.
        repeat break_match; try discriminate; clear Heqo.
        * rewrite <-D in Heqo1.
          rewrite float_eq_set_digits_m in Heqo1 by assumption.
          inversion Heqo1; subst; clear Heqo1.
          apply Bool.andb_false_elim in Heqb0; destruct Heqb0.
          all: rewrite Z.leb_gt in e; lia.
        * rewrite <-D in Heqo1.
          rewrite float_eq_set_digits_m in Heqo1 by assumption.
          inversion Heqo1.
        * unfold set_e, shift_e, inc_e, dec_e in Heqo0.
          repeat break_match; try discriminate; clear Heqo0.
          remember (3 - emax - prec) as emin.
          rewrite Z.eqb_neq in Heqb.
          destruct f as [m e], xf as [xm xe].
          unfold float_eq, not_zero in *.
          simpl in *.
          destruct H; destruct H as [EXP NUM].
          -- lia.
          -- subst m.
             replace (xe - e) with ((xe - emin) + Z.pos p) in Heqb by lia.
             rewrite Z.pow_add_r in Heqb by lia.
             rewrite Z.mul_assoc in Heqb.
             rewrite two_power_pos_equiv in Heqb.
             rewrite Z.mod_mul in Heqb.
             contradict Heqb; reflexivity.
             generalize (Z.pow_pos_nonneg 2 (Z.pos p)); lia.
  Qed.

End normalization.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  NF.v                                                                    *)
(*                                                                          *)
(*  This file contains a definition of the normal forms                     *)
(*  of evaluation and some properties which are used in                     *)
(*  later proofs.                                                           *)
(*                                                                          *)
(*                                                                          *)
(*  Jill Seaman                                                             *)
(*  Coq V5.8                                                                *)
(*  November 1993                                                           *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                   NF.v                                   *)
(****************************************************************************)

Require Import syntax.

(********************************************************)
(*							*)
(*	If <<e,A>> -> <<e',A'>>                  	*)
(*	then e' belongs to the following set:		*)
(*							*)
(*	NF = ttt | fff | S | F 				*)
(*           where					*)
(*		S = o | (succ S) 			*)
(*		F = (abs x t e) | (clos F x t e)	*)
(*							*)
(*	which corresponds to:				*)
(*	NF = 0 | true | false | succn(0) | F		*)
(*	 F = \x:t.e | <F,[x:t->e]>			*)
(*							*)
(********************************************************)

Inductive F : tm -> Prop :=
  | F_abs : forall (v : vari) (s : ty) (e : tm), F (abs v s e)
  | F_clos : forall (e e1 : tm) (v : vari) (s : ty), F e -> F (clos e v s e1).
Inductive Sno : tm -> Prop :=
  | Sno_o : Sno o
  | Sno_s : forall e : tm, Sno e -> Sno (succ e).

Inductive NF : tm -> Prop :=
  | NF_ttt : NF ttt
  | NF_fff : NF fff
  | NF_Sno : forall e : tm, Sno e -> NF e
  | NF_F : forall e : tm, F e -> NF e.

(********************************************************)
(*							*)
(*   The inverse of NF_Sno and Sno_s are proved here    *)
(*	and used in a later proof.  They require        *)
(*	predicates about (succ e) for inductive proofs. *)
(*							*)
(********************************************************)

Definition NFsucc (e : tm) :=
  match e return Prop with
  | o =>
      (* o *)  True
      (* ttt *)
  | ttt => True
      (* fff *)
  | fff => True
      (* abs v s e *)
  | abs v s e => True
      (* appl e1 e2 *)
  | appl e1 e2 => True
      (* cond e1 e2 e3 *)
  | cond e1 e2 e3 => True
      (* var v *)
  | var v => True
      (* succ n *)
  | succ n => Sno (succ n)
      (* prd n *)
  | prd n => True
      (* is_o n *)
  | is_o n => True
      (* fix v s e *)
  | Fix v s e => True
      (* clos e v s e1 *)
  | clos e v s e1 => True
  end.

Goal forall e : tm, NF (succ e) -> Sno (succ e).
intros e HNF.  change (NFsucc (succ e)) in |- *.
elim HNF; simpl in |- *; intros; exact I || elim H; simpl in |- *; intros;
 exact I || apply Sno_s; assumption.
Save inv_NF_Sno.

Definition SnoSucc (e : tm) :=
  match e return Prop with
  | o =>
      (* o *)  True
      (* ttt *)
  | ttt => True
      (* fff *)
  | fff => True
      (* abs v s e *)
  | abs v s e => True
      (* appl e1 e2 *)
  | appl e1 e2 => True
      (* cond e1 e2 e3 *)
  | cond e1 e2 e3 => True
      (* var v *)
  | var v => True
      (* succ n *)
  | succ n => Sno n
      (* prd n *)
  | prd n => True
      (* is_o n *)
  | is_o n => True
      (* fix v s e *)
  | Fix v s e => True
      (* clos e v s e1 *)
  | clos e v s e1 => True
  end.

Goal forall e : tm, Sno (succ e) -> Sno e.
intros e HSno. change (SnoSucc (succ e)) in |- *.
elim HSno; simpl in |- *; intros; exact I || assumption.
Save inv_Sno_s.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (x : lst) : lst := append x (append x Nil).