Section SigmaProtocol.
Variable R : Blist -> Blist -> bool.
Variable t : nat.
Variable (Commitment Response P_State : Set)
(P_commit : Blist -> Blist -> Comp (P_State * Commitment))
(V_challenge : Blist -> Commitment -> Comp (Bvector t))
(P_respond : P_State -> Bvector t -> Comp Response)
(V_accept :  Blist -> Commitment -> Bvector t -> Response -> bool).
Variable extract : Blist -> Commitment -> Bvector t -> Bvector t -> Response -> Response -> Comp Blist.
(* Also, extract must be efficient *)
Variable Commitment_EqDec : EqDec Commitment.
Variable Response_EqDec : EqDec Response.
Definition Protocol x w :=
[s_P, a] <-$2 P_commit x w;
e <-$ V_challenge x a;
z <-$ P_respond s_P e;
ret (a, e, z).
(* The ZK simulator *)
Variable M : Blist -> Bvector t -> Comp (Commitment * Response).
Definition G_S x :=
e <-$ {0, 1}^t;
[a, z] <-$2 M x e;
b <-$ ret (V_accept x a e z);
ret (b, (a, e, z)).
Definition G_P x w :=
[a, e, z] <-$3 Protocol x w;
b <-$ ret (V_accept x a e z);
ret (b, (a, e, z)).
Class SigmaProtocol
:= {
poly1 : nat -> nat;
w_length : forall x w, R x w = true -> (length w <= poly1 (length x))%nat;
completeness : forall x w,
R x w = true ->
Pr[[a, e, z] <-$3 Protocol x w; ret (V_accept x a e z)] == 1;
special_soundness : forall x a e e' z z',
e <> e' ->
(exists w, In (a, e, z) (getSupport (Protocol x w))) ->
(exists w, In (a, e', z') (getSupport (Protocol x w))) ->
V_accept x a e z = true ->
V_accept x a e' z' = true ->
Pr[w <-$ extract x a e e' z z'; ret (R x w)] == 1; (* Or perhaps just non-negligible *)
sHVZK : forall x w c,
evalDist (G_S x) (true, c) == evalDist (G_P x w) (true,c)
}.
End SigmaProtocol.
Ltac destruct_exists :=
match goal with
| [H : exists x, _ |- _ ] =>
destruct H
end.
intuition.
simpl in *.
apply in_getUnique_if in H.
eapply in_flatten in H.
destruct H.
intuition.
apply in_map_iff in H0.
destruct H0.
intuition.
subst.
econstructor.
intuition;
eauto.
Qed.
Ltac simp_in_support :=
match goal with
| [H : In _ (getSupport (Bind _ _)) |- _ ] =>
apply getSupport_Bind_In in H; destruct_exists; intuition
| [H : In _ (getSupport (if ?t then _ else _)) |- _ ] => let x := fresh "x" in remember t as x; destruct x
| [H : In _ (getSupport (ret _)) |- _ ] => simpl in H; intuition; try pairInv; subst
(*     | [H : false = inRange _ _ |- _] => symmetry in H *)
| [H : true = negb ?t |- _ ] => let x := fresh "x" in remember t as x; destruct x; simpl in H; try discriminate
end.
intuition.
simpl.
eapply in_getUnique.
eapply in_flatten.
econstructor.
split.
eapply in_map_iff.
econstructor.
split.
eapply eq_refl.
eauto.
trivial.
Qed.
(* Is this sequential or parallel? *)
(* Section ParallelComposition.  Context `{p : SigmaProtocol}. Hypothesis P_State_EqDec : EqDec P_State.  Definition P_commit2 x w := [s_P, a] <--* P_commit x w; [s_P', a'] <--* P_commit x w; ret ((s_P, s_P') , (a, a')).  Definition V_challenge2 x (p : Commitment * Commitment) := let (a, a') := p in e <- V_challenge x a; e' <- V_challenge x a'; ret (VectorDef.append e e').  Variable v_firstn : forall n, Bvector (n + n)%nat -> Bvector n. Variable v_lastn : forall n, Bvector (n + n)%nat -> Bvector n. Hypothesis v_firstn_correct : forall n (v1 v2 : Bvector n),  (v_firstn n (VectorDef.append v1 v2)) = v1. Hypothesis v_lastn_correct : forall n (v1 v2 : Bvector n),  (v_lastn n (VectorDef.append v1 v2)) = v2. Hypothesis firstn_lastn_correct : forall n (v : Bvector (n + n)), v = (VectorDef.append (v_firstn n v) (v_lastn n v)).  Definition P_respond2 (p : P_State * P_State) (e : Bvector (t + t)%nat) := let (s_P, s_P') := p in z <- P_respond s_P (v_firstn t e); z' <- P_respond s_P' (v_lastn t e); ret (z, z').  Definition V_accept2 x (p_a : Commitment * Commitment) (e : Bvector (t + t)%nat)(p_z : Response * Response) := let (a, a') := p_a in let (z, z') := p_z in b <-! V_accept x a (v_firstn t e) z; b' <-! V_accept x a' (v_lastn t e) z'; (b && b').  Definition extract2 x (p_a : Commitment * Commitment) (e1 e2 : Bvector (t + t)%nat)(p_z1 p_z2 : (Response * Response)) := if (eqb (v_firstn t e1) (v_firstn t e2)) then extract x (snd p_a) (v_lastn t e1) (v_lastn t e2) (snd p_z1) (snd p_z2) else extract x (fst p_a) (v_firstn t e1) (v_firstn t e2) (fst p_z1) (fst p_z2).  Definition M2 x (e : Bvector (t + t)%nat) : Comp ((Commitment * Commitment) * (Response * Response)) := [a1, z1] <--* M x (v_firstn t e); [a2, z2] <--* M x (v_lastn t e); ret ((a1, a2), (z1, z2)).  Theorem let_pair : forall (A B C : Type)(p : A * B)(f : A -> B -> C), (let (a, b) := p in f a b) = f (fst p) (snd p).  intuition.  Qed.  Instance sig2 : SigmaProtocol R P_commit2 V_challenge2 P_respond2 V_accept2 extract2 (pair_EqDec Commitment_EqDec Commitment_EqDec) (pair_EqDec Response_EqDec Response_EqDec) M2.  inversion p; clear p; subst. econstructor; intuition. unfold Protocol, P_commit2, V_challenge2, P_respond2, V_accept2 in *. specialize (completeness0 x w H). symmetry. rewrite <- ratMult_1_r. rewrite <- completeness0. rewrite <- commandTwice.  symmetry. do 2 comp_inline O O. do 2 comp_inline 1%nat O. comp_skip.  comp_inline O O. comp_inline 1%nat O. eapply eqRat_trans. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. rewrite let_pair. comp_ret O O. eapply eqRat_refl. comp_simp. do 2 comp_inline O 1%nat. comp_swap O O. comp_skip. comp_inline O 1%nat. comp_inline 1%nat O. eapply eqRat_trans. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. comp_ret O O. eapply eqRat_refl. comp_simp. do 2 comp_inline O 2%nat.  eapply eqRat_trans. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. rewrite v_firstn_correct. eapply eqRat_refl. comp_simp. comp_swap O 1%nat. comp_swap O O. comp_skip. comp_ret 1%nat O.  comp_inline O 2%nat. eapply eqRat_trans. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. eapply evalDist_Bind_id; intuition. rewrite v_lastn_correct. eapply eqRat_refl. comp_ret O O. comp_ret O O. rewrite v_firstn_correct. eapply evalDist_Bind_id; intuition. eapply eqRat_refl. rewrite v_lastn_correct. eapply eqRat_refl. comp_simp.  comp_swap O 2%nat. comp_swap O 1%nat. comp_swap O O. comp_skip.  do 2 comp_inline 1%nat O. comp_skip. comp_inline 1%nat O. comp_skip. comp_inline 1%nat O. comp_skip. comp_ret 1%nat O. unfold snd. comp_skip.   (* second proof starts here *)
unfold extract2.
case_eq (eqb (v_firstn t e) (v_firstn t e')); intuition.
apply (eqb_leibniz (v_firstn t e)) in H4.
destruct (Bvector_eq_dec (v_lastn t e) (v_lastn t e')).
exfalso.
eapply H.
rewrite firstn_lastn_correct.
rewrite firstn_lastn_correct at 1.
f_equal; trivial.
unfold snd.
eapply special_soundness0; intuition.
destruct H0.
exists x0.
unfold Protocol, P_commit2, V_challenge2, P_respond2 in H0.
unfold Protocol.
repeat simp_in_support.
destruct H0; intuition.
repeat simp_in_support.
destruct x2.
repeat simp_in_support.
destruct p.
repeat simp_in_support.
destruct x3.
repeat simp_in_support.
destruct x3.
repeat simp_in_support.
eapply getSupport_In_Bind.
eapply H7.
comp_simp.
eapply getSupport_In_Bind.
eapply H9.
eapply getSupport_In_Bind.
rewrite v_lastn_correct in H10.
eapply H10.
rewrite v_lastn_correct.
simpl; intuition.
destruct H1.
exists x0.
destruct z'.
unfold Protocol, P_commit2, V_challenge2, P_respond2 in H1.
unfold Protocol.
repeat simp_in_support.
destruct x1.
repeat simp_in_support.
destruct x2.
destruct p.
repeat simp_in_support.
destruct x5.
repeat simp_in_support.
eapply getSupport_In_Bind.
eapply H7.
comp_simp.
eapply getSupport_In_Bind.
eapply H9.
eapply getSupport_In_Bind.
rewrite v_lastn_correct in H10.
eapply H10.
rewrite v_lastn_correct.
simpl; intuition.
unfold V_accept2 in *.
destruct z'.
rewrite commandTwice in H2.
intuition.
unfold ratMult in *.
destruct r1.
destruct r2.
unfold eqRat, beqRat, ratCD in H0.
destruct (eq_nat_dec (n * n0 * p0) (n * posnatMult p0 p1)).
unfold posnatMult in *.
destruct p0.
destruct p1.
simpl in *.
eapply num_dem_same_rat1.
simpl.
rewrite (mult_comm x) in e.
arithNormalize.
apply mult_same_r in e; intuition.
apply mult_same_l in e; intuition.
assert (n = O -> False); intuition.
eapply H.
subst.
eapply rat_num_0.
congruence.
Qed.
intuition.
unfold ratInverse.
unfold ratMult in *.
destruct r1.
destruct r2.
unfold ratCD, eqRat, beqRat in *.
simpl in *.
destruct (eq_nat_dec (n * n0 * 1) (posnatMult p0 p1 + 0)).
unfold posnatMult in *.
destruct p0.
destruct p1.
simpl in *.
unfold ratCD.
rewrite mult_1_r in *.
rewrite plus_0_r in *.
destruct n0.
simpl.
rewrite mult_0_r in *.
symmetry in e.
apply mult_is_O in e.
intuition; omega.
simpl.
rewrite e.
rewrite mult_comm.
destruct (eq_nat_dec (x0 * x) (x0 * x)); congruence.
discriminate.
Qed.

Lemma rat_prod_1 : forall r1 r2,
r1 <= 1 ->
r2 <= 1 ->
r1 * r2 == 1 ->
r1 == 1 /\ r2 == 1.