(**
This file is part of the Coq.Interval library for proving bounds of
real-valued expressions in Coq: http://coq-interval.gforge.inria.fr/

Copyright (C) 2007-2016, Inria

This library is governed by the CeCILL-C license under French law and
abiding by the rules of distribution of free software. You can use,
modify and/or redistribute the library under the terms of the CeCILL-C
license as circulated by CEA, CNRS and Inria at the following URL:
http://www.cecill.info/

As a counterpart to the access to the source code and rights to copy,
modify and redistribute granted by the license, users are provided
only with a limited warranty and the library's author, the holder of
the economic rights, and the successive licensors have only limited
liability. See the COPYING file for more details.
*)

From Coq Require Import Reals Psatz.
From Flocq Require Export Raux.

Ltac evar_last :=
  match goal with
  | |- ?f ?x =>
    let tx := type of x in
    let tx := eval simpl in tx in
    let tmp := fresh "tmp" in
    evar (tmp : tx) ;
    refine (@eq_ind tx tmp f _ x _) ;
    unfold tmp ; clear tmp
  end.

Lemma Rmult_le_compat_neg_r :
  forall r r1 r2 : R,
  (r <= 0)%R -> (r1 <= r2)%R -> (r2 * r <= r1 * r)%R.
Proof.
intros.
rewrite (Rmult_comm r2).
rewrite (Rmult_comm r1).
apply Rmult_le_compat_neg_l.
exact H.
exact H0.
Qed.

Lemma Rsqr_plus1_pos x : (0 < 1 + Rsqr x)%R.
Proof. now apply (Rplus_lt_le_0_compat _ _ Rlt_0_1 (Rle_0_sqr x)). Qed.

Lemma Rsqr_plus1_neq0 x : (1 + Rsqr x <> 0)%R.
Proof. now apply Rgt_not_eq; apply Rlt_gt; apply Rsqr_plus1_pos. Qed.

Lemma Rmin_Rle :
  forall r1 r2 r,
  (Rmin r1 r2 <= r)%R <-> (r1 <= r)%R \/ (r2 <= r)%R.
Proof.
intros.
unfold Rmin.
split.
case (Rle_dec r1 r2) ; intros.
left. exact H.
right. exact H.
intros [H|H] ; case (Rle_dec r1 r2) ; intros H0.
exact H.
apply Rle_trans with (2 := H).
apply Rlt_le.
apply Rnot_le_lt with (1 := H0).
apply Rle_trans with r2 ; assumption.
exact H.
Qed.

Lemma Rle_Rinv_pos :
  forall x y : R,
  (0 < x)%R -> (x <= y)%R -> (/y <= /x)%R.
Proof.
intros.
apply Rle_Rinv.
exact H.
apply Rlt_le_trans with x ; assumption.
exact H0.
Qed.

Lemma Rle_Rinv_neg :
  forall x y : R,
  (y < 0)%R -> (x <= y)%R -> (/y <= /x)%R.
Proof.
intros.
apply Ropp_le_cancel.
repeat rewrite Ropp_inv_permute.
apply Rle_Rinv.
auto with real.
apply Rlt_le_trans with (Ropp y).
auto with real.
auto with real.
auto with real.
apply Rlt_dichotomy_converse.
left. exact H.
apply Rlt_dichotomy_converse.
left.
apply Rle_lt_trans with y ; assumption.
Qed.

Lemma Rmult_le_pos_pos :
  forall x y : R,
  (0 <= x)%R -> (0 <= y)%R -> (0 <= x * y)%R.
Proof.
exact Rmult_le_pos.
Qed.

Lemma Rmult_le_pos_neg :
  forall x y : R,
  (0 <= x)%R -> (y <= 0)%R -> (x * y <= 0)%R.
Proof.
intros.
rewrite <- (Rmult_0_r x).
apply Rmult_le_compat_l ; assumption.
Qed.

Lemma Rmult_le_neg_pos :
  forall x y : R,
  (x <= 0)%R -> (0 <= y)%R -> (x * y <= 0)%R.
Proof.
intros.
rewrite <- (Rmult_0_l y).
apply Rmult_le_compat_r ; assumption.
Qed.

Lemma Rmult_le_neg_neg :
  forall x y : R,
  (x <= 0)%R -> (y <= 0)%R -> (0 <= x * y)%R.
Proof.
intros.
rewrite <- (Rmult_0_r x).
apply Rmult_le_compat_neg_l ; assumption.
Qed.

Lemma Rabs_def1_le :
  forall x a,
  (x <= a)%R -> (-a <= x)%R ->
  (Rabs x <= a)%R.
Proof.
intros.
case (Rcase_abs x) ; intros.
rewrite (Rabs_left _ r).
rewrite <- (Ropp_involutive a).
apply Ropp_le_contravar.
exact H0.
rewrite (Rabs_right _ r).
exact H.
Qed.

Lemma Rabs_def2_le :
  forall x a,
  (Rabs x <= a)%R ->
  (-a <= x <= a)%R.
Proof.
intros x a H.
assert (0 <= a)%R.
apply Rle_trans with (2 := H).
apply Rabs_pos.
generalize H. clear H.
unfold Rabs.
case (Rcase_abs x) ; split.
rewrite <- (Ropp_involutive x).
apply Ropp_le_contravar.
exact H.
apply Rlt_le.
apply Rlt_le_trans with (1 := r).
exact H0.
generalize (Rge_le _ _ r).
clear r.
intro.
apply Rle_trans with (2 := H1).
rewrite <- Ropp_0.
apply Ropp_le_contravar.
exact H0.
exact H.
Qed.

Theorem derivable_pt_lim_eq :
  forall f g,
 (forall x, f x = g x) ->
  forall x l,
  derivable_pt_lim f x l -> derivable_pt_lim g x l.
Proof.
intros f g H x l.
unfold derivable_pt_lim.
intros.
destruct (H0 _ H1) as (delta, H2).
exists delta.
intros.
do 2 rewrite <- H.
apply H2 ; assumption.
Qed.

Definition locally_true x (P : R -> Prop) :=
  exists delta, (0 < delta)%R /\
  forall h, (Rabs h < delta)%R -> P (x + h)%R.

Theorem derivable_pt_lim_eq_locally :
  forall f g x l,
  locally_true x (fun v => f v = g v) ->
  derivable_pt_lim f x l -> derivable_pt_lim g x l.
Proof.
intros f g x l (delta1, (Hd, Heq)) Hf eps Heps.
destruct (Hf eps Heps) as (delta2, H0).
clear Hf.
assert (0 < Rmin delta1 delta2)%R.
apply Rmin_pos.
exact Hd.
exact (cond_pos delta2).
exists (mkposreal (Rmin delta1 delta2) H).
intros.
rewrite <- Heq.
pattern x at 2 ; rewrite <- Rplus_0_r.
rewrite <- Heq.
rewrite Rplus_0_r.
apply H0.
exact H1.
apply Rlt_le_trans with (1 := H2).
simpl.
apply Rmin_r.
rewrite Rabs_R0.
exact Hd.
apply Rlt_le_trans with (1 := H2).
simpl.
apply Rmin_l.
Qed.

Theorem locally_true_and :
  forall P Q x,
  locally_true x P ->
  locally_true x Q ->
  locally_true x (fun x => P x /\ Q x).
Proof.
intros P Q x HP HQ.
destruct HP as (e1, (He1, H3)).
destruct HQ as (e2, (He2, H4)).
exists (Rmin e1 e2).
split.
apply Rmin_pos ; assumption.
intros.
split.
apply H3.
apply Rlt_le_trans with (1 := H).
apply Rmin_l.
apply H4.
apply Rlt_le_trans with (1 := H).
apply Rmin_r.
Qed.

Theorem locally_true_imp :
  forall P Q : R -> Prop,
 (forall x, P x -> Q x) ->
  forall x,
  locally_true x P ->
  locally_true x Q.
Proof.
intros P Q H x (d, (Hd, H0)).
exists d.
split.
exact Hd.
intros.
apply H.
apply H0.
exact H1.
Qed.

Theorem continuity_pt_lt :
  forall f x y,
  (f x < y)%R ->
  continuity_pt f x ->
  locally_true x (fun u => (f u < y)%R).
Proof.
intros.
assert (0 < y - f x)%R.
apply Rplus_lt_reg_l with (f x).
rewrite Rplus_0_r.
replace (f x + (y - f x))%R with y. 2: ring.
exact H.
destruct (H0 _ H1) as (delta, (Hdelta, H2)).
clear H0.
exists delta.
split.
exact Hdelta.
intros.
case (Req_dec h 0) ; intro H3.
rewrite H3.
rewrite Rplus_0_r.
exact H.
generalize (H2 (x + h)%R). clear H2.
unfold R_met, R_dist, D_x, no_cond.
simpl.
intro.
apply Rplus_lt_reg_r with (- f x)%R.
apply Rle_lt_trans with (1 := RRle_abs (f (x + h) - f x)%R).
apply H2.
assert (x + h - x = h)%R. ring.
split.
split.
exact I.
intro H5.
elim H3.
rewrite <- H4.
rewrite <- H5.
exact (Rplus_opp_r _).
rewrite H4.
exact H0.
Qed.

Theorem continuity_pt_gt :
  forall f x y,
  (y < f x)%R ->
  continuity_pt f x ->
  locally_true x (fun u => (y < f u)%R).
Proof.
intros.
generalize (Ropp_lt_contravar _ _ H).
clear H. intro H.
generalize (continuity_pt_opp _ _ H0).
clear H0. intro H0.
destruct (continuity_pt_lt (opp_fct f) _ _ H H0) as (delta, (Hdelta, H1)).
exists delta.
split.
exact Hdelta.
intros.
apply Ropp_lt_cancel.
exact (H1 _ H2).
Qed.

Theorem continuity_pt_ne :
  forall f x y,
  f x <> y ->
  continuity_pt f x ->
  locally_true x (fun u => f u <> y).
Proof.
intros.
destruct (Rdichotomy _ _ H) as [H1|H1].
destruct (continuity_pt_lt _ _ _ H1 H0) as (delta, (Hdelta, H2)).
exists delta.
split.
exact Hdelta.
intros.
apply Rlt_not_eq.
exact (H2 _ H3).
destruct (continuity_pt_gt _ _ _ H1 H0) as (delta, (Hdelta, H2)).
exists delta.
split.
exact Hdelta.
intros.
apply Rgt_not_eq.
exact (H2 _ H3).
Qed.

Theorem derivable_pt_lim_tan :
  forall x,
  (cos x <> 0)%R ->
  derivable_pt_lim tan x (1 + Rsqr (tan x))%R.
Proof.
intros x Hx.
change (derivable_pt_lim (sin/cos) x (1 + Rsqr (tan x))%R).
replace (1 + Rsqr (tan x))%R with ((cos x * cos x - (-sin x) * sin x) / Rsqr (cos x))%R.
apply derivable_pt_lim_div.
apply derivable_pt_lim_sin.
apply derivable_pt_lim_cos.
exact Hx.
unfold Rsqr, tan.
field.
exact Hx.
Qed.

Definition connected (P : R -> Prop) :=
  forall x y, P x -> P y ->
  forall z, (x <= z <= y)%R -> P z.

Lemma connected_and :
  forall d1 d2, connected d1 -> connected d2 -> connected (fun t => d1 t /\ d2 t).
Proof.
intros d1 d2 H1 H2 u v [D1u D2u] [D1v D2v] t Ht.
split.
now apply H1 with (3 := Ht).
now apply H2 with (3 := Ht).
Qed.

Lemma connected_ge :
  forall x, connected (Rle x).
Proof.
intros x u v Hu _ t [Ht _].
exact (Rle_trans _ _ _ Hu Ht).
Qed.

Lemma connected_le :
  forall x, connected (fun t => Rle t x).
Proof.
intros x u v _ Hv t [_ Ht].
exact (Rle_trans _ _ _ Ht Hv).
Qed.

Theorem derivable_pos_imp_increasing :
  forall f f' dom,
  connected dom ->
 (forall x, dom x -> derivable_pt_lim f x (f' x) /\ (0 <= f' x)%R) ->
  forall u v, dom u -> dom v -> (u <= v)%R -> (f u <= f v)%R.
Proof.
intros f f' dom Hdom Hd u v Hu Hv [Huv|Huv].
assert (forall w, (u <= w <= v)%R -> derivable_pt_lim f w (f' w)).
intros w Hw.
refine (proj1 (Hd _ _)).
exact (Hdom _ _ Hu Hv _ Hw).
destruct (MVT_cor2 _ _ _ _ Huv H) as (w, (Hw1, Hw2)).
replace (f v) with (f u + (f v - f u))%R by ring.
rewrite Hw1.
pattern (f u) at 1 ; rewrite <- Rplus_0_r.
apply Rplus_le_compat_l.
apply Rmult_le_pos.
refine (proj2 (Hd _ _)).
refine (Hdom _ _ Hu Hv _ _).
exact (conj (Rlt_le _ _ (proj1 Hw2)) (Rlt_le _ _ (proj2 Hw2))).
rewrite <- (Rplus_opp_r u).
unfold Rminus.
apply Rplus_le_compat_r.
exact (Rlt_le _ _ Huv).
rewrite Huv.
apply Rle_refl.
Qed.

Theorem derivable_neg_imp_decreasing :
  forall f f' dom,
  connected dom ->
 (forall x, dom x -> derivable_pt_lim f x (f' x) /\ (f' x <= 0)%R) ->
  forall u v, dom u -> dom v -> (u <= v)%R -> (f v <= f u)%R.
Proof.
intros f f' dom Hdom Hd u v Hu Hv Huv.
apply Ropp_le_cancel.
refine (derivable_pos_imp_increasing (opp_fct f) (opp_fct f') _ Hdom _ _ _ Hu Hv Huv).
intros.
destruct (Hd x H) as (H1, H2).
split.
apply derivable_pt_lim_opp with (1 := H1).
rewrite <- Ropp_0.
apply Ropp_le_contravar with (1 := H2).
Qed.

Lemma even_or_odd :
  forall n : nat, exists k, n = 2 * k \/ n = S (2 * k).
Proof.
induction n.
exists 0.
now left.
destruct IHn as [k [Hk|Hk]].
exists k.
right.
now apply f_equal.
exists (S k).
left.
lia.
Qed.

Lemma alternated_series_ineq' :
  forall u l,
  Un_decreasing u ->
  Un_cv u 0 ->
  Un_cv (fun n => sum_f_R0 (tg_alt u) n) l ->
  forall n,
  (0 <= (-1)^(S n) * (l - sum_f_R0 (tg_alt u) n) <= u (S n))%R.
Proof.
intros u l Du Cu Cl n.
destruct (even_or_odd n) as [p [Hp|Hp]].
- destruct (alternated_series_ineq u l p Du Cu Cl) as [H1 H2].
  rewrite Hp, pow_1_odd.
  split.
  + lra.
  + apply Rplus_le_reg_r with (- sum_f_R0 (tg_alt u) (2 * p))%R.
    ring_simplify.
    replace (- sum_f_R0 (tg_alt u) (2 * p) + u (S (2 * p)))%R
      with (- (sum_f_R0 (tg_alt u) (2 * p) + (-1) * u (S (2 * p))))%R by ring.
    rewrite <- (pow_1_odd p).
    now apply Ropp_le_contravar.
- assert (H0: S (S (2 * p)) = 2 * (p + 1)) by ring.
  rewrite Hp.
  rewrite H0 at 1 2.
  rewrite pow_1_even, Rmult_1_l.
  split.
  + apply Rle_0_minus.
    now apply alternated_series_ineq.
  + apply Rplus_le_reg_l with (sum_f_R0 (tg_alt u) (S (2 * p))).
    ring_simplify.
    rewrite <- (Rmult_1_l (u (S (S (2 * p))))).
    rewrite <- (pow_1_even (p + 1)).
    rewrite <- H0.
    destruct (alternated_series_ineq u l (p + 1) Du Cu Cl) as [_ H1].
    now rewrite <- H0 in H1.
Qed.

Lemma Un_decreasing_exp :
  forall x : R,
  (0 <= x <= 1)%R ->
  Un_decreasing (fun n => / INR (fact n) * x ^ n)%R.
Proof.
intros x Hx n.
change (fact (S n)) with (S n * fact n).
rewrite mult_INR.
rewrite Rinv_mult_distr.
simpl pow.
rewrite <- (Rmult_1_r (/ _ * _ ^ n)).
replace (/ INR (S n) * / INR (fact n) * (x * x ^ n))%R
  with (/ INR (fact n) * x ^ n * (/ INR (S n) * x))%R by ring.
apply Rmult_le_compat_l.
apply Rmult_le_pos.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_fact.
now apply pow_le.
rewrite <- (Rmult_1_r 1).
apply Rmult_le_compat.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_Sn.
apply Hx.
rewrite <- Rinv_1.
apply Rle_Rinv_pos.
apply Rlt_0_1.
apply (le_INR 1).
apply le_n_S, le_0_n.
apply Hx.
now apply not_0_INR.
apply INR_fact_neq_0.
Qed.

Lemma Un_decreasing_cos :
  forall x : R,
  (Rabs x <= 1)%R ->
  Un_decreasing (fun n => / INR (fact (2 * n)) * x ^ (2 * n))%R.
Proof.
intros x Hx n.
replace (2 * S n) with (2 + 2 * n) by ring.
rewrite pow_add.
rewrite <- Rmult_assoc.
apply Rmult_le_compat_r.
rewrite pow_sqr.
apply pow_le.
apply Rle_0_sqr.
change (fact (2 + 2 * n)) with ((2 + 2 * n) * ((1 + 2 * n) * fact (2 * n))).
rewrite  mult_assoc, mult_comm.
rewrite mult_INR.
rewrite <- (Rmult_1_r (/ INR (fact _))).
rewrite Rinv_mult_distr.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_fact.
rewrite <- (Rmult_1_r 1).
apply Rmult_le_compat.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_Sn.
unfold pow.
rewrite Rmult_1_r.
apply Rle_0_sqr.
rewrite <- Rinv_1.
apply Rle_Rinv_pos.
apply Rlt_0_1.
apply (le_INR 1).
apply le_n_S, le_0_n.
replace 1%R with (1 * (1 * 1))%R by ring.
apply pow_maj_Rabs with (1 := Hx).
apply INR_fact_neq_0.
now apply not_0_INR.
Qed.

Lemma Un_cv_subseq :
  forall (u : nat -> R) (f : nat -> nat) (l : R),
  (forall n, f n < f (S n)) ->
  Un_cv u l -> Un_cv (fun n => u (f n)) l.
Proof.
intros u f l Hf Cu eps He.
destruct (Cu eps He) as [N HN].
exists N.
intros n Hn.
apply HN.
apply le_trans with (1 := Hn).
clear -Hf.
induction n.
apply le_0_n.
specialize (Hf n).
lia.
Qed.

Definition sinc (x : R) := proj1_sig (exist_sin (Rsqr x)).

Lemma sin_sinc :
  forall x,
  sin x = (x * sinc x)%R.
Proof.
intros x.
unfold sin, sinc.
now case exist_sin.
Qed.

Lemma sinc_0 :
  sinc 0 = 1%R.
Proof.
unfold sinc.
case exist_sin.
simpl.
unfold sin_in.
intros y Hy.
apply uniqueness_sum with (1 := Hy).
intros eps He.
exists 1.
intros n Hn.
rewrite (tech2 _ 0) by easy.
simpl sum_f_R0 at 1.
rewrite sum_eq_R0.
unfold R_dist, sin_n.
simpl.
replace (1 / 1 * 1 + 0 - 1)%R with 0%R by field.
now rewrite Rabs_R0.
clear.
intros m _.
rewrite Rsqr_0, pow_i.
apply Rmult_0_r.
apply lt_0_Sn.
Qed.

Lemma Un_decreasing_sinc :
  forall x : R,
  (Rabs x <= 1)%R ->
  Un_decreasing (fun n : nat => (/ INR (fact (2 * n + 1)) * x ^ (2 * n)))%R.
Proof.
intros x Hx n.
replace (2 * S n) with (2 + 2 * n) by ring.
rewrite pow_add.
rewrite <- Rmult_assoc.
apply Rmult_le_compat_r.
rewrite pow_sqr.
apply pow_le.
apply Rle_0_sqr.
change (fact (2 + 2 * n + 1)) with ((2 + 2 * n + 1) * ((1 + 2 * n + 1) * fact (2 * n + 1))).
rewrite mult_assoc, mult_comm.
rewrite mult_INR.
rewrite <- (Rmult_1_r (/ INR (fact _))).
rewrite Rinv_mult_distr.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_fact.
rewrite <- (Rmult_1_r 1).
apply Rmult_le_compat.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_Sn.
unfold pow.
rewrite Rmult_1_r.
apply Rle_0_sqr.
rewrite <- Rinv_1.
apply Rle_Rinv_pos.
apply Rlt_0_1.
apply (le_INR 1).
apply le_n_S, le_0_n.
rewrite <- (pow1 2).
apply pow_maj_Rabs with (1 := Hx).
apply INR_fact_neq_0.
now apply not_0_INR.
Qed.

Lemma atan_plus_PI4 :
  forall x, (-1 < x)%R ->
  (atan ((x - 1) / (x + 1)) + PI / 4)%R = atan x.
Proof.
intros x Hx.
assert (H1: ((x - 1) / (x + 1) < 1)%R).
  apply Rmult_lt_reg_r with (x + 1)%R.
  lra.
  unfold Rdiv.
  rewrite Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r.
  lra.
  apply Rgt_not_eq.
  lra.
assert (H2: (- PI / 2 < atan ((x - 1) / (x + 1)) + PI / 4 < PI / 2)%R).
  split.
  rewrite <- (Rplus_0_r (- PI / 2)).
  apply Rplus_lt_compat.
  apply atan_bound.
  apply PI4_RGT_0.
  apply Rplus_lt_reg_r with (-(PI / 4))%R.
  rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r.
  replace (PI/2 + - (PI/4))%R with (PI/4)%R by field.
  rewrite <- atan_1.
  now apply atan_increasing.
apply tan_is_inj.
exact H2.
apply atan_bound.
rewrite atan_right_inv.
rewrite tan_plus.
rewrite atan_right_inv.
rewrite tan_PI4.
field.
split.
apply Rgt_not_eq.
lra.
apply Rgt_not_eq.
ring_simplify.
apply Rlt_0_2.
apply Rgt_not_eq, cos_gt_0.
unfold Rdiv.
rewrite <- Ropp_mult_distr_l_reverse.
apply atan_bound.
apply atan_bound.
rewrite cos_PI4.
apply Rgt_not_eq.
unfold Rdiv.
rewrite Rmult_1_l.
apply Rinv_0_lt_compat.
apply sqrt_lt_R0.
apply Rlt_0_2.
apply Rgt_not_eq, cos_gt_0.
unfold Rdiv.
now rewrite <- Ropp_mult_distr_l_reverse.
apply H2.
rewrite tan_PI4, Rmult_1_r.
rewrite atan_right_inv.
apply Rgt_not_eq.
now apply Rgt_minus.
Qed.

Lemma atan_inv :
  forall x, (0 < x)%R ->
  atan (/ x) = (PI / 2 - atan x)%R.
Proof.
intros x Hx.
apply tan_is_inj.
apply atan_bound.
split.
apply Rlt_trans with R0.
unfold Rdiv.
rewrite Ropp_mult_distr_l_reverse.
apply Ropp_lt_gt_0_contravar.
apply PI2_RGT_0.
apply Rgt_minus.
apply atan_bound.
apply Rplus_lt_reg_r with (atan x - PI / 2)%R.
ring_simplify.
rewrite <- atan_0.
now apply atan_increasing.
rewrite atan_right_inv.
unfold tan.
rewrite sin_shift.
rewrite cos_shift.
rewrite <- Rinv_Rdiv.
apply f_equal, sym_eq, atan_right_inv.
apply Rgt_not_eq, sin_gt_0.
rewrite <- atan_0.
now apply atan_increasing.
apply Rlt_trans with (2 := PI2_Rlt_PI).
apply atan_bound.
apply Rgt_not_eq, cos_gt_0.
unfold Rdiv.
rewrite <- Ropp_mult_distr_l_reverse.
apply atan_bound.
apply atan_bound.
Qed.

Lemma Un_decreasing_atanc :
  forall x : R,
  (Rabs x <= 1)%R ->
  Un_decreasing (fun n : nat => (/ INR (2 * n + 1) * x ^ (2 * n)))%R.
Proof.
intros x Hx n.
replace (2 * S n) with (2 + 2 * n) by ring.
rewrite pow_add.
rewrite <- Rmult_assoc.
apply Rmult_le_compat_r.
rewrite pow_sqr.
apply pow_le.
apply Rle_0_sqr.
rewrite <- (Rmult_1_r (/ INR (2 * n + 1))).
apply Rmult_le_compat.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_Sn.
unfold pow.
rewrite Rmult_1_r.
apply Rle_0_sqr.
apply Rlt_le.
apply Rinv_lt.
apply (lt_INR 0).
rewrite plus_comm.
apply lt_O_Sn.
apply lt_INR.
rewrite <- plus_assoc.
apply (plus_lt_compat_r 0).
apply lt_O_Sn.
rewrite <- (pow1 2).
apply pow_maj_Rabs with (1 := Hx).
Qed.

Lemma Un_cv_atanc :
  forall x : R,
  (Rabs x <= 1)%R ->
  Un_cv (fun n : nat => (/ INR (2 * n + 1) * x ^ (2 * n)))%R 0.
Proof.
intros x Hx eps Heps.
unfold R_dist.
destruct (archimed_cor1 eps Heps) as [N [HN1 HN2]].
exists N.
intros n Hn.
assert (H: (0 < / INR (2 * n + 1))%R).
  apply Rinv_0_lt_compat.
  apply (lt_INR 0).
  rewrite plus_comm.
  apply lt_O_Sn.
rewrite Rminus_0_r, Rabs_pos_eq.
apply Rle_lt_trans with (/ INR (2 * n + 1) * 1)%R.
apply Rmult_le_compat_l.
now apply Rlt_le.
rewrite <- (pow1 (2 * n)).
apply pow_maj_Rabs with (1 := Hx).
rewrite Rmult_1_r.
apply Rlt_trans with (2 := HN1).
apply Rinv_lt.
now apply (lt_INR 0).
apply lt_INR.
apply le_lt_trans with (1 := Hn).
clear ; omega.
apply Rmult_le_pos.
now apply Rlt_le.
rewrite pow_Rsqr.
apply pow_le.
apply Rle_0_sqr.
Qed.

Lemma atanc_exists :
  forall x,
  (Rabs x <= 1)%R ->
  { l : R | Un_cv (sum_f_R0 (tg_alt (fun n => / INR (2 * n + 1) * x ^ (2 * n))%R)) l }.
Proof.
intros x Hx.
apply alternated_series.
now apply Un_decreasing_atanc.
now apply Un_cv_atanc.
Qed.

Definition atanc x :=
  match Ratan.in_int x with
  | left H => proj1_sig (atanc_exists x (Rabs_le _ _ H))
  | right _ => (atan x / x)%R
  end.

Lemma atanc_opp :
  forall x,
  atanc (- x) = atanc x.
Proof.
intros x.
unfold atanc.
destruct (Ratan.in_int x) as [Hx|Hx] ;
  case Ratan.in_int ; intros Hx'.
do 2 case atanc_exists ; simpl projT1.
intros l1 C1 l2 C2.
apply UL_sequence with (1 := C2).
apply Un_cv_ext with (2 := C1).
intros N.
apply sum_eq.
intros n _.
unfold tg_alt.
replace (-x)%R with ((-1) * x)%R by ring.
now rewrite Rpow_mult_distr, pow_1_even, Rmult_1_l.
elim Hx'.
split.
now apply Ropp_le_contravar.
rewrite <- (Ropp_involutive 1).
now apply Ropp_le_contravar.
elim Hx.
split.
rewrite <- (Ropp_involutive x).
now apply Ropp_le_contravar.
now apply Ropp_le_cancel.
rewrite atan_opp.
field.
contradict Hx.
rewrite Hx.
split.
rewrite <- Ropp_0.
apply Ropp_le_contravar.
apply Rle_0_1.
apply Rle_0_1.
Qed.

Lemma atan_atanc :
  forall x,
  atan x = (x * atanc x)%R.
Proof.
assert (H1: forall x, (0 < x < 1 -> atan x = x * atanc x)%R).
  intros x Hx.
  rewrite atan_eq_ps_atan with (1 := Hx).
  unfold ps_atan, atanc.
  case Ratan.in_int ; intros H.
  destruct ps_atan_exists_1 as [l1 C1].
  destruct atanc_exists as [l2 C2].
  simpl.
  clear H.
  apply UL_sequence with (1 := C1).
  apply Un_cv_ext with (fun N => x * sum_f_R0 (tg_alt (fun n => (/ INR (2 * n + 1) * x ^ (2 * n)))) N)%R.
  intros N.
  rewrite scal_sum.
  apply sum_eq.
  intros n Hn.
  unfold tg_alt, Ratan_seq.
  rewrite pow_add.
  unfold Rdiv.
  ring.
  apply CV_mult with (2 := C2).
  intros eps Heps.
  exists 0.
  intros n _.
  now rewrite R_dist_eq.
  elim H.
  split.
  apply Rle_trans with 0%R.
  rewrite <- Ropp_0.
  apply Ropp_le_contravar.
  apply Rle_0_1.
  now apply Rlt_le.
  now apply Rlt_le.
assert (H2: atan 1 = Rmult 1 (atanc 1)).
  rewrite Rmult_1_l.
  rewrite atan_1.
  rewrite <- Alt_PI_eq.
  unfold Alt_PI.
  destruct exist_PI as [pi C1].
  replace (4 * pi / 4)%R with pi by field.
  unfold atanc.
  case Ratan.in_int ; intros H'.
  destruct atanc_exists as [l C2].
  simpl.
  apply UL_sequence with (1 := C1).
  apply Un_cv_ext with (2 := C2).
  intros N.
  apply sum_eq.
  intros n _.
  unfold tg_alt, PI_tg.
  now rewrite pow1, Rmult_1_r.
  elim H'.
  split.
  apply Rle_trans with (2 := Rle_0_1).
  rewrite <- Ropp_0.
  apply Ropp_le_contravar.
  apply Rle_0_1.
  apply Rle_refl.
assert (H3: forall x, (0 < x -> atan x = x * atanc x)%R).
  intros x Hx.
  destruct (Req_dec x 1) as [J1|J1].
  now rewrite J1.
  generalize (H1 x).
  unfold atanc.
  case Ratan.in_int ; intros H.
  destruct (proj2 H) as [J2|J2].
  case atanc_exists ; simpl ; intros l _.
  intros K.
  apply K.
  now split.
  now elim J1.
  intros _.
  field.
  now apply Rgt_not_eq.
intros x.
destruct (total_order_T 0 x) as [[J|J]|J].
now apply H3.
rewrite <- J.
now rewrite atan_0, Rmult_0_l.
rewrite <- (Ropp_involutive x).
rewrite atan_opp, atanc_opp.
rewrite H3.
apply sym_eq, Ropp_mult_distr_l_reverse.
rewrite <- Ropp_0.
now apply Ropp_lt_contravar.
Qed.

Lemma Un_decreasing_ln1pc :
  forall x : R,
  (0 <= x <= 1)%R ->
  Un_decreasing (fun n : nat => (/ INR (n + 1) * x ^ n))%R.
Proof.
intros x Hx n.
change (S n) with (1 + n) at 2.
rewrite pow_add.
simpl (pow x 1).
rewrite Rmult_1_r, <- Rmult_assoc.
apply Rmult_le_compat_r.
now apply pow_le.
rewrite <- (Rmult_1_r (/ INR (n + 1))).
apply Rmult_le_compat ; try easy.
apply Rlt_le.
apply Rinv_0_lt_compat.
apply (lt_INR 0).
apply lt_O_Sn.
apply Rlt_le.
apply Rinv_lt.
apply (lt_INR 0).
rewrite plus_comm.
apply lt_O_Sn.
apply lt_INR.
apply lt_n_Sn.
Qed.

Lemma Un_cv_ln1pc :
  forall x : R,
  (Rabs x <= 1)%R ->
  Un_cv (fun n : nat => (/ INR (n + 1) * x ^ n))%R 0.
Proof.
intros x Hx eps Heps.
unfold R_dist.
destruct (archimed_cor1 eps Heps) as [N [HN1 HN2]].
exists N.
intros n Hn.
assert (H: (0 < / INR (n + 1))%R).
  apply Rinv_0_lt_compat.
  apply (lt_INR 0).
  rewrite plus_comm.
  apply lt_O_Sn.
rewrite Rminus_0_r.
rewrite Rabs_mult, Rabs_pos_eq.
apply Rle_lt_trans with (/ INR (n + 1) * 1)%R.
apply Rmult_le_compat_l.
now apply Rlt_le.
rewrite <- (pow1 n).
rewrite <- RPow_abs.
apply pow_maj_Rabs.
now rewrite Rabs_Rabsolu.
rewrite Rmult_1_r.
apply Rlt_trans with (2 := HN1).
apply Rinv_lt.
now apply (lt_INR 0).
apply lt_INR.
apply le_lt_trans with (1 := Hn).
rewrite plus_comm.
apply lt_n_Sn.
now apply Rlt_le.
Qed.

Lemma ln1pc_exists :
  forall x,
  (0 <= x < 1)%R ->
  { l : R | Un_cv (sum_f_R0 (tg_alt (fun n => / INR (n + 1) * x ^ n)%R)) l }.
Proof.
intros x Hx.
apply alternated_series.
apply Un_decreasing_ln1pc.
apply (conj (proj1 Hx)).
now apply Rlt_le.
apply Un_cv_ln1pc.
rewrite Rabs_pos_eq by easy.
now apply Rlt_le.
Qed.

Lemma ln1pc_in_int :
  forall x,
  { (0 <= x < 1)%R } + { ~(0 <= x < 1)%R }.
Proof.
intros x.
destruct (Rle_dec 0 x) as [H1|H1].
destruct (Rlt_dec x 1) as [H2|H2].
left.
now split.
right.
now contradict H2.
right.
now contradict H1.
Qed.

Definition ln1pc x :=
  match ln1pc_in_int x with
  | left H => proj1_sig (ln1pc_exists x H)
  | right _ => (ln (1 + x) / x)%R
  end.

Require Import Coquelicot.Coquelicot.

Lemma ln1p_ln1pc :
  forall x,
  ln (1 + x) = (x * ln1pc x)%R.
Proof.
intros x.
unfold ln1pc.
destruct ln1pc_in_int as [Hx|Hx].
2: field ; contradict Hx ; rewrite Hx ; split ;
  [ apply Rle_refl | apply Rlt_0_1 ].
destruct ln1pc_exists as [y Hy].
simpl.
replace y with (PSeries (fun n => (-1)^n / INR (n + 1)) x).
rewrite <- PSeries_incr_1.
replace (ln (1 + x)) with (RInt (fun t => / (1 + t)) 0 x).
rewrite <- (PSeries_ext (PS_Int (fun n => (-1)^n))).
assert (Hc: Rbar_lt (Rabs x) (CV_radius (fun n : nat => (-1) ^ n))).
  rewrite (CV_radius_finite_DAlembert _ 1).
  now rewrite Rinv_1, Rabs_pos_eq.
  intros n.
  apply pow_nonzero.
  now apply IZR_neq.
  exact Rlt_0_1.
  apply is_lim_seq_ext with (fun _ => 1%R).
    intros n.
    change ((-1)^(S n) / (-1)^n)%R with (-(1) * (-1)^n */ (-1)^n)%R.
    rewrite Rmult_assoc, Rinv_r, Rmult_1_r, Rabs_Ropp.
    apply eq_sym, Rabs_R1.
    apply pow_nonzero.
    now apply IZR_neq.
  apply is_lim_seq_const.
rewrite <- RInt_PSeries with (1 := Hc).
apply RInt_ext.
intros t.
rewrite Rmin_left, Rmax_right by easy.
intros Ht.
rewrite <- (Ropp_involutive t) at 1.
unfold PSeries.
rewrite <- (Series_ext (fun k => (-t)^k)).
apply eq_sym, Series_geom.
rewrite Rabs_Ropp, Rabs_pos_eq.
now apply Rlt_trans with x.
now apply Rlt_le.
intros n.
replace (-t)%R with (-1 * t)%R by ring.
apply Rpow_mult_distr.
intros [|n].
easy.
unfold PS_incr_1.
now rewrite Plus.plus_comm.
apply is_RInt_unique.
assert (H: forall t, -1 < t -> is_derive (fun t : R => ln (1 + t)) t (/ (1 + t))).
  intros t Ht.
  auto_derive.
  rewrite <- (Rplus_opp_r 1).
  now apply Rplus_lt_compat_l.
  apply Rmult_1_l.
apply (is_RInt_ext (Derive (fun t => ln (1 + t)))).
  intros t.
  rewrite Rmin_left by easy.
  intros [Ht _].
  apply is_derive_unique.
  apply H.
  apply Rlt_trans with (2 := Ht).
  now apply IZR_lt.
replace (ln (1 + x)) with (ln (1 + x) - ln (1 + 0))%R.
apply (is_RInt_derive (fun t => ln (1 + t))).
  intros t.
  rewrite Rmin_left by easy.
  intros [Ht _].
  apply Derive_correct.
  eexists.
  apply H.
  apply Rlt_le_trans with (2 := Ht).
  now apply IZR_lt.
intros t.
rewrite Rmin_left by easy.
intros [Ht _].
apply continuous_ext_loc with (fun t : R => /(1 + t)).
apply locally_interval with (-1)%R p_infty.
apply Rlt_le_trans with (2 := Ht).
now apply IZR_lt.
easy.
clear t Ht.
intros t Ht _.
apply sym_eq, is_derive_unique.
now apply H.
apply continuous_comp.
apply (continuous_plus (fun t : R => 1)).
apply filterlim_const.
apply filterlim_id.
apply (filterlim_Rbar_inv (1 + t)).
apply Rbar_finite_neq.
apply Rgt_not_eq.
rewrite <- (Rplus_0_l 0).
apply Rplus_lt_le_compat with (1 := Rlt_0_1) (2 := Ht).
rewrite Rplus_0_r, ln_1.
apply Rminus_0_r.
apply is_pseries_unique.
apply is_lim_seq_Reals.
apply Un_cv_ext with (2 := Hy).
intros n.
rewrite <- sum_n_Reals.
apply sum_n_ext.
intros m.
rewrite pow_n_pow.
unfold tg_alt.
rewrite <- Rmult_assoc.
apply Rmult_comm.
Qed.

(** Define a shorter name *)
Notation Rmult_neq0 := Rmult_integral_contrapositive_currified.

Lemma Rdiv_eq_reg a b c d :
  (a * d = b * c -> b <> 0%R -> d <> 0%R -> a / b = c / d)%R.
Proof.
intros Heq Hb Hd.
apply (Rmult_eq_reg_r (b * d)).
field_simplify; trivial.
try now rewrite Heq.
now apply Rmult_neq0.
Qed.

Lemma Rlt_neq_sym (x y : R) :
  (x < y -> y <> x)%R.
Proof. now intros Hxy Keq; rewrite Keq in Hxy; apply (Rlt_irrefl _ Hxy). Qed.

Lemma Rdiv_pos_compat (x y : R) :
  (0 <= x -> 0 < y -> 0 <= x / y)%R.
Proof.
intros Hx Hy.
unfold Rdiv; rewrite <- (@Rmult_0_l (/ y)).
apply Rmult_le_compat_r; trivial.
now left; apply Rinv_0_lt_compat.
Qed.

Lemma Rdiv_pos_compat_rev (x y : R) :
  (0 <= x / y -> 0 < y -> 0 <= x)%R.
Proof.
intros Hx Hy.
unfold Rdiv; rewrite <-(@Rmult_0_l y), <-(@Rmult_1_r x).
rewrite <-(Rinv_r y); [|now apply Rlt_neq_sym].
rewrite (Rmult_comm y), <-Rmult_assoc.
now apply Rmult_le_compat_r; trivial; left.
Qed.

Lemma Rdiv_neg_compat (x y : R) :
  (x <= 0 -> 0 < y -> x / y <= 0)%R.
Proof.
intros Hx Hy.
unfold Rdiv; rewrite <-(@Rmult_0_l (/ y)).
apply Rmult_le_compat_r; trivial.
now left; apply Rinv_0_lt_compat.
Qed.

Lemma Rdiv_neg_compat_rev (x y : R) :
  (x / y <= 0 -> 0 < y -> x <= 0)%R.
Proof.
intros Hx Hy.
rewrite <-(@Rmult_0_l y), <-(@Rmult_1_r x).
rewrite <-(Rinv_r y); [|now apply Rlt_neq_sym].
rewrite (Rmult_comm y), <-Rmult_assoc.
apply Rmult_le_compat_r; trivial.
now left.
Qed.

(** The following definition can be used by doing [rewrite !Rsimpl] *)
Definition Rsimpl :=
  (Rplus_0_l, Rplus_0_r, Rmult_1_l, Rmult_1_r, Rmult_0_l, Rmult_0_r, Rdiv_1).

Section Integral.

Variables (f : R -> R) (ra rb : R).
Hypothesis Hab : ra < rb.
Hypothesis Hint : ex_RInt f ra rb.

Lemma RInt_le_r (u : R) :
 (forall x : R, ra <= x <= rb -> f x <= u) -> RInt f ra rb / (rb - ra) <= u.
Proof.
intros Hf.
apply Rle_div_l.
now apply Rgt_minus.
rewrite Rmult_comm, <- (RInt_const (V := R_CompleteNormedModule)).
apply RInt_le with (2 := Hint).
now apply Rlt_le.
apply ex_RInt_const.
intros x [Hx1 Hx2].
apply Hf.
split; now apply Rlt_le.
Qed.

Lemma RInt_le_l (l : R) :
  (forall x : R, ra <= x <= rb -> l <= f x) -> l <= RInt f ra rb / (rb - ra).
Proof.
intros Hf.
apply Rle_div_r.
now apply Rgt_minus.
rewrite Rmult_comm, <- (RInt_const (V := R_CompleteNormedModule)).
apply RInt_le with (3 := Hint).
now apply Rlt_le.
apply ex_RInt_const.
intros x [Hx1 Hx2].
apply Hf.
split; now apply Rlt_le.
Qed.

End Integral.


Require Import Utf8.

(*
   Documentations:
       * #CoqIDE#
       * #Petit guide de survie en Coq#
       * #Cheat sheet#
       * #Coq Survey (Guide coq de Christine Paulin-Mohring)#

   Charger le fichier #LIFLC-TP3.v#, qui est
   à compléter dans ce TP, dans CoqIDE.

 *)

(* Quelques erreurs de raisonnement fréquentes

   On peut montrer que ces raisonnements sont faux en Coq.
 *)

(* ex falso sequitur quodlibet *)
Lemma ex_falso : forall P, False -> P.
Proof.
Admitted.

(* erreur très fréquente *)
Definition dyslexic_imp := ∀ P Q:Prop, (P → Q) → (Q → P).
(* Pour cette preuve il faut appliquer une hypothèse contenant des
   quantificateurs forall. Si H est le nom de l'hypothèse,

   apply (H toto)

   permet d'appliquer H en remplaçant la variable quantifiée par toto.
   Si plusieurs variables sont quantifiées, on peut écrire

   apply (H toto titi)
*)
Goal dyslexic_imp -> False.
Proof.
Admitted.

(* erreur très fréquente, bis *)
Definition dyslexic_contrap := ∀ P Q:Prop, (P → Q) → (~P → ~Q).
Goal dyslexic_contrap -> False.
Proof.
Admitted.

(*
   Quelques équivalences remarquables en logique du premier ordre
 *)

(* on ouvre une section pour alléger les assertions *)
Section Basic_FOL.

Variable U : Type.                  (*le type du domaine *)
Variable P Q : U -> Prop.           (*des prédicats unaires *)
Variable R S : U -> U -> Prop.      (*des prédicats binaires, ie des relations *)

Lemma neg_exists_equiv_forall_neg : (~ ∃ x , P x ) <-> ∀ x , ~ P x .
Proof.
Admitted.

Lemma exists_is_or : (∃ x , P x ∨ Q x) <-> (∃ x,  P x) ∨ (∃ x, Q x).
Proof.
Admitted.

Lemma forall_is_and : (∀ x , P x /\ Q x) <-> (∀ x,  P x) /\ (∀ x, Q x).
Proof.
Admitted.

Lemma forall_implies_neg_exists_neg  : (∀ x, P x)→ ~(∃ y, ~ P y).
Proof.
Admitted.

Goal (∃ x, (∀ F:U → Prop, F x)) → 2 = 3.
Proof.
Admitted.

Goal (∀ x y, (P(x) ∧ (P(y) -> Q(x)))) -> ∀x, Q(x).
Proof.
Admitted.

(* si qq'un est aimé de tous, alors tout le monde aime qq'un *)
Goal (∃ y, ∀ x, R x y) -> (∀ x, ∃ y, R x y).
Proof.
Admitted.

Goal (∃ y, ∀ x, R x y) -> (∃ x, R x x).
Proof.
Admitted.

End Basic_FOL.

Section Ensembles.
(* On va maintenant prouver quelques propriétés des ensembles dont les
   élements sont d'un certain type U.
 *)
Variable U : Type.

(* Un ensemble E peut être représenté par un prédicat unaire qui est
   vrai lorsque son argument est un élément de E. On utilise cela pour
   cela Prop (le type des proposition de Coq). Les ensembles sont donc
   vus comme de type U -> Prop. Une manière de le comprendre est voir
   un ensemble comme une fonction qui prend un élement et donne une
   formule qui sera vraie si cet élement est dans l'ensemble. *)
Definition Ensemble := U -> Prop.

(* On peut alors redéfinir l'appartenance (In) de x à E comme le fait
   que le prédicat qui représente E est vrai.  *)
Definition In (A:Ensemble) (x:U) : Prop := A x.
Notation "x ∈ E" := (In E x)  (at level 45, right associativity).

(* Les définitions suivantes se construisent naturellement à partir de
   celle de appartient (In). *)
Definition Included (A B:Ensemble) : Prop := forall x, x ∈ A -> x ∈ B.
Notation "A ⊆ B" := (Included A B)  (at level 70, right associativity).

Definition Cup (A B:Ensemble) : U -> Prop := fun x => x ∈ A \/ x ∈ B.
Notation "A ∪ B" := (Cup A B)  (at level 70, right associativity).

Definition Cap (A B:Ensemble) : U -> Prop := fun x => x ∈ A /\ x ∈ B.
Notation "A ∩ B" := (Cap A B)  (at level 70, right associativity).

Definition Empty : U -> Prop := fun x => False .
Notation "∅" := (Empty).

Definition Setminus (B C:Ensemble) : Ensemble := fun x:U => x ∈ B /\ ~ x ∈ C.
Notation "A \ B" := (Setminus A B)  (at level 80, right associativity).

(* Cet axiome permet de déduire une égalité à partir de la double
   inclusion. *)
Axiom Extensionality_Ensembles : forall A B:Ensemble,  (A ⊆ B /\ B ⊆ A) -> A = B.

Variable A B C: Ensemble.

(* Exemple pour comprendre comment utiliser les définitons ci-dessus *)
(* Réflexivité de ⊆ *)
Goal A ⊆ A.
Proof.
  unfold Included.
  intros x.
  auto.
Qed.

(* Transitivité de ⊆.

   Remarque: Avec la réflexivité et l'axiome Extensionality_Ensembles,
   on a que ⊆ est un ensemble.

 *)
Goal A ⊆ B -> B ⊆ C  -> A ⊆ C.
Proof.
Admitted.

Goal ∅ ⊆ A.
Proof.
Admitted.

Goal A ⊆ B <-> (A ∩ B) = A.
Proof.
Admitted.

(* exo de td lif LF *)
Goal  (A \ (B ∪ C)) = ((A \ B) ∩ (A \ C)).
Proof.
Admitted.

Goal A ⊆ B -> (A \ B) = ∅.
(* la réciproque est DIFFICILE *)
Proof.
Admitted.

End Ensembles.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

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


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Sgn.
Require Import Crypto.Util.ZUtil.Modulo.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Local Open Scope Z_scope.

Module Z.
  Lemma quot_div_full a b : Z.quot a b = Z.sgn a * Z.sgn b * (Z.abs a / Z.abs b).
  Proof.
    destruct (Z_zerop b); [ subst | apply Z.quot_div; assumption ].
    destruct a; simpl; reflexivity.
  Qed.

  Local Arguments Z.mul !_ !_.

  Lemma quot_sgn_nonneg a b : 0 <= Z.sgn (Z.quot a b) * Z.sgn a * Z.sgn b.
  Proof.
    rewrite quot_div_full, !Z.sgn_mul, !Z.sgn_sgn.
    set (d := Z.abs a / Z.abs b).
    destruct a, b; simpl; try (subst d; simpl; lia);
      try rewrite (Z.mul_opp_l 1);
      do 2 try rewrite (Z.mul_opp_r _ 1);
      rewrite ?Z.mul_1_l, ?Z.mul_1_r, ?Z.opp_involutive;
      apply Z.div_abs_sgn_nonneg.
  Qed.

  Lemma quot_nonneg_same_sgn a b : Z.sgn a = Z.sgn b -> 0 <= Z.quot a b.
  Proof.
    intro H.
    generalize (quot_sgn_nonneg a b); rewrite H.
    rewrite <- Z.mul_assoc, <- Z.sgn_mul.
    destruct (Z_zerop b); [ subst; destruct a; unfold Z.quot; simpl in *; congruence | ].
    rewrite (Z.sgn_pos (_ * _)) by nia.
    intro; apply Z.sgn_nonneg; lia.
  Qed.

  Lemma mul_quot_eq_full a m : m <> 0 -> m * (Z.quot a m) = a - a mod (Z.abs m * Z.sgn a).
  Proof.
    intro Hm.
    assert (0 <> m * m) by (intro; apply Hm; nia).
    assert (0 < m * m) by nia.
    assert (0 <> Z.abs m) by (destruct m; simpl in *; try congruence).
    rewrite quot_div_full.
    rewrite <- (Z.abs_sgn m) at 1.
    transitivity ((Z.sgn m * Z.sgn m) * Z.sgn a * (Z.abs m * (Z.abs a / Z.abs m))); [ nia | ].
    rewrite <- Z.sgn_mul, Z.sgn_pos, Z.mul_1_l, Z.mul_div_eq_full by lia.
    rewrite Z.mul_sub_distr_l.
    rewrite Z.mul_comm, Z.abs_sgn.
    destruct a; simpl Z.sgn; simpl Z.abs; autorewrite with zsimplify_const; [ reflexivity | reflexivity | ].
    repeat match goal with |- context[-1 * ?x] => replace (-1 * x) with (-x) by lia end.
    repeat match goal with |- context[?x * -1] => replace (x * -1) with (-x) by lia end.
    rewrite <- Zmod_opp_opp; simpl Z.opp.
    reflexivity.
  Qed.

  Lemma quot_sub_sgn a : Z.quot (a - Z.sgn a) a = 0.
  Proof.
    rewrite quot_div_full.
    destruct (Z_zerop a); subst; [ lia | ].
    rewrite Z.div_small; lia.
  Qed.

  Lemma quot_small_abs a b : 0 <= Z.abs a < Z.abs b -> Z.quot a b = 0.
  Proof.
    intros; rewrite Z.quot_small_iff by lia; lia.
  Qed.

  Lemma quot_add_sub_sgn_small a b : b <> 0 -> Z.sgn a = Z.sgn b -> Z.quot (a + b - Z.sgn b) b = Z.quot (a - Z.sgn b) b + 1.
  Proof.
    destruct (Z_zerop a), (Z_zerop b), (Z_lt_le_dec a 0), (Z_lt_le_dec b 0), (Z_lt_le_dec 1 (Z.abs a));
      subst;
      try lia;
      rewrite !Z.quot_div_full;
      try rewrite (Z.sgn_neg a) by lia;
      try rewrite (Z.sgn_neg b) by lia;
      repeat first [ reflexivity
                   | rewrite Z.sgn_neg by lia
                   | rewrite Z.sgn_pos by lia
                   | rewrite Z.abs_eq by lia
                   | rewrite Z.abs_neq by lia
                   | rewrite !Z.mul_opp_l
                   | rewrite Z.abs_opp in *
                   | rewrite Z.abs_eq in * by lia
                   | match goal with
                     | [ |- context[-1 * ?x] ]
                       => replace (-1 * x) with (-x) by lia
                     | [ |- context[?x * -1] ]
                       => replace (x * -1) with (-x) by lia
                     | [ |- context[-?x - ?y] ]
                       => replace (-x - y) with (-(x + y)) by lia
                     | [ |- context[-?x + - ?y] ]
                       => replace (-x + - y) with (-(x + y)) by lia
                     | [ |- context[(?a + ?b + ?c) / ?b] ]
                       => replace (a + b + c) with (((a + c) + b * 1)) by lia; rewrite Z.div_add' by lia
                     | [ |- context[(?a + ?b - ?c) / ?b] ]
                       => replace (a + b - c) with (((a - c) + b * 1)) by lia; rewrite Z.div_add' by lia
                     end
                   | progress intros
                   | progress Z.replace_all_neg_with_pos
                   | progress autorewrite with zsimplify ].
  Qed.
End Z.


Require Export Grothendieck.ToCat CategoryOfSections.
Require Import Common.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope functor_scope.

Section dependent_product.
  Context `{Funext}.
  Variable C : PreCategory.
  Variable P : PreCategory -> Type.
  Context `{forall C, IsHProp (P C)}.
  Context `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}.

  Local Notation Cat := (SubPreCat P).

  Variable F : Functor C Cat.

  (** Quoting http://mathoverflow.net/questions/137689/explicit-description-of-the-oplax-limit-of-a-functor-to-cat:

      The oplax limit is the category of sections for the functor from
      the Grothendieck construction to the base category.

      The strong limit is the category of cartesian sections
      (every arrow in the base category gets mapped to a cartesian
      one).

      Notice how this goes along very well with the interpretation as
      dependent product and as $∀$: The set theoretic product is just
      the set of sections into the disjoint union.

      Given a strong functor [F : X → Cat] we denote the Grothendieck
      construction by [Gr F].

      There is a canonical functor [π : Gr F → X]. Sections of this
      functor are functors [s : X → Gr F] such that [s ∘ π = id]. *)

  Definition DependentProduct : PreCategory
    := CategoryOfSections (GrothendieckCatFunctorOfFunctor F).
End dependent_product.

Notation Pi := DependentProduct.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__congruencesymmetric.
Require Export lemma__lessthancongruence.
Require Export logic.
Definition proposition__03 : forall A B C D E F, (euclidean__defs.Lt C D A B) -> ((euclidean__axioms.Cong E F A B) -> (exists X, (euclidean__axioms.BetS E X F) /\ (euclidean__axioms.Cong E X C D))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro H.
intro H0.
assert (* Cut *) (euclidean__axioms.Cong A B E F) as H1.
- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric A E F B H0).
- assert (* Cut *) (euclidean__defs.Lt C D E F) as H2.
-- apply (@lemma__lessthancongruence.lemma__lessthancongruence C D A B E F H H1).
-- assert (exists G, (euclidean__axioms.BetS E G F) /\ (euclidean__axioms.Cong E G C D)) as H3 by exact H2.
destruct H3 as [G H4].
destruct H4 as [H5 H6].
exact H2.
Qed.


Require Import Omega.

Inductive added: nat -> nat -> nat -> Prop :=
  | add_z: added 0 0 0
  | add_l: forall m n r, added m n r -> added (S m) n (S r)
  | add_r: forall m n r, added m n r -> added m (S n) (S r).

Hint Constructors added.

Lemma added_plus:
  forall m n r, added m n r -> m + n = r.
Proof.

Qed.

Lemma plus_added:
  forall m n r, m + n = r -> added m n r.
Proof.

Qed.


Axiom A1: forall p q : Prop, p->(q->p).
Axiom A2: forall p q r: Prop, p -> (q->r)->(p->q)->(p->r).
Axiom A3: forall p q: Prop, (~p->~q)->(q->p).

Require Import Coq.Logic.Classical_Prop.

Lemma HS1 : forall p q r : Prop, (q -> r) -> ((p -> q) -> (p -> r)).
Proof.
intros P Q R QimplicaR PimplicaQ HP. Show Proof.
apply QimplicaR, PimplicaQ, HP. Show Proof.
(*Since PimplicaQ : P->Q  and HP : P, then PimplicaQ HP:Q
and since QimplicaR : Q->R and (PimplicaQ HP): Q, then
QimplicaR (PimplicaQ HP): R
*)
Qed.

Lemma HS2 : forall p q r : Prop, (p -> q) -> ((q -> r) -> (p -> r)).
Proof.
intros P Q R PimplicaQ QimplicaR HP. Show Proof.
apply QimplicaR, PimplicaQ, HP. Show Proof.
Qed.

Lemma DN1 : forall p : Prop, ~~p -> p.
Proof.
intros P HDNP.
destruct (classic P) as [HP | HNP].
exact HP.
tauto.

Qed.

Lemma DN2 : forall q : Prop, q -> ~~q.
Proof.
intros Q HDNQ.
tauto. Show Proof.
Qed.

Lemma I8 : forall p q : Prop, (p -> q) -> (~q -> ~p).
Proof.
intros P Q PimplicaQ HNQ.
apply A3 with (q:=~Q).
- tauto.
- exact HNQ.
Show Proof.
Qed.

Lemma CEFMT : forall p r : Prop, r -> (p -> r).
Proof.
(*A1=p->(q->p)
R -> (P -> R)
Q := P*
*)
intros P R HR HP.
apply A1 with (q := P).
apply HR. apply HP. Show Proof.
(*
A1 R P HR HP
A1 R P = R ->(P->R)
A1 R P HR  (P->R)
*)
Qed.

Lemma counterexamplemodustollens : forall p q r : Prop, ~(p -> r) -> ~(r).
Proof.
intros P Q R NPimplicaR.
tauto.
Qed.

Theorem counterexamplea: forall p q r:Prop, ~(~(p -> q) -> ~(r)) -> ~ (~(p -> q) -> (~(p -> q) ->	~(p -> r))).
Proof.
intros P Q R NNPimplicaQimplicaNR. Show Proof.
tauto.
Qed.

Lemma I1 : forall p q : Prop, p -> ((p -> q) -> q).
Proof.
intros P Q HP PimplicaQ.
apply PimplicaQ ,HP.
(*apply H0,H. Show Proof.
apply H0.
exact H.*)
Qed.

Lemma I4 : forall p q r : Prop, (p -> (q -> r)) -> (q -> (p -> r)).
Proof.
intros P Q R PimplicaQimplicaR HQ HP.
apply PimplicaQimplicaR in HP  as HR.
- exact HR.
- exact HQ. Show Proof.
Qed.

Lemma I5 : forall p q r : Prop, (p -> q) -> ((q -> r) -> (p -> r)).
Proof.
intros P Q R PimplicaQ QimplicaR HP.
apply QimplicaR, PimplicaQ, HP. Show Proof.
Qed.

Lemma I6: forall p q : Prop, (~p -> q) -> (~q -> p).
Proof.
intros P Q NPimplicaQ.
tauto.
Qed.

Lemma I7 : forall p : Prop, (~p -> p) -> p.
Proof.
intros P NPimplicaP.
tauto.
Qed.


Section simple_proofs.
 Variables P Q R S : Prop.

 Lemma id_P : P -> P.
 Proof.
  intro; assumption.
 Qed.

 Lemma id_PP : (P -> P) -> P -> P.
 Proof.
  intro; assumption.
 Qed.

 Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
 Proof.
  intros H H0 p.
  apply H0; apply H; assumption.
 Qed.

 Lemma imp_perm : (P -> Q -> R) -> Q -> P -> R.
 Proof.
  intros H q p; apply H; assumption.
 Qed.

 Lemma ignore_Q : (P -> R) -> P -> Q -> R.
 Proof.
  intros H p q; apply H; assumption.
 Qed.

 Lemma delta_imp : (P -> P -> Q) -> P -> Q.
 Proof.
  intros H p; apply H; assumption.
 Qed.

 Lemma delta_impR : (P -> Q) -> P -> P -> Q.
 Proof.
  intros H p p'; apply H; assumption.
 Qed.

 Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
 Proof.
  intros H H0 H1 p.
  apply H1; [ apply H | apply H0 ]; assumption.
 Qed.

 Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
 Proof.
  intro H; apply H.
  intro H0; apply H0.
  intro p; apply H; intro; assumption.
 Qed.
End simple_proofs.


(**
リストのリフレクション補題
======
2019/07/25

この文書のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_list_1.v

 *)

(**
# 説明

MathComp の seq は、seq.v の中で、

``Notation seq := list``

という具合に、list のNotation (構文糖）として定義されていて、
Standard Coq の list と同じものであることが判ります。

（注記）

括弧による表記については、``[::]`` など、MathCompのNotationで上書きされるので、
かなり変わったものになりますが、支障にはなりません。
ここでは、型としてはseqを、括弧の表記はMathCompの表記を使いますが、
データ型として「リスト」と呼ぶことにします。

（注記終わり）

MathComp の中から、Standard Coq で定義されたリストの命題を使用することができます。
当然、おなじ意味（同値）な命題もあります。

実際には、Standard Coqでは Prop型の命題（述語）として、
MathCompではbool型を返す関数として定義されているわけですが、
それらの間で同値性を示すリフレクション補題を証明することで、
相互の変換ができ（リフレクションですね）、証明が捗ることがあるかもしれません。
*)

(**
# コード例 その1
*)

Require Import List.
From mathcomp Require Import all_ssreflect.

Section List_1_1.

(**
最初の例は、Standard Coq の Lists/List.v で定義されている Forall と Exists です。
述語Pが、リストの要素のすべてで成り立つ、あるいは、ある要素で成り立つ、
ことを示す命題です。（∀と∃の意味の、forallとexists とは別な意味です。）
 *)

  Check Forall : forall A : Type, (A -> Prop) -> seq A -> Prop.
  Check Exists : forall A : Type, (A -> Prop) -> seq A -> Prop.

(**
これらに対して、MathComp では、
ssreflect/seq.v で all と has という関数が定義されています。

@は、implicitな引数を表示するために使っています。
この場合、型Tの指定は、引数として省略できます。
*)

  Check @all : forall A : Type, (A -> bool) -> seq A -> bool.
  Check @has : forall A : Type, (A -> bool) -> seq A -> bool.

(**
ここでは、型しか示しませんが、実際の定義はそれぞれのソースコードを参照してください。

Standard Coq の Forall と Exists は、
(A->Prop)型の述語と、A型のリストをとり、全体としてProp型を返します。

Mathcop の allと has は、(A->bool)型の関数と、A型のリストをとり、
全体としてbool型を返します。
*)

(**
Forall と all の間のリフレクション補題を次に示します。
*)
  Lemma ForallP {A : Type} (P : A -> Prop) (p : A -> bool) :
    (forall (a : A), reflect (P a) (p a)) ->
    forall (s : seq A), reflect (Forall P s) (all p s).
  Proof.
    move=> H s.
    apply/(iffP idP).
    - elim: s => [Hp | a s IHs /= /andP].
      + by apply: Forall_nil.
      + case.
        move/H => Hpa Hps.
        apply: Forall_cons.
        * done.
        * by apply: IHs.
    - elim: s => /= [| a s IHs].
      + done.
      + move=> HP.
        apply/andP.
        inversion HP; subst.
        split.
        * by apply/H.
        * by apply IHs.
  Qed.

(**
``reflect (Forall P s) (all p s)``
が、Forall と all が同値であることを示す
リフレクション補題で、これだけで同値であることを示します。

しかし、(A->Prop)型の述語P と、(A->bool)型の関数p とがリフレクション関係である
ことを条件としなければなりません。なので、前提に
``reflect (P a) (p a)``
が必要となります。

リフレクション補題をしめす reflect の定義は、
ssreflect/ssrbool.v にある定義か、
文献 [1.] を参照してください。
*)

(**
Exists についても同様です。
*)
  Lemma ExistsP {A : Type} (P : A -> Prop) (p : A -> bool) :
    (forall (a : A), reflect (P a) (p a)) ->
    forall (s : seq A), reflect (Exists P s) (has p s).
  Proof.
    move=> H s.
    apply/(iffP idP).
    - elim: s => [Hp | a s IHs /= /orP].
      + done.
      + case=> [Hpa | Hpa].
        * apply: Exists_cons_hd.
            by apply/H.
        * apply: Exists_cons_tl.
            by apply: IHs.
    - elim: s => /= [| a s IHs] HP.
      + by inversion HP.
      + apply/orP.
        inversion HP; subst.
        * left.
            by apply/H.
        * right.
            by apply: IHs.
  Qed.

End List_1_1.

(**
# 実行例 その1

最初に、ここで証明したリフレクション補題を使う例です。
*)

Goal Forall (fun n => n == 1) [:: 1; 1; 1; 1].
Proof.
  apply/ForallP.
(**
``apply/ForallP`` がゴールに対してリフレクション補題を使うことを示します。
詳細は、文献 [2.] の 3.7節を参照してください。

すると、ForallP の前提部分の証明を求められます。
``a == 1`` と同値な命題は ``a = 1`` ですから、補題 eqP
*)

Check eqP : reflect (_ = _) (_ == _).

(**
を使って証明することができます。
*)
  - move=> a.
      by apply: eqP.

(**
残った

``all (fun a => (a == 1) == true) [:: 1; 1; 1; 1]``

については、「計算」で真偽を決定することができるので、
done で証明を終了することができます。
*)
  - done.
Qed.

(**
リフレクション補題を使わない場合は、
Forall のコンストラクタである、Forall_cons と Forall_nil を適用して
ゴールの要素を個々に証明することになります。
*)

Check Forall_cons :
  forall A  (P : A -> Prop) x l, P x -> Forall P l -> Forall P (x :: l).
Check Forall_nil :
  forall A  (P : A -> Prop), Forall P [::].

Goal Forall (fun n => n == 1) [:: 1; 1; 1; 1].
Proof.
  apply: Forall_cons.
  - done.
  - apply: Forall_cons.
    + done.
    + apply: Forall_cons.
      * done.
      * apply: Forall_cons.
        ** done.
        ** apply: Forall_nil.
Qed.

(**
タクティカルの利用して、短く書くことは可能ですが、
本質的な操作は変わらないことに注意してください。
*)

Goal Forall (fun n => n == 1) [:: 1; 1; 1; 1].
Proof.
  do ! apply: Forall_cons => //=.
Qed.

(**
# コード例 その2
*)

Section List_1_2.

(**
次の例は、指定の値と同じ値がリストの中に存在することを示す In です。
Starndard Coq の場合は、値とリストをとる述語 In、
MathComp の場合は、\in という中置記法の演算子を使います。
*)

  Lemma In_inb {A : eqType} (x : A) (s : seq A) : In x s <-> x \in s.
  Proof.
    elim: s.
    - done.
    - move=> a s IHs.
      split=> /=; rewrite inE.
      + case=> H.
        * by apply/orP/or_introl/eqP.
        * by apply/orP/or_intror/IHs.
      + move/orP; case.
        * move/eqP => ->.
            by left.
        * move=> H.
          move/IHs in H.
            by right.
  Qed.

  Lemma InP {A : eqType} (x : A) (s : seq A) : reflect (In x s) (x \in s).
  Proof.
    apply: (iffP idP) => H.
    - by apply/In_inb.
    - by apply/In_inb.
  Qed.

End List_1_2.

(**
# 実行例 その2
*)

Goal In 3 [:: 1; 2; 3; 4].
Proof.
  apply/InP.
(**
ここで証明したリフレクション補題 InP を使うと、
Goal として: ``3 \in [:: 1; 2; 3; 4]`` が得られます。
これについても、「計算」で真偽を決定することができるので、
done で終了します。
*)

  done.
Qed.

(**
# 参考文献

[1.] リフレクションのしくみをつくる

https://qiita.com/suharahiromichi/items/9cd109386278b4a22a63

[2.] 萩原学 アフェルト・レナルド 「Coq/SSReflect/MathCompによる定理証明」 森北出版

(* END *)


(** Some examples with streams **)

(* Potentially infinite streams *)
CoInductive pstream A : Type :=
| pNil : pstream A
| pCons : A -> pstream A -> pstream A.

Arguments pNil {A}.
Arguments pCons {A} _ _.

(* From the "lecture", but with pnil case also *)
CoInductive pstream_eq {A} : pstream A -> pstream A -> Prop :=
| Pstream_eq_pnil :
    pstream_eq pNil pNil
| Pstream_eq_pcons : forall h t1 t2,
    pstream_eq t1 t2 -> pstream_eq (pCons h t1) (pCons h t2).

(* Implement the standard map function for potentially infinite streams *)
CoFixpoint pmap {A B} (f : A -> B) (s : pstream A) : pstream B. Admitted.

CoFixpoint pzeroes : pstream nat := pCons 0 pzeroes.
CoFixpoint pones : pstream nat := pCons 1 pones.
Definition pones' := pmap S pzeroes.

(* Reusing the name from CPDT, maybe unfold, destruct or something else would be a better name
   (as mentioned during the "lecture") *)
Definition pfrob {A} (s : pstream A) : pstream A :=
  match s with
  | pNil => pNil
  | pCons h t => pCons h t
  end.

Theorem pfrob_eq : forall {A} (s : pstream A), s = pfrob s.
Proof. destruct s; reflexivity. Qed.

(* Warm up: Same as from the "lecture", but here with potentially infinite stream instead *)
Theorem ones_eq : pstream_eq pones pones'.
Admitted.

(* Some problems stolen from http://www.labri.fr/perso/casteran/RecTutorial.pdf,
   section "7.2 About injection, discriminate, and inversion".
   Illustrates that these things work for co-inductive reasoning also.
   Warning: Note that the proofs are given in the PDF... *)
Theorem pNil_not_pCons : forall {A} (a : A) (s : pstream A),
    pNil <> pCons a s.
Admitted.

Inductive Finite {A} : pstream A -> Prop :=
| pNil_fin : Finite pNil
| pCons_fin : forall a s, Finite s -> Finite (pCons a s).

(* Provide a definition analogous to Finite *)
CoInductive Infinite {A} : pstream A -> Prop :=.

Theorem pNil_not_Infinite : forall {A:Type}, ~ Infinite (pNil : pstream A).
Admitted.

Theorem Finite_not_Infinite : forall {A} (s : pstream A), Finite s -> ~Infinite s.
Admitted.

Theorem Not_Finite_Infinite : forall {A} (s : pstream A), ~Finite s -> Infinite s.
Admitted.

(* And now we will need similar definitions for (always infinite) streams... *)
CoInductive stream A : Type :=
| Cons : A -> stream A -> stream A.
Arguments Cons {A} _ _.
Infix "::" := Cons.

CoInductive stream_eq {A} : stream A -> stream A -> Prop :=
| Stream_eq : forall h t1 t2,
    stream_eq t1 t2 -> stream_eq (h::t1) (h::t2).

(* Some standard functions on streams also *)
Definition head {A} (s : stream A) : A :=
  match s with
  | h::t => h
  end.

Definition tail {A} (s : stream A) : stream A :=
  match s with
  | h::t => t
  end.

(* repeatedly apply a function [n] times *)
Fixpoint iterate {A} (n : nat) (f : A -> A) (a : A) : A :=
  match n with
  | O => a
  | S n' => f (iterate n' f a)
  end.

Definition tail_n {A} (n : nat) (s : stream A) : stream A := iterate n tail s.

Definition head_n {A} (n : nat) (s : stream A) : A := head (tail_n n s).

(* For example, this holds *)
Theorem tail_n_plus_m :
  forall {A} (n m : nat) (s : stream A), tail_n n (tail_n m s) = tail_n (n + m) s.
Admitted.

(* Some more examples of inductive and co-inductive definitions,
   from the standard library *)
Inductive Exists {A} (s : stream A) (P : stream A -> Prop) : Prop :=
| Here : P s -> Exists s P
| Further : Exists (tail s) P -> Exists s P.

(* Provide a definition analogous to Exists *)
CoInductive ForAll {A} (s : stream A) (P : stream A -> Prop) : Prop :=.

(* A simple thm *)
Theorem ForAll_tail : forall {A} n (P : stream A -> Prop) (s : stream A),
  ForAll s P -> ForAll (tail_n n s) P.
Admitted.

(* But, of course, the analogous thm for Exists does not hold.
   I only found ugly/long proofs for this... *)
Theorem Exists_tail : ~(forall {A} n (P : stream A -> Prop) (s : stream A),
                       Exists s P -> Exists (tail_n n s) P).
Admitted.

(* Let's prove things about this class of streams %[%#[#an element repeated indefinitely#]#%]% instead of general thms *)
CoFixpoint repeat n : stream nat := n::(repeat n).

Theorem tail_n_zeroes : forall n, stream_eq (tail (repeat n)) (repeat n).
Admitted.

Theorem iterate_n_tail_repeat : forall n m, stream_eq (tail_n n (repeat m))
                                                      (repeat m).
Admitted.

(* Mutual recursion, nothing exciting *)
CoFixpoint flip1 : stream nat := 1::flip0
with       flip0 := 0::flip1.

Theorem tail_flip1_flip0_eq : stream_eq (tail flip1) flip0.
Admitted.

(** Infinite trees **)

(* T(h)ree exercises stolen from https://www.eecs.northwestern.edu/~robby/courses/395-495-2013-fall/HW6.v: *)

(* Define the coinductive types representing the following infinite data structures: *)

(* 1. Infinite binary trees *)

(* 2. Infinitely branching infinite trees (i.e. infinitely wide and infinitely deep) *)

(* 3. Finitely and infinitely branching infinite trees (i.e. finitely or infinitely wide and infinitely deep) *)

(** Back to streams again: Bisimilarity **)
Definition Bisimulation {A} (R : stream A -> stream A -> Prop) :=
    (forall s1 s2, R s1 s2 -> head s1 = head s2) /\
    (forall s1 s2, R s1 s2 -> R (tail s1) (tail s2)).

Theorem stream_eq_bisim : forall {A}, @Bisimulation A stream_eq /\ forall (R : stream A -> stream A -> Prop),
    Bisimulation R ->
    forall s1 s2, R s1 s2 -> stream_eq s1 s2.
Proof.
  (* Same proof as in the "lecture" *)
  split.
  split; destruct 1; trivial.
  intros R [H_head H_tail]. cofix. destruct s1, s2. intros.
  generalize (H_head _ _ H). intros. simpl in H0. rewrite H0. constructor.
  apply stream_eq_bisim.
  apply (H_tail _ _ H). Qed.

(* Same as above, but use stream_eq_bisim here *)
Theorem tail_flip1_flip0_eq' : stream_eq (tail flip1) flip0.
Admitted.

(* I suggest using stream_eq_bisim again *)
Theorem heads_iff_eq : forall {A} (s1 s2 : stream A),
    (forall (n : nat), head_n n s1 = head_n n s2) <-> stream_eq s1 s2.
Admitted.

(** Optional: Do the co-inductive big-step operational semantics for an imperative language optimization example from 5.3 in CPDT in SF-style instead of CPDT-style. **)

(** Even more exercise in case you're interested: In the coinduction chapter in Coq'Art there are some exercises. Consider especially 13.9 and 13.10, for some non-stream examples. **)


Check (3,4=1):nat*Prop.
Check (fun x:nat => x=3).

Check (forall x:nat, x<3 \/ (exists y:nat, x = y + 3)).

Check (let f := fun x:nat => (x*3,x) in f).

Locate "_ <= _".

Check and.

Check and True False.

Locate "\/".

Compute let f := fun x:nat => (x*x,x) in f 30.

Compute fun x:nat => (x*x).

Definition example1 := fun x:nat => x*x.
Check example1.
Compute example1 3.

Print example1.

Require Import Bool.

Compute if true then 2 else 5.

SearchPattern bool.

Require Import Arith.

Definition is_zero (n:nat) :=
 match n with
  0 => true
| S p => false
end.

Compute is_zero 0.

Print pred.

Compute pred 12.

Definition get_pred(n:nat) :=
 match n with
  0 => n
| S u => u
 end.

Compute get_pred 12.

Definition get_succ(n:nat) :=
 match n with
  0 => S n
| S u => S (S u)
 end.

Compute get_succ 0.

(*do this question at the end of 2.5 section
Check let f := fun a::b::nil => (a+b+c+d+e+f) in f.
  *)