Require Import Program.Basics.
Require Import Coquelicot.Coquelicot.
Require Import Coq.Reals.Rbase.
Require Import Coq.Reals.Rfunctions.
Require Import Coq.Reals.RiemannInt.
Require Import Reals.

Require Import Lra Lia.
Require Import List Permutation.
Require Import Morphisms EquivDec.
Require Import Equivalence.
Require Import Classical ClassicalFacts ClassicalChoice.
Require Ensembles.

Require Import Utils DVector.
Import ListNotations.
Require Export Event SigmaAlgebras ProbSpace.
Require Export RandomVariable VectorRandomVariable.
Require Import ClassicalDescription.
Require Import Measures.
Require Import DiscreteProbSpace.
Require Import Expectation RbarExpectation RandomVariableFinite Dynkin.

Set Bullet Behavior "Strict Subproofs".

Local Open Scope prob.

Section ps_product.

  Context {X:Type}.
  Context {Y:X->Type}.
  Context {A:SigmaAlgebra X}.
  Context {B:forall (x:X), SigmaAlgebra (Y x)}.

  Context (psA : ProbSpace A).
  Context (psB : forall (a:X), ProbSpace (B a)).
  Context {psB_rv: forall (b:forall (a:X), event (B a)), RandomVariable A borel_sa (fun a:X => ps_P (b a))}.

  Definition is_measurable_rectangle (ab : pre_event (sigT Y)) : Prop
    := exists (a:event A) (b:forall (x:X), event (B x)),
      (forall (x:X) (y:Y x), ab (existT _ x y) <-> a x /\ b x y).

  Lemma is_measurable_rectangle_none : is_measurable_rectangle pre_event_none.
  Proof.
    exists event_none, (fun _ => event_none).
    unfold event_none, pre_event_none; simpl; split; tauto.
  Qed.

  Program Instance PairSemiAlgebra : SemiAlgebra (sigT Y)
    := {|
      salg_in (x:pre_event (sigT Y)) := is_measurable_rectangle x
    |}.
  Next Obligation.
    exists pre_event_none.
    apply is_measurable_rectangle_none.
  Qed.
  Next Obligation.
    destruct H as [a1[b1 HH1]]; destruct H0 as [a2[b2 HH2]].
    exists (event_inter a1 a2).
    exists (fun x => event_inter (b1 x) (b2 x)).
    intros.
    split; intros [HHa HHb].
    - apply HH1 in HHa.
      apply HH2 in HHb.
      repeat split; try apply HHa; try apply HHb.
    - destruct HHa.
      destruct HHb.
      split.
      + apply HH1.
        split; trivial.
      + apply HH2.
        split; trivial.
  Qed.
  Next Obligation.
    destruct H as [a1[b1 ?]].
    exists ([(fun (ab:sigT Y) => (event_complement a1) (projT1 ab) /\ b1 (projT1 ab) (projT2 ab))
        ; (fun ab => a1 (projT1 ab) /\ event_complement (b1 (projT1 ab)) (projT2 ab))
        ; (fun ab => event_complement a1 (projT1 ab) /\ event_complement (b1 (projT1 ab)) (projT2 ab))]).
    split;[ | split].
    - intros [x y].
      destruct a1; simpl.
      unfold pre_list_union, pre_event_complement.
      specialize (H x y).
      apply not_iff_compat in H.
      simpl in *; split.
      + intros ?.
        apply H in H0.
        apply not_and_or in H0.
        destruct H0.
        * destruct (classic (b1 x y)).
          -- eexists; split; [left; reflexivity |].
             now simpl.
          -- eexists; split; [right; right; left; reflexivity |].
             now simpl.
        * destruct (classic (x0 x)).
          -- eexists; split; [right; left; reflexivity |].
             now simpl.
          -- eexists; split; [right; right; left; reflexivity |].
             now simpl.
      + intros [??].
        apply H.
        repeat destruct H0; simpl in *; tauto.
    - repeat constructor; intros ???
      ; destruct a1; destruct b1; simpl in *; firstorder.
    - repeat constructor.
      + exists (event_complement a1), b1; intros; tauto.
      + exists a1, (fun z => (event_complement (b1 z))); intros; tauto.
      + exists (event_complement a1), (fun z => event_complement (b1 z)); intros; tauto.
  Qed.

  (* this is very classic *)
  Definition measurable_rectangle_pm (ab:salg_set PairSemiAlgebra) : Rbar.
  Proof.
    destruct ab as [? HH].
    simpl in HH.
    unfold is_measurable_rectangle in HH.
    apply IndefiniteDescription.constructive_indefinite_description in HH.
    destruct HH as [a HH].
    apply IndefiniteDescription.constructive_indefinite_description in HH.
    destruct HH as [b HH].
    assert (nneg:(NonnegativeFunction (rvmult (EventIndicator (classic_dec a)) (fun x => ps_P (b x))))).
    {
      apply NonNegMult.
      - intros ?.
        apply ps_pos.
      - typeclasses eauto.
    }
    exact ((NonnegExpectation (Prts:=psA) (rvmult (EventIndicator (classic_dec a)) (fun x => ps_P (b x))))).
  Defined.

  Lemma ps_union_diff {T:Type} {σ:SigmaAlgebra T} (ps:ProbSpace σ) (x y : event σ) :
    ps_P x = ps_P (x \ y) + ps_P (x ∩ y).
  Proof.
    rewrite (union_diff x y) at 1.
    apply ps_disjoint_union.
    firstorder.
  Qed.

  (* well, at least the definition is meaningful and proper *)
  Lemma measurable_rectangle_pm_proper' ab ab2
        (pf1:is_measurable_rectangle ab) (pf2:is_measurable_rectangle ab2) :
    pre_event_equiv ab ab2 ->
    measurable_rectangle_pm (exist _ ab pf1) = measurable_rectangle_pm (exist _ ab2 pf2).
  Proof.
    intros eqq.
    unfold measurable_rectangle_pm.
    repeat match_destr.
    clear e e0.
    rename x into a1.
    rename x1 into a2.
    rename x0 into b1.
    rename x2 into b2.
    assert (eqq1:forall x y, a1 x /\ b1 x y <-> a2 x /\ b2 x y).
    {
      intros.
      rewrite <- i, <- i0.
      apply eqq.
    }
    clear ab ab2 i i0 eqq pf1 pf2.
    apply NonnegExpectation_ext; intros ?.
    unfold rvscale, rvmult, EventIndicator.
    repeat match_destr.
    + repeat rewrite Rmult_1_l.
      apply ps_proper; intros b.
      split; intros HH
      ; apply eqq1; tauto.
    + destruct (Req_EM_T (ps_P (b1 a)) 0).
      * rewrite e0; lra.
      * destruct (zero_prob_or_witness _ n0) as [b ?].
        generalize (conj e H); intros HH.
        apply eqq1 in HH.
        tauto.
    + destruct (Req_EM_T (ps_P (b2 a)) 0).
      * rewrite e0; lra.
      * destruct (zero_prob_or_witness _ n0) as [b ?].
        generalize (conj e H); intros HH.
        apply eqq1 in HH.
        tauto.
    + lra.
  Qed.

  Global Instance measurable_rectangle_pm_proper : Proper (salg_equiv ==> eq) measurable_rectangle_pm.
  Proof.
    intros ???.
    destruct x; destruct y.
    red in H; simpl in H.
    now apply measurable_rectangle_pm_proper'.
  Qed.

  Lemma measurable_rectangle_pm_nneg ab :
    Rbar_le 0 (measurable_rectangle_pm ab).
  Proof.
    unfold measurable_rectangle_pm.
    repeat match_destr.
    apply NonnegExpectation_pos.
  Qed.

  Lemma measurable_rectangle_pm_none :
    measurable_rectangle_pm (exist _ _ is_measurable_rectangle_none) = 0.
  Proof.
    unfold measurable_rectangle_pm.
    repeat match_destr.
    unfold pre_event_none in i.
    rewrite <- (NonnegExpectation_const0 (Prts:=psA)).
    apply NonnegExpectation_ext; intros a; rv_unfold.
    match_destr.
    - destruct (classic_event_none_or_has (x0 a)) as [[??]|?].
      + generalize (conj e0 H); intros HH.
        apply i in HH.
        tauto.
      + rewrite H, ps_none; lra.
    - lra.
  Qed.

  Instance measurable_rectangle_pm_semipremeasure : is_semipremeasure measurable_rectangle_pm.
  Proof.
    apply (semipremeasure_with_zero_simpl) with (has_none:=is_measurable_rectangle_none).
    - apply measurable_rectangle_pm_proper.
    - apply measurable_rectangle_pm_nneg.
    - apply measurable_rectangle_pm_none.
    - {
        intros c cdisj pf.
        unfold measurable_rectangle_pm at 1.
        repeat match_destr.
        clear e.

        assert (HH:forall s, exists (ab:(event A * (forall (x:X), event (B x)))), forall x y, (c s) (existT _ x y) <-> fst ab x /\ snd ab x y).
        {
          intros.
          destruct (c s); simpl.
          destruct s0 as [?[??]].
          exists (x2,x3); auto.
        }
        apply choice in HH.
        destruct HH as [cp HH].

        assert (forall n,
                   NonnegativeFunction (rvmult (EventIndicator (classic_dec (fst (cp n))))
                                               (fun a : X => ps_P (snd (cp n) a)))).
        {
          intros ?.
          apply NonNegMult.
          - intros ?.
            apply ps_pos.
          - typeclasses eauto.
        }
        transitivity (ELim_seq (sum_Rbar_n
                                  (fun n : nat =>
                                     Rbar_NonnegExpectation (rvmult (EventIndicator (classic_dec (fst (cp n))))
                                                               (fun a : X => ps_P (snd (cp n) a)))))).
        - {
            rewrite NNExpectation_Rbar_NNExpectation.

            assert (nneg0:forall (a:event A) (b:forall a, event (B a)),
                       Rbar_NonnegativeFunction (rvmult (EventIndicator (classic_dec a))
                                                        (fun a : X => ps_P (b a)))).
            {
              intros ??.
              apply NonNegMult.
              - intros ?.
                apply ps_pos.
              - typeclasses eauto.
            }

            assert (nneg1:forall (a:event A) (b:forall a, event (B a)),
                       Rbar_NonnegativeFunction (Rbar_rvmult (EventIndicator (classic_dec a))
                                                             (fun a => Rbar_NonnegExpectation (EventIndicator (classic_dec (b a)))))).
            {
              intros.
              apply Rbar_rvmult_nnf.
              - typeclasses eauto.
              - intros ?.
                apply Rbar_NonnegExpectation_pos.
            }

            assert (eqq1:forall (a:event A) (b:forall a, event (B a)),
                       Rbar_NonnegExpectation (rvmult (EventIndicator (classic_dec a))
                                                      (fun a : X => ps_P (b a))) =
                         Rbar_NonnegExpectation (Rbar_rvmult (EventIndicator (classic_dec a))
                                                        (fun a => Rbar_NonnegExpectation (EventIndicator (classic_dec (b a)))))).
            {
              intros.
              apply Rbar_NonnegExpectation_ext; intros ?.
              unfold Rbar_rvmult, rvmult; simpl.
              generalize (Expectation_pos_pofrf (EventIndicator (classic_dec (b a0))))
              ; intros HH2.
              rewrite Expectation_EventIndicator in HH2.
              invcs HH2.
              rewrite NNExpectation_Rbar_NNExpectation in H1.
              rewrite <- H1.
              now simpl.
            }

            assert (nneg2inner:forall (a:event A) (b:forall a, event (B a)) x,
                       Rbar_NonnegativeFunction
                             (Rbar_rvmult
                                (const (Finite (EventIndicator (classic_dec a) x)))
                                (EventIndicator (classic_dec (b x))))).
            {
              intros.
              apply Rbar_rvmult_nnf.
              - apply nnfconst.
                apply EventIndicator_pos.
              - typeclasses eauto.
            }

            assert (nneg2:forall (a:event A) (b:forall a, event (B a)),
                     Rbar_NonnegativeFunction
                        (fun x =>
                           Rbar_NonnegExpectation
                             (Rbar_rvmult
                                (const (Finite (EventIndicator (classic_dec a) x)))
                                (EventIndicator (classic_dec (b x)))))).
            {
              intros ???.
              apply Rbar_NonnegExpectation_pos.
            }

            assert (eqq2:forall (a:event A) (b:forall a, event (B a)),
                       Rbar_NonnegExpectation (rvmult (EventIndicator (classic_dec a))
                                                      (fun a : X => ps_P (b a))) =
                         Rbar_NonnegExpectation (fun x =>
                                                Rbar_NonnegExpectation
                                                  (Rbar_rvmult
                                                     (const (Finite (EventIndicator (classic_dec a) x)))
                                                     (EventIndicator (classic_dec (b x)))))).
            {
              intros.
              apply Rbar_NonnegExpectation_ext; intros ?.
              erewrite Rbar_NonnegExpectation_scale'.
              - generalize (Expectation_pos_pofrf (EventIndicator (classic_dec (b a0))))
                ; intros HH2.
                rewrite Expectation_EventIndicator in HH2.
                invcs HH2.
                rewrite NNExpectation_Rbar_NNExpectation in H1.
                rewrite <- H1.
                now simpl.
              - typeclasses eauto.
              - apply EventIndicator_pos.
            }
            etransitivity; [etransitivity |]; [| apply (eqq2 x x0) |]
            ; [apply Rbar_NonnegExpectation_ext; reflexivity |].

            etransitivity.
            2: {
              apply ELim_seq_ext; intros.
              apply sum_Rbar_n_proper; [| reflexivity]; intros ?.
              rewrite <- eqq2.
              reflexivity.
            }
            clear eqq1 eqq2.
            {
              erewrite RbarExpectation.Rbar_series_expectation.
              Unshelve.
              shelve.
              - intros.
                eapply (RandomVariable_proper _ _ (reflexivity _) _ _ (reflexivity _)).
                + intros ?.
                  apply Rbar_NonnegExpectation_scale'; try typeclasses eauto.
                  apply EventIndicator_pos.
                + apply Rbar_rvmult_rv.
                  * typeclasses eauto.
                  * eapply (RandomVariable_proper _ _ (reflexivity _) _ _ (reflexivity _)).
                    -- intros ?.
                       generalize (Expectation_pos_pofrf (EventIndicator (classic_dec (snd (cp n) a))))
                       ; intros HH2.
                       rewrite Expectation_EventIndicator in HH2.
                       invcs HH2.
                       rewrite NNExpectation_Rbar_NNExpectation in H1.
                       rewrite <- H1.
                       reflexivity.
                    -- apply Real_Rbar_rv.
                       apply psB_rv.
              - intros ?.
                apply ELim_seq_nneg; intros.
                apply sum_Rbar_n_nneg_nneg; intros ??.
                apply nneg2.
            }
            Unshelve.
            apply Rbar_NonnegExpectation_ext; intros x'.
            {
              erewrite Rbar_series_expectation; trivial.
              Unshelve.
              shelve.
              - intros.
                apply Rbar_rvmult_rv; typeclasses eauto.
              - intros ?.
                apply ELim_seq_nneg; intros.
                apply sum_Rbar_n_nneg_nneg; intros ??.
                apply Rbar_rvmult_nnf
                ; apply EventIndicator_pos.
            }
            Unshelve.
            apply Rbar_NonnegExpectation_ext; intros y.
            unfold Rbar_rvmult, EventIndicator; simpl.
            rewrite <- Lim_seq_sum_Elim.
            (* now we finally have it down to points *)
            {
              destruct (lim_seq_sum_singleton_is_one
                          (fun n0 : nat =>
                             (if classic_dec (fst (cp n0)) x' then 1 else 0) * (if classic_dec (snd (cp n0) x') y then 1 else 0))) as [m HH2].
              - intros.
                repeat match_destr; try lra.
                destruct (HH n1 x' y) as [_ HH1].
                cut_to HH1; [| tauto].
                destruct (HH n2 x' y) as [_ HH2].
                cut_to HH2; [| tauto].
                eelim cdisj; eauto.
              - setoid_rewrite HH2.
                destruct (Req_EM_T ((if classic_dec (fst (cp m)) x' then 1 else 0) * (if classic_dec (snd (cp m) x') y then 1 else 0)) 0).
                + rewrite e in HH2.
                  rewrite e.
                  f_equal.
                  repeat match_destr; simpl; try lra.
                  destruct (i x' y) as [_ HH3].
                  cut_to HH3; [| tauto].
                  destruct HH3 as [n cpn].
                  apply HH in cpn.
                  destruct cpn as [cpnx cpny].

                  assert (HH4:forall n,
                             Finite (sum_n
                                       (fun n0 : nat =>
                                          (if classic_dec (fst (cp n0)) x' then 1 else 0) *
                                            (if classic_dec (snd (cp n0) x') y then 1 else 0)) n) = Finite 0).
                  {
                    intros.
                    apply Rbar_le_antisym.
                    - rewrite <- HH2.
                      apply Lim_seq_increasing_le; intros.
                      apply sum_n_pos_incr; intros; try lia.
                      repeat match_destr; lra.
                    - apply sum_n_nneg; intros.
                      repeat match_destr; lra.
                  }
                  specialize (HH4 n).
                  apply (f_equal real) in HH4; simpl in HH4.
                  destruct n.
                  * rewrite sum_O in HH4.
                    repeat match_destr_in HH4; invcs HH4; try tauto.
                  * rewrite sum_Sn in HH4.
                    unfold plus in HH4; simpl in *.
                    rewrite Rplus_comm in HH4.
                    apply Rplus_eq_0_l in HH4.
                    -- repeat match_destr_in HH4; try tauto.
                    -- repeat match_destr; lra.
                    -- apply sum_n_nneg; intros.
                       repeat match_destr; lra.
                + repeat match_destr_in n; try lra.
                  destruct (i x' y) as [[??] _].
                  * exists m.
                    apply HH; tauto.
                  * repeat match_destr; tauto.
            }
          }
        - apply ELim_seq_ext; intros.
          unfold sum_Rbar_n.
          f_equal.
          apply map_ext; intros.
          rewrite <- NNExpectation_Rbar_NNExpectation.

          unfold measurable_rectangle_pm.
          specialize (HH a).
          repeat match_destr.
          simpl in HH.
          assert (eqq:forall a1 b1, fst (cp a) a1 /\ snd (cp a) a1 b1 <-> x2 a1 /\ x3 a1 b1).
          {
            intros.
            etransitivity.
            - symmetry; apply HH.
            - apply i0.
          }
          clear HH i0 e.
          apply NonnegExpectation_ext; intros ?.
          rv_unfold.
          revert eqq; clear; intros eqq.
          repeat match_destr.
          + repeat rewrite Rmult_1_l.
            apply ps_proper; intros b.
            split; intros HH.
            * generalize (conj e HH); intros HH2.
              apply eqq in HH2; tauto.
            * generalize (conj e0 HH); intros HH2.
              apply eqq in HH2; tauto.
          + rewrite Rmult_0_l.
            destruct (classic_event_none_or_has (snd (cp a) a0)) as [[??]|?]; [| eauto].
            * generalize (conj e H); intros HH2.
              apply eqq in HH2; tauto.
            * rewrite H, ps_none; lra.
          + rewrite Rmult_0_l.
            destruct (classic_event_none_or_has (x3 a0)) as [[??]|?]; [| eauto].
            * generalize (conj e H); intros HH2.
              apply eqq in HH2; tauto.
            * rewrite H, ps_none; lra.
          + lra.
      }
  Qed.

  Definition product_measure := semi_μ measurable_rectangle_pm.

  Instance product_measure_is_measurable_large :
    is_measure (σ:= semi_σ is_measurable_rectangle_none
                           measurable_rectangle_pm
                           measurable_rectangle_pm_none
               ) product_measure
    := semi_μ_measurable _ _ _.

  Global Instance product_measure_is_measurable :
    is_measure (σ:=dep_product_sa A B) product_measure.
  Proof.
    generalize product_measure_is_measurable_large; intros HH.
    assert (sub:sa_sub (dep_product_sa A B)
                       (semi_σ is_measurable_rectangle_none
                               measurable_rectangle_pm
                               measurable_rectangle_pm_none
           )).
    {
      unfold dep_product_sa; intros ?.
      apply generated_sa_minimal; simpl; intros.
      apply semi_σ_in.
      simpl.
      destruct H as [?[?[?[??]]]].
      red.
      exists (exist _ _ H).
      exists (fun (a:X) => match classic_dec x1 a with
                   | left pf => exist _ _ (H0 _ pf)
                   | right _ => event_none
                   end).
      intros.
      simpl.
      etransitivity; try eapply H1; simpl.
      match_destr; tauto.
    }
    apply (is_measure_proper_sub _ _ sub) in HH.
    now simpl in HH.
  Qed.

  Instance product_measure_nneg (a:event A) (b:forall a, event (B a)) :
    NonnegativeFunction (rvmult (EventIndicator (classic_dec a)) (fun x => ps_P (b x))).
  Proof.
    apply NonNegMult.
    - intros ?.
      apply ps_pos.
    - typeclasses eauto.
  Qed.

  Theorem product_measure_product (a:event A) (b:forall a, event (B a)) :
    product_measure (fun '(existT x y) => a x /\ b x y) =
      (NonnegExpectation (Prts:=psA) (rvmult (EventIndicator (classic_dec a)) (fun x => ps_P (b x)))).
  Proof.
    unfold product_measure.
    generalize (semi_μ_λ is_measurable_rectangle_none _ measurable_rectangle_pm_none)
    ; intros HH.
    assert (pin:salg_in (fun '(existT x1 y) => a x1 /\ b x1 y)).
    {
      simpl.
      exists a; exists b; tauto.
    }
    specialize (HH (exist _ _ pin)).
    simpl in *.
    rewrite HH.
    repeat match_destr.
    apply NonnegExpectation_ext; intros ?.
    rv_unfold.
    repeat match_destr.
    - repeat rewrite Rmult_1_l.
      apply ps_proper.
      intros ?; simpl.
      specialize (i a0 x1); tauto.
    - rewrite Rmult_0_l.
      destruct (classic_event_none_or_has (x0 a0)) as [[??]|?]; [| eauto].
      + generalize (conj e0 H); intros HH2.
        apply i in HH2; tauto.
      + rewrite H, ps_none; lra.
    - rewrite Rmult_0_l.
      destruct (classic_event_none_or_has (b a0)) as [[??]|?]; [| eauto].
      + generalize (conj e0 H); intros HH2.
        apply i in HH2; tauto.
      + rewrite H, ps_none; lra.
    - lra.
  Qed.

  Global Instance dep_product_ps : ProbSpace (dep_product_sa A B).
  Proof.
    apply (measure_all_one_ps product_measure).
    generalize (product_measure_product Ω (fun _ => Ω))
    ; intros HH.
    etransitivity; [etransitivity |]; [| apply HH |].
    - unfold product_measure.
      assert (pre_eqq:pre_event_equiv
                        pre_Ω
                        (fun '(existT x y) => @pre_Ω X x /\ @pre_Ω (Y x) y)).
      {
        intros [??]; tauto.
      }
      assert (sa:sa_sigma (dep_product_sa A B) (fun '(existT x y) => @pre_Ω X x /\ @pre_Ω (Y x) y)).
      {
        rewrite <- pre_eqq.
        apply sa_all.
      }
      apply (measure_proper (σ:=dep_product_sa A B) (μ:=product_measure) Ω (exist _ _ sa)).
      now red; simpl.
    - assert (0 <= 1) by lra.
      rewrite <- (NonnegExpectation_const (Prts:=psA) R1) with (nnc:=H).
      apply NonnegExpectation_ext; intros ?.
      rv_unfold.
      rewrite ps_one.
      match_destr.
      + lra.
      + elim n; red; apply I.
  Defined.

  Theorem dep_product_sa_product (a:event A) (b:forall a, event (B a)) :
    ps_P (ProbSpace:=dep_product_ps) (dep_product_sa_event a b) =
      (NonnegExpectation (Prts:=psA) (rvmult (EventIndicator (classic_dec a)) (fun x => ps_P (b x)))).
  Proof.
    simpl.
    now rewrite product_measure_product; simpl.
  Qed.

  Lemma pre_event_set_dep_product_pi : Pi_system (pre_event_set_dep_product (sa_sigma A) (fun a => sa_sigma (B a))).
  Proof.
    unfold pre_event_set_dep_product; intros ?[?[?[?[??]]]]?[?[?[?[??]]]].
    exists (pre_event_inter x x1).
    exists (fun a => pre_event_inter (x0 a) (x2 a)).
    split; [| split].
    - now apply sa_inter.
    - intros ? [??].
      apply sa_inter; auto.
    - rewrite H1, H4.
      unfold pre_event_inter; simpl; intros [??].
      tauto.
  Qed.

  (* dep_product_ps is the unique probability space that preserves the product/integration rule. *)
  Theorem dep_product_ps_unique (ps:ProbSpace (dep_product_sa A B)) :
    (forall a b, ps_P (ProbSpace:=ps) (dep_product_sa_event a b) =
               (NonnegExpectation (Prts:=psA) (rvmult (EventIndicator (classic_dec a)) (fun x => ps_P (b x))))) ->
    forall x, ps_P (ProbSpace:=ps) x = ps_P (ProbSpace:=dep_product_ps) x.
  Proof.
    intros.
    apply pi_prob_extension_unique.
    - apply pre_event_set_dep_product_pi.
    - intros.
      assert (exists x y, event_equiv (generated_sa_base_event Ca) (dep_product_sa_event x y)).
      {
        destruct Ca as [?[?[?[??]]]]; simpl.
        exists (exist _ x0 s).
        exists (fun (a:X) => match classic_dec x0 a with
                     | left pf => exist _ _ (s0 _ pf)
                     | right _ => event_none
                     end).
        intros [??]; simpl.
        etransitivity; try apply e.
        simpl.
        match_destr; tauto.
      }
      destruct H0 as [?[? eqq]].
      repeat rewrite eqq.
      rewrite H.
      now rewrite dep_product_sa_product.
  Qed.

End ps_product.


Require Import Axioms.
Require Import Tactics.
Require Import Sigma.
Require Import Equality.
Require Import Syntax.
Require Import Ofe.
Require Import Spaces.
Require Import Uniform.
Require Import Urelsp.
Require Import Ordinal.
Require Import Equivalence.
Require Import Hygiene.
Require Import Intensional.
Require Import Candidate.
Require Import MapTerm.
Require Import Extend.
Require Export Promote.
Require Import Truncate.
Require Import Page.
Require Import Model.

Definition sterm := wterm stop.
Definition shyp := @hyp (obj stop).
Definition scontext := @context (obj stop).
Definition sjudgement := @judgement (obj stop).
Definition ssub := @sub (obj stop).
Definition surel := wurel stop.
Definition siurel := wiurel stop.
Definition siurel_ofe := wiurel_ofe stop.

Record System : Type :=
mk_system
  { valid : ordinal -> Prop ;

    sint : page -> bool -> nat -> sterm -> siurel -> Prop ;
    sintk : page -> bool -> nat -> sterm -> qkind -> Prop ;

    valid_downward :
      forall v w,
        v <<= w
        -> valid w
        -> valid v ;

    sint_closed :
      forall pg s i c R,
        sint pg s i c R
        -> hygiene clo c ;

    sintk_closed :
      forall pg s i c K,
        sintk pg s i c K
        -> hygiene clo c ;

    sint_equiv :
      forall pg s i c c' R,
        hygiene clo c'
        -> equiv c c'
        -> sint pg s i c R
        -> sint pg s i c' R ;

    sintk_equiv :
      forall pg s i c c' K,
        hygiene clo c'
        -> equiv c c'
        -> sintk pg s i c K
        -> sintk pg s i c' K ;

    sint_fun :
      forall pg s i c R R',
        sint pg s i c R
        -> sint pg s i c R'
        -> R = R' ;

    sintk_fun :
      forall pg s i c K K',
        sintk pg s i c K
        -> sintk pg s i c K'
        -> K = K' ;

    sint_downward :
      forall pg s i j c R,
        j <= i
        -> sint pg s i c R
        -> sint pg s j c (iutruncate (S j) R) ;

    sintk_downward :
      forall pg s i j c K,
        j <= i
        -> sintk pg s i c K
        -> sintk pg s j c (approx j K) ;

  }.


Require Import CoqlibC Maps.
Require Import ASTC Integers ValuesC EventsC MemoryC Globalenvs.
Require Import Op Registers.
Require Import sflib.
Require Import SmallstepC.

Set Implicit Arguments.

Fixpoint assign_junk_blocks (m0: mem) (n: nat): mem :=
  match n with
  | O => m0
  | S n' => let (m1, _) := Mem.alloc m0 0%Z 0%Z in assign_junk_blocks m1 n'
  end.

Definition is_junk_value (m0 m1: mem) (v: val): Prop :=
  match v with
  | Vptr blk _ => ~ Mem.valid_block m0 blk /\ Mem.valid_block m1 blk
  | _ => True
  end.

Section PROPS.

  Lemma assign_junk_blocks_perm: forall m0 n,
    <<EQ: Mem.perm (assign_junk_blocks m0 n) = Mem.perm m0>>.
  Proof.
    i. repeat (apply func_ext1; i). apply AxiomsC.prop_ext.
    ginduction n; ii; ss. des_ifs. split; i; cycle 1.
    - erewrite IHn. eauto with mem.
    - erewrite IHn in H. destruct (peq x0 b).
      { clarify. exploit Mem.perm_alloc_3; eauto. xomega. }
      eapply Mem.perm_alloc_4; eauto.
  Qed.

  Lemma assign_junk_blocks_nextblock: forall m0 n,
    <<NB: (Mem.nextblock (assign_junk_blocks m0 n) = if Zerob.zerob n then Mem.nextblock m0 else Mem.nextblock m0 + Pos.of_nat n)%positive>>.
  Proof.
    i. unfold NW. ginduction n; ii; ss. des_ifs_safe.
    erewrite IHn; eauto. erewrite Mem.nextblock_alloc; eauto. rewrite ! Pplus_one_succ_r; ss.
    des_ifs; try xomega. rewrite <- Pos.add_assoc. rewrite Pos.add_comm with (p := 1%positive). ss.
  Qed.

  Lemma assign_junk_blocks_nextblock'
        m0 n
        (NZR: n <> O):
    <<NB: (Mem.nextblock (assign_junk_blocks m0 n) = Mem.nextblock m0 + Pos.of_nat n)%positive>>.
  Proof. rewrite assign_junk_blocks_nextblock. destruct n; ss. Qed.

  Lemma assign_junk_blocks_unchanged_on: forall m0 n,
      <<UNCH: Mem.unchanged_on top2 m0 (assign_junk_blocks m0 n)>>.
  Proof.
    i. ginduction n; ii; ss.
    { eapply Mem.unchanged_on_refl; eauto. }
    des_ifs. r. etrans; cycle 1.
    { eapply IHn; eauto. }
    eapply Mem.alloc_unchanged_on; eauto.
  Qed.

  Lemma assign_junk_blocks_load
        m0 chunk n blk ofs
        (VALID: Mem.valid_block m0 blk):
      Mem.load chunk (assign_junk_blocks m0 n) blk ofs = Mem.load chunk m0 blk ofs.
  Proof.
    ginduction n; ii; ss. des_ifs. erewrite IHn; eauto with mem. repeat (apply func_ext1; i).
    eapply Mem.load_alloc_unchanged; eauto.
  Qed.

  Lemma assign_junk_block_extends
        m_src m_tgt
        (EXT: Mem.extends m_src m_tgt):
      forall n, <<EXT: Mem.extends (assign_junk_blocks m_src n) (assign_junk_blocks m_tgt n)>>.
  Proof.
    i. ginduction n; ii; ss. des_ifs. eapply IHn.
    exploit (Mem.alloc_extends m_src m_tgt 0 0 b m 0 0); eauto; try lia. i; des. rewrite H in *. clarify.
  Qed.

End PROPS.


(*

"iso" can be applied to objects in different precategories and that's
mathematically strange, or even incorrect, and can cause confusion.

However, it might be sort of convenient if it would check at least that the two
categories have the same morphisms, the same identity arrows, and the same
composition operations, but not check that the proofs of the identities are the
same. But even that might lead to confusion, so better not.

Here is the code that shows the problem.

*)

Require Import Foundations.hlevel2.hSet.
Require Import RezkCompletion.precategories.
        Import pathnotations.PathNotations.

(* make two precategories with the same objects *)
Parameter o : Type.
Parameter m m' : o -> o -> Type.
Parameter is : forall (c d:o), isaset (m c d).
Parameter is': forall (c d:o), isaset (m' c d).
Parameter id : forall c:o, m c c.
Parameter id': forall c:o, m' c c.
Parameter co : forall {c d e:o} (f:m c d) (g:m d e), m c e.
Parameter co': forall {c d e:o} (f:m' c d) (g:m' d e), m' c e.
Parameter rg: forall (c d:o) (f:m c d), co (id c) f == f.
Parameter lf: forall (c d:o) (f:m c d), co f (id d) == f.
Parameter rg': forall (c d:o) (f:m' c d), co' (id' c) f == f.
Parameter lf': forall (c d:o) (f:m' c d), co' f (id' d) == f.
Parameter ass: forall (a b c d : o)
                      (f : m a b) (g : m b c) (h : m c d),
                 co f (co g h) == co (co f g) h.
Parameter ass': forall (a b c d : o)
                      (f : m' a b) (g : m' b c) (h : m' c d),
                 co' f (co' g h) == co' (co' f g) h.

Definition precategory_pair (C:precategory_data) (i:is_precategory C)
  : precategory := tpair _ C i.

Definition makePrecategory
    (obj : UU)
    (mor : obj -> obj -> UU)
    (imor : forall i j:obj, isaset (mor i j))
    (identity : forall i:obj, mor i i)
    (compose : forall (i j k:obj) (f:mor i j) (g:mor j k), mor i k)
    (right : forall (i j:obj) (f:mor i j), compose _ _ _ (identity i) f == f)
    (left  : forall (i j:obj) (f:mor i j), compose _ _ _ f (identity j) == f)
    (associativity : forall (a b c d:obj) (f:mor a b) (g:mor b c) (h:mor c d),
        compose _ _ _ f (compose _ _ _ g h) == compose _ _ _ (compose _ _ _ f g) h)
    : precategory.
  intros.
  set (C := precategory_data_pair
              (precategory_ob_mor_pair
                 obj
                 (fun i j:obj => hSetpair (mor i j) (imor i j))) identity compose).
  assert (iC : is_precategory C).
    split. split. exact right. exact left. exact associativity.
  exact (precategory_pair C iC).
Defined.

Definition C := makePrecategory o m is id (@co) rg lf ass.
Definition C':= makePrecategory o m' is' id' (@co') rg' lf' ass'.

Definition funny (c:C) (c':C') := RezkCompletion.precategories.iso c c'. (* ! *)

Goal unit.
  set (m := funny).
  unfold funny in m; simpl in m. (* see see that m includes nothing about C' *)
  exact tt.
Qed.

(* Here's a seemingly simple solution: *)

Record Obj (C:precategory) := enclose { release : ob C }.
Arguments release {C} o.

Check @release : forall C : precategory, Obj C -> C.

Lemma foo {C:precategory} (c c':Obj C) : c == c' -> release c == release c'.
  intros [].
  reflexivity.
Defined.

Lemma bar {C:precategory} (c c':ob C) : enclose _ c == enclose _ c' -> c == c'.
  intro p.
  exact (maponpaths release p).
Defined.

Definition iso' {C:precategory} (c c':Obj C) := @iso C (release c) (release c').
Definition funny'   (c:ob  C) (c':ob  C') := iso c c'. (* succeeds, but confusing *)
Definition funny''  (c:Obj C) (c':Obj C ) := iso' c c.
(*
Definition funny''' (c:Obj C) (c':Obj C') := iso' c c'. (* doesn't succeed, good *)
*)

Definition Obj2 (C:precategory) (c:ob C) := c.


Require Import POCS.
Require Import ThreeVariablesAPI.

(** To start with, we define a module called [Exercises] that
    takes as an argument an implementation of our variables
    layer, called [vars].
  *)

Module Exercises (vars : VarsAPI).

  (** Now that we are inside the module, we have access to the
      variables API that we defined in [ThreeVariablesAPI].
      You can examine the functions provided by the [vars]
      module using the [Check] command, as follows: *)

  Check vars.read.

  (** The above [Check] command should have printed:

      <<
        vars.read
             : var -> proc nat
      >>

      meaning that [vars.read] is something that takes a variable
      name (of type [var]) and gives us a procedure that returns
      a [nat] value.
    *)

  Check vars.write.

  (** [vars.write] similarly takes a variable name and a new value
      and gives us a procedure with no return value.
    *)

  (** * Part A: incrementing and swapping. *)

  (** To start with, we will define a simple procedure [incX]
      that increments the value of the x variable: *)

  Definition incX : proc unit :=
    x <- vars.read VarX;
    _ <- vars.write VarX (1+x);
    Ret tt.

  (** To check if we got the implementation right, let's try first
      testing it on a specific input.  We can do this by writing a
      very particular specification: if the starting state was
      (1, 2, 3), corresponding to the values of variables x, y, and
      z respectively, then the final state should be (2, 2, 3).

      The [vars.recover] at the end of the specification says that
      we should run the [vars.recover] procedure after a crash; this
      does not matter so far, because we are ignoring crashes.

      The [vars.abstr] indicates how we are describing states in
      this specification.  Here, states are described in terms of
      the variables layer (i.e., consisting of the three values for
      x, y, and z).  We will see in the next lab how and why your
      specification may want to describe the state at a different
      abstraction layer.
    *)

  Theorem incX_test :
    proc_spec (fun (_:unit) state => {|
                    pre :=
                      state = mkState 1 2 3;
                    post := fun r state' =>
                      state' = mkState 2 2 3;
                    recovered := fun _ _ => False;
                  |})
              incX
              vars.recover vars.abstr.
  Proof.
    (*  Pretty much every proof in our lab infrastructure
        starts by expanding out the procedure you're proving.
      *)
    unfold incX.

    (*  We will now consider each step of this code in turn,
        using the [step_proc] Ltac tactic.  [step_proc] will
        take the first thing our code is doing (here, calling
        [vars.read VarX]) and find a corresponding proven spec
        for that code (here, it comes from [vars.read_ok],
        which states that [vars.read] satisfies [read_spec]).
      *)
    step_proc.

    (* We will potentially have to prove several subgoals after
      calling [step_proc]: that our precondition is sufficient to
      invoke the proven spec that [step_proc] found, that the
      recovery condition matches up, and that the rest of the
      procedure will be correct. Here, most of these were trivial
      and were proven automatically, so we are left with just one
      goal.

      This remaining goal requires us to prove something about
      executing the rest of the [incX] code. To help orient yourself
      in this proof ("what is this that I'm having to prove?"), look
      at [Lexec] in your proof context. It's a marker telling you
      that the current proof goal is what's left "after" running
      [(vars.read VarX)].

      This time, to illustrate what step_proc is doing, we break
      it apart into several steps.  This first invocation does
      everything step_proc does except solve trivial goals. *)

    step_proc_basic; simplify; split_all; simplify.

    (* We are now left with several sub-goals that we have
      to prove.  To orient yourself among these subgoals,
      look for [Marker] hypotheses in the context.  In this
      first subgoal, you should see [L] as a marker indicating
      that we are looking at a subgoal related to the precondition
      of [vars.write VarX 2].  The precondition happens to be
      just [True], so it would have been automatically solved
      if you had invoked the full [step_proc] tactic.
      *)

    {
      (* To solve this subgoal, we must use curly braces
        (or dashes), in order to keep the proof script
        clean and readable.

        Since the goal is [True], we can solve it using the
        [trivial] tactic.  [eauto] would have also worked.
        *)

      trivial.
    }

    {
      (* The next subgoal left for us by [step_proc_basic]
        relates to the recovery condition of [vars.write VarX 2],
        which you can determine by looking at the bottom-most
        [Marker] in the current context.

        Since we aren't reasoning about crashes in this lab,
        every recovered condition is [False].  You can prove
        this using the recovered condition of the [vars.read
        VarX] operation, which is [H: False].

        [assumption] does this, as would [eauto].
        *)
      assumption.
    }

    (*  Now we are left with the remaining part of the [incX] code:
        the call to [Ret tt].

        You can see there are two markers in your proof context now,
        since these markers simply accumulate. The bottom marker
        will always be the most recent one, so here [Lexec0] tells
        you that you're looking at the proof state just after
        calling [vars.write VarX (StateX {| ... |} + 1)].

        What's left for us to prove? The goal is saying something
        pretty simple: if the starting state is (2, 2, 3), as
        specified by the precondition, then running [Ret tt] gives
        us a state of (2, 2, 3).

        Invoking [step_proc] proves this simple fact. *)
    step_proc.
  Qed.

  (** Now your job is to state a more general specification for [incX]. It
      should take a precondition of [True], as stated in the theorem below. Your
      task is to fill in the postcondition below so that it applies to any
      starting state, unlike the previous theorem that only worked for [mkState
      1 2 3]. Then, prove your general specification correct.

      Replace [Admitted.] with [Qed.] when the proof is complete. When we grade,
      we basically check that your code compiles and that you didn't use
      [Admitted].

      Take a look at the specifications in ThreeVariablesAPI.v if you're not
      sure where to start.
  *)

  Theorem incX_ok :
    proc_spec (fun (_:unit) state => {|
                    pre := True;
                    post := fun r state' =>
                      (* EXERCISE: replace with your postcondition *)
                      state' = state;
                    recovered := fun _ _ => False;
                  |})
              incX
              vars.recover vars.abstr.
  Proof.
    (* EXERCISE: Fill in your proof here. *)
  Admitted.

  (** You have proven that the code of [incX] satisfies your specification
      in [incX_ok], but how do you know if your specification is good enough?
      Did your specification omit any important details?

      One general approach is to try to use your specification to prove something.
      Let's do that now: prove that your specification above is sufficient
      to prove that running [incX] from state (5, 5, 5) gives us state (6, 5, 5).

      To use your [incX_ok] theorem from above, we tell the [step_proc] tactic
      about it by including it in the [core] hints database.  To make sure that
      we don't accidentally look inside the code of [incX], and thus force ourselves
      to prove statements about [incX] by relying on [incX_ok], we mark it opaque
      using [Opaque incX].
    *)

  Hint Resolve incX_ok : core.
  Opaque incX.

  Theorem incX_ok_seems_good :
    proc_spec (fun (_:unit) state => {|
                    pre :=
                      state = mkState 5 5 5;
                    post := fun r state' =>
                      state' = mkState 6 5 5;
                    recovered := fun _ _ => False;
                  |})
              incX
              vars.recover vars.abstr.
  Proof.
    (* EXERCISE: Fill in your proof here. Most likely [step_proc.] will be
    enough to prove the entire theorem, if your specification is correct. *)
  Admitted.

  (** * Swapping. *)

  (** Here is another exercise, this time with you writing the code,
      the spec, and the proof.  Implement a procedure [swapXY] that
      swaps the values of x and y; write a specification for it; and
      prove that your code meets the spec. *)

  Definition swapXY : proc unit :=
    (* EXERCISE: Fill in your code here. *)
    Ret tt.

  Theorem swapXY_ok :
    (* EXERCISE: Fill in your spec here. *)
    True.
  Proof.
    (* EXERCISE: Fill in your proof here. *)
  Admitted.

  (** As a sanity check, prove that [swapXY] from state (2, 3, 4)
      gives you state (3, 2, 4). *)

  Hint Resolve swapXY_ok : core.
  Opaque swapXY.

  Theorem swapXY_ok_seems_good :
    proc_spec (fun (_:unit) state => {|
                   pre := state = mkState 2 3 4;
                   post := fun r state' => state' = mkState 3 2 4;
                   recovered := fun _ state' => False;
                 |})
              swapXY
              vars.recover
              vars.abstr.
  Proof.
    (* EXERCISE: Fill in your proof here. *)
  Admitted.

  (** * Part B: recursive procedures. *)

  (** In this last part of the lab assignment, you will reason about
      recursive procedures.  To start with, we will give an example.
      We define a helper called [addX] that adds [delta] to the x variable. *)

  Definition addX (delta : nat) : proc unit :=
    x <- vars.read VarX;
    _ <- vars.write VarX (x + delta);
    Ret tt.

  Theorem addX_ok : forall delta,
    proc_spec (fun (_:unit) state => {|
                   pre := True;
                   post := fun r state' => state' = mkState (delta + StateX state) (StateY state) (StateZ state);
                   recovered := fun _ _ => False;
                   |})
              (addX delta)
              vars.recover
              vars.abstr.
  Proof.
    intros.
    unfold addX.
    step_proc.
    step_proc.
    step_proc.
    replace (StateX state + delta) with (delta + StateX state).
    - reflexivity.
    - lia.
  Qed.

  Hint Resolve addX_ok : core.
  Opaque addX.

  (** Now, we define a procedure [addX_list] that takes a list of [nat]s,
      and calls [addX] on each of them in turn. *)

  Fixpoint addX_list (l : list nat) : proc unit :=
    match l with
    | nil =>
      Ret tt
    | v :: l' =>
      _ <- addX v;
      _ <- addX_list l';
      Ret tt
    end.

  (** To specify what we expect [addX_list] to do, we need to talk about
      the sum of values in a list.  To do that, we define a Gallina function
      (purely in Coq) that computes the sum of values in a list. *)

  Fixpoint list_sum (l : list nat) : nat :=
    match l with
    | nil => 0
    | v :: l' => v + (list_sum l')
    end.

  (** Now we can state a specification about [addX_list] and prove it using
      induction.

      Note: You get an error "Expected a single focused goal but 2 goals are
      focused". For the labs, we turned on an option in Coq that enforces proofs
      use bullets ([+], [-], [*]) or curly braces [{ }] to "focus" each line of
      the proof on a single goal. This makes proof scripts more manageable,
      which will help in later labs.

     If you get this error, make sure to use bullets or braces, the way you saw
     throughout Software Foundations.
   *)

  Theorem addX_list_ok : forall l,
    proc_spec (fun (_:unit) state => {|
                   pre := True;
                   post := fun r state' =>
                             state' = mkState (StateX state + list_sum l) (StateY state) (StateZ state);
                   recovered := fun _ _ => False;
                   |})
              (addX_list l)
              vars.recover
              vars.abstr.
  Proof.
    induction l.
    - (* The base case: adding an empty list. *)
      simpl.

      (* EXERCISE: Finish the proof. *)
      admit.

    - (* The inductive case: adding one more element. *)
      simpl.

      (* We first consider the [addX v] call in the second case of [addX_list]'s match. *)
      step_proc.

      (*  You can see that this is indeed where we are in the proof,
          by observing the [Lexec] marker: it says we're just after
          executing [addX a]. *)
      simpl.

      (*  Now we need to run the rest of [addX_list l].  This works
          out surprisingly easily, because the [induction l] tactic
          gave us an inductive hypothesis, [IHl], that gives us a
          specification for [addX_list l].  [step_proc] will use this
          hypothesis if it matches the invocation. *)
      step_proc.

      (*  Finally, we have to prove the state matches the postcondition
          after running both [addX] and [addX_list l]. *)

      (* EXERCISE: Finish the proof. *)
      admit.
  Admitted.

  (** * Recursive procedures on your own. *)

  (** For the final part, you will work out an example of recursive procedures
      on your own.

      Your job is to implement a procedure [add_odds_evens] that takes a list
      of [nat]s, adds all of the even nats to variable x, and all of the odd
      nats to variable y.

      Implement [add_odds_events] in the recursive [Fixpoint] style
      that we used above in part C, write a spec for it, and prove it.

      Use [Nat.even] and [Nat.odd] to determine if a [nat] value is even
      or odd.  You can use [Search] to locate helpful theorems about
      these, as follows:
    *)

  Search Nat.even.
  Search Nat.odd.

  (* EXERCISE: Fill in your code, spec, and proof here. *)

  Fixpoint add_odds_evens (l : list nat) : proc unit := Ret tt.

  (** To check your solution, prove this simple theorem about
      a particular execution of [add_odds_evens] using your spec.
      Add a [Hint Resolve] statement to let [step_proc] see your
      proven specification about [add_odds_evens]. *)

  Opaque add_odds_evens.

  Theorem add_odds_evens_ok_seems_good :
    proc_spec (fun (_:unit) state => {|
                   pre := state = mkState 0 0 0;
                   post := fun r state' => state' = mkState 6 7 0;
                   recovered := fun _ _ => False;
                   |})
              (add_odds_evens (2 :: 3 :: 3 :: 4 :: 1 :: nil))
              vars.recover
              vars.abstr.
  Proof.
    (* EXERCISE: Prove this specification. *)
  Admitted.

End Exercises.


Require Export BuildTac.
Require Import Arith Even Div2.
Require Import DiscrProp.

Open Local Scope nat_scope.

(* *********************************************************************** *)
(*                        FRAGMENT OF ALEA LIBRARY v.7                     *)
(*                      to deal with series permutation                    *)
(* *********************************************************************** *)

(** Decidability *)
Lemma dec_sig_lt : forall P : nat -> Prop, (forall x, {P x}+{ ~ P x})
  -> forall n, {i | i < n /\ P i}+{forall i, i < n -> ~ P i}.
intros P Pdec.
induction n.
right; intros; exfalso; omega.
destruct IHn as [(i,(He1,He2))|Hn]; auto.
left; exists i; auto.
destruct (Pdec n) as [HP|HnP].
left; exists n; auto.
right; intros; assert (i < n \/ i = n) as [H1|H2]; subst; auto; try omega.
Defined.

Lemma dec_exists_lt : forall P : nat -> Prop, (forall x, {P x}+{ ~ P x})
  -> forall n, {exists i, i < n /\ P i}+{~ exists i, i < n /\ P i}.
intros P decP n; destruct (dec_sig_lt P decP n) as [(i,(H1,H2))|H].
left; exists i; auto.
right; intros (i,(H1,H2)); apply (H i H1 H2).
Save.

Definition eq_nat2_dec : forall p q : nat*nat, { p=q }+{~ p=q }.
intros (p1,p2) (q1,q2).
destruct (eq_nat_dec p1 q1) as [H1|H1]; subst.
destruct (eq_nat_dec p2 q2) as [H2|H2]; subst; auto with zarith.
right; intro Heq; apply H2.
injection Heq; trivial.
right; intro Heq; apply H1.
injection Heq; trivial.
Defined.

Definition fun_cte n (a:U) : nat -> U
      := fun p => if eq_nat_dec p n then a else D0.

Lemma fun_cte_eq : forall n a, fun_cte n a n = a.
unfold fun_cte; intros; rewrite if_then; auto.
Save.

Lemma fun_cte_zero : forall n a p, p <> n -> fun_cte n a p = D0.
unfold fun_cte; intros; rewrite if_else; auto.
Save.

Lemma sigma_cte_eq : forall n a p, (n < p)%nat -> sigma (fun_cte n a) p == a.
induction 1.
rewrite sigma_S.
assert ((sigma (fun_cte n a)) n == 0).
apply sigma_zero.
intros k H; rewrite fun_cte_zero; auto; omega.
rewrite fun_cte_eq; rewrite H; auto.
rewrite sigma_S; rewrite IHle.
rewrite fun_cte_zero; auto; omega.
Save.

Hint Resolve sigma_cte_eq.

Lemma serie_cte_eq : forall n a, serie (fun_cte n a) == a.
intros; apply Ole_antisym; unfold serie.
apply lub_le.
intros p; destruct (le_lt_dec (S n) p) as [Hle|Hle].
rewrite sigma_cte_eq; auto.
transitivity (sigma (fun_cte n a) (S n)); auto.
apply fmon_le_compat; auto with arith.
transitivity (sigma (fun_cte n a) (S n));
  [ | apply le_lub ].
rewrite sigma_cte_eq; auto.
Save.

Section PartialPermutationSerieLe.
Variables f g : nat -> U.

Variable s : nat -> nat -> Prop.
Hypothesis s_dec : forall i j, {s i j}+{~s i j}.

Hypothesis s_inj : forall i j k : nat, s i k -> s j k -> i = j.
Hypothesis s_dom : forall i, ~ f i == 0 -> exists j, s i j.

Hypothesis f_g_perm : forall i j, s i j -> f i == g j.

Lemma serie_perm_rel_le : (serie f <= serie g)%tord.
unfold serie at 1.
apply lub_le; intro n.
transitivity (serie (fun k => if dec_exists_lt _
  (fun i => s_dec i k) n then g k else D0)).
induction n; auto.
rewrite sigma_S.
rewrite IHn; clear IHn.
apply (Ueq_orc (f n) 0); auto; intro H.
rewrite H; Usimpl; apply serie_le_compat; intro k.
destruct dec_exists_lt as [(i,(H1,H2))|H']; auto with zarith.
rewrite if_then; auto with zarith.
exists i; auto with zarith.
destruct (s_dom n) as (ni,Hni); auto.
rewrite <- (serie_cte_eq ni (f n)).
rewrite <- serie_plus.
apply serie_le_compat;intro k.
unfold fun_cte; destruct (eq_nat_dec k ni) as [Hkn|Hkn].
rewrite if_else; try omega.
rewrite if_then; try omega.
rewrite Hkn; auto.
exists n; subst; auto with zarith.
intros (i,(H1,H2)).
subst; absurd (i=n); auto with zarith.
apply s_inj with ni; auto.
Usimpl; destruct dec_exists_lt as [(i,(H1,H2))|Hsknd]; auto.
rewrite if_then; auto.
exists i; auto with zarith.
apply serie_le_compat; intro k.
destruct dec_exists_lt as [(i,(H1,H2))|Hsknd]; auto.
Save.
End PartialPermutationSerieLe.

Section PartialPermutationSerieEq.
Variables f g : nat -> U.

Variable s : nat -> nat -> Prop.
Hypothesis s_dec : forall i j, {s i j}+{~s i j}.
Hypothesis s_fun : forall i j k : nat, s i j -> s i k -> j = k.
Hypothesis s_inj : forall i j k : nat, s i k -> s j k -> i = j.
Hypothesis s_surj : forall j, ~ g j == 0 ->  exists i, s i j.
Hypothesis s_dom : forall i, ~ f i == 0 -> exists j, s i j.
Hypothesis f_g_perm : forall i j, s i j -> f i == g j.

Lemma serie_perm_rel_eq : serie f == serie g.
apply Ole_antisym.
apply serie_perm_rel_le with s; auto.
apply serie_perm_rel_le with (fun i j => s j i); auto.
intros; apply s_fun with k; auto.
Save.
End PartialPermutationSerieEq.

Section PermutationSerie.
Variable s : nat -> nat.
Hypothesis s_inj : forall i j : nat, s i = s j -> i = j.
Hypothesis s_surj : forall j, exists i, s i = j.

Variable f : nat -> U.

Lemma serie_perm_le : (serie (fun i => f (s i)) <= serie f)%tord.
apply serie_perm_rel_le with (fun i j => s i = j); auto.
intros; apply (eq_nat_dec (s i) j).
intros; apply s_inj; transitivity k; auto.
intros; exists (s i); auto.
Save.

Lemma serie_perm_eq : serie f == serie (fun i => f (s i)).
apply serie_perm_rel_eq with (fun i j => s j = i); auto with zarith.
intros; apply (eq_nat_dec (s j) i).
intros; exists (s j); auto.
Save.

End PermutationSerie.
Hint Resolve serie_perm_eq serie_perm_le.

(* *********************************************************************** *)
(*                              AUXILIARY LEMMAS                           *)
(* *********************************************************************** *)

(* Open Scope positive_scope. *)
Open Scope Z_scope.
Open Scope R_scope.

Lemma sum_f_R0_eq_compat:
  forall (An Bn : nat -> R) (N : nat),
  (forall n : nat, (n <= N)%nat -> An n = Bn n) ->
  sum_f_R0 An N = sum_f_R0 Bn N.
Proof.
 intros.
 apply Rle_antisym; apply sum_Rle;
   intros; rewrite H; trivial.
Qed.

Lemma Zeq_bool_comm: forall z1 z2, Zeq_bool z1 z2 = Zeq_bool z2 z1.
Proof.
 intros.
 case_eq (Zeq_bool z1 z2); intro Heq.
 symmetry; rewrite <-(@Zeq_is_eq_bool z2 z1); symmetry.
 apply (Zeq_bool_eq _ _ Heq).
 symmetry; apply not_true_iff_false; intro H'.
 apply ((Zeq_bool_neq _ _ Heq) (eq_sym (Zeq_bool_eq _ _ H'))).
Qed.

Lemma Zeq_bool_refl: forall z, Zeq_bool z z = true.
Proof.
 intro z.
 generalize (Zeq_bool_if z z); destruct (Zeq_bool z z).
   trivial.
   intro H.
   elim H; trivial.
Qed.

Lemma multRU_le_Rmult : forall (u1 u2:U) (x:R),
 (0 <= x)%R ->
 (iR u1 <= x * iR u2)%R ->
 (u1 <= x ** u2)%tord.
Proof.
 intros u1 u2 x Hx H; unfold  multRU; repeat case_Rle.
 rewrite <-(retract_U u1); apply (iU_le H).
 elim n; apply Rmult_le_pos; auto.
 auto.
Qed.

Lemma has_ub_Rle_compat: forall f g,
  (forall k, (g k <= f k)%R) ->
  has_ub f ->
  has_ub g.
Proof.
 unfold has_ub, bound; intros f g Hfg (L,HL).
 exists L.
 apply Un_bound_imp.
 intro n; rewrite (Hfg n).
 refine (HL _ (Un_in_EUn _ _)).
Qed.

Lemma sum_f_R0_le_compat: forall f g n,
 (forall (k:nat), (k <= n)%nat -> f k <= g k) ->
 sum_f_R0 f n <= sum_f_R0 g n.
Proof.
 intros.
 induction n; simpl.
   auto.
   rewrite IHn, H; auto with arith.
Qed.

Lemma Rdiv_gt_r_elim: forall (x y z:R),
  z > 0 ->
  x * z > y ->
  x > y / z.
Proof.
 intros x y z Hz H.
 rewrite <-(Rinv_r_simpl_l z x);
   [ | intro H'; subst; apply (Rgt_irrefl _ Hz) ].
 apply (Rmult_gt_compat_r _ _ _ (Rinv_0_lt_compat _ Hz) H).
Qed.

Lemma Rmult_gt_r_elim: forall (x y z:R),
  z > 0 ->
  x > y / z ->
  x * z > y.
Proof.
 intros x y z Hz H.
 rewrite <-(Rinv_r_simpl_l z y); [ | apply (Rgt_not_eq _ _ Hz) ].
 rewrite Rmult_assoc, (Rmult_comm z), <-Rmult_assoc.
 apply (Rmult_gt_compat_r _ _ _ Hz H).
Qed.

Lemma Rmult_gt_l_elim: forall (x y z:R),
  y > 0 ->
  x / y > z ->
  x > y * z.
Proof.
 intros x y z Hy H.
 rewrite <-(Rinv_r_simpl_r y x), Rmult_assoc;
   [ | intro H'; subst; apply (Rgt_irrefl _ Hy) ].
 apply (Rmult_lt_compat_l _ _ _ Hy).
 rewrite Rmult_comm; trivial.
Qed.

Lemma Rdiv_lt_r_elim: forall (x y z:R),
  z < 0 ->
  x * z > y ->
  x < y / z.
Proof.
 intros x y z Hz H.
 rewrite <-(Rinv_r_simpl_l z x);
   [ | intro H'; subst; apply (Rgt_irrefl _ Hz) ].
 apply Ropp_lt_cancel.
 unfold Rdiv; rewrite <- 2 Ropp_mult_distr_r_reverse.
 refine (Rmult_lt_compat_r _ _ _ _ H).
 apply (Ropp_0_gt_lt_contravar _ (Rinv_lt_0_compat _ Hz)).
Qed.

(* *********************************************************************** *)
(*                      (DISCRETE) NORMAL DISTRIBUTION                     *)
(* *********************************************************************** *)

Section NORMAL.

 (* Scale factor *)
 Variable sf : R.
 Hypothesis sf_pos : 0 < sf.

 Variable ZeqU : Z -> Z -O-> U.
 Hypothesis cover_uR: forall (z:Z), cover (eq z) (ZeqU z).

 Definition pdf (ctr:Z) (z:Z) :=
  let t := IZR (z - ctr) in exp (- (Rsqr t) / sf).

 Axiom sigma_pdf_has_ub : forall ctr,
  has_ub (sum_f_R0 (fun k => pdf ctr (iB k))).

 Lemma pdf_pos : forall ctr z, 0 <= pdf ctr z.
 Proof.
  intros; apply Rlt_le; apply exp_pos.
 Qed.

 Lemma pdf_notnul : forall a, exists b, 0 < pdf a b.
 Proof.
  intros; exists 0%Z; apply exp_pos.
 Qed.

 Lemma aux: forall (a:Z), has_ub (sum_f_R0 (fun k => pdf a (iB k))).
 Proof.
  intros; destruct (sigma_pdf_has_ub a) as [z Hz];
  exists z; intros ? [i Hi];
  rewrite Hi; apply Hz; exists i; auto.
 Qed.

 Definition Normal : Z -> Distr Z.
  intro a.
  refine (im_distr iB (exponential (fun a k => pdf a (iB k)) _ _ _ a)).
  exact (fun a' k' => pdf_pos a' (iB k')).
  intros; destruct (pdf_notnul a0) as [b Hb];
  exists (iN b); rewrite iB_N; trivial.
  exact aux.
 Defined.

 Lemma Normal_Discrete: forall (a:Z),
  is_Discrete (Normal a).
 Proof.
  unfold Normal, im_distr; intros.
  apply (is_Discrete_Mlet _ (exponential_is_Discrete _ _ _ _ _)).
  intros; apply is_Discrete_Munit.
 Qed.

 Lemma Normal_lossless: forall (a:Z),
   mu (Normal a) (fone _) == 1%U.
 Proof.
  intro a.
  unfold Normal; rewrite im_distr_simpl.
  apply exponential_lossless.
 Qed.

 Lemma Normal_point: forall (a z:Z),
  mu (Normal a) (ZeqU z) ==
  iU (pdf  a z / sequence_ub
    (sum_f_R0 (fun k => pdf a (iB k))) (aux a) 0).
 Proof.
  intros.
  unfold Normal; rewrite im_distr_simpl.
  match goal with  |- fmonot (mu ?d) ?f == _ => transitivity
    (fmonot (mu d) (fun a' => B2U (nat_eqb a' (iN z))))
  end.
  apply mu_stable_eq; refine (ford_eq_intro _); intro k.
  unfold B2U; case_eq (nat_eqb k (iN z)); intro H1;
    apply (cover_elim (cover_uR (iB k)) z); [ auto | | | auto | | ];
      intros (H2,H3); trivial.
      elim H2; rewrite (nat_eqb_true H1), iB_N; trivial.
      rewrite <-H2;  refine (cover_eq_one _  (cover_uR (iB k)) _); trivial.
      refine (cover_eq_zero _ (cover_uR _) _); auto.
      generalize (nat_eqb_spec k (iN z)); rewrite H1; clear H1; intro H1.
      elim H1; rewrite <-H2, iN_B; trivial.
  unfold exponential, B2U.
  rewrite discretize_point, iB_N.
  trivial.
 Qed.

 Lemma Normal_const_weight: forall a1 a2,
  sequence_ub (sum_f_R0 (fun k : nat => pdf a1 (iB k))) (aux a1) 0 =
  sequence_ub (sum_f_R0 (fun k : nat => pdf a2 (iB k))) (aux a2) 0.
 Proof.
  intros.
  assert (H:has_ub (sum_f_R0 (fun k : nat => pdf a2 (iB k + (a2 - a1))))).
    apply has_ub_Rle_compat with (sum_f_R0 (fun k => pdf a1 (iB k))).
    intros k; apply sum_f_R0_le_compat; intros.
    unfold pdf;  replace (iB k0 + (a2 - a1) - a2)%Z
      with (iB k0 - a1)%Z; [ trivial | ring ].
    apply sigma_pdf_has_ub.
  transitivity (sequence_ub (sum_f_R0 (fun k => pdf a2 (iB k + (a2 - a1)))) H 0).
    apply Rlub_eq_compat; intro k.
    apply sum_f_R0_eq_compat; intros; unfold pdf.
    replace (iB n + (a2 - a1) - a2)%Z with (iB n - a1)%Z; [ trivial | ring ].
    symmetry; refine (series_f_shift _ _ _ _ (pdf_pos a2)).
 Qed.

 Lemma Normal_shift: forall (a:Z) f,
  mu (Normal a) f == mu (Normal 0) (fun z => f (z + a)%Z).
 Proof.
  intros; simpl.
  apply serie_perm_rel_eq with (s:= fun i j => (iB i - a)%Z  = iB j).
  intros; apply Z_eq_dec.
  intros i j j' Hj Hj'.
  rewrite <-(iN_B j), <-(iN_B j'), <-Hj, <-Hj'; trivial.
  intros i i' j  Hi Hi'.
  rewrite <-(iN_B i), <-(iN_B i').
  replace (iB i) with (iB j + a)%Z by omega.
  replace (iB i') with (iB j + a)%Z by omega.
  trivial.
  intros j _.
  exists (iN (iB j + a)%Z); rewrite iB_N; ring.
  intros j _.
  exists (iN (iB j - a)%Z); rewrite iB_N; ring.
  intros i j Hij.
  rewrite (Normal_const_weight a 0).
  unfold pdf; rewrite <-Hij,Zminus_0_r.
  rewrite Zplus_comm, Zplus_minus.
  trivial.
 Qed.

 Let Z_Gt := fun (L:R) (z:Z) => if Rlt_dec L (IZR z) then 1%U else D0.
 Let Z_Lt := fun (L:R) (z:Z) => if Rgt_dec L (IZR z) then 1%U else D0.

 Lemma Normal_dist_asym: forall (a1 a2:Z) delt (lam:R),
  1 <= lam ->
  let t:= IZR (a1-a2)%Z in
  let alpha := (sf * ln lam - Rsqr t) / (2 * t) in
  (t > 0 -> (mu (Normal 0) (Z_Gt alpha) <= delt)%tord) ->
  (t < 0 -> (mu (Normal 0) (Z_Lt alpha) <= delt)%tord) ->
  le_dist_asym (Normal a1) (Normal a2) lam delt.
 Proof.
  intros a1 a2 delt lam Hlam t alpha Hdelt1 Hdelt2.
  destruct (Req_EM_T t 0)  as [Heq | Hneq ].
  (* case [a1 = a2] *)
  unfold t in Heq.
  rewrite (Zminus_eq _ _ (eq_IZR_R0 _ Heq)).
  apply le_dist_asym_weaken_ep with D0;
    [ trivial | apply (le_dist_asym_nul _ Hlam) ].
  (* case [a1 <> a2] *)
  intro f; unfold d_expr_asym.
  set (S := fun z => if Rle_dec (pdf a1 z)
    (lam * pdf a2 z) then true else false).
  rewrite (mu_restr_split (Normal a1) S f),
    (mu_restr_split (Normal a2) S f).
  rewrite <-(multRU_distr_plus_l _ _ Hlam),
    Uplus_minus_perm_assoc.
  rewrite <-(Uplus_zero_left delt); apply Uplus_le_compat;
    [ apply Uminus_le_zero | rewrite Uminus_le_left ].
  (* Multiplicative factor bound *)
  set (Ha1_discr := disc_eqpoint_l
    (Normal_Discrete a1) (Normal_Discrete a2)).
  set (Ha2_discr := disc_eqpoint_r
    (Normal_Discrete a1) (Normal_Discrete a2)).
  set (p:= parity_split (D_points (Normal_Discrete a1))
    (D_points (Normal_Discrete a2))); fold p in Ha1_discr, Ha2_discr.
  rewrite (mu_is_Discrete _ cover_uR (mkDiscr Ha1_discr)),
    (mu_is_Discrete _ cover_uR (mkDiscr Ha2_discr)); simpl.
  rewrite  (discr_distr_simpl _ cover_uR  Ha1_discr),
    (discr_distr_simpl _ cover_uR  Ha2_discr).
  rewrite <-(multRU_serie _ Hlam).
  apply serie_le_compat; intro k.
  unfold restr, S; destruct (Rle_dec (pdf a1 (p k))
    (lam * pdf a2 (p k))) as [HS | _ ]; [ | repeat Usimpl; auto ].
  apply (cover_elim (cover_not_first_repr _ _ cover_uR p) k);
    [auto | | ]; intros [_ H5]; rewrite H5; repeat Usimpl; [ | auto ].
  rewrite <-(Umult_multRU_assoc _ _ Hlam); apply Umult_le_compat_left.
  rewrite 2 Normal_point.
  apply multRU_le_Rmult; [ fourier | ].
  assert (Haux0: forall a,
    0 < sequence_ub (sum_f_R0 (fun k : nat => pdf a (iB k))) (aux a) 0).
      intro a; apply y_pos; [ intro; apply pdf_pos | destruct (pdf_notnul a)
        as [z' Hz']; exists (iN z'); rewrite iB_N; trivial ].
  assert (Haux1: forall a z,
   0 <= pdf a z / sequence_ub (sum_f_R0 (fun k => pdf a (iB k))) (aux a) 0 <= 1).
    intros a z; split.
      apply (Rdiv_pos (pdf_pos _ _) (Haux0 _)).
      apply (Rdiv_le_1 (Haux0 _)).
      rewrite <-(iB_N z).
      apply (serie_f_le (fun (a':Z) (k':nat) => pdf a' (iB k'))).
      intros; apply pdf_pos.
  rewrite 2 retract_R; try apply Haux1.
  rewrite (Normal_const_weight a1 a2).
  unfold Rdiv; rewrite <-Rmult_assoc.
  refine (Rmult_le_compat_r _ _ _ _ HS).
  refine (Rlt_le _ _ (Rinv_0_lt_compat _ (Haux0 _))).
  (* Additive term *)
  transitivity  (mu (Normal a1) (charfun (negP S))).
    apply mu_monotonic; apply restr_le_compat; auto.
  rewrite Normal_shift.
  destruct (Rdichotomy _ _ Hneq) as [Ht | Ht].
  (* case [a1 < a2] *)
  transitivity  (mu (Normal 0) (Z_Lt alpha)).
    apply mu_monotonic; refine (ford_le_intro _); intro z.
    unfold charfun, restr, negP, S, negb, fone, Z_Lt.
    match goal with |- context [Rle_dec ?x ?y] =>
      destruct (Rle_dec x y) as [_ | H] end; trivial.
    match goal with |- context [Rgt_dec ?x ?y] =>
      destruct (Rgt_dec x y) as [_ | H'] end;
       [ trivial | elim H'; clear H' ].
    apply Rnot_le_lt in H.
    unfold alpha.
    apply Rdiv_lt_r_elim; [ fourier | ].
    cut (IZR z * (2 * t) +  Rsqr t > sf * ln lam); [
      generalize (IZR z * (2 * t)) (sf * ln lam); intros; fourier | ].
    apply (Rmult_gt_l_elim _ _ _ sf_pos).
    rewrite <-(ln_exp ((IZR z * (2 * t) + Rsqr t) / sf)).
    apply (ln_increasing); [ fourier | apply  Rfourier_gt_to_lt ].
    replace (exp ((IZR z * (2 * t) + Rsqr t) / sf)) with
      (exp (- Rsqr (IZR z) / sf) * exp (Rsqr (IZR z + t) / sf)).
    Focus 2.
      rewrite <-exp_plus; apply f_equal.
      unfold t; repeat rewrite minus_IZR.
      unfold Rdiv; rewrite <-Rmult_plus_distr_r; apply Rmult_eq_compat_r.
      rewrite Rsqr_plus, Rsqr_minus.
      generalize  (IZR z) (IZR a1) (IZR a2); intros z' a1' a2'; ring.
    apply (Rmult_gt_r_elim _ _ _ (exp_pos _)).
    unfold Rdiv at 2; rewrite <-exp_Ropp.
    revert H; unfold pdf, t.
    replace (z + a1 - a1)%Z with z by ring.
    rewrite <-plus_IZR; replace (z + (a1 - a2))%Z
      with (z + a1 - a2)%Z by omega.
    unfold Rdiv at 4; rewrite <-Ropp_mult_distr_l_reverse.
    trivial.
  exact (Hdelt2 Ht).
  (* case [a1 < a2] *)
  transitivity  (mu (Normal 0) (Z_Gt alpha)).
    apply mu_monotonic; refine (ford_le_intro _); intro z.
    unfold charfun, restr, negP, S, negb, fone, Z_Gt.
    match goal with |- context [Rle_dec ?x ?y] =>
      destruct (Rle_dec x y) as [_ | H] end; trivial.
    match goal with |- context [Rlt_dec ?x ?y] =>
      destruct (Rlt_dec x y) as [_ | H'] end;
       [ trivial | elim H'; clear H' ].
    apply Rnot_le_lt in H.
    unfold alpha.
    apply Rfourier_gt_to_lt.
     apply Rdiv_gt_r_elim; [ fourier | ].
    cut (IZR z * (2 * t) +  Rsqr t > sf * ln lam); [
      generalize (IZR z * (2 * t)) (sf * ln lam); intros; fourier | ].
    apply (Rmult_gt_l_elim _ _ _ sf_pos).
    rewrite <-(ln_exp ((IZR z * (2 * t) + Rsqr t) / sf)).
    apply (ln_increasing); [ fourier | apply  Rfourier_gt_to_lt ].
    replace (exp ((IZR z * (2 * t) + Rsqr t) / sf)) with
      (exp (- Rsqr (IZR z) / sf) * exp (Rsqr (IZR z + t) / sf)).
    Focus 2.
      rewrite <-exp_plus; apply f_equal.
      unfold t; repeat rewrite minus_IZR.
      unfold Rdiv; rewrite <-Rmult_plus_distr_r; apply Rmult_eq_compat_r.
      rewrite Rsqr_plus, Rsqr_minus.
      generalize  (IZR z) (IZR a1) (IZR a2); intros z' a1' a2'; ring.
    apply (Rmult_gt_r_elim _ _ _ (exp_pos _)).
    unfold Rdiv at 2; rewrite <-exp_Ropp.
    revert H; unfold pdf, t.
    replace (z + a1 - a1)%Z with z by ring.
    rewrite <-plus_IZR; replace (z + (a1 - a2))%Z
      with (z + a1 - a2)%Z by omega.
    unfold Rdiv at 4; rewrite <-Ropp_mult_distr_l_reverse.
    trivial.
  exact (Hdelt1 Ht).
 Qed.

 Lemma Normal_dist_aux: forall (a1 a2:Z) delt (lam:R),
  1 <= lam ->
  let t:= (IZR (a1-a2)%Z) in
  let alpha1 := (sf * ln lam - Rsqr t) / (2 *  Rabs t) in
  let alpha2 := (sf * ln lam - Rsqr t) / (2 * - Rabs t) in
  (mu (Normal 0) (Z_Gt alpha1) <= delt)%tord ->
  (mu (Normal 0) (Z_Lt alpha2) <= delt)%tord ->
  le_dist (Normal a1) (Normal a2) lam delt.
 Proof.
  intros a1 a2 delt lam Hlam t alpha1 alpha2 Hdelt1 Hdelt2.
  assert (Hcontr: forall (r:R), r > 0 -> r < 0 -> False) by
    (intros r H1 H2; apply (RIneq.Rle_not_lt 0 r (Rlt_le _ _ H2) H1)).
  destruct (Rtotal_order (IZR (a1-a2)%Z) 0) as [Ht | [Ht | Ht] ].
  (* case a1 < a2 *)
  apply (le_dist_le_dist_asym Hlam).
    refine (Normal_dist_asym _ _ _ _ Hlam _ _); fold t; intro Ht'.
      elim (Hcontr t Ht' Ht).
      pattern t at 2; rewrite <-(Ropp_involutive t), <-(Rabs_left t Ht).
      exact Hdelt2.
    refine (Normal_dist_asym _ _ _ _ Hlam _ _); fold t; intro Ht'.
      replace (a2 - a1)%Z with (-(a1 - a2))%Z by ring.
      rewrite Ropp_Ropp_IZR; rewrite <-(Rabs_left (IZR (a1 - a2)%Z) Ht) at 2.
      rewrite <-Rsqr_neg.
      exact Hdelt1.
      elim (Hcontr t); trivial.
      apply Ropp_gt_cancel; rewrite Ropp_0; unfold t.
      replace (- IZR (a1 - a2)%Z) with (IZR (a2 - a1)%Z) by
        (rewrite <-opp_IZR; apply f_equal; ring).
      trivial.
  (* case a1 = a2 *)
  rewrite (Zminus_eq _ _ (eq_IZR_R0 _ Ht)).
  apply le_dist_weaken_ep with D0;
    [ trivial | apply (le_dist_nul _ Hlam) ].
  (* case a1 > a2 *)
  apply (le_dist_le_dist_asym Hlam).
    refine (Normal_dist_asym _ _ _ _ Hlam _ _); fold t; intro Ht'.
      rewrite <-(Rabs_right t (Rgt_ge _ _ Ht)) at 2.
      exact Hdelt1.
      elim (Hcontr t Ht Ht').
    refine (Normal_dist_asym _ _ _ _ Hlam _ _); intro Ht'.
      elim (Hcontr t); trivial.
      apply Ropp_gt_cancel; rewrite Ropp_0; unfold t.
      replace (- IZR (a1 - a2)%Z) with (IZR (a2 - a1)%Z) by
        (rewrite <-opp_IZR; apply f_equal; ring).
      trivial.
      replace (a2 - a1)%Z with (-(a1 - a2))%Z by ring.
      rewrite Ropp_Ropp_IZR;
        rewrite <-(Rabs_right (IZR (a1 - a2)%Z) (Rgt_ge _ _ Ht)) at 2.
      rewrite <-Rsqr_neg.
      exact Hdelt2.
 Qed.

 Lemma Normal_sym_bound: forall (a:R),
  mu (Normal 0) (Z_Gt a) == mu (Normal 0) (Z_Lt (-a)%R).
 Proof.
  intro a; simpl.
  apply serie_perm_rel_eq with (s:= fun i j => iB i  = (- iB j)%Z).
  intros; apply Z_eq_dec.
  intros i j j' Hj Hj'.
  rewrite <-(iN_B j), <-(iN_B j').
  replace (iB j) with (- iB i)%Z by omega.
  replace (iB j') with (- iB i)%Z by omega.
  trivial.
  intros i i' j  Hi Hi'.
  rewrite <-(iN_B i), <-(iN_B i'), Hi, Hi'; trivial.
  intros j _.
  exists (iN (- iB j)%Z); rewrite iB_N; ring.
  intros j _.
  exists (iN (- iB j)%Z); rewrite iB_N; ring.
  intros i j Hij.
  apply Umult_eq_compat.
     rewrite Hij; unfold pdf.
     rewrite 2 Zminus_0_r, Ropp_Ropp_IZR, <-Rsqr_neg.
     trivial.
  unfold Z_Gt, Z_Lt.
  destruct (Rlt_dec a (IZR (iB i))) as [H1 | H1];
    destruct (Rgt_dec (- a) (IZR (iB j))) as [H2 | H2]; trivial.
  rewrite Hij in H1; elim H2; clear Hij H2.
  rewrite Ropp_Ropp_IZR in H1; fourier.
  rewrite Hij in H1; elim H1; clear Hij H1.
  rewrite Ropp_Ropp_IZR; fourier.
 Qed.

 Lemma Normal_dist: forall (a1 a2:Z) delt (lam:R),
  1 <= lam ->
  let t:= (IZR (a1-a2)%Z) in
  let alpha := (sf * ln lam - Rsqr t) / (2 *  Rabs t) in
  (mu (Normal 0) (Z_Gt alpha) <= delt)%tord ->
  le_dist (Normal a1) (Normal a2) lam delt.
 Proof.
  intros a1 a2 del lam Hlam t alpha H.
  destruct (Z_eq_dec a1 a2) as [Ha | Ha].
    (* a1 = a2 *)
    rewrite Ha.
    apply le_dist_weaken_ep with D0;
      [ trivial | apply (le_dist_nul _ Hlam) ].
    (* a1 <> a2 *)
    apply (Normal_dist_aux _ _ _ _ Hlam H).
    rewrite <-H, Normal_sym_bound.
    unfold alpha, Rdiv at 1.
    rewrite Ropp_mult_distr_r_reverse, <-Ropp_inv_permute,
      Ropp_mult_distr_r_reverse; trivial.
    apply Rmult_integral_contrapositive;
       split; [ intros ?; fourier | ].
    refine (Rabs_no_R0 _ (not_0_IZR _ _)).
    intro H'; apply Ha; omega.
 Qed.

End NORMAL.


Require Export Relation_Definitions.

Arguments reflexive [A].
Arguments transitive [A].
Arguments symmetric [A].
Arguments antisymmetric [A].
Arguments equiv [A].
Arguments preorder [A].
Arguments Build_preorder [A].
Arguments preord_refl [A] [R].
Arguments preord_trans [A] [R].
Arguments order [A].
Arguments Build_order [A].
Arguments ord_refl [A] [R].
Arguments ord_trans [A] [R].
Arguments ord_antisym [A] [R].
Arguments equivalence [A].
Arguments Build_equivalence [A].
Arguments equiv_refl [A] [R].
Arguments equiv_trans [A] [R].
Arguments equiv_sym [A] [R].
Arguments PER [A].
Arguments Build_PER [A].
Arguments per_sym [A] [R].
Arguments per_trans [A] [R].
Arguments inclusion [A].
Arguments same_relation [A].
Arguments commut [A].


From UT Require Import Prelims.

Require Import Coq.Classes.CRelationClasses.
Require Import FunctionalExtensionality.

Class Setoid (A: Type): Type :=
   mkSetoid
   {
      et         :  crelation A where "a ~> b" := (et a b);
      eqv        :  ∏ x: A, x ~> x;
      star       :  ∏ {x y z: A}, x ~> y -> y ~> z -> x ~> z where "a 'o' b" := (star a b);
      inv        :  ∏ {x y: A}, x ~> y -> y ~> x;
   }.

Arguments et {_ _} _ _.
Arguments eqv {_ _} _.
Arguments star {_ _ _ _ _} _ _.
Notation "x 'o' y"   := (star x y): type_scope.
Notation "x '~>' y"  := (et x y) : type_scope.

Instance EqRel_et: ∏ {A} {S: Setoid A}, Equivalence (@et A S).
  constructor; intro.
        apply eqv.
        apply (@inv A).
        apply (@star A).
Defined.

Definition OppositeSetoid {A: Type} (S: Setoid A): Setoid A.
Proof. destruct S as (et, cc1, cc2, cc3).
        unshelve econstructor.
        - exact (flip et).
        - exact cc1.
        - intros x y z i1 i2.
          exact (cc2 z y x i2 i1).
        - intros x y.
          exact (cc3 y x).
Defined.

Program Definition OppositeS {A: Type} (S: Setoid A): Setoid A := {|
  et   := fun x y => y ~> x
  |}.
Next Obligation. exact (eqv x). Defined.
Next Obligation. exact (X0 o X). Defined.
Next Obligation. exact (inv X). Defined.

Definition ProductSetoid {A B: Type} (SA: Setoid A) (SB: Setoid B): Setoid (A * B).
Proof. unshelve econstructor.
       - intros a b.
         exact ((@et A SA (fst a) (fst b)) * (@et B SB (snd a) (snd b)))%type.
       - easy.
       - intros x y z Hx Hy.
         destruct Hx, Hy.
         split.
         + exact (e o e1).
         + exact (e0 o e2).
       - cbn. intros x y H.
         destruct H.
         split.
         + exact (inv e).
         + exact (inv e0).
Defined.