(* infotheo v2 (c) AIST, Nagoya University. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq div.
From mathcomp Require Import choice fintype tuple finfun bigop prime ssralg.
From mathcomp Require Import poly polydiv finset finalg zmodp matrix mxalgebra.
From mathcomp Require Import mxpoly vector fieldext finfield.
Require Import ssralg_ext hamming linearcode decoding cyclic_code poly_decoding.
Require Import vandermonde dft euclid grs f2.

(** * Binary BCH Codes *)

(** OUTLINE
- Module BCH.
  - Section BCH_PCM_def.
  - Section BCH_PCM_alt : equivalence between PCM matrices
  - Section BCH_def.
  - Section BCH_syndromep.
- Section BCH_is_GRS.
- Section BCH_PCM_checksum.
  - Equivalence between the PCM and the system of checksum equations
- Section BCH_syndrome_syndromep.
  - Equivalence between the PCM and the syndrome polynomial
- Section BCH_minimum_distance_lb.
- Section BCH_erreval.
- Section decoding_using_euclid.
- Section BCH_cyclic.
*)

Reserved Notation "'\BCHsynp_(' a , e , t )" (at level 3).
Reserved Notation "'\BCHomega_(' a , e )" (at level 3).

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

Import GRing.Theory.
Local Open Scope ring_scope.

Local Open Scope vec_ext_scope.

Local Open Scope dft_scope.

Module BCH.

Section BCH_PCM_def.

Variables (F : finFieldType) (n : nat) (a : 'rV[F]_n) (t : nat).

Definition PCM : 'M_(t, n) := \matrix_(i < t, j < n) (a ``_ j) ^+ i.*2.+1.

Definition PCM_alt : 'M[F]_(t.*2, n) := \matrix_(i < t.*2, j < n) (a ``_ j) ^+ i.+1.

Lemma PCM_alt_GRS : PCM_alt = GRS.PCM a a t.*2.
Proof.
apply/matrixP => i j.
rewrite !mxE (bigD1 j) //= !mxE eqxx mulr1n exprS mulrC.
rewrite (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 ?addr0 // => k kj.
by rewrite !mxE (negbTE kj) mulr0n mulr0.
Qed.

End BCH_PCM_def.

Section BCH_PCM_alt.

Variables (n : nat) (m' : nat).
Let m := m'.+1.
Let F := GF2 m.
Variable a : 'rV[F]_n.
Variable t : nat.

Lemma BCH_PCM_altP2 (x : 'rV[F]_n) :
  (forall i : 'I_t.*2, \sum_j x ``_ j * a ``_ j ^+ i.+1 = 0) ->
  (forall i : 'I_t,\sum_j x ``_ j * a ``_ j ^+ i.*2.+1 = 0).
Proof.
move=> H i.
have @j : 'I_t.*2 by refine (@Ordinal _ i.*2 _); rewrite -!muln2 ltn_pmul2r.
rewrite -[RHS](H j); by apply eq_bigr => /= k _.
Qed.

Lemma BCH_PCM_altP1 (x : 'rV['F_2]_n) :
  (forall i : 'I_t, \sum_j GF2_of_F2 x ``_ j * a ``_ j ^+ i.*2.+1 = 0) ->
  (forall i : 'I_t.*2, \sum_j GF2_of_F2 x ``_ j * a ``_ j ^+ i.+1 = 0).
Proof.
move=> H [i].
elim: i {-2}i (leqnn i) => [|i IH j ji i1].
  move=> i; rewrite leqn0 => /eqP -> i0.
  destruct t.
    exfalso; by rewrite -muln2 mul0n ltnn in i0.
  by rewrite -[RHS](H ord0); apply eq_bigr.
case/boolP : (odd j) => [odd_j|even_j]; last first.
  have j2t : j./2 < t by rewrite -divn2 ltn_divLR // muln2.
  rewrite -[in RHS](H (Ordinal j2t)) /=.
  apply/eq_bigr => k _.
  move: (odd_double_half j).
  by rewrite (negbTE even_j) add0n => ->.
move: (IH j.-1./2).
rewrite -{1}divn2 leq_divLR; last first.
  rewrite dvdn2 -subn1 odd_sub; last by destruct j.
  by rewrite /= addbT odd_j.
have -> : (j.-1 <= i * 2)%N.
  rewrite muln2 -addnn -subn1 leq_subLR addnA add1n (leq_trans ji) //.
  by rewrite addSn ltnS leq_addr.
move/(_ isT).
have j2t : (j.-1)./2 < t.*2.
  rewrite -divn2 ltn_divLR // -ltnS.
  destruct j => //.
  by rewrite /= (ltn_trans i1) // ltnS muln2 -[in X in _ <= X]addnn leq_addl.
move/(_ j2t)/(congr1 (fun x => x ^+ 2)).
rewrite expr0n /= sum_char2 ?char_GFqm // => H'.
rewrite -[RHS]H'; apply eq_bigr => k _.
rewrite exprMn_comm; last by rewrite /GRing.comm mulrC.
congr (_ * _); last first.
  rewrite /= -exprM muln2; congr (_ ^+ _).
  move: (odd_double_half j).
  rewrite odd_j add1n => <-.
  by rewrite (half_bit_double (j./2) false) -doubleS.
by rewrite (expr2 (GF2_of_F2 x ``_ k)) -rmorphM -expr2 f2.expr2_char2.
Qed.

Lemma PCM_altP (x : 'rV_n) :
  (syndrome (BCH.PCM a t) (F2_to_GF2 m x) == 0) =
  (syndrome (BCH.PCM_alt a t) (F2_to_GF2 m x) == 0).
Proof.
apply/idP/idP.
- rewrite /BCH.PCM /BCH.PCM_alt /syndrome => H.
  suff H' : forall j : 'I_t.*2, \sum_j0 (GF2_of_F2 (x ``_ j0) * (a ``_ j0) ^+ j.+1) = 0.
    apply/eqP/rowP => j; rewrite !mxE.
    rewrite -[RHS](H' j).
    apply eq_bigr => /= i _.
    by rewrite !mxE mulrC.
  move=> j.
  apply BCH_PCM_altP1 => i.
  move/eqP/rowP : H => /(_ i).
  rewrite !mxE => H; rewrite -[RHS]H.
  apply eq_bigr => /= k _; by rewrite !mxE /= mulrC.
- rewrite /BCH.PCM_alt /BCH.PCM /syndrome => H.
  apply/eqP/rowP => i.
  have @j : 'I_t.*2.
    refine (@Ordinal _ i.*2 _); by rewrite -!muln2 ltn_pmul2r.
  move/eqP : H => /matrixP/(_ ord0 j).
  rewrite !mxE => {2}<-.
  apply eq_bigr => k _.
  by rewrite !mxE.
Qed.

End BCH_PCM_alt.

Section BCH_def.

Variables (n : nat) (m : nat).

Definition code (a : 'rV_n) t :=
  Rcode.t (@GF2_of_F2_rmorphism m) (kernel (PCM a t)).

End BCH_def.

Section BCH_syndromep.

Variables (n' : nat).
Let n := n'.+1.
Variable (m : nat).
Let F : fieldType := GF2 m.
Implicit Types a : 'rV[F]_n.

Definition syndromep a y t := syndromep a (F2_to_GF2 m y) t.*2.

End BCH_syndromep.

End BCH.

Notation "'\BCHsynp_(' a , e , t )" := (BCH.syndromep a e t) : bch_scope.

Local Open Scope bch_scope.

Section BCH_is_GRS.

Variable (m : nat).
Let F := GF2 m.
Variable (n' : nat).
Let n := n'.+1.
Variable a : F.
Variable (t : nat).

Hypothesis tn : t.*2 < n.

Lemma fdcoor_syndrome_coord (y : 'rV['F_2]_n) i (it : i < t.*2) :
  fdcoor (rVexp a n) (F2_to_GF2 m y) (inord i.+1) =
  GRS.syndrome_coord (rVexp a n) (rVexp a n) i (F2_to_GF2 m y).
Proof.
rewrite /fdcoor /GRS.syndrome_coord horner_poly; apply eq_bigr => j _.
rewrite insubT // => jn.
rewrite !mxE -mulrA; congr (GF2_of_F2 (y _ _) * _); first by apply val_inj.
by rewrite -exprS -exprM mulnC exprM inordK // ltnS (leq_trans it).
Qed.

Lemma BCH_syndromep_is_GRS_syndromep y :
  \BCHsynp_(rVexp a n, y, t) =
  GRS.syndromep (rVexp a n) (rVexp a n) t.*2 (F2_to_GF2 m y).
Proof.
apply/polyP => i.
rewrite !coef_poly; case: ifPn => // it; by rewrite fdcoor_syndrome_coord.
Qed.

End BCH_is_GRS.

Section BCH_PCM_checksum.

Variables (n' : nat) (m : nat).
Let n := n'.+1.
Let F := GF2 m.
Variable a : F.
Variable t : nat.
Variable BCHcode : BCH.code (rVexp a n) t.

Hypothesis tn : t <= n.-1./2.

Lemma BCH_codebook (c : 'rV['F_2]_n) :
  (c \in BCHcode) =
  [forall j : 'I_t, (map_mx (@GF2_of_F2 m) c) ^`_(rVexp a n, inord j.*2.+1) == 0].
Proof.
apply/idP/idP.
- case: BCHcode => code condition /= /condition.
  rewrite mem_kernel_syndrome0 -trmx0 => /eqP/trmx_inj/matrixP Hc.
  apply/forallP => /= i; apply/eqP; rewrite /fdcoor horner_poly.
  move: (Hc i ord0); rewrite !mxE => H1; rewrite -[RHS]H1.
  apply/eq_bigr => /= j _; rewrite insubT // => jn.
  rewrite mulrC 3![in RHS]mxE; congr (_ * (map_mx _ c) ord0 _); last by apply val_inj.
  rewrite inordK //; last first.
    move: (ltn_ord i).
    rewrite -(@ltn_pmul2r 2) // !muln2 -(ltn_add2r 1) !addn1.
    move/leq_trans; apply.
    move: tn.
    rewrite -divn2 leq_divRL // muln2.
    move/leq_ltn_trans; by apply.
  by rewrite exprAC.
- move/forallP => H.
  case: BCHcode => code condition /=; apply (proj2 (condition _)).
  rewrite mem_kernel_syndrome0; apply/eqP/rowP => i; rewrite !mxE.
  rewrite -[RHS](eqP (H i)) /fdcoor horner_poly; apply/eq_bigr => /= j _.
  rewrite insubT // => jn.
  rewrite !mxE mulrC; congr (GF2_of_F2 (c ord0 _) * _); first by apply val_inj.
  rewrite inordK //; first by rewrite exprAC.
  move: (ltn_ord i).
  rewrite -(@ltn_pmul2r 2) // !muln2 -(ltn_add2r 1) !addn1.
  move/leq_trans; apply.
  move: tn.
  rewrite -divn2 leq_divRL // muln2 => /leq_ltn_trans; exact.
Qed.

End BCH_PCM_checksum.

Section BCH_syndrome_syndromep.

Variables (n' : nat) (m : nat).
Let n := n'.+1.
Let F := GF2 m.
Variable a : F.
Variable t' : nat.
Let t := t'.+1.

Lemma BCH_syndrome_synp y : t.*2 < n ->
  (syndrome (BCH.PCM (rVexp a n) t) (F2_to_GF2 m y) == 0) =
  (\BCHsynp_(rVexp a n, y, t) == 0).
Proof.
move=> tn.
apply/idP/idP.
- move/eqP/eqP.
  rewrite BCH.PCM_altP // /BCH.PCM_alt.
  move/eqP => K.
  rewrite /BCH.syndromep /syndromep.
  rewrite poly_def (eq_bigr (fun=> 0)) ?big_const ?iter_addr0 // => /= i _.
  apply/eqP; rewrite scaler_eq0.
  rewrite fdcoorE -size_poly_eq0 size_polyXn /= orbF.
  move/rowP : K => /(_ (inord i)) K.
  apply/eqP.
  rewrite !mxE in K.
  rewrite -[RHS]K.
  apply eq_bigr => k _.
  rewrite !mxE mulrC; congr (_ * _).
  rewrite -exprM mulnC exprM; congr (a ^+ _ ^+ _).
  by rewrite inord_val // inordK // (leq_ltn_trans (ltn_ord i)).
- move=> K.
  apply/eqP; apply/eqP.
  rewrite BCH.PCM_altP //; apply/eqP.
  rewrite /BCH.PCM_alt.
  apply/rowP => i.
  rewrite !mxE.
  move/eqP: K.
  move/(congr1 (fun x : {poly F} => x`_i)).
  rewrite /BCH.syndromep /syndromep.
  rewrite coef0 poly_def coef_sum (bigD1 i) //= (eq_bigr (fun=> 0)); last first.
    move=> j ji.
    rewrite coefZ coefXn (_ : _ == _ = false) ?mulr0 //.
    by apply/negbTE; rewrite eq_sym.
  rewrite big_const iter_addr0 addr0 fdcoorE coefZ coefXn eqxx mulr1 => K.
  rewrite -[RHS]K.
  apply eq_bigr => k _.
  rewrite !mxE mulrC; congr (_ * _).
  by rewrite -exprM mulnC exprM inordK // (leq_ltn_trans _ tn).
Qed.

End BCH_syndrome_syndromep.

Section BCH_minimum_distance_lb.

Variables (m : nat) (n : nat).
Let F := GF2 m.
Variable a : 'rV[F]_n.

Lemma BCH_det_mlinear t r' (f : 'I_r'.+1 -> 'I_n) (rt : r' < t.*2) :
  let B := \matrix_(i, j) BCH.PCM_alt a t (widen_ord rt i) (f j) in
  let V := vander (row 0 B) in
  \det B = \prod_(i < r'.+1) BCH.PCM_alt a t (widen_ord rt 0) (f i) * \det V.
Proof.
move=> B V.
set h := vander (row 0 B).
set g := fun i => BCH.PCM_alt a t (widen_ord (rt) 0) (f i).
transitivity (\det (\matrix_(i, j) (h i j * g j))).
  congr (\det _).
  apply/matrixP => i j.
  by rewrite !mxE /h /g /BCH.PCM_alt !mxE -!exprD /= -exprM mul1n addn1.
rewrite det_mlinear; congr (_ * _).
congr (\det _); apply/matrixP => i j; by rewrite !mxE /h -exprM.
Qed.

Hypothesis a_neq0 : distinct_non_zero a.

Lemma det_B_neq0 t r f (Hr' : r.+1 < t.*2) (Hinj : injective f) :
  let B := \matrix_(i < r.+1, j < r.+1)
             BCH.PCM_alt a t (widen_ord (ltnW Hr') i) (f j) in
  \det B != 0.
Proof.
rewrite /=.
set B := \matrix_(_, _) _.
rewrite BCH_det_mlinear det_vander mulf_neq0 //.
- rewrite prodf_seq_neq0 /=; apply/allP => /= j _.
  by rewrite !mxE /= expr1 (proj2 a_neq0).
- rewrite prodf_seq_neq0 /=; apply/allP => /= j _.
  rewrite prodf_seq_neq0 /=; apply/allP => /= k _.
  apply/implyP => jk.
  rewrite !mxE /= !expr1 subr_eq0.
  apply/negP => /eqP.
  move: (proj1 a_neq0) => /(_ (f (inord k)) (f (inord j))).
  rewrite 2!ffunE => akj; move/akj/Hinj.
  rewrite !inord_val; by apply/eqP/negbT/gtn_eqF.
Qed.

(** parity-check matrix of a binary (n, k) code capable ot correcting
   all error patterns of weight <= t with dimension k >= n - m * t
   (see [McEliece 2002], thm 9.1) *)
Lemma BCH_min_dist1 t x (x0 : x != 0) (t0 : 0 < t) (C : BCH.code a t) :
  x \in C -> t < wH x.
Proof.
move/(proj1 (Rcode.P C _)).
rewrite mem_kernel_syndrome0 BCH.PCM_altP // => /eqP H.
(* there are r <= t columns in the PCM s.t. their linear comb. w.r.t. is 0 *)
rewrite leqNgt; apply/negP => abs.
have /eqP : #| wH_supp x | = (wH x).-1.+1.
   by rewrite card_wH_supp prednK // lt0n wH_eq0.
rewrite cardE => supp_wH.
have Hinj : injective [ffun i : 'I_(wH x).-1.+1 => tnth (Tuple supp_wH) i].
  move=> /= i j.
  rewrite !ffunE /tnth /= => /eqP.
  rewrite (set_nth_default (tnth_default (Tuple supp_wH) j)) //; last first.
    rewrite -cardE card_wH_supp; move: i; by rewrite prednK // lt0n wH_eq0.
  rewrite nth_uniq ?enum_uniq //.
  by move/eqP/val_inj.
  rewrite -cardE card_wH_supp; move: i; by rewrite prednK // lt0n wH_eq0.
  rewrite -cardE card_wH_supp; move: j; by rewrite prednK // lt0n wH_eq0.
set f := finfun (tnth (Tuple supp_wH)).
move=> [:tmp].
have @f' : 'I_n -> 'I_(wH x).-1.+1.
  move=> i.
  set tmp' := fun i => if x ``_ i != 0 then index i (enum (wH_supp x)) else O.
  refine (@Ordinal _ (tmp' i) _).
  move: i.
  abstract: tmp.
  move=> i.
  case: ifP => // H'.
  by rewrite -(eqP supp_wH) index_mem mem_enum -mem_wH_supp.
have f'K : forall j, x ``_ j != 0 -> f (f' j) = j.
  move=> i xj.
  by rewrite ffunE /tnth /= xj nth_index // mem_enum -mem_wH_supp.
have Hf : \sum_(i < (wH x).-1.+1)
    (GF2_of_F2 x``_(f i)) *: col (f i) (BCH.PCM_alt a t) = 0 :> 'cV__.
  move/(congr1 trmx) : H; rewrite trmx0 => H.
  rewrite -[RHS]H.
  apply/colP => i.
  rewrite ![in RHS]mxE ![in LHS]summxE [in RHS](bigID (fun j => x ``_ j == 0)).
  rewrite /= [X in _ = X + _](_ : _ = 0) ?add0r; last first.
    rewrite (eq_bigr (fun x=> 0)); last first.
      by move=> j /eqP xj0; rewrite !mxE xj0 rmorph0 mulr0.
    by rewrite big_const iter_addr0.
  have ? : (wH x).-1.+1 <= n by rewrite -ltnS prednK ?lt0n ?wH_eq0 // ltnS max_wH.
  rewrite [in RHS](reindex_onto (fun x => f x) f' f'K) /= [in RHS]big_mkcond /=.
  apply/eq_bigr => j _.
  case: ifPn => [_|]; first by rewrite!mxE mulrC.
  rewrite negb_and negbK.
  case/orP => [/eqP ->|abs']; first by rewrite rmorph0 scale0r mxE.
  case/boolP : (x ``_ (f j) == 0) => [/eqP ->|abs''].
    by rewrite rmorph0 scale0r mxE.
  exfalso.
  move/eqP: abs'; apply.
  rewrite /f'; apply/val_inj => /=.
  rewrite abs'' /f ffunE /tnth /= index_uniq //.
    by rewrite -cardE card_wH_supp -[in X in _ < X](@prednK (wH x)) // lt0n wH_eq0.
  by rewrite enum_uniq.
set r' := (wH x).-1.
have Hr' : r'.+1 < t.*2.
  by rewrite /r' prednK // ?lt0n ?wH_eq0 // (leq_trans abs) // -addnn -{1}(add0n t) ltn_add2r.
have {Hf}Hf : \sum_(i < r'.+1) GF2_of_F2 x ``_ (f i) *:
    \col_(j < r'.+1) (BCH.PCM_alt a t (widen_ord (ltnW Hr') j) (f i)) = 0.
  apply/colP => j.
  rewrite mxE summxE.
  move/colP : Hf => /(_ (widen_ord (ltnW Hr') j)).
  rewrite !mxE summxE => Hf.
  rewrite -[RHS]Hf.
  apply eq_bigr => /= i _; by rewrite !mxE.
have /negP := det_B_neq0 Hr' Hinj.
rewrite -det_tr; apply.
apply/det0P; exists (\row_i GF2_of_F2 x ``_ (f i)).
  suff -> : \row_i GF2_of_F2 x ``_ (f i) = const_mx 1.
    apply/eqP => /rowP/(_ 0).
    rewrite !mxE; apply/eqP; exact: oner_neq0.
  move=> n0; apply/rowP => k.
  rewrite !mxE /f ffunE /tnth /=.
  have -> : forall i, i \in (enum (wH_supp x)) -> x ``_ i = 1.
    by move=> /= i; rewrite mem_enum inE -f2.F2_eq1 => /eqP.
  by rewrite rmorph1.
  apply/(nthP (tnth_default (Tuple supp_wH) k)); exists k => //.
  rewrite -cardE card_wH_supp.
  move: (ltn_ord k); by rewrite {2}prednK // lt0n wH_eq0.
apply/rowP => i; rewrite !mxE.
move/colP : Hf => /(_ i).
rewrite !mxE => Hf; rewrite -[RHS]Hf.
rewrite summxE; apply eq_bigr=> k _; by rewrite !mxE.
Qed.

End BCH_minimum_distance_lb.

Section BCH_erreval.

Variables (F : fieldType) (n : nat) (a : 'rV[F]_n).

Definition BCH_erreval := erreval (const_mx 1) a.

End BCH_erreval.

Notation "'\BCHomega_(' a , e )" := (BCH_erreval a e) : bch_scope.

Section BCH_key_equation_old.

Variables (F : fieldType) (n' : nat).
Let n := n'.+1.
Variable a : F.

(** see [McEliece 2002], thm 9.4 *)
Lemma BCH_key_equation_old (y : 'rV[F]_n) : a ^+ n = 1 ->
  \sigma_(rVexp a n, y) * rVpoly (dft (rVexp a n) n y) =
  \BCHomega_(rVexp a n, y) * (1 - 'X^n).
Proof.
move=> an1.
rewrite dftE big_distrr /=.
evar (tmp : 'I_n -> {poly F}).
rewrite (eq_bigr (fun i => tmp i)); last first.
  move=> i ie.
  rewrite -scalerAr.
  rewrite (_ : \sigma_(rVexp a n, y) =
    \sigma_(rVexp a n, y, i) * (1 - ((rVexp a n) ``_ i) *: 'X)); last first.
    rewrite /errloc (bigD1 i) //= mulrC; congr (_ * _).
    apply eq_bigl => ij; by rewrite in_setD1 andbC.
  rewrite /tmp; reflexivity.
rewrite {}/tmp.
transitivity (\sum_(i in supp y) y ``_ i *:
     (\sigma_(rVexp a n, y, i) * (1 - a ^+ (i * n) *: 'X^n))).
  apply eq_bigr => /= i ie; congr (_ *: _).
  rewrite -mulrA; congr (_ * _).
  rewrite mulrDl mul1r mulNr big_distrr /=.
  rewrite [X in _ - X](eq_bigr (fun j : 'I_n => a ^+ (i * j.+1) *: 'X^j.+1)); last first.
    move=> j _.
    rewrite !mxE -scalerAr -scalerAl scalerA -exprM -exprD.
    by rewrite inord_val addnC -mulSn mulnC -exprS.
  rewrite big_ord_recl !mxE inord_val expr0 expr1n scale1r expr0.
  rewrite big_ord_recr /= opprD addrA.
  rewrite (_ : forall a b c d, b = c -> a + b - c - d = a - d) //.
  move=> a0 b c d -> //; by rewrite addrK.
  apply eq_bigr => j _; by rewrite mxE -exprM mulnC inordK // ltnS.
rewrite /BCH_erreval [in RHS]big_distrl /=.
apply eq_bigr => i ie.
rewrite mxE -scalerAl mulr1; congr (_ *: (_ * _)).
by rewrite mulnC exprM an1 expr1n scale1r.
Qed.

End BCH_key_equation_old.

Section decoding_using_euclid.

Variables (n' : nat) (m : nat).
Let n := n'.+1.
Let F := GF2 m.
Variable a : F.
Variable t' : nat.
Let t := t'.+1.
Let H := BCH.PCM (rVexp a n) t.

Hypothesis a_neq0 : a != 0.

Definition BCH_mod (y : 'rV[F]_n) : {poly F} :=
  \sum_(i in supp y) y ``_ i *:
    (\prod_(j in supp y :\ i)
      (1 - a ^+ j *: 'X) * - (a ^+ (t.*2.+1 * i))%:P).

Lemma BCH_mod_is_GRS_mod y : BCH_mod y = GRS_mod y (rVexp a n) (rVexp a n) t.*2.
Proof.
rewrite /BCH_mod /GRS_mod; apply/eq_bigr => i iy.
rewrite !mulrN scalerN; congr (- _).
rewrite -!scalerAl; congr (_ *: _).
rewrite mxE -mulrA; congr (_ * _).
  apply/eq_big.
    by move=> j; rewrite in_setD1 andbC.
  move=> j _; by rewrite mxE.
by rewrite -polyC_mul -exprSr -exprM mulnC.
Qed.

Hypothesis (tn : t.*2 < n).

Lemma BCH_key_equation y :
  \sigma_(rVexp a n, F2_to_GF2 m y) * \BCHsynp_(rVexp a n, y, t) =
    \BCHomega_(rVexp a n, twisted a (F2_to_GF2 m y)) +
    BCH_mod (F2_to_GF2 m y) * 'X^t.*2.
Proof.
move: (@GRS_key_equation F n (F2_to_GF2 m y) (rVexp a n) (rVexp a n) t.*2) => H0.
rewrite BCH_syndromep_is_GRS_syndromep // H0; congr (_ + _ * _).
  rewrite /Omega /BCH_erreval; apply/polyP => i.
  rewrite !coef_sum supp_twisted //.
  apply eq_bigr => /= j jy.
  by rewrite !mxE mulr1.
by rewrite -BCH_mod_is_GRS_mod.
Qed.

Lemma errloc_twisted (y : 'rV[F]_n) :
  errloc (rVexp a n) (supp y) = errloc (rVexp a n) (supp (twisted a y)).
Proof. by rewrite /errloc supp_twisted. Qed.

Lemma size_erreval_twisted (e : 'rV_n) : #|supp (F2_to_GF2 m e)| <= t ->
  size (\omega_(const_mx 1, rVexp a n, twisted a (F2_to_GF2 m e))) <= t.
Proof.
move=> et.
have et' : #|supp (twisted a (F2_to_GF2 m e))| <= t by rewrite supp_twisted.
by apply: (size_erreval (rVexp a n) (Errvec et') (const_mx 1)).
Qed.

Local Notation "'`v'" := (Euclid.v).

Definition BCH_err y : {poly 'F_2} :=
  let r0 : {poly F} := 'X^t.*2 in
  let r1 := \BCHsynp_(rVexp a n, y, t) in
  let vstop := `v r0 r1 (stop t r0 r1) in
  let s := vstop.[0]^-1 *: vstop in
  \poly_(i < n) (if s.[a^- i] == 0 then 1 else 0).

Definition BCH_repair : repairT [finType of 'F_2] [finType of 'F_2] n :=
  [ffun y => if \BCHsynp_(rVexp a n, y, t) == 0 then
    Some y
  else
    let ret := y + poly_rV (BCH_err y) in
    if \BCHsynp_(rVexp a n, ret, t) == 0 then Some ret else None].

Lemma BCH_err_is_correct (a_not_uroot : not_uroot_on a n) l (e y : 'rV_n) :
  let r0 := 'X^t.*2 : {poly F} in
  let r1 := \BCHsynp_(rVexp a n, y, t) in
  let vj := Euclid.v r0 r1 (stop t r0 r1) in
  l <> 0 ->
  vj = l *: \sigma_(rVexp a n, F2_to_GF2 m e) ->
  e = poly_rV (BCH_err y).
Proof.
have H1 := distinct_non_zero_rVexp a_neq0 a_not_uroot.
move=> r0 r1 vj /eqP l0 Hvj; apply/rowP => i.
set r_ := \BCHomega_(rVexp a n, twisted a (F2_to_GF2 m e)).
rewrite !mxE coef_poly ltn_ord; case: ifPn.
  rewrite -/r0 -/r1 -/r_ -/vj Hvj.
  rewrite !hornerZ !mulf_eq0 invrM; last 2 first.
    by rewrite unitfE.
    by rewrite unitfE horner_errloc_0 oner_neq0.
  rewrite mulf_eq0 !invr_eq0 (negbTE l0) /= orbF horner_errloc_0 oner_eq0 /=.
  move: (errloc_zero (supp (F2_to_GF2 m e)) i H1); rewrite mxE => ->.
  by rewrite supp_F2_to_GF2 inE -F2_eq1 => /eqP.
rewrite -/r0 -/vj in Hvj *.
rewrite Hvj !hornerZ !mulf_eq0 invrM; last 2 first.
  by rewrite unitfE.
  by rewrite unitfE horner_errloc_0 oner_neq0.
rewrite mulf_eq0 !invr_eq0 (negbTE l0) /= orbF horner_errloc_0 oner_eq0 /=.
move: (errloc_zero (supp (F2_to_GF2 m e)) i H1); rewrite mxE => ->.
by rewrite supp_F2_to_GF2 inE negbK => /eqP ->.
Qed.

Local Open Scope ecc_scope.

Lemma BCH_repair_is_correct (C : BCH.code (rVexp a n) t) : not_uroot_on a n ->
  t.-BDD (C, BCH_repair).
Proof.
move=> a_not_uroot c e.
set y := c + e.
set r0 : {poly F} := 'X^t.*2.
set r1 := \BCHsynp_(rVexp a n, y, t).
set vj := Euclid.v r0 r1 (stop t r0 r1).
move=> Hc et.
set r : {poly F} := \BCHomega_(rVexp a n, twisted a (F2_to_GF2 m e)).
have H1 := distinct_non_zero_rVexp a_neq0 a_not_uroot.
rewrite /BCH_repair.
have syn_c : \BCHsynp_(rVexp a n, c, t) = 0.
  move/(proj1 (Rcode.P C _)) : Hc.
  by rewrite mem_kernel_syndrome0 BCH_syndrome_synp // => /eqP ->.
have syn_y_e : \BCHsynp_(rVexp a n, y, t) = \BCHsynp_(rVexp a n, e, t).
  rewrite {1}/BCH.syndromep /F2_to_GF2 map_mxD syndromepD.
  by rewrite -!/(BCH.syndromep _ _ _) syn_c add0r.
rewrite ffunE.
case: ifPn => syn_y.
  suff e0 : e = 0 by rewrite /y e0 addr0.
  apply/eqP/negPn/negP => e0.
  move: et.
  apply/negP.
  rewrite -ltnNge (@BCH_min_dist1 _ _ _ H1 _ _ e0 _ C) //.
  rewrite (_ : e = y - c); last by rewrite /y addrAC subrr add0r.
  apply Lcode0.aclosed => //; last by rewrite Lcode0.oclosed.
  apply: (proj2 (Rcode.P C _)).
  by rewrite mem_kernel_syndrome0 BCH_syndrome_synp.
have size_r1 : size r1 <= size ('X^t.*2 : {poly F}).
  by rewrite /r1 /BCH.syndromep size_polyXn (leq_trans (size_syndromep _ _ _)).
have eqn : \sigma_(rVexp a n, F2_to_GF2 m e) * r1 = r + - - BCH_mod (F2_to_GF2 m e) * 'X^t.*2.
  by rewrite opprK -(BCH_key_equation e) /r1 syn_y_e.
have size_sigma : size \sigma_(rVexp a n, F2_to_GF2 m e) <= t.+1.
  by rewrite (leq_trans (size_errloc _ _)) // ltnS supp_F2_to_GF2 -wH_card_supp.
have size_r : size r <= t.
  move: et.
  rewrite /r wH_card_supp -(@supp_F2_to_GF2 _ m _) -(supp_twisted a_neq0) => et'.
  by rewrite (leq_trans (size_erreval (rVexp a n) (Errvec et') _)).
have deg : (t.+1 + t)%N = size ('X^t.*2 : {poly F}).
  by rewrite size_polyXn addSn addnn.
have cop : coprimep \sigma_(rVexp a n, F2_to_GF2 m e) r.
  have tmp : (forall i, ((const_mx 1) : 'rV[F]_n) ``_ i != 0 :> F).
    by move=> ?; rewrite mxE ?oner_neq0.
  rewrite /r errloc_twisted; by apply: (coprime_errloc_erreval H1 tmp).
case: (solve_key_equation_coprimep size_r1 (errloc_neq0 _ _) syn_y eqn size_sigma size_r deg cop) => [l [l0 [Hvj _]]].
by rewrite -(@BCH_err_is_correct _ l e) // -addrA F2_addmx addr0 syn_c eqxx.
Qed.

End decoding_using_euclid.

Section BCH_cyclic.

Variables (n' : nat) (m : nat).
Let n := n'.+1.
(*Hypothesis nm : (n %| (2 ^ m.-1))%N.*)
Let F := GF2 m.
Variable a : F.
Variable t : nat.
Hypothesis tn : t <= n.-1./2.

Local Open Scope cyclic_code_scope.

Lemma rcsP_BCH_cyclic (C : BCH.code (rVexp a n) t) : a ^+ n = 1 ->
  rcsP [set cw in C].
Proof.
move=> a1 x.
rewrite inE (BCH_codebook C tn) => /forallP /= Hx.
rewrite inE (BCH_codebook C tn); apply/forallP => /= i.
rewrite map_mx_rcs rcs_rcs_poly /rcs_poly.
set x' := map_mx _ _.
have [M HM] : exists M, `[ 'X * rVpoly x' ]_ n = 'X * rVpoly x' + M * ('X^n - 1).
  exists (- ('X * rVpoly x') %/ ('X^n - 1)).
  move/eqP: (divp_eq ('X * rVpoly x') ('X^n - 1)); rewrite addrC -subr_eq => /eqP <-.
  by rewrite divp_opp mulNr.
rewrite HM /fdcoor poly_rV_K //; last first.
  rewrite -HM.
  move: (ltn_modp ('X * rVpoly x') ('X^n - 1)).
  rewrite size_Xn_sub_1 // ltnS => ->.
  by rewrite monic_neq0 // monic_Xn_sub_1.
rewrite !hornerE.
move: (Hx i); rewrite /fdcoor => /eqP ->; rewrite mulr0 add0r.
by rewrite hornerXn mxE exprAC a1 expr1n subrr mulr0.
Qed.

End BCH_cyclic.


Require Import ZFskol.
Require Import Choice. (* Axiom *)
Require Import Sublogic.

(** In this file, we give an attempt to build a model of IZF
   in Coq.
 *)

Module IZF_R <: IZF_R_Ex_sig CoqSublogicThms.

(* The level of indexes *)
Definition Ti := Type.

Inductive set_ : Type :=
  sup (X:Ti) (f:X->set_).
Definition set := set_.

Definition idx (x:set) := let (X,_) := x in X.
Definition elts (x:set) : idx x -> set :=
  match x return idx x -> set with
  | sup X f => f
  end.

Fixpoint eq_set (x y:set) {struct x} :=
  (forall i, exists j, eq_set (elts x i) (elts y j)) /\
  (forall j, exists i, eq_set (elts x i) (elts y j)).

Lemma eq_set_refl : forall x, eq_set x x.
induction x; simpl.
split; intros.
 exists i; trivial.
 exists j; trivial.
Qed.

Lemma eq_set_sym : forall x y, eq_set x y -> eq_set y x.
induction x; destruct y; simpl; intros.
destruct H0.
split; intros.
 elim (H1 i); intros.
 exists x; auto.

 elim (H0 j); intros.
 exists x; auto.
Qed.

Lemma eq_set_trans : forall x y z,
  eq_set x y -> eq_set y z -> eq_set x z.
induction x; destruct y; destruct z; simpl; intros.
destruct H0.
destruct H1.
split; intros.
 elim (H0 i); intros.
 elim (H1 x); intros.
 exists x0; eauto.

 elim (H3 j); intros.
 elim (H2 x); intros.
 exists x0; eauto.
Qed.

Lemma eq_set_def : forall x y,
  (forall i, exists j, eq_set (elts x i) (elts y j)) ->
  (forall j, exists i, eq_set (elts x i) (elts y j)) ->
  eq_set x y.
destruct x; simpl; auto.
Qed.

Definition in_set x y :=
  exists j, eq_set x (elts y j).

Definition incl_set x y := forall z, in_set z x -> in_set z y.

Lemma eq_elim0 : forall x y i,
  eq_set x y ->
  exists j, eq_set (elts x i) (elts y j).
destruct x; simpl; intros.
destruct H.
auto.
Qed.

Lemma eq_set_ax : forall x y,
  eq_set x y <-> (forall z, in_set z x <-> in_set z y).
unfold in_set; split; intros.
 split; intros; destruct H0.
  destruct (eq_elim0 x y x0); trivial.
  exists x1; apply eq_set_trans with (elts x x0); trivial.

  apply eq_set_sym in H.
  destruct (eq_elim0 y x x0); trivial.
  exists x1; apply eq_set_trans with (elts y x0); trivial.

 destruct x; simpl in *.
 destruct y; simpl in *.
 split; intros.
  destruct (H (f i)).
  apply H0.
  exists i; apply eq_set_refl.

  destruct (H (f0 j)).
  destruct H1.
   exists j; apply eq_set_refl.

   exists x; apply eq_set_sym; trivial.
Qed.

Definition elts' (x:set) (i:idx x) : {y|in_set y x}.
exists (elts x i).
abstract (exists i; apply eq_set_refl).
Defined.

Lemma in_reg : forall x x' y,
  eq_set x x' -> in_set x y -> in_set x' y.
destruct 2; intros.
exists x0.
apply eq_set_trans with x; trivial.
apply eq_set_sym; trivial.
Qed.

Lemma eq_intro : forall x y,
  (forall z, in_set z x -> in_set z y) ->
  (forall z, in_set z y -> in_set z x) ->
  eq_set x y.
intros.
rewrite eq_set_ax.
split; intros; eauto.
Qed.

Lemma eq_elim : forall x y y',
  in_set x y ->
  eq_set y y' ->
  in_set x y'.
intros.
rewrite eq_set_ax in H0.
destruct (H0 x); auto.
Qed.

(* Set induction *)

Lemma Acc_in_set : forall x, Acc in_set x.
cut (forall x y, eq_set x y -> Acc in_set y).
 intros.
 apply H with x; apply eq_set_refl.
induction x; intros.
constructor; intros.
specialize eq_elim with (1:=H1)(2:=eq_set_sym _ _ H0); intro.
clear y H0 H1.
destruct H2; simpl in *.
apply H with x.
apply eq_set_sym; trivial.
Qed.

Lemma wf_rec :
  forall P : set -> Type,
  (forall x, (forall y, in_set y x -> P y) -> P x) -> forall x, P x.
intros.
elim (Acc_in_set x); intros.
apply X; apply X0.
Defined.

Lemma wf_ax :
  forall (P:set->Prop),
  (forall x, (forall y, in_set y x -> P y) -> P x) -> forall x, P x.
intros P H x.
cut (forall x', eq_set x x' -> P x');[auto using eq_set_refl|].
induction x; intros.
apply H; intros.
assert (in_set y (sup X f)).
 apply eq_elim with x'; trivial.
 apply eq_set_sym; trivial.
clear H1 H2.
destruct H3; simpl in *.
apply eq_set_sym in H1; eauto.
Qed.

(* *)

Definition empty :=
  sup False (fun x => match x with end).

Lemma empty_ax : forall x, ~ in_set x empty.
unfold in_set, empty; simpl.
red; intros.
destruct H.
destruct x0.
Qed.

Definition singl x := sup unit (fun _ => x).

Definition pair x y :=
  sup bool (fun b => if b then x else y).

Lemma pair_ax : forall a b z,
  in_set z (pair a b) <-> eq_set z a \/ eq_set z b.
unfold in_set, pair; simpl.
split; intros.
 destruct H.
 destruct x; auto.

 destruct H.
  exists true; trivial.
  exists false; trivial.
Qed.

Lemma pair_morph :
  forall a a', eq_set a a' -> forall b b', eq_set b b' ->
  eq_set (pair a b) (pair a' b').
unfold pair.
simpl; intros.
split; intros.
 exists i; destruct i; trivial.
 exists j; destruct j; trivial.
Qed.

Definition union (x:set) :=
  sup {i:idx x & idx (elts x i)}
    (fun p => elts (elts x (projS1 p)) (projS2 p)).

Lemma union_ax : forall a z,
  in_set z (union a) <-> exists2 b, in_set z b & in_set b a.
unfold in_set at 1, union; simpl; intros.
split; intros.
 destruct H.
 exists (elts a (projT1 x)).
  exists (projT2 x); trivial.
  exists (projT1 x); apply eq_set_refl.

 destruct H.
 destruct H0.
 assert (in_set z (elts a x0)).
  apply eq_elim with x; trivial.
 destruct H1.
 exists (existT (fun i=>idx(elts a i)) x0 x1); simpl.
 trivial.
Qed.

Lemma union_morph :
  forall a a', eq_set a a' -> eq_set (union a) (union a').
unfold union.
simpl; intros.
split; intros.
 destruct i; simpl.
 assert (in_set (elts a x) a').
  apply eq_elim with a; trivial.
  exists x; apply eq_set_refl.
 destruct H0.
 assert (in_set (elts (elts a x) i) (elts a' x0)).
  apply eq_elim with (elts a x); trivial.
  exists i; apply eq_set_refl.
 destruct H1.
 exists (existT (fun i=>idx (elts a' i)) x0 x1); simpl.
 trivial.

 destruct j; simpl.
 generalize (eq_set_sym _ _ H); clear H; intro.
 assert (in_set (elts a' x) a).
  apply eq_elim with a'; trivial.
  exists x; apply eq_set_refl.
 destruct H0.
 assert (in_set (elts (elts a' x) i) (elts a x0)).
  apply eq_elim with (elts a' x); trivial.
  exists i; apply eq_set_refl.
 destruct H1.
 exists (existT (fun i=>idx (elts a i)) x0 x1); simpl.
 apply eq_set_sym; trivial.
Qed.

(* Fixpoint *)
Fixpoint wfrec (F:(set->set)->set->set) (x:set) : set :=
  F (fun y => union (sup {i:idx x|eq_set (elts x i) y}
               (fun i => wfrec F (elts x (proj1_sig i))))) x.
Section FixRec.
Hypothesis F : (set->set)->set->set.
Hypothesis Fext : forall x x' f f',
  (forall y y', in_set y x -> eq_set y y' -> eq_set (f y) (f' y')) ->
  eq_set x x' ->
  eq_set (F f x) (F f' x').

Instance wfrecm : Proper (eq_set==>eq_set) (wfrec F).
do 2 red.
induction x; destruct y; intros.
simpl wfrec.
apply Fext; trivial.
simpl in H0; destruct H0.
intros.
apply union_morph.
simpl.
split; intros.
 clear H2; destruct i as (i,?); simpl.
 destruct (H0 i) as (j,?).
 assert (eq_set (f0 j) y').
  apply eq_set_trans with y; trivial.
  apply eq_set_trans with (f i); trivial.
  apply eq_set_sym; trivial.
 exists (exist _ j H4); simpl.
 apply H; trivial.

 destruct H2 as (i,?H2); simpl in i,H2.
 destruct j as (j,?).
 exists (exist _ i (eq_set_sym _ _ H2)); simpl.
 apply H.
 apply eq_set_sym.
 apply eq_set_trans with y; trivial.
 apply eq_set_trans with y'; trivial.
 apply eq_set_sym; trivial.
Qed.

Lemma wfrec_eqn x :
  eq_set (wfrec F x) (F (wfrec F) x).
destruct x; simpl.
apply Fext.
2:apply eq_set_refl.
intros.
rewrite eq_set_ax.
intros z.
rewrite union_ax.
split; intros.
 destruct H1 as (b,?,?).
 destruct H2 as ((j,e),?).
 simpl in H2.
 apply eq_elim with b; trivial.
 apply eq_set_trans with (1:=H2).
 apply wfrecm.
 apply eq_set_trans with y; trivial.

 destruct H as (i,H).
 simpl in i,H.
 apply eq_set_sym in H0.
 exists (wfrec F (f i)).
  apply eq_elim with (1:=H1).
  apply wfrecm.
  apply eq_set_trans with y; trivial.

  apply eq_set_sym in H.
  exists (exist _ i H).
  simpl.
  apply eq_set_refl.
Qed.
End FixRec.

Definition subset (x:set) (P:set->Prop) :=
  sup {a|exists2 x', eq_set (elts x a) x' & P x'}
    (fun y => elts x (proj1_sig y)).

Lemma subset_ax : forall x P z,
  in_set z (subset x P) <->
  in_set z x /\ exists2 z', eq_set z z' & P z'.
unfold in_set at 1, subset; simpl.
split; intros.
 destruct H.
 destruct x0; simpl in H.
 split.
  exists x0; trivial.
  destruct e.
  exists x1; trivial.

  apply eq_set_trans with (elts x x0); trivial.

 destruct H.
 destruct H.
 destruct H0.
 assert (exists2 x', eq_set (elts x x0) x' & P x').
  exists x1; trivial.
  apply eq_set_trans with z; trivial.
  apply eq_set_sym; trivial.
 exists
  (@exist _ (fun a=>exists2 x',eq_set (elts x a) x' & P x')
    x0 H2); simpl; trivial.
Qed.

Definition power (x:set) :=
  sup (idx x->Prop)
   (fun P => subset x (fun y => exists2 i, eq_set y (elts x i) & P i)).

Lemma power_ax : forall x z,
  in_set z (power x) <->
  (forall y, in_set y z -> in_set y x).
unfold in_set at 1, power; simpl; intros.
split; intros.
 destruct H.
 specialize eq_elim with (1:=H0)(2:=H); intro.
 apply (proj1 (proj1 (subset_ax _ _ _) H1)).

 exists (fun i => in_set (elts x i) z).
 apply eq_intro; intros.
  apply (fun x P z => proj2 (subset_ax x P z)).
  split; auto.
  exists z0.
   apply eq_set_refl.

   elim H with z0; trivial; intros.
   exists x0; trivial.
   apply in_reg with z0; trivial.

  elim (proj2 (proj1 (subset_ax _ _ _) H0)); intros.
  destruct H2.
  apply in_reg with (elts x x1); trivial.
  apply eq_set_sym;
    apply eq_set_trans with x0; trivial.
Qed.

Lemma power_morph : forall x y,
  eq_set x y -> eq_set (power x) (power y).
intros.
apply eq_intro; intros.
 rewrite power_ax in H0|-*; intros.
 apply eq_elim with x; auto.

 apply eq_set_sym in H.
 rewrite power_ax in H0|-*; intros.
 apply eq_elim with y; auto.
Qed.

Fixpoint num (n:nat) : set :=
  match n with
  | 0 => empty
  | S k => union (pair (num k) (pair (num k) (num k)))
  end.

Definition infinity := sup _ num.

Lemma infty_ax1 : in_set empty infinity.
 exists 0.
 unfold elts, infinity, num.
 apply eq_set_refl.
Qed.

Lemma infty_ax2 : forall x, in_set x infinity ->
  in_set (union (pair x (pair x x))) infinity.
intros.
destruct H.
exists (S x0).
simpl elts.
apply union_morph.
apply pair_morph; trivial.
apply pair_morph; trivial.
Qed.

Definition replf (x:set) (F:set->set) :=
  sup _ (fun i => F (elts x i)).

Lemma replf_ax : forall x F z,
  (forall z z', in_set z x ->
   eq_set z z' -> eq_set (F z) (F z')) ->
  (in_set z (replf x F) <->
   exists2 y, in_set y x & eq_set z (F y)).
unfold in_set at 2, replf; simpl; intros.
split; intros.
 destruct H0.
 exists (elts x x0); trivial.
 exists x0; apply eq_set_refl.

 destruct H0.
 destruct H0.
 exists x1.
 apply eq_set_trans with (F x0); trivial.
 apply eq_set_sym.
 apply H.
  exists x1; apply eq_set_refl.
  apply eq_set_sym; trivial.
Qed.

Definition repl1 (x:set) (F:{y|in_set y x}->set) :=
  sup _ (fun i => F (elts' x i)).

Lemma repl1_ax : forall x F z,
  (forall z z', eq_set (proj1_sig z) (proj1_sig z') ->
   eq_set (F z) (F z')) ->
  (in_set z (repl1 x F) <->
   exists y, eq_set z (F y)).
unfold in_set at 6, repl1; simpl; intros.
split; intros.
 destruct H0.
 exists (elts' x x0); trivial.

 destruct H0.
 destruct x0.
 elim i; intros.
 exists x1.
 apply eq_set_trans with (1:=H0).
 apply H; simpl; trivial.
Qed.

Lemma repl1_morph : forall x y F G,
  eq_set x y ->
  (forall x' y', eq_set (proj1_sig x') (proj1_sig y') ->
   eq_set (F x') (G y')) ->
  eq_set (repl1 x F) (repl1 y G).
intros.
assert (forall z z', eq_set (proj1_sig z) (proj1_sig z') ->
        eq_set (F z) (F z')).
 intros.
 assert (in_set (proj1_sig z') y).
  apply eq_elim with x; trivial.
  apply (proj2_sig z').
 apply eq_set_trans with (G (exist _ (proj1_sig z') H2)).
  apply H0; simpl; trivial.

  apply eq_set_sym; apply H0; simpl; apply eq_set_refl.
assert (forall z z', eq_set (proj1_sig z) (proj1_sig z') ->
        eq_set (G z) (G z')).
 intros.
 apply eq_set_sym in H.
 assert (in_set (proj1_sig z') x).
  apply eq_elim with y; trivial.
  apply (proj2_sig z').
 apply eq_set_trans with (F (exist _ (proj1_sig z') H3)).
  apply eq_set_sym; apply H0; simpl; apply eq_set_sym; trivial.

  apply H0; simpl; apply eq_set_refl.
apply eq_intro; intros.
 rewrite repl1_ax in H3|-*; trivial.
 destruct H3.
 assert (in_set (proj1_sig x0) y).
  apply eq_elim with x; trivial.
  apply (proj2_sig x0).
 exists (exist (fun y' => in_set y' y) (proj1_sig x0) H4). (* regression of unification *)
(* exists (exist _ (proj1_sig x0) H4).*)
 apply eq_set_trans with (1:=H3).
 apply H0; simpl; apply eq_set_refl.

 rewrite repl1_ax in H3|-*; trivial.
 destruct H3.
 assert (in_set (proj1_sig x0) x).
  apply eq_set_sym in H.
  apply eq_elim with y; trivial.
  apply (proj2_sig x0).
 exists (exist (fun y0 => in_set y0 _) (proj1_sig x0) H4). (* unif regression *)
 apply eq_set_trans with (1:=H3).
 apply eq_set_sym; apply H0; simpl; apply eq_set_refl.
Qed.

(* We only use the following instance of unique choice for
   replacement: *)
Definition ttrepl :=
  forall a:set, unique_choice {x|in_set x a} set eq_set.

(* We show it is a consequence of [choice]. *)
Lemma ttrepl_axiom : ttrepl.
red; red; intros; apply choice_axiom; trivial.
Qed.

Lemma repl_ax:
    forall a (R:set->set->Prop),
    (forall x x' y y', in_set x a ->
     eq_set x x' -> eq_set y y' -> R x y -> R x' y') ->
    (forall x y y', in_set x a -> R x y -> R x y' -> eq_set y y') ->
    exists b, forall x, in_set x b <->
     (exists2 y, in_set y a & R y x).
intros.
elim (ttrepl_axiom (subset a (fun x=>exists y, R x y))
        (fun p y => R (proj1_sig p) y)); intros.
pose (a' := {x|in_set x (subset a (fun x => exists y, R x y))}).
fold a' in x,H1.
exists (repl1 _ x).
intros.
elim (repl1_ax _ x x0); intros.
 fold a' in H2,H3|-.
 split; intros.
  elim H2; trivial; intros.
  exists (proj1_sig x1).
   apply (proj1 (proj1 (subset_ax _ _ _) (proj2_sig x1))).

   apply H with (4:=H1 x1).
    apply (proj1 (proj1 (subset_ax _ _ _) (proj2_sig x1))).
    apply eq_set_refl.
    apply eq_set_sym; trivial.

  apply H3.
  destruct H4.
  assert (in_set x1 (subset a (fun x => exists y, R x y))).
   apply (proj2 (subset_ax a (fun x => exists y, R x y) x1)).
   split; trivial.
   exists x1.
    apply eq_set_refl.
    exists x0; trivial.
  pose (x' := exist _ x1 H6 : a').
  exists x'.
  apply H0 with x1; trivial.
  apply (H1 x').

 apply H0 with (proj1_sig z); trivial.
  apply (proj1 (proj1 (subset_ax _ _ _) (proj2_sig z))).
  apply H with (proj1_sig z') (x z'); trivial.
   apply (proj1 (proj1 (subset_ax _ _ _) (proj2_sig z'))).
   apply eq_set_sym; trivial.
   apply eq_set_refl.

(* side conditions *)
 elim (proj2 (proj1 (subset_ax _ _ _) (proj2_sig x))); intros.
 destruct H2.
 exists x1; apply H with (4:=H2).
  apply in_reg with (proj1_sig x); trivial.
  apply (proj1 (proj1 (subset_ax _ _ _) (proj2_sig x))).

  apply eq_set_sym; trivial.

  apply eq_set_refl.

 assert (in_set (proj1_sig x) a).
  apply (proj1 (proj1 (subset_ax _ _ _) (proj2_sig x))).
 split; intros.
  apply H0 with (proj1_sig x); trivial.

  revert H1; apply H; trivial.
  apply eq_set_refl.
Qed.

(* Attempt to prove that choice is necessary for replacement, by deriving
   choice from replacement. Works only for relations that are morphisms for
   set equality... *)
Lemma ttrepl_needed_for_repl :
  forall a:set,
  let A := {x|in_set x a} in
  let eqA (x y:A) := eq_set (proj1_sig x) (proj1_sig y) in
  let B := set in
  let eqB := eq_set in
  forall (R:A->B->Prop),
  Proper (eqA==>eqB==>iff) R ->
  (forall x:A, exists y:B, R x y) ->
  (forall x y y', R x y -> R x y' -> eqB y y') ->
  exists f:A->B, forall x:A, R x (f x).
intros a A eqA B eqB R Rext Rex Runiq.
destruct repl_ax with
  (a:=a) (R:=fun x y => exists h:in_set x a, R (exist _ x h) y).
 intros.
 destruct H2.
 exists (in_reg _ _ _ H0 x0).
 revert H2; apply Rext; apply eq_set_sym; assumption.

 intros x y y' _ (h,Rxy) (h',Rxy').
 apply Runiq with (1:=Rxy).
 revert Rxy'; apply Rext.
  apply eq_set_refl.
  apply eq_set_refl.

 exists (fun y => union (subset x (fun z => R y z))).
 intro.
 destruct Rex with x0.
 apply Rext with (3:=H0);[apply eq_set_refl|].
 apply eq_set_sym.
 apply eq_set_ax; split; intros.
  rewrite union_ax; exists x1; trivial.
  rewrite subset_ax.
  split.
   apply H.
   exists (proj1_sig x0); [apply proj2_sig|].
   exists (proj2_sig x0).
   destruct x0; trivial.

   exists x1; trivial; apply eq_set_refl.

  rewrite union_ax in H1; destruct H1.
  rewrite subset_ax in H2; destruct H2.
  destruct H3.
  apply eq_elim with x2; trivial.
  apply eq_set_trans with (1:=H3).
  apply Runiq with (1:=H4); trivial.
Qed.

Notation "x ∈ y" := (in_set x y).
Notation "x == y" := (eq_set x y).

(* Deriving the existentially quantified sets *)

Lemma empty_ex: exists empty, forall x, ~ x ∈ empty.
exists empty.
exact empty_ax.
Qed.

Lemma pair_ex: forall a b, exists c, forall x, x ∈ c <-> (x == a \/ x == b).
intros.
exists (pair a b).
apply pair_ax.
Qed.

Lemma union_ex: forall a, exists b,
    forall x, x ∈ b <-> (exists2 y, x ∈ y & y ∈ a).
intros.
exists (union a).
apply union_ax.
Qed.

Lemma subset_ex : forall x P, exists b,
  forall z, z ∈ b <->
  (z ∈ x /\ exists2 z', z == z' & P z').
intros.
exists (subset x P).
apply subset_ax.
Qed.

Lemma power_ex: forall a, exists b,
     forall x, x ∈ b <-> (forall y, y ∈ x -> y ∈ a).
intros.
exists (power a).
apply power_ax.
Qed.

Lemma repl_ex: forall a (R:set->set->Prop),
    (forall x x' y y', x ∈ a -> x == x' -> y == y' -> R x y -> R x' y') ->
    (forall x y y', x ∈ a -> R x y -> R x y' -> y == y') ->
    exists b, forall x, x ∈ b <-> (exists2 y, y ∈ a & R y x).
Proof repl_ax.

(* Collection *)
Section Collection.

Section FromTTColl.

(* TTColl is a consequence of choice *)
Lemma ttcoll :
  forall (A:Ti) (R:A->set->Prop),
  (forall x:A, exists y:set, R x y) ->
  exists X:Ti, exists f : X->set,
    forall x:A, exists i:X, R x (f i).
intros.
destruct (choice_axiom A set R) as (f,Hf); trivial.
(* X is A because choice "chooses" just one y for each x *)
exists A; exists f; eauto.
Qed.

Lemma ttcoll' :
  forall (A:Ti) R,
  (forall x:A, exists y:set, R x y) ->
  exists B, forall x:A, exists2 y, y ∈ B & R x y.
intros.
destruct ttcoll with (1:=H) as (X,(f,Hf)).
exists (sup X f).
intro.
destruct Hf with x.
exists (f x0); trivial.
exists x0; apply eq_set_refl.
Qed.

Lemma coll_ax_ttcoll : forall A (R:set->set->Prop),
    (forall x x' y y', in_set x A ->
     eq_set x x' -> eq_set y y' -> R x y -> R x' y') ->
    (forall x, in_set x A -> exists y, R x y) ->
    exists B, forall x, in_set x A -> exists2 y, in_set y B & R x y.
intros.
destruct (ttcoll (idx A) (fun i y => R (elts A i) y)) as (X,(f,Hf)).
 intro i.
 apply H0.
 exists i; apply eq_set_refl.

 exists (sup X f); intros.
 destruct H1 as (i,?).
 destruct (Hf i) as (j,?).
 exists (f j).
  exists j; apply eq_set_refl.

  revert H2; apply H.
   exists i; apply eq_set_refl.
   apply eq_set_sym; assumption.
   apply eq_set_refl.
Qed.

(* Proving collection requires the specialized version of ttcoll *)
Lemma ttcoll'' : forall A (R:set->set->Prop),
  (forall x x' y y', in_set x A ->
   eq_set x x' -> eq_set y y' -> R x y -> R x' y') ->
  (forall x, x ∈ A -> exists y:set, R x y) ->
  exists f : {x|x∈ A} -> {X:Ti & X->set},
    forall x, exists i:projT1 (f x), R (proj1_sig x) (projT2 (f x) i).
intros.
destruct (coll_ax_ttcoll A R H H0) as (B,HB).
exists (fun _ => let (X,f) := B in existT (fun X => X->set) X f).
destruct B; simpl.
destruct x; simpl; intros.
destruct HB with x; trivial.
destruct H1.
exists x1.
apply H with (4:=H2); auto with *.
apply eq_set_refl.
Qed.

End FromTTColl.

Section FromChoice.

Lemma coll_ax_choice : forall A (R:set->set->Prop),
    (forall x x' y y', in_set x A ->
     eq_set x x' -> eq_set y y' -> R x y -> R x' y') ->
    (forall x, in_set x A -> exists y, R x y) ->
    exists B, forall x, in_set x A -> exists y, in_set y B /\ R x y.
intros.
elim (choice_axiom {x|x ∈ A} set (fun p y => R (proj1_sig p) y)); trivial; intros.
 exists (repl1 A x).
 intros.
 destruct H2.
 exists (x (elts' _ x1)); split.
  exists x1; apply eq_set_refl.

  apply H with (proj1_sig (elts' _ x1)) (x (elts' _ x1)); trivial.
   apply (proj2_sig (elts' _ x1)).
   apply eq_set_sym; trivial.
   apply eq_set_refl.

 apply H0.
 apply (proj2_sig x).
Qed.

End FromChoice.

Section FromReplClassic.

Hypothesis EM : forall A:Prop, A \/ ~A.

(* von Neumann cumulative hierarchy (applied to any set) *)
Fixpoint V (x:set) := union (replf x (fun x' => power (V x'))).

Lemma V_morph : forall x x', eq_set x x' -> eq_set (V x) (V x').
induction x; destruct x'; intros.
simpl V; unfold replf; simpl sup.
apply union_morph.
simpl in H0.
destruct H0.
apply eq_intro; intros.
 destruct H2.
 destruct (H0 x).
 exists x0.
 apply eq_set_trans with (1:=H2).
 simpl elts.
 apply power_morph.
 auto.

 destruct H2.
 destruct (H1 x).
 exists x0.
 apply eq_set_trans with (1:=H2).
 simpl elts.
 apply power_morph.
 apply eq_set_sym; auto.
Qed.

Lemma V_def : forall x z,
  in_set z (V x) <-> exists y, in_set y x /\ incl_set z (V y).
destruct x; simpl; intros.
rewrite union_ax.
unfold replf; simpl.
split; intros.
 destruct H.
 destruct H0; simpl in *.
 exists (f x0); split.
  exists x0; apply eq_set_refl.

  red; rewrite <- power_ax.
  apply eq_elim with x; trivial.

 destruct H.
 destruct H.
 exists (power (V x)).
  rewrite power_ax; trivial.

  destruct H; simpl in *.
  exists x0.
  apply power_morph.
  apply V_morph; trivial.
Qed.

Lemma V_trans : forall x y z,
  z ∈ y -> y ∈ V x -> z ∈ V x.
intros x.
pattern x; apply wf_ax; trivial; clear x; intros.
rewrite V_def in H1|-*.
destruct H1.
destruct H1.
exists x0; split; trivial.
red; intros; eauto.
Qed.

Lemma V_pow : forall x, power (V x) == V (singl x).
intros.
apply eq_intro; intros.
 rewrite power_ax in H.
 rewrite V_def.
 exists x; split; trivial.
 exists tt; apply eq_set_refl.

 rewrite power_ax; intros.
 rewrite V_def in H; destruct H; destruct H.
 destruct H; simpl in *.
 apply eq_elim with (V x0); auto.
 apply V_morph; trivial.
Qed.

Lemma V_mono : forall x x',
  in_set x x' -> in_set (V x) (V x').
intros.
rewrite (V_def x').
exists x; split; trivial.
red; trivial.
Qed.

Lemma V_sub : forall x y y',
  in_set y (V x) -> incl_set y' y -> in_set y' (V x).
intros x.
pattern x; apply wf_ax; trivial; clear x; intros.
rewrite V_def in H0|-*.
destruct H0; destruct H0.
exists x0; split; trivial.
red; auto.
Qed.

Lemma V_compl : forall x z, in_set z (V x) -> in_set (V z) (V x).
intros x.
pattern x; apply wf_ax; trivial; clear x; intros.
rewrite V_def in *.
destruct H0; destruct H0.
exists x0; split; trivial.
red; intros.
rewrite V_def in H2; destruct H2; destruct H2.
apply H1 in H2.
apply V_sub with (V x1); eauto.
Qed.

Lemma V_intro : forall x, incl_set x (V x).
intros x.
pattern x; apply wf_ax; trivial; clear x; intros.
red; intros.
rewrite V_def.
exists z; split; auto.
Qed.

Lemma V_idem : forall x, V (V x) == V x.
intros.
apply eq_intro; intros.
 rewrite V_def in H; destruct H; destruct H.
 apply V_sub with (V x0); trivial.
 apply V_compl; trivial.

 apply V_sub with (V z).
  apply V_mono; trivial.
  apply V_intro.
Qed.

Lemma rk_induc :
  forall P:set->Prop,
  (forall x, (forall y, y ∈ V x -> P y) -> P x) ->
  forall x, P x.
intros.
cut (forall y, incl_set (V y) (V x) -> P y).
 intros.
 apply H0.
 red; trivial.
induction x using wf_ax; trivial; intros.
apply H; intros.
apply H1 in H2.
rewrite V_def in H2; destruct H2; destruct H2.
apply H0 with x0; trivial.
red; intros.
rewrite V_def in H4; destruct H4; destruct H4.
apply H3 in H4.
apply V_sub with (V x1); trivial.
apply V_compl; trivial.
Qed.

(* classical *)
Lemma V_total : forall x y, in_set (V x) (V y) \/ incl_set (V y) (V x).
intros x y.
revert x.
pattern y; apply wf_ax; trivial; clear y.
intros y Hy x.
destruct (EM (exists y', y' ∈ V y /\ incl_set (V x) y')).
left.
destruct H; destruct H.
apply V_sub with x0; trivial.

right; red; intros.
rewrite V_def in H0; destruct H0; destruct H0.
assert (exists w, w ∈ V x /\ ~ w ∈ V x0).
 destruct (EM (exists w, w ∈ V x /\ ~ w ∈ V x0)); trivial.
 assert (~ incl_set (V x) (V x0)).
  red; intros; apply H.
  exists (V x0); split; trivial.
  apply V_mono; trivial.
 elim H3; red; intros.
 destruct (EM (z0 ∈ V x0)); trivial.
 elim H2.
 exists z0; split; trivial.
destruct H2; destruct H2.
destruct (Hy _ H0 x1).
 elim H3.
 apply V_sub with (V x1); trivial.
 apply V_intro.

 apply V_sub with (V x1).
  apply V_compl; trivial.

  red; auto.
Qed.

Definition lst_rk (P:set->Prop) (y:set) :=
  P y /\
  (exists w, y == V w) /\
  (forall x, (exists w, x == V w) -> P x -> incl_set y (V x)).

Lemma lst_rk_morph :
  forall (P P':set->Prop), (forall x x', x == x' -> (P x <-> P' x')) ->
  forall y y', y == y' -> lst_rk P y -> lst_rk P' y'.
intros.
destruct H1.
destruct H2.
split; [|split].
 revert H1; apply H; trivial.

 destruct H2.
 exists x.
 apply eq_set_trans with y; trivial.
 apply eq_set_sym; trivial.

 red; intros.
 apply (H3 x); trivial.
 revert H5; apply H; apply eq_set_refl.

 apply eq_elim with y'; trivial.
 apply eq_set_sym; trivial.
Qed.

Lemma lst_incl : forall P y, lst_rk P y -> P y.
destruct 1.
trivial.
Qed.

Lemma lst_fun : forall P y y', lst_rk P y -> lst_rk P y' -> y == y'.
destruct 1; destruct 1.
destruct H0; destruct H2.
apply H3 in H1; trivial; apply H4 in H; trivial.
clear H3 H4.
apply eq_intro; intros.
 apply H1 in H3.
 destruct H2.
 apply eq_elim with (V x).
 2:apply eq_set_sym; trivial.
 apply eq_elim with (V (V x)).
 2:apply V_idem.
 apply eq_elim with (V y'); trivial.
 apply V_morph; trivial.

 apply H in H3.
 destruct H0.
 apply eq_elim with (V y); trivial.
 apply eq_set_trans with (V (V x)).
  apply V_morph; trivial.
 apply eq_set_trans with (V x).
  apply V_idem.
 apply eq_set_sym; trivial.
Qed.

Lemma lst_ex : forall (P:set->Prop), (forall x x', eq_set x x' -> P x -> P x') ->
  (exists x, P (V x)) -> exists y, lst_rk P y.
intros P Pm.
destruct 1.
revert H.
pattern x; apply rk_induc; clear x; intros.
destruct (EM (exists z, z ∈ V x /\ P (V z))).
 destruct H1; destruct H1; eauto.

 exists (V x).
 split; [|split]; trivial.
  exists x; apply eq_set_refl.

  red; intros.
  destruct (V_total x0 x); auto.
  elim H1.
  destruct H2.
  exists x0; split.
   apply V_sub with (V x0); trivial.
   apply V_intro.

   apply Pm with x0; trivial.
   apply eq_set_trans with (V x1); trivial.
   apply eq_set_trans with (V (V x1)).
    apply eq_set_sym; apply V_idem.
   apply eq_set_sym; apply V_morph; trivial.
Qed.

Lemma coll_ax : forall A (R:set->set->Prop),
    (forall x x' y y', in_set x A ->
     eq_set x x' -> eq_set y y' -> R x y -> R x' y') ->
    (forall x, in_set x A -> exists y, R x y) ->
    exists B, forall x, in_set x A -> exists y, in_set y B /\ R x y.
intros.
pose (P := fun x y => x ∈ A /\ exists z, z ∈ y /\ R x z).
assert (Pm : forall x x', x ∈ A -> x == x' -> forall y y', y == y' -> P x y -> P x' y').
 intros.
 destruct H4.
 destruct H5; destruct H5.
 split; [|exists x0;split].
  apply in_reg with x; trivial.

  apply eq_elim with y; trivial.

  apply H with x x0; trivial.
  apply eq_set_refl.
assert (Pwit : forall x, x ∈ A -> exists y, P x (V y)).
 intros.
 destruct (H0 x); trivial.
 exists (singl x0); split; trivial.
 exists x0; split; trivial.
 apply V_sub with (V x0).
  apply V_mono; exists tt; apply eq_set_refl.
  apply V_intro.
destruct (@repl_ax A (fun x y => lst_rk (P x) y)); eauto using lst_fun, lst_ex.
 intros.
 apply lst_rk_morph with (P x) y; trivial.
 intros.
 split; intros; eauto.
  apply Pm with x' x'0; trivial.
   apply in_reg with x; trivial.
   apply eq_set_sym; trivial.
   apply eq_set_sym; trivial.

 exists (union x); intros.
 destruct lst_ex with (P x0); auto.
  apply Pm; trivial; apply eq_set_refl.

  specialize lst_incl with (1:=H3).
  destruct 1 as (_,(?,(?,?))).
  exists x2; split; trivial.
  rewrite union_ax.
  exists x1; trivial.
  rewrite H1.
  exists x0; auto.
Qed.

Lemma coll2_ax : forall A (R:set->set->Prop) x,
    (forall x x' y y', in_set x A ->
     eq_set x x' -> eq_set y y' -> R x y -> R x' y') ->
    (exists y, R x y) ->
    in_set x A ->
    exists B, exists y, in_set y B /\ R x y.
intros.
assert (forall z, z ∈ singl x -> z ∈ A).
 intros.
 destruct H2; simpl in *.
 apply in_reg with x; trivial.
 apply eq_set_sym; trivial.
destruct (coll_ax (singl x) R); intros; eauto.
 destruct H0.
 exists x1.
 apply H with x x1; trivial.
  destruct H3; simpl in *.
  apply eq_set_sym; trivial.

  apply eq_set_refl.

 exists x0.
 apply H3.
 exists tt; apply eq_set_refl.
Qed.

End FromReplClassic.

End Collection.

(* Infinity *)

Lemma infinity_ex: exists2 infinite,
    (exists2 empty, (forall x, ~ x ∈ empty) & empty ∈ infinite) &
    (forall x, x ∈ infinite ->
     exists2 y, (forall z, z ∈ y <-> (z == x \/ z ∈ x)) &
       y ∈ infinite).
exists infinity.
 exists empty.
  exact empty_ax.
  exact infty_ax1.

 intros.
 exists (union (pair x (pair x x))); intros.
  rewrite union_ax.
  split; intros.
   destruct H0.
   rewrite pair_ax in H1; destruct H1.
    right.
    unfold in_set.
    apply eq_elim with x0; trivial.

    left.
    specialize eq_elim with (1:=H0) (2:=H1); intro.
    rewrite pair_ax in H2; destruct H2; trivial.

   destruct H0.
    exists (pair x x).
     rewrite pair_ax; auto.

     rewrite pair_ax; right; apply eq_set_refl.

    exists x; trivial.
    rewrite pair_ax; left; apply eq_set_refl.

  apply infty_ax2; trivial.
Qed.

(* Rk: decision of membership implies excluded-middle *)
Lemma set_dec_EM :
  (forall x y, in_set x y \/ ~ in_set x y) ->
  (forall P, P \/ ~ P).
intros.
destruct (H empty (subset (power empty) (fun _ => P))).
 left.
 rewrite subset_ax in H0; destruct H0.
 destruct H1; trivial.
 right; red; intros; apply H0.
 rewrite subset_ax.
 split.
  rewrite power_ax; intros.
  elim empty_ax with y; trivial.

  exists empty; trivial.
  apply eq_set_refl.
Qed.

(* Failed attempt to build (set-theoretical) choice axiom. *)

Section Choice.

Hypothesis C : forall X:Type, X + (X->False).

Lemma impl_choice_ax : forall A B, choice A B.
red; intros.
exists (fun x =>
  match C ({y:B|R x y}) with
  | inl y => proj1_sig y
  | inr h =>
    False_rect B (let (y,r) := H x in h (exist _ y r))
  end).
intros.
destruct (C {y:B|R x y}).
 destruct s; trivial.

 destruct (H x).
 destruct (f (exist (fun y => R x y) x0 r)).
Qed.

Definition choose (x:set) :=
  match C (idx x) with
  | inl i => elts x i
  | _ => empty
  end.

Lemma choose_ax : forall a, (exists x, x ∈ a) -> choose a ∈ a.
intros.
unfold choose.
destruct (C (idx a)).
 exists i; apply eq_set_refl.

 destruct H.
 destruct H.
 elim (f x0).
Qed.

(* ... but choose is not a morphism! *)
Lemma choose_not_morph : ~ forall x x', x == x' -> choose x == choose x'.
unfold choose; red; intros.
generalize (H (sup bool (fun b => if b then empty else singl empty))
              (sup bool (fun b => if b then singl empty else empty))).
simpl; intros.
assert (singl empty == empty).
 refine (let H1 := H0 _ in _).
  split; intros.
   exists (negb i).
   destruct i; apply eq_set_refl.

   exists (negb j).
   destruct j; apply eq_set_refl.

  clear H0.
  destruct (C bool).
   destruct b; auto with *.
   apply eq_set_sym; trivial.

   destruct (f true).
elim empty_ax with empty.
apply eq_elim with (singl empty); trivial.
exists tt; apply eq_set_refl.
Qed.

End Choice.

(* Regularity is classical *)

Section Regularity.

Definition regularity :=
  forall a a0, a0 ∈ a ->
  exists2 b, b ∈ a & ~(exists2 c, c ∈ a & c ∈ b).

Lemma regularity_ax (EM:forall P,P\/~P): regularity.
red.
induction a0; intros.
destruct (EM (exists i:X, f i ∈ a)).
 destruct H1; eauto.

 exists (sup X f); trivial.
 red; intros; apply H1.
 destruct H2.
 destruct H3; simpl in *.
 exists x0.
 apply in_reg with x; trivial.
Qed.

Lemma regularity_is_classical (reg : regularity) : forall P, P \/ ~P.
intros.
destruct (reg (subset (pair empty (power empty))
           (fun x => x == power empty \/ x == empty /\ P)) (power empty)).
 rewrite subset_ax.
 split.
  rewrite pair_ax; right ;apply eq_set_refl.
  exists (power empty).
   apply eq_set_refl.
   left; apply eq_set_refl.

 rewrite subset_ax in H; destruct H.
 destruct H1.
 destruct H2.
  right ;red; intros.
  apply H0.
  exists empty.
   rewrite subset_ax.
   split.
    rewrite pair_ax; left; apply eq_set_refl.
    exists empty.
     apply eq_set_refl.
     right; split; trivial.
     apply eq_set_refl.

    apply eq_elim with x0.
    2:apply eq_set_sym; trivial.
    apply eq_elim with (power empty).
    2:apply eq_set_sym; trivial.
    rewrite power_ax; trivial.

  destruct H2; auto.
Qed.

End Regularity.

End IZF_R.


(** * Writer *)

(** Output events. *)

(* begin hide *)
Set Implicit Arguments.
Set Contextual Implicit.

From Coq Require Import
     List.
Import ListNotations.

From ExtLib Require Import
     Structures.Functor
     Structures.Monad
     Structures.Monoid.

From ITree Require Import
     Basics.Basics
     Basics.CategoryOps
     Core.ITreeDefinition
     Indexed.Sum
     Core.Subevent
     Interp.Interp
     Interp.Handler
     Events.State.

Import Basics.Basics.Monads.
(* end hide *)

(** Event to output values of type [W]. *)
Variant writerE (W : Type) : Type -> Type :=
| Tell : W -> writerE W unit.

(** Output action. *)
Definition tell {W E F} `{writerE W +? F -< E} : W -> itree E unit :=
  fun w => trigger (Tell w).

(** One interpretation is to accumulate outputs in a list. *)

(** Note that this handler appends new outputs to the front of the list. *)
Definition handle_writer_list {W E}
  : writerE W ~> stateT (list W) (itree E)
  := fun _ e s =>
       match e with
       | Tell w => Ret (w :: s, tt)
       end.

Definition run_writer_list_state {W E F} `{writerE W +? E -< F}
  : itree F ~> stateT (list W) (itree E)
  := interp (over handle_writer_list).

Arguments run_writer_list_state {W E F _} [T].

(** Returns the outputs in order: the first output at the head, the last
    output and the end of the list. *)
Definition run_writer_list {W E F} `{writerE W +? E -< F}
  : itree F ~> writerT (list W) (itree E)
  := fun _ t =>
       ITree.map (fun wsx => (rev' (fst wsx), snd wsx))
                 (run_writer_list_state t []).

Arguments run_writer_list {W E F _} [T].

(** When [W] is a monoid, we can also use that to append the outputs together. *)

Definition handle_writer {W E} (Monoid_W : Monoid W)
  : writerE W ~> stateT W (itree E)
  := fun _ e s =>
       match e with
       | Tell w => Ret (monoid_plus Monoid_W s w, tt)
       end.

Definition run_writer {W E F} (Monoid_W : Monoid W) `{writerE W +? E -< F}
  : itree F ~> writerT W (itree E)
  := fun _ t =>
       interp (T := fun x => x) (over (handle_writer Monoid_W)) t
                    (monoid_unit Monoid_W).

Arguments run_writer {W E _} Monoid_W {_} [T].