Require Export RTopology SeparatednessAxioms.
Require Import RFuncContinuity UniformTopology ContinuousFactorization.
From Coq Require Import Description Max Psatz ClassicalChoice.
From ZornsLemma Require Import Proj1SigInjective.
Require Import UrysohnsLemma.

(* This proof of the Tietze extension theorem is heavily based on
   the proof described on planetmath.org. *)

Section Tietze_extension_construction.

Variable X:TopologicalSpace.
Variable F:Ensemble X.
Hypothesis F_closed: closed F.
Variable f:SubspaceTopology F -> RTop.
Hypothesis f_continuous: continuous f.
Hypothesis f_bound: forall x:SubspaceTopology F,
  -1 <= f x <= 1.
Hypothesis X_nonempty: inhabited X.

Variable Urysohns_lemma_function:
  forall F G:Ensemble X,
  closed F -> closed G -> Intersection F G = Empty_set ->
  { f:X -> RTop |
  continuous f /\ (forall x:X, 0 <= f x <= 1) /\
  (forall x:X, In F x -> f x = 0) /\
  (forall x:X, In G x -> f x = 1) }.

Lemma Rle_order: order Rle.
Proof.
constructor;
  red; intros.
- apply Rle_refl.
- eapply Rle_trans;
    eassumption.
- now apply Rle_antisym.
Qed.

Section extension_approximation.

Variable f0:SubspaceTopology F -> RTop.
Hypothesis f0_cont: continuous f0.
Hypothesis f0_bound: forall x:SubspaceTopology F,
                     -1 <= f0 x <= 1.

Definition extension_approximation: X -> RTop.
refine (
  let F0:=Im [ x:SubspaceTopology F | f0 x <= -1/3 ]
             (subspace_inc F) in
  let G0:=Im [ x:SubspaceTopology F | f0 x >= 1/3 ]
             (subspace_inc F) in
  let g:=proj1_sig (Urysohns_lemma_function F0 G0 _ _ _) in
  fun x:X => -1/3 + 2/3 * g x).
- apply subspace_inc_takes_closed_to_closed; [assumption|].
  replace ([ x:SubspaceTopology F | f0 x <= -1/3 ]) with
    (inverse_image f0 [ y:RTop | y <= -1/3 ]).
  + red.
    rewrite <- inverse_image_complement.
    apply f0_cont.
    apply lower_closed_interval_closed.
    * apply Rle_order.
    * intros.
      destruct (total_order_T x y) as [[|]|];
        auto with real.
  + extensionality_ensembles.
    * now constructor.
    * constructor.
      now constructor.
- apply subspace_inc_takes_closed_to_closed; [assumption|].
  replace ([ x:SubspaceTopology F | f0 x >= 1/3 ]) with
    (inverse_image f0 [ y:RTop | 1/3 <= y ]).
  + red.
    rewrite <- inverse_image_complement.
    apply f0_cont.
    apply upper_closed_interval_closed.
    * apply Rle_order.
    * intros.
      destruct (total_order_T x y) as [[|]|];
        auto with real.
  + extensionality_ensembles.
    * constructor. lra.
    * constructor. constructor. lra.
- extensionality_ensembles.
  destruct x, x0.
  simpl in *.
  subst.
  destruct (proof_irrelevance _ i i0).
  lra.
Defined.

Lemma extension_approximation_bound: forall x:X,
  -1/3 <= extension_approximation x <= 1/3.
Proof.
intros.
unfold extension_approximation.
destruct Urysohns_lemma_function as [g].
simpl.
destruct a as [? [? []]].
destruct (H0 x).
lra.
Qed.

Lemma extension_approximation_diff_bound:
  forall x:SubspaceTopology F,
  -2/3 <= f0 x - extension_approximation (subspace_inc F x) <= 2/3.
Proof.
intros.
unfold extension_approximation.
destruct Urysohns_lemma_function as [g [? [? []]]].
simpl.
destruct (f0_bound x).
destruct (Rle_or_lt (f0 x) (-1/3)).
- replace (g (subspace_inc F x)) with 0.
  { lra. }
  symmetry. apply e.
  econstructor; trivial.
  now constructor.
- destruct (Rle_or_lt (1/3) (f0 x)).
  + replace (g (subspace_inc F x)) with 1.
    { lra. }
    symmetry. apply e0.
    econstructor; trivial.
    constructor.
    lra.
  + destruct (a (subspace_inc F x)).
    lra.
Qed.

Lemma extension_approximation_continuous:
  continuous extension_approximation.
Proof.
unfold extension_approximation.
destruct Urysohns_lemma_function as [g [? [? []]]].
simpl.
apply pointwise_continuity.
intros.
apply sum_continuous.
- apply continuous_func_continuous_everywhere,
        continuous_constant.
- now apply const_multiple_continuous,
            continuous_func_continuous_everywhere.
Qed.

End extension_approximation.

Lemma missing_pow_mult: forall (x y:R) (n:nat),
  (x*y)^n = x^n * y^n.
Proof.
induction n.
- lra.
- simpl.
  rewrite IHn.
  lra.
Qed.

Definition extension_approximation_seq: forall n:nat,
  { g0:X -> RTop |
    continuous g0 /\
    (forall x:X, -1 + (2/3)^n <= g0 x <= 1 - (2/3)^n) /\
    (forall x:SubspaceTopology F,
      -(2/3)^n <= f x - g0 (subspace_inc F x) <= (2/3)^n) }.
simple refine (fix g (n:nat) {struct n} := match n return
  { g0:X -> RTop |
    continuous g0 /\
    (forall x:X, -1 + (2/3)^n <= g0 x <= 1 - (2/3)^n) /\
    (forall x:SubspaceTopology F,
      -(2/3)^n <= f x - g0 (subspace_inc F x) <= (2/3)^n) } with
| O => exist _ (fun _ => 0) _
| S m => match g m with
         | exist gm y =>
         let H := _ in
         let approx := extension_approximation
                       (fun x:SubspaceTopology F =>
                       (3/2)^m * (f x - gm (subspace_inc F x))) H in
         exist _ (fun x:X => gm x + (2/3)^m * approx x) _
         end
end); clear g; [ | | clearbody H ].
- simpl.
  split.
  + apply continuous_constant.
  + split; intros.
    * lra.
    * destruct (f_bound x).
      lra.
- apply pointwise_continuity.
  intros.
  apply const_multiple_continuous.
  apply diff_continuous.
  + now apply continuous_func_continuous_everywhere.
  + apply continuous_composition_at.
    * destruct y.
      now apply continuous_func_continuous_everywhere.
    * apply continuous_func_continuous_everywhere,
            subspace_inc_continuous.
- assert (H023m: 0 <= (2/3)^m).
  {
    apply pow_le. lra.
  }
  assert (H032m: 0 <= (3/2)^m).
  {
    apply pow_le. lra.
  }
  assert (forall x,
             -1 <= (3/2)^m * (f x - gm (subspace_inc F x)) <= 1).
  {
    intros.
    destruct y as [? []].
    destruct (H2 x).
    assert ((3/2)^m * (2/3)^m = 1).
    {
      rewrite <- missing_pow_mult.
      replace (3/2*(2/3)) with 1 by field.
      apply pow1.
    }
    replace (-1) with ((3/2)^m * (- (2/3)^m)) by lra.
    replace 1 with ((3/2)^m * (2/3)^m) by lra.
    auto with real.
  }
  assert (forall x, -1/3 <= approx x <= 1/3) by
    apply extension_approximation_bound.
  assert (forall x,
             -2/3 <= (3/2)^m * (f x - gm (subspace_inc F x)) -
                           approx (subspace_inc F x) <= 2/3) by
    now apply extension_approximation_diff_bound.
  destruct y as [? []].
  split.
  + apply pointwise_continuity.
    intros.
    apply sum_continuous.
    * now apply continuous_func_continuous_everywhere.
    * apply const_multiple_continuous.
      apply continuous_func_continuous_everywhere.
      apply extension_approximation_continuous.
  + split; intros.
    * destruct (H4 x), (H1 x).
      assert (0 <= (2/3)^m) by
        auto with real.
      assert ((2/3)^m * (-1/3) <= (2/3)^m * approx x <= (2/3)^m * (1/3)) by
        auto with real.
      simpl.
      lra.
    * simpl.
      replace (-(2/3*(2/3)^m)) with ((2/3)^m * (-2/3)) by field.
      replace (2/3*(2/3)^m) with ((2/3)^m * (2/3)) by ring.
      replace (f x - (gm (subspace_inc F x) + (2/3)^m * approx (subspace_inc F x)))
        with ((2/3)^m * ((3/2)^m * (f x - gm (subspace_inc F x)) -
                               approx (subspace_inc F x))).
      ** destruct (H2 x).
         auto with real.
      ** ring_simplify.
         replace ((2/3)^m*(3/2)^m) with 1.
         { ring. }
         rewrite <- missing_pow_mult.
         replace (2/3*(3/2)) with 1 by field.
         now rewrite pow1.
Defined.

Lemma extension_approximation_seq_diff: forall (n:nat) (x:X),
  -(1/3 * (2/3)^n) <= proj1_sig (extension_approximation_seq (S n)) x -
                      proj1_sig (extension_approximation_seq n) x
                   <= 1/3*(2/3)^n.
Proof.
intros.
simpl extension_approximation_seq.
destruct extension_approximation_seq.
simpl.
match goal with |- context [extension_approximation ?A ?B x] =>
  cut (-1/3 <= extension_approximation A B x <= 1/3);
  [ generalize (extension_approximation A B x) |
    apply extension_approximation_bound ] end.
intros.
assert (0 <= (2/3)^n).
{ apply pow_le. lra. }
replace (-(1/3*(2/3)^n)) with ((2/3)^n*(-1/3)) by field.
replace (1/3*(2/3)^n) with ((2/3)^n*(1/3)) by ring.
replace (x0 x + (2/3)^n*p - x0 x) with ((2/3)^n*p) by ring.
destruct H.
split;
  now apply Rmult_le_compat_l.
Qed.

(* now we've gotten what we need from the concrete definition, make
   it opaque so it doesn't slow down searches in the future *)
Global Opaque extension_approximation_seq.
Opaque extension_approximation_seq.

Lemma Rle_R1_pow: forall (x:R) (m n:nat), 0 <= x <= 1 -> (m <= n)%nat ->
  x^n <= x^m.
Proof.
induction 2;
  auto with real.
simpl.
replace (x^m) with (1*x^m) by
  auto with real.
destruct H.
apply Rmult_le_compat; trivial.
now apply pow_le.
Qed.

Lemma extension_approximation_seq_cauchy_aux:
  forall (m n:nat) (x:X),
  Rabs (proj1_sig (extension_approximation_seq m) x -
        proj1_sig (extension_approximation_seq n) x) <=
  Rabs ((2/3)^m - (2/3)^n).
Proof.
cut (forall (m n:nat) (x:X), (m <= n)%nat ->
  Rabs (proj1_sig (extension_approximation_seq m) x -
        proj1_sig (extension_approximation_seq n) x) <=
  (2/3)^m - (2/3)^n).
- intros.
  destruct (le_or_lt m n).
  + rewrite (Rabs_right ((2/3)^m - (2/3)^n)).
    { now apply H. }
    apply Rge_minus.
    cut ((2/3)^n <= (2/3)^m); auto with real.
    apply Rle_R1_pow; trivial.
    lra.
  + apply lt_le_weak in H0.
    rewrite (Rabs_left1 ((2/3)^m - (2/3)^n)).
    * replace (- ((2/3)^m - (2/3)^n)) with ((2/3)^n - (2/3)^m) by ring.
      rewrite Rabs_minus_sym.
      now apply H.
    * apply Rle_minus.
      apply Rle_R1_pow; trivial.
      lra.
- induction 1.
  + repeat match goal with |- context [ ?y - ?y ] =>
      replace (y-y) with 0 by ring end.
    rewrite Rabs_R0. lra.
  + simpl pow.
    apply Rle_trans with
      (Rabs (proj1_sig (extension_approximation_seq m) x -
             proj1_sig (extension_approximation_seq m0) x) +
       Rabs (proj1_sig (extension_approximation_seq m0) x -
             proj1_sig (extension_approximation_seq (S m0)) x)).
    * rewrite Rplus_comm.
      apply R_metric_is_metric.
    * pose proof (extension_approximation_seq_diff m0 x).
      cut (Rabs (proj1_sig (extension_approximation_seq m0) x -
                    proj1_sig (extension_approximation_seq (S m0)) x) <=
              1/3 * (2/3)^m0).
      { lra. }
      destruct H0.
      unfold Rabs.
      destruct Rcase_abs; lra.
Qed.

Definition convert_approx_to_uniform_space:
  nat -> uniform_space R_metric (fun _:X => 0).
refine (fun n:nat => exist _ (proj1_sig (extension_approximation_seq n)) _).
destruct extension_approximation_seq as [g [? []]].
simpl.
unfold R_metric.
exists (1 - (2/3)^n).
red. intros.
destruct H.
rewrite H0. clear y H0.
destruct (a x).
unfold Rabs.
destruct Rcase_abs; lra.
Defined.

Lemma extension_approximation_seq_cauchy:
  cauchy (uniform_metric R_metric (fun _:X => 0)
          R_metric_is_metric X_nonempty)
    convert_approx_to_uniform_space.
Proof.
red. intros.
assert (Rabs (2/3) < 1).
{ rewrite Rabs_right; lra. }
assert (0 < eps/2) by lra.
destruct (pow_lt_1_zero (2/3) H0 (eps/2) H1) as [N].
exists N.
intros.
apply Rle_lt_trans with (Rabs ((2/3)^m - (2/3)^n)).
- unfold uniform_metric, convert_approx_to_uniform_space.
  destruct sup.
  simpl.
  apply i.
  red. intros.
  destruct H5.
  rewrite H6. clear y H6.
  rewrite metric_sym.
  + apply extension_approximation_seq_cauchy_aux.
  + exact R_metric_is_metric.
- apply Rle_lt_trans with (Rabs ((2/3)^m) + Rabs((2/3)^n)).
  + rewrite <- (Rabs_Ropp ((2/3)^n)).
    unfold Rminus.
    apply Rabs_triang.
  + replace eps with (eps/2 + eps/2) by field.
    apply Rplus_lt_compat;
      now apply H2.
Qed.

Definition Tietze_extension_func : X -> RTop.
refine (proj1_sig (proj1_sig (constructive_definite_description
  (fun f:(UniformTopology R_metric (fun _:X => 0)
                    R_metric_is_metric X_nonempty) =>
  net_limit convert_approx_to_uniform_space f
    (I:=nat_DS) (X:=UniformTopology R_metric (fun _:X => 0)
                    R_metric_is_metric X_nonempty)) _))).
apply -> unique_existence.
split.
- assert (complete (uniform_metric R_metric (fun _:X => 0)
                      R_metric_is_metric X_nonempty)
            (uniform_metric_is_metric _ _ _ _ _ _)).
  { apply uniform_metric_complete.
    exact R_metric_complete. }
  apply H.
  exact extension_approximation_seq_cauchy.
- apply Hausdorff_impl_net_limit_unique.
  apply T3_sep_impl_Hausdorff.
  apply normal_sep_impl_T3_sep.
  apply metrizable_impl_normal_sep.
  exists (uniform_metric R_metric (fun _:X => 0)
            R_metric_is_metric X_nonempty).
  + apply (uniform_metric_is_metric _ _ R_metric (fun _:X => 0)
              R_metric_is_metric X_nonempty).
  + apply MetricTopology_metrized.
Defined.

Lemma Tietze_extension_func_bound: forall x:X,
  -1 <= Tietze_extension_func x <= 1.
Proof.
intros.
cut (Rabs (Tietze_extension_func x) <= 1).
{ intros.
  unfold Rabs in H.
  destruct Rcase_abs in H; lra. }
unfold Tietze_extension_func.
destruct constructive_definite_description as [[g]].
simpl.
assert (bound (Im Full_set (fun x:X => R_metric 0 0))).
{ exists 0.
  red. intros.
  destruct H.
  right.
  rewrite H0.
  apply R_metric_is_metric. }
apply Rle_trans with (uniform_metric _ _ R_metric_is_metric X_nonempty
                    (exist _ (fun _:X => 0) H)
                    (exist _ g b)).
- unfold uniform_metric.
  simpl.
  destruct sup.
  simpl.
  apply i.
  exists x.
  + constructor.
  + unfold R_metric.
    f_equal.
    auto with real.
- apply lt_plus_epsilon_le.
  intros.
  unshelve refine (let H1:=metric_space_net_limit_converse _ _ _ _ _ _ n eps H0 in _); [ | | clearbody H1 ]; shelve_unifiable.
  { apply MetricTopology_metrized. }
  destruct H1 as [N].
  refine (Rle_lt_trans _ _ _
    (triangle_inequality _ _ _ _ (convert_approx_to_uniform_space N) _) _).
  { apply uniform_metric_is_metric. }
  apply Rplus_lt_compat.
  + apply Rle_lt_trans with (1 - (2/3)^N).
    * unfold uniform_metric. simpl. destruct sup. simpl.
      apply i.
      red. intros.
      destruct H2.
      rewrite H3. clear y H3.
      unfold R_metric.
      destruct extension_approximation_seq as [h [? []]].
      destruct (a x1).
      simpl.
      unfold Rabs. destruct Rcase_abs; lra.
    * assert ((2/3)^N > 0).
      { apply pow_lt; lra. }
      lra.
  + rewrite metric_sym.
    * apply H1.
      constructor.
    * apply uniform_metric_is_metric.
Qed.

Lemma Tietze_extension_func_is_extension:
  forall x:SubspaceTopology F,
  Tietze_extension_func (subspace_inc F x) = f x.
Proof.
intros.
apply R_metric_is_metric.
apply Rle_antisym.
2: {
  apply Rge_le, metric_nonneg, R_metric_is_metric.
}
apply lt_plus_epsilon_le; intros.
unfold Tietze_extension_func;
  destruct constructive_definite_description as [[g]]; simpl.
assert (eps/2 > 0) by lra.
unshelve refine (let H1:=metric_space_net_limit_converse _ _ _ _ _ _ n (eps/2) H0
          in _); [ | | clearbody H1 ]; shelve_unifiable.
{ apply MetricTopology_metrized. }
destruct H1 as [N1].
assert (Rabs (2/3) < 1).
{ rewrite Rabs_right; lra. }
destruct (pow_lt_1_zero (2/3) H2 (eps/2) H0) as [N2].
pose (N := max N1 N2).
apply Rle_lt_trans with (R_metric (g (subspace_inc F x))
          (proj1_sig (extension_approximation_seq N) (subspace_inc F x)) +
  R_metric (proj1_sig (extension_approximation_seq N) (subspace_inc F x))
    (f x)).
{ apply triangle_inequality, R_metric_is_metric. }
replace (0+eps) with (eps/2+eps/2) by field.
apply Rplus_lt_compat.
- rewrite metric_sym; try apply R_metric_is_metric.
  assert (DS_ord N1 N) by apply le_max_l.
  apply Rle_lt_trans with (2:=H1 N H4).
  unfold uniform_metric; simpl; destruct sup; simpl.
  apply i.
  exists (subspace_inc F x).
  { constructor. }
  apply R_metric_is_metric.
- assert ((N >= N2)%nat) by apply le_max_r.
  apply Rle_lt_trans with (2:=H3 N H4).
  rewrite Rabs_right.
  + destruct extension_approximation_seq as [h [? []]]; simpl.
    unfold R_metric.
    destruct (a0 x).
    unfold Rabs; destruct Rcase_abs; lra.
  + apply Rle_ge, pow_le; lra.
Qed.

Let convert_continuity: forall h:X -> R,
  continuous h (Y:=RTop) <-> continuous h (Y:=MetricTopology R_metric
                                           R_metric_is_metric).
Proof.
assert (continuous (fun x:R => x)
  (X:=RTop) (Y:=MetricTopology R_metric R_metric_is_metric)).
{ apply pointwise_continuity.
  intros.
  apply metric_space_fun_continuity with R_metric R_metric;
    intros.
  - apply RTop_metrization.
  - apply MetricTopology_metrized.
  - now exists eps. }
assert (continuous (fun x:R => x)
  (X:=MetricTopology R_metric R_metric_is_metric) (Y:=RTop)).
{ apply pointwise_continuity.
  intros.
  apply metric_space_fun_continuity with R_metric R_metric;
    intros.
  - apply MetricTopology_metrized.
  - apply RTop_metrization.
  - now exists eps. }
intros.
split; intros.
- apply continuous_composition with (1:=H) (2:=H1).
- apply continuous_composition with (1:=H0) (2:=H1).
Qed.

Lemma Tietze_extension_func_continuous: continuous Tietze_extension_func.
Proof.
unfold Tietze_extension_func;
  destruct constructive_definite_description as [g];
  simpl.
apply net_limit_in_closure with
  (S:=fun h:UniformTopology R_metric (fun _:X => 0)
                          R_metric_is_metric X_nonempty =>
     continuous (proj1_sig h)
     (Y:=MetricTopology R_metric R_metric_is_metric)) in n.
- rewrite closure_fixes_closed in n.
  + unfold In in n.
    now apply <- convert_continuity.
  + apply continuous_functions_closed_in_uniform_metric.
- red. intros.
  exists i.
  split.
  + constructor.
  + red.
    unfold convert_approx_to_uniform_space. simpl.
    destruct extension_approximation_seq as [h [? []]]. simpl.
    now apply -> convert_continuity.
Qed.

End Tietze_extension_construction.

Lemma bounded_Tietze_extension_theorem: forall (X:TopologicalSpace)
  (F:Ensemble X) (f:SubspaceTopology F -> RTop),
  normal_sep X -> closed F -> continuous f ->
  (forall x:SubspaceTopology F, -1 <= f x <= 1) ->
  exists g:X -> RTop,
    continuous g /\ (forall x:SubspaceTopology F,
                     g (subspace_inc F x) = f x) /\
    (forall x:X, -1 <= g x <= 1).
Proof.
intros.
destruct (classic (inhabited X)) as [Hinh|Hempty].
- destruct (choice (fun
    (FG:{FG:Ensemble X * Ensemble X | let (F,G):=FG in
                      closed F /\ closed G /\ Intersection F G = Empty_set})
    (phi:X -> RTop) =>
     let (F,G):=proj1_sig FG in
     continuous phi /\ (forall x:X, 0 <= phi x <= 1) /\
     (forall x:X, In F x -> phi x = 0) /\
     (forall x:X, In G x -> phi x = 1))) as [choice_fun].
  + intros.
    destruct x as [[F' G] [? []]].
    now apply UrysohnsLemma.
  + pose (Urysohns_lemma_function := fun (F G:Ensemble X)
      (HF:closed F) (HG:closed G) (Hdisj:Intersection F G = Empty_set) =>
      exist (fun (f:X -> RTop) =>
               continuous f /\ (forall x:X, 0 <= f x <= 1) /\
               (forall x:X, In F x -> f x = 0) /\
               (forall x:X, In G x -> f x = 1))
        (choice_fun (exist _ (F,G) (conj HF (conj HG Hdisj))))
        (H3 (exist _ (F,G) (conj HF (conj HG Hdisj))))).
    clearbody Urysohns_lemma_function. clear choice_fun H3.
    exists (Tietze_extension_func X F H0 f H1 H2 Hinh
      Urysohns_lemma_function).
    split.
    * apply Tietze_extension_func_continuous.
    * split; intros.
      ** apply Tietze_extension_func_is_extension.
      ** apply Tietze_extension_func_bound.
- exists (fun x:X => False_rect _ (Hempty (inhabits x))).
  split.
  + apply pointwise_continuity.
    intros.
    destruct (Hempty (inhabits x)).
  + split;
      intros.
    * destruct x.
      destruct (Hempty (inhabits x)).
    * destruct (Hempty (inhabits x)).
Qed.

Lemma open_bounded_Tietze_extension_theorem: forall (X:TopologicalSpace)
  (F:Ensemble X) (f:SubspaceTopology F -> RTop),
  normal_sep X -> closed F -> continuous f ->
  (forall x:SubspaceTopology F, -1 < f x < 1) ->
  exists g:X -> RTop,
    continuous g /\ (forall x:SubspaceTopology F,
                     g (subspace_inc F x) = f x) /\
    (forall x:X, -1 < g x < 1).
Proof.
intros.
destruct (bounded_Tietze_extension_theorem _ F f) as [g0 [? []]]; trivial.
{ intros. split; left; apply H2. }
pose (G := characteristic_function_to_ensemble (fun x:X =>
  g0 x = 1 \/ g0 x = -1)).
destruct (UrysohnsLemma _ H G F) as [phi [? [? []]]]; trivial.
- replace G with (inverse_image g0 (Union (Singleton 1) (Singleton (-1)))).
  + red. rewrite <- inverse_image_complement.
    apply H3.
    apply (closed_union2 (X:=RTop)); apply Hausdorff_impl_T1_sep;
      apply T3_sep_impl_Hausdorff; apply normal_sep_impl_T3_sep;
      apply metrizable_impl_normal_sep; exists R_metric;
      (apply R_metric_is_metric || apply RTop_metrization).
  + extensionality_ensembles_inv;
      constructor.
    * now left.
    * now right.
    * destruct H7;
        [left | right ];
        now rewrite H6.
- extensionality_ensembles.
  assert (-1 < g0 x < 1).
  { change x with (subspace_inc F (exist _ x H7)).
    now rewrite H4. }
  lra.
- exists (fun x => phi x * g0 x).
  split.
  { apply pointwise_continuity.
    intros.
    apply product_continuous;
      now apply continuous_func_continuous_everywhere.
  }
  split.
  { intros.
    rewrite H9.
    - replace (1*g0 (subspace_inc F x)) with (g0 (subspace_inc F x)) by
        auto with real.
      apply H4.
    - now destruct x.
  }
  intros.
  apply and_comm, Rabs_def2.
  rewrite Rabs_mult.
  rewrite (Rabs_right (phi x));
    [ | apply Rle_ge; apply H7 ].
  destruct (classic (In G x)).
  { rewrite H8; trivial. lra. }
  assert (Rabs (g0 x) < 1).
  { assert (Rabs (g0 x) <= 1).
    { destruct (H5 x).
      unfold Rabs; destruct Rcase_abs; lra. }
    destruct H11; trivial.
    contradiction H10.
    unfold Rabs in H11.
    destruct Rcase_abs in H11;
      constructor.
    - lra.
    - now left. }
  destruct (H7 x).
  apply Rle_lt_trans with (Rabs (g0 x)); trivial.
  pattern (Rabs (g0 x)) at 2.
  replace (Rabs (g0 x)) with (1*Rabs (g0 x)) by
    auto with real.
  apply Rmult_le_compat_r; trivial.
  apply Rabs_pos.
Qed.

Theorem Tietze_extension_theorem: forall (X:TopologicalSpace)
  (F:Ensemble X) (f:SubspaceTopology F -> RTop),
  normal_sep X -> closed F -> continuous f ->
  exists g:X -> RTop,
    continuous g /\ (forall x:SubspaceTopology F,
                     g (subspace_inc F x) = f x).
Proof.
intros.
pose (U := characteristic_function_to_ensemble
      (fun x:RTop => -1 < x < 1)).
pose proof (open_interval_homeomorphic_to_real_line).
fold U in H2.
simpl in H2.
destruct H2 as [a [b]].
pose (f0 := fun x:SubspaceTopology F => subspace_inc U (a (f x))).
destruct (open_bounded_Tietze_extension_theorem X F f0) as [g0 [? []]];
  trivial.
- unfold f0.
  apply continuous_composition.
  + apply subspace_inc_continuous.
  + now apply continuous_composition.
- intros.
  unfold f0.
  destruct (a (f x)).
  now destruct i.
- assert (forall x:X, In U (g0 x)).
  { intros.
    constructor.
    apply H8. }
  pose (g0_U := continuous_factorization g0 U H9).
  assert (continuous g0_U) by
    now apply factorization_is_continuous.
  exists (fun x:X => b (g0_U x)).
  split.
  { now apply continuous_composition. }
  intros.
  unfold g0_U, continuous_factorization.
  generalize (H9 (subspace_inc F x)).
  rewrite H7.
  intros.
  replace (exist _ (f0 x) i) with (a (f x)) by
    now apply (proj1_sig_injective (In U)).
  apply H4.
Qed.


From mathcomp Require Import all_ssreflect all_algebra.
From mathcomp.analysis Require Import reals classical_sets boolp.
From mathcomp Require Import zify algebra_tactics.ring.
Require Import tactics mathcomp_extras.

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

Import GRing.Theory Num.Theory.
Open Scope classical_set_scope.
Open Scope real_scope.

(* Topological facts about sets of points in R^d,
 * in a more elementary way than mathcomp.analysis.topology. *)

Section PointTopo.

Variables (R : realType) (d : nat).
Notation point := 'M[R]_(1, d).

Section EuclidNorm.
Implicit Types (x y : point) (s t : R).
Open Scope ring_scope.

Definition norm (x : point) : R := Num.sqrt ((x *m x^T) ord0 ord0).

Lemma norm_scalel x (s : R) : norm (s *: x) = `|s| * norm x.
Proof.
  rewrite /norm trmx_scale scale_mulmx mxE -expr2 sqrtrM.
  by rewrite sqrtr_sqr.
  by rewrite sqr_ge0.
Qed.

Lemma norm_scaler x (s : R) : norm (s *: x) = norm x * `|s|.
Proof. by rewrite norm_scalel mulrC. Qed.

Lemma norm_ge0if x : (0 <= norm x ?= iff (x == 0))%R.
Proof.
  split ; first by rewrite sqrtr_ge0.
  apply /idP ; case: ifP => [/eqP ->|].
    by rewrite /norm mul0mx mxE sqrtr0.
  move /negbT => H ; apply /idP ; move: H ; apply contra.
  rewrite eq_sym /norm sqrtr_eq0 => xxT_le0.
  apply /eqP ; apply matrixP => i j ; rewrite mxE.
  have: i = 0 by case: i => [i Hi] ; apply val_inj => /= ; lia. move->.
  have xxT_ge0 : (x *m x^T) ord0 ord0 >= 0.
    by rewrite mxE ; apply sumr_ge0if => k _ ; rewrite mxE -expr2 sqr_ge0.
  have xxT_eq0 : (x *m x^T) ord0 ord0 == 0.
    by rewrite Order.POrderTheory.eq_le xxT_le0 xxT_ge0.
  clear xxT_ge0 xxT_le0 ; move: xxT_eq0.
  rewrite mxE eq_sym sumr_ge0if /= ; last first => [k _ | /forallP /(_ j)].
    by rewrite mxE -expr2 sqr_ge0.
  by rewrite mxE -expr2 sqrf_eq0 => /eqP ->.
Qed.

Lemma norm0 : norm 0 = 0.
Proof.
  move: (eqxx (GRing.zero (matrix_zmodType R 1 d))).
  by rewrite -norm_ge0if eq_sym => /eqP.
Qed.

Lemma normN x : norm (-x) = norm x.
Proof. by rewrite -scaleN1r norm_scalel normrN1 mul1r. Qed.

End EuclidNorm.

Section OpenSets.
Implicit Types (S : set point) (x : point).

(* A simple (i.e. without filters) definition of an open set of points *)
Definition openS_near S x :=
  exists2 eps : R, (eps > 0)%R & forall y, (norm (x - y) <= eps)%R -> S y.
Definition openS S := {in S, forall x, openS_near S x }.

Lemma openS_near_scale S x u :
  openS_near S x -> exists2 l, (l > 0)%R & S (x + l%:M *m u)%R.
Proof.
  rewrite /openS_near /= => [[eps eps_gt0 Heps]].
  case: (u =P 0)%R => [->|neq_u0].
    exists (GRing.one (Num.NumDomain.ringType R)) => //.
    rewrite mulmx0 addr0 ; apply Heps.
    by rewrite subrr norm0 ; apply Order.POrderTheory.ltW.
  have l_gt0 : (0 < eps / norm u)%R.
    apply mulr_gt0 ; rewrite ?invr_gt0 //.
    move: neq_u0=> /eqP ; apply contraR ; rewrite -Order.TotalTheory.leNgt => H.
    by rewrite -norm_ge0if Order.POrderTheory.eq_le H norm_ge0if.
  exists (eps / norm u)%R => //.
  apply Heps ; rewrite opprD addrA subrr sub0r normN mul_scalar_mx norm_scalel.
  rewrite gtr0_norm // -mulrA mulVr ?mulr1 //.
  by rewrite unitfE eq_sym norm_ge0if ; apply /eqP.
Qed.

Lemma openS_setT : openS (@setT point).
Proof.
  rewrite /openS /openS_near /= => x _.
  by exists (GRing.one (Num.NumDomain.ringType R)).
Qed.

Lemma le_min (x y z : R) : (x <= Num.min y z)%R <-> (x <= y)%R && (x <= z)%R.
Proof. Admitted.
  (*case: (Num.Theory.ltrP y z) => [/Order.POrderTheory.ltW|] Oyz ;
  apply is_true_inj ; apply propext ; split.
  - move=> le_xy. apply /andP ; split => //. Search transitive. apply Order.MeetJoinMixin.le_trans.*)

Lemma openS_near_cap m (P : set 'I_m) F x :
  (forall i, P i -> openS_near (F i) x) ->
  openS_near (\bigcap_(i in P) F i) x.
Proof.
  elim: m F P => [|m IH] F1 P1 Oi.
    exists (GRing.one (Num.NumDomain.ringType R)) => // y _ i.
    by rewrite (set_ord0 P1) /=.
  pose F0 := (fun i : 'I_m => F1 (widen_ord (leqnSn m) i)).
  pose P0 := [set i | P1 (widen_ord (leqnSn m) i)].
  have Oi' : forall i : 'I_m, P0 i -> openS_near (F0 i) x => [i|].
    by rewrite /P0 /F0 /= ; apply Oi.
  move: (Oi ord_max) (IH F0 P0 Oi') ; rewrite /openS_near /= => Om {}IH.
  case: (asboolP (P1 ord_max)) IH => P1om [e1 lt_0e1 IH] ;
  [move: P1om=> /Om [e2 lt_0e2 {}Om]|pose e2 := e1] ;
  exists (Num.min e1 e2) ; (try by case: (Num.Theory.ltrP e1 e2)) ;
  rewrite /bigcap /= => y /le_min/andP[le_De1 le_De2] i P1i ;
  move: (IH y le_De1) ; rewrite /bigcap /= => {}IH ;
  case: (widen_ordP i) P1i => [ |j] P1i.
  - by apply Om.
  - by apply IH ; rewrite /P0 //=.
  - by intuition.
  - by apply IH ; rewrite /P0 //=.
Qed.

Lemma openS_cap m (P : set 'I_m) F :
  (forall i, P i -> openS (F i)) -> openS (\bigcap_(i in P) F i).
Proof.
  rewrite /bigcap /openS /= => Oi x ; rewrite in_setE /= => Fx.
  apply openS_near_cap => /= i Pi ; apply Oi => //.
  by rewrite in_setE ; apply Fx.
Qed.

End OpenSets.

End PointTopo.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) : natural := mult lf2 (Succ x).


(** This file contains definitions of and lemmas about the real
functional model **)

From Coq Require Import ZArith Reals Psatz.
From Coq Require Import Arith.Arith.
From Coquelicot Require Import Coquelicot.
From mathcomp.analysis Require Import Rstruct.
From mathcomp Require Import matrix all_ssreflect all_algebra ssralg ssrnum bigop.

Set Bullet Behavior "Strict Subproofs".

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

From Iterative Require Import lemmas.
Import List ListNotations.

Open Scope R_scope.
Open Scope ring_scope.

Delimit Scope ring_scope with Ri.
Delimit Scope R_scope with Re.

Import Order.TTheory GRing.Theory Num.Def Num.Theory.

(*** Functional model for the iterative solution ***)

(** Specialized to the Jacobi iterate for the symmetric tridiagonal
    matrix:
    (1'h^2) [2 -1 0; -1 2 -1; 0 -1 2]
**)
(** define a tridiagonal system **)
Definition A (n:nat) (h:R) := \matrix_(i<n, j<n)
   if (i==j :> nat) then (2 / h^2) %Re else
      (if ((i-j)%N==1%N :>nat) then (-1 / h^2)%Re else
            (if ((j-i)%N==1%N :>nat) then (-1/ h^2)%Re else 0)).

Definition A1 (n:nat) (h:R) := \matrix_(i < n, j < n)
      if (i == j :> nat) then (A n h) i j else 0.

Definition A2 (n:nat) (h:R) := \matrix_(i < n, j < n)
  ((A n h) i j - (A1 n h) i j).

Definition inv_A1 (n:nat) (h:R) := \matrix_(i < n, j < n)
      if (i == j :> nat) then (1/ (A1 n h) i j) else 0.

Definition S_mat (n:nat) (h:R) := -(inv_A1 n h) *m (A2 n h).

Definition b_real : list R := [1;1;1].

Fixpoint X_m_real (m n:nat) (x0 b: 'cV[R]_n) (h:R) : 'cV[R]_n:=
  match m with
  | O => x0
  | S p => S_mat n h *m (X_m_real p x0 b h) + inv_A1 n h *m b
  end.

Lemma X_m_real_iter {n:nat} (k: nat) (x0 b: 'cV[R]_n) (h:R) :
    let xkr := X_m_real k x0 b h in
    X_m_real k.+1 x0 b h = X_m_real 1 xkr b h.
Proof. simpl; auto. Qed.

Close Scope R_scope.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREER SOFTWARE LICENSE AGREEMENT         *)
(**************************************************************)

Require Import List Arith Wellfounded.
Import ListNotations.

Set Implicit Arguments.

Section measure_rect.

  Variable (X : Type) (m : X -> nat) (P : X -> Type).

  Hypothesis F : forall x, (forall y, m y < m x -> P y) -> P x.

  Definition measure_rect x : P x.
  Proof.
    cut (Acc (fun x y => m x < m y) x); [ revert x | ].
    + refine (
        fix loop x Dx := @F x (fun y Dy => loop y _)
      ).
      apply (Acc_inv Dx), Dy.
    + apply wf_inverse_image with (f := m), lt_wf.
  Qed.

End measure_rect.

Tactic Notation "induction" "on" hyp(x) "as" ident(IH) "with" "measure" uconstr(f) :=
  pattern x; revert x; apply measure_rect with (m := fun x => f); intros x IH.

Section less_than_wf.

  Variable (X : Type) (R : X -> X -> Prop) (Rwf : well_founded R).

  Reserved Notation "l '<lex' m" (at level 70).  (* for lexicographic product *)
  Reserved Notation "l '<<' m" (at level 70).    (* for less than *)

  Inductive lex : list X -> list X -> Prop :=
    | lex_skip x l m : l <lex m -> x::l <lex x::m
    | lex_cons x y l m : length l = length m -> R x y -> x::l <lex y::m
  where "l <lex m" := (lex l m).

  Fact lex_length l m : l <lex m -> length l = length m.
  Proof. induction 1; simpl; auto. Qed.

  Fact lex_cons_inv l m :
          l <lex m
       -> match m with
            | [] => False
            | y::m =>
            match l with
              | [] => False
              | x::l => x = y /\ lex l m
                     \/ R x y /\ length l = length m
            end
          end.
  Proof. inversion 1; auto. Qed.

  (* Proof of Acc lex m by nested induction on:
       - induction the length of m (IHm)
       - if m = [] then finished (no l exists st l <lex [])
       - if m = x::m' then
         * we know Acc lex m' (by IHm)
         * induction on x using Rfw
         * induction on (Acc lex m')
  *)

  Theorem lex_wf : well_founded lex.
  Proof.
    intros m; induction on m as IHm with measure (length m).
    destruct m as [ | y m ].
    + constructor; intros l Hl; apply lex_cons_inv in Hl; easy.
    + revert m IHm.
      induction y as [ y IHy' ] using (well_founded_induction Rwf).
      intros m IHm.
      assert (Acc lex m) as Hm.
      1: apply IHm; simpl; auto.
      assert (forall x l, R x y -> length l = length m -> Acc lex (x::l)) as IHy.
      1: { intros x l Hx Hl; apply IHy'; auto.
           intros; apply IHm.
           simpl in *; rewrite <- Hl; auto. }
      clear IHy' IHm.
      revert Hm IHy.
      induction 1 as [ m Hm IHm ]; intros IHy.
      constructor; intros l Hl; apply lex_cons_inv in Hl.
      destruct l as [ | x l ]; try tauto.
      destruct Hl as [ (-> & Hl) | (Hx & Hl) ].
      * apply IHm; auto.
        apply lex_length in Hl as ->; auto.
      * apply IHy; auto.
  Qed.

  Inductive less_than : list X -> list X -> Prop :=
    | less_than_lt l m : length l < length m -> l << m
    | less_than_eq l m : lex l m -> l << m
  where "l << m" := (less_than l m).

  Fact less_than_inv l m : l << m -> length l < length m \/ lex l m.
  Proof. inversion 1; auto. Qed.

  Theorem less_than_wf : well_founded less_than.
  Proof.
    intros m.
    induction on m as IHm with measure (length m).
    revert IHm; generalize (lex_wf m).
    induction 1 as [ m Hm IHm ]; intros H.
    constructor; intros l Hl.
    apply less_than_inv in Hl as [ Hl | Hl ].
    + apply H; auto.
    + apply IHm; auto.
      intros; apply H.
      now apply lex_length in Hl as <-.
  Qed.

  Section less_than_rect.

    Variable (P : list X -> Type)
             (HP : forall m, (forall l, length l < length m -> P l)
                          -> (forall l, lex l m -> P l)
                          -> P m).

    Corollary less_than_rect m : P m.
    Proof.
      induction m as [ m IHm ] using (well_founded_induction_type less_than_wf).
      apply HP; intros; apply IHm.
      + now constructor 1.
      + now constructor 2.
    Qed.

  End less_than_rect.

End less_than_wf.


Require Import Lia.
Require Import NArith. Open Scope N_scope.

(* Type class definition *)
Module Type Bound.
  (* Type *)
  Parameter t : Type.

  (* Constants *)
  Parameter MIN : t.
  Parameter MAX : t.

  (* Computational functions *)
  Parameter pred : t -> t.
  Parameter succ : t -> t.

  (* Comparison operators *)
  Parameter eq : t -> t -> Prop.
  Parameter le : t -> t -> Prop.
  Parameter lt : t -> t -> Prop.

  (* Prove decidability of operators *)
  Axiom eq_dec : forall x y, {eq x y} + {~ eq x y}.
  Axiom le_dec : forall x y, {le x y} + {~ le x y}.
  Axiom lt_dec : forall x y, {lt x y} + {~ lt x y}.

  (* Properties of eq for use in proofs *)
  Axiom eq_refl : forall x, eq x x.

  (* Properties of le for use in proofs *)
  Axiom le_refl : forall x, le x x.
  Axiom le_antisymm : forall x y, le x y -> le y x -> x = y.
  Axiom le_trans : forall x y z, le x y -> le y z -> le x z.

  (* Properties of lt for use in proofs *)
  Axiom lt_irrefl : forall x, ~ lt x x.
  Axiom lt_asymm : forall x y, lt x y -> ~ lt y x.
  Axiom lt_trans : forall x y z, lt x y -> lt y z -> lt x z.

  (* Properties of bounds, relating constants, operators, and functions *)
  Axiom le_succ_r : forall x y, le x y -> le x (succ y).
  Axiom le_pred_l : forall x y, le x y -> le (pred x) y.
  Axiom le_pred_lt : forall x y, lt MIN x -> le x (pred y) -> lt x y.
  Axiom lt_succ_le : forall x y, lt x MAX -> le (succ x) y -> lt x y.
End Bound.

(* Type class instance *)
Module Byte <: Bound.

Record byte := mkbyte {
  val : N;
  range : val < 256;
}.

Definition t := byte.

Definition MIN : byte := mkbyte 0 eq_refl.
Definition MAX : byte := mkbyte 255 eq_refl.

Definition eq (x y : byte) : Prop := N.eq x.(val) y.(val).
Definition le (x y : byte) : Prop := N.le x.(val) y.(val).
Definition lt (x y : byte) : Prop := N.lt x.(val) y.(val).

Theorem eq_dec : forall x y, {eq x y} + {~ eq x y}.
Proof.
  unfold eq. destruct x, y. intros. cbn.
  destruct (N.eqb val0 val1) eqn:?.
  - left. now apply N.eqb_eq.
  - right. now apply N.eqb_neq.
Qed.

Theorem le_dec : forall x y, {le x y} + {~ le x y}.
Proof.
  unfold le. destruct x, y. intros. cbn.
  destruct (N.leb val0 val1) eqn:?.
  - left. now apply N.leb_le.
  - right. now apply N.leb_nle.
Qed.

Theorem lt_dec : forall x y, {lt x y} + {~ lt x y}.
Proof.
  unfold lt. destruct x, y. intros. cbn.
  destruct (N.ltb val0 val1) eqn:?.
  - left. now apply N.ltb_lt.
  - right. now apply N.ltb_nlt.
Qed.

Lemma N_succ_range : forall x, ~ eq x MAX -> N.succ x.(val) < 256.
Proof. unfold eq, N.eq. destruct x. cbn. lia. Qed.

Definition succ (x : byte) : byte :=
  match eq_dec x MAX with
  | left _ => x
  | right pf => mkbyte (N.succ x.(val)) (N_succ_range _ pf)
  end.

Definition pred (x : byte) : byte :=
  match eq_dec x MIN with
  | left _ => mkbyte (N.pred x.(val)) (N.lt_lt_pred _ _ x.(range))
  | right _ => x
  end.

Theorem eq_refl : forall x, eq x x. Admitted.

Theorem le_refl : forall x, le x x. Admitted.
Theorem le_antisymm : forall x y, le x y -> le y x -> x = y. Admitted.
Theorem le_trans : forall x y z, le x y -> le y z -> le x z. Admitted.

Theorem lt_irrefl : forall x, ~ lt x x. Admitted.
Theorem lt_asymm : forall x y, lt x y -> ~ lt y x. Admitted.
Theorem lt_trans : forall x y z, lt x y -> lt y z -> lt x z. Admitted.

Theorem le_succ_r : forall x y, le x y -> le x (succ y). Admitted.
Theorem le_pred_l : forall x y, le x y -> le (pred x) y. Admitted.
Theorem le_pred_lt : forall x y, lt MIN x -> le x (pred y) -> lt x y. Admitted.
Theorem lt_succ_le : forall x y, lt x MAX -> le (succ x) y -> lt x y. Admitted.

End Byte.


Require Import ssreflect Arith.
Require Import Arith.EqNat.
Require Import Arith.Compare_dec.
Require Import List.
Require Import Omega.

Definition var := nat.

Inductive term :=
| Var : var -> term
| Lambda: term -> term
| App: term -> term -> term.

Lemma lambda_equivalence: forall t u: term, t = u <-> (Lambda t = Lambda u).
Proof.
  move => t u.
  split;(move => h0).
  rewrite h0.
  done.
  inversion h0.
  trivial.
Qed.

Lemma app_equivalence: forall t u v w: term, App t u = App v w <-> (t = v) /\ (u = w).
Proof.
  move => t u v w.
  split.
  move => h0.
  split.
  inversion h0.
  done.
  inversion h0.
  done.
  move => [h0 h1].
  rewrite h0.
  rewrite h1.
  done.
Qed.

Fixpoint C (i: nat) (t: term): Prop :=
  match t with
    | Var v => (v < i)
    | App t1 t2 => (C i t1) /\ (C i t2)
    | Lambda t1 => C (i+1) t1
  end.

(*Question 1.2*)
Lemma ind_C_pred: forall t: term, forall n: nat, C n t -> C (n+1) t.
Proof.
  induction t.
  move => n.
  simpl.
  move => h0.
  Search _ (_<_).
  apply Plus.lt_plus_trans.
  done.
  move => n.
  simpl.
  move => h0.
  apply IHt.
  done.
  simpl.
  move => n.
  move => [h0 h1].
  split.
  apply IHt1.
  done.
  apply IHt2.
  done.
Qed.

(*
 ^ k
 |
 | n
 *)
(*Lifting used to do substitutions*)

Fixpoint lifting (n: nat) (k: nat) (t: term): term :=
  match t with
    | Var i => if leb k i then Var (i+n) else Var i
    | App t1 t2 => App (lifting n k t1) (lifting n k t2)
    | Lambda t1 => Lambda (lifting n (k+1) t1)
  end.

Fixpoint substitution (i: nat) (t1: term) (t2: term): term :=
  match t1 with
    | Var v => if beq_nat i v then t2 else Var v
    | App t3 t4 => App (substitution i t3 t2) (substitution i t4 t2)
    | Lambda t3 => Lambda (substitution (i+1) t3 (lifting 1 0 t2))
  end.

(*Same as lifting, only we do it in a list - equivalent to map (lifting n k) l*)
Fixpoint lift_all (n: nat) (k: nat) (l: list term): list term :=
  match l with
    | nil => nil
    | x :: xs => (lifting n k x) :: (lift_all n k xs)
  end.

Fixpoint multiple_substitution (i: nat) (t: term) (lu: list term): term :=
  match t with
    | Var v => if (leb i v) && (leb v (i+(length lu)-1)) then substitution v (Var v) (nth (v - i) lu (Var 0))  else Var v
    | App t1 t2 => App (multiple_substitution i t1 lu) (multiple_substitution i t2 lu)
    | Lambda t1 => Lambda (multiple_substitution (i+1) t1 (lift_all 1 0 lu))
  end.


Set Implicit Arguments.

Inductive mylist (a : Set) : nat -> Set :=
  MyNull : mylist a 0
| MyCons : forall n, a -> mylist a n -> mylist a (S n).

(* Require Import Coq.Program.Tactics Coq.Logic.JMeq. *)
(* Program  *)

Fixpoint append (a : Set) (k k' : nat) (x : mylist a k)
                (y : mylist a k') : mylist a (k+k') :=
  match x with
    MyNull _ => y
  | @MyCons _ p hd tl =>
      @MyCons _ _ hd (@append _ _ _ tl y)
end.

Print append.
Print mylist.

Fixpoint length a k (x : mylist a k) : nat :=
  match x with
 | MyNull _ => 0
 | MyCons hd tl => 1 + length tl
end.

Print length.

Definition bool_len n (x : mylist bool n) :=
  @length bool n x.

Print bool_len.

Ltac ByDefinition ident :=
  unfold ident; fold ident.

Require Import Omega.

Ltac ByLawsOfArithmetic' :=
try apply gt_Sn_n;
try apply eq_S.

Ltac ByLawsOfArithmetic :=
ByLawsOfArithmetic';
auto.

Theorem LowHanging : forall a k (x : mylist a k),
  @length a k x = k.

intros a k x.
induction x as [|n hd tl IH];
ByDefinition length;
ByLawsOfArithmetic.

  exact IH.

Qed.

(* Theorem LowHanging' : forall a k (x : mylist a k),
  @length a k x = k.

refine (fun a k x => _).
refine (match x with
          MyNull _ => _
        | @MyCons _ p hd tl => _
        end).
refine (ltac:(unfold length)).
refine (eq_refl 0).
refine (ltac:(unfold length)).
refine (ltac:(fold length)).
Print LowHanging.
 *)


Load "10_map_rev.v".

Definition prod_curry {X Y Z : Type}
  (f : X * Y -> Z) (x : X) (y : Y) : Z := f (x, y).

Definition prod_uncurry {X Y Z : Type}
  (f : X -> Y -> Z) (p : X * Y) : Z := f (fst p) (snd p).

Example test_map1': map (plus 3) [2;0;2] = [5;3;5].
Proof. reflexivity. Qed.

Check @prod_curry.
Check @prod_uncurry.

Theorem uncurry_curry : forall (X Y Z : Type)
                        (f : X -> Y -> Z)
                        x y,
  prod_curry (prod_uncurry f) x y = f x y.
Proof.
  intros X Y Z f x y.
  unfold prod_uncurry.
  unfold prod_curry.
  simpl.
  reflexivity.
Qed.

Lemma wat : forall (X Y : Type) (p : X * Y), (fst p, snd p) = p.
Proof.
  intros X Y p.
  destruct p. (* destructure *)
  simpl.
  reflexivity.
Qed.

Lemma wat' : forall (X Y : Type) (p : X * Y), (fst p, snd p) = p.
Proof.
  intros X Y p.
  case p. (* case analysis on the p : prod *)
  (* the only case is that it's a pair since it's the only constructor for prod *)
  intros proof_x proof_y.
  simpl.
  reflexivity.
Qed.

Print pair.
Print prod.

Check wat.
Search (forall (X Y : Type) (p : X * Y), (fst p, snd p) = p).

Theorem curry_uncurry : forall (X Y Z : Type)
                        (f : (X * Y) -> Z) (p : X * Y),
  prod_uncurry (prod_curry f) p = f p.
Proof.
  intros X Y Z f p.
  unfold prod_uncurry.
  unfold prod_curry.
  rewrite wat.
  reflexivity.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (lf2 : natural) : natural :=
  mult y (plus lf2 Zero).


Definition pierce := forall (p q : Prop),
  ((p -> q) -> p) -> p.

Definition lem := forall p, p\/ ~ p.

Theorem pierce_equiv_lem: pierce <-> lem.

Proof.
  unfold pierce, lem.
  firstorder.
  apply H with (q := ~ (p \/ ~p)).
  firstorder.
  destruct (H p).
  assumption.
  tauto.
Qed.


Require Export Init.Notations.
Require Import Init.Logic.
Require Import Init.Classical.
Require Import Init.Axiom.

(* Operators *)
Definition subset (A B: J) := (∀ x, x ∈ A → x ∈ B).
Notation   "x ⊆ y"         := (subset x y).

Definition proper_subset (A B: J) := ((subset A B) ∧ A ≠ B).
Notation   "x ⊂ y"                := (proper_subset x y).

Definition empty_c := (ex_outl ax_empty).
Notation   "∅"     := (empty_c).

Definition pair_c (A B: J) := (ex_outl (ax_pair A B)).
Notation   "`{ x , y }"    := (pair_c x y).

Definition singleton (A: J) := (pair_c A A).
Notation   "`{ x }"         := (singleton x).

Definition union_c (A: J) := (ex_outl (ax_union A)).
Notation   "∪ A "         := (union_c A).

Definition union2_c (A B: J) := (∪(`{A, B})).
Notation   "A ∪ B"           := (union2_c A B).

Definition power_c (A: J) := (ex_outl (ax_power A)).
Notation   "𝒫( x )"       := (power_c x).

Definition sub_c (P: J → Prop) (x: J) := (ex_outl (ax_subset P x)).
Notation   "{ x : A | P }"            := (sub_c (λ x, P) A).

Definition inter_c (A: J) := ({x: ∪A| ∀ a, a ∈ A → x ∈ a}).
Notation   "∩ A"          := (inter_c A).

Definition inter2_c (A B: J) := ({x: A| x ∈ B}).
Notation   "A ∩ B"           := (inter2_c A B).

Definition complement (A B : J) := ({x: A| x ∉ B}).
Notation   "A \ B"              := (complement A B).

Definition opair (A B: J) := `{`{A}, `{A, B}}.
Notation  "⟨ A , B ⟩"     := (opair A B).

Definition in_cp (x A B: J) := ∃ a, ∃ b, a ∈ A ∧ b ∈ B ∧ x = ⟨a, b⟩.
Definition cp (A B: J)      := {x: 𝒫(𝒫(A ∪ B))| in_cp x A B}.
Notation   "A ⨉ B"          := (cp A B).
(*----------------------------------------------------------------------------*)

(* Basic Properties *)

(* Subset *)
Lemma sub_a: ∀ A, ∀ B, A ⊆ B ∧ B ⊆ A → A = B.
Proof.
  intros A B [P1 P2].
  apply ax_exten.
  intro x.
  split.
  + apply (P1 x).
  + apply (P2 x).
Qed.

Lemma sub_r: ∀ A, A ⊆ A.
Proof.
  intros A x P.
  apply P.
Qed.

Lemma sub_t: ∀ A, ∀ B, ∀ C, A ⊆ B → B ⊆ C → A ⊆ C.
Proof.
  intros A B C P1 P2 x P3.
  apply ((P2 x) ((P1 x) P3)).
Qed.

Lemma sub_i_eq: ∀ A, ∀ B, A = B → A ⊆ B.
Proof.
  intros A B P1.
  apply (eq_cl _ P1).
  apply sub_r.
Qed.

Lemma ax_exten_reverse: ∀ A, ∀ B, A = B → (∀ x, x ∈  A ↔ x ∈  B).
Proof.
  intros A B P1 x.
  apply (eq_cl (λ s, x ∈ A ↔ x ∈ s) P1).
  apply iff_r.
Qed.

Lemma sub_reduce: ∀ₚ P, ∀ A, (∀ x, (P x) → x ∈ A) → (∃ B, ∀ y, y ∈ B ↔ (P y)).
Proof.
  intros P A P1.
  exists {x : A | P x}.
  intros x.
  destruct (ex_outr (ax_subset P A) x) as [P2 P3].
  split.
  + apply P2.
  + intros P4.
    apply P3.
    apply (and_i (P1 x P4) P4).
Qed.

Lemma sub_i: ∀ₚ P, ∀ A, ∀ x, x ∈ A → (P x) → x ∈ {y: A| P y}.
Proof.
  intros P A x P1 P2.
  destruct (ex_outr (ax_subset P A) x) as [_ P3].
  apply P3.
  apply (and_i P1 P2).
Qed.

Lemma sub_e: ∀ₚ P, ∀ A, ∀ x, x ∈  {y: A| P y} → x ∈ A ∧ (P x).
Proof.
  intros P A x P1.
  destruct (ex_outr (ax_subset P A) x) as [P2 _].
  apply (P2 P1).
Qed.

Lemma sub_e1: ∀ₚ P, ∀ A, {y: A| P y} ⊆ A.
Proof.
  intros P A x P1.
  destruct (sub_e _ _ _ P1) as [P2 _].
  apply P2.
Qed.
(*----------------------------------------------------------------------------*)

(* Non Equality *)
Lemma neq_e: ∀ A, ∀ B, A ≠ B → ∃ x, (x ∈ A ∧ x ∉  B) ∨ (x ∈ B ∧ x ∉  A).
Proof.
  intros A B.
  apply contraposition2.
  intros P1.
  apply sub_a.
  split.
  + intros x P2.
    destruct (not_or_and (not_ex_all_not _ P1 x)) as [P3 _].
    destruct (not_and_or P3) as [P4 | P4].
    - apply (bot_e _ (P4 P2)).
    - apply (nn_e P4).
  + intros x P2.
    destruct (not_or_and (not_ex_all_not _ P1 x)) as [_ P3].
    destruct (not_and_or P3) as [P4 | P4].
    - apply (bot_e _ (P4 P2)).
    - apply (nn_e P4).
Qed.

Lemma neq_i: ∀ A, ∀ B, ∀ x, x ∈ A → x ∉  B → A ≠ B.
Proof.
  intros A B x P1 P2 P3.
  apply (P2 (eq_cl _ P3 P1)).
Qed.
(*----------------------------------------------------------------------------*)

(* Proper Subset *)
Lemma psub_i: ∀ A, ∀ B, A ⊆ B → A ≠ B → A ⊂ B.
Proof.
  intros A B P1 P2.
  apply (and_i P1 P2).
Qed.

Lemma psub_i1: ∀ A, ∀ B, (∀ x, x ∈ A → x ∈ B) → (∃ y, y ∈ A ∧ y ∉  B) → A ⊂ B.
Proof.
  intros A B P1 [y [P2 P3]].
  split.
  + intros x P4.
    apply (P1 _ P4).
  + apply (neq_i _ _ _ P2 P3).
Qed.

Lemma psub_e: ∀ A, ∀ B, A ⊂ B → A ⊆ B.
Proof.
  intros A B [P1 _].
  apply P1.
Qed.

Lemma psub_e1: ∀ A, ∀ B, A ⊂ B → A ≠ B.
Proof.
  intros A B [_ P1].
  apply P1.
Qed.

Lemma psub_e2: ∀ A, ∀ B, A ⊂ B → ∃ x, x ∉ A ∧ x ∈ B.
Proof.
  intros A B [P1 P2].
  destruct (neq_e _ _ P2) as [x [[P3 P4] | [P3 P4]]].
  + apply bot_e.
    apply P4.
    apply (P1 _ P3).
  + exists x.
    apply (and_i P4 P3).
Qed.

Lemma psub_ir: ∀ A, ~ A ⊂ A.
Proof.
  intros A P1.
  apply (psub_e1 _ _ P1).
  apply eq_r.
Qed.

Lemma sub_e2: ∀ A, ∀ B, A ⊆ B → A ⊂ B ∨ A = B.
Proof.
  intros A B P1.
  destruct (LEM (A = B)) as [P2 | P2].
  + right.
    apply P2.
  + left.
    apply (psub_i _ _ P1 P2).
Qed.

Lemma psub_t: ∀ A, ∀ B, ∀ C, A ⊂ B → B ⊂ C → A ⊂ C.
Proof.
  intros A B C P1 P2.
  apply psub_i.
  + intros x P3.
    pose (psub_e _ _ P1 _ P3) as P4.
    apply (psub_e _ _ P2 _ P4).
  + destruct (psub_e2 _ _ P1) as [x [P3 P4]].
    apply neq_s.
    apply (neq_i _ _ x).
    - apply (psub_e _ _ P2 _ P4).
    - apply P3.
Qed.
(*----------------------------------------------------------------------------*)

(* Empty Set *)
Lemma empty_i: ∀ A, A ∉  ∅.
Proof.
  intro A.
  apply (ex_outr ax_empty A).
Qed.

Lemma empty_i1: ∀ A, ∅ ⊆ A.
Proof.
  intros A x P1.
  apply (bot_e _ (empty_i _ P1)).
Qed.

Lemma empty_unique: ∀ A, (∀ B, B ∉ A) → A = ∅ .
Proof.
  intros A P1.
  apply ax_exten.
  intro x.
  split.
  + intro P3.
    apply (bot_e _ (P1 _ P3)).
  + intro P3.
    apply (bot_e _ (empty_i _ P3)).
Qed.

Lemma nempty_ex: ∀ A, A ≠ ∅  → (∃ x, x ∈ A).
Proof.
  intros A.
  apply contraposition2.
  intro P1.
  apply empty_unique.
  apply not_ex_all_not.
  apply P1.
Qed.

Lemma ex_nempty: ∀ A, (∃ x, x ∈ A) → A ≠ ∅.
Proof.
  intros A [x P1] P2.
  apply (empty_i x).
  apply (eq_cl _ P2 P1).
Qed.

Lemma sub_empty: ∀ₚ P, ∀ A, ∀ t, {y: A| P y} = ∅ → t ∈ A → ~(P t).
Proof.
  intros P A t P1 P2 P3.
  apply (empty_i t).
  apply (eq_cl _ P1).
  apply (sub_i _ _ _ P2 P3).
Qed.

Lemma sub_empty_empty: ∀ S, S ⊆ ∅ → S = ∅.
Proof.
  intros S P1.
  apply sub_a.
  split.
  + intros x P2.
    apply (P1 _ P2).
  + intros x P2.
    apply bot_e.
    apply (empty_i _ P2).
Qed.
(*----------------------------------------------------------------------------*)

(* Power set *)
Lemma power_e: ∀ A, ∀ x, x ∈ 𝒫(A) → x ⊆ A.
Proof.
  intros A x P1 y P2.
  destruct (ex_outr (ax_power A) x) as [P3 _].
  apply (P3 P1 _ P2).
Qed.

Lemma power_i: ∀ A, ∀ x, x ⊆ A → x ∈ 𝒫(A).
Proof.
  intros A x P1.
  destruct (ex_outr (ax_power A) x) as [_ P2].
  apply (P2 P1).
Qed.

Lemma in_power: ∀ A, A ∈ 𝒫(A).
Proof.
  intros A.
  apply power_i.
  apply sub_r.
Qed.
(*----------------------------------------------------------------------------*)

(* Union *)
Lemma union_e: ∀ A, ∀ x, x ∈ ∪(A) → (∃ y, y ∈ A ∧ x ∈ y).
Proof.
  intros A x P1.
  destruct (ex_outr (ax_union A) x) as [P2 _].
  apply (P2 P1).
Qed.

Lemma union_i: ∀ A, ∀ x, (∃ y, y ∈ A ∧ x ∈ y) → x ∈ ∪(A).
Proof.
  intros A x P1.
  destruct (ex_outr (ax_union A) x) as [_ P2].
  apply (P2 P1).
Qed.

Lemma union_i2: ∀ A, ∀ x, x ∈ A → x ⊆ ∪A.
Proof.
  intros A x P1 s P2.
  apply union_i.
  exists x.
  apply (and_i P1 P2).
Qed.
(*----------------------------------------------------------------------------*)

(* Pair and Singleton *)
Lemma pair_e: ∀ A, ∀ B, ∀ x, x ∈ `{A, B} → x = A ∨ x = B.
Proof.
  intros A B x P1.
  destruct (ex_outr (ax_pair A B) x) as [P2 _].
  apply (P2 P1).
Qed.

Lemma pair_il: ∀ A, ∀ B, A ∈ `{A, B}.
Proof.
  intros A B.
  destruct (ex_outr (ax_pair A B) A) as [_ P2].
  apply P2.
  left.
  apply eq_r.
Qed.

Lemma pair_ir: ∀ A, ∀ B, B ∈ `{A, B}.
Proof.
  intros A B.
  destruct (ex_outr (ax_pair A B) B) as [_ P2].
  apply P2.
  right.
  apply eq_r.
Qed.

Lemma pair_s: ∀ A, ∀ B, `{A, B} = `{B, A}.
Proof.
  intros A B.
  apply sub_a.
  split.
  + intros x P1.
    destruct (pair_e _ _ _ P1) as [P2 | P2].
    - apply (eq_cr (λ y, y ∈ `{B, A}) P2).
      apply pair_ir.
    - apply (eq_cr (λ y, y ∈ `{B, A}) P2).
      apply pair_il.
  + intros x P1.
    destruct (pair_e _ _ _ P1) as [P2 | P2].
    - apply (eq_cr (λ y, y ∈ `{A, B}) P2).
      apply pair_ir.
    - apply (eq_cr (λ y, y ∈ `{A, B}) P2).
      apply pair_il.
Qed.

Lemma pair_eql: ∀ A, ∀ B, ∀ C, ∀ D, `{A, B} = `{C, D} → A = C ∨ A = D.
Proof.
  intros A B C D P1.
  pose (pair_il A B) as P2.
  pose (eq_cl _ P1 P2) as P3.
  apply (pair_e _ _ _ P3).
Qed.

Lemma pair_eqr: ∀ A, ∀ B, ∀ C, ∀ D, `{A, B} = `{C, D} → B = C ∨ B = D.
Proof.
  intros A B C D P1.
  pose (pair_ir A B) as P2.
  pose (eq_cl _ P1 P2) as P3.
  apply (pair_e _ _ _ P3).
Qed.

Lemma sing_i: ∀ A, A ∈ `{A}.
Proof.
  intros A.
  destruct (ex_outr (ax_pair A A) A) as [_ P1].
  apply P1.
  left.
  apply eq_r.
Qed.

Lemma sing_i2: ∀ A, ∀ B, A = B → A ∈ `{B}.
Proof.
  intros A B P1.
  apply (eq_cl (λ x, A ∈ `{x}) P1).
  apply sing_i.
Qed.

Lemma sing_e: ∀ A, ∀ B, B ∈ `{A} → A = B.
Proof.
  intros A B P1.
  destruct (ex_outr (ax_pair A A) B) as [P2 _].
  destruct (P2 P1) as [P3 | P3].
  + apply eq_s.
    apply P3.
  + apply eq_s.
    apply P3.
Qed.

Lemma nsing_i: ∀ A, ∀ B, A ≠ B → B ∉ `{A}.
Proof.
  intros A B.
  apply contraposition1.
  apply sing_e.
Qed.

Lemma nsing_e: ∀ A, ∀ B, B ∉ `{A} → A ≠ B.
Proof.
  intros A B.
  apply contraposition1.
  intros P1.
  generalize (eq_s P1).
  apply sing_i2.
Qed.

Lemma sing_sub_i: ∀ A, ∀ B, A ∈ B → `{A} ⊆ B.
Proof.
  intros A B P1 x P2.
  apply (eq_cl (λ x, x ∈ B) (sing_e _ _ P2)).
  apply P1.
Qed.

Lemma sing_sub_e: ∀ A, ∀ B, `{A} ⊆ B → A ∈ B.
Proof.
  intros A B P1.
  apply P1.
  apply sing_i.
Qed.

Lemma sing_nempty: ∀ A, `{A} ≠ ∅.
Proof.
  intros A.
  apply ex_nempty.
  exists A.
  apply sing_i.
Qed.

Lemma sing_pair_eq1: ∀ A, ∀ B, ∀ C, `{A} = `{B, C} → A = B.
Proof.
  intros A B C P1.
  apply sing_e.
  apply (eq_cr _ P1).
  apply pair_il.
Qed.

Lemma sing_pair_eq2: ∀ A, ∀ B, ∀ C, `{A} = `{B, C} → A = C.
Proof.
  intros A B C P1.
  pose (eq_t P1 (pair_s B C)) as P2.
  apply (sing_pair_eq1 _ _ _ P2).
Qed.

Lemma sing_pair_eq3: ∀ A, ∀ B, ∀ C, `{A} = `{B, C} → B = C.
Proof.
  intros A B C P1.
  pose (eq_s (sing_pair_eq1 _ _ _ P1)) as P2.
  pose (sing_pair_eq2 _ _ _ P1) as P3.
  apply (eq_t P2 P3).
Qed.

Lemma sing_eq: ∀ A, ∀ B, `{A} = `{B} → A = B.
Proof.
  intros A B P1.
  apply sing_e.
  apply (eq_cr _ P1).
  apply sing_i.
Qed.
(*----------------------------------------------------------------------------*)

(* Union of Two *)
Lemma union2_e: ∀ A, ∀ B, ∀ x, x ∈ A ∪ B → x ∈ A ∨ x ∈ B.
Proof.
  intros A B x P1.
  destruct (union_e _ _ P1) as [a [P2 P3]].
  destruct (pair_e _ _ _ P2) as [P4 | P4].
  + left.
    apply (eq_cl (λ y, x ∈ y) P4).
    apply P3.
  + right.
    apply (eq_cl (λ y, x ∈ y) P4).
    apply P3.
Qed.

Lemma union2_il: ∀ A, ∀ B, ∀ x, x ∈ A → x ∈ A ∪ B.
Proof.
  intros A B x P1.
  apply union_i.
  exists A.
  split.
  + apply pair_il.
  + apply P1.
Qed.

Lemma union2_ir: ∀ A, ∀ B, ∀ x, x ∈ B → x ∈ A ∪ B.
Proof.
  intros A B x P1.
  apply union_i.
  exists B.
  split.
  + apply pair_ir.
  + apply P1.
Qed.

Lemma union2_en: ∀ A, ∀ B, ∀ x, x ∉ A ∪ B → x ∉ A ∧ x ∉ B.
Proof.
  intros A B x P1.
  split.
  + intros P2.
    apply P1.
    apply (union2_il _ _ _ P2).
  + intros P2.
    apply P1.
    apply (union2_ir _ _ _ P2).
Qed.

Lemma union2_s: ∀ A, ∀ B, A ∪ B = B ∪ A.
Proof.
  intros A B.
  apply sub_a.
  split.
  + intros x P1.
    destruct (union2_e _ _ _ P1) as [P2 | P2].
    - apply (union2_ir _ _ _ P2).
    - apply (union2_il _ _ _ P2).
  + intros x P1.
    destruct (union2_e _ _ _ P1) as [P2 | P2].
    - apply (union2_ir _ _ _ P2).
    - apply (union2_il _ _ _ P2).
Qed.

Lemma union2_sub: ∀ A, ∀ B, ∀ C, A ⊆ C → B ⊆ C → A ∪ B ⊆ C.
Proof.
  intros A B C P1 P2 x P3.
  destruct (union2_e _ _ _ P3) as [P4 | P4].
  + apply (P1 _ P4).
  + apply (P2 _ P4).
Qed.

Lemma union2_sub_l: ∀ A, ∀ B, A ⊆ A ∪ B.
Proof.
  intros A B x P1.
  apply union2_il.
  apply P1.
Qed.

Lemma union2_sub_r: ∀ A, ∀ B, B ⊆ A ∪ B.
Proof.
  intros A B x P1.
  apply union2_ir.
  apply P1.
Qed.

Lemma union2_sub_absorb_l: ∀ A, ∀ B, A ⊆ B → A ∪ B = B.
Proof.
  intros A B P1.
  apply sub_a.
  split.
  + intros x P2.
    destruct (union2_e _ _ _ P2) as [P3 | P3].
    - apply (P1 _ P3).
    - apply P3.
  + intros x P2.
    apply (union2_ir _ _ _ P2).
Qed.

Lemma union2_sub_absorb_r: ∀ A, ∀ B, A ⊆ B → B ∪ A = B.
Proof.
  intros A B P1.
  apply (eq_t (union2_s B A)).
  apply (union2_sub_absorb_l _ _ P1).
Qed.

Lemma union2_empty_absorb_l: ∀ A, ∅ ∪ A = A.
Proof.
  intros A.
  apply sub_a.
  split.
  + intros x P1.
    destruct (union2_e _ _ _ P1) as [P2 | P2].
    - apply bot_e.
      apply (empty_i _ P2).
    - apply P2.
  + intros x P1.
    apply (union2_ir _ _ _ P1).
Qed.

Lemma union2_empty_absorb_r: ∀ A, A ∪ ∅ = A.
Proof.
  intros A.
  apply (eq_t (union2_s A ∅)).
  apply union2_empty_absorb_l.
Qed.

Lemma union2_sub_weak_l: ∀ A, ∀ B, ∀ C, C ⊆ A → C ⊆ (A ∪ B).
Proof.
  intros A B C P1 x P2.
  apply union2_il.
  apply (P1 _ P2).
Qed.

Lemma union2_sub_weak_r: ∀ A, ∀ B, ∀ C, C ⊆ B → C ⊆ (A ∪ B).
Proof.
  intros A B C P1 x P2.
  apply union2_ir.
  apply (P1 _ P2).
Qed.

Lemma union2_sub_preserve_l: ∀ A, ∀ A', ∀ B, A ⊆ A' → A ∪ B ⊆ A' ∪ B.
Proof.
  intros A A' B P1 x P2.
  destruct (union2_e _ _ _ P2) as [P3 | P3].
  + apply (union2_il _ _ _ (P1 _ P3)).
  + apply (union2_ir _ _ _ P3).
Qed.

Lemma union2_sub_preserve_r: ∀ A, ∀ B, ∀ B', B ⊆ B' → A ∪ B ⊆ A ∪ B'.
  intros A A' B P1 x P2.
  destruct (union2_e _ _ _ P2) as [P3 | P3].
  + apply (union2_il _ _ _ P3).
  + apply (union2_ir _ _ _ (P1 _ P3)).
Qed.

Lemma union2_sing_e: ∀ A, ∀ a, ∀ x, x ∈ A ∪ `{a} → x ∈ A ∨ x = a.
Proof.
  intros A a x P1.
  destruct (union2_e _ _ _ P1) as [P2 | P2].
  + left.
    apply P2.
  + right.
    apply (eq_s (sing_e _ _ P2)).
Qed.

Lemma union2_sing_il: ∀ A, ∀ a, ∀ x, x ∈ A → x ∈ A ∪ `{a}.
Proof.
  intros A a x.
  apply union2_il.
Qed.

Lemma union2_sing_ir: ∀ A, ∀ a, a ∈ A ∪ `{a}.
Proof.
  intros A a.
  apply union2_ir.
  apply sing_i.
Qed.
(*----------------------------------------------------------------------------*)

(* Intersection *)
Lemma inter_e: ∀ A, ∀ x, x ∈ ∩A → (∀ a, a ∈ A → x ∈ a).
Proof.
  intros A x P1 a P2.
  destruct (sub_e _ _ _ P1) as [_ P3].
  apply (P3 _ P2).
Qed.

Lemma inter_i: ∀ A, ∀ x, A ≠ ∅ → (∀ a, a ∈ A → x ∈ a) → x ∈ ∩A.
Proof.
  intros A x P1 P2.
  apply sub_i.
  + apply union_i.
    destruct (nempty_ex _ P1) as [a P3].
    exists a.
    split.
    - apply P3.
    - apply (P2 _ P3).
  + apply P2.
Qed.

Lemma inter_sub: ∀ A, ∀ a, a ∈ A → ∩A ⊆ a.
Proof.
  intros A a P1 x P2.
  apply (inter_e _ _ P2 _ P1).
Qed.
(*----------------------------------------------------------------------------*)

(* Intersection of Two *)
Lemma inter2_e: ∀ A, ∀ B, ∀ x, x ∈ A ∩ B → x ∈ A ∧ x ∈ B.
Proof.
  intros A B.
  apply sub_e.
Qed.

Lemma inter2_i: ∀ A, ∀ B, ∀ x, x ∈ A → x ∈ B → x ∈ A ∩ B.
Proof.
  intros A B.
  apply sub_i.
Qed.

Lemma inter2_s: ∀ A, ∀ B, A ∩ B = B ∩ A.
Proof.
  intros A B.
  apply sub_a.
  split.
  + intros x P1.
    destruct (inter2_e _ _ _ P1) as [P2 P3].
    apply (inter2_i _ _ _ P3 P2).
  + intros x P1.
    destruct (inter2_e _ _ _ P1) as [P2 P3].
    apply (inter2_i _ _ _ P3 P2).
Qed.

Lemma inter2_sub_l: ∀ A, ∀ B, A ∩ B ⊆ A.
Proof.
  intros A B x P1.
  destruct (inter2_e _ _ _ P1) as [P2 _].
  apply P2.
Qed.

Lemma inter2_sub_r: ∀ A, ∀ B, A ∩ B ⊆ B.
Proof.
  intros A B.
  apply (eq_cl (λ x, x ⊆ B) (inter2_s B A)).
  apply inter2_sub_l.
Qed.

Lemma inter2_absorb_l: ∀ A, ∀ B, A ⊆ B → A ∩ B = A.
Proof.
  intros A B P1.
  apply sub_a.
  split.
  + intros x P2.
    destruct (inter2_e _ _ _ P2) as [P3 _].
    apply P3.
  + intros x P2.
    apply inter2_i.
    - apply P2.
    - apply (P1 _ P2).
Qed.

Lemma inter2_absorb_r: ∀ A, ∀ B, B ⊆ A → A ∩ B = B.
Proof.
  intros A B P1.
  apply (eq_cr (λ x, x = B) (inter2_s _ _)).
  apply (inter2_absorb_l _ _ P1).
Qed.

Lemma inter2_eq_sub_l: ∀ A, ∀ B, A ∩ B = A → A ⊆ B.
Proof.
  intros A B P1 x P2.
  pose (eq_cr (λ y, x ∈ y) P1 P2) as P3.
  destruct (inter2_e _ _ _ P3) as [_ P4].
  apply P4.
Qed.

Lemma inter2_eq_sub_r: ∀ A, ∀ B, A ∩ B = B → B ⊆ A.
Proof.
  intros A B P1.
  apply inter2_eq_sub_l.
  apply (eq_cr (λ x, x = B) (inter2_s _ _)).
  apply P1.
Qed.

Lemma inter2_empty: ∀ A, ∀ B, (∀ x, x ∈ A → x ∉ B) → A ∩ B = ∅.
Proof.
  intros A B P1.
  apply sub_a.
  split.
  + intros x P2.
    destruct (inter2_e _ _ _ P2) as [P3 P4].
    apply bot_e.
    apply (P1 _ P3 P4).
  + intros x P2.
    apply bot_e.
    apply (empty_i _ P2).
Qed.

Lemma sub_inter2: ∀ A, ∀ B, ∀ C, C ⊆ A → C ⊆ B → C ⊆ A ∩ B.
Proof.
  intros A B C P1 P2 x P3.
  apply inter2_i.
  + apply (P1 x P3).
  + apply (P2 x P3).
Qed.

Lemma sub_inter2_el: ∀ A, ∀ B, ∀ C, C ⊆ A ∩ B → C ⊆ A.
Proof.
  intros A B C P1 x P2.
  destruct (inter2_e _ _ _ (P1 x P2)) as [P3 _].
  apply P3.
Qed.

Lemma sub_inter2_er: ∀ A, ∀ B, ∀ C, C ⊆ A ∩ B → C ⊆ B.
Proof.
  intros A B C.
  apply (eq_cl (λ x, C ⊆ x → C ⊆ B) (inter2_s B A)).
  apply sub_inter2_el.
Qed.

Lemma disjoint_selection: ∀ A, ∀ B, ∀ x, A ∩ B = ∅ → x ∈ A ∪ B →
  (x ∈ A ∧ x ∉  B) ∨ (x ∈ B ∧ x ∉  A).
Proof.
  intros A B x P1 P2.
  destruct (union2_e _ _ _ P2) as [P3 | P3].
  + left.
    split.
    - apply P3.
    - intros P4.
      apply bot_e.
      apply (empty_i x).
      apply (eq_cl _ P1).
      apply (inter2_i _ _ _ P3 P4).
  + right.
    split.
    - apply P3.
    - intros P4.
      apply bot_e.
      apply (empty_i x).
      apply (eq_cl _ P1).
      apply (inter2_i _ _ _ P4 P3).
Qed.
(*----------------------------------------------------------------------------*)

(* Complement *)
Lemma compl_i: ∀ A, ∀ B, ∀ x, x ∈ A → x ∉  B → x ∈ A \ B.
Proof.
  intros A B x P1 P2.
  apply (sub_i _ _ _ P1 P2).
Qed.

Lemma compl_e: ∀ A, ∀ B, ∀ x, x ∈ A \ B → x ∈ A ∧ x ∉  B.
Proof.
  intros A B x P1.
  apply (sub_e _ _ _ P1).
Qed.

Lemma compl_exchange: ∀ A, ∀ B, ∀ C, A \ B \ C = A \ C \ B.
Proof.
  intros A B C.
  apply sub_a.
  split.
  + intros x P1.
    destruct (compl_e _ _ _ P1) as [P2 P3].
    destruct (compl_e _ _ _ P2) as [P4 P5].
    apply compl_i.
    - apply compl_i.
      * apply P4.
      * apply P3.
    - apply P5.
  + intros x P1.
    destruct (compl_e _ _ _ P1) as [P2 P3].
    destruct (compl_e _ _ _ P2) as [P4 P5].
    apply compl_i.
    - apply compl_i.
      * apply P4.
      * apply P3.
    - apply P5.
Qed.

Lemma compl_inter2: ∀ A, ∀ B, A ∩ (B \ A) = ∅.
Proof.
  intros A B.
  apply sub_a.
  split.
  + intros x P1.
    destruct (inter2_e _ _ _ P1) as [P2 P3].
    destruct (compl_e _ _ _ P3) as [_ P4].
    apply (bot_e _ (P4 P2)).
  + intros x P1.
    apply (bot_e _ (empty_i _ P1)).
Qed.

Lemma compl_inter2_2: ∀ A, ∀ B, A ∩ (A \ B)= A \ B.
Proof.
  intros A B.
  apply sub_a.
  split.
  + intros x P1.
    destruct (inter2_e _ _ _ P1) as [_ P2].
    apply P2.
  + intros x P1.
    destruct (compl_e _ _ _ P1) as [P2 _].
    apply inter2_i.
    - apply P2.
    - apply P1.
Qed.

Lemma compl_dilemma: ∀ A, ∀ B, ∀ x, x ∈ A → x ∈ A ∩ B ∨ x ∈ A \ B.
Proof.
  intros A B x P1.
  destruct (LEM (x ∈ B)) as [P2 | P2].
  + left.
    apply (inter2_i _ _ _ P1 P2).
  + right.
    apply (compl_i _ _ _ P1 P2).
Qed.

Lemma compl_union2: ∀ A, ∀ B, A ∪ (B \ A) = A ∪ B.
Proof.
  intros A B.
  apply sub_a.
  split.
  + intros x P1.
    destruct (union2_e _ _ _ P1) as [P2 | P2].
    - apply (union2_il _ _ _ P2).
    - destruct (compl_e _ _ _ P2) as [P3 _].
      apply (union2_ir _ _ _ P3).
  + intros x P1.
    destruct (union2_e _ _ _ P1) as [P2 | P2].
    - apply (union2_il _ _ _ P2).
    - destruct (LEM (x ∈ A)) as [P3 | P3].
      * apply (union2_il _ _ _ P3).
      * apply (union2_ir _ _ _ (compl_i _ _ _ P2 P3)).
Qed.

Lemma compl_sub: ∀ A, ∀ B, (A \ B) ⊆ A.
Proof.
  intros A B x P1.
  destruct (compl_e _ _ _ P1) as [P2 _].
  apply P2.
Qed.

Lemma compl_psub: ∀ A, ∀ B, B ⊆ A → B ≠ ∅ → A \ B ⊂ A.
Proof.
  intros A B P1 P2.
  apply psub_i.
  + apply compl_sub.
  + intros P3.
    destruct (nempty_ex _ P2) as [x P4].
    pose (eq_cr (λ y, x ∈ y) P3 (P1 _ P4)) as P5.
    destruct (compl_e _ _ _ P5) as [_ P6].
    apply (P6 P4).
Qed.

Lemma compl_sub_reverse: ∀ A, ∀ B1, ∀ B2, B1 ⊆ B2 → A \ B2 ⊆ A \ B1.
Proof.
  intros A B1 B2 P1 x P2.
  destruct (compl_e _ _ _ P2) as [P3 P4].
  apply compl_i.
  + apply P3.
  + intros P5.
    apply P4.
    apply (P1 _ P5).
Qed.

Lemma compl_psub_ex: ∀ A, ∀ B, A ⊂ B → ∃ x, x ∈ B \ A.
Proof.
  intros A B [P1 P2].
  destruct (neq_e _ _ P2) as [x P3].
  exists x.
  destruct P3 as [[P3 P4] | [P3 P4]].
  + apply (bot_e _ (P4 (P1 _ P3))).
  + apply (compl_i _ _ _ P3 P4).
Qed.

Lemma compl_psub_nempty: ∀ A, ∀ B, A ⊂ B → B \ A ≠ ∅.
Proof.
  intros A B P1.
  apply ex_nempty.
  apply (compl_psub_ex _ _ P1).
Qed.

Lemma compl_empty: ∀ A, ∀ B, A \ B = ∅ → A ⊆ B.
Proof.
  intros A B P1 x P2.
  apply nn_e.
  intros P3.
  apply (empty_i x).
  apply (eq_cl (λ s, x ∈ s) P1).
  apply (compl_i _ _ _ P2 P3).
Qed.

Lemma compl_union2_annihilate: ∀ A, ∀ B, B ⊆ A → (A \ B) ∪ B = A.
Proof.
  intros A B P1.
  apply sub_a.
  split.
  + intros x P2.
    destruct (union2_e _ _ _ P2) as [P3 | P3].
    - destruct (compl_e _ _ _ P3) as [P4 _].
      apply P4.
    - apply (P1 _ P3).
  + intros x P2.
    destruct (LEM (x ∈ B)) as [P3 | P3].
    - apply union2_ir.
      apply P3.
    - apply union2_il.
      apply compl_i.
      * apply P2.
      * apply P3.
Qed.
(*----------------------------------------------------------------------------*)

(* Order Pairs *)
Lemma opair_e: ∀ A, ∀ B, ∀ x, x ∈ ⟨A, B⟩ → x = `{A} ∨ x = `{A, B}.
Proof.
  intros A B x P1.
  apply (pair_e _ _ _ P1).
Qed.

(* 3A *)
Theorem opair_eq_i: ∀ A, ∀ B, ∀ C, ∀ D, (A = C) → (B = D) → ⟨A, B⟩ = ⟨C, D⟩.
Proof.
  intros A B C D P1 P2.
  apply (eq_cl (λ x, ⟨A, B⟩ = ⟨x, D⟩) P1).
  apply (eq_cl (λ x, ⟨A, B⟩ = ⟨A, x⟩) P2).
  apply eq_r.
Qed.

Theorem opair_eq_e: ∀ A, ∀ B, ∀ C, ∀ D, ⟨A, B⟩ = ⟨C, D⟩ → (A = C) ∧ (B = D).
Proof.
  intros A B C D P1.
  destruct (pair_eql _ _ _ _ P1) as [P2 | P2].
  + destruct (pair_eqr _ _ _ _ (eq_s P1)) as [P3 | P3].
    - split.
      * apply (sing_eq _ _ P2).
      * destruct (pair_eqr _ _ _ _ P1) as [P4 | P4].
        ++apply (eq_cl _ (sing_pair_eq2 _ _ _ (eq_s P3))).
          apply (eq_s (sing_pair_eq3 _ _ _ (eq_s P4))).
        ++destruct (pair_eqr _ _ _ _ P4) as [P5 | P5].
          --apply (eq_t P5).
            apply (sing_pair_eq3 _ _ _ (eq_s P3)).
          --apply P5.
    - split.
      * apply (sing_eq _ _ P2).
      * destruct (pair_eqr _ _ _ _ P3) as [P4 | P4].
        ++destruct (pair_eqr _ _ _ _ (eq_s P3)) as [P5 | P5].
          --apply (eq_t P5).
            apply (eq_t (sing_eq _ _ (eq_s P2))).
            apply (eq_s P4).
          --apply P5.
        ++apply (eq_s P4).
  + split.
    - apply (sing_pair_eq1 _ _ _ P2).
    - destruct (pair_eqr _ _ _ _ P1) as [P3 | P3].
      * apply (eq_t (eq_s (sing_pair_eq3 _ _ _ (eq_s P3)))).
        apply (sing_pair_eq2 _ _ _ P2).
      * destruct (pair_eqr _ _ _ _ P3) as [P4 | P4].
        ++apply(eq_t P4).
          apply (sing_pair_eq3 _ _ _ P2).
        ++apply P4.
Qed.

Theorem opair_eq_el: ∀ A, ∀ B, ∀ C, ∀ D, ⟨A, B⟩ = ⟨C, D⟩ → A = C.
Proof.
  intros A B C D P1.
  destruct (opair_eq_e _ _ _ _ P1) as [P2 _].
  apply P2.
Qed.

Theorem opair_eq_er: ∀ A, ∀ B, ∀ C, ∀ D, ⟨A, B⟩ = ⟨C, D⟩ → B = D.
Proof.
  intros A B C D P1.
  destruct (opair_eq_e _ _ _ _ P1) as [_ P2].
  apply P2.
Qed.

Lemma opair_superset: ∀ A, ∀ B, ∀ C, A ∈ C → B ∈ C → ⟨A, B⟩ ∈ 𝒫(𝒫(C)).
Proof.
  intros A B C P1 P2.
  apply power_i.
  intros x P3.
  apply power_i.
  intros y P4.
  destruct (pair_e _ _ _ P3) as [P5 | P5].
  + apply (eq_cl (λ x, x ∈ C) (sing_e _ _ (eq_cl _ P5 P4))).
    apply P1.
  + destruct (pair_e _ _ _ (eq_cl (λ x, y ∈ x) P5 P4)) as [P6 | P6].
    - apply (eq_cr (λ x, x ∈ C) P6).
      apply P1.
    - apply (eq_cr (λ x, x ∈ C) P6).
      apply P2.
Qed.

Lemma opair_eq_swap: ∀ a, ∀ b, ∀ c, ∀ d, ⟨a, b⟩ = ⟨c, d⟩ → ⟨b, a⟩ = ⟨d, c⟩.
Proof.
  intros a b c d P1.
  apply (eq_cl (λ x, ⟨b, a⟩ = ⟨d, x⟩) (opair_eq_el _ _ _ _ P1)).
  apply (eq_cl (λ x, ⟨b, a⟩ = ⟨x, a⟩) (opair_eq_er _ _ _ _ P1)).
  apply eq_r.
Qed.
(*----------------------------------------------------------------------------*)

(* Cartesion Product *)
Lemma cp_i: ∀ A, ∀ B, ∀ x, ∀ y, x ∈ A → y ∈ B → ⟨x, y⟩ ∈ A ⨉ B.
Proof.
  intros A B x y P1 P2.
  apply sub_i.
  + apply opair_superset.
    - apply (union2_il _ _ _ P1).
    - apply (union2_ir _ _ _ P2).
  + exists x.
    exists y.
    repeat split.
    - apply P1.
    - apply P2.
Qed.

Lemma cp_e: ∀ A, ∀ B, ∀ x, x ∈ A ⨉ B → in_cp x A B.
  intros A B x P1.
  apply (sub_e _ _ _ P1).
Qed.

Lemma cp_e2: ∀ x, ∀ y, ∀ A, ∀ B, ⟨x, y⟩ ∈ A ⨉ B → x ∈ A ∧ y ∈ B.
Proof.
  intros x y A B P1.
  destruct (cp_e _ _ _ P1) as [a [b [P2 [P3 P4]]]].
  split.
  + apply (eq_cr (λ x, x ∈ A) (opair_eq_el _ _ _ _ P4)).
    apply P2.
  + apply (eq_cr (λ x, x ∈ B) (opair_eq_er _ _ _ _ P4)).
    apply P3.
Qed.

Lemma cp_swap: ∀ A, ∀ B, ∀ x, ∀ y, ⟨x, y⟩ ∈ cp A B → ⟨y, x⟩ ∈ B ⨉ A.
Proof.
  intros A B x y P1.
  destruct (cp_e2 _ _ _ _ P1) as [P2 P3].
  apply (cp_i _ _ _ _ P3 P2).
Qed.

Lemma cp_sub: ∀ A, ∀ B, ∀ C, ∀ D, A ⊆ C → B ⊆ D → A ⨉ B ⊆ C ⨉ D.
Proof.
  intros A B C D P1 P2 r P3.
  destruct (cp_e _ _ _ P3) as [x [y [P4 [P5 P6]]]].
  apply (eq_cr (λ r, r ∈ C ⨉ D) P6).
  apply cp_i.
  + apply (P1 _ P4).
  + apply (P2 _ P5).
Qed.
(*----------------------------------------------------------------------------*)

(* Russell *)
Lemma no_universe: ~(∃ A, ∀ x, x ∈ A).
Proof.
  intros [A P1].
  pose ({x: A| x ∉ x}) as R.
  assert (R ∉ R) as P2.
  { intros P2.
    destruct (sub_e _ _ _ P2) as [_ P3].
    apply bot_e.
    apply (P3 P2). }
  assert (R ∈ R) as P3.
  { apply sub_i.
    + apply P1.
    + apply P2. }
  apply bot_e.
  apply (P2 P3).
Qed.

Lemma ex_extra: ∀ A, ∃ x, x ∉ A.
Proof.
  intros A.
  apply not_all_ex_not.
  apply (@not_ex_all_not (λ A, ∀ x, x ∈ A) no_universe).
Qed.

(* Axiom of Regularity *)
Lemma nin_self: ∀ A, A ∉ A.
Proof.
  intros A P1.
  assert (∃ x, x ∈ `{A}) as P2.
  { exists A.
    apply sing_i. }
  destruct (ax_regular `{A}) as [m P3].
  destruct (P3 P2) as [P4 P5].
  apply P5.
  exists A.
  split.
  + apply sing_i.
  + apply (eq_cl (λ x, A ∈ x) (sing_e _ _ P4)).
    apply P1.
Qed.

Lemma no_mutual_in: ∀ A, ∀ B, ~(A ∈ B ∧ B ∈ A).
Proof.
  intros A B [P1 P2].
  assert (∃ x, x ∈ `{A, B}) as P3.
  { exists A.
    apply pair_il. }
  destruct (ax_regular `{A, B}) as [m P4].
  destruct (P4 P3) as [P5 P6].
  apply P6.
  destruct (pair_e _ _ _ P5) as [P7 | P7].
  + exists B.
    split.
    - apply pair_ir.
    - apply (eq_cr (λ x, B ∈ x) P7).
      apply P2.
  + exists A.
    split.
    - apply pair_il.
    - apply (eq_cr (λ x, A ∈ x) P7).
      apply P1.
Qed.
(*----------------------------------------------------------------------------*)