(* Copyright 2012-2015 by Adam Petcher.				* * Use of this source code is governed by the license described	* * in the LICENSE file at the root of the source tree.		*)
(* Equivalance between the oracle machine semantics and the probabilistic semantics. *)
Set Implicit Arguments.
Local Open Scope rat_scope.
Local Open Scope list_scope.
induction c; intuition; simpl in *.
inversion H; clear H; subst.
destruct (e a0 a'); subst.
destruct (eqd a' a').
intuition.
congruence.
destruct (eqd a0 a'); subst.
congruence.
intuition.
destruct (evalDet_step c nil); discriminate.
destruct n; discriminate.
congruence.
Qed.
induction 1; intuition; simpl in *.
discriminate.
case_eq (evalDet_step c1 nil); intuition;
rewrite H3 in H2; try discriminate.
inversion H2; clear H2; subst.
erewrite evalDet_step_done_support_singleton; eauto.
unfold sumList. simpl.
rewrite <- ratAdd_0_l.
rewrite (@evalDet_step_done_evalDist _ (comp_eq_dec c1)); eauto.
destruct (comp_eq_dec c1 b b).
eapply ratMult_1_l.
congruence.
inversion H2; clear H2; subst.
simpl.
rewrite sumList_permutation.
2:{
eapply evalDet_step_more_support_preserved.
eauto.
}
eapply sumList_body_eq.
intuition.
eapply ratMult_eqRat_compat; intuition.
destruct n.
inversion H; clear H; subst.
simpl.
rewrite (vector_0 a).
destruct (Bvector_eq_dec [] [] ).
eapply eqRat_terms; intuition.
congruence.
discriminate.
inversion H1; clear H1; subst.
simpl.
destruct (in_dec (comp_eq_dec c) a (getSupport c)).
symmetry.
eapply eqRat_trans.
eapply (sumList_filter_partition P).
eapply eqRat_trans.
eapply ratAdd_eqRat_compat.
eapply sumList_body_eq.
intuition.
assert (P a0 = true).
eapply filter_In; eauto.
rewrite H2.
simpl.
eapply eqRat_refl.
eapply sumList_body_eq.
intuition.
assert (P a0 = false).
assert (negb (P a0) = true).
apply filter_In in H1.
intuition.
eapply negb_true_iff.
trivial.
rewrite H2.
simpl.
eapply eqRat_refl.
case_eq (P a); intuition.
unfold indicator.
rewrite H1.
rewrite ratMult_1_l.
assert (sumList (filter P (getSupport c))
(fun a0 : A => evalDist c a0 * (if comp_eq_dec c a0 a then 1 else 0)) == evalDist c a).
rewrite (@sumList_exactly_one _ a).
destruct (comp_eq_dec c a a); try congruence.
eapply ratMult_1_r.
eapply filter_NoDup.
eapply getSupport_NoDup.
eapply filter_In; eauto.
intuition.
destruct (comp_eq_dec c b0 a); subst; intuition.
eapply ratMult_0_r.
rewrite H2.
rewrite sumList_factor_constant_r.
rewrite ratMult_1_l.
assert (sumList (filter (fun a0 : A => negb (P a0)) (getSupport c)) (evalDist c) == (ratSubtract 1 (sumList (filter P (getSupport c)) (evalDist c)))).
rewrite <- evalDist_lossless.
rewrite (sumList_filter_partition P (getSupport c)).
rewrite ratSubtract_ratAdd_inverse.
intuition.
trivial.
rewrite H3.
rewrite ratMult_ratSubtract_distrib_r.
rewrite ratMult_1_l.
rewrite <- (ratMult_assoc (sumList (filter P (getSupport c)) (evalDist c))).
rewrite (ratMult_comm (sumList (filter P (getSupport c)) (evalDist c))).
rewrite ratInverse_prod_1.
rewrite ratMult_1_l.
rewrite ratSubtract_ratAdd_inverse_2.
intuition.
eapply leRat_trans.
rewrite <- ratMult_1_l.
eapply leRat_refl.
eapply ratMult_leRat_compat; intuition.
eapply ratInverse_1_swap.
intuition.
eapply sumList_0 in H4.
eapply getSupport_In_evalDist.
eapply filter_In.
eapply H0.
eapply H4.
trivial.
eapply leRat_trans.
eapply sumList_filter_le.
rewrite evalDist_lossless.
intuition.
trivial.
intuition.
eapply sumList_0 in H4.
eapply getSupport_In_evalDist.
eapply filter_In.
eapply H0.
eapply H4.
trivial.
unfold indicator.
rewrite H1.
rewrite ratMult_0_l.
assert (sumList (filter P (getSupport c))
(fun a0 : A => evalDist c a0 * (if comp_eq_dec c a0 a then 1 else 0)) == 0).
eapply sumList_0.
intuition.
destruct (comp_eq_dec c a0 a); subst.
assert (P a = true).
eapply filter_In; eauto.
congruence.
eapply ratMult_0_r.
rewrite H2.
assert (sumList (filter (fun a0 : A => negb (P a0)) (getSupport c))
(fun a0 : A =>
evalDist c a0 *
(0 * ratInverse (sumList (filter P (getSupport c)) (evalDist c)) *
evalDist c a)) == 0).
eapply sumList_0.
intuition.
repeat rewrite ratMult_0_l.
eapply ratMult_0_r.
rewrite H3.
rewrite <- ratAdd_0_l.
symmetry.
eapply ratMult_0_l.
assert (evalDist c a == 0).
eapply getSupport_not_In_evalDist.
trivial.
rewrite H1.
rewrite ratMult_0_r.
symmetry.
eapply sumList_0.
intuition.
case_eq (P a0); intuition.
simpl.
destruct (comp_eq_dec c a0 a); subst.
intuition.
eapply ratMult_0_r.
simpl.
rewrite H1.
repeat rewrite ratMult_0_r.
intuition.
Qed.
induction 1; intuition; subst.
discriminate.
inversion H1; clear H1; subst.
inversion H0; clear H0; subst.
eapply evalDet_step_done_evalDist; eauto.
assert (s = nil).
eapply evalDet_step_more_nil_inv.
eauto.
subst.
rewrite <- IHevalDet_steps; eauto.
erewrite evalDet_step_nil_dist_preserved; eauto.
intuition.
eapply evalDet_step_well_formed_comp_preserved;
eauto.
Qed.
intuition.
eapply evalDet_steps_done_evalDist_h; eauto.
Qed.
Definition lowDistApprox (A : Set)(c : Comp A)(a : A)(n : nat)(v : Rat) :=
exists vals count,
rel_map (evalDet c) (getAllBlists n) vals /\
pred_count (eq (ca_done a)) vals count  /\
v == (count / expnat 2 n).
induction ls; inversion 1; intuition; subst; simpl in *.
f_equal.
inversion H4; clear H4; subst.
inversion H0; clear H0; subst.
simpl in *.
inversion H6; clear H6; subst.
trivial.
inversion H0; clear H0; subst; simpl in *.
inversion H6.
inversion H; clear H; subst.
eapply IHls.
trivial.
Qed.
intuition.
destruct H.
destruct H.
intuition.
specialize (map_Ret_repeat H0); intuition.
subst.
destruct (eqd a a'); subst.
specialize (pred_count_listRepeat_eq_inv _ H); intuition.
subst.
rewrite H2.
rewrite getAllBlists_length.
eapply num_dem_same_rat1.
trivial.
specialize (@pred_count_listRepeat_ne_inv (length (getAllBlists n)) _ (ca_done a') (ca_done a) x0); intuition.
rewrite H1 in H2.
rewrite H2.
apply rat_num_0.
intuition.
inversion H3.
intuition.
trivial.
Qed.
Inductive lowDistApprox_bind (A B : Set)(c1 : Comp B)(c2 : B -> Comp A)(a : A)(n : nat) : Rat -> Prop :=
| lda_b_intro :
forall v,
sumList_rel (fun (b : B) r => forall r1 r2, lowDistApprox c1 b n r1 -> lowDistApprox (c2 b) a n r2 -> r == r1 * r2) (getSupport c1) v ->
lowDistApprox_bind c1 c2  a n v.
(* We will use a tree to represent an approximation at a certain level.  These tree-based approximations are equivalent to the standard approximations above, but they make it easier to prove some properties. *)
Inductive DistApproxTree(A : Set) :=
| dat_leaf : option A -> DistApproxTree A
| dat_internal : DistApproxTree A -> DistApproxTree A -> DistApproxTree A.
(* dat_correct is an inductive predicate that lets us conclude that some tree produces a correct approximation for some computation. *)
Inductive dat_correct_h(A : Set)(c : Comp A)(s : Blist) : nat -> DistApproxTree A -> Prop :=
| dat_correct_h_leaf_Some :
forall a n,
evalDet c s (ca_done a) ->
dat_correct_h c s n (dat_leaf (Some a))
| dat_correct_h_leaf_None :
(forall a, ~ evalDet c s (ca_done a)) ->
dat_correct_h c s 0 (dat_leaf None)
| dat_correct_h_internal :
forall t1 t2 n,
(forall a, ~ evalDet c s (ca_done a)) ->
dat_correct_h c (s ++ (true :: nil)) n t1 ->
dat_correct_h c (s ++ (false :: nil)) n t2 ->
dat_correct_h c s (S n) (dat_internal t1 t2).
Definition dat_correct(A : Set)(c : Comp A)(n : nat) :=
dat_correct_h c nil n.
induction 1; intuition.
inversion H0; clear H0; subst.
assert (ca_done a = ca_done a0).
eapply evalDet_func; eauto.
inversion H0.
subst.
trivial.
specialize (H1 a).
intuition.
specialize (H1 a).
intuition.
inversion H0; clear H0; subst.
specialize (H a).
intuition.
trivial.
inversion H2; clear H2; subst.
specialize (H a).
intuition.
f_equal; eauto.
Qed.
Fixpoint getTreeSupport_dups(A : Set)(t : DistApproxTree A) :=
match t with
| dat_leaf o =>
match o with
| None => nil
| Some a => a :: nil
end
| dat_internal t1 t2 =>
getTreeSupport_dups t1 ++ getTreeSupport_dups t2
end.
Definition getTreeSupport(A : Set)(eqd : eq_dec A)(t : DistApproxTree A) : list A :=
getUnique (getTreeSupport_dups t) eqd.
induction 1; intuition; simpl in *.
intuition; subst.
eapply getSupport_In_evalDet; eauto.
intuition.
unfold getTreeSupport in *.
eapply in_getUnique_if in H2.
simpl in *.
eapply in_app_or in H2.
intuition.
eapply IHdat_correct_h1.
eapply in_getUnique.
eauto.
eauto using in_getUnique.
Qed.
intuition.
eapply H0.
eauto using getTreeSupport_in.
Qed.
induction n; intuition.
destruct (@evalDet_dec _ c s).
trivial.
destruct H0.
exists (dat_leaf (Some x)).
econstructor; eauto.
exists (dat_leaf None).
econstructor.
intuition.
eapply evalDet_done_eof_func; eauto.
destruct (@evalDet_dec _ c s).
trivial.
destruct H0.
exists (dat_leaf (Some x)).
econstructor.
trivial.
destruct (IHn (s ++ (true :: nil)) _ c).
trivial.
destruct (IHn (s ++ (false :: nil)) _ c).
trivial.
exists (dat_internal x x0).
econstructor; eauto.
intuition.
eapply evalDet_done_eof_func; eauto.
Qed.
intuition.
eapply dat_exists_h.
trivial.
Qed.
Fixpoint lowDistApproxFromTree(A : Set)(eqd : eq_dec A)(t : DistApproxTree A)(a : A) :=
match t with
| dat_leaf o =>
match o with
| None => 0
| Some a' => if (eqd a a') then 1 else 0
end
| dat_internal t1 t2 =>
(lowDistApproxFromTree eqd t1 a) * (1 / 2) + (lowDistApproxFromTree eqd t2 a) * (1 / 2)
end.
Definition lowDistApprox_ls (A : Set)(c : Comp A) a n (ls : Blist) r :=
exists vals count,
rel_map (fun s v => (evalDet c (ls ++ s) v)) (getAllBlists n) vals /\
pred_count (eq (ca_done a)) vals count /\
count /expnat 2 n == r.
intuition.
destruct H.
destruct H.
intuition.
econstructor.
econstructor.
intuition.
simpl.
eapply rel_map_eq.
eapply H0.
eauto.
intuition.
eauto.
intuition.
Qed.
intuition.
destruct H0.
destruct H0.
intuition.
destruct (eqd a2 a1); subst.
rewrite <- H3.
erewrite pred_count_eq_all_inv at 1.
erewrite <- rel_map_length.
rewrite getAllBlists_length.
apply num_dem_same_rat1.
unfold posnatToNat.
unfold natToPosnat.
eauto.
eapply H1.
eauto.
intuition.
eapply rel_map_unary_pred.
eapply H1.
intuition.
eapply evalDet_app_eq in H.
eapply evalDet_func; eauto.
trivial.
rewrite <- H3.
erewrite pred_count_eq_0 at 1.
apply rat_num_0.
2:{
eapply H1.
}
2:{
eapply H0.
}
intuition.
subst.
eapply n0.
assert (ca_done a1 = ca_done a2).
eapply evalDet_func.
eapply evalDet_app_eq.
eauto.
eauto.
inversion H5.
trivial.
Qed.
induction 1; intuition; simpl in *.
symmetry.
eapply evalDet_lowDistApprox_ls_done_inv; eauto.
inversion H0; clear H0; subst.
destruct H1; intuition.
simpl in *.
rewrite <- H3.
erewrite pred_count_eq_0 at 1.
apply eqRat_symm.
apply rat_num_0.
2:{
eapply H1.
}
2:{
eapply H0.
}
intuition.
simpl in *.
intuition.
subst.
rewrite app_nil_r in *.
eapply H; eauto.
destruct H2.
destruct H2.
intuition.
simpl in *.
apply rel_map_app_inv in H3.
intuition.
apply rel_map_map_inv in H4.
apply rel_map_map_inv in H6.
eapply (pred_count_first_skip) in H2.
destruct H2.
destruct H2.
intuition.
rewrite IHdat_correct_h1.
2:{
econstructor.
econstructor.
intuition.
eapply rel_map_eq.
eapply H4.
trivial.
intuition.
rewrite <- app_assoc.
simpl.
trivial.
eapply H3.
eapply eqRat_refl.
}
rewrite IHdat_correct_h2.
2:{
econstructor.
econstructor.
intuition.
eapply rel_map_eq.
eapply H6.
trivial.
intuition.
rewrite <- app_assoc.
simpl.
trivial.
eapply H2.
eapply eqRat_refl.
}
rewrite <- ratMult_distrib_r.
rewrite <- ratAdd_den_same.
rewrite H8.
rewrite <- ratMult_num_den.
rewrite mult_1_r.
unfold posnatMult.
unfold natToPosnat.
rewrite <- H5.
eapply eqRat_terms; trivial.
unfold natToPosnat, posnatToNat.
rewrite mult_comm.
simpl.
trivial.
Qed.
intuition.
eapply low_tree_approx_same_inv_h.
eauto.
eapply lowDistApprox_ls_impl.
trivial.
Qed.
intuition.
destruct H0.
destruct H0.
intuition.
specialize (@pred_count_eq_0 (comp_answer A) Blist (getAllBlists n) x (evalDet c) (eq (ca_done a)) x0); intuition.
rewrite H2 in H3.
rewrite H3.
apply rat_num_0.
intuition.
subst.
eapply H.
eapply getSupport_In_evalDet; eauto.
trivial.
trivial.
Qed.
Definition getSupport_bind (A B : Set)(c1 : Comp B)(c2 : B -> Comp A) : list (B * (list A)) :=
(map (fun b => (b , (getSupport (c2 b)))) (getSupport c1)).
Fixpoint flattenPair (A B : Type)(ls : list (A * list B)) :=
match ls with
| nil => nil
| (a, ls_b) :: ls' =>
(map (fun b => (a, b)) ls_b) ++ (flattenPair ls')
end.

Theorem in_flattenPair : forall (A B : Type)(ls : list (A * (list B))) a b entryList,
In (a, entryList) ls ->
In b entryList ->
In (a, b) (flattenPair ls).