Require Import Reals ClassicalEpsilon Lia Lra List.
From Coquelicot Require Import Coquelicot.
Import ListNotations.

Open Scope R_scope.

Definition Rnat (x : R) := exists n, x = INR n.

Definition Rnat' (x : R) := exists z, x = IZR z /\ (0 <= z)%Z.

Lemma Rnat_to_Rnat' r : Rnat r <-> Rnat' r.
Proof.
split; intros [w pw].
  exists (Z.of_nat w).
  split; [now rewrite pw; apply INR_IZR_INZ | ].
  apply Zle_0_nat.
exists (Z.to_nat w).
rewrite INR_IZR_INZ, Z2Nat.id; tauto.
Qed.

Lemma Rnat_IZR z : (0 <= z)%Z -> Rnat (IZR z).
Proof.
intros znn; rewrite Rnat_to_Rnat'.
now unfold Rnat'; eapply ex_intro;split; [eapply eq_refl | ].
Qed.

#[export]
Hint Extern 1 (Rnat (IZR _)) => (now apply Rnat_IZR; discriminate) : core.

Lemma Rnat_INR n : Rnat (INR n).
Proof. now exists n. Qed.

#[export]
Hint Resolve Rnat_INR : core.

Lemma Rnat_ind (n : R) (P : R -> Prop) :
  P 0 ->
  (forall k, Rnat k -> P k -> P (k + 1)) ->
  Rnat n ->
  P n.
Proof.
intros P0 Pf [n' nnat].
rewrite nnat; clear nnat; induction n'.
  exact P0.
rewrite S_INR; apply Pf.
  now exists n'.
exact IHn'.
Qed.

Lemma Rnat_ge0 (x : R) : Rnat x -> 0 <= x.
intros [x' xnat]; rewrite xnat; apply pos_INR.
Qed.

Lemma Rnat_lt_succ (x y : R) : Rnat x -> Rnat y ->
  x < y + 1 -> x <= y.
Proof.
intros [x' xnat] [y' ynat].
change 1 with (INR 1); rewrite xnat, ynat, <- plus_INR.
intros hlt; apply INR_lt in hlt; apply le_INR; lia.
Qed.

Lemma Rnat_gt_pred (x y : R) : Rnat x -> Rnat y ->
  x - 1 < y -> x <= y.
Proof.
intros xnat ynat hlt; apply Rnat_lt_succ; auto; lra.
Qed.

Lemma Rnat0 : Rnat 0.
Proof. now exists 0%nat. Qed.

Lemma Rnat_imm (x : positive) : Rnat (IZR (Z.pos x)).
Proof.  auto.  Qed.

Example Rnat42 : Rnat 42.
Proof. apply Rnat_imm. Qed.

Lemma Rnat1 : Rnat 1.
Proof. apply Rnat_imm. Qed.

Lemma course_of_value_induction (P : R -> Prop) :
  (forall p, (forall r, r < p -> Rnat r -> P r) -> Rnat p -> P p) ->
  forall n, Rnat n -> P n.
Proof.
intros main n nnat.
enough (course_of_value : forall x, x <= n -> Rnat x -> P x).
  apply course_of_value; auto; lra.
induction nnat as [ | p pnat Ih] using Rnat_ind.
  intros r rle0 rnat; apply main; auto.
  assert (rge0 := Rnat_ge0 _ rnat).
  intros r' r'ltr r'nat.
  assert (r'ge0 := Rnat_ge0 _ r'nat); lra.
intros x xlep1 xnat; assert (xge0 := Rnat_ge0 _ xnat).
assert (xltp1Veq : x < p + 1 \/  x = p + 1) by lra.
  destruct xltp1Veq as [xltp1 | xisp1].
  assert (xlep : x <= p) by now apply Rnat_lt_succ.
  apply main; auto.
  intros r rltx rnat; apply Ih; auto; lra.
apply main; auto.
intros r rltx rnat.
assert (rlep : r <= p) by now apply Rnat_lt_succ; auto; lra.
now apply Ih; auto.
Qed.

Lemma Rnat_add (x y : R) : Rnat x -> Rnat y -> Rnat (x + y).
Proof.
intros [x' xnat] [y' ynat]; exists (x' + y')%nat.
now rewrite xnat, ynat, plus_INR.
Qed.

#[export]
Hint Resolve Rnat_add : core.

Lemma Rnat_mul (x y : R) : Rnat x -> Rnat y -> Rnat (x * y).
Proof.
intros [x' xnat] [y' ynat]; exists (x' * y')%nat.
now rewrite xnat, ynat, mult_INR.
Qed.

#[export]
Hint Resolve Rnat_mul : core.

Lemma Rnat_sub (x y : R) : Rnat x -> Rnat y -> y <= x ->
  Rnat (x - y).
Proof.
intros [x' xnat] [y' ynat]; exists (x' - y')%nat.
rewrite xnat, ynat, minus_INR; auto.
now apply INR_le; rewrite <- xnat, <- ynat.
Qed.

Definition Rnat_iter {A : Type} (n : R) (f : A -> A) (e : A) :=
  epsilon (inhabits e)
    (fun v => forall n', n = INR n' -> Nat.iter n' f e = v).

Lemma Rnat_iter0 {A : Type} (f : A -> A) (e : A) :
  Rnat_iter 0 f e = e.
Proof.
unfold Rnat_iter.
assert (epsP : exists v : A, forall n', 0 = INR n' -> Nat.iter n' f e = v).
  exists e.
  intros [ | n'];[ easy | ].
  rewrite S_INR; intros abs.
  assert (tmp := pos_INR n'); lra.
assert (tmp := epsilon_spec (inhabits e) _ epsP); simpl in tmp.
now generalize (tmp 0%nat refl_equal); simpl; intros it; rewrite <- it.
Qed.

Lemma Rnat_iterS {A : Type} (n : R) (f : A -> A) (e : A) :
  Rnat n ->
  Rnat_iter (n + 1) f e = f (Rnat_iter n f e).
Proof.
intros [n' nn'].
assert (epsP1 : exists v : A, forall n2, n = INR n2 -> Nat.iter n2 f e = v).
  exists (Nat.iter n' f e).
  intros n2; rewrite nn'.
  now intros n'n2; apply INR_eq in n'n2; rewrite n'n2.
assert (tmp := epsilon_spec (inhabits e) _ epsP1); simpl in tmp.
assert (tmp' := tmp n' nn'); unfold Rnat_iter at 2; rewrite <- tmp'.
assert (epsP2 : exists v : A, forall n2, n + 1 = INR n2 ->
            Nat.iter n2 f e = v).
  exists (Nat.iter (S n') f e).
  intros n2; rewrite nn', <- S_INR.
  now intros n'n2; apply INR_eq in n'n2; rewrite n'n2.
assert (tmp2 := epsilon_spec (inhabits e) _ epsP2); simpl in tmp2.
assert (nn1' : n + 1 = INR (S n')) by now rewrite S_INR, nn'.
assert (tmp2' := tmp2 (S n') nn1'); unfold Rnat_iter; rewrite <- tmp2'.
easy.
Qed.

Lemma Rnat_iterS' {A : Type} (n : R) (f : A -> A) (e : A) :
  Rnat (n - 1) ->
  Rnat_iter n f e = f (Rnat_iter (n - 1) f e).
Proof.
intros nn; replace n with ((n - 1) + 1) at 1 by ring.
now apply Rnat_iterS.
Qed.

Lemma Rnat_iter1 {A : Type} (f : A -> A) (e : A) :
  Rnat_iter 1 f e = f e.
Proof.
rewrite Rnat_iterS'; rewrite Rminus_eq_0; auto.
now rewrite Rnat_iter0.
Qed.

Lemma Rnat_iter_add {A : Type} (n m : R) (f : A -> A) (e : A) :
  Rnat n -> Rnat m -> Rnat_iter (n + m) f e =
    Rnat_iter n f (Rnat_iter m f e).
Proof.
intros nnat mnat.
induction nnat using Rnat_ind.
  now rewrite Rplus_0_l, Rnat_iter0.
replace (k + 1 + m) with (k + m + 1) by ring.
rewrite !Rnat_iterS; auto.
now rewrite IHnnat.
Qed.

Definition Rseq_Prop (n m : R) (v : list R) :=
  forall m' : nat, m = INR m' ->
              v = map (fun e => n + IZR (Z.of_nat e)) (seq 0 m').

Definition Rseq (n m : R) : list R :=
  epsilon (inhabits nil) (Rseq_Prop n m).

(* The next two lemmas reproduce the reduction rules of Coq.Lists.List.seq *)

Lemma Rseq0 (n : R) : Rseq n 0 = nil.
Proof.
assert (exv : exists v, Rseq_Prop n 0 v).
  exists (map (fun e => n + INR e) (seq 0 0)); intros n2.
  change 0 with (INR 0); intros z0; apply INR_eq in z0.
  now rewrite <- z0.
exact (epsilon_spec (inhabits nil)
             (Rseq_Prop n 0) exv 0%nat refl_equal).
Qed.

Lemma Rseq_S (n m : R) : Rnat m ->
  Rseq n (m + 1) = n :: (Rseq (n + 1) m).
Proof.
intros [m' mnat].
assert (exv1 : exists v, Rseq_Prop (n + 1) m v).
  exists (map (fun e => (n + 1) + IZR (Z.of_nat e)) (seq 0 m')).
  intros m''; rewrite mnat; intros mnat'.
  now apply INR_eq in mnat'; rewrite <- mnat'.
assert (exv2 : exists v, Rseq_Prop n (m + 1) v).
  exists (map (fun e => n + IZR (Z.of_nat e)) (seq 0 (S m'))).
  intros m''; rewrite mnat, <- S_INR; intros mnat'.
  now apply INR_eq in mnat'; rewrite mnat'.
assert (m1nat : m + 1 = INR (S m')) by now rewrite mnat, <- S_INR.
assert (tmp := epsilon_spec (inhabits nil) _ exv2 (S m') m1nat).
assert (tmp2 := epsilon_spec (inhabits nil) _ exv1 m' mnat).
unfold Rseq; rewrite tmp, tmp2; simpl.
rewrite Rplus_0_r, <- seq_shift, map_map.
apply f_equal; apply map_ext.
intros a; rewrite Nat2Z.inj_succ, succ_IZR; ring.
Qed.

Lemma Rseq_S' (n m : R) : Rnat (m - 1) ->
  Rseq n m = n :: Rseq (n + 1) (m - 1).
Proof.
intros mn; replace m with (m - 1 + 1) at 1 by ring.
now rewrite Rseq_S; auto.
Qed.

Lemma Rseq_app (n m p : R) : Rnat m -> Rnat p ->
  Rseq n (m + p) = (Rseq n m) ++ Rseq (n + m) p.
Proof.
intros mnat pnat; revert n.
induction mnat as [ | m' m'nat Ih] using Rnat_ind; intros n.
  now rewrite Rseq0, Rplus_0_l, Rplus_0_r.
rewrite Rseq_S';
  replace (m' + 1 + p - 1) with (m' + p) by ring; auto.
rewrite Rseq_S; simpl; auto; rewrite Ih.
now rewrite <- (Rplus_comm 1 m'), <- Rplus_assoc.
Qed.

Lemma Rseq_nat (n m : R) : Rnat n -> Rnat m ->
  List.Forall (fun i => Rnat i) (Rseq n m).
Proof.
intros nnat mnat; revert n nnat.
induction mnat as [ | p pnat Ih] using Rnat_ind; intros n nnat.
  now rewrite Rseq0.
now rewrite Rseq_S; auto.
Qed.

Lemma INR_IZN x : (0 <= x)%Z -> IZR x = INR (Z.to_nat x).
Proof.
intros xge0.
destruct (IZN _ xge0) as [n Pn].
now rewrite Pn, <- INR_IZR_INZ, Nat2Z.id.
Qed.

Ltac expand_Rseq :=
  match goal with
  | |- context[Rseq ?x (IZR ?y)] =>
    let Hex := fresh "existential_hypothesis" in
    assert (Hex : exists v, Rseq_Prop x (IZR y) v);
    [exists (map (fun e => x + (IZR (Z.of_nat e))) (seq 0 (Z.to_nat y)));
     let y := fresh "y" in
     intros y; rewrite ?INR_IZR_INZ;
     let yeq := fresh "eq_for_y" in
     intros yeq; apply eq_IZR in yeq; rewrite yeq, !Nat2Z.id; reflexivity |
  unfold Rseq;
  rewrite (epsilon_spec (inhabits nil)
             (Rseq_Prop x (IZR y)) Hex (Z.to_nat y));
     [simpl; rewrite <- !plus_IZR; reflexivity | rewrite INR_IZN; auto; lia ]]
  end.

Ltac expand_Rseq' :=
  repeat (rewrite Rseq_S', <- minus_IZR;
     [ | rewrite <- minus_IZR;
        (apply Rnat_imm || apply Rnat0)]); rewrite Rseq0;
        rewrite <- !plus_IZR; reflexivity.

Example seq14 : Rseq 1 4 = [1; 2; 3; 4].
Proof.
expand_Rseq'.
(* expand_Rseq. also works. *)
Qed.

(* We can use structural recursion on datatypes as usual. *)

Fixpoint sumr (l : list R) : R :=
  match l with nil => 0 | a :: tl => a + sumr tl end.

Lemma sumr_app (l1 l2 : list R) :
  sumr (l1 ++ l2) = sumr l1 + sumr l2.
Proof.
induction l1 as [ | a l1 Ih].
  now simpl; rewrite Rplus_0_l.
now simpl; rewrite Ih, Rplus_assoc.
Qed.

Lemma sumr_seq (n : R) : Rnat n -> sumr (Rseq 0 n) = n * (n - 1) / 2.
Proof.
intros nnat; induction nnat using Rnat_ind.
  rewrite Rseq0; try apply Rnat0; simpl.
  (* field. can finish here. *)
  now unfold Rdiv; rewrite !Rmult_0_l.
rewrite Rseq_app; try (apply Rnat0 || apply Rnat1 || assumption).
rewrite sumr_app.
rewrite IHnnat.
replace 1 with (0 + 1) at 2 by now rewrite Rplus_0_l.
rewrite Rseq_S; auto.
rewrite Rseq0; simpl.
  (*  field. can finish here. *)
rewrite Rplus_0_l.
rewrite Rplus_0_r.
unfold Rminus at 2.
rewrite Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_r.
replace k with ((2 * k) / 2) at 3.
  rewrite <- Rdiv_plus_distr.
  rewrite (Rmult_comm k).
  rewrite <- Rmult_plus_distr_r.
  unfold Rminus; rewrite Rplus_assoc.
  (* The next line needs more thinking. *)
  replace (-(1) + 2) with 1 by ring.
  reflexivity.
unfold Rdiv.
rewrite (Rmult_comm 2).
rewrite Rmult_assoc.
rewrite Rinv_r.
  rewrite Rmult_1_r.
  reflexivity.
  (* The next line needs more thinking *)
lra.
Qed.

Fixpoint rlength {A : Type} (l : list A) : R :=
  match l with nil => 0 | a :: tl => rlength tl + 1 end.

Definition rnth {A : Type} (e : A) (n : R) (l : list A) :=
  hd e (Rnat_iter n (@tl A) l).

Notation "'\big[' f / idf ]_( a <= i < b ) E" :=
  (fold_right f  idf (map (fun i => E) (Rseq a (b - a))))
  (at level 35, a at level 30,  b at level 30, E at level 36, f,
   idf at level 10, i at level 0, right associativity).

Lemma Rseq1 n : Rseq n 1 = [n].
Proof.
replace 1 with (0 + 1) at 1 by ring.
now rewrite Rseq_S; auto; rewrite Rseq0; auto.
Qed.

Definition associative_monoid {A : Type} (f : A -> A -> A) (idx : A) :=
  (forall x y z, f x (f y z) = f (f x y) z) /\
   (forall x, f x idx = x) /\
   (forall x, f idx x = x).

Lemma big0 {A : Type}(E : R -> A) (f : A -> A -> A) (idx : A) (a : R) :
  \big[f / idx]_(a <= i < a) E i = idx.
Proof.
now rewrite Rminus_eq_0, Rseq0.
Qed.

Lemma big_recl {A : Type}(E : R -> A) (f : A -> A -> A) (idx : A) (a b : R) :
  Rnat (b - a) -> a < b ->
  \big[f / idx]_(a <= i < b) E i =
   f (E a) (\big[f / idx]_((a + 1) <= i < b) E i).
Proof.
intros hnat altb.
rewrite Rseq_S'; [ | apply Rnat_sub; auto]; simpl.
  replace (b - a - 1) with (b - (a + 1)) by ring.
  easy.
assert (0 < b - a) by lra.
apply Rnat_gt_pred; auto; lra.
Qed.

Lemma big_recr {A : Type}(E : R -> A) (f : A -> A -> A) (idx : A) (a b : R) :
  associative_monoid f idx ->
  Rnat (b - a) -> a < b ->
  \big[f / idx]_(a <= i < b) E i =
   f (\big[f / idx]_(a <= i < (b - 1)) E i)
    (E (b - 1)).
Proof.
intros amf hnat altb.
assert (induct_arg : Rnat (b - a  - 1)).
  apply Rnat_sub; auto; apply Rnat_gt_pred; auto; lra.
enough (main : forall p, Rnat p ->
  forall a, fold_right f idx (map (fun i => E i) (Rseq a (p + 1))) =
   f (fold_right f idx (map (fun i => E i) (Rseq a p))) (E (a + p))).
  replace (b - a) with (b - a - 1 + 1) by ring.
  rewrite main; auto.
  replace (a + (b - a - 1)) with (b - 1) by ring.
  now replace (b - 1 - a) with (b - a - 1) by ring.
clear hnat altb induct_arg a.
intros p'; induction 1 as [ | p pnat Ih] using Rnat_ind; clear p'.
  intros a; rewrite Rplus_0_l, Rplus_0_r, Rseq0, Rseq1; simpl.
  now destruct amf as [_ [P1 P2]]; rewrite P1, P2.
intros a; rewrite Rseq_S; auto; simpl.
rewrite (Rseq_S a); auto; simpl.
destruct amf as [Pa [P1 P2]].
now rewrite Ih, Pa; replace (a + (p + 1)) with (a + 1 + p) by ring.
Qed.

Lemma associative_monoid_Rplus : associative_monoid Rplus 0.
Proof.
split;[exact (fun x y z => eq_sym (Rplus_assoc x y z))| ].
split;[exact Rplus_0_r | exact Rplus_0_l].
Qed.

#[export]
Hint Resolve associative_monoid_Rplus : core.

Lemma sumr_again n :
  Rnat n -> \big[Rplus / 0]_(0 <= i < n) i = n * (n - 1) / 2.
Proof.
induction 1 as [ | p Np Ih] using Rnat_ind.
  rewrite big0; field.
assert (Rnat (p + 1 - 0)) by now rewrite Rminus_0_r; auto.
assert (0 < p + 1) by now assert (tmp := Rnat_ge0 _ Np); lra.
rewrite big_recr; auto.
replace (p + 1 - 1) with p by ring.
rewrite Ih; field.
Qed.

Section sqrt2_not_rational.

Definition multiple (a b : R) :=
  exists k, Rnat k /\ b = k * a.

Lemma multiple_sub (a b c : R) :
  0 < a ->
  c <= b -> multiple a b -> multiple a c -> multiple a (b - c).
Proof.
intros agt0 cmp [k [nk mb]] [l [nl mc]].
exists (k - l); split.
  apply Rnat_sub; auto.
  (* Here nra finishes the proof. *)
  apply (Rmult_le_reg_r a); auto.
  now rewrite <- mc, <- mb.
now rewrite Rmult_minus_distr_r, mb, mc.
Qed.

Lemma even_or_odd (n : R) :
  Rnat n -> multiple 2 n \/ multiple 2 (n - 1).
Proof.
induction 1 as [ | p pnat Ih] using Rnat_ind.
  left; exists 0; split; auto; field.
destruct Ih as [mp | [l [lnat mp]]].
  now right; replace (p + 1 - 1) with p by ring.
left; exists (l + 1); split; auto; lra.
Qed.

Lemma not_even_and_odd (n : R) :
  Rnat n -> multiple 2 n -> ~multiple 2 (n - 1).
Proof.
enough (Rnat n -> ((multiple 2 n -> ~multiple 2 (n - 1)) /\
                   (multiple 2 (n + 1) -> ~multiple 2 n))).
  tauto.
induction 1 as [ | p pnat Ih] using Rnat_ind.
  split.
    intros _ [k [knat odd0]].
    assert (tmp := Rnat_ge0 _ knat); lra.
  rewrite Rplus_0_l; intros [k [knat even1]].
  revert even1; induction knat as [ | p pnat Ih] using Rnat_ind.
    lra.
  assert (tmp := Rnat_ge0 _ pnat); lra.
split.
  replace (p + 1 - 1) with p by ring.
  tauto.
destruct Ih as [Ih1 Ih2].
replace (p + 1 + 1) with (p + 2) by ring.
intros evenpp2.
assert (evenp : multiple 2 p).
  replace p with (p + 2 - 2) by ring; apply multiple_sub; auto; try lra.
  assert (tmp := Rnat_ge0 _ pnat); lra.
  exists 1; split; auto; ring.
intros [k [knat evenpp1]]; case (Ih1 evenp).
assert (tmp := Rnat_ge0 _ knat).
exists (k - 1); split;[ | lra].
apply Rnat_sub; auto.
assert (tmp' := Rnat_ge0 _ pnat).
apply Rnat_gt_pred; auto; lra.
(* This part is a bit iffy, lra solves the problem in ways I don't
  really understand. *)
Qed.

Lemma even_square_to_even (n : R) :
  Rnat n -> multiple 2 (n * n) -> multiple 2 n.
Proof.
intros nnat evensqr.
case (even_or_odd _ nnat); auto.
intros [k [knat keq]].
assert (nsqr : Rnat (n * n)) by auto.
case (not_even_and_odd (n * n) nsqr evensqr).
exists (k * k * 2 + (n - 1)).
split;[now rewrite keq; auto | ].
replace n with (n - 1 + 1) by ring.
rewrite keq; ring.
Qed.

Lemma sqr2_not_rational (p q : R) :
  Rnat p -> Rnat q -> q <> 0 -> 2 <> (p ^ 2 / q ^ 2).
Proof.
intros pnat qnat qn0 abs.
assert (abs' : q ^ 2 * 2 = p ^ 2).
  assert (0 < q ^ 2) by nra.
  apply (Rmult_eq_reg_r (/ q ^ 2)).
  rewrite abs; field; auto.
  apply Rinv_neq_0_compat; nra.
clear abs.
assert (main :
     forall p q,  Rnat p /\ Rnat q /\ q <> 0 /\ q ^ 2 * 2 = p ^ 2 ->
        exists r, r < q /\ Rnat r /\ r <> 0 /\ r ^ 2 * 2 = q ^ 2).
  clear p q pnat qnat qn0 abs'.
  intros p q [pnat [qnat [qn0 sqrt2eq]]].
  assert (evenp2 : multiple 2 (p * p)).
    exists (q ^ 2); split.
      now simpl; auto.
    nra.
  destruct (even_square_to_even _ pnat evenp2) as [k [knat kp]].
  exists k.
  assert (kgt0 : 0 < k).
    assert (tmp := Rnat_ge0 _ knat); nra.
  assert (keq : (k ^ 2) * 2 = q ^ 2).
    apply (Rmult_eq_reg_r 2); try lra.
    replace (k ^ 2 * 2 * 2) with ((k * 2) ^ 2) by ring.
    rewrite <- kp; lra.
  assert (kltq : k < q).
    assert (k ^ 2 < q ^ 2) by nra.
    case (Rlt_le_dec k q); auto.
    intros qlek; enough (q ^ 2 <= k ^ 2) by nra.
    apply pow_incr.
    assert (tmp := Rnat_ge0 _ qnat); lra.
  repeat split; (auto || (try lra)).
revert qn0 p pnat abs'.
elim qnat using course_of_value_induction.
clear q qnat.
intros q Ih qnat qneq0 p pnat sqrt2eq.
destruct (main p q) as [r [rlt1 [rnat [rn0 req]]]].
  now repeat split; auto.
now revert req; apply Ih; auto.
Qed.

End sqrt2_not_rational.

Lemma associative_mul : associative_monoid Rmult 1.
Proof.
split.
  exact (fun x y z => eq_sym (Rmult_assoc x y z)).
split.
  exact Rmult_1_r.
exact Rmult_1_l.
Qed.

#[export]
Hint Resolve associative_mul : core.

Section Taylor_Lagrange.

Definition Rnat_to_nat (n : R) : nat :=
  Z.to_nat (Int_part n).

Lemma Rnat_to_natP (n : R) : Rnat n -> INR (Rnat_to_nat n) = n.
Proof.
rewrite Rnat_to_Rnat'; intros [k [keq kge0]].
unfold Rnat_to_nat.
assert (toz : Int_part n = k).
  destruct (base_Int_part n) as [P1 P2].
  rewrite keq in P1 at 2.
  apply le_IZR in P1.
  rewrite keq in P2 at 2.
  rewrite <- minus_IZR in P2.
  apply lt_IZR in P2.
  lia.
now rewrite toz, <- INR_IZN; auto.
Qed.

Lemma Rnat_to_natP' (n : nat) : Rnat_to_nat (INR n) = n.
Proof.
now apply INR_eq; rewrite Rnat_to_natP; auto.
Qed.

Ltac compute_Rnat_to_nat n :=
  match n with
  | IZR Z0 =>
    (replace (IZR Z0) with (INR 0) by reflexivity);
    rewrite (Rnat_to_natP' 0)
  | IZR (Zpos ?x) =>
    let v1 := eval compute in (Pos.to_nat x) in
    replace (IZR (Zpos x)) with (INR v1);
    [ rewrite Rnat_to_natP' | change v1 with (Pos.to_nat x);
        rewrite INR_IZN; auto; lia]
  end.

Definition ex_der_n (f : R -> R) (n : R) :=
  ex_derive_n f (Rnat_to_nat n).

Definition sumn (n : R) := \big[Rplus / 0]_(0 <= x < n) x.

Ltac rid_of_Rnat :=   match goal with |- Rnat ?A => field_simplify A end; auto.

Lemma sumn_eq (n : R) : Rnat n -> sumn n = n * (n - 1) / 2.
Proof.
induction 1 using Rnat_ind.
  unfold sumn.
  rewrite big0.
  field.
unfold sumn; rewrite big_recr; cycle 1.
    exact associative_monoid_Rplus.
  rid_of_Rnat.
  apply Rnat_ge0 in H.
 lra.
field_simplify.
field_simplify (k + 1 - 1).
unfold sumn in IHRnat.
rewrite IHRnat.
field.
Qed.

Definition fact (n : R) := \big[Rmult / 1]_(1 <= x < n + 1) x.

Lemma fact_ge0 n : Rnat n -> 1 <= fact n.
Proof.
induction 1 as [ | p pnat Ih] using Rnat_ind .
  unfold fact.
  field_simplify (0 + 1).
  rewrite big0.
  lra.
replace (fact (p + 1)) with (fact p * (p + 1)). (* postponed justification *)
  replace 1 with (1 * 1) at 1 by field.
  apply Rmult_le_compat; try lra.
  apply Rnat_ge0 in pnat; lra.
(* Now proving the postponed justification *)
unfold fact at 2.
rewrite big_recr; auto.
    field_simplify (p + 1 + 1 - 1).
    easy.
  field_simplify (p + 1 + 1 - 1); auto.
apply Rnat_ge0 in pnat; lra.
Qed.

Definition Der_n (f : R -> R) (n : R) :=
  Rnat_iter n (fun (dp : R -> R) => Derive dp) f.

Lemma Der_n_correct (f : R -> R) (n : nat) (x : R) :
  Der_n f (INR n) x = Derive_n f n x.
Proof.
revert x; induction n as [ | p Ih]; intros x.
  now unfold Der_n; simpl; rewrite Rnat_iter0.
unfold Der_n; rewrite S_INR, Rnat_iterS; auto; simpl.
apply Derive_ext; exact Ih.
Qed.

Lemma Der_n_0 (f : R -> R) x : Der_n f 0 x = f x.
Proof.
replace 0 with (INR 0) by (simpl; ring).
now rewrite Der_n_correct.
Qed.

Lemma Der_n_S (f : R -> R) n x : Rnat n -> 1 <= n ->
  Der_n f n x = Derive (Der_n f (n - 1)) x.
Proof.
intros [[ | p] peq] nge1.
  rewrite peq in nge1; simpl in nge1; lra.
rewrite peq, Der_n_correct.
change 1 with (INR 1); rewrite <- minus_INR; try lia.
simpl; apply Derive_ext; intros t; rewrite Der_n_correct.
now rewrite Nat.sub_0_r.
Qed.

Lemma sum_f_R0_big f n :
  sum_f_R0 f n = \big[Rplus / 0]_(0 <= x < INR n + 1) f (Rnat_to_nat x).
Proof.
induction n as [ | p Ih].
  simpl.
  rewrite big_recr; try (lra || auto).
    replace (0 + 1 - 1) with 0 by ring.
    rewrite big0, Rplus_0_l.
    replace 0 with (INR 0) by auto.
    now rewrite Rnat_to_natP'.
  replace (0 + 1 - 0) with 1 by ring; auto.
rewrite S_INR; simpl; rewrite big_recr; try (lra || auto).
    replace (INR p + 1 + 1 - 1) with (INR p + 1) by ring.
    rewrite <- Ih; clear Ih.
    now rewrite <- S_INR, Rnat_to_natP'.
  now apply Rnat_sub; auto with real.
now auto with real.
Qed.

Lemma Rnat_to_nat0 : Rnat_to_nat 0 = 0%nat.
Proof.
now replace 0 with (INR 0) by (simpl; ring); rewrite Rnat_to_natP'.
Qed.

Lemma Rnat_to_natS n :
  Rnat n -> Rnat_to_nat (n + 1) = S (Rnat_to_nat n).
Proof.
now intros [n' n'eq]; rewrite n'eq, <- S_INR, !Rnat_to_natP'.
Qed.

Lemma factP n : Rnat n -> fact n = INR (Factorial.fact (Rnat_to_nat n)).
Proof.
induction 1 as [ | p pnat Ih] using Rnat_ind.
  unfold fact.
  replace (0 + 1) with 1 by ring.
  rewrite big0.
  replace 0 with (INR 0) by (simpl; ring); rewrite Rnat_to_natP'.
  easy.
replace (fact (p + 1)) with ((p + 1) * fact p).
  rewrite Rnat_to_natS; auto; cbn [Factorial.fact].
  rewrite mult_INR, S_INR, Rnat_to_natP; auto.
  now rewrite Ih.
unfold fact at 2.
rewrite big_recr; auto.
    replace (p + 1 + 1 - 1) with (p + 1) by ring.
    now rewrite Rmult_comm.
  now replace (p + 1 + 1 - 1) with (p + 1) by ring; auto.
assert (tmp := Rnat_ge0 p pnat); lra.
Qed.

Lemma big_eq_Rnat (E2 E1 : R -> R)
  (f : R -> R -> R) (idx : R) (a b : R) :
  (forall i, Rnat i -> E1 i = E2 i) ->
  Rnat a -> Rnat b -> a <= b ->
  \big[f / idx]_(a <= i < b) E1 i =
  \big[f / idx]_(a <= i < b) E2 i.
Proof.
intros ext anat bnat altb.
rewrite (map_ext_Forall _ E2); auto.
rewrite Forall_forall; intros x xin.
apply ext; revert x xin; rewrite <- Forall_forall.
apply Rseq_nat; auto.
now apply Rnat_sub.
Qed.

Definition Rnat_pow (x n : R) := x ^ Rnat_to_nat n.

Lemma Taylor_Lagrange (f : R -> R) (n x y : R) :
  Rnat n ->
  x < y ->
  (forall t, x <= t <= y ->
     forall k,  Rnat k -> k <= n + 1 -> ex_der_n f k t) ->
  exists zeta : R,
     x < zeta < y /\
     f y =
     \big[Rplus / 0]_(0 <= m < n + 1)
        (Rnat_pow (y - x) m / fact m * Der_n f m x) +
     Rnat_pow (y - x) (n + 1) / fact (n + 1) * Der_n f (n + 1) zeta.
Proof.
intros [n' n'eq]; rewrite n'eq.
intros xlty.
intros ders.
assert (ders' :
  forall t, x <= t <= y -> forall k, (k <= S n')%nat -> ex_derive_n f k t).
  intros t xty k kleSn'.
  assert (INRkleSn' : INR k <= INR n' + 1).
    change 1 with (INR 1).
    now rewrite <- plus_INR, Nat.add_1_r; apply le_INR.
  generalize (ders t xty (INR k) (Rnat_INR _) INRkleSn').
  now unfold ex_der_n; rewrite Rnat_to_natP'.
destruct (Derive.Taylor_Lagrange f n' x y xlty ders') as
  [zeta [intzeta eqn]].
exists zeta; split;[exact intzeta | rewrite eqn].
rewrite sum_f_R0_big.
assert (ext: forall i,  Rnat i ->
   (y - x) ^ Rnat_to_nat i / INR (Factorial.fact (Rnat_to_nat i)) *
     Derive_n f (Rnat_to_nat i) x =
   Rnat_pow (y - x) i / fact i * Der_n f i x).
  intros i [i' i'eq]; rewrite i'eq, factP; auto.
  rewrite Der_n_correct; auto.
  now unfold Rnat_pow; rewrite !Rnat_to_natP'.
rewrite (big_eq_Rnat _ _ Rplus 0 _ _ ext); auto.
  apply f_equal.
  rewrite <- S_INR, factP; auto.
  unfold Rnat_pow; rewrite !Rnat_to_natP'.
  now rewrite Der_n_correct.
now auto with real.
Qed.

Lemma Rnat_to_nat_interval n : 0 <= n ->
  INR (Rnat_to_nat n) <= n < INR (Rnat_to_nat n) + 1.
Proof.
intros nge0; unfold Rnat_to_nat.
rewrite <- INR_IZN.
  assert (tmp := base_Int_part n); lra.
enough (-1 < Int_part n)%Z by lia.
assert (tmp := base_Int_part n).
apply lt_IZR; lra.
Qed.

Lemma ex_der_n_0 f x : ex_der_n f 0 x.
Proof.
now unfold ex_der_n; rewrite Rnat_to_nat0.
Qed.

Lemma ex_der_n_S' n f x :
  Rnat n ->
  1 <= n ->
  ex_der_n f n x <-> ex_derive (Der_n f (n - 1)) x.
Proof.
intros nnat nge1.
unfold ex_der_n.
assert (exists p, Rnat_to_nat n = S p) as [p pneq].
  destruct (Rnat_to_nat n) as [ | p] eqn:rnat_eq; cycle 1.
    now exists p.
  assert (nge0 : 0 <= n) by lra.
  destruct (Rnat_to_nat_interval n nge0) as [_ abs].
  rewrite rnat_eq in abs; simpl in abs; lra.
rewrite pneq; simpl.
assert (nm1nat : Rnat (n - 1)) by now apply Rnat_sub; auto.
assert (nm1eq : n - 1 = INR p).
  enough (step : n = INR p + INR 1) by now simpl in step; lra.
  now rewrite <- plus_INR, Nat.add_1_r, <- pneq, Rnat_to_natP.
rewrite nm1eq.
split;
  now apply ex_derive_ext; intros t; rewrite Der_n_correct.
Qed.

Lemma Rnat_pow_S x n : Rnat (n - 1) -> Rnat_pow x n = Rnat_pow x (n - 1) * x.
Proof.
intros nnat.
unfold Rnat_pow.
replace n with ((n - 1) + 1) at 1 by ring.
rewrite Rnat_to_natS; simpl;[ring | easy].
Qed.

Lemma Rnat_pow_0 x : Rnat_pow x 0 = 1.
Proof.
unfold Rnat_pow; rewrite Rnat_to_nat0; ring.
Qed.

Lemma is_derive_Rnat_pow_0 :
  forall t, is_derive (fun x => Rnat_pow x 0) t 0.
Proof.
intros t; unfold Rnat_pow; rewrite Rnat_to_nat0.
auto_derive; auto; ring.
Qed.

Global Instance UnaryDiff_Rnat0 :
  UnaryDiff (fun x => Rnat_pow x 0).
Proof.
exists (fun x => 0).
now apply is_derive_Rnat_pow_0.
Defined.

Lemma is_derive_Rnat_pow_S :
  forall n, Rnat n -> 1 <= n ->
  forall t,
  is_derive (fun x => Rnat_pow x n) t (n * Rnat_pow t (n - 1)).
Proof.
intros n nnat nge1 t.
unfold Rnat_pow.
auto_derive; auto.
rewrite Rnat_to_natP, Rmult_1_l; auto.
replace n with ((n - 1) + 1) at 2 by ring.
rewrite Rnat_to_natS; auto; simpl.
apply Rnat_sub; auto; lra.
Qed.

Global Instance UnaryDiff_Rnat_powS :
  forall n, Rnat n -> 1 <= n -> UnaryDiff (fun x => Rnat_pow x n).
Proof.
  intros n nnat nge0.
  exists (fun x => n * Rnat_pow x (n - 1)).
intros x.
now apply is_derive_Rnat_pow_S.
Defined.

Lemma Rnat_pow1n n : Rnat n -> Rnat_pow 1 n = 1.
Proof.
intros nnat; induction nnat as [ | p pnat Ih] using Rnat_ind.
  now rewrite Rnat_pow_0.
rewrite Rnat_pow_S; replace (p + 1 - 1) with p by ring; auto.
rewrite Ih; ring.
Qed.

Lemma Rnat_pow_incr x y n :
  Rnat n -> 0 < n -> 0 < x < y -> 0 < Rnat_pow x n < Rnat_pow y n.
Proof.
induction 1 as [ | p pnat Ih] using Rnat_ind.
  lra.
generalize (refl_equal p).
pattern p at -1; induction pnat as [ | q qnat _] using Rnat_ind.
  intros pis0 _ xlty.
  replace (0 + 1) with 1 by ring.
  rewrite (Rnat_pow_S x), (Rnat_pow_S y); replace (1 - 1) with 0 by ring;
    auto.
  now rewrite !Rnat_pow_0, !Rmult_1_l.
intros peq _ xlty; rewrite <- peq.
rewrite !(Rnat_pow_S _ (p + 1)); replace (p + 1 - 1) with p by ring;
  try (now rewrite peq; auto).
assert (pgt0 : 0 < p).
  assert (tmp := Rnat_ge0 _ qnat); lra.
assert (Ih' := Ih pgt0 xlty).
split.
  apply Rmult_lt_0_compat; lra.
apply Rlt_trans with (Rnat_pow x p * y).
  nra.
nra.
Qed.

Lemma ln23 : ln 3 - ln 2 < 1 / 2 - 1 / 8 + 1 / 24.
Proof.
assert (tmp:= Taylor_Lagrange ln 2 2 3).
assert (nat2 : Rnat 2) by auto.
assert (cmp23 : 2 < 3) by lra.
assert (ex_der_n0 : forall t, 2 <= t <= 3 -> ex_der_n ln 0 t).
  now intros t tint; apply ex_der_n_0.
assert (dln : forall t, 0 < t ->
         is_derive ln t ((fun x => / x) t)).
  intros t tint; auto_derive; lra.
assert (dV : forall t, 0 < t ->
         is_derive (fun x => / x) t ((fun x => - / (Rnat_pow t 2)) t)).
  intros t tint; auto_derive;[lra | ].
  rewrite 2!Rnat_pow_S; auto.
      replace (2 - 1 - 1) with 0 by ring; rewrite Rnat_pow_0; field; lra.
    now replace (2 - 1 - 1) with 0 by ring; auto.
  now replace (2 - 1) with 1 by ring; auto.
assert (dp2 : forall t,
  Derive (fun x => Rnat_pow x 2) t = 2 * Rnat_pow t (2 - 1)).
  intros t.
  apply is_derive_unique.
  apply is_derive_Rnat_pow_S; auto; lra.
assert (dp3 : forall t,
  Derive (fun x => Rnat_pow x 3) t = 3 * Rnat_pow t (3 - 1)).
  intros t.
  apply is_derive_unique.
  apply is_derive_Rnat_pow_S; auto; lra.
assert (dV2 : forall t, 0 < t ->
         is_derive (fun x => -/ Rnat_pow x 2) t
          ((fun x =>  2 / (Rnat_pow t 3)) t)).
  intros t tint; auto_derive.
    split.
      exists (2 * Rnat_pow t (2 - 1)).
      apply is_derive_Rnat_pow_S; auto; lra.
    split; auto.
    rewrite Rnat_pow_S; replace (2 - 1) with 1 by ring; auto.
    rewrite Rnat_pow_S; replace (1 - 1) with 0 by ring; auto.
    rewrite Rnat_pow_0; nra.
  rewrite dp2.
  rewrite !Ropp_mult_distr_l, Ropp_involutive, Rmult_1_l.
  replace (2 - 1) with 1 by ring.
  rewrite Rnat_pow_S; replace (1 - 1) with 0 by ring; auto.
  rewrite Rnat_pow_0, Rmult_1_l.
  rewrite (Rnat_pow_S _ 3); replace (3 - 1) with 2 by ring; auto.
  rewrite 2!Rnat_pow_S; replace (2 - 1) with 1 by ring;
   replace (1 - 1) with 0 by ring; auto.
  rewrite Rnat_pow_0, Rmult_1_l; field; lra.
assert (dV3 : forall t, 0 < t ->
          is_derive (fun x => 2 / Rnat_pow x 3) t
                ((fun x => -6 / Rnat_pow t 4) t)).
  intros t tint; auto_derive.
    split.
      exists (3 * Rnat_pow t (3 - 1)).
      apply is_derive_Rnat_pow_S; auto; lra.
    split; auto.
    rewrite Rnat_pow_S; replace (3 - 1) with 2 by ring; auto.
    rewrite Rnat_pow_S; replace (2 - 1) with 1 by ring; auto.
    rewrite Rnat_pow_S; replace (1 - 1) with 0 by ring; auto.
    rewrite Rnat_pow_0, Rmult_1_l.
    repeat apply Rmult_integral_contrapositive_currified; lra.
  rewrite (Rnat_pow_S _ 4); replace (4 - 1) with 3 by ring; auto.
  rewrite dp3.
  rewrite (Rnat_pow_S _ 3); replace (3 - 1) with 2 by ring; auto.
  rewrite 2!Rnat_pow_S;
   replace (2 - 1) with 1 by ring;
   replace (1 - 1) with 0 by ring; auto.
  rewrite Rnat_pow_0, Rmult_1_l; field; lra.
assert (tmp2 := tmp nat2 cmp23); clear tmp; rename tmp2 into tmp.
assert (der1 : forall t, 0 < t -> Der_n ln 1 t = / t).
  intros t tgt0; rewrite Der_n_S; auto; try lra.
  apply is_derive_unique; replace (1 - 1) with 0 by ring.
  now generalize (dln t tgt0); apply is_derive_ext; intros u; rewrite Der_n_0.
assert (der2 : forall t, 0 < t -> Der_n ln 2 t = - / Rnat_pow t 2).
  intros t tgt0; rewrite Der_n_S; auto; try lra.
  apply is_derive_unique; replace (2 - 1) with 1 by ring.
  generalize (dV t tgt0); apply is_derive_ext_loc.
  exists (mkposreal _ tgt0); simpl; intros u uloc.
  apply Rabs_def2 in uloc; unfold minus, plus, opp in uloc; simpl in uloc.
  assert (uint0 : 0 < u) by lra.
  now symmetry; apply der1.
assert (der3 : forall t, 0 < t -> Der_n ln 3 t = 2 / Rnat_pow t 3).
  intros t tgt0; rewrite Der_n_S; auto; try lra.
  apply is_derive_unique; replace (3 - 1) with 2 by ring.
  generalize (dV2 t tgt0); apply is_derive_ext_loc.
  exists (mkposreal _ tgt0); simpl; intros u uloc.
  apply Rabs_def2 in uloc; unfold minus, plus, opp in uloc; simpl in uloc.
  assert (uint0 : 0 < u) by lra.
  now symmetry; apply der2.
assert (allders : forall t, 2 <= t <= 3 ->
          forall k,  Rnat k -> k <= 2 + 1 -> ex_der_n ln k t).
  intros t tint k knat.
  assert (tint0 : 0 < t) by lra.
  induction knat as [ | k1 k1nat _] using Rnat_ind.
    now intros _; apply ex_der_n0.
  intros k1le'; assert (k1le : k1 <= 2) by lra; clear k1le'.
  rewrite ex_der_n_S'; replace (k1 + 1 - 1) with k1 by ring; auto; cycle 1.
    assert (tmp3 := Rnat_ge0 _ k1nat); lra.
  revert k1le; induction k1nat as [ | k2 k2nat _] using Rnat_ind.
    intros _.
    exists (/ t).
    generalize (dln _ tint0); apply is_derive_ext.
    now intros u; rewrite Der_n_0.
  intros k2le'; assert (k2le : k2 <= 1) by lra; clear k2le'.
  revert k2le; induction k2nat as [ | k3 k3nat _] using Rnat_ind.
    intros _.
    exists (- / Rnat_pow t 2).
    replace (0 + 1) with 1 by ring.
        generalize (dV _ tint0); apply is_derive_ext_loc.
    exists posreal_one.
    intros u uloc.
    apply Rabs_def2 in uloc; unfold minus, plus, opp in uloc; simpl in uloc.
    assert (uint0 : 0 < u) by lra.
    now rewrite der1.
  intros k3le0.
  assert (tmp3 := Rnat_ge0 _ k3nat).
  assert (k3is0 : k3 = 0) by lra; clear tmp3.
  rewrite k3is0.
  replace (0 + 1 + 1) with 2 by (simpl; ring).
  exists (2 / Rnat_pow t 3).
  generalize (dV2 _ tint0).
  apply is_derive_ext_loc.
  exists (mkposreal _ tint0).
  intros u uloc.
  apply Rabs_def2 in uloc; unfold minus, plus, opp in uloc; simpl in uloc.
  assert (uint0 : 0 < u) by lra.
  now rewrite der2.
destruct (tmp allders) as [zeta [zetaint formula]]; clear tmp.
assert (fact0 : fact 0 = 1).
  now unfold fact; replace (0 + 1) with 1 by ring; rewrite big0.
assert (fact1 : fact 1 = 1).
  unfold fact; rewrite big_recl; auto; try lra; cycle 1.
    now replace (1 + 1 - 1) with 1 by ring; auto.
  rewrite big0; ring.
assert (fact2 : fact 2 = 2).
  unfold fact; rewrite big_recl; auto; try lra; cycle 1.
    now replace (2 + 1 - 1) with 2 by ring; auto.
  rewrite big_recl; auto; try lra; cycle 1.
    now replace (2 + 1 - (1 + 1)) with 1 by ring; auto.
  rewrite big0; ring.
assert (fact3 : fact 3 = 6).
  unfold fact; rewrite big_recl; auto; try lra; cycle 1.
    now replace (3 + 1 - 1) with 3 by ring; auto.
  rewrite big_recl; auto; try lra; cycle 1.
    now replace (3 + 1 - (1 + 1)) with 2 by ring; auto.
  rewrite big_recl; auto; try lra; cycle 1.
    now replace (3 + 1 - (1 + 1 + 1)) with 1 by ring; auto.
  replace (1 + 1 + 1 + 1) with 4 by ring.
  replace (3 + 1) with 4 by ring.
  rewrite big0; ring.
revert formula; rewrite big_recr; auto; try lra; cycle 1.
  now replace (2 + 1 - 0) with 3 by ring; auto.
replace (2 + 1) with 3 by ring.
replace (3 - 1) with 2 by ring.
replace (3 - 2) with 1 by ring.
rewrite fact2, fact3, !Rnat_pow1n; auto.
rewrite big_recr; auto; try lra; cycle 1.
  now replace (2 - 0) with 2 by ring; auto.
replace (2 - 1) with 1 by ring.
rewrite Rnat_pow1n; auto.
rewrite big_recl; auto; try lra; cycle 1.
  now replace (1 - 0) with 1 by ring; auto.
replace (0 + 1) with 1 by ring.
rewrite big0, !Rnat_pow1n, fact0, fact1; auto.
rewrite Der_n_0, der1, der2, der3; try lra.
replace (1 / 1 * ln 2) with (ln 2) by field.
replace (1 / 1 * / 2) with (/ 2) by field.
intros tf_formula; rewrite tf_formula; clear tf_formula.
rewrite 2!Rnat_pow_S;
    replace (2 - 1 - 1) with 0 by ring; auto; cycle 1.
  now replace (2 - 1) with 1 by ring; auto.
rewrite Rnat_pow_0.
assert (Rnat_pow zeta 3 <> 0).
  rewrite 3!Rnat_pow_S; cycle 1.
        now replace (3 - 1 - 1 - 1) with 0 by ring; auto.
      now replace (3 - 1 - 1) with 1 by ring; auto.
    now replace (3 - 1) with 2 by ring; auto.
  replace (3 - 1 - 1 - 1) with 0 by ring; rewrite Rnat_pow_0.
  rewrite Rmult_1_l.
  repeat apply Rmult_integral_contrapositive_currified; lra.
match goal with |- ?x < _ =>
  replace x with (1 / 2 - 1 / 8 + 1 / ( 3 * Rnat_pow zeta 3));
  [ | now field; auto]
end.
repeat apply Rplus_lt_compat_l.
apply Rmult_lt_compat_l;[lra | ].
apply Rinv_1_lt_contravar;[lra | ].
apply Rle_lt_trans with (3 * Rnat_pow 2 3).
  rewrite 3!Rnat_pow_S; cycle 1.
        now replace (3 - 1 - 1 - 1) with 0 by ring; auto.
      now replace (3 - 1 - 1) with 1 by ring; auto.
    now replace (3 - 1) with 2 by ring; auto.
  replace (3 - 1 - 1 - 1) with 0 by ring; rewrite Rnat_pow_0; lra.
enough (Rnat_pow 2 3 < Rnat_pow zeta 3) by lra.
assert (rnat3 : Rnat 3) by auto.
assert (gt0 : 0 < 3) by lra.
assert (zetagt2 : 0 < 2 < zeta) by lra.
assert (tmp := Rnat_pow_incr _ _ _ rnat3 gt0 zetagt2); lra.
Qed.

(* This example shows that all lemmas about pow should be ported for
  Rnat_pow. *)

(* It also shows that computation about immediate natural number values
  needs to be made more fluid: see all the patterns
     replace ... with ... by ring  *)


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*          Pierre Letouzey, Jerome Vouillon, PPS, Paris 7, 2008        *)
(************************************************************************)

(*i $Id: NaryFunctions.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Local Open Scope type_scope.

Require Import List.

(** * Generic dependently-typed operators about [n]-ary functions *)

(** The type of [n]-ary function: [nfun A n B] is
    [A -> ... -> A -> B] with [n] occurences of [A] in this type. *)

Fixpoint nfun A n B :=
 match n with
  | O => B
  | S n => A -> (nfun A n B)
 end.

Notation " A ^^ n --> B " := (nfun A n B)
 (at level 50, n at next level) : type_scope.

(** [napply_cst _ _ a n f] iterates [n] times the application of a
    particular constant [a] to the [n]-ary function [f]. *)

Fixpoint napply_cst (A B:Type)(a:A) n : (A^^n-->B) -> B :=
 match n return (A^^n-->B) -> B with
  | O => fun x => x
  | S n => fun x => napply_cst _ _ a n (x a)
 end.

(** A generic transformation from an n-ary function to another one.*)

Fixpoint nfun_to_nfun (A B C:Type)(f:B -> C) n :
 (A^^n-->B) -> (A^^n-->C) :=
 match n return (A^^n-->B) -> (A^^n-->C) with
  | O => f
  | S n => fun g a => nfun_to_nfun _ _ _ f n (g a)
 end.

(** [napply_except_last _ _ n f] expects [n] arguments of type [A],
    applies [n-1] of them to [f] and discard the last one. *)

Definition napply_except_last (A B:Type) :=
 nfun_to_nfun A B (A->B) (fun b a => b).

(** [napply_then_last _ _ a n f] expects [n] arguments of type [A],
    applies them to [f] and then apply [a] to the result. *)

Definition napply_then_last (A B:Type)(a:A) :=
 nfun_to_nfun A (A->B) B (fun fab => fab a).

(** [napply_discard _ b n] expects [n] arguments, discards then,
    and returns [b]. *)

Fixpoint napply_discard (A B:Type)(b:B) n : A^^n-->B :=
 match n return A^^n-->B with
  | O => b
  | S n => fun _ => napply_discard _ _ b n
 end.

(** A fold function *)

Fixpoint nfold A B (f:A->B->B)(b:B) n : (A^^n-->B) :=
 match n return (A^^n-->B) with
  | O => b
  | S n => fun a => (nfold _ _ f (f a b) n)
 end.

(** [n]-ary products : [nprod A n] is [A*...*A*unit],
  with [n] occurrences of [A] in this type. *)

Fixpoint nprod A n : Type := match n with
 | O => unit
 | S n => (A * nprod A n)%type
end.

Notation "A ^ n" := (nprod A n) : type_scope.

(** [n]-ary curryfication / uncurryfication *)

Fixpoint ncurry (A B:Type) n : (A^n -> B) -> (A^^n-->B) :=
  match n return (A^n -> B) -> (A^^n-->B) with
  | O => fun x => x tt
  | S n => fun f a => ncurry _ _ n (fun p => f (a,p))
  end.

Fixpoint nuncurry (A B:Type) n : (A^^n-->B) -> (A^n -> B) :=
 match n return (A^^n-->B) -> (A^n -> B) with
  | O => fun x _ => x
  | S n => fun f p => let (x,p) := p in nuncurry _ _ n (f x) p
 end.

(** Earlier functions can also be defined via [ncurry/nuncurry].
    For instance : *)

Definition nfun_to_nfun_bis A B C (f:B->C) n :
 (A^^n-->B) -> (A^^n-->C) :=
 fun anb => ncurry _ _ n (fun an => f ((nuncurry _ _ n anb) an)).

(** We can also us it to obtain another [fold] function,
    equivalent to the previous one, but with a nicer expansion
    (see for instance Int31.iszero). *)

Fixpoint nfold_bis A B (f:A->B->B)(b:B) n : (A^^n-->B) :=
 match n return (A^^n-->B) with
  | O => b
  | S n => fun a =>
      nfun_to_nfun_bis _ _ _ (f a) n (nfold_bis _ _ f b n)
 end.

(** From [nprod] to [list] *)

Fixpoint nprod_to_list (A:Type) n : A^n -> list A :=
 match n with
  | O => fun _ => nil
  | S n => fun p => let (x,p) := p in x::(nprod_to_list _ n p)
 end.

(** From [list] to [nprod] *)

Fixpoint nprod_of_list (A:Type)(l:list A) : A^(length l) :=
 match l return A^(length l) with
  | nil => tt
  | x::l => (x, nprod_of_list _ l)
 end.

(** This gives an additional way to write the fold *)

Definition nfold_list (A B:Type)(f:A->B->B)(b:B) n : (A^^n-->B) :=
  ncurry _ _ n (fun p => fold_right f b (nprod_to_list _ _ p)).


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import mathcomp.ssreflect.ssreflect.
Require Import Classes.RelationClasses Classes.Morphisms List Tactics.
From mathcomp Require Import ssrfun ssrbool ssrnat seq.

Import ListNotations.

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

(* There are similar definitions in the Ensembles library (Included
   and Same_set); set_eq is not exactly the same as Same_set though
   (only logically equivalent). *)

Definition set T := T -> Prop.

Declare Scope set_scope.
Notation "x \in A" := (A x) (at level 70, only parsing) : set_scope.

Definition set_eq {A} (m1 m2 : set A) :=
  forall (a : A), m1 a <-> m2 a.

Infix "<-->" := set_eq (at level 70, no associativity) : set_scope.

Local Open Scope set_scope.

Lemma set_eq_trans T B (A C : set T) : A <--> B -> B <--> C -> A <--> C.
Proof.
by move=> eqAB eqBC; split=> [/eqAB/eqBC|/eqBC/eqAB].
Qed.

Lemma set_eq_symm {A} (s1 s2 : set A) :
  s1 <--> s2 -> s2 <--> s1.
Proof.
  firstorder.
Qed.

Lemma set_eq_refl {A} (s : set A) :
  s <--> s.
Proof.
  firstorder.
Qed.

#[global] Instance : forall T, Equivalence (@set_eq T).
Proof.
move=> T; constructor=> // [A B eqAB | A B C] x; first by split=> /eqAB.
exact: set_eq_trans.
Qed.

#[global] Instance set_eq_rew A : RelationClasses.RewriteRelation (@set_eq A) := {}.

Definition set_incl {A} (m1 m2 : set A) :=
  forall (a : A), m1 a -> m2 a.

Infix "\subset" := set_incl (at level 70, no associativity) : set_scope.

Notation "[ 'set' x : T | P ]" := (fun x : T => P)
  (at level 0, x at level 99, only parsing) : set_scope.
Notation "[ 'set' x | P ]" := [set x : _ | P]
  (at level 0, x, P at level 99, format "[ 'set'  x  |  P ]", only parsing) : set_scope.

Definition set0 {T} := [set _ : T | False].

Definition setT {T} := [set _ : T | True].

Notation "[ 'set' : T ]" := (@setT T)
  (at level 0, format "[ 'set' :  T ]") : set_scope.

Section setOpsDef.

Context {T U : Type}.
Implicit Types (a x : T) (A B : set T).

Definition set1 a := eq a.

Definition setU A B := [set x | x \in A \/ x \in B].

Definition setI A B := [set x | x \in A /\ x \in B].

Definition codom (f : T -> U) := [set y | exists x, f x = y].

Definition bigcup A (F : T -> set U) := [set x | exists i, i \in A /\ x \in F i].

Definition bigcap (A : set T) (F : T -> set U) :=
  [set x | forall (i : T), i \in A -> x \in F i].

End setOpsDef.

Definition imset {T U} (f : T -> U) A := bigcup A (fun x => set1 (f x)).

Definition setX T U (A : set T) (B : set U) := [set x | x.1 \in A /\ x.2 \in B].

Definition imset2 T U V (f : T -> U -> V) A1 A2 :=
  imset (uncurry f) (setX A1 A2).

Definition codom2 T U V (f : T -> U -> V) := codom (uncurry f).

Notation "[ 'set' a ]" := (set1 a)
  (at level 0, a at level 99, format "[ 'set'  a ]") : set_scope.
Notation "[ 'set' a : T ]" := [set (a : T)]
  (at level 0, a at level 99, format "[ 'set'  a   :  T ]") : set_scope.

Notation "A :|: B" := (setU A B) (at level 52, left associativity) : set_scope.
Notation "a |: A" := ([set a] :|: A) (at level 52, left associativity) : set_scope.

Notation "A :&: B" := (setI A B) (at level 48, left associativity) : set_scope.

Notation "f @: A" := (imset f A) (at level 24) : set_scope.

Notation "f @2: ( A , B )" := (imset2 f A B)
  (at level 24, format "f  @2:  ( A ,  B )") : set_scope.

Notation "\bigcup_ i F" := (bigcup setT (fun i => F))
  (at level 41, F at level 41, i at level 0,
           format "'[' \bigcup_ i '/  '  F ']'") : set_scope.
Notation "\bigcup_ ( i : t ) F" := (bigcup (@setT t) (fun i => F))
  (at level 41, F at level 41, i at level 50,
           format "'[' \bigcup_ ( i   :  t ) '/  '  F ']'", only parsing) : set_scope.
Notation "\bigcup_ ( i 'in' A ) F" := (bigcup A (fun i => F))
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \bigcup_ ( i  'in'  A ) '/  '  F ']'") : set_scope.

Notation "\bigcap_ ( i 'in' A ) F" := (bigcap A (fun i => F))
  (at level 41, F at level 41, i, A at level 50,
           format "'[' \bigcap_ ( i  'in'  A ) '/  '  F ']'") : set_scope.

Definition lift {T} (S : set T) : set (option T) :=
  Some @: S :|: [set None].

Lemma subset_eqP T (A B : set T) : (A <--> B) <-> (A \subset B /\ B \subset A).
Proof.
split; first by move=> eqAB; split=> a; rewrite (eqAB a).
by case=> subAB subBA a; split; [apply: subAB | apply:subBA].
Qed.

Lemma subset_trans T (A1 A2 A3 : set T) :
  A1 \subset A2 ->
  A2 \subset A3 ->
  A1 \subset A3.
Proof.
  now firstorder.
Qed.

Lemma subset_refl T (A : set T) : A \subset A.
Proof.
    by rewrite /set_incl.
Qed.

Lemma subset_singl :
  forall {T} (x y : T), [set x] \subset [set y] <-> y = x.
Proof.
  intros. split; intros H; subst; auto.
  - apply H; reflexivity.
  - apply subset_refl.
Qed.

Lemma subset_respects_set_eq_l :
  forall (T : Type) (s1 s2 s3 : set T),
    s1 <--> s3 -> s3 \subset s2 -> s1 \subset s2.
Proof.
  now firstorder.
Qed.

Lemma subset_respects_set_eq_r :
  forall (T : Type) (s1 s2 s3 : set T),
    s3 <--> s2 -> s1 \subset s2 -> s1 \subset s3.
Proof.
  now firstorder.
Qed.

Lemma subset_respects_set_eq :
  forall {T : Type} {s1 s2 s1' s2' : set T},
    s1 <--> s1' ->
    s2 <--> s2' ->
    s1' \subset s2' ->
    s1 \subset s2.
Proof.
  firstorder.
Qed.

Lemma imsetT T U (f : T -> U) : f @: setT <--> codom f.
Proof.
  move=> y; split; first by case=> x [_ fx]; exists x.
    by case=> x fx; exists x.
Qed.

Lemma imset_id T (A : set T) : id @: A <--> A.
Proof.
    by move=> t; split=> [[x [Ax <-]]|At] //; exists t.
Qed.

Lemma imset_incl {T U} (A B : set T) (f : T -> U):
  A \subset B ->
  f @: A \subset f @: B.
Proof.
  move => H u [x [H1 H2]]. eexists; split; eauto.
Qed.

Lemma imset_eq {T U} (A B : set T) (f : T -> U):
  A <--> B ->
  f @: A <--> f @: B.
Proof.
  move => H u. split; apply imset_incl => t Ht; by apply H.
Qed.

Lemma imset_in a b x (f : a -> b) (A : set a) :
  x \in A -> f x \in (f @: A).
Proof.
  intros. unfold imset. exists x. split; by [].
Qed.

Lemma imset_id_ext T (A : set T) f : (forall x, f x = x) -> f @: A <--> A.
Proof.
  rewrite /imset /bigcup => H x. split.
  - move => [y [H1 H2]]. rewrite H in H2. inversion H2. subst. assumption.
  - move => H1. eexists. split. eassumption. by rewrite H.
Qed.

Lemma imset_eq_ext a b (f g : a -> b) (A : set a) :
  (forall x, f x = g x) ->
  f @: A <--> g @: A.
Proof.
  rewrite /imset /bigcup /set1. move => H x.
  split => [[i [H1 H2]] | [i [H1 H2]]]; eexists; split;
           try eassumption. congruence. congruence.
Qed.

Lemma coverE T (A : set T) : \bigcup_(x in A) [set x] <--> A.
Proof. exact: imset_id. Qed.

Lemma setXT T U : setX [set: T] [set: U] <--> [set: T * U].
Proof. by case. Qed.

#[global]
Instance set_incl_Proper T U :
  Proper (@eq (T -> U) ==> set_incl ==> set_incl) imset.
Proof.
by move=> f ? <- A B subAB y [x [Ax fx]]; exists x; split=> //; apply: subAB.
Qed.

#[global]
Instance set_eq_Proper T U : Proper (@eq (T -> U) ==> set_eq ==> set_eq) imset.
Proof.
by move=> f ? <- A B /subset_eqP[subAB subBA] y; split; apply: set_incl_Proper.
Qed.

Lemma sub0set T (A : set T) : set0 \subset A.
Proof. by []. Qed.

Lemma bigcup_set0 T U (F : T -> set U) :
  \bigcup_(x in set0) F x <--> set0.
Proof. by move=> t; split=> // [[? []]]. Qed.

Lemma imset0 T U (f : T -> U) : f @: set0 <--> set0.
Proof. exact: bigcup_set0. Qed.

Lemma bigcup_set1 T U (F : T -> set U) y :
  \bigcup_(x in [set y]) F x <--> F y.
Proof. by move=> t; split=> [[y' [<-]] | Fyt] //; exists y. Qed.

Lemma bigcup_setU_l:
  forall (U T : Type) (s1 s2 : set U) (f : U -> set T),
  \bigcup_(i in (s1 :|: s2)) f i <-->
  \bigcup_(i in s1) f i :|: \bigcup_(i in s2) f i.
Proof.
  firstorder.
Qed.

Lemma bigcup_const A B (P : set B) : inhabited A -> (\bigcup_(_ : A) P) <--> P.
Proof. by case=> a x; split=> [[?] []|Px] //; exists a. Qed.

Lemma bigcup_const_2 A (x :A) B (P : set B) : (\bigcup_(_ in [set x]) P) <--> P.
Proof. by split=> [[?] []|Px] //; exists x; split => //=. Qed.

Lemma bigcupC T U V A B (F : T -> U -> set V) :
  \bigcup_(i in A) \bigcup_(j in B) F i j <-->
  \bigcup_(j in B) \bigcup_(i in A) F i j.
Proof.
  wlog suff: T U A B F / \bigcup_(i in A) \bigcup_(j in B) F i j \subset
   \bigcup_(j in B) \bigcup_(i in A) F i j.
  by move=> sub; apply/subset_eqP; split; apply: sub.
    by move=> x [i [Ai [j [Bj ?]]]]; exists j; split=> //; exists i.
Qed.

Lemma incl_bigcupr T U A (F : T -> set U) G : (forall x, F x \subset G x) ->
  \bigcup_(x in A) F x \subset \bigcup_(x in A) G x.
Proof.
  by move=> subFG t [x [Ax Fxt]]; exists x; split=> //; apply: subFG.
Qed.

Lemma eq_bigcupr T U A (F : T -> set U) G : (forall x, F x <--> G x) ->
  \bigcup_(x in A) F x <--> \bigcup_(x in A) G x.
Proof.
  by move=> eq_FG t; split; apply: incl_bigcupr => {t} x t; rewrite (eq_FG x t).
Qed.

Lemma incl_bigcupl T U A B (F : T -> set U) : A \subset B ->
  \bigcup_(x in A) F x \subset \bigcup_(x in B) F x.
Proof.
    by move=> subAB t [x [Ax Fxt]]; exists x; split=> //; apply: subAB.
Qed.

Lemma eq_bigcupl T U A B (F : T -> set U) : A <--> B ->
  \bigcup_(x in A) F x <--> \bigcup_(x in B) F x.
Proof.
  by move=> /subset_eqP[? ?]; split; apply: incl_bigcupl.
Qed.

Lemma incl_bigcup a b (x:a) (A : set a) (f:a->set b) :
  x \in A ->
  f x \subset \bigcup_(x in A) f x.
Proof.
  rewrite /set_incl /bigcup. by eauto 3.
Qed.

Arguments eq_bigcupl [T U A] B F _ _.

#[global] Instance eq_bigcup T U : Proper (set_eq ==> pointwise_relation T (@set_eq U) ==> set_eq) bigcup.
Proof.
  move=> A B eqAB F G eqFG a; apply: (@set_eq_trans _ (\bigcup_(i in A) G i)).
  exact: eq_bigcupr.
  exact: eq_bigcupl.
Qed.

Lemma bigcup_flatten T U V A (F : T -> set U) (G : U -> set V) :
  \bigcup_(x in \bigcup_(y in A) F y) G x <-->
  \bigcup_(y in A) \bigcup_(x in F y) G x.
Proof.
move=> t; split=> [[x [[y [Ay Fyx]] Gxt]] | [y [Ay [x [Fyx Gxt]]]]].
  by exists y; split=> //; exists x.
by exists x; split=> //; exists y.
Qed.

Lemma codom_apply {A B : Type} {f : A -> B} {x : A} : f x \in codom f.
Proof. eexists; eauto. Qed.

Lemma codomE T U (f : T -> U) : codom f <--> \bigcup_x [set f x].
Proof. by move=> y; split=> [[x fx]|[x [_ fx]]]; exists x. Qed.

Lemma codom_id T : codom id <--> [set: T].
Proof. by move=> x; split=> // _; exists x. Qed.

Lemma codom_const A B (x : B) : inhabited A ->
  codom (fun _ : A => x) <--> [set x].
Proof. by move=> ?; rewrite codomE bigcup_const. Qed.

Lemma imset_comp T U V (f : U -> T) (g : V -> U) A :
  (f \o g) @: A <--> f @: (g @: A).
Proof.
by rewrite /imset bigcup_flatten; apply: eq_bigcupr => x; rewrite bigcup_set1.
Qed.

Lemma codom_comp T U V (f : U -> T) (g : V -> U) :
  codom (f \o g) <--> f @: (codom g).
Proof. by rewrite -imsetT imset_comp imsetT. Qed.

Lemma curry_imset2l T U V (f : T -> U -> V) A1 A2 :
  f @2: (A1, A2) <--> \bigcup_(x1 in A1) f x1 @: A2.
Proof.
move=> a; split.
  by case=> [[x1 x2] [[/= Ax1 Ax2] fx]]; exists x1; split=> //; exists x2.
by case=> [x1 [Ax1 [x2 [Ax2 fx]]]]; exists (x1,x2).
Qed.

Lemma curry_imset2r T U V (f : T -> U -> V) A1 A2 :
  f @2: (A1, A2) <--> \bigcup_(x2 in A2) f^~ x2 @: A1.
Proof. by rewrite curry_imset2l bigcupC. Qed.

Lemma curry_codom2l T U V (f : T -> U -> V) :
  codom (uncurry f) <--> \bigcup_x1 codom (f x1).
Proof.
rewrite -imsetT -setXT -/(imset2 f _ _) curry_imset2l.
by apply: eq_bigcupr => x; rewrite imsetT.
Qed.

Lemma imset_bigcup T U V (f : U -> V) A (F : T -> set U) :
  (f @: \bigcup_(x in A) (F x)) <--> \bigcup_(x in A) f @: F x.
Proof. by rewrite /imset bigcup_flatten. Qed.

Lemma bigcup_imset T U V (f : T -> U) A (F : U -> set V) :
  \bigcup_(y in f @: A) (F y) <--> \bigcup_(x in A) F (f x).
Proof.
by rewrite bigcup_flatten; apply: eq_bigcupr => x; rewrite bigcup_set1.
Qed.

Lemma bigcup_codom T U V (f : T -> U) (F : U -> set V) :
  \bigcup_(y in codom f) (F y) <--> \bigcup_x F (f x).
Proof. by rewrite -imsetT bigcup_imset. Qed.

Coercion seq_In T : seq T -> set T := fun s x => List.In x s.
Coercion list_In T : list T -> set T := fun s x => List.In x s.

Lemma subnilset T (A : set T) : [::] \subset A.
Proof. by []. Qed.

Lemma subconsset T (A : set T) x s :
  x :: s \subset A <-> x \in A /\ s \subset A.
Proof.
split=> [sub|[Ax sub] a [<-|?]] //; last by apply: sub.
split=> [|a sa]; apply: sub; first by left.
by right.
Qed.

Lemma reindex_bigcup I J K (h : J -> I) (F : I -> set K) A B :
  h @: B <--> A ->
  \bigcup_(x in A) F x <--> \bigcup_(y in B) F (h y).
Proof.
move=> surj t; split.
  case=> x [Ax Fxt]; case: (surj x) => [?].
  by case=> // y [By eq_hyx]; exists y; rewrite eq_hyx.
case=> y [By Fhyt]; exists (h y); split=> //.
by case: (surj (h y)) => Ahy _; apply: Ahy; exists y.
Qed.
Arguments reindex_bigcup [I J K] h [F A] B _ _.

Lemma bigcup_pointwise_incl A B (s : set A) (t : A -> set B) (u : set B) :
  (forall x, x \in s -> t x \subset u) ->
  \bigcup_(x in s) t x \subset u.
Proof.
  intros H b [x []]; eapply H; eauto.
Qed.

#[global]
Instance proper_set_incl A :
  Morphisms.Proper (set_eq ==> set_eq ==> Basics.impl) (@set_incl A).
Proof. firstorder. Qed.

(** Lemmas about [setU] and [setI] *)

#[global]
Instance eq_setU U : Proper (set_eq ==> set_eq ==> set_eq) (@setU U).
Proof.
  move=> A B eqAB F G eqFG a.
  split; by move => [H1 | H2]; firstorder.
Qed.

#[global]
Instance eq_setI U : Proper (set_eq ==> set_eq ==> set_eq) (@setI U).
Proof.
  move=> A B eqAB F G eqFG a.
  by split; move => [H1 H2]; firstorder.
Qed.

Lemma setI_comm {U} (s1 s2 : set U) :
   s1 :&: s2 <--> s2 :&: s1.
Proof.
  firstorder.
Qed.

Lemma setU_comm {U} (s1 s2 : set U) :
   s1 :|: s2 <--> s2 :|: s1.
Proof.
  firstorder.
Qed.

Lemma setI_set0_abs {U} (s : set U) :
  (s :&: set0) <--> set0.
Proof.
  firstorder.
Qed.

Lemma setU_set0_neut {U} (s : set U) :
  (s :|: set0) <--> s.
Proof.
  firstorder.
Qed.

Lemma setU_set0_neut_eq {A} (s s1 : set A) :
  s1 <--> set0 ->
  s <--> s :|: s1.
Proof.
  firstorder.
Qed.

Lemma setU_set0_l {A} (s1 s2 s3 : set A) :
  s1 <--> set0 ->
  s2 <--> s3 ->
  (s1 :|: s2) <--> s3.
Proof.
  firstorder.
Qed.

Lemma setU_set0_r {A} (s1 s2 s3 : set A) :
  s1 <--> set0 ->
  s3 <--> s2 ->
  s3 <--> (s1 :|: s2).
Proof.
  firstorder.
Qed.

Lemma setI_setT_neut {U} (s : set U) :
  (s :&: setT) <--> s.
Proof.
  firstorder.
Qed.

Lemma setU_setT_abs {U} (s : set U) :
  (s :|: setT) <--> setT.
Proof.
  firstorder.
Qed.

Lemma setU_set_eq_compat {T} (s1 s2 s1' s2' : set T) :
  s1 <--> s1' ->
  s2 <--> s2' ->
  s1 :|: s2 <--> s1' :|: s2'.
Proof.
  by firstorder.
Qed.

Lemma setU_set_subset_compat :
  forall (T : Type) (s1 s2 s1' s2' : set T),
    s1 \subset s1' -> s2 \subset s2' -> s1 :|: s2 \subset s1' :|: s2'.
Proof.
  now firstorder.
Qed.

Lemma setU_set_incl_r :
  forall (T : Type) (s1 s2 s2' : set T),
    s1 \subset s2' -> s1 \subset s2 :|: s2'.
Proof.
  now firstorder.
Qed.

Lemma setU_assoc {U} (s1 s2 s3 : set U) :
  (s1 :|: (s2 :|: s3)) <--> ((s1 :|: s2) :|: s3).
Proof.
  firstorder.
Qed.

Lemma setI_assoc {U} (s1 s2 s3 : set U) :
  (s1 :&: (s2 :&: s3)) <--> ((s1 :&: s2) :&: s3).
Proof.
  firstorder.
Qed.

Lemma setI_impl_l {T} (s1 s2 : set T) : s1 \subset s2 -> s1 :&: s2 <--> s1.
Proof.
  firstorder.
Qed.

Lemma setI_impl_r {T} (s1 s2 : set T) : s2 \subset s1 -> s1 :&: s2 <--> s2.
Proof.
  firstorder.
Qed.

Lemma setI_set0 {U} (s1 s2 : set U) :
  (forall x, s1 x -> ~ s2 x) ->
  (s1 :&: s2) <--> set0.
Proof.
  intros; split; firstorder.
Qed.

Lemma setI_subset_compat {U} (s1 s2 s1' s2' : set U) :
  s1 \subset s1' ->
  s2 \subset s2' ->
  (s1 :&: s2) \subset (s1' :&: s2').
Proof.
  firstorder.
Qed.

Lemma setU_subset_r {U} (s1 s2 s3 : set U) :
  s1 \subset s3 ->
  s1 \subset (s2 :|: s3).
Proof.
  firstorder.
Qed.

Lemma setU_subset_l {U} (s1 s2 s3 : set U) :
  s1 \subset s2 ->
  s1 \subset (s2 :|: s3).
Proof.
  firstorder.
Qed.

Lemma setI_setU_distr {U} (s1 s2 s3 : set U) :
  ((s1 :|: s2) :&: s3) <--> ((s1 :&: s3) :|: (s2 :&: s3)).
Proof.
  firstorder.
Qed.

(** Lemmas about [bigcap] *)

Lemma bigcap_set0 (T U : Type) (F : T -> set U) :
  \bigcap_(x in set0) F x <--> setT.
Proof.
  split.
  - move => _. constructor.
  - move => _ x H. inversion H.
Qed.

Lemma incl_bigcapl T U A B (F : T -> set U) : B \subset A ->
  \bigcap_(x in A) F x \subset \bigcap_(x in B) F x.
Proof.
  by move => Hsub t Hcap x HB; eauto.
Qed.

Lemma eq_bigcapr (T U : Type) (A : set T) (F G : T -> set U) :
  (forall x : T, F x <--> G x) ->
  \bigcap_(x in A) F x <--> \bigcap_(x in A) G x.
Proof.
  by move => H a; split; move => Ha b Hb; eapply H; eauto.
Qed.

Lemma eq_bigcapl T U A B (F : T -> set U) : A <--> B ->
  \bigcap_(x in A) F x <--> \bigcap_(x in B) F x.
Proof.
  by move => H a; split; move => Ha b Hb; eapply Ha; eapply H; eauto.
Qed.

#[global]
Instance eq_bigcap T U : Proper (set_eq ==> pointwise_relation T (@set_eq U) ==> set_eq) bigcap.
Proof.
  move=> A B eqAB F G eqFG a. apply: (@set_eq_trans _ (\bigcap_(i in A) G i)).
  exact: eq_bigcapr.
  exact: eq_bigcapl.
Qed.

Lemma eq_bigcup' :
  forall (T U : Type) (A B : set T) (F G : T -> set U),
    A <--> B ->
    (forall x, F x <--> G x) ->
    \bigcup_(x in A) F x <--> \bigcup_(x in B) G x.
Proof.
  intros.
  eapply eq_bigcup; eauto.
Qed.

Lemma incl_bigcup_compat :
  forall (T U : Type) (A B : set T) (F G : T -> set U),
    A \subset B ->
    (forall x : T, F x \subset G x) ->
    \bigcup_(x in A) F x \subset \bigcup_(x in B) G x.
Proof.
  now firstorder.
Qed.

Lemma bigcap_setI_l {U T} (s1 s2 : set U) (f : U -> set T) :
  bigcap (s1 :|: s2) f <-->
  bigcap s1 f :&: bigcap s2 f.
Proof.
  firstorder.
Qed.

Lemma bigcap_setU_l {U T} (s1 s2 : set U) (f : U -> set T) :
  bigcap s1 f \subset bigcap (s1 :&: s2) f.
Proof.
  firstorder.
Qed.

Lemma bigcap_set1 {U T} (x : U) (f : U -> set T) :
  bigcap [set x] f <--> f x.
Proof.
  split; move => H.
  eapply H. reflexivity.
  intros y Hy. inversion Hy. subst.
  assumption.
Qed.

Lemma bigcup_set0_r (T U : Type) (s : set T) (F : T -> set U) :
  (forall x, F x <--> set0) ->
  \bigcup_(x in s) F x <--> set0.
Proof.
  firstorder.
Qed.

Lemma bigcup_set0_l_eq (T U : Type) (s : set T) (F : T -> set U) :
  s <--> set0 ->
  \bigcup_(x in s) F x <--> set0.
Proof.
  firstorder.
Qed.

(** Lemmas about lists *)
Lemma nil_set_eq {A : Type} :
  [::] <--> (@set0 A).
Proof.
  split; move => H; eauto.
Qed.

Lemma cons_set_eq {A} (x : A) l :
  (x :: l) <--> [set x] :|: l.
Proof. by []. Qed.

Lemma singl_set_eq: forall (A : Type) (x : A), [ x ] <--> [ set x ].
Proof.
  intros A x x'; split; intros H.
  - inv H. reflexivity. now inv H0.
  - inv H. now constructor.
Qed.

Lemma incl_subset {A : Type} (l1 l2 : seq A) :
  incl l1 l2 -> l1 \subset l2.
Proof.
  intros Hi x; eapply Hi.
Qed.

Lemma incl_hd_same {A : Type} (a : A) (l1 l2 : seq A) :
  incl l1 l2 -> incl (a :: l1) (a :: l2).
Proof.
  intros Hin. firstorder.
Qed.

Lemma setI_bigcup_assoc {A B} (s1 : set B) (s2 : set A) (s3 : A -> set B) :
  s1 :&: (\bigcup_(x in s2) s3 x) <--> \bigcup_(x in s2) (s1 :&: (s3 x)).
Proof.
  firstorder.
Qed.

Lemma cons_subset {A : Type} (x : A) (l : seq A) (P : set A) :
  P x ->
  l \subset P ->
  (x :: l) \subset P.
Proof.
  intros Px Pl x' Hin. inv Hin; firstorder.
Qed.

Lemma nil_subset {A : Type} (P : set A) :
  [] \subset P.
Proof.
  intros x H; inv H.
Qed.

Lemma imset_union_incl {U T : Type} (s1 s2 : set U) (f : U -> T) :
  f @: (s1 :|: s2) \subset (f @: s1) :|: (f @: s2).
Proof.
  firstorder.
Qed.

Lemma imset_singl_incl {U T : Type} (x : U) (f : U -> T) :
  f @: [set x] \subset [set (f x)].
Proof.
  intros y Hin. destruct Hin as [y' [Hin1 Hin2]].
  inv Hin1. inv Hin2. reflexivity.
Qed.

Lemma imset_set0_incl  {U T : Type} (f : U -> T) :
  f @: set0 \subset set0.
Proof.
  firstorder.
Qed.

Lemma set_eq_set_incl_r {U : Type} (s1 s2 : set U) :
  s1 <--> s2 -> s2 \subset s1.
Proof.
  firstorder.
Qed.

Lemma set_eq_set_incl_l {U : Type} (s1 s2 : set U) :
  s1 <--> s2 -> s1 \subset s2.
Proof.
  firstorder.
Qed.

Lemma rewrite_set_l {U : Type} (s1 s2 : set U) x :
  s1 x ->
  s1 <--> s2 ->
  s2 x.
Proof.
  firstorder.
Qed.

Lemma rewrite_set_r {U : Type} (s1 s2 : set U) x :
  s2 x ->
  s1 <--> s2 ->
  s1 x.
Proof.
  firstorder.
Qed.

Lemma imset_bigcup_incl_l :
  forall {T U V : Type} (f : U -> V) (A : set T) (F : T -> set U),
  f @: (\bigcup_(x in A) F x) \subset \bigcup_(x in A) f @: F x.
Proof.
  firstorder.
Qed.

Lemma in_imset {U T} (f : U -> T) (S : set U) (x : T) :
  (f @: S) x -> exists y, x = f y.
Proof.
  move => [y [H1 H2]]; eauto.
Qed.

Lemma union_lift_subset_compat {A} (s1 s2 : set (option A)) (s3 s4 : set A) :
  s1 \subset lift s3 ->
  s2 \subset lift s4 ->
  (s1 :|: s2) \subset lift (s3 :|: s4).
Proof.
  firstorder.
Qed.

Lemma lift_subset_pres_l {A} (s1 : set (option A)) (s2 s3 : set A) :
  s1 \subset lift s2 ->
  s1 \subset lift (s2 :|: s3).
Proof.
  firstorder.
Qed.

Lemma lift_subset_pres_r {A} (s1 : set (option A)) (s2 s3 : set A) :
  s1 \subset lift s3 ->
  s1 \subset lift (s2 :|: s3).
Proof.
  firstorder.
Qed.

Lemma set_incl_setI_l {A} (s1 s2 s3 : set A) :
  s1 \subset s3 ->
  (s1 :&: s2) \subset s3.
Proof.
  firstorder.
Qed.

Lemma set_incl_setI_r {A} (s1 s2 s3 : set A) :
  s2 \subset s3 ->
  (s1 :&: s2) \subset s3.
Proof.
  firstorder.
Qed.

Lemma set_incl_setU_l {A} (s1 s2 s3 : set A) :
  s1 \subset s3 ->
  s2 \subset s3 ->
  (s1 :|: s2) \subset s3.
Proof.
  firstorder.
Qed.

Lemma bigcup_set_I_l {A B} (s1 s2 : set A) (s3 : set B) (f : A -> set B) :
  \bigcup_(x in s1) (f x) \subset s3 ->
  \bigcup_(x in (s1 :&: s2)) (f x) \subset s3.
Proof.
  firstorder.
Qed.

Lemma bigcup_set_U {A B} (s1 s2 : set A) (s3 : set B) (f : A -> set B) :
  \bigcup_(x in s1) (f x) \subset s3 ->
  \bigcup_(x in s2) (f x) \subset s3 ->
  \bigcup_(x in (s1 :|: s2)) (f x) \subset s3.
Proof.
  firstorder.
Qed.

Lemma bigcup_set0_subset {A B} (s : set B) (f : A -> set B) :
  \bigcup_(x in set0) (f x) \subset s.
Proof.
  firstorder.
Qed.

Lemma bigcup_cons_subset {A B} l (ls : seq A) (f : A -> set B) s :
  f l \subset s ->
  \bigcup_(x in ls) (f x) \subset s ->
  \bigcup_(x in l :: ls) (f x) \subset s.
Proof.
  intros H1 H2 x [y [Hl Hr]].
  inv Hl.
  - eauto.
  - eapply H2. eexists; split; eauto.
Qed.

Lemma bigcup_nil_subset {A B} (f : A -> set B) s :
  \bigcup_(x in []) (f x) \subset s.
Proof.
  intros x [y [H1 H2]]. inv H1.
Qed.

Lemma option_subset {A} (s1 : set (option A)) :
  s1 \subset (isSome :&: s1) :|: [set None].
Proof.
  intros [x |]; firstorder.
Qed.

Lemma setU_l_subset {U} (s1 s2 s3 : set U) :
  s1 \subset s3 ->
  s2 \subset s3 ->
  (s1 :|: s2) \subset s3.
Proof.
  firstorder.
Qed.

Lemma bigcup_lift_lift_bigcup {T U} (s1 : set T) (f : T -> set U) :
  \bigcup_(x in s1) (lift (f x)) \subset lift (\bigcup_(x in s1) (f x)).
Proof.
  intros x [y [H1 [[z [H2 H3]] | H2]]].
  + inv H3. left; eexists; split; eauto.
    eexists; split; eauto.
  + inv H2; now right.
Qed.

Lemma lift_subset_compat {U} (s1 s2 : set U) :
  s1 \subset s2 ->
  lift s1 \subset lift s2.
Proof.
  firstorder.
Qed.

Lemma lift_set_eq_compat {U} (s1 s2 : set U) :
  s1 <--> s2 ->
  lift s1 <--> lift s2.
Proof.
  firstorder.
Qed.

Lemma bigcup_setU_r:
  forall (U T : Type) (s : set U) (f g : U -> set T),
    \bigcup_(i in s) (f i :|: g i) <-->
    \bigcup_(i in s) f i :|: \bigcup_(i in s) g i.
Proof.
  firstorder.
Qed.

Lemma lift_bigcup_comm :
  forall (U T : Type) (s : set U) (f : U -> set T),
    inhabited U ->
    lift (\bigcup_(i in [set : U]) (f i)) <-->
    \bigcup_(i in [set : U]) (lift (f i)).
Proof.
  intros U T s f Hin. unfold lift.
  rewrite !bigcup_setU_r -!imset_bigcup.
  rewrite bigcup_const; eauto.
  reflexivity.
Qed.

Lemma bigcap_setU_distr:
  forall (U T : Type) (s1 s2 : set U) (f : U -> set T),
    \bigcap_(i in s1) f i :&: \bigcap_(i in s2) f i <--> \bigcap_(i in s1 :|: s2) f i.
Proof.
  intros. split.
  - intros [ H1 H2 ] x [ H3 | H3 ]; eauto.
  - intros H. split; intros x H3; eapply H.
    now left. now right.
Qed.

Lemma setI_set_incl :
  forall (A : Type) (s1 s2 s3 : set A),
    s1 \subset s2 ->
    s1 \subset s3 ->
    s1 \subset s2 :&: s3.
Proof.
  firstorder.
Qed.

Lemma imset_isSome {A} (s : set A) :
  Some @: s \subset isSome.
Proof.
  intros y [x [Sx H]]. inv H. eauto.
Qed.

Lemma bigcup_cons_subset_r :
  forall (A B : Type) (l : A) (ls : seq A) (f : A -> set B) (s1 s2 : set B),
    s1 \subset f l ->
    s2 \subset \bigcup_(x in ls) f x ->
    s1 :|: s2 \subset \bigcup_(x in (l :: ls)) f x.
Proof.
  intros A B l ls f s1 s2 H1 H2.
  apply setU_l_subset.
  - rewrite bigcup_setU_l bigcup_set1.
    eapply setU_subset_l. eassumption.
  - rewrite bigcup_setU_l bigcup_set1.
    eapply setU_subset_r. eassumption.
Qed.

Lemma bigcup_setI_cons_subset_r :
  forall (A B : Type) (l : A) (ls : seq A) (f : A -> set B) (s1 s2 : set B) (s3 : set A),
    s3 l ->
    s1 \subset f l ->
    s2 \subset \bigcup_(x in ls :&: s3) f x ->
    s1 :|: s2 \subset \bigcup_(x in (l :: ls) :&: s3) f x.
Proof.
  intros A B l ls f s1 s2 s3 H1 H2 H3.
  apply setU_l_subset.
  - intros x Hs1. eexists l; split; eauto.
    split; eauto. left; eauto.
  - intros x Hs1. eapply H3 in Hs1.
    edestruct Hs1 as [x' [[Hs3 Hls] Hin]].
    eexists x'; split; eauto. split; eauto.
    right; eauto.
Qed.

Lemma imset_union_set_eq:
  forall (U T : Type) (s1 s2 : set U) (f : U -> T),
    f @: (s1 :|: s2) <--> f @: s1 :|: f @: s2.
Proof.
  intros U T s1 s2 f.
  firstorder.
Qed.

Lemma imset_bigcup_setI_cons_subset_r :
  forall (A B : Type) (l : A) (ls : seq A) (f : A -> set (option B))
    (s1 s2 : set B) (s3 : set A),
    s3 l ->
    Some @: s1 \subset f l ->
    Some @: s2 \subset \bigcup_(x in ls :&: s3) f x ->
    Some @: (s1 :|: s2) \subset \bigcup_(x in (l :: ls) :&: s3) f x.
Proof.
  intros A B l ls f s1 s2 s3 H1 H2 H3.
  rewrite imset_union_set_eq. apply setU_l_subset.
  - intros x Hs1. eexists l; split; eauto.
    split; eauto. left; eauto.
  - intros x Hs1. eapply H3 in Hs1.
    edestruct Hs1 as [x' [[Hs3 Hls] Hin]].
    eexists x'; split; eauto. split; eauto.
    right; eauto.
Qed.

Lemma imset_set0_subset {A B} (f : A -> B) (s : set B) :
  (f @: set0) \subset s.
Proof.
  firstorder.
Qed.

Lemma setI_set_eq_r {A : Type} (s1 s2 s2' : set A) :
  s2 <--> s2' ->
  (s1 :&: s2) <--> (s1 :&: s2').
Proof.
  intros. rewrite H; reflexivity.
Qed.

Lemma isSome_subset {A : Type} (s1 s2 s1' s2' : set (option A)) :
  isSome :&: s1 \subset isSome :&: s2 ->
  isSome :&: (s1 :|: ([set None] :&: s1')) \subset isSome :&: (s2 :|: ([set None] :&: s2')).
Proof.
  intros Hyp x [H1 H2]. destruct x as [ x | ]; try discriminate.
  split; eauto.
  inv H2. left; eauto.
  eapply Hyp. now split; eauto.
  inv H. now inv H0.
Qed.

Lemma bigcup_nil_setI {A B} (f : A -> set B)
      (l : seq A) s :
  \bigcup_(x in [] :&: s) (f x) \subset
  \bigcup_(x in (l :&: s)) (f x).
Proof.
  intros z [y [[Hin1 _] Hin2]]. inv Hin1.
Qed.

Lemma isSome_set_eq {A} (s : set (option A)) (s' : set A) :
  s \subset (Some @: s') :|: [set None] ->
  Some @: s' \subset s ->
  isSome :&: s <--> Some @: s'.
Proof.
  intros H1 H2 x; split.
  - intros [H3 H4]. destruct x; try discriminate.
    eapply H1 in H4. inv H4; try discriminate.
    eassumption.
  - intros [y [H3 H4]].
    inv H4. split. now eauto.
    eapply H2.
    eexists; split; eauto.
Qed.

Lemma set_eq_isSome_sound {A} (s : set (option A)) (s' : set A) :
  isSome :&: s <--> Some @: s' ->
  s \subset (Some @: s') :|: [set None].
Proof.
  intros H [x| ] Hin.
  - left. eapply H.
    eexists; eauto.
  - right; reflexivity.
Qed.

Lemma set_eq_isSome_complete {A} (s : set (option A)) (s' : set A) :
  isSome :&: s <--> Some @: s' ->
  Some @: s' \subset s.
Proof.
  intros H. rewrite <- H. firstorder.
Qed.

Definition somes {A} (s : set (option A)) : set A :=
  [set x | Some x \in s].

Lemma somes_subset {A} (s1 s2 : set (option A)) :
  s1 \subset s2 ->
  somes s1 \subset somes s2.
Proof.
  intros Hs a.
  apply Hs.
Qed.

Lemma bigcup_somes {A B} (sA : set A) (s : A -> set (option B)) :
  somes (\bigcup_(a in sA) s a) <--> \bigcup_(a in sA) somes (s a).
Proof.
  intro b; split; intros [a Ha]; eexists a; auto.
Qed.

#[global]
Instance proper_somes A : Morphisms.Proper (set_eq ==> set_eq) (@somes A).
Proof. firstorder. Qed.

Lemma bigcup_setI {T U} (s1 : set T) (s2 : set U) F :
  \bigcup_(x in s1) (s2 :&: F x) <--> s2 :&: \bigcup_(x in s1) (F x).
Proof. firstorder. Qed.

Lemma incl_bigcup_compat_list (T U : Type) (h1 h2 : T) (t1 t2 : list T) (F G : T -> set U) :
    F h1 \subset G h2 ->
    \bigcup_(x in t1) F x \subset \bigcup_(x in t2) G x ->
    \bigcup_(x in h1 :: t1) F x \subset \bigcup_(x in h2 :: t2) G x.
Proof.
  intros Hs1 Hs2.
  intros x Hin. inv Hin. inv H. inv H0.
  - eexists. split. now left. eauto.
  - edestruct Hs2.
    eexists. split; eauto.
    destruct H3. eexists. split. now right; eauto.
    eassumption.
Qed.

Lemma incl_bigcup_list_tl (T U : Type) (h : T) (t : list T) (G : T -> set U) s :
    s \subset \bigcup_(x in t) G x ->
    s \subset \bigcup_(x in h :: t) G x.
Proof.
  intros Hyp x Hin. eapply Hyp in Hin.
  inv Hin. inv H.
  eexists. split. now right; eauto. eauto.
Qed.

Lemma incl_bigcup_list_hd (T U : Type) (h : T) (t : list T) (G : T -> set U) s :
    s \subset G h ->
    s \subset \bigcup_(x in h :: t) G x.
Proof.
  intros Hyp x Hin. eapply Hyp in Hin.
  eexists. split. now left. eauto.
Qed.

Lemma incl_bigcup_list_nil (T U : Type) (G : T -> set U) s :
    \bigcup_(x in [::]) G x \subset s.
Proof.
  intros x Hin. inv Hin. inv H. inv H0.
Qed.

Lemma in_bigcup_list_hd (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) :
  G h z -> (\bigcup_(x in (h :: t)) G x) z.
Proof.
  intros Hin.
  eapply incl_bigcup_list_hd. now eapply subset_refl.
  eassumption.
Qed.

Lemma in_bigcup_list_tl (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) :
  (\bigcup_(x in t) G x) z -> (\bigcup_(x in (h :: t)) G x) z.
Proof.
  intros Hin.
  eapply incl_bigcup_list_tl. now eapply subset_refl.
  eassumption.
Qed.

Lemma in_bigcup_list_cons (T U : Type) (h : T) (t : seq T) (G : T -> set U) (z : U) :
  (\bigcup_(x in (h :: t)) G x) z ->
  G h z \/ (\bigcup_(x in t) G x) z.
Proof.
  intros Hin. inv Hin. inv H. inv H0; eauto.
  right. eexists; split; eauto.
Qed.

Lemma bigcup_nil_set0 (T U : Type) (F : T -> set U) :
  \bigcup_(x in [::]) F x <--> set0.
Proof.
  split; intros Hin; inv Hin; eauto.
  inv H. inv H0.
Qed.

Lemma incl_bigcup_compat_list_inter (T U : Type) (h1 h2 : T)
         (t1 t2 : seq T) (F G : T -> set U) S :
  S :&: F h1 \subset S :&: G h2 ->
  S :&: \bigcup_(x in t1) F x \subset S :&: \bigcup_(x in t2) G x ->
  S :&: \bigcup_(x in (h1 :: t1)) F x \subset
  S :&: \bigcup_(x in (h2 :: t2)) G x.
Proof.
  intros Hs1 Hs2.
  intros x Hin. inv Hin. constructor; eauto.
  inv H0. inv H1. inv H2.
  - eexists. split. now left. eapply Hs1. split; eauto.
  - edestruct Hs2. split. eassumption.
    eexists. split; eauto.
    destruct H6. destruct H6.
    eexists. split. right; eauto. eassumption.
Qed.

Lemma incl_bigcup_list_tl_inter {T U : Type} (h : T) (t : list T) (G : T -> set U) s S :
    s \subset S :&: (\bigcup_(x in t) G x) ->
    s \subset S :&: (\bigcup_(x in h :: t) G x).
Proof.
  intros Hyp x Hin. eapply Hyp in Hin.
  inv Hin. inv H0. inv H1.
  split. eassumption.
  eexists. split. now right; eauto. eauto.
Qed.

Lemma incl_bigcup_compat_list_eq (T U : Type) (h1 h2 : T) (t1 t2 : list T) (F G : T -> set U) :
    F h1 <--> G h2 ->
    \bigcup_(x in t1) F x <--> \bigcup_(x in t2) G x ->
    \bigcup_(x in h1 :: t1) F x <--> \bigcup_(x in h2 :: t2) G x.
Proof.
  intros Hs1 Hs2. split; eapply incl_bigcup_compat_list.
  - rewrite Hs1. eapply subset_refl.
  - rewrite Hs2. eapply subset_refl.
  - rewrite Hs1. eapply subset_refl.
  - rewrite Hs2. eapply subset_refl.
Qed.


Require Export GeoCoq.Axioms.continuity_axioms.
Require Export GeoCoq.Tarski_dev.Ch07_midpoint.
Require Import Arith.

Section Dedekind_cantor.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma nested__diff0 : forall A B,
  Nested A B -> forall n An Bn, A n An -> B n Bn -> An <> Bn.
Proof.
  intros A B [Hex HAB].
  destruct n.
    intros A0 B0 HA0 HB0.
    destruct (Hex 1) as [A1 [B1 []]].
    destruct (HAB O A0 A1 B1 B0) as [HBet1 [HBet2 Hdiff]]; trivial.
    assert (Bet A0 A1 B0) by eBetween.
    assert_diffs; auto.
  intros Am Bm HAm HBm.
  destruct (Hex n) as [An [Bn []]].
  destruct (HAB n An Am Bm Bn) as [HBet1 [HBet2 Hdiff]]; trivial.
Qed.

Lemma nested_sym : forall A B, Nested A B -> Nested B A.
Proof.
  intros A B [Hex HAB].
  split; intro n.
    destruct (Hex n) as [An [Bn []]]; exists Bn, An; split; assumption.
  intros Bn Bm Am An HBn HBm HAm HAn.
  destruct (HAB n An Am Bm Bn HAn HAm HBm HBn) as [HBet1 [HBet2 Hd]].
  repeat split; Between.
Qed.

Lemma nested__ex_left : forall A B n, Nested A B -> exists An, A n An.
Proof.
  intros A B n [Hex _].
  destruct (Hex n) as [An [_ [HAn _]]].
  exists An.
  apply HAn.
Qed.

Lemma nested__ex_right : forall A B n, Nested A B -> exists Bn, B n Bn.
Proof.
  intros A B n HAB; apply nested__ex_left with A; apply nested_sym, HAB.
Qed.

Lemma nested_aux1 : forall A B n m An Am Bm,
   Nested A B -> n < m -> A n An -> A m Am -> B m Bm -> Bet An Am Bm.
Proof.
  intros A B n m An Am Bm [Hex HAB] Hcomp.
  destruct (Hex n) as [_ [Bn [_ HBn]]].
  revert Am Bm.
  induction Hcomp.
    intros Am Bm HAn HAm HBm.
    destruct (HAB n An Am Bm Bn); auto.
  intros Am' Bm' HAn HAm' HBm'.
  destruct (Hex m) as [Am [Bm []]].
  assert (HBet : Bet An Am Bm) by (apply IHHcomp; trivial).
  destruct (HAB m Am Am' Bm' Bm) as [HBet1 [HBet2 Hd]]; trivial.
  assert (Bet An Am Bm') by eBetween.
  clear HBet HBet2; eBetween.
Qed.

Lemma nested_aux2 : forall A B n m An Am Bn,
  Nested A B -> n < m -> A n An -> A m Am -> B n Bn -> Bet An Am Bn.
Proof.
  intros A B n m An Am Bn HAB Hcomp HAn HAm HBn.
  destruct (nested__ex_right A B m HAB) as [Bm].
  apply outer_transitivity_between with Bm.
    apply (nested_aux1 A B n m); assumption.
    apply between_symmetry, (nested_aux1 B A n m); auto using nested_sym.
    eapply nested__diff0; eassumption.
Qed.

Lemma nested__bet : forall A B n n1 m An An1 Bm,
  Nested A B -> n < n1 -> A n An -> A n1 An1 -> B m Bm -> Bet An An1 Bm.
Proof.
  intros A B n n1 m An An1 Bm HAB Hlt HAn HAn1 HBm.
  assert (HBA := nested_sym A B HAB).
  destruct (Nat.eq_dec n1 m).
    subst n1; apply (nested_aux1 A B n m); assumption.
  destruct (nested__ex_right A B n1 HAB) as [Bn1].
  assert (Bet An An1 Bn1) by (apply (nested_aux1 A B n n1); assumption).
  destruct (nat_total_order n1 m) as [Hlt1|Hlt1]; auto.
  - apply between_inner_transitivity with Bn1; trivial.
    apply between_symmetry, (nested_aux2 B A n1 m); assumption.
  - apply outer_transitivity_between with Bn1; trivial.
      apply between_symmetry, (nested_aux1 B A m n1); assumption.
      apply (nested__diff0 A B HAB n1); assumption.
Qed.

Lemma nested__diff : forall A B n m An Bm, Nested A B -> A n An -> B m Bm -> An <> Bm.
Proof.
  intros A B n m An Bm HAB HAn HBm.
  destruct (Nat.lt_trichotomy n m) as [Hlt|[Heq|Hlt]].
  - destruct (nested__ex_left A B m HAB) as [Am].
    apply bet_neq23__neq with Am.
      apply (nested__bet A B n m m); eassumption.
      eapply nested__diff0; eassumption.
  - subst; eapply nested__diff0; eassumption.
  - destruct (nested__ex_right A B n HAB) as [Bn].
    apply nested_sym in HAB.
    apply not_eq_sym, bet_neq23__neq with Bn.
      apply (nested__bet B A m n n); assumption.
      eapply nested__diff0; eassumption.
Qed.

Lemma dedekind__cantor : dedekind_s_axiom -> cantor_s_axiom.
Proof.
  intros dedekind A B HAB.
  assert (HX : exists X, forall An Bm, (exists n, 0 < n /\ A n An) -> (exists m, B m Bm) -> Bet An X Bm).
  - apply dedekind.
    destruct (nested__ex_left A B 0 HAB) as [A0].
    exists A0.
    intros An Bm [n [Hn HAn]] [m HBm].
    apply (nested__bet A B 0 n m); assumption.
  - destruct HX as [X HX].
    exists X.
    intros n An Bn HAn HBn.
    destruct (Nat.eq_0_gt_0_cases n); [|apply HX; exists n; auto].
    subst.
    destruct (nested__ex_left A B 1 HAB) as [A1].
    apply between_exchange2 with A1.
      apply (nested_aux2 A B 0 1); auto.
      apply HX; [exists 1; split| exists 0]; auto.
Qed.

End Dedekind_cantor.