Section One.

(** Similar exercises can be found: http://www-sop.inria.fr/members/Enrico.Tassi/coqws15/coq-master1-1-exercises.v or here https://github.com/vlopezj/coq-course *)

Require Import Bool Arith List.

(*Define a function that takes a month and a season argument and returns true in case month and season match, False otherwise**)

(* Define a recursive function that takes as input a list of numbers
   and returns the sum  of these numbers, *)

Fixpoint sumlist (ns : list nat) := unit.

Compute sumlist nil.
Compute sumlist (0 :: 3 :: 7 :: nil).
Compute sumlist (3 :: 4 :: 2 :: nil).

(*Define a recursive function that takes as input a list of entities
   and returns the length of this list. *)
Definition e:=Set.
Fixpoint length (ns : list e) :=unit.

Parameter John Mary : e.
Compute length nil.
Compute length (John :: Mary :: John:: nil).

(** Define a function that subtracts 2 for every nat**)
Definition minustwo (n : nat) := unit.

(**)
Inductive Gender:Set:= Fem|Masc|Neut.
Inductive Case:Set:= Nom|Acc.
Parameter he she it him her they I me we  you: e.
Definition  pronoun (g: Gender) (c:Case):=
  match g, c with
|Fem, Nom=> she
|Fem, Acc => her
|Masc, Nom=> he
|Masc, Acc=> him
|Neut, _=> it
  end.
Compute pronoun Neut Acc.

(** extend the above function to all pronouns: use the extra features Number and Person**)
End One.


(* $Id: MoreIntegrals.v,v 1.15 2003/03/13 12:06:21 lcf Exp $ *)

Require Export Integral.
Require Export MoreFunctions.

Section Lemmas.

(* Tex_Prose
\chapter{The generalized integral}

In this file we extend the definition of integral to allow for arbitrary integration domains (that is, not requiring that the lower endpoint of integration be less or equal than the upper endpoint) and we prove the fundamental properties of the new operator.

\begin{convention} Let \verb!a,b:IR! and assume \verb!F,G! are partial functions continuous in $[\min(a,b),\max(a,b)]$.
\end{convention}

\section{Definitions}

Before we define the new integral we need to some trivial interval inclusions.
*)

Variables a,b:IR.
Hypothesis Hab:(Min a b)[<=](Max a b).

(* Begin_Tex_Verb *)
Lemma compact_inc_Min_lft : (H:?)
  (included (compact (Min a b) a H) (Compact Hab)).
(* End_Tex_Verb *)
Intros.
Apply included_compact; Split.
Apply leEq_reflexive.
Apply Min_leEq_Max.
Apply Min_leEq_lft.
Apply lft_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma compact_inc_Min_rht : (H:?)
  (included (compact (Min a b) b H) (Compact Hab)).
(* End_Tex_Verb *)
Intros.
Apply included_compact; Split.
Apply leEq_reflexive.
Apply Min_leEq_Max.
Apply Min_leEq_rht.
Apply rht_leEq_Max.
Qed.

End Lemmas.

Section Definitions.

(* Tex_Prose
The integral is defined by the formula $\int_a^bf=\int_{\min(a,b)}^bf-\int_{\min(a,b)}^af$, inspired by the domain union rule; obviously it coincides with the classical definition, and it collapses to the old one in the case $a\leq b$.
*)

Variables a,b:IR.
Hypothesis Hab:(Min a b)[<=](Max a b).
Variable F:PartIR.

Hypothesis HF:(Continuous_I Hab F).

(* Begin_Tex_Verb *)
Lemma Integral_inc1 :
  (Continuous_I (Min_leEq_lft a b) F).
(* End_Tex_Verb *)
EApply included_imp_contin with Hab:=Hab.
2: Apply HF.
Apply compact_inc_Min_lft.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_inc2 :
  (Continuous_I (Min_leEq_rht a b) F).
(* End_Tex_Verb *)
EApply included_imp_contin with Hab:=Hab.
2: Apply HF.
Apply compact_inc_Min_rht.
Qed.

(* Begin_Tex_Verb *)
Definition Integral :=
  (integral ?? (Min_leEq_rht a b) F Integral_inc2)
    [-](integral ?? (Min_leEq_lft a b) ? Integral_inc1).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma Integral_integral : (Hab':a[<=]b)(HF':?)
  Integral[=](integral ?? Hab' F HF').
(* End_Tex_Verb *)
Intros.
Unfold Integral.
Stepr (integral a b Hab' F HF')[-]Zero.
Apply cg_minus_wd.
Apply integral_wd'.
Apply leEq_imp_Min_is_lft; Assumption.
Algebra.
Apply integral_empty.
Apply leEq_imp_Min_is_lft; Assumption.
Qed.

End Definitions.

Implicits Integral [1 2 3 4].

Section Properties_of_Integral.

(* Tex_Prose
\section{Properties of the Integral}

All our old properties carry over to this new definition---and some new ones, too.  We begin with welldefinedness and strong extensionality.
*)

Variables a,b:IR.
Hypothesis Hab:(Min a b)[<=](Max a b).
Variables F,G:PartIR.

Hypothesis contF : (Continuous_I Hab F).
Hypothesis contG : (Continuous_I Hab G).

(* Begin_Tex_Verb *)
Lemma Integral_strext : ((Integral contF)[#](Integral contG))->
  {x:IR & (Compact Hab x) &
    (Hx,Hx':?)(Part F x Hx)[#](Part G x Hx')}.
(* End_Tex_Verb *)
Intro.
Unfold Integral in H.
Elim (cg_minus_strext ????? H); Intro.
Elim (integral_strext ??????? a0); Intros.
Exists x.
Apply compact_inc_Min_rht with H:=(Min_leEq_rht a b); Assumption.
Assumption.
Elim (integral_strext ??????? b0); Intros.
Exists x.
Apply compact_inc_Min_lft with H:=(Min_leEq_lft a b); Assumption.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_strext' : (c,d,Hcd,HF1,HF2:?)
  (((!Integral ?? Hab F HF1)[#](!Integral c d Hcd F HF2))->
    (a[#]c)+(b[#]d)).
(* End_Tex_Verb *)
Intros.
Elim (cg_minus_strext ????? H); Clear H; Intro H; Elim (integral_strext' ????????? H); Clear H; Intro H.
Elim (min_strext_unfolded ???? H); Auto.
Auto.
Elim (min_strext_unfolded ???? H); Auto.
Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_wd : (Feq (Compact Hab) F G)->
  (Integral contF)[=](Integral contG).
(* End_Tex_Verb *)
Intros; Unfold Integral.
Apply cg_minus_wd; Apply integral_wd.
Apply included_Feq with (Compact Hab).
Apply compact_inc_Min_rht.
Assumption.
Apply included_Feq with (Compact Hab).
Apply compact_inc_Min_lft.
Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_wd' : (a',b',Ha'b',contF':?)
  (a[=]a')->(b[=]b')->
  (Integral contF)[=](!Integral a' b' Ha'b' F contF').
(* End_Tex_Verb *)
Intros.
Unfold Integral.
Apply cg_minus_wd; Apply integral_wd'; Try Apply bin_op_wd_unfolded; Algebra.
Qed.

(* Tex_Prose
The integral is a linear operator.
*)

(* Begin_Tex_Verb *)
Lemma Integral_const : (c:IR)
  (H:(Continuous_I Hab {-C-}c))(Integral H)[=]c[*](b[-]a).
(* End_Tex_Verb *)
Intros.
Unfold Integral.
RStepr c[*](b[-](Min a b))[-]c[*](a[-](Min a b)).
Apply cg_minus_wd; Apply integral_const.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_comm_scal : (c:IR)
  (H:(Continuous_I Hab c{**}F))
    (Integral H)[=]c[*](Integral contF).
(* End_Tex_Verb *)
Intros.
Unfold Integral.
EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply dist_2a.
Apply cg_minus_wd; Apply integral_comm_scal.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_plus : (H:(Continuous_I Hab F{+}G))
  (Integral H)[=](Integral contF)[+](Integral contG).
(* End_Tex_Verb *)
Intro.
Unfold Integral.
Cut (x,y,z,w:IR)((x[-]y)[+](z[-]w))[=]((x[+]z)[-](y[+]w)); Intros.
2: Rational.
EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply H0.
Apply cg_minus_wd; Apply integral_plus.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_inv : (H:(Continuous_I Hab {--}F))
  (Integral H)[=][--](Integral contF).
(* End_Tex_Verb *)
Intro.
Unfold Integral.
Cut (x,y:IR)([--](x[-]y)[=]([--]x[-][--]y)); Intros.
2: Rational.
EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply H0.
Apply cg_minus_wd; Apply integral_inv.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_minus : (H:(Continuous_I Hab F{-}G))
  (Integral H)[=](Integral contF)[-](Integral contG).
(* End_Tex_Verb *)
Intro.
Unfold Integral.
Cut (x,y,z,w:IR)((x[-]y)[-](z[-]w))[=]((x[-]z)[-](y[-]w)); Intros.
2: Rational.
EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply H0.
Apply cg_minus_wd; Apply integral_minus.
Qed.

(* Begin_Tex_Verb *)
Lemma linear_Integral : (alpha,beta:IR)
  (H:(Continuous_I Hab alpha{**}F{+}beta{**}G))
  (Integral H)[=]
    alpha[*](Integral contF)[+]beta[*](Integral contG).
(* End_Tex_Verb *)
Intros; Unfold Integral.
Cut (x,y,z,r,s,t:IR)(x[*](y[-]z)[+]r[*](s[-]t))[=](x[*]y[+]r[*]s)[-](x[*]z[+]r[*]t).
2: Intros; Rational.
Intro; EApply eq_transitive_unfolded.
2: Apply eq_symmetric_unfolded; Apply H0.
Clear H0.
Apply cg_minus_wd; Apply linear_integral.
Qed.

(* Tex_Prose
If the endpoints are equal then the integral vanishes.
*)

(* Begin_Tex_Verb *)
Lemma Integral_empty : (a[=]b)->(Integral contF)[=]Zero.
(* End_Tex_Verb *)
Intros.
Unfold Integral.
Stepr (Zero::IR)[-]Zero.
Apply cg_minus_wd; Apply integral_empty.
Stepr a; Apply leEq_imp_Min_is_lft; Apply eq_imp_leEq; Assumption.
Apply leEq_imp_Min_is_lft; Apply eq_imp_leEq; Assumption.
Qed.

(* Tex_Prose
And the norm provides an upper bound for the absolute value of the integral.
*)

(* Begin_Tex_Verb *)
Lemma Integral_leEq_norm : (AbsIR (Integral contF))[<=]
  (Norm_Funct contF)[*](AbsIR b[-]a).
(* End_Tex_Verb *)
Unfold Integral.
EApply leEq_transitive.
Apply triangle_IR_minus.
Apply leEq_transitive with (Norm_Funct contF)[*](b[-](Min a b))[+](Norm_Funct contF)[*](a[-](Min a b)).
Apply plus_resp_leEq_both; (EApply leEq_transitive; [Apply integral_leEq_norm | Apply mult_resp_leEq_rht]).
Apply leEq_Norm_Funct; Intros.
Apply norm_bnd_AbsIR; Apply compact_inc_Min_rht with H:=(Min_leEq_rht a b); Assumption.
Apply shift_leEq_minus; Step (Min a b); Apply Min_leEq_rht.
Apply leEq_Norm_Funct; Intros.
Apply norm_bnd_AbsIR; Apply compact_inc_Min_lft with H:=(Min_leEq_lft a b); Assumption.
Apply shift_leEq_minus; Step (Min a b); Apply Min_leEq_lft.
EApply leEq_wdl.
2: Apply ring_dist_unfolded.
Apply mult_resp_leEq_lft.
2: Apply positive_norm.
RStep (a[+]b)[-]Two[*](Min a b).
Apply shift_minus_leEq; Apply shift_leEq_plus'.
Apply shift_leEq_mult' with (two_ap_zero IR).
Apply pos_two.
Apply leEq_Min.
Apply shift_div_leEq.
Apply pos_two.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
RStep b[-]a; Apply leEq_AbsIR.
Apply shift_div_leEq.
Apply pos_two.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
RStep [--](b[-]a); Apply inv_leEq_AbsIR.
Qed.

End Properties_of_Integral.

Section More_Properties.

(* Tex_Prose
Two other ways of stating the addition law for domains.
*)

(* Begin_Tex_Verb *)
Lemma integral_plus_Integral :
  (a,b,Hab,F,c,Hac,Hcb,Hab',Hac',Hcb':?)
    (integral c b Hcb F Hcb')[=]
      (integral a b Hab F Hab')[-](integral a c Hac F Hac').
(* End_Tex_Verb *)
Intros.
RStep ((integral a c Hac F Hac')[+](integral c b Hcb F Hcb'))[-](integral a c Hac F Hac').
Apply cg_minus_wd.
Apply integral_plus_integral.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma integral_plus_integral' :
  (a,b,Hab,F,c,Hac,Hcb,Hab',Hac',Hcb':?)
    (integral a c Hac F Hac')[=]
      (integral a b Hab F Hab')[-](integral c b Hcb F Hcb').
(* End_Tex_Verb *)
Intros.
RStep ((integral a c Hac F Hac')[+](integral c b Hcb F Hcb'))[-](integral c b Hcb F Hcb').
Apply cg_minus_wd.
Apply integral_plus_integral.
Algebra.
Qed.

(* Tex_Prose
And now we can prove the addition law for domains with our general operator.

\begin{convention} Assume \verb!c:IR!.
\end{convention}
*)

Variables a,b,c:IR.
(* Begin_Tex_Verb *)
Hypothesis Hab':(Min a b)[<=](Max a b).
Hypothesis Hac':(Min a c)[<=](Max a c).
Hypothesis Hcb':(Min c b)[<=](Max c b).
Hypothesis Habc':(Min (Min a b) c)[<=](Max (Max a b) c).
(* End_Tex_Verb *)

Variable F:PartIR.

(* Begin_Tex_Verb *)
Hypothesis Hab:(Continuous_I Hab' F).
Hypothesis Hac:(Continuous_I Hac' F).
Hypothesis Hcb:(Continuous_I Hcb' F).
Hypothesis Habc:(Continuous_I Habc' F).
(* End_Tex_Verb *)

Local le_abc_ab : (Min (Min a b) c)[<=](Min a b).
Apply Min_leEq_lft.
Qed.

Local le_abc_ac : (Min (Min a b) c)[<=](Min a c).
Apply leEq_Min.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply Min_leEq_lft.
Apply Min_leEq_rht.
Qed.

Local le_abc_cb : (Min (Min a b) c)[<=](Min c b).
Apply leEq_Min.
Apply Min_leEq_rht.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply Min_leEq_rht.
Qed.

Local le_abc_a : (Min (Min a b) c)[<=]a.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply Min_leEq_lft.
Qed.

Local le_abc_b : (Min (Min a b) c)[<=]b.
EApply leEq_transitive.
Apply Min_leEq_lft.
Apply Min_leEq_rht.
Qed.

Local le_abc_c : (Min (Min a b) c)[<=]c.
Apply Min_leEq_rht.
Qed.

Local le_ab_a : (Min a b)[<=]a.
Apply Min_leEq_lft.
Qed.

Local le_cb_c : (Min c b)[<=]c.
Apply Min_leEq_lft.
Qed.

Local le_ac_a : (Min a c)[<=]a.
Apply Min_leEq_lft.
Qed.

Local le_ab_b : (Min a b)[<=]b.
Apply Min_leEq_rht.
Qed.

Local le_cb_b : (Min c b)[<=]b.
Apply Min_leEq_rht.
Qed.

Local le_ac_c : (Min a c)[<=]c.
Apply Min_leEq_rht.
Qed.

Local Habc_abc : (Compact Habc' (Min (Min a b) c)).
Apply compact_inc_lft.
Qed.

Local Habc_ab : (Continuous_I le_abc_ab F).
Apply included_imp_contin with Hab:=Habc'.
2: Apply Habc.
Apply included_compact; [Apply Habc_abc | Split].
Apply Min_leEq_lft.
EApply leEq_transitive.
Apply Min_leEq_Max.
Apply lft_leEq_Max.
Qed.

Local Habc_ac : (Continuous_I le_abc_ac F).
Apply included_imp_contin with Hab:=Habc'.
2: Apply Habc.
Apply included_compact; [Apply Habc_abc | Split].
Apply le_abc_ac.
EApply leEq_transitive.
Apply Min_leEq_Max.
Apply Max_leEq.
EApply leEq_transitive.
2: Apply lft_leEq_Max.
Apply lft_leEq_Max.
Apply rht_leEq_Max.
Qed.

Local Habc_cb : (Continuous_I le_abc_cb F).
Apply included_imp_contin with Hab:=Habc'.
2: Apply Habc.
Apply included_compact; [Apply Habc_abc | Split].
Apply le_abc_cb.
EApply leEq_transitive.
2: Apply rht_leEq_Max.
Apply Min_leEq_lft.
Qed.

Local Habc_a : (Continuous_I le_abc_a F).
Apply included_imp_contin with Hab:=Habc'.
2: Apply Habc.
Apply included_compact; [Apply Habc_abc | Split].
Apply le_abc_a.
EApply leEq_transitive.
2: Apply lft_leEq_Max.
Apply lft_leEq_Max.
Qed.

Local Habc_b : (Continuous_I le_abc_b F).
Apply included_imp_contin with Hab:=Habc'.
2: Apply Habc.
Apply included_compact; [Apply Habc_abc | Split].
Apply le_abc_b.
EApply leEq_transitive.
2: Apply lft_leEq_Max.
Apply rht_leEq_Max.
Qed.

Local Habc_c : (Continuous_I le_abc_c F).
Apply included_imp_contin with Hab:=Habc'.
2: Apply Habc.
Apply included_compact; [Apply Habc_abc | Split].
Apply le_abc_c.
Apply rht_leEq_Max.
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_plus_Integral :
  (Integral Hab)[=](Integral Hac)[+](Integral Hcb).
(* End_Tex_Verb *)
Unfold Integral.
Apply eq_transitive_unfolded with ((integral ?? le_abc_b ? Habc_b)[-](integral ?? le_abc_ab ? Habc_ab))
  [-]((integral ?? le_abc_a ? Habc_a)[-](integral ?? le_abc_ab ? Habc_ab)).
Apply cg_minus_wd; Apply integral_plus_Integral.
RStep (integral ?? le_abc_b ? Habc_b)[-](integral ?? le_abc_a ? Habc_a).
RStep (((integral ?? le_abc_c ? Habc_c)[-](integral ?? le_abc_ac ? Habc_ac))[-]
    ((integral ?? le_abc_a ? Habc_a)[-](integral ?? le_abc_ac ? Habc_ac)))[+]
  (((integral ?? le_abc_b ? Habc_b)[-](integral ?? le_abc_cb ? Habc_cb))[-]
    ((integral ?? le_abc_c ? Habc_c)[-](integral ?? le_abc_cb ? Habc_cb))).
Apply eq_symmetric_unfolded; Apply bin_op_wd_unfolded; Apply cg_minus_wd; Apply integral_plus_Integral.
Qed.

(* Tex_Prose
Notice that, unlike in the classical case, an extra hypothesis (the continuity of $F$ in the interval $[\min(a,b,c),\max(a,b,c)]$) must be assumed.
*)

End More_Properties.

Section Corollaries.

Variables a,b:IR.
Hypothesis Hab:(Min a b)[<=](Max a b).
Variable F:PartIR.

Hypothesis contF:(Continuous_I Hab F).

(* Tex_Prose
As a corollary, we get the following rule:
*)
(* Begin_Tex_Verb *)
Lemma Integral_op : (Hab':?)
  (contF':(!Continuous_I (Min b a) (Max b a) Hab' F))
  (Integral contF)[=][--](Integral contF').
(* End_Tex_Verb *)
Intros.
Apply cg_inv_unique'.
Cut (Continuous_I (Min_leEq_Max a a) F); Intros.
Apply eq_transitive_unfolded with (Integral H).
Cut (Min (Min a a) b)[<=](Max (Max a a) b); Intros.
Apply eq_symmetric_unfolded; Apply Integral_plus_Integral with H0.
Cut (included (Compact H0) (Compact Hab)); Intros.
Exact (included_imp_contin ??????? H1 contF).
Apply included_compact.
Split.
Apply leEq_Min.
Apply leEq_transitive with a.
Apply Min_leEq_lft.
Apply eq_imp_leEq; Apply eq_symmetric_unfolded; Apply Min_id.
Apply Min_leEq_rht.
Apply leEq_transitive with b.
Apply Min_leEq_rht.
Apply rht_leEq_Max.
Split.
Apply leEq_transitive with b.
Apply Min_leEq_rht.
Apply rht_leEq_Max.
Apply Max_leEq.
Apply leEq_wdl with a.
Apply lft_leEq_Max.
Apply eq_symmetric_unfolded; Apply Max_id.
Apply rht_leEq_Max.
Apply leEq_transitive with b.
Apply Min_leEq_rht.
Apply rht_leEq_Max.
Apply Integral_empty; Algebra.
Apply included_imp_contin with Hab:=Hab.
2: Apply contF.
Red; Intros.
Apply compact_wd with a.
Split.
Apply Min_leEq_lft.
Apply lft_leEq_Max.
Inversion_clear H.
Apply leEq_imp_eq.
EApply leEq_wdl.
Apply H0.
Apply Min_id.
EApply leEq_wdr.
Apply H1.
Apply Max_id.
Qed.

(* Tex_Prose
Finally, some miscellaneous results:
*)

(* Begin_Tex_Verb *)
Lemma Integral_less_norm : (a[#]b)->
  (x:IR)(Compact Hab x)->(Hx:?)
    ((AbsIR (F x Hx))[<](Norm_Funct contF))->
  (AbsIR (Integral contF))[<](Norm_Funct contF)[*](AbsIR b[-]a).
(* End_Tex_Verb *)
Intros.
LetTac N:=(Norm_Funct contF).
Elim (ap_imp_less ??? H); Intro.
Apply less_wdr with N[*](b[-]a).
EApply less_wdl.
EApply less_leEq_trans.
Apply integral_less_norm with contF:=(included_imp_contin ??????? (compact_map2 a b (less_leEq ??? a0) Hab) contF) Hx:=Hx; Auto.
Apply compact_map1 with Hab':=Hab; Auto.
EApply less_leEq_trans.
Apply H1.
Unfold N; Apply included_imp_norm_leEq.
Apply compact_map1.
Apply mult_resp_leEq_rht.
Unfold N; Apply included_imp_norm_leEq.
Apply compact_map2.
Apply shift_leEq_minus; Apply less_leEq.
Step a; Auto.
Apply AbsIR_wd; Apply eq_symmetric_unfolded.
Apply Integral_integral.
Apply mult_wd_rht.
Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Apply shift_leEq_minus; Apply less_leEq.
Step a; Auto.

Apply less_wdr with N[*](a[-]b).
LetTac Hmin := (Min_leEq_Max b a).
Cut (included (Compact Hmin) (Compact Hab)).
Cut (included (Compact Hab) (Compact Hmin)); Intros.
Cut (Continuous_I Hmin F); Intros.
EApply less_wdl.
EApply less_leEq_trans.
Apply integral_less_norm with contF:=(included_imp_contin ??????? (compact_map2 ?? (less_leEq ??? b0) Hmin) H4) Hx:=Hx; Auto.
Apply compact_map1 with Hab':=Hmin; Auto.
EApply less_leEq_trans.
Apply H1.
Unfold N; Apply included_imp_norm_leEq.
EApply included_trans.
2: Apply compact_map1 with Hab':=Hmin.
Apply H2.
Apply mult_resp_leEq_rht.
Unfold N; Apply included_imp_norm_leEq.
EApply included_trans.
Apply compact_map2 with Hab':=Hmin.
Apply H3.
Apply shift_leEq_minus; Apply less_leEq.
Step b; Auto.
EApply eq_transitive_unfolded.
Apply AbsIR_inv.
Apply AbsIR_wd; Apply eq_symmetric_unfolded.
Apply eq_transitive_unfolded with [--](Integral (included_imp_contin ??????? H3 contF)).
Apply Integral_op.
Apply un_op_wd_unfolded.
Apply Integral_integral.
Apply included_imp_contin with Hab:=Hab; Auto.
Red; Intros.
Apply compact_wd' with Hab:=Hab.
Apply Min_comm.
Apply Max_comm.
Auto.
Red; Intros.
Apply compact_wd' with Hab:=Hmin.
Apply Min_comm.
Apply Max_comm.
Auto.
Apply mult_wd_rht.
EApply eq_transitive_unfolded.
Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Apply shift_leEq_minus; Apply less_leEq.
Step b; Auto.
Apply AbsIR_minus.
Qed.

(* Begin_Tex_Verb *)
Lemma ub_Integral : (a[#]b)->(c:IR)
  ((x:IR)(Compact Hab x)->(Hx:?)((AbsIR (F x Hx))[<=]c))->
  (x:IR)(Compact Hab x)->(Hx:?)((AbsIR (F x Hx))[<]c)->
  (AbsIR (Integral contF))[<]c[*](AbsIR b[-]a).
(* End_Tex_Verb *)
Intros.
LetTac N:=(Norm_Funct contF).
Cut N[<=]c; Intros.
Elim (cotrans_less_unfolded ??? H2 N); Intros.
Apply less_leEq_trans with N[*](AbsIR b[-]a).
Unfold N; Apply Integral_less_norm with x Hx; Auto.
Apply mult_resp_leEq_rht; Auto.
Apply AbsIR_nonneg.
Apply leEq_less_trans with N[*](AbsIR b[-]a).
Unfold N; Apply Integral_leEq_norm.
Apply mult_resp_less; Auto.
Apply AbsIR_pos.
Apply minus_ap_zero.
Apply ap_symmetric_unfolded; Auto.
Unfold N; Apply leEq_Norm_Funct; Auto.
Qed.

End Corollaries.

(* Begin_Tex_Verb *)
Lemma Integral_ap_zero :
  (a,b,Hab:?)(F:PartIR)(contF:?)(a[#]b)->
  (x:IR)(Compact Hab x)->(Hx:?)(Zero[<](F x Hx))->
  ((x:IR)(Compact Hab x)->(Hx:?)(Zero[<=](F x Hx)))->
  Zero[<](AbsIR (!Integral a b Hab F contF)).
(* End_Tex_Verb *)
Intros.
Elim (ap_imp_less ??? H); Intro.
EApply less_leEq_trans.
2: Apply leEq_AbsIR.
EApply less_wdr.
2: Apply eq_symmetric_unfolded.
2: Apply Integral_integral with HF':=(included_imp_contin ??????? (compact_map2 a b (less_leEq ??? a0) Hab) contF).
EApply integral_gt_zero with x Hx; Auto.
Exact (compact_map1 ?? (less_leEq ??? a0) Hab x H0).
Intros; Apply H2.
Exact (compact_map2 ?? (less_leEq ??? a0) Hab ? H3).

Cut (included (Compact (Min_leEq_Max b a)) (Compact Hab)).
2: Apply included_compact; Split.
2: Apply eq_imp_leEq; Apply Min_comm.
2: Apply leEq_transitive with a; [Apply Min_leEq_rht | Apply lft_leEq_Max].
2: Apply leEq_transitive with b; [Apply Min_leEq_rht | Apply lft_leEq_Max].
2: Apply eq_imp_leEq; Apply Max_comm.
Cut (included (Compact Hab) (Compact (Min_leEq_Max b a))).
2: Apply included_compact; Split.
2: Apply eq_imp_leEq; Apply Min_comm.
2: Apply leEq_transitive with b; [Apply Min_leEq_rht | Apply lft_leEq_Max].
2: Apply leEq_transitive with a; [Apply Min_leEq_rht | Apply lft_leEq_Max].
2: Apply eq_imp_leEq; Apply Max_comm.
Intros.
EApply less_leEq_trans.
2: Apply inv_leEq_AbsIR.
EApply less_wdr.
2: Apply Integral_op with contF:=(included_imp_contin ??????? H4 contF).
EApply less_wdr.
2: Apply eq_symmetric_unfolded.
2: Apply Integral_integral with
  HF':=(included_imp_contin ??????? (compact_map2 ?? (less_leEq ??? b0) (Min_leEq_Max b a)) (included_imp_contin ??????? H4 contF)).
EApply integral_gt_zero with x Hx; Auto.
Exact (compact_map1 ?? (less_leEq ??? b0) (Min_leEq_Max b a) x (H3 x H0)).
Intros; Apply H2.
Exact (H4 ? (compact_map2 ?? (less_leEq ??? b0) (Min_leEq_Max ??) ? H5)).
Qed.

(* Begin_Tex_Verb *)
Lemma Integral_eq_zero :
  (a,b,Hab:?)(F:PartIR)(contF:?)
  (x:IR)(Compact Hab x)->((Hx:?)(Zero[<](F x Hx)))->
  ((x:IR)(Compact Hab x)->(Hx:?)(Zero[<=](F x Hx)))->
  (((!Integral a b Hab F contF)[=]Zero)->(a[=]b)).
(* End_Tex_Verb *)
Intros.
Apply not_ap_imp_eq; Intro.
Apply less_irreflexive_unfolded with x:=(Zero::IR).
Apply less_wdr with (AbsIR (Integral contF)).
2: Step_final (AbsIR Zero).
Apply Integral_ap_zero with x (contin_imp_inc ???? contF x H); Auto.
Qed.


Require Import
  ExtLib.Structures.Monad
  ExtLib.Structures.Functor
  ExtLib.Structures.Applicative
  ExtLib.Structures.MonadLaws
  ExtLib.Structures.FunctorLaws
  Coq.Unicode.Utf8
  Coq.Logic.FunctionalExtensionality
  Coq.PArith.Pnat Coq.NArith.BinNatDef
  Coq.PArith.BinPos Lia Coq.Lists.List
  Coq.Classes.Morphisms
  Coq.Classes.SetoidClass
  Coq.Sorting.Permutation
  Coq.Relations.Relation_Definitions
  Coq.Logic.FunctionalExtensionality
  Sigma.Prob Sigma.Util.

Import ListNotations.
Section Distr.

  (* Probability Distribution on a type A *)
  Definition dist (A : Type) : Type := list (A * prob).

  (* Equality on probability distributions. Two probability
    distributions are equal when they are Permutation of
    each other.
  *)

  Definition dist_equiv {A : Type} : relation (dist A) :=
    fun xs ys => Permutation xs ys.

  Local Infix "=r=" := dist_equiv
    (at level 70, no associativity).

  (* dist_equiv is Equivalence relation *)
  Global Instance dist_refl {A : Type} :
    Reflexive (@dist_equiv A).
  Proof.
    unfold dist_equiv; eauto.
  Qed.

  Global Instance dist_sym {A : Type} :
    Symmetric (@dist_equiv A).
  Proof.
    unfold dist_equiv,
    Symmetric.
    intros * Ha.
    eapply Permutation_sym;
    assumption.
  Qed.

  Global Instance dist_trans {A : Type} :
    Transitive (@dist_equiv A).
  Proof.
    unfold dist_equiv,
    Transitive.
    intros * Ha Hb.
    eapply Permutation_trans;
    [exact Ha | exact Hb].
  Qed.

  Global Instance dist_Equiv {A : Type} :
    Equivalence (@dist_equiv A).
  Proof.
    constructor;
    [apply dist_refl |
     apply dist_sym |
     apply dist_trans].
  Qed.

  (* end of equivalence relation *)

  Global Instance cons_proper {A : Type} (d : A * prob)
    : Proper (dist_equiv ==> dist_equiv) (cons d).
  Proof.
    intros x y Hxy.
    unfold dist_equiv in * |- *.
    eapply Permutation_cons;
    [exact eq_refl | exact Hxy].
  Qed.

  Global Instance app_proper {A : Type} (ys : dist A) :
    Proper (dist_equiv ==> dist_equiv) (fun xs => xs ++ ys).
  Proof.
    intros x y Hxy.
    unfold dist_equiv in * |- *.
    eapply Permutation_app_tail;
    assumption.
  Qed.

  Global Instance app_end_proper {A : Type} (ys : dist A) :
    Proper (dist_equiv ==> dist_equiv) (fun xs => ys ++ xs).
  Proof.
    intros x y Hxy.
    unfold dist_equiv in * |- *.
    eapply Permutation_app;
    [eapply Permutation_refl | exact Hxy].
  Qed.

  Lemma dist_equiv_inv_perm {A : Type} :
    forall (xs ys : dist A) a, xs =r= ys ->
    cons a xs =r= ys ++ [a].
  Proof.
    unfold dist_equiv.
    intros * Ha.
    pose proof (@Permutation_elt _ [] xs ys [] a) as Hb.
    rewrite app_nil_r, app_nil_l in Hb.
    exact (Hb Ha).
  Qed.

  Lemma dist_equiv_first_last {A : Type} :
    forall (xs : dist A) a, cons a xs =r= xs ++ [a].
  Proof.
    intros ? ?.
    assert (Ht: xs =r= xs).
    reflexivity.
    exact (dist_equiv_inv_perm xs xs a Ht).
  Qed.

  Lemma dist_equiv_inv_comm {A : Type} :
    forall (xs ys : dist A), xs ++ ys =r= ys ++ xs.
  Proof.
    unfold dist_equiv.
    intros ? ?.
    eapply Permutation_app_comm.
  Qed.

  (* Probability Monad *)
  Definition Ret {A : Type} (x : A) : dist A := [(x, one)].

  Fixpoint Bind {A B : Type} (xs : dist A)
    (f : A -> dist B) : dist B :=
    match xs with
    | [] => []
    | (ax, px) :: tx =>
      (List.map
        (fun '(ut, pt) => (ut, mul_prob px pt)) (f ax)) ++
      Bind tx f
    end.

  Global Instance distmonad : Monad dist.
  Proof.
    constructor.
    + exact @Ret.
    + exact @Bind.
  Defined.

  Lemma bind_ret_left : forall (A B : Type)
    (a : A) (f : A -> dist B), Bind (Ret a) f = f a.
  Proof.
    intros ? ? ? f.
    unfold Bind, Ret.
    rewrite app_nil_r.
    induction (f a) as [ |(bx, px) ts IHn].
    + simpl; reflexivity.
    + simpl; repeat f_equal.
      destruct px;
      repeat f_equal;
      try lia.
      apply IHn.
  Qed.

  Lemma bind_ret_right : forall (A B : Type)
    (a : dist A), Bind a Ret = a.
  Proof.
    intros ? ? a.
    unfold Bind, Ret, mul_prob.
    induction a as [| (bx, px) ts IHn].
    + simpl; reflexivity.
    + simpl; repeat f_equal.
      destruct px;
      repeat f_equal;
      try lia.
      apply IHn.
  Qed.

  Lemma bind_map : ∀ (A B C : Type)
    (ax : A)  (f : A -> dist B)
    (g : B -> dist C)
    (ts : dist A) (px : prob),
    Bind (map (λ '(ut, pt),
      (ut, mul_prob px pt)) (f ax) ++ Bind ts f) g =
    map (λ '(ut, pt), (ut, mul_prob px pt))
      (Bind (f ax) g) ++ Bind (Bind ts f) g.
  Proof.
    intros ? ? ? ? ?.
    induction (f ax) as [| (axx, pxx) tss IHn].
    + simpl;
      intros ? ? p;
      reflexivity.
    + intros ? ? ?.
      simpl.
      rewrite IHn.
      rewrite app_assoc.
      eapply app_inv_tail_iff.
      rewrite map_app, map_map.
      apply app_inv_tail_iff,
      map_ext.
      intros [ut pt].
      rewrite mul_prob_assoc.
      reflexivity.
  Qed.

  Lemma bind_assoc : ∀ (A B C : Type)
    (am : dist A) (f : A -> dist B) (g : B -> dist C),
    Bind (Bind am f) g = Bind am (fun a => Bind (f a) g).
  Proof.
    intros ? ? ?.
    induction am as [| (ax, px) ts IHn].
    + simpl.
      reflexivity.
    + intros ? ?.
      simpl.
      rewrite <-IHn.
      rewrite bind_map;
      reflexivity.
  Qed.

  Global Instance distmonad_law : MonadLaws distmonad.
  Proof.
    constructor; intros.
    + apply bind_ret_left.
    + apply bind_ret_right;
      exact A.
    + apply bind_assoc.
  Defined.

  (* Uniform distribution u*)
  Definition uniform_with_replacement {A : Type} :
    forall (l : list A), l <> [] -> dist A.
  Proof.
    intros ? H.
    remember (Pos.of_nat (List.length l)) as len.
    exact (List.map (fun x =>  (x, mk_prob 1 len)) l).
  Defined.

  (* function that adds all the probabilities  *)
  Definition sum_of_uniform_with_replacement {A : Type} :
    dist A -> prob.
  Proof.
    intros d.
    exact (List.fold_right
      (fun '(_, y) acc => add_prob acc y)
      zero d).
  Defined.

  Definition prob_equiv : relation prob :=
    fun p q => prob_eq p q = true.

  Local Infix "=p=" := prob_equiv
    (at level 70, no associativity).

  Global Instance prob_R : Reflexive (prob_equiv).
  Proof.
    intro x.
    apply prob_eq_refl.
  Qed.

  Global Instance prob_S : Symmetric (prob_equiv).
  Proof.
    intros [ax px] [ay py] Hxy; subst.
    unfold prob_equiv, prob_eq in * |- *.
    apply PeanoNat.Nat.eqb_eq in Hxy.
    apply PeanoNat.Nat.eqb_eq. nia.
  Qed.

  Global Instance prob_T : Transitive (prob_equiv).
  Proof.
    intros [ax px] [bx qx] [cx rx] Hx Hy.
    unfold prob_equiv, prob_eq in * |- *.
    apply PeanoNat.Nat.eqb_eq in Hx, Hy.
    apply PeanoNat.Nat.eqb_eq. nia.
  Qed.

  Global Instance prob_Equiv : Equivalence (prob_equiv).
  Proof.
    constructor; [apply prob_R | apply prob_S | apply prob_T].
  Qed.

  Global Instance add_proper :
    Proper (prob_equiv ==> prob_equiv ==> prob_equiv) (@add_prob).
  Proof.
    intros [ax px] [bx qx] Hxy [ux uy] [vx vy] Huv.
    unfold add_prob, prob_equiv, prob_eq in * |- *.
    apply PeanoNat.Nat.eqb_eq in Hxy, Huv.
    apply PeanoNat.Nat.eqb_eq.
    repeat rewrite Pos2Nat.inj_mul,
      PeanoNat.Nat.mul_assoc.
    repeat rewrite PeanoNat.Nat.mul_add_distr_r.
    assert (Ht₁: ax * Pos.to_nat uy * Pos.to_nat qx * Pos.to_nat vy =
      ax * Pos.to_nat qx * Pos.to_nat uy * Pos.to_nat vy) by nia.
    rewrite Ht₁, Hxy;
    clear Ht₁.
    assert (Ht₁: ux * Pos.to_nat px * Pos.to_nat qx * Pos.to_nat vy =
      ux * Pos.to_nat vy * Pos.to_nat px * Pos.to_nat qx) by nia.
    rewrite Ht₁, Huv;
    clear Ht₁.
    nia.
  Qed.

  Global Instance mul_proper :
    Proper (prob_equiv ==> prob_equiv ==> prob_equiv) (@mul_prob).
  Proof.
    intros [ax px] [bx qx] Hxy [ux uy] [vx vy] Huv.
    unfold mul_prob, prob_equiv, prob_eq in * |- *.
    apply PeanoNat.Nat.eqb_eq in Hxy, Huv.
    apply PeanoNat.Nat.eqb_eq.
    repeat rewrite Pos2Nat.inj_mul,
      PeanoNat.Nat.mul_assoc.
    nia.
  Qed.

  Definition prop_Eqdec :
    forall p q : prob, {p =p= q} + {~(p =p= q)}.
  Proof.
    intros [px qx] [py qy];
    unfold add_prob, prob_equiv, prob_eq in * |- *.
    destruct (Nat.eqb (px * Pos.to_nat qy) (py * Pos.to_nat qx)).
    + left; reflexivity.
    + right; intro H; inversion H.
  Defined.

  Lemma one_prob :
    forall a b, mk_prob a b =p= one <-> a = Pos.to_nat b.
  Proof.
    intros ? ?; simpl; split; intro H.
    unfold one in H.
    unfold prob_equiv, prob_eq in  H.
    apply PeanoNat.Nat.eqb_eq in H. nia.
    unfold one.
    unfold prob_equiv, prob_eq.
    apply PeanoNat.Nat.eqb_eq.
    nia.
  Qed.

  Lemma eq_prob :
    forall p, p =p= one <-> num p = Pos.to_nat (denum p).
  Proof.
    intros [ap bp]; simpl; split; intro H.
    apply one_prob in H. nia.
    apply one_prob. nia.
  Qed.

  Lemma fold_right_map_add : forall (A : Type) (l : list A) (k : nat),
    fold_right (λ '(_, y) (acc : prob), add_prob acc y) zero
    (map (λ x : A, (x, {| num := 1; denum := Pos.of_nat k |})) l) =p=
    mk_prob (List.length l) (Pos.of_nat k).
  Proof.
    intros ?.
    induction l.
    + intros ?; reflexivity.
    + intros ?.
      rewrite map_cons.
      simpl; specialize (IHl k).
      rewrite add_prob_comm.
      remember (fold_right (λ '(_, y) (acc : prob), add_prob acc y) zero
        (map (λ x : A, (x, {| num := 1; denum := Pos.of_nat k |})) l)) as Hf.
      destruct Hf. simpl.
      apply PeanoNat.Nat.eqb_eq.
      apply PeanoNat.Nat.eqb_eq in IHl.
      rewrite IHl. nia.
  Qed.

  Lemma uniform_with_replacement_adds_to_one {A : Type} :
    forall (l : list A) (d : dist A) (H₁ : l <> [])
    (H₂ : d = uniform_with_replacement l H₁),
    sum_of_uniform_with_replacement d =p= one.
  Proof.
    unfold uniform_with_replacement,
    sum_of_uniform_with_replacement.
    intros ? ? Hl Hd.
    subst.
    rewrite fold_right_map_add.
    unfold prob_equiv, one,
    prob_eq.
    apply PeanoNat.Nat.eqb_eq.
    rewrite Nat2Pos.id; try nia.
    assert (Hw: exists w, length l = S w).
    destruct l.
    unfold not in Hl;
    specialize (Hl eq_refl);
    inversion Hl.
    eexists; simpl;
    eauto.
    destruct Hw as [w Hw].
    rewrite Hw.
    nia.
  Qed.

  Lemma prob_list : ∀ (A : Type)
    (xf : A) (pf : prob) (plv : positive) (la : list A),
    In (xf, pf) (map
      (λ x : A, (x, {| num := 1; denum := plv |})) la) <->
    In xf la ∧ pf = mk_prob 1 plv.
  Proof.
    intros ? ? ? ? ?.
    revert xf pf plv.
    induction la.
    + intros ? ? ?;
      split; intro Hin.
      inversion Hin.
      inversion Hin;
      inversion H.
    + intros ? ? ?;
      split;
      intro Hin.
      rewrite map_cons in Hin.
      destruct Hin eqn:Hf.
      inversion e.
      firstorder.
      pose proof (proj1 (IHla xf pf plv) i) as Hind.
      firstorder.
      rewrite map_cons. simpl.
      destruct Hin as [[Hla | Hlb] Hr].
      ++ left; subst; reflexivity.
      ++ right; apply IHla; firstorder.
  Qed.

  Lemma perm_membership : ∀ (A : Type)
    (la lb : list A), Permutation la lb ->
    (∀ x, In x la <-> In x lb) /\
    (List.length la = List.length lb).
  Proof.
    intros ? ? ?; split.
    intros x.
    split; intros Hin.
    apply Permutation_in with (l := la);
    assumption.
    apply Permutation_in with (l := lb).
    apply Permutation_sym; assumption.
    assumption.
    apply Permutation_length;
    assumption.
  Qed.

  Lemma inject_in_list : ∀ (A : Type)
    (l : list A) (x : A) (pf : prob),
    In (x, pf) (map (λ y : A, (y, pf)) l) <-> In x l.
  Proof.
    intros ?.
    induction l.
    + intros ? ?;
      split;
      intro Hin.
      inversion Hin.
      inversion Hin.
    + intros ? ?;
      split;
      intro Hin.
      rewrite map_cons in Hin.
      simpl. simpl in Hin.
      destruct Hin as [Hl | Hr].
      ++ left; inversion Hl; subst;
         reflexivity.
      ++ right; apply IHl with pf;
         exact Hr.
      ++ rewrite map_cons.
         simpl in Hin.
         simpl. destruct Hin.
         -
         left; subst;
         reflexivity.
         -
         right; apply IHl;
         exact H.
  Qed.

  Global Instance proper_fn {A : Type} :
    Proper (eq ==> @dist_equiv A) (fun x => Ret x).
  Proof.
    intros x y Hxy.
    rewrite Hxy.
    reflexivity.
  Qed.

  Global Instance subrel_eq_respect {A B : Type}
    (Ra : relation A)
    (Rb : relation B)
    (sa : subrelation Ra eq)
    (sb : subrelation eq Rb) :
    subrelation eq (respectful Ra Rb).
  Proof.
    intros f g Hfg.
    subst.
    intros a a' Raa'.
    apply sb.
    f_equal.
    apply (sa _ _ Raa').
  Qed.

  Global Instance pointwise_eq_ext {A B : Type}
    (Rb : relation B)
    (sb : subrelation Rb eq) :
    subrelation (pointwise_relation A Rb) eq.
  Proof.
    intros f g Hfg.
    unfold pointwise_relation in Hfg.
    apply functional_extensionality.
    intros. apply sb, Hfg.
  Qed.

  (* joining two probability distribution *)
  Fixpoint join_with {A B C : Type} (f : A -> B -> C)
    (xs : dist A) (ys : dist B) : dist C :=
    match xs with
    | [] => []
    | (ax, px) :: tx =>
      List.map (fun '(ut, pt) => (f ax ut, mul_prob px pt)) ys
      ++ join_with f tx ys
    end.

  Fixpoint fmap {A B : Type} (f : A -> B) (xs : dist A) : dist B :=
    match xs with
    | [] => []
    | (ax, px) :: tx => (f ax, px) :: fmap f tx
    end.

  Lemma fmap_identity : ∀ (T : Type) (x : dist T), fmap id x = x.
  Proof.
    intro T.
    induction x;
    simpl;
    try reflexivity.
    destruct a.
    rewrite IHx.
    reflexivity.
  Qed.

  Lemma fmap_compose : ∀ (T U V : Type)
    (f : T → U) (g : U → V) (x : dist T),
    fmap (PreFun.compose g f) x = fmap g (fmap f x).
  Proof.
    intros ? ? ? ? ?.
    induction x;
    simpl; try reflexivity.
    destruct a; simpl.
    rewrite IHx;
    reflexivity.
  Qed.

  Global Instance dist_functor : Functor dist.
  Proof.
    constructor.
    intros ? ? f Ha.
    exact (@fmap A B f Ha).
  Defined.

  Global Instance dist_functor_law :
    FunctorLaws dist_functor.
  Proof.
    constructor.
    + apply fmap_identity.
    + apply fmap_compose.
  Defined.

  Fixpoint repeat_dist_ntimes_vector {A : Type} (d : dist A)
    (n : nat) : dist (Vector.t A n) :=
  match n with
  | 0 => Ret (@Vector.nil A)
  | S n' =>
    Bind d (fun u =>
      Bind (repeat_dist_ntimes_vector d n')
      (fun v => Ret (Vector.cons _ u _ v)))
  end.

  Lemma repeat_dist_ntimes_nonempty_vec {A : Type} :
    forall (n : nat) (d : dist A),
    d <> [] ->
    repeat_dist_ntimes_vector d n <> [].
  Proof.
    induction n;
    intros * Ha Hb; cbn.
    +
      cbv in Hb.
      congruence.
    +
      cbn in Hb.
      eapply IHn with d;
      try assumption.
      specialize (IHn d Ha).
      remember (repeat_dist_ntimes_vector d n) as ds.
      assert (Hc : ∃ d' ds', ds = d' :: ds').
      destruct ds as [|dw dws];
      [congruence| exists dw, dws; exact eq_refl].
      destruct Hc as (d' & ds' & Hd).
      rewrite Hd in Hb; clear Hd;
      cbn in Hb.
      assert (Hc : ∃ dh dt, d = dh :: dt).
      destruct d as [|dha dta];
      [congruence | exists dha, dta; exact eq_refl].
      destruct Hc as (dh & Ht & Hc);
      rewrite Hc in Hb;
      cbn in Hb.
      destruct dh as (dha, dhb);
      destruct d' as (dl, dt);
      cbn in Hb.
      congruence.
  Qed.

  Lemma bind_membership_elim_vec  {A : Type} {n : nat} :
    ∀ (d : dist A) (f : A -> dist (Vector.t A (1 + n)))
    (a : Vector.t A (1 + n))  (b : prob),
    In (a, b) (Bind d f) ->
    ∃ ldl dx dy ldr  fdl fdx fdy fdr,
    d = ldl ++ [(dx, dy)] ++ ldr ∧
    (f dx) = fdl ++ [(fdx, fdy)] ++ fdr ∧
    b = mul_prob dy fdy.
  Proof.
    induction d as [|(u, v) d IHd];
    intros * Ha.
    +
      simpl in Ha;
      inversion Ha.
    +
      (* destruct d *)
      destruct d as [|(uh, vh) d].
      ++
        simpl in Ha;
        rewrite app_nil_r in Ha.
        eapply in_map_iff in Ha.
        destruct Ha as ((xl, xp) & Ha & Hb).
        exists [], u, v, [].
        inversion Ha; subst;
        clear Ha.
        eapply in_split in Hb.
        destruct Hb as (la & lb & Hb).
        rewrite Hb.
        repeat eexists.
      ++
        (* induction case *)
        remember ((uh, vh) :: d) as uvhd.
        simpl in Ha;
        eapply in_app_or in Ha;
        destruct Ha as [Ha | Ha].
        +++
          exists [], u, v, uvhd.
          eapply in_map_iff in Ha.
          destruct Ha as ((xl, xp) & Ha & Hb).
          inversion Ha; subst;
          clear Ha.
          eapply in_split in Hb.
          destruct Hb as (la & lb & Hb).
          rewrite Hb.
          repeat eexists.
        +++
          (* induction case *)
          destruct (IHd f a b Ha) as
          (ldl & dx & dy & ldr & fdl & fdx & fdy & fdr &
          Hb & Hc & Hd).
          exists ((u, v) :: ldl), dx, dy,
          ldr, fdl, fdx, fdy, fdr.
          split; auto.
          cbn.
          f_equal.
          exact Hb.
  Qed.

  Lemma bind_strip_head_elem_vec {A : Type} {n : nat} :
    forall (da : dist (Vector.t A n)) dx
    (ls : list (Vector.t A (1 + n) * prob)),
    da <> [] ->
    Bind da (λ v : Vector.t A n, [(Vector.cons A dx n v, one)]) = ls ->
    da = List.map (fun '(x, y) => (Vector.tl x, y)) ls.
  Proof.
    induction da as [|(u, v) da IHd].
    +
      intros * Ha Hb.
      congruence.
    +
      (* destruct da *)
      destruct da as [|(du, dv) da].
      ++
        intros * Ha Hb.
        cbn in * |- *.
        rewrite <-Hb.
        cbn.
        f_equal; f_equal.
        rewrite mul_prob_comm.
        unfold mul_prob, one.
        destruct v; cbn;
        f_equal; nia.
      ++
        (** induction case **)
        remember ((du, dv) :: da) as dha.
        intros * Ha Hb.
        cbn in * |- *.
        rewrite <-Hb.
        cbn.
        f_equal; f_equal.
        rewrite mul_prob_comm.
        unfold mul_prob, one.
        destruct v; cbn;
        f_equal; nia.
        eapply IHd.
        rewrite Heqdha.
        intros Hf; congruence.
        eauto.
  Qed.

  (*
    Let's assume d is a uniform and non-empty distribution.
  *)
  Lemma repeat_dist_ntimes_vector_prob {A : Type} :
    forall (n : nat) (d d' : dist A) (a : Vector.t A n)
    (b : prob) (p : A) (q : positive),
    d = (p, mk_prob 1 q) :: d' ->
    (forall x y, In (x, y) d -> y = mk_prob 1 q) ->
    In (a, b) (repeat_dist_ntimes_vector d n) ->
    b = mk_prob 1 (Pos.of_nat (Nat.pow (Pos.to_nat q) n)).
  Proof.
    induction n.
    +
       intros * Ha Hb Hc.
      cbn in Hc.
      destruct Hc as [Hc | Hc];
      inversion Hc; subst;
      try reflexivity.
    +
      intros  * Ha Hb Hc.
      cbn in * |- *.
      remember ((repeat_dist_ntimes_vector d n)) as ds.
      remember ((λ u : A, Bind ds
        (λ v : Vector.t A n, Ret (Vector.cons A u n v)))) as f.
      eapply  bind_membership_elim_vec in Hc.
      destruct Hc as (ldl & dx & dy & ldr & fdl & fdx &
      fdy & fdr & Hc & Hd & He).
      subst.
      assert (He :
      {| num := 1; denum := Pos.of_nat (Pos.to_nat q * Nat.pow (Pos.to_nat q) n) |} =
      mul_prob ({| num := 1; denum := q|})
        ({| num := 1; denum := Pos.of_nat (Nat.pow (Pos.to_nat q) n)|})).
      unfold mul_prob; f_equal.
      rewrite Nat2Pos.inj_mul, Pos2Nat.id.
      reflexivity.
      nia.
      eapply PeanoNat.Nat.pow_nonzero; nia.
      rewrite He; clear He.
      f_equal.
      eapply Hb.
      rewrite Hc.
      instantiate (1 := dx).
      eapply in_app_iff; right; left;
      reflexivity.
      eapply IHn;
      try assumption.
      apply eq_sym; exact Hc.
      intros ? ? He.
      eapply Hb;
      rewrite Hc.
      instantiate (1 := x).
      exact He.
      rewrite Hc in Hd.
      remember ((repeat_dist_ntimes_vector (ldl ++ [(dx, dy)] ++ ldr) n))
      as da.
      unfold Ret in Hd.
      remember (fdl ++ [(fdx, fdy)] ++ fdr) as ls.
       (* Everything works upto this point *)
      eapply bind_strip_head_elem_vec in Hd.
      rewrite Hd.
      eapply in_map_iff.
      exists (fdx, fdy).
      split. eauto.
      rewrite Heqls.
      eapply in_app_iff; right; left;
      reflexivity.
      rewrite Heqda.
      eapply repeat_dist_ntimes_nonempty_vec.
      intro Hf.
      congruence.
  Qed.

  Lemma uniform_with_replacement_non_empty {A : Type} :
    forall (lf : list A) (Hlf : lf <> []),
    uniform_with_replacement lf Hlf ≠ [].
  Proof.
    intros [|hlf lf] ?.
    +
      intro Ha; congruence.
    +
      intros Ha;
      unfold uniform_with_replacement in Ha;
      cbn in Ha;
      congruence.
  Qed.

  Lemma uniform_probability {A : Type} :
    forall (lf : list A)  (Hlf : lf <> []) a b,
    In (a, b) (uniform_with_replacement lf Hlf) ->
    b = mk_prob 1 (Pos.of_nat (List.length lf)).
  Proof.
    intros * Ha.
    unfold uniform_with_replacement in Ha.
    apply prob_list in Ha.
    destruct Ha as [_ Ha].
    exact Ha.
  Qed.

  Lemma uniform_probability_multidraw_prob {A : Type} :
    forall n lf (a : Vector.t A n) b (Hlf : lf <> []),
    In (a, b) (repeat_dist_ntimes_vector
      (uniform_with_replacement lf Hlf) n) ->
    b = mk_prob 1 (Pos.of_nat
      (Nat.pow (List.length lf) n)).
  Proof.
    intros * Ha.
    assert (Hb : (length lf) =
    Pos.to_nat (Pos.of_nat (length lf))).
    rewrite Nat2Pos.id. reflexivity.
    destruct lf;
    [congruence | cbn; nia].
    rewrite Hb; clear Hb.
    assert (Hb : ∃ lfh lft, lf = lfh :: lft).
    destruct lf as [|lfh lft];
    [congruence | exists lfh, lft; reflexivity].
    destruct Hb as (lfh & lft & Hb); subst.
    eapply repeat_dist_ntimes_vector_prob with
    (d := (uniform_with_replacement (lfh :: lft) Hlf))
    (p := lfh) (d' := map
    (λ x : A,
       (x, {|
          num := 1;
          denum :=
            match length lft with
            | 0%nat => 1
            | S _ => Pos.succ (Pos.of_nat (length lft))
            end
        |})) lft).
    unfold uniform_with_replacement; cbn.
    reflexivity.
    eapply uniform_probability.
    exact Ha.
  Qed.

End Distr.

Section Event.

  Context
    {A : Type}
    (Hdec: forall x y : A, {x = y} + {x <> y}).

  (* event as a boolean function (computable) *)
  Definition event := A -> bool.

  (* complement of an evant *)
  Definition comp_event (e : event) :=
    fun x => negb (e x).

  (* list of event in the probability distribution *)
  Definition list_of_events (e : event) (xs : dist A) : dist A  :=
    List.filter (fun '(x, y) => e x) xs.

  (* sum of the probabilities in the distribution *)
  Definition prob_of_an_event (e : event ) (xs : dist A) : prob :=
    List.fold_right (fun '(tx, bx) ax => add_prob ax bx)
    zero (list_of_events e xs).

  Definition union_of_events (e₁ e₂ : event) (xs : dist A) : dist A :=
    List.filter (fun '(x, y) => orb (e₁ x) (e₂ x)) xs.

  Definition intersection_of_events (e₁ e₂ : event)
    (xs : dist A) : dist A :=
    List.filter (fun '(x, y) => andb (e₁ x) (e₂ x)) xs.

  (* Non dependent function that sums all the probabilites  *)
  Fixpoint rec_sum_prob (l : dist A) : prob :=
    match l with
    | [] => zero
    | (_, h) :: t => add_prob h (rec_sum_prob t)
    end.

  Local Infix "=r=" := dist_equiv
  (at level 70, no associativity).

  (* A ∪ B =r= A + B - A ∩ B *)
  Theorem union_intersection_proof :
    forall (xs : dist A) (e1 e2 : event),
    (union_of_events e1 e2 xs ++ intersection_of_events e1 e2 xs) =r=
    (list_of_events e1 xs ++ list_of_events e2 xs).
  Proof.
    intros ?.
    unfold union_of_events,
    intersection_of_events,
    list_of_events.
    induction xs.
    + simpl;
      intros ? ?;
      reflexivity.
    + simpl; intros ? ?.
      destruct a as [ap bp].
      destruct (e1 ap) eqn:He1;
      destruct (e2 ap) eqn:He2;
      simpl.
      apply cons_proper.
      rewrite dist_equiv_inv_comm.
      assert (Hf: filter (λ '(x, _), e1 x) xs ++ (ap, bp) :: filter (λ '(x, _), e2 x) xs  =r=
        (ap, bp) :: filter (λ '(x, _), e2 x) xs ++ filter (λ '(x, _), e1 x) xs).
      rewrite dist_equiv_inv_comm.
      reflexivity.
      rewrite Hf; simpl.
      apply cons_proper.
      rewrite dist_equiv_inv_comm.
      clear Hf.
      assert (Hf: filter (λ '(x, _), e2 x) xs ++ filter (λ '(x, _), e1 x) xs =r=
        filter (λ '(x, _), e1 x) xs ++ filter (λ '(x, _), e2 x) xs).
      rewrite dist_equiv_inv_comm; reflexivity.
      rewrite Hf, IHxs; reflexivity.
      apply cons_proper, IHxs; reflexivity.
      assert (Hf: filter (λ '(x, _), e1 x) xs ++ (ap, bp) :: filter (λ '(x, _), e2 x) xs =r=
        (ap, bp) :: filter (λ '(x, _), e2 x) xs ++ filter (λ '(x, _), e1 x) xs).
      rewrite dist_equiv_inv_comm; reflexivity.
      rewrite Hf.
      apply cons_proper.
      clear Hf.
      assert (Hf : filter (λ '(x, _), e2 x) xs ++ filter (λ '(x, _), e1 x) xs =r=
        filter (λ '(x, _), e1 x) xs ++ filter (λ '(x, _), e2 x) xs).
      rewrite dist_equiv_inv_comm.
      reflexivity.
      rewrite Hf, IHxs; reflexivity.
      apply IHxs.
  Qed.

  (* Event and its complement preservs the universe (modulo =r=)*)
  Lemma universe_event_comp_event :
    forall (l : dist A) (f : event),
    List.filter (fun '(x, _) => f x) l ++
    List.filter (fun '(x, _) => comp_event f x) l =r= l.
  Proof.
    intros ?;
    unfold comp_event.
    induction l.
    + simpl; intros ?;
      reflexivity.
    + destruct a as (a & ap);
      simpl; intros ?.
      refine (match (f a) as a' return f a = a' -> _ with
        | true => fun Ht => _
        | false => fun Hf => _
      end eq_refl).
      rewrite Ht; simpl;
      rewrite IHl; reflexivity.
      rewrite Hf; simpl.
      rewrite dist_equiv_inv_comm.
      simpl.
      apply cons_proper.
      rewrite dist_equiv_inv_comm.
      rewrite IHl; reflexivity.
  Qed.

  Local Infix "=p=" := prob_equiv
    (at level 70, no associativity).

  Lemma sum_prob_event_comp_event :
    forall (l : dist A) (f : event),
    rec_sum_prob l =p=
    add_prob (prob_of_an_event f l) (prob_of_an_event (comp_event f) l).
  Proof.
    intros ?.
    unfold prob_of_an_event, comp_event.
    induction l;
    intros ?;
    simpl in * |- *.
    + subst; simpl; reflexivity.
    + destruct a as (ap & bp).
      destruct (f ap) eqn:Hf.
      simpl.
      assert (Hft: add_prob
        (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events f l)) bp =
        add_prob bp
        (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events f l))).
      rewrite add_prob_comm;
      reflexivity.
      rewrite Hft;
      clear Hft.
      rewrite add_prob_assoc.
      apply add_proper.
      reflexivity.
      apply IHl.
      simpl.
      assert (Hft: (add_prob
        (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events (λ x : A, negb (f x)) l)) bp) =
        (add_prob bp
        (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events (λ x : A, negb (f x)) l)))).
      rewrite add_prob_comm.
      reflexivity.
      rewrite Hft; clear Hft.
      assert (Hft:
      add_prob
      (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events f l))
      (add_prob bp
        (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events (λ x : A, negb (f x)) l))) =
      add_prob
      (add_prob bp
        (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events (λ x : A, negb (f x)) l)))
        (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (list_of_events f l))).
      rewrite add_prob_comm;
      reflexivity.
      rewrite Hft; clear Hft.
      rewrite add_prob_assoc.
      apply add_proper.
      reflexivity.
      rewrite add_prob_comm.
      apply IHl.
  Qed.

  Lemma rec_sum_prob_eq_sum_of_uniform_with_replacement :
    forall l,
    rec_sum_prob l =p=
    sum_of_uniform_with_replacement l.
  Proof.
    induction l as [|(ax, ay) l IHl].
    + simpl; reflexivity.
    + simpl. rewrite IHl.
      rewrite add_prob_comm.
      reflexivity.
  Qed.

  Lemma sum_of_uniform_prob_event_comp_event :
    forall (l : dist A) (f : event),
    sum_of_uniform_with_replacement l =p=
    add_prob (prob_of_an_event f l) (prob_of_an_event (comp_event f) l).
  Proof.
    intros *.
    rewrite <-rec_sum_prob_eq_sum_of_uniform_with_replacement.
    apply sum_prob_event_comp_event.
  Qed.

  Local Infix "<p=" := (leq) (at level 70).

  Lemma fold_right_filter_map_add_zero : forall (e : event) l k,
    fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
    (filter (λ '(x, _), e x)
      (map (λ x : A, (x, {| num := 1; denum := Pos.of_nat k |})) l)) <p=
      mk_prob (List.length l) (Pos.of_nat k) = true.
  Proof.
    intros ? ?.
    induction l.
    + simpl; reflexivity.
    + intros ?.
      rewrite map_cons.
      destruct (e a) eqn:H.
      simpl.
      rewrite H; simpl.
      rewrite add_prob_comm.
      destruct (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (filter (λ '(x, _), e x)
        (map (λ x : A, (x, {| num := 1; denum := Pos.of_nat k |})) l))) eqn:Hf.
      simpl in * |- *.
      apply PeanoNat.Nat.leb_le.
      specialize (IHl k).
      rewrite Hf in IHl.
      simpl in IHl.
      apply PeanoNat.Nat.leb_le in IHl.
      nia.
      (* false case *)
      simpl.
      rewrite H.
      destruct (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
        (filter (λ '(x, _), e x)
        (map (λ x : A, (x, {| num := 1; denum := Pos.of_nat k |})) l))) eqn:Hf.
      simpl in * |- *.
      specialize (IHl k).
      rewrite Hf in IHl.
      simpl in IHl.
      apply PeanoNat.Nat.leb_le in IHl.
      apply PeanoNat.Nat.leb_le.
      nia.
  Qed.

  (* Probability of an event is bounded between 0 and 1 (included) *)
  Lemma event_uniform_prob : forall (e : event) (l : list A)
    (H : l <> []) (xs : dist A) pevent,
    xs = uniform_with_replacement l H ->
    pevent = prob_of_an_event e xs ->
    zero <p= pevent = true ∧ pevent <p= one = true.
  Proof.
    unfold uniform_with_replacement,
    prob_of_an_event,
    list_of_events.
    intros ? ? ? ? ? Hxs Hpevent.
    rewrite Hpevent, Hxs.
    split.
    pose proof (fold_right_filter_map_add_zero e l (length l)) as Hf.
    destruct (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
      (filter (λ '(x, _), e x)
      (map (λ x : A, (x, {| num := 1; denum := Pos.of_nat (length l) |})) l))) eqn:Hff.
    simpl in * |- *; reflexivity.
    pose proof (fold_right_filter_map_add_zero e l (length l)) as Hf.
    destruct (fold_right (λ '(_, bx) (ax : prob), add_prob ax bx) zero
      (filter (λ '(x, _), e x)
      (map (λ x : A, (x, {| num := 1; denum := Pos.of_nat (length l) |})) l))) eqn:Hff.
    simpl in * |- *.
    apply PeanoNat.Nat.leb_le.
    apply PeanoNat.Nat.leb_le in Hf.
    nia.
  Qed.

  (* choice p a b := selects a with probablity p and
     b with probability 1 - p *)
  Definition choice (p : prob) (a b : A) : dist A :=
    [(a, p); (b, mk_prob (Pos.to_nat (denum p) - num p) (denum p))].

  Lemma choice_correct : ∀ (p : prob) (a b : A),
    zero <p= p = true ->
    p <p= one = true ->
    rec_sum_prob (choice p a b) =p= one.
  Proof.
    intros ? ? ? Hzero Hone.
    unfold choice.
    destruct p as (ap & bp).
    simpl.
    apply one_prob.
    assert (Ht : Pos.to_nat (bp * 1) = Pos.to_nat bp) by nia.
    rewrite Ht; clear Ht.
    assert (Ht : (Pos.to_nat bp - ap) * Pos.to_nat 1 + 0 =
      (Pos.to_nat bp - ap)).
    nia.
    rewrite Ht; clear Ht.
    rewrite PeanoNat.Nat.mul_sub_distr_r.
    assert (Ht : Pos.to_nat (bp * (bp * 1)) = Pos.to_nat (bp * bp)).
    nia.
    rewrite Ht; clear Ht.
    rewrite Minus.le_plus_minus_r.
    nia.
    apply leq_prob in Hone.
    simpl in Hone. nia.
  Qed.

End Event.

Section Example.

    Export MonadNotation.
    Open Scope monad_scope.

    Eval compute in repeat_dist_ntimes_vector [(1, mk_prob 1 1)] 3.
    Fact Hneq : [1; 2; 3; 4] <> [].
    Proof.
        intro H; inversion H.
    Defined.

    Eval compute in uniform_with_replacement [1; 2; 3; 4] Hneq.
    (*
      [(1, {| num := 1; denum := 4 |}); (2, {| num := 1; denum := 4 |});
       (3, {| num := 1; denum := 4 |}); (4, {| num := 1; denum := 4 |})]
     : dist nat
    *)

    (*
    Definition prob1 (l : list nat) (H : l <> []):=
      Bind (uniform_with_replacement l H) (fun x =>
        Bind (uniform_with_replacement l H) (fun y =>
          Ret (x * y, x, y))).
    *)
    Definition prob1 (l : list nat) (H : l <> []) :=
      x <- uniform_with_replacement l H ;;
      y <- uniform_with_replacement l H ;;
      ret  (x, y).

    (*
    Definition prob2 (l : list nat) (H : l <> []) :=
      Bind (uniform_with_replacement l H) (fun y =>
        Bind (uniform_with_replacement l H) (fun x =>
          Ret (y * x, y, x))).
    *)

    Definition prob2 (l : list nat) (H : l <> []) :=
      y <- uniform_with_replacement l H ;;
      x <- uniform_with_replacement l H ;;
      ret  (y, x).

    Eval compute in prob1 [1; 2; 3; 4] Hneq.
    (*
      = [(1, 1, {| num := 1; denum := 16 |});
       (1, 2, {| num := 1; denum := 16 |});
       (1, 3, {| num := 1; denum := 16 |});
       (1, 4, {| num := 1; denum := 16 |});
       (2, 1, {| num := 1; denum := 16 |});
       (2, 2, {| num := 1; denum := 16 |});
       (2, 3, {| num := 1; denum := 16 |});
       (2, 4, {| num := 1; denum := 16 |});
       (3, 1, {| num := 1; denum := 16 |});
       (3, 2, {| num := 1; denum := 16 |});
       (3, 3, {| num := 1; denum := 16 |});
       (3, 4, {| num := 1; denum := 16 |});
       (4, 1, {| num := 1; denum := 16 |});
       (4, 2, {| num := 1; denum := 16 |});
       (4, 3, {| num := 1; denum := 16 |});
       (4, 4, {| num := 1; denum := 16 |})]
     : dist (nat * nat)

    *)

    Eval compute in prob2 [1; 2; 3; 4] Hneq.
    (*
       [(1, 1, {| num := 1; denum := 16 |});
       (1, 2, {| num := 1; denum := 16 |});
       (1, 3, {| num := 1; denum := 16 |});
       (1, 4, {| num := 1; denum := 16 |});
       (2, 1, {| num := 1; denum := 16 |});
       (2, 2, {| num := 1; denum := 16 |});
       (2, 3, {| num := 1; denum := 16 |});
       (2, 4, {| num := 1; denum := 16 |});
       (3, 1, {| num := 1; denum := 16 |});
       (3, 2, {| num := 1; denum := 16 |});
       (3, 3, {| num := 1; denum := 16 |});
       (3, 4, {| num := 1; denum := 16 |});
       (4, 1, {| num := 1; denum := 16 |});
       (4, 2, {| num := 1; denum := 16 |});
       (4, 3, {| num := 1; denum := 16 |});
       (4, 4, {| num := 1; denum := 16 |})]
     : dist (nat * nat)

    *)

    Local Infix "=r=" := dist_equiv
    (at level 70, no associativity).

    (* Two probability distributions are same *)
    Lemma similar_distribution : forall (l : list nat) (H : l <> []),
      @prob1 l H =r= @prob2 l H.
    Proof.
      intros *.
      unfold prob1, prob2.
      simpl.
      reflexivity.
    Qed.

    Eval compute in
      (repeat_dist_ntimes_vector
        (uniform_with_replacement [1; 2; 3; 4] Hneq) 1).

    (*
      [([1; 1], {| num := 1; denum := 16 |});
        ([1; 2], {| num := 1; denum := 16 |});
        ([1; 3], {| num := 1; denum := 16 |});
        ([1; 4], {| num := 1; denum := 16 |});
        ([2; 1], {| num := 1; denum := 16 |});
        ([2; 2], {| num := 1; denum := 16 |});
        ([2; 3], {| num := 1; denum := 16 |});
        ([2; 4], {| num := 1; denum := 16 |});
        ([3; 1], {| num := 1; denum := 16 |});
        ([3; 2], {| num := 1; denum := 16 |});
        ([3; 3], {| num := 1; denum := 16 |});
        ([3; 4], {| num := 1; denum := 16 |});
        ([4; 1], {| num := 1; denum := 16 |});
        ([4; 2], {| num := 1; denum := 16 |});
        ([4; 3], {| num := 1; denum := 16 |});
        ([4; 4], {| num := 1; denum := 16 |})]
     : dist (list nat)

    *)

End Example.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable triangle_ : Universe -> Universe -> Universe -> Prop.
Variable outCirc_ : Universe -> Universe -> Prop.
Variable onCirc_ : Universe -> Universe -> Prop.
Variable inCirc_ : Universe -> Universe -> Prop.
Variable equilateral_ : Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable cI_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable postulate_Euclid3_1 : (forall A B : Universe, (exists X : Universe, (A <> B -> cI_ X A A B))).
Variable lemma_inequalitysymmetric_2 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_localextension_3 : (forall A B Q : Universe, (exists X : Universe, ((A <> B /\ B <> Q) -> (betS_ A B X /\ cong_ B X B Q)))).
Variable lemma_congruenceflip_4 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable cn_congruencereflexive_5 : (forall A B : Universe, cong_ A B A B).
Variable defoutside_6 : (forall P J : Universe, (exists X U V W : Universe, (outCirc_ P J -> (cI_ J U V W /\ (betS_ U X P /\ cong_ U X V W))))).
Variable defoutside2_7 : (forall P J X U V W : Universe, ((cI_ J U V W /\ (betS_ U X P /\ cong_ U X V W)) -> outCirc_ P J)).
Variable definside_8 : (forall P J : Universe, (exists X Y U V W : Universe, (inCirc_ P J -> ((cI_ J U V W /\ P = U) \/ (cI_ J U V W /\ (betS_ U Y X /\ (cong_ U X V W /\ cong_ U P U Y))))))).
Variable definside2a_9 : (forall P J X Y U V W : Universe, ((cI_ J U V W /\ P = U) -> inCirc_ P J)).
Variable definside2b_10 : (forall P J X Y U V W : Universe, ((cI_ J U V W /\ (betS_ U Y X /\ (cong_ U X V W /\ cong_ U P U Y))) -> inCirc_ P J)).
Variable defon_11 : (forall B J : Universe, (exists X Y U : Universe, (onCirc_ B J -> (cI_ J U X Y /\ cong_ U B X Y)))).
Variable defon2_12 : (forall B J X Y U : Universe, ((cI_ J U X Y /\ cong_ U B X Y) -> onCirc_ B J)).
Variable postulate_circle_circle_13 : (forall C D F G J K P Q R S : Universe, (exists X : Universe, ((cI_ J C R S /\ (inCirc_ P J /\ (outCirc_ Q J /\ (cI_ K D F G /\ (onCirc_ P K /\ onCirc_ Q K))))) -> (onCirc_ X J /\ onCirc_ X K)))).
Variable axiom_circle_center_radius_14 : (forall A B C J P : Universe, ((cI_ J A B C /\ onCirc_ P J) -> cong_ A P B C)).
Variable lemma_congruencesymmetric_15 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_congruencetransitive_16 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable cn_equalityreverse_17 : (forall A B : Universe, cong_ A B B A).
Variable defequilateral_18 : (forall A B C : Universe, (equilateral_ A B C -> (cong_ A B B C /\ cong_ B C C A))).
Variable defequilateral2_19 : (forall A B C : Universe, ((cong_ A B B C /\ cong_ B C C A) -> equilateral_ A B C)).
Variable axiom_nocollapse_20 : (forall A B C D : Universe, ((A <> B /\ cong_ A B C D) -> C <> D)).
Variable lemma_partnotequalwhole_21 : (forall A B C : Universe, (betS_ A B C -> ~(cong_ A B A C))).
Variable defcollinear_22 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_23 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_24 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_25 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_26 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_27 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_28 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable deftriangle_29 : (forall A B C : Universe, (triangle_ A B C -> ~(col_ A B C))).
Variable deftriangle2_30 : (forall A B C : Universe, (~(col_ A B C) -> triangle_ A B C)).

Theorem proposition_01_31 : (forall A B : Universe, (exists X : Universe, (A <> B -> (equilateral_ A B X /\ triangle_ A B X)))).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Loose Hint Behavior "Strict".
Require Import Coq.Classes.Morphisms.
Require Import Coq.ZArith.BinInt.
Import Coq.ZArith.BinInt.Z. (* for hints *)
Require Import Coq.micromega.Lia.
Require Import Coq.ZArith.ZArith.

Local Open Scope Z_scope.

Lemma mod2_cases: forall (n: Z), n mod 2 = 0 \/ n mod 2 = 1.
Proof.
  intros. pose proof (Z.mod_pos_bound n 2). lia.
Qed.

Lemma div_mul_undo: forall a b,
    b <> 0 ->
    a mod b = 0 ->
    a / b * b = a.
Proof.
  intros.
  pose proof Z.div_mul_cancel_l as A. specialize (A a 1 b).
  replace (b * 1) with b in A by lia.
  rewrite Z.div_1_r in A.
  rewrite Z.mul_comm.
  rewrite <- Z.divide_div_mul_exact; try assumption.
  - apply A; congruence.
  - apply Z.mod_divide; assumption.
Qed.

Lemma mod_0_r: forall (m: Z),
    m mod 0 = match (1 mod 0) with | 0 => 0 | _ => m end.
Proof.
  intros. destruct m; reflexivity.
Qed.

Lemma sub_mod_0: forall (a b m: Z),
    a mod m = 0 ->
    b mod m = 0 ->
    (a - b) mod m = 0.
Proof.
  intros *. intros E1 E2.
  rewrite Zminus_mod.
  rewrite E1. rewrite E2.
  reflexivity.
Qed.

Lemma add_mod_0: forall a b m : Z,
    a mod m = 0 ->
    b mod m = 0 ->
    (a + b) mod m = 0.
Proof.
  intros *. intros E1 E2.
  rewrite Zplus_mod.
  rewrite E1. rewrite E2.
  reflexivity.
Qed.

Lemma Z_mod_mult': forall a b : Z,
    (a * b) mod a = 0.
Proof.
  intros. rewrite Z.mul_comm. apply Z_mod_mult.
Qed.

Lemma mod_add_r: forall a b,
    b <> 0 ->
    (a + b) mod b = a mod b.
Proof.
  intros. rewrite <- Z.add_mod_idemp_r by lia.
  rewrite Z.mod_same by lia.
  rewrite Z.add_0_r.
  reflexivity.
Qed.

Lemma mod_pow2_same_cases: forall a n,
    a mod 2 ^ n = a ->
    2 ^ n = 0 \/ 0 <= a < 2 ^ n.
Proof.
  intros.
  assert (n < 0 \/ 0 <= n) as C by lia. destruct C as [C | C].
  - left. rewrite (Z.pow_neg_r 2 n C) in *. rewrite mod_0_r in H. auto.
  - right.
    rewrite <- H. apply Z.mod_pos_bound.
    apply Z.pow_pos_nonneg; lia.
Qed.

Lemma mod_pow2_same_bounds: forall a n,
    a mod 2 ^ n = a ->
    0 <= n ->
    0 <= a < 2 ^ n.
Proof.
  intros. rewrite <- H. apply Z.mod_pos_bound.
  apply Z.pow_pos_nonneg; lia.
Qed.

Lemma pow2_nonneg: forall n,
    0 <= 2 ^ n.
Proof.
  intros. apply Z.pow_nonneg. lia.
Qed.

Lemma pow2_pos: forall n,
    0 <= n ->
    0 < 2 ^ n.
Proof.
  intros. apply Z.pow_pos_nonneg; lia.
Qed.

Lemma pow2_times2: forall i,
    0 < i ->
    2 ^ i = 2 * 2 ^ (i - 1).
Proof.
  intros.
  rewrite <- Z.pow_succ_r by lia.
  f_equal.
  lia.
Qed.

Lemma pow2_div2: forall i,
    0 <= i ->
    2 ^ (i - 1) = 2 ^ i / 2.
Proof.
  intros.
  assert (i = 0 \/ 0 < i) as C by lia. destruct C as [C | C].
  - subst. reflexivity.
  - rewrite Z.pow_sub_r by lia.
    reflexivity.
Qed.

Lemma div_mul_undo_le: forall a b,
    0 <= a ->
    0 < b ->
    a / b * b <= a.
Proof.
  intros.
  pose proof (Zmod_eq_full a b) as P.
  pose proof (Z.mod_bound_pos a b) as Q.
  lia.
Qed.

Lemma testbit_true_nonneg: forall a i,
    0 <= a ->
    0 <= i ->
    Z.testbit a i = true ->
    2 ^ i <= a.
Proof.
  intros.
  apply Z.testbit_true in H1; [|assumption].
  pose proof (pow2_pos i H0).
  eapply Z.le_trans; [| apply (div_mul_undo_le a (2 ^ i)); lia].
  replace (2 ^ i) with (1 * 2 ^ i) at 1 by lia.
  apply Z.mul_le_mono_nonneg_r; [lia|].
  pose proof (Z.div_pos a (2 ^ i)).
  assert (a / 2 ^ i <> 0); [|lia].
  intro E. rewrite E in H1. cbv in H1. discriminate H1.
Qed.

Lemma range_div_pos: forall a b c d,
    0 < d ->
    a <= b <= c ->
    a / d <= b / d <= c / d.
Proof.
  intuition idtac.
  - apply (Z.div_le_mono _ _ _ H H1).
  - apply (Z.div_le_mono _ _ _ H H2).
Qed.

Lemma testbit_true_nonneg': forall a i,
    0 <= i ->
    2 ^ i <= a < 2 ^ (i + 1) ->
    Z.testbit a i = true.
Proof.
  intros.
  apply Z.testbit_true; [assumption|].
  destruct H0 as [A B].
  pose proof (pow2_pos i H) as Q.
  apply (Z.div_le_mono _ _ _ Q) in A.
  rewrite Z_div_same in A by lia.
  pose proof (Z.div_lt_upper_bound a (2 ^ i) 2 Q) as P.
  rewrite Z.mul_comm in P.
  replace i with (i + 1 - 1) in P by lia.
  rewrite <- pow2_times2 in P by lia.
  specialize (P B).
  replace (i + 1 - 1) with i in P by lia.
  replace (a / 2 ^ i) with 1 by lia.
  reflexivity.
Qed.

Lemma testbit_false_nonneg: forall a i,
    0 <= a < 2 ^ i ->
    0 < i ->
    Z.testbit a (i - 1) = false ->
    a < 2 ^ (i - 1).
Proof.
  intros.
  assert (2 ^ (i - 1) <= a < 2 ^ i \/ a < 2 ^ (i - 1)) as C by lia.
  destruct C as [C | C]; [exfalso|assumption].
  assert (Z.testbit a (i - 1) = true); [|congruence].
  replace i with (i - 1 + 1) in C at 2 by lia.
  apply testbit_true_nonneg'; lia.
Qed.

Lemma signed_bounds_to_sz_pos: forall sz n,
    - 2 ^ (sz - 1) <= n < 2 ^ (sz - 1) ->
    0 < sz.
Proof.
  intros.
  assert (0 < sz \/ sz - 1 < 0) as C by lia.
  destruct C as [C | C]; [assumption|exfalso].
  rewrite Z.pow_neg_r in H by assumption.
  lia.
Qed.

Lemma two_digits_encoding_inj_lo: forall base a b c d: Z,
  0 <= b < base ->
  0 <= d < base ->
  base * a + b = base * c + d ->
  b = d.
Proof.
  intros.
  pose proof Z.mod_unique as P.
  specialize P with (b := base) (q := c) (r := d).
  specialize P with (2 := H1).
  rewrite P by lia.
  rewrite <- Z.add_mod_idemp_l by lia.
  rewrite Z.mul_comm.
  rewrite Z.mod_mul by lia.
  rewrite Z.add_0_l.
  rewrite Z.mod_small by lia.
  reflexivity.
Qed.

Lemma two_digits_encoding_inj_hi: forall base a b c d: Z,
  0 <= b < base ->
  0 <= d < base ->
  base * a + b = base * c + d ->
  a = c.
Proof.
  intros. nia.
Qed.

Lemma Z_to_nat_neg: forall (n: Z),
    n < 0 ->
    Z.to_nat n = 0%nat.
Proof.
  intros. destruct n; (lia||reflexivity).
Qed.


Require Import Lt.
Require Import Vec_def Vec_prop.

Inductive VecDep : forall (n : nat), Vec Type n -> Type :=
  | VDnil : VecDep 0 Vnil
  | VDcon : forall {A : Type} {n : nat} {v : Vec Type n} (hd : A) (tl : VecDep n v),
            VecDep (S n) (Vcon A v).

Arguments VecDep [n] _.
Arguments VDcon [A n v] hd tl.

Fixpoint VDget {n : nat} {v : Vec Type n} (vd : VecDep v)
         (m : nat) (mltn : m < n) : Vget v m mltn.
Proof.
destruct vd.
 apply False_rect ; eapply lt_n_O ; eassumption.
 destruct m.
  exact hd.
  simpl ; apply VDget ; apply vd.
Defined.

Fixpoint VDupdate {n : nat} {v : Vec Type n} {A : Type} (vd : VecDep v) (m : nat)
  (mltn : m < n) (a : A) {struct vd} : VecDep (Vupdate v m mltn A).
destruct vd.
 constructor.
 destruct m.
  constructor ; [exact a | exact vd].
  constructor ; [exact hd |].
  apply VDupdate ; [exact vd | exact a].
Defined.

Fixpoint VDmap {n : nat} {v : Vec Type n} (f : Type -> Type)
 (fd : forall m mltn, Vget v m mltn -> f (Vget v m mltn))
 (vd : VecDep v) : VecDep (Vmap f v).
Proof.
destruct vd.
 constructor.
 constructor.
  change (f (Vget (Vcon A v) O (lt_O_Sn _))) ; apply fd ;
  assumption.
  apply VDmap ; [| apply vd].
  intros m mltn H.
  erewrite Vget_PI ; eapply (fd (S m) (lt_n_S _ _ mltn)) ; simpl.
  erewrite Vget_PI ; eassumption.
Defined.

Fixpoint VDmap_full {n : nat} {v : Vec Type n}
  (f : forall (m : nat) (mltn : m < n), Type -> Type)
  (fd : forall m mltn, Vget v m mltn -> f m mltn (Vget v m mltn))
  (vd : VecDep v) : VecDep (Vmap_full f v).
Proof.
destruct vd.
 constructor.
 constructor.
  apply fd ; simpl ; exact hd.
  apply VDmap_full ; [| apply vd].
  intros m mltn Hget.
  erewrite Vget_PI ; eapply (fd (S m) (lt_n_S _ _ mltn)) ;
  simpl ; erewrite Vget_PI ; eassumption.
Defined.