Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Export sset15.

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

Module NumberSums.

Definition nth_more K S := S +s1 intersection (K -s S).
Definition nth_elts K := induction_term (fun _ S => nth_more K S) emptyset.

Lemma nth_set0 x (y := intersection x) : x = emptyset -> y = \0c.
Proof. by rewrite /y;move => ->; rewrite setI_0. Qed.

Lemma nth_set1 x (y := intersection x) :
  sub x Bnat -> nonempty x ->
  (inc y x /\ forall z, inc z x -> y <=c z).
Proof.
move => sB xnz.
have osx: ordinal_set x by move => i /sB /Bnat_oset.
move:(ordinal_setI xnz osx); rewrite -/y => yx; split => //.
move => z zx.
move: (CS_Bnat (sB _ yx)) (CS_Bnat (sB _ zx)) => sa sb.
by split => // t; move/(setI_P xnz); apply.
Qed.

Lemma nth_set2 K S: sub K S -> nth_more K S = S +s1 \0c.
Proof. by move => h; rewrite /nth_more (setC_T h) setI_0. Qed.

Lemma nth_set3 K: nth_more K K = K +s1 \0c.
Proof. by apply:nth_set2. Qed.

Definition segment_nat K S:=
  sub S K /\ (forall i j, inc i S -> inc j (K -s S) -> i <c j).

Lemma nth_set4 K S (S':= nth_more K S) (x:= intersection (K -s S)):
   sub K Bnat -> segment_nat K S -> S <> K ->
   [/\ segment_nat K S', inc x (S' -s S) & cardinal S' = succ (cardinal S)].
Proof.
move => KB [sa sb sc].
have sd:=(setC_ne (conj sa sc)).
have se:=(sub_trans (@sub_setC K S) KB).
move:(nth_set1 se sd); rewrite -/x; move => [/setC_P [xK xS] xm].
split; first split.
+ by move => t /setU1_P; case; [move /sa | move => ->].
+ move => i j /setU1_P iv /setC_P [jK /setU1_P jv].
  have aux: inc j (K -s S) by apply/setC_P; split => //;dneg js; left.
  case iv; first by move => iS; apply: sb => //.
  by rewrite -/x => ->; split; [ apply: xm | dneg h; right].
+ by apply/setC_P; split; [ apply:setU1_1 | ].
+ by rewrite card_succ_pr.
Qed.

Lemma nth_elts0 K: nth_elts K \0c = emptyset.
Proof. by apply:induction_term0. Qed.

Lemma nth_elts_succ K n:
 inc n Bnat -> nth_elts K (succ n) = nth_more K (nth_elts K n).
Proof. apply:induction_terms. Qed.

Lemma nth_set5 K n (S:= nth_elts K n):
   inc n Bnat -> sub K Bnat -> n <=c cardinal K ->
   (segment_nat K S /\ cardinal S = n).
Proof.
rewrite /S => nB kB;move: n {S} nB; apply: cardinal_c_induction.
  move => _; rewrite nth_elts0 cardinal_set0; split => //; split=> i.
    by move/in_set0.
  by move => j /in_set0.
move => n nB Hrec snk.
rewrite /nth_elts (induction_terms _ _ nB) -/(nth_elts K n).
move:(Hrec (card_leT (card_le_succ nB) snk)) => [sa sb].
case (equal_or_not (nth_elts K n) K) => nsK.
  by move: (proj2 (card_lt_leT (card_lt_succ nB) snk)); rewrite - nsK sb.
by move: (nth_set4 kB sa nsK); rewrite sb; move => [ua _ ub].
Qed.

Lemma nth_set6 K (n:= cardinal K):
   inc n Bnat -> sub K Bnat -> (nth_elts K n) = K.
Proof.
move => nB kB.
move: (nth_set5 nB kB (card_leR (CS_Bnat nB))) => [[sa _] sb].
have fsk: finite_set K by apply /BnatP.
move: (cardinal_setC4 sa fsk); rewrite sb cdiff_n_n.
by move /cardinal_nonemptyset => /empty_setC h; apply: extensionality.
Qed.

Lemma nth_set_M K n m:
  inc n Bnat -> m <=c n -> sub (nth_elts K m) (nth_elts K n).
Proof.
move => nB mn.
rewrite - (cdiff_pr mn).
move:(BS_diff m nB); set k:= (n -c m) => kB.
move:(BS_le_int mn nB) => mB; move: k kB;clear n mn nB.
apply: cardinal_c_induction; first by rewrite (csum0r (CS_Bnat mB)).
move => n nB hrec.
rewrite (csum_via_succ _ nB) (nth_elts_succ _ (BS_sum mB nB)).
apply /(sub_trans hrec) /subsetU2l.
Qed.

Definition nth_elt K n := union (nth_elts K (succ n) -s nth_elts K n).

Lemma nth_set7 K n (S:= (nth_elts K n)) (x:= nth_elt K n) :
   inc n Bnat -> sub K Bnat -> n <c cardinal K ->
   [/\ inc x (K -s S), inc x (nth_elts K (succ n)),
       forall y, inc y (K -s S) -> x <=c y
     & forall y, inc y S -> y <c x].
Proof.
move => nB KB h1.
have [[SK sw] cs1]:= (nth_set5 nB KB (proj1 h1)).
have pa: sub (K -s S) Bnat by move => t/setC_P [/ KB h _].
case: (emptyset_dichot (K -s S)) => nek.
  by case: (proj2 h1); rewrite - cs1 {2} (extensionality (empty_setC nek) SK).
have h2: succ n <=c cardinal K by apply /(card_le_succ_ltP _ nB).
move: (nth_set1 pa nek).
set I := intersection (K -s S); move => [sa sb].
have /setCId_Pl di: disjoint (singleton I) S.
  by apply: disjoint_pr => u /set1_P -> eis; case/setC_P: sa => _.
move: (erefl x); rewrite {1} /x /nth_elt /nth_elts (induction_terms _ _ nB).
rewrite -/(nth_elts K n) /nth_more -/S -/I setCU2_l setC_v set0_U2 di setU_1.
by move => <-; split; fprops; move => y ys; apply: sw.
Qed.

Lemma nth_set9 K n:
   inc n Bnat -> sub K Bnat -> n <c cardinal K ->
   inc (nth_elt K n) K.
Proof. by move => pa pb pc; move:(nth_set7 pa pb pc) => [/setC_P []]. Qed.

Lemma nth_set8 K n m:
   inc n Bnat -> sub K Bnat -> n <c cardinal K ->
   m <c n -> (nth_elt K m) <c (nth_elt K n).
Proof.
move => nB KB nk mn.
have mB:= (BS_lt_int mn nB).
move: (nth_set7 nB KB nk); move => [_ _ _ h1]; apply: h1.
move:(nth_set7 mB KB (card_lt_ltT mn nk)) => [_ ub _ _].
move /(card_le_succ_ltP _ mB): mn => le1.
exact:(nth_set_M nB le1).
Qed.

Definition nth_set_fct K := Lf (nth_elt K) (Bint (cardinal K)) K.

Lemma nth_set_fct_bf K (f := (nth_set_fct K)):
  sub K Bnat -> finite_set K ->
  (bijection (nth_set_fct K) /\
  forall i j, inc i (source f) -> inc j (source f) -> i <c j ->
       Vf f i <c Vf f j).
Proof.
move => KB /BnatP kB.
have ax: lf_axiom (nth_elt K) (Bint (cardinal K)) K.
  move => n /(BintP kB) nk.
  by move:(nth_set7 (BS_lt_int nk kB) KB nk) => [/setC_P [h _] _ _ _].
have sf: source f = (Bint (cardinal K)) by rewrite /f/nth_set_fct;aw.
have pa: forall i j, inc i (source f) -> inc j (source f) -> i <c j ->
       Vf f i <c Vf f j.
  rewrite /f/nth_set_fct;aw;move => i j isf jsf; aw.
  move/(BintP kB): jsf => jk.
  by apply:nth_set8 => //; apply:(BS_lt_int jk kB).
split; last by exact.
rewrite sf in pa.
have fi: injection f.
  apply: lf_injective => // u v usf vsf sv.
  case: (Bnat_to_ell (Bint_S1 usf) (Bint_S1 vsf)) => cp //.
    by move: (proj2 (pa _ _ usf vsf cp)); rewrite /f/nth_set_fct;aw; case.
    by move: (proj2 (pa _ _ vsf usf cp)); rewrite /f/nth_set_fct;aw; case.
apply: bijective_if_same_finite_c_inj => //;rewrite /nth_set_fct; aw.
  by rewrite (card_Bint kB).
apply:finite_Bint.
Qed.

Lemma nth_set_10 K a: sub K Bnat -> finite_set K -> inc a K ->
  exists2 n, n <c (cardinal K) & a = (nth_elt K n).
Proof.
move => ha hb aK; move:( nth_set_fct_bf ha hb) => [[_ [ff fs]] _].
have hc: inc (cardinal K) Bnat by apply/BnatP.
have ax:lf_axiom (nth_elt K) (Bint (cardinal K)) K.
  move => t /(BintP hc) ta; apply:(nth_set9 _ ha ta).
  exact:(BS_lt_int ta hc).
move:fs; rewrite /nth_set_fct; aw => fs; move:(fs _ aK) => [x xa].
by aw => <-; exists x => //; apply/(BintP hc).
Qed.

Definition perm_int n := (permutations (Bint n)).

Lemma perm_intP f n: inc f (perm_int n) <->
   [/\ bijection f, source f = (Bint n) &
       target f = (Bint n)].
Proof.
split.
  by move/Zo_P => [/fun_set_P [ff sf tf] bf];split.
move => [pa pb pc]; apply:Zo_i => //; apply /fun_set_P; split=> //; fct_tac.
Qed.

Lemma perm_int_id n: inc (identity (Bint n)) (perm_int n).
Proof.
apply/perm_intP.
move:(identity_prop (Bint n)) => [_ pa pb].
split => //; apply: identity_fb.
Qed.

Lemma perm_int_inj n f: inc n Bnat -> inc f (perm_int n) ->
    (forall x y, x <c n -> y <c n -> Vf f x = Vf f y -> x = y).
Proof.
move => nB /perm_intP[ [[_ H] _] sf _].
rewrite sf in H.
by move => x y /(BintP nB) xs /(BintP nB) ys sv; apply:H.
Qed.

Lemma perm_int_surj n f: inc n Bnat -> inc f (perm_int n) ->
   forall y, y <c n -> exists2 x, x<c n & Vf f x = y.
Proof.
move => nB /perm_intP[ [_ [_ H]] sf tf].
rewrite sf tf in H.
by move => y /(BintP nB) /H [x /(BintP nB) sa sb]; exists x.
Qed.

Lemma perm_int_comp n f g:
    inc f (perm_int n) -> inc g (perm_int n) ->
    inc (f \co g) (perm_int n).
Proof.
move /perm_intP => [sa sb sc]/perm_intP [sa' sb' sc'].
apply/perm_intP; split;aw;apply: compose_fb => //.
by split; [fct_tac | fct_tac | rewrite sb sc'].
Qed.

Lemma perm_int_inv n f: inc f (perm_int n) ->
  inc (inverse_fun f) (perm_int n).
Proof.
move /perm_intP => [sa sb sc]; apply /perm_intP; split ; aw.
by apply: inverse_bij_fb.
Qed.

Lemma transposition_prop n i j
   (f:=Lf (fun z => Yo (z = i) j (Yo (z = j) i z)) (Bint n) (Bint n)):
   inc n Bnat -> inc i (Bint n) -> inc j (Bint n) ->
   [/\ inc f (perm_int n), Vf f i = j, Vf f j = i,
     forall k, inc k (Bint n) -> k <> i -> k <> j -> (Vf f k) = k &
     forall k, inc k (Bint n) -> Vf f (Vf f k) = k].
Proof.
move => nB iE jE.
set F := fun z => Yo (z = i) j (Yo (z = j) i z).
have la: lf_axiom F (Bint n) (Bint n).
   rewrite /F => z; Ytac h1; [ ue | Ytac h2; [ ue | done]].
have pa: Vf f i = j by rewrite /f; aw; Ytac0.
have pb: Vf f j = i by rewrite /f; aw; Ytac h1 => //; Ytac0.
have pc: forall k, inc k (Bint n) -> k <> i -> k <> j -> Vf f k = k.
  by move => k kE ki kj; rewrite /f; aw; Ytac0; Ytac0.
have pd:forall k, inc k (Bint n) -> Vf f (Vf f k) = k.
  move => k kE; case (equal_or_not k i) => ki; first by rewrite ki pa pb.
  case (equal_or_not k j) => kj; first by rewrite kj pb pa.
  by rewrite !(pc _ kE ki kj).
have sf: source f = (Bint n) by rewrite /f;aw.
have tf: target f = (Bint n) by rewrite /f;aw.
have ff: function f by apply: (lf_function la).
have bf: bijection f.
  split; split => //; first by rewrite sf => u v /pd {2} <- /pd {2} <- ->.
  rewrite sf tf => y ye;exists (Vf f y); [ Wtac | by rewrite pd].
split => //; apply /perm_intP; split => //.
Qed.

Lemma permutation_exists1 n i: inc n Bnat -> i <cn ->
    exists2 f, inc f (perm_int n) & Vf f \0c = i.
Proof.
move => nB lin.
move /(BintP nB): (card_le_ltT (czero_least (proj31_1 lin)) lin) => oE.
move /(BintP nB):lin => iI.
move:(transposition_prop nB iI oE) => [pa _ pb _ _].
move: pa pb;set f := Lf _ _ _ => pa pb; ex_tac.
Qed.

Lemma permutation_exists2 E n: inc n Bnat -> sub E (Bint n) ->
   exists2 f, inc f (perm_int n) & E = image_by_fun f (Bint (cardinal E)).
Proof.
move => nB;move:n nB E; apply: cardinal_c_induction.
  move => E; rewrite Bint_co00 => /sub_set0 ->.
  rewrite cardinal_set0 Bint_co00.
  by have h := (perm_int_id \0c); ex_tac; rewrite fun_image_set0.
move => n nB Hrec E seI.
case: (equal_or_not E (Bint (succ n))) => Ev.
  rewrite Ev (card_Bint (BS_succ nB)).
  set F := Bint (succ n).
  have bi:= (identity_fb F).
  exists (identity F). apply: perm_int_id.
  have {3} <-: source (identity F) = F by apply: identity_s.
  by rewrite -/(image_of_fun _) (surjective_pr0 (proj2 bi)) identity_t.
move: (setC_ne (conj seI Ev)) => [k1 /setC_P [k1I k1E]].
move:(Bint_pr4 nB) =>[].
set In:= Bint n; set Im := (Bint (succ n)) => sa sb.
have Inm: forall i, inc i In -> (inc i Im /\ i <> n).
  by move => i ein; rewrite - sa; split; [ fprops | dneg w; ue].
have nIm: inc n Im by exact : (Bint_si nB).
set k0:= Yo (inc n E) k1 n.
have kI: inc k0 Im by rewrite /k0; Ytac h.
have kE: ~(inc k0 E) by rewrite /k0; Ytac h.
set F := (E +s1 k0) -s1 n.
have eq0: F +s1 n = E +s1 k0.
  rewrite /k0;set_extens t; case/setU1_P.
  + by move/setC1_P => [].
  + move => ->; Ytac h; fprops.
  + move => tE; case (equal_or_not t n) => etn; first by rewrite etn; fprops.
    apply /setU1_P; left; apply/setC1_P; split ; fprops.
  + rewrite /F/k0;move => ->;Ytac h; fprops; case (equal_or_not k1 n).
      by move ->; fprops.
    move => h'; apply/setU1_P; left; apply/setC1_P; fprops.
have fIn: sub F In.
  move => t /setC1_P [ta tb].
  have: inc t Im by case /setU1_P:ta; [apply: seI | move => ->].
  rewrite - sa; case /setU1_P => //.
move: (Hrec _ fIn) => [f /Zo_P [/fun_set_P[ff sf tf] fb] fv].
rewrite -/In in sf tf.
pose g i := Yo (i = n) k0 (Yo (Vf f i = k0) n (Vf f i)).
have pa: lf_axiom g Im Im.
  hnf; rewrite/g - {1} sa; move => t;case /setU1_P; last by move => ->; Ytac0.
  move => ti;Ytac h => //; Ytac h' => //; rewrite - sa; apply/setU1_r;Wtac.
have sg:surjection (Lf g Im Im).
  apply: lf_surjective => // y; rewrite - {1} sa /g; case /setU1_P.
    case: (equal_or_not y k0) => yk0; first by exists n => //; Ytac0.
    rewrite - tf => /(proj2 (proj2 fb)) [x xsf fx].
    rewrite sf in xsf; move: (Inm _ xsf) => [xa xb]; ex_tac.
    by rewrite fx; Ytac0; Ytac0.
  move => ->;move: (kI) ; rewrite -/Im - {1} sa; case /setU1_P.
    rewrite - tf; move/(proj2 (proj2 fb)) => [x xsf fx].
    rewrite sf in xsf; move: (Inm _ xsf) =>[xa xb]; ex_tac.
    by rewrite /g; Ytac0; Ytac0.
  by move => kn;exists k0 => //;rewrite /g; Ytac0.
set G:= (Lf g Im Im).
have bg:bijection (Lf g Im Im).
  have cc: cardinal (source G) = cardinal (target G) by rewrite/ G; aw.
  have fsg: finite_set (source G).
    by rewrite /G /Im; aw; apply:finite_Bint.
   exact:(bijective_if_same_finite_c_surj cc fsg sg).
have gP: inc G (permutations Im).
  apply: Zo_i => //; apply/fun_set_P; rewrite /G;split;aw; fct_tac.
have nf: ~ (inc n F) by move/setC1_P => [].
have nk0: ~ inc k0 E by rewrite /k0; Ytac h.
move: (f_equal cardinal eq0).
rewrite (card_succ_pr nf)(card_succ_pr nk0).
move/(succ_injective1 (CS_cardinal F)(CS_cardinal E)) => <-.
move:(sub_smaller fIn); rewrite /In (card_Bint nB) => le1.
move:(Bint_M nB); rewrite -/In -/Im => sub2.
move: fv (Bint_M1 nB le1).
set Ik:= (Bint (cardinal F)); rewrite -/In => fv sub1.
move: (sub_trans sub1 sub2) => sub3.
have fG: function G by fct_tac.
have ssG: sub Ik (source G) by rewrite /G; aw.
have ssF: sub Ik (source f) by rewrite sf.
ex_tac.
set_extens t.
  move => tE;case (equal_or_not t n) => etn.
    move:(setU1_1 k0 E); rewrite - eq0 => /setU1_P; case.
      rewrite fv; move => /(Vf_image_P ff ssF) [u ua ub].
      apply/(Vf_image_P fG ssG); ex_tac;rewrite /G; aw; last by apply:sub3.
      rewrite /g;Ytac h1; first by move: (sub1 _ ua); rewrite h1.
      by rewrite - ub; Ytac0.
    by move => w; case kE; rewrite w - etn.
  move: (setU1_r k0 tE); rewrite - eq0 => /setU1_P;case => //.
  rewrite fv; move => /(Vf_image_P ff ssF) [u ua ub].
  apply/(Vf_image_P fG ssG); ex_tac;rewrite /G; aw; last by apply:sub3.
  rewrite /g;Ytac h1; first by move: (sub1 _ ua); rewrite h1.
  by rewrite - ub; Ytac h=> //; case kE; rewrite - h.
move /(Vf_image_P fG ssG) => [u uik ->]; move:(sub3 _ uik)=> uIm.
rewrite /G; aw;rewrite /g; Ytac un.
   by case sb; rewrite -un; exact:(sub1 _ uik).
have: inc (Vf f u) F by rewrite fv; apply/(Vf_image_P ff ssF); ex_tac.
move/setC1_P => [ha hb];Ytac h1; first by move: h1; rewrite /k0;Ytac h2.
by case/setU1_P: ha.
Qed.

Definition nds_sc n X g := osum_expansion (fun z => (X (Vf g z))) n.

Definition nds_sums n X := fun_image (perm_int n) (nds_sc n X).

Definition nds_card n X := cardinal (nds_sums n X).

Definition nds_ax X n:= ord_below_n X n.

Lemma nds_a n X: inc n Bnat -> nds_card n X <=c (factorial n).
Proof.
move=> nB.
rewrite /nds_card/nds_sums.
set a := (perm_int n).
set b := fun_image _ _.
set E:= (Bint n).
have cE: cardinal E = n by apply card_Bint.
have fsE: finite_set E by red; rewrite cE; apply /BnatP.
move: (number_of_permutations fsE); rewrite cE; move => <-.
apply: surjective_cardinal_le.
  exists (Lf (nds_sc n X) a b); red; aw; split => //.
apply:lf_surjective.
   move=> t ta; apply /funI_P; ex_tac.
by move=> y /funI_P.
Qed.

Lemma nds_b X n f: inc n Bnat -> nds_ax X n->
   inc f (perm_int n) ->
   (nds_ax (fun z => X (Vf f z)) n /\ ordinalp (nds_sc n X f)).
Proof.
move=> nB ax => /Zo_P [] /fun_set_P [ff sf tf] bf.
suff pc: nds_ax (fun z : Set => X (Vf f z)) n.
  by split => //; apply: OS_osum_expansion.
move => t tn; apply: ax; apply/(BintP nB); Wtac.
by rewrite sf; apply/(BintP nB).
Qed.

Lemma nds_sc_exten X X' n f:
  inc n Bnat -> (same_below X X' n) ->
  inc f (perm_int n) ->
  nds_sc n X f = nds_sc n X' f.
Proof.
move =>nB h /Zo_P [] /fun_set_P [fg sg tg] bg;apply: (osum_expansion_exten nB).
move => i /(BintP nB) ia; apply: h; apply/(BintP nB); Wtac.
Qed.

Lemma nds_m n X g (Y:= fun z => X (Vf g z)):
  inc n Bnat -> nds_ax X n -> inc g (perm_int n) ->
  nds_card n X = nds_card n Y.
Proof.
move => nB ax /Zo_P [] /fun_set_P [fg sg tg] bg.
rewrite /nds_card /nds_sums; apply: f_equal.
set E := perm_int n.
set_extens t; move /funI_P => [z ze ->]; apply /funI_P.
  move: (inverse_bij_fb bg) => ibg.
  move: ze => /Zo_P [] /fun_set_P [fz sz tz] bz.
  have fa: (inverse_fun g) \coP z by red;aw;split => //; [fct_tac | ue].
  have fb: function ((inverse_fun g) \co z) by fct_tac.
  exists ((inverse_fun g) \co z).
  apply: Zo_i; [ apply /fun_set_P;red;aw;split => // | by apply compose_fb ].
  apply:(osum_expansion_exten nB) => i lin.
  have iz: inc i (source z) by rewrite sz; apply /(BintP nB i).
  have cp: inverse_fun g \coP z by split; [ fct_tac | exact | aw; ue].
  have fzy: inc (Vf z i) (target g) by rewrite tg - tz; Wtac.
  by rewrite /Y (compf_V cp iz) (inverse_V bg fzy).
move: ze => /Zo_P [] /fun_set_P [fz sz tz] bz.
have fa: g \coP z by red;aw;split => //; ue.
have fb: function (g \co z) by fct_tac.
exists (g \co z).
  apply: Zo_i; [ apply /fun_set_P;red;aw;split => // | by apply compose_fb ].
apply:(osum_expansion_exten nB) => i lin.
by rewrite /Y compf_V // sz; apply/(BintP nB i).
Qed.

Lemma nds_c n X: inc n Bnat ->
   (\1c <=c nds_card n X /\ inc (nds_card n X) Bnat).
Proof.
move=> nB; move: (nds_a X nB) => pa.
move:(BS_le_int pa (BS_factorial nB)) => pb.
split => //.
rewrite /nds_card/nds_sums; apply: card_ge1; first by fprops.
apply: cardinal_nonemptyset1; apply:funI_setne.
exists (identity (Bint n)).
apply: Zo_i; [ apply /fun_set_P;red;aw;split;fprops | apply identity_fb].
Qed.

Lemma nds_d X n: (n = \0c \/ n = \1c) ->
  nds_ax X n -> nds_card n X = \1c.
Proof.
move=> np ax.
have nB: inc n Bnat by case: np => ->; fprops.
apply: card_leA.
  by move: (nds_a X nB); case: np => ->; rewrite ? factorial0 ? factorial1.
exact (proj1 (nds_c X nB)).
Qed.

Lemma nds_e X: nds_ax X \2c -> osum_expansion X \2c = (X \1c) +o (X \0c).
Proof.
rewrite - succ_one => pa.
rewrite (osum_expansion_succ _ BS1) (osum_expansion1) //; apply: pa.
rewrite succ_one; apply: card_lt_02.
Qed.

Lemma nds_f n X (f := identity (Bint n)) :
  inc n Bnat -> nds_ax X n ->
  (inc f (perm_int n) /\ (nds_sc n X f = osum_expansion X n)).
Proof.
move=> nB ax.
have bi: bijection f by apply identity_fb.
split.
  by rewrite /f; apply: Zo_i => //; apply /fun_set_P; red;aw;split;fprops.
apply:(osum_expansion_exten nB) => i lin.
by rewrite /f identity_V // ; apply/(BintP nB).
Qed.

Lemma nds_g (X:=(variant \0c \1o omega0)):
    nds_ax X \2c /\ nds_card \2c X = \2c.
Proof.
move: osum2_nc => /= nc.
have nX: nds_ax X \2c by move => t t2; rewrite /X /variant; Ytac h; fprops.
split => //; apply: card_leA.
  by move: (nds_a X BS2); rewrite factorial2.
move: (nds_f BS2 nX) => [ha hb].
have ne: \1c <> \0c by fprops.
apply /card_le2P.
exists (\1o +o omega0), (omega0 +o \1o); split => //;apply /funI_P; last first.
  exists (identity (Bint \2c)) => //.
  by rewrite hb (nds_e nX) /X /variant; Ytac0; Ytac0.
set I:= (Bint \2c).
have I1: inc \1c I by apply/(BintP BS2); apply: card_lt_12.
have I0: inc \0c I by apply/(BintP BS2); apply: card_lt_02.
have iv: forall y, inc y (Bint \2c) -> y = \0c \/ y = \1c.
    by move=> y /(BintP BS2) => h; apply card_lt2.
have ta: lf_axiom (variant \0c \1c \0c) I I.
  by move => t _; rewrite /variant; Ytac h.
have fp: inc (Lf (variant \0c \1c \0c) I I) (permutations I).
  apply/Zo_i; first by apply /fun_set_P; split; [apply: lf_function | aw | aw].
  apply: lf_bijective => //.
    move=> u v us vs.
    rewrite /variant; case: (iv _ us); case: (iv _ vs);
       move => -> ->; Ytac0 => //; Ytac0 => //.
    move => y yv; case: (iv _ yv); move => ->.
      by exists \1c => //; rewrite /variant; Ytac0.
      by exists \0c => //; rewrite /variant; Ytac0.
have ax2:= (proj1 (nds_b BS2 nX fp)).
exists (Lf (variant \0c \1c \0c) I I); first exact.
by rewrite /nds_sc nds_e; aw; aw; rewrite /X /variant; repeat Ytac0.
Qed.

Lemma nds_h (A:= omega0 ^o \2o) (B:= omega0) (C := omega0 +o \1o)
  (s1 := A +o (B +o C)) (s2:= A +o (C +o B)) (s3 := B +o (A +o C))
  (s4 := B +o (C +o A)) (s5:= C +o (A +o B)) (s6 := C +o (B +o A)):
  cardinal (((doubleton s1 s2) \cup (doubleton s3 s5)) \cup
    (doubleton s4 s6)) = card_five.
Proof.
set T := union2 _ _.
move: OS_omega OS1 OS2 => oB o1 o2.
have oA: ordinalp A by apply: OS_pow.
have oC: ordinalp C by apply: OS_sum2.
move: (ord_negl_p4 ord_lt_02); rewrite opowx0 -/A => pa.
move: (ord_negl_p4 ord_lt_12); rewrite (opowx1 oB) -/A -/B => pb.
have e1: s3 = A +o C by rewrite /s3 (osumA oB oA oC) pb.
have e2: s6 = C +o A by rewrite /s6 pb.
have pc: C +o A = A by rewrite - (osumA oB OS1 oA) pa pb.
have pd: (doubleton s4 s6) = singleton A by rewrite /s4 e2 pc pb.
have e3: s2= A +o (B +o B).
   by rewrite /s2 - (osumA oB o1 oB) (osum_int_omega ord_lt_1omega).
have e4: s5= A +o B by rewrite /s5 (osumA oC oA oB) pc.
set T1:= (union2 (doubleton s1 s2) (doubleton s3 s5)).
have bz: B <> \0o by apply: omega_nz.
have onz: \1o <> \0o by fprops.
case: (equal_or_not C \0o) => cz; first by move: (osum2_zero oB OS1 cz) => [_].
have nAt: ~ (inc A T1).
  have sA: forall b, ordinalp b ->A = A +o b -> b = \0o.
     move => b ob h; symmetry in h; exact (osum_a_ab oA ob h).
  case /setU2_P; case /set2_P.
  - by move/(sA _ (OS_sum2 oB oC)) => /(osum2_zero oB oC) [_].
  - by move/(sA _ (OS_sum2 oC oB)) => /(osum2_zero oC oB) [].
  - by rewrite e1; move /(sA _ oC).
  - by rewrite e4; move /(sA _ oB).
have ->: T = T1 +s1 A by rewrite -pd //.
rewrite /card_five (card_succ_pr nAt); congr succ.
set T2 := (doubleton s1 s2) +s1 s3.
have ->: T1 = T2 +s1 s5.
  set_extens t.
     case /setU2_P => h; first by apply /setU1_P; left; apply /setU1_P; left.
     case /set2_P :h => h; first by apply /setU1_P; left; apply /setU1_P; right.
     by apply /setU1_P; right.
  case /setU1_P =>h; last by apply /setU2_P; right; apply/set2_P; right.
  case /setU1_P:h => h; last by apply /setU2_P; right; apply/set2_P; left.
  by apply /setU2_P; left.
have aux: forall b c, ordinalp b -> ordinalp c -> A +o b = A +o c -> b = c.
  move => b c ob oc ; apply: (osum2_simpl ob oc oA).
have auB: forall b c, ordinalp b -> ordinalp c -> B +o b = B +o c -> b = c.
  move => b c ob oc ; apply: (osum2_simpl ob oc oB).
case (equal_or_not B C) => nCB; first by move: (osum_a_ab oB o1 (esym nCB)).
have nat2: ~ inc s5 T2.
  rewrite /T2 e4 /s1 e1 e3 => /setU1_P; case => h; last first.
    case: nCB; exact (aux _ _ oB oC h).
  case /set2_P:h=> h.
       move: (aux _ _ oB (OS_sum2 oB oC) h) => h1; symmetry in h1.
       case: cz; exact: (osum_a_ab oB oC h1).
     move: (aux _ _ oB (OS_sum2 oB oB) h) => h1; symmetry in h1.
     case: bz; exact: (osum_a_ab oB oB h1).
move: (ord_lt_1omega) => [h2 h3].
move: (ord_succ_lt oB) => h4.
have nat3: ~ inc s3 (doubleton s1 s2).
  rewrite /s1 e1 e3;case /set2_P=> h.
    move: (aux _ _ oC (OS_sum2 oB oC) h) => h1.
    move: (ord_le_ltT h2 h4) => [_ h5].
    by move: (auB _ _ o1 oC h1); rewrite /C (ord_succ_pr oB).
  move: (aux _ _ oC (OS_sum2 oB oB) h) => h1.
  case: h3; exact: (auB _ _ o1 oB h1).
rewrite /card_four (card_succ_pr nat2); apply: f_equal.
rewrite /card_three (card_succ_pr nat3); apply: f_equal.
apply: cardinal_set2.
rewrite /s1 e3 => h; move: (aux _ _ (OS_sum2 oB oC) (OS_sum2 oB oB) h) => h1.
by case: nCB; rewrite (auB _ _ oC oB h1).
Qed.

Definition nds_F n :=
 \osup (Zo Bnat (fun z => exists2 X, nds_ax X n & nds_card n X = z)).

Lemma Bnat_sup_pr T (s:= \osup T) k:
  sub T Bnat -> inc k Bnat -> (forall i, inc i T -> i <=c k) ->
  [/\ inc s Bnat, s <=c k,
    (forall i, inc i T -> i <=c s) &
    (T = emptyset \/ inc s T)].
Proof.
move=> TB kB km.
have qa: forall t, inc t Bnat -> ordinalp t.
   move => t tb; apply: OS_cardinal; fprops.
move: (qa _ kB) => ok.
have pa: ordinal_set T by move=> t tT; apply: qa; apply: TB.
have pb: s <=o k.
  apply: ord_ub_sup => // i iT; move: (km _ iT); apply: ordinal_cardinal_le.
have pc: inc s Bnat.
  move: kB => /(ord_ltP OS_omega) => ko; apply /(ord_ltP OS_omega).
  ord_tac.
have pd: s <=c k by apply: ordinal_cardinal_le3; fprops.
split => //.
  move=> i iT.
  have: i <=o s by apply:ord_sup_ub => //.
  by apply: ordinal_cardinal_le3; fprops.
case: (emptyset_dichot T) => tne; first by left.
case: (ord_sup_inVlimit pa tne); first by right.
move => li; move: (omega_limit2 li) => [_ _ li2].
case: (ordinal_irreflexive (qa _ pc) (li2 _ pc)).
Qed.

Lemma nds_j n (f := nds_F n): inc n Bnat ->
  [/\ inc f Bnat,
   f <=c factorial n,
   (exists2 X, nds_ax X n & nds_card n X = f) &
   (forall X, nds_ax X n -> nds_card n X <=c f)].
Proof.
move => nB.
set T := (Zo Bnat(fun z => exists2 X, nds_ax X n & nds_card n X = z)).
have ta: sub T Bnat by apply: Zo_S.
move: (BS_factorial nB) => tb.
have tc: (forall i, inc i T -> i <=c (factorial n)).
  rewrite /T;move=> i /Zo_P [iB [X ea <-]]; exact: (nds_a X nB).
move: (Bnat_sup_pr ta tb tc) => [pa pb pc pd].
have pe: forall X, nds_ax X n -> inc (nds_card n X) Bnat.
  move=> X ax; move: (nds_a X nB) => le1; apply: (BS_le_int le1 tb).
have pf: forall X, nds_ax X n -> nds_card n X <=c f.
  by move=> X xv; apply: pc; apply: Zo_i;fprops; exists X.
case: pd => h; last by move:h => /Zo_P [_].
set X := (fun z: Set => \0o).
have aX: nds_ax X n by rewrite /X;move => i _ /=; fprops.
by empty_tac1 (nds_card n X); apply: Zo_i; [by apply: pe | exists X].
Qed.

Lemma nds_k: (nds_F \0c = \1c /\ nds_F \1c = \1c).
Proof.
move: nds_d => h.
move: (nds_j BS0); set f := nds_F \0c;move => [_ _ p3 _].
move: p3 => [X ax <-].
move: (nds_j BS1); set g := nds_F \0c;move => [_ _ p2 _].
move: p2 => [Y ay <-].
have pa: \0c = \0c \/ \0c = \1c by left.
have pb: \1c = \0c \/ \1c = \1c by right.
by rewrite (h X _ pa ax) (h Y _ pb ay).
Qed.

Lemma nds_l: nds_F \2c = \2c.
Proof.
move: (nds_j BS2); set f := nds_F \2c.
move => [p1 p2 p3 p4].
move: nds_g => [ax xv]; move: (p4 _ ax); rewrite xv => le1.
rewrite factorial2 in p2; co_tac.
Qed.

Lemma nds_n e c1 c2 r1 r2:
  ordinalp e -> ordinalp c1 -> r1 <o omega0 ^o e ->
  \0o <o c2 -> ordinalp r2 ->
  (omega0 ^o e *o c1 +o r1) +o (omega0 ^o e *o c2 +o r2) =
  (omega0 ^o e *o (c1 +o c2) +o r2).
Proof.
set p := omega0 ^o e;move => oe oc1 pa pb or2.
have op := OS_pow OS_omega oe.
have or1:= (proj31_1 pa).
have oc2:= (proj32_1 pb).
have oa := OS_prod2 op oc1.
have ob := OS_prod2 op oc2.
have oc := OS_sum2 ob or2.
move:(ord_negl_prod or1 op pb (indecomp_prop1 (indecomp_prop4 oe) pa)) => H.
rewrite - (osumA oa or1 oc) (osumA or1 ob or2) H (osumA oa ob or2).
by rewrite - (osum_prodD oc1 oc2 op).
Qed.

Lemma nds_o e (c r: fterm) n:
  inc n Bnat -> ordinalp e ->
  (forall i, i<=c n -> \0o <o c i /\ r i <o omega0 ^o e) ->
  osum_expansion (fun i => omega0 ^o e *o (c i) +o r i) (succ n) =
  omega0 ^o e *o (osum_expansion c (succ n)) +o (r \0c).
Proof.
move => nb oe; move: (OS_pow OS_omega oe) => op.
move: n nb; apply: cardinal_c_induction.
  move => H; rewrite succ_zero.
  move: (H _ (czero_least CS0)) => [[[_ oc _] _] [[or _ _] _]].
  have ot:= (OS_sum2 (OS_prod2 op oc) or).
  by rewrite (osum_expansion1) // (osum_expansion1 oc).
move => n nB Hrec ol.
have sa: forall i, i <=c n -> \0o <o c i /\ r i <o omega0 ^o e.
  move:(card_le_succ nB) => nn i lein; apply: ol;co_tac.
move: (ol _ (card_leR (CS_succ n))) => [/proj32_1 ocn rs].
have or0:=(proj31_1 (proj2 (ol _ (czero_least (CS_succ n))))).
rewrite (osum_expansion_succ _ (BS_succ nB)) (Hrec sa).
have pc: \0o <o osum_expansion c (succ n).
  have: ord_below_n c n.
    move => i lin; exact : (proj32_1 (proj1 (sa i (proj1 lin)))).
  move /(OS_osum_expansion nB) => ha.
  have [[_ oc0 _] /nesym cnz]:= proj1 (ol _ (card_le_succ nB)).
  rewrite (osum_expansion_succ _ nB).
  by apply:(ord_ne0_pos (OS_sum2 oc0 ha)) => /(osum2_zero oc0 ha) [].
by rewrite (nds_n oe ocn rs pc or0) (osum_expansion_succ _ (BS_succ nB)).
Qed.

Lemma nds_p1 e (c r: fterm) n f (X := (fun i => omega0 ^o e *o (c i) +o r i)):
  inc n Bnat -> ordinalp e ->
  (forall i, i<=c n -> \0o <o c i /\ r i <o omega0 ^o e) ->
  (forall i, i<=c n -> c i <o omega0) ->
  inc f (perm_int (succ n)) ->
  nds_sc (succ n) X f =
  omega0 ^o e *o (osum_expansion c (succ n)) +o (r (Vf f \0c)).
Proof.
move => nB oe h1 h2 fp.
have aux: forall n Z, inc n Bnat -> (forall i, i <c n -> inc (Z i) Bnat)
  -> osum_expansion Z n = card_sumb (Bint n) Z.
  move => m z mb; move: m mb; apply: cardinal_c_induction.
    move => _; rewrite osum_expansion0 /card_sumb csum_trivial //.
    bw;exact:Bint_co00.
  move => m mB Hrec zp; rewrite (osum_expansion_succ _ mB).
  move: (Bint_pr4 mB) => [<- sb].
  have ha: forall i, i <c m -> inc (z i) Bnat.
    move => i lim; apply: zp; move: (card_lt_succ mB) => hb; co_tac.
  have zmB:= (zp _ (card_lt_succ mB)).
  have sB: inc (card_sumb (Bint m) z) Bnat.
    apply:finite_sum_finite; split.
      by hnf; bw;move => i lim; bw; apply: ha; apply /(BintP mB).
    bw; apply:finite_Bint.
  by rewrite (csumA_setU1 z sb) (Hrec ha) csumC (osum2_2int zmB sB).
move:(fp) => /Zo_P [] /fun_set_P [fz sz tz] bz.
have sa: forall i, i <=c n -> \0o <o c (Vf f i) /\ r (Vf f i) <o omega0 ^o e.
  move => i /(BintsP nB) lin; apply: h1; apply /(BintsP nB); Wtac.
transitivity
 (osum_expansion (fun i => omega0 ^o e *o (c (Vf f i)) +o r (Vf f i)) (succ n)).
  by apply:(osum_expansion_exten (BS_succ nB)) => i lin.
have h3: forall i,i <c (succ n) -> inc (c i) Bnat.
  by move => i /(card_lt_succ_leP nB) /h2 /olt_omegaP.
have h4: forall i,i <c (succ n) -> inc (c (Vf f i)) Bnat.
  move => i /(BintP (BS_succ nB)) lin; apply: h3.
  apply /(BintP (BS_succ nB)); Wtac.
rewrite (nds_o nB oe sa) (aux _ _ (BS_succ nB) h3) (aux _ _ (BS_succ nB) h4).
rewrite - {1} sz - tz (csum_Cn' c bz); reflexivity.
Qed.

Lemma the_CNF_omega_k k (X := omega0 +o k)
  (r:= fun i => CNFbvo (Vg (P (Q (the_CNF X))))
        (Vg (Q (Q (the_CNF X)))) (cpred (P (the_CNF X)))):
  inc k Bnat ->
  [/\ \0o <o X , the_CNF_degree X = \1o & r \0c = k].
Proof.
move => /olt_omegaP ko.
have ok: ordinalp k by ord_tac.
have ox: ordinalp X by apply: (OS_sum2 OS_omega ok).
have xp: \0o <o X.
  apply: ord_ne0_pos => // sz.
  by move: (osum2_zero OS_omega ok sz) => [p1 _]; move: omega_nz.
case : (ord_zero_dichot ok) => kz.
   set e := fun i: Set => \1o.
   have ax: CNFb_axo e e \1c.
    split; first split.
    + apply: ord_le_2omega.
    + move => i lin; rewrite /e; fprops.
    + move => i lin; rewrite /e; apply:ord_lt_1omega.
    + by move => i iB /card_lt1 h; case: (@succ_nz i).
    + move => i lin; rewrite /e; apply: ord_lt_01.
  move: (CNFbB_prop ax BS1); set y := (CNFbB \1c e e); move => [ax2 yv].
  have py2: P y = \1c by rewrite /y /CNFbB; aw.
  move: (CNFB_ax_simp ax2) => [_ ax4].
  move: BS0 card_lt_01 => b0 lt01.
  have eq1: X = CNFBv y.
    rewrite py2 in ax4.
    rewrite /X kz (osum0r OS_omega) /CNFBv py2 /CNFbvo.
    rewrite (CNFq_p3 (proj1 ax4) lt01) /cantor_mon.
    rewrite /y /CNFbB !(pr1_pair, pr2_pair) /e; bw; Ytac0.
    by rewrite (opowx1 OS_omega) (oprod1r OS_omega).
  move:(the_CNF_p0 ox) => [sa sb].
  rewrite - sb in eq1; rewrite py2 in ax4.
  rewrite /r /the_CNF_degree.
  rewrite (CNFB_unique sa ax2 eq1) py2 - succ_zero (cpred_pr1 CS0).
  split;[ by exact | by rewrite /y /CNFbB; aw; bw; Ytac0 |].
  by rewrite /CNFbvo (CNFq_p2).
pose e i := Yo (i = \0c) \0o \1o.
pose c i := Yo (i = \0c) k \1o.
move:card1_nz => H.
move: card_lt_12 => lt12.
move: card_lt_02 => lt02.
move: ord_lt_01 BS0 BS1 => l01 bs0 bs1.
have e0: e \0c = \0o by rewrite /e; Ytac0.
have e1: e \1c = \1o by rewrite /e; Ytac0.
have c0: c \0c = k by rewrite /c; Ytac0.
have c1: c \1c = \1o by rewrite /c; Ytac0.
have ax: CNFb_axo e c \2c.
  split; first split.
  + apply: ord_le_2omega.
  + move => i lin; rewrite /e; Ytac h; fprops.
  + by move => i lin; rewrite /c; Ytac h => //; apply: ord_lt_1omega.
  + move => i iB /card_lt2; rewrite /e; move: (@succ_nz i) => ss.
    rewrite - succ_zero; case => // si.
    by move: (succ_injective1 (CS_Bnat iB) CS0 si) => iz;Ytac0; Ytac0.
  + move => i lin; rewrite /c; Ytac h => //.
move: (CNFbB_prop ax BS2); set y := (CNFbB \2c e c); move => [ax2 yv].
have py2: P y = \2c by rewrite /y /CNFbB; aw.
move: (CNFB_ax_simp ax2) => [_ ax4].
have eq1: X = CNFBv y.
  rewrite py2 in ax4.
  move: (CNFq_p7 (proj1 ax4) lt12).
  rewrite /X /CNFBv /y /CNFbB !(pr1_pair, pr2_pair) -/CNFbvo => ->.
  rewrite /cantor_mon; bw; repeat Ytac0; rewrite e0 c0 e1 c1.
  by rewrite opowx0 (opowx1 OS_omega) (oprod1r OS_omega) (oprod1l ok).
move:(the_CNF_p0 ox) => [sa sb].
rewrite - sb in eq1; rewrite py2 in ax4.
rewrite /r /the_CNF_degree.
rewrite (CNFB_unique sa ax2 eq1) py2 - succ_one (cpred_pr1 CS1).
split;[ by exact | by rewrite /y /CNFbB; aw; bw; Ytac0 |].
rewrite /CNFbvo (CNFq_p3 (proj1 ax4) lt02).
rewrite /cantor_mon /y /CNFbB; aw; bw; Ytac0; Ytac0.
by rewrite c0 e0 opowx0 (oprod1l ok).
Qed.

Lemma nds_q1 e X n
  (r:= fun i => CNFbvo (Vg (P (Q (the_CNF (X i)))))
        (Vg (Q (Q (the_CNF (X i)))))
       (cpred (P (the_CNF (X i)))))
  (F:= fun_image (Bint (succ n)) r):
  inc n Bnat ->
  (forall i, i<=c n -> \0o <o X i) ->
  (forall i, i<=c n -> the_CNF_degree (X i) = e) ->
  nds_card (succ n) X = cardinal F.
Proof.
move => nB pa pb.
have oe: ordinalp e.
  have ha:= (czero_least (CS_Bnat nB)).
  rewrite -(pb _ ha); exact: (OS_the_CNF_degree (proj32_1 (pa _ ha))).
pose c i := Vg (Q (Q (the_CNF (X i)))) (cpred (P (the_CNF (X i)))).
have pc: forall i, i<=c n -> [/\ \0o <o c i, c i <o omega0, r i <o omega0 ^o e
      & X i = omega0 ^o e *o (c i) +o (r i)].
  move => i lein; move: (pa _ lein) (pb _ lein) => sa sb.
  by move: (the_CNF_split sa); rewrite sb.
have pd: (forall i, i<=c n -> \0o <o c i /\ r i <o omega0 ^o e).
  by move => i /pc[].
have pe: (forall i, i<=c n -> c i <o omega0) by move => i /pc[].
rewrite /nds_card /nds_sums.
set E := (permutations (Bint (succ n))).
set s1:= omega0 ^o e *o (osum_expansion c (succ n)).
have os1: ordinalp s1.
  apply: (OS_prod2 (OS_pow OS_omega oe)).
  apply: (OS_osum_expansion (BS_succ nB)) => i /(card_lt_succ_leP nB) lin.
  by move:(pc _ lin) => [ /proj32_1 h _ _ _].
set F1 := (fun_image E (nds_sc (succ n) X)).
set F2 := (fun_image E (fun f => r (Vf f \0c))).
have pf: forall f, inc f E -> nds_sc (succ n) X f = s1 +o (r (Vf f \0c)).
  move => f fp; rewrite - (nds_p1 nB oe pd pe fp).
  by apply:(nds_sc_exten (BS_succ nB) _ fp) => i /(card_lt_succ_leP nB) /pc [].
have pg: forall z, inc z E -> inc (Vf z \0c) (Bint (succ n)).
  move => z /Zo_P [] /fun_set_P [fz sz tz] bz; Wtac.
  rewrite sz; apply/(BintsP nB); fprops.
have osF: ordinal_set F2.
  by move => s /funI_P [z /pg /(BintsP nB) /pc [_ _ /proj31_1 h _] ->].
have ->: cardinal F1 = cardinal F2.
  symmetry; apply/card_eqP; exists (Lf (fun z => s1 +o z) F2 F1).
  split; aw; apply:lf_bijective.
  + by move => s /funI_P [z ze -> ]; apply /funI_P; ex_tac; rewrite (pf _ ze).
  + by move => u v /osF ou /osF ov /(osum2_simpl ou ov os1).
  + move => s /funI_P [z ze -> ]; rewrite (pf _ ze).
    exists (r (Vf z \0c)) => //;apply/funI_P; ex_tac.
apply: f_equal; set_extens t.
  move => /funI_P [z /pg ze -> ]; apply /funI_P; ex_tac.
move => /funI_P [i /(BintP (BS_succ nB)) iI ->]; apply /funI_P.
move: (permutation_exists1 (BS_succ nB) iI) => [f fe <-]; ex_tac.
Qed.

Lemma nds_q2 e X n: inc n Bnat ->
  (forall i, i<=c n -> \0o <o X i) ->
  (forall i, i<=c n -> the_CNF_degree (X i) = e) ->
  nds_card (succ n) X <=c (succ n).
Proof.
move => pa pb pc. rewrite (nds_q1 pa pb pc).
set r := fun i:Set => _.
move: (fun_image_smaller (Bint (succ n)) r).
by rewrite (card_Bint (BS_succ pa)).
Qed.

Lemma nds_q3 n: inc n Bnat -> exists X,
  [/\ nds_ax X (succ n), forall i, i<c succ n -> \0o <o X i,
  (forall i, i<=c n -> the_CNF_degree (X i) = \1o) &
  nds_card (succ n) X = (succ n)].
Proof.
move=> nB.
pose X i := (omega0 +o i).
have Ha: (forall i, i <=c n -> \0o <o X i).
  move => i lein; move:(BS_le_int lein nB) => iB.
  exact:(proj31 (the_CNF_omega_k iB)).
have Hb:(forall i, i <=c n -> the_CNF_degree (X i) = \1o).
   move => i lein; move:(BS_le_int lein nB) => iB.
   exact:(proj32 (the_CNF_omega_k iB)).
have Hc:(forall i, i<c succ n -> \0o <o X i).
   by move => i/(card_lt_succ_leP nB) /Ha.
have Hd:nds_ax X (succ n) by move => i /Hc /proj32_1.
exists X; split => //.
rewrite (nds_q1 nB Ha Hb).
set E := (Bint (succ n)).
set F := fun_image _ _.
have ->: F = fun_image E id.
   by set_extens t => /funI_P [z ze ->]; apply/funI_P; ex_tac;
   rewrite (proj33 (the_CNF_omega_k (Bint_S1 ze))).
have ->: (fun_image E id) = E.
   set_extens t; first by move => /funI_P [z ze ->].
   move => te; apply/funI_P; ex_tac.
exact: (card_Bint (BS_succ nB)).
Qed.

Definition nds_type0 X n :=
  exists2 i, i<c n & X i = \0o.

Definition nds_type' X n k :=
  (forall i, i<c n -> \0o <o X i) /\
  (exists m, [/\ ordinalp m,
     (forall i, i<c n -> m <=o the_CNF_degree (X i)) &
     cardinal (Zo (Bint n)(fun i => the_CNF_degree (X i) = m)) =k]).

Definition nds_type X n k:=
   ((k = \0c) /\ (nds_type0 X n)) \/
   (k <> \0c /\ (nds_type' X n k)).

Definition nds_FA n k:=
 \osup (Zo Bnat (fun z => exists X, [/\ nds_ax X n, nds_card n X = z
     & nds_type X n k])).

Lemma nds_type_p1 X n k1 k2: inc n Bnat ->
  (nds_type X n k1) -> (nds_type X n k2) -> k1 = k2.
Proof.
rewrite /nds_type /nds_type'; move=> nB p1 p2.
case: p1; move => [pa pb]; case: p2; move => [pc pd].
+ by rewrite pa pc.
+ by move: pb pd=> [i id vz] [pd _]; move: (proj2 (pd _ id)); case.
+ by move: pb pd => [pb _] [i id iz]; move: (proj2 (pb _ id)); case.
+ move: pb pd => [qa [m [om qb qc]]] [_ [p [op qd qe]]].
  suff mp: m = p by rewrite -qc -qe mp.
  move: qc; set T1 := Zo _ _ => qc.
  have : \1c <=c (cardinal T1) by apply: card_ge1; fprops; ue.
  move /card_le1P => [i] /Zo_P [/(BintP nB) /qd le1 mv].
  move: qe; set T2 := Zo _ _ => qe.
  have : \1c <=c (cardinal T2) by apply: card_ge1; fprops; ue.
  move /card_le1P => [j] /Zo_P [/(BintP nB) /qb le2 pv].
  rewrite pv in le2; rewrite mv in le1; ord_tac.
Qed.

Lemma nds_type_p2 X n: inc n Bnat -> n <> \0c -> nds_ax X n ->
  exists2 k, k <=c n & nds_type X n k.
Proof.
move => nB nnz ax.
case: (p_or_not_p (nds_type0 X n)) => h.
  exists \0c; fprops;left; split => //.
set E:= fun_image (Bint n) (fun i => the_CNF_degree (X i)).
set m := intersection E.
set F := (Zo (Bint n) (fun i => the_CNF_degree (X i) = m)).
have s1: sub F (Bint n) by apply Zo_S.
move: (sub_smaller s1); rewrite (card_Bint nB) => le1.
have osE: ordinal_set E.
  rewrite /E; move=> t /funI_P [z /(BintP nB) /ax zi ->].
  by apply: OS_the_CNF_degree.
have neE: nonempty E.
  apply:funI_setne; exists \0c.
  apply /(BintP nB);split; [ apply: czero_least | ]; fprops.
move: (ordinal_setI neE osE); rewrite -/m => mE.
have om: ordinalp m by apply:osE.
have neF: nonempty F.
  by move: mE => /funI_P [z zn zv]; exists z; apply: Zo_i.
set k := cardinal F.
exists k => //; right; split => //.
  by apply: (cardinal_nonemptyset1 neF).
split.
  move => i lin; case: (ord_zero_dichot (ax _ lin)) => //.
  by move => baa;case: h; exists i.
exists m; split => // i /(BintP nB) lin.
have uE: inc (the_CNF_degree (X i)) E by apply /funI_P; ex_tac.
by split; [ exact | apply: osE | apply:setI_s1].
Qed.

Lemma nds_FA_ex n k:
   inc n Bnat -> n <> \0c -> k <=c n -> nds_FA n k <> \0c.
Proof.
move => nB nz klen.
rewrite /nds_FA.
have [X pa pb]: exists2 X, nds_ax X n & nds_type X n k.
  case (equal_or_not k \0c) => kz.
    rewrite kz; exists (fun z:Set => \0o).
      move => i _ /=; fprops.
    left; split => //; exists \0c => //; apply: card_ne0_pos; fprops.
  pose X i := Yo (i <c k) \1o omega0.
  have ha: nds_ax X n by move => t _; rewrite /X; Ytac h; fprops.
  have hb:forall i, i <c n -> \0o <o X i.
    move => i _; rewrite /X; Ytac h; [apply: ord_lt_01| apply: ord_lt_0omega].
  exists X => //; right; split => //; split => //.
  move: the_CNF_degree_one the_CNF_degree_omega => dg1 dgo.
  exists \0o; split; fprops.
  + move => i /ha/OS_the_CNF_degree h; ord_tac1.
  + set E := Zo _ _.
    move:(BS_le_int klen nB) => kB.
    have ->: E = (Bint k).
      set_extens t.
        move => /Zo_P [ /(BintP nB) lth]; rewrite /X; Ytac h1.
          by move => _; apply/(BintP kB).
        by rewrite dgo => ba; case: card1_nz.
      move => /(BintP kB) ltl;apply: Zo_i.
        apply /(BintP nB); co_tac.
      by rewrite /X; Ytac0; rewrite dg1.
   by rewrite (card_Bint kB).
set E := Zo Bnat _.
have ce: cardinal_set E by move => i /Zo_S /CS_Bnat.
move: (nds_c X nB) => [pc pd].
have zE: inc (nds_card n X) E.
   apply/Zo_i => //; exists X => //.
by move: (card_sup_ub ce zE) => /(card_leT pc) /card_ge1P[_ /nesym].
Qed.

Lemma nds_type_p3 n k (v := nds_FA n k):
  inc n Bnat -> n <> \0c -> k <=c n ->
  [/\ inc v Bnat,
   v <=c (nds_F n),
   (forall X, nds_ax X n -> nds_type X n k -> nds_card n X <=c v) &
   (exists X, [/\ nds_ax X n, nds_type X n k & nds_card n X = v])].
Proof.
move=> nB nz kn.
rewrite /v /nds_FA; set T:= Zo Bnat _.
have ta: sub T Bnat by apply: Zo_S.
have tb: inc (nds_F n) Bnat by move: (nds_j nB) => [ok _].
have tc: (forall i, inc i T -> i <=c (nds_F n)).
  move => i /Zo_P [_ [X [ax <- _]]].
  by move: (nds_j nB) => [_ _ _ p4]; apply: p4.
move: (Bnat_sup_pr ta tb tc) => [pa pb pc pd].
have pe: forall X, nds_ax X n -> inc (nds_card n X) Bnat.
  move: (BS_factorial nB) => tb1.
  move=> X ax; move: (nds_a X nB) => le1; apply: (BS_le_int le1 tb1).
split => //.
  by move=> X ax ax2; apply: pc; apply: Zo_i; [by apply: pe | exists X ].
case: pd; last by move /Zo_P=> [_ [X [p1 p2 p3]]];exists X; split.
move => te.
by move: (nds_FA_ex nB nz kn); rewrite /nds_FA -/T te setU_0; case.
Qed.

Lemma nds_type_p4 n (g := nds_FA n) (f:= nds_F n):
 inc n Bnat -> n <> \0c ->
 [/\ (forall k, k <=c n -> (g k) <=c f),
     (exists2 k, k <=c n & (g k) = f) &
     f= \osup (fun_image (Bintc n) g) ].
Proof.
move=> nB nz.
have pa: (forall k : Set, k <=c n -> g k <=c f).
  by move => k kn; move: (nds_type_p3 nB nz kn) => [_ pa _].
move: (nds_j nB); rewrite -/f; move=> [_ _ [X x1 x2] pd].
move: (nds_type_p2 nB nz x1) => [k kn kt].
move: (nds_type_p3 nB nz kn) => [_ _ pe pf].
have pb: (exists2 k, k <=c n & g k = f).
  move: (pe _ x1 kt); rewrite x2 => qa.
  move: pf=> [Y [ax x3 x4]]; exists k => //.
   apply card_leA.
      rewrite /g - x4; apply: pd => //.
  by apply: (card_leT qa); apply card_leR; move: qa => [_ ok _].
split => //.
have oT: ordinal_set (fun_image (Bintc n) g).
  move=> t /funI_P [z zc ->].
  by move: zc => /(BintcP nB) => kn1; move: (pa _ kn1) => [[ok _] _].
apply: ord_leA.
  move: pb=> [s sn sv].
  apply: ord_sup_ub => //; apply /funI_P; exists s => //.
  by apply /(BintcP nB).
apply: ord_ub_sup => //.
   by move: (pa _ kn) => [_ [ok _] _].
move=> t /funI_P [z zc ->]; move: zc => /(BintcP nB) => zc.
exact: (ordinal_cardinal_le (pa _ zc)).
Qed.

Lemma nds_type_p5 n X:
  inc n Bnat -> nds_ax X n -> nds_type0 X n ->
  exists Y,
    [/\ nds_ax Y n, nds_card n X = nds_card n Y & Y (cpred n) = \0o].
Proof.
move => nB ax [i lin vz].
set E := (Bint n).
move /(BintP nB):(lin) => ii.
move: (card_le_ltT (czero_least (proj31_1 lin)) lin) => np.
case: (equal_or_not i (cpred n)) => ip.
  exists X; split; [exact | exact |ue].
pose g j := Yo (j = i) (cpred n) (Yo (j = (cpred n)) i j).
have pa: g (cpred n) = i by rewrite /g; Ytac0; Ytac0.
have nz:= (nesym (proj2 np)).
move: (cpred_pr nB nz) => [pb pc].
have axx: cpred n <c n by rewrite {2} pc; apply: card_lt_succ.
have ta: lf_axiom g E E.
  move=> t /(BintP nB) => h; apply /(BintP nB).
  by rewrite /g; Ytac h1 => //; Ytac h2.
set G:= Lf g E E.
have qc: inc (cpred n) E by apply /(BintP nB).
have bg: bijection G.
  apply: lf_bijective => //.
   move=> u v ue ve; rewrite /g; Ytac h1; Ytac h2.
   + by rewrite h1 h2.
   + Ytac h3; [ by rewrite h3 h1 | by move=> eq; case: h3 ].
   + by rewrite h2; Ytac h3; [ move => <-| Ytac h4; [| move=> h; case: h3]].
   + by Ytac h3; [ move=> h4; case: h2 | Ytac h4;[ move => h5; case: h1 |]].
  move=> y yE; rewrite /g.
  case: (equal_or_not y (cpred n)) => qa.
    by exists i=> //; Ytac0; Ytac0.
  case: (equal_or_not y i) => qb.
    exists (cpred n) => //;Ytac0; Ytac0 => //.
  by exists y => //; Ytac0; Ytac0.
have qx: function (Lf g E E) by apply: lf_function.
have GE: inc G (permutations E).
   apply: Zo_i => //; apply /fun_set_P;split => //; rewrite /G; aw.
have ax2:= proj1(nds_b nB ax GE).
exists (fun z => X (Vf G z)).
by rewrite - (nds_m nB ax GE) {2}/G /g; aw; Ytac0; Ytac0; split.
Qed.

Lemma nds_type_p6 n X: inc n Bnat -> nds_ax X (succ n) -> X n = \0o ->
  nds_card (succ n) X = nds_card n X.
Proof.
move => nB ax nz.
have snB := BS_succ nB.
set I := Bint n.
set I' := Bint (succ n).
have IP: forall i, inc i I <-> i <c n by move => i; exact: (BintP nB).
have IP': forall i, inc i I' <-> i <c (succ n)
      by move => i; exact: (BintP snB).
have H0:=(card_lt_succ_leP nB).
have nn:= card_lt_succ nB.
have nI': inc n I' by apply /IP'.
have Ha: forall i, i <=c n -> i <> n -> inc i I.
  move => i lein nin; apply /IP; split => //.
rewrite /nds_card; apply:f_equal; set_extens z; last first.
  move => /funI_P [f /Zo_P [ /fun_set_P [ff sf tf] bf] ->].
  have Hb: forall i, i <=c n -> i <> n -> Vf f i <c n.
    move => i lein nin; move: (Ha _ lein nin); rewrite /I- sf => isf.
    by move:(Vf_target ff isf); rewrite tf => /IP.
  pose g z := Yo (z = n) n (Vf f z).
  have ta: lf_axiom g I' I'.
    move => i /IP' /H0 isn;apply /IP'; rewrite /g; Ytac h; fprops.
    exact: (card_lt_ltT (Hb _ isn h) nn).
  have bg: bijection (Lf g I' I').
    apply: lf_bijective => //.
      move => u v /IP' /H0 lun /IP' /H0 lvn.
      rewrite /g; Ytac h1; Ytac h2.
      + by rewrite h1 h2.
      + by move: (nesym (proj2 (Hb _ lvn h2))).
      + by move: (proj2 (Hb _ lun h1)).
      + by apply: (proj2 (proj1 bf)); rewrite sf; apply: Ha.
    move => y yI; case (equal_or_not y n) => eyn.
      by exists y => //; rewrite eyn /g; Ytac0.
    move:yI => /IP' /H0 lyn.
    move: (Ha _ lyn eyn); rewrite /I - tf => /(proj2 (proj2 bf)).
    rewrite sf - /I; move => [x /IP xsf <-].
    move: (card_lt_ltT xsf nn) => /IP'; rewrite -/I' => xi'.
    by move: (proj2 xsf) => lxn; ex_tac;rewrite /g; Ytac0.
  apply/funI_P; exists (Lf g I' I').
     apply/Zo_i => //;apply/fun_set_P; split; [ fct_tac | aw | aw].
  rewrite /nds_sc (osum_expansion_succ _ nB) {1} /g; aw; Ytac0; rewrite nz.
  set A := osum_expansion _ _; set B := osum_expansion _ _.
  have <-: A = B.
     apply: (osum_expansion_exten nB) => i lin; rewrite /g.
     have ii: inc i I' by apply /IP'; co_tac.
     by aw; move: (proj2 lin) => nin; Ytac0.
  have oA: ordinalp A.
     apply: (OS_osum_expansion nB) => i lin; apply: ax.
     move: (Hb _ (proj1 lin) (proj2 lin)) => h2; co_tac.
  by rewrite (osum0l oA).
move => /funI_P [f /Zo_P [ /fun_set_P [ff sf tf] bf] ->].
have ntf: inc n (target f) by rewrite tf; apply /(BintP snB).
set i0:= Vf (inverse_fun f) n.
have fif: function (inverse_fun f) by apply: bijective_inv_f.
have i0sf: inc i0 (source f) by rewrite -ifun_t /i0; Wtac; rewrite ifun_s.
have fi0: Vf f i0 = n by rewrite /i0; rewrite (inverse_V bf ntf).
move: (proj2 (proj1 bf)) => iif.
case (equal_or_not i0 n) => ei0n.
  set f0:= Lf (Vf f) I I.
  have axf: lf_axiom (Vf f) I I.
    move => i /IP lin; apply/IP.
    have isf: inc i (source f) by rewrite sf; apply/IP'; co_tac.
    move: (Vf_target ff isf); rewrite tf => /IP' /H0 le1.
    case (equal_or_not (Vf f i) n) => eq1; last by split.
    rewrite - eq1 in fi0.
    move: (iif _ _ i0sf isf fi0) => h1.
    by case (proj2 lin); rewrite - h1 ei0n.
  have fp: inc f0 (permutations (Bint n)).
    apply: Zo_i.
      by rewrite /f0;apply/fun_set_P; split; aw;apply:lf_function.
    apply:lf_bijective => //.
      move => u v /IP ui /IP vp; apply:(iif u v);rewrite sf; apply /IP';co_tac.
    move => y /IP yp.
    have ytf: inc y (target f) by rewrite tf; apply /IP'; co_tac.
    move:(proj2 (proj2 bf) _ ytf) => [x xsf eq1]; exists x => //.
    move: xsf;rewrite sf => /IP' /H0 xn.
    by apply /IP; split => //exn; move:(proj2 yp); rewrite -eq1 - fi0 exn ei0n.
  apply/funI_P; exists f0; first exact.
  rewrite /nds_sc (osum_expansion_succ _ nB) - {1} ei0n fi0 nz.
  set A := osum_expansion _ _.
  have oA: ordinalp A.
     apply: (OS_osum_expansion nB) => i lin; apply: ax.
     apply/IP'; rewrite /I' - tf; Wtac; rewrite sf;apply/IP'; co_tac.
   rewrite (osum0l oA); apply: (osum_expansion_exten nB).
   move => i /IP lin /=; rewrite /f0; aw.
have li0n: i0 <=c n.
  apply /H0; apply/IP'; rewrite /i0 /I'- sf - ifun_t.
  by apply:Vf_target => //;rewrite ifun_s.
move/(card_le_succ_succP (proj31 li0n) (proj32 li0n)): (li0n) => li0n1.
move: (cdiff_pr li0n1)(BS_diff (succ i0) snB).
set m := (succ n -c succ i0) => sa mB.
have iB:=(BS_le_int li0n nB).
have siB:=(BS_le_int li0n1 snB).
have sb : i0 +c m = n.
  apply: (succ_injective1 (CS_sum2 i0 m) (CS_Bnat nB)).
  by rewrite - (csum_via_succ1 _ iB) sa.
pose g i := Yo (i <c i0) (Vf f i) (Vf f (succ i)).
pose g0 i := X (Vf (Lf g I I) i).
pose f0 i := X (Vf f i).
have axg: lf_axiom g I I.
  move => i /IP lin; rewrite /g; Ytac h; apply /IP => //.
    have isf: inc i (source f) by rewrite sf; apply /IP'; co_tac.
    move: (Vf_target ff isf); rewrite tf => /IP' /H0 ha; split; first exact.
    rewrite - fi0 => h1; move: (iif _ _ isf i0sf h1) => h2.
    by case: (proj2 h).
  have isf: inc (succ i) (source f).
    by rewrite sf; apply /IP'; apply /(card_succ_succ_ltP(BS_lt_int lin nB) nB).
  move: (Vf_target ff isf); rewrite tf => /IP' /H0 ha; split; first exact.
  rewrite - fi0 => h1; move: (iif _ _ isf i0sf h1) => h2.
  by case: h; rewrite - h2; apply:(card_lt_succ (BS_lt_int lin nB)).
have ax1: ord_below_n f0 (succ i0 +c m).
  rewrite sa => i lin; rewrite /f0; apply: ax; apply/(BintP snB).
  by Wtac; rewrite sf; apply/(BintP snB).
have ax2: (ord_below_n g0 (i0 +c m)).
   rewrite sb => i /IP lin; rewrite /g0; aw; apply ax.
   move: (axg _ lin) => /IP h1 ; co_tac.
have osa: ordinalp (osum_expansion f0 i0).
  apply: (OS_osum_expansion iB) => i lin; rewrite /f0; apply: ax.
  apply/(BintP snB); Wtac; rewrite sf;apply/(BintP snB).
  exact: (card_lt_ltT lin (card_le_ltT li0n nn)).
have -> : nds_sc (succ n) X f = nds_sc n X (Lf g I I).
  move: (osum_expansionA siB mB ax1); rewrite sa -/(nds_sc _ _ _) => ->.
  rewrite (osum_expansion_succ _ iB) {2} /f0 fi0 nz (osum0l osa).
  rewrite /nds_sc - sb (osum_expansionA iB mB ax2); apply: f_equal2.
     apply:(osum_expansion_exten mB) => i lim; rewrite /f0/g0 /g.
     have ha: inc (i +c i0) I.
       apply /IP; rewrite - sb (csumC _ m); apply:(csum_Mlteq iB mB lim).
     have hb: ~(i +c i0 <c i0).
       move:(csum_M0le i (proj31 li0n)); rewrite csumC => ua ub; co_tac.
     by aw; Ytac0; rewrite (csum_via_succ _ iB).
   apply:(osum_expansion_exten iB) => i lim; rewrite /f0/g0 /g.
   aw; [ by Ytac0 |apply /IP; co_tac].
apply /funI_P; exists (Lf g I I) => //; apply: Zo_i.
  by apply/fun_set_P; split; aw; apply:lf_function.
apply: lf_bijective => //.
  move => u v /IP ui /IP vi.
  have usf: inc u (source f) by rewrite sf;apply/IP'; co_tac.
  have vsf: inc v (source f) by rewrite sf;apply/IP'; co_tac.
  move:(BS_lt_int ui nB) (BS_lt_int vi nB) => uB vB.
  have u'sf: inc (succ u) (source f).
    by rewrite sf;apply/IP';apply/(card_succ_succ_ltP uB nB).
  have v'sf: inc (succ v) (source f).
    by rewrite sf;apply/IP';apply/(card_succ_succ_ltP vB nB).
  rewrite /g; Ytac h1; Ytac h2 => eq.
  + by apply: (proj2 (proj1 bf) _ _ usf vsf).
  + move: (proj2 (proj1 bf) _ _ usf v'sf eq) => e2.
    move: h1; rewrite e2 => e3; case h2; move: (card_le_succ vB) => e4; co_tac.
  + move: (proj2 (proj1 bf) _ _ u'sf vsf eq) => e2.
    move: h2;rewrite - e2 => e3; case h1; move: (card_le_succ uB) => e4; co_tac.
  + move: (proj2 (proj1 bf) _ _ u'sf v'sf eq).
    by move => /(succ_injective1 (proj31_1 ui) (proj31_1 vi)).
move => y /IP yi.
have ytf: inc y (target f) by rewrite tf; apply/IP'; co_tac.
move: (proj2 (proj2 bf) _ ytf) => [x xsf ea]; rewrite - ea.
move: xsf; rewrite sf => /IP' xsn.
have xB:= (BS_lt_int xsn snB).
case: (Bnat_to_ell iB xB) => cix.
+ by move:(f_equal (Vf f) cix); rewrite fi0 ea; move => eb; case: (proj2 yi).
+ case (equal_or_not x \0c) => xnz.
    rewrite xnz in cix;case:(card_lt0 cix).
  move: (cpred_pr xB xnz) => [sc sd].
  move: xsn; rewrite sd; move/(card_succ_succ_ltP sc nB) => /IP ci.
  exists (cpred x) => //; rewrite - sd /g; Ytac h; last by rewrite - sd.
 move/(card_le_succ_lt0P (CS_Bnat sc) iB):h; rewrite - sd => ha; co_tac.
exists x; [ apply /IP; co_tac | by rewrite /g; Ytac0].
Qed.

Lemma nds_type_p7 n: inc n Bnat -> nds_FA (succ n) \0c = nds_F n.
Proof.
move => nB.
move: (nds_type_p3 (BS_succ nB) (@succ_nz n) (czero_least (CS_succ n))).
move => [pa pb pc pd].
move:pd => [X0 [aX0 Xt0 Xv]].
move: Xt0; case; [move => [_ pe] | by case].
move: (nds_type_p5 (BS_succ nB) aX0 pe) => [X2 [ax2 X2v X20]].
have pg': X2 n = \0o by move:X20; rewrite (cpred_pr2 nB).
move: Xv; rewrite X2v => eq0.
clear pe aX0 X20 X2v.
have r1:= (nds_type_p6 nB ax2 pg').
move: (nds_j nB) => [sa sb [X4 ax4 eq1] sd].
set X5 := fun z => Yo (z = n) \0o (X4 z).
have ax5: nds_ax X5 (succ n).
  move => i /(card_lt_succ_leP nB) lin; rewrite /X5; Ytac h; fprops; apply: ax4.
  split => //.
have X5n: X5 n = \0c by rewrite /X5; Ytac0.
have ax3: nds_ax X2 n.
   move => i lin; apply: (ax2 i (card_lt_ltT lin (card_lt_succ nB))).
have nd5: nds_type X5 (succ n) \0c.
  by rewrite /X5;left; split => //; exists n; fprops; Ytac0.
have r2:= (nds_type_p6 nB ax5 X5n).
have r3: nds_card n X5 = nds_card n X4.
  rewrite /nds_card/nds_sums; apply: f_equal.
   have H: forall z i, inc z (permutations (Bint n)) -> i <c n
     -> (Vf z i <> n).
     move => z i /Zo_P [] /fun_set_P [fz sz tz] bz /(BintP nB).
     rewrite - sz => isz; move: (Vf_target fz isz); rewrite tz.
     by move/(BintP nB) => [_].
  by set_extens t; move /funI_P => [z zp ->]; apply/funI_P; ex_tac;
    apply:(osum_expansion_exten nB) => i lin; move: (H _ _ zp lin) => w;
    rewrite /X5; Ytac0.
apply: card_leA; first by move: (sd _ ax3); rewrite - eq0 r1.
by move: (pc _ ax5 nd5); rewrite r2 r3 eq1.
Qed.

Lemma nds_type_p8 n: inc n Bnat -> nds_FA (succ n) (succ n) = (succ n).
Proof.
move => nB.
move: (nds_type_p3 (BS_succ nB) (@succ_nz n) (card_leR (CS_succ n))).
set v := (nds_FA (succ n)).
move => [vB vle va vb].
move: (nds_q3 nB) => [X[pa pb pc pd]].
have pe: nds_type X (succ n) (succ n).
  right; split; first by apply: succ_nz.
  split => //; exists \1o; split.
   + apply: OS1.
   + move => i/(card_lt_succ_leP nB) /pc ->; fprops.
   + set E := Zo _ _.
     have ->: E = Bint (succ n).
       apply: extensionality;[ apply: Zo_S | move => t ti; apply: Zo_i => //].
       by apply:pc; apply /(BintsP nB).
     by rewrite (card_Bint (BS_succ nB)).
move: (va _ pa pe); rewrite pd => le1.
move: vb => [Y [ay ty yv]].
case ty; [ by move :(@succ_nz n) => sp [h _] | move => [_ [ty1 ty2]]].
move:ty2 => [m [om mp1 mp2]].
have pg:forall i, i<=c n -> the_CNF_degree (Y i) = m.
  move: mp2; set I := (Bint (succ n)).
  have ci: cardinal I = succ n by rewrite (card_Bint (BS_succ nB)).
  have fsI: finite_set I. rewrite /finite_set ci; apply:(Bnat_hi (BS_succ nB)).
  set E := Zo _ _ => ce.
  have seI: sub E I by apply: Zo_S.
  move: (cardinal_setC4 seI fsI);rewrite ci ce cdiff_n_n.
  move /cardinal_nonemptyset => H.
  move => i /(BintsP nB) iI; ex_middle bad.
  by empty_tac1 i; apply /setC_P; split => // /Zo_hi.
have pf: forall i, i<=c n -> \0o <o (Y i).
  by move => i /(card_lt_succ_leP nB) /ty1.
by move: (nds_q2 nB pf pg); rewrite yv => le2; apply: card_leA.
Qed.

Lemma nds_type_p9_aux a b i j:
  ordinalp a -> ordinalp b -> i <o omega0 -> j <o omega0 ->
  exists2 k, k <o omega0 &
      (omega0 *o a +o i) +o (omega0 *o b +o j) = (omega0 *o (a +o b) +o k).
Proof.
move: OS_omega => oo oa ob ip jp.
move: (proj31_1 ip)(proj31_1 jp) => oi oj.
have oA :=OS_sum2 (OS_prod2 oo oa) oi.
have ooa:= OS_prod2 oo oa.
have oob:= OS_prod2 oo ob.
rewrite (osumA oA oob oj) - (osumA ooa oi oob).
case: (ord_zero_dichot ob) => bp.
   exists (i +o j); first by apply:osum2_lt_omega.
   by rewrite bp oprod0r (osum0r oa) (osum0r oi) osumA.
exists j => //.
move: (odiff_pr (oprod_Mle1 oo bp)) => [pb pc]; rewrite pc.
by rewrite (osumA oi oo pb) (osum_int_omega ip) - pc (osum_prodD oa ob oo).
Qed.

Lemma nds_type_p9 n (X:fterm) (Y:= fun i => succ_o (omega0 *o (X i))):
  inc n Bnat -> nds_ax X n -> nds_card n X <=c nds_card n Y.
Proof.
move => nB aX.
have pa: forall z, inc z (perm_int n) ->
    exists k, (ord_div_pr0 (nds_sc n Y z) omega0 (nds_sc n X z) k).
  move => s /perm_intP [[[fs _] _] sf tf]; rewrite /Y /nds_sc.
  have: forall z, z<c n -> ordinalp (X (Vf s z)).
     move => z /(BintP nB) zb; apply: aX; apply/(BintP nB); Wtac.
  move: (n) nB; apply: cardinal_c_induction.
     have o0 := OS0.
     move => _; exists \0o;hnf;rewrite !osum_expansion0 oprod0r (osum0r OS0).
     split => //; by exact ord_lt_0omega.
  move => m mB Hrec h1.
  have mm:= card_lt_succ mB.
  have /Hrec [k [oa kb kv kp]]: (forall z, z <c m -> ordinalp (X (Vf s z))).
    move => z zm; apply:h1 => //; co_tac.
  rewrite ! (osum_expansion_succ _ mB) kv.
  set a := osum_expansion _ _.
  have ob := h1 _ mm.
  rewrite - (ord_succ_pr (OS_prod2 OS_omega ob)).
  move:(nds_type_p9_aux ob oa ord_lt_1omega kp) => [k2 k2p ->].
  exists k2; split; [ by apply: OS_sum2 | ord_tac | exact | exact ].
have pb: forall z, inc z (perm_int n) ->
     nds_sc n X z = P (oquorem (nds_sc n Y z) omega0).
  move => z zp; move:(pa _ zp) => [k kp].
  have o1:ordinalp(nds_sc n Y z) by move: (kp) => [ra rb -> _]; fprops.
  exact (proj1 (oquoremP2 o1 ord_lt_0omega kp)).
rewrite /nds_card /nds_sums.
set F := fun_image _ _; set E := fun_image _ _.
pose f x := P (oquorem x omega0).
have ax: forall x, inc x E -> inc (f x) F.
  by move => x /funI_P [z zp ->]; apply/funI_P; ex_tac; rewrite /f - pb.
have sjf: surjection(Lf f E F).
  apply: lf_surjective => //.
  move => y /funI_P [z zp ->]; rewrite (pb _ zp).
  exists (nds_sc n Y z) => //; apply/funI_P; ex_tac.
move: (image_smaller_cardinal (proj1 sjf)).
rewrite surjective_pr0; aw.
Qed.

Lemma nds_type_p10 n: inc n Bnat ->
  exists X, [/\ nds_ax X n, forall i, i <c n -> \0o <o X i &
      nds_card n X = nds_F n].
Proof.
move => nB; move:(nds_j nB) => [ _ _ [X ax xv] pb].
move: (nds_type_p9 nB ax).
set Y := (fun i => succ_o (omega0 *o X i)) => r1.
have ha: forall i, i <c n -> \0o <o Y i.
  move => i /ax ox; apply:ord_lt0_succ;apply: (OS_prod2 OS_omega ox).
have hb: nds_ax Y n by move => t /ha h;ord_tac.
move: (pb _ hb) => hc; rewrite xv in r1.
by exists Y; split => //; apply: card_leA.
Qed.

Lemma nds_type_p11 n (g := nds_FA n) (f:= nds_F n):
 inc n Bnat -> n <> \0c ->
   (forall k, k <=c n -> k <> \0c -> (g k) <=c f) /\
   (exists k, [/\ k <=c n, k <> \0c & (g k) = f]).
Proof.
move => pa pb; move:(nds_type_p4 pa pb) => [pc _ _].
split; first by move => k kn _; apply: pc.
move: (nds_type_p10 pa) => [X [ax1 ax2 xv]].
move: (nds_type_p2 pa pb ax1) => [k1 k1n tX].
move:(nds_type_p3 pa pb k1n) => [_ _ qa _].
move: (qa _ ax1 tX); rewrite xv => le1.
case: tX; first by move => [_ [i lin xi]]; case: (proj2 (ax2 _ lin)).
move => [knz _]; exists k1; split => //.
exact: (card_leA (pc _ k1n) le1).
Qed.

Definition nds_tn_S X n:=
   unionf (powerset (Bint n)) (fun K =>
      fun_image (perm_int (cardinal K))
         (fun s => nds_sc (cardinal K) (fun z => X (nth_elt K z)) s)).
Definition nds_tn_C X n := cardinal (nds_tn_S X n).
Definition ndstnC n := succ (n *c (\2c ^c (cpred n))).

Definition nds_tn_ax X n :=
    (forall i, i<c n -> \0o <o X i) /\
    exists2 e, ordinalp e & forall i, i<c n -> the_CNF_degree (X i) = e.

Definition nds_tn_sup n :=
  \osup(Zo Bnat (fun z => exists2 X, nds_tn_ax X n & nds_tn_C X n = z)).

Lemma nds_tn1 X n:
   inc n Bnat -> nds_ax X n ->
   nds_tn_C X n <=c (\2c ^c n) *c (factorial n).
Proof.
move => nB ax.
rewrite /nds_tn_C /nds_tn_S. set F:= (fun K : Set => _).
set pIn := (powerset (Bint n)).
set g1:= (Lg pIn (fun a : Set => cardinal (Vg (Lg pIn F) a))).
move: (csum_pr1_bis pIn F).
have <-: card_sum g1 = card_sumb pIn (fun a : Set => cardinal (F a)).
  rewrite /card_sumb;apply:f_equal;apply:Lg_exten => t tx; bw.
set g2 := cst_graph pIn (factorial n).
have sd: domain g1 = domain g2 by rewrite /g1/g2; bw.
have le1:forall x, inc x (domain g1) -> Vg g1 x <=c Vg g2 x.
   rewrite /g1 /g2; bw => K KB; bw; move/setP_P:KB => KB.
  move:(sub_smaller KB); rewrite (card_Bint nB) => ka.
  have nKB:=(BS_le_int ka nB).
  move: (factorial_monotone nB ka); apply: card_leT.
  move:(number_of_permutations (finite_Bint (cardinal K))).
  rewrite -/(perm_int _) (card_Bint nKB) => <-.
  apply:fun_image_smaller.
move:(csum_increasing sd le1).
rewrite csum_of_same cprodC - cprod2_pr2a card_setP - cpow_prb (card_Bint nB).
move => ha hb; exact:(card_leT hb ha).
Qed.

Lemma nds_tn2 n (f:= nds_tn_sup n): inc n Bnat ->
  [/\ inc f Bnat, \0c <c f, f <=c (\2c ^c n) *c (factorial n),
  (exists2 X, nds_tn_ax X n & nds_tn_C X n = f) &
  (forall X, nds_tn_ax X n -> nds_tn_C X n <=c f)].
Proof.
move => nB.
rewrite /f /nds_tn_sup; set T := Zo _ _.
have TB: sub T Bnat by apply: Zo_S.
have kB:=(BS_prod (BS_pow BS2 nB) (BS_factorial nB)).
set k := \2c ^c n *c factorial n.
have H: forall X, nds_tn_ax X n -> nds_tn_C X n <=c k.
  by move => X [ax _]; apply:(nds_tn1 nB) => i /ax /proj32_1.
have H1:forall X, nds_tn_ax X n -> inc (nds_tn_C X n) Bnat.
  move => X x1; exact:(BS_le_int (H _ x1) kB).
have ks:forall i, inc i T -> i <=c k by move => z /Zo_hi [X /H ax <-].
pose X (i:Set):= omega0.
have ax: nds_tn_ax X n.
  split; first by move => i _; apply: ord_lt_0omega.
  exists \1o; [ apply: OS1 | move => i _; apply:the_CNF_degree_omega].
have ta: inc (nds_tn_C X n) T by apply: (Zo_i (H1 _ ax)); exists X.
have ha: \0c <c union T.
  have: nonempty (nds_tn_S X n).
    set K:= Bint n; have idp:=(perm_int_id n).
    exists (nds_sc (cardinal K) (fun z => X (nth_elt K z)) (identity (Bint n))).
    apply/setUf_P; exists K; first by apply:setP_Ti.
    rewrite /K (card_Bint nB);apply/funI_P;ex_tac.
  move /cardinal_nonemptyset1; rewrite -/(nds_tn_C X n) => h0.
  have cst:cardinal_set T by move => t /TB /CS_Bnat.
  exact:(card_lt_leT (card_ne0_pos (cst _ ta) h0) (card_sup_ub cst ta)).
move: (Bnat_sup_pr TB kB ks) => [pa pb pc pd];split => //; last first.
  move => Y x1; apply: pc; apply/ Zo_P; split; [by apply: H1 | by exists Y].
by case:pd => h1; [ empty_tac1 (nds_tn_C X n) | exact: (Zo_hi h1)].
Qed.

Lemma nds_tn3: nds_tn_sup \0c = \1c.
Proof.
move:(nds_tn2 BS0); rewrite factorial0 cpowx0 (cprod1r CS1).
set f := nds_tn_sup \0c.
move =>[pa /card_ge1P pb px _ _]; co_tac.
Qed.

Lemma nth_set11 K a (f:= nth_elt K)(g:= nth_elt (K +s1 a)) (q:= cardinal K) :
  sub K Bnat -> finite_set K -> inc a Bnat ->
  (forall i, inc i K -> i <c a) ->
  (forall i, i<c q -> f i = g i) /\ g q = a.
Proof.
move => KB fsK aB Ha.
have anK: ~ inc a K by move => /Ha [].
move:(card_succ_pr anK); set q1:= cardinal (K +s1 a);rewrite -/q => qv.
have K1B: sub (K +s1 a) Bnat by move => t /setU1_P; case; [apply: KB | move ->].
have qB: inc q Bnat by apply /BnatP.
have q1B: inc q1 Bnat by rewrite qv; fprops.
move:(nth_set6 qB KB) (nth_set6 q1B K1B); rewrite -/q -/q1 qv => sa sb.
suff aux: forall i, i<=c q -> nth_elts K i = nth_elts (K +s1 a) i.
  rewrite /f/g /nth_elt.
  split.
    move => i liq.
    move/(card_le_succ_ltP _ (BS_lt_int liq qB)): (liq) => /aux ->.
    by rewrite (aux _ (proj1 liq)).
  have hb: ((K +s1 a) -s K) = singleton a.
    apply:set1_pr; first by apply/setC_P; split; fprops.
    by move => z /setC_P [/setU1_P ha hb]; case: ha.
  by rewrite - (aux _ (card_leR (CS_Bnat qB))) sb sa hb setU_1.
move => i ilq; move:(BS_le_int ilq qB) => iB.
move: i iB ilq; apply: cardinal_c_induction.
   by rewrite /nth_elts !induction_term0.
move => n nB Hrec sc.
rewrite (nth_elts_succ _ nB) (nth_elts_succ _ nB).
have lenk:=(card_leT (card_le_succ nB) sc).
rewrite - (Hrec lenk).
move:(nth_set5 nB KB lenk) => [[]].
rewrite /nth_more; set S1 := (nth_elts K n) => ha hb hc.
have s1: sub (K -s S1) Bnat by move => t /setC_P [/KB].
have s2: sub ((K +s1 a) -s S1) Bnat by move => t /setC_P [/K1B].
case:(emptyset_dichot (K -s S1)) => ne1.
  move:(cardinal_setC4 ha fsK); rewrite - /q hc ne1 cardinal_set0.
  by move: (nesym (cdiff_nz (card_lt_leT (card_lt_succ nB) sc))).
have ne2: nonempty ((K +s1 a) -s S1).
   by exists a; apply/setC_P; split; [ fprops | move/ha].
move:(nth_set1 s1 ne1); set y1:= intersection _; move => [/setC_P[hu hv] pb].
move:(nth_set1 s2 ne2); set y2:= intersection _; move => [pa' pb'].
apply: f_equal; apply:f_equal.
have /pb' y21: inc y1 ((K +s1 a) -s S1) by apply/setC_P; split; fprops.
move/setC_P:pa' => [/setU1_P hu1 hv1]; case: hu1=> hu1.
  move/(setC_P): (conj hu1 hv1) => /pb le1; co_tac.
move:(Ha _ hu); rewrite - hu1 => hu2; co_tac.
Qed.

Lemma nds_p2 n c K: inc n Bnat ->
   (forall i, i<c n -> inc (c i) Bnat) ->
   inc K (powerset (Bint n)) ->
   osum_expansion (fun z => c (nth_elt K z)) (cardinal K) =
    card_sumb K c.
Proof.
move => nB cIb /setP_P Kb.
have KB: sub K Bnat by apply: (sub_trans Kb (@Bint_S1 n)).
have fsK:=(sub_finite_set Kb (finite_Bint n)).
set q := cardinal K; set f := nth_elt K.
have qB: inc q Bnat by apply /BnatP.
have ha: forall i, i <c q -> inc (f i) K.
  move => i iq; apply:(nth_set9 (BS_lt_int iq qB) KB iq).
have: forall j, inc j K -> exists2 i, i <c q & j = f i.
  move => j jK; exact(nth_set_10 KB fsK jK).
have : forall i j, i <c q -> j <c q -> f i = f j -> i = j.
  move => i j /(BintP qB) iq /(BintP qB) jq.
  move:(proj2 (proj1 (proj1 (nth_set_fct_bf KB fsK)))).
  have ax: lf_axiom (nth_elt K) (Bint (cardinal K)) K.
    by move => t /(BintP qB) /ha.
  rewrite /nth_set_fct; aw => h; move: (h i j iq jq);aw.
have: forall i, inc i K -> inc (c i) Bnat by move => i /Kb /(BintP nB) /cIb.
move: q qB (f) (K) ha fsK; clear.
apply: cardinal_c_induction.
  move => k K _ _ _ _ sf.
  have h: domain (Lg K c) = emptyset.
    by bw; apply /set0_P => t /sf [i /card_lt0].
  by rewrite osum_expansion0 /card_sumb (csum_trivial h).
move => n nB Hrec f K fK fsK cB fi fs.
rewrite (osum_expansion_succ _ nB).
have nn:= (card_lt_succ nB).
move:(fK _ nn) => fnK.
move: (setC1_K fnK); set K1:= K -s1 (f n) => Kv.
have h1: forall i, i <c n -> inc (f i) K1.
  move => i lin; move:(card_lt_ltT lin nn) => h; move: (fK _ h).
  rewrite - Kv =>/setU1_P; case => // eq; move:(fi _ _ h nn eq) => ein.
  by case: (proj2 lin).
have h2:=(sub_finite_set (@sub_setC K (singleton (f n))) fsK).
have h3: forall i, inc i K1 -> inc (c i) Bnat by move => i /setC1_P [/cB].
have h4: forall i j, i <c n -> j <c n -> f i = f j -> i = j.
  move => i j lin ljn;apply (fi _ _ (card_lt_ltT lin nn) (card_lt_ltT ljn nn)).
have h5:forall j, inc j K1 -> exists2 i : Set, i <c n & j = f i.
  move => j /setC1_P [/fs [i /(card_lt_succ_leP nB) lin ->] h].
  case: (equal_or_not i n) => ein; first by case: h; rewrite ein.
  by exists i.
have fnk1:~ inc (f n) K1 by move/setC1_P=> [ _ ].
have skB: inc (card_sumb K1 c) Bnat.
  apply:finite_sum_finite; hnf; rewrite/allf;bw;split => //.
  by move => t tk1; bw; apply: h3.
rewrite (Hrec f K1 h1 h2 h3 h4 h5) - Kv (csumA_setU1 _ fnk1).
by rewrite (osum2_2int (cB _ fnK) skB) csumC.
Qed.

Lemma the_CNF_omega_kj j k (X := omega0 *o j +o k)
  (e := (the_CNF_degree X))
  (r:= CNFbvo (Vg (P (Q (the_CNF X))))
        (Vg (Q (Q (the_CNF X))))(cpred (P (the_CNF X))))
  (c:= (Vg (Q (Q (the_CNF X))) (cpred (P (the_CNF X))))):
  inc j Bnat -> inc k Bnat -> \0c <c j ->
  \0o <o X /\ [/\ e = \1o, c = j & r = k].
Proof.
move => /olt_omegaP kj /olt_omegaP ko /proj2 jp1.
have ok: ordinalp k by ord_tac.
have oj: ordinalp j by ord_tac.
have jp : \0c <o j by split; [ apply:ozero_least | exact].
have op:= (OS_prod2 OS_omega oj).
have ox: ordinalp X by apply: (OS_sum2 (OS_prod2 OS_omega oj) ok).
have xp: \0o <o X.
  apply: ord_ne0_pos => // sz.
  move: (osum2_zero op ok sz) => [p1 _].
  by case: (oprod2_nz OS_omega oj omega_nz (nesym jp1)).
split; first by exact.
case : (ord_zero_dichot ok) => kz.
   set ee := fun i: Set => \1o.
   set cc := fun i: Set => j.
   have ax: CNFb_axo ee cc \1c.
    split; first split.
    + apply: ord_le_2omega.
    + move => i lin; rewrite /ee; fprops.
    + by move => i lin; rewrite /cc.
    + by move => i iB /card_lt1 h; case: (@succ_nz i).
    + by move => i lin.
  move: (CNFbB_prop ax BS1); set y := (CNFbB \1c ee cc); move => [ax2 yv].
  have py2: P y = \1c by rewrite /y /CNFbB; aw.
  move: (CNFB_ax_simp ax2) => [_ ax4].
  move: BS0 card_lt_01 => b0 lt01.
  have eq1: X = CNFBv y.
    rewrite py2 in ax4.
    rewrite /X kz (osum0r op) /CNFBv py2 /CNFbvo.
    rewrite (CNFq_p3 (proj1 ax4) lt01) /cantor_mon.
    rewrite /y /CNFbB !(pr1_pair, pr2_pair) /e; bw; Ytac0.
    by rewrite (opowx1 OS_omega); Ytac0.
  move:(the_CNF_p0 ox) => [sa sb].
  rewrite - sb in eq1; rewrite py2 in ax4.
  rewrite /e/c /r /the_CNF_degree.
  rewrite (CNFB_unique sa ax2 eq1) py2 - succ_zero (cpred_pr1 CS0).
  rewrite /y/CNFbB; aw; bw; repeat Ytac0; rewrite /CNFbvo (CNFq_p2).
  by split.
pose ee i := Yo (i = \0c) \0o \1o.
pose cc i := Yo (i = \0c) k j.
move:card1_nz => H.
move: card_lt_12 => lt12.
move: card_lt_02 => lt02.
move: ord_lt_01 BS0 BS1 => l01 bs0 bs1.
have e0: ee \0c = \0o by rewrite /ee; Ytac0.
have e1: ee \1c = \1o by rewrite /ee; Ytac0.
have c0: cc \0c = k by rewrite /cc; Ytac0.
have c1: cc \1c = j by rewrite /cc; Ytac0.
have ax: CNFb_axo ee cc \2c.
  split; first split.
  + apply: ord_le_2omega.
  + move => i lin; rewrite /ee; Ytac h; fprops.
  + by move => i lin; rewrite /cc; Ytac h => //; apply: ord_lt_1omega.
  + move => i iB /card_lt2; rewrite /ee; move: (@succ_nz i) => ss.
    rewrite - succ_zero; case => // si.
    by move: (succ_injective1 (CS_Bnat iB) CS0 si) => iz;Ytac0; Ytac0.
  + move => i lin; rewrite /cc; Ytac h => //.
move: (CNFbB_prop ax BS2); set y := (CNFbB \2c ee cc); move => [ax2 yv].
have py2: P y = \2c by rewrite /y /CNFbB; aw.
move: (CNFB_ax_simp ax2) => [_ ax4].
have eq1: X = CNFBv y.
  rewrite py2 in ax4.
  move: (CNFq_p7 (proj1 ax4) lt12).
  rewrite /X /CNFBv /y /CNFbB !(pr1_pair, pr2_pair) -/CNFbvo => ->.
  rewrite /cantor_mon; bw; repeat Ytac0; rewrite e0 c0 e1 c1.
  by rewrite opowx0 (opowx1 OS_omega) (oprod1l ok).
move:(the_CNF_p0 ox) => [sa sb].
rewrite - sb in eq1; rewrite py2 in ax4.
rewrite /e/c/r /the_CNF_degree.
rewrite (CNFB_unique sa ax2 eq1) py2 - succ_one (cpred_pr1 CS1).
rewrite /CNFbvo (CNFq_p3 (proj1 ax4) lt02) /cantor_mon /y/CNFbB/CNFbvo.
by aw; bw; repeat Ytac0; rewrite e0 opowx0 c0 (oprod1l ok); split.
Qed.

Section NdsStudy1.
Variables (X: fterm) (n:Set).
Hypothesis nB: inc n Bnat.
Hypothesis np: \0c <c n.
Hypothesis ax: nds_tn_ax X n.

Let ee := (the_CNF_degree (X \0c)).

Lemma nds_tn4: ordinalp ee.
Proof. by move:(proj2 ax) => [e ea eb]; rewrite /ee (eb _ np). Qed.

Lemma nds_tn5 i: i<c n -> the_CNF_degree (X i) = ee.
Proof.
by move:(proj2 ax) => [e ea eb] lin; rewrite /ee (eb _ np) (eb _ lin).
Qed.

Let rr:= fun i => CNFbvo (Vg (P (Q (the_CNF (X i)))))
        (Vg (Q (Q (the_CNF (X i)))))
        (cpred (P (the_CNF (X i)))).
Let cc:= fun i => (Vg (Q (Q (the_CNF (X i)))) (cpred (P (the_CNF (X i))))).

Lemma nds_tn6 i: i <c n ->
   [/\ \0o <o cc i, cc i <o omega0, rr i <o omega0 ^o ee &
    X i = omega0 ^o ee *o (cc i) +o rr i].
Proof.
move => lin.
rewrite - (nds_tn5 lin).
have xp:= (proj1 ax i lin).
move:(the_CNF_p0 (proj32_1 xp)) (the_CNF_p2 xp) => [/CNFB_ax_simp [ha hb] hc].
move: ha hb hc; rewrite /cc /rr /ee /the_CNF_degree.
set e := Vg (P (Q (the_CNF (X i)))).
set c := Vg (Q (Q (the_CNF (X i)))).
set ln := (cpred (P (the_CNF (X i)))).
set lm:= (P (the_CNF (X i))).
move => lmB axx Xv [lnB lmv].
have lnm: ln <c lm by move:(card_lt_succ lnB); rewrite - lmv.
split.
+ exact (proj2 axx _ lnm).
+ move: (proj1 axx) =>[_ _ pc _]; exact: (pc _ lnm).
+ apply:(CNFq_pg lnB); rewrite - lmv;exact:(proj1 axx).
+ by rewrite - Xv /CNFBv -/lm lmv /CNFbvo (CNFq_p1 _ _ _ lnB).
Qed.

Lemma nds_tn7 K s: K = emptyset
  -> nds_sc (cardinal K) (fun z => X (nth_elt K z)) s = \0c.
Proof. by move => ->;rewrite cardinal_set0 /nds_sc osum_expansion0. Qed.

Lemma nds_tn8 K s: inc K (powerset (Bint n)) -> inc s (perm_int (cardinal K))
  -> nonempty K
  -> nds_sc (cardinal K) (fun z => X (nth_elt K z)) s =
    omega0 ^o ee *o osum_expansion (fun z => cc (nth_elt K z)) (cardinal K)
    +o rr (nth_elt K (Vf s \0c)).
Proof.
move => /setP_P sb sp nek.
move:(sub_smaller sb); rewrite (card_Bint nB) => ckn.
have ckB:=(BS_le_int ckn nB).
have cknz:= (cardinal_nonemptyset1 nek).
move:(cpred_pr ckB cknz); set k:= cpred _; move => [kB kv].
have ikP: forall i, i<=c k -> (nth_elt K i) <c n.
  move => i /(card_lt_succ_leP kB); rewrite -kv => l1.
  have sKB: sub K Bnat by move => t /sb/(BintP nB) => h; apply(BS_lt_int h nB).
  by move: (nth_set9 (BS_lt_int l1 ckB) sKB l1) => /sb/(BintP nB).
pose Y z := X (nth_elt K z).
pose c z := cc (nth_elt K z).
pose r z := rr (nth_elt K z).
have h2:= nds_tn4.
have h3:(forall i, i <=c k -> \0o <o c i /\ r i <o omega0 ^o ee).
  by move => i /ikP/nds_tn6 [ra _ rb _].
have h4:(forall i, i <=c k -> c i <o omega0).
  by move => i /ikP /nds_tn6 [_ rc _ _].
have lkn: k <c n by apply/(card_le_succ_ltP _ kB); rewrite - kv.
have <-:nds_sc (cardinal K) (fun i => omega0 ^o ee *o c i +o r i) s =
   nds_sc (cardinal K) (fun z => X (nth_elt K z)) s.
  apply:(osum_expansion_exten ckB) => i /(BintP ckB) lin.
  move/(perm_intP): sp => [[[fs _] _] ss ts].
  have: (Vf s i) <c cardinal K by apply/(BintP ckB); Wtac; rewrite ss.
  by rewrite kv; move/(card_lt_succ_leP kB) => /ikP /nds_tn6 [_ _ _ rd].
rewrite kv in sp.
by rewrite kv (nds_p1 kB h2 h3 h4 sp); rewrite /c/r - kv.
Qed.

Lemma nds_tn9 v:
  inc v (nds_tn_S X n) <->
  (v = \0o \/ exists K a, [/\ inc K (powerset (Bint n)), inc a K &
   v =
     omega0 ^o ee *o osum_expansion (fun z => cc (nth_elt K z)) (cardinal K)
    +o rr a]).
Proof.
split.
  move/setUf_P => [K ka /funI_P [s sp sv]].
  case:(emptyset_dichot K) => ke.
    by rewrite sv ke cardinal_set0/nds_sc osum_expansion0; left.
  right; exists K,(nth_elt K (Vf s \0c)).
  move/(perm_intP): (sp) => [[[fs _] _] ss ts].
  have h:inc (nth_elt K (Vf s \0c)) K.
    move/setP_P: ka => ka.
    have sKB: sub K Bnat by move => t /ka/(BintP nB) => h;apply(BS_lt_int h nB).
    move:(sub_smaller ka); rewrite (card_Bint nB) => ckn.
    have ckB:=(BS_le_int ckn nB).
    have cknz:= (cardinal_nonemptyset1 ke).
    have zi: inc \0c (Bint (cardinal K)).
      apply /(BintP ckB); split; [ apply: czero_least; fprops | fprops].
    have l1: (Vf s \0c) <c cardinal K by apply/(BintP ckB); Wtac; rewrite ss.
    by move:(nth_set7 (BS_lt_int l1 ckB) sKB l1) => [/setC_P []].
  by split => //; rewrite sv - (nds_tn8 ka sp ke).
case => vv.
   apply/setUf_P; exists emptyset; first by apply: setP_0i.
   apply/funI_P; exists (identity (Bint (cardinal emptyset))).
      apply:perm_int_id.
   by rewrite cardinal_set0 /nds_sc osum_expansion0.
move:vv=> [K [a [Ks1 aK ->]]]; apply/setUf_P; exists K => //.
have neK: nonempty K by ex_tac.
move/setP_P: (Ks1) => ka.
have sKB: sub K Bnat by move => t /ka/(BintP nB) => h;apply(BS_lt_int h nB).
move:(sub_smaller ka); rewrite (card_Bint nB) => ckn.
have cknz:= (cardinal_nonemptyset1 neK).
have ckB:=(BS_le_int ckn nB).
move:(cpred_pr ckB cknz); set k:= cpred _; move => [kB kv].
have fsk: finite_set K by apply/BnatP.
move:(nth_set_10 sKB fsk aK) => [i il1 iv].
move: (permutation_exists1 ckB il1) => [f fp fiv].
rewrite -fiv in iv.
by apply/funI_P;ex_tac; rewrite (nds_tn8 Ks1 fp neK) - iv.
Qed.

Lemma nds_p3 a K:inc K (powerset (Bint n)) -> inc a K ->
  omega0 ^o ee *o osum_expansion (fun z => cc (nth_elt K z)) (cardinal K)
    +o rr a =
  omega0 ^o ee *o card_sumb (K -s1 a) cc +o X a.
Proof.
move => pa pb.
have h1:(forall i, i <c n -> inc (cc i) Bnat).
  by move => i /nds_tn6 [_ /(ord_ltP OS_omega) h _ _].
rewrite (nds_p2 nB h1 pa).
move: (setC1_K pb); set K1:= K -s1 a => Kv.
move/setP_P:pa => Kb.
have ss1:= (@sub_setC K (singleton a)).
have fsK:=(sub_finite_set Kb (finite_Bint n)).
have h2:=(sub_finite_set ss1 fsK).
have skB: inc (card_sumb K1 cc) Bnat.
  apply:finite_sum_finite; hnf; rewrite/allf;bw;split => //.
  move => t tk1; bw; apply: h1;apply /(BintP nB); apply: (Kb _ (ss1 _ tk1)).
have ak1:~ inc a K1 by move/setC1_P=> [ _ ].
move /(BintP nB): (Kb _ pb) =>/nds_tn6 [_ _ /proj31_1 o4 r2].
have ccaB: inc (cc a) Bnat by apply: h1; apply /(BintP nB);apply: Kb.
rewrite -{1} Kv (csumA_setU1 _ ak1) - (osum2_2int skB ccaB).
have o1:=(OS_pow OS_omega nds_tn4).
move: (Bnat_oset ccaB) (Bnat_oset skB) => o2 o3.
by rewrite (osum_prodD) // - (osumA (OS_prod2 o1 o3) (OS_prod2 o1 o2) o4) r2.
Qed.

Lemma nds_tn10: (nds_tn_S X n) =
  unionf (Bint n) (fun a => fun_image (powerset ((Bint n) -s1 a))
   (fun K => omega0 ^o ee *o (card_sumb K cc) +o X a)) +s1 \0c.
Proof.
set_extens v.
  case /nds_tn9;[ move ->; fprops | move => [K [a [kp ak ->]]] ].
  apply/setU1_P; left; apply /setUf_P.
  move/setP_P:(kp) => kb;move:(kb _ ak) => aN;ex_tac; apply /funI_P.
  exists (K -s1 a).
    by apply/setP_P => t/setC1_P [ha hb]; apply/setC1_P; split=> //; apply:kb.
  by rewrite nds_p3.
case/setU1_P => h1; apply/nds_tn9; [right | by left].
move/setUf_P: h1 => [a aB /funI_P[K /setP_P Kb ->]].
have nk1: ~ (inc a K) by move /Kb => /setC1_P[].
have eq1:= setU1_K nk1.
have ha: inc (K +s1 a) (powerset (Bint n)).
   apply /setP_P => t/setU1_P; case; [by move/Kb => /setC1_P[] | by move ->].
have hb:inc a (K +s1 a) by fprops.
by exists (K +s1 a),a; split => //; rewrite (nds_p3 ha hb) eq1.
Qed.

Lemma nds_tn11: (nds_tn_C X n) <=c ndstnC n.
Proof.
rewrite /nds_tn_C nds_tn10/ndstnC.
set S := unionf _ _.
suff h: cardinal S <=c (n *c \2c ^c cpred n).
  have w:cardinalp (n *c \2c ^c cpred n) by fprops.
  have w1:= (card_le_succ0 w).
  case: (inc_or_not \0c S) => ha; first by rewrite (setU1_eq ha); co_tac.
  by rewrite (card_succ_pr ha); apply /(card_le_succ_succP (CS_cardinal S) w).
rewrite /S; set F:= (fun a : Set => _).
move:(cpred_pr nB (nesym (proj2 np))) => [pnB pnv].
move:(csum_pr1_bis (Bint n) F).
set g1:= (Lg (Bint n) (fun a => cardinal (Vg (Lg (Bint n) F) a))).
have <-: card_sum g1 = card_sumb (Bint n) (fun a : Set => cardinal (F a)).
  rewrite /card_sumb;apply:f_equal;apply:Lg_exten => t tx; bw.
set g2 := cst_graph (Bint n) (\2c ^c cpred n).
have sd: domain g1 = domain g2 by rewrite /g1/g2; bw.
suff le1:forall x, inc x (domain g1) -> Vg g1 x <=c Vg g2 x.
  move:(csum_increasing sd le1).
  rewrite csum_of_same cprodC - cprod2_pr2a (card_Bint nB).
  move => hb ha ; exact:(card_leT ha hb).
rewrite /g1 /g2; bw => a abn; bw.
have ->: \2c ^c cpred n = cardinal (powerset (Bint n -s1 a)).
  move: (card_succ_pr2 abn); rewrite (card_Bint nB) => eq1.
  rewrite card_setP - (cpow_prb _ ((Bint n -s1 a))); apply: f_equal.
  apply:succ_injective1; fprops; ue.
apply: fun_image_smaller.
Qed.

Lemma nds_tn11_ex:
  (forall i, X i = omega0 *o (\2c ^c i) +o i) ->
  (nds_tn_S X n) =
  unionf (Bint n) (fun a => fun_image (powerset ((Bint n) -s1 a))
   (fun K => omega0 *o (card_sumb K (fun i => (\2c ^c i))) +o X a)) +s1 \0c.
Proof.
move => h.
rewrite nds_tn10.
have ha: forall i, inc i Bnat -> inc (\2c ^c i) Bnat.
  move => i; apply:(BS_pow BS2).
have hb: forall i, inc i Bnat -> \0c <c (\2c ^c i).
  by move => i ib; split;[ fprops |apply: nesym;apply: cpow2_nz].
have ->: ee = \1o.
  move:(proj31 (proj2 (the_CNF_omega_kj (ha _ BS0) BS0 (hb _ BS0)))).
  by rewrite - (h \0c).
apply:f_equal2; last by exact.
rewrite (opowx1 OS_omega).
have aux: forall y, sub y Bnat ->
  card_sumb y [eta card_pow \2c] = card_sumb y cc.
  move => y yb; rewrite /card_sumb /card_sum; apply:f_equal; apply:f_equal.
  apply:Lg_exten => t /yb yB.
  move: (proj32 (proj2 (the_CNF_omega_kj (ha _ yB) yB (hb _ yB)))).
  by rewrite - (h t).
have H2: forall y a, inc y (powerset (Bint n -s1 a)) -> sub y Bnat.
  by move => y a /setP_P hy t /hy /setC1_P [/Bint_S1 uu _].
set F1 := fun a: Set => _; set F2 := fun a: Set => _.
suff r1: forall a, inc a (Bint n) -> F1 a = F2 a.
  set_extens t => /setUf_P [y ya yb]; apply/setUf_P; exists y;
   [exact |by rewrite - (r1 _ ya) | exact | by rewrite (r1 _ ya)].
move => a ab; set_extens t; move => /funI_P [y ya ->]; apply/funI_P.
  exists y; [exact | by rewrite (aux _ (H2 _ _ ya))].
 exists y; [exact | by rewrite (aux _ (H2 _ _ ya))].
Qed.

End NdsStudy1.

Definition sumpow2 K := card_sumb K (fun z => \2c ^c z).

Lemma omega_monom_inj a b c d:
   inc a Bnat -> inc b Bnat -> inc c Bnat -> inc d Bnat
  -> omega0 *o a +o b = omega0 *o c +o d -> (a = c /\ b = d).
Proof.
move => aB bB cB dB eq1.
have aux: forall u v, inc u Bnat -> inc v Bnat ->inc (omega0 *o u +o v) Bnat
   -> u = \0c.
  move => u v uB vB h; ex_middle h1.
  have h2:= (ozero_least (Bnat_oset uB)).
  have h3: \0o <o u by split; [apply: h2| apply:nesym].
  have l1:=(oprod_Mle1 OS_omega h3).
  move:(ord_leT l1 (osum_Mle0 (proj32 l1) (Bnat_oset vB))) => l2.
  move/(ord_ltP OS_omega): h => l3; ord_tac.
case: (equal_or_not a \0c) => az.
  move: eq1; rewrite az oprod0r (osum0l (Bnat_oset bB)) => eq1.
  rewrite eq1 in bB.
  by rewrite eq1 (aux _ _ cB dB bB) oprod0r (osum0l (Bnat_oset dB)).
case: (equal_or_not c \0c) => cz.
  move: eq1; rewrite cz oprod0r (osum0l (Bnat_oset dB)) => eq1.
  case: az;rewrite - eq1 in dB; exact:(aux _ _ aB bB dB).
have ap: \0c <c a by split; fprops.
have cp: \0c <c c by split; fprops.
move:(the_CNF_omega_kj aB bB ap) => [_ [_ e1 e2]].
move:(the_CNF_omega_kj cB dB cp) => [_ [_ e3 e4]].
by rewrite eq1 in e1 e2; rewrite e1 in e3; rewrite e2 in e4.
Qed.

Lemma sumpow2_a K: finite_set K -> sub K Bnat -> inc (sumpow2 K) Bnat.
Proof.
move => ha hb; apply:finite_sum_finite; split; aw; bw.
hnf; bw => x xk; bw; fprops.
Qed.

Lemma sumpow2_b n a K:
  inc n Bnat -> inc K (powerset (Bint n -s1 a)) -> inc (sumpow2 K) Bnat.
Proof.
move => nB /setP_P h1; move:(sub_trans h1 (@sub_setC _ _)) => h2.
have h3:= (sub_trans h2 (@Bint_S1 n)).
exact (sumpow2_a (sub_finite_set h2 (finite_Bint n)) h3).
Qed.

Lemma sumpow2_c a K: ~ (inc a K) ->
  sumpow2 (K+s1 a) = sumpow2 K +c (\2c ^c a).
Proof. by move => naK; rewrite /sumpow2 (csumA_setU1 _ naK). Qed.

Lemma sumpow2_d a K: inc a K ->
  sumpow2 K = sumpow2 (K -s1 a) +c (\2c ^c a).
Proof.
by move => aK; rewrite -{1} (setC1_K aK) sumpow2_c // => /setC1_P [].
Qed.

Lemma sumpow2_e n a K (X := fun i => omega0 *o (\2c ^c i) +o i):
  inc n Bnat -> inc a (Bint n) ->
  inc K (powerset (Bint n -s1 a)) ->
  omega0 *o (sumpow2 K) +o X a = omega0 *o (sumpow2 (K +s1 a)) +o a
  /\ (inc (sumpow2 (K +s1 a)) Bnat).
Proof.
move => nB ak KP.
have aB := (@Bint_S1 n a ak).
have haa: inc (\2c ^c a) Bnat by fprops.
have naK: ~ inc a K by move/setP_P:KP => KP1; move /KP1 => /setC1_P [_].
move: (sumpow2_b nB KP) => sB.
have o1:= (Bnat_oset sB).
rewrite (sumpow2_c naK); split; last by fprops.
rewrite {2} /sumpow2 - (osum2_2int sB haa).
rewrite (osum_prodD o1 (Bnat_oset haa) OS_omega).
exact:(osumA (OS_prod2 OS_omega o1) (OS_prod2 OS_omega (Bnat_oset haa))
   (Bnat_oset aB)).
Qed.

Lemma sumpow2_f n K:
   inc n Bnat -> (forall i, inc i K -> i <c n) ->
   sumpow2 K <c \2c ^c n.
Proof.
move => nB;move:n nB K ; apply: cardinal_c_induction.
  move => K h; rewrite cpowx0.
  case:(emptyset_dichot K).
     move => ->; rewrite /sumpow2/ card_sumb csum_trivial;bw;apply:card_lt_01.
  by move => [i /h /card_lt0].
move => n nB Hrec K kP.
set K1:= K -s1 n.
have /Hrec r1:(forall i, inc i K1 -> i <c n).
   by move => i /setC1_P [/kP /(card_lt_succ_leP nB) h1 h2].
rewrite (pow_succ _ nB) cprodC two_times_n.
case: (inc_or_not n K) => ink.
  rewrite (sumpow2_d ink); apply:csum_Mlteq; fprops.
rewrite -(setC1_eq ink); apply: (card_lt_leT r1); apply:csum_M0le; fprops.
Qed.

Lemma sumpow2_g n a K1 K2 (X := fun i => omega0 *o (\2c ^c i) +o i):
  inc n Bnat -> inc a (Bint n) ->
  inc K1 (powerset (Bint n -s1 a)) ->
  inc K2 (powerset (Bint n -s1 a)) ->
   omega0 *o (sumpow2 K1) +o X a =
   omega0 *o (sumpow2 K2) +o X a ->
   K1 = K2.
Proof.
move => nB ab K1b K2b.
move: (sumpow2_e nB ab K1b) (sumpow2_e nB ab K2b) => [e1 e2][e3 e4].
rewrite e1 e3 => eq1.
have aB := (@Bint_S1 n a ab).
move: (proj1 (omega_monom_inj e2 aB e4 aB eq1)).
move:(sumpow2_b nB K1b)(sumpow2_b nB K2b) => e5 e6.
move/setP_P:K1b => K1b1.
move/setP_P:K2b => K2b1.
have naK1: ~(inc a K1) by move /K1b1 => /setC1_P [_].
have naK2: ~(inc a K2) by move /K2b1 => /setC1_P [_].
rewrite (sumpow2_c naK1) (sumpow2_c naK2) => eq2.
move:(csum_simplifiable_right (BS_pow BS2 aB) e5 e6 eq2).
have: forall i, inc i K1 -> i<c n by move => i /K1b1 /setC1_P [/(BintP nB)].
have: forall i, inc i K2 -> i<c n by move => i /K2b1 /setC1_P [/(BintP nB)].
move:nB; clear; move => nB; move:n nB K1 K2; apply: cardinal_c_induction.
  move => K1 K2 h1 h2 sv.
  case:(emptyset_dichot K1) => ha.
      case:(emptyset_dichot K2) => hb; first by rewrite ha hb.
     by move:hb => [i/h1 /card_lt0].
   by move:ha => [i/h2 /card_lt0].
move => n nB Hrec K1 K2 h2 h1.
have kk1:(forall i, inc i (K1 -s1 n) -> i <c n).
  by move => i /setC1_P [/h1 /(card_lt_succ_leP nB) hu hv].
have kk2:(forall i, inc i (K2 -s1 n) -> i <c n).
  by move => i /setC1_P [/h2 /(card_lt_succ_leP nB) hu hv].
have l1:(sumpow2 (K1 -s1 n)) <c \2c ^c n by apply: sumpow2_f.
have l2:(sumpow2 (K2 -s1 n)) <c \2c ^c n by apply: sumpow2_f.
have pB:= (BS_pow BS2 nB).
case: (inc_or_not n K1) => nk1.
   case: (inc_or_not n K2) => nk2.
      have hh1:= (BS_lt_int l1 (BS_pow BS2 nB)).
      have hh2:= (BS_lt_int l2 (BS_pow BS2 nB)).
      rewrite (sumpow2_d nk1) (sumpow2_d nk2) => eq2.
      move:(csum_simplifiable_right pB hh1 hh2 eq2) => eq3.
      by rewrite - (setC1_K nk1) - (setC1_K nk2) (Hrec _ _ kk2 kk1 eq3).
  move: l2; rewrite (sumpow2_d nk1) (setC1_eq nk2) => l2 eq.
  move: (csum_M0le (sumpow2 (K1 -s1 n)) (CS_Bnat pB)).
  rewrite csumC eq => l3; co_tac.
case: (inc_or_not n K2) => nk2.
  move: l1; rewrite (setC1_eq nk1) (sumpow2_d nk2) => l1 eq.
  move: (csum_M0le (sumpow2 (K2 -s1 n)) (CS_Bnat pB)).
  rewrite csumC - eq => l3; co_tac.
by rewrite - (setC1_eq nk1) - (setC1_eq nk2); apply: Hrec.
Qed.


Lemma card_fun_image a f: {inc a &, injective f} ->
   cardinal (fun_image a f) = cardinal a.
Proof.
move => H.
symmetry; apply/card_eqP; exists (Lf f a (fun_image a f)); split; aw.
apply:lf_bijective.
+ by move=> t ta; apply /funI_P; ex_tac.
+ exact H.
+ by move=> y /funI_P.
Qed.

Lemma nds_tn12 n: inc n Bnat -> \0c <c n -> (nds_tn_sup n) <=c ndstnC n.
Proof.
move => nB np.
move: (nds_tn2 nB) => [_ _ _ [X hx <-] _]; exact:(nds_tn11 nB np hx).
Qed.

Lemma nds_tn13 n: inc n Bnat -> nds_tn_sup n = ndstnC n.
Proof.
move => nB.
case: (equal_or_not n \0c) => nz.
  by rewrite nz nds_tn3 /ndstnC cprodC cprod0r succ_zero.
have np: \0c <c n by split; fprops.
apply: card_leA; first by apply:nds_tn12.
pose X i := omega0 *o (\2c ^c i) +o i.
have Xv: (forall i, X i = omega0 *o \2c ^c i +o i) by [].
have ha: forall i, inc i Bnat -> inc (\2c ^c i) Bnat.
  move => i; apply:(BS_pow BS2).
have hb: forall i, inc i Bnat -> \0c <c (\2c ^c i).
  by move => i ib; split;[ fprops |apply: nesym;apply: cpow2_nz].
have ax: nds_tn_ax X n.
  split.
    move => i lin; move:(BS_lt_int lin nB) => yB.
    exact:(proj1 (the_CNF_omega_kj (ha _ yB) yB (hb _ yB))).
  exists \1o; first by apply:OS1.
  move => i lin; move:(BS_lt_int lin nB) => yB.
  exact:(proj31 (proj2(the_CNF_omega_kj (ha _ yB) yB (hb _ yB)))).
suff eq1: nds_tn_C X n = ndstnC n.
  by move: (nds_tn2 nB) => [_ _ _ _ h]; move: (h _ ax); rewrite - eq1.
rewrite /nds_tn_C (nds_tn11_ex nB np ax Xv).
rewrite card_succ_pr; last first.
  move/setUf_P => [a aB /funI_P [K Ka kv]].
  move/(BintP nB): aB => /(proj1 ax) => xP.
  have o1:=(OS_prod2 OS_omega (Bnat_oset (sumpow2_b nB Ka))).
  by move:(osum2_zero o1 (proj32_1 xP) (esym kv))=>[_ h]; case: (proj2 xP).
rewrite /ndstnC; congr succ;rewrite csum_pr4_bis; last first.
  move => i j iB jB; case (equal_or_not i j) => eij; [by left | right].
  apply:disjoint_pr => u /funI_P [K1 K1p uv1] /funI_P [K2 K2p uv2]; case eij.
  move: (sumpow2_e nB iB K1p) (sumpow2_e nB jB K2p) => [e1 e2] [e3 e4].
  move: uv2; rewrite uv1 e1 e3 => eq1.
  exact:(proj2 (omega_monom_inj e2(@Bint_S1 n i iB) e4 (@Bint_S1 n j jB) eq1)).
set F := fun a:Set => _.
suff H: forall a, inc a (Bint n) -> F a = \2c ^c cpred n.
   rewrite - {2} (card_Bint nB) (cprod2_pr2a).
   rewrite cprodC - csum_of_same /card_sumb; apply: f_equal.
   by apply:Lg_exten; move => i ib /=; apply: H.
move => a aB; rewrite /F; rewrite card_fun_image.
  rewrite card_setP - cpow_prb; apply:f_equal; symmetry.
  move: (cpred_pr nB (nesym (proj2 np))) => [sa sb].
  move: (card_succ_pr2 aB); rewrite (card_Bint nB) {1} sb.
  exact:(succ_injective1 (CS_Bnat sa) (CS_cardinal (Bint n -s1 a))).
move => K1 K2;apply:(sumpow2_g nB aB).
Qed.

Definition nds_type_nor X n k e:=
 [/\ nds_type X n k, ordinalp e,
    forall i, i<c n -> \0o <o (X i),
    forall i, i<c k -> the_CNF_degree (X i) = e &
    forall i, k <=c i -> i <c n -> e <o the_CNF_degree (X i)].

Lemma nds_type9 X n k:
   inc n Bnat -> k <> \0c -> k <=c n -> nds_type X n k ->
   exists Y e, nds_type_nor Y n k e /\ nds_card n Y = nds_card n X.
Proof.
move => nB knz lekn;case; first by move => [sa sb]; case: knz.
move => [_ [ha [m [om h1]]]].
set E := Zo _ _ => ce.
have ax:nds_ax X n by move => i /ha/proj32_1.
have sk: sub (Bint k) (Bint n).
  by apply:Bint_M1.
move:(BS_le_int lekn nB) => kB.
have sE: sub E (Bint n) by apply: Zo_S.
move:(permutation_exists2 nB sE) => [f fp]. rewrite ce.
move: (nds_m nB ax fp); set Y:= fun i =>X (Vf f i) => yv.
move:fp => /Zo_P [/fun_set_P [ff sf tf] bf] fv.
have sisf: sub (Bint k) (source f) by rewrite sf.
move: (cardinal_image sisf (proj1 bf));rewrite- fv (card_Bint kB) => ck.
have pa:forall i, i <c n -> \0o <o Y i.
  move => i /(BintP nB) ii; apply: ha; apply/(BintP nB); Wtac.
have pb: forall i, i <c n -> m <=o the_CNF_degree (Y i).
  move => i /(BintP nB) ii; apply: h1;apply/(BintP nB); Wtac.
have pc: forall i, i <c k -> the_CNF_degree (Y i) = m.
  move => i /(BintP kB) ik.
  have/Zo_hi //: inc (Vf f i) E
    by rewrite fv; apply/(Vf_image_P ff sisf); ex_tac.
have pd: (Zo (Bint n) (fun i => the_CNF_degree (Y i) = m)) = (Bint k).
  set_extens t.
    move => /Zo_P [ta tb].
    have: inc (Vf f t) E by apply/Zo_P; split => //; Wtac.
    rewrite fv => /(Vf_image_P ff sisf) [u usf].
    move: ta (sk _ usf); rewrite - sf => hb hc hd.
    by rewrite(proj2(proj1 bf) _ _ hb hc hd).
  move => ta; apply /Zo_P;split; first by apply: sk.
  by apply: pc; apply /(BintP kB).
have pf:forall i, k <=c i -> i <c n -> m <o the_CNF_degree (Y i).
  move => i ki kin; split; first by apply: pb.
  move => sa.
  have: inc i (Bint k).
     by rewrite - pd; apply /Zo_P; split => //; apply/(BintP nB).
   move/(BintP kB) => ba; co_tac.
have pe: nds_type Y n k.
   right; split; [exact| split;[ exact | exists m; split => //]].
   by rewrite pd (card_Bint kB).
exists Y, m; rewrite - yv; split => //.
Qed.

Lemma nds_r1 c n X: inc n Bnat -> nds_ax X n -> ordinalp c ->
   osum_expansion (fun z : Set => c *o X z) n = c *o osum_expansion X n.
Proof.
move:n; apply: cardinal_c_induction.
  by rewrite !osum_expansion0 (oprod0r).
move => n nB Hrec axn oc.
have nn:= (card_lt_succ nB).
have ax1: nds_ax X n by move =>i lin; apply:axn; co_tac.
rewrite !(osum_expansion_succ _ nB) (Hrec ax1 oc).
by rewrite (osum_prodD (axn _ nn) (OS_osum_expansion nB ax1) oc).
Qed.

Lemma nds_r2 c n X (Y:= fun i => c *o X i):
  inc n Bnat -> nds_ax X n -> \0o <o c ->
  nds_card n X = nds_card n Y.
Proof.
move => nB ax cp.
rewrite /nds_card /nds_sums.
set E := perm_int n; set A := fun_image _ _;set B := fun_image _ _.
apply /card_eqP; exists (Lf (fun z => c *o z) A B).
have osA: ordinal_set A.
  by move => z /funI_P [f /(nds_b nB ax) [_ os] ->].
have aux: forall f, inc f E -> nds_sc n Y f = c *o nds_sc n X f.
  move => f /(nds_b nB ax) [ax1 _ ].
  apply:(nds_r1 nB ax1 (proj32_1 cp)).
split; aw.
apply: lf_bijective.
+ by move => z /funI_P [f fp ->]; apply /funI_P; exists f => //; rewrite aux.
+ move => u v /osA ou /osA ov h; exact (oprod2_simpl ou ov cp h).
+ move => z /funI_P [f fp ->]; exists(nds_sc n X f).
  apply /funI_P; exists f => //.
  by apply: aux.
Qed.

Lemma nds_card_exten m Y1 Y2:
   inc m Bnat -> same_below Y1 Y2 m ->
   nds_card m Y1 = nds_card m Y2.
Proof.
move => ha hb.
rewrite /nds_card; apply:f_equal; set_extens t;
   move => /funI_P [z zp ->];apply/funI_P; ex_tac.
by apply:nds_sc_exten.
by symmetry;apply:nds_sc_exten.
Qed.

Lemma nds_tn_C_exten Z Y n: inc n Bnat -> same_below Z Y n ->
  nds_tn_C Z n = nds_tn_C Y n.
Proof.
move => nB h.
have aux: forall K s, inc K (powerset (Bint n)) ->
    inc s (perm_int (cardinal K)) ->
    nds_sc (cardinal K) (fun z : Set => Z (nth_elt K z)) s =
    nds_sc (cardinal K) (fun z : Set => Y (nth_elt K z)) s.
  move => K s /setP_P Kb /perm_intP [[[fs _] _ ] ss tf].
  have fsK:=(sub_finite_set Kb (finite_Bint n)).
  have ckB: inc (cardinal K) Bnat by apply /BnatP.
  have sKB: sub K Bnat by move => t /Kb/(BintP nB) => w;apply(BS_lt_int w nB).
  apply:(osum_expansion_exten ckB) => i lin; apply: h.
  have h1: Vf s i <c cardinal K.
     by apply /(BintP ckB); Wtac; rewrite ss;apply /(BintP ckB).
  have h2:= (BS_lt_int h1 ckB).
  by apply/(BintP nB); apply: Kb; apply: nth_set9.
rewrite /nds_tn_C/nds_tn_S; apply: f_equal.
set_extens t; move => /setUf_P [K KP /funI_P [s sp ->]];
  apply /setUf_P; ex_tac;apply/funI_P; ex_tac.
  symmetry;exact:(aux K s KP sp).
Qed.

Section NdsStudy.
Variables (X: fterm) (n k e: Set).
Hypothesis nB: inc n Bnat.
Hypothesis kBp: k <> \0c.
Hypothesis kln: k <c n.
Hypothesis Xax: nds_type_nor X n k e.

Let pL f i := k <=c Vf f i.
Let pS f i := Vf f i <c k.
Let rp f g i:=
    [/\ inc g (perm_int n), nds_sc n X f = nds_sc n X g &
        forall j, j<c i -> Vf f j = Vf g j].

Let fL f := intersection (Zo Bnat (fun i => i <c n /\ pL f i)).

Lemma nds_tg0 f i: pL f i -> pS f i -> False.
Proof. rewrite /pL/pS => ha hb; co_tac. Qed.

Lemma nds_tg1 f i:
   inc f (perm_int n) -> inc i (Bint n) -> inc (Vf f i) (Bint n).
Proof.
move => /perm_intP [[[ff _] _] sf tf]; rewrite -{1} sf -tf => isf; Wtac.
Qed.

Lemma nds_tg2 f i: inc f (perm_int n) -> inc i (Bint n) ->
  pL f i \/ pS f i.
Proof.
move => fp /(nds_tg1 fp) /(BintP nB) [[cf _ _] _].
exact:(card_le_to_el (proj31_1 kln) cf).
Qed.

Lemma nds_tg3 f: inc f (perm_int n) ->
  [/\ inc (fL f) Bnat, (fL f) <=c k, (fL f) <c n, pL f (fL f) &
      forall j, j <c (fL f) -> pS f j].
Proof.
move => fp; rewrite /fL; set E:= Zo _ _.
move/perm_intP:(fp) =>[[injf [ff fs]] sf tf].
have nee: nonempty E.
  move:(perm_int_surj nB fp kln) => [i lin si].
  exists i;apply:Zo_i;[ by apply: (BS_lt_int lin nB) | split => //].
  rewrite /pL si; apply: (card_leR (proj31_1 kln)).
have seB: sub E Bnat by apply:Zo_S.
move: (nth_set1 seB nee); set i:= intersection E.
move => [/Zo_P [iB [ha hb]] etc].
have kB:= (BS_lt_int kln nB).
have aux: forall j, j <c i -> pS f j.
  move => // j lji.
  move: (card_lt_ltT lji ha) => ljn; move/(BintP nB): (ljn) => jb.
  case:(nds_tg2 fp jb) => // sa.
  have: inc j E by apply:Zo_i => //;apply: (BS_lt_int ljn nB).
  move/etc => he; co_tac.
split => //.
case: (Bnat_to_el iB kB) => // lki.
have aux2: forall i, i <=c k -> pS f i by move =>j jk; apply: aux; co_tac.
rewrite /pS in aux2.
have h3: sub (Bintc k) (source f).
  move => j/(BintcP kB) ja; rewrite sf; apply/(BintP nB); co_tac.
have su1: sub (image_by_fun f (Bintc k)) (Bint k).
  move => t /(Vf_image_P ff h3) [u /(BintcP kB) ul1 ->].
  by apply/(BintP kB); apply: aux2.
move: (sub_smaller su1).
rewrite(cardinal_image h3 injf) (card_Bintc kB) (card_Bint kB).
move: (card_lt_succ kB) => l1 l2; co_tac.
Qed.

Lemma nds_tg4 f i (q:= (fL f) +c i) :
  inc f (perm_int n) -> inc i Bnat -> (fL f) +c i <c n ->
  (forall j, j<c i -> pL f ((fL f) +c j)) ->
  [\/ (i = n -c k /\ forall j, j <c n -> q <=c j -> pS f j),
     pL f q |
    q <> \0c /\
    exists j, [/\ inc j Bnat, succ (q +c j) <c n,
       pL f (succ (q +c j)),
       pL f (cpred q) &
       forall z, z <=c j -> pS f (q +c z) ]].
Proof.
move => fp iB inb Hi.
move: (nds_tg3 fp) => [sa _ sb sc sd].
move/perm_intP: fp => [bf sf tf].
have ff: function f by fct_tac.
have qB: inc q Bnat by apply: BS_sum.
have kB:= (BS_lt_int kln nB).
set E1 := Zo Bnat (fun z => [/\ z <c n, pL f z & q <=c z]).
set E2:= Zo Bnat (fun z => [/\ z <c n, pL f z & z <c q]).
set E3:= (Bint n) -s (Bint k).
have: disjoint E1 E2.
    apply: disjoint_pr => u /Zo_P[_ [_ _ ha]]/Zo_P[_ [_ _ hb]]; co_tac.
move/csum2_pr5;rewrite - csum2_pr2a - csum2_pr2b => eq1.
have e2v: E2 = fun_image (Bint i) (fun z => (fL f) +c z).
  set_extens t.
    move/Zo_P => [tB [tn h tq]]; apply/funI_P.
    case: (card_le_to_el (proj31_1 sb)(proj31_1 tq)) => le1.
      move:tq; rewrite - (cdiff_pr le1) => tq.
      move /(BintP iB):(csum_lt_simplifiable sa (BS_diff (fL f) tB) iB tq).
      move => di; ex_tac.
    move: h (sd _ le1);rewrite /pL /pS => ua ub; co_tac.
  move /funI_P => [z /(BintP iB) zi ->]; apply/Zo_P.
  move: (card_lt_ltT (csum_Meqlt sa iB zi) inb) => lt1.
  move: (csum_Meqlt sa iB zi) => sf1.
  split; [ exact:(BS_lt_int lt1 nB) | by split => //; apply: Hi ].
have e3v: E1 \cup E2 = fun_image E3 (Vf (inverse_fun f)).
   set_extens t => h.
    have[ha hb]: t <c n /\ k <=c Vf f t by case/setU2_P:h => /Zo_P[_ [ha hb _]].
    have tsf: inc t (source f) by rewrite sf; apply /(BintP nB).
    have se:=(inverse_V2 bf tsf).
    apply/funI_P; exists (Vf f t); last by exact.
    apply /setC_P; split; [ Wtac | move/(BintP kB) => hh; co_tac].
  move/funI_P:h => [z /setC_P [ha hb] ->].
  have ft: inc z (target f) by ue.
  have eq2:=(inverse_V bf ft).
  have zt:= (inverse_Vis bf ft).
  rewrite sf in zt; move /(BintP nB): zt => lt1.
  have izB:= (BS_lt_int lt1 nB).
  have zB: inc z Bnat by move/(BintP nB):ha => hd; apply: (BS_lt_int hd nB).
  case: (Bnat_to_el kB zB) => zz; last by case: hb; apply /(BintP kB).
  by case: (Bnat_to_el qB izB) => lea; apply /setU2_P; [left | right];
     apply:Zo_i => //; split => //; rewrite /pL eq2.
have sjb: (bijection (Lf (card_sum2 (fL f)) (Bint i) E2)).
  apply: lf_bijective.
  + by rewrite e2v;move=> t ta; apply /funI_P; ex_tac.
  + move => u v /(BintP iB) uI /(BintP iB) vI eq.
    exact:(csum_simplifiable_left sa (BS_lt_int uI iB) (BS_lt_int vI iB)eq).
  + by rewrite e2v; move=> y /funI_P.
have sjc: (bijection (Lf(Vf (inverse_fun f)) E3 (E1 \cup E2))).
  apply: lf_bijective.
  + by rewrite e3v;move=> t ta; apply /funI_P; ex_tac.
  + move => u v /setC_P [uI _] /setC_P[vI _] eq.
    rewrite - tf in uI vI.
    by rewrite - (inverse_V bf uI) - (inverse_V bf vI) eq.
  + by rewrite e3v; move=> y /funI_P.
move: eq1.
have ->: cardinal E2 = i.
  rewrite - (card_Bint iB); symmetry;apply/card_eqP.
  exists (Lf (card_sum2 (fL f)) (Bint i) E2); split => //; aw.
have <-:n -c k = cardinal (E1 \cup E2).
  rewrite - (card_Bint nB) - (card_Bint kB).
  rewrite - (cardinal_setC4 (Bint_M1 nB (proj1 kln)) (@finite_Bint n)).
  apply/card_eqP;exists (Lf (Vf (inverse_fun f)) E3 (E1 \cup E2)).
  split => //; aw.
move => cc.
clear e2v e3v sjb sjc E2 E3.
have cE1B: inc (cardinal E1) Bnat.
   have sw: sub E1 (Bint n) by move => t /Zo_P [_ [/(BintP nB)]].
   by move: (sub_finite_set sw (@finite_Bint n)) => /BnatP.
have ci:= (CS_Bnat iB).
case: (card_le_to_ell (CS_diff n k) ci) => cink.
+ constructor 1; split; first by symmetry.
  move => j ljn lqj.
  have jsf: inc j (source f) by rewrite sf; apply /(BintP nB).
  move:(Vf_target ff jsf); rewrite tf; move/(BintP nB) => ha.
  case: (card_le_to_el (proj31_1 kln) (proj31_1 ha)) => hb; last exact.
  rewrite cink - {1} (csum0l ci) in cc.
  move:(esym(csum_simplifiable_right iB BS0 cE1B cc))=>/cardinal_nonemptyset hw.
  have jE1: inc j E1 by apply:Zo_i; [apply: (BS_lt_int ljn nB) | ].
  empty_tac1 j.
+ move: (csum_M0le (cardinal E1) ci);rewrite csumC - cc=> h; co_tac.
+ have qsf: inc q (source f) by rewrite sf;apply/(BintP nB).
  move:(Vf_target ff qsf); rewrite tf => /(BintP nB) => lt1.
  case: (card_le_to_el (CS_Bnat kB) (proj31_1 lt1)) => lt2.
    by constructor 2.
  constructor 3.
  case: (equal_or_not i \0c) => inz.
    move: sc lt2; rewrite /pL /q inz (csum0r (proj31_1 sb)) => ua ub; co_tac.
  case: (emptyset_dichot E1) => nee.
    by move: (proj2 cink); rewrite cc nee cardinal_set0 (csum0l ci).
  have seB: sub E1 Bnat by apply:Zo_S.
  move: (nth_set1 seB nee) =>[]; set j:= intersection E1 => ja jb.
  move/Zo_P: ja => [jB [ljn jc lqj]].
  have eq0:= (cdiff_pr lqj).
  case: (equal_or_not (j -c q) \0c) => eq1.
     move: jc; rewrite - eq0 eq1 (csum0r (proj31 lqj)) /pL => ha; co_tac.
  move: (cpred_pr (BS_diff _ jB) eq1)=> [].
  set m := (cpred (j -c q)) => mB mv.
  have eq4:q +c succ m = j by rewrite - mv.
  have eq2: succ (q +c m) = j by rewrite - (csum_via_succ _ mB).
  move: (cpred_pr iB inz) => [ia ib].
  have eq3: q = succ (fL f +c (cpred i)) by rewrite -(csum_via_succ _ ia) - ib.
  split; first by rewrite eq3; apply: succ_nz.
  move: (cpred_pr1 (CS_sum2 (fL f) (cpred i))); rewrite - eq3 => eq5.
  move: (card_lt_succ ia); rewrite - ib => /Hi; rewrite - eq5 => eq6.
  exists m; rewrite eq2; split => //.
  move => z /(card_lt_succ_leP mB) zm.
  move:(csum_Meqlt qB (BS_succ mB) zm); rewrite eq4 => l1.
  move: (card_lt_ltT l1 ljn) => ra.
  move: (BS_lt_int ra nB) => qzB.
  move/(BintP nB):(ra); rewrite - sf => /(Vf_target ff); rewrite tf.
  move /(BintP nB) => /proj31_1 fzn.
  case: (card_le_to_el (CS_Bnat kB) fzn) => // l2.
  have: (inc (q +c z) E1).
     apply:Zo_i => //; split => //; apply:(csum_M0le _ (CS_Bnat qB)).
  move/jb => res; co_tac.
Qed.

Lemma nds_tg5 i l f:
  inc f (perm_int n) -> inc i Bnat -> inc l Bnat ->
  (succ (succ (i +c l))) <c n ->
  pL f i ->
  (forall j, j <=c l -> pS f (succ (i+c j))) ->
  pL f (succ (succ (i +c l))) ->
  exists g, rp f g (succ i) /\ pL g (succ i).
Proof.
move => fp iB lB ltil2n p1 p2 p3.
set i1:= succ i; set il2:= succ (succ (i +c l)); set il3:= succ il2.
set il:= succ (i +c l).
rewrite -/il2 in ltil2n.
have il1B:= BS_succ (BS_sum iB lB).
have il2B:= (BS_lt_int ltil2n nB).
have il3B: inc il3 Bnat by apply:BS_succ il2B.
have i1B:= BS_succ iB.
have i2B:= BS_succ i1B.
have leil3n: il3 <=c n by apply/card_le_succ_ltP.
have lti1il2: i1 <c il2.
  rewrite /i1 /il2; apply/(card_succ_succ_ltP iB il1B).
  exact (card_le_ltT (csum_M0le l (CS_Bnat iB))(card_lt_succ (BS_sum iB lB))).
have lti1n:=(card_lt_ltT lti1il2 ltil2n).
have ltin:= (card_lt_ltT (card_lt_succ iB) lti1n).
have Ha: inc il2 (Bint n) by apply /(BintP nB).
have Hb: inc i1 (Bint n)by apply /(BintP nB).
have le1:=(card_le_succ (BS_succ iB)).
move: (transposition_prop nB Ha Hb).
set g := Lf _ _ _.
move => [gp gssi gsi ngsi ggi].
move/perm_intP: (gp) => [[[fg _] _] sg tg].
move/perm_intP: (fp) => [[[ff _] _] sf tf].
set h:= f \co g.
have fgP: f \coP g by split => //; ue.
exists h; split; last by rewrite /h /pL; aw; [ rewrite gsi | rewrite sg].
have pa: forall j, j <c succ i -> Vf f j = Vf h j.
  move => j jsi.
  have jb: inc j (Bint n) by apply /(BintP nB); co_tac.
  have jb': inc j (source g) by ue.
  have ne1:= (proj2(card_lt_ltT jsi (lti1il2))).
  by rewrite /h; aw; rewrite ngsi //; exact (proj2 jsi).
have pb: forall j, inc j (Bint n) -> il3 <=c j -> Vf f j = Vf h j.
  move => j jsi l3.
  have jb': inc j (source g) by ue.
  have lt1:= (card_lt_leT (card_lt_succ il2B) l3).
  have ne2:= (nesym (proj2 (card_lt_ltT lti1il2 lt1))).
  have ne1:= nesym(proj2 lt1).
  by rewrite /h; aw;rewrite ngsi.
have hp:= (perm_int_comp fp gp).
split; [ exact | | exact].
move: Xax => [_ _ hw hu hv].
have ax: nds_ax X n by move => z /hw h2; ord_tac.
move: (nds_b nB ax fp) (nds_b nB ax hp).
rewrite /nds_sc.
set Y:= (fun z => X (Vf f z)).
set Z:= (fun z => X (Vf h z)); move => [aY _ ] [aZ _].
move: (cdiff_pr leil3n); set m := _ -c _ => mv.
have mB: inc m Bnat by apply: (BS_diff _ nB).
rewrite - mv in aY aZ |- *.
rewrite (osum_expansionA il3B mB aY) (osum_expansionA il3B mB aZ).
apply: f_equal2.
   apply: (osum_expansion_exten mB) => z zm.
   have le2:il3 <=c z +c il3 by rewrite csumC; apply: csum_M0le; fprops.
   have le3: inc (z +c il3) (Bint n).
     by apply/(BintP nB); rewrite - mv (csumC il3); apply:csum_Mlteq.
   by rewrite /Y/Z pb.
set a := X (Vf f i); set b := X(Vf f i1); set c:= X(Vf f il2).
have il2sg: inc il2 (source g) by ue.
have i1sg: inc i1 (source g) by ue.
have ib: inc i (Bint n) by apply /(BintP nB).
have ig: inc i (source g) by ue.
rewrite 2! (osum_expansion_succ _ il2B).
rewrite {1} /Z {1}/Y /h (compf_V fgP il2sg) gssi -/b -/c.
have le2: succ (succ i) <=c il2.
  apply/(card_le_succ_succP (CS_succ i) (CS_succ ((i +c l)))).
  apply/(card_le_succ_succP (CS_Bnat iB) (CS_sum2 i l)).
  apply: (csum_M0le _ (CS_Bnat iB)).
move: (cdiff_pr le2); set m1 := _ -c _ => m1v.
have m1B: inc m1 Bnat by apply: (BS_diff _ il2B).
rewrite mv in aY aZ.
have aY': nds_ax Y (succ (succ i) +c m1).
  move => z; rewrite m1v => l1; apply: aY; co_tac.
have aZ': nds_ax Z (succ (succ i) +c m1).
  move => z; rewrite m1v => l1; apply: aZ; co_tac.
have ha:= card_lt_succ iB.
have hb:= (proj2 (card_lt_ltT ha lti1il2)).
rewrite - m1v (osum_expansionA i2B m1B aY') (osum_expansionA i2B m1B aZ').
rewrite 2! (osum_expansion_succ _ i1B) 2! (osum_expansion_succ _ iB).
rewrite {2 3} /Y {2 3} /Z /h (compf_V fgP ig)(compf_V fgP i1sg).
rewrite gsi (ngsi _ ib hb (proj2 ha)) -/a -/b -/c.
set A:= osum_expansion _ m1.
set B:= osum_expansion _ i.
have <-: A = (osum_expansion (fun z : Set => Z (z +c succ (succ i))) m1).
  apply: (osum_expansion_exten m1B) => j lej.
  have [_ /nesym ltb]:i1 <c j +c succ (succ i).
     apply/(card_le_succ_ltP _ i1B); rewrite csumC; apply:csum_M0le; fprops.
  have lta: j +c succ (succ i) <c il2.
     rewrite - m1v (csumC _ m1); exact: (csum_Mlteq i2B m1B lej).
  have hc: inc (j +c succ (succ i)) (source g).
    rewrite sg; apply/(BintP nB); rewrite - mv /il3 - m1v.
    rewrite (csum_via_succ1 _ (BS_sum i2B m1B)) (csumC _ m1).
    apply: (card_lt_ltT lta); rewrite (csumC m1) m1v.
    apply /(card_lt_succ_leP (BS_sum il2B mB)) /csum_M0le; fprops.
  by rewrite /Y/Z /h (compf_V fgP hc) (ngsi _ _ (proj2 lta) ltb) // - sg.
have <-: B = osum_expansion Z i.
  apply: (osum_expansion_exten iB) => j lej; rewrite /Y/Z pa //; co_tac.
have oA: ordinalp A.
   apply: (OS_osum_expansion m1B) => j jl1; apply: aY'.
   rewrite (csumC _ m1); exact:(csum_Mlteq i2B m1B jl1).
have oB: ordinalp B.
   apply: (OS_osum_expansion iB) => j jl1; apply: aY; co_tac.
have fis: Vf f i <c n by apply/(BintP nB); Wtac.
have fil2s: Vf f il2 <c n by apply/(BintP nB); Wtac.
have fi1s: Vf f i1 <c n by apply/(BintP nB); Wtac.
have da:= (hv _ p1 fis).
have dc:= (hv _ p3 fil2s); rewrite -/c in dc.
move: (hu _(p2 _ (czero_least (CS_Bnat lB)))).
rewrite (csum0r (CS_Bnat iB)); rewrite -/b => db.
have d1a: the_CNF_degree b <o the_CNF_degree a by ue.
have d1c: the_CNF_degree b <o the_CNF_degree c by ue.
move: (hw _ fis) (hw _ fil2s)(hw _ fi1s); rewrite -/a -/b -/c => ap cp bp.
move: (proj32_1 ap)(proj32_1 bp)(proj32_1 cp) => oa ob oc.
have hc: l +c (succ (succ i)) = il2.
  by rewrite csumC (csum_via_succ1 _ i1B) (csum_via_succ1 _ iB).
have [eq1 eq2]: (A +o a = a /\ A +o c = c).
  have: m1 <=c l.
   apply:(csum_le_simplifiable i2B m1B lB).
   rewrite m1v (csumC _ l) hc; apply:card_leR; fprops.
  rewrite /A; move:m1B; move:(m1); apply: cardinal_c_induction.
    by move => _; rewrite osum_expansion0 (osum0l oa) (osum0l oc).
  move => q qB Hrec sql.
  have ql:= (card_leT (card_le_succ qB) sql).
  move:(Hrec ql) => [eqa eqb].
  set d := (Y (q +c succ (succ i))).
  have oD: ordinalp (osum_expansion (fun z => Y (z +c succ (succ i))) q).
    apply: (OS_osum_expansion qB) => j jlt; apply:aY.
    have jlt1:=(card_lt_leT jlt ql).
    move:(csum_Mlteq i2B lB jlt1); rewrite hc => hd; co_tac.
  have ql': q <c l by apply/(card_le_succ_ltP _ qB).
  have lt2: q +c succ (succ i) <c n.
     move:(csum_Mlteq i2B lB ql'); rewrite hc => hd; co_tac.
  have lt3: Vf f (q +c succ (succ i)) <c k.
    have eq3: q +c (succ (succ i)) = succ (i +c (succ q)).
      rewrite (csum_via_succ _ i1B) csumC.
      by rewrite (csum_via_succ1 _ iB) (csum_via_succ _ qB).
    by move: (p2 _ sql); rewrite - eq3.
  move: (hu _ lt3); rewrite -/(Y _ ) -/d => dd.
 have dp: \0o <o d.
    by apply: hw; apply /(BintP nB); Wtac; rewrite sf;apply /(BintP nB).
  have ot:= proj32_1 dp.
  have d2a: the_CNF_degree d <o the_CNF_degree a by ue.
  have d2c: the_CNF_degree d <o the_CNF_degree c by ue.
  rewrite !(osum_expansion_succ _ qB) - (osumA ot oD oa) eqa.
  rewrite - (osumA ot oD oc) eqb (ord_negl_p7 dp ap d2a).
  by rewrite (ord_negl_p7 dp cp d2c).
rewrite (osumA ob oa oB) (ord_negl_p7 bp ap d1a) (osumA oA oa oB) eq1.
rewrite (osumA oc oa oB) (osumA oA (OS_sum2 oc oa) oB) (osumA oA oc oa) eq2.
rewrite (osumA ob (OS_sum2 oc oa) oB) (osumA ob oc oa) (ord_negl_p7 bp cp d1c).
done.
Qed.

Lemma nds_tg6 f:
  inc f (perm_int n) -> exists g,
  [/\ inc g (perm_int n), nds_sc n X f = nds_sc n X g,
      fL f = fL g &
      forall i, i<c n -c k -> pL g ((fL g) +c i) ].
Proof.
move => fp.
move: (BS_diff k nB) (card_leR (CS_diff n k)).
move:{1 2 4} (n -c k); apply: cardinal_c_induction.
  by move => _; exists f; split => // i /card_lt0.
move => q qB Hrec le1.
move:(card_le_succ qB) => le2.
move: (Hrec (card_leT le2 le1)) => [g [ga gb gc gd]].
move: (nds_tg3 ga) => [aa ab ac ad ae].
have kB:= (BS_lt_int kln nB).
move: (csum_Meqlt kB (BS_diff k nB) (card_lt_leT (card_lt_succ qB) le1)).
rewrite (cdiff_pr (proj1 kln))=> lt2.
move: (card_le_ltT (csum_Mleeq q ab) lt2) => lt3.
case:(nds_tg4 ga qB lt3 gd).
+ move => [ua _]; move: le1 (card_lt_succ qB); rewrite - ua => sa sb; co_tac.
+ move => h; exists g; split; [ exact | exact| exact | ].
  move => j; move/(card_lt_succ_leP qB) => ljq.
  case: (equal_or_not j q) => ejq; [ ue | by apply: gd].
set q1:= fL g +c q.
move => [q1p [ j [jB ja jb jc jd]]].
move: (cpred_pr (BS_sum aa qB) q1p); rewrite -/q1; move=> [je ef].
have eg:=(csum_via_succ1 j je).
have sa: succ (succ (cpred q1 +c j)) <c n by rewrite -eg - ef.
have sc: pL g (succ (succ (cpred q1 +c j))) by rewrite -eg - ef.
have sb: (forall j0 : Set, j0 <=c j -> pS g (succ (cpred q1 +c j0))).
  by move => j1 jl1; rewrite -(csum_via_succ1 _ je) - ef; apply: jd.
move:(nds_tg5 ga je jB sa jc sb sc).
move => [g1 [[r1 r2 r3] r4]].
rewrite -ef in r3 r4.
have sw: fL g = fL g1.
  move: (nds_tg3 r1) => [aa' _ _ ad' ae'].
  have af: fL g <=c q1 by apply /csum_M0le; fprops.
  have q1B: inc q1 Bnat by move:(BS_succ je); rewrite - ef.
  case: (Bnat_to_el aa' q1B) => ag; last first.
    move:(ae' _ ag) r4; rewrite /pS/pL => l1 l2; co_tac.
  case:(Bnat_to_ell aa aa') => l3.
  + exact.
  + move: (ae' _ l3) ad; rewrite /pL/pS (r3 _ (card_lt_leT l3 ag)).
    move => l1 l2; co_tac.
  + move: (ae _ l3) ad'; rewrite /pL/pS (r3 _ (card_lt_leT l3 af)).
    move => l1 l2; co_tac.
exists g1;split; [exact | ue| by rewrite gc | ].
move => i /(card_lt_succ_leP qB) isa; rewrite - sw.
case:(equal_or_not i q) => eqi; first by rewrite eqi.
move: (csum_Meqlt aa qB (conj isa eqi));rewrite /pL => /r3 <-.
apply: (gd _ (conj isa eqi)).
Qed.

Lemma nds_tg7 f:
  inc f (perm_int n) -> exists K s1 s2,
  [/\ sub K (Bint k), inc s1 (perm_int (cardinal K)),
     inc s2 (perm_int (n -c k)) &
     nds_sc n X f = nds_sc (n-c k) (fun z => X (k +c z)) s2 +o
       nds_sc (cardinal K) (fun z => X (nth_elt K z)) s1].
Proof.
move/nds_tg6 => [g [gp -> _ p1]].
move:(nds_tg3 gp) => [qB p2 p3 p4 p5].
move/perm_intP:gp =>[[injg [fg sjg]] sg tg].
rewrite sg tg in sjg.
set q := (fL g); rewrite -/q in qB p1 p2 p3 p4 p5.
have nkB:=(BS_diff k nB).
have le3 := (cdiff_pr3 nB p2 (proj1 kln)).
have eq2:=(cdiff_pr (proj1 p3)).
have eq3:=(cdiff_pr le3).
have eq4:=(cdiff_pr (proj1 kln)).
have nqB:= (BS_diff q nB).
have qnkB:= (BS_sum qB nkB).
have kB:= (BS_lt_int kln nB).
have lt1: q +c (n -c k) <=c n.
  move: (csum_Mleeq n p2); rewrite - {1} eq4 (csumC k) csumA (csumC _ k).
  by move/(csum_le_simplifiable kB qnkB nB).
set E := Bint q.
move: (Bint_M1 nB (proj1 p3)); rewrite - {1} sg => sK.
move: (cardinal_image sK injg);set K := image_by_fun g (Bint q).
rewrite (card_Bint qB) => cK.
have iKP: forall i, inc i K <-> exists2 j, inc j E & i = Vf g j.
  move => i; split; by move /(Vf_image_P fg sK).
have h0:sub K (Bint k).
 by move => t /iKP [j jE ->]; apply/(BintP kB); apply: p5; apply/(BintP qB).
set E1:= Bint (q +c (n -c k)) -s E.
set K1 := image_by_fun g E1.
have sK1: sub E1 (source g).
  move => t /setC_P [/(BintP qnkB) ha _]; rewrite sg; apply/(BintP nB);co_tac.
have iK1P: forall i, inc i K1 <-> exists2 j, inc j E1 & i = Vf g j.
  move => i; split; by move /(Vf_image_P fg sK1).
have cK1: cardinal K1 = n -c k.
  move: (cardinal_image sK1 injg); rewrite -/K1.
  have ha:=(Bint_M1 qnkB (csum_M0le (n-c k) (CS_Bnat qB))).
  rewrite (cardinal_setC4 ha (finite_Bint (q +c (n -c k)))).
  by rewrite (card_Bint qnkB) (card_Bint qB) csumC (cdiff_pr1 nkB qB).
have sK1': sub K1 ((Bint n) -s (Bint k)).
  move => t/iK1P [j ja ->]; apply/setC_P; split.
    by move: (Vf_target fg (sK1 _ ja)); rewrite tg.
  have jB: inc j Bnat.
    move:(sK1 j ja); rewrite sg => /(BintP nB) lj; exact(BS_lt_int lj nB).
  move/setC_P:ja => [/(BintP qnkB) ja jb]; dneg h.
  case: (card_le_to_el (CS_Bnat qB) (proj31_1 ja)); last by move/(BintP qB).
  move => le1; move:(cdiff_pr le1) => eqa.
  rewrite - eqa in ja.
  move:(csum_lt_simplifiable qB (BS_diff q jB) nkB ja) => jc.
  move: (p1 _ jc); rewrite eqa /pL => jd.
  move/(BintP kB):h => je; co_tac.
case: (equal_or_not K1 (Bint n -s Bint k))=> eq5; last first.
  move: (Bint_M1 nB (proj1 kln)) (finite_Bint n) => s1 fn.
  move: (sub_finite_set (@sub_setC (Bint n) (Bint k)) fn) => ha.
  move:(proj2 (strict_sub_smaller (conj sK1' eq5) ha)).
  by rewrite (cardinal_setC4 s1 fn) (card_Bint kB) (card_Bint nB) cK1.
have p6: forall i, i<c n -> q +c (n -c k) <=c i -> pS g i.
   move => i li1 li2; rewrite /pS; ex_middle h.
   have isn: inc i (source g) by rewrite sg; apply/(BintP nB).
   have: inc (Vf g i) K1.
      rewrite eq5; apply/setC_P; split; [Wtac | by move/(BintP kB)].
  move/(iK1P) => [j /setC_P [/(BintP qnkB) ja jb] eqa].
  have jsg: inc j (source g).
    by move: (card_lt_ltT (card_lt_leT ja li2) li1) => /(BintP nB); rewrite sg.
  move: ((proj2 injg) i j isn jsg eqa) => eij; rewrite - eij in ja; co_tac.
have sKb: sub K (Bint n) by move => t /iKP [ u /sK usf ->]; Wtac.
have sKB:=(sub_trans sKb (@Bint_S1 n)).
have fsK:=(sub_finite_set sKb (finite_Bint n)).
move:(nth_set_fct_bf sKB fsK).
set FK:= (nth_set_fct K); move => [pa pb].
have sFK: source FK = E by rewrite /FK/nth_set_fct cK; aw.
have tFK: target FK = K by rewrite /FK/nth_set_fct; aw.
have ax2: lf_axiom (nth_elt K) (Bint q) K.
  move => t /(BintP qB) lt2; move:(lt2); rewrite - cK => lt3.
  by move:(nth_set7 (BS_lt_int lt2 qB) sKB lt3) => [/setC_P []].
pose s1' i := (Vf (inverse_fun FK) (Vf g i)).
have ax1: lf_axiom s1' E E.
  move => t ta;rewrite - sFK; apply:(inverse_Vis pa); rewrite tFK.
  by apply iKP; exists t.
have pc: forall i, inc i E -> Vf FK (s1' i) = Vf g i.
  move => i iE; rewrite /s1' (inverse_V pa) // tFK; apply/iKP; ex_tac.
set s1 := Lf s1' E E.
have s1fb: bijection s1.
   apply:lf_bijective; first by exact.
      move => u v uE vE eq6.
      move: (f_equal (Vf FK) eq6); rewrite (pc _ uE) (pc _ vE) => eq7.
      exact: (proj2 injg _ _ (sK _ uE) (sK _ vE) eq7).
   rewrite - sFK;move => y ye.
   move: (Vf_target (proj1(proj1 pa)) ye); rewrite tFK => /iKP [u us eq1].
   by rewrite - sFK in us; ex_tac; rewrite /s1'- eq1 (inverse_V2 pa ye).
have s1perm: inc s1 (perm_int q).
  apply/perm_intP; rewrite /s1; split; aw.
set Ec:= Bint (n -c k).
pose s2' z := (Vf g (q +c z) -c k).
have pd1: forall z, z <c n -c k -> inc (q +c z) (source g).
  move => z zi.
  move:(csum_Meqlt qB (BS_diff q nB) (card_lt_leT zi le3)).
  by rewrite eq2 => /(BintP nB);rewrite - sg => ha.
have ax3: lf_axiom s2' Ec Ec.
  move => z /(BintP nkB) zi.
  move: (Vf_target fg (pd1 _ zi)); rewrite tg => /(BintP nB) lt2.
  rewrite -/q - cK in lt2.
  move:(p1 _ zi);rewrite /pL /s2' - cK=> fzi.
  apply/(BintP nkB); exact(cdiff_pr7 fzi lt2 nB).
have pd: forall z, z <c n -c k -> (s2' z) +c k = Vf g (q +c z).
  move => z /p1;rewrite /pL /s2' - cK=> fzi.
  by rewrite csumC; apply:cdiff_pr.
set s2 := Lf s2' Ec Ec.
have s2fb: bijection s2.
  apply:bijective_if_same_finite_c_inj.
  + rewrite /s2; aw.
  + rewrite /s2/Ec; aw; apply:finite_Bint.
  + apply: lf_injective => // u v /(BintP nkB) ue /(BintP nkB) ve eq.
    move: (f_equal (fun z => z +c k) eq).
    rewrite (pd _ ue) (pd _ ve) => eq7.
    move:(proj2 injg _ _ (pd1 _ ue)(pd1 _ ve) eq7).
    exact:(csum_simplifiable_left qB (BS_lt_int ue nkB) (BS_lt_int ve nkB)).
have s2perm: inc s2 (perm_int (n -c k)).
  apply/perm_intP; rewrite /s2; split; aw.
exists K, s1, s2; rewrite cK;split => //.
set X1:=osum_expansion (fun z => X (nth_elt K (Vf s1 z))) q.
have r1: X1 = osum_expansion (fun z => X (Vf g z)) q.
  apply: (osum_expansion_exten qB) => i /(BintP qB) iE.
  have vK: inc (Vf g i) (target FK) by rewrite tFK;apply/iKP; ex_tac.
  rewrite /s1/s1'; aw; rewrite -{2} (inverse_V pa vK) {2} /FK/nth_set_fct cK.
  aw; rewrite -/E - sFK; apply: (inverse_Vis pa vK).
set X2:= osum_expansion (fun z=> X (Vf g (z +c q))) (n -c k).
have r2: X2 = osum_expansion (fun z => X (k +c Vf s2 z)) (n -c k).
   apply:(osum_expansion_exten nkB).
   move => z znk /=;rewrite (csumC z) (csumC k) - (pd _ znk) /s2; aw.
   by apply/(BintP nkB).
move: Xax => [_ oe hw hu hv].
have aX: nds_ax (fun z => X (Vf g z)) n.
   move => z /(BintP nB) zi.
   rewrite - sg in zi.
   move:(Vf_target fg zi); rewrite tg => /(BintP nB) /hw h; ord_tac.
have aX2: ord_below_n (fun z=> X (Vf g (z +c q))) (n -c q).
  move=> z zle1; apply: aX; move: (csum_Mlteq qB nqB zle1).
  by rewrite (csumC (_ -c _)) eq2.
rewrite /nds_sc - {1} eq2;rewrite - eq2 in aX. rewrite - eq3 in aX2.
rewrite (osum_expansionA qB nqB aX) -/X1 - r1 - eq3.
rewrite (osum_expansionA nkB (BS_diff (n -c k) nqB) aX2) - r2;congr (_ +o X1).
have knz1:= (cdiff_nz kln).
move: (cpred_pr nkB knz1) => [nk1B nk1v].
rewrite /X2 nk1v (osum_expansion_succ _ nk1B).
set X3:= osum_expansion _ _.
set X4:= osum_expansion _ _.
set a := X _.
move:(card_lt_succ nk1B); rewrite -nk1v => /p1; rewrite /pL csumC => le1.
have lt2: inc ((cpred (n -c k) +c q)) (source g).
   rewrite csumC;apply/pd1; rewrite {2} nk1v; apply:(card_lt_succ nk1B).
have lt3: Vf g (cpred (n -c k) +c q) <c n by apply/(BintP nB); Wtac.
move: (hw _ lt3) (hv _ le1 lt3); rewrite -/a => ap da.
have oa: ordinalp a by ord_tac.
have oX4: ordinalp X4.
  apply:(OS_osum_expansion nk1B) => t ta;apply: aX2.
  move: (card_lt_leT ta (card_le_succ nk1B)); rewrite - nk1v => sa.
  move: (csum_M0le ((n -c q) -c (n -c k)) (CS_Bnat nkB)) => sb;co_tac.
set wa:=((n -c q) -c succ (cpred (n -c k))).
have wB: inc wa Bnat by rewrite /wa; fprops.
have wa1: (wa +c (n -c k)) = (n -c q).
  by rewrite /wa -nk1v (csumC (_ -c _)) cdiff_pr.
have oX3: ordinalp X3.
  apply:(OS_osum_expansion wB) => z zw;apply: aX2;rewrite eq3.
  by move: (csum_Mlteq nkB wB zw); rewrite -nk1v wa1.
rewrite (osumA oX3 oa oX4); congr (_ +o X4).
rewrite /X3 -/wa - nk1v.
have eq7: ((wa +c (n -c k)) +c q) = n by rewrite wa1 csumC eq2//.
have: wa +c ((n -c k) +c q) <=c n by rewrite csumA eq7; fprops.
clear eq7 wa1.
move: wa wB; apply: cardinal_c_induction.
  by move => _ ; rewrite osum_expansion0 (osum0l oa).
move=> j jB Hrec.
have sB:= BS_sum jB (BS_sum nkB qB).
rewrite (csum_via_succ1 _ jB) => /(card_le_succ_ltP _ sB) ha.
have oS: ordinalp (osum_expansion (fun z => X (Vf g ((z +c (n -c k))
      +c q))) j).
  apply:(OS_osum_expansion jB) => z zl; apply:aX2;rewrite eq3.
  move:(csum_Mlteq nkB jB zl) => hc.
  move:(csum_M0le (j +c (n -c k)) (CS_Bnat qB)); rewrite csumC => hd.
  rewrite csumA in ha; move: (cdiff_pr7 hd ha nB).
  rewrite (cdiff_pr1 (BS_sum jB nkB) qB) => he; co_tac.
rewrite (osum_expansion_succ _ jB) - csumA.
set j0 := j +c ((n -c k) +c q).
have j0b: inc j0 (source g) by rewrite sg; apply/(BintP nB).
rewrite -/j0 in ha.
have hb:q +c (n -c k) <=c j0.
  rewrite /j0 csumC (csumC j); apply:csum_M0le; fprops.
move:(Vf_target fg j0b); rewrite tg => /(BintP nB) => hc.
have ofp:= hw _ hc.
have oft:= proj32_1 ofp.
rewrite - (osumA oft oS oa) (Hrec (proj1 ha)).
move: (hu _ (p6 _ ha hb)) => hd.
rewrite - hd in da; exact: (ord_negl_p7 ofp ap da).
Qed.

Lemma nds_tg8 v (X2:= (fun z => X (k +c z))):
  inc v (nds_sums n X) ->
  exists v1 v2, [/\ inc v1 (nds_tn_S X k), inc v2 (nds_sums (n -c k) X2) &
   v = v2 +o v1].
Proof.
move => /funI_P [z zp ->].
move: (nds_tg7 zp) => [K [s1 [s2 [/setP_P pa pb pc ->]]]].
set v1:=nds_sc (cardinal K) (fun z0 => X (nth_elt K z0)) s1.
set v2:=nds_sc (n -c k) (fun z => X (k +c z)) s2.
have v2p:inc v2 (nds_sums (n -c k) X2) by apply/funI_P; ex_tac.
exists v1, v2; split => //;apply/setUf_P; ex_tac; apply/funI_P; ex_tac.
Qed.

Lemma nds_tg9 (X2:= (fun z => X (k +c z))):
  (nds_sums n X) =
     unionf (nds_tn_S X k) (fun v1 => fun_image (nds_sums (n -c k) X2)
         (fun v2 => v2 +o v1)).
Proof.
set_extens v.
  move /nds_tg8 => [v1 [v2 [va vb vc]]].
  apply/setUf_P; ex_tac; apply/funI_P; ex_tac.
move/setUf_P => [v1 /setUf_P [K /setP_P Kp/funI_P [s1 s1p va]]].
move => /funI_P [v2 /funI_P [s2 s2p ->]] => ->; rewrite va; apply/funI_P.
set K' := (Bint k) -s K.
set q := cardinal K.
have kB:=(BS_lt_int kln nB).
move:(sub_smaller Kp); rewrite (card_Bint kB); rewrite -/q => leqk.
have lqn:=(card_le_ltT leqk kln).
have qB:= BS_lt_int lqn nB.
have nkB:=(BS_diff k nB).
have qnB:= (BS_sum qB nkB).
have sKB: sub K Bnat by move => t /Kp /Bint_S1.
have sK'B: sub K' Bnat by move => t /setC_P [] /Bint_S1.
have cK': cardinal K' = k -c q.
  have fsk:finite_set (Bint k) by apply /BnatP; rewrite (card_Bint kB).
  by rewrite (cardinal_setC4 Kp fsk) (card_Bint kB).
have qqn:=(Bsum_M0le qB nkB).
have kqB:= (BS_diff q kB).
have fK: finite_set K by apply/BnatP.
have fK': finite_set K' by apply/BnatP; rewrite cK'.
have knk:=(cdiff_pr (proj1 kln)).
set qn := q +c (n -c k); rewrite -/qn in qnB qqn.
have qnkq: qn +c (k-c q) = n.
  by rewrite -knk /qn (csumC q) - csumA (cdiff_pr leqk) csumC.
have lqnn: qn <=c n by rewrite - qnkq; apply:(Bsum_M0le qnB kqB).
have sBkBn:=(Bint_M1 nB (proj1 kln)).
move/perm_intP: (s1p) => [bs1 ss1 ts1]; move: (proj1(proj1 bs1)) => fs1.
move/perm_intP: (s2p) => [bs2 ss2 ts2]; move: (proj1(proj1 bs2)) => fs2.
pose s i := Yo (i <c q) (nth_elt K (Vf s1 i))
     (Yo (i <c qn) (Vf s2 (i -c q) +c k) (nth_elt K' (i -c qn))).
have pa: forall i, i<c q -> s i = (nth_elt K (Vf s1 i)).
   by move => i liq; rewrite /s; Ytac0.
have pb: forall i, i<c q -> inc (s i) K.
   move => i iq; rewrite (pa _ iq).
   have p1: inc (Vf s1 i) (Bint q) by Wtac; rewrite ss1; apply/(BintP qB).
   by apply: (nth_set9 (Bint_S1 p1) sKB); apply /(BintP qB).
have pc: forall i, qn <=c i -> s i = (nth_elt K' (i -c qn)).
   rewrite /s => i le1;Ytac h; first by move:(card_le_ltT le1 h) => h'; co_tac.
   Ytac h' => //; co_tac.
have pd: forall i, qn <=c i -> i <c n -> inc (s i) K'.
  move => i l1 l2; rewrite (pc _ l1); move:(BS_lt_int l2 nB) => iB.
  apply:(nth_set9 (BS_diff qn iB) sK'B); rewrite cK'.
  by apply:(cdiff_increasing3 kqB iB l1); rewrite csumC qnkq.
have pe: forall i, q <=c i -> i <c qn -> s i = (Vf s2 (i -c q) +c k).
  move => i l1 l2; rewrite /s; Ytac0; Ytac h => //; co_tac.
have pf: forall i, q <=c i -> i <c qn ->
  [/\ s i = (Vf s2 (i -c q) +c k), inc (Vf s2 (i -c q)) (Bint (n -c k)) &
   inc (s i) ((Bint n) -s (Bint k))].
  move => i l1 l2; rewrite (pe i l1 l2).
  have iB:= BS_lt_int l2 qnB.
  rewrite - {1}(cdiff_pr l1) /qn in l2.
  have sa:= (csum_lt_simplifiable qB (BS_diff q iB) nkB l2).
  have sb: inc (Vf s2 (i -c q)) (Bint (n -c k)).
    by Wtac; rewrite ss2; apply/BintP.
  move/(BintP nkB):(sb) => sc.
  move:(csum_Mlteq kB nkB sc); rewrite (csumC (n -c k)) knk => sd.
  split => //; apply/setC_P; split; first by apply /(BintP nB).
  move/(BintP kB); move:(csum_M0le (Vf s2 (i -c q)) (CS_Bnat kB)).
  rewrite csumC => ua ub; co_tac.
have ax: forall i, inc i (Bint n) -> inc (s i) (Bint n).
  move => i /(BintP nB) lin.
  case: (card_le_to_el (CS_Bnat qB) (proj31_1 lin)) => le1.
    case: (card_le_to_el (CS_Bnat qnB) (proj31_1 lin)) => le2.
      by move: (pd i le2 lin) => /setC_P [/sBkBn ha _].
    by move:(pf _ le1 le2) =>[_ _ /setC_P []].
  by move: (pb i le1) => /Kp /sBkBn.
have sjs: forall j, inc j (Bint n) -> exists2 i, inc i (Bint n) & j = s i.
  move => j /(BintP nB) ljn.
  have jB:= (BS_lt_int ljn nB).
  case:(card_le_to_el (CS_Bnat kB) (proj31_1 ljn)) => lkj.
    have l1: (j -c k) <c (n-c k).
      rewrite - (cdiff_pr lkj) - knk in ljn.
      exact: (csum_lt_simplifiable kB (BS_diff k jB) nkB ljn).
    move: (perm_int_surj nkB s2p l1) => [i1 l2 iv].
    have i1B := BS_lt_int l2 nkB.
    have l3:=(csum_Meqlt qB nkB l2).
    move:(proj31 (pf _ (csum_M0le i1 (CS_Bnat qB)) l3)).
    rewrite {2} csumC (cdiff_pr1 i1B qB) iv (csumC _ k) (cdiff_pr lkj) => <-.
    exists (q +c i1) => //; apply/(BintP nB); co_tac.
  case: (inc_or_not j K) => jK.
      move:(nth_set_10 sKB fK jK) => [i ia ->].
      move:(perm_int_surj qB s1p ia) => [i1 ib <-].
      rewrite - (pa _ ib); exists i1 => //; apply/(BintP nB); co_tac.
  have jK': inc j K' by apply/setC_P; split => //; apply/(BintP kB).
  move:(nth_set_10 sK'B fK' jK') => [i ia ->].
  rewrite cK' in ia.
  move: (csum_Meqlt qnB kqB ia); rewrite qnkq => /(BintP nB) ic; ex_tac.
  rewrite (pc _ (csum_M0le i (CS_Bnat qnB))) csumC cdiff_pr1 //.
  apply:(BS_lt_int ia kqB).
set sigma := Lf s (Bint n) (Bint n).
have sp: inc sigma (perm_int n).
   rewrite /sigma; apply/perm_intP; aw; split => //.
   apply:bijective_if_same_finite_c_surj; aw; first by apply:finite_Bint.
   by apply: lf_surjective.
ex_tac.
move: Xax => [qa qb qc qd qe].
have: ord_below_n (fun z => X (Vf sigma z)) n.
  rewrite /sigma;move => y /(BintP nB) ys; aw.
  by move:(ax _ ys) => /(BintP nB) /qc [[]].
rewrite /nds_sc - {1 3}qnkq => ax2.
have ax3: ord_below_n (fun z=> X (Vf sigma z)) (q +c (n -c k)).
 by move => z z1; apply: ax2; rewrite qnkq; co_tac.
rewrite (osum_expansionA qnB kqB ax2) (osum_expansionA qB nkB ax3).
set A := osum_expansion _ _.
set B := osum_expansion _ _.
set C' := osum_expansion _ _.
set A' := osum_expansion _ _.
set B' := osum_expansion _ _.
have ea: A = A'.
  apply: (osum_expansion_exten nkB) => i l1.
  have iB:= BS_lt_int l1 nkB.
  move: (csum_Mlteq qB nkB l1) ; rewrite (csumC (n -c k))- /qn => l2.
  have ha: inc (i +c q) (Bint n) by apply /(BintP nB); co_tac.
  move:(csum_M0le i (CS_Bnat qB)); rewrite csumC => hb.
  by rewrite /sigma; aw; rewrite (pe _ hb l2) /X2 csumC cdiff_pr1.
have eb: B = B'.
  apply: (osum_expansion_exten qB) => i l1.
  have ib:inc i (Bint n) by apply /(BintP nB); co_tac.
   by rewrite /sigma; aw; rewrite - ( pa _ l1).
have oa: ordinalp A'.
   apply:(OS_osum_expansion nkB) => i l1; apply: ax3.
   by move: (csum_Mlteq qB nkB l1);rewrite (csumC q).
have ob: ordinalp B'.
   apply:(OS_osum_expansion qB) => i l1; apply: ax2; rewrite qnkq; co_tac.
have oc: ordinalp C'.
   apply:(OS_osum_expansion kqB) => i l1; apply: ax2.
   by rewrite (csumC qn);apply:csum_Mlteq.
rewrite (osumA oc oa ob) - ea; apply: (f_equal2 _ _ eb).
have knz1:= (cdiff_nz kln).
move: (cpred_pr nkB knz1) => [nk1B nk1v].
rewrite /A nk1v (osum_expansion_succ _ nk1B) /X2.
set C:= osum_expansion _ _ .
move: (card_lt_succ nk1B); rewrite - nk1v => eq1.
have oc': ordinalp C.
  apply:(OS_osum_expansion nk1B) => i lin.
  have ha:inc i (source s2) by rewrite ss2; apply/(BintP nkB); co_tac.
  move:(Vf_target fs2 ha); rewrite ts2 => /(BintP nkB) lt1.
  by move:(csum_Meqlt kB nkB lt1); rewrite knk => /qc /proj32_1.
have ha:inc (cpred (n -c k)) (source s2).
   by rewrite ss2; apply/(BintP nkB); rewrite {2} nk1v; apply: card_lt_succ.
move:(Vf_target fs2 ha); rewrite ts2 => /(BintP nkB) lt1.
move:(csum_Meqlt kB nkB lt1); rewrite knk => hb.
move:(csum_M0le (Vf s2 (cpred (n -c k))) (CS_Bnat kB)) => hc.
move: (qc _ hb) (qe _ hc hb);set a:= X _ => ap da.
rewrite (osumA oc (proj32_1 ap) oc'); congr (_ +o C).
rewrite /C'.
have hd: forall i, i<c k -c q -> (Vf sigma (i +c qn)) <c k.
  move => i lik.
  move:(csum_Meqlt qnB kqB lik); rewrite qnkq => l1.
  move: (csum_M0le i(CS_Bnat qnB)) => l2.
  move/(BintP nB):(l1) => iB.
  by rewrite csumC /sigma; aw; move: (pd _ l2 l1) => /setC_P []/(BintP kB).
have he: forall i, i<c k -c q -> let b := X (Vf sigma (i +c qn)) in
  [/\ ordinalp b, \0o <o b & the_CNF_degree b = e].
  move => i l1; move:(hd _ l1) => sa.
  move:(qd _ sa) (qc _ (card_lt_ltT sa kln)) => r1 r2.
  split; [exact (proj32_1 r2) | exact r2| exact r1].
symmetry.
move:kqB (card_leR (CS_Bnat kqB)).
have oa':=(proj32_1 ap).
move: {-3} (k -c q); apply: cardinal_c_induction.
  by rewrite osum_expansion0 (osum0l oa').
move => i iB Hrec le1.
rewrite (osum_expansion_succ _ iB).
move/(card_le_succ_ltP _ iB): (le1) => /he [].
set b := (X (Vf sigma (i +c qn))) => ob' bp db.
have ikq:=(card_leT (card_le_succ iB) le1).
have oc'':ordinalp (osum_expansion (fun z : Set => X (Vf sigma (z +c qn))) i).
   apply: (OS_osum_expansion iB) => j jli.
   by move: (he _ (card_lt_leT jli ikq)) => [].
rewrite - db in da.
rewrite - (osumA ob' oc'' oa').
by rewrite (Hrec ikq) (ord_negl_p7 bp ap da).
Qed.

Lemma nds_tg10 : nds_card n X <=c (ndstnC k) *c (nds_F (n -c k)).
Proof.
rewrite /nds_card nds_tg9.
set F:= (fun v1 : Set => _).
set E := (nds_tn_S X k).
move:(csum_pr1_bis E F).
set g1:= (Lg E (fun a => cardinal (Vg (Lg E F) a))).
have <-: card_sum g1 = card_sumb E (fun a => cardinal (F a)).
  rewrite /card_sumb;apply:f_equal;apply:Lg_exten => t tx; bw.
set g2 := cst_graph E (nds_F (n -c k)).
have sd: domain g1 = domain g2 by rewrite /g1/g2; bw.
have kB:= BS_lt_int kln nB.
have nkB:= (BS_diff k nB).
move: (nds_j nkB) => [pe _ pf pg].
move: Xax => [pa pb pc pd _].
suff le1:forall x, inc x (domain g1) -> Vg g1 x <=c Vg g2 x.
  move:(csum_increasing sd le1).
  rewrite csum_of_same cprodC - cprod2_pr2a /E -/(nds_tn_C _ _) => ha hb.
  have kp: \0c <c k by split; fprops.
  have ax: nds_tn_ax X k by split; [move => i ik; apply:pc;co_tac | exists e].
  move: (cprod_Mlele (nds_tn11 kB kp ax) (card_leR (CS_Bnat pe))) => hc.
  exact:(card_leT (card_leT hb ha) hc).
rewrite /g1 /g2; bw => a abn; bw.
have /pg:nds_ax(fun z => X (k +c z)) (n -c k).
  move => i ink; move:(csum_Meqlt kB nkB ink).
  by rewrite(cdiff_pr (proj1 kln)) => /pc /proj32_1.
apply:card_leT; apply:fun_image_smaller.
Qed.

Lemma nds_tg11 Y :
  (forall i, i <c n -c k ->
      \0o <o Y i /\ X (k +c i) = omega0 ^o (succ_o e) *o (Y i)) ->
  nds_tn_C X k = ndstnC k ->
  nds_card (n-c k) Y = nds_F (n -c k) ->
  nds_card n X = (ndstnC k) *c (nds_F (n -c k)).
Proof.
move => yp <- <-.
rewrite /nds_card nds_tg9.
have kB := BS_lt_int kln nB.
have nkB := BS_diff k nB.
move: Xax => [Xpa Xpb Xpc Xpd Xpe].
set c:= omega0 ^o succ_o e.
have cp: \0o <o c by apply: (omega_pow_pos (OS_succ Xpb)).
have oc:= proj32_1 cp.
set E := (nds_sums (n -c k) (fun z => X (k +c z))).
have ax0: nds_ax Y (n -c k) by move => i /yp [] h _; ord_tac.
have aux: forall i, inc i (nds_tn_S X k) -> i <o c.
  move => i /setUf_P [K /setP_P K1 /funI_P [s sp] ->].
  have sKB:= (sub_trans K1 (@Bint_S1 k)).
  have fsk:= (sub_finite_set K1 (finite_Bint k)).
  have cKB: inc (cardinal K) Bnat by apply /BnatP.
  have : forall i, i <c (cardinal K) -> X (nth_elt K (Vf s i)) <o c.
    move => j jk.
    have r0: (Vf s j) <c cardinal K.
      move /perm_intP: sp => [[[fs _] _] ss ts].
      by apply/(BintP cKB); Wtac; rewrite ss; apply/(BintP cKB).
    have r1:(nth_elt K (Vf s j)) <c k.
      apply /(BintP kB); apply:K1; apply: nth_set9 => //.
      apply: (BS_lt_int r0 cKB).
    by move: (proj2(the_CNF_p4 (Xpc _ (card_lt_ltT r1 kln)))); rewrite Xpd.
  move: (cardinal K) cKB; apply: cardinal_c_induction.
    by rewrite /nds_sc osum_expansion0.
  move => m mB Hrec aux; rewrite /nds_sc (osum_expansion_succ _ mB).
  have oic:= (indecomp_prop4 (OS_succ Xpb)).
  have alc:=(aux _ (card_lt_succ mB)).
  apply: (indecomp_prop2 alc _ oic); apply: Hrec => j jm; apply:aux.
  exact: (card_lt_ltT jm (card_lt_succ mB)).
have aux2: forall i j u v, inc i (nds_tn_S X k) -> inc j (nds_tn_S X k) ->
   inc u E -> inc v E -> u +o i = v +o j -> (u = v /\ i = j).
  move => i j u v ia ja /funI_P [s1 s1p v1p] /funI_P [s2 s2p v2p].
  move/perm_intP:s1p => [[[fs1 _] _] sf1 tf1].
  move/perm_intP:s2p => [[[fs2 _] _] sf2 tf2].
  have ha: forall q, q<c n -c k -> (Vf s1 q) <c n -c k.
    by move => q qa;apply /(BintP nkB); Wtac; rewrite sf1; apply/(BintP nkB).
  have hb: forall q, q<c n -c k -> (Vf s2 q) <c n -c k.
    by move => q qa;apply /(BintP nkB); Wtac; rewrite sf2; apply/(BintP nkB).
  have v1a: u = nds_sc (n -c k) (fun z => c *o Y z) s1.
    by rewrite v1p; apply:(osum_expansion_exten nkB) => q /ha /yp [].
  have v2a: v = nds_sc (n -c k) (fun z => c *o Y z) s2.
    by rewrite v2p; apply:(osum_expansion_exten nkB) => q /hb/yp [].
  have ax1:nds_ax (fun z => Y (Vf s1 z)) (n -c k).
    move => z /ha/yp [hc _]; ord_tac.
  have ax2:nds_ax (fun z => Y (Vf s2 z)) (n -c k).
    move => z /hb/yp [hc _]; ord_tac.
  rewrite v1a v2a /nds_sc (nds_r1 nkB ax1 oc) (nds_r1 nkB ax2 oc).
  set v1':= osum_expansion _ _; set v2':= osum_expansion _ _ => eq1.
  have ov1: ordinalp v1' by apply:(OS_osum_expansion nkB); apply: ax1.
  have ov2: ordinalp v2' by apply:(OS_osum_expansion nkB); apply: ax2.
  move: (aux _ ia) (aux _ ja) => ib jb.
  set a := c *o v1' +o i.
  move:(proj31_1 ib)(proj31_1 jb) => oi oj.
  have oa:ordinalp a by apply (OS_sum2 (OS_prod2 oc ov1) oi).
  by move:(odivision_unique oa oc (And4 ov1 oi (erefl a) ib)
    (And4 ov2 oj eq1 jb)) => [-> rb].
pose F a :=(fun_image E (ord_sum2^~ a)).
have H: forall a, inc a (nds_tn_S X k) -> cardinal (F a) = nds_card (n -c k) Y.
  move => a ias.
  rewrite card_fun_image.
    rewrite /E -/(nds_card _ _) (nds_r2 nkB ax0 cp).
    by apply:(nds_card_exten nkB) => i /yp [_ ->].
  move => u v ua va /= eq; exact: (proj1 (aux2 _ _ _ _ ias ias ua va eq)).
rewrite csum_pr4_bis.
  rewrite cprodC /nds_tn_C cprod2_pr2b - csum_of_same /card_sumb.
  by apply: f_equal; apply: Lg_exten => i ib; apply: H.
move => i j ia ja; case (equal_or_not i j) => eij; [by left | right].
  apply:disjoint_pr => u /funI_P [v1 va vb] /funI_P [v2 vc vd].
  rewrite vb in vd; case eij; exact: (proj2 (aux2 _ _ _ _ ia ja va vc vd)).
Qed.

End NdsStudy.

Lemma nds_s1 n k: inc n Bnat -> k <c n -> k <> \0c ->
   nds_FA n k <=c (ndstnC k) *c (nds_F (n -c k)).
Proof.
move => nB kln knz.
move: (card_le_ltT (czero_least (proj31_1 kln)) kln) => np.
move: (nds_type_p3 nB (nesym (proj2 np)) (proj1 kln)).
move=> [pa _ _ [X [pb pc <-]]].
move:(nds_type9 nB knz (proj1 kln) pc)=> [Y [e [ya <-]]].
by apply: (nds_tg10 nB knz kln ya).
Qed.

Lemma nds_s2 n k: inc n Bnat -> k <c n -> k <> \0c ->
   nds_FA n k = (ndstnC k) *c (nds_F (n -c k)).
Proof.
move => nB kln knz; apply: card_leA; first by apply:nds_s1.
move: (card_le_ltT (czero_least (proj31_1 kln)) kln) => np.
move: (nds_type_p3 nB (nesym (proj2 np)) (proj1 kln)) => [pa _ pb _].
move:(nds_type_p10 (BS_diff k nB)) => [X [ax xa1 xv]].
move:(nds_tn2 (BS_lt_int kln nB)) => [_ _ _ [Y [ya1 [e oe yd]] yv] _].
set c := omega0 ^o (succ_o e).
have cp: \0o <o c by apply:(omega_pow_pos (OS_succ oe)).
have oc:= (proj32_1 cp).
pose Z i := Yo (i <c k) (Y i) (c *o X (i -c k)).
have kB:=(BS_lt_int kln nB).
have nkB:= (BS_diff k nB).
have az1: forall i, i<c n -> \0o <o Z i.
  move => i lin; rewrite /Z; Ytac h; first by apply: ya1.
  case: (card_le_to_el (proj31_1 kln) (proj31_1 lin)) => // leki.
  apply: (oprod2_pos cp (xa1 _ (cdiff_pr7 leki lin nB))).
have az2: forall i, i <c n -> ~ i <c k -> e <o the_CNF_degree (Z i).
  move => i lin h.
  rewrite /Z; Ytac0;apply /ord_lt_succ_succP.
  case: (card_le_to_el (proj31_1 kln) (proj31_1 lin)) => // leki.
  have xip :=(xa1 _ (cdiff_pr7 leki lin nB)).
  have ha:= (oprod_Mle1 oc xip).
  have od:=(OS_the_CNF_degree (proj32 ha)).
  have:= (ord_le_ltT ha (proj2 (the_CNF_p4 (oprod2_pos cp xip)))).
  by move /(opow_Meqltr ord_le_2omega (OS_succ oe) ( (OS_succ od))).
have az3:forall i, i <c k -> the_CNF_degree (Z i) = e.
  by move => i lik;rewrite /Z; Ytac0;rewrite (yd _ lik).
have az4:forall i, i <c n -> e <=o the_CNF_degree (Z i).
  move => i lin; case (p_or_not_p (i <c k)) => h.
    rewrite (az3 _ h); apply: (ord_leR oe).
   exact: (proj1 (az2 _ lin h)).
have ha: nds_type Z n k.
  right; split => //; split => //; exists e; split => //.
  have ->: (Zo (Bint n) (fun i => the_CNF_degree (Z i) = e)) = Bint k.
    set_extens i.
        move => /Zo_P [/(BintP nB) lin di]; apply/(BintP kB).
        by ex_middle h; move:(proj2 (az2 i lin h)); rewrite di; case.
    move => /(BintP kB) => lik; apply:Zo_i; first by apply /(BintP nB); co_tac.
    apply: (az3 _ lik).
  by rewrite (card_Bint kB).
have hb: nds_type_nor Z n k e.
 split => // i ki lin; apply: (az2 i lin) => h; co_tac.
have hc: forall i,
   i <c n -c k -> \0o <o X i /\ Z (k +c i) = omega0 ^o succ_o e *o X i.
  move => i ib; split; first by apply: xa1.
  rewrite /Z; Ytac h; first by move: (csum_M0le i (proj31_1 kln)) => h1; co_tac.
  by rewrite csumC (cdiff_pr1 (BS_lt_int ib nkB) kB).
have hd:nds_tn_C Z k = ndstnC k.
  have sb: same_below Z Y k by move => i klik; rewrite /Z; Ytac0.
   have ->: nds_tn_C Z k = nds_tn_C Y k by apply:nds_tn_C_exten.
  by rewrite yv (nds_tn13 kB).
have he: nds_ax Z n by move => i lin; exact (proj32_1 (az1 _ lin)).
by rewrite - (nds_tg11 nB kln hb hc hd xv); apply: pb.
Qed.

Lemma ndstnC1: ndstnC \1c = \2c.
Proof.
rewrite /ndstnC.
move:(cpred_pr1 CS0); rewrite succ_zero => ->.
by rewrite cpowx0 (cprod1r CS1) succ_one.
Qed.

Lemma nds_s3 n: inc n Bnat -> n <> \0c ->
   \2c *c (nds_F n) <=c (nds_F (succ n)).
Proof.
move => nB nz.
have np: \0c <c n by by split; fprops.
have snB:=(BS_succ nB).
have pa: \1c <c succ n.
  by rewrite - succ_zero; apply /(card_succ_succ_ltP BS0 nB).
move:(proj1 (nds_type_p11 snB (@succ_nz n)) _ (proj1 pa) (card1_nz)).
move:(nds_s2 snB pa (card1_nz)); rewrite ndstnC1.
by rewrite -(cpred_pr4 (CS_succ n)) (cpred_pr1 (CS_Bnat nB)) => ->.
Qed.

Lemma nds_s4 n: inc n Bnat -> \2c ^c n <=c (nds_F (succ n)).
Proof.
move: n; apply: cardinal_c_induction.
    rewrite cpowx0 succ_zero (proj2 nds_k); fprops.
move => n nB hrec.
move:(nds_s3 (BS_succ nB) (@succ_nz n)) => sb.
move: (card_leT (cprod_Mlele (card_leR CS2) hrec) sb).
by rewrite (pow_succ _ nB) cprodC.
Qed.

Lemma nds_s5 n: inc n Bnat -> \2c <c n -> n <c (nds_F n).
Proof.
move => nB ngt2.
have ra:=(proj1(card_lt_02)).
have rb:= (card_lt_12).
have nnz: n <> \0c.
   move => h; move: ra; rewrite -h => h'; co_tac.
move:(cpred_pr nB nnz) => [n1B sa].
have npz: cpred n <> \0c.
  move => h; move: sa (proj1 ngt2); rewrite h succ_zero => -> h1;co_tac.
move:(cpred_pr n1B npz) => [n2B sb].
have pB:= BS_pow BS2 n2B.
have ha : \2c <=c \2c ^c cpred (cpred n).
   apply:(cpow_Mle1 CS2) => mz.
   by case:(proj2 ngt2); rewrite sa sb mz succ_zero succ_one.
have hb: succ (cpred n) <c \2c ^c cpred n.
  rewrite sb (pow_succ _ n2B) cprodC two_times_n.
  rewrite (Bsucc_rw (BS_succ n2B)) (Bsucc_rw n2B) - csumA card_two_pr csumC.
  exact:(csum_Mlelt pB pB ha (cantor (CS_Bnat n2B))).
rewrite sa; move: (nds_s4 n1B) => hc; co_tac.
Qed.

Lemma nds_s6 n: inc n Bnat -> \2c <=c n ->
  (forall k, k <c n -> k <> \0c ->
      (ndstnC k) *c (nds_F (n -c k)) <=c (nds_F n)) /\
  (exists k, [/\ k <c n, k <> \0c &
      (ndstnC k) *c (nds_F (n -c k)) = (nds_F n)]).
Proof.
move => nB n2.
have np: n <> \0c by move => h; move:(card_lt_02); rewrite - h => h1; co_tac.
move:(nds_type_p11 nB np) => [pa [k0 [k0n k0nz kv]]]; split.
  move => k kn knz; rewrite -(nds_s2 nB kn knz); apply: pa => //; co_tac.
case (equal_or_not k0 n) => ekn.
   case (equal_or_not \2c n) => en2.
     rewrite - en2 nds_l; exists \1c; split.
     + apply: card_lt_12.
     + fprops.
     + move:(cpred_pr1 CS1); rewrite succ_one => cp1.
       by rewrite ndstnC1 - (cpred_pr4 CS2) cp1 (proj2 nds_k) (cprod1r CS2).
  move: (cpred_pr nB np) => [sa sb].
  move: (proj2 (nds_s5 nB (conj n2 en2))).
  by rewrite - kv ekn sb (nds_type_p8 sa).
have lkn:= (conj k0n ekn).
by exists k0; split => //; rewrite -(nds_s2 nB lkn k0nz).
Qed.

Section NdsNat.
Definition ndstnC_nat n := (n * 2 ^ (n-1)).+1.
Notation C := ndstnC_nat.
Variable F: nat -> nat.

Hypothesis F0: F 0 = 1.
Hypothesis F1: F 1 = 1.
Hypothesis Fr1:
  forall n k, 2 <= n -> 0 < k < n -> (C k) * (F (n - k)) <= F n.
Hypothesis Fr2:
  forall n , 2 <= n -> exists2 k, 0 < k < n & (C k) * (F (n - k)) = F n.

Lemma ndsNC1 : C 1 = 2. Proof. by []. Qed.
Lemma ndsNC2 : C 2 = 5. Proof. by []. Qed.
Lemma ndsNC3 : C 3 = 13. Proof. by []. Qed.
Lemma ndsNC4 : C 4 = 33. Proof. by []. Qed.
Lemma ndsNC5 : C 5 = 81. Proof. by []. Qed.
Lemma ndsNC6 : C 6 = 193. Proof. by []. Qed.
Lemma ndsNC7 : C 7 = 449. Proof. by []. Qed.

Lemma ndsnF2: F 2 = 2.
Proof.
move: (Fr2 (leqnn 2)) => [k kab <-].
move: kab; rewrite ltnS => /anti_leq <-.
by rewrite F1 ndsNC1 muln1.
Qed.

Lemma ndsnF3: F 3 = 5.
Proof.
have h0: 2 <= 3 by [].
have h2: 0 < 2 < 3 by [].
have ha: C 2 * F (3 - 2) = 5 by rewrite F1 ndsNC2 muln1.
move: (Fr1 h0 h2); rewrite ha => eq1.
move:(Fr2 h0) => [k kp kv].
move: kp kv; rewrite ltnS; rewrite (leq_eqVlt k).
case k2: (k== 2); first by move => _ ;rewrite (eqP k2) ha.
rewrite /= ltnS => /anti_leq <-; rewrite ndsNC1 ndsnF2 => eq2.
by move: (gtn_eqF eq1); rewrite - eq2.
Qed.

Lemma ndsnF4: F 4 = 13.
Proof.
have h0: 2 <= 4 by [].
have h2: 0 < 3 < 4 by [].
have ha: C 3 * F (4 - 3) = 13 by rewrite F1 ndsNC3 muln1.
move: (Fr1 h0 h2); rewrite ha => eq1.
move:(Fr2 h0) => [k kp kv].
move: kp kv; rewrite ltnS; rewrite (leq_eqVlt k).
case k3: (k== 3); first by move => _ ;rewrite (eqP k3) ha.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k2: (k== 2).
  move => _ ;rewrite (eqP k2) ndsNC2 ndsnF2 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS => /anti_leq <-; rewrite ndsNC1 ndsnF3 => eq2.
by move:eq1; rewrite - eq2.
Qed.

Lemma ndsnF5: F 5 = 33.
Proof.
have h0: 2 <= 5 by [].
have h2: 0 < 4 < 5 by [].
have ha: C 4 * F (5 - 4) = 33 by rewrite F1 ndsNC4 muln1.
move: (Fr1 h0 h2); rewrite ha => eq1.
move:(Fr2 h0) => [k kp kv].
move: kp kv; rewrite ltnS; rewrite (leq_eqVlt k).
case k4: (k== 4); first by move => _ ;rewrite (eqP k4) ha.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k3: (k== 3).
  move => _ ;rewrite (eqP k3) ndsNC3 ndsnF2 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k2: (k== 2).
  move => _ ;rewrite (eqP k2) ndsNC2 ndsnF3 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS => /anti_leq <-; rewrite ndsNC1 ndsnF4 => eq2.
by move:eq1; rewrite - eq2.
Qed.

Lemma ndsnF6: F 6 = 81.
Proof.
have h0: 2 <= 6 by [].
have h2: 0 < 5 < 6 by [].
have ha: C 5 * F (6 - 5) = 81 by rewrite F1 ndsNC5 muln1.
move: (Fr1 h0 h2); rewrite ha => eq1.
move:(Fr2 h0) => [k kp kv].
move: kp kv; rewrite ltnS; rewrite (leq_eqVlt k).
case k5: (k== 5); first by move => _ ;rewrite (eqP k5) ha.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k4: (k== 4).
  move => _ ;rewrite (eqP k4) ndsNC4 ndsnF2 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k3: (k== 3).
  move => _ ;rewrite (eqP k3) ndsNC3 ndsnF3 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k2: (k== 2).
  move => _ ;rewrite (eqP k2) ndsNC2 ndsnF4 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS => /anti_leq <-; rewrite ndsNC1 ndsnF5 => eq2.
by move:eq1; rewrite - eq2.
Qed.

Lemma ndsnF7: F 7 = 193.
Proof.
have h0: 2 <= 7 by [].
have h2: 0 < 6 < 7 by [].
have ha: C 6 * F (7 - 6) = 193 by rewrite F1 ndsNC6 muln1.
move: (Fr1 h0 h2); rewrite ha => eq1.
move:(Fr2 h0) => [k kp kv].
move: kp kv; rewrite ltnS; rewrite (leq_eqVlt k).
case k6: (k== 6); first by move => _ ;rewrite (eqP k6) ha.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k5: (k== 5).
  move => _ ;rewrite (eqP k5) ndsNC5 ndsnF2 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k4: (k== 4).
  move => _ ;rewrite (eqP k4) ndsNC4 ndsnF3 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k3: (k== 3).
  move => _ ;rewrite (eqP k3) ndsNC3 ndsnF4 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k2: (k== 2).
  move => _ ;rewrite (eqP k2) ndsNC2 ndsnF5 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS => /anti_leq <-; rewrite ndsNC1 ndsnF6 => eq2.
by move:eq1; rewrite - eq2.
Qed.

Lemma ndsnF8: F 8 = 449.
Proof.
have h0: 2 <= 8 by [].
have h2: 0 < 7 < 8 by [].
have ha: C 7 * F (8 - 7) = 449 by rewrite F1 ndsNC7 muln1.
move: (Fr1 h0 h2); rewrite ha => eq1.
move:(Fr2 h0) => [k kp kv].
move: kp kv; rewrite ltnS; rewrite (leq_eqVlt k).
case k7: (k== 7); first by move => _ ;rewrite (eqP k7) ha.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k6: (k== 6).
  move => _ ;rewrite (eqP k6) ndsNC6 ndsnF2 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k5: (k== 5).
  move => _ ;rewrite (eqP k5) ndsNC5 ndsnF3 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k4: (k== 4).
  move => _ ;rewrite (eqP k4) ndsNC4 ndsnF4 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k3: (k== 3).
  move => _ ;rewrite (eqP k3) ndsNC3 ndsnF5 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k2: (k== 2).
  move => _ ;rewrite (eqP k2) ndsNC2 ndsnF6 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS => /anti_leq <-; rewrite ndsNC1 ndsnF7 => eq2.
by move:eq1; rewrite - eq2.
Qed.

Definition Bp (n m:nat) := (n,m).

Definition pair_lt p q := (p.1 * q.2) < (p.2 * q.1).

Lemma R1 a b c d: pair_lt (Bp a b) (Bp c d) = pair_lt (Bp a c) (Bp b d).
Proof. by rewrite /Bp/pair_lt /= mulnC (mulnC b). Qed.


Lemma ndsnF9: F 8 = 449.
Proof.
have h0: 2 <= 8 by [].
have h2: 0 < 7 < 8 by [].
have ha: C 7 * F (8 - 7) = 449 by rewrite F1 ndsNC7 muln1.
move: (Fr1 h0 h2); rewrite ha => eq1.
move:(Fr2 h0) => [k kp kv].
move: kp kv; rewrite ltnS; rewrite (leq_eqVlt k).
case k7: (k== 7); first by move => _ ;rewrite (eqP k7) ha.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k6: (k== 6).
  move => _ ;rewrite (eqP k6) ndsNC6 ndsnF2 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k5: (k== 5).
  move => _ ;rewrite (eqP k5) ndsNC5 ndsnF3 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k4: (k== 4).
  move => _ ;rewrite (eqP k4) ndsNC4 ndsnF4 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k3: (k== 3).
  move => _ ;rewrite (eqP k3) ndsNC3 ndsnF5 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS; rewrite (leq_eqVlt k).
case k2: (k== 2).
  move => _ ;rewrite (eqP k2) ndsNC2 ndsnF6 => eq2.
  by move:eq1; rewrite - eq2.
rewrite /= ltnS => /anti_leq <-; rewrite ndsNC1 ndsnF7 => eq2.
by move:eq1; rewrite - eq2.
Qed.

End NdsNat.

End NumberSums.

Module Realisation.

Definition universe y :=
  let aux := fun b => transfinite_defined (ordinal_o b)
       (fun f => unionf (target f) powerset)
  in Vf (aux (succ_o y)) y.

Lemma universe_rec z: ordinalp z ->
   universe z = unionf z (fun t => powerset (universe t)).
Proof.
set p :=(fun f => unionf (target f) powerset).
pose f b := transfinite_defined (ordinal_o b) p.
have si: forall x, universe x = Vf (f (succ_o x)) x by move => x.
have up1: forall b, ordinalp b ->
  forall y, inc y b -> Vf (f b) y = unionf y (fun z => powerset (Vf (f b) z)).
  move => b ob.
  move: (transfinite_defined_pr p (ordinal_o_wor ob)).
  rewrite /transfinite_def (ordinal_o_sr b) //. rewrite -/(f b).
  move => [pa pb pc] y yb.
  have ysf: sub y (source (f b)) by rewrite pb; apply: (ordinal_transitive ob).
  move: (Vf_image_P (proj1 pa) ysf) => aux.
  rewrite (pc _ yb)/restriction_to_segment/restriction1 (ordinal_segment ob yb).
  rewrite /p; aw; set_extens t; move /setUf_P => [u za zb]; apply/setUf_P.
    by move /aux: za => [v pd pe]; ex_tac; rewrite -pe.
  exists (Vf (f b) u) => //; apply/aux; ex_tac.
have up2:forall b1 b2 x, ordinalp b1 -> ordinalp b2 ->
  inc x b1 -> inc x b2 -> ordinalp x -> Vf (f b1) x = Vf (f b2) x.
  move => b1 b2 x p1 p2 xb1 xb2 ox.
  case: (least_ordinal6 (fun z =>
     inc z b1 -> inc z b2 -> Vf (f b1) z = Vf (f b2) z) ox); first by apply.
  set t:= least_ordinal _ _; move => [oz zp1]; case => tb1 tb2.
  move: (up1 _ p1 _ tb1) (up1 _ p2 _ tb2) => -> ->.
  have aux: forall y, inc y t -> Vf (f b1) y = Vf (f b2) y.
    move => y yt; apply: zp1 => //; ord_tac0.
  set_extens s => /setUf_P [y yt ys]; apply/setUf_P; ex_tac; rewrite? aux //.
  by rewrite - aux.
move => oz; move: (OS_succ oz) => osz.
have ziz: inc z (succ_o z) by fprops.
rewrite /universe (up1 _ osz _ ziz).
have aux: forall t, inc t z -> (Vf (f (succ_o z)) t) = (Vf (f (succ_o t)) t).
    move => t tz; move: (ordinal_hi oz tz) => ot.
    by apply: up2 => //; rewrite /succ_o; fprops; apply:OS_succ.
set_extens s => /setUf_P [t tz zs]; apply/setUf_P; ex_tac; rewrite? aux //.
by rewrite -aux.
Qed.

Lemma universe_P a: ordinalp a ->
  forall x, inc x (universe a) <-> exists2 b, b<o a & sub x (universe b).
Proof.
move => oa x.
rewrite (universe_rec oa); split.
  by move /setUf_P => [b /(ord_ltP oa) ba /setP_P xb]; exists b.
move => [b /(ord_ltP oa) ba /setP_P xb]; union_tac.
Qed.

Lemma universe_inc1 a b: a <o b -> sub (powerset (universe a)) (universe b).
Proof.
move /ord_ltP0 => [oa ob ab].
rewrite (universe_rec ob) => t ta; apply /setUf_P; ex_tac.
Qed.

Lemma universe_trans a: ordinalp a -> transitive_set (universe a).
Proof.
pose p x := transitive_set (universe x).
apply: (least_ordinal2 (p:=p)) => y oy h t.
move /(universe_P oy) => [s sy sb].
move => b bt; apply /(universe_P oy);exists s => //;apply:(h _ sy _ (sb _ bt)).
Qed.

Lemma universe_inc2 a b: a <=o b -> sub (universe a) (universe b).
Proof.
move => lab.
case: (equal_or_not a b); first by move => ->; fprops.
move=> anb; move: (universe_inc1 (conj lab anb)).
by apply: sub_trans => t ta; apply /setP_P; apply:(universe_trans (proj31 lab)).
Qed.

Lemma universe_0: universe \0o = emptyset.
Proof. by rewrite (universe_rec OS0); rewrite setUf_0. Qed.

Lemma universe_succ a: ordinalp a ->
  universe (succ_o a) = powerset (universe a).
Proof.
move => oa.
have asa: a <o succ_o a by apply: ord_succ_lt.
apply: extensionality; last by exact:(universe_inc1 asa).
rewrite (universe_rec (OS_succ oa)) => t /setUf_P [y ys].
have: y <=o a by apply /ord_leP.
move /universe_inc2 /setP_S; apply.
Qed.

Lemma universe_limit a: limit_ordinal a ->
  universe a = unionf a universe.
Proof.
move => [pa pb pc]; apply extensionality.
  move => t /(universe_P pa) [b /(ord_ltP pa) ba /setP_P etc].
  apply /setUf_P; exists (succ_o b); first by apply: pc.
  rewrite universe_succ //; ord_tac.
move => t /setUf_P [y ya]; apply: (universe_inc2); ord_tac.
Qed.

Definition is_in_universe x := exists2 a, ordinalp a & inc x (universe a).
Definition urank_prop x a :=
  [/\ ordinalp a, sub x (universe a) &
    forall c, c <o a -> ~(sub x (universe c)) ].
Definition urankA_prop x a :=
  [/\ ordinalp a, inc x (universe a) &
    forall c, c <o a -> ~(inc x (universe c)) ].
Definition urank a x:= least_ordinal (fun b => sub x (universe b)) a.
Definition urankA a x:= least_ordinal (fun b => inc x (universe b)) a.

Lemma urank_universe a: ordinalp a -> urank_prop (universe a) a.
Proof.
move => ap; split => // c /universe_inc1 ca su.
move: (sub_smaller (sub_trans ca su)); rewrite card_setP - cpow_prb.
move: (cantor (CS_cardinal (universe c))) => pa pb;co_tac.
Qed.

Lemma urank_uniq x: uniqueness (urank_prop x).
Proof.
move => a b [oa pa pb][ob pc pd].
case: (ord_le_to_ell oa ob) => //; [ by move /pd | by move /pb].
Qed.

Lemma urankA_uniq x: uniqueness (urankA_prop x).
Proof.
move => a b [oa pa pb][ob pc pd].
case: (ord_le_to_ell oa ob) => //; [ by move /pd | by move /pb].
Qed.

Lemma urank_pr x a (b:= urank a x): ordinalp a -> sub x (universe a) ->
  b <=o a /\ urank_prop x b.
Proof.
move =>oa pa.
pose p b := sub x (universe b).
move: (least_ordinal4 oa pa (p:=p)) => []; rewrite -/(urank _ _) -/b /p.
move => ob xb etc; split; first by apply: etc.
split => //;move => c cb xc.
move: (etc _ (proj31_1 cb) xc) => h; ord_tac.
Qed.

Lemma OS_urank x a: ordinalp a -> ordinalp (urank a x).
Proof.
move => oa; rewrite /urank /least_ordinal; set S := Zo _ _.
case: (emptyset_dichot S) => h; first by rewrite h setI_0; fprops.
have os: ordinal_set S by move => t /Zo_S /setU1_P [] ta; [ ord_tac | ue ].
by move: (ordinal_setI h os) => /os.
Qed.

Lemma urankA_pr x a (b:= urankA a x): ordinalp a -> inc x (universe a) ->
  b <=o a /\ urankA_prop x b.
Proof.
move =>oa pa.
pose p b := inc x (universe b).
move: (least_ordinal4 oa pa (p:=p)) => []; rewrite -/(urank _ _) -/b /p.
move => ob xb etc; split; first by apply: etc.
split => //;move => c cb xc.
move: (etc _ (proj31_1 cb) xc) => h; ord_tac.
Qed.

Lemma urank_ex x: is_in_universe x -> exists b, urank_prop x b.
Proof.
move => [a oa xa]; exists (urank a x).
by move: (universe_trans oa xa) => /(urank_pr oa) [_ h].
Qed.

Lemma urankA_succ x a: urankA_prop x a -> succ_op a.
Proof.
move => [oa xa etc].
case: (limit_ordinal_pr2 oa) => // hc.
- by move: xa; rewrite hc; rewrite universe_0 => /in_set0.
- by move: xa; rewrite (universe_limit hc) => /setUf_P [y /(ord_ltP oa) /etc].
Qed.

Lemma urankA_ex x: is_in_universe x ->
   exists2 b, ordinalp b & urankA_prop x (succ_o b).
Proof.
move => [a oa xa]; move: (urankA_pr oa xa) => [_ pb].
move /urankA_succ: (pb) => [b ob bs]; rewrite bs in pb; exists b => //.
Qed.

Lemma urank_alt x b: urankA_prop x (succ_o b) <-> urank_prop x b.
Proof.
split.
  move => [pa pb pc].
  have ob: ordinalp b by apply: OS_succr.
  split => //; first by apply/setP_P; rewrite - (universe_succ ob).
  move => c cb /setP_P h.
  have oc: ordinalp c by ord_tac.
  by move /ord_lt_succ_succP: cb => /pc; rewrite (universe_succ).
move => [ob pb pc]; move: (OS_succ ob) => osb.
have ha: inc x (universe(succ_o b)) by rewrite (universe_succ ob); apply/setP_P.
have: is_in_universe x by exists (succ_o b).
move /urankA_ex => [c oc h]; move: (h) => [qa qb qc].
move: qb; rewrite (universe_succ oc) => /setP_P => qb.
case: (ord_le_to_ell ob oc); [by move => -> | | by move /pc].
by move /ord_lt_succ_succP => /qc.
Qed.

Lemma urank_alt1 a x: ordinalp a -> inc x (universe a) ->
   urankA a x = succ_o (urank a x).
Proof.
move => oa xa.
move: (proj2 (urankA_pr oa xa)) => h2.
move:(urank_pr oa (universe_trans oa xa))=> [_ ] /urank_alt h1.
exact:(urankA_uniq h2 h1).
Qed.

Lemma urank_alt2 a x: ordinalp a -> inc x (universe a) ->
  inc x (universe (succ_o (urank a x))).
Proof.
move => oa xa; rewrite - (urank_alt1 oa xa).
by move: (urankA_pr oa xa) => [h1 []].
Qed.

Lemma urank_pr1 x a (b:= urank a x): ordinalp a -> inc x (universe a) ->
  b <o a /\ urank_prop x b.
Proof.
move => oa xa.
move:(urank_pr oa (universe_trans oa xa))=> [_ h]; split => //.
move: (urankA_pr oa xa) => [h1 h2]; apply /ord_succ_ltP.
by rewrite - (urank_alt1 oa xa).
Qed.

Lemma urank_uniq2 x a b:
   ordinalp a -> ordinalp b ->
   inc x (universe a) -> inc x (universe b) ->
   urank a x = urank b x.
Proof.
move => oa ob xa xb;
move: (urank_pr1 oa xa) (urank_pr1 ob xb) => [_ s2] [_ s4].
apply: (urank_uniq s2 s4).
Qed.

Lemma urank_ordinal x: ordinalp x -> urank_prop x x.
Proof.
have pa: forall y, ordinalp y -> sub y (universe y).
  move => y oy.
  case: (least_ordinal6 (fun z => sub z (universe z)) oy) => //.
  set z := least_ordinal _ _; move => [pa pb]; case.
  move => t tz; move: (pb _ tz) => /setP_P.
  have ot: ordinalp t by ord_tac.
  have: succ_o t <=o z by apply /ord_succ_ltP; ord_tac.
  rewrite - (universe_succ ot) => /universe_inc2; apply.
move => ox; split; fprops.
move => c cx /setP_P.
move: (universe_inc1 cx) => qa qb; move: (qa _ qb) => xx.
move: (least_ordinal4 ox xx (p:= fun y => inc y (universe y))).
simpl; set a := least_ordinal _ _; move => [oa nzz rec].
move /(universe_P oa): nzz => [b ba bb]; apply: (ord_leA1 _ ba).
apply:rec; first exact: (proj31_1 ba).
by apply: bb; apply /(ord_ltP oa).
Qed.

Lemma universe_ordinal x: ordinalp x -> is_in_universe x.
Proof. by move /urank_ordinal => /urank_alt [pa pb pc]; exists (succ_o x). Qed.

Lemma urank_inc a x y : ordinalp a -> inc x (universe a) -> inc y x ->
   inc y (universe a) /\ (urank a y) <o (urank a x).
Proof.
move => oa xa yx.
move: (urank_pr1 oa xa) => [_ [sa sb _]].
move: (universe_trans oa xa yx) => ya; split => //; apply /ord_succ_ltP.
have ysa:= (universe_trans oa ya).
move: (sb _ yx) => h; move: (urankA_pr sa h)=> [pc pd].
by rewrite - (urank_alt1 oa ya) - (urankA_uniq pd (proj2 (urankA_pr oa ya))).
Qed.

Lemma urank_sub a x y : ordinalp a -> inc x (universe a) -> sub y x ->
   inc y (universe a) /\ (urank a y) <=o (urank a x).
Proof.
move => oa xa yx.
move:(urank_pr1 oa xa) =>[pa pb];move: (pb) => [p1 p2 p3].
have pc: inc y (universe (succ_o (urank a x))).
  rewrite (universe_succ p1); apply /setP_P; apply: (sub_trans yx p2).
have p4: (succ_o (urank a x)) <=o a by apply /ord_succ_ltP.
have ya: inc y (universe a) by apply:(universe_inc2 p4).
move: (urank_pr1 (OS_succ p1) pc) => [].
by rewrite (urank_uniq2 (OS_succ p1) oa pc ya) => /ord_lt_succP h _.
Qed.

Lemma urank_powerset a x : ordinalp a -> inc x (universe a) ->
   inc (powerset x) (universe (succ_o a)) /\
   (urank a (powerset x)) = succ_o (urank a x).
Proof.
move => oa xa.
move: (urank_pr1 oa xa); set r := urank a x; move => [ra pra].
move /ord_succ_ltP: ra => sra.
have pa: sub (powerset x) (universe (succ_o r)).
   move: pra => [uu vv _]; move => t /setP_P tcx; rewrite (universe_succ uu).
   apply /setP_P; apply: sub_trans tcx vv.
move: (sub_trans pa (universe_inc2 sra)) => sa.
split; first by rewrite (universe_succ oa); apply /setP_P.
move: (urank_pr oa sa); move => [qa qb].
suff:urank_prop (powerset x) (succ_o r) by move => h; apply(urank_uniq qb h).
split => //; first by ord_tac.
move => c /ord_lt_succP cr h; move: (h _ (setP_Ti x))=> xc.
move: (urank_pr1 (proj31 cr) xc) => [u1 u2].
move: cr ; rewrite (urank_uniq pra u2)=> u3; ord_tac.
Qed.

Lemma urank_union a x : ordinalp a -> inc x (universe a) ->
   inc (union x) (universe a) /\ (urank a (union x)) = (\opred (urank a x)).
Proof.
move => oa xa.
move: (urank_pr1 oa xa) => [pa pb].
move: (pb) => [orx qb qc].
set b := urank a x.
set c := \opred (urank a x).
have pc: forall y, inc y x -> inc y (universe a) /\ (urank a y) <o b.
  by move => y /(urank_inc oa xa).
have pd: c <=o b by apply: ord_ub_sup => // t tb; ord_tac.
have oc: ordinalp c by ord_tac.
have aux: forall u, u <o b -> u <=o c.
  move => u ub; split => //; [ord_tac | by apply: setU_s1; apply /ord_ltP].
have pe: sub (union x) (universe c).
  move => t /setU_P [z za zb].
  have p3: sub z (universe a) by move: (pc _ zb) => [/(universe_trans oa)].
  move: (urank_inc oa xa zb) => [_] /aux /universe_inc2; apply.
  by move: (urank_pr oa p3) => [_ [s1 s2 s3]];apply: s2.
have pf :inc (union x) (universe a).
  by apply: (universe_inc1 (ord_le_ltT pd pa)); apply /setP_P.
move: (urank_pr oc pe) => [s1 s2].
move: (urank_pr oa (universe_trans oa pf)) => [_ s4].
move: (urank_uniq s2 s4) => eq.
move: s1 s2; rewrite eq; set d := urank a (union x) => dc pg.
split => //; clear s4 eq; apply: ord_leA => //.
move: (urank_powerset oa pf) => [q1].
move:(urank_pr1 (OS_succ oa) q1) => [_ rp1].
move: (q1); rewrite (universe_succ oa) => /setP_P /(urank_pr oa) [_ rp2].
rewrite (urank_uniq rp2 rp1) => h.
have sa: sub x (powerset (union x)).
  move => t tx; apply /setP_P => s st; union_tac.
move: (urank_sub (OS_succ oa) q1 sa) => [q3].
rewrite - (urank_uniq2 oa (OS_succ oa) xa q3) h -/d /c -/b => bsd.
apply: ord_ub_sup => //; [ move => t tb; ord_tac| ord_tac |].
by move => t /(ord_ltP (proj31 pb)) ha; apply /ord_lt_succP; ord_tac.
Qed.

Lemma universe_stable_inc x:
  is_in_universe x <-> (forall y, inc y x -> is_in_universe y).
Proof.
split.
  by move => [a pa pb] y ye; move: (urank_inc pa pb ye) => [ya _]; exists a.
move => h.
pose p x y := ordinalp y /\ inc x (universe y).
have cp: forall y, inc y x -> p y (choose (p y)).
  by move => y yx; apply choose_pr; move: (h _ yx) => [t ta tb]; exists t.
set E := fun_image x (fun z => choose (p z)).
have ose: ordinal_set E by move => t /funI_P [z /cp [pa _] ->].
move: (OS_sup ose)(ord_sup_ub ose); set a := \osup E => pa pb.
exists (succ_o a); first by fprops.
rewrite (universe_succ pa); apply /setP_P => y yx.
have: inc (choose (p y)) E by apply /funI_P; ex_tac.
by move /pb /universe_inc2; apply; move: (cp _ yx) => [_].
Qed.

Definition transitive_closure X:=
  union (target (induction_defined union X)).

Definition transitive_closure_pr X Y:=
   [/\ transitive_set Y, sub X Y &
     forall Z, transitive_set Z -> sub X Z -> sub Y Z].

Lemma tc_unique X: uniqueness (transitive_closure_pr X).
Proof.
move => a b [p1 p2 p3] [q1 q2 q3].
apply: extensionality; [by apply:p3 | by apply:q3].
Qed.

Lemma tc_exists X:
  transitive_closure_pr X (transitive_closure X).
Proof.
rewrite /transitive_closure.
move: (induction_defined_pr union X) => [].
set f := induction_defined _ _; set Y := union (target f) => sf [ff sjf] f0 fs.
have yp: forall y, inc y Y <-> exists2 n, inc n Bnat & inc y (Vf f n).
  rewrite - sf;move => y; split.
     move /setU_P => [z zy /sjf [x xsf fx]]; ex_tac; ue.
  move => [n nsf yv]; apply /setU_P; exists (Vf f n) => //; Wtac.
split.
    move => t /yp [n nB tv] s st; apply/yp; exists (succ n); fprops.
    rewrite (fs _ nB); union_tac.
  rewrite -f0;move => t tX; apply /yp; exists \0c; fprops.
move => Z tz xz.
have aux: forall n, inc n Bnat -> sub (Vf f n) Z.
  apply: cardinal_c_induction; first by ue.
  by move => n nB h; rewrite (fs _ nB); apply: setU_s2 => y /h /tz.
move => t /yp [n /aux]; apply.
Qed.

Lemma tc_pr1 X:
  transitive_closure X = X \cup (unionf X transitive_closure).
Proof.
move: (tc_exists X) =>[].
set Y := (transitive_closure X) => pa pb pc.
apply: extensionality.
  set Z := _ \cup _; apply: pc; last by apply:subsetU2l.
  move => t tz s st; apply /setU2_P; right; apply /setUf_P;case /setU2_P: tz.
    by move => h;ex_tac; apply:(proj32 (tc_exists t)).
  by move/setUf_P => [y yx etc]; ex_tac; apply: (proj31 (tc_exists y) _ etc).
move => t /setU2_P;case; first by apply: pb.
move /setUf_P => [y ya yb].
exact: (proj33 (tc_exists y) Y pa (pa _ (pb _ ya)) _ yb).
Qed.

Definition foundation_prop x :=
  x = emptyset \/ exists2 y, inc y x & disjoint y x.
Definition foundation_axiom:= forall x, foundation_prop x.

Definition well_founded_set x :=
  forall f, function f -> source f = Bnat ->
    (forall n, (inc n Bnat -> inc (Vf f (succ n)) (Vf f n))) ->
  x <> Vf f \0c.

Section Foundation.
Hypothesis AF: foundation_axiom.

Lemma AF_infinite_seq x: well_founded_set x.
Proof.
move => f ff sf hf.
case: (AF (image_of_fun f)).
  move => ie; empty_tac1 (Vf f \0c); apply/(Vf_image_P1 ff).
  rewrite sf; exists \0c; fprops.
move => [y /(Vf_image_P1 ff) [u usf -> h]]; rewrite sf in usf.
case: (in_set0 (x := Vf f (succ u))). rewrite -h.
empty_tac1 (Vf f (succ u)).
apply/(Vf_image_P1 ff); exists (succ u) => //; rewrite sf; fprops.
Qed.

Lemma AF_irreflexive x: ~(inc x x).
Proof.
move => xx; case: (AF (singleton x)); first by apply/nonemptyP; fprops.
move => [y /set1_P -> /set0_P s]; case: (s x); apply /setI2_P; fprops.
Qed.

Lemma AF_asymmetric x: asymmetric_set x.
Proof.
move => u v _ _ uv vu.
case: (AF (doubleton u v)); first by apply /nonemptyP; exists u; fprops.
move => [y /set2_P]; case => ->; apply/nonemptyP.
  exists v;fprops.
exists u;fprops.
Qed.

Lemma AF_ordinal x:
  ordinalp x <-> (transitive_set x /\
   forall u v, inc u x -> inc v x -> [\/ inc u v, inc v u | u = v]).
Proof.
split.
  move => ox; split; first by apply: ordinal_transitive.
  move => u v ux vx; apply: ordinal_trichotomy; ord_tac.
move => [trx xp]; apply /ordinal_pr1; split => //; last by apply:AF_asymmetric.
have pa: (substrate (ordinal_oa x)) = x.
  by rewrite graph_on_sr => // a ax; right.
have pb: order (ordinal_oa x).
  pose r a b := [/\ inc a x, inc b x & (inc a b \/ a = b)].
  have ->: ((ordinal_oa x) = graph_on r x).
    by apply: Zo_exten1 => t /setX_P [_ px qx]; split => //; move => [_ _].
  apply:order_from_rel; split.
      move => b a c [ax bx ab] [_ cx bc]; split => //.
      case :(ab) => ab'; last by ue.
      case :bc=> bc; last by ue.
      move: (AF_asymmetric ax bx ab') => nba.
      case: (xp _ _ ax cx); first (by left); last first.
        by move => ac; case: nba; rewrite ac.
      move => ca; case: (AF (tripleton a b c)).
        by move/set0_P=> h; case: (h a); apply/set3_P; constructor 1.
     move => [y /set3_P ya]; move /set0_P => h; case: ya => yv.
      case: (h c); rewrite yv;apply /setI2_P ; split=> //; apply/set3_P; in_TP4.
      case: (h a); rewrite yv;apply /setI2_P ; split=> //; apply/set3_P; in_TP4.
      case: (h b); rewrite yv;apply /setI2_P ; split=> //; apply/set3_P; in_TP4.
    move => a b [ax bx]; case => // ab [_ _]; case => // ba.
    case: (AF_asymmetric ax bx ab ba).
  by move => a b [ax bx etc]; split; split => //; right.
split => //; rewrite pa.
move => y yx /nonemptyP ney; case: (AF y) => // [] [z zy ztc].
exists z; red; rewrite (iorder_sr pb); last by ue.
split => // t ty; apply /iorder_gleP => //.
move: (yx _ zy)(yx _ ty) => zx tx.
apply /graph_on_P1; split => //.
case: (xp _ _ zx tx); [ by left | move => tz; empty_tac1 t | by right].
Qed.

Lemma AF_universe x: is_in_universe x.
Proof.
move: (tc_exists x) => []; set b1 := (transitive_closure x) => tb xb etc.
set b:= Zo b1 (fun z => ~(is_in_universe z)).
case: (AF b).
   move => be; apply /universe_stable_inc => y yx; ex_middle bad.
   by empty_tac1 y; apply: Zo_i => //; apply: xb.
move => [y yb ye]; move: (Zo_S yb) => yb1.
move: (Zo_hi yb) => yne.
have [u uy nuu]: exists2 u, inc u y & ~ (is_in_universe u).
  ex_middle nxu; case: yne; apply /universe_stable_inc => s sx.
  ex_middle bad1; case: nxu; ex_tac.
by empty_tac1 u; apply:Zo_i => //; apply: (tb y).
Qed.

End Foundation.

Lemma universe_AF x: is_in_universe x -> foundation_prop x.
Proof.
case: (emptyset_dichot x); first by left.
move => [e ex] [a oa xua]; right.
set U := fun_image x (urank a).
have neU: nonempty U by exists (urank a e); apply /funI_P; ex_tac.
have ose: ordinal_set U.
  move => b /funI_P [z zx ->].
  move: (urank_pr1 oa (universe_trans oa xua zx)) => [h _]; ord_tac.
move:(ordinal_setI neU ose); set y:= intersection U => yU.
move: (ose _ yU) => yo.
move/funI_P: (yU) => [z zx zu]; ex_tac; apply /set0_P => t /setI2_P [tz tx].
have bu: inc (urank a t) U by apply /funI_P; ex_tac.
case: (ordinal_irreflexive (ose _ bu)); apply: (setI_s1 bu).
move:(universe_trans oa xua zx) => za.
by move: (urank_inc oa za tz)=> [ _]; rewrite - zu => /(ord_ltP yo).
Qed.

Lemma AF_universe': foundation_axiom <-> forall x, is_in_universe x.
Proof.
split; first by apply: AF_universe.
by move => h x; apply (universe_AF (h x)).
Qed.

Lemma universe_omega_props x: inc x (universe omega0) ->
   [/\ finite_set x, sub x (universe omega0) & inc (urank omega0 x) Bnat].
Proof.
have aux: forall n, inc n Bnat -> finite_set (universe n).
  apply: cardinal_c_induction.
    by rewrite universe_0; apply: emptyset_finite.
  move => n nB /card_finite_setP Hrec.
  rewrite (succ_of_Bnat nB) (universe_succ (Bnat_oset nB)).
  apply /card_finite_setP; rewrite card_setP - cpow_prb; fprops.
move => xo.
move:(xo);rewrite {1} (universe_limit omega_limit) => /setUf_P [].
move => n nB etc; move:(Bnat_oset nB) => on.
split.
    move: (universe_inc2 (proj1 (ord_succ_lt on)) etc).
    rewrite (universe_succ on); move /setP_P => sn.
    apply:(sub_finite_set sn (aux _ nB)).
  by apply: (universe_trans OS_omega).
move: (urank_pr1 on etc) => [[pa _] pb].
rewrite (urank_uniq2 OS_omega on xo etc).
apply/(ord_ltP OS_omega).
move /(ord_ltP OS_omega): nB; by apply: (ord_le_ltT).
Qed.

Lemma universe_omega_hi x:
   finite_set x -> sub x (universe omega0) -> inc x (universe omega0).
Proof.
move => fxs ux.
set s := fun_image x (fun t => (urank omega0 t)).
case: (emptyset_dichot x) => nex.
  rewrite nex (universe_limit omega_limit);apply /setUf_P.
  exists \1o;fprops; rewrite - succ_o_zero (universe_succ OS0) universe_0.
  apply: setP_Ti.
have nes: nonempty s.
  exists (urank omega0 (rep x)); apply /funI_P;exists (rep x) => //.
  by apply: rep_i.
have fss: finite_set s by apply: finite_fun_image.
have sr: sub s Bnat.
  move => t /funI_P [z zx ->].
  by move: (universe_omega_props (ux _ zx)) => [].
move: (finite_subset_Bnat sr fss nes) => [n].
move /funI_P => [z /ux /universe_omega_props [_ _ za] zb] pb.
set k := succ_o (succ_o n).
have on: ordinalp n by rewrite zb; apply: Bnat_oset.
rewrite (universe_limit omega_limit); apply /setUf_P; exists k.
  by move: (proj33 omega_limit)=> rec; apply: (rec); apply: rec; rewrite zb.
rewrite universe_succ; last by apply: OS_succ.
apply /setP_P => t tx.
have: inc (urank omega0 t) s by apply /funI_P; ex_tac.
move /pb => /ordinal_cardinal_le /universe_inc2 pd.
move :(urank_pr1 OS_omega (ux _ tx)) => [_ [_ pe _]].
rewrite (universe_succ on);apply/setP_P; apply: sub_trans pe pd.
Qed.

Definition rept_union x := Vf (induction_defined union x).
Definition finite_depth x :=
   exists2 n, inc n Bnat & rept_union x n = emptyset.
Definition rec_finite x:= forall n, inc n Bnat -> finite_set (rept_union x n).
Definition hereditarily_finite x := rec_finite x /\ finite_depth x.

Lemma rept_union_pr x (f := rept_union x):
   f \0c = x /\ (forall n, inc n Bnat -> f (succ n) = union (f n)).
Proof.
move: (induction_defined_pr union x) => [pa pb pc pd]; split => //.
Qed.

Lemma rept_union_inc x y: inc y x ->
  forall n, inc n Bnat -> sub (rept_union y n) (rept_union x (succ n)).
Proof.
move: (rept_union_pr y) => [sc sd] yx.
move: (rept_union_pr x) => [sa sb].
apply:cardinal_c_induction.
    by rewrite sc (sb _ BS0) sa; apply: setU_s1.
move => n nB Hrec.
rewrite (sd _ nB) (sb _ (BS_succ nB)).
move => t /setU_P [z tz /Hrec etc]; union_tac.
Qed.

Lemma hereditarily_finite_pr x:
  hereditarily_finite x ->
  finite_set x /\ (forall y, inc y x -> hereditarily_finite y).
Proof.
move=> [pa [m mB xe]].
move: (rept_union_pr x) => [sa sb].
split; first by move: (pa _ BS0); rewrite sa.
move => y /rept_union_inc aux.
split.
  move => n nB; exact (sub_finite_set (aux _ nB) (pa _ (BS_succ nB))).
exists m; first by exact.
by move: (aux _ mB); rewrite (sb _ mB) xe setU_0 => /sub_set0.
Qed.

Lemma universe_omega_HF x: inc x (universe omega0) <->
   hereditarily_finite x.
Proof.
split; last first.
  move => [rf [n nb]]; move: n nb x rf.
  apply: cardinal_c_induction.
    move => x rd; rewrite (proj1 (rept_union_pr x)) => ->.
    apply: universe_omega_hi; [apply:emptyset_finite | apply: sub0_set].
  move => n nB Hrec x recf fn.
  move: (rept_union_pr x) => [pa pb]; apply: universe_omega_hi.
    by move: (recf _ BS0); rewrite pa.
  move => t tx; move:(rept_union_inc tx nB); rewrite fn=> /sub_set0;apply: Hrec.
  move:(rept_union_inc tx) => aux.
  move => k kB; exact: (sub_finite_set (aux _ kB) (recf _ (BS_succ kB))).
move => h.
move: (rept_union_pr x) => [pa pb].
have aux: forall n, inc n Bnat -> (inc (rept_union x n) (universe omega0)).
  apply: cardinal_c_induction; first by rewrite pa.
  by move => n nB; move /(urank_union OS_omega)=> []; rewrite (pb _ nB).
split; first by move => n /aux /universe_omega_props [].
move:(proj33 (universe_omega_props h)); set n := urank _ _ => nB.

have rec: forall k, inc k Bnat -> k <=c n ->
     urank omega0 (rept_union x k) = n -c k.
  apply: cardinal_c_induction; first by rewrite pa (cdiff_n_0 nB).
  move => k kb Hrec skn.
  move: (urank_union OS_omega (aux _ kb)) => [_]; rewrite - (pb _ kb).
  suff: union (n -c k) = n -c succ k.
     by move <-; rewrite (Hrec (card_leT (proj1 (card_lt_succ kb)) skn)).
  move: (cdiff_pr skn). set c := n -c (succ k).
  have cb: inc c Bnat by rewrite /c; fprops.
  rewrite (csum_via_succ1 _ kb) -(csum_via_succ _ cb) csumC => h1.
  rewrite (cdiff_pr2 (BS_succ cb) kb h1) (succ_of_Bnat cb) succo_K //.
  by apply: Bnat_oset.
move: (urank_pr1 OS_omega (aux _ nB)).
move: (rec _ nB (card_leR (CS_Bnat nB))); rewrite cdiff_n_n => ->.
by move => [_ [_]]; rewrite universe_0 => /sub_set0 => sa _;exists n.
Qed.

Lemma rept_union_inc2 x y n: inc n Bnat -> inc y (rept_union x (succ n)) ->
  exists2 z, inc z x & inc y (rept_union z n).
Proof.
move => nB; rewrite (proj2 (rept_union_pr x) _ nB).
move: n nB x y;apply: cardinal_c_induction.
  move => x y; rewrite (proj1 (rept_union_pr x)) => /setU_P [z yz zx];ex_tac.
  by rewrite (proj1(rept_union_pr z)).
move => n nB Hrec x y.
rewrite (proj2 (rept_union_pr x) n nB) => /setU_P [z yz /Hrec [t tx zu]].
ex_tac; rewrite (proj2 (rept_union_pr t) n nB); union_tac.
Qed.

Lemma infinite_depth_prop x (f := rept_union x):
  (forall n, inc n Bnat -> (finite_set (f n) /\ nonempty (f n))) ->
  ~ (well_founded_set x).
Proof.
rewrite /f.
pose H x :=(forall n,
    inc n Bnat -> finite_set (rept_union x n) /\ nonempty (rept_union x n)).
rewrite -/(H x) => Hx wfx.
have aux: (forall x, H x -> exists2 y, inc y x & H y).
  move => z hz; ex_middle bad.
  move: (proj1 (rept_union_pr z)) => h0.
  case: (emptyset_dichot z) => znz.
   by move: (proj2 (hz _ BS0)); rewrite h0 znz; move => [t /in_set0].
  pose Ha x := (forall n, inc n Bnat -> finite_set (rept_union x n)).
  have hay: forall y, inc y z -> Ha y.
    move => y yz n nB; move: (proj1 (hz _ (BS_succ nB))) => tu.
    by move: (rept_union_inc yz nB) => /sub_finite_set; apply.
    have hby: forall y, inc y z ->
       exists2 n, inc n Bnat & (rept_union y n) = emptyset.
      move => y yz; ex_middle bad2; case: bad; ex_tac.
      move => n nB; split; first by apply: (hay _ yz _ nB).
      case: (emptyset_dichot (rept_union y n)) => // h; case: bad2; ex_tac.
    pose q y n := inc n Bnat /\ (rept_union y n) = emptyset.
    pose tn y:= choose (q y).
    have tnp: forall y, inc y z -> q y (tn y).
       by move => y /hby [n nb etc]; apply: choose_pr; exists n.
    have tmp: forall y m, inc y z -> inc m Bnat -> (tn y) <=c m ->
        rept_union y m = emptyset.
      move => y m yz mB le; rewrite - (cdiff_pr le); move: (BS_diff (tn y) mB).
      move: (tnp _ yz) => [sa sb].
      move: (m -c tn y); apply : cardinal_c_induction; first by aw; fprops.
      move => n nB;rewrite (csum_via_succ _ nB).
      rewrite (proj2(rept_union_pr y) _ (BS_sum sa nB)) => ->; exact setU_0.
    have [n nB pn]: exists2 n, inc n Bnat & forall y, inc y z -> (tn y) <=c n.
       set s := fun_image z tn.
       have p1: sub s Bnat by move => y /funI_P [t /tnp [aa _] ->].
       have p2: finite_set s.
         by apply finite_fun_image; move: (proj1 (hz _ BS0)); rewrite h0.
       have p3: nonempty s by apply: funI_setne.
       move: (finite_subset_Bnat p1 p2 p3) => [n ns etc].
       exists n; first by apply: p1.
       move => y yz; apply: etc; apply /funI_P; ex_tac.
   move: (proj2 (hz _ (BS_succ nB))) => [s sp].
   move: (rept_union_inc2 nB sp) => [y yz].
   by rewrite (tmp _ _ yz nB (pn _ yz)) => /in_set0.
pose p x y:= (inc y x /\ H y); pose nf x := choose (p x).
move: (induction_defined_pr nf x); set g := induction_defined nf x.
move => [pa pb pc pd].
have pe: (forall n, inc n Bnat -> inc (Vf g (succ n)) (Vf g n)).
  have px: forall x, H x -> p x (nf x).
    by move => z /aux [y yz hy]; apply: (choose_pr); exists y.
  have py: forall n, inc n Bnat ->p (Vf g n) (Vf g (succ n)).
    apply: cardinal_c_induction; first by rewrite (pd _ BS0) pc; apply: px.
    by move => n nB [_ h]; rewrite (pd _ (BS_succ nB)); apply: px.
  by move => n /py [].
by case: (wfx g (proj1 pb) pa pe); rewrite - pc.
Qed.

Lemma AC_variants:
   let AC:= forall x, (forall z, inc z x -> nonempty z) ->
      (forall z z', inc z x -> inc z' x -> z = z' \/ disjoint z z') ->
      (exists y, forall z, inc z x -> singletonp (y \cap z)) in
   (AC -> (forall f, nonempty_fam f -> nonempty (productb f)))
   /\ (AC -> forall x, exists y,
      [/\ fgraph y, domain y = powerset x -s1 emptyset &
        forall z, sub z x -> nonempty z -> inc (Vg y z) z])
   /\ ((forall x, exists r, forall z, inc z x -> nonempty z -> inc (r z) z)
        -> AC).
Proof.
move => AC.
have pr1: AC -> (forall f, nonempty_fam f -> nonempty (productb f)).
  move => ac f nef.
  set d := domain f.
  set x := fun_image d (fun z => (singleton z) \times (Vg f z)).
  have pa: (forall z, inc z x -> nonempty z).
    move => z /funI_P [u /nef [v ud] ->];exists (J u v); apply: setXp_i; fprops.
  have pb: (forall z z', inc z x -> inc z' x -> z = z' \/ disjoint z z').
    move => z z' /funI_P [u /nef _ ->] /funI_P [v /nef _ ->].
    case: (equal_or_not u v); first by move => ->; left.
    move => uv; right; apply: disjoint_pr => w /setX_P [_ /set1_P pw _].
    by move => /setX_P [_ /set1_P pw' _]; case: uv; rewrite -pw -pw'.
  move: (ac _ pa pb) => [y yp].
  set y1:= y \cap (union x).
  have yp': forall z, inc z x -> singletonp (y1 \cap z).
    move => z zx; move/yp: (zx) => [t t1];exists t; apply: set1_pr.
      move: (set1_1 t); rewrite -t1 => /setI2_P [ty tz]; apply /setI2_P.
      split => //; apply /setI2_P; split => //; union_tac.
    move => u /setI2_P [/setI2_P [p1 p2] p3].
    by apply /set1_P; rewrite -t1; apply /setI2_P.
  have pc: forall s, inc s y1 ->
    exists2 b, inc b d & let a:= singleton b \times Vg f b in
      [/\ inc a x, y1 \cap a = singleton s & inc s (singleton b \times Vg f b)].
    move => s sy1; move: (sy1) => /setI2_P [_ /setU_P [a sa sb]].
    have pc:inc s (y1 \cap a) by apply /setI2_P.
    move /funI_P: (sb) => [b ba bb]; ex_tac; rewrite -bb; split => //.
    apply: set1_pr1; first by exists s.
    by move => z za; move:(yp' _ sb) => /singletonP [_ ss]; apply ss.
  have sy1: fgraph y1.
     split; first by move => t /pc [b _ [_ _ /setX_P []]].
     move => s s' s1 s2 sp.
     move: (pc _ s1)(pc _ s2) => [a ax [i1a i2a i3a]] [b bx [i1b i2b i3b]].
     move: i3a i3b => /setX_P [_ /set1_P psa _] /setX_P [_ /set1_P psb _].
     by apply: set1_inj; rewrite -i2a -i2b - psa sp psb.
  have dy1: domain y1 = domain f.
     set_extens t.
       by move /funI_P => [z /pc [b bd [_ _ /setX_P [_ /set1_P -> _]]]-> ].
     move => tdf.
     set z := (singleton t \times Vg f t).
     have zx: inc z x by apply /funI_P;ex_tac.
     move: (yp' _ zx) => [a sa].
     have ay1: inc a y1 by move: (set1_1 a); rewrite - sa => /setI2_P [].
     have : inc a z by move: (set1_1 a); rewrite - sa => /setI2_P [].
     move => /setX_P [_ /set1_P pat _].
     apply /funI_P; by ex_tac.
  exists y1; apply /setXb_P; split => //.
  move => i idf.
  set z := (singleton i \times Vg f i).
  have zx: inc z x by apply /funI_P;ex_tac.
  move: (yp' _ zx) => [a sa].
  have ay1: inc a y1 by move: (set1_1 a); rewrite - sa => /setI2_P [].
  move: (pc _ ay1) => [b b1 [b2 b3 b4]].
  have : inc a z by move: (set1_1 a); rewrite - sa => /setI2_P [].
  move => /setX_P [_ /set1_P pat _].
  move: (set1_1 a); rewrite -b3 => /setI2_P [_ /setX_P [_ /set1_P sb sc]].
  by rewrite - pat - (pr2_V sy1 ay1) sb.
have pr2: (AC -> forall x, exists y,
      [/\ fgraph y, domain y = powerset x -s1 emptyset &
        forall z, sub z x -> nonempty z -> inc (Vg y z) z]).
  move => ac x; set f := Lg (powerset x -s1 emptyset) id.
  have : nonempty_fam f.
    by rewrite /f;hnf; bw;move => t tp; bw; move /setC1_P: tp => [_ /nonemptyP].
  move /(pr1 ac) => [y /setXb_P [pa pb pc]]; exists y; split => //.
    rewrite pb /f; bw.
  move => z zb zne.
  have zi: inc z (powerset x -s1 emptyset).
     apply /setC1_P; split => //; [by apply/setP_P | by apply /nonemptyP].
  have: inc z (domain f) by rewrite /f; bw.
  move /pc;rewrite /f; bw.
have pr3: (forall x : Set,
     exists r : Set -> Set,
       forall z : Set, inc z x -> nonempty z -> inc (r z) z) -> AC.
  move => h x x1 x2; move: (h x) => [r ra].
  set y := fun_image x r; exists y => z zx.
  have p1: inc (r z) z by apply: ra => //; apply: x1.
  have p2: inc (r z) y by apply /funI_P;ex_tac.
  apply/singletonP; split; first by exists (r z); apply/ setI2_P.
  move => a b /setI2_P [/funI_P [u ua ub] az] /setI2_P [/funI_P [v va vb] bz].
  move: (ra _ ua (x1 _ ua)) (ra _ va (x1 _ va)) => uc vc.
  move: (x2 _ _ zx ua); case => zu; last by empty_tac1 a; ue.
  move: (x2 _ _ zx va); case => zv; last by empty_tac1 b; ue.
  by rewrite ub vb - zu -zv.
done.
Qed.

Section ModelTheory.
Variables (U: property)(R: relation).

Definition unionA_pr x u :=
  U u /\ (forall y, U y -> (R y u <->
            (exists z, [/\ U z, R z x & R y z]))).
Definition powersetA_pr x p:=
  U p /\ (forall y, U y -> (R y p <->
             (forall t, U t -> R t y -> R t x))).
Definition comprehensionA_pr x (p:property) c :=
  U c /\ (forall z, U z -> (R z c <-> (R z x /\ p z))).
Definition replacementA_pr x (p:property) (f: fterm) r :=
  U r /\ (forall z, U z ->
        (R z r <-> (exists2 t, U t & [/\ R t x, p t & z = f t]))).
Definition emptysetA_pr e:= U e /\ forall t, U t -> ~ (R t e).

Definition pairA_pr a b p :=
  U p /\ (forall t, U t -> (R t p <-> t = a \/ t = b)).

Definition extensionalityA :=
  (forall x y, U x -> U y -> (forall z, U z -> (R z x <-> R z y)) ->
       x = y).

Definition unionA := forall x, U x -> exists u, unionA_pr x u.
Definition powersetA := forall x, U x -> exists p, powersetA_pr x p.
Definition comprehensionA :=
   forall x (p:property), U x -> exists c, comprehensionA_pr x p c.
Definition replacementA :=
  forall x (p: property) f, U x ->
      (forall t, U t -> R t x -> p t -> U (f t)) ->
     exists r, replacementA_pr x p f r.
Definition pairA := forall a b, U a -> U b -> exists c, pairA_pr a b c.

Lemma model_uniqueness: extensionalityA ->
  [/\ forall x, uniqueness (unionA_pr x),
      forall x, uniqueness (powersetA_pr x),
      forall x p, (uniqueness (comprehensionA_pr x p)),
      forall x p f, (uniqueness (replacementA_pr x p f)) &
      uniqueness emptysetA_pr /\
      forall a b, uniqueness (pairA_pr a b)].
Proof.
move => ea.
have pa: forall x, uniqueness (unionA_pr x).
  move => x y1 y2 [u1 p1] [u2 p2]; apply ea => // z uz; split.
    by move /(p1 _ uz) => [t [ta tb tc]]; apply /(p2 _ uz); exists t.
    by move /(p2 _ uz) => [t [ta tb tc]]; apply /(p1 _ uz); exists t.
have pb: forall x, uniqueness (powersetA_pr x).
   move => x y1 y2 [u1 p1] [u2 p2]; apply ea => // z uz; split.
     by move /(p1 _ uz) => h; apply /(p2 _ uz).
     by move /(p2 _ uz) => h; apply /(p1 _ uz).
have pc: forall x p, (uniqueness (comprehensionA_pr x p)).
   move => x p y1 y2 [u1 p1] [u2 p2]; apply ea => // z uz; split.
     by move /(p1 _ uz) => h; apply /(p2 _ uz).
     by move /(p2 _ uz) => h; apply /(p1 _ uz).
have pd: forall x p f, (uniqueness (replacementA_pr x p f)).
   move => x p f y1 y2 [u1 p1] [u2 p2]; apply ea => // z uz; split.
     by move /(p1 _ uz) => h; apply /(p2 _ uz).
     by move /(p2 _ uz) => h; apply /(p1 _ uz).
have pe: uniqueness emptysetA_pr.
  move => e e' [u1 p1] [u2 p2]; apply: ea => // z uz; split => h.
      by case: (p1 _ uz).
      by case: (p2 _ uz).
have pf: forall a b, uniqueness (pairA_pr a b).
   move => a b y1 y2 [u1 p1] [u2 p2]; apply ea => // z uz; split.
     by move /(p1 _ uz) => h; apply /(p2 _ uz).
     by move /(p2 _ uz) => h; apply /(p1 _ uz).
split => //.
Qed.

Lemma model_replacement_comprehension: replacementA -> comprehensionA.
Proof.
move => h x p ux.
have su:(forall t, U t -> R t x -> p t -> U t) by move => t.
move: (h x p id ux su)=> [r [r1 r2]]; exists r; split => // z uz.
split; first by move /(r2 _ uz)=> [t _ [ta tb ->]].
by move=> [pa pb]; apply /(r2 _ uz); exists z.
Qed.

Definition emptysetU := choose (fun z => emptysetA_pr z).
Definition unionU x:= choose (fun z => unionA_pr x z).
Definition powersetU x:= choose (fun z => powersetA_pr x z).
Definition setofU x p := choose (fun z => comprehensionA_pr x p z).
Definition funimageU x p f := choose (fun z => replacementA_pr x p f z).
Definition doubletonU a b := choose (fun z => pairA_pr a b z).

Definition ZF_axioms1 :=
  [/\ (exists x, U x), extensionalityA, unionA, powersetA & replacementA].

Lemma model_existence: ZF_axioms1 ->
  [/\ emptysetA_pr (emptysetU),
       forall x, U x -> unionA_pr x (unionU x),
       forall x, U x -> powersetA_pr x (powersetU x),
       forall x r, U x -> comprehensionA_pr x r (setofU x r) &
       forall x (p: property) f,
           U x -> (forall t, U t -> R t x -> p t -> U (f t)) ->
       replacementA_pr x p f (funimageU x p f)].
Proof.
move => [[x0 ux0] ea ua pa ra].
move: (model_replacement_comprehension ra) => ca.
have p1: emptysetA_pr (emptysetU).
  apply: choose_pr.
  move :(ca x0 (fun t => ~(R t x0)) ux0) => [c [c1 c2]].
  by exists c; split => // t ut; move /(c2 _ ut) => [].
have p2: forall x, U x -> unionA_pr x (unionU x).
   move => x /ua; apply: choose_pr.
have p3: forall x, U x -> powersetA_pr x (powersetU x).
   move => x /pa; apply: choose_pr.
have p4: forall x r, U x -> comprehensionA_pr x r (setofU x r).
   move => x r /ca => h; apply: choose_pr; apply: h.
have p5: forall x (p: property) f,
   U x -> (forall t, U t -> R t x -> p t -> U (f t)) ->
   replacementA_pr x p f (funimageU x p f).
   move => x p f ux hf; apply: choose_pr; exact: (ra _ _ _ ux hf).
done.
Qed.

Lemma model_existence2 : ZF_axioms1 ->
  forall a b, U a -> U b -> pairA_pr a b (doubletonU a b).
Proof.
move => ax a b ua ub.
move: (model_existence ax) => [ea una pa ca ra].
move: ax => [es eaa uaa paa raa].
move: ea => []; set e := emptysetU => [ea1 ea2].
move: (pa _ ea1) => []; set e1 := (powersetU e) => [eb1 eb2].
have qa: R e e1 by apply /(eb2 _ ea1).
have qb: forall x, U x -> (R x e1 <-> x = e).
   move => x xu; split; last by move ->.
   move /(eb2 _ xu) => te; apply:(eaa _ _ xu ea1) => s us; split.
      apply: (te _ us).
   by move => v; case: (ea2 _ us).
have ee1: e1 <> e.
  by move => ee1; move /(qb _ eb1): (ee1); rewrite ee1; apply: ea2.
move: (pa _ eb1) => []; set e2 := (powersetU e1) => [ec1 ec2].
have qc: R e e2 by apply /(ec2 _ ea1) => t ut ba; case: (ea2 _ ut).
have qd: R e1 e2 by apply /(ec2 _ eb1).
have qe: forall x, U x -> (R x e2 <-> x = e \/ x = e1).
   move => x Ux; split; last by case => ->;[ apply qc | apply: qd].
   move => xe2; move/ (ec2 _ Ux): xe2 => sa.
   case: (equal_or_not x e) => xne; [by left | right].
   apply: (eaa _ _ Ux eb1) => z uz; split; first by apply: sa.
   move /(qb _ uz) => ->.
   case: (p_or_not_p (exists2 t, U t & R t x)).
    by move => [t ut tx]; move /(sa _ ut): (tx) => /(qb _ ut) => <-.
  move => ne; case: xne; apply: (eaa _ _ Ux ea1) => s su; split.
    by move => sx; case: ne; exists s.
  by move => sz; case: (ea2 _ su).
pose f := variant e a b.
have fa: f e = a by rewrite /f /variant; Ytac0.
have fb: f e1 = b by rewrite /f /variant; Ytac0.
have fp: (forall t, U t -> R t e2 -> True -> U (f t)).
  by move => t _ _ _; rewrite /f /variant;Ytac h.
move: (ra e2 (fun _ => True) f ec1 fp)=> [].
set c := funimageU _ _ _ => [c1 c2].
apply: choose_pr; exists c;split => // t ut; split.
  move/(c2 _ ut) => [s us [/(qe _ us) rs2 _ ->]].
  by case: rs2 => ->; [ left | right].
case => ->.
  by apply /(c2 _ ua); exists e.
by apply /(c2 _ ub); exists e1.
Qed.

Definition unionU2 a b := unionU (doubletonU a b).
Definition intersectionU2 a b := setofU a (fun z => R z b).

Lemma model_union: ZF_axioms1 ->
  forall a b, U a -> U b ->
  ( (forall z, U z -> (R z (unionU2 a b) <-> R z a \/ R z b)))
   /\ (forall z, U z -> (R z (intersectionU2 a b) <-> R z a /\ R z b)).
Proof.
move => ax a b ua ub.
move: (model_existence ax) => [ea una pa ca ra].
rewrite /unionU2 /intersectionU2.
move: (model_existence2 ax ua ub) => []; set c := (doubletonU a b) => cu cp.
split.
  move => z uz; move: (una c cu) => [u1 u2]; split.
     by move /(u2 _ uz) => [t [tu /(cp _ tu)]]; case => ->; [left| right].
  case => zx; apply /(u2 _ uz); [exists a | exists b];split => //.
    by apply/ (cp _ ua); left.
    by apply/ (cp _ ub); right.
move=> z uz.
move: (ca a (fun z => R z b) ua) => []; set d := (setofU _ _) => [du].
by apply.
Qed.

Definition choiceA:= forall x,
    U x -> (forall z, U z -> R z x -> z <> emptysetU) ->
    (forall z1 z2, U z1 -> U z2 -> R z1 x -> R z2 x ->
        (z1 = z2 \/ intersectionU2 z1 z2 = emptysetU)) ->
   exists2 y, U y &
     forall z, U z -> R z x -> exists2 s, U s &
       intersectionU2 y z = doubletonU s s.
Definition infiniteA:=
   exists2 x, U x &
    (R emptysetU x /\
     forall t, U t -> R t x -> R (unionU2 t (doubletonU t t)) x).
Definition foundationA :=
  forall x, U x ->
  x = emptysetU \/ exists2 y, U y &
     R y x /\ intersectionU2 y x = emptysetU.

End ModelTheory.

Lemma universe_mo1 (U: property):
   (forall x y, U x -> inc y x -> U y) ->
   (forall x y, U x -> sub y x -> U y) ->
  (extensionalityA U inc)
  /\ (forall x r, U x -> (setofU U inc x r) = (Zo x r))
  /\ (comprehensionA U inc)
  /\ (forall x, U x -> U (union x) ->
      (unionA_pr U inc x (union x)) /\ (unionU U inc x = union x))
  /\ (forall x, U x -> U (powerset x) ->
      (powersetA_pr U inc x (powerset x)) /\ (powersetU U inc x = powerset x))
  /\ ( forall a b, U a -> U b -> U (doubleton a b) ->
       (pairA_pr U inc a b (doubleton a b))
       /\ (doubletonU U inc a b = doubleton a b))
  /\ (forall a b, U a -> intersectionU2 U inc a b = a \cap b)
  /\ (forall a b, U a -> U b -> U (doubleton a b) -> U (a\cup b) ->
     unionU2 U inc a b = a \cup b)
  /\ ((exists x, U x) -> emptysetU U inc = emptyset)
  /\ ((forall a, inc a omega0 -> U (singleton a))
   -> (forall a, inc a omega0 -> U (doubleton a (singleton a)))
   -> U omega0
   -> infiniteA U inc)
  /\ ( (forall a b, U a -> U b -> U (doubleton a b)) ->
       (forall a b, U a -> U b -> U (a \cup b)) ->
        infiniteA U inc -> U omega0)
  /\ ( (forall x, U x -> x = emptyset \/ exists2 y, U y &
     inc y x /\ disjoint y x) -> foundationA U inc).
Proof.
move => su su'.
have p1: extensionalityA U inc.
  move => x y ux uy h; apply: extensionality => t ta.
    by apply /(h _ (su _ _ ux ta)).
  by apply /(h _ (su _ _ uy ta)).
move: (model_uniqueness p1) => [uu up uc ur [ue upa]].
have aux: forall (p:property) x, p x -> uniqueness p -> (choose p) = x.
  by move => p x px unp; apply: unp => //; apply: choose_pr; exists x.
have p2: forall x p, U x -> (comprehensionA_pr U inc x p (Zo x p)).
  move => x p ux; split; first by apply: (su' x _ ux); apply: Zo_S.
  by move => z uz; split; move/Zo_P.
have p3: (comprehensionA U inc).
  by move => x p ux; exists (Zo x p); apply: p2.
have p4: (forall x r, U x -> (setofU U inc x r) = (Zo x r)).
  move => x p ux; apply: aux; [ by apply: p2 | apply: uc].
have p5: forall x, U x -> U (union x) ->
  (unionA_pr U inc x (union x)) /\ (unionU U inc x = union x).
  move => x ux uux.
  have pa:unionA_pr U inc x (union x).
    split=> // y uy; split => //.
       move /setU_P => [z za zb]; exists z; split => //; apply: (su _ _ ux zb).
    move => [z [_ zx zy]]; union_tac.
  split => //; apply: aux; [ by apply: pa | apply: uu].
have p6: (forall x, U x -> U (powerset x) ->
  (powersetA_pr U inc x (powerset x)) /\ (powersetU U inc x = powerset x)).
  move => x ux uux.
  have pa:(powersetA_pr U inc x (powerset x)).
    split => // y uy; split.
     move /setP_P => yx t _; apply: yx.
     move => h; apply /setP_P => t tx; apply: h => //;apply (su _ _ uy tx).
  split => //; apply: aux; [ by apply: pa | apply: up].
have p7: forall a b, U a -> intersectionU2 U inc a b = a \cap b.
  move => a b ua ; rewrite /intersectionU2 (p4 _ _ ua);set_extens t.
    by move /Zo_P /setI2_P.
    by move /setI2_P => h; apply/Zo_P.
have p8: forall a b, U a -> U b -> U (doubleton a b) ->
  (pairA_pr U inc a b (doubleton a b))
   /\ (doubletonU U inc a b = doubleton a b).
  move => a b ua ub uab.
  have pa:(pairA_pr U inc a b (doubleton a b)).
    split=> // y uy; split => //; by move /set2_P.
  split => //; apply: aux; [ by apply: pa | apply: upa].
have p9: forall a b, U a -> U b -> U (doubleton a b) -> U (a\cup b) ->
  unionU2 U inc a b = a \cup b.
  move => a b ua ub ud uab.
  rewrite /unionU2 (proj2 (p8 _ _ ua ub ud)).
  by rewrite (proj2 (p5 _ ud uab)).
have p0: (exists x, U x) -> emptysetU U inc = emptyset.
  move => [x Ux]; apply: aux => //.
  split; last by move => t _ /in_set0.
  move: (p2 x (fun _:Set => False) Ux) => [].
  have -> // : (Zo x (fun _ : Set => False))= emptyset.
    apply /set0_P; apply /Zo_hi.
have p10:
   (forall a, inc a omega0 -> U (singleton a))
   -> (forall a, inc a omega0 -> U (doubleton a (singleton a)))
   -> U omega0
   -> infiniteA U inc.
  move=> q1 q2 q3; exists omega0 => //.
  move: omega_limit => [o1 o2 o3].
  have neu: (exists x, U x) by exists omega0.
  rewrite (p0 neu); split; [exact | move => t ut to].
  move: (p8 _ _ ut ut (q1 _ to))=> [[sa _] ->].
  move: (o3 _ to) => so.
  by rewrite (p9 _ _ ut sa (q2 _ to) (su _ _ q3 so)).
have p11:((forall a b, U a -> U b -> U (doubleton a b)) ->
    (forall a b, U a -> U b -> U (a \cup b)) ->
    infiniteA U inc -> U omega0).
  move => pa pb [u ux [uy uz]].
  have ee: (exists x : Set, U x) by exists u.
  rewrite (p0 ee) in uy.
  have pc: forall t, inc t u -> inc (succ_o t) u.
    move => t tu; move: (su _ _ ux tu) => ut.
    move: (uz _ ut tu); move: (pa _ _ ut ut) => utt.
    rewrite (proj2 (p8 _ _ ut ut utt)).
    move: (pa _ _ ut utt) => ut3.
    by rewrite (p9 _ _ ut utt ut3 (pb _ _ ut utt)).
  have: sub omega0 u.
    by apply:cardinal_c_induction => // n nB /pc; rewrite succ_of_Bnat.
  by apply: su'.
have p12: (forall x, U x -> x = emptyset \/ exists2 y, U y &
     inc y x /\ disjoint y x) -> foundationA U inc.
  move => hyp x ux.
  have neu: (exists x, U x) by exists x.
  rewrite (p0 neu); case: (hyp _ ux);[ by left | move => [y yu [yx di]]; right].
  by exists y => //; rewrite (p7 _ _ yu).
done.
Qed.

Lemma universe_mo2 :
   let U := is_in_universe in
     [/\ ZF_axioms1 U inc, comprehensionA U inc,
        infiniteA U inc, choiceA U inc & foundationA U inc].
Proof.
set U := is_in_universe => /=.
have pa: forall x y, U x -> inc y x -> U y.
   move => x y /universe_stable_inc; apply.
have pa': forall x y, U x -> sub y x -> U y.
   move => x y ux yx; apply /universe_stable_inc => t ty.
   apply:(pa _ _ ux (yx _ ty)).
move: (universe_mo1 pa pa')=>
    [p1 [p2 [p3 [p4 [p5 [p6 [p7 [p8 [p9 [p10 [p10b p11]]]]]]]]]]].
have q1: (forall x, U x -> U (union x)).
  move => x ux; apply /universe_stable_inc => y /setU_P [z za zb].
  exact (pa _ _ (pa _ _ ux zb) za).
have q2: unionA U inc.
  by move =>x ux; move: (p4 _ ux (q1 _ ux)) => [h _]; exists (union x).
have q3: (forall x : Set, U x -> U (powerset x)).
  by move => x ux; apply /universe_stable_inc => y /setP_P; apply: pa'.
have q4: powersetA U inc.
  by move =>x ux; move: (p5 _ ux (q3 _ ux)) => [h _]; exists (powerset x).
have q5: replacementA U inc.
  move => x p f ux fp; exists (fun_image (Zo x p) f); split.
    apply/universe_stable_inc => s /funI_P [z /Zo_P [za zb] ->].
    by apply:fp => //; apply: (pa _ _ ux za).
  move => z uz; split.
       move /funI_P => [s /Zo_P [r1 r2] ->]; exists s => //.
       apply: (pa _ _ ux r1).
  by move => [t ut [tx pt ->]]; apply /funI_P; exists t => //;apply /Zo_P.
have q6: U omega0 by apply (universe_ordinal OS_omega).
have q7: exists x, U x by exists omega0.
have q8: (ZF_axioms1 U inc) by [].
move: (model_existence2 q8) => p12.
have pru: forall a b, U a -> U b -> U (doubleton a b).
  by move => a b ua ub; apply /universe_stable_inc=> y /set2_P; case => ->.
have q9: infiniteA U inc.
  have qq:forall a, inc a omega0 -> U (singleton a).
    move => a ao; apply: pru; apply: (pa _ _ q6 ao).
  apply: p10 => //.
  by move => a ao; apply: pru => //; [ apply: (pa _ _ q6 ao) | apply: qq].
have q10: foundationA U inc.
  apply p11 => x xu; case:(universe_AF xu);[ by left| move => [y yx dx]; right].
  exists y => //; apply (pa _ _ xu yx).
split => //.
move => x xu; rewrite (p9 q7); move => xx1 xx2.
set y := fun_image x rep.
have pc: forall t, inc t x -> inc (rep t) t.
   move => t tx; apply: rep_i; apply /nonemptyP; apply: xx1 => //.
   apply: (pa _ _ xu tx).
have pd: forall t, inc t x -> U (rep t).
  move => t tx; exact: (pa _ _ (pa _ _ xu tx) (pc _ tx)).
have yU: U y.
  by apply /universe_stable_inc => s /funI_P [z zx ->]; apply: pd.
exists y => // z _ zx; exists (rep z); first by apply: pd.
rewrite (p7 _ _ yU).
have ->: doubletonU U inc (rep z) (rep z) = (singleton (rep z)).
  move: (p12 _ _ (pd _ zx) (pd _ zx)) => [s1 s2].
   apply: extensionality.
     move => t ts; apply /set1_P.
     by move: (s2 _ (pa _ _ s1 ts)) => h; move /h: ts; case.
   by move => t /set1_P ->; apply /(s2 _ (pd _ zx)); left.
apply: set1_pr.
  apply /setI2_P; split; [apply /funI_P; ex_tac | by apply: pc].
move => t /setI2_P [/funI_P [u ux -> t2]].
case: (xx2 _ _ (pa _ _ xu zx) (pa _ _ xu ux) zx ux); first by move ->.
rewrite (p7 _ _ (pa _ _ xu zx)) => di; empty_tac1 (rep u).
Qed.

Lemma universe_mo' a (U :=fun z => inc z (universe a)) :
  ordinalp a ->
  ( (forall x y, U x -> inc y x -> U y) /\
    (forall x y, U x -> sub y x -> U y)).
Proof.
move => oa.
rewrite /U; split; first by move => x y xy; apply: (universe_trans oa).
by move => x y xua /(urank_sub oa xua) [].
Qed.

Lemma universe_mo3 a (U :=fun z => inc z (universe a)) :
  limit_ordinal a ->
  [/\ [/\ (exists x, U x), (extensionalityA U inc), (unionA U inc),
      (powersetA U inc) & comprehensionA U inc],
       ((forall x : Set, U x -> U (powerset x)) /\
       (forall x y, U x -> U y -> U (doubleton x y))),
       (omega0 <o a <-> infiniteA U inc), choiceA U inc & foundationA U inc].
Proof.
move => /limit_ordinal_P3 [anz la].
have la': forall t, succ_o t <=o a ->
   sub (universe (succ_o (succ_o t))) (universe a).
   by move => t /ord_succ_ltP /la /ord_succ_ltP/universe_inc2.
have oa:= (proj32_1 anz).
move: (universe_mo' oa) => [pa pb].
move: (universe_mo1 pa pb)
   =>[p1 [p2 [p3 [p4 [p5 [p6 [p7 [p8 [p9 [p10 [p10b p11]]]]]]]]]]].
have q1: (forall x, U x -> U (union x)).
   move =>x ux; exact (proj1(urank_union oa ux)).
have q2: unionA U inc.
  by move =>x ux; move: (proj1 (p4 _ ux (q1 _ ux))); exists (union x).
have q3: (forall x : Set, U x -> U (powerset x)).
  move => x xa.
  move: (urank_pr1 oa xa) => [sa [sb /setP_P sc sd]].
  move: sc; rewrite - (universe_succ sb) => aa.
  have: (succ_o (succ_o (urank a x))) <=o a by apply /ord_succ_ltP; apply:la.
  move /universe_inc2; apply.
  by move: (urank_powerset (OS_succ sb) aa) => [se _].
have q8b: forall x y, U x -> U y -> U (doubleton x y).
  move => x y xa ya.
  suff: exists b, [/\ b <o a, inc x (universe b) & inc y (universe b)].
    move => [b [b1 b2 b3]].
    by apply:(universe_inc1 b1); apply /setP_P => t;case /set2_P => ->.
  move: (urank_alt2 oa xa) (urank_alt2 oa ya) => sx sy.
  move: (urank_pr1 oa xa) => [/la sa _].
  move: (urank_pr1 oa ya) => [/la sb _].
  move: (OS_succ (OS_urank oa (x:=x))) => o1.
  move: (OS_succ (OS_urank oa (x:=y))) => o2.
  case: (ord_le_to_ee o1 o2) => H.
     by exists (succ_o (urank a y)); split => //; apply:(universe_inc2 H).
     by exists (succ_o (urank a x)); split => //; apply:(universe_inc2 H).
have q8: forall x, U x -> U (singleton x) by move => x ux; apply: q8b.
have q4: powersetA U inc.
  by move =>x ux; move: (p5 _ ux (q3 _ ux)) => [h _]; exists (powerset x).
have q6: U emptyset.
  move: (ord_ne0_pos oa (nesym (proj2 anz))) => /universe_inc1.
  by rewrite universe_0 setP_0; apply; apply /set1_P.
have q7: exists x, U x by exists emptyset.
have q9: foundationA U inc.
  apply p11 => x xa.
  have xu: is_in_universe x by exists a.
  case:(universe_AF xu);[ by left| move => [y yx dx]; right].
  exists y => //; apply (pa _ _ xa yx).
have q10: choiceA U inc.
  move => x xu; rewrite (p9 q7); move => xx1 xx2.
  set y := fun_image x rep.
  have pc: forall t, inc t x -> inc (rep t) t.
     move => t tx; apply: rep_i; apply /nonemptyP; apply: xx1 => //.
     apply: (pa _ _ xu tx).
  have pd: forall t, inc t x -> U (rep t).
    move => t tx; exact: (pa _ _ (pa _ _ xu tx) (pc _ tx)).
  have yU: U y.
    apply: (pb _ _ (q1 _ xu)) => s /funI_P [z zx ->]; apply /setU_P; ex_tac.
  exists y => // z _ zx; exists (rep z); first by apply: pd.
  rewrite (p7 _ _ yU).
  have ->: doubletonU U inc (rep z) (rep z) = (singleton (rep z)).
     rewrite /doubletonU.
     set p := [eta pairA_pr U inc (rep z) (rep z)].
     move: (pd _ zx) => urz; move: (q8 _ urz) => sa.
     have aux: p (singleton (rep z)).
       split => // t _; split; first by move /set1_P => h; left.
       by case => ->; apply /set1_P.
     have: exists y, p y by exists (singleton (rep z)).
     move /choose_pr; set w := choose p; move => [sb h]; set_extens t => tz.
        move /(h _ (pa _ _ sb tz)): tz; case => ->; fprops.
     by move /set1_P: tz ->; apply /(h _ urz); left.
  apply: set1_pr.
    apply /setI2_P; split; [apply /funI_P; ex_tac | by apply: pc].
  move => t /setI2_P [/funI_P [u ux -> t2]].
  case: (xx2 _ _ (pa _ _ xu zx) (pa _ _ xu ux) zx ux); first by move ->.
  rewrite (p7 _ _ (pa _ _ xu zx)) => di; empty_tac1 (rep u).
have q11 : omega0 <o a <-> infiniteA U inc.
  move: (urank_ordinal OS_omega) => [sa sb sc].
  split.
    move /universe_inc1 => h.
    have ou: U omega0 by apply h; apply /setP_P.
    apply: p10 => // b bo; first by apply:(q8 _ (pa _ _ ou bo)).
    move: (pa _ _ ou bo) => aa; exact: (q8b _ _ aa (q8 _ aa)).
  move => ia.
  case: (ord_le_to_el oa OS_omega) => // /universe_inc2 H.
  have pr1: forall u v, U u -> U v -> U (u \cup v).
    by move => u v uu vv; apply: q1; apply: q8b.
  by move: (H _ (p10b q8b pr1 ia)) => /(universe_P OS_omega) [b /sc].
split => //.
Qed.

Lemma universe_mo4 (U :=fun z => inc z (universe omega0)) :
  [/\ ZF_axioms1 U inc, ~(infiniteA U inc), choiceA U inc & foundationA U inc].
Proof.
move:(universe_mo3 omega_limit).
move: (universe_mo' OS_omega) => [pr1 pr2].
move => [[pa pb pc pd] pe ap pf pg ph]; split => //;last by move => /pf [].
split => //.
move => x p f ux au; exists (fun_image (Zo x p) f); split.
  move: (universe_omega_props ux) => [ra rb rc].
  apply: universe_omega_hi.
     apply: finite_fun_image;apply: (sub_finite_set _ ra); apply: Zo_S.
  move => t /funI_P [z /Zo_P [sa sb] ->]; apply: au => //.
  apply: (pr1 _ _ ux sa).
move => z uz; split.
move /funI_P => [a /Zo_P [bb cc] ->]; exists a => //; apply: (pr1 _ _ ux bb).
by move => [t tu [sa sb ->]]; apply /funI_P;exists t => //; apply /Zo_P.
Qed.

Definition subU U x y:= forall t, U t -> inc t x -> inc t y.
Definition transitive_setU U X := forall x, U x -> inc x X -> subU U x X.
Definition ordinalU U X:= forall Y, U Y -> subU U Y X -> transitive_setU U Y ->
   Y <> X -> inc Y X.
Definition equipotentU U X Y := exists2 Z, U Z & [/\ subU U Z (X \times Y),
   (forall x, inc x X -> exists2 y, U y & inc (J x y) Z),
   (forall y, inc y Y -> exists2 x, U x & inc (J x y) Z),
   (forall x x' y, U x -> U x' -> U y -> inc (J x y) Z -> inc (J x' y) Z ->
       x = x') &
   (forall x y y', U x -> U y -> U y' -> inc (J x y) Z -> inc (J x y') Z ->
       y = y')].
Definition cardinalU U x :=
    [/\ U x, ordinalU U x & forall z, U z -> ordinalU U z ->
      equipotentU U x z -> subU U x z].
Definition funsetU U X Y Z :=
  U Z /\ (forall f, inc f Z <->
      [/\ U f,
          (forall p, inc p f -> inc p (Y \times X)),
          (forall x, inc x Y -> exists2 y, U y & inc (J x y) f) &
          (forall x y y', inc (J x y) f -> inc (J x y') f -> y = y') ]).
Definition powerU_pr U x y z :=
    cardinalU U z /\ (exists2 Z, funsetU U x y Z & equipotentU U z Z).
Definition powerU U x y := choose (powerU_pr U x y).
Definition inaccessibleU U x :=
  [/\ cardinalU U x, ssub omega0 x,
    (forall a b, cardinalU U a -> cardinalU U b -> ssub a x -> ssub b x ->
       ssub (powerU U a b) x) &
    (forall a, cardinalU U a -> a <> emptyset -> ssub a x ->
       (powerU U x a) = x) ].

Definition Ufacts U a:=
 [/\
   (forall x, (U x /\ ordinalU U x) <-> (ordinalp x /\ x <o a)),
   (forall x y, U x -> U y -> (x \Eq y <-> equipotentU U x y)),
   (forall x, cardinalU U x <-> (cardinalp x /\ x <c a)),
   (forall x y, cardinalU U x -> cardinalU U y ->
     powerU U x y = (x ^c y)) &
   (forall x, inaccessibleU U x <-> (inaccessible x /\ x <c a)) ].

Section InaccessibleUniverse.
Variable a: Set.
Hypothesis ia: inaccessible a.

Lemma universe_inaccessible_card1 b:
   b <o a -> cardinal(universe b) <c a.
Proof.
pose p b := b<o a -> cardinal (universe b) <c a.
move: (ia) => [[ [ica _] _] _].
move => ba;ex_middle bad.
apply:(least_ordinal2 (p:=p)) (proj31_1 ba) ba => y oy etc yb.
move /(ordinal_cardinal_le2P (proj1 ica) oy) : (yb) => cya.
rewrite /p (universe_rec oy).
set yy := unionf _ _.
have ->: yy = unionb (Lg y (fun z => powerset (universe z))).
  set_extens t.
     move /setUf_P => [s sa sb]; apply /setUb_P; bw; ex_tac; bw.
  move => /setUb_P; bw; move => [s sa]; bw => sb; apply /setUf_P; ex_tac.
move: (csum_pr1 (Lg y (fun z => powerset (universe z)))).
set s := card_sumb _ _; move => h; apply: (card_le_ltT h); clear h.
set f := Lg y (fun z => cardinal(powerset (universe z))).
have pra: card_sum f = s.
  rewrite /s /card_sumb /f; bw; congr (card_sum _); apply:Lg_exten.
  move => t ty /=; bw.
have prb: domain f = y by rewrite /f;bw.
have prc: cardinal_fam f by move => t; rewrite prb /f => ys; bw; fprops.
have prd: fgraph f by rewrite /f; fprops.
move /(infinite_regularP ica) : (proj1 (proj1 ia)) => h.
apply: h; last bw.
split;fprops; hnf; bw => x xy; bw; rewrite card_setP.
move: (xy) => /(ord_ltP oy) iy';rewrite - cpow_prb.
exact: ((proj2 ia) _ (etc _ iy' (ord_le_ltT (proj1 iy') yb))).
Qed.

Lemma universe_inaccessible_card2: cardinal(universe a) = a.
Proof.
move: (ia) => [[ [ica _] _] _].
move:(infinite_card_limit2 ica) => loa.
move:(proj31 loa) => oa.
move: (card_card (proj1 ica)) => caa.
apply card_leA; last first.
  by move: (urank_ordinal oa)=> [ _ /sub_smaller]; rewrite caa.
rewrite (universe_rec oa).
set yy := unionf _ _.
have ->: yy = unionb (Lg a (fun z => powerset (universe z))).
  set_extens t.
     move /setUf_P => [s sa sb]; apply /setUb_P; bw; ex_tac; bw.
  move => /setUb_P; bw; move => [s sa]; bw => sb; apply /setUf_P; ex_tac.
move: (csum_pr1 (Lg a (fun z => powerset (universe z)))) => h.
apply: (card_leT h); set s := card_sumb _ _; clear h.
set f := Lg a (fun z => cardinal(powerset (universe z))).
have pra: card_sum f = s.
  rewrite /s /card_sumb /f; bw; congr (card_sum _); apply:Lg_exten.
  move => t ty /=; bw.
have prb: domain f = a by rewrite /f;bw.
have prc: cardinal_fam f by move => t; rewrite prb /f => ys; bw; fprops.
have prd: fgraph f by rewrite /f; fprops.
have pre: forall i : Set, inc i (domain f) -> Vg f i <c a.
  move => i; rewrite prb /f => iy; bw; rewrite card_setP.
  move: (iy) => /(ord_ltP oa) iy'.
  rewrite - cpow_prb; exact: (proj2 ia _ (universe_inaccessible_card1 iy')).
move: (csum_of_small_b2 (conj prd pre)).
by rewrite prb pra (square_of_infinite ica).
Qed.

Lemma universe_inaccessible_inc x:
   inc x (universe a) <-> (sub x (universe a) /\ cardinal x <c a).
Proof.
move: (ia) => [[ [ica _] _] _].
move:(infinite_card_limit2 ica) => loa.
move:(proj31 loa) => oa.
split.
  move => xua; split;first by apply: universe_trans.
  move: xua; rewrite (universe_limit loa) => /setUf_P [y ya yu].
  move: (universe_trans (ordinal_hi oa ya) yu) => /sub_smaller.
  move /(ord_ltP oa) : ya => /universe_inaccessible_card1.
  move => pa pb; apply: (card_le_ltT pb pa).
move => [xu cx].
set f := Lg x (fun z => cardinal (urank a z)).
set s := card_sum f.
have pra: card_sum f = s by [].
have prb: domain f = x by rewrite /f;bw.
have prc: cardinal_fam f by move => t; rewrite prb /f => ys; bw; fprops.
have prd: fgraph f by rewrite /f; fprops.
have pre: forall i : Set, inc i (domain f) -> Vg f i <c a.
  move => i; rewrite prb /f => tx; bw.
  move: (xu _ tx); rewrite (universe_limit loa) => /setUf_P [y ya yb].
  move: (urank_pr1 oa (xu _ tx)) => [pa1 pa2].
  move: (urank_pr1 (ordinal_hi oa ya) yb) => [pb1 pb2].
  apply /(ordinal_cardinal_le2P (proj1 ica) (proj31_1 pa1)).
  rewrite (urank_uniq pa2 pb2); apply: (ord_le_ltT (proj1 pb1)).
  by apply /(ord_ltP oa).
move /(infinite_regularP ica) : (proj1 (proj1 ia)) => h.
have ww: cardinal (domain f) <c a by ue.
move: (h _ (conj prd pre) ww) => lsa.
move: (proj2 ia _ lsa); set s1 := \2c ^c s => lsb.
move: (ordinal_cardinal_lt lsb) => /universe_inc1; apply; apply /setP_P.
move => i ix; move: (ix); rewrite - prb => ix'.
move: (urank_pr1 oa (xu _ ix)) => [_ [hb /setP_P hc _]].
move: (csum_increasing6 prc ix'); rewrite pra /f; bw => le2.
move: (card_le_ltT le2 (cantor (proj31_1 lsa))).
by move /(ordinal_cardinal_le2P (CS_pow \2c s) hb) => /universe_inc1; apply.
Qed.

Lemma universe_inaccessible_mo1:
   replacementA (fun z => inc z (universe a)) inc.
Proof.
move => x p f /universe_inaccessible_inc [pa pb] h.
exists (fun_image (Zo x p) f); split; last first.
  move => z za; split.
    by move /funI_P => [t /Zo_P [ra rb] ->]; exists t => //; apply: pa.
  by move => [t ta [tx pt ->]]; apply /funI_P; exists t => //; apply /Zo_P.
have sc: sub (Zo x p) x by apply: Zo_S.
apply /universe_inaccessible_inc; split.
  by move => t/funI_P [z /Zo_P[ra rb] ->]; apply: h => //; apply: pa.
move: (card_leT (fun_image_smaller (Zo x p) f) (sub_smaller sc)) => sa.
exact: (card_le_ltT sa pb).
Qed.

Lemma universe_inaccessible_mo2 :
   let U := (fun z => inc z (universe a)) in
   [/\ ZF_axioms1 U inc, comprehensionA U inc,
        infiniteA U inc, choiceA U inc & foundationA U inc]
   /\ Ufacts U a.
Proof.
move: ia => [[[/infinite_card_limit2 la _] _] _].
move:(universe_mo3 la) => [ [p1 p2 p3 p4 p5] [ap ap'] p6 p7 p8].
move: universe_inaccessible_mo1 => p9.
have p10: ZF_axioms1 (inc^~ (universe a)) inc by [].
have loa: omega0 <o a.
   rewrite -aleph_pr1 (inaccessible_pr1 (proj1 ia)).
   by apply /aleph_lt_lto; apply: limit_positive.
move /p6: (loa) => p6'.
move:(proj32_1 loa) => oa.
move: (universe_mo' oa) => [pa pb].
move: (universe_mo1 pa pb)
   =>[r1 [r2 [r3 [r4 [r5 [r6 [r7 [r8 [r9 [r10 [r10b r11]]]]]]]]]]].
pose U x := inc x (universe a).
have sa: forall x y, U x -> U y -> (subU U x y <-> sub x y).
  move => x y ux uy; split.
    move => h t tx; apply:h => //; apply: (pa _ _ ux tx).
  by move => h t ut tx; apply: h.
have sb: forall X, U X -> (transitive_setU U X <-> transitive_set X).
  move => X UX; split => h.
    move => t tX; move:(pa _ _ UX tX) => ut.
    by apply /(sa _ _ ut UX); apply: h.
  by move => x ux xx; apply /(sa _ _ ux UX); apply: h.
have sc: forall X, U X -> (ordinalU U X <-> ordinalp X).
  move => X UX; split => h.
    move=> t tT tt tnx; move: (pb _ _ UX tT) => tU; apply: h => //;
      [by apply/ (sa _ _ tU UX) | by apply /(sb _ tU)].
  move => y uy yx ty xy; apply: h => //; first by apply/ (sa _ _ uy UX).
  by apply /(sb _ uy).
have sd: forall x, (U x /\ ordinalU U x) <-> (ordinalp x /\ x <o a).
  move => x; split; move => [xa xb].
    move /(sc _ xa): xb => ox; split => //.
    move: (urank_pr1 oa xa)(urank_ordinal ox) => [q1 q2] q3.
    by rewrite -{1} (urank_uniq q2 q3).
  have ux: U x.
    apply:(universe_inc1 xb); apply /setP_P; exact:(proj32 (urank_ordinal xa)).
  by split => //; apply /(sc _ ux).
have se0: forall x, U x -> U (union x).
   move => x ux; move: (p3 x ux) => [u [ua ub]].
   suff : u = union x by move => <-.
   set_extens t => tu.
     move /(ub _ (pa _ _ ua tu)): tu => [z [za zx tz]]; union_tac.
   move/setU_P: tu => [z tz zx]; move:(pa _ _ ux zx) => zu.
   by apply /(ub _ (pa _ _ zu tz)); exists z.
have se00: forall r x, U x -> (forall t, inc t x -> U (r t)) ->
  U (fun_image x r).
  move => r x /universe_inaccessible_inc [pa1 pb1] xru.
  apply /universe_inaccessible_inc; split.
    by move => t/funI_P [z ra ->]; apply: xru => //; apply: pa.
  exact: (card_le_ltT (fun_image_smaller x r) pb1).
have se1: forall x y, U x -> U y -> U (J x y).
  by move => x y ux uy; rewrite Pair.kprE /kpair; apply: (ap'); apply: ap'.
have se2: forall x y, U x -> U y -> U (x \times y).
  move => x y ux uy; apply: se0; apply: (se00) => //.
  move => t tx; apply: se00 => // s sy; apply: se1.
      apply: (pa _ _ ux tx).
      apply: (pa _ _ uy sy).
have se3: forall x y, U x -> U y -> (x \Eq y <-> equipotentU U x y).
  move => x y ux uy; split => ha.
    move: ha => [f [[fa fb] sf tf]].
    move: (proj1 fa) => [[qa qa'] qb qc].
    rewrite sf in qa'; rewrite tf in qa'; move: (se2 _ _ ux uy) => xyu.
    move: (pb _ _ xyu qa') => grfu.
    have qd: subU U (graph f) (x \times y) by apply /sa.
    have qe:forall b, inc b x -> exists2 c, U c & inc (J b c) (graph f).
       move => b; rewrite - sf => bsf.
       move: (Vf_target (proj1 fa) bsf); rewrite tf => h1.
       rewrite qc in bsf; move :(fdomain_pr1 qb bsf) => h.
       exists (Vg (graph f) b) => //; apply (pa _ _ uy h1).
    have qf:forall c, inc c y -> exists2 b, U b & inc (J b c) (graph f).
      rewrite - tf; move => c cy; move: (surjective_pr fb cy); rewrite sf.
      move => [b bx ok]; exists b => //; apply (pa _ _ ux bx).
    have qg:forall b c c', U b -> U c -> U c' -> inc (J b c) (graph f)
      -> inc (J b c') (graph f) -> c = c'.
       move => b b' c _ _ _ s1 s2; move: (proj2 qb _ _ s1 s2); aw => h.
       by move: (pr2_def (h (erefl b))).
    have qh:forall b b' c, U b -> U b' -> U c -> inc (J b c) (graph f)
      -> inc (J b' c) (graph f) -> b = b'.
       move => b b' c _ _ _ s1 s2; exact: (injective_pr3 fa s1 s2).
     exists (graph f) => //; split => //.
  move: ha => [g gu [q1 q2 q3 q4 q5]].
  have q7: sub g (x \times y) by apply/sa => //; apply /se2.
  have q8: forall b c, inc (J b c) g -> U b /\ U c.
     move => b c /q7 /setXp_P [s1 s2]; split.
       apply: (pa _ _ ux s1).
       apply: (pa _ _ uy s2).
  set f := (triple x y g); exists f; rewrite /f; split => //;aw.
  have fgg: fgraph g.
     apply /functionalP; split; first by apply: (sub_setX_graph q7).
   move => b c c' bc1 bc2.
   exact (q5 _ _ _ (proj1 (q8 _ _ bc1)) (proj2 (q8 _ _ bc1))
       (proj2 (q8 _ _ bc2)) bc1 bc2).
  have ff: function f.
    apply: function_pr => //.
      by move => s /funI_P [z /q7 /setX_P [_ _ h] -> ].
    set_extens s.
       move => /q2 [c _ cu]; apply /funI_P; ex_tac; aw.
    by move => /funI_P [z /q7 /setX_P [_ h _] -> ].
  split.
    apply: injective_pr_bis => // c; aw; move => b b' /= bu b'u.
    exact: (q4 _ _ _ (proj1 (q8 _ _ bu)) (proj1 (q8 _ _ b'u))
       (proj2 (q8 _ _ bu)) bu b'u).
  apply: surjective_pr5 => //; aw => b /q3 [c uc pg]; exists c => //.
  by move: (q7 _ pg) => /setXp_P [].
have ca: cardinalp a by move: ia => [[[[]]]].
have se6: forall x, cardinalU U x <-> (cardinalp x /\ x <c a).
   move => x; split.
     move => [ux oux etc].
     move /sd: (conj ux oux) => [ox xa]; suff: cardinalp x.
       by split => //; apply:ordinal_cardinal_lt3 => //.
     split => // z oz xeqz.
     case: (ord_le_to_el (proj1 ca) oz) => za.
       move: (ordinal_cardinal_le1 za); rewrite (card_card ca).
       move /(universe_inaccessible_inc x): ux => [_ ].
       move /card_eqP: xeqz => -> e1 e2; co_tac.
     move /sd:(conj oz za) => [uz ouz].
     move /(se3 _ _ ux uz): xeqz => eq1.
     apply /(sa _ _ ux uz); exact (etc _ uz ouz eq1).
  move => [cx xa]. move: cx => [c1 c2].
  have xa1: x <o a by apply: ordinal_cardinal_lt.
  move /sd:(conj c1 xa1) => [ux oux]; split => // z uz ouz euz.
  move /sd: (conj uz ouz) => [oz za]; move /(se3 _ _ ux uz):euz => euz'.
  by move: (c2 _ oz euz') => /(sa _ _ ux uz).
have se4: forall X Y Z Z', funsetU U X Y Z -> funsetU U X Y Z' -> Z = Z'.
  move => X Y Z Z' [ra rb] [rc rd].
  set_extens t; [ by move /rb /rd | by move /rd /rb].
have se5: forall X Y, U X -> U Y -> funsetU U X Y (gfunctions Y X).
  move => X Y ux uy.
  have ra: sub (gfunctions Y X) (powerset (Y \times X)) by apply: Zo_S.
  move: (ap _ (se2 _ _ uy ux)) => rb.
  split; first by exact (pb _ _ rb ra).
  split.
    move => /Zo_P [rc [rd re]];move: (pa _ _ rb rc)=> rf.
    move/setP_P: rc => rc; split => //.
      rewrite re => x /(fdomain_pr1 rd) => h; exists (Vg f x) => //.
      by move: (rc _ h) => /setXp_P [_] => vx; apply: (pa _ _ ux vx).
   move => x y z rg rh; move: (proj2 rd _ _ rg rh); aw => h.
   exact: (pr2_def(h (erefl x))).
  move => [rc rd re rf].
  have sgf: sgraph f by move => t /rd /setX_P [].
  apply: Zo_i; [by apply /setP_P => p /rd | split ].
     split=> //.
     move => u v rg rh sp; move: (sgf _ rg)(sgf _ rh) => pr1 pr2.
     by move: rg rh; rewrite - pr1 -pr2 sp => rg rh; rewrite (rf _ _ _ rg rh).
  set_extens t; first by move /re => [y uuy yv]; apply /funI_P; ex_tac; aw.
  by move /funI_P => [z /rd /setX_P [_ aa bb] ->].
have se7: forall x y, cardinalU U x -> cardinalU U y -> powerU_pr U x y (x^c y).
  move => x y cux cuy.
  move /se6: (cux) => [cx cxs]; move: (proj31 cux) => ux.
  move /se6: (cuy) => [cy cys]; move: (proj31 cuy) => uy.
  move: (se5 _ _ ux uy) => fsv; move: (fsv) => [fsu _].
  have aux: cardinalU U (x^c y).
    by apply /se6; split; fprops;apply: (proj2 (inaccessible_dominant ia)).
  split => //; exists (gfunctions y x) => //.
  apply/se3 => //; first by exact (proj31 aux).
  eqtrans (functions y x); first by apply: cardinal_pr.
  apply:fun_set_equipotent.
have se8: (forall x y, cardinalU U x -> cardinalU U y ->
     powerU U x y = (x ^c y)).
  move => x y cux cuy; move: (se7 _ _ cux cuy) => h.
  move: (se5 _ _ (proj31 cux) (proj31 cuy)) => ha.
  pose p z := powerU_pr U x y z.
  have: exists z, p z by exists (x ^c y).
  move /choose_pr; rewrite -/(powerU _ _ _); set z := (powerU U x y).
  rewrite /p; move => [ra [Z za zb]]; move: (se4 _ _ _ _ ha za) => hb.
  move / (se3 _ _ (proj31 ra) (proj1 za)): zb; rewrite - hb.
  move/se6:ra => [cz _].
  move /card_eqP; rewrite (card_card cz) => ->.
  by move:(fun_set_equipotent y x) => /card_eqP <-.
have se9: (forall x, inaccessibleU U x <-> (inaccessible x /\ x <c a)).
  have aux: forall a b, (a <c b) <-> [/\ cardinalp a, cardinalp b& ssub a b].
    by move => b c; split; [move => [[s1 s2 s3] s4] | move => [s1 s2 [s3 s4]]].
  move => x;split.
    move=> [ra rb rc rd]; move /se6: (ra) => [re rf]; split => //.
    move /aux: (And3 CS_omega re rb) => ox.
    have a2: forall b, b <c x -> cardinalU U b /\ ssub b x.
     move => b bx.
        move: (card_lt_leT bx (proj1 rf)) => ba.
        by move/aux: bx => [cb _ h]; split => //;apply /se6.
    apply /(inaccessible_dominant3 ox); split.
       move => b c l1 l2; move: (a2 _ l1)(a2 _ l2) => [c1 c2][c3 c4].
       apply/ aux; split; [ by apply: CS_pow | exact | ].
       move: (rc _ _ c1 c3 c2 c4);rewrite se8 //.
     move => z za zb; move: (a2 _ zb) => [c1 c2].
     have ze: z <> emptyset by move => h; move: (proj2 za); rewrite h.
     by move: (rd _ c1 ze c2); rewrite se8.
  move=> [ra rb].
  have xo: omega0 <c x.
    move: (ra) => [[[/infinite_card_limit2 la1 _] _] _].
    rewrite -aleph_pr1 (inaccessible_pr1 (proj1 ra)).
    by apply /aleph_lt_ltc; apply: limit_positive.
  move /(inaccessible_dominant3 xo): ra=> [rc rd].
  have cux: cardinalU U x by apply /se6; split => //; co_tac.
  move/ (aux): xo => [_ cx xo1].
  split => //.
    move => b c qa qb qc qd; move/se6: (qa) => [qe qf].
    move /se6: (qb) => [qg qh].
    move /aux: (And3 qe cx qc) => bx.
    move /aux: (And3 qg cx qd) => lcx.
    move /aux: (rc _ _ bx lcx) => [qi qj qk]; rewrite se8 //.
  move => b qa qb qc; move/se6: (qa) => [qd qe].
  move /aux: (And3 qd cx qc) => bx.
  have qf: ssub emptyset b by split; fprops.
  move /aux: (And3 CS0 qd qf) => bx0.
  by move: (rd _ bx0 bx); rewrite se8.
done.
Qed.

End InaccessibleUniverse.

Section UniversePermutation.
Variables (f g: fterm).
Hypotheses (fg: forall x, f (g x) = x) (gf: forall x, g (f x) = x).

Let U:= fun x: Set => True.
Let inc':= fun x y => inc x (f y).

Lemma up_fi x y: f x = f y -> x = y.
Proof. by move => h ; rewrite - (gf x) - (gf y) h. Qed.

Lemma up_Ut t: U t.
Proof. by []. Qed.

Lemma up_exten: extensionalityA U inc'.
Proof.
by move => a b _ _ /= h; apply:up_fi; set_extens t; move / (h _ (up_Ut t)).
Qed.

Lemma up_ZF1: ZF_axioms1 U inc'.
Proof.
split.
+ by exists emptyset.
+ apply: up_exten.
+ move => x _; exists (g (union (fun_image (f x) f))); split => // y _.
  rewrite /inc' fg; split.
    move /setU_P => [z yz /funI_P [t zx zv]]; exists t; split => //; ue.
  move => [z [_ zfx yfz]]; union_tac; apply /funI_P; ex_tac.
+ move => x _; exists (g (fun_image (powerset (f x)) g)); split => // y _.
  rewrite /inc' fg; split.
    by move/funI_P=> [z /setP_P h1 ->] t _; rewrite fg => /h1.
  move => h; apply/funI_P; exists (f y); rewrite ? gf //.
  by apply/setP_P => t; apply:(h _ (up_Ut t)).
+ move => x p f0 _ _; exists (g (fun_image (Zo (f x) p) f0));split => // y _.
  rewrite /inc' fg; split.
    move => /funI_P [z /Zo_P [pa pb] pc]; exists z => //.
  by move => [t _ [pa pb pc]]; apply /funI_P; exists t => //; apply/Zo_P.
Qed.

Lemma up_values:
 [/\ emptysetU U inc' = g emptyset,
     forall x, unionU U inc' x = (g (union (fun_image (f x) f))),
     forall x, powersetU U inc' x = (g (fun_image (powerset (f x)) g)),
     forall x p, setofU U inc' x p = (g (Zo (f x) p)) &
    (forall x p f0, funimageU U inc' x p f0 = (g (fun_image (Zo (f x) p) f0)))
    /\ (forall x y, doubletonU U inc' x y = g (doubleton x y))].
Proof.
move:(model_uniqueness up_exten) => [uU uP uC uR [uE up]].
move:(model_existence up_ZF1) => [eE eU eP eC eR].
split; last split.
+ by apply: uE => //; split => // t _; rewrite /inc' fg => /in_set0.
+ move => x; apply:(uU x); first by apply:eU.
  split => // y _; rewrite /inc' fg; split.
    move /setU_P => [z yz /funI_P [t zx zv]]; exists t; split => //; ue.
  move => [z [_ zfx yfz]]; union_tac; apply /funI_P; ex_tac.
+ move =>x; apply(uP x); first by apply:eP.
  split => // y _ ;rewrite /inc' fg; split.
    by move/funI_P=> [z /setP_P h1 ->] t _; rewrite fg => /h1.
  move => h; apply/funI_P; exists (f y); rewrite ? gf //.
  by apply/setP_P => t; apply:(h _ (up_Ut t)).
+ move => x p; apply:(uC x p); first by apply:eC.
  split => // y _; rewrite /inc' fg; exact:(Zo_P (f x) p y).
+ move => x p f0; apply:(uR x p f0); first by apply:eR.
  split => // y _; rewrite /inc' fg; split.
    move => /funI_P [z /Zo_P [pa pb] pc]; exists z => //.
  by move => [t _ [pa pb pc]]; apply /funI_P; exists t => //; apply/Zo_P.
+ move => x y; apply:(up x y).
    exact:(model_existence2 up_ZF1 (up_Ut x) (up_Ut y)).
  by split => // t _; rewrite /inc' fg; move:(set2_P t x y).
Qed.

Lemma up_union2 x y: unionU2 U inc' x y = g (f x \cup f y).
Proof.
move:up_values => [_ pb _ _ [_ pf]].
by rewrite /unionU2 pf pb fg funI_set2.
Qed.

Lemma up_succ x: (unionU2 U inc' x (doubletonU U inc' x x)) = g (f x +s1 x).
Proof.
by move:up_values => [_ pb _ _ [_ ->]]; rewrite up_union2 fg.
Qed.

Lemma up_infinite: infiniteA U inc'.
Proof.
move:up_values => [pa pb pc pd [pe pf]].
move:(induction_defined_pr (fun x => g (f x +s1 x)) (g emptyset)).
set h:= induction_defined _ _; move => [sh [fh sjh] h0 hr].
exists (g (target h)) => //; split.
  rewrite pa - h0 /inc' fg; Wtac; rewrite sh; fprops.
move => t _; rewrite up_succ /inc' fg; move /sjh => [x xh <-].
by rewrite sh in xh; rewrite - hr //; Wtac; rewrite sh; apply: BS_succ.
Qed.

Lemma up_inter2 x y: intersectionU2 U inc' x y = g (f x \cap f y).
Proof.
move:up_values => [pa pb pc pd [pe pf]].
rewrite /intersectionU2 pd. apply: f_equal.
set_extens t; first by move /Zo_P => /setI2_P.
by move /setI2_P => h; apply/Zo_P.
Qed.

Lemma up_disjoint x y:
  (intersectionU2 U inc' x y = emptysetU U inc') <-> disjoint (f x) (f y).
Proof.
rewrite up_inter2; move:up_values => [-> _ _ _ _].
rewrite /disjoint; split => // h; first by move: (f_equal f h); rewrite fg fg.
by rewrite h.
Qed.

Lemma up_choice: choiceA U inc'.
Proof.
move:up_values => [Ev _ _ _ [_ dv]].
rewrite /choiceA => x _ pa pb.
set E := fun_image (f x) f.
have p1: (forall z, inc z E -> nonempty z).
  move => z /funI_P [y /(pa _ (up_Ut y)) h ->].
  by case: (emptyset_dichot (f y)) => // fe; case h;rewrite Ev - (gf y) fe.
have p2:(forall z z', inc z E -> inc z' E -> z = z' \/ disjoint z z').
  move => z z' /funI_P [y fyx ->] /funI_P [y' fyx' ->].
  move:(pb _ _ (up_Ut y) (up_Ut y') fyx fyx').
  rewrite up_disjoint;case; [ by move => ->; left | by right].
move: AC_variants => [_ [_ ac3]].
have: (forall x, exists r, forall z, inc z x -> nonempty z -> inc (r z) z).
  by move => X; exists rep => y _ ney; apply:rep_i.
move /ac3 => AC; move: (AC E p1 p2) => [y yp]; clear AC ac3.
exists (g y) => //.
move => z _ zx.
have fze: inc (f z) E by apply /funI_P; exists z.
by move: (yp _ fze) => [t]; move => h; exists t => //;rewrite up_inter2 fg dv h.
Qed.

End UniversePermutation.

Lemma Universe_permutation1
  (f:= fun x => Yo (x = \0c) \1c (Yo (x = \1c) \0c x))
  (U := fun z: Set => True)
  (R := fun x y => inc x (f y))
  (x0 := \1c) (x1:= \0c):
  [/\ ZF_axioms1 U R, infiniteA U R, choiceA U R, emptysetU U R = x0 &
   ( doubletonU U R x1 x1 = x1 /\
    forall t, doubletonU U R t t = t -> t = x1 \/ (t = singleton t))].
Proof.
have h0:= card1_nz.
have ff: forall x, f (f x) = x.
  rewrite /f => x; case: (equal_or_not x \0c) => xz; first by repeat Ytac0.
  case: (equal_or_not x \1c) => xo; first by repeat Ytac0.
  by repeat Ytac0.
move: (up_values ff ff) => [us _ _ _ [_ db]].
split; last split.
+ exact: (up_ZF1 ff ff).
+ exact: (up_infinite ff ff).
+ exact: (up_choice ff ff).
+ by rewrite us /f -/card_zero; Ytac0; Ytac0.
+ by rewrite db /x1 -/(singleton _) -/card_one /f; Ytac0; Ytac0.
+ move => t; rewrite db -/(singleton _) /f.
  case: (equal_or_not t \0c) => tz //; first by rewrite tz; left.
  have hb: (singleton t <> \0c).
    by move => h; move: (set1_1 t); rewrite h => /in_set0.
  have hc: (singleton t <> \1c) by move => h; move:(set1_inj h).
  by Ytac0; Ytac0; right.
Qed.

End Realisation.

Module OrdinalAdd.



End OrdinalAdd.