(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext ssr_ext ssralg_ext logb Rbigop fdist entropy.
Require Import ln_facts num_occ types jtypes divergence conditional_divergence.
Require Import entropy channel_code channel.

(******************************************************************************)
(*         Lemmas for the converse of the channel coding theorem              *)
(*                                                                            *)
(* Definitions:                                                               *)
(*   success_factor       == bound of the success rate of decoding for typed  *)
(*                           codes using conditional divergence               *)
(*   success_factor_bound == bound of the success rate of decoding for typed  *)
(*                           codes                                            *)
(*                                                                            *)
(* Lemmmas:                                                                   *)
(*   typed_success_bound  == bound of the success rate of decoding for typed  *)
(*                           codes using mutual information                   *)
(*          success_bound == bound of the success rate of decoding            *)
(*                                                                            *)
(* For details, see Reynald Affeldt, Manabu Hagiwara, and Jonas Sénizergues.  *)
(* Formalization of Shannon's theorems. Journal of Automated Reasoning,       *)
(* 53(1):63--103, 2014                                                        *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope R_scope.
Local Open Scope channel_code_scope.
Local Open Scope channel_scope.
Local Open Scope entropy_scope.
Local Open Scope tuple_ext_scope.
Local Open Scope reals_ext_scope.
Local Open Scope types_scope.
Local Open Scope divergence_scope.
Local Open Scope set_scope.

Section typed_success_decomp_sect.

Variables A B M : finType.
Variable W : `Ch*(A, B).
Hypothesis Mnot0 : (0 < #|M|)%nat.

Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).

Definition success_factor (tc : typed_code B M P) (V : P_ n (A , B)) :=
  exp2 (- n%:R * `H(V | P)) / #|M|%:R *
  \sum_ (m : M) #| (V.-shell (tuple_of_row (enc tc m ))) :&:
                    (@tuple_of_row B n @: ((dec tc) @^-1: [set Some m])) |%:R.

Let Anot0 : (0 < #|A|)%nat. Proof. by case: W. Qed.

Let Bnot0 : (0 < #|B|)%nat.
Proof.
case/card_gt0P : Anot0 => a _; exact (fdist_card_neq0 (W a)).
Qed.

Lemma typed_success (tc : typed_code B M P) : scha(W, tc) =
  \sum_ (V | V \in \nu^{B}(P)) exp_cdiv P V W * success_factor tc V.
Proof.
rewrite schaE // div1R.
symmetry.
transitivity (/ #|M|%:R * \sum_(m : M) \sum_(V | V \in \nu^{B}(P))
    exp_cdiv P V W * #| V.-shell (tuple_of_row (enc tc m)) :&:
                        (@tuple_of_row B n @: (dec tc @^-1: [set Some m])) |%:R *
    exp2 (- n%:R * `H(V | P))).
  rewrite exchange_big /= big_distrr /=.
  apply eq_bigr => V _.
  rewrite /success_factor !mulRA -(mulRC (/ #|M|%:R)) -!mulRA; f_equal.
  symmetry; rewrite -big_distrl /= -big_distrr /= -mulRA; f_equal.
  by rewrite mulRC.
f_equal.
apply eq_bigr=> m _.
rewrite (reindex_onto (@row_of_tuple B n) (@tuple_of_row B n)); last first.
  move=> i Hi; by rewrite tuple_of_rowK.
rewrite (sum_tuples_ctypes (typed_prop tc m)) //.
apply eq_bigr=> V HV.
rewrite -mulRA mulRC -mulRA -iter_addR -big_const.
apply eq_big => tb.
- rewrite inE row_of_tupleK eqxx andbT.
  f_equal.
  apply/imsetP/idP.
    case=> v H ->; rewrite tuple_of_rowK.
    by rewrite 2!inE in H.
  move=> Hm.
  exists (row_of_tuple tb); last by rewrite row_of_tupleK.
  by rewrite !inE.
- rewrite in_set.
  move=> /andP [Htb _].
  rewrite mulRC -(@dmc_exp_cdiv_cond_entropy _ _ _ _ _ _ _ (row_of_tuple tb) (typed_prop tc m) HV) //.
  by rewrite row_of_tupleK.
Qed.

End typed_success_decomp_sect.

Section typed_success_factor_bound_sect.
Variables A B M : finType.
Hypothesis Mnot0 : (0 < #|M|)%nat.
Variable n' : nat.
Let n := n'.+1.
Variable V : P_ n ( A , B ).
Variable P : P_ n ( A ).

Definition success_factor_bound :=
  exp2(- n%:R * +| log #|M|%:R / n%:R - `I(P, V) |).

Variable tc : typed_code B M P.
Hypothesis Vctyp : V \in \nu^{B}(P).

Lemma success_factor_bound_part1 : success_factor tc V <= 1.
Proof.
apply/leRP; rewrite -(leR_pmul2l' #|M|%:R) ?ltR0n' //; apply/leRP.
rewrite /success_factor /Rdiv -(mulRC (/ #|M|%:R)) 2!mulRA.
rewrite mulRV ?INR_eq0' -?lt0n // mul1R.
rewrite -iter_addR -big_const /=.
rewrite (_ : \sum_(m | m \in M ) 1 = \sum_(m : M) 1); last exact/eq_bigl.
rewrite big_distrr /=.
apply: leR_sumR => m _.
rewrite mulNR exp2_Ropp.
rewrite mulRC leR_pdivr_mulr // ?mul1R.
apply/(@leR_trans #| V.-shell (tuple_of_row (enc tc m)) |%:R); last first.
  apply card_shelled_tuples => //.
    exact/typed_prop.
  case: (JType.c V) => _ Anot0.
  case/card_gt0P : (Anot0) => a _.
  exact: (fdist_card_neq0 (V a)).
apply/le_INR/leP/subset_leq_card/setIidPl/setP => tb.
by rewrite in_set in_set andbC andbA andbb.
Qed.

Let partition_pre_image : {set set_of_finType [finType of n.-tuple B]} :=
  [set T_{ `tO( V ) } :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m])) |
   m in M & [exists y, y \in T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))]].

Let trivIset_pre_image : trivIset partition_pre_image.
Proof.
apply/trivIsetP => /= E F.
case/imsetP => m _ Em.
case/imsetP => l _ El diffEF.
have m_l : m != l by apply/negP => /eqP abs; move: diffEF; apply/negPn/negPn; subst.
rewrite disjoints_subset; apply/subsetP => y; subst E F; rewrite !in_set => /andP [H1 /eqP H2].
rewrite H1 andTb.
move/eqP in H2.
case/imsetP : H2 => y1 Hy1 yy1.
apply/imsetP; case => y2 Hy2 yy2.
rewrite !inE in Hy1.
rewrite !inE in Hy2.
subst y.
move/tuple_of_row_inj : yy2 => ?; subst y2.
rewrite (eqP Hy1) in Hy2.
case/eqP : Hy2 => ?; subst l.
by rewrite eqxx in m_l.
Qed.

Let cover_pre_image : cover partition_pre_image =
  \bigcup_(m : M) (T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))).
Proof.
apply/setP => tb.
case/boolP : (tb \in cover partition_pre_image) => Hcase.
- symmetry; case/bigcupP: Hcase => E.
  rewrite /partition_pre_image; case/imsetP => m _ Em ; subst E => Hcase.
  apply/bigcupP; by exists m.
- symmetry.
  apply/negP => abs; move: Hcase; apply/negP/negPn.
  case/bigcupP : abs => m _ H.
  rewrite /cover /partition_pre_image.
  apply/bigcupP; exists (T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))) => //.
  apply/imsetP; exists m => //.
  rewrite in_set; apply/andP; split => //.
  apply/existsP; by exists tb.
Qed.

Lemma success_factor_bound_part2 :
  success_factor tc V <= exp2(n%:R * `I(P, V)) / #|M|%:R.
Proof.
rewrite /success_factor -mulRA (mulRC (/ #|M|%:R)) !mulRA.
apply leR_wpmul2r; first exact/invR_ge0/ltR0n.
rewrite /mutual_info_chan -addR_opp addRC addRA.
rewrite (_ : - `H(P , V) + `H P = - `H( V | P )); last by rewrite /cond_entropy_chan; field.
rewrite mulRDr mulRN -mulNR /exp2 ExpD; apply leR_wpmul2l => //.
rewrite -big_morph_natRD; apply (@leR_trans #| T_{`tO( V )} |%:R); last first.
  by rewrite -output_type_out_entropy //; exact: card_typed_tuples.
apply/le_INR/leP.
apply: (@leq_trans (\sum_m #| T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))|)).
- apply leq_sum => m _.
  by apply subset_leq_card, setSI, shell_subset_output_type.
- set lhs := (\sum__ _)%nat.
  rewrite (_ : lhs = #|\bigcup_(i : M) (T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some i]))) | ); last first.
    subst lhs.
    rewrite -cover_pre_image.
    move: trivIset_pre_image ; rewrite /trivIset => /eqP => <-.
    rewrite big_imset /= ; last first.
      move=> m l _.
      rewrite in_set; case/existsP => tb Htb.
      move/setP/(_ tb); rewrite Htb; move: Htb.
      rewrite in_set => /andP [_ Hl].
      rewrite in_set => /andP [_ Hm].
      suff : Some m = Some l by case.
      move: Hl Hm.
      case/imsetP => v1 Hv1 ->.
      case/imsetP => v2 Hv2.
      move/tuple_of_row_inj => ?; subst v2.
      rewrite !inE in Hv1, Hv2.
      by rewrite -(eqP Hv1) -(eqP Hv2).
    symmetry; rewrite big_mkcond /=.
    apply eq_bigr => m _.
    case : ifP => //; rewrite in_set => /negbT H.
    symmetry; apply/eqP/negPn/negP => abs ; move: H.
    apply/negP/negPn/existsP/card_gt0P; by rewrite lt0n.
  apply subset_leq_card; apply/subsetP => tb.
  case/bigcupP => m _.
  by rewrite in_set => /andP [H _].
Qed.

Lemma success_factor_ub :
  success_factor tc V <= success_factor_bound.
Proof.
rewrite /success_factor_bound.
apply Rmax_case.
- rewrite mulR0 exp2_0; by apply success_factor_bound_part1.
- apply (@leR_trans (exp2 (n%:R * `I(P, V)) / #|M|%:R)); last first.
  + apply/Req_le/esym.
    rewrite mulRDr mulRC.
    rewrite Rmult_opp_opp -mulRA mulRN mulVR ?INR_eq0' //.
    rewrite mulRN mulR1 /exp2 ExpD mulRC /Rdiv; f_equal.
    rewrite Exp_Ropp LogK //; exact/ltR0n.
  + exact/success_factor_bound_part2.
Qed.

End typed_success_factor_bound_sect.

Section typed_success_bound_sect.

Variables A B M : finType.
Variable W : `Ch*(A, B).
Hypothesis Mnot0 : (0 < #|M|)%nat.

Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).
Variable tc : typed_code B M P.

Let Anot0 : (0 < #|A|)%nat. Proof. by case: (W). Qed.

Let Bnot0 : (0 < #|B|)%nat.
Proof. case/card_gt0P : Anot0 => a _; exact: (fdist_card_neq0 (W a)). Qed.

Let V0 : P_ n (A, B).
Proof.
move: (jtype_not_empty n Anot0 Bnot0) => H; exact (enum_val (Ordinal H)).
Qed.

Hypothesis HV0 : V0 \in \nu^{B}(P).

Let exp_cdiv_bound := fun V => exp_cdiv P V W * success_factor_bound M V P.

Let Vmax := [arg max_(V > V0) exp_cdiv_bound V]%O.

Lemma typed_success_bound :
  scha(W, tc) <= n.+1%:R ^ (#|A| * #|B|) * exp_cdiv_bound Vmax.
Proof.
rewrite (typed_success W Mnot0 tc).
apply (@leR_trans ( \sum_(V|V \in \nu^{B}(P)) exp_cdiv P V W *
  exp2 (- n%:R *  +| log #|M|%:R * / n%:R - `I(P, V) |))).
  apply: leR_sumR => V Vnu.
  rewrite -mulRA; apply leR_wpmul2l.
    by rewrite /exp_cdiv; case : ifP => _ //; exact/leRR.
  by rewrite /success_factor mulRA; exact: success_factor_ub.
apply (@leR_trans (\sum_(V | V \in \nu^{B}(P)) exp_cdiv P Vmax W *
                    exp2 (- n%:R * +| log #|M|%:R * / n%:R - `I(P, Vmax)|))).
  apply leR_sumR => V HV.
  by move/leRP: (@arg_rmax2 [finType of (P_ n (A, B))] V0
    (fun V => exp_cdiv P V W * success_factor_bound M V P) V).
rewrite big_const iter_addR /success_factor_bound; apply leR_wpmul2r.
- apply mulR_ge0; last exact/exp2_ge0.
  by rewrite /exp_cdiv; case: ifP => _ //; exact/leRR.
- by rewrite natRexp; exact/le_INR/leP/card_nu.
Qed.

End typed_success_bound_sect.

Section success_bound_sect.

Variables A B M : finType.
Variable W : `Ch*(A, B).
Hypothesis Mnot0 : (0 < #|M|)%nat.

Variable n' : nat.
Let n := n'.+1.
Variable c : code A B M n.

Lemma Anot0 : (0 < #|A|)%nat. Proof. by case: (W) => _ Anot0. Qed.

Let P0 : P_ n ( A ).
Proof.
move: (type_card_neq0 n' Anot0) => H; exact (enum_val (Ordinal H)).
Defined.

Local Open Scope num_occ_scope.

Lemma success_bound :
  let Pmax := [arg max_(P > P0) scha(W, P.-typed_code c)]%O in
  scha(W, c) <= n.+1%:R ^ #|A| * scha(W, Pmax.-typed_code c).
Proof.
move=> Pmax.
apply (@leR_trans (#| P_ n ( A ) |%:R * scha W (Pmax.-typed_code c))); last first.
  apply leR_wpmul2r; first exact: scha_pos.
  rewrite natRexp; exact/le_INR/leP/(type_counting A n).
apply (@leR_trans (\sum_(P : P_ n ( A )) scha W (P.-typed_code c))); last first.
  rewrite (_ : #| P_ n ( A ) |%:R * scha W (Pmax.-typed_code c) =
             \sum_(P : P_ n ( A )) scha W (Pmax.-typed_code c)); last first.
    by rewrite big_const iter_addR.
  apply leR_sumR => P _.
  by move/leRP : (arg_rmax2 P0 (fun P1 : P_ n (A) => scha(W, P1.-typed_code c)) P).
rewrite schaE // -(sum_messages_types c).
rewrite div1R (big_morph _ (morph_mulRDr _) (mulR0 _)).
apply leR_sumR => P _.
rewrite mulRC leR_pdivr_mulr; last exact/ltR0n.
rewrite schaE // div1R -mulRA mulRCA mulVR ?INR_eq0' -?lt0n // mulR1.
apply/(@leR_trans (\sum_(m | m \in enc_pre_img c P)
                     \sum_(y | (dec (P.-typed_code c)) y == Some m)
                     (W ``(|(enc (P.-typed_code c)) m)) y)).
  apply leR_sumR => m Hm.
  apply Req_le, eq_big => tb // _.
  rewrite inE in Hm.
  by rewrite /tcode /= ffunE Hm.
- by apply leR_sumRl => //= i ?; [exact/leRR | exact: sumR_ge0].
Qed.

End success_bound_sect.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import Basics.
Require Import Types.
Require Import HSet.
Require Import Spaces.Nat.
Require Import HFiber.
Require Import Factorization.
Require Import Truncations.
Require Import Colimits.Quotient.
Require Import Projective.
Require Import Fin.

Local Open Scope path_scope.
Local Open Scope nat_scope.

(** ** Definition of general finite sets *)

Class Finite (X : Type) :=
  { fcard : nat ;
    merely_equiv_fin : merely (X <~> Fin fcard) }.

Arguments fcard X {_}.
Arguments merely_equiv_fin X {_}.

Definition issig_finite X
: { n : nat & merely (X <~> Fin n) } <~> Finite X.
Proof.
  issig.
Defined.

(** Note that the sigma over cardinalities is not truncated.  Nevertheless, because canonical finite sets of different cardinalities are not isomorphic, being finite is still an hprop.  (Thus, we could have truncated the sigma and gotten an equivalent definition, but it would be less convenient to reason about.) *)
Global Instance ishprop_finite X
: IsHProp (Finite X).
Proof.
  refine (istrunc_equiv_istrunc _ (issig_finite X)).
  apply ishprop_sigma_disjoint; intros n m Hn Hm.
  strip_truncations.
  refine (nat_eq_fin_equiv n m (Hm oE Hn^-1)).
Defined.

(** ** Preservation of finiteness by equivalences *)

Definition finite_equiv X {Y} (e : X -> Y) `{IsEquiv X Y e}
: Finite X -> Finite Y.
Proof.
  intros ?.
  refine (Build_Finite Y (fcard X) _).
  assert (f := merely_equiv_fin X); strip_truncations.
  apply tr.
  exact (equiv_compose f e^-1).
Defined.

Definition finite_equiv' X {Y} (e : X <~> Y)
: Finite X -> Finite Y
  := finite_equiv X e.

Corollary finite_equiv_equiv X Y
: (X <~> Y) -> (Finite X <~> Finite Y).
Proof.
  intros ?; apply equiv_iff_hprop; apply finite_equiv';
    [ assumption | symmetry; assumption ].
Defined.

Definition fcard_equiv {X Y} (e : X -> Y) `{IsEquiv X Y e}
           `{Finite X} `{Finite Y}
: fcard X = fcard Y.
Proof.
  transitivity (@fcard Y (finite_equiv X e _)).
  - reflexivity.
  - exact (ap (@fcard Y) (path_ishprop _ _)).
Defined.

Definition fcard_equiv' {X Y} (e : X <~> Y)
           `{Finite X} `{Finite Y}
: fcard X = fcard Y
  := fcard_equiv e.

(** ** Simple examples of finite sets *)

(** Canonical finite sets are finite *)
Global Instance finite_fin n : Finite (Fin n)
  := Build_Finite _ n (tr (equiv_idmap _)).

(** This includes the empty set. *)
Global Instance finite_empty : Finite Empty
  := finite_fin 0.

(** The unit type is finite, since it's equivalent to [Fin 1]. *)
Global Instance finite_unit : Finite Unit.
Proof.
  refine (finite_equiv' (Fin 1) _ _); simpl.
  apply sum_empty_l.
Defined.

(** Thus, any contractible type is finite. *)
Global Instance finite_contr X `{Contr X} : Finite X
  := finite_equiv Unit equiv_contr_unit^-1 _.

(** Any decidable hprop is finite, since it must be equivalent to [Empty] or [Unit]. *)
Definition finite_decidable_hprop X `{IsHProp X} `{Decidable X}
: Finite X.
Proof.
  destruct (dec X) as [x|nx].
  - assert (Contr X) by exact (contr_inhabited_hprop X x).
    exact _.
  - refine (finite_equiv Empty nx^-1 _).
Defined.

#[export]
Hint Immediate finite_decidable_hprop : typeclass_instances.

(** It follows that the propositional truncation of any finite set is finite. *)
Global Instance finite_merely X {fX : Finite X}
: Finite (merely X).
Proof.
  (** As in decidable_finite_hprop, we case on cardinality first to avoid needing funext. *)
  destruct fX as [[|n] e]; refine (finite_decidable_hprop _).
  - right.
    intros x; strip_truncations; exact (e x).
  - left.
    strip_truncations; exact (tr (e^-1 (inr tt))).
Defined.

(** Finite sets are closed under path-spaces. *)
Global Instance finite_paths {X} `{Finite X} (x y : X)
: Finite (x = y).
Proof.
  (** If we assume [Funext], then typeclass inference produces this automatically, since [X] has decidable equality and (hence) is a set, so [x=y] is a decidable hprop.  But we can also deduce it without funext, since [Finite] is an hprop even without funext. *)
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (finite_equiv _ (ap e)^-1 _).
  apply finite_decidable_hprop; exact _.
Defined.

(** Finite sets are also closed under successors. *)

Global Instance finite_succ X `{Finite X} : Finite (X + Unit).
Proof.
  refine (Build_Finite _ (fcard X).+1 _).
  pose proof (merely_equiv_fin X).
  strip_truncations; apply tr.
  refine (_ +E 1); assumption.
Defined.

Definition fcard_succ X `{Finite X}
: fcard (X + Unit) = (fcard X).+1
  := 1.

(** ** Decidability *)

(** Like canonical finite sets, finite sets have decidable equality. *)
Global Instance decidablepaths_finite `{Funext} X `{Finite X}
: DecidablePaths X.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (decidablepaths_equiv _ e^-1 _).
Defined.

(** However, contrary to what you might expect, we cannot assert that "every finite set is decidable"!  That would be claiming a *uniform* way to select an element from every nonempty finite set, which contradicts univalence. *)

(** One thing we can prove is that any finite hprop is decidable. *)
Global Instance decidable_finite_hprop X `{IsHProp X} {fX : Finite X}
: Decidable X.
Proof.
  (** To avoid having to use [Funext], we case on the cardinality of [X] before stripping the truncation from its equivalence to [Fin n]; if we did things in the other order then we'd have to know that [Decidable X] is an hprop, which requires funext. *)
  destruct fX as [[|n] e].
  - right; intros x.
    strip_truncations; exact (e x).
  - left.
    strip_truncations; exact (e^-1 (inr tt)).
Defined.

(** It follows that if [X] is finite, then its propositional truncation is decidable. *)
Global Instance decidable_merely_finite X {fX : Finite X}
: Decidable (merely X).
Proof.
  exact _.
Defined.

(** From this, it follows that any finite set is *merely* decidable. *)
Definition merely_decidable_finite X `{Finite X}
: merely (Decidable X).
Proof.
  apply O_decidable; exact _.
Defined.

(** ** Induction over finite sets *)

(** Most concrete applications of this don't actually require univalence, but the general version does.  For this reason the general statement is less useful (and less used in the sequel) than it might be. *)
Definition finite_ind_hprop `{Univalence}
           (P : forall X, Finite X -> Type)
           `{forall X (fX:Finite X), IsHProp (P X _)}
           (f0 : P Empty _)
           (fs : forall X (fX:Finite X), P X _ -> P (X + Unit)%type _)
           (X : Type) `{Finite X}
: P X _.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  assert (p := transportD Finite P (path_universe e^-1) _).
  refine (transport (P X) (path_ishprop _ _) (p _)).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - exact f0.
  - refine (transport (P (Fin n.+1)) (path_ishprop _ _) (fs _ _ IH)).
Defined.

(** ** The finite axiom of choice, and projectivity *)

Definition finite_choice {X} `{Finite X} : HasChoice X.
Proof.
  intros P oP f; clear oP.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  set (P' := P o e^-1).
  assert (f' := (fun x => f (e^-1 x)) : forall x, merely (P' x)).
  refine (Trunc_functor (X := forall x:Fin (fcard X), P' x) (-1) _ _).
  - intros g x; exact (eissect e x # g (e x)).
  - clearbody P'; clear f P e.
    generalize dependent (fcard X); intros n P f.
    induction n as [|n IH].
    + exact (tr (Empty_ind P)).
    + specialize (IH (P o inl) (f o inl)).
      assert (e := f (inr tt)).
      strip_truncations.
      exact (tr (sum_ind P IH (Unit_ind e))).
Defined.

Corollary isprojective_fin_n (n : nat) : IsProjective (Fin n).
Proof.
  apply (iff_isoprojective_hasochoice _ (Fin n)).
  rapply finite_choice.
Defined.

(** ** Constructions on finite sets *)

(** Finite sets are closed under sums, products, function spaces, and equivalence spaces.  There are multiple choices we could make regarding how to prove these facts.  Since we know what the cardinalities ought to be in all cases (since we know how to add, multiply, exponentiate, and take factorials of natural numbers), we could specify those off the bat, and then reduce to the case of canonical finite sets.  However, it's more amusing to instead prove finiteness of these constructions by "finite-set induction", and then *deduce* that their cardinalities are given by the corresponding operations on natural numbers (because they satisfy the same recurrences). *)

(** *** Binary sums *)

Global Instance finite_sum X Y `{Finite X} `{Finite Y}
: Finite (X + Y).
Proof.
  assert (e := merely_equiv_fin Y).
  strip_truncations.
  refine (finite_equiv _ (functor_sum idmap e^-1) _).
  generalize (fcard Y); intros n.
  induction n as [|n IH].
  - refine (finite_equiv _ (sum_empty_r X)^-1 _).
  - refine (finite_equiv _ (equiv_sum_assoc X _ Unit) _).
Defined.

(** Note that the cardinality function [fcard] actually computes.  The same will be true of all the other proofs in this section, though we don't always verify it. *)
Goal fcard (Fin 3 + Fin 4) = 7.
  reflexivity.
Abort.

Definition fcard_sum X Y `{Finite X} `{Finite Y}
: fcard (X + Y) = (fcard X + fcard Y).
Proof.
  refine (_ @ nat_add_comm _ _).
  assert (e := merely_equiv_fin Y).
  strip_truncations.
  refine (fcard_equiv' (1 +E e) @ _).
  refine (_ @ ap (fun y => (y + fcard X)) (fcard_equiv e^-1)).
  generalize (fcard Y); intros n.
  induction n as [|n IH].
  - refine (fcard_equiv (sum_empty_r X)^-1).
  - refine (fcard_equiv (equiv_sum_assoc _ _ _)^-1 @ _).
    exact (ap S IH).
Defined.

(** *** Binary products *)

Global Instance finite_prod X Y `{Finite X} `{Finite Y}
: Finite (X * Y).
Proof.
  assert (e := merely_equiv_fin Y).
  strip_truncations.
  refine (finite_equiv _ (functor_prod idmap e^-1) _).
  generalize (fcard Y); intros n.
  induction n as [|n IH].
  - refine (finite_equiv _ (prod_empty_r X)^-1 _).
  - refine (finite_equiv _ (sum_distrib_l X _ Unit)^-1 (finite_sum _ _)).
    refine (finite_equiv _ (prod_unit_r X)^-1 _).
Defined.

Definition fcard_prod X Y `{Finite X} `{Finite Y}
: fcard (X * Y) = fcard X * fcard Y.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (fcard_equiv' (e *E 1) @ _).
  refine (_ @ ap (fun x => x * fcard Y) (fcard_equiv e^-1)).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - refine (fcard_equiv (prod_empty_l Y)).
  - refine (fcard_equiv (sum_distrib_r Y (Fin n) Unit) @ _).
    refine (fcard_sum _ _ @ _).
    simpl.
    refine (_ @ nat_add_comm _ _).
    refine (ap011 add _ _).
    + apply IH.
    + apply fcard_equiv', prod_unit_l.
  Defined.

(** *** Function types *)

(** Finite sets are closed under function types, and even dependent function types. *)

Global Instance finite_forall `{Funext} {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: Finite (forall x:X, Y x).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  simple refine (finite_equiv' _
            (equiv_functor_forall' (P := fun x => Y (e^-1 x)) e _) _); try exact _.
  { intros x; refine (equiv_transport _ (eissect e x)). }
  set (Y' := Y o e^-1); change (Finite (forall x, Y' x)).
  assert (forall x, Finite (Y' x)) by exact _; clearbody Y'; clear e.
  generalize dependent (fcard X); intros n Y' ?.
  induction n as [|n IH].
  - exact _.
  - refine (finite_equiv _ (equiv_sum_ind Y') _).
    apply finite_prod.
    + apply IH; exact _.
    + refine (finite_equiv _ (@Unit_ind (fun u => Y' (inr u))) _).
      refine (isequiv_unit_ind (Y' o inr)).
Defined.

#[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances.

Definition fcard_arrow `{Funext} X Y `{Finite X} `{Finite Y}
: fcard (X -> Y) = nat_exp (fcard Y) (fcard X).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (fcard_equiv (functor_arrow e idmap)^-1 @ _).
  refine (_ @ ap (fun x => nat_exp (fcard Y) x) (fcard_equiv e)).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - reflexivity.
  - refine (fcard_equiv (equiv_sum_ind (fun (_:Fin n.+1) => Y))^-1 @ _).
    refine (fcard_prod _ _ @ _).
    apply (ap011 mul).
    + assumption.
    + refine (fcard_equiv (@Unit_ind (fun (_:Unit) => Y))^-1).
Defined.

(** [fcard] still computes, despite the funext: *)
Goal forall fs:Funext, fcard (Fin 3 -> Fin 4) = 64.
  reflexivity.
Abort.

(** *** Automorphism types (i.e. symmetric groups) *)

Global Instance finite_aut `{Funext} X `{Finite X}
: Finite (X <~> X).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (finite_equiv _
            (equiv_functor_equiv e^-1 e^-1) _).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - exact _.
  - refine (finite_equiv _ (equiv_fin_equiv n n) _).
Defined.

Definition fcard_aut `{Funext} X `{Finite X}
: fcard (X <~> X) = factorial (fcard X).
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (fcard_equiv
            (equiv_functor_equiv e^-1 e^-1)^-1 @ _).
  generalize (fcard X); intros n.
  induction n as [|n IH].
  - reflexivity.
  - refine (fcard_equiv (equiv_fin_equiv n n)^-1 @ _).
    refine (fcard_prod _ _ @ _).
    apply ap011.
    + reflexivity.
    + assumption.
Defined.

(** [fcard] still computes: *)
Goal forall fs:Funext, fcard (Fin 4 <~> Fin 4) = 24.
  reflexivity.
Abort.

(** ** Finite sums of natural numbers *)

(** Perhaps slightly less obviously, finite sets are also closed under sigmas. *)

Global Instance finite_sigma {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: Finite { x:X & Y x }.
Proof.
  assert (e := merely_equiv_fin X).
  strip_truncations.
  refine (finite_equiv' _
            (equiv_functor_sigma (equiv_inverse e)
                                 (fun x (y:Y (e^-1 x)) => y)) _).
  (** Unfortunately, because [compose] is currently beta-expanded, [set (Y' := Y o e^-1)] doesn't change the goal. *)
  set (Y' := fun x => Y (e^-1 x)).
  assert (forall x, Finite (Y' x)) by exact _; clearbody Y'; clear e.
  generalize dependent (fcard X); intros n Y' ?.
  induction n as [|n IH].
  - refine (finite_equiv Empty pr1^-1 _).
  - refine (finite_equiv _ (equiv_sigma_sum (Fin n) Unit Y')^-1 _).
    apply finite_sum.
    + apply IH; exact _.
    + refine (finite_equiv _ (equiv_contr_sigma _)^-1 _).
Defined.

(** Amusingly, this automatically gives us a way to add up a family of natural numbers indexed by any finite set.  (We could of course also define such an operation directly, probably using [merely_ind_hset].) *)

Definition finadd {X} `{Finite X} (f : X -> nat) : nat
  := fcard { x:X & Fin (f x) }.

Definition fcard_sigma {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: fcard { x:X & Y x } = finadd (fun x => fcard (Y x)).
Proof.
  set (f := fun x => fcard (Y x)).
  set (g := fun x => merely_equiv_fin (Y x) : merely (Y x <~> Fin (f x))).
  apply finite_choice in g; [| exact _].
  strip_truncations.
  unfold finadd.
  refine (fcard_equiv' (equiv_functor_sigma_id g)).
Defined.

(** The sum of a finite constant family is the product by its cardinality. *)
Definition finadd_const X `{Finite X} n
: finadd (fun x:X => n) = fcard X * n.
Proof.
  transitivity (fcard (X * Fin n)).
  - exact (fcard_equiv' (equiv_sigma_prod0 X (Fin n))).
  - exact (fcard_prod X (Fin n)).
Defined.

(** Closure under sigmas and paths also implies closure under hfibers. *)
Definition finite_hfiber {X Y} (f : X -> Y) (y : Y)
       `{Finite X} `{Finite Y}
: Finite (hfiber f y).
Proof.
  exact _.
Defined.

(** Therefore, the cardinality of the domain of a map between finite sets is the sum of the cardinalities of its hfibers. *)
Definition fcard_domain {X Y} (f : X -> Y) `{Finite X} `{Finite Y}
: fcard X = finadd (fun y => fcard (hfiber f y)).
Proof.
  refine (_ @ fcard_sigma (hfiber f)).
  refine (fcard_equiv' (equiv_fibration_replacement f)).
Defined.

(** In particular, the image of a map between finite sets is finite. *)
Definition finite_image
       {X Y} `{Finite X} `{Finite Y} (f : X -> Y)
: Finite (himage f).
Proof.
  exact _.
Defined.

(** ** Finite products of natural numbers *)

(** Similarly, closure of finite sets under [forall] automatically gives us a way to multiply a family of natural numbers indexed by any finite set.  Of course, if we defined this explicitly, it wouldn't need funext. *)

Definition finmult `{Funext} {X} `{Finite X} (f : X -> nat) : nat
  := fcard (forall x:X, Fin (f x)).

Definition fcard_forall `{Funext} {X} (Y : X -> Type)
       `{Finite X} `{forall x, Finite (Y x)}
: fcard (forall x:X, Y x) = finmult (fun x => fcard (Y x)).
Proof.
  set (f := fun x => fcard (Y x)).
  set (g := fun x => merely_equiv_fin (Y x) : merely (Y x <~> Fin (f x))).
  apply finite_choice in g; [| exact _].
  strip_truncations.
  unfold finmult.
  refine (fcard_equiv' (equiv_functor_forall' (equiv_idmap X) g)).
Defined.

(** The product of a finite constant family is the exponential by its cardinality. *)
Definition finmult_const `{Funext} X `{Finite X} n
: finmult (fun x:X => n) = nat_exp n (fcard X).
Proof.
  refine (fcard_arrow X (Fin n)).
Defined.

(** ** Finite subsets *)

(** Closure under sigmas implies that a detachable subset of a finite set is finite. *)
Global Instance finite_detachable_subset {X} `{Finite X} (P : X -> Type)
       `{forall x, IsHProp (P x)} `{forall x, Decidable (P x)}
: Finite { x:X & P x }.
Proof.
  exact _.
Defined.

(** Conversely, if a subset of a finite set is finite, then it is detachable.  We show first that an embedding between finite subsets has detachable image. *)
Definition detachable_image_finite
           {X Y} `{Finite X} `{Finite Y} (f : X -> Y) `{IsEmbedding f}
: forall y, Decidable (hfiber f y).
Proof.
  intros y.
  assert (ff : Finite (hfiber f y)) by exact _.
  destruct ff as [[|n] e].
  - right; intros u; strip_truncations; exact (e u).
  - left; strip_truncations; exact (e^-1 (inr tt)).
Defined.

Definition detachable_finite_subset {X} `{Finite X}
           (P : X -> Type) `{forall x, IsHProp (P x)}
           {Pf : Finite ({ x:X & P x })}
: forall x, Decidable (P x).
Proof.
  intros x.
  refine (decidable_equiv _ (hfiber_fibration x P)^-1 _).
  (* The try clause below is only needed for Coq <= 8.11 *)
  refine (detachable_image_finite pr1 x); try assumption.
  - apply (mapinO_pr1 (Tr (-1))).  (** Why doesn't Coq find this? *)
Defined.

(** ** Quotients *)

(** The quotient of a finite set by a detachable equivalence relation is finite. *)

Section DecidableQuotients.
  Context `{Univalence} {X} `{Finite X}
          (R : Relation X) `{is_mere_relation X R}
          `{Reflexive _ R} `{Transitive _ R} `{Symmetric _ R}
          {Rd : forall x y, Decidable (R x y)}.

  Global Instance finite_quotient : Finite (Quotient R).
  Proof.
    assert (e := merely_equiv_fin X).
    strip_truncations.
    pose (R' x y := R (e^-1 x) (e^-1 y)).
    assert (is_mere_relation _ R') by exact _.
    assert (Reflexive R') by (intros ?; unfold R'; apply reflexivity).
    assert (Symmetric R') by (intros ? ?; unfold R'; apply symmetry).
    assert (Transitive R') by (intros ? ? ?; unfold R'; apply transitivity).
    assert (R'd : forall x y, Decidable (R' x y))
      by (intros ? ?; unfold R'; apply Rd).
    srefine (finite_equiv' _ (equiv_quotient_functor R' R e^-1 _) _).
    1: by try (intros; split).
    clearbody R'; clear e.
    generalize dependent (fcard X);
      intros n; induction n as [|n IH]; intros R' ? ? ? ? ?.
    - refine (finite_equiv Empty _^-1 _).
      refine (Quotient_rec R' _ Empty_rec (fun x _ _ => match x with end)).
    - pose (R'' x y := R' (inl x) (inl y)).
      assert (is_mere_relation _ R'') by exact _.
      assert (Reflexive R'') by (intros ?; unfold R''; apply reflexivity).
      assert (Symmetric R'') by (intros ? ?; unfold R''; apply symmetry).
      assert (Transitive R'') by (intros ? ? ?; unfold R''; apply transitivity).
      assert (forall x y, Decidable (R'' x y)) by (intros ? ?; unfold R''; apply R'd).
      assert (inlresp := (fun x y => idmap)
                         : forall x y, R'' x y -> R' (inl x) (inl y)).
      destruct (dec (merely {x:Fin n & R' (inl x) (inr tt)})) as [p|np].
      { strip_truncations.
        destruct p as [x r].
        refine (finite_equiv' (Quotient R'') _ _).
        refine (Build_Equiv _ _ (Quotient_functor R'' R' inl inlresp) _).
        apply isequiv_surj_emb.
        - apply BuildIsSurjection.
          refine (Quotient_ind_hprop R' _ _).
          intros [y|[]]; apply tr.
          + exists (class_of R'' y); reflexivity.
          + exists (class_of R'' x); simpl.
            apply qglue, r.
        - apply isembedding_isinj_hset; intros u.
          refine (Quotient_ind_hprop R'' _ _); intros v.
          revert u; refine (Quotient_ind_hprop R'' _ _); intros u.
          simpl; intros q.
          apply qglue; unfold R''.
          exact (related_quotient_paths R' (inl u) (inl v) q). }
      { refine (finite_equiv' (Quotient R'' + Unit) _ _).
        refine (Build_Equiv _ _ (sum_ind (fun _ => Quotient R')
                                        (Quotient_functor R'' R' inl inlresp)
                                        (fun _ => class_of R' (inr tt))) _).
        apply isequiv_surj_emb.
        - apply BuildIsSurjection.
          refine (Quotient_ind_hprop R' _ _).
          intros [y|[]]; apply tr.
          + exists (inl (class_of R'' y)); reflexivity.
          + exists (inr tt); reflexivity.
        - apply isembedding_isinj_hset; intros u.
          refine (sum_ind _ _ _).
          + refine (Quotient_ind_hprop R'' _ _); intros v.
            revert u; refine (sum_ind _ _ _).
            * refine (Quotient_ind_hprop R'' _ _); intros u.
              simpl; intros q.
              apply ap, qglue; unfold R''.
              exact (related_quotient_paths R' (inl u) (inl v) q).
            * intros []; simpl.
              intros q.
              apply related_quotient_paths in q; try exact _.
              apply symmetry in q.
              elim (np (tr (v ; q))).
          + intros []; simpl.
            destruct u as [u|[]]; simpl.
            * revert u; refine (Quotient_ind_hprop R'' _ _); intros u; simpl.
              intros q.
              apply related_quotient_paths in q; try exact _.
              elim (np (tr (u;q))).
            * intros; reflexivity. }
  Defined.

  (** Therefore, the cardinality of [X] is the sum of the cardinalities of its equivalence classes. *)
  Definition fcard_quotient
  : fcard X = finadd (fun z:Quotient R => fcard {x:X & in_class R z x}).
  Proof.
    refine (fcard_domain (class_of R) @ _).
    apply ap, path_arrow; intros z; revert z.
    refine (Quotient_ind_hprop _ _ _); intros x; simpl.
    apply fcard_equiv'; unfold hfiber.
    refine (equiv_functor_sigma_id _); intros y; simpl.
    symmetry.
    refine (path_quotient R y x oE _).
    apply equiv_iff_hprop; apply symmetry.
  Defined.

End DecidableQuotients.

(** ** Injections *)

(** An injection between finite sets induces an inequality between their cardinalities. *)
Definition leq_inj_finite {X Y} {fX : Finite X} {fY : Finite Y}
           (f : X -> Y) (i : IsEmbedding f)
: fcard X <= fcard Y.
Proof.
  assert (MapIn (Tr (-1)) f) by exact _. clear i.
  destruct fX as [n e]; simpl.
  destruct fY as [m e']; simpl.
  strip_truncations.
  pose (g := e' o f o e^-1).
  assert (MapIn (Tr (-1)) g) by (unfold g; exact _).
  clearbody g. clear e e'. generalize dependent m.
  induction n as [|n IHn].
  1: exact _.
  intros m g ?.
  assert (i : isinj g) by (apply isinj_embedding; exact _).
  destruct m as [|m].
  { elim (g (inr tt)). }
  pose (h := (fin_transpose_last_with m (g (inr tt)))^-1 o g).
  assert (MapIn (Tr (-1)) h) by (unfold h; exact _).
  assert (Ha : forall a:Fin n, is_inl (h (inl a))).
  { intros a.
    remember (g (inl a)) as b eqn:p.
    destruct b as [b|[]].
    - assert (q : g (inl a) <> (g (inr tt))).
      { intros r. exact (inl_ne_inr _ _ (i _ _ r)). }
      rewrite p in q; apply symmetric_neq in q.
      assert (r : h (inl a) = inl b).
      { unfold h; apply moveR_equiv_V; symmetry.
        refine (fin_transpose_last_with_rest m (g (inr tt)) b q @ p^). }
      rewrite r; exact tt.
    - assert (q : h (inl a) = g (inr tt)).
      { unfold h; apply moveR_equiv_V; symmetry.
        refine (_ @ p^); apply fin_transpose_last_with_with. }
      rewrite q.
      destruct (is_inl_or_is_inr (g (inr tt))) as [l|r]; try assumption.
      assert (s := inr_un_inr _ r).
      revert s; generalize (un_inr (g (inr tt)) r); intros [] s.
      elim (inl_ne_inr _ _ (i _ _ (p @ s))). }
  assert (Hb : forall b:Unit, is_inr (h (inr b))).
  { intros [].
    assert (q : h (inr tt) = inr tt).
    { unfold h; apply moveR_equiv_V; symmetry.
      apply fin_transpose_last_with_last. }
    rewrite q; exact tt. }
  apply leq_S_n'.
  exact (IHn m (unfunctor_sum_l h Ha)
             (mapinO_unfunctor_sum_l (Tr (-1)) h Ha Hb)).
Qed.

(** ** Surjections  *)
(** A surjection between finite sets induces an inequality between their cardinalities. *)
Definition geq_surj_finite  {X Y} {fX : Finite X} {fY : Finite Y}
           (f : X -> Y) (i : IsSurjection f)
  : fcard X >= fcard Y.
Proof.
  destruct fX as [n e], fY as [m e']; simpl.
  assert (k := isprojective_fin_n m).
  strip_truncations.
  pose (g := e' o f o e^-1).
  assert (k' : IsSurjection g) by exact _ .
  clearbody g; clear i f.
  assert (j := k (Fin n) _ (Fin m) _ idmap g k').
  strip_truncations.
  simpl; destruct j as [s is_section].
  change n with (fcard (Fin n)).
  change m with (fcard (Fin m)).
  apply (leq_inj_finite s).
  apply isembedding_isinj_hset, (isinj_section is_section).
Defined.

  (** ** Enumerations *)

(** A function from [nat] to a finite set must repeat itself eventually. *)
Section Enumeration.
  Context `{Funext} {X} `{Finite@{_ Set _} X} (e : nat -> X).

  Let er (n : nat) : Fin n -> X
    := fun k => e (nat_fin n k).

  Lemma finite_enumeration_stage (n : nat)
  : IsEmbedding (er n)
    + { n : nat & { k : nat & e n = e (n + k).+1 }}.
  Proof.
    induction n as [|n [IH|IH]].
    - left. intros x.
      apply hprop_inhabited_contr; intros [[] _].
    - destruct (detachable_image_finite (er n) (er n.+1 (inr tt)))
        as [[k p]|ne].
      + right.
        exists (nat_fin n k).
        exists (nat_fin_compl n k).
        rewrite nat_fin_compl_compl.
        exact p.
      + left. intros x.
        apply hprop_allpath.
        intros k l.
        apply path_sigma_hprop.
        destruct k as [[k|[]] p], l as [[l|[]] q]; simpl.
        * apply isinj_embedding in IH.
          apply ap.
          apply IH.
          unfold er in p, q. simpl in p, q.
          exact (p @ q^).
        * refine (Empty_rec (ne _)).
          exists k.
          exact (p @ q^).
        * refine (Empty_rec (ne _)).
          exists l.
          exact (q @ p^).
        * reflexivity.
    - right; exact IH.
  Defined.

  Definition finite_enumeration_repeats
  : { n : nat & { k : nat & e n = e (n + k).+1 }}.
  Proof.
    destruct (finite_enumeration_stage (fcard X).+1) as [p|?].
    - assert (q := leq_inj_finite (er (fcard X).+1) p); simpl in q.
      elim (not_lt_n_n _ q).
    - assumption.
  Defined.

End Enumeration.


From discprob.basic Require Import base nify order seq_ext.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype choice fintype bigop seq.
From Coquelicot Require Import Rcomplements Rbar Series Lim_seq Hierarchy Markov.
Require Import Reals Psatz Omega.

(* Coquelicot defines some of its own algebraic hierarchy and
   functions for indexed sums: sum_n_m. But, ssreflect has its own
   rather developed library for so-called "big-ops", which uses a
   different algebraic hierarchy. We now define a compatibility layer
   to connect the Coquelicot hierarchy for R to the one assumed by
   ssreflect. *)

Section RAddLaw.
Import Monoid.

Lemma Rplus_associative: associative  Rplus.
Proof. intros ???; apply: Hierarchy.plus_assoc. Qed.
Lemma Rplus_left_id: left_id R0 Rplus.
Proof. intros ?. apply: Hierarchy.plus_zero_l. Qed.
Lemma Rplus_right_id: right_id R0 Rplus.
Proof. intros ?. apply: Hierarchy.plus_zero_r. Qed.
Lemma Rplus_commutative: commutative Rplus.
Proof. intros ?. apply: Hierarchy.plus_comm. Qed.

Lemma Rplus_left_distributive: left_distributive Rmult Rplus.
Proof. intros ???. nra. Qed.
Lemma Rplus_right_distributive: right_distributive Rmult Rplus.
Proof. intros ???. nra. Qed.
Lemma Rmult_left_zero: left_zero 0 Rmult.
Proof. intros ?. nra. Qed.
Lemma Rmult_right_zero: right_zero 0 Rmult.
Proof. intros ?. nra. Qed.

Canonical Rplus_monoid := Law Rplus_associative Rplus_left_id Rplus_right_id.
Canonical Rplus_comoid := ComLaw Rplus_commutative.
Canonical Rplus_addoid := AddLaw Rplus_left_distributive Rplus_right_distributive.
Canonical Rmult_muloid := MulLaw Rmult_left_zero Rmult_right_zero.

End RAddLaw.

Section sum_reidx.
Local Open Scope R_scope.

Lemma inj_neq {X Y: eqType} (h: X -> Y) a b: injective h -> a != b -> h a != h b.
Proof.
  intros Hinj Hab. apply /negP. move/eqP. intros H%Hinj.
  move:Hab. rewrite H eq_refl. done.
Qed.

Lemma sum_reidx_map {A B: eqType} (p: seq A) (q: seq B) P Q (h : A -> B) (F: A -> R) (F': B -> R) :
  (forall a,  a \in p -> F a = F' (h a)) ->
  (forall a,  a \in p -> P a = true -> (h a) \in q /\ Q (h a) = true ) ->
  (forall b,  b \in q -> Q b -> ~ (exists a, a \in p /\ P a = true /\ h a = b) -> F' b = 0) ->
  uniq p -> uniq q -> (∀ x x', P x → h x = h x' → x = x') ->
  \big[Rplus/0]_(i <- p | P i) (F i) =
  \big[Rplus/0]_(i <- q | Q i) (F' i).
Proof.
  move: q.
  induction p;
  intros q HFF' HPQ Hnin0 Huniq Huniq' Hinj.
  - rewrite big_nil.
    clear Huniq Huniq'.
    induction q as [|b q].
    * rewrite big_nil. done.
    * rewrite big_cons.
      case: ifP => [?|?].
      ** rewrite -[a in a = _]Rplus_0_r. f_equal.
         *** rewrite Hnin0 //; first apply mem_head.
             intros (a'&?&?&?). done.
         *** eapply IHq; eauto.
             **** intros a'. rewrite in_nil. done.
             **** intros ?? HQ Hbad. eapply Hnin0; auto. rewrite in_cons. apply /orP. by right.
      ** eapply IHq; eauto.
         *** intros a'. rewrite in_nil. done.
         *** intros ?? HQ Hbad. eapply Hnin0; auto. rewrite in_cons. apply /orP. by right.
  - rewrite big_cons.
    case: ifP => [HP | HnP].
    * apply HPQ in HP as (?&Hin); auto using mem_head.
      rewrite (big_rem (h a)) //= Hin.
      f_equal.
      ** eauto using HFF', mem_head.
      ** eapply IHp; auto using rem_uniq.
         *** intros. apply HFF'.
             rewrite in_cons. apply /orP. by right.
         *** intros a' Hin' HP'.
             rewrite rem_filter //; split.
             **** rewrite mem_filter. apply /andP.
                  split.
                  ***** rewrite /predC1 //=.
                        apply /eqP => Heq. apply Hinj in Heq; eauto.
                        move:Huniq. rewrite cons_uniq.
                        move/andP. intros (Hnin'&?).
                        subst. move: Hnin'. move /negP. auto.
                   ***** eapply HPQ; eauto. rewrite in_cons. apply /orP. by right.
             **** eapply HPQ; eauto. rewrite in_cons. apply /orP. by right.
         *** intros b.  rewrite rem_filter // mem_filter /predC1 //=. move/andP=>[Hneq' ?] HQ Hneq.
             eapply Hnin0; auto.
             intros (a'&Hin'&HP'&Ha').
             eapply Hneq. exists a'. split; auto.
             move:Hin'. rewrite in_cons.
             move/orP=>[Heq|?].
             **** exfalso. rewrite -Ha' in Hneq'.
                  move:Hneq'. move/eqP. move:Heq. move/eqP. intros ->.  done.
             **** auto.
         *** move:Huniq. rewrite cons_uniq. move/andP. firstorder.
    * eapply IHp; auto.
      ** intros. apply HFF'.
         rewrite in_cons. apply /orP. by right.
      ** intros a' Hin' HP'.
         eapply HPQ; auto.
         rewrite in_cons. apply /orP. by right.
      ** intros ?? HQ Hnin'. eapply Hnin0; auto.
         intros (a'&Hin'&HP'&Ha'). eapply Hnin'.
         exists a'. split; auto.
         move:Hin'. rewrite in_cons. move/orP=>[Heq|?]; auto.
         exfalso. move:Heq. move/eqP. intros Heq. rewrite Heq in HP'. congruence.
      ** move:Huniq. rewrite cons_uniq. move/andP. firstorder.
Qed.

(* TODO: this is obviously rather redundant with above *)
Lemma sum_reidx_map_le {A B: eqType} (p: seq A) (q: seq B) P Q (h : A -> B) (F: A -> R) (F': B -> R) :
  (forall a,  a \in p -> F a <= F' (h a)) ->
  (forall a,  a \in p -> P a = true -> (h a) \in q /\ Q (h a) = true ) ->
  (forall b,  b \in q -> Q b -> ~ (exists a, a \in p /\ P a = true /\ h a = b) -> F' b >= 0) ->
  uniq p -> uniq q -> (∀ x x', P x → h x = h x' → x = x') ->
  \big[Rplus/0]_(i <- p | P i) (F i) <=
  \big[Rplus/0]_(i <- q | Q i) (F' i).
Proof.
  move: q.
  induction p;
  intros q HFF' HPQ Hnin0 Huniq Huniq' Hinj.
  - rewrite big_nil.
    clear Huniq Huniq'.
    induction q as [|b q].
    * rewrite big_nil. nra.
    * rewrite big_cons.
      case: ifP => [?|?].
      ** rewrite -[a in a <= _]Rplus_0_r. apply Rplus_le_compat.
         *** eapply Rge_le, Hnin0; auto; first apply mem_head.
             intros (a'&?&?&?). done.
         *** eapply IHq; eauto.
             **** intros a'. rewrite in_nil. done.
             **** intros ?? HQ Hbad. eapply Hnin0; auto. rewrite in_cons. apply /orP. by right.
      ** eapply IHq; eauto.
         *** intros a'. rewrite in_nil. done.
         *** intros ?? HQ Hbad. eapply Hnin0; auto. rewrite in_cons. apply /orP. by right.
  - rewrite big_cons.
    case: ifP => [HP | HnP].
    * apply HPQ in HP as (?&Hin); auto using mem_head.
      rewrite (big_rem (h a)) //= Hin.
      apply Rplus_le_compat.
      ** eauto using HFF', mem_head.
      ** eapply IHp; auto using rem_uniq.
         *** intros. apply HFF'.
             rewrite in_cons. apply /orP. by right.
         *** intros a' Hin' HP'.
             rewrite rem_filter //; split.
             **** rewrite mem_filter. apply /andP.
                  split.
                  ***** rewrite /predC1 //=.
                        apply /eqP => Heq. apply Hinj in Heq; eauto.
                        move:Huniq. rewrite cons_uniq.
                        move/andP. intros (Hnin'&?).
                        subst. move: Hnin'. move /negP. auto.
                  ***** eapply HPQ; eauto. rewrite in_cons. apply /orP. by right.
             **** eapply HPQ; eauto. rewrite in_cons. apply /orP. by right.
         *** intros b.  rewrite rem_filter // mem_filter /predC1 //=. move/andP=>[Hneq' ?] HQ Hneq.
             eapply Hnin0; auto.
             intros (a'&Hin'&HP'&Ha').
             eapply Hneq. exists a'. split; auto.
             move:Hin'. rewrite in_cons.
             move/orP=>[Heq|?].
             **** exfalso. rewrite -Ha' in Hneq'.
                  move:Hneq'. move/eqP. move:Heq. move/eqP. intros ->.  done.
             **** auto.
         *** move:Huniq. rewrite cons_uniq. move/andP. firstorder.
    * eapply IHp; auto.
      ** intros. apply HFF'.
         rewrite in_cons. apply /orP. by right.
      ** intros a' Hin' HP'.
         eapply HPQ; auto.
         rewrite in_cons. apply /orP. by right.
      ** intros ?? HQ Hnin'. eapply Hnin0; auto.
         intros (a'&Hin'&HP'&Ha'). eapply Hnin'.
         exists a'. split; auto.
         move:Hin'. rewrite in_cons. move/orP=>[Heq|?]; auto.
         exfalso. move:Heq. move/eqP. intros Heq. rewrite Heq in HP'. congruence.
      ** move:Huniq. rewrite cons_uniq. move/andP. firstorder.
Qed.

Variable A B : eqType.

Lemma sum_reidx_map_sym (p: seq A) (q: seq B) (P: A -> bool) Q (h : A -> B) (F: A -> R) (F': B -> R) :
  (forall a,  a \in p -> F a = F' (h a)) ->
  (forall a,  a \in p -> P a ->  (~ (h a \in q /\ Q (h a) = true)) -> F a = 0) ->
  (forall b,  b \in q -> Q b -> ~ (exists a, a \in p /\ P a = true /\ h a = b) -> F' b = 0) ->
  uniq p -> uniq q -> injective h ->
  \big[Rplus/0]_(i <- p | P i) (F i) =
  \big[Rplus/0]_(i <- q | Q i) (F' i).
Proof.
  intros HFF' Hnin0a Hnin0b Huniq Huniq' Hinj.
  transitivity (\big[Rplus/0]_(i <- p | P i && (h i \in q) && (Q (h i))) (F i)).
  { symmetry.
    eapply (sum_reidx_map _ _ (fun a => P a && (h a \in q) && Q (h a))
                              P (fun x => x)); auto.
    - intros a Hin. by do 2 move /andP => [].
    - intros a Hin HP Hfalse. apply Hnin0a; auto. intros (?&?). apply Hfalse.
      exists a; repeat split; auto.
      apply /andP; split; auto.
      apply /andP; split; auto.
  }
  eapply (sum_reidx_map _ _ _ _ h); auto.
  - intros a Hin. move /andP => []. move /andP => []. auto.
  - intros b Hin HQ Hfalse. apply Hnin0b; auto.
    intros (a&?&?&Heq). apply Hfalse; exists a; repeat split; auto.
    rewrite Heq. do 2 (apply /andP; split; auto).
Qed.

Lemma sum_reidx_surj1 (p: seq A) (q: seq B) P Q (h : A -> B) (F: A -> R) (F': B -> R) :
  (forall a,  a \in p -> F a = F' (h a)) ->
  (forall a,  a \in p -> P a = true -> (h a) \in q /\ Q (h a) = true ) ->
  (forall b,  b \in q -> Q b -> exists a, a \in p /\ P a = true /\ h a = b) ->
  uniq p -> uniq q -> injective h ->
  \big[Rplus/0]_(i <- p | P i) (F i) =
  \big[Rplus/0]_(i <- q | Q i) (F' i).
Proof.
  intros ?? Hsurj ???. eapply sum_reidx_map; eauto.
  intros ??? Hfalse. exfalso; apply Hfalse.
  apply Hsurj; auto.
Qed.

Lemma sum_reidx_surj2 (p: seq A) (q: seq B) P Q (h : A -> B) (F: A -> R) (F': B -> R) :
  (forall a,  a \in p -> F a = F' (h a)) ->
  (forall a,  a \in p -> P a = true -> (h a) \in q /\ Q (h a) = true ) ->
  (forall b,  b \in q -> Q b -> has (fun a => P a && (h a == b)) p) ->
  uniq p -> uniq q -> injective h ->
  \big[Rplus/0]_(i <- p | P i) (F i) =
  \big[Rplus/0]_(i <- q | Q i) (F' i).
Proof.
  intros ?? Hsurj ???. eapply sum_reidx_surj1; eauto.
  intros b Hinb HQ. specialize (Hsurj b Hinb HQ).
  move: Hsurj. move /hasP => [x ?]. move /andP => [HP Heq].
  exists x. repeat split; eauto. apply /eqP. done.
Qed.

End sum_reidx.

Lemma Rabs_bigop_triang {A} (f: A → R) (p: seq A) (P: pred A):
  Rabs (\big[Rplus/0]_(i <- p | P i) (f i)) <= \big[Rplus/0]_(i <- p | P i) (Rabs (f i)).
Proof.
  induction p.
  - rewrite ?big_nil Rabs_R0 //. reflexivity.
  - rewrite ?big_cons.
    case: ifP; eauto.
    etransitivity; first eapply Rabs_triang. nra.
Qed.

Lemma bigop_cond_non0 {A} (f: A → R) (p: seq A) P:
  \big[Rplus/0]_(i <- p | P i) (f i) =
  \big[Rplus/0]_(i <- p | P i && (f i != 0)) (f i).
Proof.
  induction p as [| a p].
  - rewrite ?big_nil //.
  - rewrite ?big_cons.
    case: (P a) => //=.
    case: ifP.
    * intros. f_equal; eauto.
    * move /eqP => ->. nra.
Qed.

Lemma Rabs_bigop_filter {A} (f: A → R) (p: seq A) (P Q: pred A):
  (∀ a, P a → Q a) →
  \big[Rplus/0]_(i <- p | P i) (Rabs (f i)) <= \big[Rplus/0]_(i <- p | Q i) (Rabs (f i)).
Proof.
  intros Hcond.
  induction p as [| a p].
  - rewrite ?big_nil //. reflexivity.
  - rewrite ?big_cons. specialize (Hcond a).
    move: Hcond. case: (P a).
    * intros ->; auto. nra.
    * case: (Q a).
      ** intros. specialize (Rabs_pos (f a)). nra.
      ** done.
Qed.

Lemma sum_n_bigop (f: nat → R) n:
  sum_n f n = \big[Rplus/0]_(i < S n) (f i).
Proof.
  induction n.
  - rewrite sum_O big_ord_recl big_ord0 /=. nra.
  - rewrite sum_Sn big_ord_recr IHn. rewrite /plus//=.
Qed.

Lemma sum_n_m_bigop (f: nat → R) n m:
  sum_n_m f n m = \big[Rplus/0]_(n <= i < S m) (f i).
Proof.
  revert n. induction m => n.
  - induction n => //=.
    * specialize (sum_O f). rewrite /sum_n => ->.
      rewrite big_mkord big_ord_recl big_ord0 //=. nra.
    * rewrite sum_n_m_zero; last by lia.
      rewrite big_geq; try (nify; lia). done.
  - destruct (le_dec n (S m)) as [Hle|Hgt].
    * rewrite sum_n_Sm //=.
      assert (ssrnat.leq (S m) (S (S m))) as Hrange by (nify; lia).
      rewrite (big_cat_nat _ _ _ _ Hrange); last by (nify; lia).
      rewrite IHm big_nat1 /plus//=.
    * rewrite sum_n_m_zero; last by omega.
      rewrite big_geq; try (nify; lia). done.
Qed.

Lemma Rle_bigr {A} (f1 f2: A → R) (p: seq A) (P: pred A):
  (∀ i, P i → f1 i <= f2 i) →
  (\big[Rplus/0]_(i <- p | P i) (f1 i)) <= \big[Rplus/0]_(i <- p | P i) f2 i.
Proof.
  intros Hle.
  induction p as [| a p].
  - rewrite ?big_nil //=. nra.
  - rewrite ?big_cons.
    case: ifP; eauto => HP.
    specialize (Hle a HP).
    nra.
Qed.

Lemma Rle_bigr' {A} (f1 f2: A → R) (p: seq A) (P Q: pred A):
  (∀ i, P i → (Q i) ∧ f1 i <= f2 i) →
  (∀ i, ¬ P i →  Q i → 0 <= f2 i) →
  (\big[Rplus/0]_(i <- p | P i) (f1 i)) <= \big[Rplus/0]_(i <- p | Q i) f2 i.
Proof.
  intros Hle Hpos.
  induction p as [| a p].
  - rewrite ?big_nil //=. nra.
  - rewrite ?big_cons.
    case: ifP; eauto => HP.
    * specialize (Hle a HP). destruct Hle as (->&?).
      nra.
    * case: ifP; eauto => HQ.
      move /negP in HP. specialize (Hpos a HP HQ). nra.
Qed.

Lemma Rle_big0 {A} (f: A → R) (p: seq A) (P: pred A):
  (∀ i, P i → 0 <= f i) →
  0 <= \big[Rplus/0]_(i <- p | P i) f i.
Proof.
  intros Hle.
  induction p as [| a p].
  - rewrite ?big_nil //=. nra.
  - rewrite ?big_cons.
    case: ifP; eauto => HP.
    specialize (Hle a HP).
    nra.
Qed.

Lemma Rlt_big_inv {A: eqType} (f g: A → R) (p: seq A) (P: pred A):
  \big[Rplus/0]_(i <- p | P i) f i < \big[Rplus/0]_(i <- p | P i) g i →
  ∃ i, (i \in p) ∧ P i ∧ f i < g i.
Proof.
  intros Hle.
  induction p as [| a p].
  - rewrite ?big_nil in Hle. nra.
  - rewrite ?big_cons in Hle.
    move: Hle.
    case: ifP; eauto => HP.
    * intros; destruct (Rlt_dec (f a) (g a)).
      ** exists a. repeat split; auto. rewrite in_cons eq_refl. done.
      ** edestruct IHp as (?&?&?&?); first by nra.
         exists x. repeat split; auto. rewrite in_cons. apply /orP. by right.
    * intros; edestruct IHp as (?&?&?&?); first by nra.
         exists x. repeat split; auto. rewrite in_cons. apply /orP. by right.
Qed.

Lemma Rlt_bigr {A: eqType} (f1 f2: A → R) (p: seq A) (P: pred A):
  (∀ i, P i → f1 i <= f2 i) →
  (∃ i, (i \in p) ∧ P i ∧ f1 i < f2 i) →
  (\big[Rplus/0]_(i <- p | P i) (f1 i)) < \big[Rplus/0]_(i <- p | P i) f2 i.
Proof.
  intros Hle (i&Hin&HP&Hlt).
  induction p as [| a p].
  - rewrite in_nil in Hin. exfalso; auto.
  - rewrite in_cons in Hin. move /orP in Hin. destruct Hin as [Heq|Hin].
    * move /eqP in Heq; subst. rewrite ?big_cons HP.
      apply Rplus_lt_le_compat; first done.
      apply Rle_bigr; auto.
    * rewrite ?big_cons. case: ifP =>?; eauto.
      apply Rplus_le_lt_compat; eauto.
Qed.

Lemma Rlt_0_bigr {A: eqType} (f: A → R) (p: seq A) (P: pred A):
  (∀ i, P i → 0 <= f i) →
  (∃ i, (i \in p) ∧ P i ∧ 0 < f i) →
  0 < \big[Rplus/0]_(i <- p | P i) f i.
Proof.
  intros Hle (i&Hin&HP&Hlt).
  eapply Rle_lt_trans; last apply (Rlt_bigr (λ x, 0)); eauto.
  rewrite big1 => //=. reflexivity.
Qed.

Lemma Rlt_0_big_inv {A: eqType} (f: A → R) (p: seq A) (P: pred A):
  0 < \big[Rplus/0]_(i <- p | P i) f i →
  (∃ i, (i \in p) ∧ P i ∧ 0 < f i).
Proof.
  intros; eapply Rlt_big_inv.
  rewrite big1 => //=.
Qed.

Lemma big_INR {A: finType} F:
  (\big[Rplus/0]_(i : A) INR (F i) = INR (\sum_(i : A) (F i))).
Proof.
  elim: (index_enum _) => [| hd tl IH].
  - rewrite 2!big_nil => //=.
  - by rewrite 2!big_cons IH -plus_INR.
Qed.

Lemma Rmax_INR a b: Rmax (INR a) (INR b) = INR (max a b).
Proof.
  apply Rmax_case_strong; intros ?%INR_le; f_equal;
    [ rewrite Max.max_l // | rewrite Max.max_r //].
Qed.

From mathcomp Require Import ssrnat.

Lemma sum_index_ordinal_P_aux {A} (f: A → R) (l: seq A) r P P':
  (∀ i, (i < size l)%nat → P i = P' (nth r l i)) →
  \big[Rplus/0%R]_(a in 'I_(size l) | P a) nth 0 [seq (f i) | i <- l] a =
  \big[Rplus/0%R]_(a<-l | P' a) (f a).
Proof.
    revert r P P'.
    induction l as [| a l] => r P P' HP.
    - rewrite //= big_nil big_ord0 //.
    - transitivity (\big[Rplus/0%R]_(0<= a' < S (size l) | P a') nth 0 ([seq (f i)| i <- a :: l]) a').
      { by rewrite big_mkord. }
      rewrite big_mkcond [a in _ = a]big_mkcond //= big_cons big_mkcond big_ltn //=.
      f_equal.
      * specialize (HP 0%nat). rewrite HP //=.
      * rewrite big_add1 //=. rewrite -big_mkcond -big_mkcond -(IHl r (λ i, P (S i)) P').
        ** rewrite big_mkord. done.
        ** intros. rewrite (HP (S i)) //=.
Qed.

Lemma sum_index_ordinal_P {A} (f: A → R) (l: seq (A)) r (P: 'I_(size l) → bool) P':
  (∀ i, P i = P' (nth r l i)) →
  \big[Rplus/0%R]_(a in 'I_(size l) | P a) nth 0 [seq (f i) | i <- l] a =
  \big[Rplus/0%R]_(a<-l | P' a) (f a).
Proof.
  set (P'' := λ (n: nat),
              match lt_dec n (size l) with
                | left Pf => P (Ordinal ((introT ltP Pf)))
                | _ => true
              end).
  intros HP.
  rewrite -(sum_index_ordinal_P_aux f l r P''); last first.
  {
    intros i Hlt. rewrite /P'' //=. destruct lt_dec as [?|n] => //=.
    - eauto.
    - exfalso; apply n. apply /ltP. done.
  }
  rewrite /P'' //=.
  rewrite big_mkcond.
  rewrite big_mkcond [a in _ = a]big_mkcond.
  apply eq_bigr => i ?.
  destruct (lt_dec i (size l)) as [Hlt|Hn].
  - rewrite //=.
    assert (i = Ordinal (m := i) (introT ltP Hlt)) as <-.
    { apply ord_inj => //=. }
    done.
  - exfalso; apply Hn. apply /ltP/ltn_ord.
Qed.

Lemma sum_index_ordinal {A: eqType} f (l: seq A):
  \big[Rplus/0]_(a in 'I_(size l)) nth 0 [seq (f i) | i <- l] a =
  \big[Rplus/0]_(a<-[seq (f i) | i <- l]) a.
Proof.
    induction l as [| a l].
    * rewrite //= big_nil big_ord0 //.
    * transitivity (\big[Rplus/0%R]_(0<= a' < (size l).+1) nth 0 ([seq (f i) | i <- a :: l]) a').
      { by rewrite big_mkord. }
      rewrite //= big_cons big_ltn; last auto.
      f_equal; rewrite big_add1 //=. rewrite -IHl big_mkord. done.
Qed.

Lemma sum_index_ordinal_F {A: eqType} (l: seq (R * A)) F:
  \big[Rplus/0]_(a in 'I_(size l)) F (nth 0 [seq i.1 | i <- l] a) =
  \big[Rplus/0]_(a<-[seq i.1 | i <- l]) F a.
Proof.
    induction l as [| a l].
    * rewrite //= big_nil big_ord0 //.
    * transitivity (\big[Rplus/0%R]_(0<= a' < (size l).+1) F (nth 0 ([seq i.1 | i <- a :: l]) a')).
      { by rewrite big_mkord. }
      rewrite //= big_cons big_ltn; last auto.
      f_equal; rewrite big_add1 //=. rewrite -IHl big_mkord. done.
Qed.

Lemma big_Rplus_allpair {A B: eqType} (l1: seq A) (l2: seq B) F:
  \big[Rplus/0]_(i <- [seq (x1, x2) | x1 <- l1, x2 <- l2]) F i =
  \big[Rplus/0]_(i1 <- l1) \big[Rplus/0]_(i2 <- l2) F (i1, i2).
Proof.
  revert l2. induction l1 => //=.
  - intros l2. rewrite ?big_nil. done.
  - intros l2. rewrite big_cat big_cons IHl1 big_map //.
Qed.

Lemma big_Rplus_allpair' {A B: eqType} P Q (l1: seq {x: A | P x}) (l2: seq {x: B | Q x}) F:
  \big[Rplus/0]_(i <- [seq (sval x1, sval x2) | x1 <- l1, x2 <- l2]) F i =
  \big[Rplus/0]_(i1 <- l1) \big[Rplus/0]_(i2 <- l2) F (sval i1, sval i2).
Proof.
  etransitivity; last first.
  { eapply eq_bigr => i ?. rewrite -(big_map _ (λ x, true) (λ x, F (sval i, x))). done. }
  rewrite -(big_map _ (λ x, true) (λ x, \big[Rplus/0]_(i <- _ ) F (x, i))).
  rewrite -big_Rplus_allpair.
  f_equal. apply (allpairs_comp sval sval l1 l2).
Qed.


(*  Slightly modified version of the Drinker's Paradox, making it equivalent
    to DNE, LEM and similar statements in the constructive Logic of Coq.
*)

Definition Eater := forall X (p : X -> Prop),
  forall a : X, exists x, (~~p x -> forall y, p y).

Definition classical q : Prop := forall P : Prop, ~~ q P.
Definition constructive (q : Prop -> Prop) := forall P : Prop, q P.

Lemma Eater_cl q : classical q -> Eater -> constructive q.
Proof.
  intros Hq eater X.
  specialize (eater _ q) as [P H]; auto.
Qed.

Section DNE.

  Definition stable X := ~~ X -> X.
  Definition DNE := forall X, stable X.

  Goal DNE -> Eater.
  Proof.
    intros dnE X p x.
    apply dnE.
    intros nH. apply nH.
    exists x.
    intros _ y. apply dnE.
    intros ?. apply nH.
    exists y. tauto.
  Qed.

  Goal Eater -> DNE.
  Proof.
    refine (Eater_cl _ _).
    unfold classical, stable. tauto.
  Qed.

End DNE.

Section LEM.

  Definition definite X := X \/ ~X.
  Definition LEM := forall X, definite X.

  Lemma pred_LEM {X} (p : X -> Prop) :
    LEM -> (forall x, p x) \/ (exists x, ~p x).
  Proof.
    intros lem.
    destruct (lem (exists x, ~p x)) as [| H]; auto.
    left. intros x.
    destruct (lem (p x)); auto.
    exfalso. apply H.
    now exists x.
  Qed.

  Goal LEM -> Eater.
  Proof.
    intros lem X p x.
    destruct (pred_LEM p lem) as [|H].
    - exists x. tauto.
    - destruct H as [d ].
      now exists d.
  Qed.

  Goal Eater -> LEM.
  Proof.
    refine (Eater_cl _ _).
    unfold classical, definite. tauto.
  Qed.

End LEM.