Require Import
  HoTT.Types.Universe
  HoTT.Basics.Decidable
  HoTT.Classes.implementations.peano_naturals
  HoTT.Classes.implementations.natpair_integers
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.interfaces.naturals
  HoTT.Classes.interfaces.integers
  HoTT.Classes.interfaces.rationals
  HoTT.Classes.interfaces.orders
  HoTT.Classes.theory.rings
  HoTT.Classes.theory.groups
  HoTT.Classes.theory.integers
  HoTT.Classes.theory.dec_fields
  HoTT.Classes.orders.sum
  HoTT.Classes.orders.dec_fields
  HoTT.Classes.orders.lattices
  HoTT.Classes.theory.additional_operations
  HoTT.Classes.tactics.ring_quote
  HoTT.Classes.tactics.ring_tac.

Import Quoting.Instances.
Import NatPair.Instances.
Local Set Universe Minimization ToSet.

Section contents.
Context `{Funext} `{Univalence}.
Universe UQ.
Context {Q : Type@{UQ} } {Qap : Apart@{UQ UQ} Q}
  {Qplus : Plus Q} {Qmult : Mult Q}
  {Qzero : Zero Q} {Qone : One Q} {Qneg : Negate Q} {Qrecip : DecRecip Q}
  {Qle : Le@{UQ UQ} Q} {Qlt : Lt@{UQ UQ} Q}
  {QtoField : RationalsToField@{UQ UQ UQ UQ} Q}
  {Qrats : Rationals@{UQ UQ UQ UQ UQ UQ UQ UQ UQ UQ} Q}
  {Qtrivialapart : TrivialApart Q} {Qdec : DecidablePaths Q}
  {Qmeet : Meet Q} {Qjoin : Join Q} {Qlattice : LatticeOrder Qle}
  {Qle_total : TotalRelation (@le Q _)}
  {Qabs : Abs Q}.

Global Instance rational_1_neq_0 : PropHolds (@apart Q _ 1 0).
Proof.
red. apply trivial_apart. solve_propholds.
Qed.

Record Qpos@{} : Type@{UQ} := mkQpos { pos : Q; is_pos : 0 < pos }.
Notation "Q+" := Qpos.

Global Instance Qpos_Q@{} : Cast Qpos Q := pos.
Arguments Qpos_Q /.

Lemma Qpos_plus_pr@{} : forall a b : Qpos, 0 < 'a + 'b.
Proof.
intros.
apply semirings.pos_plus_compat;apply is_pos.
Qed.

Global Instance Qpos_plus@{} : Plus Qpos := fun a b => mkQpos _ (Qpos_plus_pr a b).

Global Instance pos_is_pos@{} : forall q : Q+, PropHolds (0 < ' q)
  := is_pos.

Lemma pos_eq@{} : forall a b : Q+, @paths Q (' a) (' b) -> a = b.
Proof.
intros [a Ea] [b Eb] E.
change (a = b) in E.
destruct E;apply ap;apply path_ishprop.
Qed.

Global Instance Qpos_isset : IsHSet Q+.
Proof.
apply (@HSet.ishset_hrel_subpaths _ (fun e d => ' e = ' d)).
- intros e; reflexivity.
- apply _.
- exact pos_eq.
Qed.

Global Instance Qpos_one@{} : One Q+.
Proof.
exists 1. apply lt_0_1.
Defined.

Global Instance Qpos_mult@{} : Mult Q+.
Proof.
intros a b;exists (' a * ' b).
solve_propholds.
Defined.

Global Instance qpos_plus_comm@{} : Commutative (@plus Q+ _).
Proof.
hnf. intros.
apply pos_eq. change (' x + ' y = ' y + ' x).
apply plus_comm.
Qed.

Global Instance qpos_mult_comm@{} : Commutative (@mult Q+ _).
Proof.
hnf;intros;apply pos_eq,mult_comm.
Qed.

Global Instance pos_recip@{} : DecRecip Q+.
Proof.
intros e. exists (/ ' e).
apply pos_dec_recip_compat.
solve_propholds.
Defined.

Global Instance pos_of_nat@{} : Cast nat Q+.
Proof.
intros n. destruct n as [|k].
- exists 1;apply lt_0_1.
- exists (naturals_to_semiring nat Q (S k)).
  induction k as [|k Ik].
  + change (0 < 1). apply lt_0_1.
  + change (0 < 1 + naturals_to_semiring nat Q (S k)).
    set (K := naturals_to_semiring nat Q (S k)) in *;clearbody K.
    apply pos_plus_compat.
    * apply lt_0_1.
    * trivial.
Defined.

Lemma pos_recip_r@{} : forall e : Q+, e / e = 1.
Proof.
intros;apply pos_eq.
unfold dec_recip,cast,pos_recip;simpl.
change (' e / ' e = 1). apply dec_recip_inverse.
apply lt_ne_flip. solve_propholds.
Qed.

Lemma pos_recip_r'@{} : forall e : Q+, @paths Q (' e / ' e) 1.
Proof.
intros. change (' (e / e) = 1). rewrite pos_recip_r. reflexivity.
Qed.

Lemma pos_mult_1_r@{} : forall e : Q+, e * 1 = e.
Proof.
intros;apply pos_eq. apply mult_1_r.
Qed.

Lemma pos_split2@{} : forall e : Q+, e = e / 2 + e / 2.
Proof.
intros.
path_via (e * (2 / 2)).
- rewrite pos_recip_r,pos_mult_1_r;reflexivity.
- apply pos_eq. change (' e * (2 / 2) = ' e / 2 + ' e / 2).
  ring_tac.ring_with_nat.
Qed.

Lemma pos_split3@{} : forall e : Q+, e = e / 3 + e / 3 + e / 3.
Proof.
intros.
path_via (e * (3 / 3)).
- rewrite pos_recip_r,pos_mult_1_r;reflexivity.
- apply pos_eq. change (' e * (3 / 3) = ' e / 3 + ' e / 3 + ' e / 3).
  ring_tac.ring_with_nat.
Qed.

Global Instance Qpos_mult_assoc@{} : Associative (@mult Q+ _).
Proof.
hnf.
intros;apply pos_eq.
apply mult_assoc.
Qed.

Global Instance Qpos_plus_assoc@{} : Associative (@plus Q+ _).
Proof.
hnf.
intros;apply pos_eq.
apply plus_assoc.
Qed.

Global Instance Qpos_mult_1_l@{} : LeftIdentity (@mult Q+ _) 1.
Proof.
hnf;intros;apply pos_eq;apply mult_1_l.
Qed.

Global Instance Qpos_mult_1_r@{} : RightIdentity (@mult Q+ _) 1.
Proof.
hnf;intros;apply pos_eq;apply mult_1_r.
Qed.

Lemma pos_recip_through_plus@{} : forall a b c : Q+,
  a + b = c * (a / c + b / c).
Proof.
intros. path_via ((a + b) * (c / c)).
- rewrite pos_recip_r;apply pos_eq,symmetry,mult_1_r.
- apply pos_eq;ring_tac.ring_with_nat.
Qed.

Lemma pos_unconjugate@{} : forall a b : Q+, a * b / a = b.
Proof.
intros. path_via (a / a * b).
- apply pos_eq;ring_tac.ring_with_nat.
- rewrite pos_recip_r;apply Qpos_mult_1_l.
Qed.

Lemma Qpos_recip_1 : / 1 = 1 :> Q+.
Proof.
apply pos_eq. exact dec_recip_1.
Qed.

Lemma Qpos_plus_mult_distr_l : @LeftDistribute Q+ mult plus.
Proof.
hnf. intros;apply pos_eq,plus_mult_distr_l.
Qed.

Global Instance Qpos_meet@{} : Meet Q+.
Proof.
intros a b. exists (meet (' a) (' b)).
apply not_le_lt_flip. intros E.
destruct (total_meet_either (' a) (' b)) as [E1|E1];
rewrite E1 in E;(eapply le_iff_not_lt_flip;[exact E|]);
solve_propholds.
Defined.

Global Instance Qpos_join@{} : Join Q+.
Proof.
intros a b. exists (join (' a) (' b)).
apply not_le_lt_flip. intros E.
destruct (total_join_either (' a) (' b)) as [E1|E1];
rewrite E1 in E;(eapply le_iff_not_lt_flip;[exact E|]);
solve_propholds.
Defined.

Lemma Q_sum_eq_join_meet@{} : forall a b c d : Q, a + b = c + d ->
  a + b = join a c + meet b d.
Proof.
intros ???? E.
destruct (total le a c) as [E1|E1].
- rewrite (join_r _ _ E1). rewrite meet_r;trivial.
  apply (order_preserving (+ b)) in E1.
  rewrite E in E1. apply (order_reflecting (c +)). trivial.
- rewrite (join_l _ _ E1).
  rewrite meet_l;trivial.
  apply (order_reflecting (a +)). rewrite E. apply (order_preserving (+ d)).
  trivial.
Qed.

Lemma Qpos_sum_eq_join_meet@{} : forall a b c d : Q+, a + b = c + d ->
  a + b = join a c + meet b d.
Proof.
intros ???? E.
apply pos_eq;apply Q_sum_eq_join_meet.
change (' a + ' b) with (' (a + b)). rewrite E;reflexivity.
Qed.

Lemma Qpos_le_lt_min : forall a b : Q+, ' a <= ' b ->
  exists c ca cb, a = c + ca /\ b = c + cb.
Proof.
intros a b E. exists (a/2),(a/2).
simple refine (existT _ _ _);simpl.
- exists (' (a / 2) + (' b - ' a)).
  apply nonneg_plus_lt_compat_r.
  + apply (snd (flip_nonneg_minus _ _)). trivial.
  + solve_propholds.
- split.
  + apply pos_split2.
  + apply pos_eq. unfold cast at 2;simpl.
    unfold cast at 3;simpl.
    set (a':=a/2);rewrite (pos_split2 a);unfold a';clear a'.
    ring_tac.ring_with_integers (NatPair.Z nat).
Qed.

Lemma Qpos_lt_min@{} : forall a b : Q+, exists c ca cb : Q+,
  a = c + ca /\ b = c + cb.
Proof.
intros.
destruct (total le (' a) (' b)) as [E|E].
- apply Qpos_le_lt_min;trivial.
- apply Qpos_le_lt_min in E. destruct E as [c [cb [ca [E1 E2]]]].
  exists c,ca,cb;auto.
Qed.

Definition Qpos_diff : forall q r : Q, q < r -> Q+.
Proof.
intros q r E;exists (r-q).
apply (snd (flip_pos_minus _ _) E).
Defined.

Lemma Qpos_diff_pr@{} : forall q r E, r = q + ' (Qpos_diff q r E).
Proof.
intros q r E. change (r = q + (r - q)).
abstract ring_tac.ring_with_integers (NatPair.Z nat).
Qed.

Lemma Qmeet_plus_l : forall a b c : Q, meet (a + b) (a + c) = a + meet b c.
Proof.
intros. destruct (total le b c) as [E|E].
- rewrite (meet_l _ _ E). apply meet_l.
  apply (order_preserving (a +)),E.
- rewrite (meet_r _ _ E). apply meet_r.
  apply (order_preserving (a +)),E.
Qed.

Lemma Qabs_nonneg@{} : forall q : Q, 0 <= abs q.
Proof.
intros q;destruct (total_abs_either q) as [E|E];destruct E as [E1 E2];rewrite E2.
- trivial.
- apply flip_nonneg_negate.
 rewrite involutive;trivial.
Qed.

Lemma Qabs_nonpos_0@{} : forall q : Q, abs q <= 0 -> q = 0.
Proof.
intros q E. pose proof (antisymmetry le _ _ E (Qabs_nonneg _)) as E1.
destruct (total_abs_either q) as [[E2 E3]|[E2 E3]];rewrite E3 in E1.
- trivial.
- apply (injective (-)). rewrite negate_0. trivial.
Qed.

Lemma Qabs_0_or_pos : forall q : Q, q = 0 |_| 0 < abs q.
Proof.
intros q. destruct (le_or_lt (abs q) 0) as [E|E].
- left. apply Qabs_nonpos_0. trivial.
- right. trivial.
Qed.

Lemma Qabs_of_nonneg@{} : forall q : Q, 0 <= q -> abs q = q.
Proof.
intro;apply ((abs_sig _).2).
Qed.

Lemma Qabs_of_nonpos : forall q : Q, q <= 0 -> abs q = - q.
Proof.
intro;apply ((abs_sig _).2).
Qed.

Lemma Qabs_le_raw@{} : forall x : Q, x <= abs x.
Proof.
intros x;destruct (total_abs_either x) as [[E1 E2]|[E1 E2]].
- rewrite E2;reflexivity.
- transitivity (0:Q);trivial.
  rewrite E2. apply flip_nonpos_negate. trivial.
Qed.

Lemma Qabs_neg@{} : forall x : Q, abs (- x) = abs x.
Proof.
intros x. destruct (total_abs_either x) as [[E1 E2]|[E1 E2]].
- rewrite E2. path_via (- - x);[|rewrite involutive;trivial].
  apply ((abs_sig (- x)).2). apply flip_nonneg_negate;trivial.
- rewrite E2. apply ((abs_sig (- x)).2). apply flip_nonpos_negate;trivial.
Qed.

Lemma Qabs_le_neg_raw : forall x : Q, - x <= abs x.
Proof.
intros x. rewrite <-Qabs_neg. apply Qabs_le_raw.
Qed.

Lemma Q_abs_le_pr@{} : forall x y : Q, abs x <= y <-> - y <= x /\ x <= y.
Proof.
intros x y;split.
- intros E. split.
  + apply flip_le_negate. rewrite involutive. transitivity (abs x);trivial.
    apply Qabs_le_neg_raw.
  + transitivity (abs x);trivial.
    apply Qabs_le_raw.
- intros [E1 E2].
  destruct (total_abs_either x) as [[E3 E4]|[E3 E4]];rewrite E4.
  + trivial.
  + apply flip_le_negate;rewrite involutive;trivial.
Qed.

Lemma Qabs_is_join@{} : forall q : Q, abs q = join (- q) q.
Proof.
intros q. symmetry.
destruct (total_abs_either q) as [[E1 E2]|[E1 E2]];rewrite E2.
- apply join_r. transitivity (0:Q);trivial.
  apply flip_nonneg_negate;trivial.
- apply join_l. transitivity (0:Q);trivial.
  apply flip_nonpos_negate;trivial.
Qed.

Lemma Qlt_join : forall a b c : Q, a < c -> b < c ->
  join a b < c.
Proof.
intros a b c E1 E2.
destruct (total le a b) as [E3|E3];rewrite ?(join_r _ _ E3),?(join_l _ _ E3);
trivial.
Qed.

Lemma Q_average_between@{} : forall q r : Q, q < r -> q < (q + r) / 2 < r.
Proof.
intros q r E.
split.
- apply flip_pos_minus.
  assert (Hrw : (q + r) / 2 - q = (r - q) / 2);[|rewrite Hrw;clear Hrw].
  { path_via ((q + r) / 2 - 2 / 2 * q).
    { rewrite dec_recip_inverse;[|solve_propholds].
      rewrite mult_1_l;trivial.
    }
    ring_tac.ring_with_integers (NatPair.Z nat).
  }
  apply pos_mult_compat;[|apply _].
  red. apply (snd (flip_pos_minus _ _)). trivial.
- apply flip_pos_minus.
  assert (Hrw : r - (q + r) / 2 = (r - q) / 2);[|rewrite Hrw;clear Hrw].
  { path_via (2 / 2 * r - (q + r) / 2).
    { rewrite dec_recip_inverse;[|solve_propholds].
      rewrite mult_1_l;trivial.
    }
    ring_tac.ring_with_integers (NatPair.Z nat).
  }
  apply pos_mult_compat;[|apply _].
  red. apply (snd (flip_pos_minus _ _)). trivial.
Qed.

Lemma pos_gt_both : forall a b : Q, forall e, a < ' e -> b < ' e ->
  exists d d', a < ' d /\ b < ' d /\ e = d + d'.
Proof.
assert (Haux : forall a b : Q, a <= b -> forall e, a < ' e -> b < ' e ->
  exists d d', a < ' d /\ b < ' d /\ e = d + d').
{ intros a b E e E1 E2.
  pose proof (Q_average_between _ _ (Qlt_join _ 0 _ E2 prop_holds)) as [E3 E4].
  exists (mkQpos _ (le_lt_trans _ _ _ (join_ub_r _ _) E3)).
  unfold cast at 1 4;simpl.
  exists (Qpos_diff _ _ E4).
  repeat split.
  - apply le_lt_trans with b;trivial.
    apply le_lt_trans with (join b 0);trivial.
    apply join_ub_l.
  - apply le_lt_trans with (join b 0);trivial. apply join_ub_l.
  - apply pos_eq. unfold cast at 2;simpl. unfold cast at 2;simpl.
    unfold cast at 3;simpl.
    abstract ring_tac.ring_with_integers (NatPair.Z nat).
}
intros a b e E1 E2. destruct (total le a b) as [E|E];auto.
destruct (Haux _ _ E e) as [d [d' [E3 [E4 E5]]]];trivial.
eauto.
Qed.

Lemma two_fourth_is_one_half@{} : 2/4 =  1/2 :> Q+.
Proof.
assert (Hrw : 4 = 2 * 2 :> Q) by ring_tac.ring_with_nat.
apply pos_eq. repeat (unfold cast;simpl).
rewrite Hrw;clear Hrw.
rewrite dec_recip_distr.
rewrite mult_assoc. rewrite dec_recip_inverse;[|solve_propholds].
reflexivity.
Unshelve. exact (fun _ => 1). (* <- wtf *)
Qed.

Lemma Q_triangle_le : forall q r : Q, abs (q + r) <= abs q + abs r.
Proof.
intros. rewrite (Qabs_is_join (q + r)).
apply join_le.
- rewrite negate_plus_distr.
  apply plus_le_compat;apply Qabs_le_neg_raw.
- apply plus_le_compat;apply Qabs_le_raw.
Qed.

Lemma Qabs_triangle_alt_aux : forall x y : Q, abs x - abs y <= abs (x - y).
Proof.
intros q r.
apply (order_reflecting (+ (abs r))).
assert (Hrw : abs q - abs r + abs r = abs q)
  by ring_tac.ring_with_integers (NatPair.Z nat);
rewrite Hrw;clear Hrw.
etransitivity;[|apply Q_triangle_le].
assert (Hrw : q - r + r = q)
  by ring_tac.ring_with_integers (NatPair.Z nat);
rewrite Hrw;clear Hrw.
reflexivity.
Qed.

Lemma Qabs_triangle_alt : forall x y : Q, abs (abs x - abs y) <= abs (x - y).
Proof.
intros q r.
rewrite (Qabs_is_join (abs q - abs r)).
apply join_le.
- rewrite <-(Qabs_neg (q - r)),<-!negate_swap_r.
  apply Qabs_triangle_alt_aux.
- apply Qabs_triangle_alt_aux.
Qed.

Lemma Q_dense@{} : forall q r : Q, q < r -> exists s, q < s < r.
Proof.
intros q r E;econstructor;apply Q_average_between,E.
Qed.

Lemma Qabs_neg_flip@{} : forall a b : Q, abs (a - b) = abs (b - a).
Proof.
intros a b.
rewrite <-Qabs_neg. rewrite <-negate_swap_r. trivial.
Qed.

Definition pos_of_Q : Q -> Q+
  := fun q => {| pos := abs q + 1;
    is_pos := le_lt_trans _ _ _ (Qabs_nonneg q)
                (fst (pos_plus_lt_compat_r _ _) lt_0_1) |}.

Lemma Q_abs_plus_1_bounds@{} : forall q : Q,
  - ' (pos_of_Q q) ≤ q
  ≤ ' (pos_of_Q q).
Proof.
intros. change (- (abs q + 1) ≤ q ≤ (abs q + 1)). split.
- apply flip_le_negate. rewrite involutive.
  transitivity (abs q).
  + apply Qabs_le_neg_raw.
  + apply nonneg_plus_le_compat_r. solve_propholds.
- transitivity (abs q).
  + apply Qabs_le_raw.
  + apply nonneg_plus_le_compat_r. solve_propholds.
Qed.

Lemma Qabs_mult@{} : forall a b : Q, abs (a * b) = abs a * abs b.
Proof.
intros a b.
destruct (total_abs_either a) as [Ea|Ea];destruct Ea as [Ea1 Ea2];rewrite Ea2;
destruct (total_abs_either b) as [Eb|Eb];destruct Eb as [Eb1 Eb2];rewrite Eb2.
- apply ((abs_sig (a*b)).2). apply nonneg_mult_compat;trivial.
- rewrite <-negate_mult_distr_r.
  apply ((abs_sig (a*b)).2). apply nonneg_nonpos_mult;trivial.
- rewrite <-negate_mult_distr_l.
  apply ((abs_sig (a*b)).2). apply nonpos_nonneg_mult;trivial.
- rewrite negate_mult_negate. apply ((abs_sig (a*b)).2).
  apply nonpos_mult;trivial.
Qed.

Lemma Qpos_neg_le@{} : forall a : Q+, - ' a <= ' a.
Proof.
intros a;apply between_nonneg;solve_propholds.
Qed.

Definition Qpos_upper (e : Q+) := exists x : Q, ' e <= x.

Definition Qpos_upper_inject e : Q -> Qpos_upper e.
Proof.
intros x. exists (join x (' e)). apply join_ub_r.
Defined.

Global Instance QLe_dec : forall q r : Q, Decidable (q <= r).
Proof.
intros q r;destruct (le_or_lt q r).
- left;trivial.
- right;intros ?. apply (irreflexivity lt q).
  apply le_lt_trans with r;trivial.
Qed.

Global Instance QLt_dec : forall q r : Q, Decidable (q < r).
Proof.
intros q r;destruct (le_or_lt r q).
- right;intros ?. apply (irreflexivity lt q).
  apply lt_le_trans with r;trivial.
- left;trivial.
Qed.

Section enumerable.
Context `{Enumerable Q}.

Definition Qpos_enumerator : nat -> Q+.
Proof.
intros n.
destruct (le_or_lt (enumerator Q n) 0) as [E|E].
- exact 1.
- exists (enumerator Q n);trivial.
Defined.

Lemma Qpos_is_enumerator :
  TrM.RSU.IsConnMap@{Uhuge Ularge UQ UQ Ularge} (trunc_S minus_two) Qpos_enumerator.
Proof.
apply BuildIsSurjection.
unfold hfiber.
intros e;generalize (center _ (enumerator_issurj Q (' e))). apply (Trunc_ind _).
intros [n E]. apply tr;exists n.
unfold Qpos_enumerator. destruct (le_or_lt (enumerator Q n) 0) as [E1|E1].
- destruct (irreflexivity lt 0). apply lt_le_trans with (enumerator Q n);trivial.
  rewrite E;solve_propholds.
- apply pos_eq,E.
Qed.

Global Instance Qpos_enumerable `{Enumerable Q} : Enumerable Q+.
Proof.
  exists Qpos_enumerator.
  first [exact Qpos_is_enumerator@{Uhuge Ularge}|
         exact Qpos_is_enumerator@{}].
Qed.

End enumerable.

End contents.

Arguments Qpos Q {_ _}.


Require Import Coq.Lists.List.

Require Export SystemFR.Judgments.
Require Export SystemFR.AnnotatedTactics.
Require Export SystemFR.ErasedNat.

Lemma annotated_reducible_zero:
  forall Θ Γ,
    [[ Θ; Γ ⊨ zero : T_nat ]].
Proof.
  eauto using open_reducible_zero.
Qed.

Lemma annotated_reducible_succ:
  forall Θ Γ t,
    [[ Θ; Γ ⊨ t : T_nat ]] ->
    [[ Θ; Γ ⊨ succ t : T_nat ]].
Proof.
  eauto using open_reducible_succ.
Qed.

Lemma annotated_reducible_match:
  forall Θ Γ tn t0 ts T n p,
    ~(p ∈ fv ts) ->
    ~(p ∈ fv t0) ->
    ~(p ∈ fv tn) ->
    ~(p ∈ fv T) ->
    ~(p ∈ fv_context Γ) ->
    ~(n ∈ fv tn) ->
    ~(n ∈ fv ts) ->
    ~(n ∈ fv T) ->
    ~(n ∈ fv_context Γ) ->
    ~(n = p) ->
    ~(n ∈ Θ) ->
    ~(p ∈ Θ) ->
    wf ts 1 ->
    wf t0 0 ->
    subset (fv t0) (support Γ) ->
    subset (fv ts) (support Γ) ->
    is_annotated_term ts ->
    [[ Θ; Γ ⊨ tn : T_nat ]] ->
    [[ Θ; (p, T_equiv tn zero) :: Γ ⊨ t0 : T ]] ->
    [[ Θ; (
      (p, T_equiv tn (succ (fvar n term_var))) ::
      (n, T_nat) ::
      Γ
    ) ⊨
      open 0 ts (fvar n term_var) :
      T
    ]]
    ->
    [[ Θ; Γ ⊨ tmatch tn t0 ts : T ]].
Proof.
  repeat step || erase_open.
  apply open_reducible_match with n p; repeat step || erase_open; side_conditions.
Qed.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div.
From mathcomp Require Import choice fintype tuple finfun bigop prime binomial.
From mathcomp Require Import ssralg finset fingroup finalg matrix perm.
Require Import Reals Fourier Classical.
Require Import ssrR Reals_ext logb ssr_ext ssralg_ext bigop_ext Rbigop proba.
Require Import entropy aep typ_seq joint_typ_seq channel channel_code.

(** * Channel Coding Theorem (direct part) *)

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

Local Open Scope proba_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_sect.

Variables (A M : finType) (P : dist A) (n : nat).

Definition pmf := fun f : encT A M n => \rprod_(m in M) P `^ n (f m).

Lemma pmf0 (f : {ffun M -> 'rV[A]_n}) : 0 <= pmf f.
Proof. apply rprodr_ge0 => ?; exact: dist_ge0. Qed.

Lemma pmf1 : \rsum_(f | f \in {ffun M -> 'rV[A]_n}) pmf f = 1.
Proof.
rewrite -(bigA_distr_bigA (fun _ ta => P `^ n ta)) /=.
rewrite [X in _ X](_ : 1 = \rprod_(i : M | xpredT i) 1); last first.
  by rewrite big_const /= iter_mulR pow1.
apply eq_bigr => _ _; by rewrite (pmf1 (P `^ n)).
Qed.

Definition d : dist [finType of encT A M n] := locked (makeDist pmf0 pmf1).

End Wght_sect.

End Wght.

Arguments Wght.d [A] [M] _ [n].

Section joint_typicality_decoding.

Variables A B M : finType.
Variable n : nat.

(** Joint typicality decoding *)

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 : dist A) (W : `Ch_1(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) :
  \rsum_(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 := \rsum_(f <- _) _ in H.
have : \rsum_(f : encT A M n) Wght.d P f * epsilon <= x.
  rewrite /x.
  apply ler_rsum_l => //= i _.
  - apply leR_wpmul2l; [exact/dist_ge0 | exact/Rnot_lt_le/abs].
  - apply mulR_ge0; [exact/dist_ge0 | exact/echa_ge0].
apply/Rlt_not_le/(@ltR_leR_trans epsilon) => //.
rewrite -big_distrl /= (pmf1 (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 /Wght.d -lock /Wght.pmf /= (reindex_onto (fun m_ => (tperm m m') m_)
  (fun m_ => (tperm m m') m_)) /=; last first.
  move=> i _; by rewrite tpermK.
apply eq_big => m_.
by rewrite tpermK eqxx.
move=> _; by rewrite /o_PI ffunE tpermK.
Qed.

Lemma error_rate_symmetry (P : {dist A}) (W : `Ch_1(A, B)) epsilon :
  0 <= epsilon -> let Jtdec := jtdec P W epsilon in
    forall m m',
      \rsum_(f : encT A M n) (Wght.d P f * e(W, mkCode f (Jtdec f)) m) =
      \rsum_(f : encT A M n) (Wght.d P f * e(W, mkCode f (Jtdec f)) m').
Proof.
move=> Hepsilon PHI' m m'.
set lhs := \rsum_(_ <- _) _.
have Hlhs : lhs = \rsum_(f : encT A M n) (Wght.d P f * e(W, mkCode f (PHI' f)) m).
  done.
have Hlhs2 : lhs = \rsum_(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.
    move=> i _; apply/ffunP => m_; by rewrite o_PI_2.
  apply eq_bigl => x /=.
  apply/eqP.
  apply/ffunP => y.
  by apply: o_PI_2.
rewrite Hlhs2.
apply eq_bigr => g _.
rewrite wght_o_PI; congr (_ * _).
rewrite /ErrRateCond /= (_ : (o_PI m m' g) m = g m'); last by rewrite ffunE tpermL.
apply Pr_ext; apply/setP => tb /=.
rewrite 2!inE.
apply/negbLR. rewrite in_setC negbK.
apply/idP/idP.
- rewrite {1}/PHI' {1}/jtdec.
  rewrite ffunE.
  set p0 := fun _ => _ && _.
  case: (pickP _) => [m0 Hm0 | Hm0].
  + case/eqP => ?; subst m0.
    rewrite /p0 {p0} in Hm0.
    rewrite /PHI' /jtdec.
    rewrite inE ffunE.
    case: (pickP _) => [m1 Hm1 | Hm1].
    * apply/eqP; f_equal.
      have Hm' : (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)].
        apply/andP; split.
        - rewrite {1}/o_PI ffunE tpermL in Hm0. by case/andP : Hm0.
        - apply/forallP => m_. apply/implyP => m__m'.
          case/andP : Hm0 => Hm0. move/forallP => Hm0'.
          case/boolP : (m_ == m) => m__m.
          + move/eqP in m__m; subst m_.
            move: {Hm0'}(Hm0' m') => Hm0'.
            rewrite eqtype.eq_sym m__m' /= /o_PI ffunE tpermR in Hm0'. by apply Hm0'.
          + move: {Hm0'}(Hm0' m_) => Hm0'.
            rewrite eqtype.eq_sym in m__m'.
            rewrite m__m /= /o_PI ffunE tpermD // in Hm0'; by rewrite eqtype.eq_sym.
      by apply: (jtdec_map Hm1 Hm').
    * suff : False by done.
      rewrite {1}/o_PI ffunE tpermL in Hm0.
      move/negbT: {Hm1}(Hm1 m').
      rewrite negb_and; case/orP => Hm'.
      - case/andP : Hm0 => Hm0 _; by rewrite Hm0 in Hm'.
        move/negP : Hm'; apply.
        apply/forallP => m_. apply/implyP => m__m'.
        case/andP: Hm0 => Hm0.
        move/forallP => Hm01.
        case/boolP : (m_ == m) => m__m.
        + move/eqP in m__m; subst m_.
          move: {Hm01}(Hm01 m') => Hm01.
          rewrite eqtype.eq_sym m__m' /= /o_PI ffunE tpermR in Hm01. by apply Hm01.
        + move: {Hm01}(Hm01 m_) => Hm01.
          rewrite m__m /= /o_PI ffunE tpermD // in Hm01; by rewrite eqtype.eq_sym.
  + by move/eqP.
- rewrite {1}/PHI' {1}/jtdec.
  rewrite inE ffunE.
  case: (pickP _) => [m0 Hm0 | Hm0].
  + case/eqP => ?; subst m0.
    apply/eqP.
    rewrite /PHI' /jtdec.
    rewrite ffunE.
    case: (pickP _) => [m1 Hm1 | Hm1].
    * f_equal.
      have {Hm0}Hm0 : (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)].
        apply/andP; split.
        - rewrite /o_PI ffunE tpermL. by case/andP: Hm0.
        - apply/forallP => m_.
          apply/implyP => m__m.
          case/boolP : (m_ == m').
          + move/eqP => ?; subst m_.
            rewrite /o_PI ffunE tpermR.
            case/andP : Hm0 => _.
            move/forallP. move/(_ m). by rewrite eqtype.eq_sym m__m.
          + move=> m__m'.
            rewrite eqtype.eq_sym in m__m. rewrite eqtype.eq_sym in m__m'.
            rewrite /o_PI ffunE tpermD //.
            case/andP : Hm0 => _.
            move/forallP. move/(_ m_). by rewrite eqtype.eq_sym m__m'.
      by apply: (jtdec_map Hm1 Hm0).
    * suff : False by done.
      move: {Hm1}(Hm1 m).
      move/negbT. rewrite negb_and. case/orP.
      - rewrite /o_PI ffunE tpermL.
        by case/andP : Hm0 => ->.
      - move/negP; apply.
        apply/forallP => m_.
        apply/implyP => m__m.
        case/boolP : (m_ == m').
        + move/eqP => ?; subst m_.
          rewrite /o_PI ffunE tpermR.
          case/andP : Hm0 => _.
          move/forallP. move/(_ m). by rewrite eqtype.eq_sym m__m.
        + move=> m__m'.
          rewrite eqtype.eq_sym in m__m. rewrite eqtype.eq_sym in m__m'.
          rewrite /o_PI ffunE tpermD //.
          case/andP : Hm0 => _.
          move/forallP. move/(_ m_). by rewrite eqtype.eq_sym m__m'.
  + by move/eqP.
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 _ -> _} => \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/matrixP => a b; rewrite {a}(ord1 a).
by rewrite mxE ffunE enum_valK.
Qed.

End sum_rV_ffun.

Section random_coding_good_code_existence.

Variables B A : finType.
Variable W : `Ch_1(A, B).
Variable P : dist 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.

(** the set of output tb such that (f m, tb) is jointly typical: *)

Definition cal_E M n epsilon (f : encT A M n) m :=
  [set tb | prod_rV (f m, tb) \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}) :
  \rsum_(i in C | P1 i) \rsum_(j in {: n.-tuple C} | P2 j) (F [tuple of (i :: j)])
  =
  \rsum_(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=> i; 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 : dist C) :
  \rsum_(t : {:k.-tuple ('rV[C]_n)}) \rprod_(m < k) (Q `^ n) t \_ m = 1%R.
Proof.
transitivity (\rsum_(j : {ffun 'I_k -> 'rV[_]_n})
  \rprod_(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 _ _ (card_ord k)) //.
  apply eq_big => //.
  - move=> i /=; apply/esym/eqP/eq_from_tnth => j.
    by rewrite tnth_fgraph ffunE enum_valK.
  - move=> i _; apply eq_bigr => j _; by rewrite ffunE /= tcastE -enum_rank_ord.
rewrite -(bigA_distr_bigA (fun m xn => Q `^ _ xn)) /= big_const.
rewrite (_ : \rsum_(_ <- _) _ = 1%R); last by rewrite pmf1.
by rewrite iter_mulR pow1.
Qed.

(* TODO: move? *)
Lemma rsum_rmul_tuple_pmf {C} n k (Q : dist C) :
  (\rsum_(t in {:k.-tuple ('rV[C]_n)}) \rprod_(x <- t) (Q `^ n) x = 1)%R.
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
  (\rsum_(f : encT A M n) Wght.d P f *
    Pr (W ``(| f ord0)) (~: cal_E epsilon0 f ord0))%R =
  Pr (`J(P , 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 : (dist_domain_not_empty P) => a _.
pose zero := @enum_rank M ord0.
have : 0%N = zero :> nat by rewrite /zero enum_rank_ord.
move/(@sum_rV_ffun _ _ _ _ _ (fun f => \rprod_(m : M) P `^ n (f m))
  (fun r v => (r * Pr (W ``(| v )) (~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0]))%R)
  ord0 zero).
rewrite (_ : nth ord0 (enum M) 0 = ord0); last by rewrite enum_ordS.
rewrite /Wght.d -lock /= => <- /=.
transitivity (\rsum_(v : 'rV['rV[A]_n]_#|M|) (
    (\rprod_(m : M) P `^ n ([ffun x => v ``_ x] (enum_rank m))) *
    \rsum_(w | w \in ~: cal_E epsilon0 [ffun x => v ``_ x] zero)
    (W ``(| [ffun x => v ``_ x] zero)) w))%R.
  apply eq_bigr => v _; congr (_ * _)%R.
    by apply eq_bigr => m _; rewrite 2!ffunE.
  apply eq_big.
  - move=> /= ?; by rewrite !inE ffunE.
  - move=> ? _; by rewrite ffunE.
rewrite /cal_E.
transitivity (\rsum_(v : 'rV[A]_n)
  (\rsum_(y in ~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0])
  (W ``(| v)) y) *
    \rsum_(j in {: #|M|.-1.-tuple ('rV[A]_n)})
      (\rprod_(m : M) P `^ _ ((tcast M_prednK [tuple of v :: j]) \_ (enum_rank m))))%R.
  rewrite (reindex_onto (fun y : {ffun _ -> _} => \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 (\rsum_(f : {ffun M -> _})
    ((\rprod_(m < k.+1) P `^ n (f m)) *
      \rsum_(y in ~: [set y0 | prod_rV (f ord0, y0) \in `JTS P W n epsilon0])
      W ``(y | f ord0)))%R.
    apply eq_big => //= f.
    - apply/eqP/ffunP => m; by rewrite ffunE mxE enum_rankK.
    - move/eqP => Hf;  congr (_ * _)%R.
        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_ordS.
  rewrite -(big_tuple_ffun _ (fun f => \rprod_(m : M) P `^ n (f m))
    (fun r => fun yn => r *
      (\rsum_(y in ~: [set y0 | prod_rV (yn, y0) \in `JTS P W n epsilon0])
      W ``(y | yn))) (\row_(i < n) a) ord0)%R.
  transitivity (\rsum_(j : _)
    (\rprod_(m : M) P `^ n ((tcast M_prednK j) \_ (enum_rank m))) *
      (\rsum_(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)))%R.
    rewrite (big_tcast _ _ M_prednK) //.
    apply eq_bigr => i _; congr (_ * _)%R.
      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 => ((\rprod_(m : M) P `^ n ((tcast M_prednK j) \_ (enum_rank m))) *
     (\rsum_(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)%R.
  apply eq_bigr => ta _ /=; by rewrite -big_distrl /= mulRC.
transitivity ((\rsum_(ta in 'rV[A]_n) P `^ _ ta *
    (\rsum_(y in ~: [set y0 | prod_rV (ta, y0) \in `JTS P W n epsilon0])
    (W ``(| ta ) ) y)) *
    \rsum_(j in {:k.-tuple ('rV[A]_n)}) \rprod_(m < k) (P `^ _ (j \_ m)))%R.
  rewrite big_distrl /=.
  apply eq_bigr => ta _.
  rewrite -mulRA mulRCA; congr Rmult.
  transitivity (\rsum_(j in {: #|'I_k|.-tuple ('rV[A]_n) })
    P `^ _ ta * \rprod_(m < k) P `^ _ (j \_ (enum_rank m)))%R.
    have k_prednK : #|'I_k.+1|.-1 = #|'I_k| by rewrite !card_ord.
    rewrite (big_tcast _ _ k_prednK) //.
    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 _ _ (card_ord k)) //.
  apply eq_bigr => i0 _.
  apply eq_bigr => i1 _.
  by rewrite tcastE -enum_rank_ord.
rewrite rsum_rmul_tuple_pmf_tnth mulR1.
transitivity (\rsum_(v in 'rV[A]_n)
  \rsum_(y in ~: [set w | prod_rV (v, w) \in `JTS P W n epsilon0])
    (`J(P , W) `^ n (prod_rV (v, y)))).
  apply eq_bigr => /= v _.
  rewrite big_distrr /=.
  apply eq_bigr => // w _.
  rewrite DMCE 2!TupleDist.dE -big_split /=.
  apply eq_bigr => /= i _.
  by rewrite JointDist.dE -fst_tnth_prod_rV -snd_tnth_prod_rV /= mulRC.
rewrite /Pr big_rV_prod pair_big_dep /=.
apply eq_bigl; case=> /= ? ?; by rewrite !inE.
Qed.

(* TODO: move? *)
Lemma big_cat_tuple {C : finType} m n (F : (m + n)%nat.-tuple C -> R) :
  \rsum_(i in {:m.-tuple C}) \rsum_(j in {: n.-tuple C})
  F [tuple of (i ++ j)] = \rsum_(p in {: (m + n)%nat.-tuple C}) (F p).
Proof.
elim: m n F => [m2 F /=|m IH n F].
- transitivity ( \rsum_(i <- [tuple] :: [::])
    \rsum_(j in {: m2.-tuple C}) F [tuple of i ++ j] ).
    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 (\rsum_(p in tuple_finType (m + n).+1 C) F p); 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) :
  \rsum_(i in {:m.-tuple C} ) \rsum_(j in {: n.-tuple C}) (F (i ++ j)) =
  \rsum_(p in {: (m + n)%nat.-tuple C}) (F p).
Proof.
move: (@big_cat_tuple _ m n (fun l => if size l == (m + n)%nat then F l else R0)).
set lhs := \rsum_(i in _) _ => 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 ->
      (\rsum_(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 (
  \rsum_(j1 in {: i.-1.-tuple ('rV[A]_n)})
  \rsum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)})
  \rsum_(j0 in 'rV[A]_n)
  \rsum_(ji in 'rV[A]_n)
  Wght.d P [ffun x => (tcast Hcast [tuple of j0 :: j1 ++ ji :: j2])\_x] *
  \rsum_(y | y \in [set w | prod_rV (ji, w) \in `JTS P W n epsilon0])
  (W ``(| j0)) y)%R.
  transitivity (
    \rsum_(j0 in 'rV[A]_n)
    \rsum_(j1 in {: i.-1.-tuple ('rV[A]_n)})
    \rsum_(ji in 'rV[A]_n)
    \rsum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)})
    Wght.d P [ffun x => (tcast Hcast [tuple of j0 :: j1 ++ ji :: j2])\_x] *
    \rsum_( 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 ( \rsum_(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 _ _ (esym (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 _ _ Hq) //.
    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 : (k - i = #|'I_k.+1| - i.+1)%nat by rewrite card_ord /= subSS.
    rewrite (big_tcast _ _ Ht) //.
    apply eq_bigr => i3 _.
    rewrite /Wght.d -!lock /Wght.pmf /=.
    congr (_ * _)%R.
    - 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: eq_tcast => /=.
      apply/esym/eq_tcast2 => /=; congr (_ :: _).
      apply: eq_tcast2 => /=; congr (_ ++ _).
      apply: eq_tcast2 => /=; congr (_ :: _).
      exact/esym/eq_tcast2.
    - apply eq_big.
      + move=> x /=.
        rewrite !inE ffunE.
        rewrite (_ : (_ \_ _) = i2) //=.
        rewrite enum_rank_ord /= tcastE !cast_ord_comp (tnth_nth i0) /=.
        rewrite (_ : tval (tcast Hq _) = i1 ++ i2 :: i3); last first.
          apply/esym/eq_tcast2 => /=; congr cat; exact/eq_tcast2.
        by rewrite -cat_cons nth_cat /= size_tuple prednK ?lt0n // ltnn subnn.
      + 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 (
  (\rsum_(j1 in {: i.-1.-tuple ('rV[A]_n)})
   \rsum_(j2 in {: (#|M| - i.+1).-tuple ('rV[A]_n)})
   \rprod_(i <- j1 ++ j2) (P `^ n) i) *
  (\rsum_(j0 in 'rV[A]_n)
    \rsum_(ji in 'rV[A]_n)
    ((P `^ n) j0) * ((P `^ n) ji) *
    (\rsum_( 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.d -lock /Wght.pmf /=; congr (_ * _)%R.
  transitivity (\rprod_( 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 (\rprod_(j < #|@predT M|)
    P `^ _ ([ffun x => (tcast Hcast [tuple of j0 :: j1 ++ j3 :: j2])\_(enum_rank x)] (enum_val j)))%R.
    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 (\rsum_(j0 : 'rV[A]_n) \rsum_(ji : 'rV[A]_n)
  ((P `^ n) j0) * ((P `^ n) ji) * (\rsum_( 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 := \rsum_(_ <- _) _.
  suff : lhs = 1%R by move=> ->; rewrite mul1R.
  rewrite /lhs {lhs}.
  rewrite (@big_cat_tuple_seq _ i.-1 (#|M| - i.+1) (fun x => \rprod_(i0 <- x) (P `^ n) i0))%R.
  by rewrite rsum_rmul_tuple_pmf.
transitivity (\rsum_(ji : 'rV[A]_n) ((P `^ n) ji) *
  (\rsum_(y | y \in [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0])
  \rsum_(j0 : 'rV[A]_n) ((W ``(| j0) ) y) * ((P `^ n) j0)))%R.
  rewrite exchange_big /=.
  apply eq_bigr => ta _.
  transitivity (\rsum_(i1 : 'rV[A]_n) P `^ _ ta * P `^ _ i1 *
    (\rsum_(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 (\rsum_(ji : 'rV[A]_n) ((P `^ n) ji) *
  \rsum_( 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 _.
  rewrite -tuple_pmf_out_dist.
  apply eq_bigr => i0 _; by rewrite DMCE.
transitivity (\rsum_(ji : 'rV[A]_n)
  (\rsum_( y | y \in
    [set y0 | prod_rV (ji , y0) \in `JTS P W n epsilon0])
    ((P `^ n) `x ((`O(P , W)) `^ n)) (ji, y))).
  apply eq_bigr => // i0 _; by rewrite /= big_distrr.
transitivity (\rsum_( jiy | prod_rV jiy \in `JTS P W n epsilon0)
  ((P `^ n) `x ((`O(P , W)) `^ n)) jiy).
  rewrite [in LHS]pair_big_dep /=.
  apply eq_big => //.
  case=> ? ?; by rewrite !inE.
apply eq_bigl => tab; by 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 inE {1}/Cal_E {1}/cal_E 2!inE.
    apply/orP; left.
    case/andP : Hm2 => _.
    move/forallP/(_ ord0).
    rewrite /set_jtyp_seq inE.
    move/implyP => -> //.
    apply/eqP => ?; by subst m2.
  + move=> _.
    rewrite inE.
    move/negbT : {Hm2}(Hm2 ord0).
    rewrite negb_and.
    case/orP => Hm2.
    * rewrite {1}/Cal_E {1}/cal_E 2!inE.
      by apply/orP; left.
    * 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_ => //.
      rewrite !inE in Hm2.
      by rewrite /Cal_E !inE.
- rewrite inE ffunE.
  case: (pickP _) => [m2 Hm2 | Hm2 //].
  case/orP => Hy.
  + rewrite inE /cal_E inE in Hy.
    case/andP : Hm2 => Hm2 _.
    apply/eqP. case => ?; subst m2.
    by rewrite Hm2 in Hy.
  + apply/eqP. case => ?; subst m2.
    case/andP : Hm2 => _ /forallP Hm2.
    case/bigcupP : Hy => m Hm m_tb.
    rewrite /cal_E inE inE in m_tb.
    move: {Hm2}(Hm2 m).
    by rewrite !inE m_tb Hm.
Qed.

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| = Z.abs_nat (Int_part (exp2 (INR n * r))) /\
  let Jtdec := jtdec P W epsilon0 in
  \rsum_(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 (Z.abs_nat k).-1.
  rewrite prednK; last first.
    apply/ltP/INR_lt.
    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| *
  \rsum_(f : encT A M n) Wght.d P f * (\rsum_(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 < _](_ : _ = (\rsum_(f : encT A M n) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0)%R); last first.
  transitivity (1 / INR #|M| *
    \rsum_(f : encT A M n) (\rsum_(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| * \rsum_(f : encT A M n)
    (\rsum_( m_ in M ) Wght.d P f * (e(W, mkCode f (Jtdec f))) ord0))%R.
    congr (_ * _)%R.
    apply/esym.
    rewrite 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
(\rsum_(f : encT A M n) Wght.d P f * Pr (W ``(| f ord0)) (~: Cal_E f ord0) +
  \rsum_(i | i != ord0)
  \rsum_(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_rsum => /= i _.
  rewrite -big_distrr /= -mulRDr.
  apply leR_wpmul2l; first exact: (dist_ge0 (Wght.d P)).
  rewrite [X in X <= _](_ : _ = Pr (W ``(| i ord0))
    (~: Cal_E i ord0 :|: \bigcup_(i0 : M | i0 != ord0) Cal_E i i0)); last first.
    apply Pr_ext; 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 := \rsum_(_ < _ | _) _.
have -> : lhs = (INR #| M |.-1 * Pr ((P `^ n) `x ((`O(P , W)) `^ n)) [set x | prod_rV x \in `JTS P W n epsilon0])%R.
  rewrite {}/lhs.
  rewrite [RHS](_ : _ = \rsum_(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.
    do 2 f_equal.
    rewrite card_ord /=.
    transitivity (#| setT :\ (@ord0 k)|).
      move: (cardsD1 (@ord0 k) setT) => /=.
      rewrite !cardsT !card_ord inE /= add1n.
      case=> H1; by rewrite {1}H1.
    rewrite cardsE.
    apply eq_card => m_.
    by rewrite -!topredE /= !in_set andbC.
    apply eq_big => //; by apply: second_summand.
rewrite card_ord /=.
apply (@leR_ltR_trans (epsilon0 + INR k *
   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.
  have : forall a b, a >= 1 - b -> 1 - a <= b by move=> *; fourier.
  apply.
  apply JTS_1 => //.
  rewrite /epsilon0_condition in Hepsilon0; tauto.
  by case: Hn => _ [_ []].
apply (@leR_ltR_trans (epsilon0 + INR #| M | * exp2 (- INR n * (`I( P ; W ) - 3 * epsilon0)))%R).
  apply/leR_add2l/leR_pmul.
    rewrite (_ : 0 = INR 0)%R //; exact/le_INR/leP.
    exact: le_0_Pr.
    apply/le_INR/leP; by rewrite card_ord.
    exact: non_typical_sequences.
apply (@ltR_trans (epsilon0 + epsilon0)%R); last first.
  case: Hepsilon0 => ? [? ?]; fourier.
apply ltR_add2l.
have -> : INR #| M | = exp2 (log (INR #| M |)).
  rewrite logK // (_ : 0 = INR 0)%R //.
  apply lt_INR. rewrite card_ord. by apply/ltP.
rewrite -ExpD.
rewrite (_ : _ + _ = - INR n * (`I(P ; W) - log (INR #| M |) / INR n - 3 * epsilon0))%R; last first.
  field.
  apply/eqP; rewrite INR_eq0' gtn_eqF //; by case: Hn.
rewrite (_ : _ / _ = r)%R; last by rewrite -Hk card_ord.
apply (@ltR_trans (exp2 (- INR n * 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 by fourier.
    rewrite mulRCA mulRV ?mulR1 in Hepsilon0; last exact/eqP.
    clear Hk; fourier.
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.
      apply/eqP/gtR_eqF; by case: Hepsilon0.
    rewrite logK; [exact/leRR | by case: Hepsilon0].
Qed.

End random_coding_good_code_existence.

Section channel_coding_theorem.

Variables A B : finType.
Variable W : `Ch_1(A, B).
Variable cap : R.
Hypothesis Hc : capacity W cap.

(** Channel Coding Theorem (direct part) *)

Theorem channel_coding (r : CodeRateType) : r < cap ->
  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 : dist A, r < `I(P ; W).
  case: Hc => H1 H2.
  apply NNPP => abs.
  have {abs}abs : forall P : dist A, `I(P ; W) <= r.
    move/not_ex_all_not in abs.
    move=> P; exact/Rnot_lt_le/abs.
  have Hcap : cap <= r by apply/H2 => P; exact/abs.
  fourier.
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 Htmp : 0 < Rmin (epsilon / 2) (((`I(P ; W) - r) / 4)).
    apply Rmin_pos; apply mulR_gt0 => //; fourier.
  split.
    apply mulR_gt0 => //; fourier.
  split; [exact/(ltR_leR_trans (Rlt_eps2_eps _ Htmp))/geR_minl |
          exact/(ltR_leR_trans (Rlt_eps2_eps _ Htmp))/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 (Z.abs_nat (up (aep_bound P (epsilon0 / 3))))
    (maxn (Z.abs_nat (up (aep_bound (`O(P , W)) (epsilon0 / 3))))
          (Z.abs_nat (up (aep_bound (`J(P , W)) (epsilon0 / 3))))) <= n)%nat.
    set supermax := maxn 1
      (maxn (Z.abs_nat (up (- log epsilon0 / epsilon0)))
      (maxn (Z.abs_nat (up (aep_bound P (epsilon0 / 3))))
      (maxn (Z.abs_nat (up (aep_bound (`O(P , W)) (epsilon0 / 3))))
            (Z.abs_nat (up (aep_bound (`J(P , 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=> ?; fourier.
      apply (@leR_trans (INR (Z.abs_nat (up (- log epsilon0 / epsilon0))))).
        case: (Z_lt_le_dec (up (- log epsilon0 / epsilon0)) 0) => H1.
          apply (@leR_trans 0); [exact/IZR_le/Zlt_le_weak | exact: leR0n].
        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.
    intuition.
    congruence.
  split.
    apply/(@leq_trans n1) => //; tauto.
  split.
    apply (@ltR_leR_trans (INR n1)); [tauto | exact/le_INR/leP].
  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_pos.
suff Htmp : IZR (Int_part (exp2 (INR n * r))) = exp2 (INR n * r).
  rewrite Htmp exp2K /Rdiv -mulRA mulRCA mulRV ?INR_eq0' -?lt0n ?mulR1 //; by case: Hn.
apply frac_Int_part; by case: Hn => _ [_ []].
Qed.

End channel_coding_theorem.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                  Pol2.v                                  *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

           (* Preuve de terminaison: polynome P2 *)

Require Import Le.
Require Import Lt.
Require Import Plus.
Require Import Gt.
Require Import Minus.
Require Import Mult.
Require Import TS.
Require Import sigma_lift.
Require Import comparith.

Definition e_P2 (b : wsort) (U : TS b) : nat :=
  (fix F (w : wsort) (t : TS w) {struct t} : nat :=
     match t with
     | var _ => 1
     | app t0 t1 => S (F wt t0 + F wt t1)
     | lambda t0 => 2 * F wt t0
     | env t0 t1 => F wt t0 * S (F ws t1)
     | id => 1
     | shift => 1
     | cons t0 t1 => S (F wt t0 + F ws t1)
     | comp t0 t1 => F ws t0 * S (F ws t1)
     | lift t0 => 4 * F ws t0
     | meta_X _ => 1
     | meta_x _ => 1
     end) b U.
(* var *)
(* app *)
(* lam *)
(* env *)
(*  id *)
(*  |  *)
(*  .  *)
(*  o  *)
(*  || *)
(*  X  *)
(*  x  *)

Notation P2 := (e_P2 _) (only parsing).
(* <Warning> : Syntax is discontinued *)

Theorem P2_pos : forall (b : wsort) (M : TS b), e_P2 _ M > 0.
Proof.
simple induction M; simpl in |- *; intros; auto with arith.
Qed.
Hint Resolve P2_pos.

Theorem P2_app : forall M N : terms, reg_app M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; elim Mult.mult_plus_distr_r;
 auto with arith.
Qed.
Hint Resolve P2_app.

Theorem P2_lambda : forall M N : terms, reg_lambda M N -> e_P2 _ M < e_P2 _ N.
Proof.
simple induction 1; intros.
change (2 * (e_P2 _ a * S (4 * e_P2 _ s)) > 2 * e_P2 _ a * S (e_P2 _ s))
 in |- *.
elim mult_assoc_reverse; auto with arith.
Qed.
Hint Resolve P2_lambda.

Theorem P2_clos : forall M N : terms, reg_clos M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *.
elim mult_assoc_l; apply gt_mult_reg_l.
auto with arith.
simpl in |- *; auto with arith.
Qed.
Hint Resolve P2_clos.

Theorem P2_varshift1 :
 forall M N : terms, reg_varshift1 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; simpl in |- *; auto with arith.
Qed.
Hint Resolve P2_varshift1.

Theorem P2_varshift2 :
 forall M N : terms, reg_varshift2 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; repeat elim plus_n_O;
 auto with arith.
Qed.
Hint Resolve P2_varshift2.

Theorem P2_fvarcons :
 forall M N : terms, reg_fvarcons M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; elim plus_n_O; auto with arith.
Qed.
Hint Resolve P2_fvarcons.

Theorem P2_fvarlift1 :
 forall M N : terms, reg_fvarlift1 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros.
change (1 * S (4 * e_P2 _ s) > 1) in |- *.
auto with arith.
Qed.
Hint Resolve P2_fvarlift1.

Theorem P2_fvarlift2 :
 forall M N : terms, reg_fvarlift2 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; repeat elim plus_n_O;
 auto with arith.
Qed.
Hint Resolve P2_fvarlift2.

Theorem P2_rvarcons :
 forall M N : terms, reg_rvarcons M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; repeat elim plus_n_O;
 auto with arith.
Qed.
Hint Resolve P2_rvarcons.

Theorem P2_rvarlift1 :
 forall M N : terms, reg_rvarlift1 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; repeat elim plus_n_O.
elim mult_n_2; auto with arith.
Qed.
Hint Resolve P2_rvarlift1.

Theorem P2_rvarlift2 :
 forall M N : terms, reg_rvarlift2 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros.
change
  (1 * S (4 * e_P2 _ s * S (e_P2 _ t)) >
   1 * S (e_P2 _ s * S (1 * S (e_P2 _ t)))) in |- *.
unfold mult at 1 in |- *; unfold mult at 3 in |- *; unfold mult at 4 in |- *;
 repeat elim plus_n_O.
apply gt_n_S; repeat elim mult_n_Sm; elim plus_assoc.
apply gt_plus_plus.
elim mult_assoc_l; auto with arith.
elim mult_n_2; elim mult_sym; auto with arith.
Qed.
Hint Resolve P2_rvarlift2.

Theorem P2_assenv :
 forall M N : sub_explicits, reg_assenv M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *.
rewrite mult_assoc_reverse; simpl in |- *; auto with arith.
Qed.
Hint Resolve P2_assenv.

Theorem P2_mapenv :
 forall M N : sub_explicits, reg_mapenv M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; elim Mult.mult_plus_distr_r;
 auto with arith.
Qed.
Hint Resolve P2_mapenv.

Theorem P2_shiftcons :
 forall M N : sub_explicits, reg_shiftcons M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; elim plus_n_O; auto with arith.
Qed.
Hint Resolve P2_shiftcons.

Theorem P2_shiftlift1 :
 forall M N : sub_explicits, reg_shiftlift1 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros.
change (1 * S (4 * e_P2 _ s) > e_P2 _ s * 2) in |- *.
unfold mult at 1 in |- *; elim plus_n_O.
apply gt_S_l; elim mult_sym; auto with arith.
Qed.
Hint Resolve P2_shiftlift1.

Theorem P2_shiftlift2 :
 forall M N : sub_explicits, reg_shiftlift2 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros.
change
  (1 * S (4 * e_P2 _ s * S (e_P2 _ t)) > e_P2 _ s * S (1 * S (e_P2 _ t)))
 in |- *.
unfold mult at 1 in |- *; elim plus_n_O; unfold mult at 4 in |- *;
 elim plus_n_O.
apply gt_S_l; repeat elim mult_n_Sm; elim plus_assoc.
apply gt_plus_plus.
elim mult_assoc_l; auto with arith.
elim mult_n_2; elim mult_sym; auto with arith.
Qed.
Hint Resolve P2_shiftlift2.

Theorem P2_lift1 :
 forall M N : sub_explicits, reg_lift1 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros.
change (4 * e_P2 _ s * S (4 * e_P2 _ t) > 4 * (e_P2 _ s * S (e_P2 _ t)))
 in |- *.
elim mult_assoc_reverse; auto with arith.
Qed.
Hint Resolve P2_lift1.

Theorem P2_lift2 :
 forall M N : sub_explicits, reg_lift2 M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros.
change
  (4 * e_P2 _ s * S (4 * e_P2 _ t * S (e_P2 _ u)) >
   4 * (e_P2 _ s * S (e_P2 _ t)) * S (e_P2 _ u)) in |- *.
elim mult_assoc_reverse;
 elim (mult_assoc_l (4 * e_P2 _ s) (S (e_P2 _ t)) (S (e_P2 _ u)));
 apply gt_mult_reg_l.
auto with arith.
apply gt_S_l; apply gt_mult_reg_r.
auto with arith.
apply gt_trans with (3 * e_P2 _ t).
auto with arith.
simpl in |- *; elim plus_n_O; rewrite S_plus; apply plus_gt_compat_l.
elim mult_n_2; auto with arith.
Qed.
Hint Resolve P2_lift2.

Theorem P2_liftenv :
 forall M N : sub_explicits, reg_liftenv M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros.
change
  (4 * e_P2 _ s * S (S (e_P2 _ a + e_P2 _ t)) >
   S (e_P2 _ a + e_P2 _ s * S (e_P2 _ t))) in |- *.
cut (S (S (e_P2 _ a + e_P2 _ t)) = e_P2 _ a + (e_P2 _ t + 2)).
intro H1; rewrite H1.
rewrite (S_plus (e_P2 _ a + e_P2 _ s * S (e_P2 _ t)));
 rewrite comparith.mult_plus_distr_r.
elim plus_assoc; apply gt_plus_plus.
apply gt_mult_l.
auto with arith.
auto with arith.
replace (e_P2 _ t + 2) with (e_P2 _ t + 1 + 1).
rewrite comparith.mult_plus_distr_r; apply gt_plus_plus.
elim S_plus; elim mult_assoc_l.
apply gt_mult_l; auto with arith.
apply gt_mult_l; auto with arith.
elim (plus_n_Sm (e_P2 _ t) 1); auto with arith.
rewrite plus_assoc; elim plus_n_Sm; elim plus_n_Sm; elim plus_n_O;
 auto with arith.
Qed.
Hint Resolve P2_liftenv.

Theorem P2_idl :
 forall M N : sub_explicits, reg_idl M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; simpl in |- *; intros; elim plus_n_O; auto with arith.
Qed.
Hint Resolve P2_idl.

Theorem P2_idr :
 forall M N : sub_explicits, reg_idr M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; auto with arith.
Qed.
Hint Resolve P2_idr.

Theorem P2_liftid :
 forall M N : sub_explicits, reg_liftid M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; auto with arith.
Qed.
Hint Resolve P2_liftid.

Theorem P2_id : forall M N : terms, reg_id M N -> e_P2 _ M > e_P2 _ N.
Proof.
simple induction 1; intros; simpl in |- *; auto with arith.
Qed.
Hint Resolve P2_id.


(*
  vim: filetype=coq
*)
(*
Copyright (C) 2016-2018 Philip H. Smith

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.
*)

Require Import Way.Tactics.

Open Scope list_scope.

Notation " [ ] " := nil (format "[ ]") : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; y ; .. ; z ] " := (cons x (cons y .. (cons z nil) ..)) : list_scope.

(* Right fold *)
Fixpoint fold {A B : Type} (f : A -> B -> B) (b : B) (l : list A) {struct l} : B :=
  match l with
  | [] => b
  | a :: t => f a (fold f b t)
  end.

Module FoldExamples.

Example plus_over_triple : fold plus 0 [3; 1; 4] = 8.
Proof.
  infer.
Defined.

Example cons_over_triple : fold (@cons nat) nil [3; 1; 4] = [3; 1; 4].
Proof.
  infer.
Defined.

End FoldExamples.

Lemma unfold : forall {A B : Type} (f : A -> B -> B) (b : B) (a : A) (t : list A),
  fold f b (a :: t) = f a (fold f b t).
Proof.
  infer.
Defined.

Definition map {A B : Type} (f : A -> B) (l : list A) : list B :=
  fold (fun e t => (f e) :: t) [] l.

Module MapExamples.

Example successor_over_triple : map S [3; 1; 4] = [4; 2; 5].
Proof.
  infer.
Defined.

End MapExamples.

Definition has {A : Type} (a : A) (l : list A) : Prop :=
  fold (fun e acc => e = a \/ acc) False l.

Hint Unfold has : way.

Module HasExamples.

Example a_zero_in_pair : has 0 [2; 7] = (2 = 0 \/ 7 = 0 \/ False).
Proof.
  infer.
Defined.

End HasExamples.

Lemma intro_has_singleton :
  forall {A : Type} (a b : A), b = a -> has a [b].
Proof.
  infer.
Defined.

Hint Resolve intro_has_singleton : way.

Lemma elim_has_singleton :
  forall {A : Type} (a b : A), has a [b] -> b = a.
Proof.
  infer.
Defined.

Hint Extern 7 => match goal with
| [ H : has ?a [?b] |- _ ] => pose proof (elim_has_singleton a b H)
end : way.

Lemma intro_not_has_singleton :
  forall {A : Type} (a b : A), b <> a -> ~ has a [b].
Proof.
  infer.
Defined.

Hint Resolve intro_not_has_singleton : way.

Lemma elim_not_has_singleton :
  forall {A : Type} (a b : A), ~ has a [b] -> b <> a.
Proof.
  infer.
Defined.

Hint Extern 7 => match goal with
| [ H : ~ has ?a [?b] |- _ ] => pose proof (elim_not_has_singleton a b H)
end : way.

Lemma intro_has_cons :
  forall {A : Type} (a b : A) (l : list A), b = a \/ has a l -> has a (b :: l).
Proof.
  infer.
Defined.

Hint Resolve intro_has_cons : way.

Lemma elim_has_cons :
  forall {A : Type} (a b : A) (l : list A), has a (b :: l) -> b = a \/ has a l.
Proof.
  infer.
Defined.

Hint Extern 7 => match goal with
| [ H : has ?a (?b :: ?l) |- _ ] => pose proof (elim_has_cons a b l H)
end : way.

Lemma intro_not_has_cons :
  forall {A : Type} (a b : A) (l : list A), b <> a /\ ~ has a l -> ~ has a (b :: l).
Proof.
  infer.
Defined.

Hint Resolve intro_not_has_cons : way.

Lemma elim_not_has_cons :
  forall {A : Type} (a b : A) (l : list A), ~ has a (b :: l) -> b <> a /\ ~ has a l.
Proof.
  infer.
Defined.

Hint Extern 7 => match goal with
| [ H : ~ has ?a (?b :: ?l) |- _ ] => pose proof (elim_not_has_cons a b l H)
end : way.

Lemma intro_has_append :
  forall {A : Type} (a : A) (l m : list A), has a l \/ has a m -> has a (m ++ l).
Proof.
  induction m; infer.
Defined.

Hint Resolve intro_has_append : way.

Lemma elim_has_append :
  forall {A : Type} (a : A) (l m : list A), has a (m ++ l) -> has a l \/ has a m.
Proof.
  induction m; infer.
Defined.

Hint Extern 7 => match goal with
| [ H : has ?a (?m ++ ?l) |- _ ] => pose proof (elim_has_append a l m H)
end : way.

Lemma intro_not_has_append :
  forall {A : Type} (a : A) (l m : list A), ~ has a l /\ ~ has a m -> ~ has a (l ++ m).
Proof.
  infer.
Defined.

Hint Resolve intro_not_has_append : way.

Lemma elim_not_has_append :
  forall {A : Type} (a : A) (l m : list A), ~ has a (l ++ m) -> ~ has a l /\ ~ has a m.
Proof.
  infer.
Defined.

Hint Extern 7 => match goal with
| [ H : ~ has ?a (?l ++ ?m) |- _ ] => pose proof (elim_not_has_append a l m H)
end : way.

Lemma elim_not_has_append2 :
  forall {A : Type} (a : A) (l m n : list A),
  ~ has a (l ++ m ++ n) -> ~ has a l /\ ~ has a m /\ ~ has a n.
Proof.
  infer.
Defined.

Hint Extern 7 => match goal with
| [ H : ~ has ?a (?l ++ ?m ++ ?n) |- _ ] => pose proof (elim_not_has_append2 a l m n H)
end : way.


Require Import Coq.Lists.List.
Import ListNotations.

Require Export Parser.Structures.
Require Export Parser.Option.
Require Export Parser.List.
Require Export Parser.DescriptionInd.
Require Export Parser.CommonRules.
Require Export Parser.NullableFun.
Require Export Parser.ProductiveFun.
Require Export Parser.FirstFun.

Open Scope bool_scope.

Search in_dec.

Definition should_not_follow_descr (k: token_class): Description (fun A => unit) := {|
  epsilon_descr := fun A a => [];
  failure_descr := fun A => [];
  token_descr := fun k' => [];
  map_descr := fun _ _ _ _ _ => [ @id_rule unit ];
  disj_descr := fun _ s1 s2 =>
    [ disj_rule ] ++
    when_opt (nullable_fun s2) (when_sum (in_dec kind_eq_dec k (first_fun s1)) [ some_rule tt ])  ++
    when_opt (nullable_fun s1) (when_sum (in_dec kind_eq_dec k (first_fun s2)) [ some_rule tt ]);
  seq_descr :=
    fun _ _ s1 s2 =>
      when_opt (nullable_fun s2) [ left_rule ] ++
      when (productive_fun s1) [ right_rule ];
  var_descr := fun _ _ => [ @id_rule unit ];
|}.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m765_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m765_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e521m1_19limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import HoTT.
From HoTT.Categories Require Import Category Functor NaturalTransformation.
Require Import GR.bicategories.bicategories.
Require Import GR.bicategories.lax_functors.
Require Import GR.bicategories.lax_transformations.
Require Import GR.bicategories.modifications.
Require Import GR.bicategories.biadjunction.biadjunction.
From GR.groupoid Require Import
     groupoid_quotient.gquot
     groupoid_quotient.gquot_functor
     groupoid_quotient.gquot_principles
     grpd_bicategory.grpd_bicategory
     path_groupoid.path_groupoid
     adjunction.unit
     adjunction.counit.
From GR.basics Require Import
     general.

Section BiAdjunction.
  Context `{Univalence}.

  Definition gquot_biadjunction_d
    : BiAdjunction_d grpd one_types
    := Build_BiAdjunction_d
         gquot_functor
         _
         path_groupoid_functor
         _
         unit_gq
         counit_gq.

  Definition gquot_triangle_l_map_help
             {G : groupoid}
             {a₁ a₂ : G}
             (g : G a₁ a₂)
    : path_over
        (fun h : gquot G =>
           counit_map (gquot_functor_obj G) (gquot_functor_map (unit_map G) h)
           = h)
        (gcleq G g)
        1%path
        1%path.
  Proof.
    apply map_path_over ; apply path_to_square.
    rewrite ap_idmap.
    rewrite ap_compose.
    rewrite !gquot_rec_beta_gcleq.
    rewrite concat_1p, concat_p1.
    reflexivity.
  Qed.

  Definition gquot_triangle_l_map (G : grpd)
    : forall x : gquot G,
      counit_map (gquot_functor_obj G) (gquot_functor_map (unit_map G) x) = x.
  Proof.
    simple refine (gquot_ind_set _ _ _ _).
    - reflexivity.
    - intros.
      apply gquot_triangle_l_map_help.
  Defined.

  Definition gquot_triangle_l_d
    : Modification_d
        (triangle_l_lhs gquot_biadjunction_d)
        (identity_transformation gquot_functor).
  Proof.
    intros G ; cbn.
    funext x ; revert x ; simpl.
    apply gquot_triangle_l_map.
  Defined.

  Definition gquot_triangle_l_is_modification
    : is_modification gquot_triangle_l_d.
  Proof.
    intros G₁ G₂ F.
    cbn.
    rewrite !concat_1p, !concat_p1.
    rewrite <- !path_forall_pp.
    f_ap.
    refine (path_forall _ _ _).
    simple refine (gquot_ind_prop _ _ _).
    intros a ; simpl.
    rewrite !concat_1p, !ap10_path_forall.
    rewrite ap_idmap, !concat_1p.
    unfold gquot_triangle_l_map ; simpl.
    rewrite !concat_p1.
    rewrite gquot_rec_beta_gcleq.
    reflexivity.
  Qed.

  Definition gquot_triangle_l_modification
    : Modification
        (triangle_l_lhs gquot_biadjunction_d)
        (identity_transformation gquot_functor)
    := Build_Modification gquot_triangle_l_d gquot_triangle_l_is_modification.

  Definition gquot_triangle_l_is_iso
    : iso_modification gquot_triangle_l_modification.
  Proof.
    intros X ; cbn.
    apply one_types_is_21.
  Defined.

  Definition gquot_triangle_l
    : IsoModification
        (triangle_l_lhs gquot_biadjunction_d)
        (identity_transformation gquot_functor).
  Proof.
    make_iso_modification.
    - exact gquot_triangle_l_modification.
    - exact gquot_triangle_l_is_iso.
  Defined.

  Definition gquot_triangle_r_d
    : Modification_d
        (triangle_r_lhs gquot_biadjunction_d)
        (identity_transformation path_groupoid_functor).
  Proof.
    intros A ; simpl.
    simple refine (Build_NaturalTransformation _ _ _ _).
    - reflexivity.
    - intros F G α ; cbn in *.
      refine (concat_p1 _ @ _ @ (concat_1p _)^).
      exact (gquot_rec_beta_gcleq _ _ _ _ _ _ _ _ _ _).
  Defined.

  Definition gquot_triangle_r_is_modification
    : is_modification gquot_triangle_r_d.
  Proof.
    intros A B f.
    apply path_natural_transformation.
    intros x.
    cbn.
    rewrite ge, !concat_1p.
    rewrite !ap10_path_forall ; simpl.
    rewrite !ge ; simpl.
    reflexivity.
  Qed.

  Definition gquot_triangle_r_modification
    : Modification
        (triangle_r_lhs gquot_biadjunction_d)
        (identity_transformation path_groupoid_functor)
    := Build_Modification gquot_triangle_r_d gquot_triangle_r_is_modification.

  Global Instance gquot_triangle_r_is_iso
    : iso_modification gquot_triangle_r_modification.
  Proof.
    intros A ; simpl.
    unfold gquot_triangle_r_d ; simpl.
    apply _.
  Defined.

  Definition gquot_triangle_r
    : IsoModification
        (triangle_r_lhs gquot_biadjunction_d)
        (identity_transformation path_groupoid_functor).
  Proof.
    make_iso_modification.
    - exact gquot_triangle_r_modification.
    - exact gquot_triangle_r_is_iso.
  Defined.

  Definition gquot_is_biadjunction
    : is_biadjunction gquot_biadjunction_d
    := Build_is_biadjunction _ _ gquot_triangle_l gquot_triangle_r.

  Definition gquot_biadjunction
    : BiAdjunction grpd one_types
    := Build_BiAdjunction gquot_biadjunction_d gquot_is_biadjunction.
End BiAdjunction.


Require Import Coq.Classes.Morphisms
        Coq.Classes.SetoidTactics.
Require Import Fiat.Computation.

Section FueledFix.
  (* A bounded recursion operation for the Comp Monad. *)

  Variable A : Type. (* Argument Type *)
  Variable R : Type. (* Return Type *)

  Fixpoint FueledFix
           (fuel : nat)
           (base : Comp R)
           (body : (A -> Comp R) -> A -> Comp R)
           (arg : A)
  : Comp R :=
    match fuel with
      | O => base
      | S fuel' => body (FueledFix fuel' base body) arg
    end.
End FueledFix.

(* Can't rewrite under Fueled Fix at the moment,
as the condition on the body is not a proper relation. :p *)

(* Notation for our fueled fix function. *)
Notation "'Repeat' fuel 'initializing' a 'with' arg 'defaulting' rec 'with' base {{ bod }} " :=
  (FueledFix fuel base (fun rec a => bod) arg)
    (no associativity, at level 50,
     format "'Repeat' '[hv'  fuel  '/' 'initializing'  a  'with'  arg '/'  'defaulting'  rec  'with'  base  '/' {{ bod  }} ']' ").

Section FueledFixRefinements.
  (* TODO: Find a home for these refinements in the Computation folder. *)

  Variable A : Type. (* Argument Type *)
  Variable R : Type. (* Return Type *)

  (* Lemmas for refining FueledFix. *)

  (* Lemma refine_FueledFix_Bind (B : Type) :
    forall fuel body body' (base base' : Comp R) (arg : A) (k k' : R -> Comp B),
      refine base base'
      -> (forall a, refine (body a) (body' a))
      -> (forall r, refine (k r) (k' r))
      ->  refine (a <- FueledFix fuel base body arg; k a)
                 (a <- FueledFix fuel base body' arg; k' a).
  Proof.
    induction fuel; eauto.
  Qed. *)

Definition pointwise_refine
  (f g : (A -> Comp R) -> A -> Comp R) :=
  forall (rec rec' : A -> Comp R) (a : A),
    pointwise_relation A (@refine R) rec rec'
    -> refine (f rec a) (g rec' a).

Lemma transitive_pR :
  Transitive (pointwise_refine).
Proof.
  unfold Transitive, pointwise_refine, pointwise_relation; intros.
  etransitivity.
  apply H; eauto.
  apply H0. reflexivity.
Qed.

Add Parametric Morphism i
  : (@FueledFix A R i)
    with signature
    ((@refine R)
       ==> (pointwise_refine)
       ==> (@eq A)
       ==> (@refine R))
      as refineFix.
Proof.
  simpl; induction i; intros; simpl.
  - assumption.
  - unfold pointwise_refine, pointwise_relation, Proper, respectful in *.
    eapply H0.
    intros.
    generalize (IHi _ _ H _ _ H0 a); eauto.
Qed.

(* This is the main lemma for Fueled Fix, as we cannot use *)
(* setoid_rewriting because pointwise refine isn't a proper *)
(* relation (it's not reflexive). *)
Definition refineFueledFix
  : forall (fuel : nat)
           (base base' : Comp R)
           (body body' : (A -> Comp R) -> A -> Comp R)
           (arg : A),
    refine base base'
    -> (forall a bod bod',
           (forall a, refine (bod a) (bod' a))
           -> refine (body bod a) (body' bod' a))
    -> refine (FueledFix fuel base body arg)
           (FueledFix fuel base' body' arg).
Proof.
  intros; eapply refineFix; intros; eauto.
  intro; intros.
  eapply H0; apply H1.
Qed.

End FueledFixRefinements.


Require Export Iron.Language.SimpleData.Base.

(* Type Constructors *)
Inductive tycon : Type :=
 | TyConData   : nat -> tycon.
Hint Constructors tycon.

Fixpoint tycon_beq t1 t2 :=
  match t1, t2 with
  | TyConData n1, TyConData n2 => beq_nat n1 n2
  end.

(* Types *)
Inductive ty : Type :=
 | TCon   : tycon -> ty
 | TFun   : ty    -> ty -> ty.
Hint Constructors ty.

(* Type Environment *)
Definition tyenv := list ty.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*                Xavier Leroy, INRIA Paris                            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** This library provides type classes and tactics to decide logical
  propositions by reflection into computable Boolean equalities.
  It extends the [DecidableClass] module from the standard library
  of Coq 8.5 with more instances of decidable properties, including
  universal and existential quantification over finite types. *)

(** Temporarily and for compatibility with Coq 8.4, this file includes
  a copy of the relevant definitions from the Coq 8.5 [DecidableClass]
  library.  This library is copyright INRIA. *)

Require Import Coqlib.

Class Decidable (P : Prop) := {
  Decidable_witness : bool;
  Decidable_spec : Decidable_witness = true <-> P
}.

Lemma Decidable_sound : forall P (H : Decidable P),
  Decidable_witness = true -> P.
Proof.
  intros. rewrite <- Decidable_spec. auto.
Qed.

Lemma Decidable_complete : forall P (H : Decidable P),
  P -> Decidable_witness = true.
Proof.
  intros. rewrite Decidable_spec. auto.
Qed.

Lemma Decidable_sound_alt : forall P (H : Decidable P),
   ~ P -> Decidable_witness = false.
Proof.
  intros. destruct Decidable_witness eqn:E; auto. elim H0. eapply Decidable_sound; eauto.
Qed.

Lemma Decidable_complete_alt : forall P (H : Decidable P),
  Decidable_witness = false -> ~ P.
Proof.
  intros; red; intros. rewrite (Decidable_complete P H) in H0 by auto. discriminate.
Qed.

Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H).

Ltac _decide_ P H :=
  let b := fresh "b" in
  set (b := decide P) in *;
  assert (H : decide P = b) by reflexivity;
  clearbody b;
  destruct b; [apply Decidable_sound in H|apply Decidable_complete_alt in H].

Tactic Notation "decide" constr(P) "as" ident(H) :=
  _decide_ P H.

Tactic Notation "decide" constr(P) :=
  let H := fresh "H" in _decide_ P H.

Ltac decide_goal := eapply Decidable_sound; reflexivity.

(** Deciding logical connectives *)

Program Instance Decidable_not (P: Prop) (dP: Decidable P) : Decidable (~ P) := {
  Decidable_witness := negb (@Decidable_witness P dP)
}.
Next Obligation.
  rewrite negb_true_iff. split. apply Decidable_complete_alt. apply Decidable_sound_alt.
Qed.

Program Instance Decidable_equiv (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P <-> Q) := {
  Decidable_witness := Bool.eqb (@Decidable_witness P dP) (@Decidable_witness Q dQ)
}.
Next Obligation.
  rewrite eqb_true_iff.
  split; intros.
  split; intros; eapply Decidable_sound; [rewrite <- H | rewrite H]; eapply Decidable_complete; eauto.
  destruct (@Decidable_witness Q dQ) eqn:D.
  eapply Decidable_complete; rewrite H; eapply Decidable_sound; eauto.
  eapply Decidable_sound_alt; rewrite H; eapply Decidable_complete_alt; eauto.
Qed.

Program Instance Decidable_and (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P /\ Q) := {
  Decidable_witness := @Decidable_witness P dP && @Decidable_witness Q dQ
}.
Next Obligation.
  rewrite andb_true_iff. rewrite ! Decidable_spec. tauto.
Qed.

Program Instance Decidable_or (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P \/ Q) := {
  Decidable_witness := @Decidable_witness P dP || @Decidable_witness Q dQ
}.
Next Obligation.
  rewrite orb_true_iff. rewrite ! Decidable_spec. tauto.
Qed.

Program Instance Decidable_implies (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P -> Q) := {
  Decidable_witness := if @Decidable_witness P dP then @Decidable_witness Q dQ else true
}.
Next Obligation.
  split.
- intros. rewrite Decidable_complete in H by auto. eapply Decidable_sound; eauto.
- intros. destruct (@Decidable_witness P dP) eqn:WP; auto.
  eapply Decidable_complete. apply H. eapply Decidable_sound; eauto.
Qed.

(** Deciding equalities. *)

Program Definition Decidable_eq {A: Type} (eqdec: forall (x y: A), {x=y} + {x<>y}) (x y: A) : Decidable (eq x y) := {|
  Decidable_witness := proj_sumbool (eqdec x y)
|}.
Next Obligation.
  split; intros. InvBooleans. auto. subst y. apply dec_eq_true.
Qed.

Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := {
  Decidable_witness := Bool.eqb x y
}.
Next Obligation.
  apply eqb_true_iff.
Qed.

Program Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := {
  Decidable_witness := beq_nat x y
}.
Next Obligation.
  apply beq_nat_true_iff.
Qed.

Program Instance Decidable_eq_positive : forall (x y : positive), Decidable (eq x y) := {
  Decidable_witness := Pos.eqb x y
}.
Next Obligation.
  apply Pos.eqb_eq.
Qed.

Program Instance Decidable_eq_Z : forall (x y : Z), Decidable (eq x y) := {
  Decidable_witness := Z.eqb x y
}.
Next Obligation.
  apply Z.eqb_eq.
Qed.

(** Deciding order on Z *)

Program Instance Decidable_le_Z : forall (x y: Z), Decidable (x <= y) := {
  Decidable_witness := Z.leb x y
}.
Next Obligation.
  apply Z.leb_le.
Qed.

Program Instance Decidable_lt_Z : forall (x y: Z), Decidable (x < y) := {
  Decidable_witness := Z.ltb x y
}.
Next Obligation.
  apply Z.ltb_lt.
Qed.

(** Deciding properties over lists *)

Program Instance Decidable_forall_in_list :
      forall (A: Type) (l: list A) (P: A -> Prop) (dP: forall x:A, Decidable (P x)),
      Decidable (forall x:A, In x l -> P x) := {
  Decidable_witness := List.forallb (fun x => @Decidable_witness (P x) (dP x)) l
}.
Next Obligation.
  rewrite List.forallb_forall. split; intros.
- eapply Decidable_sound; eauto.
- eapply Decidable_complete; eauto.
Qed.

Program Instance Decidable_exists_in_list :
      forall (A: Type) (l: list A) (P: A -> Prop) (dP: forall x:A, Decidable (P x)),
      Decidable (exists x:A, In x l /\ P x) := {
  Decidable_witness := List.existsb (fun x => @Decidable_witness (P x) (dP x)) l
}.
Next Obligation.
  rewrite List.existsb_exists. split.
- intros (x & U & V). exists x; split; auto. eapply Decidable_sound; eauto.
- intros (x & U & V). exists x; split; auto. eapply Decidable_complete; eauto.
Qed.

(** Types with finitely many elements. *)

Class Finite (T: Type) := {
  Finite_elements: list T;
  Finite_elements_spec: forall x:T, In x Finite_elements
}.

(** Deciding forall and exists quantification over finite types. *)

Program Instance Decidable_forall : forall (T: Type) (fT: Finite T) (P: T -> Prop) (dP: forall x:T, Decidable (P x)), Decidable (forall x, P x) := {
  Decidable_witness := List.forallb (fun x => @Decidable_witness (P x) (dP x)) (@Finite_elements T fT)
}.
Next Obligation.
  rewrite List.forallb_forall. split; intros.
- eapply Decidable_sound; eauto. apply H. apply Finite_elements_spec.
- eapply Decidable_complete; eauto.
Qed.

Program Instance Decidable_exists : forall (T: Type) (fT: Finite T) (P: T -> Prop) (dP: forall x:T, Decidable (P x)), Decidable (exists x, P x) := {
  Decidable_witness := List.existsb (fun x => @Decidable_witness (P x) (dP x)) (@Finite_elements T fT)
}.
Next Obligation.
  rewrite List.existsb_exists. split.
- intros (x & A & B). exists x. eapply Decidable_sound; eauto.
- intros (x & A). exists x; split. eapply Finite_elements_spec. eapply Decidable_complete; eauto.
Qed.

(** Some examples of finite types. *)

Program Instance Finite_bool : Finite bool := {
  Finite_elements := false :: true :: nil
}.
Next Obligation.
  destruct x; auto.
Qed.

Program Instance Finite_pair : forall (A B: Type) (fA: Finite A) (fB: Finite B), Finite (A * B) := {
  Finite_elements := list_prod (@Finite_elements A fA) (@Finite_elements B fB)
}.
Next Obligation.
  apply List.in_prod; eapply Finite_elements_spec.
Qed.

Program Instance Finite_option : forall (A: Type) (fA: Finite A), Finite (option A) := {
  Finite_elements := None :: List.map (@Some A) (@Finite_elements A fA)
}.
Next Obligation.
  destruct x; auto. right; apply List.in_map; eapply Finite_elements_spec.
Qed.