(** *** The Baire Category Theorem for complete metric spaces  by  Ken'ichi Kuga ****)
(** ***************************************************************

Theorem BaireCategoryTheorem :  complete d d_metric -> baire_space.

******************************************************************)

Require Import ssreflect ssrbool.
Require Export MetricSpaces.
Require Export Completeness.
Require Import ClassicalChoice.
Require Export ChoiceFacts.
Require Import EnsemblesSpec.
Require Import RationalsInReals.
Require Import Reals.
Require Import Fourier.

Open Scope R_scope.

Section BaireSpaces.

Variable X : TopologicalSpace.

(* We use the the following form of the Axiom of Choice *)
Print FunctionalDependentChoice_on.
Axiom FDC : FunctionalDependentChoice_on (point_set X * { r:R | r > 0} * nat).
Print FunctionalDependentChoice_on.

(* Definition of Baire Spaces *)
Definition baire_space : Prop :=
  forall V : IndexedFamily nat (point_set X),
    (forall n: nat, (open (V n)) /\ (dense (V n))) ->
       dense (IndexedIntersection V).

(* Introducing metric metrizing X *)
Variable d : (point_set X) -> (point_set X) -> R.
Hypothesis d_metric : metric d.
Hypothesis d_metrizes : metrizes X d.

(* Some definitions and lemmas  *)

Lemma ln_mult_pow : forall a:R, a > 0 ->
  forall k:nat, (INR k)*(ln a) = ln (a^k).
Proof.
move=>a a_pos.
induction k.
simpl.
rewrite Rmult_0_l.
rewrite ln_1.
reflexivity.
have H: S k = (k + 1)%nat by auto with *.
rewrite H; clear H.
have H1: INR (k + 1)%nat = (INR k ) + 1 by apply plus_INR.
rewrite H1; clear H1.
have H2: (INR k + 1) * ln a = (INR k) * ln a + 1 * ln a.
apply Rmult_plus_distr_r.
rewrite H2.
have H3: a^(k+1) = a^k * a^1 by auto with real.
rewrite H3.
clear H2 H3.
have H4: ln (a^k * a^1) = ln (a^k) + ln (a^1).
apply ln_mult.
move: a_pos; by auto with real.
move: a_pos; by auto with real.
rewrite H4; clear H4.
rewrite IHk.
have H5: 1 * ln a = ln a by auto with real.
rewrite H5; clear H5.
have H6: a^1 =a by auto with real.
rewrite H6; clear H6.
reflexivity.
Qed.

Lemma Rm2p: forall r1 r2 : R, r1 - r2 = r1 + -r2.
Proof. move=> r1 r2; auto. Qed.

Lemma Req_move_pr2ml: forall r1 r2 r : R, r1 = r2 + r -> r1 - r = r2.
Proof.
move=> r1 r2 r lhs. rewrite Rm2p.
have H: r1 + -r = r2 + r + -r.
move: lhs. auto with real.
rewrite H.
rewrite Rplus_assoc.
rewrite Rplus_opp_r.
rewrite Rplus_0_r.
reflexivity.
Qed.

Lemma Req_move_pl2mr: forall r1 r2 r : R, r1 + r = r2 -> r1 = r2 - r.
Proof.
move=> r1 r2 r lhs.
apply eq_sym.
apply Req_move_pr2ml.
by apply eq_sym.
Qed.

Lemma Req_move_mr2pl: forall r1 r2 r : R, r1 = r2 - r -> r1 + r = r2.
Proof.
move=> r1 r2 r lhs.
rewrite Rm2p in lhs.
have H: r1 + r = r2 + -r + r.
move: lhs.
auto with real.
rewrite Rplus_assoc in H.
have H0: -r + r = 0 by auto with real.
rewrite H0 in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Req_move_ml2pr: forall r1 r2 r : R, r1 - r = r2 -> r1 = r2 + r.
Proof.
move=> r1 r2 r lhs.
apply eq_sym.
apply Req_move_mr2pl.
by apply eq_sym.
Qed.

Lemma Rle_move_pr2ml: forall r1 r2 r : R, r1 <= r2 + r -> r1 - r <= r2.
Proof.
move=> r1 r2 r lhs. rewrite Rm2p.
have H: r1 + -r <= r2 + r + -r.
move: lhs. auto with real.
rewrite Rplus_assoc in H.
rewrite Rplus_opp_r in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rle_move_pl2mr: forall r1 r2 r : R, r1 + r <= r2 -> r1 <= r2 - r.
Proof.
move=> r1 r2 r lhs. rewrite Rm2p.
have H: r1 + r + - r <= r2 + - r.
move: lhs. auto with real.
rewrite Rplus_assoc in H.
rewrite Rplus_opp_r in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rle_move_mr2pl: forall r1 r2 r : R, r1 <= r2 - r -> r1 + r <= r2.
Proof.
move=> r1 r2 r lhs.
rewrite Rm2p in lhs.
have H: r1 + r <= r2 + -r + r.
move: lhs.
auto with real.
rewrite Rplus_assoc in H.
have H0: -r + r = 0 by auto with real.
rewrite H0 in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rle_move_ml2pr: forall r1 r2 r : R, r1 - r <= r2 -> r1 <= r2 + r.
Proof.
move=> r1 r2 r lhs. rewrite Rm2p in lhs.
have H: r1 + - r +r <= r2 +  r.
move: lhs. auto with real.
rewrite Rplus_assoc in H.
rewrite Rplus_opp_l in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rlt_move_pr2ml: forall r1 r2 r : R, r1 < r2 + r -> r1 - r < r2.
Proof.
move=> r1 r2 r lhs. rewrite Rm2p.
have H: r1 + -r < r2 + r + -r.
move: lhs. auto with real.
rewrite Rplus_assoc in H.
rewrite Rplus_opp_r in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rlt_move_pl2mr: forall r1 r2 r : R, r1 + r < r2 -> r1 < r2 - r.
Proof.
move=> r1 r2 r lhs. rewrite Rm2p.
have H: r1 + r + - r < r2 + - r.
move: lhs. auto with real.
rewrite Rplus_assoc in H.
rewrite Rplus_opp_r in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rlt_move_mr2pl: forall r1 r2 r : R, r1 < r2 - r -> r1 + r < r2.
Proof.
move=> r1 r2 r lhs.
rewrite Rm2p in lhs.
have H: r1 + r < r2 + -r + r.
move: lhs.
auto with real.
rewrite Rplus_assoc in H.
have H0: -r + r = 0 by auto with real.
rewrite H0 in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rlt_move_ml2pr: forall r1 r2 r : R, r1 - r < r2 -> r1 < r2 + r.
Proof.
move=> r1 r2 r lhs. rewrite Rm2p in lhs.
have H: r1 + - r +r < r2 +  r.
move: lhs. auto with real.
rewrite Rplus_assoc in H.
rewrite Rplus_opp_l in H.
rewrite Rplus_0_r in H.
exact.
Qed.

Lemma Rge_move_pr2ml: forall r1 r2 r : R, r1 >= r2 + r -> r1 - r >= r2.
Proof.
move=> r1 r2 r lhs.
apply Rle_ge.
apply Rge_le in lhs.
by apply Rle_move_pl2mr.
Qed.

Lemma Rge_move_pl2mr: forall r1 r2 r : R, r1 + r >= r2 -> r1 >= r2 - r.
Proof.
move=> r1 r2 r lhs.
apply Rle_ge.
apply Rge_le in lhs.
by apply Rle_move_pr2ml.
Qed.

Lemma Rge_move_mr2pl: forall r1 r2 r : R, r1 >= r2 - r -> r1 + r >= r2.
Proof.
move=> r1 r2 r lhs.
apply Rle_ge.
apply Rge_le in lhs.
by apply Rle_move_ml2pr.
Qed.

Lemma Rge_move_ml2pr: forall r1 r2 r : R, r1 - r >= r2 -> r1 >= r2 + r.
Proof.
move=> r1 r2 r lhs.
apply Rle_ge.
apply Rge_le in lhs.
by apply Rle_move_mr2pl.
Qed.

Lemma Rgt_move_pr2ml: forall r1 r2 r : R, r1 > r2 + r -> r1 - r > r2.
Proof.
move=> r1 r2 r lhs.
apply Rlt_gt.
apply Rgt_lt in lhs.
by apply Rlt_move_pl2mr.
Qed.

Lemma Rgt_move_pl2mr: forall r1 r2 r : R, r1 + r > r2 -> r1 > r2 - r.
Proof.
move=> r1 r2 r lhs.
apply Rlt_gt.
apply Rgt_lt in lhs.
by apply Rlt_move_pr2ml.
Qed.

Lemma Rgt_move_mr2pl: forall r1 r2 r : R, r1 > r2 - r -> r1 + r > r2.
Proof.
move=> r1 r2 r lhs.
apply Rlt_gt.
apply Rgt_lt in lhs.
by apply Rlt_move_ml2pr.
Qed.

Lemma Rgt_move_ml2pr: forall r1 r2 r : R, r1 - r > r2 -> r1 > r2 + r.
Proof.
move=> r1 r2 r lhs.
apply Rlt_gt.
apply Rgt_lt in lhs.
by apply Rlt_move_mr2pl.
Qed.

Lemma Rle_pow_inv2_1: forall n:nat, (/2)^n <= 1.
Proof.
induction n.
simpl.
by auto with *.
have H: S n = (n + 1)%nat by auto with *.
rewrite H; clear H.
have H1: (/2)^(n + 1)= (/2)^n * (/2)^1 by auto with *.
rewrite H1; clear H1.
simpl.
have H2: (/2)^n * (/2 * 1) <= 1 * (/2 * 1).
move: IHn.
apply Rmult_le_compat_r.
rewrite Rmult_1_r.
auto with *.
apply Rle_trans with (1*(/2 * 1)).
assumption.
rewrite Rmult_1_l.
rewrite Rmult_1_r.
fourier.
Qed.

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

Lemma Rle_n_pow_2_n: forall n:nat,  (INR n) <= (2^n).
Proof.
induction n.
simpl.
by auto with *.
have H: S n = (n + 1)%nat by auto with *.
rewrite H; clear H.
have H1: INR (n + 1)%nat = (INR n) + (INR 1) by auto with *.
rewrite H1; clear H1.
have H2: 2^(n + 1) = 2^n * 2^1 by auto with *.
rewrite H2; clear H2.
simpl.
rewrite Rmult_1_r.
have H3: INR n + 1 <= 2^n + 1 by apply Rplus_le_compat_r.
apply Rle_trans with (2^n + 1).
assumption. clear H3.
have H4: 2^n * 2 = 2^n + 2^n by field.
rewrite H4; clear H4.
apply Rplus_le_compat_l.
clear IHn.
induction n.
simpl.
by auto with *.
have H: S n = (n + 1)%nat by auto with *.
rewrite H; clear H.
have H2: 2^(n + 1) = 2^n * 2^1 by auto with *.
rewrite H2; clear H2.
simpl.
fourier.
Qed.

Lemma pow_inv_2_n_approach_0: forall eps : R, eps > 0 ->
  exists N : nat, forall n : nat, (n >= N)%nat -> (/2)^n <= eps.
Proof.
move=> eps eps_pos.
have H: exists N: nat, (N>0)%nat /\ /(INR N) < eps.
apply inverses_of_nats_approach_0 with (eps:=eps).
assumption.
destruct H as [N].
exists N.
move=> n lenN.
destruct H.
have H1: (/2)^n <= (/2)^N.
have H2: n = ((n - N) + N)%nat by auto with *.
rewrite H2; clear H2.
have H3: (/2)^(n-N+N) = (/2)^(n-N)*(/2)^N by auto with *.
rewrite H3; clear H3.
have H4: (/2)^(n-N) <= 1.
auto with *.
set k:= (n - N)%nat.
induction k.
simpl.
by auto with *.
have H5: S k = (k + 1)%nat by auto with *.
rewrite H5; clear H5.
have H6: (/2)^(k+1) = (/2)^k*(/2)^1 by auto with *.
rewrite H6; clear H6.
simpl.
have H7: (/2)^k*(/2) <= 1*(/2).
apply Rmult_le_compat_r.
by auto with *.
assumption.
rewrite Rmult_1_r.
rewrite Rmult_1_l in H7.
apply Rle_trans with (/2).
assumption.
fourier.
have H8: (/2)^(n-N)*(/2)^N <= 1* (/2)^N.
apply Rmult_le_compat_r.
have H9: 0 < (/2)^N by auto with real.
move: H9.
by auto with *.
assumption.
rewrite Rmult_1_l in H8.
move: H8.
by auto with *.
have H10: (/2)^N <= /(INR N).
have H11: (/2)^N = /(2^N).
apply eq_sym.
apply Rinv_pow.
pose proof Rlt_R0_R2 as H12.
move:H12.
auto with *.
clear H11.
apply Rle_trans with ((/2)^N).
auto with *.
have H13: /(2^N) = (/2)^N.
apply Rinv_pow.
pose proof Rlt_R0_R2 as H14.
move:H14.
auto with *.
rewrite <- H13.
apply Rle_Rinv.
move: H.
by auto with *.
by auto with *.
apply Rle_n_pow_2_n.
apply Rle_trans with ((/2)^N).
assumption.
apply Rle_trans with (/ INR N).
assumption.
move:H0.
by auto with *.
Qed.

(*************************************************)
Lemma open_ball_is_open:
  forall (x: point_set X) (r: R),
    r > 0 -> open (open_ball (point_set X) d x r).
Proof.
move=> x r H_r_pos.
have H_In_MTOB_oball:
  In (metric_topology_neighborhood_basis d x)
     (open_ball (point_set X) d x r)
  by apply: intro_open_ball.
have H_ON_oball : open_neighborhood (open_ball (point_set X) d x r) x.
apply:  (open_neighborhood_basis_elements (metric_topology_neighborhood_basis d x) x).
by apply: d_metrizes.
assumption.
by destruct H_ON_oball.
Qed.

Lemma open_ball_in_open_set:
  forall (x : point_set X) (U : Ensemble (point_set X)),
    open U -> In U x  ->
    exists r : R, r > 0 /\
      Included (open_ball (point_set X) d x r) U.
Proof.
move=> x U open_U In_U_x.
have Hoball: exists oball : Ensemble (point_set X),
        In (metric_topology_neighborhood_basis d x ) oball /\
        Included oball U.
apply: (open_neighborhood_basis_cond
         (metric_topology_neighborhood_basis d x) x (d_metrizes x)).
red; split.
assumption.
assumption.
destruct Hoball as [oball H_oball].
destruct H_oball as [HmNb HbInU].
destruct HmNb as [r H_rpos].
exists r.
by move: H_rpos HbInU.
Qed.

Definition closed_ball (x0 : point_set X) (r : R):
  Ensemble (point_set X):=
     fun (x : point_set X)  => d x0 x <= r.

Lemma closed_ball_is_closed :
  forall (x0: point_set X) (r: R), closed (closed_ball x0 r).
Proof.
move=> x0 r0.
red.
set cover := fun (xd: { x: point_set X | d x0 x > r0 }%type) =>
  open_ball (point_set X) d (proj1_sig xd) (d x0 (proj1_sig xd) - r0).
have cplmt_as_union:
  Complement (closed_ball x0 r0) = IndexedUnion cover.
apply: Extensionality_Ensembles; red; split.
red.
move=> x In_C_c_x.
have cplmt_x : ~ In (closed_ball x0 r0) x.
by apply: In_C_c_x.
have not_dx0x_le_r0: d x0 x <= r0 -> False.
have Hcb: d x0 x <= r0 -> (closed_ball x0 r0) x by auto.
have Hncb: (closed_ball x0 r0) x -> False by apply: cplmt_x.
move: Hcb Hncb; tauto.
have dx0x_gt_r0 : d x0 x > r0 by apply: Rnot_le_gt.
clear In_C_c_x cplmt_x not_dx0x_le_r0.
have xd_exists :
  exists xd : { x: point_set X | d x0 x > r0 }, proj1_sig xd = x.
exists (exist (fun y : point_set X => d x0 y > r0) x dx0x_gt_r0).
auto.
destruct xd_exists as [xd].
have cx : In (cover xd) x.
constructor.
rewrite H.
rewrite metric_zero.
apply: Rlt_move_pl2mr.
apply: Rgt_lt.
rewrite Rplus_0_l.
exact.
assumption.
apply (indexed_union_intro cover xd).
exact.
red.
move=> x InIndUx.
destruct InIndUx.
destruct H.
have H1 : d x0 (proj1_sig a) > r0.
apply (proj2_sig a).
have Ht: d x0 x >= (d x0 (proj1_sig a)) - (d (proj1_sig a) x).
have h_tmp: d (proj1_sig a) x = d x (proj1_sig a) by apply metric_sym.
rewrite h_tmp. clear h_tmp.
apply: Rge_move_pl2mr.
apply Rle_ge.
apply triangle_inequality.
assumption.
apply Rlt_move_mr2pl in H.
rewrite Rplus_comm in H.
apply Rlt_move_pl2mr in H.
apply Rlt_gt in H.
have H2: d x0 x > r0.
apply Rge_gt_trans with (r2:= d x0 (proj1_sig a) - d (proj1_sig a) x).
exact.
exact.
red.
red.
red.
move=> InCbx.
destruct InCbx.
apply Rgt_not_le in H2.
apply Rlt_le in H0.
move: H0 H2.
tauto.
apply Rgt_not_le in H2.
apply Req_le in H0.
move: H0 H2.
tauto.
have HoU: open (IndexedUnion cover).
Print IndexedUnion.
SearchAbout IndexedUnion.
apply open_indexed_union.
move=>xd.
apply: open_ball_is_open.
apply Rgt_move_pr2ml.
rewrite Rplus_0_l.
apply (proj2_sig xd).
rewrite cplmt_as_union.
exact.
Qed.
Print complete.

(* The Baire Category Theorem for complete metric spaces *)

Theorem BaireCategoryTheorem :  complete d d_metric -> baire_space.

Proof.
move=> H_cplt.
rewrite/baire_space /dense.
move=> V H_od.
apply: Extensionality_Ensembles; split; red; intros.
exact.
apply: meets_every_open_neighborhood_impl_closure.
move=> U H_opn_U H_In_U_x.
set (IStep (xrn0 xrn1: point_set X * { r:R | r > 0} * nat) :=
  snd xrn1 = S (snd xrn0) /\
  proj1_sig (snd (fst xrn1)) <= (proj1_sig (snd (fst xrn0))) * /2 /\
  d (fst (fst xrn0)) (fst (fst xrn1)) < (proj1_sig (snd (fst xrn0))) * /2 /\
  Included
    (open_ball _ d (fst (fst xrn1)) (2*proj1_sig (snd (fst xrn1))))
    (V (snd xrn1))).
(* step 0 *)
have H_V0U : Inhabited (Intersection (V 0%nat) U).
apply: dense_meets_every_nonempty_open.
move: (H_od 0%nat).
tauto.
assumption.
move: H_In_U_x.
by apply Inhabited_intro.
destruct H_V0U as [x0 H_V0U].
apply (open_ball_in_open_set x0 (Intersection (V 0%nat) U)) in H_V0U.
destruct H_V0U as [r0_t HrI].
destruct HrI as [r0_t_pos Inc_ball_V0U].
set r0:=r0_t/2.
have r0_pos: r0>0.
rewrite/r0.
fourier.
set rp0 := exist (fun r:R => r>0)r0 r0_pos.
(**** Axiom of Choice used *******)
have CFun: exists Fn : nat -> point_set X * { r:R | r>0 } * nat,
 (Fn 0%nat) = (pair (pair x0 rp0) 0%nat) /\
 (forall n : nat, (IStep (Fn n) (Fn (S n)))).
apply: FDC.
(*********************************)
(* step n *)
move=> xrn.
set xn := fst (fst xrn).
set rn := proj1_sig (snd (fst xrn)).
set rn_pos := proj2_sig (snd (fst xrn)).
set nn := snd xrn.
have H_Vn1B : Inhabited (Intersection (V (S nn)) (open_ball (point_set X) d xn (rn * /2))).
apply: dense_meets_every_nonempty_open.
move: (H_od (S nn)).
tauto.
apply: open_ball_is_open.
apply : eps2_Rgt_R0.
by apply: rn_pos.
exists xn.
red.
constructor.
rewrite metric_zero.
apply: Rgt_lt.
apply: eps2_Rgt_R0.
by apply: rn_pos.
assumption.
destruct H_Vn1B as [yn H_In_Int_yn].
apply (open_ball_in_open_set yn) in H_In_Int_yn.
destruct H_In_Int_yn as [rn1_t HVSnyn].
destruct HVSnyn as [rn1_t_pos HIbVnb].
set (rn1 := Rmin (rn1_t/2) (rn* /2)).
have rn1_pos: rn1 > 0.
rewrite/rn1.
apply/Rmin_Rgt; split.
fourier.
apply: eps2_Rgt_R0.
by apply: rn_pos.
set rpn1 := (exist (fun r:R => r > 0) rn1 rn1_pos).
exists (pair (pair yn rpn1) (S nn)).
rewrite/IStep.
split.
simpl.
rewrite/nn.
reflexivity.
split.
simpl.
have Hrn: proj1_sig (snd (fst xrn)) = rn by auto.
rewrite Hrn.
rewrite/ rn1.
by apply: Rmin_r.
split.
simpl.
have Hrn: proj1_sig (snd (fst xrn)) = rn by auto.
rewrite Hrn.
have Hxn: (fst (fst xrn)) = xn by auto.
rewrite Hxn.
have HynInInt: In (Intersection (V (S nn)) (open_ball (point_set X) d xn (rn * /2))) yn.
apply: HIbVnb.
constructor.
rewrite metric_zero.
by apply: rn1_t_pos.
assumption.
destruct HynInInt as [yn HVSnyn Hbxnyn].
destruct Hbxnyn.
exact.
simpl.
red.
move=>x1 In_rn1.
have In_rn1_t : In (open_ball (point_set X) d yn rn1_t) x1.
red.
constructor.
destruct In_rn1.
have rn1_le_rn1_t_half: rn1 <= rn1_t/2.
rewrite/rn1.
by apply: Rmin_l.
have : 2* rn1 <= rn1_t  by fourier.
move: H0.
by apply: Rlt_le_trans.
have In_Vb : In (Intersection (V (S nn))
                   (open_ball (point_set X) d xn (rn * /2))) x1
by apply: HIbVnb.
destruct In_Vb.
assumption.
apply: open_intersection2.
move: (H_od (S nn)).
tauto.
apply: open_ball_is_open.
apply: eps2_Rgt_R0.
exact.
destruct CFun as [Fn H_I].
destruct H_I as [H_0 H_n].
(* sequences and properties obtained so far*)
set (x_n (n : DS_set nat_DS) := fst (fst (Fn n))).
have x_n_0 : x_n 0%nat = x0.
have h_tmp: x_n 0%nat = fst (fst (Fn 0%nat)) by auto.
rewrite h_tmp; clear h_tmp.
rewrite H_0.
auto.
set (r_n (n : nat) := proj1_sig (snd (fst (Fn n)))).
have r_n_0 : r_n 0%nat = r0.
have h_tmp: r_n 0%nat = proj1_sig (snd (fst (Fn 0%nat))) by auto.
rewrite h_tmp; clear h_tmp.
rewrite H_0.
auto.
have r_n_pos : forall n : nat, r_n n > 0.
move=>n.
pose proof (proj2_sig (snd (fst (Fn n)))).
simpl in H0.
have h_tmp: (r_n n) = proj1_sig (snd (fst (Fn n))) by auto.
by rewrite h_tmp; clear h_tmp.
have r_n_r_Sn : forall n : nat, r_n (S n) <= (r_n n)* /2.
move=> n.
pose proof (H_n n).
destruct H0.
destruct H1.
have h_tmp: r_n (S n) = proj1_sig (snd (fst (Fn (S n)))) by auto.
rewrite h_tmp; clear h_tmp.
have h_tmp: r_n n = proj1_sig (snd (fst (Fn n))) by auto.
rewrite h_tmp; clear h_tmp.
assumption.
have r_n_r_ni : forall n i : nat, r_n (n+i)%nat <= r_n n * (/2)^i.
move=> n.
induction i.
simpl.
have h_tmp: (n + O)%nat = n by auto.
rewrite h_tmp; clear h_tmp.
have h_tmp: r_n n * 1 = r_n n by auto with real.
rewrite h_tmp; clear h_tmp.
auto with real.
simpl.
have h_tmp: (n + S i)%nat = S (n + i) by auto.
rewrite h_tmp; clear h_tmp.
have h_trans:
   r_n (S (n + i)) <= r_n (n + i)%nat * /2
->  r_n (n + i)%nat * /2   <= r_n n * (/ 2 * (/ 2) ^ i)
 ->  r_n (S (n + i)) <= r_n n * (/ 2 * (/ 2) ^ i) by apply Rle_trans.
apply h_trans; clear h_trans.
apply: r_n_r_Sn.
have h_tmp: r_n n * (/2 * (/2)^i) = r_n n * (/2)^i * (/2).
have h_tmp1: /2 * (/2)^i = (/2)^i * /2 by auto with real.
rewrite h_tmp1; clear h_tmp1.
auto with real.
rewrite h_tmp; clear h_tmp.
move: IHi.
apply: Rmult_le_compat_r.
auto with real.
have x_n_x_Sn_r_n : forall n : nat,
  d (x_n n) (x_n (S n)) < (r_n n) * /2.
move=>n.
pose proof (H_n n) as H_In.
destruct H_In as [_ H_In].
destruct H_In as [_ H_In].
have h_tmp: r_n n = proj1_sig (snd (fst (Fn n))) by auto.
rewrite h_tmp; clear h_tmp.
have h_tmp: x_n n = fst (fst (Fn n)) by auto.
rewrite h_tmp; clear h_tmp.
have h_tmp: x_n (S n) = fst (fst (Fn (S n))) by auto.
rewrite h_tmp; clear h_tmp.
move: H_In.
tauto.
have x_ni_x_nSi_r_n :
forall n i : nat,
  d (x_n (n+i)%nat) (x_n (n + (S i))%nat) < (r_n n)* /2 * (/2)^i.
move=>n i.
have h_trans:
  d (x_n (n+i)%nat) (x_n (n + (S i))%nat) < r_n (n+i)%nat * /2
->
 r_n (n+i)%nat * /2 <= (r_n n)* /2 * (/2)^i
->
 d (x_n (n+i)%nat) (x_n (n + (S i))%nat) < (r_n n)* /2 * (/2)^i
by apply:Rlt_le_trans.
apply h_trans; clear h_trans.
have h_tmp: (n + S i)%nat = S (n + i)%nat by auto with real.
rewrite h_tmp; clear h_tmp.
apply: x_n_x_Sn_r_n.
have h_tmp: r_n n * /2 * (/2)^i = r_n n * (/2)^i * /2 by field.
rewrite h_tmp; clear h_tmp.
have h_tmp: r_n (n + i)%nat  <= r_n n * (/ 2) ^ i by apply: r_n_r_ni.
move:h_tmp.
apply: Rmult_le_compat_r.
by auto with real.
have x_n_x_nk: forall n : nat,
           forall k : nat, d (x_n n%nat) (x_n (n+k)%nat) <= r_n n * (1 - (/2)^k).
move=>n.
induction k.
simpl.
have tmp: (n + 0)%nat = n by auto.
rewrite tmp. clear tmp.
rewrite metric_zero.
have tmp: 1 - 1 = 0.
rewrite Rm2p.
auto with real.
rewrite tmp.
rewrite Rmult_0_r.
by auto with real.
assumption.
have tri : d (x_n n) (x_n (n + (S k))%nat) <=
            d (x_n n) (x_n (n + k)%nat) + d (x_n (n + k)%nat) (x_n (n + (S k))%nat).
apply triangle_inequality.
assumption.
have tmp:  d (x_n n) (x_n (n + k)%nat) + d (x_n (n + k)%nat) (x_n (n + (S k))%nat) <=
                  r_n n * (1 - (/2)^k) + d (x_n (n + k)%nat) (x_n (n + (S k))%nat).
apply Rplus_le_compat_r.
by apply IHk.
have tri2: d (x_n n) (x_n (n + (S k))%nat) <=
      r_n n * (1 - (/2)^k) + d (x_n (n + k)%nat) (x_n (n + (S k))%nat).
apply Rle_trans with
  (r2:= d (x_n n) (x_n (n + k)%nat) + d (x_n (n + k)%nat) (x_n (n + (S k))%nat)).
apply tri.
apply tmp.
clear tri tmp.
have tmp : d (x_n (n + k)%nat) (x_n (n + S k)%nat) < r_n n * /2 * (/2)^k by apply x_ni_x_nSi_r_n.
have tmp1 :  r_n n * (1 - (/ 2) ^ k) + d (x_n (n + k)%nat) (x_n (n + S k)%nat) <
                       r_n n * (1 - (/ 2) ^ k) + r_n n * /2 * (/2)^k.
apply Rplus_lt_compat_l.
by apply tmp.
have tmp2 : d (x_n n) (x_n (n + S k)%nat) < r_n n * (1 - (/ 2) ^ k) + r_n n * / 2 * (/ 2) ^ k.
apply Rle_lt_trans with (r2 :=r_n n * (1 - (/ 2) ^ k) + d (x_n (n + k)%nat) (x_n (n + S k)%nat) ).
apply tri2.
by apply tmp1.
have ineq : r_n n * (1 - (/ 2) ^ k) + r_n n * / 2 * (/ 2) ^ k
          <=  r_n n * (1 - (/ 2) ^ S k).
have tmp3:  r_n n * (1 - (/ 2) ^ k) + r_n n * / 2 * (/ 2) ^ k
  = r_n n * ((1 - (/ 2) ^ k) +  / 2 * (/ 2) ^ k).
SearchAbout Rmult.  rewrite  Rmult_plus_distr_l.
have tmp4: r_n n * (/2 * (/2)^k) = r_n n * /2 *(/2)^k.
rewrite Rmult_assoc.
reflexivity.
rewrite tmp4.
reflexivity.
rewrite tmp3.
apply Rmult_le_compat_l.
have tmp5: 0 < r_n n.
apply Rgt_lt.
by apply r_n_pos.
move: tmp5.
apply Rlt_le.
clear tmp tmp1 tmp2 tmp3.
apply Rle_move_mr2pl.
apply Rle_move_pr2ml.
have tmp:
  0 <=  0 - (/ 2) ^ S k - / 2 * (/ 2) ^ k + (/ 2) ^ k ->
  1+0 <=  1 + (0 - (/ 2) ^ S k - / 2 * (/ 2) ^ k + (/ 2) ^ k)
                                   by apply Rplus_le_compat_l.
have tmp1: 1 + 0 = 1 by apply Rplus_0_r.
rewrite tmp1 in tmp. clear tmp1.
have tmp2: 1 + (0 - (/ 2) ^ S k - / 2 * (/ 2) ^ k + (/ 2) ^ k)
    = 1  - (/ 2) ^ S k - / 2 * (/ 2) ^ k + (/ 2) ^ k.
field.
rewrite tmp2 in tmp.
apply tmp.
clear tmp tmp2.
have tmp3 : 0  - (/ 2) ^ S k - / 2 * (/ 2) ^ k + (/ 2) ^ k
 =  - (/ 2) ^ S k - / 2 * (/ 2) ^ k + (/ 2) ^ k.
field. rewrite tmp3. clear tmp3.
have tmp4: (/2)^S k = /2* (/2)^k by auto.
rewrite tmp4. clear tmp4.
have tmp3 : - (/ 2 * (/2)^k) - / 2 * (/ 2) ^ k + (/ 2) ^ k
 = (- /2 -/2 +1) * (/ 2) ^ k.
field.
rewrite tmp3. clear tmp3.
have tmp4: -/2 -/2 +1 = 0 by field.
rewrite tmp4.
rewrite Rmult_0_l.
by auto with real.
have Ineq: d (x_n n) (x_n (n + S k)%nat) < r_n n * (1 - (/ 2) ^ S k).
apply Rlt_le_trans with (r2:= r_n n * (1 - (/ 2) ^ k) + r_n n * / 2 * (/ 2) ^ k).
exact.
exact.
move: Ineq.
by apply Rlt_le.

(*********************************)
Print Inhabited_intro.
Print cauchy.
have HCauchy: cauchy  d x_n.
red.
move=> eps eps_pos.
have HN: exists N:nat, forall n:nat,
      (n >=N)%nat -> (/2)^n <= (/r0) * (/2) * eps.
apply pow_inv_2_n_approach_0 with (eps:= (/r0) * (/2) * eps).
apply Rmult_gt_0_compat.
apply Rmult_gt_0_compat.
apply Rlt_gt.
apply Rinv_0_lt_compat.
assumption.
auto with *.
assumption.
destruct HN as [N HN].
exists N.
have Hn: forall n:nat, (n>=N)%nat -> d (x_n N) (x_n n) < r0 * ((/2)^N).
move=>n ngeN.
have tmp: n=(N+(n-N))%nat by auto with *.
rewrite tmp; clear tmp.
set k:= (n-N)%nat.
have Hk: d(x_n N) (x_n (N+k)%nat) <= r_n N * (1-(/2)^k).
apply x_n_x_nk.
have HrN : r_n (0+N)%nat <= (r_n 0%nat) * (/2)^N  by apply r_n_r_ni.
simpl in HrN.
rewrite r_n_0 in HrN.
have HrN1: r_n N * (1 - (/2)^k) <= r0 * (/2)^N * (1-(/2)^k).
move: HrN.
apply Rmult_le_compat_r.
apply Rle_move_pl2mr.
rewrite Rplus_0_l.
by apply Rle_pow_inv2_1.
have HrNk: d(x_n N) (x_n (N+k)%nat) <= r0 * (/2)^N * (1 - (/2)^k).
apply Rle_trans with (r_n N * (1 - (/2)^k)).
assumption.
assumption.
clear Hk HrN HrN1.
have HrN2: r0 * (/2)^N * (1 - (/2)^k) < r0 * (/2)^N.
have tmp3: r0 * (/2)^N = r0 * (/2)^N * 1 by auto with *.
rewrite {2} tmp3. clear tmp3.
apply Rmult_lt_compat_l.
have tmp4: 0 < r0.
by apply Rgt_lt.
have tmp5: 0< (/2)^N by auto with *.
move: tmp4 tmp5.
by apply Rmult_lt_0_compat.
apply Rlt_move_pr2ml.
rewrite Rplus_comm.
apply Rlt_move_ml2pr.
have tmp7: 1-1 = 0 by auto with *.
rewrite tmp7; clear tmp7.
by auto with *.
apply Rle_lt_trans with (r0 * (/ 2) ^ N * (1 - (/ 2) ^ k)).
assumption.
assumption.
move=>m1 n1 m1gtN n1gtN.
have Tri: d (x_n m1) (x_n n1) <= d (x_n m1) (x_n N) + d (x_n N) (x_n n1) by apply triangle_inequality.
have Hdm1: d (x_n m1) (x_n N) < r0 * (/2)^N.
rewrite metric_sym.
apply Hn.
assumption.
assumption.
have Hdn1: d (x_n N) (x_n n1) < r0 * (/2)^N.
apply Hn.
assumption.
have Hsum: d (x_n m1) (x_n N) + d (x_n N) (x_n n1) < r0 * (/2)^N + r0 * (/2)^N.
apply Rplus_lt_compat.
assumption.
assumption.
have Hs : r0 * (/2)^N + r0 * (/2)^N = 2 * r0 * (/2)^N.
field.
rewrite Hs in Hsum; clear Hs.
clear Hdm1 Hdn1.
have Htr: d (x_n m1) (x_n n1) < 2 * r0 * (/2)^N.
apply Rle_lt_trans with (d (x_n m1) (x_n N) + d (x_n N) (x_n n1)).
assumption.
assumption.
have Htr2: (/2)^N <= / r0 * /2 * eps by apply HN.
have Htr3: 2 * r0 * (/2)^N <= 2 * r0 * /r0 * /2 * eps.
have tmp4: 2 * r0 * /r0 * /2 * eps = 2 * r0 * (/r0 * /2 * eps).
field.
move: (r0_pos).
auto with *.
rewrite tmp4; clear tmp4.
apply Rmult_le_compat_l with (r:= 2 * r0).
have r0pos: 0 <= r0.
apply Rge_le.
move: (r0_pos).
auto with *.
move: r0pos.
have tmp: 0 = 2 * 0 by auto with *.
rewrite {2} tmp.
auto with *.
assumption.
clear Htr2.
apply Rlt_le_trans with (2 * r0 * (/ 2) ^ N).
assumption.
have HNeps: (/2)^N <= / r0 * /2 * eps.
apply HN.
auto with *.
have HNeps2: (2 * r0) * (/2)^N <= (2 * r0) * (/r0 * /2 * eps).
move: HNeps.
apply Rmult_le_compat_l with (r:= 2 * r0).
have r0pos: 0 <= r0.
apply Rge_le.
move: (r0_pos).
auto with *.
move: r0pos.
have tmp: 0 = 2 * 0 by auto with *.
rewrite {2} tmp.
auto with *.
have Hre: 2 * r0 * /r0 */2 * eps = eps.
have Hre1: 2 * /2 * eps = eps.
have tmp: 2* /2 = 1 by field.
have tmp2: r0 * /r0 = 1.
field.
move: (r0_pos).
auto with *.
rewrite tmp.
rewrite Rmult_1_l.
reflexivity.
have tmp3: 2 * r0 * /r0 = 2 * (r0 * /r0).
field.
move: (r0_pos).
auto with *.
rewrite tmp3.
have tmp4: r0 * /r0 = 1.
auto with *.
rewrite tmp4.
clear tmp3 tmp4.
have tmp5: 2*1 = 2 by field.
rewrite tmp5.
assumption.
have tmp5: 2 * r0 * (/r0 * /2 * eps) = 2 * r0* /r0* /2 * eps.
field.
move: (r0_pos).
by auto with *.
rewrite tmp5 in HNeps2.
rewrite Hre in HNeps2.
assumption.
(************************)
destruct (H_cplt x_n) as [xL Lim].
assumption.
(***********************)
set D:= open_ball (point_set X) d xL r0.
have HopenD: open D.
(* simpl--DOES NOTHING HERE...BUT *)
apply open_ball_is_open.
assumption.
destruct (Lim D).
(* assumption. (* <-DESN'T WORK-*)*)
simpl. (** THIS simpl REVEALS THIS open D ISN'T THAT open D**)
Print B_open.
(*apply B_open_intro.*)
Print IndexedFamily.
Print Singleton.
set F:= Singleton D.
Check F.
have FD: D=FamilyUnion F.
apply Extensionality_Ensembles; red; split.
red. intros.
Print FamilyUnion.
apply (family_union_intro F D).
Print Singleton.
apply In_singleton.
assumption.
red.
intros.
destruct H0.
SearchAbout Singleton.
have tmp: D = S by apply Singleton_inv.
rewrite tmp; clear tmp.
assumption.
rewrite FD.
apply (B_open_intro (point_set X) ).
red.
intros.
have temp2: D=x1 by apply Singleton_inv.
apply eq_sym in temp2.
rewrite temp2.
rewrite temp2 in H0.
apply indexed_union_intro with xL.
red.
constructor.
assumption.
constructor.
rewrite metric_zero.
assumption.
assumption.
have nn_Vnn: forall n:nat,
  snd (Fn n) = n /\ Included (open_ball (point_set X) d (x_n n) (2*(r_n n))) (V n).
induction n.
split.
by rewrite H_0.
rewrite x_n_0.
rewrite r_n_0.
have temp: 2*r0 = r0_t.
rewrite/r0.
field.
rewrite temp; clear temp.
red.
move=>z InObz.
have InV0Uz : In (Intersection (V 0%nat) U) z.
apply: Inc_ball_V0U.
assumption.
destruct InV0Uz.
assumption.
pose proof (H_n n).
destruct H1 as [Hn_Sn Hn_V].
destruct Hn_V as [_ Hn_V].
destruct Hn_V as [_ Hn_V].
destruct IHn as [Hn_n _].
split.
rewrite Hn_Sn.
rewrite Hn_n.
reflexivity.
rewrite/x_n /r_n.
rewrite Hn_Sn in Hn_V.
rewrite Hn_n in Hn_V.
assumption.
(************************************)
apply Inhabited_intro with xL.
split.
apply indexed_intersection_intro.
move=>n.
simpl in H0.
simpl in x1.

set D_n:= open_ball (point_set X) d xL (r_n n).
destruct (Lim D_n).
set F_n:= Singleton D_n.
have FD_n: D_n=FamilyUnion F_n.
apply Extensionality_Ensembles; red; split.
red. intros.
apply (family_union_intro F_n D_n).
apply In_singleton.
assumption.
red.
intros.
destruct H1.
have tmp: D_n = S by apply Singleton_inv.
rewrite tmp; clear tmp.
assumption.
rewrite FD_n.
apply (B_open_intro (point_set X) ).
red.
intros.
have temp2: D_n=x2 by apply Singleton_inv.
apply eq_sym in temp2.
rewrite temp2.
rewrite temp2 in H1.
apply indexed_union_intro with xL.
red.
constructor.
by apply r_n_pos.
constructor.
rewrite metric_zero.
move: (r_n_pos n).
by auto with *.
assumption.
simpl in H1.
simpl in x2.
set n1:= max x2 n.
have Dnn1: In D_n (x_n n1).
apply H1.
rewrite/n1.
by apply Max.le_max_l.
destruct Dnn1 as [d_xL_xn1].
set k1:= (n1 - n)%nat.
have le_0_k1: le 0%nat k1.
rewrite/k1.
have tmp0: (0 = n - n)%nat by auto with *.
rewrite tmp0; clear tmp0.
apply minus_le_compat_r.
rewrite/n1.
by apply Max.le_max_r.
have d_xn_xn1: d (x_n n) (x_n n1) <= r_n n.
have tmpk: n1 = (n + k1)%nat.
rewrite/k1.
apply le_plus_minus.
rewrite/n1.
by apply Max.le_max_r.
rewrite tmpk.
apply Rle_trans with (r_n n * (1-(/2)^k1)).
by apply x_n_x_nk.
have tmp3: 1-(/2)^k1 <= 1.
apply Rle_move_pr2ml.
have tmp4: 1 = 1 + 0 by auto with real.
rewrite {1} tmp4; clear tmp4.
apply Rplus_le_compat_l.
have: 0<(/2)^k1 by auto with real.
by auto with real.
have tmp5: r_n n = (r_n n)*1 by auto with real.
rewrite {2} tmp5; clear tmp5.
move: tmp3.
apply Rmult_le_compat_l.
have tmp2: (n + (n1 - n) = (n1 - n)+ n)%nat by ring.
(*rewrite tmp2; clear tmp2.*)
move:(r0_pos).
by auto with *.
rewrite metric_sym in d_xn_xn1.
have d_xn_xL: d xL (x_n n) < 2*r_n n.
have triang : d xL (x_n n) <= d xL (x_n n1) + d (x_n n1) (x_n n) by apply triangle_inequality.
have tmp6: d xL (x_n n1) + d (x_n n1) (x_n n) <= d xL (x_n n1) + r_n n.
apply Rplus_le_compat_l.
assumption.
have tmp7: d xL (x_n n1) + r_n n < r_n n + r_n n.
apply Rplus_lt_compat_r.
assumption.
have tmp8: 2*r_n n = r_n n + r_n n by field.
rewrite tmp8; clear tmp8.
apply Rle_lt_trans with (d xL (x_n n1) + d (x_n n1) (x_n n)).
assumption.
apply Rle_lt_trans with (d xL (x_n n1) + r_n n).
assumption.
assumption.
rewrite metric_sym in d_xn_xL.
destruct (nn_Vnn n) as [_ bVn].
red in bVn.
apply bVn.
constructor.
assumption.
assumption.
assumption.
(*****************************)
simpl in H0.
simpl in x1.
set n2:= x1.
destruct (H0 n2).
rewrite/n2.
by auto.
have H3: d (x_n n2) (x_n 0%nat) <= r_n 0%nat.
apply Rle_trans with ((r_n 0%nat) * (1-(/2)^n2)).
rewrite metric_sym.
have tmp9: n2 = (0 + n2)%nat by auto with real.
rewrite tmp9; clear tmp9.
by apply x_n_x_nk.
assumption.
have tmp10: r_n 0%nat = (r_n 0%nat)*1 by auto with *.
rewrite {2} tmp10; clear tmp10.
apply Rmult_le_compat_l.
move:(r0_pos).
rewrite r_n_0.
by auto with *.
apply Rle_move_pr2ml.
have tmp11 : 1=1+0 by auto with real.
rewrite {1} tmp11; clear tmp11.
apply Rplus_le_compat_l with (r:=1).
have : 0 < (/2)^n2 by auto with real.
by auto with real.
rewrite r_n_0 in H3.
rewrite x_n_0 in H3.
have d_x0_xL: d x0 xL < r0_t.
rewrite metric_sym.
apply Rle_lt_trans with (d xL (x_n n2) + d (x_n n2) x0).
apply triangle_inequality.
assumption.
apply Rlt_le_trans with (r0 + d (x_n n2) x0).
apply Rplus_lt_compat_r.
assumption.
have tmp12: r0_t = r0 + r0.
rewrite/r0.
rewrite/Rdiv.
SearchAbout Rmult.
rewrite -Rmult_plus_distr_r.
field.
rewrite tmp12; clear tmp12.
apply Rplus_le_compat_l.
assumption.
assumption.
red in Inc_ball_V0U.
have Inball: In (open_ball (point_set X) d x0 r0_t) xL.
constructor.
by apply d_x0_xL.
have InV0U: In (Intersection (V 0%nat) U) xL.
apply Inc_ball_V0U.
by apply Inball.
destruct InV0U.
assumption.
(**********************)
apply open_intersection2.
destruct (H_od 0%nat).
assumption.
assumption.
Qed. (* BaireCategoryTheorem *)

End BaireSpaces.


(******************************************************************************)
(** * Lemmas about traces (finite or infinite sequences) *)
(******************************************************************************)

Require Import HahnBase HahnList HahnSets HahnRelationsBasic.
Require Import HahnOmega HahnWf.
Require Import Arith micromega.Lia IndefiniteDescription.

Set Implicit Arguments.

Lemma set_infinite_natE (s : nat -> Prop) (INF: ~ set_finite s) n :
  exists m, s m /\ length (filterP s (List.seq 0 m)) = n.
Proof.
  assert (IMP: forall findom, exists x, s x /\ ~ In x findom).
  { unfold set_finite in *; apply NNPP; intro X; clarify_not.
    eapply INF; eexists; ins; apply NNPP; intro Y; eauto. }
  apply functional_choice in IMP; destruct IMP as [nin IMP].
  assert (exists m, s m /\ n <= length (filterP s (List.seq 0 m))).
  { induction n; desf.
    1: exists (nin nil); split; [apply IMP | lia].
    exists (nin (List.seq 0 (S m))); split; [apply IMP|].
    rewrite seq_split0 with (a := m).
    rewrite filterP_app, length_app; ins; desf; ins; lia.
    specialize (IMP (List.seq 0 (S m))); desf.
    rewrite in_seq0_iff in IMP0; lia. }
  desf; rewrite Nat.le_lteq in *; desf; eauto.
  clear - H0; induction m; ins.
  replace (List.seq 0 0) with (@nil nat) in H0; ins; lia.
  replace (S m) with (m + 1) in H0; try lia.
  rewrite seq_add, filterP_app, length_app in H0; ins.
  replace (List.seq m 1) with (m :: nil) in H0; ins; desf; ins.
  1: rewrite Nat.add_1_r, Nat.lt_succ_r, Nat.le_lteq in *; desf; eauto.
  rewrite Nat.add_0_r in *; eauto.
Qed.

(** Prepend a finite list to an infinite sequence *)

Definition trace_prepend A (l : list A) (fl : nat -> A) n :=
  if Nat.ltb n (length l) then nth n l (fl 0)
  else fl (n - length l).

(******************************************************************************)
(** Lemmas about [trace_prepend] *)
(******************************************************************************)

Lemma trace_prepend_fst A (l: list A) fl n (LT : n < length l) :
  trace_prepend l fl n = nth n l (fl 0).
Proof.
  unfold trace_prepend; desf; f_equal; lia.
Qed.

Lemma trace_prepend_fst0 A (l: list A) fl x :
  trace_prepend (x :: l) fl 0 = x.
Proof.
  ins.
Qed.

Lemma trace_prepend_snd A (l: list A) fl n :
  trace_prepend l fl (length l + n) = fl n.
Proof.
  unfold trace_prepend; desf; f_equal; lia.
Qed.

Lemma trace_prepend_snd0 A (l: list A) fl :
  trace_prepend l fl (length l) = fl 0.
Proof.
  unfold trace_prepend; desf; f_equal; lia.
Qed.

Lemma trace_prepend_app A (l l' : list A) fl :
  trace_prepend (l ++ l') fl = trace_prepend l (trace_prepend l' fl).
Proof.
  unfold trace_prepend; extensionality n.
  rewrite length_app, nth_app; desf; try lia.
  all: first [apply nth_indep | f_equal]; lia.
Qed.

Hint Rewrite
     filterP_app
     length_app
     trace_prepend_fst0
     trace_prepend_snd
     trace_prepend_snd0
     trace_prepend_app : trace_prepends.

Lemma map_trace_prepend_geq A (l: list A) fl n (LT: length l <= n) :
  map (trace_prepend l fl) (List.seq 0 n) =
    l ++ map fl (List.seq 0 (n - length l)).
Proof.
  unfold trace_prepend.
  rewrite seq_split with (x := length l); ins.
  rewrite map_app.
  rewrite map_nth_seq with (d := fl 0); [|by ins; desf].
  rewrite map_seq_shift with (g := fl) (b := 0); ins.
  desf; try f_equal; lia.
Qed.

Lemma map_trace_prepend_lt A (l: list A) fl n (LT: n < length l) :
  exists l' a l'',
    l = l' ++ a :: l'' /\ length l' = n /\
    map (trace_prepend l fl) (List.seq 0 n) = l'.
Proof.
  unfold trace_prepend.
  destruct (Nat.le_exists_sub n (length l)) as (p & X & _);
    try lia.
      rewrite Nat.add_comm in X.
  apply length_eq_add in X; desf.
  rewrite length_app in *; destruct l''; ins; try lia.
  repeat eexists.
  eapply map_nth_seq with (d := fl 0); ins; desf; try lia.
  rewrite nth_app; desf; try lia.
Qed.

Lemma set_finite_prepend A (l : list A) (fl : nat -> A) (f : A -> Prop) :
  set_finite (set_map (trace_prepend l fl) f) <-> set_finite (set_map fl f).
Proof.
  unfold trace_prepend, set_finite, set_map.
  split; ins; desf.
  { exists (map (fun x => x - length l) findom); intro y; ins.
    rewrite in_map_iff.
    specialize (H (y + length l)); desf; eauto; try lia.
    exists (y + length l); rewrite Nat.add_sub in *; eauto. }
  { exists (List.seq 0 (length l) ++ map (fun x => x + length l) findom);
    intro y; ins.
    rewrite in_app_iff, in_seq0_iff, in_map_iff; desf; eauto.
    apply H in IN.
    right; eexists; split; eauto; lia.
  }
Qed.

(******************************************************************************)
(** Finite or infinite traces of [A] elements. *)
(******************************************************************************)

Inductive trace (A : Type) : Type :=
| trace_fin (l : list A)
| trace_inf (fl : nat -> A).

Definition trace_finite A (t : trace A) :=
  exists l, t = trace_fin l.

(** [trace_app] concatenates two traces *)

Definition trace_app A (t t' : trace A) :=
  match t, t' with
  | trace_fin l, trace_fin l' => trace_fin (l ++ l')
  | trace_fin l, trace_inf f =>
    trace_inf (trace_prepend l f)
  | trace_inf f, _ => trace_inf f
  end.

(** [trace_map f t] applies [f] to all the elements of [t] *)

Definition trace_map A B (f : A -> B) (t : trace A) : trace B :=
  match t with
  | trace_fin l => trace_fin (map f l)
  | trace_inf fl => trace_inf (fun x => f (fl x))
  end.

(** Returns the length of a trace *)

Definition trace_length A (t : trace A) : nat_omega :=
  match t with
  | trace_fin l => NOnum (length l)
  | trace_inf fl => NOinfinity
  end.

(** [trace_elems t] returns true iff [a] is an element of the trace [t] *)

Definition trace_elems A (t : trace A) :=
  match t with
  | trace_fin l => (fun a => In a l)
  | trace_inf fl => (fun a => exists n, a = fl n)
  end.

(** [trace_nth n t d] returns the [n]th element of trace [t]
   or the default element [d], if [n] exceeds the trace's length. *)

Definition trace_nth (n : nat) A (t : trace A) (d : A) : A :=
  match t with
  | trace_fin l => nth n l d
  | trace_inf fl => fl n
  end.

(** [trace_filter f t] returns the sub-trace of [t] whose elements
satisfy the predicate [f]. *)

Definition trace_filter A (f : A -> Prop) (t : trace A) : trace A :=
  match t with
  | trace_fin l => trace_fin (filterP f l)
  | trace_inf fl =>
    let s := excluded_middle_informative (set_finite (set_map fl f)) in
    match s with
    | left FIN =>
        let B := set_finite_nat_bounded FIN in
        let n := proj1_sig (constructive_indefinite_description _ B) in
        trace_fin (filterP f (map fl (List.seq 0 (S n))))
    | right INF =>
        trace_inf
          (fun n =>
           let H := set_infinite_natE INF n in
           let H0 := constructive_indefinite_description _ H in
           fl (proj1_sig H0))
    end
  end.

(** Is a trace a prefix of another trace? *)

Definition trace_prefix A (t t' : trace A) :=
  match t, t' with
  | trace_fin l, trace_fin l' => exists l'', l' = l ++ l''
  | trace_fin l, trace_inf f => forall i (LLEN: i < length l) d, f i = nth i l d
  | trace_inf f, trace_fin _ => False
  | trace_inf f, trace_inf f' => forall x, f x = f' x
  end.

(** Is the trace duplicate-free? *)

Definition trace_nodup A (t: trace A) :=
  forall i j (LTi: i < j) (LTj: NOmega.lt_nat_l j (trace_length t)) d,
    trace_nth i t d <> trace_nth j t d.

(** Is [e] before [e'] in the duplicate-free trace [t]? *)

Definition trace_order A (t: trace A) e e' :=
  trace_nodup t /\
  (exists i j, i < j /\ NOmega.lt_nat_l j (trace_length t)
              /\ trace_nth i t e = e /\ trace_nth j t e = e').

(******************************************************************************)
(** Basic lemmas *)
(******************************************************************************)

Lemma trace_nth_indep (n : nat) A (t : trace A)
      (LT : NOmega.lt_nat_l n (trace_length t)) (d d' : A) :
  trace_nth n t d = trace_nth n t d'.
Proof.
  destruct t; ins; desf; auto using nth_indep.
Qed.

Lemma trace_nth_in A (t : trace A) n
      (LT : NOmega.lt_nat_l n (trace_length t)) d :
  trace_elems t (trace_nth n t d).
Proof.
  destruct t; ins; desf; eauto using nth_In.
Qed.

Global Hint Resolve trace_nth_in : hahn.

Lemma trace_in_nth A (t : trace A) a (IN : trace_elems t a) d :
  exists n, NOmega.lt_nat_l n (trace_length t) /\
            trace_nth n t d = a.
Proof.
  destruct t; ins; desf; eauto using In_nth.
Qed.

Lemma trace_elems_nth A (t : trace A) d :
  trace_elems t
   ≡₁ (⋃₁ n ∈ (fun n => NOmega.lt_nat_l n (trace_length t)),
       eq (trace_nth n t d)).
Proof.
  repeat autounfold with unfolderDb; intuition; desf;
    eauto using trace_in_nth with hahn.
Qed.

Lemma trace_length_app A (t t' : trace A) :
  trace_length (trace_app t t') =
  NOmega.add (trace_length t) (trace_length t').
Proof.
  destruct t, t'; ins; auto using length_app.
Qed.

(** Lemmas about concatenation of traces *)

Lemma trace_in_app A (a : A) (t t' : trace A) :
  trace_elems (trace_app t t') a <->
  trace_elems t a \/ trace_length t <> NOinfinity /\ trace_elems t' a.
Proof.
  split; destruct t, t'; ins; unfold trace_prepend in *;
    desf; rewrite ?in_app_iff in *; desf;
    eauto using nth_In; vauto.
  all: try solve [right; split; ins; eauto].
  apply In_nth with (d := fl 0) in H; desf; exists n; desf; ins.
  exists (n + length l); desf; try f_equal; lia.
Qed.

Lemma trace_elems_app A (t t' : trace A) :
  trace_elems (trace_app t t') ≡₁
    trace_elems t ∪₁ ifP trace_finite t then trace_elems t' else ∅.
Proof.
  unfold set_union, trace_finite; split; intro x;
    rewrite trace_in_app; ins; desf; desf; ins; eauto.
  destruct t; ins; destruct n; eauto.
  right; ins.
Qed.

Lemma trace_nth_app (n : nat) A (t t' : trace A) (d : A) :
  trace_nth n (trace_app t t') d =
  ifP NOmega.lt_nat_l n (trace_length t) then trace_nth n t d
  else trace_nth (NOmega.sub_nat_l n (trace_length t)) t' d.
Proof.
  destruct t, t'; ins; unfold trace_prepend in *;
    desf; try rewrite app_nth; desf;
      auto using nth_indep; lia.
Qed.

Lemma trace_appA A (t t' t'' : trace A) :
  trace_app (trace_app t t') t'' = trace_app t (trace_app t' t'').
Proof.
  unfold trace_app; ins; desf; try by rewrite appA.
  all: f_equal; extensionality x; desf.
  by rewrite trace_prepend_app.
Qed.

Lemma trace_app_assoc A (t t' t'' : trace A) :
  trace_app t (trace_app t' t'') = trace_app (trace_app t t') t''.
Proof.
  symmetry; apply trace_appA.
Qed.

(** Lemmas about [trace_map] *)

Lemma trace_length_map A B (f : A -> B) (t : trace A) :
  trace_length (trace_map f t) = trace_length t.
Proof.
  destruct t; ins; eauto using length_map.
Qed.

Lemma trace_in_map A (a : A) B (f : B -> A) (t : trace B) :
  trace_elems (trace_map f t) a <-> exists x, trace_elems t x /\ f x = a.
Proof.
  destruct t; ins; try rewrite in_map_iff; split; ins; desf; eauto.
Qed.

Lemma trace_elems_map A B (f : B -> A) (t : trace B) :
  trace_elems (trace_map f t) ≡₁ set_collect f (trace_elems t).
Proof.
  unfold set_collect; split; intro x; destruct t; ins; desf;
    try rewrite in_map_iff in *; desf; eauto.
Qed.

Lemma trace_nth_map (n : nat) A B (f : B -> A) (t : trace B) d :
  trace_nth n (trace_map f t) (f d) = f (trace_nth n t d).
Proof.
  destruct t; ins; apply map_nth.
Qed.

(** Lemmas about [trace_filter] *)

Lemma trace_in_filter A (a : A) (f : A -> Prop) (t : trace A) :
  trace_elems (trace_filter f t) a <-> trace_elems t a /\ f a.
Proof.
  destruct t; ins; desf; ins; rewrite ?in_filterP_iff, ?in_map_iff; ins.
  all: split; ins; desf; splits; eauto.
  all: try (eexists; try split; ins).
  all: destruct (constructive_indefinite_description); ins; desf.
  { in_simp; apply l in H0; lia. }
  revert a0.
  instantiate (1 := length (filterP (fl ↓₁ f) (List.seq 0 n0))).
  destruct (lt_eq_lt_dec x n0) as [[LT|]|LT]; desf.
  unfold set_map.
  all: rewrite (seq_split0 LT), filterP_app, length_app;
    ins; desf; ins; lia.
Qed.

Lemma trace_elems_filter A (f : A -> Prop) (t : trace A) :
  trace_elems (trace_filter f t) ≡₁ trace_elems t ∩₁ f.
Proof.
  repeat autounfold with unfolderDb; split; ins.
  all: rewrite trace_in_filter in *; desf.
Qed.

Lemma trace_filter_app A (f : A -> Prop) (t t' : trace A)
      (IMP: trace_length (trace_filter f t) <> NOinfinity ->
            trace_length t <> NOinfinity) :
  trace_filter f (trace_app t t') =
  trace_app (trace_filter f t)
            (trace_filter f t').
Proof.
  destruct t; ins; desf; ins; desf.
  all: try solve [destruct IMP; ins]; clear IMP.
  all: repeat destruct (constructive_indefinite_description); ins; desf.
  all: try solve [exfalso; rewrite set_finite_prepend in *; ins].
    by rewrite filterP_app in *.
  { unfold set_map in *.
    destruct (le_lt_dec (length l) (S x)).
    - rewrite map_trace_prepend_geq; ins.
      unfold trace_prepend in *.
      rewrite filterP_app.
      do 2 f_equal.
      eapply filterP_map_seq_eq; simpl; eauto.
      ins; forward apply (l0 (length l + i)); desf; try lia.
        by rewrite minus_plus.
      ins; eapply l1 in H; lia.
    - eapply map_trace_prepend_lt with (fl := fl) in l2; desf.
      rewrite l4, filterP_app, appA; clear l4.
      f_equal.
      symmetry; rewrite app_eq_prefix, app_eq_nil, ?filterP_eq_nil.
      remember (a :: l'') as l; clear a l'' Heql.
      split; ins.
      apply in_split in IN; desf.
        forward apply (l0 (length l' + length l2)); try lia.
        by autorewrite with trace_prepends.
      in_simp.
      forward apply (l0 (length l' + (length l + x2))); try lia.
      by autorewrite with trace_prepends.
  }
  { f_equal; extensionality y; ins.
    destruct (constructive_indefinite_description); ins; desf.
    erewrite <- length_map, <- filterP_map.
    destruct (le_lt_dec (length l) x) as [LE|LT].
    { rewrite map_trace_prepend_geq; ins.
      autorewrite with trace_prepends.
      rewrite filterP_map, length_map.
      destruct (constructive_indefinite_description); ins; desf.
      unfold set_map, trace_prepend in *; desf; try lia.
      destruct (lt_eq_lt_dec (x - length l) x0) as [[LT|]|LT]; desf;
      apply seq_split0 in LT; rewrite LT in *;
        exfalso; revert a1; rewrite ?map_app, ?filterP_app, ?length_app;
          ins; desf; ins; lia. }
    eapply map_trace_prepend_lt with (fl := fl) in LT; desf.
    rewrite filterP_app, LT1; red in a.
    autorewrite with trace_prepends in *; ins; desf.
  }
Qed.

Lemma trace_lt_length_filter A n t
      (LT : NOmega.lt_nat_l n (trace_length t))
      (f : A -> Prop) d (F : f (trace_nth n t d)) :
  NOmega.lt_nat_l
    (length
       (filterP f
          (map (fun i => trace_nth i t d) (List.seq 0 n))))
    (trace_length (trace_filter f t)).
Proof.
  destruct t; ins; desf; ins.
  erewrite <- map_nth_seq
    with (a := 0) (l := l)
         (f := fun i => nth i l d) at 1; auto using app_nth1.
  rewrite (seq_split0 LT), map_app, filterP_app, length_app; ins; desf; ins;
    try lia.
  destruct (IndefiniteDescription.constructive_indefinite_description);
    ins; desf.
  specialize (l _ F).
  rewrite seqS, (seq_split0 l); ins.
  rewrite !map_app, !filterP_app, !length_app; ins; desf; ins; desf.
  all: rewrite <- !Nat.add_assoc; apply Nat.lt_add_pos_r; lia.
Qed.

Lemma trace_nth_filter A (f : A -> Prop) (t : trace A) i d
      (LT : NOmega.lt_nat_l i (trace_length (trace_filter f t))) :
  exists n, NOmega.lt_nat_l n (trace_length t)
            /\ trace_nth i (trace_filter f t) d = trace_nth n t d
            /\ i = length (filterP f (map (fun i => trace_nth i t d)
                                          (List.seq 0 n))).
Proof.
  destruct t; ins; desf; ins.
  { apply nth_filterP; ins. }
  {
    destruct (IndefiniteDescription.constructive_indefinite_description);
      ins; desf.
    apply nth_filterP with (d := d) in LT; desf.
    rewrite map_length, seq_length in *; ins.
    exists n; splits; try rewrite map_length, seq_length; ins.
    rewrite LT0, nth_indep with (d' := fl 0); ins.
    rewrite map_nth, seq_nth; ins.
    rewrite map_length, seq_length; ins.
    do 2 f_equal; apply map_ext_in; ins; in_simp.
    rewrite nth_indep with (d' := fl 0); ins.
    rewrite map_nth, seq_nth; ins; lia.
    rewrite map_length, seq_length; ins; lia.
  }
  destruct set_infinite_natE with (n := i) as (m & F & NF).
  exists m; desf.
  destruct (IndefiniteDescription.constructive_indefinite_description);
    ins; desf.
  rewrite filterP_map, length_map; splits; ins.
  clear LT; destruct (lt_eq_lt_dec x m) as [[LT|]|LT]; desf.
  all: rewrite (seq_split0 LT), filterP_app, length_app in *; ins; desf;
    ins; lia.
Qed.

Lemma trace_nth_filter' A (f : A -> Prop) (t : trace A) n d
      (LT : NOmega.lt_nat_l n (trace_length t)) (F: f (trace_nth n t d)):
  trace_nth (length (filterP f (map (fun i => trace_nth i t d)
                              (List.seq 0 n))))
      (trace_filter f t) d = trace_nth n t d.
Proof.
  destruct t; ins; desf; ins; eauto using nth_filterP'.
  {
    destruct (IndefiniteDescription.constructive_indefinite_description);
      ins; desf.
    clear LT; assert (LT := l _ F); ins.
    rewrite seqS, (seq_split0 LT), appA, map_app, filterP_app.
    rewrite app_nth2, Nat.sub_diag; ins; desf.
  }
  destruct (IndefiniteDescription.constructive_indefinite_description); ins.
  destruct a as [F' LEQ].
  rewrite filterP_map, length_map in *.
  change (fun i => fl i) with fl in *.
  clear LT; destruct (lt_eq_lt_dec x n) as [[LT|]|LT]; desf.
  all: rewrite (seq_split0 LT), filterP_app, length_app in *; ins; desf;
    ins; lia.
Qed.

(** Lemmas about [trace_prefix] *)

Lemma trace_prefix_app A (t t' : trace A) :
  trace_prefix t (trace_app t t').
Proof.
  destruct t, t'; ins; unfold trace_prepend;
    desf; eauto using nth_indep; done.
Qed.

Lemma trace_prefixE A (t t' : trace A) :
  trace_prefix t t' <-> exists t'', t' = trace_app t t''.
Proof.
  split; ins; desf; eauto using trace_prefix_app.
  destruct t, t'; ins; desf; desf.
  - by eexists (trace_fin _).
  - exists (trace_inf (fun x => fl (x + length l))).
    unfold trace_prepend; f_equal; extensionality y; desf; eauto.
    f_equal; lia.
  - exists (trace_fin nil); f_equal; extensionality x; eauto.
Qed.

Lemma trace_prefix_refl A (t : trace A) :
  trace_prefix t t.
Proof.
  destruct t; ins; eauto using app_nil_end.
Qed.

Lemma trace_prefix_trans A (t t' t'' : trace A) :
  trace_prefix t t' ->
  trace_prefix t' t'' ->
  trace_prefix t t''.
Proof.
  destruct t, t', t''; ins; desf; try rewrite <- H0; eauto.
    by rewrite appA; vauto.
  forward apply H0 with (i := i) (d := d);
    rewrite ?length_app, ?nth_app;
    ins; desf; lia.
Qed.

(** No duplicates *)

Lemma trace_nodup_filter A (f : A -> Prop) (t : trace A) :
  trace_nodup t -> trace_nodup (trace_filter f t).
Proof.
  unfold trace_nodup; ins; desf.
  red; intros.
  forward eapply trace_nth_filter with (i := i) (d := d)
    as (n & LTn & N); eauto with hahn.
  forward eapply trace_nth_filter with (i := j) (d := d)
    as (m & LTm & M); eauto with hahn.
  desf.
  destruct (lt_eq_lt_dec n m) as [[LT|]|LT]; desf; try lia;
  eapply H with (d := d) in LT; congruence.
Qed.

Lemma trace_nodup_mapE A B (f : A -> B) (t : trace A) :
  trace_nodup (trace_map f t) -> trace_nodup t.
Proof.
  unfold trace_nodup; ins; desf.
  intro; eapply H; try rewrite trace_length_map; eauto.
  rewrite !trace_nth_map; eauto using f_equal.
Qed.

Lemma trace_nodup_inj A (t: trace A)
      (ND: trace_nodup t)
      i (LTi : NOmega.lt_nat_l i (trace_length t))
      j (LTj : NOmega.lt_nat_l j (trace_length t)) d d'
      (EQ: trace_nth i t d = trace_nth j t d') :
  i = j.
Proof.
  rewrite trace_nth_indep with (d := d) (d' := d') in EQ; ins.
  destruct (lt_eq_lt_dec i j) as [[LT|]|LT]; ins.
  all: exfalso; eapply ND; eauto.
Qed.

Lemma trace_nodup_filter_inj A (f : A -> Prop) t
      (ND : trace_nodup (trace_filter f t))
      n (Ln : NOmega.lt_nat_l n (trace_length t))
      m (Lm : NOmega.lt_nat_l m (trace_length t))
      d (EQ : trace_nth n t d = trace_nth m t d)
      (EXT : f (trace_nth n t d)) :
  n = m.
Proof.
  assert (Em: f (trace_nth m t d)) by congruence.
  rewrite <- trace_nth_filter'
    with (n := m) (f := f) in EQ; ins.
  rewrite <- trace_nth_filter'
    with (n := n) (f := f) in EQ; ins; desf.
  eapply trace_nodup_inj in EQ; ins;
    try eapply trace_lt_length_filter; eauto.
  destruct (lt_eq_lt_dec n m) as [[LT|]|LT]; desf.
  all: rewrite (seq_split0 LT) in *.
  all: rewrite map_app, filterP_app, length_app in *;
      ins; desf; ins; lia.
Qed.

(** Lemmas about [trace_order] *)

Lemma trace_order_in1 A (t : trace A) a b :
  trace_order t a b -> trace_elems t a.
Proof.
  unfold trace_order; destruct t; ins; desf; ins; eauto.
  rewrite <- H2; apply nth_In; lia.
Qed.

Lemma trace_order_in2 A (t : trace A) a b :
  trace_order t a b -> trace_elems t b.
Proof.
  unfold trace_order; destruct t; ins; desf; ins; eauto.
  rewrite <- H2; apply nth_In; lia.
Qed.

Global Hint Immediate trace_order_in1 trace_order_in2 : hahn.

Lemma trace_order_total A (t : trace A) (ND : trace_nodup t) :
  is_total (trace_elems t) (trace_order t).
Proof.
  red; ins.
  apply trace_in_nth with (d := a) in IWa; desf.
  apply trace_in_nth with (d := a) in IWb; desf.
  destruct (lt_eq_lt_dec n n0) as [[LT|]|LT]; desf; try congruence.
  left; repeat eexists; eauto.
  right; repeat eexists; eauto using trace_nth_indep.
  rewrite trace_nth_indep with (d' := a); ins.
Qed.

Lemma trace_order_trans A (t : trace A) x y z :
  trace_order t x y ->
  trace_order t y z ->
  trace_order t x z.
Proof.
  unfold trace_order; splits; ins; desf.
  rewrite trace_nth_indep with (d' := x) in *; ins; eauto.
  2: destruct (trace_length t); ins; lia.
  exists i0, j; splits; eauto.
  destruct (le_lt_dec j0 i) as [|LT]; try lia.
  exfalso; eapply H0; try apply LT; eauto.
Qed.

Lemma trace_order_irrefl A (t : trace A) x
      (ORD: trace_order t x x) : False.
Proof.
  unfold trace_order in *; ins; desf.
  eapply ORD with (d := x); eauto; congruence.
Qed.

Lemma fsupp_trace_order A (t : trace A) :
  fsupp (trace_order t).
Proof.
  intro y.
  tertium_non_datur (trace_elems t y).
  2: exists nil; ins; eauto with hahn.
  apply trace_in_nth with (d := y) in H; desc.
  exists (map (fun i => trace_nth i t y) (List.seq 0 n)).
  unfold trace_order; ins; desf.
  ins; in_simp.
  rewrite trace_nth_indep with (d' := x) in H0; ins.
  apply trace_nodup_inj in H0; ins; desf.
  exists i; rewrite trace_nth_indep with (d' := x);
    splits; ins; in_simp; eauto with hahn.
Qed.

Lemma trace_order_nth_nth A (t : trace A)
      n (LTn : NOmega.lt_nat_l n (trace_length t)) d
      m (LTm : NOmega.lt_nat_l m (trace_length t)) d' :
  trace_order t (trace_nth n t d) (trace_nth m t d') <->
  trace_nodup t /\ n < m.
Proof.
  unfold trace_order; split; ins; desf; splits; ins.
    apply trace_nodup_inj in H2; ins; desf.
    apply trace_nodup_inj in H3; ins; desf.
    destruct (trace_length t); ins; lia.
  exists n, m; splits; ins; auto using trace_nth_indep.
Qed.

Lemma exists_max (cond : nat -> Prop) n :
  (forall m (LT : m < n), ~ cond m)
  \/ exists m, m < n /\ cond m /\ forall j, m < j -> j < n -> ~ cond j.
Proof.
  induction n; [left; ins; lia|].
  tertium_non_datur (cond n).
    right; exists n; splits; ins; lia.
  desf; [left | right].
  ins; rewrite Nat.lt_succ_r, Nat.le_lteq in *; desf; eauto.
  exists m; splits; ins; eauto.
  rewrite Nat.lt_succ_r, Nat.le_lteq in *; desf; eauto.
Qed.

(** Labelled transition system (LTS) *)

Record LTS (State Label : Type) : Type :=
  { LTS_init : State -> Prop ;
    LTS_final : State -> Prop ;
    LTS_step : State -> Label -> State -> Prop }.

Section LTS_traces.

  Variable State : Type.
  Variable Label : Type.
  Variable lts : LTS State Label.

  (** Traces generated by a labelled transition system *)

  Definition LTS_trace (t : trace Label) :=
    match t with
    | trace_fin l =>
      exists fl', LTS_init lts (fl' 0) /\
                  forall i (LLEN : i < length l) d,
                    LTS_step lts (fl' i) (nth i l d) (fl' (S i))
    | trace_inf fl =>
      exists fl', LTS_init lts (fl' 0) /\
                  forall i, LTS_step lts (fl' i) (fl i) (fl' (S i))
    end.

  Definition LTS_complete_trace (t : trace Label) :=
    match t with
    | trace_fin l =>
      exists fl', LTS_init lts (fl' 0) /\
                  LTS_final lts (fl' 0) /\
                  forall i (LLEN : i < length l) d,
                    LTS_step lts (fl' i) (nth i l d) (fl' (S i))
    | trace_inf fl =>
      exists fl', LTS_init lts (fl' 0) /\
                  forall i, LTS_step lts (fl' i) (fl i) (fl' (S i))
    end.

  Lemma LTS_complete_trace_weaken t :
    LTS_complete_trace t -> LTS_trace t.
  Proof.
    destruct t; ins; desf; eauto.
  Qed.

  Lemma LTS_trace_prefix_closed t t' :
    LTS_trace t' -> trace_prefix t t' -> LTS_trace t.
  Proof.
    destruct t, t'; ins; desf; exists fl'; splits; ins.
    all: specialize (H1 i); rewrite ?length_app in *.
    all: specialize_full H1; try lia.
    all: try rewrite nth_app in *; desf; eauto; try lia.
    rewrite <- H0; ins.
    rewrite H0; ins.
  Qed.

  Lemma LTS_traceE t (T : LTS_trace t) :
    exists fl',
      LTS_init lts (fl' 0) /\
      (forall i (LTi : NOmega.lt_nat_l i (trace_length t)) d,
          LTS_step lts (fl' i) (trace_nth i t d) (fl' (S i))).
  Proof.
    destruct t; ins; desf.
    exists fl'; split; ins.
  Qed.

End LTS_traces.

Global Hint Resolve fsupp_trace_order : hahn.


Require Import STLCSubRec.syntax.
Require Import STLCSubRec.bindings.
Require Import Utf8.

Implicit Types V: Set.

Definition Ctx V U := V → ty U.

Definition DV_extend {V : Set} {K:Type} (f: V -> K) (T : K) : inc V -> K :=
  fun t =>
    match t with
    | VZ => T
    | VS k => f k
    end.

Notation ctx_append Γ T := (DV_extend Γ T).

(*
Inductive val (V: Set) : Set :=
  | v_var  : V -> val V
  | v_true : val V
  | v_false : val V
  | v_abs  : exp (inc V) -> val V
with exp (V : Set) : Set :=
  | e_val  : val V -> exp V
  | e_if   : exp V -> exp V -> exp V -> exp V
  | e_app  : exp V -> exp V -> exp V.
   *)

(* Inductive val_has_type {V} : Ctx V -> val V -> ty -> Prop :=
  | htv_var : forall Γ x T,
    Γ x = T ->
    val_has_type Γ (v_var x) T
  | htv_true : forall Γ,
    val_has_type Γ v_true ty_bool
  | htv_false : forall Γ,
    val_has_type Γ v_false ty_bool
  | htv_abs : forall Γ exp_body Ti To,
    exp_has_type (ctx_append Γ Ti) exp_body To ->
    val_has_type Γ (v_abs Ti exp_body) (ty_arrow Ti To)
with exp_has_type {V} : Ctx V -> exp V -> ty -> Prop :=
  | hte_val : forall Γ x T,
    val_has_type Γ x T ->
    exp_has_type Γ (e_val x) T
  | hte_if : forall Γ cond a b T,
    exp_has_type Γ cond ty_bool ->
    exp_has_type Γ a T ->
    exp_has_type Γ b T ->
    exp_has_type Γ (e_if cond a b) T
  | hte_app : forall Γ a b Ti To,
    exp_has_type Γ a (ty_arrow Ti To) ->
    exp_has_type Γ b Ti ->
    exp_has_type Γ (e_app a b) To. *)

(* Notation "Gamma '⊢ᵛ' t '∈' T" := (val_has_type Gamma t T)
(at level 101).

Notation "Gamma '⊢ᵉ' t '∈' T" := (exp_has_type Gamma t T)
(at level 101). *)


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files defines a lexicographic order on various common data structures
and proves that it is a partial order having a strong variant of trichotomy. *)
From stdpp Require Import numbers.
Set Default Proof Using "Type".

Notation cast_trichotomy T :=
  match T with
  | inleft (left _) => inleft (left _)
  | inleft (right _) => inleft (right _)
  | inright _ => inright _
  end.

Instance prod_lexico `{Lexico A, Lexico B} : Lexico (A * B) := λ p1 p2,
  (**i 1.) *) lexico (p1.1) (p2.1) ∨
  (**i 2.) *) p1.1 = p2.1 ∧ lexico (p1.2) (p2.2).

Instance bool_lexico : Lexico bool := λ b1 b2,
  match b1, b2 with false, true => True | _, _ => False end.
Instance nat_lexico : Lexico nat := (<).
Instance N_lexico : Lexico N := (<)%N.
Instance Z_lexico : Lexico Z := (<)%Z.
Typeclasses Opaque bool_lexico nat_lexico N_lexico Z_lexico.
Instance list_lexico `{Lexico A} : Lexico (list A) :=
  fix go l1 l2 :=
  let _ : Lexico (list A) := @go in
  match l1, l2 with
  | [], _ :: _ => True
  | x1 :: l1, x2 :: l2 => lexico (x1,l1) (x2,l2)
  | _, _ => False
  end.
Instance sig_lexico `{Lexico A} (P : A → Prop) `{∀ x, ProofIrrel (P x)} :
  Lexico (sig P) := λ x1 x2, lexico (`x1) (`x2).

Lemma prod_lexico_irreflexive `{Lexico A, Lexico B, !Irreflexive (@lexico A _)}
  (x : A) (y : B) : complement lexico y y → complement lexico (x,y) (x,y).
Proof. intros ? [?|[??]]. by apply (irreflexivity lexico x). done. Qed.
Lemma prod_lexico_transitive `{Lexico A, Lexico B, !Transitive (@lexico A _)}
    (x1 x2 x3 : A) (y1 y2 y3 : B) :
  lexico (x1,y1) (x2,y2) → lexico (x2,y2) (x3,y3) →
  (lexico y1 y2 → lexico y2 y3 → lexico y1 y3) → lexico (x1,y1) (x3,y3).
Proof.
  intros Hx12 Hx23 ?; revert Hx12 Hx23. unfold lexico, prod_lexico.
  intros [|[??]] [?|[??]]; simplify_eq/=; auto.
  by left; trans x2.
Qed.

Instance prod_lexico_po `{Lexico A, Lexico B, !StrictOrder (@lexico A _)}
  `{!StrictOrder (@lexico B _)} : StrictOrder (@lexico (A * B) _).
Proof.
  split.
  - intros [x y]. apply prod_lexico_irreflexive.
    by apply (irreflexivity lexico y).
  - intros [??] [??] [??] ??.
    eapply prod_lexico_transitive; eauto. apply transitivity.
Qed.
Instance prod_lexico_trichotomyT `{Lexico A, tA : !TrichotomyT (@lexico A _)}
  `{Lexico B, tB : !TrichotomyT (@lexico B _)}: TrichotomyT (@lexico (A * B) _).
Proof.
 red; refine (λ p1 p2,
  match trichotomyT lexico (p1.1) (p2.1) with
  | inleft (left _) => inleft (left _)
  | inleft (right _) => cast_trichotomy (trichotomyT lexico (p1.2) (p2.2))
  | inright _ => inright _
  end); clear tA tB;
    abstract (unfold lexico, prod_lexico; auto using injective_projections).
Defined.

Instance bool_lexico_po : StrictOrder (@lexico bool _).
Proof. split. by intros [] ?. by intros [] [] [] ??. Qed.
Instance bool_lexico_trichotomy: TrichotomyT (@lexico bool _).
Proof.
 red; refine (λ b1 b2,
  match b1, b2 with
  | false, false => inleft (right _)
  | false, true => inleft (left _)
  | true, false => inright _
  | true, true => inleft (right _)
  end); abstract (unfold strict, lexico, bool_lexico; naive_solver).
Defined.

Instance nat_lexico_po : StrictOrder (@lexico nat _).
Proof. unfold lexico, nat_lexico. apply _. Qed.
Instance nat_lexico_trichotomy: TrichotomyT (@lexico nat _).
Proof.
 red; refine (λ n1 n2,
  match Nat.compare n1 n2 as c return Nat.compare n1 n2 = c → _ with
  | Lt => λ H, inleft (left (nat_compare_Lt_lt _ _ H))
  | Eq => λ H, inleft (right (nat_compare_eq _ _ H))
  | Gt => λ H, inright (nat_compare_Gt_gt _ _ H)
  end eq_refl).
Defined.

Instance N_lexico_po : StrictOrder (@lexico N _).
Proof. unfold lexico, N_lexico. apply _. Qed.
Instance N_lexico_trichotomy: TrichotomyT (@lexico N _).
Proof.
 red; refine (λ n1 n2,
  match N.compare n1 n2 as c return N.compare n1 n2 = c → _ with
  | Lt => λ H, inleft (left (proj2 (N.compare_lt_iff _ _) H))
  | Eq => λ H, inleft (right (N.compare_eq _ _ H))
  | Gt => λ H, inright (proj1 (N.compare_gt_iff _ _) H)
  end eq_refl).
Defined.

Instance Z_lexico_po : StrictOrder (@lexico Z _).
Proof. unfold lexico, Z_lexico. apply _. Qed.
Instance Z_lexico_trichotomy: TrichotomyT (@lexico Z _).
Proof.
 red; refine (λ n1 n2,
  match Z.compare n1 n2 as c return Z.compare n1 n2 = c → _ with
  | Lt => λ H, inleft (left (proj2 (Z.compare_lt_iff _ _) H))
  | Eq => λ H, inleft (right (Z.compare_eq _ _ H))
  | Gt => λ H, inright (proj1 (Z.compare_gt_iff _ _) H)
  end eq_refl).
Defined.

Instance list_lexico_po `{Lexico A, !StrictOrder (@lexico A _)} :
  StrictOrder (@lexico (list A) _).
Proof.
  split.
  - intros l. induction l. by intros ?. by apply prod_lexico_irreflexive.
  - intros l1. induction l1 as [|x1 l1]; intros [|x2 l2] [|x3 l3] ??; try done.
    eapply prod_lexico_transitive; eauto.
Qed.
Instance list_lexico_trichotomy `{Lexico A, tA : !TrichotomyT (@lexico A _)} :
  TrichotomyT (@lexico (list A) _).
Proof.
 refine (
  fix go l1 l2 :=
  let go' : TrichotomyT (@lexico (list A) _) := @go in
  match l1, l2 with
  | [], [] => inleft (right _)
  | [], _ :: _ => inleft (left _)
  | _ :: _, [] => inright _
  | x1 :: l1, x2 :: l2 => cast_trichotomy (trichotomyT lexico (x1,l1) (x2,l2))
  end); clear tA go go';
    abstract (repeat (done || constructor || congruence || by inversion 1)).
Defined.

Instance sig_lexico_po `{Lexico A, !StrictOrder (@lexico A _)}
  (P : A → Prop) `{∀ x, ProofIrrel (P x)} : StrictOrder (@lexico (sig P) _).
Proof.
  unfold lexico, sig_lexico. split.
  - intros [x ?] ?. by apply (irreflexivity lexico x).
  - intros [x1 ?] [x2 ?] [x3 ?] ??. by trans x2.
Qed.
Instance sig_lexico_trichotomy `{Lexico A, tA : !TrichotomyT (@lexico A _)}
  (P : A → Prop) `{∀ x, ProofIrrel (P x)} : TrichotomyT (@lexico (sig P) _).
Proof.
 red; refine (λ x1 x2, cast_trichotomy (trichotomyT lexico (`x1) (`x2)));
  abstract (repeat (done || constructor || apply (sig_eq_pi P))).
Defined.


Require Import Overture PathGroupoids.

Lemma transport2_is_ap  (A : Type) (Q : A -> Type) (x y : A) (p q : x = y)
      (r : p = q) (z : Q x)
  : transport2 Q r z = ap (fun U => transport Q U z) r.
Proof.
  destruct r. reflexivity.
Defined.

Lemma concat_ap_Fpq (A B:Type) (a b:A) (c d e:B) (f: a = b -> c = d)
      (v:d = e)
      (u1 u2:a=b) (p:u1 = u2)
  : ap (fun u:a=b => f u @ v) p = whiskerR (ap f p) v.
Proof.
  destruct p; reflexivity.
Defined.

Lemma concat_ap_pFq (A B:Type) (a b:A) (d e c:B) (f: a = b -> e = c)
      (v:d = e)
      (u1 u2:a=b) (p:u1 = u2)
  : ap (fun u:a=b => v @ f u) p = whiskerL v (ap f p).
Proof.
  destruct p; reflexivity.
Defined.

Lemma whiskerL_1pp (A : Type) (x y z t: A) (p : x = y) (p':y=t) (q q' : t = z)
      (r : q = q')
  : whiskerL (p@p') r = (concat_pp_p _ _ _) @ whiskerL p (whiskerL p' r) @ (concat_p_pp _ _ _).
Proof.
  destruct r, q, p, p'. reflexivity.
Qed.

Lemma whiskerL_LV (A : Type) (x y z: A) (p : x = y) (q q' : y = z)
      (r : q = q')
  : whiskerL p r^ = (whiskerL p r)^.
Proof.
  destruct r, q, p; reflexivity.
Qed.

Lemma whiskerR_RV (A : Type) (x y z: A) (p : y = z) (q q' : x = y)
      (r : q = q')
  : whiskerR r^ p = (whiskerR r p)^.
Proof.
  destruct r, q, p; reflexivity.
Defined.

Lemma concat_ap_FpFq_pp_p (A B:Type) (a b:A)
      (c d e f:B)
      (g: a = b -> e = f) (h: a = b -> c = d)
      (v:d = e)
      (u1 u2:a=b) (p:u1 = u2)
  : ap (fun u:a=b => (h u @ v) @ g u) p
    = ((concat_pp_p _ _ _) @ (whiskerR (ap h p) (v @ g u1) @ (concat_p_pp _ _ _))) @
                                                                                whiskerL (h u2 @ v) (ap g p).
Proof.
  destruct p, u1, v; cbn.
  destruct (g idpath), (h idpath); reflexivity.
Defined.

Lemma concat_ap_FpFq_p_pp (A B:Type) (a b:A)
      (c d e f:B)
      (g: a = b -> e = f) (h: a = b -> c = d)
      (v:d = e)
      (u1 u2:a=b) (p:u1 = u2)
  : ap (fun u:a=b => h u @ (v @ g u)) p =
    (whiskerR (ap h p) (v @ g u1) @ (concat_p_pp _ _ _)) @ (whiskerL (h u2 @ v) (ap g p) @ (concat_pp_p _ _ _)).
Proof.
  destruct p, u1, v; cbn.
  destruct (g idpath), (h idpath); reflexivity.
Defined.

Lemma concat_ap_FFpq_p_pp (A B:Type) (a b:A)
      (c d e f:B)
      (g: a = b -> d = f) (h: a = b -> c = d)
      (v:f = e)
      (u1 u2:a=b) (p:u1 = u2)
  : ap (fun u:a=b => h u @ (g u @ v)) p = (concat_p_pp _ _ _) @ (whiskerR (ap h p @@ ap g p) v @ (concat_pp_p _ _ _)).
Proof.
  destruct p, u1, v; cbn.
  destruct (g idpath), (h idpath); reflexivity.
Defined.

Lemma concat2_inv (A : Type) (x y z : A) (p p' : x = y) (q q' : y = z)
      (r:p=p') (s:q=q')
  : (r @@ s)^ = (r^ @@ s^).
Proof.
  destruct r, s. reflexivity.
Defined.

Lemma concat2_p_pp (A : Type) (w x y z : A) (p p' : w = x) (q q' : x = y) (r r' : y = z)
      (s:p=p') (s':q=q') (s'':r=r')
  : s @@ (s' @@ s'') = (concat_p_pp _ _ _) @ (((s @@ s') @@ s'') @ (concat_pp_p _ _ _)).
Proof.
  destruct s, s', s'', p, q, r; reflexivity.
Defined.

Lemma ap02_is_ap (A B : Type) (f : A -> B) (x y : A) (p q : x = y) (r:p=q)
  : ap02 f r = ap (ap f) r.
Proof.
  destruct r; reflexivity.
Defined.

Lemma ap02_compose (A B C : Type) (f : A -> B) (g : B -> C) (x y : A) (p p': x = y) (q:p=p')
  : ap02 (g o f) q = ap_compose f g p @ (ap02 g (ap02 f q) @ (ap_compose f g p')^).
Proof.
  destruct q, p; reflexivity.
Defined.

Lemma ap02_V (A B : Type) (f : A -> B) (x y : A) (p q : x = y) (r:p=q)
  : ap02 f r^ = (ap02 f r)^.
Proof.
  destruct r; reflexivity.
Defined.


(* Contribution to the Coq Library   V6.3 (July 1999)                       *)
(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.11                                 *)
(*                              Feb 2nd 1996                                *)
(*                                                                          *)
(*                (notations and layout updated March 2009)                 *)
(****************************************************************************)
(*                            Setminus_fact.v                               *)
(****************************************************************************)
(* This file is distributed under the terms of the                          *)
(* GNU Lesser General Public License Version 2.1                            *)
(****************************************************************************)

Require Import Ensembles.    (* Ensemble, In, Included, Setminus *)

Section Contravariance_of_Setminus.

Variable U : Type.

Lemma Setminus_contravariant :
 forall A B B' : Ensemble U,
 Included U B' B -> Included U (Setminus U A B) (Setminus U A B').
intros A B B' B'_Included_B; unfold Setminus in |- *.
red in |- *; intros x x_in_B.
elim x_in_B; intros x_in_A x_in_nonB.
split.
  assumption.
red in |- *; intro x_in_B'.
apply x_in_nonB.
apply B'_Included_B.
assumption.
Qed.

End Contravariance_of_Setminus.

(* $Id$ *)