(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Import ZAxioms ZMulOrder ZSgnAbs NZDiv.

(** * Euclidean Division for integers, Euclid convention

    We use here the "usual" formulation of the Euclid Theorem
    [forall a b, b<>0 -> exists r q, a = b*q+r /\ 0 <= r < |b| ]

    The outcome of the modulo function is hence always positive.
    This corresponds to convention "E" in the following paper:

    R. Boute, "The Euclidean definition of the functions div and mod",
    ACM Transactions on Programming Languages and Systems,
    Vol. 14, No.2, pp. 127-144, April 1992.

    See files [ZDivTrunc] and [ZDivFloor] for others conventions.

    We simply extend NZDiv with a bound for modulo that holds
    regardless of the sign of a and b. This new specification
    subsume mod_bound_pos, which nonetheless stays there for
    subtyping. Note also that ZAxiomSig now already contain
    a div and a modulo (that follow the Floor convention).
    We just ignore them here.
*)

Module Type EuclidSpec (Import A : ZAxiomsSig')(Import B : DivMod A).
 Axiom mod_always_pos : forall a b, b ~= 0 -> 0 <= B.modulo a b < abs b.
End EuclidSpec.

Module Type ZEuclid (Z:ZAxiomsSig) := NZDiv.NZDiv Z <+ EuclidSpec Z.

Module ZEuclidProp
 (Import A : ZAxiomsSig')
 (Import B : ZMulOrderProp A)
 (Import C : ZSgnAbsProp A B)
 (Import D : ZEuclid A).

 (** We put notations in a scope, to avoid warnings about
     redefinitions of notations *)
 Infix "/" := D.div : euclid.
 Infix "mod" := D.modulo : euclid.
 Local Open Scope euclid.

 Module Import Private_NZDiv := Nop <+ NZDivProp A D B.

(** Another formulation of the main equation *)

Lemma mod_eq :
 forall a b, b~=0 -> a mod b == a - b*(a/b).
Proof.
intros.
rewrite <- add_move_l.
symmetry. now apply div_mod.
Qed.

Ltac pos_or_neg a :=
 let LT := fresh "LT" in
 let LE := fresh "LE" in
 destruct (le_gt_cases 0 a) as [LE|LT]; [|rewrite <- opp_pos_neg in LT].

(** Uniqueness theorems *)

Theorem div_mod_unique : forall b q1 q2 r1 r2 : t,
  0<=r1<abs b -> 0<=r2<abs b ->
  b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2.
Proof.
intros b q1 q2 r1 r2 Hr1 Hr2 EQ.
pos_or_neg b.
rewrite abs_eq in * by trivial.
apply div_mod_unique with b; trivial.
rewrite abs_neq' in * by auto using lt_le_incl.
rewrite eq_sym_iff. apply div_mod_unique with (-b); trivial.
rewrite 2 mul_opp_l.
rewrite add_move_l, sub_opp_r.
rewrite <-add_assoc.
symmetry. rewrite add_move_l, sub_opp_r.
now rewrite (add_comm r2), (add_comm r1).
Qed.

Theorem div_unique:
 forall a b q r, 0<=r<abs b -> a == b*q + r -> q == a/b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0).
 pos_or_neg b.
 rewrite abs_eq in Hr; intuition; order.
 rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

Theorem mod_unique:
 forall a b q r, 0<=r<abs b -> a == b*q + r -> r == a mod b.
Proof.
intros a b q r Hr EQ.
assert (Hb : b~=0).
 pos_or_neg b.
 rewrite abs_eq in Hr; intuition; order.
 rewrite <- opp_0, eq_opp_r. rewrite abs_neq' in Hr; intuition; order.
destruct (div_mod_unique b q (a/b) r (a mod b)); trivial.
now apply mod_always_pos.
now rewrite <- div_mod.
Qed.

(** Sign rules *)

Lemma div_opp_r : forall a b, b~=0 -> a/(-b) == -(a/b).
Proof.
intros. symmetry.
apply div_unique with (a mod b).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma mod_opp_r : forall a b, b~=0 -> a mod (-b) == a mod b.
Proof.
intros. symmetry.
apply mod_unique with (-(a/b)).
rewrite abs_opp; now apply mod_always_pos.
rewrite mul_opp_opp; now apply div_mod.
Qed.

Lemma div_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a)/b == -(a/b).
Proof.
intros a b Hb Hab. symmetry.
apply div_unique with (-(a mod b)).
rewrite Hab, opp_0. split; [order|].
pos_or_neg b; [rewrite abs_eq | rewrite abs_neq']; order.
now rewrite mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma div_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a)/b == -(a/b)-sgn b.
Proof.
intros a b Hb Hab. symmetry.
apply div_unique with (abs b -(a mod b)).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma mod_opp_l_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a) mod b == 0.
Proof.
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)).
split; [order|now rewrite abs_pos].
now rewrite <-opp_0, <-Hab, mul_opp_r, <-opp_add_distr, <-div_mod.
Qed.

Lemma mod_opp_l_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a) mod b == abs b - (a mod b).
Proof.
intros a b Hb Hab. symmetry.
apply mod_unique with (-(a/b)-sgn b).
rewrite lt_sub_lt_add_l.
rewrite <- le_add_le_sub_l. nzsimpl.
rewrite <- (add_0_l (abs b)) at 2.
rewrite <- add_lt_mono_r.
destruct (mod_always_pos a b); intuition order.
rewrite <- 2 add_opp_r, mul_add_distr_l, 2 mul_opp_r.
rewrite sgn_abs.
rewrite add_shuffle2, add_opp_diag_l; nzsimpl.
rewrite <-opp_add_distr, <-div_mod; order.
Qed.

Lemma div_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a)/(-b) == a/b.
Proof.
intros. now rewrite div_opp_r, div_opp_l_z, opp_involutive.
Qed.

Lemma div_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a)/(-b) == a/b + sgn(b).
Proof.
intros. rewrite div_opp_r, div_opp_l_nz by trivial.
now rewrite opp_sub_distr, opp_involutive.
Qed.

Lemma mod_opp_opp_z : forall a b, b~=0 -> a mod b == 0 ->
 (-a) mod (-b) == 0.
Proof.
intros. now rewrite mod_opp_r, mod_opp_l_z.
Qed.

Lemma mod_opp_opp_nz : forall a b, b~=0 -> a mod b ~= 0 ->
 (-a) mod (-b) == abs b - a mod b.
Proof.
intros. now rewrite mod_opp_r, mod_opp_l_nz.
Qed.

(** A division by itself returns 1 *)

Lemma div_same : forall a, a~=0 -> a/a == 1.
Proof.
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
now nzsimpl.
Qed.

Lemma mod_same : forall a, a~=0 -> a mod a == 0.
Proof.
intros.
rewrite mod_eq, div_same by trivial. nzsimpl. apply sub_diag.
Qed.

(** A division of a small number by a bigger one yields zero. *)

Theorem div_small: forall a b, 0<=a<b -> a/b == 0.
Proof. exact div_small. Qed.

(** Same situation, in term of modulo: *)

Theorem mod_small: forall a b, 0<=a<b -> a mod b == a.
Proof. exact mod_small. Qed.

(** * Basic values of divisions and modulo. *)

Lemma div_0_l: forall a, a~=0 -> 0/a == 0.
Proof.
intros. pos_or_neg a. apply div_0_l; order.
apply opp_inj. rewrite <- div_opp_r, opp_0 by trivial. now apply div_0_l.
Qed.

Lemma mod_0_l: forall a, a~=0 -> 0 mod a == 0.
Proof.
intros; rewrite mod_eq, div_0_l; now nzsimpl.
Qed.

Lemma div_1_r: forall a, a/1 == a.
Proof.
intros. symmetry. apply div_unique with 0.
assert (H:=lt_0_1); rewrite abs_pos; intuition; order.
now nzsimpl.
Qed.

Lemma mod_1_r: forall a, a mod 1 == 0.
Proof.
intros. rewrite mod_eq, div_1_r; nzsimpl; auto using sub_diag.
apply neq_sym, lt_neq; apply lt_0_1.
Qed.

Lemma div_1_l: forall a, 1<a -> 1/a == 0.
Proof. exact div_1_l. Qed.

Lemma mod_1_l: forall a, 1<a -> 1 mod a == 1.
Proof. exact mod_1_l. Qed.

Lemma div_mul : forall a b, b~=0 -> (a*b)/b == a.
Proof.
intros. symmetry. apply div_unique with 0.
split; [order|now rewrite abs_pos].
nzsimpl; apply mul_comm.
Qed.

Lemma mod_mul : forall a b, b~=0 -> (a*b) mod b == 0.
Proof.
intros. rewrite mod_eq, div_mul by trivial. rewrite mul_comm; apply sub_diag.
Qed.

Theorem div_unique_exact a b q: b~=0 -> a == b*q -> q == a/b.
Proof.
 intros Hb H. rewrite H, mul_comm. symmetry. now apply div_mul.
Qed.

(** * Order results about mod and div *)

(** A modulo cannot grow beyond its starting point. *)

Theorem mod_le: forall a b, 0<=a -> b~=0 -> a mod b <= a.
Proof.
intros. pos_or_neg b. apply mod_le; order.
rewrite <- mod_opp_r by trivial. apply mod_le; order.
Qed.

Theorem div_pos : forall a b, 0<=a -> 0<b -> 0<= a/b.
Proof. exact div_pos. Qed.

Lemma div_str_pos : forall a b, 0<b<=a -> 0 < a/b.
Proof. exact div_str_pos. Qed.

Lemma div_small_iff : forall a b, b~=0 -> (a/b==0 <-> 0<=a<abs b).
Proof.
intros a b Hb.
split.
intros EQ.
rewrite (div_mod a b Hb), EQ; nzsimpl.
now apply mod_always_pos.
intros. pos_or_neg b.
apply div_small.
now rewrite <- (abs_eq b).
apply opp_inj; rewrite opp_0, <- div_opp_r by trivial.
apply div_small.
rewrite <- (abs_neq' b) by order. trivial.
Qed.

Lemma mod_small_iff : forall a b, b~=0 -> (a mod b == a <-> 0<=a<abs b).
Proof.
intros.
rewrite <- div_small_iff, mod_eq by trivial.
rewrite sub_move_r, <- (add_0_r a) at 1. rewrite add_cancel_l.
rewrite eq_sym_iff, eq_mul_0. tauto.
Qed.

(** As soon as the divisor is strictly greater than 1,
    the division is strictly decreasing. *)

Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a.
Proof. exact div_lt. Qed.

(** [le] is compatible with a positive division. *)

Lemma div_le_mono : forall a b c, 0<c -> a<=b -> a/c <= b/c.
Proof.
intros a b c Hc Hab.
rewrite lt_eq_cases in Hab. destruct Hab as [LT|EQ];
 [|rewrite EQ; order].
rewrite <- lt_succ_r.
rewrite (mul_lt_mono_pos_l c) by order.
nzsimpl.
rewrite (add_lt_mono_r _ _ (a mod c)).
rewrite <- div_mod by order.
apply lt_le_trans with b; trivial.
rewrite (div_mod b c) at 1 by order.
rewrite <- add_assoc, <- add_le_mono_l.
apply le_trans with (c+0).
nzsimpl; destruct (mod_always_pos b c); try order.
rewrite abs_eq in *; order.
rewrite <- add_le_mono_l. destruct (mod_always_pos a c); order.
Qed.

(** In this convention, [div] performs Rounding-Toward-Bottom
    when divisor is positive, and Rounding-Toward-Top otherwise.

    Since we cannot speak of rational values here, we express this
    fact by multiplying back by [b], and this leads to a nice
    unique statement.
*)

Lemma mul_div_le : forall a b, b~=0 -> b*(a/b) <= a.
Proof.
intros.
rewrite (div_mod a b) at 2; trivial.
rewrite <- (add_0_r (b*(a/b))) at 1.
rewrite <- add_le_mono_l.
now destruct (mod_always_pos a b).
Qed.

(** Giving a reversed bound is slightly more complex *)

Lemma mul_succ_div_gt: forall a b, 0<b -> a < b*(S (a/b)).
Proof.
intros.
nzsimpl.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite abs_eq in *; order.
Qed.

Lemma mul_pred_div_gt: forall a b, b<0 -> a < b*(P (a/b)).
Proof.
intros a b Hb.
rewrite mul_pred_r, <- add_opp_r.
rewrite (div_mod a b) at 1; try order.
rewrite <- add_lt_mono_l.
destruct (mod_always_pos a b). order.
rewrite <- opp_pos_neg in Hb. rewrite abs_neq' in *; order.
Qed.

(** NB: The three previous properties could be used as
    specifications for [div]. *)

(** Inequality [mul_div_le] is exact iff the modulo is zero. *)

Lemma div_exact : forall a b, b~=0 -> (a == b*(a/b) <-> a mod b == 0).
Proof.
intros.
rewrite (div_mod a b) at 1; try order.
rewrite <- (add_0_r (b*(a/b))) at 2.
apply add_cancel_l.
Qed.

(** Some additional inequalities about div. *)

Theorem div_lt_upper_bound:
  forall a b q, 0<b -> a < b*q -> a/b < q.
Proof.
intros.
rewrite (mul_lt_mono_pos_l b) by trivial.
apply le_lt_trans with a; trivial.
apply mul_div_le; order.
Qed.

Theorem div_le_upper_bound:
  forall a b q, 0<b -> a <= b*q -> a/b <= q.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

Theorem div_le_lower_bound:
  forall a b q, 0<b -> b*q <= a -> q <= a/b.
Proof.
intros.
rewrite <- (div_mul q b) by order.
apply div_le_mono; trivial. now rewrite mul_comm.
Qed.

(** A division respects opposite monotonicity for the divisor *)

Lemma div_le_compat_l: forall p q r, 0<=p -> 0<q<=r -> p/r <= p/q.
Proof. exact div_le_compat_l. Qed.

(** * Relations between usual operations and mod and div *)

Lemma mod_add : forall a b c, c~=0 ->
 (a + b * c) mod c == a mod c.
Proof.
intros.
symmetry.
apply mod_unique with (a/c+b); trivial.
now apply mod_always_pos.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add : forall a b c, c~=0 ->
 (a + b * c) / c == a / c + b.
Proof.
intros.
apply (mul_cancel_l _ _ c); try order.
apply (add_cancel_r _ _ ((a+b*c) mod c)).
rewrite <- div_mod, mod_add by order.
rewrite mul_add_distr_l, add_shuffle0, <- div_mod by order.
now rewrite mul_comm.
Qed.

Lemma div_add_l: forall a b c, b~=0 ->
 (a * b + c) / b == a + c / b.
Proof.
 intros a b c. rewrite (add_comm _ c), (add_comm a).
 now apply div_add.
Qed.

(** Cancellations. *)

(** With the current convention, the following isn't always true
    when [c<0]: [-3*-1 / -2*-1 = 3/2 = 1] while [-3/-2 = 2] *)

Lemma div_mul_cancel_r : forall a b c, b~=0 -> 0<c ->
 (a*c)/(b*c) == a/b.
Proof.
intros.
symmetry.
apply div_unique with ((a mod b)*c).
(* ineqs *)
rewrite abs_mul, (abs_eq c) by order.
rewrite <-(mul_0_l c), <-mul_lt_mono_pos_r, <-mul_le_mono_pos_r by trivial.
now apply mod_always_pos.
(* equation *)
rewrite (div_mod a b) at 1 by order.
rewrite mul_add_distr_r.
rewrite add_cancel_r.
rewrite <- 2 mul_assoc. now rewrite (mul_comm c).
Qed.

Lemma div_mul_cancel_l : forall a b c, b~=0 -> 0<c ->
 (c*a)/(c*b) == a/b.
Proof.
intros. rewrite !(mul_comm c); now apply div_mul_cancel_r.
Qed.

Lemma mul_mod_distr_l: forall a b c, b~=0 -> 0<c ->
  (c*a) mod (c*b) == c * (a mod b).
Proof.
intros.
rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))).
rewrite <- div_mod.
rewrite div_mul_cancel_l by trivial.
rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
apply div_mod; order.
rewrite <- neq_mul_0; intuition; order.
Qed.

Lemma mul_mod_distr_r: forall a b c, b~=0 -> 0<c ->
  (a*c) mod (b*c) == (a mod b) * c.
Proof.
 intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l.
Qed.

(** Operations modulo. *)

Theorem mod_mod: forall a n, n~=0 ->
 (a mod n) mod n == a mod n.
Proof.
intros. rewrite mod_small_iff by trivial.
now apply mod_always_pos.
Qed.

Lemma mul_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)*b) mod n == (a*b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite add_comm, (mul_comm n), (mul_comm _ b).
 rewrite mul_add_distr_l, mul_assoc.
 rewrite mod_add by trivial.
 now rewrite mul_comm.
Qed.

Lemma mul_mod_idemp_r : forall a b n, n~=0 ->
 (a*(b mod n)) mod n == (a*b) mod n.
Proof.
 intros. rewrite !(mul_comm a). now apply mul_mod_idemp_l.
Qed.

Theorem mul_mod: forall a b n, n~=0 ->
 (a * b) mod n == ((a mod n) * (b mod n)) mod n.
Proof.
 intros. now rewrite mul_mod_idemp_l, mul_mod_idemp_r.
Qed.

Lemma add_mod_idemp_l : forall a b n, n~=0 ->
 ((a mod n)+b) mod n == (a+b) mod n.
Proof.
 intros a b n Hn. symmetry.
 rewrite (div_mod a n) at 1 by order.
 rewrite <- add_assoc, add_comm, mul_comm.
 now rewrite mod_add.
Qed.

Lemma add_mod_idemp_r : forall a b n, n~=0 ->
 (a+(b mod n)) mod n == (a+b) mod n.
Proof.
 intros. rewrite !(add_comm a). now apply add_mod_idemp_l.
Qed.

Theorem add_mod: forall a b n, n~=0 ->
 (a+b) mod n == (a mod n + b mod n) mod n.
Proof.
 intros. now rewrite add_mod_idemp_l, add_mod_idemp_r.
Qed.

(** With the current convention, the following result isn't always
    true with a negative intermediate divisor. For instance
    [ 3/(-2)/(-2) = 1 <> 0 = 3 / (-2*-2) ] and
    [ 3/(-2)/2 = -1 <> 0 = 3 / (-2*2) ]. *)

Lemma div_div : forall a b c, 0<b -> c~=0 ->
 (a/b)/c == a/(b*c).
Proof.
 intros a b c Hb Hc.
 apply div_unique with (b*((a/b) mod c) + a mod b).
 (* begin 0<= ... <abs(b*c) *)
 rewrite abs_mul.
 destruct (mod_always_pos (a/b) c), (mod_always_pos a b); try order.
 split.
 apply add_nonneg_nonneg; trivial.
 apply mul_nonneg_nonneg; order.
 apply lt_le_trans with (b*((a/b) mod c) + abs b).
 now rewrite <- add_lt_mono_l.
 rewrite (abs_eq b) by order.
 now rewrite <- mul_succ_r, <- mul_le_mono_pos_l, le_succ_l.
 (* end 0<= ... < abs(b*c) *)
 rewrite (div_mod a b) at 1 by order.
 rewrite add_assoc, add_cancel_r.
 rewrite <- mul_assoc, <- mul_add_distr_l, mul_cancel_l by order.
 apply div_mod; order.
Qed.

(** Similarly, the following result doesn't always hold when [b<0].
    For instance [3 mod (-2*-2)) = 3] while
    [3 mod (-2) + (-2)*((3/-2) mod -2) = -1]. *)

Lemma mod_mul_r : forall a b c, 0<b -> c~=0 ->
 a mod (b*c) == a mod b + b*((a/b) mod c).
Proof.
 intros a b c Hb Hc.
 apply add_cancel_l with (b*c*(a/(b*c))).
 rewrite <- div_mod by (apply neq_mul_0; split; order).
 rewrite <- div_div by trivial.
 rewrite add_assoc, add_shuffle0, <- mul_assoc, <- mul_add_distr_l.
 rewrite <- div_mod by order.
 apply div_mod; order.
Qed.

Lemma mod_div: forall a b, b~=0 ->
 a mod b / b == 0.
Proof.
 intros a b Hb.
 rewrite div_small_iff by assumption.
 auto using mod_always_pos.
Qed.

(** A last inequality: *)

Theorem div_mul_le:
 forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b.
Proof. exact div_mul_le. Qed.

(** mod is related to divisibility *)

Lemma mod_divides : forall a b, b~=0 ->
 (a mod b == 0 <-> (b|a)).
Proof.
intros a b Hb. split.
intros Hab. exists (a/b). rewrite mul_comm.
 rewrite (div_mod a b Hb) at 1. rewrite Hab; now nzsimpl.
intros (c,Hc). rewrite Hc. now apply mod_mul.
Qed.

End ZEuclidProp.


Require Import Reals.
Require Import Rsequence_def.
Require Import Rpser_def Rpser_def_simpl Rpser_base_facts Rpser_sums Rpser_cv_facts.
Require Import Rinterval Ranalysis_def Rfunction_facts.
Require Import Ass_handling.

(** * Extensionality of the common properties of functions. *)

(** Usual properties. *)

Section Functions_extensionality.

Variables f g : R -> R.
Hypothesis fg_ext : f == g.

Lemma continuity_ext : continuity f -> continuity g.
Proof.
intros f_cont x eps eps_pos.
 destruct (f_cont x _ eps_pos) as [delta [delta_pos Hdelta]].
 exists delta ; split ; [assumption |].
 intros ; do 2 rewrite <- fg_ext ; auto.
Qed.

Lemma derivable_pt_lim_ext : forall x l, derivable_pt_lim f x l ->
  derivable_pt_lim g x l.
Proof.
intros x l Hl eps eps_pos ; destruct (Hl _ eps_pos) as [delta Hdelta] ;
 exists delta ; intros ; do 2 rewrite <- fg_ext ; auto.
Qed.

Lemma derivable_pt_ext : forall x, derivable_pt f x ->
  derivable_pt g x.
Proof.
intros x [df Hdf] ; exists df ; apply derivable_pt_lim_ext ; trivial.
Qed.

Lemma derivable_ext : derivable f -> derivable g.
Proof.
intros f_deriv x ; apply derivable_pt_ext ; auto.
Qed.

Lemma derive_pt_ext (x : R) (prf : derivable_pt f x) (prg : derivable_pt g x) :
  derive_pt f x prf = derive_pt g x prg.
Proof.
apply pr_nu_var2 ; assumption.
Qed.

Lemma derive_ext (prf : derivable f) (prg : derivable g) :
  derive f prf == derive g prg.
Proof.
intro x ; unfold derive ; apply derive_pt_ext.
Qed.

End Functions_extensionality.

(** * Extensionality of power serie related concepts. *)

Section Rpser_extensionality.

Variables An Bn : Rseq.
Hypothesis AnBn_ext : (An == Bn)%Rseq.

Lemma sum_f_R0_ext : (sum_f_R0 An == sum_f_R0 Bn)%Rseq.
Proof.
intro n ; induction n ; simpl ; rewrite AnBn_ext ;
 [| rewrite IHn] ; reflexivity.
Qed.

Lemma Pser_ext : forall x l, Pser An x l <-> Pser Bn x l.
Proof.
intros x l ; split ; intros HP eps eps_pos ; destruct (HP _ eps_pos) as [N HN] ;
 exists N ; intros n n_lb ;
 [rewrite (sum_eq _ (fun n => An n * x ^ n)%R) |
 rewrite (sum_eq _ (fun n => Bn n * x ^ n)%R)] ;
 ((apply HN ; assumption) || (intros ; rewrite AnBn_ext ; reflexivity)).
Qed.

Lemma weaksum_r_ext : forall (r : R) (rAn : Cv_radius_weak An r)
 (rBn : Cv_radius_weak Bn r),
 weaksum_r An r rAn == weaksum_r Bn r rBn.
Proof.
intros r rAn rBn x.
 unfold weaksum_r ; destruct (Rlt_le_dec (Rabs x) r) ; trivial.
 destruct (Rpser_abel _ _ rAn x r0) as [l1 Hl1] ; copy Hl1 ;
  rewrite Pser_ext in Hl0.
 destruct (Rpser_abel _ _ rBn x r0) as [l2 Hl2].
 simpl ; eapply Rpser_unique ; eassumption.
Qed.

Lemma sum_r_ext : forall (r : R) (rAn : finite_cv_radius An r)
 (rBn : finite_cv_radius Bn r),
 sum_r An r rAn == sum_r Bn r rBn.
Proof.
intros r rAn rBn x.
 unfold sum_r ; destruct (Rlt_le_dec (Rabs x) r) ; trivial ;
  apply weaksum_r_ext.
Qed.

Lemma sum_ext : forall (rAn : infinite_cv_radius An)
  (rBn : infinite_cv_radius Bn),
  sum An rAn == sum Bn rBn.
intros rAn rBn x ; unfold sum ; apply weaksum_r_ext.
Qed.

End Rpser_extensionality.


From mathcomp Require Import ssreflect seq ssrfun ssrbool ssrnat.
From mf Require Import all_mf.
Require Import pointwise reals.
Require Import Reals Psatz Morphisms ChoiceFacts Classical.

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

Delimit Scope pseudometric_scope with pmetric.
Local Open Scope pseudometric_scope.
Local Open Scope R_scope.
Section pseudometrics.
  Class is_pseudometric `{M: Type} (d: M * M -> R) :=
    {
      positive: forall x y, 0 <= d(x,y);
      symmetric: forall x y, d(x,y) = d(y,x);
      reflexive: forall x, d(x,x) = 0;
      triangle_inequality: forall x y z, d(x,y) <= d(x,z) + d(z,y);
    }.
  Local Notation "p /is_pseudometric":= (is_pseudometric p) (at level 30).

  Context `{is_pseudometric}.
  Implicit Types (x y z: M).

  Lemma dst_pos x y: 0 <= d(x,y).
  Proof. by apply positive. Qed.

  Lemma dst_sym x y: d(x,y) = d(y,x).
  Proof. by apply symmetric. Qed.

  Lemma dstxx x: d(x,x) = 0.
  Proof. by apply reflexive. Qed.

  Lemma dst_trngl z x y: d(x,y) <= d(x,z) + d(z,y).
  Proof. by apply triangle_inequality. Qed.

  Lemma dst_le x y z r r' q: d(x,z) <= r -> d(z,y) <= r' -> r + r' <= q -> d(x,y) <= q.
  Proof.
    move => ineq ienq' add.
    by apply/Rle_trans/add/Rle_trans/Rplus_le_compat; first exact/dst_trngl.
  Qed.

  Lemma le_dst x y z r r' q: r + r' <= q -> d(x,z) <= r -> d(z,y) <= r' -> d(x,y) <= q.
  Proof. by move => ineq dst dst'; apply/dst_le/ineq/dst'/dst. Qed.

  Lemma dst_lt x y z r r' q: d(x,z) <= r -> d(z,y) <= r' -> r + r' < q -> d(x,y) < q.
  Proof.
    move => ineq ienq' add.
    by apply/Rle_lt_trans/add/Rle_trans/Rplus_le_compat; first exact/dst_trngl.
  Qed.
End pseudometrics.
Notation "d \is_pseudometric_on M" := (@is_pseudometric M d) (at level 36): pseudometric_scope.
Notation "d \is_pseudometric" := (is_pseudometric d) (at level 36): pseudometric_scope.

Delimit Scope metric_scope with metric.
Local Open Scope metric_scope.
Section limits.
  Context `{is_pseudometric}.
  Definition limit M (d: M * M -> R) := make_mf (fun xn x =>
    forall eps, 0 < eps -> exists N, forall m,
          (N <= m)%nat -> d (x,xn m) <= eps).

  Local Notation "x \limits xn \wrt d" := (limit d xn x) (at level 4).
  Local Notation "x \is_limit_of xn \wrt d" := (limit d xn x) (at level 4).

  Global Instance lim_prpr M d: Proper (@eqfun M nat ==> @set_equiv M) (limit d).
  Proof.
    move => xn yn eq x.
    split => lim eps eg0; have [N prp]:= lim eps eg0; exists N => m.
    - by rewrite -(eq m); apply/prp.
    by rewrite (eq m); apply/prp.
  Qed.

  Implicit Types (x y z: M).

  Lemma lim_dst xn x y: x \limits xn \wrt d -> y \limits xn \wrt d -> d(x,y) = 0.
  Proof.
    move => limxnx limxnx'.
    apply/cond_eq => eps epsg0.
    rewrite Rminus_0_r Rabs_pos_eq; last by apply dst_pos.
    have [ | N Nprp]:= limxnx (eps/3); try lra.
    have [ | N' N'prp]:= limxnx' (eps/3); try lra.
    pose k:= maxn N N'.
    apply/(@dst_lt _ _ H); first by apply/Nprp/leq_maxl/N'.
    - rewrite dst_sym; apply/N'prp/leq_maxr.
    lra.
  Qed.

  Lemma lim_cnst x: x \limits (cnst x) \wrt d.
  Proof. by exists 0%nat; rewrite/cnst dstxx; intros; lra. Qed.

  Lemma lim_tpmn xn x: x \limits xn \wrt d <->
    (forall n, exists N, forall m, (N <= m)%nat -> d(x,xn m) <= /2 ^ n).
  Proof.
    split => [lim n | lim eps eg0].
    - case: (lim (/2 ^ n)) => [ | N]; last by exists N.
      by apply/Rinv_0_lt_compat/pow_lt; lra.
    have [n [? ineq]]:= accf_tpmn eg0.
    have [N prp]:= lim n; exists N => ? ?.
    exact/Rlt_le/Rle_lt_trans/ineq/prp.
  Qed.

  Lemma dst0_tpmn x y: d(x,y) = 0 <-> forall n, d(x,y) <= / 2 ^ n.
  Proof.
    split => [-> | ?]; first exact/tpmn_pos.
    apply/cond_eq_f; first exact/accf_tpmn.
    rewrite /R_dist Rminus_0_r Rabs_pos_eq //.
    by apply dst_pos.
  Qed.

  Lemma lim_lim_choice xnk xn x:
    FunctionalCountableChoice_on nat ->
    (forall n, (xn n) \limits (xnk n) \wrt d) -> x \limits xn \wrt d ->
    exists mu, x \limits (fun n => xnk n (mu n)) \wrt d.
  Proof.
    move => choice lmtlmt /lim_tpmn lmt.
    have /choice [mu muprp]:
      forall n, exists m, forall k, (m <= k)%nat -> d (xn n, xnk n k) <= /2 ^ n.
    - by move => n; apply/(lmtlmt n (/2^n))/Rinv_0_lt_compat/pow_lt; lra.
    exists mu.
    apply/lim_tpmn => n.
    have [N prp]:= lmt (n.+1).
    exists (maxn n.+1 N) => k ineq.
    apply/(le_dst _)/muprp => //; last exact/prp/leq_trans/ineq/leq_maxr.
    rewrite [X in _ <= X]tpmn_half.
    apply/Rplus_le_compat/Rinv_le_contravar/Rle_pow/leP/leq_trans/ineq/leq_maxl; try lra.
    by apply/pow_lt; lra.
  Qed.
End limits.
Notation "xn \converges_to x \wrt d" := (limit d xn x) (at level 23): pseudometric_scope.

Section density.
  Context `{pm: is_pseudometric}.

  Definition dense_subset (A: subset M):=
    forall x eps, eps > 0 -> exists y, y \from A /\ d(x,y) <= eps.

  Global Instance dns_prpr: Proper (@set_equiv M ==> iff) dense_subset.
  Proof.
    move => A B eq; split => dns x eps eg0; have [y []]:= dns x eps eg0; exists y.
    - by rewrite <-eq.
    by rewrite ->eq.
  Qed.

  Lemma dns_tpmn (A: subset M):
    dense_subset A <-> forall x n, exists y, y \from A /\ d(x,y) <= /2^n.
  Proof.
    split => [dns x n | dns x eps eg0]; first by apply/dns/Rlt_gt/Rinv_0_lt_compat/pow_lt; lra.
    have [n ineq]:= accf_tpmn eg0.
    have [y []]:= dns x n.
    exists y; split => //.
    exact/Rlt_le/Rle_lt_trans/ineq.2.
  Qed.

  Local Notation sequence := (nat -> M).

  Definition dense_sequence (r: sequence) :=
    forall x eps, 0 < eps -> exists n, d(x,r n) <= eps.

  Lemma dseq_dns (r: sequence):
    dense_sequence r <-> dense_subset (codom (F2MF r)).
  Proof.
    split => dns x eps eg0; have []:= dns x eps eg0.
    - by move => n ineq; exists (r n); split => //; exists n.
    by move => y [[n <-] ineq]; exists n.
  Qed.

  Lemma dseq_tpmn (r: sequence):
    dense_sequence r <-> forall x n, exists m, d(x,r m) <= /2^n.
  Proof.
    split => [dns x n| dns x eps eg0]; first apply/dns.
    - by apply/Rinv_0_lt_compat/pow_lt; lra.
    have [n [_ ineq]]:= accf_tpmn eg0.
    have [m prp]:= dns x n.
    exists m.
    exact/Rlt_le/Rle_lt_trans/ineq/prp.
  Qed.

  Definition closure A := make_subset (fun (x: M) =>
    forall eps, 0 < eps -> exists y, y \from A /\ d(x,y) <= eps).

  Lemma subs_clos A: A \is_subset_of closure A.
  Proof. by move => x Ax eps epsg0; exists x; split; last rewrite dstxx; try lra. Qed.

  Lemma dns_clos A: dense_subset A <-> closure A === All.
  Proof.
    split => [dns x | eq x]; first by split => // _; apply/dns.
    by have [_ prp]:= eq x; apply/prp.
  Qed.

  Lemma clos_spec_choice A x:
    FunctionalCountableChoice_on M ->
    x \from closure A <->
                     exists (xn: sequence), (forall n, xn n \from A) /\ xn \converges_to x \wrt d.
  Proof.
    move => choice; split => [clos | [xn [prp lmt]] eps eg0].
    - have /choice [xn prp]: forall n, exists y, d(y, x) <= /2^n /\ A y.
      + move => n.
        have [ | y []]:= clos (/2^n); first by apply/Rinv_0_lt_compat/pow_lt; lra.
        by exists y; rewrite dst_sym.
      exists xn; split => [n | ]; first by have []:= prp n.
      apply/lim_tpmn => n; exists n => k ineq.
      rewrite dst_sym; apply/Rle_trans; first exact/(prp k).1.
      apply/Rinv_le_contravar/Rle_pow/leP => //; try lra.
      by apply/pow_lt; lra.
    have [n cnd]:= lmt eps eg0.
    by exists (xn n); split; [apply/prp | apply/(cnd n)].
  Qed.
End density.
Notation sequence_in M := (nat -> M).
Arguments dense_subset: clear implicits.
Arguments dense_subset {M} (d).
Notation "A \dense_subset_wrt d" := (dense_subset d A) (at level 35): pseudometric_scope.
Arguments dense_sequence: clear implicits.
Arguments dense_sequence {M} (d).
Notation "xn \dense_wrt d":= (dense_sequence d xn) (at level 35): pseudometric_scope.
Notation "xn \dense_sequence_wrt d":= (dense_sequence d xn) (at level 35): pseudometric_scope.
Arguments closure: clear implicits.
Arguments closure {M} (d).
Notation "A \closed_wrt d":= (closure d A) (at level 35): pseudometric_scope.

Section Cauchy_sequences.
  Context `{is_pseudometric}.
  Implicit Types (x y z: M) (xn yn: sequence_in M).
  Notation limit := (limit d).

  Definition Cauchy_sequences := make_subset (fun xn =>
    forall eps, 0 < eps -> exists N, forall n m, (N <= n)%nat -> (N <= m)%nat -> d(xn n, xn m) <= eps).

  Lemma lim_cchy: dom limit \is_subset_of Cauchy_sequences.
  Proof.
    move => xn [x lim] eps eg0.
    have [ | N prp]:= lim (eps/2); first by lra.
    exists N => n m ineq ineq'.
    apply/(@dst_le _ _ H); try exact/prp; first by rewrite dst_sym; apply/prp.
    lra.
  Qed.

  Definition complete := Cauchy_sequences \is_subset_of dom limit.

  Lemma cchy_tpmn xn: xn \from Cauchy_sequences <->
    forall k, exists N, forall n m, (N <= n <= m)%nat -> d (xn n, xn m) <= /2^k.
  Proof.
    split => [cchy k | ass eps /dns0_tpmn [N /Rlt_le ineq]].
    - have [ | N prp]:= cchy (/2 ^ k); first exact/tpmn_lt.
      by exists N => n m /andP [? ineq]; apply/prp/leq_trans/ineq.
    have [N' N'prp]:= ass N; exists N' => n m ? ?.
    case/orP: (leq_total n m) => ineq'.
    - by apply/Rle_trans; first exact/N'prp/andP.
    by rewrite dst_sym; apply/Rle_trans; first apply/N'prp/andP.
  Qed.

  Definition Cauchy_sequences_with_modulus mu := make_subset (fun xn =>
    forall k n m, (mu k <= n <= m)%nat -> d (xn n, xn m) <= /2^k).

  Lemma chym_subs mu: Cauchy_sequences_with_modulus mu \is_subset_of Cauchy_sequences.
  Proof. by move => xn chy; apply/cchy_tpmn => k; exists (mu k); apply/chy. Qed.

  Lemma cchy_mod_exists_choice xn:
    FunctionalCountableChoice_on nat ->
    xn \from Cauchy_sequences <-> exists mu, xn \from Cauchy_sequences_with_modulus mu.
  Proof. by move => choice; split => [/cchy_tpmn /choice | [mu]]//; apply/chym_subs. Qed.

  Definition eventually_big mu:= forall (n: nat), exists N, forall m, (N <= m)%nat -> (n <= mu m)%nat.

  Lemma lim_evb xn mu (x: M): limit xn x -> eventually_big mu -> limit (xn \o_f mu) x.
  Proof.
    move => lim evb eps eg0.
    have [N prp]:= lim eps eg0.
    have [N' ineq]:= evb N.
    exists N' => m ineq'.
    exact/prp/ineq/ineq'.
  Qed.

  Lemma cchy_evb xn mu:
    xn \from Cauchy_sequences -> eventually_big mu -> (xn \o_f mu) \from Cauchy_sequences.
  Proof.
    move => cchy evb eps /cchy [N prp].
    have [N' le]:= evb N.
    exists N' => n m ineq ineq'; apply/prp/le/ineq'.
    exact/le/ineq.
  Qed.
End Cauchy_sequences.
Arguments Cauchy_sequences: clear implicits.
Arguments Cauchy_sequences {M} (d).
Notation "xn \Cauchy_wrt d" := (xn \from Cauchy_sequences d) (at level 45): pseudometric_scope.
Notation "xn \Cauchy_sequence_wrt d" := (xn \from Cauchy_sequences d) (at level 45): pseudometric_scope.
Notation "xn \is_Cauchy_wrt d" := (xn \from Cauchy_sequences d) (at level 45): pseudometric_scope.
Notation "xn \is_Cauchy_sequence_wrt d" :=
  (xn \from Cauchy_sequences d) (at level 45): pseudometric_scope.
Arguments complete: clear implicits.
Arguments complete {M} (d).
Notation "d \is_complete" := (complete d) (at level 45): pseudometric_scope.
Notation "d \is_complete_metric" := (complete d) (at level 45): pseudometric_scope.

Section efficient_convergence.
  Context `{pm: is_pseudometric}.
  Local Notation limit := (limit d).
  Local Notation Cauchy_sequences:= (Cauchy_sequences d).
  Local Notation complete := (complete d).

  Definition fast_Cauchy_sequence xn :=
    forall n m, d (xn n,xn m) <= /2^n + /2^m.

  Definition fast_Cauchy_sequences := make_subset fast_Cauchy_sequence.

  Lemma fchy_cchy: fast_Cauchy_sequences \is_subset_of Cauchy_sequences.
  Proof.
    move => xn cchy eps epsg0.
    have [N [_ ineq]]:= accf_tpmn epsg0.
    exists N.+1 => n m nineq mineq.
    apply/Rlt_le/Rle_lt_trans; last exact/ineq.
    apply /Rle_trans; [exact/cchy | rewrite (tpmn_half N)].
    by apply/Rplus_le_compat; apply/Rinv_le_contravar;
      try apply/pow_lt; try apply/Rle_pow/leP => //; try lra.
  Qed.

  Definition efficient_limit := make_mf (fun xn (x: M) =>
    forall n, d(x, xn n) <= /2^n).

  Lemma lim_eff_spec: efficient_limit =~= limit|_(fast_Cauchy_sequences).
  Proof.
    move => xn x; split => [lim | [fchy lim] n].
    - split => [n m | eps epsg0].
      apply/(@dst_le _ _ pm)/Rle_refl/lim; first by rewrite dst_sym; apply/lim.
      have [n ineq]:= accf_tpmn epsg0.
      exists n => m nlm.
      apply/Rlt_le/Rle_lt_trans/ineq.2/Rle_trans; first exact/lim.
      apply/Rinv_le_contravar; first by apply/pow_lt; lra.
      by apply/Rle_pow/leP => //; lra.
    suff all: forall m, d(x, xn n) <= / 2 ^ n + / 2 ^ m.
    - suff: d(x, xn n) - / 2 ^ n <= 0 by lra.
      apply/Rnot_lt_le => ineq.
      have [m ineq']:= accf_tpmn ineq.
      by have := all m; lra.
    move => m.
    have [ | N prp]:= lim (/2 ^ m.+1); first by apply/Rinv_0_lt_compat/pow_lt; lra.
    rewrite (tpmn_half m) -Rplus_assoc Rplus_comm.
    apply/Rle_trans/Rplus_le_compat.
    - by apply (dst_trngl (xn (maxn m.+1 N))).
    - exact/prp/leq_maxr.
    rewrite dst_sym; apply/Rle_trans; first exact/fchy.
    apply/Rplus_le_compat_l/Rinv_le_contravar/Rle_pow/leP/leq_maxl; try lra.
    by apply/pow_lt; lra.
  Qed.

  Lemma lim_eff_lim : limit \extends efficient_limit.
  Proof.
    rewrite ->lim_eff_spec.
    rewrite {2}[limit]restr_all.
    exact/exte_restr/subs_all.
  Qed.

  Lemma fchy_lim_eff: complete -> fast_Cauchy_sequences === dom efficient_limit.
  Proof.
    move => cmplt xn; split => [cchy | [x /lim_eff_spec []]]//.
    rewrite ->lim_eff_spec; rewrite ->dom_restr_spec; split => //.
    exact/cmplt/fchy_cchy.
  Qed.

  Lemma cchy_fchy_choice xn: FunctionalCountableChoice_on nat ->
    xn \Cauchy_wrt d -> exists mu, (xn \o_f mu) \from fast_Cauchy_sequences.
  Proof.
    move => choice /cchy_tpmn /choice [mu prp].
    exists mu => n k /=.
    case/orP: (leq_total (mu n) (mu k)) => ineq.
    - apply/Rle_trans; first by apply/prp/andP.
      rewrite -[X in X <= _]Rplus_0_r; apply/Rplus_le_compat_l.
      by apply/Rlt_le/Rinv_0_lt_compat/pow_lt; lra.
    rewrite dst_sym; apply/Rle_trans; first by apply/prp/andP.
    rewrite -[X in X <= _]Rplus_0_l; apply/Rplus_le_compat_r.
    by apply/Rlt_le/Rinv_0_lt_compat/pow_lt; lra.
  Qed.

  Lemma lim_eff_dst xn x y: efficient_limit xn x -> efficient_limit xn y -> d(x, y) = 0.
  Proof. by move => lim lim'; apply/(@lim_dst _ _ pm)/lim_eff_lim/lim'/lim_eff_lim/lim. Qed.

  Lemma lim_tight_lim_eff: limit \tightens efficient_limit.
  Proof.
    move => xn [x lim]; split => [ | y lim' n]; first by exists x; apply/lim_eff_lim.
    apply/Rle_trans; first by apply (dst_trngl x).
    have ->: d(y, x) = 0 by apply/(@lim_dst _ _ pm)/lim_eff_lim/lim.
    by rewrite Rplus_0_l; apply/lim.
  Qed.

  Lemma cchy_eff_suff xn:
    (forall n m, (n <= m)%nat -> d (xn n, xn m) <= /2^n + /2^m) ->
    fast_Cauchy_sequence xn.
  Proof.
    move => ass n m.
    case /orP: (leq_total n m) => ineq; first by apply ass.
    by rewrite dst_sym Rplus_comm; apply ass.
  Qed.
End efficient_convergence.
Arguments fast_Cauchy_sequence: clear implicits.
Arguments fast_Cauchy_sequence {M} (d).
Arguments fast_Cauchy_sequences: clear implicits.
Arguments fast_Cauchy_sequences {M} (d).
Notation "xn \fast_Cauchy_wrt d" :=
  (xn \from fast_Cauchy_sequences d) (at level 45): pseudometric_scope.
Notation "xn \fast_Cauchy_sequence_wrt d" :=
  (xn \from fast_Cauchy_sequences d) (at level 45): pseudometric_scope.
Notation "xn \is_fast_Cauchy_sequence_wrt d" :=
  (xn \from fast_Cauchy_sequences d) (at level 45): pseudometric_scope.
Arguments efficient_limit: clear implicits.
Arguments efficient_limit {M} (d).
Notation "x \efficient_limit_of xn \wrt d" := (efficient_limit d xn x) (at level 45): pseudometric_scope.

Section continuity.
  Context `{pm: is_pseudometric}.
  Context `{pm0: is_pseudometric}.
  Context (f: M -> M0).
  Implicit Types (x y: M) (xn yn: sequence_in M).

  Definition continuity_point x :=
    forall eps, 0 < eps -> exists delta, 0 < delta /\ forall y, d(x,y) <= delta -> d0(f x, f y) <= eps.

  Lemma cntp_tpmn x:
    continuity_point x <-> forall n, exists m, forall x', d (x, x') <= /2^m -> d0 (f x, f x') <= /2^n.
  Proof.
    split => [cont n | cont eps /dns0_tpmn [n ineq]].
    - have [delta [/dns0_tpmn [m ineq] prp]]:= cont (/2^n) (tpmn_lt n).
      by exists m => x' dst; apply/prp/Rlt_le/Rle_lt_trans/ineq.
    have [m prp]:= cont n.
    exists (/2^m); split => [ | y dst]; first exact/tpmn_lt.
    exact/Rlt_le/Rle_lt_trans/ineq/prp.
  Qed.

  Definition continuity_points := make_subset continuity_point.

  Definition continuous:= forall x, continuity_point x.

  Lemma cont_tpmn:
    continuous <-> forall x n, exists m, forall x', d (x, x') <= /2^m -> d0 (f x, f x') <= /2^n.
  Proof. by split => cont x; apply/cntp_tpmn. Qed.

  Lemma cntp_all: continuous <-> continuity_points === All.
  Proof.
    split => [cont x | eq x]; last exact/eq.
    by split => // _; apply/cont.
  Qed.

  Definition sequential_continuity_point x:=
    forall xn, xn \converges_to x \wrt d -> (ptw f xn) \converges_to (f x) \wrt d0.

  Definition sequential_continuity_points := make_subset sequential_continuity_point.

  Definition sequentially_continuous:=
    forall x, sequential_continuity_point x.

  Lemma scntp_all: sequentially_continuous <-> sequential_continuity_points === All.
  Proof.
    split => [cont x | eq x]; last exact/eq.
    by split => // _; apply/cont.
  Qed.

  Lemma cntp_scntp x: continuity_point x -> sequential_continuity_point x.
  Proof.
    move => cont xn lmt eps eg0.
    have [delta [dg0 prp]]:= cont eps eg0.
    have [N' cnd]:= lmt delta dg0.
    exists N' => m ineq.
    exact/prp/cnd.
  Qed.

  Lemma cont_scnt: continuous -> sequentially_continuous.
  Proof. by move => cont x; apply/cntp_scntp. Qed.

  Lemma scnt_cont_choice:
    FunctionalCountableChoice_on M -> sequentially_continuous -> continuous.
  Proof.
    move => choice scnt x eps eg0.
    apply/not_all_not_ex => prp.
    have /choice [xn xnprp]: forall n, exists y, d(x, y) <= /2^n /\ eps < d0(f x, f y).
    - move => n; have /not_and_or [ | cnd]:= (prp (/2 ^ n)).
      + by have : 0 < /2^n by apply/Rinv_0_lt_compat/pow_lt; lra.
      apply/not_all_not_ex => asd.
      apply/cnd => y dst.
      have /not_and_or [ineq | ineq]:= asd y; last exact/Rnot_lt_le.
      lra.
    have lmt: xn \converges_to x \wrt d.
    - rewrite ->lim_tpmn => n.
      exists n => k ineq; have [le _]:= xnprp k.
      apply/Rle_trans; first exact/le.
      apply/Rinv_le_contravar/Rle_pow; try lra; first by apply/pow_lt; lra.
      exact/leP.
    have [K cnd]:= scnt x xn lmt eps eg0.
    have []:= xnprp K.
    suff: d0 (f x, f (xn K)) <= eps by lra.
    exact/cnd.
  Qed.
End continuity.
Arguments continuity_point: clear implicits.
Arguments continuity_point {M} (d) {M0} (d0).
Arguments continuity_points: clear implicits.
Arguments continuity_points {M} (d) {M0} (d0).
Notation "f \continuous_wrt d \and d0 \in x" :=
  (continuity_point d d0 f x) (at level 35): pseudometric_scope.
Notation continuous_wrt d d0 := (@continuous _ d _ d0).
Notation "f \continuous_wrt d \and d0" :=
  (continuous_wrt d d0 f) (at level 30): pseudometric_scope.
Notation "f \is_continuous_wrt d \and d0" :=
  (continuous_wrt d d0 f) (at level 30): pseudometric_scope.
Arguments sequential_continuity_points: clear implicits.
Arguments sequential_continuity_points {M} (d) {M0} (d0).
Arguments sequential_continuity_point: clear implicits.
Arguments sequential_continuity_point {M} (d) {M0} (d0).
Arguments sequentially_continuous: clear implicits.
Arguments sequentially_continuous {M} (d) {M0} (d0).
Notation "f \sequentially_continuous_wrt d \and d0 \in x" :=
  (sequential_continuity_point d d0 f x) (at level 40): pseudometric_scope.
Notation "f \sequentially_continuous_wrt d \and d0" :=
  (sequentially_continuous d d0 f) (at level 40): pseudometric_scope.
Notation "f \is_sequentially_continuous_wrt d \and d0" :=
  (sequentially_continuous d d0 f) (at level 40): pseudometric_scope.

Section subpseudometric.
  Context `{pm: is_pseudometric}.
  Global Instance sub_pseudo_metric (A: subset M):
    (fun xy => d (sval xy.1, sval xy.2)) \is_pseudometric_on {x | x \from A}.
    split; first by move => x y; apply dst_pos.
    - by move => x y; apply dst_sym.
    - by move => x; apply dstxx.
    by move => x y z; apply dst_trngl.
  Defined.
End subpseudometric.


(* partly inspired by "Coq in a Hurry" *)

Check False.
Check (3,3).
Compute let f := fun x => (x * 3, x) in f 3.
Definition example1 := fun x : nat => x*x + 2*x + 1.
Compute example1 5.

Require Import Bool.
Require Import Arith.

Print bool.
Print pred.
Print Init.Nat.pred.

Locate "_ <= _".
Locate "_ -> _".

SearchPattern (nat -> bool).
SearchPattern (_ + _ <= _ + _).
SearchRewrite (_ + (_ + _)).

Fixpoint sum_n n :=
  match n with
    0 => 0
  | S p => p + sum_n p
  end.

Theorem sum_n_eq:
  forall n, 2 * sum_n n = n * (n - 1).
Proof.
  intro n; induction n.
  - auto.
  - pose (s := sum_n (S n)); fold s; simpl in s; unfold s; clear s. (* eww, but direct 'simpl' goes too far *)
    rewrite Nat.mul_add_distr_l. rewrite IHn.
    case n.
    + reflexivity.
    + intro n'.
      repeat (rewrite Nat.mul_succ_l || rewrite Nat.add_succ_l || rewrite Nat.mul_succ_r ||
        rewrite Nat.add_succ_r || rewrite Nat.add_0_r || rewrite Nat.add_0_l || rewrite Nat.sub_succ ||
        rewrite Nat.sub_0_r).
      ring.
Qed.

(* discriminate / injection *)
(* Open Scope Z_scope. *)
Require Import ZArith.
About Z.iter.


Add LoadPath "C:\Projects\Coq".

Require Export Basic.
Require Export Case.

Theorem andb_true_elim1:
  forall b c, andb b c = true -> b = true.
Proof.
  intros b c.
  intro H.
  destruct b.
  Case "b = true".
    reflexivity.
  Case "b = false".
    rewrite <- H.
    reflexivity.
Qed.

Theorem andb_true_elim2:
  forall b c, andb b c = true -> c = true.
Proof.
  intros b c.
  intro H.
  destruct c.
  Case "c = true".
    reflexivity.
  Case "c = false".
    rewrite <- H.
    destruct b.
    SCase "b = false".
      reflexivity.
    SCase "b = true".
      reflexivity.
Qed.

Theorem plus_0_r_firsttry:
  forall n, n + 0 = n.
Proof.
  intros n.
  destruct n as [|n'].
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
  simpl.
Abort.

Theorem plus_0_r:
  forall n, n + 0 = n.
Proof.
  intros n.
  induction n as [|n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    reflexivity.
Qed.

Theorem minus_diag:
  forall n, minus n n = 0.
Proof.
  intro n.
  induction n as [|n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    reflexivity.
Qed.

Theorem mult_0_r:
  forall n, n * 0 = 0.
Proof.
  intro n.
  induction n as [|n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    reflexivity.
Qed.

Theorem plus_n_Sm:
  forall n m, S (n + m) = n + S m.
Proof.
  intros n m.
  induction n as [|n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    reflexivity.
Qed.

Theorem plus_comm:
  forall n m, n + m = m + n.
Proof.
  intros n m.
  induction n as [|n'].
  Case "n = 0".
    rewrite -> plus_0_r.
    reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    rewrite plus_n_Sm. reflexivity.
Qed.

Theorem plus_assoc:
  forall n m p, n + (m + p) = n + m + p.
Proof.
  intros n m p.
  induction n as [|n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    reflexivity.
Qed.

Fixpoint double n :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

Lemma double_plus:
  forall n, double n = n + n.
Proof.
  intro n.
  induction n as [|n'].
  Case "n = 0". reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'.
    rewrite -> plus_n_Sm.
    reflexivity.
Qed.

(*
Destructs attempts to demonstrate the property by solving cases
of the inductively defined type separately.
Induction attempts to demonstrate the property by showing how
the truth value for a value of the inductively defined set implies
the truth of the subsequent value.
*)

Theorem plus_0_plus':
  forall n m, (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (0 + n = n) as H.
  Case "Proof of assertion". reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_rearrange_firsttry:
  forall n m p q, n + m + (p + q) = m + n + (p + q).
Proof.
  intros n m p q.
  rewrite -> plus_comm.
Abort.

Theorem plus_rearrange:
  forall n m p q, n + m + (p + q) = m + n + (p + q).
Proof.
  intros n m p q.
  assert (n + m = m + n) as H.
  Case "proof of assertion".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_swap:
  forall n m p, n + (m + p) = m + (n + p).
Proof.
  intros.
  rewrite -> plus_assoc.
  assert (n + m = m + n) as H.
    Case "proof of assertion".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H.
  rewrite -> plus_assoc.
  reflexivity.
Qed.

Theorem times_n_succm:
  forall n m, n * S m = n + n * m.
Proof.
  intros n m.
  induction n as [|n'].
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> plus_swap.
    rewrite -> IHn'.
    reflexivity.
Qed.

Theorem mult_comm:
  forall n m, n * m = m * n.
Proof.
  intros.
  induction n as [|n'].
  Case "n = 0".
    rewrite -> mult_0_r. reflexivity.
  Case "n = S n'".
    simpl.
    rewrite -> IHn'.
    rewrite -> times_n_succm.
    reflexivity.
Qed.

Theorem evenb_n__oddb_Sn:
  forall n, evenb n = negb (evenb (S n)).
Proof.
  intro n.
  induction n.
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
    assert (evenb (S (S n)) = evenb n).
      SCase "Proof of assertion".
      reflexivity.
    rewrite -> H.
    rewrite -> IHn.
    rewrite -> negb_involutive.
    reflexivity.
Qed.

Theorem ble_nat_refl:
  forall n, true = ble_nat n n.
Proof.
  intro.
  induction n.
  reflexivity.
  rewrite -> IHn.
  reflexivity.
Qed.

Theorem zero_nbeq_S:
  forall n, beq_nat 0 (S n) = false.
Proof.
  intro.
  reflexivity.
Qed.

Theorem andb_false_r:
  forall b, andb b false = false.
Proof.
  intro.
  destruct b.
  reflexivity.
  reflexivity.
Qed.

Theorem plus_ble_compat_l:
  forall n m p, ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  intros.
  induction p as [|p'].
  Case "p = 0".
    simpl. rewrite -> H. reflexivity.
  Case "p = S p'".
    simpl.
    rewrite -> IHp'.
    reflexivity.
Qed.

Theorem S_nbeq_0:
  forall n, beq_nat (S n) 0 = false.
Proof.
  intro. reflexivity.
Qed.

Theorem mult_1_l:
  forall n, 1 * n = n.
Proof.
  intro. simpl.
  rewrite -> plus_0_r.
  reflexivity.
Qed.

Theorem all3_spec:
  forall b c,
    orb
      (andb b c)
      (orb
        (negb b)
        (negb c))
        = true.
Proof.
  intros.
  destruct b.
  destruct c.
  reflexivity.
  reflexivity.
  reflexivity.
Qed.

Theorem mult_plus_distr_r:
  forall n m p, (n + m) * p = n * p + m * p.
Proof.
  intros.
  induction n.
  induction m.
  reflexivity.
  reflexivity.
  simpl.
  rewrite -> IHn.
  rewrite -> plus_assoc.
  reflexivity.
Qed.

Theorem mult_assoc:
  forall n m p, n * (m * p) = n * m * p.
Proof.
  intros.
  induction n.
  induction m.
  reflexivity.
  reflexivity.
  simpl.
  rewrite -> IHn.
  rewrite -> mult_plus_distr_r.
  reflexivity.
Qed.

Theorem beq_nat_refl:
  forall n, true = beq_nat n n.
Proof.
  intro n.
  induction n.
  reflexivity.
  rewrite -> IHn.
  reflexivity.
Qed.

Theorem plus_swap':
  forall n m p, n + (m + p) = m + (n + p).
Proof.
  intros.
  rewrite -> plus_assoc.
  replace (n + m) with (m + n).
  rewrite -> plus_assoc.
  reflexivity.
  rewrite -> plus_comm.
  reflexivity.
Qed.

Inductive bin :=
  | Z
  | T: bin -> bin
  | TPlus: bin -> bin.

Fixpoint incr n :=
  match n with
  | Z => TPlus Z
  | T n' => TPlus n'
  | TPlus n' => T (incr n')
  end.

Fixpoint toNat n :=
  match n with
  | Z => O
  | T n' => mult 2 (toNat n')
  | TPlus n' => S (mult 2 (toNat n'))
  end.

Theorem incr_toNat_comm:
  forall b, toNat (incr b) = S (toNat b).
Proof.
  intro.
  induction b as [|b'| b''].
  Case "b = Z".
    reflexivity.
  Case "b = T b'".
    simpl.
    rewrite -> plus_0_r.
    reflexivity.
  Case "b = TPlus b''".
    simpl.
    rewrite -> plus_0_r.
    rewrite -> plus_0_r.
    rewrite -> IHb''.
    simpl.
    rewrite -> plus_comm.
    reflexivity.
Qed.

Fixpoint toBin n :=
  match n with
  | O => Z
  | S n' => incr (toBin n')
  end.

Theorem toBin_toNat:
  forall n, toNat (toBin n) = n.
Proof.
  intro n.
  induction n.
  reflexivity.
  simpl.
  rewrite -> incr_toNat_comm.
  rewrite -> IHn.
  reflexivity.
Qed.
(*

Eval simpl in toBin 3.
Eval simpl in toBin 4.
Eval simpl in toBin 5.
Eval simpl in toBin 6.
Eval simpl in toBin 7.
Eval simpl in toBin 8.
Eval simpl in toBin 9.
Eval simpl in toBin 10.
Eval simpl in toBin 11.

Fixpoint normalize b:
  match b with
  | Z => Z
  | T b' =>

Theorem toNat_toBin:
  forall b, toBin (toNat b) = b.
Proof.
  intro b.
  induction b as [|b'|b''].
  Case "b = Z".
    reflexivity.
  Case "b = T b'".
    simpl.
    rewrite -> plus_0_r.

*)


Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint less (less_arg0 : natural) (less_arg1 : natural) : bool
           := match less_arg0, less_arg1 with
              | x, Zero => false
              | Zero, Succ x => true
              | Succ x, Succ y => less x y
              end.

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

Fixpoint count  (count_arg1 : lst) (count_arg0 : natural): natural
           := match  count_arg1,count_arg0 with
              | Nil, x => Zero
              | Cons y z, x => if eqb x y then Succ (count z x) else count z x
              end.

              Fixpoint insort  (insort_arg1 : lst) (insort_arg0 : natural) : lst
              := match insort_arg1, insort_arg0 with
                 |  Nil, i => Cons i Nil
                 | Cons x y, i => if less i x then Cons i (Cons x y) else Cons x (insort y i)
                 end.

                 Fixpoint sort (sort_arg0 : lst) : lst
                 := match sort_arg0 with
                    | Nil => Nil
                    | Cons x y => insort (sort y) x
                    end.

Theorem eqb_refl: forall n, eqb n n = true.
Proof.
   induction n; simpl.
   { assumption. }
   { reflexivity. }
Qed.

Theorem eqb_diff: forall (x y: natural), x <> y -> eqb x y = false.
Proof.
   induction x; induction y; simpl.
   {
   intros.
   apply IHx.
   intro.
   subst.
   assert (Succ y = Succ y). reflexivity.
   apply H in H0.
   destruct H0.
   }
   {
   intros. reflexivity.
   }
   {
   intros. reflexivity.
   }
   {
   intros.
   assert (Zero = Zero). reflexivity.
   apply H in H0.
   destruct H0.
   }
Qed.

Theorem eqb_elim: forall (x y: natural), Bool.Is_true (eqb x y) -> x = y.
Proof.
   induction x; induction y; simpl in *.
   intros.
   {
   apply IHx in H.
   subst.
   reflexivity.
   }
   {
   intros.
   destruct H.
   }
   { intros; destruct H. }
   {
   intros. reflexivity.
   }
Qed.

Theorem count_cons: forall (x: natural) (l: lst), count (Cons x l) x = Succ (count l x).
Proof.
   intros.
   simpl.
   rewrite eqb_refl.
   reflexivity.
Qed.

Theorem count_insort: forall (x: natural) (l: lst), count (insort l x) x= Succ (count l x).
Proof.
   intros.
   induction l.
   {
   simpl in *.
   destruct (less x n).
   {
      rewrite count_cons.
      f_equal.
   }
   {
      destruct (eqb x n) eqn:E.
      {
         apply Bool.Is_true_eq_left in E.
         apply eqb_elim in E.
         rewrite E in *.
         rewrite count_cons.
         rewrite IHl.
         reflexivity.
      }
      {
         simpl.
         rewrite E.
         assumption.
      }
   }
   }
   {
   simpl.
   rewrite eqb_refl.
   reflexivity.
   }
Qed.

Theorem count_cons_diff: forall (x y: natural) (l: lst), x <> y -> count (Cons y l) x= count l x.
Proof.
   intros. simpl.
   apply eqb_diff in H.
   rewrite H.
   reflexivity.
Qed.

Theorem count_insort_diff: forall (x y: natural) (l: lst), x <> y -> count (insort l y) x= count l x.
Proof.
   intros.
   induction l.
   {
   simpl.
   destruct (less y n) eqn:El; destruct (eqb x n) eqn:Ee.
   {
      simpl.
      apply eqb_diff in H. rewrite H.
      rewrite Ee.
      reflexivity.
   }
   {
      rewrite count_cons_diff.
      { simpl. rewrite Ee. reflexivity. }
      { assumption. }
   }
   {
      simpl. rewrite Ee. f_equal.
      assumption.
   }
   {
      simpl. rewrite Ee. assumption.
   }
   }
   {
   simpl.
   apply eqb_diff in H.
   rewrite H.
   reflexivity.
   }
Qed.

Theorem theorem0 : forall (x : natural) (y : lst), eq (count (sort y) x) (count y x).
Proof.
   intros.
   induction y.
   {
   simpl.
   destruct (eqb x n) eqn:E.
   {
      apply Bool.Is_true_eq_left in E.
      apply eqb_elim in E.
      subst.
      rewrite count_insort.
      f_equal. assumption.
   }
   {
      simpl.
      rewrite count_insort_diff.
      assumption.
      intro.
      rewrite H in E.
      rewrite eqb_refl in E.
      inversion E.
   }
   }
   {
   simpl.
   reflexivity.
   }
Qed.


Require Import Basics PeanoNat Bool.
Require Import Lia ZifyBool.

Inductive List : Set :=
  | nil : List
  | cons (n : nat) (tail : List) : List.

Definition Empty (l : List) : Prop := match l with
  | nil => True
  | cons _ _ => False
  end.

Fixpoint length (l : List) : nat := match l with
  | nil => 0
  | cons _ rest => 1 + length rest
  end.

Inductive Sorted (R : nat -> nat -> Prop): List -> Prop :=
  | Sorted_empty : Sorted R nil
    (* prázdný List je vždy seřazen *)
  | Sorted_one (n : nat) : Sorted R (cons n nil)
    (* List s jedním prvkem je také vždy seřazen *)
  | Sorted_cons (n : nat) (m : nat) (rest : List)
    (* List s více prvky [n, m, ...rest] je seřazen, když:*)
      (* 1. n a m jsou správně seřazeny: *)
        (first_pair_sorted : R n m)
      (* 2. zbytek [m, ...rest] je seřazen: *)
        (rest_sorted : Sorted R (cons m rest))
      : Sorted R (cons n (cons m rest)).

Fixpoint elem (n:nat) (l:List) : bool := match l with
  | nil => false
  | cons m r => (if n =? m then true else elem n r)
end.

Inductive Elem (n: nat) : List -> Prop :=
  | Elem_triv : forall l, Elem n (cons n l)
  | Elem_cons : forall l u, Elem n l -> Elem n (cons u l).

Theorem Elem_tail {l n u}: Elem n (cons u l) -> n <> u -> Elem n l.
Proof.
  intros.
  inversion H.
  - contradiction.
  - assumption.
Qed.

Theorem Elem_el0 {l n u} : Elem n (cons u l) <-> n = u \/ (Elem n l /\ n <> u).
Proof.
  intros.
  split.
  - destruct (Nat.eq_decidable n u).
    left. exact H.
    right.
    split.
    + apply (Elem_tail H0 H).
    + assumption.
  - intros.
    destruct H as [-> | E].
    + apply Elem_triv.
    + apply Elem_cons.
      destruct E.
      exact H.
      Show Proof.
Qed.

Theorem Elem_el {l n u} : Elem n (cons u l) <-> n = u \/ Elem n l.
Proof.
  intros.
  split.
  - destruct (Nat.eq_decidable n u).
    left. exact H.
    right.
    apply (Elem_tail H0 H).
  - intros.
    destruct H as [-> | E].
    + apply Elem_triv.
    + apply Elem_cons.
      exact E.
Qed.

Theorem elem_spec n l: Elem n l <-> elem n l = true.
Proof.
  split.
  - intro E.
    induction l.
    + inversion E.
    + simpl.
      destruct (Nat.eqb_spec n n0); [reflexivity| ].
      apply IHl.
      apply Elem_el in E.
      destruct E; [contradiction | ].
      exact H.
  - intro E.
    induction l.
    + simpl in E.
      discriminate E.
    + simpl in E.
      destruct (Nat.eqb_spec n n0) as [-> | D].
      * apply Elem_triv.
      * apply Elem_cons.
        exact (IHl E).
Qed.

Definition elem_reflect n l: reflect (Elem n l) (elem n l) := iff_reflect _ _ (elem_spec n l).

Theorem elem_not_nil : forall l n, Elem n l -> l <> nil.
Proof.
  intros.
  destruct l.
  - inversion H.
  - discriminate.
Qed.

Fixpoint push (a : nat) (l : List) : List :=
  match l with
    | nil => cons a nil
    | cons h rest => cons h (push a rest)
  end.

Fixpoint reverse (a : List) : List :=
  match a with
    | nil => nil
    | cons a rest => push a (reverse rest)
  end.

Fixpoint append (a b : List) : List :=
  match a with
    | nil => b
    | cons ah ar => cons ah (append ar b)
  end.

Fixpoint lastd (n : nat) (l : List) : nat :=
  match l with
  | nil => n
  | cons m r => lastd m r
  end.

Definition last (l : List) : if l then unit else nat :=
  match l with
  | nil => tt
  | cons m r => lastd m r
  end.

Definition head (l : List) : if l then unit else nat :=
  match l with
  | nil => tt
  | cons m r => m
  end.

Declare Scope List_scope.
Delimit Scope List_scope with List.
Open Scope List_scope.

Notation "a +> b" := (cons a b) (right associativity, at level 100) : List_scope.
Notation "[ ]" := nil : List_scope.
Notation "[ a ; .. ; e ]" := ( cons a .. (cons e nil) ..) : List_scope.
Notation "a ++ b" := (append a b) : List_scope.
Notation "a <+ b" := (push b a) (left associativity, at level 101) : List_scope.

Theorem append_nil {a}: append a nil = a.
Proof.
  induction a.
  - reflexivity.
  - simpl.
    rewrite IHa.
    reflexivity.
Qed.

Theorem append_comm {a b c}: append a (append b c) = append (append a b) c.
Proof.
  induction a.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHa.
    reflexivity.
Qed.

Theorem append_length a b: length (append a b) = length a + length b.
Proof.
  induction a.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHa.
    reflexivity.
Qed.

Theorem Elem_push l n: Elem n (push n l).
Proof.
  induction l.
  - constructor.
  - simpl.
    constructor.
    exact IHl.
Qed.

Theorem append_push l a: append l (cons a nil) = push a l.
Proof.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite IHl.
    reflexivity.
Qed.

Theorem cons_push_comm l a b: cons a (push b l) = push b (cons a l).
Proof.
  simpl.
  reflexivity.
Qed.

Theorem reverse_cons l a: reverse (cons a l) = push a (reverse l).
Proof.
  simpl.
  reflexivity.
Qed.

Theorem reverse_push l a: reverse (push a l) = cons a (reverse l).
Proof.
  induction l.
  - reflexivity.
  - simpl.
    rewrite IHl.
    simpl.
    reflexivity.
Qed.

Theorem reverse_reverse l: reverse (reverse l) = l.
Proof.
  induction l.
  - reflexivity.
  - simpl.
    rewrite reverse_push.
    rewrite IHl.
    reflexivity.
Qed.

Theorem reverse_exists l: exists rl, l = reverse rl.
Proof.
  induction l.
  - exists nil.
    reflexivity.
  - destruct IHl.
    rewrite H.
    exists (push n x).
    rewrite reverse_push.
    reflexivity.
Qed.

Theorem List_push_ind: forall (P: List -> Prop), P nil -> (forall n tail, P tail -> P (push n tail)) -> forall l, P l.
Proof.
  intros.
  destruct (reverse_exists l).
  rewrite H1.
  clear H1 l.
  induction x.
  - simpl.
    exact H.
  - simpl.
    apply H0.
    exact IHx.
Qed.

Theorem List_push_case l: l = nil \/ exists n r, l = push n r.
Proof.
  intros.
  induction l using List_push_ind.
  - left. reflexivity.
  - right.
    exists  n.
    exists l.
    reflexivity.
Qed.

Theorem push_length l a: length (push a l) = S (length l).
Proof.
  induction l.
  - reflexivity.
  - simpl.
    rewrite IHl.
    reflexivity.
Qed.

Theorem push_nnil l a: nil <> push a l.
Proof.
  induction l; discriminate.
Qed.

Theorem Sorted_tail {l a R}: Sorted R (cons a l) -> Sorted R l.
Proof.
  intros.
  inversion H.
  - constructor.
  - apply rest_sorted.
Qed.

Theorem Sorted_pop {l a R}: Sorted R (push a l) -> Sorted R l.
Proof.
  intros.
  destruct l.
    apply Sorted_empty.
  generalize dependent a.
  generalize dependent n.
  induction l; intros.
    apply Sorted_one.
  simpl in H.
  inversion H; subst.
  simpl in rest_sorted.
  apply IHl in rest_sorted.
  apply Sorted_cons.
  - exact first_pair_sorted.
  - exact rest_sorted.
Qed.

Theorem Sorted_app1 {a b R}:
  Sorted R (append a b)
  -> Sorted R a.
Proof.
  intros.
  destruct a.
    constructor.
  generalize dependent n.
  induction a; intros.
    constructor.
  simpl in *.
  inversion H.
  subst.
  constructor.
  assumption.
  exact (IHa n rest_sorted).
Qed.

Theorem Sorted_app2 {a b R}:
  Sorted R (append a b)
  -> Sorted R b.
Proof.
  intros.
  destruct a.
    destruct b.
    constructor.
    simpl in H.
    assumption.
  generalize dependent n.
  induction a; intros.
    destruct b.
    constructor.
    simpl in H.
    exact (Sorted_tail H).
  simpl in *.
  exact (IHa n (Sorted_tail H)).
Qed.

Theorem Sorted_push {l a b R}:
  Sorted R (push a l) ->
  R a b
  -> Sorted R (push b (push a l)).
Proof.
  intros.
  induction l.
  - simpl in *.
    apply Sorted_cons.
    exact H0.
    apply Sorted_one.
  - simpl in *.
    pose proof (Sorted_tail H).
    apply IHl in H1.
    destruct l.
      simpl in *.
      inversion H; subst.
      auto using Sorted.
    simpl in *.
    inversion H; subst.
    constructor.
    exact first_pair_sorted.
    exact H1.
Qed.

Theorem Sorted_reverse l R: Sorted R l -> Sorted (flip R) (reverse l).
Proof.
  intros S.
  destruct l.
    constructor.
  generalize dependent n.
  induction l; intros.
    constructor.
  simpl in *.
  apply Sorted_push.
  apply Sorted_tail in S.
  apply IHl.
  exact S.
  unfold flip.
  inversion S; subst.
  exact first_pair_sorted.
Qed.

Theorem Sorted_unreverse l R: Sorted R (reverse l) -> Sorted (flip R) l.
Proof.
  intros S.
  destruct (reverse_exists l).
  subst.
  rewrite reverse_reverse in S.
  apply Sorted_reverse.
  exact S.
Qed.

Theorem Sorted_append {R l1 n l2 m} :
  Sorted R (push n l1) ->
  Sorted R (cons m l2) ->
  R n m
  -> Sorted R (append (push n l1) (cons m l2)).
Proof.
  generalize dependent l2.
  generalize dependent m.
  generalize dependent n.
  induction l1; intros.
  - simpl.
    constructor.
    exact H1.
    exact H0.
  - simpl in *.
    pose proof (Sorted_tail H).
    pose proof (IHl1 _ _ _ H2 H0 H1).
    destruct l1.
    + simpl in *.
      inversion H. subst.
      repeat assumption || constructor.
    + simpl in *.
      inversion H; subst.
      constructor.
      exact first_pair_sorted.
      exact H3.
Qed.

Fixpoint min (n: nat) (l: List): nat :=
  match l with
    | nil => n
    | cons m t => if m <? n then min m t else min n t
  end.

Theorem min_elem {n l}: Elem (min n l) (cons n l).
Proof.
  generalize dependent n.
  induction l; intros.
  - simpl.
    constructor.
  - simpl in *.
    destruct (Nat.ltb_spec n n0).
    constructor.
    apply IHl.
    specialize (IHl n0).
    rewrite Elem_el in IHl.
    rewrite Elem_el.
    destruct IHl.
    rewrite H0.
    left. reflexivity.
    right.
    constructor.
    exact H0.
Qed.

Theorem min_refl n l: min n l <= n.
Proof.
  generalize dependent n.
  induction l; intros.
  - simpl. lia.
  - simpl.
    destruct (Nat.ltb_spec n n0).
    + specialize (IHl n).
      lia.
    + apply IHl.
Qed.

Theorem min_inj n m l: n <= m -> min n l <= min m l.
Proof.
  intros.
  generalize dependent m.
  generalize dependent n.
  induction l; intros.
  - simpl.
    lia.
  - simpl.
    destruct (Nat.ltb_spec n n0), (Nat.ltb_spec n m).
    + lia.
    + lia.
    + specialize (IHl n0 n H0).
      lia.
    + specialize (IHl n0 m H).
      lia.
Qed.

Theorem min_lt_elem {n l x}: Elem x l ->  min n l <= x.
Proof.
  intros.
  induction l.
  - inversion H.
  - apply Elem_el in H.
    destruct H.
    subst.
    simpl.
    destruct (Nat.ltb_spec n0 n).
    apply min_refl.
    pose proof (min_refl n l).
    lia.
    specialize (IHl H).
    simpl.
    destruct (Nat.ltb_spec n0 n).
    assert (n0 <= n) by lia.
    pose proof (min_inj n0 n l H1).
    lia.
    lia.
Qed.

Notation LeSorted := (Sorted le).

Theorem LeSorted_min {l} n : LeSorted l -> LeSorted (cons (min n l) l).
Proof.
  intros.
  generalize dependent n.
  induction l; intros.
    simpl.
    constructor.
  simpl.
  destruct (Nat.ltb_spec n n0).
  - constructor.
    + apply min_refl.
    + exact H.
  - constructor.
    + pose proof (min_refl n0 l).
      lia.
    + exact H.
Qed.

Fixpoint remove_elem n l: List :=
  match l with
    | nil => nil
    | cons m l' => if m =? n then remove_elem n l' else cons m (remove_elem n l')
  end.

Theorem List_strong_ind:
  forall P : (List -> Prop),
  P nil ->
  (forall l, (forall r, length r < length l -> P r) -> P l)
  -> forall l, P l.
Proof.
  intros.
  assert (exists r, length l < length r).
    exists (cons 8 l).
    simpl.
    lia.
  destruct H1.
  generalize dependent l.
  induction x; intros.
  - simpl in H1.
    lia.
  - simpl in H1.
    assert (length l <= length x) by lia.
    Nat.le_elim H2.
    + apply IHx.
      exact H2.
    + apply H0.
      intros.
      apply IHx.
      lia.
Qed.

Theorem List_strong_ind0:
  forall P : (List -> Prop),
  P nil ->
  (forall l, (forall r, length r <= length l -> P r) -> forall n, P (cons n l) )
  -> forall l, P l.
Proof.
  intros.
  destruct l.
  exact H.
  assert (exists r, length (cons n l) <= length r).
    exists (cons 9 l).
    simpl.
    lia.
  destruct H1.
  generalize dependent l.
  generalize dependent n.
  induction x; intros.
  - simpl in H1.
    lia.
  - simpl in H1.
    assert (length l <= length x) by lia.
    Nat.le_elim H2.
    + apply IHx.
      exact H2.
    + apply H0.
      intros.
      destruct r.
      exact H.
      apply IHx.
      lia.
Qed.

Theorem Sorted_over {n m l}: LeSorted (cons n (cons m l)) -> LeSorted (cons n l).
Proof.
  intros.
  destruct l.
  constructor.
  inversion H. subst.
  inversion rest_sorted. subst.
  constructor.
  lia.
  assumption.
Qed.

Theorem Sorted_remove_elem {l} n: LeSorted l -> LeSorted (remove_elem n l).
Proof.
  intros.
  destruct l.
    simpl.
    constructor.
  generalize dependent n0.
  generalize dependent n.
  induction l; intros.
  - simpl.
    destruct (n0 =? n); constructor.
  - simpl.
    destruct (Nat.eqb_spec n1 n0);
    destruct (Nat.eqb_spec n n0); subst.
    + apply Sorted_tail in H.
      specialize (IHl n0 0).
      assert (LeSorted (cons 0 l)). {
        destruct l.
        * constructor.
        * apply Sorted_cons.
          lia.
          exact (Sorted_tail H).
      }
      specialize (IHl H0).
      simpl in IHl.
      destruct n0.
      * exact IHl.
      * exact (Sorted_tail IHl).
    + simpl in *.
      assert (n =? n0 = false) by lia.
      specialize (IHl n0 n (Sorted_tail H)).
      rewrite H0 in IHl.
      exact IHl.
    + simpl in *.
      assert (n1 =? n0 = false) by lia.
      specialize (IHl n0 n1 (Sorted_over H)).
      rewrite H0 in IHl.
      exact IHl.
    + simpl in *.
      assert (n =? n0 = false) by lia.
      specialize (IHl n0 n (Sorted_tail H)).
      rewrite H0 in IHl.
      inversion H. subst.
      constructor.
      * exact first_pair_sorted.
      * exact IHl.
Qed.

Fixpoint count (n : nat) (l : List) : nat :=
  match l with
    | nil => 0
    | cons m lr => (if m =? n then 1 else 0) + count n lr
  end.

Theorem count_elem n l: count n l >= 1 <-> Elem n l.
  split.
  - intros.
    induction l.
    + simpl in H.
      lia.
    + simpl in *.
      destruct (Nat.eqb_spec n0 n).
      * subst.
        constructor.
      * simpl in H.
        specialize (IHl H).
        constructor.
        exact IHl.
  - intros.
    induction l.
    + inversion H.
    + simpl in *.
      rewrite Elem_el0 in H.
      destruct H.
      * subst.
        rewrite Nat.eqb_refl.
        lia.
      * simpl.
        destruct H.
        assert (n0 =? n = false) by lia.
        rewrite H1.
        simpl.
        apply (IHl H).
Qed.

Definition Permutation a b : Prop := forall n, count n a = count n b.

Goal Permutation (cons 4 (cons 6 nil)) (cons 6 (cons 4 nil)).
Proof.
  unfold Permutation.
  intros.
  do 6 try destruct n.
  all: simpl.
  all: reflexivity.
Qed.

Theorem Permutation_refl l : Permutation l l.
Proof.
  intro.
  reflexivity.
Qed.

Theorem Permutation_symm {a b} : Permutation a b -> Permutation b a.
Proof.
  intros H n.
  specialize (H n).
  rewrite H.
  reflexivity.
Qed.

Theorem Permutation_trans {a b c} : Permutation a b -> Permutation b c -> Permutation a c.
Proof.
  unfold Permutation.
  intros AB BC n.
  rewrite AB.
  apply BC.
Qed.

Theorem count_append a b : forall n, count n (append a b) = count n a + count n b.
Proof.
  generalize dependent b.
  induction a; intros.
  - simpl.
    reflexivity.
  - simpl.
    destruct (Nat.eqb_spec n n0).
    + subst.
      simpl.
      f_equal.
      apply IHa.
    + simpl.
      apply IHa.
Qed.

Theorem count_push a m: forall n, count n (push m a) = count n (cons m a).
Proof.
  intro.
  rewrite <- append_push.
  rewrite count_append.
  simpl.
  lia.
Qed.

Theorem Permutation_reverse l: Permutation l (reverse l).
Proof.
  intro.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    rewrite count_push.
    simpl.
    rewrite IHl.
    reflexivity.
Qed.

Fixpoint filter (f: nat -> bool) (l: List): List :=
  match l with
  | nil => nil
  | cons n r => if f n then cons n (filter f r)
                      else filter f r
  end.

Theorem filter_forall l f: forall n, Elem n (filter f l) -> Elem n l /\ f n = true.
Proof.
  intros.
  split. {
    generalize dependent n.
    induction l.
    - intros.
      simpl in H.
      inversion H.
    - intros.
      simpl in H.
      destruct (f n).
      + rewrite Elem_el0 in H.
        destruct H as [].
        * subst.
          constructor.
        * constructor.
          apply IHl.
          apply H.
      + constructor.
        apply IHl.
        exact H.
  } {
    generalize dependent n.
    induction l.
    - intros.
      simpl in H.
      inversion H.
    - intros.
      simpl in H.
      destruct (f n) eqn:E.
      + destruct (Nat.eqb_spec n0 n).
        * subst.
          exact E.
        * apply IHl.
          apply Elem_tail in H.
          exact H. exact n1.
      + apply IHl.
        exact H.
  }
Qed.

Theorem filter_length f l: length (filter f l) <= length l.
  induction l.
  - simpl.
    lia.
  - simpl.
    destruct (f n).
    + simpl.
      lia.
    + lia.
Qed.

Theorem filter_comp f g l: filter f (filter g l) = filter (fun x => f x && g x) l.
  induction l.
  - simpl.
    reflexivity.
  - simpl.
    all: destruct (g n).
    all: simpl.
    all: destruct (f n).
    all: simpl.
    all: rewrite IHl.
    all: reflexivity.
Qed.

Eval compute in filter (fun a => a <? 8) (cons 2 (cons 6 (cons 8 (cons 11 (cons 3 nil))))).

Fixpoint qs (u : nat) (l : List) : List :=
  match l, u with
  | cons p r, S v => append (qs v (filter (fun a => a <? p) r))
              (cons p (qs v (filter (fun a => p <=? a) r)))
  | _, _ => nil
  end.

Definition quicksort (l: List) : List := qs (length l) l.

Eval compute in quicksort (cons 2 (cons 6 (cons 8 (cons 11 (cons 3 nil))))).
Eval compute in quicksort nil.

Theorem le_to_add {n m}: n <= m -> exists x, x + n = m.
Proof .
  intros.
  induction n.
  - exists m.
    lia.
  - destruct m.
    + lia.
    + assert (n <= S m) by lia.
      specialize (IHn H0).
      destruct IHn.
      destruct x; simpl in *.
      * lia.
      * exists x.
        lia.
Qed.

Theorem qs_u_irrelevant0 {l} u: qs (length l) l = qs (u + length l) l.
Proof.
  replace (length l) with (0 + length l) by lia.
  generalize 0 as v.
  revert u.
  induction l using List_strong_ind0; intros.
  - simpl.
    destruct u.
    + simpl. reflexivity.
    + simpl. destruct v; reflexivity.
  - simpl.
    replace (v + S (length l)) with (S (v + length l)) by lia.
    replace (u + S (v + length l)) with (S (u + v + length l)) by lia.
    simpl.
    f_equal.
    + remember (fun a => a <? n) as less.
      pose proof (filter_length less l).
      remember (filter less l) as before.
      pose proof (H _ H0).
      destruct (le_to_add H0).
      specialize (H1 u (v + x)).
      rewrite <- H2.
      repeat rewrite Nat.add_assoc in *.
      exact H1.
    + remember (fun a => n <=? a) as more.
      pose proof (filter_length more l).
      remember (filter more l) as after.
      f_equal.
      pose proof (H _ H0).
      destruct (le_to_add H0).
      specialize (H1 u (v + x)).
      rewrite <- H2.
      repeat rewrite Nat.add_assoc in *.
      exact H1.
Qed.

Theorem qs_u_irrelevant {l u}: length l <= u -> qs (length l) l = qs u l.
Proof.
  intros.
  destruct (le_to_add H) as [? <-].
  apply qs_u_irrelevant0.
Qed.

Theorem Elem_case l: l = nil \/ exists n, Elem n l.
Proof.
  destruct l.
  - left.
    reflexivity.
  - right.
    exists n.
    constructor.
Qed.

Theorem Permutation_Elem {l l'}: Permutation l l' -> forall n, Elem n l -> Elem n l'.
Proof.
  intros.
  unfold Permutation in H.
  rewrite <- count_elem in *.
  specialize (H n).
  rewrite <- H.
  exact H0.
Qed.

Theorem quicksort_permutation l: Permutation l (quicksort l).
Proof.
  unfold quicksort.
  induction l as [| l IH p] using List_strong_ind0 .
  - simpl.
    intros n.
    simpl.
    reflexivity.
  - intros n.
    simpl.
    rewrite count_append.
    simpl.

    remember (fun a => a <? p) as less.
    pose proof (filter_length less l).
    remember (filter less l) as before.
    pose proof (IH _ H).
    rewrite (qs_u_irrelevant H) in H0.
    specialize (H0 n).
    rewrite <- H0.
    clear H0 H.

    remember (fun a => p <=? a) as more.
    pose proof (filter_length more l).
    remember (filter more l) as after.
    pose proof (IH _ H).
    rewrite (qs_u_irrelevant H) in H0.
    specialize (H0 n).
    rewrite <- H0.
    clear H0 H.

    enough (count n l = count n before + count n after) by lia.
    clear IH.
    subst.
    induction l.
    + subst.
      simpl.
      reflexivity.
    + simpl.
      destruct (Nat.ltb_spec n0 p).
      * replace (p <=? n0) with false by lia.
        simpl.
        lia.
      * replace (p <=? n0) with true by lia.
        simpl.
        lia.
Qed.

Theorem quicksort_sorted l: LeSorted (quicksort l).
Proof.
  unfold quicksort.
  induction l as [| l IH p] using List_strong_ind0 .
  - compute.
    constructor.
  - simpl.
    remember (fun a => a <? p) as less.
    pose proof (filter_length less l).
    remember (filter less l) as before.
    remember (fun a => p <=? a) as more.
    pose proof (filter_length more l).
    remember (filter more l) as after.
    pose proof (IH _ H).
    rewrite (qs_u_irrelevant H) in H1.
    pose proof (IH _ H0).
    rewrite (qs_u_irrelevant H0) in H2.
    assert (LeSorted (cons p (qs (length l) after))). {
      clear IH H H1 Heqless Heqbefore less before.
      pose proof (quicksort_permutation after).
      unfold quicksort in *.
      rewrite (qs_u_irrelevant H0) in H.
      pose proof (filter_forall l more).
      rewrite <- Heqafter in H1.
      remember (qs (length l) after) as qafter.
      destruct qafter.
      constructor.
      specialize (H1 n).
      pose proof (Permutation_Elem (Permutation_symm H) n).
      assert (Elem n (cons n qafter)) by constructor.
      specialize (H3 H4).
      destruct (H1 H3).
      subst more.
      constructor.
      lia.
      exact H2.
    }
    destruct (List_push_case (qs (length l) before)).
    + rewrite H4.
      simpl.
      exact H3.
    + destruct H4 as (n & r & H4).
      rewrite H4.
      apply Sorted_append.
      rewrite <- H4.
      exact H1.
      exact H3.
      clear IH H1 H2 H3 H0 Heqmore more Heqafter after.
      pose proof (quicksort_permutation before).
      unfold quicksort in *.
      rewrite (qs_u_irrelevant H) in H0.
      pose proof (Elem_push r n).
      rewrite <- H4 in H1.
      pose proof (filter_forall l less).
      rewrite <- Heqbefore in H2.
      pose proof (Permutation_Elem (Permutation_symm H0) n).
      specialize (H3 H1).
      destruct (H2 n H3).
      subst less.
      lia.
Qed.

Require Import FunInd Recdef.

Function fquicksort (l : List) {measure length l} : List :=
  match l with
  | nil => nil
  | cons p r => append (fquicksort (filter (fun a => a <? p) r))
              (cons p (fquicksort (filter (fun a => p <=? a) r)))
  end.
Proof.
  all: intros.

  remember (fun a => p <=? a) as more.
  pose proof (filter_length more r).
  simpl. lia.

  remember (fun a => a <? p) as less.
  pose proof (filter_length less r).
  simpl. lia.
Defined.

Search "fquicksort".

Print fquicksort.
Print fquicksort_terminate.

Eval vm_compute in fquicksort (cons 2 (cons 6 (cons 8 (cons 11 (cons 3 nil))))).

Eval vm_compute in (6 +> 5 +> []).

Eval vm_compute in fquicksort  (6 +> 7 +> 1 +> 0 +> 100 +> 2 +> 20 +> 120 +> 130 +> 140 +> 151 +> 156 +> nil).

Eval vm_compute in fquicksort [6; 7; 1; 0; 100; 2; 20; 120; 130; 140; 151; 156].

Eval vm_compute in (5 +> 1 +> nil <+ 6 <+ 19).

Eval vm_compute in fquicksort [6; 5; 4; 3; 7; 5; 7; 2; 7; 1; 7; 8; 2; 5; 7; 3; 9].

Eval vm_compute in filter (fun a => 0 <? a) [ 6 ; 7 ; 1 ; 0 ; 100 ; 2 ; 20 ; 120 ; 130 ; 140 ; 151 ; 156].

Theorem fquicksort_permutation l: Permutation l (fquicksort l).
Proof.
  intros n.
  functional induction (fquicksort l) as [ | ? p r ? IHbefore IHafter].
  - simpl. reflexivity.
  - set (less := fun a => a <? p) in *.
    set (before := filter less r) in *.
    set (more := fun a => p <=? a) in *.
    set (after := filter more r) in *.
    simpl.
    rewrite count_append.
    simpl.
    enough (count n r = count n (fquicksort before) + count n (fquicksort after))
      by (simpl;lia).
    destruct IHbefore, IHafter.
    induction r.
    + simpl. reflexivity.
    + subst less more before after.
      simpl in *.
      destruct (n0 <? p) eqn:E.
      * replace (p <=? n0) with false by lia.
        simpl. lia.
      * replace (p <=? n0) with true by lia.
        simpl. lia.
Qed.

Theorem fquicksort_sorted l: LeSorted (fquicksort l).
Proof.
  functional induction (fquicksort l) as [ | ? p l ? IHbefore IHafter].
  - constructor.
  - set (less := fun a => a <? p) in *.
    set (before := filter less l) in *.
    set (more := fun a => p <=? a) in *.
    set (after := filter more l) in *.

    assert ( LeSorted (cons p (fquicksort after))) as p_after_sorted. {
      clear IHbefore less before.
      remember (fquicksort after) as qafter.
      destruct qafter.
      + constructor.
      + constructor.
        rewrite Heqqafter in *.
        pose proof (fquicksort_permutation after).
        apply Permutation_symm in H.
        pose proof (Permutation_Elem H n).
        assert (Elem n (n +> qafter)) by constructor.
        rewrite Heqqafter in H1.
        apply H0 in H1.
        clear H0 H qafter Heqqafter.
        subst more after.
        apply filter_forall in H1.
        destruct H1.
        lia.
        exact IHafter.
    }

    destruct (List_push_case (fquicksort before)) as [-> | H].
    + simpl.
      exact p_after_sorted.
    + destruct H as (n & r & push_eq).
      rewrite push_eq.
      apply Sorted_append.
      * rewrite <- push_eq.
        exact IHbefore.
      * exact p_after_sorted.
      * clear p_after_sorted more after IHafter.
        pose proof (fquicksort_permutation before).
        apply Permutation_symm in H.
        pose proof (Permutation_Elem H n).
        pose proof (Elem_push r n).
        rewrite <- push_eq in H1.
        apply H0 in H1.
        clear push_eq H0 H r.
        subst before less.
        apply filter_forall in H1.
        destruct H1.
        lia.
Qed.


(*From LF Require Export Logic.*)
From Coq Require Import Lia.
Require Import Coq.Strings.Ascii.
Require Import List.

Module IndPropRegexp.

Inductive reg_exp (T : Type) : Type :=
  | EmptySet
  | EmptyStr
  | Char (t : T)
  | App (r1 r2 : reg_exp T)
  | Union (r1 r2 : reg_exp T)
  | Star (r : reg_exp T).
Arguments EmptySet {T}.
Arguments EmptyStr {T}.
Arguments Char {T} _.
Arguments App {T} _ _.
Arguments Union {T} _ _.
Arguments Star {T} _.

Reserved Notation "s =~ re" (at level 80).

(*
    The expression EmptySet does not match any string.
    The expression EmptyStr matches the empty string [].
    The expression Char x matches the one-character string [x].
    If re1 matches s1, and re2 matches s2, then App re1 re2 matches s1 ++ s2.
    If at least one of re1 and re2 matches s, then Union re1 re2 matches s.
    Finally, if we can write some string s as the concatenation of a sequence of
      strings s = s_1 ++ ... ++ s_k, and the expression re matches each one of the
      strings s_i, then Star re matches s.
    In particular, the sequence of strings may be empty, so Star re always matches
      the empty string [] no matter what re is.
*)

Search nil.

Inductive exp_match {T} : list T -> reg_exp T -> Prop :=
  | MEmpty : nil =~ EmptyStr
  | MChar x : cons x nil =~ (Char x)
  | MApp s1 re1 s2 re2
             (H1 : s1 =~ re1)
             (H2 : s2 =~ re2)
           : (s1 ++ s2) =~ (App re1 re2)
  | MUnionL s1 re1 re2
                (H1 : s1 =~ re1)
              : s1 =~ (Union re1 re2)
  | MUnionR re1 s2 re2
                (H2 : s2 =~ re2)
              : s2 =~ (Union re1 re2)
  | MStar0 re : nil =~ (Star re)
  | MStarApp s1 s2 re
                 (H1 : s1 =~ re)
                 (H2 : s2 =~ (Star re))
               : (s1 ++ s2) =~ (Star re)
  where "s =~ re" := (exp_match s re).

Search list.
Definition string := list ascii.

Module HelperLemmas.
  Lemma provable_equiv_true : forall (P : Prop), P -> (P <-> True).
  Proof.
    intros.
    split.
    - intros. constructor.
    - intros _. apply H.
  Qed.

  Lemma not_equiv_false : forall (P : Prop), ~P -> (P <-> False).
  Proof.
    intros.
    split.
    - apply H.
    - intros. destruct H0.
  Qed.

  Lemma null_matches_none : forall (s : string), (s =~ EmptySet) <-> False.
  Proof.
    intros.
    apply not_equiv_false.
    unfold not. intros. inversion H.
  Qed.

  Lemma empty_matches_eps : forall (s : string), s =~ EmptyStr <-> s = nil.
  Proof.
    split.
    - intros. inversion H. reflexivity.
    - intros. rewrite H. apply MEmpty.
  Qed.

  Lemma empty_nomatch_ne : forall (a : ascii) s, (a :: s =~ EmptyStr) <-> False.
  Proof.
    intros.
    apply not_equiv_false.
    unfold not. intros. inversion H.
  Qed.

  Lemma char_nomatch_char :
    forall (a b : ascii) s, b <> a -> (b :: s =~ Char a <-> False).
  Proof.
    intros.
    apply not_equiv_false.
    unfold not.
    intros.
    apply H.
    inversion H0.
    reflexivity.
  Qed.

  Lemma char_eps_suffix : forall (a : ascii) s, a :: s =~ Char a <-> s = nil.
  Proof.
    split.
    - intros. inversion H. reflexivity.
    - intros. rewrite H. apply MChar.
  Qed.

  Lemma app_exists : forall (s : string) re0 re1,
    s =~ App re0 re1 <->
    exists s0 s1, s = s0 ++ s1 /\ s0 =~ re0 /\ s1 =~ re1.
  Proof.
    intros.
    split.
    - intros. inversion H. exists s1, s2. split.
      + reflexivity.
      + split. apply H3. apply H4.
    - intros [ s0 [ s1 [ Happ [ Hmat0 Hmat1 ] ] ] ].
      rewrite Happ. apply (MApp s0 _ s1 _ Hmat0 Hmat1).
  Qed.

  Lemma app_ne : forall (a : ascii) s re0 re1,
    a :: s =~ (App re0 re1) <->
    (nil =~ re0 /\ a :: s =~ re1) \/
    exists s0 s1, s = s0 ++ s1 /\ a :: s0 =~ re0 /\ s1 =~ re1.
  Proof.
    intros. split.
    - intros Hmat.
      (* MApp s1 re1 s2 re2
             (H1 : s1 =~ re1)
             (H2 : s2 =~ re2) *)
      inversion Hmat.
      destruct s1 as [| s1h s1t].
      + left.
        split. apply H1.
        simpl. apply H3.
      + right.
        simpl in H0.
        injection H0 as H0h H0.
        exists s1t, s2.
        split.
        * symmetry. apply H0.
        * split.
          ** rewrite -> H0h in H1. apply H1.
          ** apply H3.
    - intros [ [ Hnil Hasre1] | [ s0 [ s1 [ Es [ Has0re0 Hs1re1 ] ] ] ] ].
      + (*MApp s1 re1 s2 re2 (H1 : s1 =~ re1) (H2 : s2 =~ re2): (s1 ++ s2) *)
        apply (MApp nil re0 (a :: s) re1 Hnil Hasre1).
      + assert(G: a :: s = (a :: s0) ++ s1). {
          rewrite -> Es. simpl. reflexivity.
        }
        rewrite -> G.
        apply (MApp (a :: s0) re0 s1 re1 Has0re0 Hs1re1).
  Qed.

  Lemma union_disj : forall (s : string) re0 re1,
    s =~ Union re0 re1 <-> (s =~ re0 \/ s =~ re1).
  Proof.
    intros. split.
    - intros. inversion H.
      + left. apply H2.
      + right. apply H1.
    - intros [ H | H ].
      + apply MUnionL. apply H.
      + apply MUnionR. apply H.
  Qed.

  Lemma star_empty_empty: forall (s: string),
    s =~ Star EmptyStr -> s = nil.
  Proof.
    intros.
    remember (Star EmptyStr) as k eqn:Ek.
    induction H as [| c
                    | s1 re1 s2 re2 H1 IH1 H2 IH2
                    | s1 re1 re2 H1 IH
                    | re1 s2 re2 H2 IH
                    | re
                    | s1 s2 re H1 IH1 H2 IH2 ].
    - (* MEmpty  *) discriminate Ek.
    - (* MChar *) discriminate Ek.
    - (* MApp *) discriminate Ek.
    - (* MUnionL *) discriminate Ek.
    - (* MUnionR *) discriminate Ek.
    - (* MStar0 *) reflexivity.
    - (* MStarApp *) injection Ek as Ek'.
      rewrite -> Ek' in H2.
      rewrite -> Ek' in H1.
      assert(G: s1 = nil). {
        apply empty_matches_eps.
        apply H1.
      }
      rewrite -> G. simpl.
      apply IH2.
      rewrite -> Ek'.
      reflexivity.
  Qed.

  Search (?l ++ nil = ?l).
  Lemma star_ne : forall (a : ascii) s re,
    a :: s =~ Star re <->
    exists s0 s1, s = s0 ++ s1 /\ a :: s0 =~ re /\ s1 =~ Star re.
  Proof.
    intros.
    split.
    + intros H.
      remember (Star re) as k eqn:Ek.
      remember (a :: s) as acs eqn:Eacs.
      induction H as [| c
                      | s1 re1 s2 re2 H1 IH1 H2 IH2
                      | s1 re1 re2 H1 IH
                      | re1 s2 re2 H2 IH
                      | re'
                      | s1 s2 re' H1 IH1 H2 IH2 ].
      - (* MEmpty  *) discriminate Ek.
      - (* MChar *) discriminate Ek.
      - (* MApp *) discriminate Ek.
      - (* MUnionL *) discriminate Ek.
      - (* MUnionR *) discriminate Ek.
      - (* MStar0 *) discriminate Eacs.
      - (* MStarApp *)
        destruct s1 as [| s1h s1t] eqn:Es1.
        * simpl in Eacs.
          apply (IH2 Ek Eacs).
        * simpl in Eacs.
          injection Eacs as Eacs'h Eacs't.
          exists s1t, s2.
          split.
          ** symmetry. apply Eacs't.
          ** split.
             *** rewrite -> Eacs'h in H1. injection Ek as Ek. rewrite -> Ek in H1. apply H1.
             *** apply H2.
    + intros [ s0 [ s1 [ Es [Has0 Hs1 ] ] ] ].
      rewrite -> Es.
      assert (G: a :: s0 ++ s1 = (a :: s0) ++ s1). { reflexivity. }
      rewrite -> G.
      (* MStarApp s1 s2 re (H1 : s1 =~ re) (H2 : s2 =~ (Star re))   : (s1 ++ s2) =~ (Star re) *)
      apply (MStarApp (a :: s0) s1 _ Has0 Hs1).
  Qed.

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

End HelperLemmas.

Import HelperLemmas.

Definition refl_matches_eps m := forall re : reg_exp ascii, reflect (nil =~ re) (m re).

Fixpoint match_eps (re: reg_exp ascii) : bool :=
  match re with
  | EmptyStr => true
  | EmptySet => false
  | Char _ => false
  | App r1 r2 => match_eps r1 && match_eps r2
  | Union r1 r2 => match_eps r1 || match_eps r2
  | Star _ => true
  end.

  Search (?l1 ++ ?l2 = nil).

Lemma match_eps_refl : refl_matches_eps match_eps.
Proof.
  unfold refl_matches_eps.
  intros re.
  induction re as [ | | c | r1 IHl r2 IHr | r1 IHl r2 IHr | r IH].
  - simpl. apply ReflectF. unfold not. intros H. inversion H.
  - simpl. apply ReflectT. apply MEmpty.
  - simpl. apply ReflectF. unfold not. intros H. inversion H.
  - simpl.
    destruct (match_eps r1).
    + destruct (match_eps r2).
      ++ simpl. inversion IHl as [IHl' | _]. inversion IHr as [IHr' | _]. apply ReflectT.
         apply (MApp nil r1 nil r2 IHl' IHr').
      ++ simpl. apply ReflectF. unfold not. intros H. inversion H. inversion IHr.
         apply H5.
         assert (G: s2 = nil). { destruct (app_eq_nil s1 s2 H1). apply H7. }
         rewrite -> G in H4. apply H4.
    + simpl. apply ReflectF. unfold not. intros H. inversion H. inversion IHl.
      apply H5.
      assert (G: s1 = nil). { destruct (app_eq_nil s1 s2 H1). apply H6. }
      rewrite -> G in H3. apply H3.
  - simpl.
    destruct (match_eps r1).
    + simpl. apply ReflectT.
      assert (G: nil =~ r1). {inversion IHl. apply H. }
      apply (MUnionL nil r1 r2 G).
    + destruct (match_eps r2).
      ++ simpl. apply ReflectT.
         assert (G: nil =~ r2). {inversion IHr. apply H. }
         apply (MUnionR r1 nil r2 G).
      ++ simpl. apply ReflectF. unfold not. intros H. inversion IHl.
         apply H0. inversion H. apply H3.
         inversion IHr. exfalso. apply H5. apply H3.
  - simpl. apply ReflectT. apply MStar0.
Qed.

Definition is_der re (a : ascii) re' :=
  forall s, a :: s =~ re <-> s =~ re'.

Definition derives d := forall a re, is_der re a (d a re).

Fixpoint derive (a : ascii) (re : reg_exp ascii) : reg_exp ascii :=
  match re with
  | EmptySet => EmptySet
  | EmptyStr => EmptySet
  | Char t => if eqb t a then EmptyStr else EmptySet
  | App r1 r2 =>  (* TODO *)
    if match_eps r1
    then
      match derive a r1 with
      | EmptySet => derive a r2
      | o => App o r2
      end
    else App (derive a r1) r2
  | Union r1 r2 =>
    match derive a r1 with
    | EmptySet => derive a r2
    | o => o
    end
  | Star r =>
    let d := derive a r in
    if match_eps d then Star r else App d (Star r)
  end.

Module DeriveTests.
  Example c := ascii_of_nat 99.
  Example d := ascii_of_nat 100.

  (* "c" =~ EmptySet: *)
  Example test_der0 : match_eps (derive c (EmptySet)) = false.
  Proof. simpl. reflexivity. Qed.

  (* "c" =~ Char c:  *)
  Example test_der1 : match_eps (derive c (Char c)) = true.
  Proof. simpl. reflexivity. Qed.

  (* "c" =~ Char d: *)
  Example test_der2 : match_eps (derive c (Char d)) = false.
  Proof. simpl. reflexivity. Qed.

  (* "c" =~ App (Char c) EmptyStr: *)
  Example test_der3 : match_eps (derive c (App (Char c) EmptyStr)) = true.
  Proof. simpl. reflexivity. Qed.

  (* "c" =~ App EmptyStr (Char c): *)
  Example test_der4 : match_eps (derive c (App EmptyStr (Char c))) = true.
  Proof. simpl. reflexivity. Qed.

  (* "c" =~ App (Star d) (Char c): *)
  Example test_der41 : match_eps (derive c (App (Star (Char d)) (Char c))) = true.
  Proof. simpl. reflexivity. Qed.

  (* "dc" =~ App (Star d) (Char c): *)
  Example test_der42 : match_eps (derive c (derive d (App (Star (Char d)) (Char c)))) = true.
  Proof. simpl. reflexivity. Qed.

  (* "c" =~ Star c: *)
  Example test_der5 : match_eps (derive c (Star (Char c))) = true.
  Proof. simpl. reflexivity. Qed.

  (* "cd" =~ App (Char c) (Char d): *)
  Example test_der6 :
    match_eps (derive d (derive c (App (Char c) (Char d)))) = true.
  Proof. simpl. reflexivity. Qed.

  (* "cd" =~ App (Char d) (Char c): *)
  Example test_der7 :
    match_eps (derive d (derive c (App (Char d) (Char c)))) = false.
  Proof. simpl. reflexivity. Qed.

End DeriveTests.

Search (?s = nil ++ ?s).

Lemma derive_corr : derives derive.
Proof.
  unfold derives, is_der.
  intros a re.
  generalize dependent a.
  induction re as [ | | c | r1 IHl r2 IHr | r1 IHl r2 IHr | r IH].
  - simpl. intros. split.
    + intros H. inversion H.
    + intros H. inversion H.
  - simpl. intros. split.
    + intros H. inversion H.
    + intros H. inversion H.
  - simpl. intros. split.
    + intros H. inversion H.
      destruct (eqb_spec c c).
      * apply MEmpty.
      * exfalso. apply n. reflexivity.
    + intros H.
      destruct (eqb_spec c a) as [Eca | Eca].
      * rewrite <- Eca.
        inversion H.
        apply (MChar c).
      * inversion H.
  - simpl. intros. split.
Admitted.

Definition matches_regex m : Prop :=
  forall (s : string) re, reflect (s =~ re) (m s re).

Fixpoint regex_match (s : string) (re : reg_exp ascii) : bool. Admitted.

Theorem regex_refl : matches_regex regex_match.
Proof. Admitted.

Module End.


Inductive bTree : Set :=
  | bleaf : bool -> bTree
  | bnode : (bool -> bool -> bool) -> bTree -> bTree -> bTree.

Check bleaf true.
Check bnode orb (bleaf true) (bnode andb (bleaf false) (bleaf true)).

(* a *)

Fixpoint height (t:bTree) : nat :=
  match t with
    | bleaf b => 1
    | bnode o bl br => 1 + max (height bl) (height br)
  end.

Definition t1 := bnode orb (bleaf true) (bnode andb (bleaf false) (bleaf true)).
Definition t2 := bnode orb (bnode andb (bleaf true) (bleaf false)) (bleaf true).

Eval compute in height t1.
Eval compute in height t2.

(* b *)

Fixpoint mirror (t:bTree) : bTree :=
  match t with
    | bleaf b => bleaf b
    | bnode o bl br => bnode o (mirror br) (mirror bl)
  end.

Eval simpl in mirror t1.
Eval simpl in mirror t2.

Print t1.
Print t2.

(* c *)

Inductive hbTree : nat -> Set :=
  | hleaf : bool -> hbTree 0
  | hnode : forall n:nat, (bool->bool->bool) -> hbTree n -> hbTree n -> hbTree (S n).

Check hleaf true.
Check hnode 0 andb (hleaf true) (hleaf true).
Check hnode 1 andb (hnode 0 andb (hleaf true) (hleaf true)) (hnode 0 andb (hleaf true) (hleaf true)).

Fixpoint forgetful (n:nat) (t: hbTree n) : bTree :=
  match t with
    | hleaf b => bleaf b
    | hnode m o bl br => bnode o (forgetful m bl) (forgetful m br)
  end.

Eval compute in forgetful 0 (hleaf true).
Eval compute in forgetful 1 (hnode 0 andb (hleaf true) (hleaf true)).
Eval compute in forgetful 2 (hnode 1 andb (hnode 0 andb (hleaf true) (hleaf true)) (hnode 0 andb (hleaf true) (hleaf true))).


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_congruenceflip.
Require Import ProofCheckingEuclid.lemma_congruencesymmetric.
Require Import ProofCheckingEuclid.lemma_congruencetransitive.
Require Import ProofCheckingEuclid.lemma_extensionunique.

Section Euclid.

Context `{Ax:euclidean_neutral}.

Lemma lemma_rightreverse :
	forall A B C D,
	RightTriangle A B C ->
	BetS A B D ->
	Cong A B B D ->
	Cong A C D C.
Proof.
	intros A B C D.
	intros RightTriangle_ABC.
	intros BetS_A_B_D.
	intros Cong_AB_BD.

	destruct RightTriangle_ABC as (E & BetS_A_B_E & Cong_AB_EB & Cong_AC_EC & _).

	pose proof (lemma_congruencesymmetric _ _ _ _ Cong_AB_BD) as Cong_BD_AB.
	pose proof (lemma_congruencetransitive _ _ _ _ _ _ Cong_BD_AB Cong_AB_EB) as Cong_BD_EB.
	pose proof (lemma_congruenceflip _ _ _ _ Cong_BD_EB) as (_ & _ & Cong_BD_BE).
	pose proof (lemma_extensionunique _ _ _ _ BetS_A_B_D BetS_A_B_E Cong_BD_BE) as eq_D_E.
	assert (Cong A C D C) as Cong_AC_DC by (rewrite eq_D_E; exact Cong_AC_EC).

	exact Cong_AC_DC.
Qed.

End Euclid.


(** Proof that the square root of 2 is irrational *)

Require Import Coq.ZArith.Znumtheory.
Require Import Coq.omega.Omega.
Require Import Coq.Reals.Reals.

Open Scope Z_scope.

Lemma even_sqr_even :
  forall n:Z, Zeven (n * n) -> Zeven n.
Proof.
  intros.
  apply Zeven_bool_iff in H.
  apply Zeven_bool_iff.
  rewrite Z.even_mul in H.
  rewrite Bool.orb_diag in H.
  apply H.
Qed.

Lemma even_not_rel_prime :
  forall a b:Z, Zeven a /\ Zeven b -> ~ rel_prime a b.
Proof.
  intros.
  destruct H as [ H_even_a H_even_b ].
  assert (H_b_half_exists : exists b_half : Z, b = 2 * b_half).
  apply Zeven_ex_iff.
  apply H_even_b.
  destruct H_b_half_exists as [ b_half H_b_half_b_eqn ].
  assert (H_a_half_exists : exists a_half : Z, a = 2 * a_half).
  apply Zeven_ex_iff.
  apply H_even_a.
  destruct H_a_half_exists as [ a_half H_a_half_a_eqn ].
  rewrite H_b_half_b_eqn, H_a_half_a_eqn.
  unfold rel_prime.
  intro H_rel_prime.
  remember (Z.gcd a_half b_half) as g.
  assert (H_rel_prime' : Zis_gcd a_half b_half g).
  rewrite Heqg.
  apply Zgcd_is_gcd.
  apply (Zis_gcd_mult _ _ 2 _) in H_rel_prime'.
  apply Zis_gcd_gcd in H_rel_prime.
  apply Zis_gcd_gcd in H_rel_prime'.
  assert (H_1_eq_2_g : 1 = 2 * g).
  congruence.
  assert (H_1_neq_2_g : 1 <> 2 * g).
  omega.
  contradiction.
  assert (H_g_nonneg : 0 <= g).
  rewrite Heqg.
  apply Z.gcd_nonneg.
  omega.
  discriminate.
Qed.

Theorem sqrt_2_irrat :
  (*
    sqrt(2) = b / a
    2 = (b * b) / (a * a)
    b * b = 2 * a * a
  *)
  forall a b:Z, a <> 0 -> b * b = 2 * a * a /\ rel_prime a b -> False.
Proof.
  intros a b H_a_nonzero H.
  destruct H as [ H_b_a_eqn H_rel_prime ].
  assert (H_2_a_sqr_even : Zeven (2 * a * a)).
  rewrite <- Z.mul_assoc.
  apply Zeven_2p.
  assert (H_b_sqr_even : Zeven (b * b)).
  rewrite H_b_a_eqn.
  apply H_2_a_sqr_even.
  clear H_2_a_sqr_even.
  assert (H_b_even : Zeven b).
  apply even_sqr_even.
  apply H_b_sqr_even.
  clear H_b_sqr_even.
  assert (H_c_exists : exists c : Z, b = 2 * c).
  apply Zeven_ex_iff.
  apply H_b_even.
  destruct H_c_exists as [ c H_b_c_eqn ].
  assert (H_c_a_eqn : 2 * c * c = a * a).
  rewrite <- (Z.mul_cancel_l _ _ 2).
  rewrite Z.mul_comm.
  rewrite <- H_b_c_eqn.
  replace (b * c * 2) with (b * (2 * c)) by ring.
  rewrite <- H_b_c_eqn.
  rewrite Z.mul_assoc.
  apply H_b_a_eqn.
  discriminate.
  clear H_b_c_eqn.
  assert (H_2_c_sqr_even : Zeven (2 * c * c)).
  rewrite <- Z.mul_assoc.
  apply Zeven_2p.
  assert (H_a_sqr_even : Zeven (a * a)).
  rewrite <- H_c_a_eqn.
  apply H_2_c_sqr_even.
  clear dependent c.
  assert (H_a_even : Zeven a).
  apply even_sqr_even.
  apply H_a_sqr_even.
  clear H_a_sqr_even.
  assert (H_not_rel_prime : ~ rel_prime a b).
  apply even_not_rel_prime.
  auto.
  contradiction.
Qed.