Require Export Poly_J.

Check (2 + 2 = 4).
Check (ble_nat 3 2 = false).

Theorem plus_2_2_is_4 :
  2 + 2 = 4.
Proof. reflexivity. Qed.

Definition plus_fact : Prop := 2 + 2 = 4.
Check plus_fact.

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity. Qed.

Definition strange_prop1 : Prop :=
  (2 + 2 = 5) -> (99 + 26 = 42).

Definition strange_prop2 :=
  forall n, (ble_nat n 17 = true) -> (ble_nat n 99 = true).

Definition even (n : nat) : Prop :=
  evenb n = true.

Check even.
Check (even 4).
Check (even 3).

Definition even_n__even_SSn (n : nat) : Prop :=
  (even n) -> (even (S (S n))).

Definition between (n m o : nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.

Definition teen : nat -> Prop := between 13 19.

Definition true_for_zero (P : nat -> Prop) : Prop :=
  P 0.

Definition true_for_n__true_for_Sn (P : nat -> Prop) (n : nat) : Prop :=
  P n -> P (S n).

Definition preserved_by_S (P : nat -> Prop) : Prop :=
  forall n', P n' -> P (S n').

Definition true_for_all_numbers (P : nat -> Prop) : Prop :=
  forall n, P n.

Definition our_nat_induction (P : nat -> Prop) : Prop :=
  (true_for_zero P) ->
  (preserved_by_S P) ->
  (true_for_all_numbers P).

Inductive good_day : day -> Prop :=
| gd_sat : good_day saturday
| gd_sun : good_day sunday.

Theorem gds : good_day sunday.
Proof. apply gd_sun. Qed.

Inductive day_before : day -> day -> Prop :=
| db_tue : day_before tuesday monday
| db_wed : day_before wednesday tuesday
| db_thu : day_before thursday wednesday
| db_fri : day_before friday thursday
| db_sat : day_before saturday friday
| db_sun : day_before sunday saturday
| db_mon : day_before monday sunday.

Inductive fine_day_for_singing : day -> Prop :=
| fdfs_any : forall d : day, fine_day_for_singing d.

Theorem fdfs_wed : fine_day_for_singing wednesday.
Proof. apply fdfs_any. Qed.

Definition fdfs_wed' : fine_day_for_singing wednesday :=
  fdfs_any wednesday.
Check fdfs_wed.
Check fdfs_wed'.

Inductive ok_day : day -> Prop :=
| okd_gd : forall d,
    good_day d ->
    ok_day d
| okd_before : forall d1 d2,
    ok_day d2 ->
    day_before d2 d1 ->
    ok_day d1.

Definition okdw : ok_day wednesday :=
  okd_before wednesday thursday
             (okd_before thursday friday
                         (okd_before friday saturday
                                     (okd_gd saturday gd_sat)
                                     db_sat)
                         db_fri)
             db_thu.
Theorem okdw' : ok_day wednesday.
Proof.
  apply okd_before with (d2 := thursday).
  apply okd_before with (d2 := friday).
  apply okd_before with (d2 := saturday).
  apply okd_gd. apply gd_sat.
  apply db_sat.
  apply db_fri.
  apply db_thu. Qed.

Print okdw'.

Definition okd_before2 := forall d1 d2 d3,
    ok_day d3 ->
    day_before d2 d1 ->
    day_before d3 d2 ->
    ok_day d1.

Theorem okd_before2_valid : okd_before2.
Proof.
  unfold okd_before2.
  intros d1 d2 d3 ok b0 b1.
  apply okd_before with (d2 := d2).
  apply okd_before with (d2 := d3).
  apply ok.
  apply b1.
  apply b0. Qed.

Definition okd_before2_valid' : okd_before2 :=
  fun (d1 d2 d3 : day) =>
    fun (H : ok_day d3) =>
      fun (H0 : day_before d2 d1) =>
        fun (H1 : day_before d3 d2) =>
          okd_before d1 d2 (okd_before d2 d3 H H1) H0.

Print okd_before2_valid.

Check nat_ind.

Theorem mult_0_r' : forall n : nat,
    n * 0 = 0.
Proof.
  apply nat_ind.
  Case "O". reflexivity.
  Case "S". simpl. intros n IHn. rewrite -> IHn.
    reflexivity. Qed.

Theorem plus_one_r' : forall n:nat,
  n + 1 = S n.
Proof.
  apply nat_ind.
  Case "0". reflexivity.
  Case "S n". intros n H. simpl. apply eq_remove_S. apply H. Qed.

Inductive yesno : Type :=
| yes : yesno
| no : yesno.

Check yesno_ind.

Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.
Check rgb_ind.

Inductive natlist : Type :=
| nnil : natlist
| ncons : nat -> natlist -> natlist.

Check natlist_ind.

Inductive natlist1 : Type :=
| nnil1 : natlist1
| nsnoc1 : natlist1 -> nat -> natlist1.
Check natlist1_ind.

Inductive ExSet : Type :=
| con1 : bool -> ExSet
| con2 : nat -> ExSet -> ExSet.
Check ExSet_ind.

Inductive tree (X : Type) : Type :=
| leaf : X -> tree X
| node : tree X -> tree X -> tree X.
Check tree_ind.
(*
  tree_ind :
    forall (X : Type) (P : tree X -> Prop),
      (forall x : X, P (leaf X x)) ->
      (forall t : tree X, P t -> forall t0 : tree X, P t0 -> P (node X t t0)) ->
      forall t : tree X, P t
 *)

Inductive mytype (X : Type) : Type :=
| constr1 : X -> mytype X
| constr2 : nat -> mytype X
| constr3 : mytype X -> nat -> mytype X.
(*
   mytype_ind :
     forall (X : Type) (P : mytype X -> Prop),
       (forall x : X, P (constr1 X x)) ->
       (forall n : nat, P (constr2 X n)) ->
       (forall m : mytype X, P m ->
         forall n : nat, P (constr3 X m n)) ->
       forall m : mytype X, P m

 *)

Check mytype_ind.

Inductive foo (X Y : Type) : Type :=
| bar : X -> foo X Y
| baz : Y -> foo X Y
| quux : (nat -> foo X Y) -> nat -> foo X Y.

Check foo_ind.

Inductive foo' (X : Type) : Type :=
| C1 : list X -> foo' X -> foo' X
| C2 : foo' X.
Check foo'_ind.
(*
   foo'_ind :
     forall (X : Type) (P : foo' X -> Prop),
       (forall (l : list X) (f : foo' X),
         P f -> P (C1 X l f)) ->
       P (C2 X) ->
       forall f1 : foo' X, P f1
 *)

Definition P_m0r (n:nat) : Prop :=
  n * 0 = 0.

Definition P_m0r' : nat->Prop :=
  fun n => n * 0 = 0.

Theorem mult_0_r'' : forall n:nat,
  P_m0r n.
Proof.
  apply nat_ind.
  Case "n = O". reflexivity.
  Case "n = S n'".

    unfold P_m0r. simpl. intros n' IHn'.
    apply IHn'.  Qed.

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n:nat, ev n -> ev (S (S n)).

Theorem four_ev' :
  ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

Definition four_ev : ev 4 :=
  ev_SS 2 (ev_SS 0 ev_0).

Theorem ev_plus4' : forall n,
  ev n -> ev (4 + n).
Proof.
  simpl.
  intros n Hev.
  apply ev_SS. apply ev_SS. apply Hev. Qed.

Definition ev_plus4 : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) (Hev : ev n) => ev_SS (S (S n)) (ev_SS n Hev).

Theorem double_even : forall n,
  ev (double n).
Proof.
  intros n. induction n as [| n'].
  Case "n = 0". simpl. apply ev_0.
  Case "n = S n'".
    simpl. apply ev_SS. apply IHn'. Qed.

Definition double_even' : forall n, ev (double n) :=
  nat_ind
    (fun (n : nat) => ev (double n))
    ev_0
    (fun (n' : nat) (IHn' : ev (double n')) => ev_SS (double n') IHn').

Theorem ev_minus2: forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E. induction E as [| n' E'].
  Case "E = ev_0". simpl.
  apply ev_0.
  Case "E = ev_SS". simpl. apply E'. Qed.

Definition ev_minus2' : forall (n : nat), ev n -> ev (pred (pred n)) :=
  ev_ind
    (fun (n' : nat) => ev (pred (pred n')))
    ev_0
    (fun (n'' : nat) (E' : ev n'') =>  (fun (E'' : ev (pred (pred n''))) => E')).

Theorem ev_minus2'' : forall n,
    ev n -> ev (pred (pred n)).
Proof.
  intros n E. destruct n as [| n'].
  Case "n = 0". simpl. apply E.
  Case "n = S n'". inversion E. simpl. apply H0. Qed.

Theorem ev_even : forall n,
  ev n -> even n.
Proof.
  intros n E. induction E as [| n' E'].
  Case "E = ev_0". reflexivity.
  Case "E = ev_SS n' E'".
    unfold even. apply IHE'. Qed.

Theorem ev_even_n : forall n,
    ev n -> even n.
Proof.
  intros n E. induction n as [| n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    inversion E. unfold even.
  Admitted.

Theorem ev_sum : forall n m,
   ev n -> ev m -> ev (n+m).
Proof.
  intros n m En Em. induction En as [| n' En'].
  Case "En = ev_0".
    simpl. apply Em.
  Case "En = ev_SS n' En'".
    simpl. apply ev_SS. apply IHEn'. Qed.

Definition ev_sum' : forall n m, ev n -> ev m -> ev (n + m) :=
  fun (n m : nat) (En : ev n) (Em : ev m) =>
    (ev_ind
      (fun (n' : nat) => ev (n' + m))
      Em
      (fun (n' : nat) (En' : ev n') (Enm : ev (n' + m)) => ev_SS (n' + m) Enm))
      n En.

Theorem SSev_ev_firsttry : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E.
  destruct E as [| n' E'].

Admitted.

Theorem SSev_even : forall n,
  ev (S (S n)) -> ev n.
Proof.
  intros n E. inversion E as [| n' E']. apply E'. Qed.

Theorem SSSSev_even : forall n,
  ev (S (S (S (S n)))) -> ev n.
Proof.
  intros n E. inversion E as [| n' E']. inversion E' as [| n'' E'']. apply E''. Qed.

Theorem even5_nonsense :
  ev 5 -> 2 + 2 = 9.
Proof.
  intros E. inversion E. inversion H0. inversion H2. Qed.

Theorem ev_minus2''': forall n,
  ev n -> ev (pred (pred n)).
Proof.
  intros n E. inversion E as [| n' E'].
  Case "E = ev_0". simpl. apply ev_0.
  Case "E = ev_SS n' E'". simpl. apply E'. Qed.

Theorem ev_ev_even : forall n m,
  ev (n+m) -> ev n -> ev m.
Proof.
  intros n m Enm E.
  generalize dependent Enm.
  generalize dependent m.
  induction E as [| n' E'].
  Case "ev n = ev_0".
    intros m Enm. apply Enm.
  Case "ev n = ev_SS n' E'".
    simpl. intros m Em. inversion Em as [| nm Em'].
    apply IHE'. apply Em'. Qed.

Theorem ev_plus_plus : forall n m p,
  ev (n+m) -> ev (n+p) -> ev (m+p).
Proof.
  intros n m p Enm Enp.
  apply (ev_ev_even (n + n) (m + p)).
  rewrite <- (plus_assoc' n n (m + p)).
  rewrite -> (plus_assoc' n m p).
  rewrite -> (plus_comm (n + m) p).
  rewrite -> (plus_assoc' n p (n + m)).
  apply (ev_sum (n + p) (n + m)).
  apply Enp.
  apply Enm.
  rewrite <- double_plus.
  apply double_even. Qed.

Inductive MyProp : nat -> Prop :=
| MyProp1 : MyProp 4
| MyProp2 : forall n : nat, MyProp n -> MyProp (4 + n)
| MyProp3 : forall n : nat, MyProp (2 + n) -> MyProp n.

Theorem MyProp_ten : MyProp 10.
Proof.
  apply MyProp3. simpl.
  assert (12 = 4 + 8) as H12.
    Case "Proof of assert". reflexivity.
  rewrite -> H12.
  apply MyProp2.
  assert (8 = 4 + 4) as H8.
    Case "Proof of assert". reflexivity.
  rewrite -> H8.
  apply MyProp2.
  apply MyProp1. Qed.

Theorem MyProp_0 : MyProp 0.
Proof.
  apply MyProp3.
  simpl.
  apply MyProp3.
  simpl.
  apply MyProp1. Qed.

Theorem MyProp_plustwo : forall n:nat, MyProp n -> MyProp (S (S n)).
Proof.
  intros n E.
  induction E.
  Case "E = MyProp1".
    assert (6 = 4 + 2) as H6.
      SCase "Proof of assert". reflexivity.
    rewrite -> H6.
    apply MyProp2.
    apply MyProp3.
    simpl.
    apply MyProp1.
  Case "E = MyProp2".
    apply MyProp2. apply IHE.
  Case "E = MyProp3".
    apply E. Qed.

Theorem MyProp_ev : forall n:nat,
  ev n -> MyProp n.
Proof.
  intros n E.
  induction E as [| n' E'].
  Case "E = ev_0".
    apply MyProp_0.
  Case "E = ev_SS n' E'".
    apply MyProp_plustwo. apply IHE'.  Qed.

Theorem ev_MyProp : forall n:nat,
  MyProp n -> ev n.
Proof.
  intros n M.
  induction M.
    Case "M = MyProp1". apply ev_SS. apply ev_SS. apply ev_0.
    Case "M = MyProp2". apply ev_SS. apply ev_SS. apply IHM.
    Case "M = MyProp2". apply SSev_even. apply IHM. Qed.

Theorem ev_even' : forall n,
    ev n -> even n.
Proof.
  apply ev_ind.
    Case "ev_0". unfold even. reflexivity.
    Case "ev_SS". intros n' E' IHE'. unfold even. apply IHE'. Qed.

Check list_ind.
Check MyProp_ind.

Theorem ev_MyProp' : forall n:nat,
  MyProp n -> ev n.
Proof.
  apply MyProp_ind.
  Case "MyProp1". apply ev_SS. apply ev_SS. apply ev_0.
  Case "MyProp2". intros n E IHE. apply ev_SS. apply ev_SS. apply IHE.
  Case "MyProp3". intros n E IHE. apply SSev_even. apply IHE. Qed.

Definition MyProp_ev' : forall n:nat, ev n -> MyProp n :=
  ev_ind (fun (n : nat) => MyProp n)
         MyProp_0
         (fun (n' : nat) (E' : ev n') (M' : MyProp n') => MyProp_plustwo n' M').

Definition ev_MyProp'' : forall n : nat, MyProp n -> ev n :=
  MyProp_ind
    (fun (n' : nat) => ev n')
    (ev_SS _ (ev_SS _ ev_0))
    (fun (n' : nat) (M : MyProp n') (E : ev n') => ev_SS _ (ev_SS _ E))
    (fun (n' : nat) (M : MyProp (2 + n')) (E : ev (2 + n')) => SSev_even n' E).

Module P.
  Inductive p : (tree nat) -> nat -> Prop :=
  | c1 : forall n, p (leaf _ n) 1
  | c2 : forall t1 t2 n1 n2,
      p t1 n1 -> p t2 n2 -> p (node _ t1 t2) (n1 + n2)
  | c3 : forall t n, p t n -> p t (S n).
End P.

Inductive pal {X : Type} : list X -> Prop :=
| pal_rev (l : list X) : l = rev l -> pal l.

Theorem pal_append_rev : forall (X : Type) (l : list X),
    pal (l ++ rev l).
Proof.
  intros X l.
  apply pal_rev.
  induction l as [| x l'].
  Case "l = []". reflexivity.
  Case "l = x :: l'".
    simpl.
    rewrite <- snoc_with_append.
    rewrite -> rev_snoc.
    rewrite <- IHl'.
    simpl. reflexivity. Qed.

Theorem pal_id_rev : forall (X : Type) (l : list X),
    pal l -> l = rev l.
Proof.
  intros X l P.
  induction P. apply H. Qed.

Theorem id_rev_pal : forall (X : Type) (l : list X),
    l = rev l -> pal l.
Proof.
  intros X l eq. apply pal_rev. apply eq. Qed.

Inductive subseq : list nat -> list nat -> Prop :=
| subseq_0 : forall (l : list nat), subseq [] l
| subseq_tail : forall (x : nat) (l xs : list nat), subseq l xs -> subseq (x :: l) (x :: xs)
| subseq_all : forall (x : nat) ( l xs : list nat), subseq l xs -> subseq l (x :: xs).

Theorem subseq_refl : forall l : list nat, subseq l l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = []". apply subseq_0.
  Case "l = n :: l'".
    apply subseq_tail. apply IHl'. Qed.

Theorem subseq_app : forall (l1 l2 l3 : list nat),
    subseq l1 l2 -> subseq l1 (l2 ++ l3).
Proof.
  intros l1 l2 l3 s.
  induction s.
  apply subseq_0.
  simpl. apply subseq_tail. apply IHs.
  simpl. apply subseq_all. apply IHs. Qed.

Theorem subseq_trans : forall (l1 l2 l3 : list nat),
    subseq l1 l2 -> subseq l2 l3 -> subseq l1 l3.
Proof.
  intros l1 l2 l3.
  generalize dependent l2.
  generalize dependent l1.
  induction l3 as [| n3 l3'].
  Case "l3 = []".
    intros l1 l2 s1 s2. inversion s2.
    rewrite <- H in s1. inversion s1. apply subseq_0.
  Case "l3 = n3 :: l3'".
    intros l1 l2 s1 s2. inversion s2.
      SCase "subseq_0".
        rewrite <- H in s1. inversion s1. apply subseq_0.
      SCase "subseq_tail".
        subst n3 l2 l3'. inversion s1.
        SSCase "subseq_0".
          apply subseq_0.
        SSCase "subseq_tail".
          subst x l l1. apply subseq_tail.
          apply (IHl3' l0 xs0).
          apply H2.
          apply H1.
        SSCase "subseq_all".
          subst l x l1. apply subseq_all. apply (IHl3' l0 xs0).
          apply H2.
          apply H1.
      SCase "subseq_all".
        subst l3' n3 l2. apply subseq_all. apply (IHl3' l1 l).
        apply s1.
        apply H1. Qed.


(* Computation of nth root (code from Yves.Bertot@inria.fr)                   *)
From mathcomp Require Import all_ssreflect.

(******************************************************************************)
(*                                                                            *)
(*   rootn n i      ==  computes the integer n^th root of i                   *)
(*   is_rootn n i   ==  check if i is of n^th root of a number                *)
(*                                                                            *)
(******************************************************************************)

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

Fixpoint rootn_rec k r n :=
  if r == 0 then 0 else
  if n is n1.+1 then
  let v := (rootn_rec k (r %/ (2 ^ k)) n1).*2 in
  if v.+1 ^ k <= r then v.+1 else v
  else 0.

Definition rootn k n :=
  if k == 0 then 0 else rootn_rec k n n.

Lemma rootn_rec_bound k r n :
  0 < k -> r <= n -> (rootn_rec k r n) ^ k  <= r < (rootn_rec k r n ).+1 ^ k.
Proof.
case: k => // k _.
have F : 1 < 2 ^ k.+1 by rewrite -{1}[1](exp1n k.+1) ltn_exp2r.
elim: n r => [[] //=|n IH [|[|r]] rLn /=]; rewrite ?(exp0n, exp1n) //.
  rewrite divn_small //=.
  have -> : rootn_rec k.+1 0 n = 0 by case: (n).
  by rewrite exp1n /= exp1n.
set x := _ %/ _; set u := rootn_rec _ _ _.
have /IH : x <= n.
  apply: leq_trans (rLn : _ < n).
  have /mulnK H : 0 < 2 ^ k.+1 by rewrite expn_gt0.
  rewrite -[r.+1]H leq_div2r //.
  by rewrite -{1}[r.+1]muln1 ltn_mul2l.
rewrite -/u => /andP[uLx xLu].
case: (leqP (u.*2.+1 ^ k.+1 ) r.+2) => ->; rewrite !(andbT, andTb).
  rewrite -doubleS -muln2 expnMn.
  rewrite (divn_eq r.+2 (2 ^ k.+1)) -/x.
  apply: leq_trans (_ : x.+1 * 2 ^ k.+1 <= _).
    by rewrite mulSn addnC ltn_add2r // ltn_mod ?expn_gt0.
  by rewrite leq_mul2r // expn_eq0.
rewrite -muln2 expnMn (divn_eq r.+2 (2 ^ k.+1)) -/x.
apply: leq_trans (leq_addr _ _).
by rewrite leq_mul2r // expn_eq0.
Qed.

Lemma root0n i : rootn 0 i = 0.
Proof. by rewrite /rootn eqxx. Qed.

Lemma rootn_bound n i : 0 < n -> rootn n i ^ n <= i < (rootn n i).+1 ^ n.
Proof. by case: n => // n  _; apply: rootn_rec_bound. Qed.

Lemma rootn0 n : rootn n 0 = 0.
Proof. by case: n. Qed.

Definition is_rootn n i := (i == rootn n i ^ n).

Lemma is_rootnE n i : is_rootn n i = (i == rootn n i ^ n).
Proof. by []. Qed.

Lemma leq_rootn n x y : 0 < n -> x <= y -> rootn n x <= rootn n y.
Proof.
move=> n_gt0 xLy.
rewrite -ltnS -(ltn_exp2r _ _ n_gt0).
have /andP[rLx _] := rootn_bound x n_gt0.
have /andP[_ yLr] := rootn_bound y n_gt0.
by apply: leq_ltn_trans rLx (leq_ltn_trans _ yLr).
Qed.

Lemma rootnE n x y :
  0 < n -> y ^ n <= x < y.+1 ^ n -> rootn n x = y.
Proof.
move=> n_gt0 /andP[ynLx xLySn].
have /andP[rLx xLrS] := rootn_bound x n_gt0.
apply/eqP; rewrite eqn_leq.
rewrite -ltnS -(ltn_exp2r _ _ n_gt0) (leq_ltn_trans rLx) //.
by rewrite -ltnS -(ltn_exp2r _ _ n_gt0) (leq_ltn_trans ynLx).
Qed.

Lemma expnK n x : 0 < n -> rootn n (x ^ n) = x.
Proof.
by move=> n_gt0; apply: rootnE; rewrite // leqnn ltn_exp2r ?ltnSn.
Qed.

Lemma rootn_leq n x y :
  0 < n -> x ^ n <= y -> x <= rootn n y.
Proof. by move=> n_gt0 xnLy; rewrite -(expnK x n_gt0) leq_rootn. Qed.

Lemma rootn_ltn n x y :
  0 < n -> x < y.+1 ^ n -> rootn n x <= y.
Proof.
move=> n_gt0; rewrite ltnNge [in X in _ -> X]leqNgt.
apply: contra => yLrx.
have /andP[rLx _] := rootn_bound x n_gt0.
by apply: leq_trans rLx; rewrite leq_exp2r.
Qed.

Definition sqrtn := rootn 2.

Lemma sqrtn_bound n : (sqrtn n) ^ 2 <= n < ((sqrtn n).+1) ^ 2.
Proof. by apply: rootn_bound. Qed.

Lemma sqrtnE n x : x ^ 2 <= n < x.+1^2 -> sqrtn n = x.
Proof. by apply: rootnE. Qed.

Lemma leq_sqrtn m n : m <= n -> sqrtn m <= sqrtn n.
Proof. by apply: leq_rootn. Qed.

Lemma sqrnK n : sqrtn (n ^ 2) = n.
Proof. by apply: expnK. Qed.

Lemma sqrtn_gt0 n : (0 < sqrtn n) = (0 < n).
Proof.
by case: n => [|n]; rewrite // -[1%N]/(sqrtn 1) // leq_sqrtn.
Qed.


Require Export P01.

(** **** Problem #2: 2 stars (blt_nat) *)
(** The [blt_nat] function tests [nat]ural numbers for [l]ess-[t]han,
    yielding a [b]oolean.  Use [Fixpoint] to define it. **)

Fixpoint blt_nat(n m : nat) : bool :=
  match n with
  | O => match m with
       | O => false
       | S m' => true
        end
  | S n' => match m with
          | O => false
          | S m' => blt_nat n' m'
          end
end.

Example test_blt_nat1:             (blt_nat 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat2:             (blt_nat 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_blt_nat3:             (blt_nat 4 2) = false.
Proof. simpl. reflexivity. Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*** [reflect] predicate *)

Section MotivationalExample.

Variable T : Type.

Variable p : pred T.
Print pred.
Check p : T -> bool.

Lemma all_filter (s : seq T) :
  all p s -> filter p s = s.
Proof.

(* Notation "[ 'seq' x <- s | C ]" := (filter (fun x => C) s) *)

Print filter.
Print all.

elim: s => //= x s IHs.

rewrite /is_true.
move=> /andP.
(* Set Printing Coercions. *)
rewrite /is_true.
move=> [].
move=> ->.
move/IHs.
move=>->.
done.

Restart.

by elim: s => //= x s IHs /andP[-> /IHs->].
Qed.

End MotivationalExample.

(** How does [andP] from above work? *)

About andP.

Print reflect.
Print Bool.reflect.

(**
    Inductive reflect (P : Prop) : bool -> Set :=
    | ReflectT : P -> reflect P true
    | ReflectF : ~ P -> reflect P false
 *)

Search _ reflect.

(** First, let us show that [P] if and only if [b = true]
    as two separate lemmas
  *)

Lemma introT_my (P : Prop) (b : bool) :
  reflect P b -> P -> b.
Proof.
Set Printing Coercions.
rewrite /is_true.
Unset Printing Coercions.
case.
- move=> _ _. done.
move=> np. move/np. case.
Qed.

Lemma elimT_my (P : Prop) (b : bool) :
  reflect P b -> b -> P.
Proof.
case.
- move=> p _. exact: p.
move=> _. done.
Qed.

  (* reflect P b -> (b <-> P). *)

(** Essentially, a [reflect] predicate connects
    a _decidable_ proposition to its decision procedure.
 *)
Lemma reflect_lem P b :
  reflect P b -> P \/ ~ P.
Proof.
by case=> H; [left | right].
Qed.

(** Lets look at some standard [reflect] predicates *)

Lemma andP_my (b c : bool) :
  reflect (b /\ c) (b && c).
Proof.
by case: b; case: c; constructor=> //; case.
Qed.

Lemma orP_my (b c : bool) :
  reflect (b \/ c) (b || c).
Proof. (* exercise *) Admitted.

Lemma nandP_my b c : reflect (~~ b \/ ~~ c) (~~ (b && c)).
Proof. by case: b; case: c; constructor; auto; case. Qed.

(** * Using reflection views in intro patterns *)

Lemma special_support_for_reflect_predicates b c :
  b && c -> b /\ c.
Proof.
move/andP.
Show Proof.

(**
SSReflect implicitly inserts the so-called view hints to
facilitate boolean reflection. In this case it's [elimTF] view hint.

Here is the syntax to do that (see ssrbool.v file):
Hint View for move/ elimTF|3 elimNTF|3 elimTFn|3 introT|2 introTn|2 introN|2.

The optional natural number is the number of implicit arguments
to be considered for the declared hint view lemma.

The ssrbool.v module already declares a numbers of view hints,
so adding new ones should be justified. For instance, one might need to do it
if one defines a new logical connective.
 *)

(* Set Printing All. *)
(* Show Proof. *)

About introTF.
About elimTF.
About elimF.

Restart.

move=> Hb.
Check @elimTF (b /\ c) (b && c) true (@andP b c) Hb.
move: Hb.
move/(@elimTF (b /\ c) (b && c) true (@andP b c)).

exact: id.
Qed.

(** Reflection views generally work in both directions *)
Lemma special_support_for_reflect_predicates' (b c : bool) :
  b /\ c -> b && c.
Proof.
move/andP.
Show Proof.
About introT.  (** [introT] view hint gets implicitly inserted *)
exact: id.
Qed.

(** * Switching views at the goal *)

Lemma special_support_for_reflect_predicates'' (b c : bool) :
  b /\ c -> b && c.
Proof.
move=> ab.
apply/andP.  (** [apply/] syntax *)
Show Proof.  (** [introTF] view hint gets inserted *)
About introTF.
done.
Qed.

(** Specification for [eqn] -- decision procedure for equality on [nat]s *)
Lemma eqnP_my (n m : nat) : reflect (n = m) (eqn n m).
Proof.
elim: n m=> [|n IHn] [|m]; try constructor=> //.

move=> /=.

(** Need to convert a [reflect]-based propositions into biimplications *)
Search reflect -seq -"or" -"and" -"mem" -negb -minn.

Check iffP (IHn m).
(**
How the conclusion of [iffP (IHn m)] matches with the goal:

                                         reflect (n.+1 = m.+1) (eqn n m)
       (n = m -> ?Q) -> (?Q -> n = m) -> reflect ?Q            (eqn n m)

Coq infers [?Q] existential variable to be [n.+1 = m.+1]
*)
by apply: (iffP (IHn _)) => [-> | /succn_inj].

Restart.

apply: (iffP idP).   (** [idP] -- the trivial reflection view *)
- by elim: n m => [|n IHn] [|m] //= /IHn->.
- move=> ->. by elim: m.
Qed.

Lemma silly_example_iffP_andP (b c : bool) :
  reflect (b /\ c) (b && c).
Proof.
apply: (iffP idP).
Undo.
Check (iffP andP).
apply: (iffP andP).
done.
done.
Qed.

(** A better example of using [iffP] with a non-[idP] argument *)
Lemma nseqP (T : eqType) n (x y : T) :
  reflect (y = x /\ n > 0) (y \in nseq n x).
Proof.
rewrite mem_nseq andbC.
(* apply: (iffP idP); move/andP. *)
apply: (iffP andP).
(* reflect (x = y) (x == y) *)
case. move/eqP. move=>->. done.
case=>->. done.

Restart.

by rewrite mem_nseq andbC; apply: (iffP andP) => -[/eqP].
Qed.

(** * Rewriting with [reflect] predicates *)

About maxn_idPl.

Lemma leq_max m n1 n2 :
  (m <= maxn n1 n2) = (m <= n1) || (m <= n2).
Proof.
(* move: (leq_total n2 n1). *)
(* case. *)
(* rewrite /is_true. *)
(* Print eq. *)
(* Set Printing All. *)
(*   move/orP. case=> [le_n21 | le_n12]. *)
case/orP: (leq_total n2 n1) => [le_n21 | le_n12].

Check (@maxn_idPl n1 n2).
rewrite (@maxn_idPl n1 n2 le_n21).

(** Why does this work?
    [maxn_idPl] is _not_ a function but behaves like one here *)

Check (maxn_idPl le_n21).  (** OK, this is an ordinary equation,
                               no wonder [rewrite] works. *)

Set Printing Coercions.
Check (maxn_idPl le_n21).   (** [elimT] get implicitly inserted *)
Unset Printing Coercions.

About elimT.

(** [elimT] is a coercion from [reflect] to [Funclass],
    This means it gets inserted when one uses a reflect view as a function.
  *)

(** Essentially we invoke the following tactic: *)

Undo.
rewrite (elimT maxn_idPl le_n21).
Abort.

(** * An example of a specification for a [seq] function *)

(** [all] specification *)
About allP.
(**
    forall (T : eqType) (a : pred T) (s : seq T),
    reflect {in s, forall x : T, a x} (all a s)
*)

(** Check out some other specs in the [seq] module! *)
Search _ reflect in seq.

(*** Specs as rewrite rules *)

Example for_ltngtP m n :
  (m <= n) && (n <= m) ->
  (m == n) || (m > n) || (m + n == 0).
Proof.
by case: ltngtP.

Restart.

case: ltngtP.
done.
done.
move=>/=.
Abort.

Module Trichotomy.

Variant compare_nat m n :
   bool -> bool -> bool -> bool -> bool -> bool -> Set :=
  | CompareNatLt of m < n : compare_nat m n true false true false false false
  | CompareNatGt of m > n : compare_nat m n false true false true false false
  | CompareNatEq of m = n : compare_nat m n true true false false true true.

Lemma ltngtP m n : compare_nat m n (m <= n) (n <= m) (m < n)
                                   (n < m)  (n == m) (m == n).
Proof.
rewrite !ltn_neqAle [_ == m]eq_sym; case: ltnP => [mn|].
  by rewrite ltnW // gtn_eqF //; constructor.
rewrite leq_eqVlt; case: ltnP; rewrite ?(orbT, orbF) => //= lt_nm eq_mn.
  by rewrite ltn_eqF //; constructor.
by rewrite eq_mn; constructor; apply/eqP.
Qed.

(** One more example *)
Lemma maxnC : commutative maxn.
Proof. by move=> m n; rewrite /maxn; case: ltngtP. Qed.

End Trichotomy.

(*** Coercions summary *)

(** * [is_true] coercion *)

(** We have already been using [is_true] coercion regularly.
    It's defined in ssrbool.v as follows:

    Coercion is_true : bool >-> Sortclass.
 *)

(** E.g. [is_true] makes the following typecheck *)
Check (erefl true) : true.

(** * [elimT] coercion *)

(**  Allow the direct application of a reflection lemma
     to a boolean assertion.

    Coercion elimT : reflect >-> Funclass.
 *)

Section ElimT_Example.

Variables b c : bool.
Hypothesis H : b || c.

Check orP H.
Set Printing Coercions.
Check orP H.
Unset Printing Coercions.

End ElimT_Example.

(** * [nat_of_bool] coercion *)

About nat_of_bool.

About leq_b1.
About mulnb.

About count_nseq.

(** You can learn more using the following search query: *)
Search _ nat_of_bool.


Require Export Basics.

Module NatList.

Inductive natprod : Type :=
  pair : nat -> nat -> natprod.

Definition fst(p : natprod) : nat :=
  match p with
  |pair x y => x
  end.

Definition snd(p :natprod) : nat :=
  match p with
  |pair x y => y
  end.

Notation "( x , y )" := (pair x y).

Eval simpl in (fst (3,4)).

Definition fst' (p : natprod) : nat :=
  match p with
  | (x,y) => x
  end.

Definition snd' (p : natprod) : nat :=
  match p with
  | (x,y) => y
  end.

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
    (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity. Qed.

Theorem surjective_pairing : forall (p : natprod),
    p = (fst p, snd p).
Proof.
  intros p. destruct p as (n,m). simpl. reflexivity. Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
    (snd p, fst p) = swap_pair p.
Proof.
  intros p. destruct p as (n,m). simpl. reflexivity. Qed.

Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Definition l_123 := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l)(at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).

Definition l_123' := 1 :: (2 :: (3 :: nil)).
Definition l_123'' := 1 :: 2 :: 3 :: nil.
Definition l_123''' := [1,2,3].

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  |O => nil
  |S count' => n :: (repeat n count')
  end.

Fixpoint length (l : natlist) : nat :=
  match l with
  |nil => O
  |h :: t => S (length t)
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  |nil => l2
  |h :: t => h :: (app t l2)
  end.

Notation "x ++ y" := (app x y)
                       (right associativity, at level 60).

Example test_app1: [1,2,3] ++ [4,5] = [1,2,3,4,5].
Proof. reflexivity. Qed.
Example test_app2: nil ++ [4,5] = [4,5].
Proof. reflexivity. Qed.
Example test_app3: [1,2,3] ++ nil = [1,2,3].
Proof. reflexivity. Qed.

Definition hd (default:nat)(l:natlist) : nat :=
  match l with
  |nil => default
  |h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  |nil => nil
  |h :: t => t
  end.

Example test_hd1:             hd 0 [1,2,3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tail:            tl [1,2,3] = [2,3].
Proof. reflexivity.  Qed.

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => if beq_nat h O then nonzeros t else h :: (nonzeros t)
  end.

Example test_nonzeros: nonzeros [0,1,0,2,3,0,0] = [1,2,3].
Proof. reflexivity. Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t =>
    match (oddb h) with
    | true  => h :: (oddmembers t)
    | false => oddmembers t
    end
  end.

Example test_oddmembers: oddmembers [0,1,0,2,3,0,0] = [1,3].
Proof. reflexivity. Qed.

Fixpoint countoddmembers (l : natlist) : nat :=
  match l with
  | nil    => 0
  | h :: t =>
    match (oddb h) with
    | true  => S (countoddmembers t)
    | false => countoddmembers t
    end
  end.

Example test_countoddmembers1: countoddmembers [1,0,3,1,4,5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers2: countoddmembers [0,2,4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers3: countoddmembers nil = 0.
Proof. reflexivity. Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
  | nil, nil => nil
  | nil, _   => l2
  | _  , nil => l1
  | h1 :: t1, h2 :: t2 =>
    h1 :: h2 :: (alternate t1 t2)
  end.

Example test_alternate1: alternate [1,2,3] [4,5,6] = [1,4,2,5,3,6].
Proof. simpl. reflexivity. Qed.
Example test_alternate2: alternate [1] [4,5,6] = [1,4,5,6].
Proof. simpl. reflexivity. Qed.
Example test_alternate3: alternate [1,2,3] [4] = [1,4,2,3].
Proof. simpl. reflexivity. Qed.
Example test_alternate4: alternate [] [20,30] = [20,30].
Proof. simpl. reflexivity. Qed.

Definition bag := natlist.

Fixpoint count (v:nat) (s:bag) : nat :=
  match s with
  | nil    => 0
  | h :: t =>
    match (beq_nat v h) with
    | true  => S (count v t)
    | false => count v t
                     end
  end.

Example test_count1: count 1 [1,2,3,1,4,1] = 3.
Proof. simpl. reflexivity. Qed.
Example test_count2: count 6 [1,2,3,1,4,1] = 0.
Proof. simpl. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1,2,3] [1,4,1]) = 3.
Proof. simpl. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag := cons v s.

Example test_add1: count 1 (add 1 [1,4,1]) = 3.
Proof. simpl. reflexivity. Qed.

Example test_add2: count 5 (add 1 [1,4,1]) = 0.
Proof. simpl. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
  match (count v s) with
  | O   => false
  | S _ => true
  end.

Example test_member1: member 1 [1,4,1] = true.
Proof. simpl. reflexivity. Qed.
Example test_member2: member 2 [1,4,1] = false.
Proof. simpl. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t =>
    match (beq_nat v h) with
    | true  => t
    | false => h :: (remove_one v t)
    end
  end.

Example test_remove_one1: count 5 (remove_one 5 [2,1,5,4,1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_one2: count 5 (remove_one 5 [2,1,4,1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_one3: count 4 (remove_one 5 [2,1,4,5,1,4]) = 2.
Proof. simpl. reflexivity. Qed.
Example test_remove_one4: count 5 (remove_one 5 [2,1,5,4,5,1,4]) = 1.
Proof. simpl. reflexivity. Qed.

Fixpoint remove_all (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t =>
    match (beq_nat v h) with
    | true  => remove_all v t
    | false => h :: (remove_all v t)
    end
  end.

Example test_remove_all1:          count 5 (remove_all 5 [2,1,5,4,1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_all2:          count 5 (remove_all 5 [2,1,4,1]) = 0.
Proof. simpl. reflexivity. Qed.
Example test_remove_all3:          count 4 (remove_all 5 [2,1,4,5,1,4]) = 2.
Proof. simpl. reflexivity. Qed.
Example test_remove_all4:          count 5 (remove_all 5 [2,1,5,4,5,1,4,5,1,4]) = 0.
Proof. simpl. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1, s2 with
  | nil, nil  => true
  | _,   nil  => false
  | nil, _    => true
  | h1::t1, _::t2 =>
    match (count h1 s2) with
    | O   => false
    | S _ => subset t1 (remove_one h1 s2)
    end
  end.

Example test_subset1: subset [1,2] [2,1,4,1] = true.
Proof. simpl. reflexivity. Qed.
Example test_subset2: subset [1,2,2] [2,1,4,1] = false.
Proof. simpl. reflexivity. Qed.

Theorem nil_app : forall l:natlist,
    [] ++ l = l.
Proof.
  reflexivity. Qed.

Theorem tl_length_pred : forall l:natlist,
    pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = cons n l'".
    simpl. reflexivity.
  Qed.

Theorem app_ass : forall l1 l2 l3 : natlist,
    (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1'].
  Case "l1 = nil".
    simpl. reflexivity.
  Case "l1 = n l1'".
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem app_length : forall l1 l2 : natlist,
    length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros l1 l2. induction l1 as [| n l1'].
  Case "l1 = l1'".
    simpl. reflexivity.
  Case "l1 = cons".
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

Fixpoint snoc (l:natlist) (v:nat) : natlist :=
  match l with
  | nil    => [v]
  | h :: t => h :: (snoc t v)
  end.

Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil    => nil
  | h :: t => snoc (rev t) h
  end.

Example test_rev1: rev [1,2,3] = [3,2,1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem length_snoc : forall n : nat, forall l : natlist,
      length (snoc l n) = S (length l).
Proof.
  intros n l.
  induction l as [| n' l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = cons n' l'".
    simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem rev_length : forall l : natlist,
    length (rev l) = length l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = n :: l'".
    simpl. rewrite -> length_snoc. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_nil_end : forall l : natlist,
    l ++ [] = l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = n :: l'".
    simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem rev_snoc : forall l : natlist, forall n : nat,
          rev (snoc l n) = n :: rev l.
Proof.
  intros l n. induction l as [| n' l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = n' :: l'".
    simpl. rewrite -> IHl'. simpl. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
    rev (rev l) = l.
Proof.
  intros l. induction l as [| n l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = n :: l'".
    simpl. rewrite -> rev_snoc. rewrite -> IHl'. reflexivity.
Qed.

Theorem snoc_rev : forall l1 l2 : natlist, forall n : nat,
          snoc (l1 ++ rev l2) n = l1 ++ snoc (rev l2) n.
Proof.
  intros l1 l2 n. induction l1 as [|n' l1'].
  Case "l1 = nil".
    simpl. reflexivity.
  Case "l1 = n :: l1'".
    simpl. rewrite -> IHl1'. reflexivity.
Qed.

Theorem distr_rev : forall l1 l2 : natlist,
    rev (l1 ++ l2) = (rev l2) ++ (rev l1).
Proof.
  intros l1 l2. induction l1 as [| n l1'].
  Case "l1 = nil".
    simpl. rewrite -> app_nil_end. reflexivity.
  Case "l1 = n :: l1'".
    simpl. rewrite -> IHl1'.
    rewrite -> snoc_rev. reflexivity.
Qed.

Theorem app_ass4 : forall l1 l2 l3 l4 : natlist,
    l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  induction l1 as [| n l1'].
  Case "l1 = nil".
    simpl. rewrite -> app_ass. reflexivity.
  Case "l1 = n :: l1'".
    simpl. rewrite <- app_ass. rewrite <- app_ass. reflexivity.
Qed.

Theorem snoc_append : forall (l:natlist) (n:nat),
    snoc l n = l ++ [n].
Proof.
  intros l n.
  induction l as [| n' l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = n' l'".
    simpl. rewrite -> IHl'. reflexivity.
Qed.

Theorem app_nil : forall l : natlist,
    l ++ [] = l.
Proof.
  intros l. induction l as [|n l'].
  Case "l = nil".
    simpl. reflexivity.
  Case "l = n :: l'".
    simpl. rewrite -> IHl'. reflexivity.
Qed.

(*わかりません(絶望)*)
(*三章でif文のdestructを知って使ったらこれだよ☆*)
(*恐らくnonzerosの実装に問題があるためこのようにせざるを得ないのだと思います*)
Lemma nonzeros_length : forall l1 l2 : natlist,
    nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2.
  induction l1 as [| n l1'].
  Case "l1 = []". reflexivity.
  Case "l1 = n :: l1'".
    simpl. destruct (beq_nat n 0).
    SCase "beq_nat n 0 = true". rewrite -> IHl1'. reflexivity.
    SCase "beq_nat n 0 = false".
      rewrite -> IHl1'. simpl. reflexivity.
Qed.

End NatList.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Fixpoint bgcdn (k m n : nat) :=
  if m == 0 then n else
  if m == 1 then 1 else
  if n == 0 then m else
  if n == 1 then 1 else
  if k is k1.+1 then
    if odd m then
      if odd n then
        let m1 := maxn m n in
        let n1 := minn m n in
        bgcdn k1 (m1 - n1)./2 n1
      else bgcdn k1 m n./2
    else
      if odd n then bgcdn k1 m./2 n
      else (bgcdn k1 m./2 n./2).*2
  else 1.

Lemma bgcdnC k m n : bgcdn k m n = bgcdn k n m.
Proof.
elim: k m n => [|k IH] [|[|m]] [|[|n]] //=.
case: odd; case: odd => //=.
  by rewrite maxnC minnC.
by rewrite IH.
Qed.

Lemma bgcdnE k1 k2 m n :
  m < 2 ^ k1 -> n < 2 ^ k2 -> bgcdn (k1 + k2) m n = gcdn m n.
Proof.
elim: {k1 k2}_.+1 {-2}k1 {-2} k2 (ltnSn (k1 + k2)) m n =>
         // k IH [|k1] [|k2] Hk // [|[|m]] [|[|n]] //= Hm Hn.
- by rewrite gcd1n.
- by rewrite gcdn1.
move: (odd_double_half m) (odd_double_half n).
have [Om|Em] := boolP (odd _); have [On|En] := boolP (odd _);
     rewrite ?add0n ?add1n => //= mE nE.
- rewrite /maxn /minn; case: leqP => [nLm|mLn].
    have mDnE :  m.+2 - n.+2 = (m.+2 - n.+2)./2.*2.
      by rewrite -{1}(odd_double_half (_ - _)) oddB //= Om On.
    rewrite IH //.
      rewrite  -{2}[m.+2](subnK nLm) [RHS]gcdnC [RHS]gcdnDr [RHS]gcdnC.
      rewrite {2}mDnE -muln2 [LHS]gcdnC [RHS]gcdnC Gauss_gcdl //.
      by rewrite /coprime -gcdn_modl modn2 /= On gcd1n.
    rewrite -ltn_double -mDnE -mul2n -expnS (leq_trans _ Hm) //.
    by rewrite (leq_trans _ (_ : m.+2 < _)) // ltnS leq_subr.
  have m1Ln : m.+1 < n.+2 by apply: leq_trans mLn.
  have nDmE :  n.+2 - m.+2 = (n.+2 - m.+2)./2.*2.
    by rewrite -{1}(odd_double_half (_ - _)) oddB //= Om On.
  rewrite [(_ + _)%Nrec]addnC addSnnS IH //; last first.
  - rewrite -ltn_double -nDmE -mul2n -expnS (leq_trans _ Hn) //.
    by rewrite (leq_trans _ (_ : n.+2 < _)) // ltnS leq_subr.
  - by rewrite addnC addSnnS.
  rewrite  -{2}[n.+2](subnK m1Ln) gcdnDr.
  rewrite {2}nDmE -muln2 Gauss_gcdl 1?gcdnC //.
  by rewrite /coprime -gcdn_modl modn2 /= Om gcd1n.
- rewrite -[(_ + _)%Nrec]addSnnS IH //; last 2 first.
  - by rewrite addSnnS.
  - rewrite -nE expnS mul2n in Hn.
    by rewrite (ltn_double _.+1) in Hn.
  rewrite -{2}nE -doubleS -muln2 Gauss_gcdl //.
  by rewrite /coprime -gcdn_modl modn2 /= Om gcd1n.
- rewrite IH //; last first.
    rewrite -mE expnS mul2n in Hm.
    by rewrite (ltn_double _.+1) in Hm.
  rewrite -{2}mE.
  rewrite -doubleS -muln2 [LHS]gcdnC [RHS]gcdnC Gauss_gcdl //.
  by rewrite /coprime -gcdn_modl modn2 /= On gcd1n.
rewrite IH //; last 2 first.
- by rewrite -mE -doubleS expnS mul2n ltn_double in Hm.
- rewrite -nE -doubleS expnS mul2n ltn_double in Hn.
  by rewrite (leq_trans Hn) // leq_exp2l.
rewrite -{2}mE -{2}nE -!doubleS -!muln2.
by rewrite  muln_gcdl.
Qed.


Require Export Reals.
Require Export TopologicalSpaces.
Require Export NeighborhoodBases.
Require Import RationalsInReals.
Require Export EnsemblesSpec.

Open Scope R_scope.

Section metric.

Variable X:Type.
Variable d:X->X->R.

Record metric : Prop := {
  metric_nonneg: forall x y:X, d x y >= 0;
  metric_sym: forall x y:X, d x y = d y x;
  triangle_inequality: forall x y z:X, d x z <= d x y + d y z;
  metric_zero: forall x:X, d x x = 0;
  metric_strict: forall x y:X, d x y = 0 -> x = y
}.

End metric.

Implicit Arguments metric [[X]].

Section metric_topology.

Variable X:Type.
Variable d:X->X->R.
Hypothesis d_is_metric: metric d.

Definition open_ball (x0:X) (r:R) : Ensemble X :=
  [ x:X | d x0 x < r ].

Inductive metric_topology_neighborhood_basis (x:X) : Family X :=
  | intro_open_ball: forall r:R, r > 0 ->
    In (metric_topology_neighborhood_basis x) (open_ball x r).

Definition MetricTopology : TopologicalSpace.
refine (Build_TopologicalSpace_from_open_neighborhood_bases
  X metric_topology_neighborhood_basis _ _ _ _).

intros.
destruct H as [r1].
destruct H0 as [r2].
exists (open_ball x (Rmin r1 r2)); split.
constructor.
apply Rmin_Rgt_r; split; trivial.
red; intros.
destruct H1.
constructor; constructor.
apply Rlt_le_trans with (Rmin r1 r2); trivial.
apply Rmin_l.
apply Rlt_le_trans with (Rmin r1 r2); trivial.
apply Rmin_r.

intros.
destruct H.
constructor.
rewrite metric_zero; trivial.

intro.
exists (open_ball x 1).
constructor.
auto with *.

intros.
destruct H.
destruct H0.
exists (open_ball y (r - d x y)); split.
constructor.
apply Rgt_minus; trivial.
red; intros z ?.
destruct H1.
constructor.
apply Rle_lt_trans with (d x y + d y z).
apply triangle_inequality; trivial.
assert (d x y + d y z < d x y + (r - d x y)).
auto with *.
ring_simplify in H2.
assumption.
Defined.

End metric_topology.

Implicit Arguments metric_topology_neighborhood_basis [[X]].
Implicit Arguments MetricTopology [[X]].

Definition metrizes (X:TopologicalSpace)
  (d:point_set X -> point_set X -> R) : Prop :=
  forall x:point_set X, open_neighborhood_basis
             (metric_topology_neighborhood_basis d x) x.

Inductive metrizable (X:TopologicalSpace) : Prop :=
  | intro_metrizable: forall d:point_set X -> point_set X -> R,
    metric d -> metrizes X d ->
    metrizable X.

Lemma MetricTopology_metrizable: forall (X:Type) (d:X->X->R)
  (d_metric: metric d),
  metrizes (MetricTopology d d_metric) d.
Proof.
intros.
red.
intros.
apply Build_TopologicalSpace_from_open_neighborhood_bases_basis.
Qed.

Require Export Nets.

Lemma metric_space_net_limit: forall (X:TopologicalSpace)
  (d:point_set X -> point_set X -> R), metrizes X d ->
  forall (I:DirectedSet) (x:Net I X) (x0:point_set X),
  (forall eps:R, eps > 0 -> for large i:DS_set I, d x0 (x i) < eps) ->
  net_limit x x0.
Proof.
intros.
red; intros.
destruct (H x0).
destruct (open_neighborhood_basis_cond U) as [V []].
split; trivial.
destruct H3.
apply eventually_impl_base with (2:=H0 r H3).
intros.
apply H4.
constructor; trivial.
Qed.

Lemma metric_space_net_limit_converse: forall (X:TopologicalSpace)
  (d:point_set X -> point_set X -> R), metrizes X d ->
  forall (I:DirectedSet) (x:Net I X) (x0:point_set X),
    net_limit x x0 -> forall eps:R, eps > 0 ->
                         for large i:DS_set I, d x0 (x i) < eps.
Proof.
intros.
pose (U:=open_ball _ d x0 eps).
assert (open_neighborhood U x0).
apply H.
constructor; trivial.
destruct H2.
destruct (H0 U) as [i]; trivial.
exists i; intros.
apply H4; trivial.
Qed.

Lemma metric_space_net_cluster_point: forall (X:TopologicalSpace)
  (d:point_set X -> point_set X -> R), metrizes X d ->
  forall (I:DirectedSet) (x:Net I X) (x0:point_set X),
  (forall eps:R, eps > 0 ->
     exists arbitrarily large i:DS_set I, d x0 (x i) < eps) ->
  net_cluster_point x x0.
Proof.
intros.
red; intros.
destruct (H x0).
destruct (open_neighborhood_basis_cond U) as
  [? [[]]].
split; trivial.
red; intros.
destruct (H0 r H3 i) as [j []].
exists j; split; trivial.
apply H4.
constructor; trivial.
Qed.

Lemma metric_space_net_cluster_point_converse: forall (X:TopologicalSpace)
  (d:point_set X -> point_set X -> R), metrizes X d ->
  forall (I:DirectedSet) (x:Net I X) (x0:point_set X),
    net_cluster_point x x0 -> forall eps:R, eps > 0 ->
                exists arbitrarily large i:DS_set I, d x0 (x i) < eps.
Proof.
intros.
pose (U:=open_ball _ d x0 eps).
assert (open_neighborhood U x0).
apply H.
constructor; trivial.
destruct H2.
pose proof (H0 U H2 H3).
red; intros.
destruct (H4 i) as [j []].
exists j.
split; trivial.
destruct H6; trivial.
Qed.

Require Export Continuity.

Lemma metric_space_fun_continuity_converse: forall (X Y:TopologicalSpace)
  (f:point_set X->point_set Y) (x:point_set X)
  (dX:point_set X -> point_set X -> R)
  (dY:point_set Y -> point_set Y -> R),
  metrizes X dX -> metrizes Y dY ->
  continuous_at f x -> forall eps:R, eps > 0 ->
                         exists delta:R, delta > 0 /\
                         forall x':point_set X, dX x x' < delta ->
                                        dY (f x) (f x') < eps.
Proof.
intros.
destruct (H x).
destruct (H0 (f x)).
assert (neighborhood (open_ball _ dY (f x) eps) (f x)).
apply open_neighborhood_is_neighborhood.
apply open_neighborhood_basis_elements0.
constructor; trivial.
apply H1 in H3.
destruct H3 as [U].
destruct H3.
destruct (open_neighborhood_basis_cond U H3) as [V].
destruct H5.
destruct H5 as [delta].
exists delta.
split; trivial.
intros.
assert (In (inverse_image f (open_ball _ dY (f x) eps)) x').
apply H4.
apply H6.
constructor.
trivial.
destruct H8.
destruct H8.
trivial.
Qed.

Lemma metric_space_fun_continuity: forall (X Y:TopologicalSpace)
  (f:point_set X->point_set Y) (x:point_set X)
  (dX:point_set X -> point_set X -> R)
  (dY:point_set Y -> point_set Y -> R),
  metrizes X dX -> metrizes Y dY ->
  (forall eps:R, eps > 0 -> exists delta:R, delta > 0 /\
                         forall x':point_set X, dX x x' < delta ->
                                        dY (f x) (f x') < eps) ->
  continuous_at f x.
Proof.
intros.
destruct (H x).
destruct (H0 (f x)).
red; intros.
destruct H2 as [V'].
destruct H2.
destruct (open_neighborhood_basis_cond0 V' H2).
destruct H4.
destruct H4 as [eps].
destruct (H1 eps H4) as [delta []].
exists (open_ball _ dX x delta).
split.
apply open_neighborhood_basis_elements.
constructor; trivial.
intros x' ?.
destruct H8.
constructor.
apply H3.
apply H5.
constructor.
apply H7; trivial.
Qed.

Require Export CountabilityAxioms.

Lemma metrizable_impl_first_countable: forall X:TopologicalSpace,
  metrizable X -> first_countable X.
Proof.
intros.
destruct H.
red; intros.
exists (Im [n:nat | (n>0)%nat]
           (fun n:nat => open_ball _ d x (/ (INR n)))).
split.
apply open_neighborhood_basis_is_neighborhood_basis.
constructor.
intros.
destruct H1 as [n ? V].
destruct H1.
apply H0.
rewrite H2; constructor.
auto with *.

intros.
destruct (H0 x).
destruct (open_neighborhood_basis_cond U) as [V [[eps] ?]]; trivial.
destruct (inverses_of_nats_approach_0 eps H2) as [n [? ?]].
exists (open_ball _ d x (/ (INR n))); split.
exists n; trivial.
constructor; trivial.
red; intros y ?.
apply H3.
destruct H6.
constructor.
apply Rlt_trans with (/ INR n); trivial.

apply countable_img.
apply countable_type_ensemble.
exists (fun n:nat => n).
red; intros; trivial.
Qed.

Lemma metrizable_separable_impl_second_countable:
  forall X:TopologicalSpace, metrizable X -> separable X ->
    second_countable X.
Proof.
intros.
destruct H.
destruct H0.
exists (Im [p:(Q*(point_set X))%type |
            let (r,x):=p in (r>0)%Q /\ In S x]
  (fun p:(Q*(point_set X))%type =>
      let (r,x):=p in open_ball _ d x (Q2R r))).
constructor.
intros.
destruct H3.
destruct H3.
destruct x as [r x].
destruct H3.
destruct (H1 x).
destruct (open_neighborhood_basis_elements y).
rewrite H4.
constructor; trivial.
assert (Q2R 0 = 0).
unfold Q2R.
simpl.
ring.
rewrite <- H6.
apply Qlt_Rlt; trivial.
assumption.

intros.
destruct (H1 x).
destruct (open_neighborhood_basis_cond U) as [V [[r]]].
split; trivial.

destruct (dense_meets_every_nonempty_open _ _ H2
  (open_ball _ d x (r/2))).
destruct (open_neighborhood_basis_elements
  (open_ball _ d x (r/2))).
constructor; trivial.
apply Rmult_lt_0_compat; auto with real.
destruct (open_neighborhood_basis_elements
  (open_ball (point_set X) d x (r/2))).
constructor; trivial.
apply Rmult_lt_0_compat; auto with real.
assumption.
exists x.
constructor.
rewrite metric_zero.
apply Rmult_lt_0_compat; auto with real.
trivial.

destruct H7.
destruct H8.

destruct (rationals_dense_in_reals (d x x0) (r - d x x0)) as [r'].
assert (d x x0 + d x x0 < r/2 + r/2).
auto with *.
assert (r/2 + r/2 = r).
field.
rewrite H10 in H9; clear H10.
assert ((d x x0 + d x x0) - d x x0 < r - d x x0).
unfold Rminus.
auto with *.
ring_simplify in H10.
ring_simplify.
assumption.

exists (open_ball _ d x0 (Q2R r')); repeat split.
exists ( (r', x0) ); auto.
constructor; split; trivial.
assert (Q2R r' > 0).
apply Rgt_ge_trans with (d x x0).
apply H9.
apply metric_nonneg; trivial.
apply Rlt_Qlt.
unfold Q2R at 1.
simpl.
ring_simplify.
assumption.

red; intros y ?.
destruct H10.
apply H6.
constructor.
apply Rle_lt_trans with (d x x0 + d x0 y).
apply triangle_inequality; trivial.
apply Rlt_trans with (d x x0 + Q2R r').
auto with *.
destruct H9.
assert (d x x0 + Q2R r' < d x x0 + (r - d x x0)).
auto with *.
ring_simplify in H12.
assumption.
destruct H9.
rewrite metric_sym; trivial.

apply countable_img.
destruct H0 as [h].

destruct (Q_countable).
destruct countable_nat_product as [g].

red.

match goal with |- CountableT ?T =>
exists (fun x:T =>
  match x with
  | exist (r, x0) (intro_characteristic_sat (conj r_pos i)) =>
    g (h (exist _ x0 i), f r)
  end)
end.
red; intros.
destruct x1 as [[r1 x1] [[pos_r1 i1]]].
destruct x2 as [[r2 x2] [[pos_r2 i2]]].
Require Import Proj1SigInjective.
apply subset_eq_compatT.
apply H4 in H5.
f_equal.
injection H5; intros.
apply H3; trivial.
injection H5; intros.
apply H0 in H7.
injection H7; trivial.
Qed.

Lemma metrizable_Lindelof_impl_second_countable:
  forall X:TopologicalSpace, metrizable X -> Lindelof X ->
    second_countable X.
Proof.
intros.
destruct H.
Require Import ClassicalChoice.
destruct (choice (fun (n:{n:nat | (n > 0)%nat}) (S:Family (point_set X)) =>
  Included S (Im Full_set (fun x:point_set X =>
                            open_ball _ d x (/ (INR (proj1_sig n)))))
  /\ Countable S /\ FamilyUnion S = Full_set))
as [choice_fun].
destruct x as [n].
apply H0.
intros.
destruct H2 as [x ? U].
destruct (H1 x).
Opaque In. apply open_neighborhood_basis_elements. Transparent In.
rewrite H3; constructor.
simpl.
auto with *.

apply Extensionality_Ensembles; split; red; intros.
constructor.
simpl.
exists (open_ball _ d x (/ INR n)).
exists x; trivial.
constructor.
rewrite metric_zero; auto with *.

exists (IndexedUnion choice_fun).
constructor.
intros.
destruct H3 as [n V].
destruct (H2 n) as [? [? ?]].
apply H4 in H3.
destruct H3 as [x ? V].
destruct (H1 x).
Opaque In. apply open_neighborhood_basis_elements. Transparent In.
rewrite H7; constructor.
destruct n as [n g].
simpl.
auto with *.

intros.
destruct (H1 x).
destruct (open_neighborhood_basis_cond U) as [V [? ?]].
split; trivial.
inversion H5.
destruct (inverses_of_nats_approach_0 (r/2)) as [n [? ?]].
apply Rmult_lt_0_compat; auto with *.
pose (nsig := exist (fun n:nat => (n>0)%nat) n H9).
destruct (H2 nsig) as [? [? ?]].
assert (In (FamilyUnion (choice_fun nsig)) x).
rewrite H13; constructor.
destruct H14 as [W].
pose proof (H11 _ H14).
destruct H16 as [y ? W].
rewrite H17 in H15; destruct H15.
exists W; repeat split.
exists nsig; trivial.
assert (Included W V); auto with *.
rewrite H17; rewrite <- H8.
red; intros z ?.
destruct H18.
constructor.
apply Rle_lt_trans with (d x y + d y z).
apply triangle_inequality; trivial.
rewrite (metric_sym _ d H x y).
apply Rlt_trans with (/ INR (proj1_sig nsig) + / INR (proj1_sig nsig)).
auto with *.
simpl.
assert (r = r/2 + r/2).
field.
rewrite H19; clear H19.
auto with *.
rewrite H17; constructor.
assumption.

apply countable_union.
apply countable_type_ensemble.
exists (fun n:nat => n).
red; intros; trivial.
intro.
destruct (H2 a) as [? [? ?]]; trivial.
Qed.

Section dist_to_set.

Variable X:Type.
Variable d:X->X->R.
Hypothesis d_is_metric: metric d.
Variable S:Ensemble X.
Hypothesis S_nonempty: Inhabited S.

Require Export SupInf.

Definition dist_to_set (x:X) : R.
refine (proj1_sig (inf (Im S (d x)) _ _)).
exists 0.
red; intros.
destruct H.
rewrite H0; apply metric_nonneg; trivial.
destruct S_nonempty.
exists (d x x0); exists x0; trivial.
Defined.

Lemma dist_to_set_triangle_inequality: forall (x y:X),
  dist_to_set y <= dist_to_set x + d x y.
Proof.
intros.
unfold dist_to_set at 1; destruct inf as [dSy [? ?]].
simpl.
unfold dist_to_set at 1; destruct inf as [dSx].
simpl.
clear r.
apply lt_plus_epsilon_le.
intros.
destruct (glb_approx _ _ _ i0 H) as [dxz [[z]]].
rewrite H1 in H2; clear y0 H1.
destruct H2.
apply Rle_lt_trans with (d y z).
assert (d y z >= dSy); auto with *.
apply i.
exists z; trivial.
apply Rle_lt_trans with (d y x + d x z).
apply triangle_inequality; trivial.
rewrite (metric_sym _ _ d_is_metric y x).
replace (dSx + d x y + eps) with (d x y + (dSx + eps)).
auto with *.
ring.
Qed.

End dist_to_set.

Implicit Arguments dist_to_set [[X]].
Implicit Arguments dist_to_set_triangle_inequality [[X]].

Section dist_to_set_and_topology.

Variable X:TopologicalSpace.
Variable d:point_set X -> point_set X -> R.
Hypothesis d_is_metric: metric d.
Hypothesis d_metrizes_X: metrizes X d.
Variable S:Ensemble (point_set X).
Hypothesis S_nonempty: Inhabited S.

Lemma dist_to_set_zero_impl_closure: forall x:point_set X,
  dist_to_set d d_is_metric S S_nonempty x = 0 -> In (closure S) x.
Proof.
intros.
apply NNPP; intro.
destruct (d_metrizes_X x).
destruct (open_neighborhood_basis_cond (Complement (closure S))) as [V [? ?]].
split; trivial.
apply closure_closed.
destruct H1 as [r].
unfold dist_to_set in H.
destruct inf in H.
simpl in H.
rewrite H in i; clear x0 H.
destruct i.
assert (is_lower_bound (Im S (d x)) r).
red; intros y ?.
destruct H4 as [y].
rewrite H5; clear y0 H5.
destruct (total_order_T (d x y) r) as [[?|?]|?]; auto with *.
assert (In (open_ball _ d x r) y).
constructor; trivial.
apply H2 in H5.
contradiction H5.
apply closure_inflationary; trivial.
apply H3 in H4.
assert (0 < 0).
apply Rlt_le_trans with r; trivial.
revert H5; apply Rlt_irrefl.
Qed.

Lemma closure_impl_dist_to_set_zero: forall x:point_set X,
  In (closure S) x -> dist_to_set d d_is_metric S S_nonempty x = 0.
Proof.
intros.
unfold dist_to_set; destruct inf.
destruct i.
simpl.
apply Rle_antisym.
apply lt_plus_epsilon_le.
intros.
ring_simplify.
assert (exists y:point_set X, In S y /\ d x y < eps).
apply NNPP; intro.
pose proof (not_ex_all_not _ _ H1).
clear H1.
simpl in H2.
assert (In (interior (Complement S)) x).
exists (open_ball _ d x eps).
red; split.
destruct (d_metrizes_X x).
destruct (open_neighborhood_basis_elements (open_ball _ d x eps)).
constructor; trivial.
split.
assumption.

red; intros y ?.
destruct H4.
red; red; intro.
contradiction (H2 y).
split; trivial.

constructor.
rewrite metric_zero; trivial.

rewrite interior_complement in H1.
contradiction H1; trivial.

destruct H1 as [y [? ?]].
apply Rle_lt_trans with (d x y); trivial.
assert (d x y >= x0).
apply i.
exists y; trivial.
auto with *.

apply r.
red; intros.
destruct H0.
rewrite H1; apply metric_nonneg; trivial.
Qed.

Variable T:Ensemble (point_set X).
Hypothesis T_nonempty: Inhabited T.

Lemma closer_to_S_than_T_open: open
  [x:point_set X | dist_to_set d d_is_metric S S_nonempty x <
                   dist_to_set d d_is_metric T T_nonempty x].
Proof.
match goal with |- open ?U => assert (interior U = U) end.
apply Extensionality_Ensembles; split.
apply interior_deflationary.
red; intros.
destruct H.
match type of H with ?d1 < ?d2 => pose (eps := d2 - d1) end.
match goal with |- In (interior ?U) x =>
  assert (Included (open_ball _ d x (eps/2)) (interior U)) end.
apply interior_maximal.
destruct (d_metrizes_X x).
destruct (open_neighborhood_basis_elements
  (open_ball _ d x (eps/2))).
constructor.
assert (eps > 0).
apply Rgt_minus; auto with *.
apply Rmult_gt_0_compat; auto with *.
assumption.
red; intros.
destruct H0.
constructor.
apply Rle_lt_trans with
  (dist_to_set d d_is_metric S S_nonempty x +
   d x x0).
apply dist_to_set_triangle_inequality.
apply Rlt_le_trans with
  (dist_to_set d d_is_metric T T_nonempty x - d x x0).
apply Rminus_lt.
ring_simplify.
assert (2 * d x x0 < eps).
replace eps with (2 * (eps / 2)).
auto with *.
field.
match goal with |- ?LHS < 0 => replace LHS with (2 * d x x0 - eps) end.
apply Rlt_minus; trivial.
unfold eps; ring.

assert (dist_to_set d d_is_metric T T_nonempty x <=
        dist_to_set d d_is_metric T T_nonempty x0 + d x x0).
rewrite (metric_sym _ d d_is_metric x x0).
apply dist_to_set_triangle_inequality.
apply Rminus_le.
apply Rle_minus in H1.
match type of H1 with ?A <= 0 =>
  match goal with |- ?B <= 0 =>
    replace B with A end end.
assumption.
ring.

apply H0.
constructor.
rewrite metric_zero.
apply Rmult_gt_0_compat; auto with *.
apply Rgt_minus; trivial.
trivial.

rewrite <- H; apply interior_open.
Qed.

End dist_to_set_and_topology.

Require Export SeparatednessAxioms.

Lemma metrizable_impl_normal_sep: forall X:TopologicalSpace,
  metrizable X -> normal_sep X.
Proof.
intros.
destruct H.
split.
red; intros.
assert (closure (Singleton x) = Singleton x).
apply Extensionality_Ensembles; split.
red; intros.
assert (x0 = x).
apply metric_strict with d; trivial.
apply NNPP; intro.
assert (d x0 x > 0).
destruct (total_order_T (d x0 x) 0) as [[?|?]|?]; trivial.
assert (0 < 0).
apply Rle_lt_trans with (d x0 x); trivial.
assert (d x0 x >= 0); auto with *.
apply metric_nonneg; trivial.
contradict H3; apply Rlt_irrefl.
contradiction H2.

assert (In (interior (Complement (Singleton x))) x0).
exists (open_ball _ d x0 (d x0 x)).
split.
destruct (H0 x0).
destruct (open_neighborhood_basis_elements
  (open_ball (point_set X) d x0 (d x0 x))).
constructor; trivial.
split.
assumption.
red; intros.
intro.
destruct H7.
destruct H6.
revert H6; apply Rlt_irrefl.
constructor.
rewrite metric_zero; trivial.

rewrite interior_complement in H4.
contradiction H4.

rewrite H2; constructor.

apply closure_inflationary.

rewrite <- H1; apply closure_closed.

intros.
Require Import DecidableDec.
case (classic_dec (Inhabited F)); intro.
case (classic_dec (Inhabited G)); intro.

pose (U := [ x:point_set X | dist_to_set d H F i x <
                             dist_to_set d H G i0 x ]).
pose (V := [ x:point_set X | dist_to_set d H G i0 x <
                             dist_to_set d H F i x ]).
exists U; exists V; repeat split.
apply closer_to_S_than_T_open; trivial.
apply closer_to_S_than_T_open; trivial.
replace (dist_to_set d H F i x) with 0.
destruct (total_order_T 0 (dist_to_set d H G i0 x)) as [[?|?]|?]; trivial.
symmetry in e.
apply dist_to_set_zero_impl_closure in e.
rewrite closure_fixes_closed in e; trivial.
assert (In Empty_set x).
rewrite <- H3; constructor; trivial.
destruct H5.
trivial.

assert (0 < 0).
apply Rle_lt_trans with (dist_to_set d H G i0 x); auto with sets.
unfold dist_to_set; destruct inf.
simpl.
apply i1.
red; intros.
destruct H5.
rewrite H6; apply metric_nonneg; trivial.
contradict H5; apply Rlt_irrefl.

unfold dist_to_set; destruct inf.
simpl.
apply Rle_antisym.
apply i1.
red; intros.
destruct H5.
rewrite H6; apply metric_nonneg; trivial.
destruct i1.
assert (0 >= x0); auto with *.
apply H5.
exists x; trivial.
symmetry; apply metric_zero; trivial.

replace (dist_to_set d H G i0 x) with 0.
destruct (total_order_T 0 (dist_to_set d H F i x)) as [[?|?]|?]; trivial.
symmetry in e.
apply dist_to_set_zero_impl_closure in e.
rewrite closure_fixes_closed in e; trivial.
assert (In Empty_set x).
rewrite <- H3; constructor; trivial.
destruct H5.
trivial.

assert (0 < 0).
apply Rle_lt_trans with (dist_to_set d H F i x); auto with *.
unfold dist_to_set; destruct inf.
simpl.
apply i1.
red; intros.
destruct H5.
rewrite H6; apply metric_nonneg; trivial.
contradict H5; apply Rlt_irrefl.

symmetry.
apply closure_impl_dist_to_set_zero; trivial.
apply closure_inflationary; trivial.

apply Extensionality_Ensembles; split; auto with sets.
red; intros.
destruct H4.
destruct H4.
destruct H5.
contradict H5.
auto with *.

exists Full_set; exists Empty_set; repeat split; auto with topology.
red; intros.
contradiction n.
exists x; trivial.

auto with sets.

exists Empty_set; exists Full_set; repeat split; auto with topology.
red; intros.
contradiction n.
exists x; trivial.
auto with sets.
Qed.