(* -------------------------------------------------------------------- *)
(* Copyright (c) - 2015--2016 - IMDEA Software Institute                *)
(* Copyright (c) - 2015--2018 - Inria                                   *)
(* Copyright (c) - 2016--2018 - Polytechnique                           *)

(* -------------------------------------------------------------------- *)
From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.classical Require Import boolp.
Require Import xfinmap ereal reals discrete realseq.
From mathcomp.classical Require Import classical_sets functions mathcomp_extra.
Require Import topology.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Unset SsrOldRewriteGoalsOrder.

Import Order.TTheory GRing.Theory Num.Theory.

Local Open Scope fset_scope.
Local Open Scope ring_scope.

(* -------------------------------------------------------------------- *)
Local Notation "\`| f |" := (fun x => `|f x|) (at level 2).
Local Notation simpm := Monoid.simpm.

(* -------------------------------------------------------------------- *)
Section Summable.
Variables (T : choiceType) (R : realType) (f : T -> R).

Definition summable := exists (M : R), forall (J : {fset T}),
  \sum_(x : J) `|f (val x)| <= M.

Lemma summableP : summable ->
  { M | 0 <= M & forall (J : {fset T}), \sum_(x : J) `|f (val x)| <= M }.
Proof.
move/asboolP/exists_asboolP=> h; have := (xchooseP h).
move: (xchoose _)=> {h} M /asboolP h; exists M => //.
by have := h fset0; rewrite big_pred0 // => -[x]; rewrite in_fset0.
Qed.
End Summable.

(* -------------------------------------------------------------------- *)
Section Sum.
Context {R : realType} {T : choiceType}.

Implicit Types f g : T -> R.

Definition fpos f := fun x => `|Num.max 0 (f x)|.
Definition fneg f := fun x => `|Num.min 0 (f x)|.

Lemma eq_fpos f g : f =1 g -> fpos f =1 fpos g.
Proof. by move=> eq_fg x; rewrite /fpos eq_fg. Qed.

Lemma eq_fneg f g : f =1 g -> fneg f =1 fneg g.
Proof. by move=> eq_fg x; rewrite /fneg eq_fg. Qed.

Lemma fpos0 x : fpos (fun _ : T => 0) x = 0 :> R.
Proof. by rewrite /fpos maxxx normr0. Qed.

Lemma fneg0 x : fneg (fun _ : T => 0) x = 0 :> R.
Proof. by rewrite /fneg minxx normr0. Qed.

Lemma fnegN f : fneg (- f) =1 fpos f.
Proof. by move=> x; rewrite /fpos /fneg -{1}oppr0 -oppr_max normrN. Qed.

Lemma fposN f : fpos (- f) =1 fneg f.
Proof. by move=> x; rewrite /fpos /fneg -{1}oppr0 -oppr_min normrN. Qed.

Lemma fposZ f c : 0 <= c -> fpos (c \*o f) =1 c \*o fpos f.
Proof.
move=> ge0_c x; rewrite /fpos /= -{1}(mulr0 c).
by rewrite -maxr_pmulr // normrM ger0_norm.
Qed.

Lemma fnegZ f c : 0 <= c -> fneg (c \*o f) =1 c \*o fneg f.
Proof.
move=> ge0_c x; rewrite /= -!fposN; have /=<- := (fposZ (- f) ge0_c x).
by apply/eq_fpos=> y /=; rewrite mulrN.
Qed.

Lemma fpos_natrM f (n : T -> nat) x :
  fpos (fun x => (n x)%:R * f x) x = (n x)%:R * fpos f x.
Proof.
rewrite /fpos -[in RHS]normr_nat -normrM.
by rewrite maxr_pmulr ?ler0n // mulr0.
Qed.

Lemma fneg_natrM f (n : T -> nat) x :
  fneg (fun x => (n x)%:R * f x) x = (n x)%:R * fneg f x.
Proof.
rewrite -[in RHS]fposN -fpos_natrM -fposN.
by apply/eq_fpos=> y; rewrite mulrN.
Qed.

Lemma fneg_ge0 f x : (forall x, 0 <= f x) -> fneg f x = 0.
Proof. by move=> ?; rewrite /fneg min_l ?normr0. Qed.

Lemma fpos_ge0 f x : (forall x, 0 <= f x ) -> fpos f x = f x.
Proof. by move=> ?; rewrite /fpos max_r ?ger0_norm. Qed.

Lemma ge0_fpos f x : 0 <= fpos f x.
Proof. by apply/normr_ge0. Qed.

Lemma ge0_fneg f x : 0 <= fneg f x.
Proof. by apply/normr_ge0. Qed.

Lemma le_fpos_norm f x : fpos f x <= `|f x|.
Proof.
rewrite /fpos ger0_norm ?(le_maxr, lexx) //.
by rewrite le_maxl normr_ge0 ler_norm.
Qed.

Lemma le_fpos f1 f2 : f1 <=1 f2 -> fpos f1 <=1 fpos f2.
Proof.
move=> le_f x; rewrite /fpos !ger0_norm ?le_maxr ?lexx //.
by rewrite le_maxl lexx /=; case: ltP => //=; rewrite le_f.
Qed.

Lemma fposBfneg f x : fpos f x - fneg f x = f x.
Proof.
rewrite /fpos /fneg maxC.
case: (leP (f x) 0); rewrite normr0 (subr0, sub0r) => ?.
  by rewrite ler0_norm ?opprK.
by rewrite gtr0_norm.
Qed.

Definition psum f : R :=
  (* We need some ticked `image` operator *)
  let S := [set x | exists J : {fset T}, x = \sum_(x : J) `|f (val x)| ]%classic in
  if `[<summable f>] then sup S else 0.

Definition sum f : R := psum (fpos f) - psum (fneg f).
End Sum.

(* -------------------------------------------------------------------- *)
Section SummableCountable.
Variable (T : choiceType) (R : realType) (f : T -> R).

Lemma summable_countn0 : summable f -> countable [pred x | f x != 0].
Proof.
case/summableP=> M ge0_M bM; pose E (p : nat) := [pred x | `|f x| > 1 / p.+1%:~R].
set F := [pred x | _]; have le: {subset F <= [pred x | `[< exists p, x \in E p >]]}.
  move=> x; rewrite !inE => nz_fx.
  pose j := `|floor (1 / `|f x|)|%N; exists j; rewrite inE.
  rewrite ltr_pdivr_mulr ?ltr0z // -ltr_pdivr_mull ?normr_gt0 //.
  rewrite mulr1 /j div1r -addn1 /= PoszD intrD mulr1z.
  rewrite gez0_abs ?floor_ge0 ?invr_ge0 ?normr_ge0 //.
  by rewrite -RfloorE; apply lt_succ_Rfloor.
apply/(countable_sub le)/cunion_countable=> i /=.
case: (existsTP (fun s : seq T => {subset E i <= s}))=> /= [[s le_Eis]|].
  by apply/finite_countable/finiteP; exists s => x /le_Eis.
move/finiteNP; pose j := `|floor (M / i.+1%:R)|.+1.
pose K := (`|floor M|.+1 * i.+1)%N; move/(_ K)/asboolP/exists_asboolP.
move=> h; have /asboolP[] := xchooseP h.
set s := xchoose h=> eq_si uq_s le_sEi; pose J := [fset x in s].
suff: \sum_(x : J) `|f (val x)| > M by rewrite ltNge bM.
apply/(@lt_le_trans _ _ (\sum_(x : J) 1 / i.+1%:~R)); last first.
  apply/ler_sum=> /= m _; apply/ltW.
  by have:= fsvalP m; rewrite in_fset => /le_sEi.
rewrite sumr_const -cardfE card_fseq undup_id // eq_si -mulr_natr -pmulrn.
rewrite mul1r natrM mulrCA mulVf ?mulr1 ?pnatr_eq0 //.
have /andP[_] := mem_rg1_Rfloor M; rewrite RfloorE -addn1.
by rewrite natrD /= mulr1n pmulrn -{1}[floor _]gez0_abs // floor_ge0.
Qed.
End SummableCountable.

(* -------------------------------------------------------------------- *)
Section PosCnv.
Context {R : realType}.

Lemma ncvg_mono (u : nat -> R) :
    (* {mono u : x y / (x <= y)%N >-> u x <= u y *)
    (forall x y, (x <= y)%N -> u x <= u y)
  -> exists2 l, (-oo < l)%E & ncvg u l.
Proof.
move=> mono_u; pose E := [set x | exists n, x = u n]%classic.
have nzE: nonempty E by exists (u 0%N); exists 0%N.
case: (pselect (has_sup E)); last first.
  move/has_supPn=> -/(_ nzE) h; exists +oo%E => //; elim/nbh_pinfW => M /=.
  case/(_ M): h=> x [K -> lt_MuK]; exists K=> n le_Kn; rewrite inE.
  by apply/(lt_le_trans lt_MuK)/mono_u.
move=> supE; exists (sup E)%:E => //; first exact: ltNyr.
elim/nbh_finW=>e /= gt0_e.
case: (sup_adherent gt0_e supE)=> x [K ->] lt_uK.
exists K=> n le_Kn; rewrite inE distrC ger0_norm ?subr_ge0.
  by move/ubP: (sup_upper_bound supE); apply; exists n.
rewrite ltr_subl_addr addrC -ltr_subl_addr.
by rewrite (lt_le_trans lt_uK) //; apply/mono_u.
Qed.

Lemma ncvg_mono_bnd (u : nat -> R) :
    (* {mono u : x y / (x <= y)%N >-> u x <= u y *)
    (forall x y, (x <= y)%N -> u x <= u y)
  -> nbounded u -> exists l, ncvg u l%:E.
Proof.
case/ncvg_mono=> -[x||] // _ cu bdu; first by exists x.
case/asboolP/nboundedP: bdu=> M gt0_M bdu.
case/(_ (NPInf M)): cu => K /= /(_ K (leqnn _)).
rewrite inE/= => /ltW /le_trans /(_ (ler_norm _)).
by move/le_lt_trans/(_ (bdu _)); rewrite ltxx.
Qed.
End PosCnv.

(* -------------------------------------------------------------------- *)
Section SumTh.
Context {R : realType} (T : choiceType).

Implicit Type S : T -> R.

Lemma summable_sup (S : T -> R) : summable S -> has_sup
  [set x | exists J : {fset T}, x = \sum_(j : J) `|S (val j)|]%classic.
Proof.
case/summableP=> M _ hbd; split.
  by exists 0, fset0; rewrite big_fset0.
by exists M; apply/ubP=> y [J ->].
Qed.

Lemma psum_sup S : psum S =
  sup [set x | exists J : {fset T}, x = \sum_(x : J) `|S (val x)|]%classic.
Proof.
rewrite /psum; case: ifPn => // /asboolPn h.
rewrite sup_out //; set X := [set r | _]%classic => hs.
apply: h; exists (sup X) => J.
by move/ubP : (sup_upper_bound hs); apply; exists J.
Qed.

Lemma psum_sup_seq S : psum S =
  sup [set x | exists2 J : seq T,
    uniq J & x = \sum_(x <- J) `|S x| ]%classic.
Proof.
rewrite psum_sup; congr sup; rewrite predeqE => x; split.
  case=> J ->; exists (enum_fset J).
    by case: J => /= J /canonical_uniq.
  by rewrite (big_fset_seq \`|_|) /=.
case=> J uqJ ->; exists [fset x in J].
by rewrite (big_seq_fset \`|_|).
Qed.

Lemma eq_summable (S1 S2 : T -> R) :
  (S1 =1 S2) -> summable S1 -> summable S2.
Proof.
move=> eq_12 [M h]; exists M => J; rewrite (le_trans _ (h J)) //.
rewrite le_eqVlt; apply/orP; left; apply/eqP/eq_bigr.
by move=> /= K _; rewrite eq_12.
Qed.

Lemma eq_summableb (S1 S2 : T -> R) :
  (S1 =1 S2) -> `[< summable S2 >] = `[< summable S1 >].
Proof. by move=> eq_12; apply/asboolP/asboolP; apply/eq_summable. Qed.

Lemma eq_ppsum (F1 F2 : {fset T} -> R) : F1 =1 F2 ->
  (sup [set x | exists J, x = F1 J] = sup [set x | exists J, x = F2 J])%classic.
Proof.
move=> eq_12; congr sup; rewrite predeqE => x.
by split=> -[J ->]; exists J.
Qed.

Lemma eq_psum (F1 F2 : T -> R) : F1 =1 F2 -> psum F1 = psum F2.
Proof.
move=> eq_12; rewrite /psum (eq_summableb eq_12).
case: `[< summable F1 >] => //.
congr sup.
rewrite predeqE => x; split=> -[J ->]; exists J;
  by apply/eq_bigr=> /= K _; rewrite eq_12.
Qed.

Lemma eq_sum (F1 F2 : T -> R) : F1 =1 F2 -> sum F1 = sum F2.
Proof.
move=> eq_fg; rewrite /sum; congr (_ - _); apply/eq_psum.
  by apply/eq_fpos. by apply/eq_fneg.
Qed.

Lemma le_summable (F1 F2 : T -> R) :
  (forall x, 0 <= F1 x <= F2 x) -> summable F2 -> summable F1.
Proof.
move=> le_F [M leM]; exists M => J; apply/(le_trans _ (leM J)).
apply/ler_sum => /= j _; case/andP: (le_F (val j)) => h1 h2.
by rewrite !ger0_norm // (le_trans h1 h2).
Qed.

Lemma le_psum (F1 F2 : T -> R) :
  (forall x, 0 <= F1 x <= F2 x) -> summable F2 -> psum F1 <= psum F2.
Proof.
move=> le_F smF2; have smF1: summable F1 by apply/(le_summable le_F).
rewrite /psum (asboolT smF1) (asboolT smF2); apply/le_sup; first last.
+ by apply/summable_sup.
+ by exists 0, fset0; rewrite big_fset0.
move=> x [J ->]; apply/downP; exists (\sum_(j : J) `|F2 (val j)|).
  by exists J.
apply/ler_sum=> /= j _; case/andP: (le_F (val j)) => h1 h2.
by rewrite !ger0_norm // (le_trans h1 h2).
Qed.

Lemma psum_out S : ~ summable S -> psum S = 0.
Proof. by move/asboolPn/negbTE=> smN; rewrite /psum smN. Qed.

Lemma psumE S : (forall x, 0 <= S x) -> summable S -> psum S =
  sup [set x | exists J : {fset T}, x = \sum_(j : J) S (val j)]%classic.
Proof.
move=> gt0_S smS; rewrite /psum (asboolT smS); apply/eq_ppsum=> /=.
by move=> J; apply/eq_bigr=> j _; rewrite ger0_norm.
Qed.

Lemma psum_absE S : summable S -> psum S =
  sup [set x | exists J : {fset T}, x = \sum_(j : J) `|S (val j)|]%classic.
Proof. by move=> smS; rewrite /psum (asboolT smS). Qed.

Lemma summable_seqP S :
  summable S <-> (exists2 M, 0 <= M &
    forall s : seq T, uniq s -> \sum_(x <- s) `|S x| <= M).
Proof.
split=> [/summableP|] [M gt0_M h]; exists M => //.
  by move=> s uq_s; have := h [fset x in s]; rewrite (big_seq_fset \`|S|).
by case=> J cJ; rewrite (big_fset_seq \`|_|) /=; apply/h/canonical_uniq.
Qed.

Lemma gerfin_psum S (J : {fset T}) :
  summable S -> \sum_(j : J) `|S (val j)| <= psum S.
Proof.
move=> smS; rewrite /psum (asboolT smS).
by move/ubP : (sup_upper_bound (summable_sup smS)); apply; exists J.
Qed.

Lemma gerfinseq_psum S (r : seq T) :
  uniq r -> summable S -> \sum_(j <- r) `|S j| <= psum S.
Proof.
move=> uq_r /gerfin_psum -/(_ [fset x in r]);
  by rewrite (big_seq_fset \`|S|).
Qed.

Lemma psum_le S z :
  (forall J, uniq J -> \sum_(j <- J) `|S j| <= z) -> psum S <= z.
Proof.
move=> le_z; have: summable S; first (apply/summable_seqP; exists z).
+ by apply/(le_trans _ (le_z [::] _)) => //; rewrite big_nil.
+ by move=> J uqJ; apply/le_z.
move/summable_sup=> [neS hsS]; rewrite psum_sup.
apply/sup_le_ub => //; apply/ubP=> r [J ->].
by rewrite (big_fset_seq \`|_|) le_z /=; case: J => J /= /canonical_uniq.
Qed.

Lemma lt_psum (F : T -> R) l :
  summable F -> l < psum F ->
    exists J : {fset T}, l < \sum_(j : J) `|F (val j)|.
Proof.
move=> smF; rewrite /psum (asboolT smF) => /lt_sup_imfset.
by case=> /= [|J lt_lJ _]; [apply/summable_sup | exists J].
Qed.
End SumTh.

(* -------------------------------------------------------------------- *)
Lemma max_sup {R : realType} x (E : set R) :
  (E `&` ubound E)%classic x -> sup E = x.
Proof.
case=> /= xE xubE; have nzE: nonempty E by exists x.
apply/eqP; rewrite eq_le sup_le_ub //=.
have : has_sup E by split; exists x.
by move/sup_upper_bound/ubP; apply.
Qed.

(* -------------------------------------------------------------------- *)
Section FinSumTh.
Context {R : realType} (I : finType).

Lemma summable_fin (f : I -> R) : summable f.
Proof.
exists (\sum_(i : [fset i | i : I]) `|f (val i)|).
move=> J; apply: (big_fset_subset (F := \`|_|)).
  by move=> x; rewrite normr_ge0.
by move=> i _; apply/imfsetP; exists i.
Qed.

Lemma psum_fin (f : I -> R) : psum f = \sum_i `|f i|.
Proof.                          (* FIXME *)
pose S := \sum_(i : [fset i | i : I]) `|f (val i)|.
rewrite /psum (asboolT (summable_fin f)) (@max_sup _ S).
  rewrite /=; split; first by exists [fset i | i : I]%fset.
  apply/ubP=> y [J ->]; apply/(big_fset_subset (F := \`|_|)).
    by move=> i; rewrite normr_ge0.
  by move=> j jJ; apply/in_imfset.
rewrite /S -(big_map val xpredT \`|f|); apply/perm_big.
rewrite /index_enum -!enumT; apply/(perm_trans _ enum_fsetT).
apply/uniq_perm; rewrite ?map_inj_uniq ?enum_uniq //=.
  by apply/val_inj. by rewrite -enumT enum_uniq.
move=> i /=; rewrite mem_enum in_imfset //; apply/mapP.
have h: i \in [fset j | j : I] by rewrite in_imfset.
by exists (FSetSub h) => //; rewrite mem_enum.
Qed.
End FinSumTh.

(* -------------------------------------------------------------------- *)
Section PSumGe.
Context {R : realType} (T : choiceType).

Variable (S : T -> R).

Lemma ger_big_psum r : uniq r -> summable S ->
  \sum_(x <- r) `|S x| <= psum S.
Proof.
move=> uq_r smS; rewrite /psum (asboolT smS).
set E := (X in sup X).
have : has_sup E by apply/summable_sup.
move/sup_upper_bound/ubP; apply.
by exists [fset x in r]; rewrite (big_seq_fset (fun i => `|S i|)).
Qed.

Lemma ger1_psum x : summable S -> `|S x| <= psum S.
Proof.
move=> smS; have h := @ger_big_psum [:: x] _ smS.
by rewrite (le_trans _ (h _)) ?big_seq1.
Qed.

Lemma ge0_psum : 0 <= psum S.
Proof.                          (* FIXME: asbool_spec *)
case/boolP: `[< summable S >] => [|/asboolPn/psum_out ->//].
move/asboolP=> smS; have h := @ger_big_psum [::] _ smS.
by rewrite (le_trans _ (h _)) ?big_nil.
Qed.
End PSumGe.

(* -------------------------------------------------------------------- *)
Section PSumNatGe.
Context {R : realType}.

Variable (S : nat -> R) (smS : summable S).

Lemma ger_big_ord_psum n : \sum_(i < n) `|S i| <= psum S.
Proof.
rewrite -(big_mkord predT (fun i => `|S i|)) /=.
by apply/ger_big_psum => //; rewrite iota_uniq.
Qed.
End PSumNatGe.

(* -------------------------------------------------------------------- *)
Section PSumCnv.
Context {R : realType}.

Variable (S : nat -> R).

Hypothesis ge0_S : (forall n, 0 <= S n).
Hypothesis smS   : summable S.

Lemma ptsum_homo x y : (x <= y)%N -> (\sum_(i < x) S i <= \sum_(i < y) S i).
Proof.
move=> le_xy; rewrite -!(big_mkord predT) -(subnKC le_xy) /=.
by rewrite /index_iota !subn0 iotaD big_cat /= ler_addl sumr_ge0.
Qed.

Lemma psummable_ptbounded : nbounded (fun n => \sum_(i < n) S i).
Proof.
apply/asboolP/nboundedP; exists (psum S + 1).
  rewrite ltr_spaddr ?ltr01 1?(le_trans (normr_ge0 (S 0%N))) //.
  by apply/ger1_psum.
move=> n; rewrite ltr_spaddr ?ltr01 // ger0_norm ?sumr_ge0 //.
apply/(le_trans _ (ger_big_ord_psum _ n)) => //.
by apply/ler_sum=> /= i _; apply/ler_norm.
Qed.

Lemma ncvg_sum : ncvg (fun n => \sum_(i < n) S i) (psum S)%:E.
Proof.
set u := (fun n => _); apply: contraPP smS => ncv _.
case: (ncvg_mono_bnd (u := u)) => //.
  by apply/ptsum_homo. by apply/psummable_ptbounded.
move=> x cvux; suff xE: x = (psum S) by rewrite xE in cvux.
apply/eqP; case: (x =P _) => // /eqP /lt_total /orP[]; last first.
+ rewrite -lte_fin => /ncvg_gt /(_ cvux) [K /(_ _ (leqnn _))] /=.
  rewrite ltNge lee_fin (le_trans _ (ger_big_ord_psum _ K)) //.
  by apply/ler_sum=> /= i _; apply/ler_norm.
move=> lt_xS; pose e := psum S - x.
  have ge0_e: 0 < e by rewrite subr_gt0.
case: (sup_adherent ge0_e (summable_sup smS)) => y.
case=> /= J ->; rewrite /e /psum (asboolT smS).
rewrite opprB addrCA subrr addr0 => lt_xSJ.
pose k := \max_(j : J) (val j); have lt_x_uSk: x < u k.+1.
  apply/(lt_le_trans lt_xSJ); rewrite /u big_ord_mkfset.
  rewrite (eq_bigr (S \o val)) => /= [j _|]; first by rewrite ger0_norm.
  apply/big_fset_subset=> // j jJ; rewrite in_fset //.
  by rewrite (mem_iota _ k.+1) /= add0n ltnS (leq_bigmax (FSetSub jJ)).
have /= := ncvg_homo_le ptsum_homo cvux k.+1; rewrite -/(u _).
by rewrite lee_fin => /le_lt_trans/(_ lt_x_uSk); rewrite ltxx.
Qed.

Lemma sum_ncvg l :
  ncvg (fun n => \sum_(i < n) S i) l%:E -> summable S.
Proof using ge0_S. Abort.
End PSumCnv.

(* -------------------------------------------------------------------- *)
Section PSumAsLim.
Context {R : realType} {T : choiceType}.

Variable (S : T -> R) (P : nat -> {fset T}).

Hypothesis ge0_S   : (forall x, 0 <= S x).
Hypothesis smS     : summable S.
Hypothesis homo_P  : forall n m, (n <= m)%N -> (P n `<=` P m).
Hypothesis cover_P : forall x, S x != 0 -> exists n, x \in P n.

Lemma psum_as_lim : psum S = fine (nlim (fun n => \sum_(j : P n) (S (val j)))).
Proof.
set v := fun n => _; have hm_v m n: (m <= n)%N -> v m <= v n.
  by move=> le_mn; apply/big_fset_subset/fsubsetP/homo_P.
have bd_v n : v n <= psum S.
  apply/(le_trans _ (gerfin_psum _ smS))/ler_sum.
  by move=> J _; apply/ler_norm.
case: (ncvg_mono_bnd hm_v) => [|l cv].
  apply/asboolP/nboundedP; exists (psum S + 1) => //.
    by apply/(le_lt_trans (ge0_psum S)); rewrite ltr_addl ltr01.
  move=> n; rewrite ger0_norm ?sumr_ge0 //.
  by rewrite (le_lt_trans (bd_v n)) // ltr_addl ltr01.
have le_lS: l <= psum S by rewrite -lee_fin (ncvg_leC _ cv).
rewrite (nlimE cv) /= (rwP eqP) eq_le le_lS andbT.
rewrite leNgt; apply/negP=> {le_lS} /(lt_psum smS)[J].
rewrite (big_fset_seq \`|_|) /=; case: J => /= J.
move/canonical_uniq=> uqJ lt_jS; pose K := [seq x <- J | S x != 0].
have [n]: exists n, {subset K <= P n}; first rewrite {}/K.
  elim: {uqJ lt_jS} J => /= [|x J [n ih]]; first by exists 0%N.
  case: (S x =P 0) => /=; first by move=> _; exists n.
  move/eqP/cover_P=> [k Pk_x]; exists (maxn n k)=> y.
  rewrite inE => /orP[/eqP->|/=].
    by apply/fsubsetP/homo_P/leq_maxr: x Pk_x.
  by move/ih; apply/fsubsetP/homo_P/leq_maxl: y.
move=> le_K_Pn; have: l < v n; first apply/(lt_le_trans lt_jS).
  rewrite (eq_bigr S) => [x _|]; first by rewrite ger0_norm.
  rewrite /v (bigID (fun x => S x == 0)) /= big1 => [x /eqP|] //.
  rewrite add0r -big_filter -/K -big_seq_fset ?filter_uniq //=.
  by apply/big_fset_subset => // x; rewrite in_fset => /le_K_Pn.
by apply/negP; rewrite -leNgt -lee_fin ncvg_homo_le.
Qed.
End PSumAsLim.

(* -------------------------------------------------------------------- *)
Section SummableAlg.
Context {R : realType} (T : choiceType) (I : Type).

(* -------------------------------------------------------------------- *)
Lemma summable_addrC (S1 S2 : T -> R) :
  summable (S1 \+ S2) -> summable (S2 \+ S1).
Proof. by apply/eq_summable => x; rewrite /= addrC. Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_mulrC (S1 S2 : T -> R) :
  summable (S1 \* S2) -> summable (S2 \* S1).
Proof. by apply/eq_summable => x; rewrite /= mulrC. Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_abs (S : T -> R) : summable \`|S| <-> summable S.
Proof.
have h J: \sum_(j <- J) `| `|S j| | = \sum_(j <- J) `|S j|.
  by apply/eq_bigr=> j _; rewrite normr_id.
split=> /summable_seqP[M ge0_M leM]; apply/summable_seqP;
  by exists M=> // => J /leM; rewrite h.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summable0 : summable (fun _ : T => 0 : R).
Proof. by exists 0 => J; rewrite big1 ?normr0. Qed.

(* -------------------------------------------------------------------- *)
Lemma summableD (S1 S2 : T -> R) :
  summable S1 -> summable S2 -> summable (S1 \+ S2).
Proof.
case=> [M1 h1] [M2 h2]; exists (M1 + M2) => J /=.
pose M := \sum_(x : J) (`|S1 (val x)| + `|S2 (val x)|).
rewrite (@le_trans _ _ M) // ?ler_sum // => [K _|].
  by rewrite ler_norm_add.
by rewrite /M big_split ler_add ?(h1, h2).
Qed.

(* -------------------------------------------------------------------- *)
Lemma summableN (S : T -> R) : summable S -> summable (- S).
Proof.
case=> [M h]; exists M => J; rewrite (le_trans _ (h J)) //.
rewrite le_eqVlt; apply/orP; left; apply/eqP/eq_bigr.
by move=> /= K _; rewrite normrN.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summablebN (S : T -> R) :
  `[< summable (- S)>] = `[< summable S >].
Proof.
apply/asboolP/asboolP => /summableN //.
by apply/eq_summable => x /=; rewrite opprK.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summablebDl (S1 S2 : T -> R) : summable S1 ->
  `[< summable (S1 \+ S2) >] = `[< summable S2 >].
Proof.
move=> sm1; apply/asboolP/asboolP; last by apply/(summableD sm1).
move=> sm12; apply/(@eq_summable _ _ ((S1 \+ S2) \- S1)).
  by move=> x /=; rewrite addrC addKr.
by apply/summableD/summableN.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summablebDr (S1 S2 : T -> R) : summable S2 ->
  `[< summable (S1 \+ S2) >] = `[< summable S1 >].
Proof.
move=> sm1; rewrite (@eq_summableb _ _ (S2 \+ S1)) ?summablebDl //.
by move=> x /=; rewrite addrC.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summableZ (S : T -> R) c : summable S -> summable (c \*o S).
Proof.
case=> [M h]; exists (`|c| * M) => J; move/(_ J): h => /=.
move/(ler_wpmul2l (normr_ge0 c)); rewrite mulr_sumr.
move/(le_trans _); apply; rewrite le_eqVlt; apply/orP.
by left; apply/eqP/eq_bigr=> j _; rewrite normrM.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summableZr (S : T -> R) (c : R) :
  summable S -> summable (c \o* S).
Proof. by move=> smS; apply/summable_mulrC/summableZ. Qed.

(* -------------------------------------------------------------------- *)
Lemma summableMl (S1 S2 : T -> R) :
  (exists M, forall x, `|S1 x| <= M) -> summable S2 -> summable (S1 \* S2).
Proof.
case=> M leM smS2; apply/summable_abs.
apply/(le_summable (F2 := M \*o \`|S2|)).
+ by move=> x /=; rewrite normr_ge0 /= normrM ler_wpmul2r.
+ by apply/summableZ/summable_abs.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summableMr (S1 S2 : T -> R) :
  (exists M, forall x, `|S2 x| <= M) -> summable S1 -> summable (S1 \* S2).
Proof. by move=> bd sm; apply/summable_mulrC/summableMl. Qed.

(* -------------------------------------------------------------------- *)
Lemma summableM (S1 S2 : T -> R) :
  summable S1 -> summable S2 -> summable (S1 \* S2).
Proof.
move=> smS1 smS2; apply/summableMl => //; exists (psum S1).
by move=> x; apply/ger1_psum.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_fpos (f : T -> R) :
  summable f -> summable (fpos f).
Proof.
move/summable_abs; apply/le_summable=> x.
by rewrite ge0_fpos /= le_fpos_norm.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_fneg (f : T -> R) :
  summable f -> summable (fneg f).
Proof. by move/summableN/summable_fpos/(eq_summable (fposN _)). Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_condl (S : T -> R) (P : pred T) :
  summable S -> summable (fun x => (P x)%:R * S x).
Proof.
case/summable_seqP=> M ge0_M leM; apply/summable_seqP.
exists M => //; move=> J /leM /(le_trans _); apply.
apply/ler_sum=> x _; case: (P x); rewrite (mul1r, mul0r) //.
by rewrite normr0 normr_ge0.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_condr (S : T -> R) (P : pred T) :
  summable S -> summable (fun x => S x * (P x)%:R).
Proof.
move=> /(summable_condl P) /eq_summable; apply.
by move=> x /=; rewrite mulrC.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_of_bd (S : T -> R) (d : R) :
  (forall J, uniq J -> \sum_(x <- J) `|S x| <= d) ->
    summable S /\ psum S <= d.
Proof.
move=> leS; have ge0_d: 0 <= d.
  by apply/(le_trans _ (leS [::] _)); rewrite // big_nil.
have smS: summable S by apply/summable_seqP; exists d.
split=> //; rewrite /psum (asboolT smS); apply/sup_le_ub.
  by exists 0, fset0; rewrite big_fset0.
apply/ubP=> _ [J ->]; rewrite (big_fset_seq \`|_|) /=.
by apply/leS; case: J => J /= /canonical_uniq.
Qed.

(* -------------------------------------------------------------------- *)
Lemma summable_sum (F : I -> T -> R) (P : pred I) r :
    (forall i, P i -> summable (F i))
  -> summable (fun x => \sum_(i <- r | P i) F i x).
Proof.
move=> sm_F; elim: r => [|i r ih].
  by apply/(eq_summable _ summable0) => x; rewrite big_nil.
pose G x := (F i x) * (P i)%:R + \sum_(i <- r | P i) F i x.
apply/(eq_summable (S1 := G)) => [x|].
  by rewrite {}/G big_cons; case: ifP=> Pi; rewrite !Monoid.simpm.
apply/summableD => //; case/boolP: (P i) => [|_].
  by move/sm_F; apply/eq_summable => x; rewrite mulr1.
by apply/(eq_summable _ summable0) => x; rewrite mulr0.
Qed.

End SummableAlg.

(* -------------------------------------------------------------------- *)
Section StdSum.
Context {R : realType} (T : choiceType) (I : Type).

Implicit Type S : T -> R.

(* -------------------------------------------------------------------- *)
Lemma psum0 : psum (fun _ : T => 0) = 0 :> R.
Proof.
rewrite /psum asboolT; first by apply/summable0.
set S := [set x | _]%classic; suff: S = (set1 0).
  by move => ->; rewrite sup1.
rewrite predeqE => x; split.
  by case=> J -> /=; rewrite big1 // normr0.
by move=> ->; exists fset0; rewrite big_fset0.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psum_eq0 (f : T -> R) : (forall x, f x = 0) -> psum f = 0.
Proof. by move=> eq; rewrite (eq_psum eq) psum0. Qed.

(* -------------------------------------------------------------------- *)
Lemma eq0_psum (f : T -> R) :
  summable f -> psum f = 0 -> (forall x : T, f x = 0).
Proof.
move=> sm psum_eq0 x; apply/eqP; rewrite -normr_eq0.
rewrite eq_le normr_ge0 andbT -psum_eq0.
apply/(le_trans _ (gerfinseq_psum (r := [:: x]) _ sm)) => //.
by rewrite big_seq1.
Qed.

(* -------------------------------------------------------------------- *)
Lemma neq0_psum (f : T -> R) : psum f <> 0 -> exists x : T, f x <> 0.
Proof.
by move=> nz_psum; apply/existsp_asboolPn/asboolPn => /psum_eq0.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psum_abs (S : T -> R) : psum \`|S| = psum S.
Proof.
rewrite /psum; do 2! case: ifPn => //; first last.
+ by move/asboolP/summable_abs/asboolP=> ->.
+ by move/asboolPn/summable_abs/asboolPn=> /negbTE->.
move=> _ _; congr sup; rewrite predeqE => x; split.
  case=> J ->; exists J.
  by under eq_bigr do rewrite normr_id.
case=> J ->; exists J.
by under [in RHS]eq_bigr do rewrite normr_id.
Qed.

(* -------------------------------------------------------------------- *)
Lemma eq_psum_abs (S1 S2 : T -> R) :
  \`|S1| =1 \`|S2| -> psum S1 = psum S2.
Proof.
by move=> eqS; rewrite -[LHS]psum_abs -[RHS]psum_abs; apply/eq_psum.
Qed.

(* -------------------------------------------------------------------- *)
Lemma le_psum_abs (S1 S2 : T -> R) :
  (forall x, `|S1 x| <= `|S2 x|) -> summable S2 -> psum S1 <= psum S2.
Proof.
move=> leS smS2; rewrite -[X in X<=_]psum_abs -[X in _<=X]psum_abs.
by apply/le_psum/summable_abs => // x; rewrite normr_ge0 leS.
Qed.

(* -------------------------------------------------------------------- *)
Lemma le_psum_condl (S : T -> R) (P : pred T) :
  summable S -> psum (fun x => (P x)%:R * S x) <= psum S.
Proof.
move=> smS; apply/le_psum_abs=> // x; rewrite normrM.
by apply/ler_pimull => //; rewrite normr_nat lern1 leq_b1.
Qed.

(* -------------------------------------------------------------------- *)
Lemma le_psum_condr (S : T -> R) (P : pred T) :
  summable S -> psum (fun x => S x * (P x)%:R) <= psum S.
Proof.
move=> smS; apply/(le_trans _ (le_psum_condl P smS)).
rewrite le_eqVlt -(rwP orP); left; apply/eqP/eq_psum.
by move=> x /=; rewrite mulrC.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psumN (S : T -> R) : psum (- S) = psum S.
Proof.
case/boolP: `[< summable S >] => h; last first.
  by rewrite !psum_out ?oppr0 //; apply/asboolPn; rewrite ?summablebN.
rewrite /psum summablebN h; apply/eq_ppsum=> J /=.
by apply/eq_bigr=> j _; rewrite normrN.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psumD S1 S2 :
    (forall x, 0 <= S1 x) -> (forall x, 0 <= S2 x)
  -> summable S1 -> summable S2
  -> psum (S1 \+ S2) = (psum S1 + psum S2).
Proof.
move=> ge0_S1 ge0_S2 smS1 smS2; have smD := summableD smS1 smS2.
have ge0D: forall x, 0 <= S1 x + S2 x by move=> x; rewrite addr_ge0.
rewrite !psumE // (rwP eqP) eq_le -(rwP andP); split.
  apply/sup_le_ub.
  + by exists 0, fset0; rewrite big_fset0.
  apply/ubP=> _ [J ->]; rewrite big_split /=.
  apply/ler_add; rewrite -psumE 1?(le_trans _ (gerfin_psum J _)) //.
  + by apply/ler_sum=> j _ /=; apply/ler_norm.
  + by apply/ler_sum=> j _ /=; apply/ler_norm.
rewrite -ler_subr_addr; apply/sup_le_ub.
+ by exists 0, fset0; rewrite big_fset0.
apply/ubP=> _ [J1 ->]; rewrite ler_subr_addr addrC.
rewrite -ler_subr_addr; apply/sup_le_ub.
+ by exists 0, fset0; rewrite big_fset0.
apply/ubP=> _ [J2 ->]; rewrite ler_subr_addr addrC.
pose J := J1 `|` J2; rewrite -psumE ?(le_trans _ (gerfin_psum J _)) //.
pose D := \sum_(j : J) (S1 (val j) + S2 (val j)).
apply/(@le_trans _ _ D); last by apply/ler_sum=> i _; apply/ler_norm.
rewrite /D big_split /=; apply/ler_add; apply/big_fset_subset=> //.
+ by apply/fsubsetP/fsubsetUl. + by apply/fsubsetP/fsubsetUr.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psumB S1 S2 :
    (forall x, 0 <= S2 x <= S1 x) -> summable S1
  -> psum (S1 \- S2) = (psum S1 - psum S2).
Proof using Type. Admitted.

(* -------------------------------------------------------------------- *)
Lemma psumZ S c : 0 <= c -> psum (c \*o S) = c * psum S.
Proof.
rewrite le_eqVlt => /orP[/eqP<-|gt0_c].
  by rewrite mul0r psum_eq0 // => x /=; rewrite mul0r.
case/asboolP: (summable S) => [smS|NsmS]; last first.
  rewrite !psum_out ?mulr0 // => smZ; apply/NsmS.
  move/(summableZ c^-1): smZ; apply/eq_summable=> x /=.
  by rewrite mulKf // gt_eqF.
have smZ := summableZ c smS; rewrite (rwP eqP) eq_le.
apply/andP; split; first rewrite {1}/psum asboolT //.
  apply/sup_le_ub.
  + by exists 0, fset0; rewrite big_fset0.
  apply/ubP=> _ [J ->]; rewrite -ler_pdivr_mull //.
  rewrite mulr_sumr (le_trans _ (gerfin_psum J _)) //.
  apply/ler_sum=> /= j _; rewrite normrM.
  by rewrite gtr0_norm // mulKf ?gt_eqF.
rewrite -ler_pdivl_mull // {1}/psum asboolT //; apply/sup_le_ub.
+ by exists 0, fset0; rewrite big_fset0.
apply/ubP=> _ [J ->]; rewrite ler_pdivl_mull //.
rewrite mulr_sumr; apply/(le_trans _ (gerfin_psum J _))=> //.
by apply/ler_sum=> /= j _; rewrite normrM (gtr0_norm gt0_c).
Qed.

(* -------------------------------------------------------------------- *)
Lemma psumZr S c :
  0 <= c -> psum (c \o* S) = psum S * c.
Proof.
move=> ge0_c; rewrite [RHS]mulrC -psumZ //.
by apply/eq_psum => x /=; rewrite mulrC.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psum_bigop (F : I -> T -> R) P r :
    (forall i x, 0 <= F i x) -> (forall i, summable (F i)) ->
  \sum_(i <- r | P i) psum (F i) =
    psum (fun x => \sum_(i <- r | P i) F i x).
Proof.
move=> ge0_F sm_F; elim: r => [|i r ih].
  by rewrite big_nil; apply/esym/psum_eq0 => x; rewrite big_nil.
rewrite big_cons ih; case: ifP => Pi; last first.
  by apply/eq_psum=> x /=; rewrite big_cons Pi.
rewrite -psumD //; first by move=> x; apply/sumr_ge0.
  by apply/summable_sum.
by apply/eq_psum=> x /=; rewrite big_cons Pi.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psumID S (P : pred T) :
  summable S -> psum S =
    psum (fun x => (P x)%:R * S x) + psum (fun x => (~~P x)%:R * S x).
Proof.
have h x: `|S x| = (P x)%:R * `|S x| + (~~P x)%:R * `|S x|.
  by case: (P x); rewrite !Monoid.simpm.
move=> smS; rewrite -[LHS]psum_abs (eq_psum h) psumD.
  by move=> x; rewrite mulr_ge0. by move=> x; rewrite mulr_ge0.
  by apply/summable_condl/summable_abs.
  by apply/summable_condl/summable_abs.
congr (_ + _); apply/eq_psum_abs=> x /=.
  by rewrite !normrM normr_nat normr_id.
  by rewrite !normrM normr_nat normr_id.
Qed.

(* -------------------------------------------------------------------- *)
Lemma psum_finseq S (r : seq.seq T) :
    uniq r -> {subset [pred x | S x != 0] <= r}
  -> psum S = \sum_(x <- r) `|S x|.
Proof.
move=> eq_r ler; set s := RHS; have h J: uniq J -> \sum_(x <- J) `|S x| <= s.
  move=> uqJ; rewrite (bigID (ssrbool.mem r)) /= addrC big1.
    move=> x xNr; apply/eqP; apply/contraR: xNr.
    by rewrite normr_eq0 => /ler.
  rewrite add0r {}/s -big_filter; set s := seq.filter _ _.
  rewrite [X in _<=X](bigID (ssrbool.mem J)) /=.
  rewrite (perm_big [seq x <- r | x \in J]) /=.
    apply/uniq_perm; rewrite ?filter_uniq // => x.
    by rewrite !mem_filter andbC.
  by rewrite big_filter ler_addl sumr_ge0.
case/summable_of_bd: h => smS le_psum; apply/eqP.
by rewrite eq_le le_psum /=; apply/gerfinseq_psum.
Qed.
End StdSum.

(* -------------------------------------------------------------------- *)
Section PSumReindex.
Context {R : realType} {T U : choiceType}.
Context (S : T -> R) (P : pred T) (h : U -> T).

Lemma reindex_psum_onto h' :
     (forall x, S x != 0 -> x \in P)
  -> (forall i, i \in P -> omap h (h' i) = Some i)
  -> (forall i, h i \in P -> h' (h i) = Some i)
  -> psum S = psum (fun x : U => S (h x)).
Proof.
move=> PS hO hP; rewrite !psum_sup_seq; congr sup; rewrite predeqE => x.
split=> -[J uqJ ->] {x}; last first.
  exists [seq h j | j <- J & S (h j) != 0].
    rewrite map_inj_in_uniq ?filter_uniq // => y1 y2.
    rewrite !mem_filter => /andP[nz_S1 _] /andP[nz_S2 _].
    by move/(congr1 h'); rewrite !hP ?PS // => -[].
  apply/eqP; rewrite big_map big_filter.
  rewrite (bigID (fun i => S (h i) == 0)) /= big1 ?add0r //.
  by move=> y /eqP->; rewrite normr0.
have uqpJ: uniq (pmap h' [seq j | j <- J & S j != 0]).
  apply/(map_uniq (f := some)); rewrite pmapS_filter.
  rewrite map_inj_in_uniq ?filter_uniq // => [y1 y2|]; last first.
    by rewrite map_id filter_uniq.
  rewrite !map_id !mem_filter => /andP[h'1 h1] /andP[h'2 h2].
  case/andP: h1 => h1 _; case/andP: h2 => h2 _.
  by move/(congr1 (omap h)); rewrite !hO ?PS // => -[].
exists (pmap h' [seq j | j <- J & S j != 0]) => //.
apply/eqP; rewrite -(big_map h predT \`|S|) (bigID [pred j | S j == 0]) /=.
rewrite big1 ?add0r => [i /eqP->|]; first by rewrite normr0.
rewrite -big_filter; apply/eqP; apply/perm_big/uniq_perm.
+ by rewrite filter_uniq.
+ rewrite map_inj_in_uniq // !map_id => y1 y2 h1 h2.
  move/(congr1 h'); rewrite !hP ?PS //; last by case.
  * move: h1; rewrite mem_pmap => /mapP[x1].
    rewrite mem_filter => /andP[nz_Sx1 _] /(congr1 (omap h)) /=.
    by rewrite hO ?PS // => -[->].
  * move: h2; rewrite mem_pmap => /mapP[x2].
    rewrite mem_filter => /andP[nz_Sx2 _] /(congr1 (omap h)) /=.
    by rewrite hO ?PS // => -[->].
move=> x; rewrite !mem_filter; apply/andP/idP.
+ case=> nzSx Jx; apply/mapP; move/(_ x (PS _ nzSx)): hO.
  case E: (h' x) => [u|] //= -[xE]; exists u => //.
  rewrite mem_pmap; apply/mapP; exists x => //.
  by rewrite map_id mem_filter nzSx.
+ case/mapP=> u; rewrite mem_pmap => /mapP[t]; rewrite map_id.
  rewrite mem_filter=> /andP[h1 h2] /(congr1 (omap h)) /=.
  by rewrite hO ?PS // => -[->] ->; split.
Qed.

Lemma reindex_psum :
     (forall x, S x != 0 -> x \in P)
  -> {on P, bijective h}
  -> psum S = psum (fun x : U => S (h x)).
Proof.
move=> hP [hI h1 h2]; apply/(@reindex_psum_onto (some \o hI)) => //.
+ by move=> x Px /=; rewrite h2.
+ by move=> x Px /=; rewrite h1.
Qed.
End PSumReindex.

(* -------------------------------------------------------------------- *)
Section PSumPartition.
Context {R : realType} {T U : choiceType} (f : T -> U).

Let C y := `[< exists x : T, f x == y >].

Lemma partition_psum (S : T -> R) : summable S ->
  psum S = psum (fun y => psum (fun x => S x * (f x == y)%:R)).
Proof.                          (* FIXME: this proof is a joke *)
move=> smS; rewrite (rwP eqP) eq_le -(rwP andP); split.
  pose F x y := `|S x| * (f x == y :> U)%:R.
  have smFy y: summable (F^~ y).
    by apply/summable_condr/summable_abs.
  set G := fun y : U => _; have: summable G.
    case/summable_seqP: smS => M ge0_M leM.
    apply/summable_seqP; exists M => // J uqJ; rewrite {}/G.
    rewrite (eq_bigr (fun y => psum (F^~ y))) => [y _|].
      rewrite ger0_norm ?ge0_psum //; apply/eq_psum_abs => x.
      by rewrite !normrM [ `|_%:R|]ger0_norm ?(normr_id, ler0n).
    rewrite psum_bigop // => [y x|].
      by rewrite mulr_ge0 ?(normr_ge0, ler0n).
    apply/psum_le=> L uqL; pose G x := \sum_(j <- J | f x == j) `|S x|.
    rewrite (eq_bigr G) => [x _|]; first rewrite ger0_norm //.
    + by rewrite sumr_ge0 // => y _; rewrite mulr_ge0.
    + rewrite /G [RHS]big_mkcond /F /=; apply/eq_bigr=> y _.
      by case: ifPn => //; rewrite !simpm.
    rewrite {}/G /F; pose K := [seq x <- L | f x \in J].
    apply/(le_trans _ (leM K _)); rewrite ?filter_uniq //.
    rewrite le_eqVlt -(rwP orP); left; apply/eqP.
    rewrite /K big_filter [RHS]big_mkcond /=; apply/eq_bigr.
    move=> x _; case: ifPn => [fxJ|fxNJ].
      rewrite big_mkcond (bigD1_seq _ fxJ uqJ) /= eqxx.
      by rewrite big1 ?addr0 // => y; rewrite eq_sym => /negbTE=> ->.
    rewrite big_seq_cond big1 // => y; rewrite andbC.
    by case/andP=> /eqP<-; rewrite (negbTE fxNJ).
  move=> smG; apply/psum_le => J uqJ; pose K := undup (map f J).
  move/gerfinseq_psum: smG => /(_ K (undup_uniq _)).
  move/(le_trans _); apply; rewrite {}/G.
  pose G x y := `|S x| * (f x == y)%:R.
  rewrite (eq_bigr (fun y => psum (G^~ y))).
    move=> y _; rewrite ger0_norm ?ge0_psum //.
    rewrite -psum_abs; apply/eq_psum=> x.
    by rewrite normrM [ `|_%:R|]ger0_norm ?ler0n.
  rewrite psum_bigop => [y x|y|]; first by rewrite mulr_ge0.
    by apply/summable_condr/summable_abs.
  rewrite (eq_psum (F2 := fun x => `|S x * (f x \in K)%:R|)).
    move=> x; rewrite {}/G normrM. (*[ `|_%:R|]ger0_norm //.*)
    case/boolP: (f x \in K); last first.
      move=> fxNK.
      rewrite [ `|_%:R|]ger0_norm // mulr0 big_seq big1 // => y.
      apply/contraTeq; rewrite mulf_eq0 pnatr_eq0 eqb0.
      by rewrite negb_or negbK => /andP[_ /eqP<-].
    move=> fxK; rewrite (bigD1_seq (f x)) ?undup_uniq //=.
    rewrite [ `|_%:R|]ger0_norm // ?ler01 // eqxx !mulr1 big1 ?addr0 // => y; rewrite eq_sym.
    by move/negbTE=> ->; rewrite mulr0.
  rewrite big_seq (eq_bigr (fun j => `|S j * (f j \in K)%:R|)) {}/G.
    by move=> x /(map_f f); rewrite -mem_undup => ->; rewrite mulr1.
  rewrite psum_abs; set G := (fun x : T => _ in X in _<=X).
  have: summable G by apply/summable_condr.
  move/gerfinseq_psum => /(_ _ uqJ) /(le_trans _); apply.
  by rewrite -big_seq; apply/ler_sum => x _; rewrite normrM.
apply/psum_le=> J uqJ; pose F j := psum (fun x => `|S x| * (f x == j)%:R).
rewrite (eq_bigr F) => [y _|]; first rewrite ger0_norm ?ge0_psum //.
+ rewrite -psum_abs; apply/eq_psum => x; rewrite normrM.
  by rewrite [ `|_%:R|]ger0_norm ?ler0n.
rewrite psum_bigop => [y x|y|].
+ by rewrite mulr_ge0 ?(normr_ge0, ler0n).
+ by apply/summable_condr/summable_abs.
apply/psum_le=> L uqL; pose K := [seq x <- L | f x \in J].
have /gerfinseq_psum: uniq K by rewrite filter_uniq.
move=> /(_ _ _ smS) /(le_trans _); apply; rewrite big_filter.
rewrite le_eqVlt -(rwP orP); left; apply/eqP.
rewrite [RHS]big_mkcond /=; apply/eq_bigr=> x _.
rewrite big_seq; case: ifPn => [fx_in_J|fx_Nin_J].
  rewrite -big_seq (bigD1_seq _ fx_in_J uqJ) /= eqxx mulr1.
  rewrite big1 ?addr0 ?normr_id // => y; rewrite eq_sym.
  by move/negbTE=> ->; rewrite mulr0.
rewrite big1 ?normr0 // => y; apply/contraTeq.
rewrite mulf_eq0 pnatr_eq0 eqb0 negb_or negbK.
by case/andP => _ /eqP<-.
Qed.

Lemma partition_psum_cond (S : T -> R) : summable S ->
  psum S = psum (fun y => (C y)%:R * psum (fun x => S x * (f x == y)%:R)).
Proof.
move=> smS; apply/(eq_trans (partition_psum smS)).
apply/eq_psum => y; case/boolP: (C y); rewrite !simpm //.
move=> NCy; rewrite psum_eq0 // => x; case: (_ =P y).
  by move/eqP=> fxE; move/asboolP: NCy; case; exists x.
by rewrite mulr0.
Qed.
End PSumPartition.

(* -------------------------------------------------------------------- *)
Section PSumPair.
Context {R : realType} {T U : choiceType}.

Lemma psum_pair (S : T * U -> R) : summable S ->
  psum S = psum (fun x => psum (fun y => S (x, y))).
Proof.
move=> sblS; rewrite (partition_psum fst) //; apply/eq_psum.
move=> x /=; pose P := [pred xy : T * U | xy.1 == x].
rewrite (reindex_psum (h := [eta pair x]) (P := P)) //=.
+ case=> x' y' /=; rewrite mulf_eq0 => /norP[_].
  by rewrite pnatr_eq0 eqb0 negbK /P inE => /eqP->.
+ by exists snd => // -[x' y'] /eqP /= <-.
by apply/eq_psum=> y /=; rewrite eqxx mulr1.
Qed.

Lemma psum_pair_swap (S : T * U -> R) : summable S ->
  psum S = psum (fun y => psum (fun x => S (x, y))).
Proof.
move=> sblS; rewrite (partition_psum snd) //; apply/eq_psum.
move=> y /=; pose P := [pred xy : T * U | xy.2 == y].
rewrite (reindex_psum (h := [eta pair^~ y]) (P := P)) //=.
+ case=> x' y' /=; rewrite mulf_eq0 => /norP[_].
  by rewrite pnatr_eq0 eqb0 negbK /P inE => /eqP->.
+ by exists fst => // -[x' y'] /eqP /= <-.
by apply/eq_psum=> x /=; rewrite eqxx mulr1.
Qed.
End PSumPair.

(* -------------------------------------------------------------------- *)
(* FIXME: MOVE ME                                                       *)
Section SupInterchange.
Context {R : realType} {T U : Type}.

Lemma interchange_sup (S : T -> U -> R) :
    (forall x, has_sup [set r | exists y, r = S x y])
  -> has_sup [set r | exists x, r = sup [set r | exists y, r = S x y]]
  -> sup [set r | exists x, r = sup [set r | exists y, r = S x y]]
  = sup [set r | exists y, r == sup [set r | exists x, r = S x y]].
Proof using Type. Admitted.
End SupInterchange.

(* -------------------------------------------------------------------- *)
Section PSumInterchange.
Context {R : realType} {T U : choiceType}.

Lemma interchange_psum (S : T -> U -> R) :
    (forall x, summable (S x))
  -> summable (fun x => psum (fun y => S x y))
  -> psum (fun x => psum (fun y => S x y)) = psum (fun y => psum (fun x => S x y)).
Proof using Type. Admitted.
End PSumInterchange.

(* -------------------------------------------------------------------- *)
Section SumTheory.
Context {R : realType} {T : choiceType}.

Implicit Types (S : T -> R).

Lemma psum_sum S : (forall x, 0 <= S x) -> psum S = sum S.
Proof.
move=> ge0_S; rewrite /sum [X in _-X]psum_eq0 ?subr0.
  by move=> x; rewrite fneg_ge0.
by apply/eq_psum=> x; rewrite fpos_ge0.
Qed.

Lemma le_sum S1 S2 :
  summable S1 -> summable S2 -> (S1 <=1 S2) ->
    sum S1 <= sum S2.
Proof.
move=> smS1 smS2 leS; rewrite /sum ler_sub //.
  apply/le_psum/summable_fpos => // x.
  by rewrite ge0_fpos /= le_fpos.
apply/le_psum/summable_fneg => // x.
rewrite -!fposN ge0_fpos le_fpos // => y.
by rewrite ler_opp2.
Qed.

Lemma sum0 : sum (fun _ : T => 0) = 0 :> R.
Proof. by rewrite /sum !(eq_psum fpos0, eq_psum fneg0) !psum0 subr0. Qed.

Lemma sumN S : sum (- S) = - sum S.
Proof. by rewrite /sum (eq_psum (fnegN _)) (eq_psum (fposN _)) opprB. Qed.

Lemma sumZ S c : sum (c \*o S) = c * sum S.
Proof.
rewrite (eq_sum (F2 := fun x => Num.sg c * (`|c| * S x))).
  by move=> x; rewrite mulrA -numEsg.
transitivity (Num.sg c * sum (`|c| \*o S)).
  case: sgrP => [_|gt0_c|lt0_c]; rewrite ?Monoid.simpm.
  + by rewrite (eq_sum (F2 := fun _ => 0)) ?sum0 // => x; rewrite !mul0r.
  + by apply/eq_sum=> x; rewrite mul1r.
  by rewrite mulN1r -sumN; apply/eq_sum=> x; rewrite !mulN1r.
rewrite {1}/sum !(eq_psum (fposZ _ _), eq_psum (fnegZ _ _)) //.
by rewrite !psumZ // -mulrBr mulrA -numEsg.
Qed.

Lemma sumID S (P : pred T) :
  summable S -> sum S =
    sum (fun x => (P x)%:R * S x) + sum (fun x => (~~ P x)%:R * S x).
Proof.
move=> sm_S; rewrite /sum addrACA -[in RHS]opprD; congr (_ - _).
+ rewrite (psumID P); first by apply/summable_fpos.
  by congr (_ + _); apply/eq_psum => x; rewrite fpos_natrM.
+ rewrite (psumID P); first by apply/summable_fneg.
  by congr (_ + _); apply/eq_psum => x; rewrite fneg_natrM.
Qed.

Lemma sum_finseq S (r : seq T) :
  uniq r -> {subset [pred x | S x != 0] <= r} ->
    sum S = \sum_(x <- r) S x.
Proof.
move=> eqr domS; rewrite /sum !(psum_finseq eqr).
+ move=> x; rewrite !inE => xPS; apply/domS; rewrite !inE.
  move: xPS; rewrite /fpos normr_eq0.
  by apply: contra => /eqP ->; rewrite maxxx.
+ move=> x; rewrite !inE => xPS; apply/domS; rewrite !inE.
  move: xPS; rewrite /fneg normr_eq0.
  by apply: contra => /eqP ->; rewrite minxx.
rewrite -sumrB; apply/eq_bigr=> i _.
by rewrite !ger0_norm ?(ge0_fpos, ge0_fneg) ?fposBfneg.
Qed.

Lemma sum_seq1 S x : (forall y, S y != 0 -> x == y) -> sum S = S x.
Proof.
move=> domS; rewrite (sum_finseq (r := [:: x])) //.
  by move=> y; rewrite !inE => /domS /eqP->.
by rewrite big_seq1.
Qed.

End SumTheory.

Arguments sum_seq1 {R T} [S] x _.


Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.NArith.BinNat.
Require Import Coq.Arith.Compare.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep_dec.
Require Import ZArith.

Open Scope N_scope.

Definition option_prop {a : Set} (p : a -> Prop) (o : option a): Prop :=
  match o with
  | None => True
  | Some x => p x
  end.

Inductive mode : Set := Read | Write.

Inductive sender : Set := Server | Client.

Definition N8 := {n : N | n < 256}.

Definition N8_to_N (n : N8) : N := proj1_sig n.

Definition N16 := {n : N | n < 256*256}.

Definition N_to_N16 (n : N) : option N16 :=
  match n ?= 256 * 256 as cmp return (n ?= 256 * 256) = cmp -> option N16 with
  | Lt => fun pf => Some (exist _ n pf)
  | _ => fun _ => None
  end eq_refl.

Definition N16_to_N (n : N16) : N := proj1_sig n.

Theorem two_N8_bounds (a : N8) (b : N8) : N8_to_N a * 256 + N8_to_N b < 256*256.
  destruct a.
  destruct b.
  simpl.
  zify.
  omega.
Qed.

Theorem N16_to_N_injection : forall (a : N16) (b : N16), N16_to_N a = N16_to_N b -> a = b.
Proof.
  intros.
  unfold N16_to_N in H.
  unfold proj1_sig in H.
  revert H.
  destruct a.
  destruct b.
  intro.
  revert l.
  revert l0.
  rewrite H.
  intros.
  assert (l0 = l).
  * apply UIP_dec. decide equality.
  * rewrite H0. reflexivity.
Qed.

Lemma safe_N16_incr_any : forall (n16 : N16),
    let n := N16_to_N n16 + 1 in
    (n < 256*256) -> exists (m16 : N16), N_to_N16 n = Some m16.
Proof.
  intros.
  cut (n < 256 * 256).
  * generalize (N16_to_N n16 + 1).
    intros.
    eexists.
    unfold N_to_N16.
    cut (
        (fun pf : (n ?= 256 * 256) = Lt =>
           Some (exist (fun n : N => n < 256 * 256) n pf))
        =
        (fun pf : (n ?= 256 * 256) = Lt =>
           Some (exist (fun n : N => n < 256 * 256) n H))).
    ** intros ->.
       generalize (eq_refl (n ?= 256 * 256)).
       revert H0.
       case_eq (n ?= 256 * 256);
         intros; unfold N.lt in H1; congruence + reflexivity.
    ** extensionality pf.
       f_equal.
       f_equal.
       apply UIP_dec.
       decide equality.
  * zify; omega.
Qed.

Lemma safe_N16_incr : forall (n16 : N16),
    let n := N16_to_N n16 + 1 in
    (n < 256*256) -> exists (H0 : n < 256*256), N_to_N16 n = Some (exist _ n H0).
Proof.
  intros.
  cut (n < 256 * 256).
  * generalize n.
    intros.
    eexists.
    unfold N_to_N16.
    cut (
        (fun pf : (n0 ?= 256 * 256) = Lt =>
           Some (exist (fun n1 : N => n1 < 256 * 256) n0 pf))
        =
        (fun pf : (n0 ?= 256 * 256) = Lt =>
           Some (exist (fun n1 : N => n1 < 256 * 256) n0 H0))).
    ** intros ->.
       generalize (eq_refl (n0 ?= 256 * 256)).
       revert H0.
       case_eq (n0 ?= 256 * 256);
         intros; unfold N.lt in H1; congruence + reflexivity.
    ** extensionality pf.
       f_equal.
       f_equal.
       apply UIP_dec.
       decide equality.
  * zify; omega.
Qed.

Definition N16_of_two_N8 (a : N8) (b : N8): N16.
  refine (exist _ (N8_to_N a * 256 + N8_to_N b) (two_N8_bounds a b)).
Defined.

Definition fst {a : Set} {b : Set} (p : a * b): a := match p with (x, _) => x end.

Definition snd {a : Set} {b : Set} (p : a * b): b := match p with (_, x) => x end.


Section hilbert_cid.

  Definition hilbert := forall X, inhabited X -> X.
  Definition cid := forall X (P : X -> Prop), (exists x, P x) -> { x | P x }.

  Fact hilbert_cid : hilbert -> cid.
  Proof.
    intros H X P HP.
    apply H.
    destruct HP as (x & Hx).
    exists.
    exists x; auto.
  Qed.

  Fact cid_hilbert : cid -> hilbert.
  Proof.
    intros H X HX.
    set (P (_ : X) := True).
    assert (exists x, P x) as H1.
      destruct HX as [ x ].
      exists x; red; auto.
    apply H in H1.
    destruct H1 as (x & _); exact x.
  Qed.

  Fact hilbert_or_plus : hilbert -> forall A B : Prop, A \/ B -> { A } + { B }.
  Proof.
    intros H A B H1.
    apply H.
    destruct H1; exists; [ left | right ]; auto.
  Qed.

End hilbert_cid.


From Undecidability.L.Datatypes Require Import LProd LNat LTerm.

Fixpoint largestVar (s:term) : nat :=
  match s with
    var n => n
  | app s t => max (largestVar s) (largestVar t)
  | lam s => largestVar s
  end.

Lemma largestVar_prod X Y `{Rx : registered X} {Ry : registered Y} (w:X*Y):
  largestVar (enc w) = max (largestVar (enc (fst w))) (largestVar (enc (snd w))).
Proof.
  destruct w.
  unfold enc. destruct Rx,Ry. cbn.  reflexivity.
Qed.
Lemma largestVar_nat (n:nat):
  largestVar (enc n) <= 1.
Proof.
  unfold enc,registered_nat_enc.
  induction n;cbn in *. all:Lia.lia.
Qed.
Lemma largestVar_term (s:term):
  largestVar (enc s) <= 2.
Proof.
  unfold enc,registered_term_enc.
  induction s;cbn -[max] in *.
  1:rewrite largestVar_nat.
  all:try Lia.lia.
Qed.

Lemma largestVar_size s :
  largestVar s <= size s.
Proof.
  induction s;cbn;Lia.lia.
Qed.


(* Seven Trees in One *)
(* http://www.thebigquestions.com/2013/05/09/seven-trees-in-one/ *)

Inductive Tree :=
| Nil : Tree
| Cons :Tree -> Tree -> Tree.

Notation "[ a , b ]" := (Cons a b).

Check (Cons (Cons Nil Nil) Nil).
Check ([[Nil, Nil], Nil]).

Definition combineT (zt:Tree*Tree*Tree*Tree*Tree*Tree*Tree) :Tree :=
  match zt with
    | (t1,t2,t3,t4,t5,t6,t7) =>
      match t1,t2,t3,t4 with
        | Nil,Nil,Nil,Nil =>
          match t5,t6 with
            | [t5a,t5b],_ =>
              [[[[Nil,t7],t6],t5a],t5b]
            | Nil,[_,_] =>
              [[[[[t6,t7],Nil],Nil],Nil],Nil]
            | Nil,Nil =>
              match t7 with
                | [[[[t7a,t7b],t7c],t7d],t7e] =>
                  [[[[[Nil,t7a],t7b],t7c],t7d],t7e]
                | _ => t7
              end
          end
        | _,_,_,_ =>
          [[[[[[t7,t6],t5],t4],t3],t2],t1]
      end
  end.

Eval compute in (combineT (Nil,Nil,[Nil,Nil],Nil,Nil,Nil,Nil)).

Definition splitT (t:Tree) :Tree*Tree*Tree*Tree*Tree*Tree*Tree :=
  match t with
    | [[[[[[t7,t6],t5],t4],t3],t2],t1] =>
      match t1,t2,t3,t4 with
        | Nil,Nil,Nil,Nil =>
          (* case 3 *)
          (Nil,Nil,Nil,Nil,Nil,[t7,t6],t5)
        | _,_,_,_ =>
          (* case 1 *)
          (t1,t2,t3,t4,t5,t6,t7)
      end
    | [[[[[Nil,t7a],t7b],t7c],t7d],t7e] =>
      (Nil,Nil,Nil,Nil,Nil,Nil,[[[[t7a,t7b],t7c],t7d],t7e])
    | [[[[Nil,t7],t6],t5a],t5b] =>
      (Nil,Nil,Nil,Nil,[t5a,t5b],t6,t7)
    | _ =>
      (Nil,Nil,Nil,Nil,Nil,Nil,t)
  end.

Definition test_case1_0 := ([Nil,Nil],Nil,Nil,Nil,Nil,Nil,Nil).
Definition test_case1_1 := (Nil,[Nil,Nil],Nil,Nil,Nil,Nil,Nil).
Definition test_case2_0 := (Nil,Nil,Nil,Nil,[Nil,Nil],Nil,Nil).
Definition test_case2_1 := (Nil,Nil,Nil,Nil,[Nil,Nil],Nil,[Nil,Nil]).
Definition test_case3_0 := (Nil,Nil,Nil,Nil,Nil,[Nil,Nil],Nil).
Definition test_case3_1 := (Nil,Nil,Nil,Nil,Nil,[Nil,Nil],[Nil,Nil]).
Definition test_case4_0 := (Nil,Nil,Nil,Nil,Nil,Nil,[[[[Nil,Nil],Nil],Nil],Nil]).
Definition test_case4_1 := (Nil,Nil,Nil,Nil,Nil,Nil,[[[[Nil,Nil],Nil],[Nil,Nil]],Nil]).
Definition test_case4_2 := (Nil,Nil,Nil,Nil,Nil,Nil,[[[[Nil,Nil],Nil],Nil],[Nil,Nil]]).
Definition test_case4_3 := (Nil,Nil,Nil,Nil,Nil,Nil,[[[[Nil,[Nil,Nil]],Nil],Nil],Nil]).
Definition test_case5_0 := (Nil,Nil,Nil,Nil,Nil,Nil,Nil).
Definition test_case5_1 := (Nil,Nil,Nil,Nil,Nil,Nil,[Nil,Nil]).

Eval compute in splitT (combineT test_case1_0) = test_case1_0.
Eval compute in splitT (combineT test_case1_1) = test_case1_1.
Eval compute in splitT (combineT test_case2_0) = test_case2_0.
Eval compute in splitT (combineT test_case2_1) = test_case2_1.
Eval compute in splitT (combineT test_case3_0) = test_case3_0.
Eval compute in splitT (combineT test_case3_1) = test_case3_1.
Eval compute in splitT (combineT test_case4_0) = test_case4_0.
Eval compute in splitT (combineT test_case4_1) = test_case4_1.
Eval compute in splitT (combineT test_case4_2) = test_case4_2.
Eval compute in splitT (combineT test_case4_3) = test_case4_3.
Eval compute in splitT (combineT test_case5_0) = test_case5_0.
Eval compute in splitT (combineT test_case5_1) = test_case5_1.

Goal forall zt, splitT (combineT zt) = zt.
Proof.
  intros.
  unfold combineT.
  destruct zt as [[[[[[t1 t2] t3] t4] t5] t6] t7].
  destruct t5; destruct t6; destruct t7; simpl;
  destruct t1; destruct t2; destruct t3; destruct t4; try reflexivity.
  destruct t7_1; try reflexivity.
  destruct t7_1_1; try reflexivity.
  destruct t7_1_1_1; try reflexivity.
Qed.

Goal forall t, combineT (splitT t) = t.
Proof.
  intro t1. unfold splitT.
  destruct t1 as [_|t2]. reflexivity.
  destruct t2 as [_|t3]. reflexivity.
  destruct t3 as [_|t4]. reflexivity.
  destruct t4 as [_|t5]. reflexivity.
  destruct t5 as [_|t6]. reflexivity.
  destruct t6. reflexivity.

  destruct t4_1; destruct t3_1; destruct t2_1; destruct t1_1; reflexivity.
Qed.


Require Export SystemFR.ErasedTermLemmas.
Require Export SystemFR.FVLemmasLists.

Definition no_type_fvar T vars :=
  forall X, X ∈ pfv T type_var -> X ∈ vars -> False.

Lemma is_erased_term_no_type_fvar:
  forall t vars,
    is_erased_term t ->
    no_type_fvar t vars.
Proof.
  unfold no_type_fvar; repeat step || rewrite is_erased_term_tfv in *.
Qed.

Lemma no_type_fvar_open:
  forall T vars rep k,
    is_erased_term rep ->
    no_type_fvar T vars ->
    no_type_fvar (open k T rep) vars.
Proof.
  unfold no_type_fvar;
    repeat step || fv_open || list_utils ||
           rewrite is_erased_term_tfv in * by steps; eauto.
Qed.

Lemma no_type_fvar_tail:
  forall T x xs,
    no_type_fvar T (x :: xs) ->
    no_type_fvar T xs.
Proof.
  unfold no_type_fvar; repeat step; eauto.
Qed.

Lemma no_type_fvar_head:
  forall T x xs,
    no_type_fvar T (x :: xs) ->
    x ∈ pfv T type_var ->
    False.
Proof.
  unfold no_type_fvar; repeat step; eauto.
Qed.

#[export]
Hint Immediate no_type_fvar_head: b_no_type_fvar.
#[export]
Hint Resolve no_type_fvar_tail: b_no_type_fvar.

Lemma no_type_fvar_in_topen:
  forall T vars k X,
    no_type_fvar T vars ->
    ~(X ∈ vars) ->
    no_type_fvar (topen k T (fvar X type_var)) vars.
Proof.
  unfold no_type_fvar; repeat step || fv_open || list_utils; eauto.
Qed.

Lemma no_type_fvar_append:
  forall T vars1 vars2,
    no_type_fvar T vars1 ->
    no_type_fvar T vars2 ->
    no_type_fvar T (vars1 ++ vars2).
Proof.
  unfold no_type_fvar; repeat step || list_utils; eauto.
Qed.

Lemma no_type_fvar_subst:
  forall T l vars tag,
    pclosed_mapping l type_var ->
    no_type_fvar T vars ->
    no_type_fvar (psubstitute T l tag) vars.
Proof.
  unfold no_type_fvar; repeat step || eapply_any;
    eauto using pfv_in_subst.
Qed.


Set Implicit Arguments.

Require Import List.
Require Import JMeq.

Scheme JMeq_rec_type := Induction for JMeq Sort Type.

(*
JMeq_rec_type.
     : forall (A : Type) (x : A)
         (P : forall (B : Type) (b : B), JMeq x b -> Type),
       P A x JMeq_refl -> forall (B : Type) (x0 : B) (j : JMeq x x0), P B x0 j
*)

Check JMeq_eq.

Check JMeq_ind.
Print JMeq_ind.

(*
JMeq_ind
     : forall (A : Type) (x : A) (P : A -> Prop),
       P x -> forall y : A, JMeq x y -> P y
*)

Infix "==" := JMeq (at level 70, no associativity).

Lemma pairC: forall A B1 B2 (x:A)(y1:B1)(y2:B2), y1==y2 -> (x,y1) == (x, y2).
  intros until y2.
  intro Hy.
  rewrite Hy.
  reflexivity.
Qed.

Print pairC.

Definition Top_internal_JMeq_rew_r :=
fun (A : Type) (x : A) (B : Type) (b : B) (P : forall B0 : Type, B0 -> Type)
    (HC : P B b) (H : x == b) =>
  match H in (@JMeq _ _ B0 b0) return (P B0 b0 -> P A x) with
  | JMeq_refl => fun HC0 : P A x => HC0
  end HC.

Check Top_internal_JMeq_rew_r.

Print Assumptions pairC.

Lemma pairC': forall A B1 (x:A)(y1 y2:B1), y1==y2 -> (x,y1) == (x, y2).
 intros.
  apply pairC.
  assumption.

Restart.
 intros.
  eapply JMeq_ind with (2:=H).
  reflexivity.

Restart.
  intros until y2.
  intro Hy.
  rewrite Hy.
  reflexivity.
Qed.

Print pairC'.

Print Assumptions pairC'.

Definition pairC'': forall A B1 (x:A)(y1 y2:B1), y1==y2 -> (x,y1) == (x, y2) :=
fun (A B1: Type) (x : A) (y1 y2: B1) (Hy : y1 == y2) =>
Top_internal_JMeq_rew_r (fun (B3 : Type) (y3 : B3) => (x, y3) == (x, y2))
  JMeq_refl Hy.

Print Assumptions pairC''.


(* week-02_the-intro-tactic.v *)
(* FPP 2020 - YSC3236 2020-2021, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 23 Aug 2020 *)

(* ********** *)

Lemma a_proposition_implies_itself :
  forall A : Prop,
    A -> A.
Proof.
  intro A.
  intro H_A.
  exact H_A.

  Restart.

  intro rose.
  intro H_rose.
  exact H_rose.
Qed.

(* ********** *)

Lemma the_following_example :
  forall A B C : Prop,
    A ->
    B ->
    C ->
    forall i j : nat,
      A /\ B /\ C /\ i = i /\ j = j.
Proof.
  intros A B C.
  intros H_A H_B H_C.
  intros i j.
  split.
    exact H_A.
  split.
    exact H_B.
  split.
    exact H_C.
  split.
    reflexivity.
  reflexivity.
Qed.

(* ********** *)

Lemma a_pair_of_propositions_implies_the_left_one :
  forall A B : Prop,
    A /\ B -> A.
Proof.
  intros A B.
  intro H_A_and_B.
  destruct H_A_and_B.
  exact H.

  Restart.

  intros A B.
  intro H_A_and_B.
  destruct H_A_and_B as [H_A H_B].
  exact H_A.

  Restart.

  intros A B.
  intros [H_A H_B].
  exact H_A.
Qed.

(* ********** *)

Lemma disjunction_is_commutative :
  forall A B : Prop,
    A \/ B -> B \/ A.
Proof.
  intros A B.
  intros [H_A | H_B].

  - right.
    exact H_A.

  - left.
    exact H_B.
Qed.

(* ********** *)

Lemma about_nested_conjunctions :
  forall A B C D : Prop,
    (A /\ B) /\ (C /\ D) -> (D /\ A) /\ (B /\ C).
Proof.
  intros A B C D.
  intros [[H_A H_B] [H_C H_D]].
  Check (conj (conj H_D H_A) (conj H_B H_C)).
  exact (conj (conj H_D H_A) (conj H_B H_C)).
Qed.

Lemma about_nested_conjunctions_and_disjunctions :
  forall A B C D E F : Prop,
    (A \/ B) /\ (C \/ (D /\ E)) -> F.
Proof.
  intros A B C D E F.
  intros [[H_A | H_B] [H_C | [H_D H_E]]].
Abort.

(* ********** *)

(* end of week-02_the-intro-tactic.v *)


(** * Group Structure *)

From DEZ.Has Require Export
  EquivalenceRelations Operations.
From DEZ.Is Require Export
  Monoid Invertible Proper
  Fixed Involutive Injective Cancellative Antidistributive
  Preserving Unital Compatible.
From DEZ.Provides Require Import
  TypeclassTactics.
From DEZ.Supports Require Import
  EquivalenceNotations AdditiveNotations.

#[local] Open Scope core_scope.

(** ** Group *)

Class IsGrp (A : Type) (X : A -> A -> Prop)
  (x : A) (f : A -> A) (k : A -> A -> A) : Prop := {
  grp_is_mon :> IsMon X x k;
  grp_is_inv :> IsInv X x f k;
  grp_is_proper :> IsProper (X ==> X) f;
}.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (x : A) (f : A -> A) (k : A -> A -> A) `{!IsGrp X x f k}.

#[local] Instance grp_has_equiv_rel : HasEquivRel A := X.
#[local] Instance grp_has_null_op : HasNullOp A := x.
#[local] Instance grp_has_un_op : HasUnOp A := f.
#[local] Instance grp_has_bin_op : HasBinOp A := k.

Ltac note := progress (
  denote X with (equiv_rel (A := A));
  denote x with (null_op (A := A));
  denote f with (un_op (A := A));
  denote k with (bin_op (A := A))).

(** Zero is a fixed point of negation. *)

#[export] Instance grp_is_fixed : IsFixed X x f.
Proof with note.
  hnf...
  rewrite <- (unl_elem_r (- x)).
  rewrite (inv_l x).
  reflexivity.
Qed.

(** Negation is an involution. *)

#[export] Instance grp_is_invol : IsInvol X f.
Proof with note.
  intros y...
  rewrite <- (unl_elem_r (- (- y))).
  rewrite <- (inv_l y).
  rewrite (assoc (- (- y)) (- y) y).
  rewrite (inv_l (- y)).
  rewrite (unl_elem_l y).
  reflexivity.
Qed.

(** Negation is injective. *)

#[export] Instance grp_is_inj : IsInj X f.
Proof with note.
  intros y z a...
  rewrite <- (unl_elem_l z).
  rewrite <- (inv_r y).
  rewrite a.
  rewrite <- (assoc y (- z) z).
  rewrite (inv_l z).
  rewrite (unl_elem_r y).
  reflexivity.
Qed.

(** Addition is left-cancellative. *)

#[local] Instance grp_is_cancel_l : IsCancelL X k.
Proof with note.
  intros y z w a...
  rewrite <- (unl_elem_l z).
  rewrite <- (inv_l y).
  rewrite <- (assoc (- y) y z).
  rewrite a.
  rewrite (assoc (- y) y w).
  rewrite (inv_l y).
  rewrite (unl_elem_l w).
  reflexivity.
Qed.

(** Addition is right-cancellative. *)

#[local] Instance grp_is_cancel_r : IsCancelR X k.
Proof with note.
  intros y z w a...
  rewrite <- (unl_elem_r y).
  rewrite <- (inv_r w).
  rewrite (assoc y w (- w)).
  rewrite a.
  rewrite <- (assoc z w (- w)).
  rewrite (inv_r w).
  rewrite (unl_elem_r z).
  reflexivity.
Qed.

(** Addition is cancellative. *)

#[export] Instance grp_is_cancel : IsCancel X k.
Proof. esplit; typeclasses eauto. Qed.

(** Negation antidistributes over addition. *)

#[export] Instance grp_is_antidistr_un_op : IsAntidistrUnOp X f k.
Proof with note.
  intros y z...
  apply (cancel_l (y + z) (- (y + z)) ((- z) + (- y)))...
  rewrite (inv_r (y + z)).
  rewrite (assoc (y + z) (- z) (- y)).
  rewrite <- (assoc y z (- z)).
  rewrite (inv_r z).
  rewrite (unl_elem_r y).
  rewrite (inv_r y).
  reflexivity.
Qed.

End Context.

(** ** Group Homomorphism *)

Class IsGrpHom (A B : Type)
  (X : A -> A -> Prop) (x : A) (f : A -> A) (k : A -> A -> A)
  (Y : B -> B -> Prop) (y : B) (g : B -> B) (m : B -> B -> B)
  (h : A -> B) : Prop := {
  grp_hom_dom_is_grp : IsGrp X x f k;
  grp_hom_codom_is_grp : IsGrp Y y g m;
  grp_hom_is_bin_pres :> IsBinPres Y k m h;
  grp_hom_is_proper :> IsProper (X ==> Y) h;
}.

Section Context.

Context (A B : Type)
  (X : A -> A -> Prop) (x : A) (f : A -> A) (k : A -> A -> A)
  (Y : B -> B -> Prop) (y : B) (g : B -> B) (m : B -> B -> B)
  (h : A -> B) `{!IsGrp X x f k} `{!IsGrp Y y g m}
  `{!IsGrpHom X x f k Y y g m h}.

#[local] Instance grp_hom_dom_has_equiv_rel : HasEquivRel A := X.
#[local] Instance grp_hom_dom_has_null_op : HasNullOp A := x.
#[local] Instance grp_hom_dom_has_un_op : HasUnOp A := f.
#[local] Instance grp_hom_dom_has_bin_op : HasBinOp A := k.
#[local] Instance grp_hom_codom_has_equiv_rel : HasEquivRel B := Y.
#[local] Instance grp_hom_codom_has_null_op : HasNullOp B := y.
#[local] Instance grp_hom_codom_has_un_op : HasUnOp B := g.
#[local] Instance grp_hom_codom_has_bin_op : HasBinOp B := m.

Ltac note := progress (
  denote X with (equiv_rel (A := A));
  denote x with (null_op (A := A));
  denote f with (un_op (A := A));
  denote k with (bin_op (A := A));
  denote Y with (equiv_rel (A := B));
  denote y with (null_op (A := B));
  denote g with (un_op (A := B));
  denote m with (bin_op (A := B))).

(** Homomorphisms preserve zero. *)

#[export] Instance grp_hom_is_null_pres : IsNullPres Y x y h.
Proof with note.
  hnf...
  apply (cancel_l (h 0) (h 0) 0).
  rewrite <- (bin_pres 0 0).
  rewrite (unl_elem_l 0).
  rewrite (unl_elem_r (h 0)).
  reflexivity.
Qed.

(** Homomorphisms preserve negation. *)

#[export] Instance grp_hom_is_un_pres : IsUnPres Y f g h.
Proof with note.
  intros z...
  apply (cancel_l (h z) (h (- z)) (- h z)).
  rewrite <- (bin_pres z (- z)).
  rewrite (inv_r z).
  rewrite (inv_r (h z)).
  apply null_pres.
Qed.

End Context.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (x : A) (f : A -> A) (k : A -> A -> A) `{!IsGrp X x f k}.

(** Identity is a group homomorphism. *)

#[export] Instance id_is_grp_hom : IsGrpHom X x f k X x f k id.
Proof.
  split.
  - typeclasses eauto.
  - typeclasses eauto.
  - enough (IsDistrUnOp X id k) by assumption. typeclasses eauto.
  - typeclasses eauto.
Qed.

End Context.

(** ** Left Group Action *)

Class IsGrpActL (A B : Type)
  (X : A -> A -> Prop) (x : A) (f : A -> A) (k : A -> A -> A)
  (Y : B -> B -> Prop) (al : A -> B -> B) : Prop := {
  grp_act_l_is_grp : IsGrp X x f k;
  grp_act_l_is_unl_elem_act_l :> IsUnlElemActL Y x al;
  grp_act_l_is_compat_ext_act_l :> IsCompatExtActL Y k al;
  grp_act_l_is_proper :> IsProper (X ==> Y ==> Y) al;
}.

Section Context.

Context (A : Type) (X : A -> A -> Prop)
  (x : A) (f : A -> A) (k : A -> A -> A) `{!IsGrp X x f k}.

(** Identity is a left group action. *)

#[export] Instance id_is_grp_act_l : IsGrpActL X x f k X (flip const).
Proof.
  split.
  - typeclasses eauto.
  - enough (IsUnlElemL X x (flip const)) by assumption.
    intros y. unfold flip, const. reflexivity.
  - enough (IsAssoc X (flip const)) by assumption.
    intros y z w. unfold flip, const. reflexivity.
  - typeclasses eauto.
Qed.

(** Addition is a left group action. *)

#[export] Instance bin_op_is_grp_act_l : IsGrpActL X x f k X k.
Proof.
  split.
  - typeclasses eauto.
  - enough (IsUnlElemL X x k) by assumption. typeclasses eauto.
  - enough (IsAssoc X k) by assumption. typeclasses eauto.
  - typeclasses eauto.
Qed.

End Context.


Definition NonEmpty_foldr1 {a} (f : a -> a -> a) (x: GHC.Base.NonEmpty a) : a :=
  match x with
    | GHC.Base.NEcons a as_ => List.fold_right f a as_
  end.

Definition NonEmpty_maximum {a} `{GHC.Base.Ord a} (x:GHC.Base.NonEmpty a) : a :=
  NonEmpty_foldr1 GHC.Base.max x.

Definition NonEmpty_minimum {a} `{GHC.Base.Ord a} (x:GHC.Base.NonEmpty a) : a :=
  NonEmpty_foldr1 GHC.Base.min x.

Definition toList {a} : GHC.Base.NonEmpty a -> list a :=
  fun arg_0__ => match arg_0__ with | GHC.Base.NEcons a as_ => cons a as_ end.

Definition List_size {a} : list a -> nat :=
List.fold_right (fun x y => S y) O .
Definition NonEmpty_size {a} : GHC.Base.NonEmpty a -> nat :=
  fun arg_0__ =>
    match arg_0__ with
      | GHC.Base.NEcons _ xs => 1 + List_size xs
    end.

Program Fixpoint insertBy {a} (cmp: a -> a -> comparison) (x : a)
        (xs : GHC.Base.NonEmpty a) {measure (NonEmpty_size xs)} : GHC.Base.NonEmpty a :=
  match xs with
  | GHC.Base.NEcons x nil => GHC.Base.NEcons x nil
  | (GHC.Base.NEcons y ((cons y1 ys') as ys)) =>
    match cmp x y with
    | Gt  => GHC.Base.NEcons y (toList (insertBy cmp x (GHC.Base.NEcons y1 ys')))
    | _   => GHC.Base.NEcons x ys
    end
  end.

Program Fixpoint insertBy' {a} (cmp: a -> a -> comparison) (x : a)
        (xs : list a) {measure (List_size xs)} : GHC.Base.NonEmpty a :=
  match xs with
  | nil => GHC.Base.NEcons x nil
  | cons x nil => GHC.Base.NEcons x nil
  | (cons y ((cons y1 ys') as ys)) =>
    match cmp x y with
    | Gt  => GHC.Base.NEcons y (toList (insertBy' cmp x (cons y1 ys')))
    | _   => GHC.Base.NEcons x ys
    end
  end.

Definition insert {a} `{GHC.Base.Ord a} : a ->  GHC.Base.NonEmpty a -> GHC.Base.NonEmpty a :=
  insertBy GHC.Base.compare.

Definition sortBy {a} : (a -> a -> comparison) -> GHC.Base.NonEmpty a -> GHC.Base.NonEmpty a :=
  fun f ne => match ne with
           | GHC.Base.NEcons x xs => insertBy' f x (Data.OldList.sortBy f xs)
           end.

Definition sort {a} `{GHC.Base.Ord a} : GHC.Base.NonEmpty a -> GHC.Base.NonEmpty a :=
             sortBy GHC.Base.compare.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Parameter pow2: Z -> Z.

Axiom Power_0 : ((pow2 0%Z) = 1%Z).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%Z * (pow2 n))%Z).

Axiom Power_1 : ((pow2 1%Z) = 2%Z).

Axiom Power_sum : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%Z).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2; admit.
Open Scope Z_scope.

(* Why3 goal *)
Theorem pow2pos : forall (i:Z), (0%Z <= i)%Z -> (0%Z < (pow2 i))%Z.
(* Why3 intros i h1. *)
intros i Hi.
generalize Hi.
pattern i; apply Z_lt_induction; auto.
intros j Hind Hj.
assert (h: j=0 \/ j>0) by omega; destruct h.
ae.
replace j with ((j-1)+1) by omega.
ae.
Admitted.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype div.
From mathcomp Require Import tuple finfun path bigop finset binomial fingroup perm automorphism action.

From Combi Require Import symgroup partition Greene.

Set Implicit Arguments.
Unset Strict Implicit.

Section Definitions.

Variable T : finType.
Implicit Type s : {perm T}.

Lemma pcycleP s x y : reflect (exists i, y = (s ^+ i)%g x) (y \in pcycle s x).
Proof.
  apply (iffP idP).
  - rewrite pcycle_traject => H.
    have:= H; rewrite -index_mem size_traject => Hlt.
    exists (index y (traject s x #|pcycle s x|)).
    have {Hlt} := nth_traject s Hlt x; rewrite (nth_index _ H) => {H} {1}->.
    elim: (index _ _) => [|n IHn] /=; first by rewrite expg0 perm1.
    by rewrite expgSr permM IHn.
  - move => [i ->]; exact: mem_pcycle.
Qed.

Lemma pcycleV s x : pcycle s^-1 x = pcycle s x.
Proof. rewrite -setP => y; by rewrite /pcycle cycleV. Qed.

Lemma pcycle_s s x y : y \in pcycle s x -> s y \in pcycle s x.
Proof.
  rewrite -!eq_pcycle_mem => /eqP <-.
  by have:= mem_pcycle s 1 y; rewrite eq_pcycle_mem expg1 => ->.
Qed.

Lemma pcycle1 s x : s x = x <-> pcycle s x = [set x].
Proof.
  split => [Heq | Hcy].
  - rewrite -setP => y; rewrite !inE.
    apply/pcycleP/idP=> [[i ->] | /eqP ->]; last by exists 0; rewrite expg0 perm1.
    elim: i => [//=| i /eqP IHi]; first by rewrite expg0 perm1.
    by rewrite expgSr permM IHi Heq.
  - by have := mem_pcycle s 1 x; rewrite expg1 Hcy inE => /eqP.
Qed.

Definition support s := [set x | s x != x].

Lemma support0 s : support s = set0 -> s = 1%g.
Proof.
  move=> H; rewrite -permP => y; rewrite perm1.
  suff : y \notin support s by rewrite inE negbK => /eqP.
  by rewrite H inE.
Qed.

Lemma support_stable s x : (x \in support s) = (s x \in support s).
Proof.
  rewrite !inE; congr negb; apply/idP/idP => [/eqP -> // | /eqP H].
  by rewrite -[s x](permK s) H permK.
Qed.

Lemma pcycle_subset_support s x :
  x \in support s -> pcycle s x \subset support s.
Proof.
  move=> H; apply/subsetP => y; rewrite -eq_pcycle_mem => /eqP Heq.
  move: H; rewrite !inE; apply contra => /eqP Hy.
  have:= Hy => /pcycle1; rewrite {}Heq => Hyx.
  have:= pcycle_id s x; rewrite {}Hyx inE => /eqP ->.
  by rewrite Hy.
Qed.

Lemma support_card s x : (x \in support s) = (#|pcycle s x| != 1).
Proof.
  rewrite neq_ltn ltnS leqn0 cards_eq0.
  have /negbTE -> /= : pcycle s x != set0.
    apply/set0Pn; exists x; exact: pcycle_id.
  rewrite inE; apply/idP/idP.
  - apply contraR; rewrite -leqNgt => Hcard.
    apply/eqP/pcycle1/eqP; rewrite eq_sym eqEcard cards1 Hcard andbT.
    apply/subsetP => y; rewrite inE => /eqP ->; exact: pcycle_id.
  - apply contraL => /eqP/pcycle1 ->.
    by rewrite cards1.
Qed.

Lemma support_disjointC s t :
  [disjoint support s & support t] -> (s * t = t * s)%g.
Proof.
  move=> Hdisj; apply/permP => x; rewrite !permM.
  case: (boolP (x \in support s)) => [Hs |].
  - have:= Hdisj; rewrite disjoints_subset => /subsetP H.
    have:= H x Hs; rewrite !inE negbK => /eqP ->.
    by move: Hs; rewrite support_stable => /H; rewrite !inE negbK => /eqP ->.
  - rewrite inE negbK => /eqP Hs; rewrite Hs.
    case: (boolP (x \in support t)) => [Ht |].
    + move: Ht; rewrite support_stable.
      move: Hdisj; rewrite -setI_eq0 setIC setI_eq0 disjoints_subset => /subsetP.
      by move=> H/H{H}; rewrite !inE negbK => /eqP ->.
    + by rewrite inE negbK => /eqP ->; rewrite Hs.
Qed.

Lemma trivIset_supportC (A B : seq {perm T}) :
  trivIseq [seq support s | s <- A] -> perm_eq A B ->
  (\prod_(s <- A) s = \prod_(s <- B) s)%g.
Proof.
  move=> Htriv Hperm.
  apply: (catCA_perm_ind
            (P := fun S => (\prod_(s <- A) s = \prod_(s <- S) s)%g)
            _ Hperm (erefl _)).
Admitted.

Definition cyclefun_of s x := [fun y => if y \in pcycle s x then s y else y].

Lemma cyclefun_ofP s x : injective (cyclefun_of s x).
Proof.
  move=> y z /=.
  case: (boolP (y \in pcycle s x)) => Hy;
    case: (boolP (z \in pcycle s x)) => Hz // Heq.
  - exact: (perm_inj Heq).
  - by exfalso; move: Heq Hz => <-; rewrite pcycle_s.
  - by exfalso; move: Heq Hy => ->; rewrite pcycle_s.
Qed.

Definition cycle_of s x : {perm T} := perm (@cyclefun_ofP s x).

Lemma cycle_ofK s x y : (cycle_of s^-1 x) ((cycle_of s x) y) = y.
Proof.
  rewrite !permE /=.
  case: (boolP (y \in pcycle s x)); rewrite pcycleV.
  - by move=> /pcycle_s ->; rewrite permK.
  - by move=> /negbTE ->.
Qed.

Lemma cycle_ofV s x : ((cycle_of s x)^-1)%g = cycle_of s^-1 x.
Proof.
  rewrite -permP => y.
  by rewrite -{2}(permKV (cycle_of s x) y) cycle_ofK.
Qed.

Lemma cycle_of_nsupp s x :
  x \notin support s -> cycle_of s x = 1%g.
Proof.
  rewrite inE negbK => /eqP/pcycle1 Hx.
  rewrite -permP => y.
  rewrite permE /= Hx inE perm1.
  by case: eqP => [-> | //]; rewrite pcycle1.
Qed.

Lemma support_cycle_of s x :
  x \in support s -> support (cycle_of s x) = pcycle s x.
Proof.
  move=> H; rewrite -setP => y.
  rewrite /support inE permE /=.
  case: (boolP (y \in pcycle s x)); last by rewrite eq_refl.
  rewrite pcycle_sym=> Hcy; move: H; rewrite /support inE.
  apply contra => /eqP; rewrite pcycle1 => Hy.
  move: Hcy; rewrite Hy inE => /eqP ->.
  by apply/eqP; rewrite pcycle1.
Qed.

Lemma exp_cycle_of s x n : (cycle_of s x ^+ n)%g x = (s ^+ n)%g x.
Proof.
  elim: n => [// | n IHn].
  by rewrite !expgSr !permM {}IHn permE /= mem_pcycle.
Qed.

Lemma pcycle_cycle_ofE s x : pcycle (cycle_of s x) x = pcycle s x.
Proof.
  rewrite -setP => y.
  by apply/pcycleP/pcycleP => [] [i Hi]; exists i; rewrite {}Hi exp_cycle_of.
Qed.

Definition is_cycle s := #|[set C in pcycles s | #|C| != 1 ]| == 1.

Lemma is_cycleP s :
  reflect (exists x, x \in support s /\ cycle_of s x = s) (is_cycle s).
Proof.
  rewrite /is_cycle; apply (iffP idP).
  - move=> /cards1P [] C HC.
    have:= eq_refl C; rewrite -in_set1 -HC inE => /andP [] /imsetP [x _] HCC.
    subst C; rewrite -support_card => Hx.
    exists x; split; first exact Hx.
    suff Heq : support s = pcycle s x.
      by rewrite -permP => y; rewrite permE /= -Heq inE; case: eqP.
    rewrite -setP => y.
    by rewrite -eq_pcycle_mem -in_set1 -HC inE mem_imset //= support_card.
  - move=> [x [Hx Hcy]].
    suff -> : [set C in pcycles s | #|C| != 1] = [set pcycle s x] by rewrite cards1.
    rewrite -setP => C; rewrite /pcycles !inE; apply/idP/idP.
    + move=> /andP [] /imsetP [x0 _ -> {C}].
      by rewrite -support_card -{1}Hcy (support_cycle_of Hx) eq_pcycle_mem.
    + move=> /eqP ->.
      by rewrite mem_imset // -support_card Hx.
Qed.

Lemma cycle_ofP s x : x \in support s -> is_cycle (cycle_of s x).
Proof.
  move=> H; apply/is_cycleP; exists x; split.
  - by move: H; rewrite !inE permE /= pcycle_id.
  - rewrite -permP => y; rewrite permE /=.
    by rewrite pcycle_cycle_ofE permE /=; case: (y \in _).
Qed.

Lemma perm_cycle_ofK s x :
  support ((cycle_of s x)^-1 * s) = support s :\: pcycle s x.
Proof.
  rewrite -setP => y; rewrite !inE -negb_or orbC; congr negb.
  case: (altP (s y =P y)) => /= Hy.
  - have Hcy : cycle_of s x y = y.
      by rewrite permE /= Hy if_same.
    by rewrite -{1}Hcy permM permK Hy eq_refl.
  - rewrite cycle_ofV permM permE /= pcycleV.
    case: (y \in pcycle s x).
    + by rewrite permKV eq_refl.
    + exact: negbTE.
Qed.

Lemma supp_decr s x :
  x \in support s -> #|support ((cycle_of s x)^-1 * s)| < #|support s|.
Proof.
  rewrite perm_cycle_ofK cardsD => Hsupp.
  rewrite -subSn; last by apply subset_leqif_cards; exact: subsetIl.
  rewrite leq_subLR.
  rewrite -{1}(add0n #|_|) ltn_add2r lt0n cards_eq0.
  by apply/set0Pn; exists x; rewrite inE Hsupp pcycle_id.
Qed.

Fixpoint dec_cycles_rec n s : seq {perm T} :=
  if n is n'.+1 then
    if pick (mem (support s)) is Some x then
      (cycle_of s x) :: (dec_cycles_rec n' ((cycle_of s x)^-1 * s))
    else [::]
  else [::].
Definition dec_cycles s := dec_cycles_rec #|support s|.+1 s.

Lemma dec_cycles_recE s : (\prod_(c <- dec_cycles s) c = s)%g.
Proof.
  rewrite /dec_cycles.
  move: {2 3}_.+1 (ltnSn #|support s|) => n.
  elim: n s => [// | n IHn] s Hcard /=.
  case: pickP => [x /= Hx |]/=.
  - rewrite big_cons {}IHn; first by rewrite mulgA mulgV mul1g.
    rewrite -ltnS; apply: (leq_trans _ Hcard); exact: supp_decr.
  - rewrite big_nil => H; apply esym; apply support0.
    by rewrite -setP => x; have /= -> := (H x); rewrite inE.
Qed.

Lemma all_dec_cyclesP s : all is_cycle (dec_cycles s).
Proof.
  rewrite /dec_cycles.
  move: {2 3}_.+1 (ltnSn #|support s|) => n.
  elim: n s => [// | n IHn] s Hcard /=.
  case: pickP => [x /= Hx | //].
  rewrite cycle_ofP //=; apply: IHn.
  rewrite -ltnS; apply: (leq_trans _ Hcard); exact: supp_decr.
Qed.

Lemma support_dec_cycles_rec s n :
  all (fun C => support C \subset support s) (dec_cycles_rec n s).
Proof.
  elim: n s => [// | n IHn] s /=.
  case: pickP => [x /= Hx | //]; apply /andP; split.
  - rewrite (support_cycle_of Hx).
    exact: pcycle_subset_support.
  - have:= IHn ((cycle_of s x)^-1 * s)%g.
    apply sub_all => mu /subset_trans; apply.
    apply/subsetP => y; rewrite !inE.
    apply contra => /eqP.
    rewrite permM cycle_ofV permE /= pcycleV.
    case: (y \in _) => [|-> //];  by rewrite permKV.
Qed.

Lemma trivIseq_dec s : trivIseq [seq support C | C <- dec_cycles s].
Proof.
  rewrite /dec_cycles.
  move: {2 3}_.+1 (ltnSn #|support s|) => n.
  elim: n s => [// | n IHn] s Hcard /=.
  case: pickP => [x /= Hx | _ i j /= /andP [] //].
  case=> [ |i] [| j] //=; rewrite !ltnS.
  + move=> /(mem_nth set0).
    move: (nth _ _ _) => S /mapP [] mu.
    move=> /(allP (support_dec_cycles_rec ((cycle_of s x)^-1 * s) n)).
    rewrite perm_cycle_ofK support_cycle_of // => Hsubs -> {S}.
    rewrite disjoint_sym disjoints_subset.
    apply (subset_trans Hsubs); rewrite setDE; exact: subsetIr.
  + apply IHn.
    rewrite -ltnS; apply: (leq_trans _ Hcard); exact: supp_decr.
Qed.

End Definitions.


Require Import Vec_def.
Require Import Omega.
Require Import Ass_handling.
Require Import PI.

Lemma Vget_PI : forall {A : Type} {n : nat} (v : Vec A n) (m : nat) (mltn1 mltn2 : m < n),
      Vget v m mltn1 = Vget v m mltn2.
Proof.
intros A n v ; induction v.
 intros m H ; apply False_ind ; omega.
 destruct m ; simpl ; auto.
Qed.

Lemma Vmap_sound : forall (A B : Type) (n : nat) (f : A -> B) (v : Vec A n)
  (p : nat) (pltn : p < n), Vget (Vmap f v) p pltn = f (Vget v p pltn).
Proof.
intros A B n f v ; induction v ; intros p pltn.
 inversion pltn.
 destruct p ; [reflexivity | simpl ; apply IHv].
Qed.

Lemma Vmap_full_sound : forall (A B : Type) (n : nat)
  (f : forall (m : nat) (mltn : m < n), A -> B)
  (v : Vec A n) (p : nat) (pltn : p < n),
  Vget (Vmap_full f v) p pltn = f p pltn (Vget v p pltn).
Proof.
intros A B n f v ; induction v ; intros p pltn.
 inversion pltn.
 destruct p ; simpl ; [| rewrite IHv ] ;
 f_equal ; apply lt_PI.
Qed.

Definition Vec_rect2 : forall A (P : forall n, Vec A n -> Vec A n -> Type),
  P 0 Vnil Vnil -> (forall n h1 h2 (v1 v2 : Vec A n), P n v1 v2 -> P (S n) (Vcon h1 v1) (Vcon h2 v2)) ->
  forall n v1 v2, P n v1 v2 :=
fun A P H0 HS => fix F (n : nat) {struct n} :=
match n return forall (v1 v2 : Vec A n), P n v1 v2 with
| 0 => fun v1 =>
  match v1 in Vec _ m return
    match m with
    | 0 => forall v2 : Vec A m, P m v1 v2
    | S _ => False -> False
    end
  with
  | Vnil => fun v2 =>
    match v2 in Vec _ m return
      match m return forall v2 : Vec A m, Type with
      | 0 => fun v2 => P 0 Vnil v2
      | S _ => fun v2 => False -> False
      end v2
    with
    | Vnil => H0
    | Vcon _ _ => False_rect _
    end
  | Vcon _ _ => False_rect _
  end
| S n =>
  let F := F n in
  fun v1 => match v1 in Vec _ m return
    match m with
    | 0 => False -> False
    | S m' => (forall v1 v2, P m' v1 v2) -> forall v2 : Vec A m, P m v1 v2
    end
  with
  | Vnil => False_rect _
  | Vcon h1 v1 => fun F v2 =>
    match v2 in Vec _ m return
      match m return forall v2 : Vec A m, Type with
      | 0 => fun v2 => False -> False
      | S m => fun v2 => forall v1 : Vec A m, (forall v2, P _ v1 v2) -> P (S m) (Vcon h1 v1) v2
      end v2
    with
    | Vnil => False_rect _
    | Vcon h2 v2 => fun v1 F => HS _ h1 h2 v1 v2 (F v2)
    end v1 (F v1)
  end F
end.

Lemma Vec_ext_eq : forall (A : Type) (n : nat) (v1 v2 : Vec A n)
  (Hext : forall (p : nat) (pr : p < n), Vget v1 p pr = Vget v2 p pr),
  v1 = v2.
Proof.
intros A n v1 v2; pattern n, v1, v2; apply Vec_rect2; clear.
+ reflexivity.
+ intros n h1 h2 v1 v2 IH H; f_equal.
  - assert (pr : 0 < S n) by auto with arith.
    now apply (H 0 pr).
  - apply IH; intros p pr.
    assert (prS : S p < S n) by auto with arith.
    specialize (H _ prS); simpl in H.
    erewrite (Vget_PI v1), (Vget_PI v2); eassumption.
Qed.

Lemma genVec_pr_get : forall (n p : nat) (pr : p < n),
  Vget (genVec_pr n) p pr = exist _ p pr.
Proof.
intros n p pr ; unfold genVec_pr ; rewrite Vmap_full_sound ;
 reflexivity.
Qed.

Definition PI_fun {A n} (P : forall (m : nat), m < n -> A) :=
  forall (m : nat) (pr1 pr2 : m < n), P m pr1 = P m pr2.

Lemma genVec_P_get : forall (A : Type) (n : nat) (P : forall (m : nat), m < n -> A)
 (m : nat) (mltn : m < n), PI_fun P -> Vget (genVec_P n P) m mltn = P m mltn.
Proof.
intros A n P m mltn HP ; unfold genVec_P ; rewrite Vmap_full_sound ;
reflexivity.
Qed.

Lemma genVec_get : forall (n p : nat) (pr : p < n), Vget (genVec n) p pr = p.
Proof.
intro n ; induction n ; intros p pr.
 inversion pr.
 destruct p ; [| simpl ; rewrite Vmap_full_sound] ; reflexivity.
Qed.

(*
Lemma genVec2_get : forall (n p : nat) (pr : p < n), Vget (genVec2 n) p pr = p.
Proof.
intros n p pr ; unfold genVec2, genVec_P ;
 rewrite Vmap_sound ; apply genVec_pr_get.
Qed.

Lemma genVec_genVec_pr : forall (n : nat), genVec n = genVec2 n.
Proof.
intros ; apply Vec_ext_eq ; intros ;
 rewrite genVec_get, genVec2_get ; reflexivity.
Qed.
*)


(* exercise 5.1 *)

Lemma id_P : forall (P : Prop), P -> P.
Proof.
  intros P p.
  assumption.
Qed.

Lemma id_PP : forall (P : Prop), (P -> P) -> (P -> P).
Proof.
  intros P pp p.
  assumption.
Qed.

Lemma imp_trans : forall (P Q R : Prop), (P -> Q) -> (Q -> R) -> (P -> R).
Proof.
  intros P Q R pq qr p.
  apply qr.
  apply pq.
  assumption.
Qed.

Lemma imp_perm : forall (P Q R : Prop), (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros P Q R pqr q r.
  apply pqr.
  assumption.
  assumption.
Qed.

Lemma ignore_Q : forall (P Q R : Prop), (P -> R) -> P -> Q -> R.
Proof.
  intros P Q R pr p q.
  apply pr.
  assumption.
Qed.

Lemma delta_imp : forall (P Q : Prop), (P -> P -> Q) -> P -> Q.
Proof.
  intros P Q ppq p.
  apply ppq.
  assumption.
  assumption.
Qed.

Lemma delta_impR : forall (P Q : Prop), (P -> Q) -> (P -> P -> Q).
Proof.
  intros P Q pq p p2.
  apply pq.
  assumption.
Qed.

Lemma diamond : forall (P Q R T : Prop), (P -> Q) -> (Q -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros P Q R T pq qr qrt p.
  apply qrt.
  apply pq.
  assumption.
  apply qr.
  apply pq.
  assumption.
Qed.

Lemma weak_pierce : forall (P Q : Prop), ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros P Q pqppq.
  apply pqppq.
  intro pqp.
  apply pqp.
  intro p.
  apply pqppq.
  intro pqp2.
  assumption.
Qed.

(* Exercise 5.3 *)

Goal (~False).
  intro.
  assumption.
Qed.

Goal (forall (P : Prop), ~~~P -> ~P).
  intros P nnnp p.
  apply nnnp.
  intros np.
  apply np.
  assumption.
Qed.

Goal (forall (P Q : Prop), ~~~P -> P -> Q).
  intros P Q nnnp p.
  apply False_ind.
  apply nnnp.
  intro np.
  apply np.
  assumption.
Qed.

Goal forall (P Q : Prop), (P -> Q) -> ~Q -> ~P.
  intros P Q pq nq p.
  apply nq.
  apply pq.
  assumption.
Qed.

Goal forall (P Q R : Prop), (P -> Q) -> (P -> ~Q) -> P -> R.
  intros P Q R pq pnq p.
  apply False_ind.
  apply pnq.
  assumption.
  apply pq.
  assumption.
Qed.

(* Exercise 5.4 *)

Definition dyslexic_imp := forall (P Q : Prop), (P -> Q) -> Q -> P.
Definition dyslexic_contrap := forall (P Q : Prop), (P -> Q) -> (~P -> ~Q).

(*

P->QからQ->Pという誤謬が成り立つとすれば矛盾する

恒真命題Tがあれば P -> T は任意のPに対し成り立つ。
dyslexicの命題からPを導ける

*)
Check False_ind.

Goal dyslexic_imp -> False.
  intro d.
  apply (d False True).
  exact (fun _ => I).
  exact I.
Qed.

Goal dyslexic_contrap -> False.
  intro d.
  apply (d False True).
  exact (fun _ => I).
  exact (fun x => x).
  exact I.
Qed.


(**
In this file, ew define the notion of a HIT for a HIT signature.
We make use of the category of algebras and the notion of displayed algebras.
 *)
Require Import prelude.all.

Require Import syntax.hit_signature.
Require Import algebras.set_algebra.
Require Import displayed_algebras.displayed_algebra.

Open Scope cat.

(**
To be a HIT of a HIT signature, requires introduction, elimination, and computation rule.
The introduction rules follow from the algebra structure.
The elimination and computation rules follow from the fact that for each displayed algebra (data for elimination rule), we get a displayed algebra map.
This requires both the existence of a dependent map (elimination) and the commutation of certain diagrams (computation).
 *)
Definition is_a_HIT
           {Σ : hit_signature}
           (X : set_algebra Σ)
  : UU
  := ∏ (Y : disp_algebra X), disp_algebra_map Y.

(**
Projections of HITs
 *)
Definition HIT
           (Σ : hit_signature)
  : UU
  := ∑ (X : set_algebra Σ), is_a_HIT X.

Coercion HIT_carrier
         {Σ : hit_signature}
         (H : HIT Σ)
  : set_algebra Σ
  := pr1 H.

Section HITInd.
  Context {Σ : hit_signature}.
  Variable (H : HIT Σ)
           (Yfam : alg_carrier H → UU)
           (Yset : ∏ (x : alg_carrier H), isaset (Yfam x)).

  Local Definition Y : alg_carrier H → hSet
    := λ X, make_hSet (Yfam X) (Yset X).

  Variable (c : ∏ (x : ⦃ point_arg Σ ⦄ (alg_carrier H)),
                poly_dact (point_arg Σ) Y x → Y (alg_operation H x))
           (p : ∏ (j : path_index Σ)
                  (x : ⦃ path_arg Σ j ⦄ (alg_carrier H))
                  (y : poly_dact (path_arg Σ j) Y x),
                transportf
                  (poly_dact I Y)
                  (alg_paths H j x)
                  (endpoint_dact (alg_to_prealg H) (path_lhs Σ j) c y)
                =
                endpoint_dact (alg_to_prealg H) (path_rhs Σ j) c y).

  Definition hit_ind
    : ∏ (x : alg_carrier H), Y x
    := pr1 (pr2 H (Y ,, (c ,, p))).
End HITInd.


From mathcomp
  Require Import ssreflect.
Require Import Coq.Logic.JMeq.
Require Import Coq.Logic.EqdepFacts.

(* fooのようなRecordは等値性を簡単に証明できる *)

Record foo := make_foo
{
  foo_carrier : Set;
}.

Theorem foo_eq (F F' : foo) :
  foo_carrier F = foo_carrier F'
  -> F = F'.
Proof.
  move=> Hcarrier.
  destruct F, F'.
  simpl in * |-.
  f_equal.
  exact Hcarrier.
Qed.

(* barのようなRecordはfooと同じようには等値性の証明ができない？ *)

Record bar := make_bar
{
  bar_carrier : Set;
  bar_star : bar_carrier;
}.

Theorem bar_eq (B B' : bar) :
  bar_carrier B = bar_carrier B'
  -> JMeq (bar_star B) (bar_star B')
  -> B = B'.
Proof.
  destruct B as [Bcarrier Bstar].
  destruct B' as [B'carrier B'star].
  simpl.
  move=> Hcarrier Hstar.
  pose proof (JMeq_eq_dep (U := Set) (fun X => X) Hcarrier Hstar) as Heq.
  apply eq_dep_eq_sigT in Heq.
  dependent rewrite Heq.
  reflexivity.
Qed.


(** * Composition of adjunctions [F' ⊣ G' → F ⊣ G → (F' ∘ F) ⊣ (G ∘ G')] *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Composition.Core NaturalTransformation.Composition.Core.
Require Import Functor.Identity.
Require NaturalTransformation.Composition.Laws.
Require Import Adjoint.UnitCounit Adjoint.Core.
Require Import HoTT.Tactics.
Require Import Basics.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope natural_transformation_scope.

(** ** via the unit+counit+zig+zag definition *)
Section compose.
  Variables C D E : PreCategory.

  Variable F : Functor C D.
  Variable F' : Functor D E.
  Variable G : Functor D C.
  Variable G' : Functor E D.

  Variable A' : F' -| G'.
  Variable A : F -| G.

  Definition compose_unit
  : NaturalTransformation 1 ((G o G') o (F' o F)).
  Proof.
    pose (unit A) as eta.
    pose (unit A') as eta'.
    refine ((fun (T : NaturalTransformation _ _)
                 (U : NaturalTransformation _ _)
             => T o (G oL eta' oR F) o U o eta) _ _);
      NaturalTransformation.Composition.Laws.nt_solve_associator.
  Defined.

  Definition compose_counit
  : NaturalTransformation ((F' o F) o (G o G')) 1.
  Proof.
    pose (counit A) as eps.
    pose (counit A') as eps'.
    refine ((fun (T : NaturalTransformation _ _)
                 (U : NaturalTransformation _ _)
             => eps' o U o (F' oL eps oR G') o T) _ _);
      NaturalTransformation.Composition.Laws.nt_solve_associator.
  Defined.

  Definition compose : F' o F -| G o G'.
  Proof.
    exists compose_unit compose_counit;
    simpl;
    abstract (
        repeat
          match goal with
            | _ => intro
            | _ => reflexivity
            | _ => progress rewrite ?identity_of, ?left_identity, ?right_identity
            | _ => rewrite <- ?composition_of, unit_counit_equation_1
            | _ => rewrite <- ?composition_of, unit_counit_equation_2
            | [ A : _ -| _ |- _ = 1%morphism ]
              => (etransitivity; [ | apply (unit_counit_equation_1 A) ];
                  try_associativity_quick f_ap)
            | [ A : _ -| _ |- _ = 1%morphism ]
              => (etransitivity; [ | apply (unit_counit_equation_2 A) ];
                  try_associativity_quick f_ap)
            | _ => repeat (try_associativity_quick rewrite <- !composition_of);
                  progress repeat apply ap;
                  rewrite ?composition_of
            | [ |- context[components_of ?T] ]
              => (try_associativity_quick simpl rewrite <- (commutes T));
                try_associativity_quick (apply concat_right_identity
                                               || apply concat_left_identity)
            | [ |- context[components_of ?T] ]
              => (try_associativity_quick simpl rewrite (commutes T));
                try_associativity_quick (apply concat_right_identity
                                               || apply concat_left_identity)
          end
      ).
  Defined.
End compose.

Module Export AdjointCompositionCoreNotations.
  Infix "o" := compose : adjunction_scope.
End AdjointCompositionCoreNotations.


Require Import Coq.Vectors.Vector.
Require Import Coq.Program.Equality.

Theorem vector_forall_append {A: Type}(P: A -> Prop):
  forall (m n: nat)(u: t A m)(v: t A n),
    Forall P (append u v) <->
    Forall P u /\ Forall P v.
Proof.
  intros m n u.
  generalize dependent n.
  induction u as [| x m u];
    simpl;
    intros n v;
    split.
  { intros Hv;
      split;
      [constructor | assumption]. }
  { intros [Hnil Hv];
      assumption. }
  { intros Happ.
    inversion Happ.
    inversion_sigma.
    subst.
    split.
    { constructor;
        [assumption |].
      let H := match goal with H : m + n = m + n |- _ => H end in
        pose proof (Eqdep_dec.UIP_refl_nat _ H); subst H;
        simpl in *; subst.
      apply IHu in H3.
      inversion_clear H3 as [Hu Hv].
      assumption. }
    { let H := match goal with H : m + n = m + n |- _ => H end in
        pose proof (Eqdep_dec.UIP_refl_nat _ H); subst H;
        simpl in *; subst.
      apply IHu in H3.
      inversion_clear H3 as [Hu Hv].
      assumption. } }
  { intros [Hxu Hv].
    inversion Hxu;
      subst.
    inversion_sigma.
    let H := match goal with H : m = m |- _ => H end in
      pose proof (Eqdep_dec.UIP_refl_nat _ H); subst H;
      simpl in *; subst.
    constructor;
      [assumption |].
    apply IHu.
    split;
      assumption. }
Qed.

Definition vector_ind2 {A B: Type}
    (P: forall {n}, t A n -> t B n -> Prop)
    (base: P (nil A) (nil B))
    (ind: forall {n v1 v2}, P v1 v2 ->
      forall a b, P (cons A a _ v1) (cons B b _ v2)) :=
  fix vector_ind2_fix {n} (v1: t A n): forall (v2: t B n), P v1 v2 :=
    match v1 with
    | nil _ => fun v2 => case0 _ base v2
    | @cons _ hd1 n' tl1 =>
      fun v2 =>
        caseS' v2 (fun v2' => P (cons A hd1 _ tl1) v2')
          (fun hd2 tl2 => ind (vector_ind2_fix tl1 tl2) hd1 hd2)
    end.

Theorem vector_fold_right2_append {A B C: Type}(g: A -> B -> C -> C)(c: C):
  forall {n: nat}(u2: t A n)(v2: t B n){m: nat}(u1: t A m)(v1: t B m),
    fold_right2 g c _ (append u1 u2) (append v1 v2) =
      fold_right2 g (fold_right2 g c _ u2 v2) _ u1 v1.
Proof.
  intros n u2 v2.
  apply vector_ind2;
    simpl;
    [reflexivity |].
  intros m u1 v1 IH.
  intros a b.
  rewrite IH.
  reflexivity.
Qed.

Lemma vector_forall_map {A: Type}(P: A -> Prop)(f: A -> A):
  (forall (a: A), P a -> P (f a)) ->
  forall {n: nat}(v: t A n),
    Forall P v ->
    Forall P (map f v).
Proof.
  intros Hclosed n.
  induction v;
    simpl.
  { constructor. }
  { intros Hcons.
    inversion Hcons.
    subst.
    inversion_sigma.
    let H := match goal with H: n = n |- _ => H end in
      pose proof (Eqdep_dec.UIP_refl_nat _ H); subst H;
      simpl in *; subst.
    constructor.
    { apply Hclosed.
      assumption. }
    { apply IHv.
      assumption. } }
Qed.

Lemma vector_forall_map_spec {A B: Type}(P: B -> Prop)(f: A -> B):
  (forall (a: A), P (f a)) ->
  forall {n: nat}(v: t A n),
    Forall P (map f v).
Proof.
  intros Hspec.
  intros n.
  induction v as [| a n v];
    simpl;
    constructor.
  { apply Hspec. }
  { assumption. }
Qed.

Fixpoint const_seq {A: Type}(a: A)(n: nat): t A n :=
  match n with
  | 0 => nil A
  | S n' => cons _ a _ (const_seq a n')
  end.

Lemma vector_forall_const_seq {A: Type}(a: A){n: nat}(P: A -> Prop):
  Forall P (const_seq a n) <-> n = 0 \/ P a.
Proof.
  split;
    [intros Hforall |].
  { destruct n as [| n'].
    { left; reflexivity. }
    { right.
      simpl in Hforall.
      inversion_clear Hforall.
      assumption. } }
  { induction n as [| n'].
    { left; reflexivity. }
    { simpl.
      intros [Hcontra | Ha];
        [inversion Hcontra |].
      constructor;
        [assumption |].
      apply IHn'.
      right.
      assumption. } }
Qed.

Definition zipWith {A B C: Type}
    (f: A -> B -> C){n: nat}(u: t A n)(v: t B n): t C n :=
  rect2 (fun n _ _ => t C n) (nil C)
    (fun n _ _ accum a b => cons C (f a b) n accum) u v.

Theorem vector_forall_zipwith_binary_op {A: Type}
    (f: A -> A -> A)(P: A -> Prop):
  (forall (a0 a1: A), P a0 -> P a1 -> P (f a0 a1)) ->
  forall {n: nat}(v0: t A n)(v1: t A n),
    Forall P v0 -> Forall P v1 ->
    Forall P (zipWith f v0 v1).
Proof.
  intros Hclosed n v0 v1.
  induction v0 as [| a0 n v0].
  { dependent destruction v1.
    intros _ _.
    simpl.
    constructor. }
  { dependent destruction v1.
    rename h into a1.
    intros Hv0 Hv1.
    simpl.
    inversion Hv0.
    subst.
    inversion_sigma.
    let H := match goal with H: n = n |- _ => H end in
      pose proof (Eqdep_dec.UIP_refl_nat _ H); subst H;
      simpl in *; subst v.
    inversion Hv1.
    subst.
    inversion_sigma.
    let H := match goal with H: n = n |- _ => H end in
      pose proof (Eqdep_dec.UIP_refl_nat _ H); subst H;
      simpl in *; subst v.
    constructor.
    { apply Hclosed;
        assumption. }
    { apply IHv0;
        assumption. } }
Qed.

Theorem vector_map_composed {A B C: Type}(f: A -> B)(g: B -> C):
  forall {n: nat}(v: t A n),
    map (fun x => g (f x)) v =
      map g (map f v).
Proof.
  intros n.
  induction v;
    simpl;
    [| rewrite IHv];
    reflexivity.
Qed.