(* 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.
induction ls; intuition; simpl in *.
intuition.
inversion H1; clear H1; subst.
eapply in_or_app.
left.
eapply in_map_iff.
econstructor.
intuition.
eapply in_or_app.
right.
eapply IHls; eauto.
Qed.
Definition getSupport_bind_cp (A B : Set)(c1 : Comp B)(c2 : B -> Comp A) : list (B * A) :=
flattenPair (getSupport_bind c1 c2).
intuition.
unfold getSupport_bind_cp, getSupport_bind.
eapply in_flattenPair.
eapply in_map_iff.
econstructor; intuition.
trivial.
Qed.
intuition.
destruct (in_dec eqdb b (getSupport c1)); intuition.
destruct (in_dec eqda a (getSupport (c2 b))); intuition.
exfalso.
eapply H.
eapply In_getSupport_bind_cp; eauto.
Qed.
Instance length_getSupport_nz : forall (A : Set)(c : Comp A),
well_formed_comp c ->
nz (length (getSupport c)).
intuition.
econstructor.
eapply getSupport_length_nz.
trivial.
Qed.
unfold lowDistApprox_ls.
intuition.
exists (listRepeat (ca_done a1) (length (getAllBlists n))).
destruct (eqd a1 a2); subst.
exists (length (getAllBlists n)).
intuition.
eapply rel_map_listRepeat.
intuition.
eapply evalDet_app_eq.
trivial.
eapply pred_count_eq_all; intuition.
symmetry.
eapply in_listRepeat_inv.
eauto.
rewrite listRepeat_length.
trivial.
destruct (eqd a2 a2); try congruence.
rewrite getAllBlists_length.
apply num_dem_same_rat1.
unfold natToPosnat, posnatToNat.
trivial.
exists O.
intuition.
eapply rel_map_listRepeat.
intuition.
eapply evalDet_app_eq.
trivial.
eapply pred_count_eq_none; intuition.
subst.
assert (ca_done a2 = ca_done a1).
eapply in_listRepeat_inv.
eauto.
inversion H1; subst; clear H1.
intuition.
destruct (eqd a2 a1); subst; try congruence.
apply rat_num_0.
Qed.
intuition.
unfold lowDistApprox_ls.
exists (listRepeat (@ca_eof A) (length (getAllBlists n))).
exists O.
intuition.
eapply rel_map_listRepeat; intuition.
destruct (@evalDet_dec _ c (s ++ a)).
trivial.
destruct H2.
exfalso.
eapply H0.
eauto.
eauto.
trivial.
eapply pred_count_eq_none; intuition.
assert (a = (ca_eof A)).
eapply in_listRepeat_inv.
eauto.
subst.
discriminate.
eapply rat_num_0.
Qed.
induction 1; intuition; simpl in *.
eapply evalDet_lowDistApprox_ls_done.
trivial.
eapply evalDet_lowDistApprox_ls_not_done.
trivial.
intuition.
simpl in *.
intuition.
subst.
rewrite app_nil_r in *.
eauto.
destruct (IHdat_correct_h1 a).
trivial.
destruct H3.
destruct (IHdat_correct_h2 a).
trivial.
destruct H4.
intuition.
unfold lowDistApprox_ls.
econstructor. econstructor.
intuition.
simpl.
eapply rel_map_app.
eapply rel_map_map.
eapply rel_map_eq.
eapply H5.
trivial.
intuition.
rewrite <- app_assoc in H11.
simpl in *.
trivial.
eapply rel_map_map.
eapply rel_map_eq.
eapply H3.
trivial.
intuition.
rewrite <- app_assoc in H11.
simpl in *.
trivial.
eapply pred_count_app; eauto.
simpl.
rewrite <- H8.
rewrite <- H9.
repeat rewrite <- ratMult_num_den.
rewrite <- ratAdd_den_same.
eapply eqRat_terms.
repeat rewrite mult_1_r.
trivial.
unfold posnatMult, natToPosnat, posnatToNat.
rewrite mult_comm.
simpl.
trivial.
Qed.
intuition.
unfold dat_correct in *.
edestruct low_tree_approx_same_h.
eauto.
trivial.
destruct H1.
econstructor.
econstructor.
intuition.
simpl in *.
eauto.
eauto.
rewrite H4.
eapply eqRat_refl.
Qed.
unfold left_total.
intuition.
destruct (@dat_exists n _ c).
trivial.
exists (lowDistApproxFromTree eqd x a).
eapply low_tree_approx_same.
trivial.
trivial.
Qed.
Inductive datMap(A B : Set)(f : A -> DistApproxTree B -> Prop) : DistApproxTree A -> DistApproxTree B  -> Prop :=
| datMap_leaf_None :
datMap f (dat_leaf None) (dat_leaf None)
| datMap_leaf_Some :
forall a t,
f a t ->
datMap f (dat_leaf (Some a)) t
| datMap_internal :
forall t1a t2a t1b t2b,
datMap f t1a t1b ->
datMap f t2a t2b ->
datMap f (dat_internal t1a t2a) (dat_internal t1b t2b).
(* a variant of datMap that builds a tree of a maximum depth *)
Inductive datMap_depth(A B : Set)(f : nat -> A -> DistApproxTree B -> Prop) : nat -> DistApproxTree A -> DistApproxTree B -> Prop :=
| datMap_depth_leaf_None :
forall n,
datMap_depth f n (dat_leaf None) (dat_leaf None)
| datMap_depth_leaf_Some :
forall n a t,
f n a t ->
datMap_depth f n (dat_leaf (Some a)) t
| datMap_depth_internal :
forall n t1a t2a t1b t2b,
datMap_depth f n t1a t1b ->
datMap_depth f n t2a t2b ->
datMap_depth f (S n) (dat_internal t1a t2a) (dat_internal t1b t2b).
Definition dat_correct_bind(A B : Set)(c1 : Comp B)(c2 : B -> Comp A)(n : nat)(t : DistApproxTree A) :=
exists tb, dat_correct c1 n tb /\
(datMap_depth (fun n' b ta => (dat_correct (c2 b) n' ta)) n tb t).
Definition dat_correct_bind2(A B : Set)(c1 : Comp B)(c2 : B -> Comp A)(n : nat)(t : DistApproxTree A) :=
exists tb, dat_correct c1 n tb /\
(datMap (fun b ta => (dat_correct (c2 b) n ta)) tb t).
induction t; intuition; simpl in *.
destruct o.
destruct (eqd a a0); subst.
exfalso.
eapply H.
simpl.
intuition.
intuition.
intuition.
rewrite IHt1.
rewrite IHt2.
rewrite ratMult_0_l.
rewrite <- ratAdd_0_r.
intuition.
intuition.
eapply H.
unfold getTreeSupport in *.
simpl.
eapply in_getUnique.
eapply in_or_app.
right.
eapply in_getUnique_if.
eauto.
intuition.
eapply H.
unfold getTreeSupport in *.
simpl.
eapply in_getUnique.
eapply in_or_app.
left.
eapply in_getUnique_if.
eauto.
Qed.

Lemma lowDistApproxFromTree_datMap_inv : forall (A B : Set)(eqda : eq_dec A)(eqdb : eq_dec B)(tb : DistApproxTree B)(ta : DistApproxTree A)(mapRel : B -> DistApproxTree A -> Prop),
datMap mapRel tb ta ->
(forall b, In b (getTreeSupport eqdb tb) -> exists t,  mapRel b t) ->
(forall b t1 t2, mapRel b t1 -> mapRel b t2 -> t1 = t2) ->
forall a r,
sumList_rel
(fun b r' =>
forall ta', mapRel b ta' ->
lowDistApproxFromTree eqdb tb b * lowDistApproxFromTree eqda ta' a == r')
(getTreeSupport eqdb tb)
r ->
lowDistApproxFromTree eqda ta a == r.