Require Export GeoCoq.Elements.OriginalProofs.proposition_23.
Require Export GeoCoq.Elements.OriginalProofs.proposition_11B.
Require Export GeoCoq.Elements.OriginalProofs.lemma_Euclid4.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglesflip.
Require Export GeoCoq.Elements.OriginalProofs.lemma_9_5.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_23B :
   forall A B C D E P,
   neq A B -> nCol D C E -> nCol A B P ->
   exists X Y, Out A B Y /\ CongA X A Y D C E /\ TS X A B P.
Proof.
intros.
assert (neq B A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists F G, (Out A B G /\ CongA F A G D C E)) by (conclude proposition_23);destruct Tf as [F[G]];spliter.
assert (neq A G) by (conclude lemma_raystrict).
assert (~ Col A B F).
 {
 intro.
 assert (CongA D C E F A G) by (conclude lemma_equalanglessymmetric).
 assert (nCol F A G) by (conclude lemma_equalanglesNC).
 assert (Col A B G) by (conclude lemma_rayimpliescollinear).
 assert (Col B F G) by (conclude lemma_collinear4).
 assert (Col B F A) by (forward_using lemma_collinearorder).
 assert (~ eq F B).
  {
  intro.
  assert (Out A F G) by (conclude cn_equalitysub).
  assert (Col A F G) by (conclude lemma_rayimpliescollinear).
  assert (Col F A G) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (neq B F) by (conclude lemma_inequalitysymmetric).
 assert (Col F A G) by (conclude lemma_collinear4).
 contradict.
 }
rename_H H;let Tf:=fresh in
assert (Tf:exists H, Perp_at F H A B H) by (conclude proposition_12);destruct Tf as [H];spliter.
let Tf:=fresh in
assert (Tf:exists J, (Col F H H /\ Col A B H /\ Col A B J /\ Per J H F)) by (conclude_def Perp_at );destruct Tf as [J];spliter.
assert (nCol J H F) by (conclude lemma_rightangleNC).
assert (~ eq F H).
 {
 intro.
 assert (Col A B F) by (conclude cn_equalitysub).
 contradict.
 }
assert (~ eq J H).
 {
 intro.
 assert (Col J H F) by (conclude_def Col ).
 contradict.
 }
assert (neq H J) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists T, (BetS J H T /\ Cong H T H J)) by (conclude lemma_extension);destruct Tf as [T];spliter.
assert (Col J H T) by (conclude_def Col ).
assert (Col B J H) by (conclude lemma_collinear4).
assert (neq J T) by (forward_using lemma_betweennotequal).
assert (Col H J B) by (forward_using lemma_collinearorder).
assert (Col H J T) by (forward_using lemma_collinearorder).
assert (neq J H) by (forward_using lemma_betweennotequal).
assert (neq H J) by (conclude lemma_inequalitysymmetric).
assert (Col J B T) by (conclude lemma_collinear4).
assert (Col J T B) by (forward_using lemma_collinearorder).
assert (Col B A J) by (forward_using lemma_collinearorder).
assert (Col B A H) by (forward_using lemma_collinearorder).
assert (Col A J H) by (conclude lemma_collinear4).
assert (Col H J A) by (forward_using lemma_collinearorder).
assert (Col J A T) by (conclude lemma_collinear4).
assert (Col J T A) by (forward_using lemma_collinearorder).
assert (~ Col J T P).
 {
 intro.
 assert (Col A B P) by (conclude lemma_collinear5).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists Q, (Per J H Q /\ TS Q J T P)) by (conclude proposition_11B);destruct Tf as [Q];spliter.
assert (nCol J H Q) by (conclude lemma_rightangleNC).
assert (~ eq H Q).
 {
 intro.
 assert (Col J H Q) by (conclude_def Col ).
 contradict.
 }
assert (~ eq H F).
 {
 intro.
 assert (Col J H F) by (conclude_def Col ).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists S, (Out H Q S /\ Cong H S H F)) by (conclude lemma_layoff);destruct Tf as [S];spliter.
assert (eq F F) by (conclude cn_equalityreflexive).
assert (neq D C) by (forward_using lemma_angledistinct).
assert (neq C D) by (conclude lemma_inequalitysymmetric).
assert (neq C E) by (forward_using lemma_angledistinct).
assert (Col J H A) by (forward_using lemma_collinearorder).
assert (Per J H S) by (conclude lemma_8_3).
assert (Per S H J) by (conclude lemma_8_2).
assert (CongA J H F J H S) by (conclude lemma_Euclid4).
assert (eq S S) by (conclude cn_equalityreflexive).
assert (neq H S) by (forward_using lemma_angledistinct).
assert (CongA F A G S A G).
by cases on (eq A H \/ neq A H).
{
 assert (Per J A F) by (conclude cn_equalitysub).
 assert (Per J A S) by (conclude cn_equalitysub).
 assert (Col A B G) by (conclude lemma_rayimpliescollinear).
 assert (Col J H G) by (conclude lemma_collinear5).
 assert (Col J A G) by (conclude cn_equalitysub).
 assert (neq G A) by (conclude lemma_inequalitysymmetric).
 assert (Per G A F) by (conclude lemma_collinearright).
 assert (Per F A G) by (conclude lemma_8_2).
 assert (Per G A S) by (conclude lemma_collinearright).
 assert (Per S A G) by (conclude lemma_8_2).
 assert (CongA F A G S A G) by (conclude lemma_Euclid4).
 close.
 }
{
 assert (Cong F H S H) by (forward_using lemma_doublereverse).
 assert (Per A H F) by (conclude lemma_collinearright).
 assert (Per F H A) by (conclude lemma_8_2).
 assert (Per J H S) by (conclude lemma_8_2).
 assert (Per A H S) by (conclude lemma_collinearright).
 assert (CongA A H F A H S) by (conclude lemma_Euclid4).
 assert (nCol F H A) by (conclude lemma_rightangleNC).
 assert (CongA F H A A H F) by (conclude lemma_ABCequalsCBA).
 assert (CongA F H A A H S) by (conclude lemma_equalanglestransitive).
 assert (nCol A H S) by (conclude lemma_rightangleNC).
 assert (CongA A H S S H A) by (conclude lemma_ABCequalsCBA).
 assert (CongA F H A S H A) by (conclude lemma_equalanglestransitive).
 assert (Cong H F H S) by (forward_using lemma_congruenceflip).
 assert (Cong H A H A) by (conclude cn_congruencereflexive).
 assert (~ Col S H A).
  {
  intro.
  assert (Col A H S) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert ((Cong F A S A /\ CongA H F A H S A /\ CongA H A F H A S)) by (conclude proposition_04).
 assert (~ Col F A H).
  {
  intro.
  assert (Col F H A) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (CongA F A H H A F) by (conclude lemma_ABCequalsCBA).
 assert (~ Col H A S).
  {
  intro.
  assert (Col S H A) by (forward_using lemma_collinearorder).
  contradict.
  }
 assert (CongA H A S S A H) by (conclude lemma_ABCequalsCBA).
 assert (CongA F A H H A S) by (conclude lemma_equalanglestransitive).
 assert (CongA F A H S A H) by (conclude lemma_equalanglestransitive).
 assert (eq A A) by (conclude cn_equalityreflexive).
 assert (Col A B A) by (conclude_def Col ).
 assert (Col A B G) by (conclude lemma_rayimpliescollinear).
 assert (Col G H A).
 by cases on (eq G H \/ neq G H).
 {
  assert (Col G H A) by (conclude_def Col ).
  close.
  }
 {
  assert (Col G H A) by (conclude lemma_collinear5).
  close.
  }
(** cases *)
 assert (neq F A) by (forward_using lemma_angledistinct).
 assert (neq A F) by (conclude lemma_inequalitysymmetric).
 assert (Out A F F) by (conclude lemma_ray4).
 assert (neq S A) by (forward_using lemma_angledistinct).
 assert (neq A S) by (conclude lemma_inequalitysymmetric).
 assert (Out A S S) by (conclude lemma_ray4).
 assert ((eq G H \/ eq G A \/ eq H A \/ BetS H G A \/ BetS G H A \/ BetS G A H)) by (conclude_def Col ).
 assert (CongA F A G S A G).
 by cases on (eq G H \/ eq G A \/ eq H A \/ BetS H G A \/ BetS G H A \/ BetS G A H).
 {
  assert (~ ~ CongA F A G S A G).
   {
   intro.
   assert (CongA F A G S A G) by (conclude cn_equalitysub).
   contradict.
   }
  close.
  }
 {
  assert (~ ~ CongA F A G S A G).
   {
   intro.
   assert (neq A G) by (conclude lemma_raystrict).
   assert (neq G A) by (conclude lemma_inequalitysymmetric).
   contradict.
   }
  close.
  }
 {
  assert (~ ~ CongA F A G S A G).
   {
   intro.
   assert (neq H A) by (conclude lemma_inequalitysymmetric).
   contradict.
   }
  close.
  }
 {
  assert (BetS A G H) by (conclude axiom_betweennesssymmetry).
  assert (Out A H G) by (conclude lemma_ray4).
  assert (CongA F A H F A H) by (conclude lemma_equalanglesreflexive).
  assert (~ Col S A H).
   {
   intro.
   assert (Col S H A) by (forward_using lemma_collinearorder).
   contradict.
   }
  assert (CongA S A H S A H) by (conclude lemma_equalanglesreflexive).
  assert (CongA F A H F A G) by (conclude lemma_equalangleshelper).
  assert (CongA S A H S A G) by (conclude lemma_equalangleshelper).
  assert (CongA F A G F A H) by (conclude lemma_equalanglessymmetric).
  assert (CongA F A G S A H) by (conclude lemma_equalanglestransitive).
  assert (CongA F A G S A G) by (conclude lemma_equalanglestransitive).
  close.
  }
 {
  assert (BetS A H G) by (conclude axiom_betweennesssymmetry).
  assert (Out A H G) by (conclude lemma_ray4).
  assert (CongA F A H F A H) by (conclude lemma_equalanglesreflexive).
  assert (~ Col S A H).
   {
   intro.
   assert (Col S H A) by (forward_using lemma_collinearorder).
   contradict.
   }
  assert (CongA S A H S A H) by (conclude lemma_equalanglesreflexive).
  assert (CongA F A H F A G) by (conclude lemma_equalangleshelper).
  assert (CongA S A H S A G) by (conclude lemma_equalangleshelper).
  assert (CongA F A G F A H) by (conclude lemma_equalanglessymmetric).
  assert (CongA F A G S A H) by (conclude lemma_equalanglestransitive).
  assert (CongA F A G S A G) by (conclude lemma_equalanglestransitive).
  close.
  }
 {
  assert (BetS H A G) by (conclude axiom_betweennesssymmetry).
  assert (Supp H A F F G) by (conclude_def Supp ).
  assert (Supp H A S S G) by (conclude_def Supp ).
  assert (CongA H A F H A S) by (conclude lemma_equalanglesflip).
  assert (CongA F A G S A G) by (conclude lemma_supplements).
  close.
  }
(** cases *)
 close.
 }
(** cases *)
assert (CongA S A G F A G) by (conclude lemma_equalanglessymmetric).
assert (CongA S A G D C E) by (conclude lemma_equalanglestransitive).
assert (Out H S Q) by (conclude lemma_ray5).
assert (Col J T H) by (forward_using lemma_collinearorder).
assert (TS S J T P) by (conclude lemma_9_5).
let Tf:=fresh in
assert (Tf:exists M, (BetS S M P /\ Col J T M /\ nCol J T S)) by (conclude_def TS );destruct Tf as [M];spliter.
assert (Col T A B) by (conclude lemma_collinear4).
assert (Col A B T) by (forward_using lemma_collinearorder).
assert (Col B A T) by (forward_using lemma_collinearorder).
assert (Col A J T) by (conclude lemma_collinear4).
assert (Col J T A) by (forward_using lemma_collinearorder).
assert (Col B J T) by (conclude lemma_collinear4).
assert (Col J T B) by (forward_using lemma_collinearorder).
assert (Col A B M) by (conclude lemma_collinear5).
assert (~ Col A B S).
 {
 intro.
 assert (Col J T S) by (conclude lemma_collinear5).
 contradict.
 }
assert (TS S A B P) by (conclude_def TS ).
close.
Qed.

End Euclid.


(* 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 perm.
Require Import Reals Lra Classical.
From mathcomp Require Import Rstruct classical_sets.
Require Import ssrZ ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop.
Require Import fdist proba entropy aep typ_seq joint_typ_seq channel.
Require Import channel_code.

(******************************************************************************)
(*                 Channel coding theorem (direct part)                       *)
(*                                                                            *)
(* Definitions:                                                               *)
(*   jtdec == joint typicality decoding                                       *)
(*   cal_E M n epsilong f == the set of output vb such that (f m, vb) is      *)
(*                           jointly typical                                  *)
(*                                                                            *)
(* Theorem:                                                                   *)
(*   channel_coding == channel coding theorem (direct part)                   *)
(*                                                                            *)
(* 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 fdist_scope.
Local Open Scope jtyp_seq_scope.
Local Open Scope channel_code_scope.
Local Open Scope channel_scope.
Local Open Scope vec_ext_scope.

Module Wght.
Section wght.
Variables (A M : finType) (P : fdist A) (n : nat).

Definition f := [ffun g : encT A M n => \prod_(m in M) P `^ n (g m)].

Lemma f0 g : 0 <= f g. Proof. rewrite ffunE; exact: prodR_ge0. Qed.

Lemma f1 : \sum_(g in {ffun M -> 'rV[A]_n}) f g = 1.
Proof.
under eq_bigr do rewrite ffunE /=.
rewrite -(bigA_distr_bigA (fun _ v => P `^ n v)) /=.
rewrite [RHS](_ : _ = \prod_(m0 : M | xpredT m0) 1); last by rewrite big1.
by apply eq_bigr => _ _; rewrite (FDist.f1 (P `^ n)).
Qed.

Definition d : {fdist encT A M n} := locked (FDist.make f0 f1).

Lemma dE x : d x = f x. Proof. by rewrite /d; unlock; rewrite ffunE. Qed.
End wght.
End Wght.

Arguments Wght.d {A} {M} _ {n}.

Section joint_typicality_decoding.
Variables (A B M : finType) (n : nat).

Definition jtdec P W epsilon (f : encT A M n) : decT B M n :=
  [ffun tb => [pick m |
    (prod_rV (f m, tb) \in `JTS P W n epsilon) &&
    [forall m', (m' != m) ==> (prod_rV (f m', tb) \notin `JTS P W n epsilon)]]].

Lemma jtdec_map epsilon (P : fdist A) (W : `Ch(A, B)) (f : encT A M n) tb m0 m1 :
  (prod_rV (f m0, tb) \in `JTS P W n epsilon) &&
  [forall m', (m' != m0) ==> (prod_rV (f m', tb) \notin `JTS P W n epsilon)] ->
  (prod_rV (f m1, tb) \in `JTS P W n epsilon) &&
  [forall m', (m' != m1) ==> (prod_rV (f m', tb) \notin `JTS P W n epsilon)] ->
  m0 = m1.
Proof.
case/andP.
rewrite /prod_rV /= => H1 H2.
case/andP => H1'.
move/forallP/(_ m0).
rewrite implybE.
case/orP.
- rewrite negbK; by move/eqP.
- by rewrite H1.
Qed.

Hypothesis HM : (0 < #|M|)%nat.

Lemma good_code_sufficient_condition P W epsilon
  (phi : encT A M n -> decT B M n) :
  \sum_(f : encT A M n) (Wght.d P f * echa(W , mkCode f (phi f))) < epsilon ->
  exists f, echa(W , mkCode f (phi f)) < epsilon.
Proof.
move=> H.
apply not_all_not_ex => abs.
set x := \sum_(f <- _) _ in H.
have : \sum_(f : encT A M n) Wght.d P f * epsilon <= x.
  rewrite /x; apply leR_sumRl => //= f _.
  - by apply leR_wpmul2l => //; exact/Rnot_lt_le/abs.
  - by apply mulR_ge0 => //; exact/echa_ge0.
apply/Rlt_not_le/(@ltR_leR_trans epsilon) => //.
by rewrite -big_distrl /= (FDist.f1 (Wght.d P)) mul1R; exact/leRR.
Qed.

Definition o_PI (m m' : M) := fun g : encT A M n => [ffun x => g (tperm m m' x)].

Lemma o_PI_2 (g : encT A M n) (m m' m_ : M) : (o_PI m m' (o_PI m m' g)) m_ = g m_.
Proof. by rewrite /o_PI !ffunE tpermK. Qed.

Lemma wght_o_PI m m' P (h : encT A M n) : Wght.d P (o_PI m m' h) = Wght.d P h.
Proof.
rewrite 2!Wght.dE /Wght.f 2!ffunE
  (reindex_onto (tperm m m') (tperm m m')) /=; last first.
  move=> m0 _; by rewrite tpermK.
apply eq_big => m0.
- by rewrite tpermK eqxx.
- by move=> _; rewrite /o_PI ffunE tpermK.
Qed.

Lemma error_rate_symmetry (P : {fdist A}) (W : `Ch(A, B)) epsilon :
  0 <= epsilon -> let Jtdec := jtdec P W epsilon in
    forall m m',
      \sum_(f : encT A M n) (Wght.d P f * e(W, mkCode f (Jtdec f)) m) =
      \sum_(f : encT A M n) (Wght.d P f * e(W, mkCode f (Jtdec f)) m').
Proof.
move=> Hepsilon PHI' m m'.
set lhs := \sum_(_ <- _) _.
have Hlhs : lhs = \sum_(f : encT A M n) (Wght.d P f * e(W, mkCode f (PHI' f)) m) by [].
have -> : lhs = \sum_(f : encT A M n)
    (Wght.d P (o_PI m m' f) * e(W, mkCode (o_PI m m' f) (PHI' (o_PI m m' f))) m).
  rewrite Hlhs (reindex_onto (o_PI m m') (o_PI m m')) /=; last first.
    by move=> i _; apply/ffunP => m_; rewrite o_PI_2.
  by apply eq_bigl => x /=; apply/eqP/ffunP => y; exact: o_PI_2.
apply: eq_bigr => g _; rewrite wght_o_PI; congr (_ * _).
rewrite /ErrRateCond /= (_ : (o_PI m m' g) m = g m'); last by rewrite ffunE tpermL.
congr Pr; apply/setP => tb /=.
rewrite 2!inE.
apply/negbLR.
rewrite finset.in_setC negbK.
apply/idP/idP.
- rewrite {1}/PHI' {1}/jtdec ffunE.
  set p0 := fun _ => _ && _.
  case: (pickP _) => [m0 Hm0 | Hm0 /eqP //].
  case/eqP => ?; subst m0.
  rewrite /p0 {p0} in Hm0.
  rewrite /PHI' /jtdec.
  rewrite inE ffunE.
  case: (pickP _) => [m1 Hm1 | Hm1].
  + apply/eqP; f_equal.
    suff : (prod_rV (g m', tb) \in `JTS P W n epsilon) &&
      [forall m'0, (m'0 != m') ==> (prod_rV (g m'0, tb) \notin `JTS P W n epsilon)].
      by move/(jtdec_map Hm1).
    apply/andP; split.
    * by move: Hm0; rewrite {1}/o_PI ffunE tpermL => /andP[].
    * apply/forallP => m_; apply/implyP => m__m'.
      case/andP : Hm0 => Hm0 /forallP Hm0'.
      have [m_m|m_m] := eqVneq m_ m.
      - subst m_.
        by move: (Hm0' m'); rewrite eq_sym m__m' /= /o_PI ffunE tpermR; exact.
      - move: (Hm0' m_) => {}Hm0'.
        rewrite eq_sym in m__m'.
        by move: Hm0'; rewrite m_m /= /o_PI ffunE tpermD // eq_sym.
  + exfalso.
    rewrite {1}/o_PI ffunE tpermL in Hm0.
    move/negbT: {Hm1}(Hm1 m').
    rewrite negb_and; case/orP => Hm'.
    * by case/andP : Hm0 => Hm0 _; rewrite Hm0 in Hm'.
    * move/negP : Hm'; apply.
      apply/forallP => m_; apply/implyP => m_m'.
      case/andP: Hm0 => Hm0 /forallP Hm01.
      have [m_m|m_m] := eqVneq m_ m.
      - subst m_.
        by move: (Hm01 m'); rewrite eq_sym m_m' /= /o_PI ffunE tpermR; exact.
      - by move: (Hm01 m_); rewrite m_m /= /o_PI ffunE tpermD // eq_sym.
- rewrite {1}/PHI' {1}/jtdec inE ffunE.
  case: (pickP _) => [m0 Hm0 | Hm0 /eqP //].
  case/eqP => ?; subst m0.
  apply/eqP.
  rewrite /PHI' /jtdec ffunE.
  case: (pickP _) => [m1 Hm1 | Hm1].
  + f_equal.
    suff : (prod_rV ((o_PI m m' g) m, tb) \in `JTS P W n epsilon) &&
      [forall m'0, (m'0 != m) ==>
         (prod_rV ((o_PI m m' g) m'0, tb) \notin `JTS P W n epsilon)].
      by move/(jtdec_map Hm1).
    apply/andP; split.
    - by rewrite /o_PI ffunE tpermL; case/andP: Hm0.
    - apply/forallP => m_; apply/implyP => m_m.
      have [?|m_m'] := eqVneq m_ m'.
      + subst m_.
        rewrite /o_PI ffunE tpermR.
        case/andP : Hm0 => _ /forallP/(_ m).
        by rewrite eq_sym m_m.
      + rewrite eq_sym in m_m; rewrite eq_sym in m_m'.
        rewrite /o_PI ffunE tpermD //.
        case/andP : Hm0 => _ /forallP/(_ m_).
        by rewrite eq_sym m_m'.
  * exfalso.
    move: {Hm1}(Hm1 m) => /negbT; rewrite negb_and => /orP[|].
    - rewrite /o_PI ffunE tpermL.
      by case/andP : Hm0 => ->.
    - move/negP; apply.
      apply/forallP => m_; apply/implyP => m_m.
      have [?|m_m'] := eqVneq m_ m'.
      + subst m_.
        rewrite /o_PI ffunE tpermR.
        case/andP : Hm0 => _ /forallP/(_ m).
        by rewrite eq_sym m_m.
      + rewrite eq_sym in m_m; rewrite eq_sym in m_m'.
        rewrite /o_PI ffunE tpermD //.
        case/andP : Hm0 => _ /forallP/(_ m_).
        by rewrite eq_sym m_m'.
Qed.

End joint_typicality_decoding.

(* TODO: move? *)
Section sum_rV_ffun.
Import Monoid.Theory.
Variable R : Type.
Variable times : Monoid.mul_law 0.
Local Notation "*%M" := times (at level 0).
Variable plus : Monoid.add_law 0 *%M.
Local Notation "+%M" := plus (at level 0).

Lemma sum_rV_ffun (I J : finType) (F : {ffun I -> J} -> R)
  (G : _ -> _ -> _) (idef : I) (zero : 'I_ _) : O = zero ->
  \big[+%M/0]_(j : 'rV[J]_#|I|) G (F [ffun x => j ord0 (enum_rank x)]) (j ord0 zero) =
  \big[+%M/0]_(f : {ffun I -> J}) G (F f) (f (nth idef (enum I) 0)).
Proof.
Local Open Scope ring_scope.
move=> Hzero.
rewrite (reindex_onto (fun y : {ffun _ -> J} => \row_(i < _) y (enum_val i))
                      (fun p => [ffun x => p ord0 (enum_rank x)])) //.
  apply eq_big.
    move=> t /=.
    apply/eqP/ffunP => i'.
    by rewrite ffunE mxE enum_rankK.
  move=> i Hi.
  rewrite /= in Hi.
  rewrite (eqP Hi).
  f_equal.
  by rewrite mxE (enum_val_nth idef) -Hzero.
move=> i _.
apply/rowP => a; by rewrite mxE ffunE enum_valK.
Qed.

End sum_rV_ffun.

Section random_coding_good_code_existence.

Variables (B A : finType) (W : `Ch(A, B)) (P : fdist A).

Definition epsilon0_condition r epsilon epsilon0 :=
  0 < epsilon0 /\ epsilon0 < epsilon / 2 /\ epsilon0 < (`I(P, W) - r) / 4.

Definition n_condition r epsilon0 n :=
  (O < n)%nat /\ - log epsilon0 / epsilon0 < INR n /\
  frac_part (exp2 (INR n * r)) = 0 /\ (JTS_1_bound P W epsilon0 <= n)%nat.

Definition cal_E M n epsilon (f : encT A M n) m :=
  [set vb | prod_rV (f m, vb) \in `JTS P W n epsilon].

Local Open Scope tuple_ext_scope.

(* TODO: move? *) (* NB: similar to big_rV_cons_behead *)
Lemma big_tuple_cons_behead {C : finType} n (F : n.+1.-tuple C -> R)
  (P1 : pred C) (P2 : pred {: n.-tuple C}) :
  \sum_(i in C | P1 i) \sum_(j in {: n.-tuple C} | P2 j) (F [tuple of (i :: j)])
  =
  \sum_(p in {: n.+1.-tuple C} | (P1 (thead p)) && (P2 (tbehead p)) ) (F p).
Proof.
apply/esym.
rewrite (partition_big (fun x => thead x) (fun x => P1 x)) //=; last first.
  move=> t; by case/andP.
apply eq_bigr => i Hi.
rewrite (reindex_onto (fun j : {: n.-tuple C} => [tuple of (i :: j)])
  (fun p => [tuple of (behead p)])) /=; last first.
  move=> j /andP[Hj1 /eqP <-]; exact/esym/tuple_eta.
apply congr_big => // x /=.
rewrite !theadE eqxx /= Hi /= -andbA /=.
rewrite (_ : _ == x = true) ?andbT; last first.
  rewrite tupleE /behead_tuple /=; exact/eqP/val_inj.
congr P2; rewrite /tbehead tupleE /behead_tuple; exact: val_inj.
Qed.

(* TODO: move? *)
Lemma rsum_rmul_tuple_pmf_tnth {C : finType} n k (Q : fdist C) :
  \sum_(t : {:k.-tuple ('rV[C]_n)}) \prod_(m < k) (Q `^ n) t \_ m = 1.
Proof.
transitivity (\sum_(j : {ffun 'I_k -> 'rV[_]_n}) \prod_(m < k) Q `^ _ (j m)).
  rewrite (reindex_onto (fun p => [ffun x => p\_(enum_rank x)])
                        (fun x => fgraph x)) //=; last first.
    by move=> f _; apply/ffunP => /= i; rewrite ffunE tnth_fgraph enum_rankK.
  rewrite (big_tcast (esym (card_ord k))) esymK.
  apply eq_big => //.
  - move=> i /=; apply/esym/eqP/eq_from_tnth => j.
    by rewrite tnth_fgraph ffunE enum_valK.
  - by move=> i _; apply eq_bigr => j _; rewrite ffunE /= tcastE -enum_rank_ord.
rewrite -(bigA_distr_bigA (fun m xn => Q `^ _ xn)) /= big_const.
by rewrite FDist.f1 iter_mulR exp1R.
Qed.

(* TODO: move? *)
Lemma rsum_rmul_tuple_pmf {C} n k (Q : fdist C) :
  \sum_(t in {:k.-tuple ('rV[C]_n)}) \prod_(x <- t) (Q `^ n) x = 1.
Proof.
rewrite -[X in _ = X](rsum_rmul_tuple_pmf_tnth n k Q).
apply eq_bigr => t _.
rewrite big_tnth /= (reindex_onto (cast_ord (size_tuple t))
  (cast_ord (esym (size_tuple t)))) //=; last first.
  move=> i _; exact/val_inj.
apply eq_big => //= i.
- by rewrite cast_ordK eqxx.
- move=> _; by rewrite tvalK tcastE esymK.
Qed.

Local Open Scope ring_scope.

Lemma first_summand k n epsilon0 :
  let M := [finType of 'I_k.+1] in
  (\sum_(f : encT A M n) Wght.d P f *
    Pr (W ``(| f ord0)) (~: cal_E epsilon0 f ord0)) =
  Pr ((P `X W) `^ n) (~: `JTS P W n epsilon0).
Proof.
move=> M.
have M_prednK : #|M|.-1.+1 = #|M| by rewrite card_ord.
pose E_F_N := @cal_E M n epsilon0.
rewrite {1}/cal_E.
case/card_gt0P : (fdist_card_neq0 P) => a _.
pose zero := @enum_rank M ord0.
have : 0%N = zero :> nat by rewrite /zero enum_rank_ord.
move/(@sum_rV_ffun _ _ _ _ _ (Wght.d P)
  (fun r v => r * Pr (W ``(| v )) (~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0]))
  ord0 zero).
rewrite (_ : nth ord0 (enum M) 0 = ord0); last by rewrite enum_ordSl.
move=> <- /=.
transitivity (\sum_(v : 'rV['rV[A]_n]_#|M|) (
    (\prod_(m : M) P `^ n ([ffun x => v ``_ x] (enum_rank m))) *
    \sum_(w | w \in ~: cal_E epsilon0 [ffun x => v ``_ x] zero)
    (W ``(| [ffun x => v ``_ x] zero)) w)).
  apply eq_bigr => v _; congr (_ * _).
    rewrite Wght.dE ffunE. (* NB *)
    by apply eq_bigr => m _; rewrite 2!ffunE.
  apply eq_big.
  - move=> /= ?; by rewrite !inE ffunE.
  - move=> ? _; by rewrite ffunE.
rewrite /cal_E.
transitivity (\sum_(v : 'rV[A]_n)
  (\sum_(y in ~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0])
  (W ``(| v)) y) *
    \sum_(j in {: #|M|.-1.-tuple ('rV[A]_n)})
      (\prod_(m : M) P `^ _ ((tcast M_prednK [tuple of v :: j]) \_ (enum_rank m)))).
  rewrite (reindex_onto (fun y : {ffun _ -> 'rV__} => \row_(i < _) y (enum_val i))
      (fun p : 'rV_ _ => [ffun x => p ``_ (enum_rank x)])) //=; last first.
    move=> v _; by apply/rowP => i; rewrite mxE ffunE enum_valK.
  apply trans_eq with (\sum_(f : {ffun M -> 'rV__})
    ((\prod_(m < k.+1) P `^ n (f m)) *
      \sum_(y in ~: [set y0 | prod_rV (f ord0, y0) \in `JTS P W n epsilon0])
      W ``(y | f ord0))).
    apply eq_big => //= f.
    - apply/eqP/ffunP => m; by rewrite ffunE mxE enum_rankK.
    - move/eqP => Hf;  congr (_ * _).
        apply eq_bigr => i _; by rewrite -[in RHS]Hf 2!ffunE.
      apply eq_big => /=.
        move=> ?; by rewrite !inE -[in RHS]Hf !ffunE mxE.
      move=> ? _; by rewrite -[in RHS]Hf !ffunE mxE.
  rewrite (_ : ord0 = nth ord0 (enum M) 0); last by rewrite enum_ordSl.
  rewrite -(big_tuple_ffun _ (fun f => \prod_(m : M) P `^ n (f m))
    (fun r => fun yn => r *
      (\sum_(y in ~: [set y0 | prod_rV (yn, y0) \in `JTS P W n epsilon0])
      W ``(y | yn))) (\row_(i < n) a) ord0)%R.
  transitivity (\sum_(j : _)
    (\prod_(m : M) P `^ n ((tcast M_prednK j) \_ (enum_rank m))) *
      (\sum_(y in ~: [set y0 | prod_rV (nth (\row_(i < n) a) j 0, y0) \in
          `JTS P W n epsilon0])
      W ``(y | nth (\row_(i < n) a) j 0))).
    rewrite (big_tcast (esym M_prednK)) esymK.
    apply eq_bigr => i _; congr (_ * _).
      apply eq_bigr => m _; by rewrite ffunE.
    have H : nth (\row_(i < n) a) (tcast M_prednK i) 0 = nth (\row_(i < n) a) i 0.
      move: M_prednK i; rewrite card_ord => M_prednK i.
      rewrite -(tnth_nth _ i ord0) -(tnth_nth _ (tcast M_prednK i) ord0).
      by rewrite tcastE /= cast_ord_id.
    apply eq_big => m; by rewrite !inE H.
  rewrite -(@big_tuple_cons_behead _ #|M|.-1
   (fun j => ((\prod_(m : M) P `^ n ((tcast M_prednK j) \_ (enum_rank m))) *
     (\sum_(y in ~: [set y0 | prod_rV (nth (\row_(i < n) a) j 0, y0) \in
         `JTS P W n epsilon0]) W ``(y | nth (\row_(i < n) a) j 0)))) xpredT xpredT).
  apply eq_bigr => ta _ /=; by rewrite -big_distrl /= mulRC.
transitivity ((\sum_(ta in 'rV[A]_n) P `^ _ ta *
    (\sum_(y in ~: [set y0 | prod_rV (ta, y0) \in `JTS P W n epsilon0])
    (W ``(| ta ) ) y)) *
    \sum_(j in {:k.-tuple ('rV[A]_n)}) \prod_(m < k) (P `^ _ (j \_ m)))%R.
  rewrite big_distrl /=.
  apply eq_bigr => ta _.
  rewrite -mulRA mulRCA; congr Rmult.
  transitivity (\sum_(j in {: #|'I_k|.-tuple ('rV[A]_n) })
    P `^ _ ta * \prod_(m < k) P `^ _ (j \_ (enum_rank m)))%R.
    have k_prednK : #|'I_k.+1|.-1 = #|'I_k| by rewrite !card_ord.
    rewrite (big_tcast (esym k_prednK)) esymK.
    apply eq_bigr => i0 Hi0.
    rewrite big_ord_recl /=.
    congr (P `^ _ _ * _)%R; first by rewrite tcastE // enum_rank_ord.
    apply eq_bigr => i1 _; congr (P `^ _ _).
    rewrite !tcastE {1}/tnth /=.
    rewrite (_ : enum_rank _ = (enum_rank i1).+1 :> nat) /=; last by rewrite !enum_rank_ord.
    apply set_nth_default; by rewrite size_tuple /= enum_rank_ord /= card_ord.
  rewrite -big_distrr /=; congr (_ * _)%R.
  rewrite (big_tcast (esym (card_ord k))) esymK.
  apply eq_bigr => /= i0 _.
  apply eq_bigr => /= i1 _.
  by rewrite tcastE -enum_rank_ord.
rewrite rsum_rmul_tuple_pmf_tnth mulR1.
transitivity (\sum_(v in 'rV[A]_n)
  \sum_(y in ~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0])
    ((P `X W) `^ n (prod_rV (v, y))))%R.
  apply eq_bigr => /= v _.
  rewrite big_distrr /=.
  apply eq_bigr => // w _.
  rewrite DMCE 2!fdist_rVE -big_split /=.
  apply eq_bigr => /= i _.
  by rewrite fdist_prodE -fst_tnth_prod_rV -snd_tnth_prod_rV /= mulRC.
rewrite /Pr big_rV_prod pair_big_dep /=.
by apply eq_bigl; case=> /= ? ?; rewrite !inE.
Qed.

(* TODO: move? *)
Lemma big_cat_tuple {C : finType} m n (F : (m + n)%nat.-tuple C -> R) :
  (\sum_(i in {:m.-tuple C}) \sum_(j in {: n.-tuple C})
  F [tuple of (i ++ j)] = \sum_(p in {: (m + n)%nat.-tuple C}) (F p))%R.
Proof.
elim: m n F => [m2 F /=|m IH n F].
- transitivity (\sum_(i <- [tuple] :: [::])
    \sum_(j in {: m2.-tuple C}) F [tuple of i ++ j] )%R.
    apply congr_big => //=.
    apply (@eq_from_nth _ [tuple]);
      rewrite /index_enum -enumT /= (eqP (enum_tupleP _)) card_tuple expn0 //.
    move=> i; rewrite ltnS leqn0 => /eqP ->.
    rewrite tupleE /=.
    case: (enum _) => //= t.
    by rewrite (tuple0 t).
  rewrite big_cons /= big_nil /= addR0.
  apply eq_bigr => // i _; congr F.
  exact/val_inj.
- symmetry.
  transitivity (\sum_(p in tuple_finType (m + n).+1 C) F p)%R; first by apply congr_big.
  rewrite -(@big_tuple_cons_behead _ _ _ xpredT xpredT).
  rewrite -(@big_tuple_cons_behead _ _ _ xpredT xpredT).
  apply eq_bigr => i _.
  move: {IH}(IH n (fun x => F [tuple of i :: x])) => <-.
  apply eq_bigr => /= t _; apply eq_bigr => /= t' _; congr F.
  exact/val_inj.
Qed.

(* TODO: move? *)
Lemma big_cat_tuple_seq {C : finType} m n (F : seq C -> R) :
  (\sum_(i in {:m.-tuple C} ) \sum_(j in {: n.-tuple C}) (F (i ++ j)) =
  \sum_(p in {: (m + n)%nat.-tuple C}) (F p))%R.
Proof.
move: (@big_cat_tuple _ m n (fun l => if size l == (m + n)%nat then F l else R0)).
set lhs := (\sum_(i in _) _)%R => H.
apply trans_eq with lhs.
  apply eq_bigr => /= t _; apply eq_bigr => /= t' _.
  case: ifP => //; by rewrite size_tuple eqxx.
rewrite H; apply eq_bigr => /= t _; by rewrite size_tuple eqxx.
Qed.

Lemma second_summand n k epsilon0 :
  let M := [finType of 'I_k.+1] in
    forall i, i != ord0 ->
      (\sum_(f : encT A M n) Wght.d P f *
        Pr (W ``(| f ord0)) (cal_E epsilon0 f i))%R =
   Pr ((P `^ n) `x `O( P , W ) `^ n) [set x | prod_rV x \in `JTS P W n epsilon0].
Proof.
move=> M.
have M_prednK : #|M|.-1.+1 = #|M| by rewrite card_ord.
move=> i i_m0.
set E_F_N := @cal_E M n epsilon0.
have Hcast : (i.-1 + (#|M| - i.+1).+1).+1 = #|M|.
  rewrite /M card_ord subSS addnS -addSn prednK; last by rewrite lt0n.
  by rewrite subnKC // -ltnS ltn_ord.
transitivity (
  \sum_(j1 in {: i.-1.-tuple ('rV[A]_n)})
  \sum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)})
  \sum_(j0 in 'rV[A]_n)
  \sum_(ji in 'rV[A]_n)
  Wght.d P [ffun x => (tcast Hcast [tuple of j0 :: j1 ++ ji :: j2])\_x] *
  \sum_(y | y \in [set w | prod_rV (ji, w) \in `JTS P W n epsilon0])
  (W ``(| j0)) y)%R.
  transitivity (
    \sum_(j0 in 'rV[A]_n)
    \sum_(j1 in {: i.-1.-tuple ('rV[A]_n)})
    \sum_(ji in 'rV[A]_n)
    \sum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)})
    Wght.d P [ffun x => (tcast Hcast [tuple of j0 :: j1 ++ ji :: j2])\_x] *
    \sum_( y | y \in [set w | prod_rV (ji, w) \in `JTS P W n epsilon0])
    (W ``(| j0) ) y)%R.
    rewrite (reindex_onto (fun p => [ffun x => p\_(enum_rank x)]) (fun y => fgraph y)) /=; last first.
      move=> f _; apply/ffunP => m; by rewrite ffunE tnth_fgraph enum_rankK.
    transitivity ( \sum_(j : _)
      (Wght.d P [ffun x => j\_(enum_rank x)] *
        Pr (W ``(| [ffun x => j\_(enum_rank x)] ord0)) (E_F_N [ffun x => j\_(enum_rank x)] i)))%R.
      apply eq_big => //= x; apply/eqP/eq_from_tnth => j.
      by rewrite tnth_fgraph ffunE enum_valK.
    rewrite (big_tcast (card_ord k.+1)).
    rewrite -(big_tuple_cons_behead _ xpredT xpredT).
    apply eq_bigr => i0 _.
    have [Hq i_q] : (i.-1 + (k - i.-1) = k /\ i <= k)%nat.
      split.
        by rewrite subnKC // -(leq_add2r 1) !addn1 (leq_ltn_trans _ (ltn_ord i)) // leq_pred.
      by rewrite -(leq_add2r 1) !addn1 ltn_ord.
    rewrite (big_tcast (esym Hq)) esymK.
    rewrite -big_cat_tuple /=.
    apply eq_bigr => /= i1 _.
    have Hs : (k - i.-1 = (k - i).+1)%nat.
      by rewrite -subn1 subnBA ?lt0n // addnC -addnBA.
    rewrite (big_tcast Hs) -(big_tuple_cons_behead _ xpredT xpredT).
    apply eq_bigr => i2 _.
    have Ht : (#|'I_k.+1| - i.+1 = k - i)%nat by rewrite card_ord /= subSS.
    rewrite (big_tcast Ht) //; apply eq_bigr => /= i3 _; congr (_ * _)%R.
    - rewrite 2!Wght.dE /Wght.f 2!ffunE /=.
      rewrite (reindex_onto enum_rank enum_val); last by move=> *; rewrite enum_valK.
      apply eq_big => /=; first by move=> x; rewrite enum_rankK eqxx inE.
      move=> i4 _; congr (P `^ _ _).
      rewrite !ffunE; congr (_ \_ _).
      apply/val_inj => /=.
      rewrite [LHS]eq_tcast /= !eq_tcast /= [RHS]eq_tcast eq_tcast /=; congr (_ :: _ ++ _ :: _).
      by rewrite eq_tcast.
    - apply eq_big.
      + move=> x /=.
        rewrite !inE ffunE.
        rewrite (_ : (_ \_ _) = i2) //=.
        rewrite enum_rank_ord /= tcastE !cast_ord_comp (tnth_nth i0) /=.
        rewrite eq_tcast /=.
        rewrite -cat_cons nth_cat /= size_tuple prednK ?lt0n // ltnn subnn.
        by rewrite eq_tcast.
      + move=> i4 Hi4.
        rewrite 2!DMCE.
        apply eq_bigr => i5 /= _; congr (W _ _).
        by rewrite ffunE tcastE /= enum_rank_ord /= cast_ordK.
  rewrite exchange_big /=.
  apply eq_bigr => /= i1 _.
  rewrite [in RHS]exchange_big /=.
  apply eq_bigr => /= i2 _.
  rewrite [in RHS]exchange_big /=.
  by apply eq_bigr.
transitivity (
  (\sum_(j1 in {: i.-1.-tuple ('rV[A]_n)})
   \sum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)})
   \prod_(i <- j1 ++ j2) (P `^ n) i) *
  (\sum_(j0 in 'rV[A]_n)
    \sum_(ji in 'rV[A]_n)
    ((P `^ n) j0) * ((P `^ n) ji) *
    (\sum_( y | y \in
      [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0])
    (W ``(| j0) ) y)))%R.
  rewrite !big_distrl /=.
  apply eq_bigr => j1 _.
  rewrite !big_distrl /=.
  apply eq_bigr => j2 _.
  rewrite !big_distrr /=.
  apply eq_bigr => j0 _.
  rewrite !big_distrr /=.
  apply eq_bigr => j3 _.
  rewrite !mulRA Wght.dE /Wght.f /=; congr (_ * _)%R.
  transitivity (\prod_( i <- j0 :: j1 ++ j3 :: j2) P `^ _ i)%R; last first.
    rewrite big_cons -mulRA mulRCA; congr (_ * _)%R.
    rewrite big_cat /= big_cons [in RHS]mulRC mulRCA; congr (_ * _)%R.
    by rewrite big_cat /= mulRC.
  rewrite [in RHS](big_nth j0) /= big_mkord.
  transitivity (\prod_(j < #|@predT M|)
    P `^ _ ([ffun x => (tcast Hcast [tuple of j0 :: j1 ++ j3 :: j2])\_(enum_rank x)] (enum_val j)))%R.
    rewrite ffunE; apply eq_big => ? //= _.
    by rewrite !ffunE enum_valK.
  have j_M : (size (j1 ++ j3 :: j2)).+1 = #|M|.
    rewrite size_cat (size_tuple j1) /= (size_tuple j2) card_ord.
    by rewrite -[RHS](card_ord k.+1) -Hcast card_ord.
  rewrite j_M.
  apply eq_bigr => i0 _; congr (P `^ n _).
  rewrite ffunE /= enum_valK tcastE /tnth /=.
  apply set_nth_default; by rewrite /= j_M ltn_ord.
transitivity (\sum_(j0 : 'rV[A]_n) \sum_(ji : 'rV[A]_n)
  ((P `^ n) j0) * ((P `^ n) ji) * (\sum_( y | y \in
    [set y0 in 'rV[B]_n | prod_rV (ji , y0) \in `JTS P W n epsilon0])
  (W ``(| j0)) y))%R.
  set lhs := (\sum_(_ <- _) _)%R.
  suff : lhs = 1%R by move=> ->; rewrite mul1R.
  rewrite /lhs {lhs}.
  rewrite (@big_cat_tuple_seq _ i.-1 (#|M| - i.+1) (fun x => \prod_(i0 <- x) (P `^ n) i0))%R.
  by rewrite rsum_rmul_tuple_pmf.
transitivity (\sum_(ji : 'rV[A]_n) ((P `^ n) ji) *
  (\sum_(y | y \in [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0])
  \sum_(j0 : 'rV[A]_n) ((W ``(| j0) ) y) * ((P `^ n) j0)))%R.
  rewrite exchange_big /=.
  apply eq_bigr => ta _.
  transitivity (\sum_(i1 : 'rV[A]_n) P `^ _ ta * P `^ _ i1 *
    (\sum_(y in [set y0 | prod_rV (ta, y0) \in `JTS P W n epsilon0])
       W ``(y | i1)))%R.
    apply eq_bigr => i1 _.
    by rewrite -mulRA mulRCA mulRA.
  rewrite exchange_big /= big_distrr /=.
  apply eq_bigr => ta' _.
  rewrite -[in X in _ = (_ * X)%R]big_distrl /= -mulRA; congr Rmult.
  by rewrite mulRC.
transitivity (\sum_(ji : 'rV[A]_n) ((P `^ n) ji) *
  \sum_( y | y \in [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0])
  ((`O(P , W)) `^ n) y)%R.
  apply eq_bigr => ta _; congr (_ * _)%R; apply eq_bigr => /= tb _.
  by rewrite fdist_rV_out; apply eq_bigr => i0 _; by rewrite DMCE.
transitivity (\sum_(v : 'rV[A]_n)
  (\sum_(y | y \in
    [set y0 | prod_rV (v , y0) \in `JTS P W n epsilon0])
    ((P `^ n) `x ((`O(P , W)) `^ n)) (v, y)))%R.
  apply eq_bigr => // v _.
  rewrite big_distrr /=; apply eq_bigr => w _; by rewrite fdist_prodE.
transitivity (\sum_( jiy | prod_rV jiy \in `JTS P W n epsilon0)
  ((P `^ n) `x ((`O(P , W)) `^ n)) jiy)%R.
  rewrite [in LHS]pair_big_dep /=.
  by apply eq_big => -[? ?] /=; rewrite !inE ?fdist_prodE.
by apply eq_bigl => ?; rewrite !inE.
Qed.

Local Close Scope tuple_ext_scope.

Lemma preimC_Cal_E k n epsilon0 :
  let M := [finType of 'I_k.+1] in
  let PHI' := jtdec P W epsilon0 in
  let Cal_E := @cal_E M n epsilon0 in
  forall f : encT A M n,
    preimC (PHI' f) ord0 =i
    (~: Cal_E f ord0) :|: \bigcup_(m : M | m != ord0) Cal_E f m.
Proof.
move=> M PHI' Cal_E f tb.
rewrite 2!inE.
apply/idP/idP.
- rewrite /PHI' /jtdec ffunE.
  case: (pickP _) => [m2 Hm2 | Hm2].
  + move/eqP => m2m0.
    rewrite finset.in_setU finset.in_setC {1}/Cal_E {1}/cal_E inE; apply/orP; left.
    case/andP : Hm2 => _ /forallP/(_ ord0)/implyP; apply.
    by move/eqP in m2m0; apply: contra m2m0 => /eqP <-.
  + move=> _.
    rewrite finset.in_setU.
    move/negbT : {Hm2}(Hm2 ord0).
    rewrite negb_and.
    case/orP => Hm2.
    * by rewrite finset.in_setC {1}/Cal_E {1}/cal_E inE Hm2.
    * apply/orP; right.
      apply/negPn.
      move: Hm2; apply contra => Hm2.
      apply/forallP => m_; apply/implyP => m_m0.
      apply: contra Hm2 => Hm2.
      apply/bigcupP; exists m_ => //; by rewrite /Cal_E /cal_E inE.
- rewrite finset.in_setU ffunE.
  case: (pickP _) => [m2 Hm2|//].
  case/orP.
  + rewrite finset.in_setC /cal_E inE => Hy.
    apply/eqP => -[m20].
    by case/andP : Hm2; rewrite m20 (negbTE Hy).
  + case/bigcupP => m Hm; rewrite /cal_E 2!inE => m_tb.
    apply/eqP => -[m20].
    case/andP : Hm2 => _ /forallP /(_ m); by rewrite !inE m_tb m20 Hm implyTb.
Qed.

Local Open Scope zarith_ext_scope.

Lemma random_coding_good_code epsilon : 0 <= epsilon ->
  forall (r : CodeRateType),
    forall epsilon0, epsilon0_condition r epsilon epsilon0 ->
    forall n, n_condition r epsilon0 n ->
  exists M : finType, (0 < #|M|)%nat /\ #|M| = '| Int_part (exp2 (INR n * r)) | /\
  let Jtdec := jtdec P W epsilon0 in
  \sum_(f : encT A M n) (Wght.d P f * echa(W , mkCode f (Jtdec f)))%R < epsilon.
Proof.
move=> Hepsilon r epsilon0 Hepsilon0 n Hn.
have [k Hk] : exists k, (log (INR k.+1) / INR n = r)%R.
  case: Hn => ? [? [Hn2 ?]].
  case/fp_nat : Hn2 => k Hn2.
  exists '| k |.-1.
  rewrite prednK; last first.
    apply/ltP/INR_lt. (* TODO: ssrZ? *)
    rewrite INR_Zabs_nat; [by rewrite -Hn2 | apply le_IZR; by rewrite -Hn2].
  rewrite -(@eqR_mul2l (INR n)); last by rewrite INR_eq0; apply/eqP; rewrite -lt0n.
  rewrite mulRCA mulRV ?INR_eq0' -?lt0n // mulR1 -(exp2K (INR n * r)) Hn2 INR_Zabs_nat //.
  apply le_IZR; by rewrite -Hn2.
set M := [finType of 'I_k.+1].
exists [finType of 'I_k.+1].
split; first by rewrite /= card_ord.
split.
  have -> : (INR n * r)%R = log (INR k.+1).
    rewrite -Hk mulRCA mulRV ?INR_eq0' -?lt0n ?mulR1 //; by case: Hn.
  rewrite logK; last exact/ltR0n.
  by rewrite Int_part_INR Zabs_nat_Z_of_nat card_ord.
move=> Jtdec.
rewrite /CodeErrRate.
rewrite [X in X < _](_ : _ = (1 / INR #|M| *
  \sum_(f : encT A M n) Wght.d P f * (\sum_(m in M) e(W, mkCode f (Jtdec f)) m))%R); last first.
  rewrite big_distrr /=.
  apply eq_bigr => f _.
  rewrite -!mulRA mulRC -!mulRA.
  do 2 f_equal.
  by rewrite mulRC.
rewrite [X in X < _](_ : _ = (\sum_(f : encT A M n) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0)%R); last first.
  transitivity (1 / INR #|M| *
    \sum_(f : encT A M n) (\sum_(m in M) Wght.d P f * (e(W, mkCode f (Jtdec f))) m))%R.
    f_equal.
    apply eq_bigr => i _; by rewrite big_distrr.
  rewrite exchange_big /=.
  transitivity (1 / INR #|M| * \sum_(f : encT A M n)
    (\sum_( m_ in M ) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0))%R.
    congr (_ * _)%R.
    rewrite [in RHS]exchange_big /=.
    apply eq_bigr => m' _.
    apply error_rate_symmetry.
    by move: Hepsilon0; rewrite /epsilon0_condition; case => /ltRW.
  rewrite exchange_big /= big_const /= iter_addR div1R mulRA mulVR ?mul1R //.
  by rewrite INR_eq0' card_ord.
set Cal_E := @cal_E M n epsilon0.
apply (@leR_ltR_trans
(\sum_(f : encT A M n) Wght.d P f * Pr (W ``(| f ord0)) (~: Cal_E f ord0) +
  \sum_(i | i != ord0)
  \sum_(f : encT A M n) Wght.d P f * Pr (W ``(| f ord0)) (Cal_E f i))%R).
  rewrite exchange_big /= -big_split /=.
  apply leR_sumR => /= i _.
  rewrite -big_distrr /= -mulRDr.
  apply leR_wpmul2l; first exact: FDist.ge0.
  rewrite [X in X <= _](_ : _ = Pr (W ``(| i ord0))
    (~: Cal_E i ord0 :|: \bigcup_(i0 : M | i0 != ord0) Cal_E i i0)); last first.
    congr Pr; apply/setP => /= tb.
    move: (preimC_Cal_E epsilon0 i tb); by rewrite inE.
  apply (@leR_trans (Pr (W ``(| i ord0)) (~: Cal_E i ord0) +
    Pr (W ``(| i ord0)) (\bigcup_(i0 | i0 != ord0) (Cal_E i i0)))%R).
    exact: Pr_union.
  exact/leR_add2l/Pr_bigcup.
rewrite first_summand //.
set lhs := (\sum_(_ < _ | _) _)%R.
have -> : lhs = (#| M |.-1%:R * Pr ((P `^ n) `x ((`O(P , W)) `^ n)) [set x | prod_rV x \in `JTS P W n epsilon0])%R.
  rewrite {}/lhs.
  rewrite [RHS](_ : _ = \sum_(H0 < k.+1 | H0 != ord0)
    Pr ((P `^ n) `x ((`O( P , W )) `^ n)) [set x | prod_rV x \in `JTS P W n epsilon0])%R; last first.
    rewrite big_const /= iter_addR; congr (_%:R * _)%R.
    rewrite card_ord /=.
    transitivity (#| finset.setT :\ (@ord0 k)|).
      move: (cardsD1 (@ord0 k) finset.setT) => /=.
      rewrite !cardsT !card_ord inE /= add1n.
      case=> H1; by rewrite {1}H1.
    rewrite cardsE.
    apply eq_card => m_.
    by rewrite -!topredE /= !finset.in_set andbC.
  by apply eq_big => //; exact: second_summand.
rewrite card_ord /=.
apply (@leR_ltR_trans (epsilon0 + k%:R *
   Pr P `^ n `x (`O(P , W)) `^ n [set x | prod_rV x \in `JTS P W n epsilon0])%R).
  apply leR_add2r.
  rewrite Pr_of_cplt leR_subl_addr addRC -leR_subl_addr; apply/JTS_1 => //.
  by case: Hepsilon0.
  by case: Hn => _ [_ []].
apply (@leR_ltR_trans (epsilon0 +
    #| M |%:R * exp2 (- n%:R * (`I(P, W ) - 3 * epsilon0)))).
  apply/leR_add2l/leR_pmul; [exact: leR0n|exact: Pr_ge0| |exact: non_typical_sequences].
  by apply/le_INR/leP; rewrite card_ord.
apply (@ltR_trans (epsilon0 + epsilon0)); last by case: Hepsilon0 => ? [? ?]; lra.
apply ltR_add2l.
have -> : INR #| M | = exp2 (log (INR #| M |)).
  rewrite logK // (_ : 0 = INR 0)%R //.
  by apply lt_INR; rewrite card_ord; exact/ltP.
rewrite -ExpD.
rewrite (_ : _ + _ = - n%:R * (`I(P, W) - log #| M |%:R / n%:R - 3 * epsilon0))%R; last first.
  field.
  by apply/eqP; rewrite INR_eq0' gtn_eqF //; case: Hn.
rewrite (_ : _ / _ = r)%R; last by rewrite -Hk card_ord.
apply (@ltR_trans (exp2 (- n%:R * epsilon0))).
  apply Exp_increasing => //.
  rewrite !mulNR ltR_oppr oppRK; apply/ltR_pmul2l.
  - apply ltR0n; by case: Hn.
  - case: Hepsilon0 => _ [_ Hepsilon0].
    apply (@ltR_pmul2l 4) in Hepsilon0; last lra.
    rewrite mulRCA mulRV ?mulR1 in Hepsilon0; last exact/eqP.
    clear Hk; lra.
apply (@ltR_leR_trans (exp2 (- (- (log epsilon0) / epsilon0) * epsilon0))).
  apply Exp_increasing => //; apply ltR_pmul2r.
  - rewrite /epsilon0_condition in Hepsilon0; tauto.
  - rewrite ltR_oppr oppRK; by case: Hn => _ [Hn2 _].
    rewrite !mulNR -mulRA mulVR ?mulR1 ?oppRK; last first.
      by apply/gtR_eqF; case: Hepsilon0.
    by rewrite logK; [exact/leRR | case: Hepsilon0].
Qed.

End random_coding_good_code_existence.

Section channel_coding_theorem.
Variables (A B : finType) (W : `Ch(A, B)).
Hypothesis set_of_I_nonempty :
  classical_sets.nonempty (fun y => exists P, `I(P, W) = y).

Local Open Scope zarith_ext_scope.

Theorem channel_coding (r : CodeRateType) : r < capacity W ->
  forall epsilon, 0 < epsilon ->
    exists n M (c : code A B M n), CodeRate c = r /\ echa(W, c) < epsilon.
Proof.
move=> r_I epsilon Hepsilon.
have [P HP] : exists P : fdist A, r < `I(P, W).
  apply NNPP => abs.
  have {}abs : forall P : fdist A, `I(P, W) <= r.
    move/not_ex_all_not in abs.
    move=> P; exact/Rnot_lt_le/abs.
  have ? : capacity W <= r.
    apply/RleP.
    have : has_sup [set `I(P, W) | P in [set: fdist A]].
      case: set_of_I_nonempty => [x [P H1]]; split; first by exists x, P.
      by exists (rate r) => _ [Q _ <-]; exact/Rstruct.RleP/abs.
    move=> /(@Rsup_isLub 0 [set `I(P, W) | P in [set: fdist A]])[_].
    apply.
    by move=> x [P _ <-{x}]; exact/RleP/abs.
  lra.
have [epsilon0 Hepsilon0] : exists epsilon0,
  0 < epsilon0 /\ epsilon0 < epsilon / 2 /\ epsilon0 < (`I(P, W) - r) / 4.
  exists ((Rmin (epsilon/2) ((`I(P, W) - r) / 4))/2).
  have H0 : 0 < Rmin (epsilon / 2) ((`I(P, W) - r) / 4).
    apply Rmin_pos; apply mulR_gt0 => //; lra.
  split; first by apply mulR_gt0 => //; lra.
  split; [exact/(ltR_leR_trans (Rlt_eps2_eps _ H0))/geR_minl |
          exact/(ltR_leR_trans (Rlt_eps2_eps _ H0))/geR_minr ].
have [n Hn] : exists n, n_condition W P r epsilon0 n.
  destruct r as [r [num [den [Hnum [Hden Hr]]]]].
  have Hn : exists n, (0 < n)%nat /\
    - log epsilon0 / epsilon0 < INR n /\
    (maxn '| up (aep_bound P (epsilon0 / 3)) |
    (maxn '| up (aep_bound (`O(P , W)) (epsilon0 / 3)) |
          '| up (aep_bound ((P `X W)) (epsilon0 / 3)) |) <= n)%nat.
    set supermax := maxn 1
      (maxn '| up (- log epsilon0 / epsilon0) |
      (maxn '| up (aep_bound P (epsilon0 / 3)) |
      (maxn '| up (aep_bound (`O(P , W)) (epsilon0 / 3)) |
            '| up (aep_bound ((P `X W)) (epsilon0 / 3)) |))).
    exists supermax.
    split; first by rewrite leq_max.
    split.
      apply (@ltR_leR_trans (IZR (up (- log epsilon0 / epsilon0)))).
        rewrite up_Int_part.
        case: (base_Int_part (- log epsilon0 / epsilon0)) => H1 H2.
        rewrite plus_IZR //.
        move: H2.
        set eps := - log epsilon0 / epsilon0.
        move=> ?; lra.
      apply (@leR_trans (INR '| up (- log epsilon0 / epsilon0) |)).
        case: (Z_lt_le_dec (up (- log epsilon0 / epsilon0)) 0) => H1.
          by apply (@leR_trans 0); [exact/IZR_le/ltZW | exact: leR0n].
        by rewrite INR_Zabs_nat //; exact/leRR.
      apply le_INR.
      rewrite /supermax maxnA.
      apply/leP.
      by rewrite leq_max leq_max leqnn orbT.
    by rewrite [X in (_ <= X)%nat]maxnA leq_maxr.
  lapply (exists_frac_part Hn Hnum Hden); last move=> n1 n2 n1_n2 Pn1.
    case=> n [[Hn1 [Hn3 Hn4]] Hn2].
    exists n => /=.
    rewrite /n_condition.
    split => //; split => //; split => //.
    by rewrite -Hr in Hn2.
  split.
    by apply/(@leq_trans n1) => //; tauto.
  split.
    by apply (@ltR_leR_trans (INR n1)); [tauto | exact/le_INR/leP].
  by apply leq_trans with n1 => //; tauto.
case: (random_coding_good_code (ltRW Hepsilon) Hepsilon0 Hn) =>
  M [HM [M_k H]].
case: (good_code_sufficient_condition HM H) => f Hf.
exists n, M, (mkCode f (jtdec P W epsilon0 f)); split => //.
rewrite /CodeRate M_k INR_Zabs_nat; last exact/Int_part_ge0.
suff -> : IZR (Int_part (exp2 (INR n * r))) = exp2 (INR n * r).
  rewrite exp2K /Rdiv -mulRA mulRCA mulRV ?INR_eq0' -?lt0n ?mulR1 //; by case: Hn.
by apply frac_Int_part; case: Hn => _ [_ []].
Qed.

End channel_coding_theorem.


Set Printing Universes.
Set Universe Polymorphism.

Add LoadPath "../quotient".
Require Import Base.

(* Contractible types *)

Record contractible (T : Type) := CtrMk
  { Point : T ;
    Ctr   : forall t : T, heq t Point }.

(* Integers for h-levels *)

Inductive hlevel :=
| minus2 : hlevel
| suc    : hlevel -> hlevel.

Definition minus1 := suc minus2.
Definition zero   := suc minus1.

Notation "-2" := (minus2).
Notation "-1" := (minus1).
Notation "0"  := (zero).

(* is-n-Type *)

Fixpoint ishType (n : hlevel) (T : Type) : Type :=
  match n with
  | minus2 => contractible T
  | suc n  => forall x y : T, ishType n (heq x y)
  end.

Definition hctr : forall T, contractible T -> ishType minus2 T.
  intros T h ; exact h.
Defined.

Definition hsuc : forall l T, (forall x y : T, ishType l (heq x y)) -> ishType (suc l) T.
  intros l T h. easy.
Defined.

Notation "is- N -Type" := (ishType N) (at level 80).

Goal is-minus2-Type True.
Proof.
  apply hctr.
  exists I.
  intro t ; now destruct t.
Qed.

Definition ishProp := is-minus1-Type.
Definition ishSet  := is-0-Type.

(* n-Type *)

Definition hType (n : hlevel) := { T : Type | is-n-Type T }.

Notation "n -Type" := (hType n) (at level 75).

Definition hProp := minus1-Type.
Definition hSet  := 0-Type.

(* Truncation *)

Module Export Truncation.

  Private Inductive trunc (n : hlevel) (A : Type) : Type :=
  | tr : A -> trunc n A.
  Bind Scope trunc_scope with trunc.
  Arguments tr {n A} a.

  Section Foo.

    Universes i j k l.

    Global Lemma ishType_trunc (n : hlevel) (A : Type@{i})
    : ishType@{i j k l} n (trunc@{i} n A).
    Admitted.

  End Foo.

  Definition trunc_ind {n A}
             (P : trunc n A -> Type) {Pt : forall aa, ishType n (P aa)}
  : (forall a, P (tr a)) -> (forall aa, P aa)
    := fun f aa =>
        match aa with
            tr a => fun _ => f a
        end
          Pt.

End Truncation.
Import Truncation.

Notation "|| A ||" := (trunc minus1 A).

(* Equivalence *)

Definition comp {A B C} (f : B -> C) (g : A -> B) := fun x => f (g x).
Notation "f ∘ g" := (comp f g) (at level 86).

Definition homo {A B} (f g : A -> B) := forall a : A, heq (f a) (g a).
Notation "f ~ g" := (homo f g) (at level 87).

Definition id A := fun x : A => x.

(*Inductive prod A B :=
| pair : forall (a : A) (b : B), prod A B.*)
Notation "A * B" := (prod A B).

Definition isEquiv {A B} (f : A -> B) :=
  { g : B -> A | g ∘ f ~ id A } * { h : B -> A | f ∘ h ~ id B }.

(* Equivalence relations *)

Definition pi1 (T : hProp) : Type :=
  let (TT, _) := T in TT.

(* I don't really like this solution with projections but that'll have to do for now. *)
Record isEqRel {A} (R : A -> A -> hProp) :=
  { rho : forall x : A, pi1 (R x x) ;
    sigma : forall x y : A, pi1 (R x y) -> pi1 (R y x) ;
    tau : forall x y z : A, pi1 (R y z) -> pi1 (R x y) -> pi1 (R x z) }.

(* Quotient *)

Definition isEqClass {A} (R : A -> A -> hProp) (P : A -> hProp) :=
  { x : A | forall y : A,  { f : pi1 (R x y) -> pi1 (P y) | isEquiv f } }.


From Coqprime Require Import PocklingtonRefl.

Local Open Scope positive_scope.

Lemma primo83 : prime 1659108721.
Proof.
 apply (Pocklington_refl
         (Pock_certif 1659108721 11 ((6912953, 1)::(2,4)::nil) 1)
        ((Pock_certif 6912953 3 ((864119, 1)::(2,3)::nil) 1) ::
         (Pock_certif 864119 7 ((432059, 1)::(2,1)::nil) 1) ::
         (Pock_certif 432059 2 ((41, 1)::(2,1)::nil) 13) ::
         (Proof_certif 41 prime41) ::
         (Proof_certif 2 prime2) ::
          nil)).
 native_cast_no_check (refl_equal true).
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(** Typeerties of decidable propositions *)

Require Export HoTT.Overture.

Definition decidable (P:Type) := P \/ ~ P.

Definition dec_not_not : forall P:Type, decidable P -> (~ P -> Empty) -> P
  := fun P ponp nnp => match ponp with
                         | inl p => p
                         | inr np => match nnp np with end
                       end.

Definition dec_True : decidable True
  := inl I.

Definition dec_Empty : decidable Empty
  := inr (fun x => x).

Definition dec_or :
 forall A B:Type, decidable A -> decidable B -> decidable (A \/ B)
  := fun A B HA HB => match HA, HB with
                        | inl a, _ => inl (inl a)
                        | _, inl b => inl (inr b)
                        | inr na, inr nb => inr (fun ab => match ab with
                                                             | inl a => na a
                                                             | inr b => nb b
                                                           end)
                      end.

Definition dec_and :
 forall A B:Type, decidable A -> decidable B -> decidable (A /\ B)
  := fun A B HA HB =>
       match HA, HB with
         | inr na, _ => inr (fun ab => na (fst ab))
         | _, inr nb => inr (fun ab => nb (snd ab))
         | inl a, inl b => inl (a, b)
       end.

Definition dec_not : forall A:Type, decidable A -> decidable (~ A)
  := fun A HA => match HA with
                   | inl a => inr (fun na => na a)
                   | inr na => inl na
                 end.

Definition dec_imp :
 forall A B:Type, decidable A -> decidable B -> decidable (A -> B)
  := fun A B HA HB =>
       match HA, HB with
         | _, inl b => inl (fun _ => b)
         | inr na, _ => inl (fun a => match na a with end)
         | inl a, inr nb => inr (fun f => nb (f a))
       end.

Definition dec_iff :
 forall A B:Type, decidable A -> decidable B -> decidable (A<->B)
  := Eval compute in
      fun A B HA HB =>
        match dec_imp A B HA HB, dec_imp B A HB HA with
          | inl f, inl g => inl (Iff f g)
          | inr nf, _ => inr (fun fg : A <-> B => let (f, g) := fg in nf f)
          | _, inr ng => inr (fun fg : A <-> B => let (f, g) := fg in ng g)
        end.

Definition not_not : forall P:Type, decidable P -> ~ ~ P -> P
  := fun P HP nnP =>
       match HP with
         | inl p => p
         | inr np => match nnP np with end
       end.

Definition not_or : forall A B:Type, ~ (A \/ B) -> ~ A /\ ~ B
  := fun A B nab => (fun a => nab (inl a), fun b => nab (inr b)).

Definition not_and : forall A B:Type, decidable A -> ~ (A /\ B) -> ~ A \/ ~ B
  := fun A B HA nab => match HA with
                         | inl a => inr (fun b => nab (a, b))
                         | inr na => inl na
                       end.

Definition not_imp : forall A B:Type, decidable A -> ~ (A -> B) -> A /\ ~ B
  := fun A B HA nab => (match HA with
                          | inl a => a
                          | inr na => match nab (fun a => match na a with end) with end
                        end,
                        fun b => nab (fun _ => b)).

Definition imp_simp : forall A B:Type, decidable A -> (A -> B) -> ~ A \/ B
  := fun A B HA f => match HA with
                       | inl a => inr (f a)
                       | inr na => inl na
                     end.

Definition not_iff :
  forall A B:Type, decidable A -> decidable B ->
    ~ (A <-> B) -> (A /\ ~ B) \/ (~ A /\ B)
  := fun A B HA HB nab => match HA, HB with
                            | inl a, inr nb => inl (a, nb)
                            | inr na, inl b => inr (na, b)
                            | inl a, inl b => match nab (Iff (fun _ => b) (fun _ => a)) with end
                            | inr na, inr nb => match nab (Iff (fun a => match na a with end) (fun b => match nb b with end)) with end
                          end.

(** Results formulated with iff, used in FSetDecide.
    Negation are expanded since it is unclear whether setoid rewrite
    will always perform conversion. *)

(** We begin with lemmas that, when read from left to right,
    can be understood as ways to eliminate uses of [not]. *)

Definition not_true_iff : (True -> Empty) <-> Empty.
Proof.
  constructor; auto.
Defined.

Definition not_false_iff : (Empty -> Empty) <-> True.
Proof.
  constructor; auto.
Defined.

Local Ltac decide_by_auto :=
  repeat (intros [?|?] || intro);
  constructor; intros; auto;
  refine (match _ : Empty with end);
  unfold not in *;
  auto.

Definition not_not_iff : forall A:Type, decidable A ->
  (((A -> Empty) -> Empty) <-> A).
Proof.
  decide_by_auto.
Defined.

Definition contrapositive : forall A B:Type, decidable A ->
  (((A -> Empty) -> (B -> Empty)) <-> (B -> A)).
Proof.
  decide_by_auto.
Defined.

Definition or_not_l_iff_1 : forall A B: Type, decidable A ->
  ((A -> Empty) \/ B <-> (A -> B))
  := fun A B HA => Iff (fun nab => fun a => match nab with
                                              | inl na => match na a : Empty with end
                                              | inr b => b
                                            end)
                       (fun ab => match HA with
                                    | inl a => inr (ab a)
                                    | inr na => inl na
                                  end).
(*
Lemma or_not_l_iff_2 : forall A B: Type, decidable B ->
  ((A -> Empty) \/ B <-> (A -> B)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_r_iff_1 : forall A B: Type, decidable A ->
  (A \/ (B -> Empty) <-> (B -> A)).
Proof.
unfold decidable. tauto.
Qed.

Lemma or_not_r_iff_2 : forall A B: Type, decidable B ->
  (A \/ (B -> Empty) <-> (B -> A)).
Proof.
unfold decidable. tauto.
Qed.

Lemma imp_not_l : forall A B: Type, decidable A ->
  (((A -> Empty) -> B) <-> (A \/ B)).
Proof.
unfold decidable. tauto.
Qed.

(** Moving Negations Around:
    We have four lemmas that, when read from left to right,
    describe how to push negations toward the leaves of a
    proposition and, when read from right to left, describe
    how to pull negations toward the top of a proposition. *)

Definition not_or_iff : forall A B:Type,
  (A \/ B -> Empty) <-> (A -> Empty) /\ (B -> Empty).
Proof.
tauto.
Qed.

Lemma not_and_iff : forall A B:Type,
  (A /\ B -> Empty) <-> (A -> B -> Empty).
Proof.
tauto.
Qed.

Lemma not_imp_iff : forall A B:Type, decidable A ->
  (((A -> B) -> Empty) <-> A /\ (B -> Empty)).
Proof.
unfold decidable. tauto.
Qed.

Lemma not_imp_rev_iff : forall A B : Type, decidable A ->
  (((A -> B) -> Empty) <-> (B -> Empty) /\ A).
Proof.
unfold decidable. tauto.
Qed.

(* Functional relations on decidable co-domains are decidable *)

Definition dec_functional_relation :
  forall (X Y : Type) (A:X->Y->Type), (forall y y' : Y, decidable (y=y')) ->
  (forall x, exists! y, A x y) -> forall x y, decidable (A x y).
Proof.
intros X Y A Hdec H x y.
destruct (H x) as (y',(Hex,Huniq)).
destruct (Hdec y y') as [->|Hnot]; firstorder.
Qed.
*)
(** With the following hint database, we can leverage [auto] to check
    decidability of propositions. *)

Hint Resolve dec_True dec_Empty dec_or dec_and dec_imp dec_not dec_iff
 : decidable_prop.

(** [solve_decidable using lib] will solve goals about the
    decidability of a proposition, assisted by an auxiliary
    database of lemmas.  The database is intended to contain
    lemmas stating the decidability of base propositions,
    (e.g., the decidability of equality on a particular
    inductive type). *)

Tactic Notation "solve_decidable" "using" ident(db) :=
  match goal with
   | |- decidable _ =>
     solve [ auto 100 with decidable_prop db ]
  end.

Tactic Notation "solve_decidable" :=
  solve_decidable using core.


(** Properties of the operations on [FSetC A]. These are needed to prove that the
    representations are isomorphic. *)
Require Import HoTT HitTactics.
Require Import list_representation list_representation.operations.

Section properties.
  Context {A : Type}.

  Definition append_nl (x: FSetC A) : ∅ ∪ x = x
    := idpath.

  Lemma append_nr : forall (x: FSetC A), x ∪ ∅ = x.
  Proof.
    hinduction; try (intros; apply path_ishprop).
    - reflexivity.
    - intros. apply (ap (fun y => a;;y) X).
  Defined.

  Lemma append_assoc :
    forall (x y z: FSetC A), x ∪ (y ∪ z) = (x ∪ y) ∪ z.
  Proof.
    intros x y z.
    hinduction x ; try (intros ; apply path_ishprop).
    - reflexivity.
    - intros.
      cbn.
      f_ap.
  Defined.

  Lemma append_singleton: forall (a: A) (x: FSetC A),
      a ;; x = x ∪ (a ;; ∅).
  Proof.
    intro a. hinduction; try (intros; apply path_ishprop).
    - reflexivity.
    - intros b x HR.
      refine (comm_s _ _ _ @ ap (fun y => b ;; y) HR).
  Defined.

  Lemma append_comm :
    forall (x1 x2: FSetC A), x1 ∪ x2 = x2 ∪ x1.
  Proof.
    intros x1 x2.
    hinduction x1 ;  try (intros ; apply path_ishprop).
    - intros.
      apply (append_nr _)^.
    - intros a x HR.
      refine (ap (fun y => a;;y) HR @ _).
      refine (append_singleton _ _ @ _).
      refine ((append_assoc _ _ _)^ @ _).
      refine (ap (x2 ∪) (append_singleton _ _)^).
  Defined.

  Lemma singleton_idem: forall (a: A),
      {|a|} ∪ {|a|} = {|a|}.
  Proof.
    intro.
    apply dupl.
  Defined.

End properties.


(** * LDef: Definition of an STLC-based language.  *)

(** This is SF's Stlc with Gamma change to be a list of declarations.
*)

Load Init.
Require Export SfLib.
Require Import LibTactics.

Module LDEF.

(* ###################################################################### *)
(** ** Syntax *)

(* ################################### *)
(** *** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif" ].

(* ###################################################################### *)
(** ** Operational Semantics *)

(* ################################### *)
(** *** Values *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.

Hint Constructors value.

(* ###################################################################### *)
(** *** Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if eq_id_dec x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if eq_id_dec x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x], that do not mention
    variables are not bound by some enclosing lambda), we can skip
    this extra complexity here, but it must be dealt with when
    formalizing richer languages. *)

(* ################################### *)
(** *** Reduction *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
   repeat (print_goal; eapply multi_step ;
             [ (eauto 10; fail) | (instantiate; simpl)]);
   apply multi_refl.

(* ###################################################################### *)
(** ** Typing *)

(* ################################### *)
(** *** Contexts *)

Inductive decl :=
  | Lv : id -> ty -> decl.

Definition context := list decl.
Definition empty := nil (A:=decl).
Definition add_vdecl(x : id) (T : ty)  (Gamma : context)
  := (Lv x T) :: Gamma.
Fixpoint lookup_vdecl (x : id) (Gamma : context) :=
  match Gamma with
    | nil => None
    | (Lv y T) :: Ls' => if eq_id_dec y x then Some T else lookup_vdecl x Ls'
  end.

Lemma lookup_add_vdecl_eq :
  forall (x : id) (T : ty) (Ls : list decl),
    lookup_vdecl x (add_vdecl x T Ls) = Some T.
Proof.
  intros. simpl. apply eq_id.
Qed.

Lemma lookup_add_vdecl_neq :
  forall (x y : id) (T : ty) (Ls : list decl),
    y <> x ->
    lookup_vdecl x (add_vdecl y T Ls) = lookup_vdecl x Ls.
Proof.
  intros. simpl. apply neq_id. apply H.
Qed.

(*
Lemma add_vdecl_eq : forall (ctxt: context) x T,
  lookup_vdecl x (add_vdecl ctxt x T) = Some T.
Proof.
  intros. unfold add_vdecl, lookup_vdecl. rewrite eq_id; auto.
Qed.

Lemma add_vdecl_neq : forall (ctxt: context) x1 x2 T,
  x2 <> x1 ->
  lookup_vdecl x1 (add_vdecl ctxt x2 T) = lookup_vdecl x1 ctxt.
Proof.
  intros. unfold add_vdecl, lookup_vdecl. rewrite neq_id; auto.
Qed.
*)

Lemma lookup_add_vdecl_shadow : forall (ctxt: context) t1 t2 x1 x2,
  lookup_vdecl x1 (add_vdecl x2 t2 (add_vdecl x2 t1 ctxt))
    = lookup_vdecl x1 (add_vdecl x2 t2 ctxt).
Proof with auto.
  intros. unfold add_vdecl, lookup_vdecl. destruct (eq_id_dec x2 x1)...
Qed.

(* ################################### *)
(** *** Typing Relation *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      lookup_vdecl x Gamma = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      add_vdecl x T11 Gamma |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If" ].

Hint Constructors has_type.

End LDEF.

(** $Date: $ *)