(* 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.		*)
(* Rules used to prove facts based on the distribution semantics *)

Set Implicit Arguments.

Require Import fcf.DistSem.
Require Import fcf.Fold.
Require Import Permutation.
Require Import fcf.SemEquiv.
Require Import fcf.DetSem.
Require Import fcf.NotationV1.

Local Open Scope rat_scope.
Local Open Scope comp_scope.
Local Open Scope list_scope.

(* The uniformity rule allows us to conclude that all bit vectors (of the same length) are equally likely. *)
Theorem uniformity : forall n (x1 x2 : Bvector n),
  evalDist ({0, 1} ^ n) x1 == evalDist ({0, 1} ^ n) x2.

  intuition.
  unfold evalDist.
  eapply eqRat_refl.
Qed.

Lemma evalDist_in_f : forall (A B : Set)(c1 : Comp A)(c2 : Comp B)(f : A -> B),
  (forall a, eqRat (evalDist c1 a) (evalDist c2 (f a))) ->
  (forall a, In a (getSupport c1) <-> In (f a) (getSupport c2)).

  intros.
  specialize (getSupport_correct c1).
  specialize (getSupport_correct c2).
  intros.
  inversion H0; clear H0.
  inversion H1; clear H1.

  intuition.
  apply H3.
  intuition.
  eapply H4; eauto.
  eapply eqRat_trans.
  eapply H.
  eauto.

  eapply H4.
  intuition.
  eapply H3; eauto.
  eapply eqRat_trans.
  eapply eqRat_symm.
  eapply H.
  eauto.
Qed.

Lemma perm_map_in : forall (A B : Set)(lsa : list A)(lsb : list B)(f : A -> B)(f_inv : B -> A),
  (forall b, In b lsb -> f (f_inv b) = b) ->
  (forall a, In a lsa <-> In (f a) lsb) ->
  NoDup (map f lsa) ->
  NoDup lsb ->
  Permutation (map f lsa) lsb.

  intuition.
  eapply NoDup_Permutation; intuition.
  apply in_map_iff in H3.
  destruct H3.
  intuition.
  subst.
  eapply H0.
  trivial.

  eapply in_map_iff.
  econstructor.
  split.
  Focus 2.
  eapply H0.
  assert (x = f (f_inv x)).
  symmetry.
  eapply H.
  trivial.
  rewrite H4 in H3.
  eapply H3.
  eapply H.
  trivial.
Qed.

Lemma not_in_map : forall (A B : Set)(ls : list A)(f : A -> B)(f_inv : B -> A)(a : A),
  (forall a, f_inv (f a) = a) ->
  ~In a ls ->
  ~In (f a) (map f ls).

  induction ls; intuition.
  simpl in *.

  intuition.

  eapply H1.
  rewrite <- (H a).
  rewrite <- (H a0).
  f_equal.
  trivial.

  eapply IHls; eauto.
Qed.

Lemma map_NoDup : forall (A B : Set)(ls : list A)(f : A -> B)(f_inv : B -> A),
  (forall a, In a ls -> f_inv (f a) = a) ->
  NoDup ls ->
  NoDup (map f ls).

  induction ls; intuition; simpl in *.
  econstructor.

  inversion H0; clear H0; subst.
  econstructor; eauto.

  intuition.
  apply in_map_iff in H0.
  destruct H0.
  intuition.
  assert (x = a).
  rewrite <- (H x); intuition.
  rewrite <- (H a); intuition.
  f_equal.
  trivial.
  subst.
  intuition.
Qed.

Lemma support_NoDup : forall (A : Set)(c : Comp A),
  NoDup (getSupport c).

  intuition.
  specialize (getSupport_correct c); intuition.
  inversion H.
  eauto.
Qed.

Lemma filter_NoDup : forall (A : Set)(ls : list A)(P : A -> bool),
  NoDup ls ->
  NoDup (filter P ls).

  induction ls; simpl in *; intuition.

  inversion H; clear H; subst.
  destruct (P a).
  econstructor; eauto.
  intuition.
  eapply filter_In in H.
  intuition.

  eapply IHls; eauto.

Qed.

Lemma evalDist_getSupport_perm : forall (A B : Set)(c1 : Comp A)(c2 : Comp B) (f : A -> B)(f_inv : B -> A),
  (forall b, In b (getSupport c2) -> (f (f_inv b)) = b) ->
  (forall a, In a (getSupport c1) -> (f_inv (f a)) = a) ->
  (forall a, In a (getSupport c1) -> eqRat (evalDist c1 a) (evalDist c2 (f a))) ->
  (forall a, In a (getSupport c2) -> eqRat (evalDist c2 a) (evalDist c1 (f_inv a))) ->
  Permutation (map f (getSupport c1)) (getSupport c2).

  intuition.
  eapply NoDup_Permutation.
  eapply map_NoDup.
  intuition.
  eapply getSupport_NoDup.
  eapply getSupport_NoDup.
  intuition.
  apply in_map_iff in H3.
  destruct H3.
  intuition.
  subst.
  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  eauto.
  eapply eqRat_trans.
  eapply H1.
  trivial.
  trivial.

  eapply in_map_iff.
  econstructor.
  split.
  eapply H.
  trivial.

  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  eapply H3.
  rewrite H2.
  trivial.
  trivial.

Qed.

Lemma evalDist_getSupport_filter_perm : forall (A: Set)(c1 : Comp A)(c2 : Comp A)(P : A -> bool),
  (forall a, P a = true -> eqRat (evalDist c1 a) (evalDist c2 a)) ->
  Permutation (filter P (getSupport c1)) (filter P (getSupport c2)).

  intuition.
  eapply NoDup_Permutation.
  eapply filter_NoDup.
  eapply support_NoDup.
  eapply filter_NoDup.
  eapply support_NoDup.

  intuition.
  eapply filter_In in H0.
  eapply filter_In.
  intuition.
  eapply getSupport_In_evalDist.
  apply getSupport_In_evalDist in H1.
  intuition.
  apply H1.
  eapply eqRat_trans.
  eapply H.
  trivial.
  trivial.

  intuition.
  eapply filter_In in H0.
  eapply filter_In.
  intuition.
  eapply getSupport_In_evalDist.
  apply getSupport_In_evalDist in H1.
  intuition.
  apply H1.
  eapply eqRat_trans.
  eapply eqRat_symm.
  eapply H.
  trivial.
  trivial.
Qed.

Lemma evalDist_getSupport_perm_id : forall (A : Set)(c1 c2 : Comp A),
  (forall a, eqRat (evalDist c1 a) (evalDist c2 a)) ->
  Permutation (getSupport c1) (getSupport c2).

  intuition.
  rewrite <- map_id.
  eapply Permutation_sym.
  eapply evalDist_getSupport_perm; intuition.
  symmetry.
  eauto.
Qed.

Lemma sumList_f_inverse : forall (A B : Set)(ls : list A)(f : A -> B)(f_inv : B -> A)(fa : A -> Rat),
    (forall a, In a ls -> f_inv (f a) = a) ->
    sumList (map f ls) (fun (b : B) => fa (f_inv b) ) ==
    sumList ls fa.

  intuition.
  unfold sumList.
  eapply fold_add_f_inverse;
  intuition.
Qed.

Theorem distro_iso_eq : forall (A B C D : Set)(f : C -> D)(f_inv : D -> C)(d : Comp D)(c : Comp C)(f1 : D -> Comp B)(f2 : C -> Comp A)(a : A)(b : B),
  (forall x, In x (getSupport d) -> f (f_inv x) = x) ->
  (forall x, In x (getSupport c) -> f_inv (f x) = x) ->
  (forall x, In x (getSupport d) -> In (f_inv x) (getSupport c)) ->
  (forall x, In x (getSupport c) -> (evalDist d (f x)) == (evalDist c x)) ->
  (forall x, In x (getSupport c) -> (evalDist (f1 (f x)) b) == (evalDist (f2 x) a)) ->
  (evalDist (Bind d f1) b == evalDist (Bind c f2) a).

  intuition.
  simpl.

  eapply eqRat_trans.
  eapply fold_add_rat_perm.
  eapply Permutation_sym.
  eapply evalDist_getSupport_perm; eauto.

  intuition.
  symmetry.
  eauto.

  intuition.
  rewrite <- (H a0) at 1.
  eapply H2.
  eauto.
  trivial.

  eapply eqRat_refl.
  intuition.
  eapply ratMult_eqRat_compat.
  rewrite <- H at 1.
  eauto.
  trivial.
  rewrite <- H at 1.
  eapply H3.
  eauto.
  trivial.

  eapply eqRat_trans.
  Focus 2.
  eapply fold_add_f_inverse; eauto.
  eapply eqRat_refl.
  simpl.
  eapply eqRat_refl.

Qed.

Lemma evalDist_seq_eq : forall (A1 A2 B : Set)(c1 c2 : Comp B)(f1 : B -> Comp A1)(f2 : B -> Comp A2) y z,
  (forall x : B, evalDist c1 x == evalDist c2 x) ->
  (forall x : B, In x (getSupport c1) -> evalDist (f1 x) y == evalDist (f2 x) z) ->
  evalDist (x <-$ c1; f1 x) y == evalDist (x <-$ c2; f2 x) z.

  intuition.
  eapply (distro_iso_eq (fun b => b)(fun b => b)); intuition.

  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  eauto.
  rewrite H.
  trivial.

  eapply H0.
  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  eauto.
  rewrite <- H.
  trivial.
Qed.

Theorem distro_irr_eq : forall (A B : Set)(b : Comp B)(a : B -> Comp A)(y : A) v,
  well_formed_comp b ->
  (forall x, In x (getSupport b) -> (evalDist (a x) y) == v) ->
  evalDist (Bind b a) y == v.

  intuition.
  simpl.
  rewrite sumList_body_eq.
  Focus 2.
  intuition.
  rewrite H0 at 1.
  eapply eqRat_refl.
  trivial.
  rewrite sumList_factor_constant_r.
  rewrite evalDist_lossless.
  eapply ratMult_1_l.
  trivial.
Qed.

Lemma sumList_filter : forall (A : Set)(ls : list A)(f : A -> Rat)(P : A -> bool) init,
  fold_left (fun r a => r + if (P a) then (f a) else 0) ls init  ==
  fold_left (fun r a => r + (f a)) (filter P ls) init.

  induction ls; simpl in *; intuition.

  destruct (P a); simpl.
  eapply IHls.
  rewrite fold_add_body_eq.
  eapply IHls.
  symmetry.
  eapply ratAdd_0_r.

  intuition.
Qed.

Theorem evalDist_left_ident_eq : forall (B : Set)(eqd : EqDec B)(b : B)(A : Set)(c2 : B -> Comp A)  a,
  (evalDist (x <-$ ret b; (c2 x)) a) == (evalDist (c2 b) a).

  intuition.
  simpl.
  unfold sumList.
  simpl.
  destruct (EqDec_dec eqd b b).
  rewrite <- ratAdd_0_l.
  rewrite ratMult_1_l.
  intuition.
  congruence.

Qed.

Theorem evalDist_assoc_eq : forall (A : Set)(c1 : Comp A)(B C : Set)(c2 : A -> Comp B)(c3 : B -> Comp C),
  dist_sem_eq (Bind (Bind c1 c2) c3) (Bind c1 (fun a => (Bind (c2 a) c3))).

  unfold dist_sem_eq.
  intuition.
  assert (EqDec B).
  eapply bind_EqDec; eauto.
  simpl.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intuition.
  symmetry.
  eapply sumList_factor_constant_r.
  simpl.
  rewrite sumList_comm.
  eapply sumList_body_eq.
  intuition.
  rewrite <- sumList_factor_constant_l.
  eapply eqRat_trans.
  eapply (sumList_filter_partition (fun b => if (in_dec (EqDec_dec _) b (getSupport (c2 a0))) then true else false)).
  eapply eqRat_trans.
  eapply ratAdd_eqRat_compat.
  eapply eqRat_refl.
  eapply sumList_0.
  intuition.
  eapply filter_In in H1.
  intuition.
  destruct (in_dec (EqDec_dec H) a1 (getSupport (c2 a0))).
  simpl in H3.
  discriminate.
  assert (evalDist (c2 a0) a1 == 0).
  eapply getSupport_not_In_evalDist.
  trivial.
  rewrite H1.
  rewrite ratMult_0_r.
  eapply ratMult_0_l.
  rewrite <- ratAdd_0_r.
  eapply eqRat_trans.
  eapply sumList_permutation.
  Focus 2.
  eapply sumList_body_eq.
  intuition.
  eapply ratMult_assoc.
  eapply NoDup_Permutation.
  eapply filter_NoDup.
  eapply getUnique_NoDup.
  eapply getSupport_NoDup.
  intuition.
  apply filter_In in H1.
  intuition.
  destruct (in_dec (EqDec_dec H) x (getSupport (c2 a0))).
  trivial.
  discriminate.

  eapply filter_In.
  intuition.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eauto.
  eauto.
  destruct (in_dec (EqDec_dec H) x (getSupport (c2 a0)) ).
  trivial.
  intuition.
Qed.

(* We can swap any two independent commands *)
Theorem evalDist_commute_eq : forall (A B : Set)(c1 : Comp A)(c2 : Comp B)(C : Set)(c3 : A -> B -> Comp C),
  dist_sem_eq (a <-$ c1; b <-$ c2; (c3 a b)) (b <-$ c2; a <-$ c1; (c3 a b)).

  intuition.
  unfold dist_sem_eq.
  intuition.
  simpl.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intuition.
  symmetry.
  eapply sumList_factor_constant_l.
  symmetry.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intuition.
  symmetry.
  eapply sumList_factor_constant_l.
  rewrite sumList_summation.
  eapply sumList_body_eq.
  intuition.
  eapply sumList_body_eq.
  intuition.
  repeat rewrite <- ratMult_assoc.
  eapply ratMult_eqRat_compat; intuition.
  eapply ratMult_comm.
Qed.

Lemma evalDist_Repeat_eq : forall (A : Set)(c1 c2 : Comp A)(P1 P2 : A -> bool) v1 v2,
  evalDist c1 v1 == evalDist c2 v2 ->
  P1 v1 = P2 v2 ->
  In v1 (filter P1 (getSupport c1)) ->
  sumList (filter P1 (getSupport c1)) (evalDist c1) == sumList (filter P2 (getSupport c2)) (evalDist c2) ->
  evalDist (Repeat c1 P1) v1 == evalDist (Repeat c2 P2) v2.

  intuition.
  simpl.
  eapply ratMult_eqRat_compat; intuition.
  eapply ratMult_eqRat_compat.
  unfold indicator.
  rewrite H0.
  intuition.
  eapply ratInverse_eqRat_compat.
  intuition.
  eapply getSupport_In_evalDist.
  eapply filter_In.
  eauto.
  eapply sumList_0 in H3; eauto.
  trivial.

Qed.

Definition intersect(A : Set)(eqd : eq_dec A)(ls1 ls2 : list A) :=
  filter (fun x => if (in_dec eqd x ls1) then true else false) ls2.

Lemma in_intersect : forall (A : Set)(eqd : eq_dec A)(ls1 ls2 : list A) a,
  In a (intersect eqd ls1 ls2) <->
  In a ls1 /\ In a ls2.

  unfold intersect in *.

  intuition.
  apply filter_In in H.
  intuition.
  destruct (in_dec eqd a ls1).
  trivial.
  discriminate.
  apply filter_In in H.
  intuition.

  eapply filter_In.
  intuition.
  destruct (in_dec eqd a ls1); intuition.
Qed.

Lemma intersect_comm : forall (A : Set)(eqd : eq_dec A)(ls1 ls2 : list A),
  NoDup ls1 ->
  NoDup ls2 ->
  Permutation (intersect eqd ls1 ls2) (intersect eqd ls2 ls1).

  intuition.
  eapply NoDup_Permutation.
  apply filter_NoDup; trivial.
  apply filter_NoDup; trivial.

  unfold intersect in *.
  intuition.
  apply filter_In.
  apply filter_In in H1.
  intuition.
  destruct (in_dec eqd x ls1); intuition.
  discriminate.
  destruct (in_dec eqd x ls2); intuition.

  apply filter_In.
  apply filter_In in H1.
  intuition.
  destruct (in_dec eqd x ls2); intuition.
  discriminate.
  destruct (in_dec eqd x ls1); intuition.

Qed.

Theorem fundamental_lemma_h : forall (A : Set)(eqda : EqDec A)(c1 c2 : Comp (A * bool)),
  (evalDist (Bind c1 (fun x => ret snd x)) true == evalDist (Bind c2 (fun x => ret snd x)) true) ->
  (forall a, evalDist c1 (a, false) == evalDist c2 (a, false)) ->
  forall a,
    ratDistance (evalDist (Bind c1 (fun x => ret (fst x))) a) (evalDist (Bind c2 (fun x => ret (fst x))) a) <=
    evalDist (Bind c1 (fun x => ret snd x)) true.

  intuition.
  simpl in *.

  rewrite (sumList_filter_partition (@snd A bool)).
  rewrite (sumList_filter_partition (@snd A bool) (getSupport c2)).

  rewrite ratDistance_add_same_r_gen.

  eapply leRat_trans.
  eapply ratDistance_le_max_triv.
  eapply maxRat_leRat_same.

  eapply leRat_trans.
  Focus 2.
  eapply sumList_filter_le.

  eapply sumList_le; intuition.
  apply filter_In in H1.
  intuition.
  eapply ratMult_leRat_compat; intuition.
  destruct a0.
  simpl in *.
  subst.
  destruct (EqDec_dec bool_EqDec true true); try congruence.
  destruct (EqDec_dec eqda a0 a); intuition.

  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  symmetry.
  eapply H.
  eapply leRat_trans.
  Focus 2.
  eapply sumList_filter_le.
  eapply sumList_le; intuition.
  apply filter_In in H1.
  intuition.
  eapply ratMult_leRat_compat; intuition.
  destruct a0.
  simpl in *.
  subst.
  destruct (EqDec_dec bool_EqDec true true); try congruence.
  destruct (EqDec_dec eqda a0 a); intuition.

  assert (eq_dec (A * bool)).
  unfold eq_dec.
  eapply (EqDec_dec (pair_EqDec _ _)).

  assert (NoDup (filter (fun a0 : A * bool => negb (snd a0)) (intersect H1 (getSupport c1) (getSupport c2)))).
  eapply filter_NoDup.
  eapply filter_NoDup; eapply getSupport_NoDup.

  eapply eqRat_trans.
  symmetry.
  eapply sumList_subset'.
  trivial.
  eapply H2.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  intuition.
  apply filter_In in H3.
  intuition.
  eapply filter_In.
  split.

  eapply in_intersect.
  eapply Permutation_in.
  eapply intersect_comm.
  eapply getSupport_NoDup.
  Focus 2.
  eauto.
  eapply getSupport_NoDup.
  trivial.

  intuition.
  apply filter_In in H3.
  intuition.
  destruct a0.
  simpl in *.
  destruct (EqDec_dec eqda a0 a); subst.
  rewrite ratMult_1_r.
  destruct b; simpl in *; try discriminate.
  rewrite H0.
  eapply getSupport_not_In_evalDist.
  intuition.
  eapply H4.
  eapply filter_In.
  intuition.
  eapply in_intersect.
  intuition.
  apply ratMult_0_r.

  symmetry.
  eapply eqRat_trans.
  symmetry.
  eapply sumList_subset'.
  trivial.
  eapply H2.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  intuition.
  apply filter_In in H3.
  intuition.
  eapply filter_In.
  split.

  eapply in_intersect.
  eauto.
  trivial.

  intuition.
  apply filter_In in H3.
  intuition.
  destruct a0.
  simpl in *.
  destruct (EqDec_dec eqda a0 a); subst.
  rewrite ratMult_1_r.
  destruct b; simpl in *; try discriminate.
  rewrite <- H0.
  eapply getSupport_not_In_evalDist.
  intuition.
  eapply H4.
  eapply filter_In.
  intuition.
  eapply in_intersect.
  intuition.
  apply ratMult_0_r.

  eapply sumList_body_eq.
  intuition.
  apply filter_In in H3.
  intuition.
  destruct a0; simpl in *.
  destruct b; simpl in *; try discriminate.
  rewrite H0.
  intuition.
Qed.

Theorem evalDist_right_ident : forall (A : Set)(eqd : EqDec A)(c : Comp A) a,
  evalDist (x <-$ c; ret x) a == evalDist c a.

  intuition.
  destruct (in_dec (EqDec_dec eqd) a (getSupport c)).
  simpl.
  eapply eqRat_trans.
  eapply sumList_exactly_one.
  eapply getSupport_NoDup.
  eauto.
  intuition.
  destruct (EqDec_dec eqd b a).
  subst.
  intuition.
  eapply ratMult_0_r.

  destruct (EqDec_dec eqd a a).
  eapply ratMult_1_r.
  congruence.

  simpl.
  eapply eqRat_trans.
  eapply sumList_0.
  intuition.
  destruct (EqDec_dec eqd a0 a).
  subst.
  intuition.
  eapply ratMult_0_r.
  symmetry.
  eapply getSupport_not_In_evalDist.
  trivial.
Qed.

Theorem fundamental_lemma : forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B)(c1 c2 : Comp A)(badness : A -> bool)(proj : A -> B),
  Pr [a <-$ c1; ret (badness a)] == Pr[a <-$ c2; ret (badness a)] ->
  (forall x, evalDist (a <-$ c1; ret (proj a, badness a)) (x, false) == evalDist (a <-$ c2; ret (proj a, badness a)) (x, false)) ->
  forall x,
    | (evalDist (a <-$ c1; ret (proj a)) x)  - (evalDist (a <-$ c2; ret (proj a)) x) | <=
    Pr [a <-$ c1; ret (badness a)].

  intuition.
  specialize (@fundamental_lemma_h B eqdb (a <-$ c1; ret (proj a, badness a)) (a <-$ c2; ret (proj a, badness a)) ); intuition.
  assert ( | evalDist (x <-$ (a0 <-$ c1; ret (proj a0, badness a0)); ret fst x) x -
       evalDist (x <-$ (a0 <-$ c2; ret (proj a0, badness a0)); ret fst x) x | ==
          | evalDist (a <-$ c1; ret proj a) x - evalDist (a <-$ c2; ret proj a) x |).
  eapply ratDistance_eqRat_compat.

  eapply eqRat_trans.
  eapply evalDist_assoc_eq.
  cbv beta.
  eapply eqRat_trans.
  eapply evalDist_seq_eq.
  intuition.
  eapply eqRat_refl.
  intuition.
  eapply eqRat_trans.
  eapply evalDist_left_ident_eq.
  eapply eqRat_refl.
  cbv beta.
  unfold fst.
  intuition.

  eapply eqRat_trans.
  eapply evalDist_assoc_eq.
  cbv beta.
  eapply evalDist_seq_eq; intuition.
  eapply evalDist_left_ident_eq.

  rewrite <- H2.
  rewrite H1.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply eqRat_trans.
  eapply evalDist_assoc_eq.
  cbv beta.
  eapply evalDist_seq_eq; intuition.
  eapply eqRat_refl.
  eapply eqRat_trans.
  eapply evalDist_left_ident_eq.
  cbv beta.
  eapply eqRat_refl.
  cbv beta.
  unfold snd.
  intuition.
  eapply eqRat_trans.
  eapply evalDist_assoc_eq.
  eapply eqRat_trans.
  eapply evalDist_seq_eq; intuition.
  eapply eqRat_refl.
  eapply eqRat_trans.
  eapply evalDist_left_ident_eq.
  cbv beta.
  eapply eqRat_refl.
  rewrite H.
  symmetry.
  eapply eqRat_trans.
  eapply evalDist_assoc_eq.
  eapply eqRat_trans.
  eapply evalDist_seq_eq; intuition.
  eapply eqRat_refl.
  eapply eqRat_trans.
  eapply evalDist_left_ident_eq.
  eapply eqRat_refl.
  cbv beta.

  simpl.
  intuition.
  intuition.
Qed.

Theorem repeat_unroll_eq: forall (A : Set)(eqd : EqDec A)(c : Comp A)(P : A -> bool) v,
  well_formed_comp c ->
  (exists a, In a (filter P (getSupport c))) ->
  evalDist (Repeat c P) v == evalDist (x <-$ c; if (P x) then ret x else (Repeat c P)) v.

  intuition.

  eapply det_eq_impl_dist_sem_eq; trivial.
  destruct H0.

  eapply well_formed_Repeat; trivial.
  unfold eq_dec.
  intuition.
  eapply (EqDec_dec _).
  eauto.
  econstructor; intuition.
  destruct (P b).
  econstructor.
  destruct H0.
  econstructor.
  unfold eq_dec.
  intuition.
  eapply (EqDec_dec _).
  trivial.
  eauto.

  unfold DetSem.evalDet_equiv.
  intuition.
  inversion H1; clear H1; subst.

  inversion H2; clear H2; subst.
  simpl in *.
  eapply evalDet_steps_bind_done_inv in H6.
  destruct H6.
  destruct H1.
  intuition.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  destruct (P x).
  inversion H3; clear H3; subst.
  simpl in *.
  inversion H7; clear H7; subst.
  econstructor.
  eauto.
  simpl.
  econstructor.
  trivial.

  inversion H2; clear H2; subst.
  simpl in *.
  apply evalDet_steps_bind_eof_inv in H6.
  intuition.
  econstructor.
  eapply evalDet_bind_eof.
  trivial.
  destruct H1.
  destruct H1.
  intuition.
  econstructor.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  destruct (P x).
  inversion H3; clear H3; subst.
  simpl in *.
  inversion H7.
  trivial.

  inversion H1; clear H1; subst.
  eapply evalDet_steps_bind_done_inv in H2.
  destruct H2.
  destruct H1.
  intuition.
  econstructor.
  econstructor.
  eauto.
  simpl.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  destruct (P x).
  inversion H3; clear H3; subst.
  simpl in *.
  inversion H7; clear H7; subst.
  econstructor.
  eauto.
  simpl.
  econstructor.
  trivial.

  apply evalDet_steps_bind_eof_inv in H2.
  intuition.
  econstructor.
  econstructor.
  eauto.
  simpl.
  eapply evalDet_bind_eof.
  trivial.
  destruct H1.
  destruct H1.
  intuition.
  econstructor.
  econstructor.
  eauto.
  simpl.
  eapply evalDet_steps_trans.
  eapply evalDet_steps_bind_done.
  eauto.
  destruct (P x).
  inversion H3; clear H3; subst.
  simpl in *.
  inversion H7.
  trivial.
Qed.

(* rules related to case splits and specifications *)
Lemma evalDist_seq_case_split_eq : forall (B : Set)(e : B -> bool) v v1 v2 (A : Set)(c : Comp B)(f : B -> Comp A) a,
  well_formed_comp c ->
  Pr[b <-$ c; ret (e b)] == v ->
  (forall b, (e b) = true -> (evalDist (f b) a) == v1) ->
  (forall b, (e b) = false -> (evalDist (f b) a) == v2) ->
  (evalDist (Bind c f) a == v * v1 + (ratSubtract 1 v) * v2).

  intuition.
  simpl in *.
  rewrite (sumList_partition e).
  eapply ratAdd_eqRat_compat.

  rewrite (sumList_body_eq _ _ (fun b => ((evalDist c b) * (if (e b) then 1 else 0)) * v1)).
  rewrite sumList_factor_constant_r.
  eapply ratMult_eqRat_compat; intuition.
  rewrite <- H0.
  eapply sumList_body_eq; intuition.
  destruct (EqDec_dec bool_EqDec (e a0) true).
  rewrite e0.
  intuition.
  destruct (e a0); try congruence.
  intuition.

  intuition.
  case_eq (e a0); intuition.
  repeat rewrite ratMult_1_r.
  eapply ratMult_eqRat_compat; intuition.
  repeat rewrite ratMult_0_r.
  rewrite ratMult_0_l.
  intuition.

  rewrite (sumList_body_eq _ _ (fun b => ((evalDist c b) * (if (e b) then 0 else 1)) * v2)).
  rewrite sumList_factor_constant_r.
  eapply ratMult_eqRat_compat; intuition.
  rewrite <- H0.

  rewrite <- (@evalDist_lossless _ c).
  rewrite (sumList_partition e _ (evalDist c)).
  rewrite ratAdd_comm.
  rewrite ratSubtract_ratAdd_assoc.
  rewrite ratSubtract_0.
  rewrite <- ratAdd_0_r.
  intuition.
  eapply eqRat_impl_leRat.
  eapply sumList_body_eq; intuition.
  destruct (EqDec_dec bool_EqDec (e a0) true).
  rewrite e0.
  intuition.
  destruct (e a0); try congruence.
  intuition.
  eapply eqRat_impl_leRat.
  eapply sumList_body_eq; intuition.
  destruct (EqDec_dec bool_EqDec (e a0) true).
  rewrite e0.
  intuition.
  destruct (e a0); try congruence.
  intuition.
  trivial.

  intuition.
  case_eq (e a0); intuition.
  repeat rewrite ratMult_0_r.
  rewrite ratMult_0_l.
  intuition.
  repeat rewrite ratMult_1_r.
  eapply ratMult_eqRat_compat; intuition.
Qed.

Theorem evalDist_bind_distance : forall (A B : Set)(c1 c2 : Comp B)(c3 c4 : B -> Comp A) d,
  well_formed_comp c2 ->
  (forall b, evalDist c1 b == evalDist c2 b) ->
  (forall b a, In b (getSupport c1) -> | evalDist (c3 b) a - evalDist (c4 b) a | <= d) ->
  (forall a, | evalDist (Bind c1 c3) a - evalDist (Bind c2 c4) a | <= d).

  intuition.
  simpl.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  rewrite sumList_body_eq.
  Focus 2.
  intros.
  eapply ratMult_eqRat_compat.
  eapply H0.
  eapply eqRat_refl.
  eapply eqRat_refl.

  assert (Permutation (getSupport c1) (getSupport c2)).
  eapply NoDup_Permutation; intuition; eauto using getSupport_NoDup.
  eapply getSupport_In_evalDist.
  rewrite <- H0.
  eapply getSupport_In_evalDist.
  trivial.
  eapply getSupport_In_evalDist.
  rewrite H0.
  eapply getSupport_In_evalDist.
  trivial.
  erewrite sumList_permutation; eauto.

  rewrite sumList_distance_prod.
  eapply leRat_trans.
  eapply sumList_le; intuition.
  eapply ratMult_leRat_compat.
  eapply leRat_refl.
  eapply H1.
  eapply getSupport_In_evalDist.
  rewrite H0.
  eapply getSupport_In_evalDist.
  trivial.

  rewrite sumList_factor_constant_r.
  rewrite evalDist_lossless.
  rewrite ratMult_1_l.
  intuition.
  trivial.

Qed.

Lemma evalDist_Bind_1_le_l : forall (A B : Set) (b : Comp B) (a : B -> Comp A) (y : A) (v : Rat),
  well_formed_comp b ->
  (forall x : B, In x (getSupport b) -> evalDist (a x) y <= v) ->
  evalDist (x <-$ b; a x) y <= v.

  intuition.
  simpl.
  eapply leRat_trans.
  eapply sumList_le; intuition.
  eapply ratMult_leRat_compat.
  eapply leRat_refl.
  eapply H0.
  trivial.
  rewrite sumList_factor_constant_r.
  rewrite evalDist_lossless.
  rewrite ratMult_1_l.
  intuition.
  trivial.
Qed.

Lemma evalDist_ret_1 :
  forall (A : Set)(eqd : eq_dec A)(a1 a2 : A),
    a1 = a2 ->
    evalDist (Ret eqd a1) a2 = 1.

  intuition.
  subst.
  simpl.
  destruct (eqd a2 a2); subst; intuition.

Qed.

Lemma evalDist_ret_0 :
  forall (A : Set)(eqd : eq_dec A)(a1 a2 : A),
    a1 <> a2 ->
    evalDist (Ret eqd a1) a2 = 0.

  intuition.
  simpl.
  destruct (eqd a1 a2); subst; intuition.

Qed.

Lemma evalDist_ret_eq :
  forall (A : Set)(eqd1 eqd2 : eq_dec A) a1 a2 x,
    a1 = a2 ->
    evalDist (Ret eqd1 a1) x == evalDist (Ret eqd2 a2) x.

  intuition.
  simpl.
  subst.
  destruct (eqd1 a2 x); destruct (eqd2 a2 x); subst; intuition.
Qed.

Theorem evalDist_seq_step :
  forall (A B :Set)(c : Comp A)(f : A -> Comp B) b,
    evalDist (Bind c f) b ==
    sumList (getSupport c) (fun a => evalDist c a * evalDist (f a) b).

  intuition.
  simpl.
  eapply sumList_body_eq; intuition.

Qed.

Theorem evalDist_1 :
  forall (A : Set)(eqd : EqDec A)(c : Comp A) a,
    well_formed_comp c ->
    evalDist c a == 1 ->
    (getSupport c) = (a :: nil)%list.

  intuition.

  specialize (evalDist_getSupport_perm_id c (ret a)); intuition.
  assert (forall a0 : A, evalDist c a0 == evalDist (ret a) a0).
  intuition.
  case_eq (eqb a a0); intuition.
  rewrite eqb_leibniz in H2.
  subst.
  simpl.
  destruct (EqDec_dec eqd a0 a0); intuition.

  simpl.
  assert (evalDist c a0 == 0).
  eapply evalDist_1_0; intuition.
  eapply H0.
  subst.
  rewrite eqb_refl in H2.
  discriminate.
  rewrite H3.
  destruct ( EqDec_dec eqd a a0); subst; intuition.
  rewrite eqb_refl in H2.
  discriminate.

  intuition.
  simpl in *.

  eapply Permutation_length_1_inv.
  eapply Permutation_sym.
  trivial.

Qed.

Theorem evalDist_bool_equiv_all :
  forall (c1 c2 : Comp bool),
    well_formed_comp c1 ->
    well_formed_comp c2 ->
    Pr[c1] == Pr[c2] ->
    (forall b, evalDist c1 b == evalDist c2 b).

  intuition.
  destruct b.
  trivial.

  rewrite evalDist_complement.
  rewrite evalDist_complement.
  eapply ratSubtract_eqRat_compat; intuition.
  trivial.
  trivial.
Qed.

Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.

Class RatRel (R : Rat -> Rat -> Prop) :=
{
  refl : forall r1 r2, r1 == r2 -> R r1 r2;
  trans : Transitive R;
  add_proper : Proper (R ==> R ==> R) ratAdd;
  mult_proper : Proper (R ==> R ==> R) ratMult
}.

Instance RatRel_trans :
  forall (R : Rat -> Rat -> Prop),
    RatRel R -> Transitive R.

intuition.
destruct H.
intuition.

Qed.

Instance RatRel_flip :
  forall R,
    RatRel R ->
    RatRel (Basics.flip R).

intuition.
econstructor; intuition.
unfold Basics.flip.
eapply refl.
eapply eqRat_symm.
intuition.

unfold Proper, respectful, Basics.flip in *; intuition.
eapply add_proper; trivial.
unfold Proper, respectful, Basics.flip in *; intuition.
eapply mult_proper; trivial.
Qed.

(* The class includes equality and inequality. *)

Instance eqRat_RatRel : RatRel eqRat.

econstructor;
eauto with typeclass_instances.

Qed.

Instance leRat_RatRel : RatRel leRat.

econstructor;
eauto with typeclass_instances.
eapply eqRat_impl_leRat.

Qed.

(* This one comes up some times: *)
Instance eqRat_RatRel_1 :
  RatRel (fun r r1 : Rat => r1 == r).

eapply RatRel_flip.
intuition.

Qed.

(* some distribution rules that use RatRel *)
Theorem evalDist_left_ident :
  forall rel (B : Set)(eqd : EqDec B)(b : B)(A : Set)(c2 : B -> Comp A) a,
    RatRel rel ->
    rel (evalDist (x <-$ ret b; (c2 x)) a) (evalDist (c2 b) a).

  intuition.
  eapply refl.
  eapply evalDist_left_ident_eq.
Qed.

Theorem evalDist_assoc :
  forall rel (A : Set)(c1 : Comp A)(B C : Set)(c2 : A -> Comp B)(c3 : B -> Comp C) x,
    RatRel rel ->
    rel (evalDist (Bind (Bind c1 c2) c3) x) (evalDist (Bind c1 (fun a => (Bind (c2 a) c3))) x).

  intuition.
  eapply refl.
  eapply evalDist_assoc_eq.

Qed.

Theorem evalDist_commute:
  forall rel  (A B : Set)(c1 : Comp A)(c2 : Comp B)(C : Set)(c3 : A -> B -> Comp C) x,
    RatRel rel ->
    rel (evalDist (a <-$ c1; b <-$ c2; (c3 a b)) x) (evalDist (b <-$ c2; a <-$ c1; (c3 a b)) x).

  intuition.
  eapply refl.
  eapply evalDist_commute_eq.

Qed.

Lemma rel_sumList_compat :
  forall (A : Set)(f1 f2 : A -> Rat) ls rel,
    RatRel rel ->
    (forall a, In a ls -> rel (f1 a) (f2 a)) ->
    rel (sumList ls f1) (sumList ls f2).

  induction ls; intuition; simpl in *.
  unfold sumList; simpl.
  eapply refl.
  intuition.

  eapply trans.
  eapply refl.
  eapply sumList_cons.
  eapply trans.
  Focus 2.
  eapply refl.
  symmetry.
  eapply sumList_cons.
  eapply add_proper.
  intuition.
  eapply IHls; intuition.
Qed.

Lemma rel_seq :
  forall (A B C : Set)(c : Comp A)(f1 : A -> Comp B)(f2 : A -> Comp C) rel x1 x2,
    RatRel rel ->
    (forall a, In a (getSupport c) -> rel (evalDist (f1 a) x1) (evalDist (f2 a) x2)) ->
    rel (evalDist (a <-$ c; f1 a) x1) (evalDist (a <-$ c; f2 a) x2).

  intuition.
  simpl.
  eapply rel_sumList_compat; intuition.
  eapply mult_proper.
  eapply refl.
  intuition.
  intuition.
Qed.

Lemma evalDist_bind_case_split :
  forall rel (B : Set)(e : B -> bool) v v1 v2 (A : Set)(c : Comp B)(f : B -> Comp A)  a,
    RatRel rel ->
    well_formed_comp c ->
    Pr[b <-$ c; ret (e b)] == v ->
    (forall b, (e b) = true -> rel (evalDist (f b) a) v1) ->
    (forall b, (e b) = false -> rel (evalDist (f b) a) v2) ->
    (rel (evalDist (Bind c f) a) (v * v1 + (ratSubtract 1 v) * v2)).

  intuition.
  simpl in *.
  eapply trans.
  eapply refl.
  rewrite (sumList_filter_partition e).
  eapply eqRat_refl.
  eapply add_proper.

  eapply trans.
  eapply (rel_sumList_compat); intuition.
  eapply mult_proper.
  eapply refl.
  eapply eqRat_refl.
  eapply H2.
  eapply filter_In.
  eauto.
  eapply refl.
  rewrite sumList_factor_constant_r.
  eapply ratMult_eqRat_compat; intuition.

  rewrite (sumList_filter_partition e) in H1.
  rewrite <- H1.
  rewrite ratAdd_0_r.
  eapply ratAdd_eqRat_compat.
  eapply sumList_body_eq; intuition.
  rewrite <- ratMult_1_r at 1.
  eapply ratMult_eqRat_compat.
  intuition.
  destruct ( EqDec_dec bool_EqDec (e a0) true); intuition.
  exfalso.
  eapply n.
  eapply filter_In.
  eauto.

  symmetry.
  eapply sumList_0; intuition.
  destruct (EqDec_dec bool_EqDec (e a0) true).
  apply filter_In in H4.
  intuition.
  rewrite e0 in H6.
  simpl in *.
  congruence.
  eapply ratMult_0_r.

  eapply trans.
  eapply (rel_sumList_compat); intuition.
  eapply mult_proper.
  eapply refl.
  eapply eqRat_refl.
  eapply H3.
  eapply filter_In in H4.
  intuition.
  destruct (e a0); intuition.
  eapply refl.
  rewrite sumList_factor_constant_r.
  eapply ratMult_eqRat_compat; intuition.

  rewrite <- H1.
  rewrite <- (@evalDist_lossless _ c); trivial.
  symmetry.
  rewrite (sumList_partition e _ (evalDist c)).
  rewrite ratAdd_comm.
  rewrite ratSubtract_ratAdd_assoc.
  rewrite ratSubtract_0.
  rewrite <- ratAdd_0_r.

  rewrite (sumList_filter_partition e).
  symmetry.
  rewrite ratAdd_0_l.
  eapply ratAdd_eqRat_compat.
  symmetry.
  eapply sumList_0; intuition.
  apply filter_In in H4.
  intuition.
  rewrite H6.
  eapply ratMult_0_r.
  eapply sumList_body_eq; intuition.
  apply filter_In in H4.
  intuition.
  destruct (e a0); simpl in *; try discriminate.
  symmetry.
  eapply ratMult_1_r.
  eapply sumList_le; intuition.
  destruct (EqDec_dec bool_EqDec (e a0) true).
  rewrite e0.
  intuition.
  destruct (e a0); intuition.

  eapply sumList_le; intuition.
  destruct ( EqDec_dec bool_EqDec (e a0) true).
  destruct (e a0); try discriminate.
  intuition.
  destruct (e a0); intuition.
Qed.

Theorem evalDist_irr_l :
  forall (A B : Set)(c : Comp A)(f : A -> Comp B)(y : B) rel v,
    RatRel rel ->
    well_formed_comp c ->
    (forall x, In x (getSupport c) -> rel (evalDist (f x) y) v) ->
    rel (evalDist (Bind c f) y) v.

  intuition.
  simpl.
  eapply trans.
  eapply rel_sumList_compat;
  intuition.
  eapply mult_proper.
  eapply refl.
  eapply eqRat_refl.
  eapply H1.
  trivial.

  Lemma rel_sumList_factor_r :
    forall (A : Set) (f : A -> Rat) (ls : list A) c rel,
      RatRel rel ->
      rel (sumList ls (fun a => (f a) * c)) ((sumList ls f) * c).

    induction ls; intuition; simpl in *.
    unfold sumList; simpl.
    eapply refl.
    symmetry.
    eapply ratMult_0_l.

    eapply trans.
    eapply refl.
    eapply sumList_cons.
    eapply trans.
    Focus 2.
    eapply refl.
    symmetry.
    eapply eqRat_trans.
    eapply ratMult_eqRat_compat.
    eapply sumList_cons.
    eapply eqRat_refl.
    eapply ratMult_distrib_r.
    eapply add_proper.
    eapply refl.
    intuition.
    eapply IHls; intuition.
  Qed.

  specialize (rel_sumList_factor_r (evalDist c) (getSupport c) v H); intuition.

  eapply trans.
  eapply H2.
  eapply refl.
  rewrite evalDist_lossless.
  eapply ratMult_1_l.
  trivial.
Qed.

Theorem evalDist_irr_r :
  forall (A B : Set)(c : Comp A)(f : A -> Comp B)(y : B) rel v,
    RatRel rel ->
    well_formed_comp c ->
    (forall x, In x (getSupport c) -> rel v (evalDist (f x) y)) ->
    rel v (evalDist (Bind c f) y).

  intuition.
  simpl.
  eapply trans.
  Focus 2.
  eapply rel_sumList_compat;
  intuition.
  eapply mult_proper.
  eapply refl.
  eapply eqRat_refl.
  eapply H1.
  trivial.

  Lemma rel_sumList_factor_r_r :
    forall (A : Set) (f : A -> Rat) (ls : list A) c rel,
      RatRel rel ->
      rel ((sumList ls f) * c) (sumList ls (fun a => (f a) * c)).

    induction ls; intuition; simpl in *.
    unfold sumList; simpl.
    eapply refl.
    eapply ratMult_0_l.

    eapply trans.
    eapply refl.
    eapply eqRat_trans.
    eapply ratMult_eqRat_compat.
    eapply sumList_cons.
    eapply eqRat_refl.
    eapply ratMult_distrib_r.

    eapply trans.
    Focus 2.
    eapply refl.
    symmetry.
    eapply sumList_cons.
    simpl.
    eapply add_proper.
    eapply refl.
    intuition.
    eapply IHls; intuition.
  Qed.

  specialize (rel_sumList_factor_r_r (evalDist c) (getSupport c) v H); intuition.

  eapply trans.
  Focus 2.
  eapply H2.
  eapply refl.
  rewrite evalDist_lossless.
  symmetry.
  eapply ratMult_1_l.
  trivial.
Qed.

Theorem evalDist_iso :
  forall rel (A B C D : Set) (f : C -> D) (f_inv : D -> C)
    (d : Comp D) (c : Comp C) (f1 : D -> Comp B)
    (f2 : C -> Comp A) (a : A) (b : B),
    RatRel rel ->
    (forall x : D, In x (getSupport d) -> f (f_inv x) = x) ->
    (forall x : C, In x (getSupport c) -> f_inv (f x) = x) ->
    (forall x : D, In x (getSupport d) -> In (f_inv x) (getSupport c)) ->
    (forall x : C, In x (getSupport c) -> evalDist d (f x) == evalDist c x) ->
    (forall x : C,
      In x (getSupport c) -> rel (evalDist (f1 (f x)) b) (evalDist (f2 x) a)) ->
    rel (evalDist (x <-$ d; f1 x) b) (evalDist (x <-$ c; f2 x) a).

  intuition.
  eapply trans.
  eapply refl.
  eapply (distro_iso_eq); intros.
  eapply H0.
  trivial.
  eapply H1.
  eauto.
  eapply H2.
  eauto.

  eapply H3.
  trivial.
  eapply eqRat_refl.

  eapply rel_seq;
  intuition.

Qed.

Theorem evalDist_seq :
forall rel (A1 A2 B : Set) (c1 c2 : Comp B) (f1 : B -> Comp A1)(f2 : B -> Comp A2) y z,
  RatRel rel ->
  (forall x : B, evalDist c1 x == evalDist c2 x) ->
  (forall x : B,
    In x (getSupport c1) -> rel (evalDist (f1 x) y) (evalDist (f2 x) z)) ->
  rel (evalDist (x <-$ c1; f1 x) y) (evalDist (x <-$ c2; f2 x) z).

  intuition.
  eapply (evalDist_iso (fun b => b)(fun b => b)); intuition.

  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  eauto.
  rewrite H0.
  trivial.
  eapply H1.
  eapply getSupport_In_evalDist.
  intuition.
  eapply getSupport_In_evalDist.
  eauto.
  rewrite <- H0.
  trivial.

Qed.

Theorem oc_comp_invariant :
  forall (A B C : Set)(c : OracleComp A B C)(S : Set)(P : S -> Prop)
    (eqds : EqDec S)
    (o : S -> A -> Comp (B * S))(s : S),
    (forall a b c d, In (a, b) (getSupport (o c d)) -> P c -> P b) ->
      P s ->
      forall a b, In (a, b) (getSupport (c _ _ o s)) -> P b.

  Opaque getSupport.
  induction c; intuition; simpl in *.
  eapply H; eauto.

  Transparent getSupport.
  repeat simp_in_support.
  destruct x.
  simpl in *.

  specialize (IHc (S * S0) (fun x => P (snd x)) _
  (fun (x : S * S0) (y : A) =>
                p <-$ (o (fst x) y) S0 eqds o0 (snd x);
                ret (fst (fst p), (snd (fst p), snd p))) (s, s0))%type.
  eapply IHc; intros.
  Focus 3.
  eapply H3.
  repeat simp_in_support.
  simpl.
  destruct c1.
  destruct x.
  eapply H.
  eapply H0.
  eapply H4.
  eapply H5.
  trivial.

  repeat simp_in_support.
  trivial.

  repeat simp_in_support.
  destruct x.
  eapply H.
  eapply H0.
  eapply IHc.
  eapply H0.
  eapply H1.
  eauto.
  eauto.
Qed.

Theorem oc_comp_invariant_f :
  forall (A B C : Set)(c : OracleComp A B C)(S : Set)(f : S -> bool)
    (eqds : EqDec S)
    (o : S -> A -> Comp (B * S))(s : S),
    (forall a b c d, In (a, b) (getSupport (o c d)) -> f c = true -> f b = true) ->
    f s = true ->
    forall a b, In (a, b) (getSupport (c _ _ o s)) -> f b = true.

  intuition.
  eapply (@oc_comp_invariant _ _ _ _ _ (fun x => f x = true)); intuition.
  eapply H.
  eapply H2.
  eapply H3.
  eapply H0.
  eapply H1.
Qed.

Theorem distro_irr_le
     : forall (A B : Set) (c : Comp A) (f : A -> Comp B)
         (y : B) (v : Rat),
       (forall x : A, In x (getSupport c) -> (evalDist (f x) y) <=  v) ->
       (evalDist (x <-$ c; f x) y)  <= v.

  intuition.
  simpl.
  rewrite sumList_le.
  Focus 2.
  intuition.
  rewrite H at 1.
  eapply leRat_refl.
  trivial.
  rewrite sumList_factor_constant_r.
  eapply leRat_trans.
  eapply ratMult_leRat_compat.
  eapply evalDist_sum_le_1.
  eapply leRat_refl.
  rewrite ratMult_1_l.
  intuition.
Qed.

Theorem oc_comp_wf :
  forall (A B C : Set)(c : OracleComp A B C),
    well_formed_oc c ->
    forall (S : Set)(eqds : EqDec S)(o : S -> A -> Comp (B * S))(s : S),
      (forall a b, well_formed_comp (o a b)) ->
      well_formed_comp (c _ _ o s).

  induction 1; intuition; simpl in *; intuition.
  eapply well_formed_Bind; intuition.

  eapply IHwell_formed_oc; intuition.
  eapply well_formed_Bind; intuition.
  eapply well_formed_Ret.
  eapply well_formed_Ret.

  eapply well_formed_Bind; intuition.
  eapply well_formed_Ret.

  eapply well_formed_Bind; intuition.
  destruct b.
  eauto.

Qed.

Theorem repeat_fission :
  forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B)(c : Comp A)(P : A -> bool)(f : A -> Comp B) x,
    well_formed_comp c ->
    (exists a, In a (filter P (getSupport c))) ->
    (forall a, In a (getSupport c) -> well_formed_comp (f a)) ->
    evalDist (a <-$ Repeat c P; b <-$ f a; ret (a, b)) x ==
    evalDist
      (Repeat (a <-$ c; b <-$ f a; ret (a, b)) (fun p => P (fst p))) x.

  intuition.

  case_eq (P a); intuition.

  simpl.
  symmetry.
  rewrite <- sumList_factor_constant_l.

  symmetry.
  rewrite (@sumList_subset' A (EqDec_dec _ ) _ (getSupport c)).

  eapply sumList_body_eq; intuition.
  unfold indicator.
  simpl.
  rewrite H2.
  case_eq (P a0); intuition.
  repeat rewrite ratMult_1_l.
  rewrite <- ratMult_assoc.
  eapply ratMult_eqRat_compat; intuition.
  eapply ratMult_eqRat_compat; intuition.
  eapply ratInverse_eqRat_compat.
  eapply sumList_nz.
  econstructor; intuition.
  eapply filter_In; intuition; eauto.
  eapply getSupport_In_evalDist;
  eauto.

  symmetry.

  assert ((getUnique
           (flatten
              (map
                 (fun b0 : A =>
                  getUnique
                    (flatten
                       (map (fun b1 : B => (b0, b1) :: nil)
                          (getSupport (f b0))))
                    (bind_eq_dec (f b0) (fun b1 : B => ret (b0, b1))))
                 (getSupport c)))
           (bind_eq_dec c (fun a1 : A => b0 <-$ f a1; ret (a1, b0)))) =
           (flatten
              (map
                 (fun b0 : A =>
                    (map (fun b1 : B => (b0, b1))
                         (getSupport (f b0))))
                 (getSupport c)))).

  rewrite DetSem.getUnique_NoDup_eq.
  f_equal.
  eapply map_ext; intuition.

  rewrite flatten_map_eq.
  rewrite DetSem.getUnique_NoDup_eq.
  intuition.

  eapply map_NoDup; intuition.
  assert (snd (a1, a2) = a2).
  trivial.
  eauto.
  eapply getSupport_NoDup.

  eapply flatten_NoDup;
    intuition.

  eapply map_NoDup'; intuition.
  eapply getSupport_NoDup.

  repeat rewrite flatten_map_eq in *.

  edestruct (@well_formed_val_exists _ (f a1)).
  intuition.

  eapply (getUnique_eq_inv (a1, x)) in H8.
  apply in_map_iff in H8.
  destruct H8.
  intuition.
  pairInv.
  intuition.
  eapply in_map_iff.
  econstructor.
  intuition.

  apply in_map_iff in H5.
  destruct H5.
  intuition.
  subst.
  eapply getUnique_NoDup.

  eapply in_map_iff in H5.
  destruct H5.
  intuition.
  eapply in_map_iff in H6.
  destruct H6.
  intuition.
  subst.
  repeat rewrite flatten_map_eq in *.
  eapply app_NoDup; intuition.
  eapply getUnique_NoDup.
  eapply getUnique_NoDup.

  apply in_getUnique_if in H5.
  apply in_getUnique_if in H6.
  apply in_map_iff in H5.
  apply in_map_iff in H6.
  destruct H5.
  destruct H6.
  intuition.
  subst.
  pairInv.
  intuition.

  apply in_getUnique_if in H5.
  apply in_getUnique_if in H6.
  apply in_map_iff in H5.
  apply in_map_iff in H6.
  destruct H5.
  destruct H6.
  intuition.
  subst.
  pairInv.
  intuition.

  rewrite H5.
  clear H5.

  rewrite sumList_filter_twice.
  eapply sumList_body_eq; intuition.
  apply filter_In in H5; intuition.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  rewrite (@sumList_exactly_one _ a1) at 1.
  eapply eqRat_refl.
  eapply getSupport_NoDup.
  intuition.
  intuition.
  eapply eqRat_trans.
  eapply ratMult_eqRat_compat.
  eapply eqRat_refl.
  eapply sumList_0; intuition.
  destruct (EqDec_dec (pair_EqDec eqda eqdb) (b0, a3) (a1, a2)).
  pairInv.
  intuition.
  eapply ratMult_0_r.
  eapply ratMult_0_r.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  eapply ratMult_eqRat_compat.
  eapply eqRat_refl.
  eapply (@sumList_exactly_one _ a2); intuition.
  eapply getSupport_NoDup.
  destruct (EqDec_dec (pair_EqDec eqda eqdb) (a1, b0) (a1, a2)).
  pairInv.
  intuition.
  eapply ratMult_0_r.

  rewrite sumList_factor_constant_l.
  symmetry.
  rewrite <- ratMult_1_r at 1.
  eapply ratMult_eqRat_compat; intuition.
  symmetry.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  destruct (EqDec_dec (pair_EqDec eqda eqdb) (a1, a2) (a1, a2)).
  eapply ratMult_1_r.
  congruence.
  eapply evalDist_lossless.
  intuition.

  repeat rewrite ratMult_0_l.
  symmetry.
  rewrite ratMult_1_l.
  eapply eqRat_trans.
  eapply ratMult_eqRat_compat.
  eapply eqRat_refl.
  eapply ratMult_eqRat_compat.
  eapply eqRat_refl.
  eapply sumList_0; intuition.
  destruct (EqDec_dec (pair_EqDec eqda eqdb) (a0, a1) (a, b)).
  pairInv.
  congruence.
  eapply ratMult_0_r.
  repeat rewrite ratMult_0_r.
  intuition.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  eapply getSupport_NoDup.

  intuition.
  apply filter_In in H3; intuition.

  intuition.
  unfold indicator.
  case_eq (P a0); intuition.
  exfalso.
  eapply H4.
  eapply filter_In; intuition.
  repeat rewrite ratMult_0_l.
  intuition.

  destruct H0.
  eapply evalDist_irr_l; intuition.
  eapply well_formed_Repeat.
  unfold eq_dec; intuition.
  eapply (EqDec_dec _).
  trivial.
  eauto.

  eapply evalDist_irr_l; intuition.
  simpl in *.
  apply filter_In in H3.
  intuition.

  simpl in *.
  apply filter_In in H3.
  intuition.
  destruct (EqDec_dec (pair_EqDec eqda eqdb) (x0, x1) (a, b)).
  pairInv.
  congruence.

  unfold indicator.
  simpl.
  rewrite H2.
  repeat rewrite ratMult_0_l.
  intuition.
Qed.

Lemma evalDistRepeat_sup_0 :
  forall (A : Set)(c : Comp A)(P : A -> bool) x,
    evalDist c x == 0 ->
    evalDist (Repeat c P) x == 0.

  intuition.
  simpl.
  rewrite H.
  rewrite ratMult_0_r.
  intuition.

Qed.

Lemma evalDistRepeat_pred_0 :
  forall (A : Set)(c : Comp A)(P : A -> bool) x,
    P x = false ->
    evalDist (Repeat c P) x == 0.

  intuition.
  simpl.
  unfold indicator.
  rewrite H.
  repeat rewrite ratMult_0_l.
  intuition.

Qed.

Theorem repeat_snd_equiv :
  forall (A B : Set)(eqd : EqDec B)(c : Comp (A * B))(P : B -> bool) x,
    evalDist (p <-$ Repeat c (fun p => P (snd p)); ret (snd p)) x ==
    evalDist (Repeat (p <-$ c; ret (snd p)) P) x.

  intuition.

  simpl.
  case_eq (P x); intuition.

  unfold indicator.
  rewrite H.
  rewrite ratMult_1_l.
  rewrite <- sumList_factor_constant_l.

  symmetry.
  rewrite (sumList_filter_partition (fun p : A * B => P (snd p))).
  symmetry.
  rewrite ratAdd_0_r.
  eapply ratAdd_eqRat_compat.
  eapply sumList_body_eq; intuition.
  apply filter_In in H0; intuition.
  rewrite H2.
  destruct (EqDec_dec eqd (snd a) x).
  rewrite ratMult_1_l.
  repeat rewrite ratMult_1_r.
  eapply ratMult_eqRat_compat; intuition.

  rewrite flatten_map_eq.
  eapply ratInverse_eqRat_compat.
  intuition.
  destruct a.
  simpl in *.
  subst.
  eapply sumList_nz; eauto.
  exists (a, x).
  intuition.
  eapply filter_In; intuition.
  eapply getSupport_In_evalDist; eauto.

  rewrite sumList_comm.
  symmetry.
  rewrite (sumList_filter_partition (fun p : A * B => P (snd p))).
  symmetry.
  rewrite ratAdd_0_r.
  eapply ratAdd_eqRat_compat.
  eapply sumList_body_eq; intuition.
  apply filter_In in H0; intuition.
  rewrite sumList_factor_constant_l.
  rewrite <- ratMult_1_r at 1.
  eapply ratMult_eqRat_compat; intuition.
  symmetry.
  destruct a0.
  simpl in *.
  rewrite (@sumList_exactly_one _ b).
  destruct (EqDec_dec eqd b b); intuition.
  eapply filter_NoDup.
  eapply getUnique_NoDup.
  eapply filter_In; intuition.
  eapply in_getUnique.
  eapply in_map_iff.
  econstructor. split; eauto.
  simpl.
  trivial.

  intuition.
  destruct (EqDec_dec eqd b b0); subst; intuition.

  symmetry.
  eapply sumList_0.
  intuition.
  eapply sumList_0; intuition.
  apply filter_In in H3; intuition.
  apply filter_In in H0; intuition.
  destruct a0.
  simpl in *.
  destruct (EqDec_dec eqd b a1); subst.
  destruct (P a1); simpl in *; discriminate.
  eapply ratMult_0_r.

  repeat rewrite ratMult_0_r.
  intuition.

  symmetry.
  eapply sumList_0; intuition.
  eapply filter_In in H0; intuition.
  destruct (EqDec_dec eqd (snd a) x); subst.
  destruct (P (snd a)); simpl in *; discriminate.

  repeat rewrite ratMult_0_r.
  intuition.

  unfold indicator.
  rewrite H.
  repeat rewrite ratMult_0_l.
  eapply sumList_0; intuition.
  apply filter_In in H0.
  intuition.
  rewrite H2.
  rewrite ratMult_1_l.
  destruct a.
  simpl in *.
  destruct (EqDec_dec eqd b x); subst; try congruence.
  rewrite ratMult_0_r.
  intuition.

Qed.

Theorem repeat_fst_equiv :
  forall (A B : Set)(eqd : EqDec A)(c : Comp (A * B))(P : A -> bool) x,
    evalDist (p <-$ Repeat c (fun p => P (fst p)); ret (fst p)) x ==
    evalDist (Repeat (p <-$ c; ret (fst p)) P) x.

  intuition.

  simpl.
  case_eq (P x); intuition.

  unfold indicator.
  rewrite H.
  rewrite ratMult_1_l.
  rewrite <- sumList_factor_constant_l.

  symmetry.
  rewrite (sumList_filter_partition (fun p : A * B => P (fst p))).
  symmetry.
  rewrite ratAdd_0_r.
  eapply ratAdd_eqRat_compat.
  eapply sumList_body_eq; intuition.
  apply filter_In in H0; intuition.
  rewrite H2.
  destruct (EqDec_dec eqd (fst a) x).
  rewrite ratMult_1_l.
  repeat rewrite ratMult_1_r.
  eapply ratMult_eqRat_compat; intuition.

  rewrite flatten_map_eq.
  eapply ratInverse_eqRat_compat.
  intuition.
  destruct a.
  simpl in *.
  subst.
  eapply sumList_nz; eauto.
  exists (x, b).
  intuition.
  eapply filter_In; intuition.
  eapply getSupport_In_evalDist; eauto.

  rewrite sumList_comm.
  symmetry.
  rewrite (sumList_filter_partition (fun p : A * B => P (fst p))).
  symmetry.
  rewrite ratAdd_0_r.
  eapply ratAdd_eqRat_compat.
  eapply sumList_body_eq; intuition.
  apply filter_In in H0; intuition.
  rewrite sumList_factor_constant_l.
  rewrite <- ratMult_1_r at 1.
  eapply ratMult_eqRat_compat; intuition.
  symmetry.
  destruct a0.
  simpl in *.
  rewrite (@sumList_exactly_one _ a0).
  destruct (EqDec_dec eqd a0 a0); intuition.
  eapply filter_NoDup.
  eapply getUnique_NoDup.
  eapply filter_In; intuition.
  eapply in_getUnique.
  eapply in_map_iff.
  econstructor. split; eauto.
  simpl.
  trivial.

  intuition.
  destruct (EqDec_dec eqd a0 b0); subst; intuition.

  symmetry.
  eapply sumList_0.
  intuition.
  eapply sumList_0; intuition.
  apply filter_In in H3; intuition.
  apply filter_In in H0; intuition.
  destruct a0.
  simpl in *.
  destruct (EqDec_dec eqd a0 a1); subst.
  destruct (P a1); simpl in *; discriminate.
  eapply ratMult_0_r.

  repeat rewrite ratMult_0_r.
  intuition.

  symmetry.
  eapply sumList_0; intuition.
  eapply filter_In in H0; intuition.
  destruct (EqDec_dec eqd (fst a) x); subst.
  destruct (P (fst a)); simpl in *; discriminate.

  repeat rewrite ratMult_0_r.
  intuition.

  unfold indicator.
  rewrite H.
  repeat rewrite ratMult_0_l.
  eapply sumList_0; intuition.
  apply filter_In in H0.
  intuition.
  rewrite H2.
  rewrite ratMult_1_l.
  destruct a.
  simpl in *.
  destruct (EqDec_dec eqd a x); subst; try congruence.
  rewrite ratMult_0_r.
  intuition.

Qed.

Theorem repeat_fission' :
  forall (A B : Set)(eqda : EqDec A)(eqdb : EqDec B)(c : Comp A)(P1 : A -> bool)(P2 : B -> bool)(f : A -> Comp B) x,
    well_formed_comp c ->
    (exists a, In a (filter P1 (getSupport c))) ->
    (forall a, In a (getSupport c) -> well_formed_comp (f a)) ->
    (forall a b, In a (getSupport c) -> In b (getSupport (f a)) -> (P1 a = P2 b)) ->
    evalDist (a <-$ Repeat c P1; f a) x ==
    evalDist
      (Repeat (a <-$ c; f a) P2) x.

  intuition.

  assert (evalDist (a <-$ Repeat c P1; f a) x  ==
          evalDist (z <-$ (a <-$ Repeat c P1; b <-$ f a; ret (a, b)); ret (snd z)) x).

  rewrite evalDist_assoc.
  eapply evalDist_seq_eq; intuition.
  rewrite evalDist_assoc.
  rewrite <- evalDist_right_ident.
  eapply evalDist_seq_eq; intuition.
  rewrite evalDist_left_ident.
  simpl.
  reflexivity.
  intuition.
  intuition.
  intuition.

  rewrite H3.
  clear H3.

  assert (evalDist (z <-$ (a <-$ Repeat c P1; b <-$ f a; ret (a, b)); ret snd z) x ==
          evalDist (z <-$ (Repeat (a <-$ c; b <-$ f a; ret (a, b)) (fun p => P1 (fst p))); ret snd z) x).

  eapply evalDist_seq_eq; intuition.
  eapply repeat_fission; intuition.
  rewrite H3.
  clear H3.

  assert (evalDist
     (z <-$
      Repeat (a <-$ c; b <-$ f a; ret (a, b)) (fun p : A * B => P1 (fst p));
      ret snd z) x ==
          evalDist
     (z <-$
      Repeat (a <-$ c; b <-$ f a; ret (a, b)) (fun p : A * B => P2 (snd p));
      ret snd z) x).

  eapply evalDist_seq_eq; intuition.
  destruct (in_dec (EqDec_dec _ ) a (getSupport c)).
  destruct (in_dec (EqDec_dec _) b (getSupport (f a))).
  case_eq (P1 a); intuition.

  eapply evalDist_Repeat_eq; intuition.
  eapply filter_In; intuition.
  eapply getSupport_In_Seq; eauto.
  eapply getSupport_In_Seq; eauto.
  simpl; intuition.

  eapply sumList_permutation.
  eapply NoDup_Permutation; intuition.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  eapply filter_NoDup.
  eapply getSupport_NoDup.

  apply filter_In in H4.
  intuition.
  repeat simp_in_support.
  eapply filter_In; intuition.
  eapply getSupport_In_Seq; eauto.
  eapply getSupport_In_Seq; eauto.
  simpl.
  intuition.
  simpl in *.
  erewrite <- H2; eauto.

  apply filter_In in H4.
  intuition.
  repeat simp_in_support.
  eapply filter_In; intuition.
  eapply getSupport_In_Seq; eauto.
  eapply getSupport_In_Seq; eauto.
  simpl.
  intuition.
  simpl in *.
  erewrite H2; eauto.

  assert (P2 b = false).
  erewrite <- H2; eauto.

  repeat rewrite evalDistRepeat_pred_0; intuition.

  repeat rewrite evalDistRepeat_sup_0; intuition;
  eapply getSupport_not_In_evalDist; intuition;
  repeat simp_in_support; intuition.

  repeat rewrite evalDistRepeat_sup_0; intuition;
  eapply getSupport_not_In_evalDist; intuition;
  repeat simp_in_support; intuition.

  rewrite H3.
  clear H3.

  rewrite repeat_snd_equiv.

  (* The following fact comes up a couple times. *)
  assert (forall a,
             evalDist (p <-$ (a0 <-$ c; b <-$ f a0; ret (a0, b)); ret snd p) a ==
   evalDist (a0 <-$ c; f a0) a).
  intuition.
  rewrite evalDist_assoc; intuition.
  eapply evalDist_seq_eq; intuition.
  rewrite evalDist_assoc; intuition.
  symmetry.
  rewrite <- evalDist_right_ident.
  eapply evalDist_seq_eq; intuition.
  rewrite evalDist_left_ident; intuition.
  simpl.
  reflexivity.

  case_eq (P2 x); intuition.
  destruct (in_dec (EqDec_dec _) x (getSupport (Bind c f))).
  eapply evalDist_Repeat_eq; intuition.

  eapply filter_In; intuition.
  repeat simp_in_support.
  eapply getSupport_In_Seq.
  eapply getSupport_In_Seq; eauto.
  eapply getSupport_In_Seq; eauto.
  simpl.
  intuition.
  simpl.
  intuition.

  rewrite sumList_permutation.
  Focus 2.
  eapply (evalDist_getSupport_filter_perm _ (a <-$ c; f a)); intuition.

  eapply sumList_body_eq; intuition.

  repeat rewrite evalDistRepeat_sup_0; intuition;
  eapply getSupport_not_In_evalDist; intuition;
  repeat simp_in_support; intuition.
  eapply n.
  eapply getSupport_In_Seq; eauto.

  repeat rewrite evalDistRepeat_pred_0; intuition.
Qed.

Theorem prob_or_le_sum :
  forall (c1 c2 : Comp bool),
    Pr[x1 <-$ c1;
        x2 <-$ c2;
        ret (x1 || x2)] <= Pr[c1] + Pr[c2].

  intuition.
  Local Transparent evalDist.
  simpl.
  rewrite (sumList_partition (fun x => x)).
  eapply ratAdd_leRat_compat.

  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  eapply evalDist_right_ident.
  simpl.
  eapply sumList_le.
  intuition.
  destruct a; simpl.
  destruct (EqDec_dec bool_EqDec true true).
  rewrite ratMult_1_r.
  eapply ratMult_leRat_compat; intuition.
  eapply leRat_trans.
  eapply sumList_le.
  intros.
  eapply eqRat_impl_leRat.
  eapply ratMult_1_r.
  eapply evalDist_sum_le_1.

  intuition.

  rewrite ratMult_0_r.
  eapply rat0_le_all.

  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  eapply evalDist_right_ident.
  simpl.
  eapply leRat_trans.
  eapply sumList_le.
  intros.
  eapply eqRat_impl_leRat.
  eapply eqRat_trans.
  eapply ratMult_eqRat_compat.
  symmetry.
  eapply sumList_factor_constant_l.
  reflexivity.
  symmetry.
  eapply sumList_factor_constant_r.
  rewrite sumList_summation.
  eapply sumList_le.
  intuition.
  destruct a.
  destruct (EqDec_dec bool_EqDec true true); intuition.

  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply sumList_body_eq.
  intros.
  rewrite orb_true_r.
  destruct ( EqDec_dec bool_EqDec true true).
  rewrite ratMult_1_r at 1.
  rewrite ratMult_assoc at 1.
  rewrite ratMult_comm at 1.
  eapply ratMult_assoc.
  intuition.
  rewrite sumList_factor_constant_l.
  eapply ratMult_leRat_compat.
  intuition.
  eapply leRat_trans.
  eapply sumList_le.
  intros.
  assert ( (if a then 0 else 1) * evalDist c1 a <= evalDist c1 a).
  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  eapply ratMult_1_l.
  eapply ratMult_leRat_compat.
  destruct a;
    intuition.
  reflexivity.
  eapply H1.
  eapply evalDist_sum_le_1.

  destruct ( EqDec_dec bool_EqDec false true).
  discriminate.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply sumList_0.
  intuition.
  destruct a; simpl.
  repeat rewrite ratMult_0_r.
  intuition.
  destruct (EqDec_dec bool_EqDec false true ); try discriminate.
  repeat rewrite ratMult_0_r.
  eapply ratMult_0_l.

  eapply rat0_le_all.
Qed.

Theorem evalDist_orb_le :
  forall (A : Set)(c : Comp A) f1 f2,
    Pr [x <-$ c; ret (f1 x || f2 x)] <=
    Pr[ x <-$ c; ret (f1 x)] + Pr[x <-$ c; ret (f2 x)].

  intuition.
  simpl.
  rewrite (sumList_partition f1).
  eapply ratAdd_leRat_compat.

  eapply sumList_le.
  intuition.
  rewrite ratMult_assoc.
  eapply ratMult_leRat_compat; intuition.
  destruct (f1 a); simpl.
  rewrite ratMult_1_r.
  reflexivity.
  rewrite ratMult_0_r.
  eapply rat0_le_all.

  eapply sumList_le.
  intuition.
  rewrite ratMult_assoc.
  eapply ratMult_leRat_compat; intuition.
  destruct (f1 a); simpl.
  rewrite ratMult_0_r.
  eapply rat0_le_all.
  rewrite ratMult_1_r.
  reflexivity.

Qed.


(** This file considers spaces of the form Q -> A where Q is countable.
    Given an enumeration of Q it defines a metric and proves that the
    notions of continuity for functions on Baire space and functions
    of the constructed metric space coincide. **)
From mathcomp Require Import all_ssreflect.
From metric Require Import reals metric standard.
From Coquelicot Require Import Coquelicot.
Require Import all_count all_cont baire iseg classical_cont classical_count seq_cont.
Require Import Reals Psatz.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope metric_scope.
Local Open Scope baire_scope.

Section baire_metric.
  Context Q (cnt: nat -> Q).
  Hypothesis sur: cnt \is_surjective.
  Context (A: eqType).
  Notation B := (Q -> A).
  Implicit Types (phi psi: B).

  Lemma coin_has phi psi n: phi \and psi \coincide_on (iseg cnt n) <->
                            ~~ has (fun i => phi (cnt i) != psi (cnt i)) (init_seg n).
  Proof.
    elim: n => // n ih /=.
    rewrite ih.
    split => [[eq /negP hs'] | /orP hs].
    - by apply/negP => /orP [/negP neq| hs]; [apply/neq/eqP | apply/hs'].
    split; first by apply/eqP/negP => neq; apply/hs; left; apply/negP.
    by apply/negP => hs'; apply/hs; right.
  Qed.

  Lemma inP (T: eqType) q (L: seq T): reflect (List.In q L) (q \in L).
  Proof.
    elim: L => [ | t L ih]; first by apply/ReflectF.
    case E: (q \in t :: L).
    - rewrite seq.inE in E.
      by apply/ReflectT; case/orP: E => [/eqP -> | /ih ]; [left | right].
    apply/ReflectF => [/= [eq | lstn]]; suff: false by trivial.
    - by rewrite -E seq.inE; apply/orP; left; rewrite eq.
    by rewrite -E seq.inE; apply/orP; right; apply/ih.
  Qed.

  Definition baire_val_seq phipsi n :=
    search (fun i => (phipsi.1 (cnt i): A) != phipsi.2 (cnt i)) n.

  Lemma bvls_spec phi psi n:
    (forall m, (m < n)%nat -> phi (cnt m) = psi (cnt m)) <->
    baire_val_seq (phi, psi) n = n.
  Proof.
    split => [prp | eq m ineq].
    - rewrite/baire_val_seq /=.
      apply/eqP; rewrite eqn_leq; apply/andP; split; first exact/search_le.
      rewrite leqNgt search_find -{2}(size_iota 0 n) -has_find.
      apply/negP => /hasP [m]; rewrite mem_iota add0n => /andP [_ ineq] /negP prp'.
      exact/prp'/eqP/prp.
    apply/eqP/negP => /negP neq.
    suff: (baire_val_seq (phi, psi) n < n)%nat by rewrite eq => /leP; lia.
    rewrite /baire_val_seq search_find -{2}(size_iota 0 n) -has_find; apply/hasP.
    by exists m => //; rewrite mem_iota add0n; apply/andP.
  Qed.

  Lemma bvls_ext phi psi n:
    (forall m, (m < n)%nat -> phi (cnt m) = psi (cnt m)) ->
    baire_val_seq (phi, psi) n = n.
  Proof. by move => /bvls_spec. Qed.

  Lemma bvls_geq phi psi n: (baire_val_seq (phi, psi) n <= n)%nat.
  Proof. exact/search_le. Qed.

  Lemma bvls_eq_coin phi psi n:
    baire_val_seq (phi, psi) n = n <-> phi \and psi \coincide_on (iseg cnt n).
  Proof.
    rewrite coin_lstn -bvls_spec.
    split => [prp q /lstn_iseg [m [ineq <-]] | prp m ineq]; first exact/prp.
    by apply/prp/lstn_iseg; exists m.
  Qed.

  Lemma coin_bvls phi psi n: phi \and psi \coincide_on (iseg cnt (baire_val_seq (phi, psi) n)).
  Proof.
    elim: n => // n ih.
    rewrite /baire_val_seq searchS.
    case: ifP => // /eqP eq.
    case: ifP => /= [neq | /eqP eq']; first by rewrite -eq; apply/ih.
    by split; last by rewrite -eq; apply/ih.
  Qed.

  Lemma max_min n m: Rmax (/2^n) (/2^m) = /2^(minn n m).
  Proof.
    case E: (n <= m)%nat.
    - have ->:= minn_idPl E.
      by rewrite Rmax_left //; apply/tpmnP/E.
    move: E => /negP/negP.
    rewrite -ltnNge => ineq.
    have ineq': (m <= n)%nat by apply/leq_trans/ineq.
    have ->:= minn_idPr ineq'.
    by rewrite Rmax_right //; apply/tpmnP.
  Qed.

  Lemma search_correct_le (p: pred nat) n m: p m -> (m <= n)%nat -> p (search p n).
  Proof.
    move => pm ineq.
    rewrite -(search_eq pm ineq).
    exact/search_correct.
  Qed.

  Lemma bvls_inc phi psi n m:
    (n <= m)%nat -> (baire_val_seq (phi, psi) n <= baire_val_seq (phi, psi) m)%nat.
  Proof. exact/search_inc. Qed.

  Lemma bvls_lt phi psi i n:
    (i <= n)%nat -> (i < baire_val_seq (phi, psi) n)%nat -> phi (cnt i) = psi (cnt i).
  Proof.
    rewrite ltnNge => iln /negP ineq.
    apply/eqP/negP => /negP neq.
    exact/ineq/search_min.
  Qed.

  Lemma bvls_trngl phi psi psi' n:
     (minn (baire_val_seq (phi, psi') n) (baire_val_seq (psi', psi) n) <= baire_val_seq (phi, psi) n)%nat.
  Proof.
    case eq: (baire_val_seq (phi, psi) n == n).
    - move: eq => /eqP ->.
      by rewrite geq_min; apply/orP; left; apply/bvls_geq.
    move: eq => /eqP neq.
    rewrite leqNgt leq_min; apply/negP => /andP [ineq ineq'].
    pose k := baire_val_seq (phi, psi) n.
    apply/neq.
    rewrite -bvls_spec => m mln.
    apply/eqP/negP => /negP neq'.
    have /negP bvneq: phi (cnt k) != psi (cnt k).
    - apply/(@search_correct_le (fun i => phi (cnt i) != psi (cnt i))).
      apply/neq'.
      exact/leq_trans/mln.
    have eq: phi (cnt k) = psi' (cnt k) by apply/bvls_lt/ineq/search_le.
    have eq': psi' (cnt k) = psi (cnt k) by apply/bvls_lt/ineq'/search_le.
    by apply/bvneq/eqP; rewrite eq eq'.
  Qed.

  Lemma bvls_fchy phi psi: (fun n => /2^(baire_val_seq (phi, psi) n)) \is_fast_Cauchy_sequence.
  Proof.
    pose p i := phi (cnt i) != psi (cnt i).
    apply/cchy_eff_suff => n m ineq.
    have le: 0 <= /2^n by apply/Rlt_le/Rinv_0_lt_compat/pow_lt; lra.
    have le': 0 <= /2^m by apply/Rlt_le/Rinv_0_lt_compat/pow_lt; lra.
    case E:(has p (seq.iota 0%nat n.+1)).
    - move: E => /hasP => [[k]]; rewrite mem_iota add0n => /andP [_ ineq'] neq.
      rewrite /p/d/= Rminus_diag_eq /baire_val_seq; first by split_Rabs; lra.
      do 2 f_equal; rewrite -(search_eq neq); last by apply/leq_trans/ineq'.
      by rewrite -[RHS](search_eq neq) //; apply/leq_trans/ineq/leq_trans/ineq'.
    rewrite /d /= bvls_ext => [ | k ineq']; last first.
    - apply/eqP/negP => neg.
      move: E => /hasP prp; apply/prp; exists k; last exact/negP.
      rewrite mem_iota add0n; apply/andP; split => //.
      by apply/leq_trans; first exact/ineq'.
    case E':(has (fun i => phi (cnt i) != psi (cnt i)) (seq.iota 0%nat m.+1)); last first.
    - rewrite bvls_ext => [ | k ineq']; first by split_Rabs; lra.
    - apply/eqP/negP => neg.
      move: E' => /hasP prp; apply/prp; exists k; last exact/negP.
      by rewrite mem_iota add0n; apply/andP; split; last by apply/leq_trans; first exact/ineq'.
    suff: (/2 ^ baire_val_seq (phi, psi) m <= /2 ^ n).
    - by have := tpmn_pos n; have := tpmn_pos (baire_val_seq (phi, psi) m); split_Rabs; lra.
    apply/tpmnP; rewrite /baire_val_seq /=.
    rewrite -(@search_fail p n); first exact/search_inc.
    move => k pk; rewrite ltnNge; apply/negP => kln.
    move: E => /hasP [].
    by exists k; first by rewrite mem_iota; apply/andP.
  Qed.

  Lemma bdsq_sym phi psi n: baire_val_seq (phi, psi) n = baire_val_seq (psi, phi) n.
  Proof.
    apply/search_ext => k ineq /=.
    by apply/eqP; case: ifP => /eqP // neg eq; apply/neg.
  Qed.

  Definition mf_baire_distance := make_mf (fun phipsi =>
    efficient_limit (fun n => /2^(baire_val_seq phipsi n))).

  Lemma bdst_sing: mf_baire_distance \is_singlevalued.
  Proof. by move => [phi psi] r r' dst dst'; apply/metric.lim_eff_sing/dst'/dst. Qed.

  Lemma bdst0 phi: mf_baire_distance (phi,phi) 0.
  Proof.
    by move => n; rewrite bvls_ext; first by have:= tpmn_pos n; rewrite /d/=; split_Rabs; lra.
  Qed.

  Lemma bdst_tot: mf_baire_distance \is_total.
  Proof.
    move => [phi psi].
    have /fchy_lim_eff [ | r lmt]:= bvls_fchy phi psi; first exact/R_cmplt.
    by exists r.
  Qed.

  Lemma bdst_sym phi psi: mf_baire_distance (phi, psi) === mf_baire_distance (psi, phi).
  Proof. by split => dst n; rewrite bdsq_sym; apply/dst. Qed.

  Definition baire_distance phi psi := iota (mf_baire_distance (phi,psi)).

  Lemma bdst_spec phi psi: mf_baire_distance (phi, psi) (baire_distance phi psi).
  Proof.
    apply/(iota_correct (mf_baire_distance (phi,psi))).
    have [x val]:= bdst_tot (phi, psi).
    by exists x; split => // x' val'; apply/bdst_sing/val'/val.
  Qed.

  Lemma bdst_val phi psi x: mf_baire_distance (phi, psi) x -> baire_distance phi psi = x.
  Proof. move => dst; exact/bdst_sing/dst/bdst_spec. Qed.

  Lemma bdst_lim phi psi:
    metric.limit (fun n => /2 ^ (baire_val_seq (phi, psi) n)) (baire_distance phi psi).
  Proof. exact/lim_eff_lim/bdst_spec. Qed.

  Lemma dst_pos phi psi: 0 <= baire_distance phi psi.
  Proof.
    apply/lim_pos => [ | n]; first exact/lim_eff_lim/bdst_spec.
    exact/tpmn_pos.
  Qed.

  Lemma dst_sym phi psi: baire_distance phi psi = baire_distance psi phi.
  Proof. exact/bdst_val/bdst_sym/bdst_spec. Qed.

  Lemma dstxx phi: baire_distance phi phi = 0.
  Proof. exact/bdst_val/bdst0. Qed.

  Lemma dst_eq phi psi: baire_distance phi psi = 0 -> phi = psi.
  Proof.
    move => eq.
    apply/functional_extensionality => q.
    have [n <-]:= sur q.
    suff /eqP/bvls_spec prp: baire_val_seq (phi, psi) n.+1 == n.+1 by apply/ prp.
    rewrite eqn_leq; apply/andP; split; first exact/search_le.
    by apply/tpmnP; have := bdst_spec phi psi n.+1; rewrite /d /=; split_Rabs; lra.
  Qed.

  Lemma dst_trngl phi psi psi':
    baire_distance phi psi <= baire_distance phi psi' + baire_distance psi' psi.
  Proof.
    apply/lim_inc; [ | apply/lim_eff_lim/bdst_spec | apply/limD/lim_eff_lim/bdst_spec/lim_eff_lim/bdst_spec].
    move => n; rewrite /pointwise.ptw_op.
    apply/Rle_trans.
    - exact/tpmnP/bvls_trngl.
    rewrite -max_min.
    exact/Rmax_le_Rplus/tpmn_pos/tpmn_pos.
  Qed.

  Lemma search_lt p n: (search p n < n)%nat -> p (search p n).
  Proof.
    rewrite {1}search_find -{2}(size_iota 0 n) -has_find => /hasP [m].
    rewrite mem_iota add0n => /andP [_ mln] pm.
    apply/search_correct_le; first exact/pm.
    by apply/leq_trans/mln.
  Qed.

  Lemma dst_dscrt phi psi n:
    (baire_val_seq (phi, psi) n < n)%nat -> baire_distance phi psi = /2^(baire_val_seq (phi, psi) n).
  Proof.
    move => ineq.
    apply/cond_eq => eps /accf_tpmn [m [g0 mle]].
    apply/Rle_lt_trans/mle.
    have:= bdst_spec phi psi (maxn n m).
    have ->: baire_val_seq (phi, psi) (maxn n m) = baire_val_seq (phi, psi) n.
    - have /=prp:= search_lt ineq.
      rewrite /baire_val_seq/= -(search_eq _ (bvls_geq phi psi n)) //.
      have ineq': (baire_val_seq (phi, psi) n <= maxn n m)%nat by apply/leq_trans/leq_maxl/leq_trans/ineq.
      rewrite -(search_eq _ ineq') //.
    have /tpmnP:= leq_maxr n m.
    rewrite /d /baire_val_seq /=; lra.
  Qed.

  Lemma dst_coin phi psi n: baire_distance phi psi <= /2^n <->
                            phi \and psi \coincide_on (iseg cnt n).
  Proof.
    case lt: (baire_val_seq (phi, psi) n < n)%nat.
    - have ->:= dst_dscrt lt.
      split => [/tpmnP | /bvls_eq_coin coin]; first by rewrite leqNgt lt.
      by apply/tpmnP; rewrite coin.
    move: lt; rewrite ltnNge => /leP/leP ineq.
    have eq: baire_val_seq (phi, psi) n = n.
    - by apply/eqP; rewrite eqn_leq; apply/andP; split; first exact/bvls_geq.
    split => [dst | coin]; first exact/bvls_eq_coin.
    apply/cond_leq => eps /accf_tpmn [m [_ mle]].
    have:= bdst_spec phi psi (maxn n m.+1).
    rewrite /d/= => ineq'.
    have leq: baire_distance phi psi <= /2^baire_val_seq (phi, psi) (maxn n m.+1) + /2^maxn n m.+1.
    - by split_Rabs; lra.
    apply/Rle_trans; first exact/leq.
    apply/Rplus_le_compat; first by apply/tpmnP; rewrite -{1}eq; apply/search_inc/leq_maxl.
    apply/Rle_trans/Rlt_le/mle.
    exact/tpmnP/leq_trans/leq_maxr.
  Qed.

  Definition metric_baire_mixin: MetricSpace.mixin_of B :=
    MetricSpace.Mixin dst_pos dst_sym dstxx dst_eq dst_trngl.

  Canonical metric_baire: MetricSpace := MetricSpace.Pack metric_baire_mixin B.

Section continuity.
  (** This section assumes the existence of a minimal section for cnt. However,
      classically the existence of such a section can be proven. **)
  Context (sec: Q -> nat).
  Hypothesis (ms: minimal_section cnt sec).
  Notation melt := (max_elt sec).

  Lemma lim_lim: (@metric.limit metric_baire) =~= baire.limit.
  Proof.
    move => phin phi.
    split => [lmt L | lmt eps /accf_tpmn [n [_ nle]]].
    - have [ | N prp]:= lmt (/2^(melt L)); first by apply/Rinv_0_lt_compat/pow_lt; lra.
      exists N => m ineq.
      apply/coin_subl/dst_coin/prp/ineq.
      exact/iseg_melt.
    have [N prp]:= lmt (iseg cnt n).
    exists N => m ineq.
    exact/Rle_trans/Rlt_le/nle/dst_coin/prp.
  Qed.

(** Since clasically continuity and sequential continuity are identical, the above can be
    used to prove that the continuity notions coincide. A direct proof is probably also
    possible but more work. **)

  Lemma cont_f_cont (F: B -> B): F \is_continuous_function <-> (F \is_continuous)%met.
  Proof.
    split => [/cont_F2MF cont | cont].
    - apply/metric.scnt_cont => phi phin.
      rewrite lim_lim => lmt.
      by apply/(cont_scnt cont); first exact/lmt.
    apply/cont_F2MF/scnt_cont.
    - by exists (F2MF cnt); split; [apply/F2MF_sing | rewrite -F2MF_cotot].
    move => phi phin Fphin Fphi .
    rewrite -lim_lim => lmt eq <-.
    have ->: Fphin = pointwise.ptw F phin by apply/functional_extensionality => n; rewrite -eq.
    exact/(metric.cont_scnt cont).
  Qed.

  Lemma cont_cont (F: B ->> B) f: F =~= (F2MF f)|_(dom F) ->
     F \is_continuous <-> ((@sub_fun _ _ (dom F) f) \is_continuous)%met.
  Proof.
    move => eq; split => [/cont_scnt cont | /metric.cont_scnt cont].
    - apply/metric.scnt_cont => phi phin lmt; rewrite lim_lim.
      apply/cont; first by rewrite -lim_lim; apply/lmt.
      - move => n /=; rewrite /pointwise.ptw /sub_fun/=.
        case: (phin n) => /= psin [Fpsin val].
        by have /= [_ ->]:= (eq psin Fpsin).1 val.
      case: (phi) => /= psi [Fpsi val]; rewrite /sub_fun/=.
      by have /= [_ ->]:= (eq psi Fpsi).1 val.
    apply/scnt_cont => [ | phi phin Fphin Fphi /lim_lim lmt valn val].
    - exists (F2MF cnt); split; first exact/F2MF_sing.
      by rewrite -F2MF_cotot; apply/sur.
    apply/lim_lim.
    have [phifd <-]:= (eq phi Fphi).1 val.
    have ->: Fphin = pointwise.ptw f phin.
    - apply/ functional_extensionality => n.
      by have [phinfd <-]:= (eq (phin n) (Fphin n)).1 (valn n).
    pose psi := exist _ _ phifd.
    have phinfd: forall n, (phin n) \from dom F by move => n; exists (Fphin n).
    pose psin n := exist _ _ (phinfd n).
    move => eps eg0.
    have [N prp]:= cont (exist _ _ phifd) psin lmt eps eg0.
    exists N => m ineq.
    by have := prp m ineq.
  Qed.
  End continuity.
End baire_metric.


(**
This file is part of the CoqApprox formalization of rigorous
polynomial approximation in Coq:
http://tamadi.gforge.inria.fr/CoqApprox/

Copyright (C) 2010-2012, ENS de Lyon.
Copyright (C) 2010-2016, Inria.
Copyright (C) 2014-2016, IRIT.

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

Require Import Rdefinitions Raxioms RIneq Rbasic_fun Rpow_def Epsilon FunctionalExtensionality ProofIrrelevance Lra.

From mathcomp
Require Import all_ssreflect finalg ssrnum ssralg finalg matrix.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope R_scope.

Lemma Req_EM_T (r1 r2 : R) : {r1 = r2} + {r1 <> r2}.
Proof.
case: (total_order_T r1 r2) => [[r1Lr2 | <-] | r1Gr2].
- by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {2}r1Er2.
- by left.
by right=> r1Er2; case: (Rlt_irrefl r1); rewrite {1}r1Er2.
Qed.

Definition eqr (r1 r2 : R) : bool :=
  if Req_EM_T r1 r2 is left _ then true else false.

Lemma eqrP : Equality.axiom eqr.
Proof.
by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP).
Qed.

Canonical Structure real_eqMixin := EqMixin eqrP.
Canonical Structure real_eqType := Eval hnf in EqType R real_eqMixin.

Fact inhR : inhabited R.
Proof. exact: (inhabits 0). Qed.

Definition pickR (P : pred R) (n : nat) :=
  let x := epsilon inhR P in if P x then Some x else None.

Fact pickR_some P n x : pickR P n = Some x -> P x.
Proof. by rewrite /pickR; case: (boolP (P _)) => // Px [<-]. Qed.

Fact pickR_ex (P : pred R) :
  (exists x : R, P x) -> exists n, pickR P n.
Proof. by rewrite /pickR; move=> /(epsilon_spec inhR)->; exists 0%N. Qed.

Fact pickR_ext (P Q : pred R) : P =1 Q -> pickR P =1 pickR Q.
Proof.
move=> PEQ n; rewrite /pickR; set u := epsilon _ _; set v := epsilon _ _.
suff->: u = v by rewrite PEQ.
by congr epsilon; apply: functional_extensionality=> x; rewrite PEQ.
Qed.

Definition R_choiceMixin : choiceMixin R :=
  Choice.Mixin pickR_some pickR_ex pickR_ext.

Canonical R_choiceType := Eval hnf in ChoiceType R R_choiceMixin.

Fact RplusA : associative (Rplus).
Proof. by move=> *; rewrite Rplus_assoc. Qed.

Definition real_zmodMixin := ZmodMixin RplusA Rplus_comm Rplus_0_l Rplus_opp_l.

Canonical Structure real_zmodType := Eval hnf in ZmodType R real_zmodMixin.

Fact RmultA : associative (Rmult).
Proof. by move=> *; rewrite Rmult_assoc. Qed.

Fact R1_neq_0 : R1 != R0.
Proof. by apply/eqP/R1_neq_R0. Qed.

Definition real_ringMixin := RingMixin RmultA Rmult_1_l Rmult_1_r
  Rmult_plus_distr_r Rmult_plus_distr_l R1_neq_0.

Canonical Structure real_ringType := Eval hnf in RingType R real_ringMixin.
Canonical Structure real_comringType := Eval hnf in ComRingType R Rmult_comm.

Import Monoid.

Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r.
Canonical Radd_comoid := ComLaw Rplus_comm.

Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r.
Canonical Rmul_comoid := ComLaw Rmult_comm.

Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r.
Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l.

Definition Rinvx r := if (r != 0) then / r else r.

Definition unit_R r := r != 0.

Lemma RmultRinvx : {in unit_R, left_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_l //; apply/eqP.
Qed.

Lemma RinvxRmult : {in unit_R, right_inverse 1 Rinvx Rmult}.
Proof.
move=> r; rewrite -topredE /unit_R /Rinvx => /= rNZ /=.
by rewrite rNZ Rinv_r //; apply/eqP.
Qed.

Lemma intro_unit_R x y : y * x = 1 /\ x * y = 1 -> unit_R x.
Proof.
move=> [yxE1 xyE1]; apply/eqP=> xZ.
case/eqP: R1_neq_0.
now rewrite xZ Rmult_0_r in yxE1.
Qed.

Lemma Rinvx_out : {in predC unit_R, Rinvx =1 id}.
Proof. by move=> x; rewrite inE /= /Rinvx -if_neg => ->. Qed.

Definition real_unitRingMixin :=
  UnitRingMixin RmultRinvx RinvxRmult intro_unit_R Rinvx_out.

Canonical Structure real_unitRing :=
  Eval hnf in UnitRingType R real_unitRingMixin.

Canonical Structure real_comUnitRingType :=
  Eval hnf in [comUnitRingType of R].

Lemma real_idomainMixin x y : x * y = 0 -> (x == 0) || (y == 0).
Proof.
(do 2 case: (boolP (_ == _))=> // /eqP)=> yNZ xNZ xyZ.
by case: (Rmult_integral_contrapositive_currified _ _ xNZ yNZ).
Qed.

Canonical Structure real_idomainType :=
   Eval hnf in IdomainType R real_idomainMixin.

Lemma real_fieldMixin : GRing.Field.mixin_of [unitRingType of R].
Proof. done. Qed.

Definition real_fieldIdomainMixin := FieldIdomainMixin real_fieldMixin.

Canonical Structure real_field := FieldType R real_fieldMixin.

(** Reflect the order on the reals to bool *)

Definition Rleb r1 r2 := if Rle_dec r1 r2 is left _ then true else false.
Definition Rltb r1 r2 := Rleb r1 r2 && (r1 != r2).
Definition Rgeb r1 r2 := Rleb r2 r1.
Definition Rgtb r1 r2 := Rltb r2 r1.

Lemma RleP r1 r2 : reflect (r1 <= r2) (Rleb r1 r2).
Proof. by rewrite /Rleb; apply: (iffP idP); case: Rle_dec. Qed.

Lemma RltP r1 r2 : reflect (r1 < r2) (Rltb r1 r2).
Proof.
rewrite /Rltb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
- by case=> // r1Er2 /eqP[].
- by move=> _ r1Lr2; apply/eqP/Rlt_not_eq.
by move=> Nr1Lr2 r1Lr2; case: Nr1Lr2; left.
Qed.

Lemma RgeP r1 r2 : reflect (r1 >= r2) (Rgeb r1 r2).
Proof.
rewrite /Rgeb /Rleb; apply: (iffP idP); case: Rle_dec=> //=.
  by move=> r2Lr1 _; apply: Rle_ge.
by move=> Nr2Lr1 r1Gr2; case: Nr2Lr1; apply: Rge_le.
Qed.

Lemma RgtP r1 r2 : reflect (r1 > r2) (Rgtb r1 r2).
Proof.
rewrite /Rleb; apply: (iffP idP) => r1Hr2; first by apply: Rlt_gt; apply/RltP.
by apply/RltP; apply: Rgt_lt.
Qed.


Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.Classical_Prop.

Parameter expr : Type.

Parameter sepcon : expr -> expr -> expr.
Parameter impp : expr -> expr -> expr.
Parameter emp : expr.

Declare Scope shallow_syntax.
Local Open Scope shallow_syntax.

Notation "x --> y" := (impp x y) (at level 55, right associativity) : shallow_syntax.
Notation "x * y" := (sepcon x y) (at level 40, left associativity) : shallow_syntax.

Inductive provable: expr -> Prop :=
| modus_ponens: forall x y, provable (x --> y) -> provable x -> provable y
| axiom1: forall x y, provable (x --> (y --> x))
| axiom2: forall x y z, provable ((x --> y --> z) --> (x --> y) --> (x --> z))
| sepcon_emp1: forall x, provable (x * emp --> x)
| sepcon_emp2: forall x, provable (x --> x * emp)
| sepcon_comm_impp: forall x y, provable (x * y --> y * x)
| sepcon_assoc1: forall x y z, provable (x * (y * z) --> (x * y) * z)
| sepcon_mono: forall x1 x2 y1 y2,
    provable (x1 --> x2) -> provable (y1 --> y2) -> provable ((x1 * y1) --> (x2 * y2)).

Notation "|--  x" := (provable x) (at level 71, no associativity) : shallow_syntax.

Section AxiomClass1.

Lemma provable_impp_refl : forall x,
  |-- x --> x.
Proof.
  intros.
  pose proof axiom2 x (x --> x) x.
  pose proof axiom1 x (x --> x).
  pose proof axiom1 x x.
  pose proof modus_ponens _ _ H H0.
  pose proof modus_ponens _ _ H2 H1.
  auto.
Qed.

Lemma provable_emp_refl :
  |-- emp --> emp.
Proof.
  intros.
  pose proof provable_impp_refl emp.
  auto.
Qed.

End AxiomClass1.

Section RewriteClass.

Lemma aux_minimun_rule00: forall (x y: expr), |-- x -> |-- y --> x.
Proof.
  intros.
  pose proof axiom1 x y.
  eapply modus_ponens; eauto.
Qed.

Lemma aux_minimun_theorem00: forall (x y z: expr), |--  (y --> z) --> (x --> y) --> (x --> z).
Proof.
  intros.
  pose proof axiom2 x y z.
  pose proof aux_minimun_rule00 _ (y --> z) H.
  pose proof axiom1 (y --> z) x.
  pose proof axiom2 (y --> z) (x --> y --> z) ((x --> y) --> (x --> z)).
  pose proof modus_ponens _ _ H2 H0.
  pose proof modus_ponens _ _ H3 H1.
  auto.
Qed.

Lemma aux_minimun_rule01: forall (x y z: expr), |-- x --> y -> |-- (z --> x) --> (z --> y).
Proof.
  intros.
  pose proof aux_minimun_theorem00 z x y.
  pose proof modus_ponens _ _ H0 H.
  auto.
Qed.

Lemma aux_minimun_rule02: forall (x y z: expr), |-- x --> y -> |-- y --> z -> |-- x --> z.
Proof.
  intros.
  pose proof aux_minimun_theorem00 x y z.
  pose proof modus_ponens _ _ H1 H0.
  pose proof modus_ponens _ _ H2 H.
  auto.
Qed.

Lemma aux_minimun_theorem01: forall (x y z: expr), |-- (x --> z) --> (x --> y --> z).
Proof.
  intros.
  apply aux_minimun_rule01.
  apply axiom1.
Qed.

Lemma aux_minimun_theorem02: forall (x y: expr), |-- x --> (x --> y) --> y.
Proof.
  intros.
  pose proof axiom2 (x --> y) x y.
  pose proof provable_impp_refl (x --> y).
  pose proof modus_ponens _ _ H H0.
  pose proof aux_minimun_rule01 _ _ x H1.
  pose proof axiom1 x (x --> y).
  pose proof modus_ponens _ _ H2 H3.
  auto.
Qed.

Lemma provable_impp_arg_switch: forall (x y z: expr), |-- (x --> y --> z) --> (y --> x --> z).
Proof.
Proof.
  intros.
  apply aux_minimun_rule02 with (y --> x --> y --> z).
  + apply axiom1.
  + pose proof axiom2 y (x --> y --> z) (x --> z).
    eapply modus_ponens; eauto. clear H.
    pose proof aux_minimun_theorem00 x (y --> z) z.
    eapply aux_minimun_rule02; eauto.
    apply aux_minimun_theorem02.
Qed.

Instance provable_impp_rewrite: RewriteRelation (fun x y => |-- x --> y).
Qed.
Instance provable_impp_refl_instance: Reflexive (fun x y => |-- x --> y).
Proof.
  intros.
  hnf; intros.
  apply provable_impp_refl.
Qed.
Instance provable_proper_impp:
  Proper ((fun x y => |-- impp x y) ==> Basics.impl) provable.
Proof.
  intros.
  hnf; intros.
  intro.
  eapply modus_ponens; eauto.
Qed.
Instance impp_proper_impp:
  Proper ((fun x y => |-- impp x y) --> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) impp.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  unfold Basics.flip in H.
  eapply modus_ponens; [apply provable_impp_arg_switch |].
  eapply aux_minimun_rule02; [apply H |].
  eapply modus_ponens; [apply provable_impp_arg_switch |].
  apply aux_minimun_rule01, H0.
Qed.

Goal forall x1 x2 y1 y2,
  |-- x2 --> x1 ->
  |-- y1 --> y2 ->
  |-- (x1 --> y1) --> (x2 --> y2).
  intros.
  rewrite <- H, H0.
  Abort.

Instance sepcon_proper_impp: Proper ((fun x y => |-- impp x y) ==> (fun x y => |-- impp x y) ==> (fun x y => |-- impp x y)) sepcon.
Proof.
  hnf; intros x1 x2 ?.
  hnf; intros y1 y2 ?.
  apply sepcon_mono; auto.
Qed.

Goal forall x y1 y2,
  |-- x --> y1 * emp * y2 ->
  |-- x --> emp * y1 * y2.
  intros.
  rewrite <- (sepcon_comm_impp y1 emp).
  Abort.

End RewriteClass.

Existing Instances provable_impp_rewrite
                   provable_impp_refl_instance
                   provable_proper_impp
                   impp_proper_impp
                   sepcon_proper_impp.