(* 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.		*)
(* A denotational semantics for computations that relates every computation to a denotation. *)
Set Implicit Arguments.
Require Export FCF.Comp.
Require Export FCF.Rat.
Local Open Scope list_scope.
Local Open Scope rat_scope.
Ltac simp_in_support :=
unfold setLet in *;
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 _)) |- _ ] => apply getSupport_In_Ret in H; 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.
(* evalDist is a denotational semantics that produces a distribution instead of a value. *)
Definition Distribution(A : Set) := A -> Rat.
Definition indicator(A : Set)(P : A -> bool) :=
fun a => if (P a) then rat1 else rat0.
Fixpoint evalDist(A : Set)(c : Comp A) : Distribution A :=
match c with
| Ret eqd a => fun a' => if (eqd a a') then 1 else 0
| Bind c1 c2 => fun a =>
sumList (getSupport c1) (fun b => (evalDist c1 b) * (evalDist (c2 b) a))
| Rnd n => fun v => 1 / (expnat 2 n)
| Repeat c P => fun a => (indicator P a) * (ratInverse (sumList (filter P (getSupport c)) (evalDist c))) * (evalDist c a)
end.
Definition dist_sem_eq(A : Set)(c1 c2 : Comp A) :=
forall a, (evalDist c1 a) == (evalDist c2 a).
Definition Support(A : Set)(ls : list A)(d : Distribution A) :=
NoDup ls /\
(forall a, In a ls <-> ~((d a) == 0)).
destruct c; intuition; simpl in *.
econstructor.
apply in_nil.
econstructor.
eapply getUnique_NoDup.
eapply getAllBvectors_NoDup.
eapply filter_NoDup.
eapply getSupport_NoDup.
Qed.
intuition.
eapply H1.
eapply filter_In; eauto.
assert (P a = true -> False).
intuition.
congruence.
eapply H.
eapply filter_In; eauto.
case_eq (P a); intuition.
left.
intuition.
eapply H.
eapply filter_In; eauto.
Qed.
induction c; simpl in *; intuition.
subst.
destruct (e a0 a0).
eapply rat1_ne_rat0.
trivial.
congruence.
destruct (e a a0); subst.
intuition.
right.
intuition.
apply in_getUnique_if in H0.
apply in_flatten in H0.
destruct H0.
intuition.
apply in_map_iff in H2.
destruct H2.
intuition.
eapply sumList_0 in H1; eauto.
apply ratMult_0 in H1; intuition.
eapply IHc; eauto.
subst.
eapply H; eauto.
apply (in_getUnique (flatten (map (fun b : B => getSupport (c0 b)) (getSupport c)))).
apply in_flatten.
apply sumList_nz in H0.
destruct H0.
intuition.
apply ratMult_nz in H2.
intuition.
econstructor.
split.
eapply in_map_iff.
econstructor.
split.
eapply eq_refl.
eapply H1.
eapply H.
eauto.
eapply in_getAllBvectors.
apply ratMult_0 in H0.
intuition.
apply ratMult_0 in H1.
intuition.
unfold indicator in *.
case_eq (b a); intuition.
rewrite H1 in H0.
eapply rat1_ne_rat0.
trivial.
eapply filter_not_In.
eauto.
eauto.
eapply ratInverse_nz; eauto.
eapply IHc.
eapply filter_In.
eauto.
trivial.
apply ratMult_nz in H.
intuition.
apply ratMult_nz in H0.
intuition.
unfold indicator in *.
case_eq (b a); intuition;
rewrite H0 in H.
eapply filter_In.
intuition.
eapply IHc.
trivial.
exfalso.
intuition.
Qed.
induction c; intuition; simpl in *.
intuition.
destruct (e a a0); subst;
intuition.
eapply sumList_0.
intuition.
eapply ratMult_0.
right.
eapply H.
intuition.
eapply H0.
eapply (in_getUnique (flatten (map (fun b : B => getSupport (c0 b)) (getSupport c)))).
eapply in_flatten.
exists (getSupport (c0 a0)).
intuition.
eapply in_map_iff.
exists a0.
intuition.
exfalso.
eapply H.
eapply in_getAllBvectors.
apply filter_not_In in H.
intuition.
eapply ratMult_0.
right.
eauto.
eapply ratMult_0.
left.
unfold indicator.
rewrite H0.
rewrite ratMult_0_l.
intuition.
Qed.
intuition.
eapply getSupport_not_In_evalDist_h.
intuition.
eapply getSupport_In_evalDist; eauto.
Qed.
intuition.
econstructor.
eapply getSupport_NoDup.
apply getSupport_In_evalDist.
Qed.
(* We use evalDist as the probability measure.  Instead of supplying an event on the return type, we expect the computation to test for the occurrence of the event.  *)
Notation "'Pr' [ c  ] " := (evalDist c true) (at level 20).
intuition. simpl.
eapply eqRat_trans.
eapply sumList_comm.
eapply sumList_body_eq; intuition.
eapply eqRat_trans.
eapply sumList_factor_constant_l.
eapply ratMult_eqRat_compat; intuition.
eapply eqRat_symm.
eapply sumList_subset; intuition.
eapply getSupport_NoDup.
eapply getUnique_NoDup.
eapply (in_getUnique (flatten (map (fun b : B => getSupport (c2 b)) (getSupport c1)))).
eapply in_flatten.
econstructor.
split.
eapply in_map_iff.
econstructor.
split.
eapply eq_refl.
eauto.
eauto.
eapply getSupport_not_In_evalDist.
eauto.
Qed.
(* Lemma evalDist_sum_repeat_eq : forall (A : Set)(eqda : eq_dec A)(c : Comp A) P, let scale := (ratInverse (sumList (filter P (getSupport c)) (evalDist c))) in sumList (getSupport (Repeat c P)) (evalDist (Repeat c P)) == sumList (filter P (getSupport c1)) (fun b => scale * evalDist c1 b * (sumList (getSupport (c2 b)) (evalDist (c2 b)))).  intuition. simpl. eapply eqRat_trans. eapply sumList_comm. eapply sumList_body_eq; intuition.  eapply eqRat_trans. eapply sumList_factor_constant_l. eapply ratMult_eqRat_compat; intuition.  eapply eqRat_symm. eapply sumList_subset; intuition. eapply getSupport_NoDup. eapply getUnique_NoDup. eapply in_getUnique. eapply in_flatten. econstructor. split. eapply in_map_iff. econstructor. split. eapply eq_refl. eauto. eauto.  eapply getSupport_not_In_evalDist. eauto.  Qed. *)
intuition.
rewrite sumList_factor_constant_l.
eapply ratInverse_prod_1.
intuition.
destruct ls; simpl in *.
omega.
eapply sumList_0 in H1.
eapply H.
eauto.
eauto.
simpl.
eauto.
Qed.
induction 1; intuition; simpl in *.
unfold sumList; simpl in *.
destruct (pf a a); intuition.
rewrite <- ratAdd_0_l.
intuition.
eapply eqRat_trans.
apply evalDist_sum_bind_eq.
eapply comp_eq_dec; eauto.
eapply bind_eq_dec; eauto.
eapply eqRat_trans.
eapply sumList_body_eq.
intuition.
apply ratMult_eqRat_compat.
apply eqRat_refl.
apply H1.
trivial.
eapply eqRat_trans.
eapply sumList_body_eq; intuition.
apply ratMult_1_r.
trivial.
rewrite sumList_body_const.
rewrite getAllBvectors_length.
rewrite <- ratMult_num_den.
rewrite mult_1_l.
eapply num_dem_same_rat1.
rewrite posnatMult_1_r.
unfold posnatToNat, natToPosnat.
trivial.
eapply eqRat_trans.
eapply sumList_body_eq.
intuition.
eapply ratMult_eqRat_compat.
assert (P a = true).
eapply filter_In; eauto.
unfold indicator.
rewrite H2.
eapply ratMult_1_l.
eapply eqRat_refl.
eapply ratInverse_scale_sum_1.
intuition.
eapply getSupport_In_evalDist.
eapply filter_In.
eapply H1.
trivial.
destruct (filter P (getSupport c)); simpl in *; intuition.
Qed.
intuition.
assert (sumList (filter (fun a0 : A => negb (P a0)) (getSupport c)) (evalDist c) == 1).
eapply leRat_impl_eqRat; trivial.
eapply leRat_trans.
eapply sumList_filter_le.
rewrite evalDist_lossless.
intuition.
trivial.
rewrite <- evalDist_lossless in H2; eauto.
rewrite (sumList_filter_partition P (getSupport c)) in H2.
symmetry in H2.
rewrite ratAdd_comm in H2.
apply ratAdd_arg_0 in H2.
eapply sumList_0 in H2; eauto.
eapply getSupport_In_evalDist.
eapply filter_In; eauto.
trivial.
Qed.
intuition.
rewrite (sumList_filter_partition (eqb true)).
eapply ratAdd_eqRat_compat.
destruct (eq_Rat_dec (Pr[c]) 0).
rewrite e.
eapply sumList_0.
intuition.
apply filter_In in H.
intuition.
rewrite eqb_leibniz in H1.
subst.
trivial.
eapply sumList_exactly_one.
eapply filter_NoDup.
eapply getSupport_NoDup.
eapply filter_In.
intuition.
eapply getSupport_In_evalDist.
intuition.
eapply eqb_leibniz.
trivial.
intuition.
eapply filter_In in H.
intuition.
rewrite eqb_leibniz in H2.
subst.
intuition.
destruct (eq_Rat_dec (evalDist c false) 0).
rewrite e.
eapply sumList_0.
intuition.
eapply filter_In in H.
intuition.
destruct a.
rewrite eqb_refl in H1.
simpl in *.
discriminate.
trivial.
eapply sumList_exactly_one.
eapply filter_NoDup.
eapply getSupport_NoDup.
eapply filter_In.
intuition.
eapply getSupport_In_evalDist.
intuition.
case_eq (eqb true false); intuition.
rewrite eqb_leibniz in H.
discriminate.
intuition.
eapply filter_In in H.
intuition.
destruct b.
rewrite eqb_refl in H2.
simpl in *.
discriminate.
intuition.
Qed.
induction c; intuition; simpl in *.
unfold sumList; simpl in *.
destruct (e a a); intuition.
rewrite <- ratAdd_0_l.
intuition.
eapply leRat_trans.
eapply eqRat_impl_leRat.
apply evalDist_sum_bind_eq.
eapply comp_eq_dec; eauto.
eapply bind_eq_dec; eauto.
eapply leRat_trans.
eapply sumList_le.
intuition.
apply ratMult_leRat_compat.
apply leRat_refl.
apply H.
eapply leRat_trans.
eapply sumList_le; intuition.
eapply eqRat_impl_leRat.
eapply ratMult_1_r.
trivial.
rewrite sumList_body_const.
rewrite getAllBvectors_length.
rewrite <- ratMult_num_den.
rewrite mult_1_l.
eapply eqRat_impl_leRat.
eapply num_dem_same_rat1.
rewrite posnatMult_1_r.
unfold posnatToNat, natToPosnat.
trivial.
destruct (gt_dec (length (filter b (getSupport c))) 0).
eapply leRat_trans.
eapply eqRat_impl_leRat.
eapply sumList_body_eq.
intuition.
eapply ratMult_eqRat_compat.
assert (b a = true).
eapply filter_In; eauto.
unfold indicator.
rewrite H0.
eapply ratMult_1_l.
eapply eqRat_refl.
eapply leRat_trans.
eapply eqRat_impl_leRat.
eapply ratInverse_scale_sum_1.
intuition.
eapply getSupport_In_evalDist.
eapply filter_In.
eapply H.
trivial.
trivial.
intuition.
destruct (filter b (getSupport c)); simpl in *.
unfold sumList.
simpl.
eapply rat0_le_all.
omega.
Qed.
intuition.
eapply leRat_trans.
2:{
eapply (@evalDist_sum_le_1 _ c).
}
pose proof (comp_EqDec c).
destruct (in_dec (EqDec_dec _) a (getSupport c)).
eapply leRat_trans.
2:{
eapply eqRat_impl_leRat.
symmetry.
rewrite (sumList_partition (eqb a)).
eapply ratAdd_eqRat_compat.
eapply sumList_exactly_one.
eapply getSupport_NoDup.
eauto.
intuition.
case_eq (eqb a b); intuition.
exfalso.
eapply H1.
eapply eqb_leibniz.
trivial.
eapply ratMult_0_r.
eapply eqRat_refl.
}
eapply leRat_trans.
eapply eqRat_impl_leRat.
eapply ratAdd_0_r.
eapply ratAdd_leRat_compat.
rewrite eqb_refl.
eapply leRat_trans.
2:{
eapply eqRat_impl_leRat.
symmetry.
eapply ratMult_1_r.
}
intuition.
eapply rat0_le_all.
apply getSupport_not_In_evalDist in n.
rewrite n.
eapply rat0_le_all.
Qed.
intuition.
eapply (@ratAdd_add_same_l _ (Pr[c])).
rewrite ratSubtract_ratAdd_inverse_2.
rewrite <- sumList_support_bool.
eapply evalDist_lossless.
trivial.
eapply evalDist_le_1.
Qed.

Theorem evalDist_le_1_gen :
forall (A : Set)(eqd : EqDec A)(c : Comp A)(ls : list A),
NoDup ls ->
sumList ls (evalDist c) <= 1.