(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond
Copyright (C) 2020      Joseph Tassarotti

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

From Coq Require Import Reals Psatz ssreflect Utf8 ClassicalEpsilon.

Require Import Rcomplements Lim_seq Rbar Hierarchy Series Markov.

Section Definitions.

(** * Definitions *)

Definition enn_is_series (a : nat -> Rbar) (l : Rbar) :=
  (∀ n, Rbar_le 0 (a n)) ∧
  match l with
  | Finite x => (∀ n, is_finite (a n)) ∧ is_series (λ n, real (a n)) x
  | m_infty => False
  | p_infty => (∃ n, a n = p_infty) ∨ (¬ ex_series (λ n, real (a n)))
  end.

Definition enn_ex_series (a : nat -> Rbar) :=
   exists l : Rbar, enn_is_series a l.

End Definitions.

Definition enn_Series (a : nat -> Rbar) : Rbar.
  destruct (ClassicalEpsilon.excluded_middle_informative (enn_ex_series a)) as [e|ne].
  - apply ClassicalEpsilon.constructive_indefinite_description in e.
    destruct e as (e&_). apply e.
  - exact (Series a).
Defined.

Lemma enn_is_series_unique (a : nat -> Rbar) (l : Rbar) :
  enn_is_series a l -> enn_Series a = l.
Proof.
  rewrite /enn_Series/enn_is_series.
  move => Ha.
  destruct (excluded_middle_informative _) as [?|n]; last first.
  { exfalso. apply n. exists l. eauto. }
  destruct Ha.
  destruct constructive_indefinite_description as (l''&HHle&Hl'').
  destruct l; try (exfalso; eauto; fail); destruct l''; eauto.
  - intuition.
    apply is_series_unique in H2.
    apply is_series_unique in H3. congruence.
  - destruct Hl''. intuition. exfalso. destruct H1 as (n&Heq). specialize (H2 n).
    rewrite Heq in H2. rewrite /is_finite in H2. inversion H2.
  - intuition. exfalso. eapply H1; eauto. eexists; eauto.
  - intuition.
  - destruct H0.
    * destruct Hl''. destruct H0 as (n&?). specialize (H1 n). rewrite H0 in H1. inversion H1.
    * exfalso. apply H0. eexists; eauto. eapply Hl''.
  - exfalso; eauto.
Qed.
Lemma enn_Series_correct (a : nat -> Rbar) :
  enn_ex_series a -> enn_is_series a (enn_Series a).
Proof.
  case => l Ha.
  by rewrite (enn_is_series_unique a l).
Qed.

Lemma enn_is_series_reals (a : nat -> R) (l : R) :
  (∀ n, 0 <= a n) ->
  is_series a l <-> enn_is_series a l.
Proof.
  intros Hnonneg.
  split.
  - intros His. split; [| split]; eauto. intros. rewrite /is_finite. reflexivity.
  - intros (?&?&His). eauto.
Qed.

Lemma enn_is_series_reals2 (a : nat -> Rbar) (l : R) :
  (∀ n, is_finite (a n)) ->
  enn_ex_series a ->
  is_series (fun n => real (a n)) l -> enn_is_series a l.
Proof.
  intros Hfin Hex His.
  rewrite /enn_is_series.
  split; [| split]; auto.
  destruct Hex as (?&?&?); eauto.
Qed.

Lemma enn_is_series_ext (a b : nat -> Rbar) (l : Rbar) :
  (forall n, a n = b n) -> (enn_is_series a l)
    -> enn_is_series b l.
Proof.
  move => Heq.
  rewrite /enn_is_series. intros (Hnonneg&Hlim).
  destruct l; eauto.
  - destruct Hlim as (Hfin&Hseries); split; [| split]; auto.
    * intros. rewrite -Heq; eauto.
    * intros. rewrite -Heq; eauto.
    * eapply is_series_ext; eauto. intros. simpl. f_equal. by rewrite Heq.
  - split.
    { intros. rewrite -Heq; eauto. }
    destruct Hlim as [Hpinfty|Hnotex].
    * left. destruct Hpinfty as (n&Heq'). exists n. congruence.
    * right. intros Hex. eapply Hnotex. eapply ex_series_ext; try eassumption.
      intros. simpl. symmetry. congruence.
  - exfalso; eauto.
Qed.

Lemma enn_ex_series_ext (a b : nat -> Rbar) :
  (forall n, a n = b n) -> enn_ex_series a
    -> enn_ex_series b.
Proof.
  move => Heq [l Ha].
  exists l ; by apply enn_is_series_ext with a.
Qed.

Lemma enn_Series_ext (a b : nat -> Rbar) :
  (forall n, a n = b n) -> enn_Series a = enn_Series b.
Proof.
  move => Heq.
  rewrite {1}/enn_Series.
  destruct (excluded_middle_informative _) as [He|Hne].
  - destruct constructive_indefinite_description.
    symmetry. eapply enn_is_series_unique. eapply enn_is_series_ext; eauto.
  - rewrite /enn_Series. destruct excluded_middle_informative; auto.
    * exfalso. eapply Hne. eapply enn_ex_series_ext; try eassumption.
      intros. congruence.
    * f_equal. apply Series_ext; eauto.
      intros. f_equal. eauto.
Qed.

Lemma enn_ex_series_nonneg (a : nat -> Rbar) :
  (∀ n, Rbar_le 0 (a n)) ->
  enn_ex_series a.
Proof.
  intros Hnonneg.
  rewrite /enn_ex_series.
  rewrite /enn_is_series.
  destruct (excluded_middle_informative (∃ n, a n = p_infty)) as [He|Hne].
  { destruct He as (n&Heq).
    exists p_infty. split; auto. left; eauto. }
  destruct (excluded_middle_informative (ex_series (λ n, real (a n)))) as [He|Hne2].
  { destruct He as (l&His). exists l. split; [| split]; eauto.
    intros n. destruct (a n) eqn:Heq; eauto; rewrite /is_finite//=.
    { exfalso. eapply Hne. eauto. }
    specialize (Hnonneg n). rewrite Heq in Hnonneg. exfalso; simpl in Hnonneg. eauto.
  }
  exists p_infty. split; eauto.
Qed.

Lemma enn_ex_series_inv (a : nat -> Rbar) :
  enn_ex_series a ->
  (ex_series (fun n => real (a n)) ∧ (forall n, is_finite (a n)) ∧ enn_Series a = Series a) ∨
  enn_Series a = p_infty.
Proof.
  intros Hex.
  destruct Hex as (l&His).
  destruct l.
  - left.
    split; [| split].
    * destruct His as (Hnonneg&?&?); eexists; eauto.
    * destruct His as (Hnonneg&?&?); eauto.
    * apply enn_is_series_unique.
      destruct His as (Hnonneg&?&?); eexists; eauto.
      split; eauto. apply Series_correct; eexists; eauto.
  - right. by apply enn_is_series_unique.
  - exfalso; eapply His.
Qed.

(** Index offset *)

Lemma enn_is_series_incr_1 (a : nat -> Rbar) (l : Rbar) :
  is_finite (a O) ->
  enn_is_series a (Rbar_plus l (a O))
    -> enn_is_series (fun k => a (S k)%nat) l.
Proof.
  rewrite /enn_is_series.
  intros Hfin (Hnonneg&Hlim).
  split.
  { intros. eapply Hnonneg. }
  destruct l.
  - destruct (a O) as [r'| |] eqn:Heq; try (exfalso; congruence).
    destruct Hlim as (Hfin'&His). split; eauto.
    apply (is_series_incr_1 (fun k => real (a k))).
    rewrite Heq. eauto.
  - destruct (a O) as [r'| |] eqn:Heq; try (exfalso; congruence).
    simpl in Hlim. destruct Hlim as [(n&Heqn)|Hnex].
    * destruct n as [| n]; first by congruence.
      left. exists n; eauto.
    * right. intros Hex. apply Hnex.
      eapply ex_series_incr_1; eauto.
  - destruct (a O) as [r'| |] eqn:Heq; try (exfalso; congruence).
    simpl in Hlim; eauto.
Qed.

Lemma enn_ex_series_incr_1 (a : nat -> Rbar) :
  enn_ex_series a ->
  enn_ex_series (fun k => a (S k)).
Proof.
  intros (l&Heq). destruct Heq. apply enn_ex_series_nonneg; eauto.
Qed.

(*
Lemma enn_is_series_incr_n (a : nat -> V) (n : nat) (l : V) :
  (0 < n)%nat -> is_series a (plus l (sum_n a (pred n)))
    -> is_series (fun k => a (n + k)%nat) l.
Proof.
  case: n => /= [ | n] Hn Ha.
  by apply lt_irrefl in Hn.
  clear Hn.
  elim: n l Ha => [ | n IH] l Ha.
  rewrite sum_O in Ha.
  by apply is_series_incr_1.
  apply is_series_ext with (fun k : nat => a (S (n + S k))).
  move => k ; apply f_equal ; ring.
  apply (is_series_incr_1 (fun k : nat => a (S (n + k))) l).
  rewrite plus_0_r.
  apply IH.
  replace (plus (plus l (a (S n))) (sum_n a n)) with (plus l (sum_n a (S n))).
  assumption.
  rewrite <- plus_assoc, sum_Sn; apply f_equal; simpl; apply plus_comm.
Qed.
*)

Lemma enn_is_series_decr_1 (a : nat -> Rbar) (l : Rbar) :
  is_finite (a O) ->
  Rbar_le 0 (a O) ->
  enn_is_series (fun k => a (S k)%nat) (Rbar_plus l (Rbar_opp (a O))) -> enn_is_series a l.
Proof.
  rewrite /enn_is_series.
  intros Hfin0 Hnonneg0 (Hnonneg&Hlim).
  split.
  { intros. destruct n; eauto; eapply Hnonneg. }
  destruct l.
  - destruct (a O) as [r'| |] eqn:Heq; try (exfalso; congruence).
    destruct Hlim as (Hfin'&His). split; eauto.
    { intros [|]; eauto. rewrite Heq; eauto. }
    apply (is_series_decr_1 (fun k => real (a k))).
    rewrite Heq. eauto.
  - destruct (a O) as [r'| |] eqn:Heq; try (exfalso; congruence).
    simpl in Hlim. destruct Hlim as [(n&Heqn)|Hnex].
    * left. eauto.
    * right. intros Hex. apply Hnex.
      eapply ex_series_incr_1 in Hex; eauto.
  - destruct (a O) as [r'| |] eqn:Heq; try (exfalso; congruence).
    simpl in Hlim; eauto.
Qed.

Lemma enn_ex_series_decr_1 (a : nat -> Rbar) :
  is_finite (a O) ->
  Rbar_le 0 (a O) ->
  enn_ex_series (fun k => a (S k)%nat) -> enn_ex_series a.
Proof.
  intros Hfin Hle (l&Hnonneg&?).
  apply enn_ex_series_nonneg. intros [| n']; eauto.
Qed.

(*
Lemma is_series_decr_n (a : nat -> V) (n : nat) (l : V) :
  (0 < n)%nat -> is_series (fun k => a (n + k)%nat) (plus l (opp (sum_n a (pred n))))
    -> is_series a l.
Proof.
  case: n => /= [ | n] Hn Ha.
  by apply lt_irrefl in Hn.
  clear Hn.
  elim: n a l Ha => [ | n IH] a l Ha.
  rewrite sum_O in Ha.
  by apply is_series_decr_1.
  apply is_series_decr_1.
  apply IH.
  replace (plus (plus l (opp (a 0%nat))) (opp (sum_n (fun k : nat => a (S k)) n)))
    with (plus l (opp (sum_n a (S n)))).
  by apply Ha.
  rewrite /sum_n sum_n_m_S sum_Sn_m /=.
  rewrite <- plus_assoc.
  apply f_equal.
  now rewrite opp_plus.
  by apply le_O_n.
Qed.
*)

(*
Lemma ex_series_incr_1 (a : nat -> V) :
  ex_series a <-> ex_series (fun k => a (S k)%nat).
Proof.
  split ; move => [la Ha].
  exists (plus la  (opp (a O))).
  apply is_series_incr_1.
  now rewrite -plus_assoc plus_opp_l plus_zero_r.
  exists (plus la (a O)).
  apply is_series_decr_1.
  now rewrite -plus_assoc plus_opp_r plus_zero_r.
Qed.

Lemma ex_series_incr_n (a : nat -> V) (n : nat) :
  ex_series a <-> ex_series (fun k => a (n + k)%nat).
Proof.
  case: n => [ | n].
  split ; apply ex_series_ext ; by intuition.
  split ; move => [la Ha].
  exists (plus la (opp (sum_n a (pred (S n))))).
  apply is_series_incr_n.
  by apply lt_O_Sn.
  now rewrite -plus_assoc plus_opp_l plus_zero_r.
  exists (plus la (sum_n a (pred (S n)))).
  apply is_series_decr_n with (S n).
  by apply lt_O_Sn.
  now rewrite -plus_assoc plus_opp_r plus_zero_r.
Qed.
*)

Lemma enn_Series_incr_1' (a : nat -> Rbar) :
  is_finite (a O) ->
  Rbar_le 0 (a O) ->
  enn_ex_series a -> enn_Series a = Rbar_plus (a O) (enn_Series (fun k => a (S k))).
Proof.
  move => Hfin Hnonneg Ha.
  apply enn_is_series_unique.
  rewrite Rbar_plus_comm.
  apply enn_is_series_decr_1; auto.
  rewrite Rbar_plus_assoc_finite //=; last first.
  { by apply Rbar_opp_finite. }
  rewrite Rbar_plus_opp_finite; auto.
  rewrite Rbar_plus_0_r.
  eapply enn_Series_correct.
  eapply enn_ex_series_incr_1; eauto.
Qed.

Lemma is_series_0 a: (∀ n, a n = 0) → is_series a 0.
Proof.
  intros Ha. apply (is_series_ext (λ x, 0)); auto.
  rewrite /is_series.
  apply (filterlim_ext (λ x, 0)).
  - intros m. rewrite sum_n_const Rmult_0_r //.
  - apply filterlim_const.
Qed.

Lemma Series_0 a: (∀ n, a n = 0) → Series a = 0.
Proof.
  intros Heq. apply is_series_unique, is_series_0. done.
Qed.

Lemma enn_is_series_0 (a : nat -> Rbar) : (∀ n, a n = Finite 0) → enn_is_series a 0.
Proof.
  intros Heq. split; [| split]; auto.
  { intros n. rewrite Heq. apply Rbar_le_refl. }
  { intros n. rewrite Heq. rewrite //=. }
  { apply is_series_0. intros n. rewrite Heq //=. }
Qed.

Lemma enn_Series_0 (a : nat -> Rbar) : (∀ n, a n = Finite 0) → enn_Series a = Finite 0.
Proof. intros. apply enn_is_series_unique, enn_is_series_0; auto. Qed.

Lemma enn_is_series_finite_nonneg (a : nat -> Rbar) (r: R) :
  enn_is_series a r ->
  0 <= r.
Proof.
  intros (Hnonneg&Hfin&His).
  replace r with (Series a); last first.
  { apply is_series_unique; eauto. }
  rewrite -(Series_0 (λ n, 0)); last auto.
  apply Series_le.
  { intros n. specialize (Hnonneg n). simpl in Hnonneg.
    destruct (a n); simpl in *; eauto; nra. }
  eexists; eauto.
Qed.

Lemma enn_is_series_nonneg (a : nat -> Rbar) (r: Rbar) :
  enn_is_series a r ->
  Rbar_le 0 r.
Proof.
  destruct r.
  - apply enn_is_series_finite_nonneg.
  - simpl. auto.
  - rewrite /enn_is_series. intuition.
Qed.

Lemma enn_Series_nonneg (a : nat -> Rbar) :
  enn_ex_series a ->
  Rbar_le 0 (enn_Series a).
Proof.
  intros (r&His). eapply enn_is_series_nonneg. erewrite enn_is_series_unique; eauto.
Qed.

Lemma enn_Series_incr_1 (a : nat -> Rbar) :
  Rbar_le 0 (a O) ->
  enn_ex_series a -> enn_Series a = Rbar_plus (a O) (enn_Series (fun k => a (S k))).
Proof.
  move => Hnonneg Ha.
  destruct (a O) as [r | |] eqn:Heq.
  { rewrite -Heq. eapply enn_Series_incr_1'; rewrite ?Heq //=. }
  { transitivity p_infty.
    - apply enn_is_series_unique.
      destruct Ha as (r'&?&?).
      split; auto. left. exists O. auto.
    - apply enn_ex_series_incr_1 in Ha.
      specialize (enn_Series_nonneg _ Ha) as Hle.
      destruct (enn_Series _); simpl in *; eauto. intuition.
  }
  { simpl in Hnonneg. intuition. }
Qed.

(*
Lemma Series_incr_n (a : nat -> R) (n : nat) :
  (0 < n)%nat -> ex_series a
    -> Series a = sum_f_R0 a (pred n)  + Series (fun k => a (n + k)%nat).
Proof.
  move => Hn Ha.
  apply is_series_unique.
  rewrite Rplus_comm.
  apply is_series_decr_n with n.
  by [].
  rewrite /plus /opp /= sum_n_Reals.
  ring_simplify (Series (fun k : nat => a (n+ k)%nat) + sum_f_R0 a (pred n) + - sum_f_R0 a (pred n)).
  apply Series_correct.
  by apply ex_series_incr_n.
Qed.
*)

Lemma enn_Series_incr_1_aux (a : nat -> Rbar) :
  a O = 0 -> enn_Series a = enn_Series (fun k => a (S k)).
Proof.
  intros Heq. destruct (excluded_middle_informative (enn_ex_series a)) as [He|Hne] eqn:Heq'.
  - rewrite enn_Series_incr_1; rewrite ?Heq //=.
    * by rewrite Rbar_plus_0_l.
    * nra.
  - rewrite /enn_Series. rewrite Heq'.
    destruct (excluded_middle_informative (enn_ex_series (λ k, a (S k)))) as [He'|Hne'].
    { exfalso. apply Hne. apply enn_ex_series_decr_1; rewrite ?Heq => //=. nra. }
    rewrite Series_incr_1_aux ?Heq //=.
Qed.

(*
Lemma Series_incr_n_aux (a : nat -> R) (n : nat) :
   (forall k, (k < n)%nat -> a k = 0)
     -> Series a = Series (fun k => a (n + k)%nat).
Proof.
  elim: n => [ | n IH] Ha.
  by apply Series_ext => k.
  rewrite IH.
  rewrite Series_incr_1_aux.
  apply Series_ext => k.
  apply f_equal ; ring.
  intuition.
  move => k Hk ; intuition.
Qed.
*)

(** * Convergence theorems *)

(** Comparison *)

Lemma enn_Series_finite (a : nat -> Rbar) :
  (forall n, is_finite (a n)) ->
  ex_series (fun n => real (a n)) ->
  enn_Series a = Series (fun n => real (a n)).
Proof.
  intros Hfin Hex.
  destruct (excluded_middle_informative (enn_ex_series a)) eqn:Heq; last first.
  { rewrite /enn_Series. rewrite Heq. auto. }
  apply enn_is_series_unique.
  apply enn_is_series_reals2; auto.
  apply Series_correct; auto.
Qed.

Lemma enn_Series_le (a b : nat -> Rbar) :
  (forall n : nat, Rbar_le 0 (a n) /\ Rbar_le (a n) (b n)) ->
   Rbar_le (enn_Series a) (enn_Series b).
Proof.
  intros Hle.
  assert (enn_ex_series a).
  { apply enn_ex_series_nonneg. eapply Hle. }
  assert (enn_ex_series b).
  { apply enn_ex_series_nonneg. intros. apply (Rbar_le_trans _ (a n)); eapply Hle. }
  destruct (enn_ex_series_inv b) as [Hex|Hpinfty]; auto.
  - destruct Hex as (Hex&Hfin&->).
    assert (Hfina: ∀ n, is_finite (a n)).
    { intros n.
      rewrite /is_finite.
      specialize (Hle n).
      specialize (Hfin n).
      destruct (a n) => //=; rewrite -Hfin in Hle; simpl in Hle; intuition.
    }
    rewrite enn_Series_finite; auto; last first.
    { apply: ex_series_le; eauto.
      simpl. rewrite /norm //= /abs //=. intros n.
      destruct (Hle n) as (Hnonneg&Hleb).
      rewrite -Hfin in Hleb.
      rewrite -Hfina in Hleb Hnonneg.
      simpl in Hleb, Hnonneg.
      rewrite Rabs_right; auto. nra.
    }
    simpl. apply Series_le; eauto.
    { intros n.
      specialize (Hle n).
      specialize (Hfin n).
      rewrite -Hfin in Hle.
      rewrite -Hfina in Hle. simpl in Hle. auto.
    }
  - rewrite Hpinfty. destruct (enn_Series a) => //=.
Qed.

(** * Operations *)

(** Additive operators *)

(*
Lemma is_series_opp (a : nat -> V) (la : V) :
  is_series a la
    -> is_series (fun n => opp (a n)) (opp la).
Proof.
  move => Ha.
   apply filterlim_ext with (fun n => opp (sum_n a n)).
  elim => [ | n IH].
  rewrite !sum_O ; easy.
  rewrite !sum_Sn -IH.
  apply: opp_plus.
  apply filterlim_comp with (1:=Ha).
  apply filterlim_opp.
Qed.

Lemma ex_series_opp (a : nat -> V) :
  ex_series a
    -> ex_series (fun n => opp (a n)).
Proof.
  move => [la Ha].
  exists (opp la).
  by apply is_series_opp.
Qed.
Lemma Series_opp (a : nat -> R) :
  Series (fun n => - a n) = - Series a.
Proof.
  rewrite /Series
    (Lim_seq_ext (sum_n (fun k : nat => - a k)) (fun n => - (sum_n (fun k => a k) n))).
  rewrite Lim_seq_opp.
  by rewrite Rbar_opp_real.
  elim => [ | n IH].
  rewrite !sum_O ; ring.
  rewrite !sum_Sn IH /plus /=.
  ring.
Qed.
*)

Lemma enn_lim_p_infty_strengthen (a : nat -> Rbar) :
  (∀ n : nat, Rbar_le 0 (a n)) ->
  (∃ n : nat, a n = p_infty) ∨ ¬ ex_series (λ n : nat, real (a n)) ->
  (∃ n : nat, a n = p_infty) ∨ (¬ ex_series (λ n : nat, real (a n)) ∧ (∀ n, is_finite (a n))).
Proof.
  intros Hnonneg Hcase.
  destruct (ClassicalEpsilon.excluded_middle_informative (∃ n, a n = p_infty)) as [Htrue|Hfalse].
  { left; eauto. }
  destruct Hcase as [Hl|Hr]; first (exfalso; eauto).
  right. split; eauto. intros n. rewrite /is_finite; specialize (Hnonneg n); destruct (a n) eqn:Heq; eauto.
  * exfalso. eapply Hfalse; eauto.
  * simpl in Hnonneg; exfalso; eauto.
Qed.

Lemma enn_is_series_plus_pinfty (a b : nat -> Rbar) (la : Rbar) :
  enn_is_series a la -> enn_is_series b p_infty
    -> enn_is_series (fun n => Rbar_plus (a n) (b n)) (Rbar_plus la p_infty).
Proof.
  intros Ha Hb.
  destruct la as [ra | |]; last by (exfalso; eapply Ha).
  * simpl in *.
    destruct Ha as (Hnonnega&Hfina&Ha').
    destruct Hb as (Hnonnegb&Hlim).
    split.
    { simpl. intros n.
      specialize (Hfina n).
      specialize (Hnonnega n). specialize (Hnonnegb n).
      destruct (a n), (b n); try simpl in *; try nra.
    }
    destruct Hlim as [Hpinfty|Hnexists].
    ** left. destruct Hpinfty as (n&Heq). exists n.
       specialize (Hfina n). rewrite Heq.
       rewrite /is_finite in Hfina.
       destruct (a n); try simpl in *; try nra; try congruence.
    ** right. intros Hex. apply Hnexists.
       apply: ex_series_le; last eapply Hex.
       intros n. rewrite /norm //= /abs //=.
       rewrite Rabs_right; last first.
       { specialize (Hnonnegb n).  destruct (b n); simpl in *; try nra. }
       specialize (Hfina n). specialize (Hnonnega n).
       destruct (a n); try simpl in *; try nra; try congruence.
       destruct (b n); try simpl in *; try nra.
  * destruct Ha as (Hnonnega&Hlima).
    destruct Hb as (Hnonnegb&Hlimb).
    split.
    { simpl. intros n.
      specialize (Hnonnega n). specialize (Hnonnegb n).
      destruct (a n), (b n); try simpl in *; try nra.
    }
    apply enn_lim_p_infty_strengthen in Hlima; eauto.
    apply enn_lim_p_infty_strengthen in Hlimb; eauto.
    destruct Hlimb as [Hpinfty|(Hnexistsb&Hfinb)].
    { left. destruct Hpinfty as (n&Heq). exists n.
       specialize (Hnonnega n). rewrite Heq.
       destruct (a n); try simpl in *; try nra; try congruence. }
    destruct Hlima as [Hpinfty|(Hnexistsa&Hfina)].
    { left. destruct Hpinfty as (n&Heq). exists n.
       specialize (Hnonnegb n). rewrite Heq.
       destruct (b n); try simpl in *; try nra; try congruence. }
    right. intros Hex.
    apply Hnexistsb.
    apply: ex_series_le; last eapply Hex.
    intros n. rewrite /norm //= /abs //=.
    rewrite Rabs_right; last first.
    { specialize (Hnonnegb n). destruct (b n); simpl in *; try nra. }
    specialize (Hnonnega n). specialize (Hnonnegb n).
    specialize (Hfina n). specialize (Hfinb n).
    destruct (a n); try simpl in *; try nra; try congruence;
    destruct (b n); try simpl in *; try nra.
Qed.

Lemma enn_is_series_plus (a b : nat -> Rbar) (la lb : Rbar) :
  enn_is_series a la -> enn_is_series b lb
    -> enn_is_series (fun n => Rbar_plus (a n)  (b n)) (Rbar_plus la  lb).
Proof.
  move => Ha Hb.
  destruct la as [ra | |]; last by (exfalso; eapply Ha).
  - destruct lb as [rb | |]; last by (exfalso; eapply Hb).
    * simpl in *. destruct Ha as (Hnonnega&Hfina&Ha'); destruct Hb as (Hnonnegb&Hfinb&Hb'); split.
      { simpl. intros n.
        specialize (Hfina n). specialize (Hfinb n).
        specialize (Hnonnega n). specialize (Hnonnegb n).
        destruct (a n), (b n); try simpl in *; try nra.
      }
      split.
      { simpl. intros n.
        specialize (Hfina n). specialize (Hfinb n).
        specialize (Hnonnega n). specialize (Hnonnegb n).
        destruct (a n), (b n); try simpl in *; rewrite /is_finite //=.
      }
      simpl.
      eapply (is_series_ext (λ n : nat, (a n) + (b n))).
      { intros n.
        specialize (Hfina n). specialize (Hfinb n).
        destruct (a n), (b n); try simpl in *; rewrite /is_finite //=.
      }
      apply: is_series_plus; eauto.
    * eapply enn_is_series_plus_pinfty; eauto.
  - rewrite Rbar_plus_comm. eapply enn_is_series_ext.
    { intros n. rewrite Rbar_plus_comm; reflexivity. }
    eapply enn_is_series_plus_pinfty; eauto.
Qed.

Lemma enn_ex_series_plus (a b : nat -> Rbar) :
  enn_ex_series a -> enn_ex_series b
    -> enn_ex_series (fun n => Rbar_plus (a n) (b n)).
Proof.
  move => [la Ha] [lb Hb].
  exists (Rbar_plus la lb).
  by apply enn_is_series_plus.
Qed.

(*
Lemma is_series_minus (a b : nat -> V) (la lb : V) :
  is_series a la -> is_series b lb
    -> is_series (fun n => plus (a n) (opp (b n))) (plus la (opp lb)).
Proof.
  move => Ha Hb.
  apply is_series_plus => //.
  apply is_series_opp => //.
Qed.
Lemma ex_series_minus (a b : nat -> V) :
  ex_series a -> ex_series b
    -> ex_series (fun n => plus (a n) (opp (b n))).
Proof.
  move => Ha Hb.
  apply ex_series_plus => //.
  apply ex_series_opp => //.
Qed.
*)

Lemma enn_Series_plus (a b : nat -> Rbar) :
  enn_ex_series a -> enn_ex_series b
    -> enn_Series (fun n => Rbar_plus (a n) (b n)) = Rbar_plus (enn_Series a) (enn_Series b).
Proof.
  intros Ha Hb.
  apply enn_is_series_unique;
    apply enn_is_series_plus;
    by apply enn_Series_correct.
Qed.

(*
Lemma Series_minus (a b : nat -> R) :
  ex_series a -> ex_series b
    -> Series (fun n => a n - b n) = Series a - Series b.
Proof.
  intros Ha Hb.
  rewrite Series_plus => //.
  rewrite Series_opp => //.
  apply ex_series_opp in Hb.
  now simpl in Hb.
Qed.
*)

(** Multiplication by a scalar *)

Lemma Series_strict_pos_inv a:
  (∀ n, a n >= 0) →
  0 < Series a →
  ∃ n, a n > 0.
Proof.
  intros Hge Hlt.
  destruct (LPO (λ n, a n > 0)) as [Hs|Heq0].
  - intros n. destruct (Rgt_dec (a n) 0) => //=; auto.
  - destruct Hs as (n&Hgt0); exists n; done.
  - exfalso. assert (Series a = 0).
    { apply Series_0. intros n. destruct (Hge n) => //=.
      exfalso; eapply Heq0; eauto.
    }
    nra.
Qed.

Lemma is_series_strict_pos_inv a r :
  (∀ n, a n >= 0) →
  is_series a r →
  0 < r →
  ∃ n, a n > 0.
Proof.
  intros. eapply Series_strict_pos_inv; eauto.
  replace (Series a) with r; auto.
  symmetry. apply is_series_unique; auto.
Qed.

Lemma enn_is_series_strict_pos_inv a (r : R) :
  enn_is_series a r →
  0 < r →
  ∃ n, Rbar_lt 0 (a n).
Proof.
  intros His Hlt. destruct His as (Hnonneg&Hfin&His).
  eapply is_series_strict_pos_inv in His; eauto.
  - destruct His as (n&Hgt). exists n. specialize (Hfin n); destruct (a n); simpl in *; try nra.
  - intros n. specialize (Hnonneg n); simpl in *; destruct (a n); simpl in *; try nra.
Qed.

Lemma is_lim_seq_unique_series a v:
  is_series a v → Lim_seq (sum_n a) = v.
Proof.
  intros. apply is_lim_seq_unique. rewrite //=.
Qed.

Lemma Rbar_le_fin' x y: 0 <= y → Rbar_le x y → Rle x (real y).
Proof.
  rewrite /Rbar_le. destruct x => //=.
Qed.

Lemma is_lim_seq_pos a (v: R):
  (∀ n, a n >= 0) →
  is_lim_seq a v →
  0 <= v.
Proof.
  rewrite /is_lim_seq => Hn; intros.
  cut (Rbar_le 0 v); first by auto.
  apply (@filterlim_le _ eventually _ (λ x, 0) a); auto.
  - exists O; intros. apply Rge_le; auto.
  - apply filterlim_const.
Qed.

Lemma is_series_partial_pos a n v:
  (∀ n, a n >= 0) →
  is_series a v →
  sum_n a n <= v.
Proof.
  intros Hpos His_series.
  assert (Hpos' : ∀ n : nat, sum_n a n >= 0).
  { intros n'. induction n' => //=; rewrite ?sum_O ?sum_Sn; eauto.
    specialize (Hpos (S n')). rewrite /plus//=. nra. }
  replace (sum_n a n) with (real (sum_n a n)) by auto.
  rewrite -(is_series_unique _ _ His_series).
  eapply Rbar_le_fin'.
  - case_eq (Lim_seq (sum_n a)) => //=; try nra.
    intros r Heq.
    rewrite /is_series in His_series.
    assert (ex_lim_seq (sum_n a)).
    { exists v. eauto. }
    eapply is_lim_seq_pos; eauto.
    rewrite -Heq. apply Lim_seq_correct; eauto.
  -  rewrite -Lim_seq_const.
     case_eq (Lim_seq (sum_n a)) => //=; try nra.
     * intros r Heq. rewrite -Heq.
       apply Lim_seq_le_loc. exists n.
       intros m; induction 1.
       ** apply Rle_refl.
       ** rewrite sum_Sn /plus//=. specialize (Hpos (S m)). nra.
     * intros Heq_infty. apply is_lim_seq_unique_series in His_series. exfalso.
       rewrite Heq_infty in His_series. congruence.
     * intros Heq_infty. apply is_lim_seq_unique_series in His_series. exfalso.
       rewrite Heq_infty in His_series. congruence.
Qed.

Lemma sum_n_partial_pos a :
  (∀ n, a n >= 0) →
   ∀ n : nat, sum_n a n >= 0.
Proof.
  intros Hpos n'; induction n' => //=; rewrite ?sum_O ?sum_Sn; eauto.
    specialize (Hpos (S n')). rewrite /plus//=. nra.
Qed.

Lemma sum_n_pos a (n: nat):
  (∀ n, a n >= 0) →
  0 <= sum_n a n.
Proof.
  intros Hge. induction n => //=.
  - rewrite sum_O. by apply Rge_le.
  - rewrite sum_Sn /plus//=. specialize (Hge (S n)). nra.
Qed.

Lemma sum_n_strict_pos a (n: nat):
  (∀ n, a n >= 0) →
  a n > 0 →
  0 < sum_n a n.
Proof.
  intros Hge Hgt.
  destruct n => //=.
  - rewrite sum_O. nra.
  - rewrite sum_Sn /plus//=. specialize (sum_n_pos a n Hge).
    nra.
Qed.

Lemma Lim_seq_pos a:
  (∀ n, a n >= 0) →
  0 <= Lim_seq a.
Proof.
  intros.
  cut (Rbar_le 0 (Lim_seq a)).
  { rewrite //=. rewrite /real. destruct Lim_seq; nra. }
  rewrite -Lim_seq_const. apply Lim_seq_le_loc.
  exists O. intros. apply Rge_le; auto.
Qed.

Lemma Series_partial_pos a (n: nat):
  (∀ n, a n >= 0) →
  ex_finite_lim_seq (sum_n a) →
  sum_n a n <= Series a.
Proof.
  intros Hpos Hfin.
  specialize (sum_n_partial_pos a Hpos) => Hpos'.
  replace (sum_n a n) with (real (sum_n a n)) by auto.
  eapply Rbar_le_fin'.
  - case_eq (Lim_seq (sum_n a)) => //=; try nra.
    intros r Heq'.
    eapply Rle_trans; first apply Lim_seq_pos; eauto.
    move: Heq'. destruct Lim_seq => //=. inversion 1. nra.
  - destruct Hfin as (?&Hfin).
    rewrite -Lim_seq_const.
     case_eq (Lim_seq (sum_n a)) => //=; try nra.
     * intros r Heq'. rewrite -Heq'.
       apply Lim_seq_le_loc. exists n.
       intros m; induction 1.
       ** apply Rle_refl.
       ** rewrite sum_Sn /plus//=. specialize (Hpos (S m)). nra.
     * apply is_lim_seq_unique in Hfin. congruence.
     * apply is_lim_seq_unique in Hfin. congruence.
Qed.

Lemma Series_strict_pos a (n: nat):
  (∀ n, a n >= 0) →
  a n > 0 →
  ex_finite_lim_seq (sum_n a) →
  0 < Series a.
Proof.
  intros. eapply Rlt_le_trans; last eapply Series_partial_pos; eauto.
  eapply sum_n_strict_pos; eauto.
Qed.

Lemma is_series_nonneg_0_inv a :
  (∀ n, 0 <= a n) ->
  is_series a 0 →
  ∀ n, a n = 0.
Proof.
  intros Hnonneg His.
  apply not_ex_not_all.
  intros (n&Hneq).
  assert (0 < Series a).
  {
    apply (Series_strict_pos _ n).
    - intros n0. specialize (Hnonneg n0). nra.
    - specialize (Hnonneg n). nra.
    - exists 0. eauto.
  }
  apply is_series_unique in His. nra.
Qed.

Lemma enn_is_series_0_inv (a : nat -> Rbar) :
  enn_is_series a 0 ->
  ∀ n, a n = Finite 0.
Proof.
  intros (Hnonneg&Hfin&His).
  intros n.
  rewrite /is_finite in Hfin.
  rewrite -Hfin. f_equal.
  eapply is_series_nonneg_0_inv in His; eauto.
  intros n0. specialize (Hnonneg n0). simpl in Hnonneg.
  destruct (a n0); simpl; try nra; eauto.
Qed.

Lemma Rbar_mult_p_infty_fin_pos_l r :
  0 < r ->
  Rbar_mult p_infty r = p_infty.
Proof.
  intros Hgt. rewrite //=. destruct Rle_dec; try destruct Rle_lt_or_eq_dec; try nra. auto.
Qed.

Lemma not_ex_series_non_zero a:
  ¬ ex_series a -> ∃ n, a n ≠ 0.
Proof.
  intros Hex.
  apply not_all_not_ex. intros Hneq.
  apply Hex. eapply (ex_series_ext (λ n, 0)); last first.
  { exists 0. eapply is_series_0; eauto. }
  intros n. specialize (Hneq n).
  symmetry. by apply NNPP.
Qed.

Lemma enn_is_series_scal (c : Rbar) (a : nat -> Rbar) (l : Rbar) :
  Rbar_le 0 c ->
  enn_is_series a l -> enn_is_series (fun n => Rbar_mult c (a n)) (Rbar_mult c l).
Proof.
  intros Hnonneg His.
  destruct l as [r | |]; last by (exfalso; eapply His).
  - assert (0 <= r) as [Hpos|HR0].
    { eapply enn_is_series_finite_nonneg; eauto. }
    * destruct c as [r' | |]; last by (exfalso; eauto).
      ** simpl. destruct His as (Hnonneg'&Hfin&His).
         split; [| split]; eauto.
         *** intros n. specialize (Hnonneg' n). specialize (Hfin n). simpl in *.
             destruct (a n); simpl in *; try nra; rewrite //= in Hfin; eauto.
         *** intros n. specialize (Hnonneg' n). specialize (Hfin n). simpl in *.
             destruct (a n); simpl in *; try nra; rewrite //= in Hfin; eauto.
         *** eapply (is_series_ext (λ n, r' * (a n))).
             { intros n. specialize (Hnonneg' n). specialize (Hfin n). simpl in *.
               destruct (a n); simpl in *; try nra; rewrite //= in Hfin; eauto. }
             apply: is_series_scal; eauto.
      ** rewrite Rbar_mult_p_infty_fin_pos_l; auto.
         split.
         {
           destruct His as (Hnonneg'&?).
           intros n. specialize (Hnonneg' n).
           destruct (a n); simpl in *; try nra; auto.
           { destruct Rle_dec; simpl in *; try auto. destruct Rle_lt_or_eq_dec; simpl in *; try auto.
             nra. }
         }
         left.
         apply enn_is_series_strict_pos_inv in His; eauto.
         destruct His as (n&Hpos'). exists n.
         destruct (a n); simpl in *; try nra; auto.
         { destruct Rle_dec; simpl in *; try auto; try nra.
           destruct Rle_lt_or_eq_dec; simpl in *; try auto.
           nra. }
    * rewrite -HR0. rewrite Rbar_mult_0_r. apply enn_is_series_0.
      intros n. subst.
      rewrite enn_is_series_0_inv //= Rbar_mult_0_r. reflexivity.
  - destruct c as [r | |]; last by (exfalso; eauto).
    * destruct Hnonneg as [Hpos|HR0].
      { destruct His as (Hnonneg&His).
        split.
        { intros n. specialize (Hnonneg n).
          destruct (a n); simpl in *; try auto; try nra.
          destruct Rle_dec; try nra.
          destruct Rle_lt_or_eq_dec; try nra.
        }
        rewrite Rbar_mult_comm. rewrite Rbar_mult_p_infty_fin_pos_l; auto.
        apply enn_lim_p_infty_strengthen in His.
        destruct His as [Hp_infty|(Hdiverge&Hfin)].
        { left. destruct Hp_infty as (n&Heq). exists n.
          rewrite Heq Rbar_mult_comm Rbar_mult_p_infty_fin_pos_l //=.
        }
        {
          right. intros Hex.
          apply Hdiverge.
          apply (ex_series_scal_l (Rinv r) _) in Hex.
          eapply ex_series_ext; try eassumption.
          intros n. rewrite /scal //= /mult //=.
          specialize (Hfin n). destruct (a n); simpl in *; try congruence; [].
          rewrite -Rmult_assoc.
          rewrite Rinv_l; nra.
        }
        { eauto. }
      }
      {
        rewrite -HR0. rewrite Rbar_mult_0_l.
        apply enn_is_series_0. intros. rewrite Rbar_mult_0_l //=.
      }
    * simpl.
      destruct His as (Hnonneg'&His).
      apply enn_lim_p_infty_strengthen in His; auto.
      split.
      { intros n. specialize (Hnonneg' n).
        destruct (a n); simpl in *; try nra; auto.
        { destruct Rle_dec; simpl in *; try auto. destruct Rle_lt_or_eq_dec; simpl in *; try auto.
          nra. }
      }
      destruct His as [Hp_infty|(Hdiverge&Hfin)].
      { left. destruct Hp_infty as (n&Heq). exists n.
        rewrite Heq //=. }
      { apply not_ex_series_non_zero in Hdiverge. left.
        destruct Hdiverge as (n&Hneq0). exists n.
        specialize (Hnonneg' n).
        destruct (a n); simpl in *; try nra; auto.
        { destruct Rle_dec; simpl in *; try auto; try nra.
          destruct Rle_lt_or_eq_dec; simpl in *; try auto.
          nra. }
      }
Qed.

Lemma enn_is_series_scal_l : forall (c : Rbar) (a : nat -> Rbar) (l : Rbar),
  Rbar_le 0 c ->
  enn_is_series a l -> enn_is_series (fun n => Rbar_mult c (a n)) (Rbar_mult c l).
exact enn_is_series_scal.
Qed.

Lemma enn_ex_series_scal (c : Rbar) (a : nat -> Rbar) :
  Rbar_le 0 c ->
  enn_ex_series a -> enn_ex_series (fun n => Rbar_mult c (a n)).
Proof.
  move => ? [l Ha].
  exists (Rbar_mult c l).
  by apply: enn_is_series_scal_l.
Qed.

Lemma enn_ex_series_scal_l : forall (c : Rbar) (a : nat -> Rbar),
  Rbar_le 0 c ->
  enn_ex_series a -> enn_ex_series (fun n => Rbar_mult c (a n)).
exact enn_ex_series_scal.
Qed.

Lemma enn_Series_scal_l (c : Rbar) (a : nat -> Rbar) :
  enn_ex_series a ->
  Rbar_le 0 c ->
  enn_Series (fun n => Rbar_mult c (a n)) = Rbar_mult c (enn_Series a).
Proof.
  intros Hex Hnonneg.
  apply enn_is_series_unique.
  apply enn_is_series_scal_l; auto.
  apply enn_Series_correct.
  auto.
Qed.

Lemma enn_is_series_scal_r (c : Rbar) (a : nat -> Rbar) (l : Rbar) :
  Rbar_le 0 c ->
  enn_is_series a l -> enn_is_series  (fun n => Rbar_mult (a n) c) (Rbar_mult l c).
Proof.
  move => Hle Ha.
  rewrite Rbar_mult_comm.
  apply enn_is_series_ext with (fun n : nat => Rbar_mult c (a n)).
  move => n ; apply Rbar_mult_comm.
  apply (enn_is_series_scal_l _ _ _ Hle Ha).
Qed.

Lemma ex_series_scal_r (c : Rbar) (a : nat -> Rbar) :
  Rbar_le 0 c ->
  enn_ex_series a -> enn_ex_series (fun n => Rbar_mult (a n) c).
Proof.
  intros Hle [l Ha].
  exists (Rbar_mult l c).
  by apply enn_is_series_scal_r.
Qed.

Lemma enn_Series_scal_r (c : Rbar) (a : nat -> Rbar) :
  enn_ex_series a ->
  Rbar_le 0 c ->
  enn_Series (fun n => Rbar_mult (a n) c) = Rbar_mult (enn_Series a) c.
Proof.
  intros. rewrite Rbar_mult_comm -enn_Series_scal_l //=.
  apply enn_Series_ext.
  move => n ; apply Rbar_mult_comm.
Qed.

(*
Lemma is_series_mult_pos (a b : nat -> R) (la lb : R) :
  is_series  a la -> is_series  b lb ->
  (forall n, 0 <= a n) -> (forall n, 0 <= b n)
  -> is_series  (fun n => sum_f_R0 (fun k => a k * b (n - k)%nat) n) (la * lb).
Proof.
  move => Hla Hlb Ha Hb.

  have H0 : forall n,
    sum_f_R0 (fun k : nat => sum_f_R0 (fun p : nat => a p * b (k - p)%nat) k) n
      <= sum_f_R0 a n * sum_f_R0 b n.
    case => [ | n].
    simpl ; apply Rle_refl.
    rewrite (cauchy_finite a b (S n) (lt_O_Sn n)).
    apply Rminus_le_0 ; ring_simplify.
    apply cond_pos_sum => m.
    apply cond_pos_sum => k.
    by apply Rmult_le_pos.
  have H1 : forall n, sum_f_R0 a n * sum_f_R0 b n
    <= sum_f_R0 (fun k : nat => sum_f_R0 (fun p : nat => a p * b (k - p)%nat) k) ((2*n)%nat).
    case => [ /= | n].
    by apply Rle_refl.
    rewrite (cauchy_finite a b (S n) (lt_O_Sn n)).
    rewrite Rplus_comm ; apply Rle_minus_r.
    replace (pred (S n)) with n by auto.
    replace (2 * S n)%nat with (S n + S n)%nat by ring.
    rewrite -sum_f_rw.
    rewrite /sum_f.
    replace (S n + S n - S (S n))%nat with n.
    elim: {1 5 8}n (le_refl n) => [ | m IH] Hm ; rewrite /sum_f_R0 -/sum_f_R0.
    rewrite -minus_n_O plus_0_l ; simpl pred.
    rewrite -?sum_f_rw_0.
    replace (sum_f 0 (S (S n)) (fun p : nat => a p * b (S (S n) - p)%nat))
      with ((sum_f 0 (S (S n)) (fun p : nat => a p * b (S (S n) - p)%nat) -
        (fun p : nat => a p * b (S (S n) - p)%nat) 0%nat)
        + a O * b (S (S n))) by (rewrite -minus_n_O ; ring).
    rewrite -(sum_f_Sn_m _ O (S (S n))) ; [ | by apply lt_O_Sn].
    rewrite sum_f_u_Sk ; [ | by apply le_O_n].
    rewrite sum_f_n_Sm ; [ | by apply le_O_n].
    apply Rle_trans with (sum_f 0 n (fun l0 : nat => a (S (l0 + 0)) * b (S n - l0)%nat) +
      a (S (S n)) * b (S (S n) - S (S n))%nat + a 0%nat * b (S (S n))).
      apply Rminus_le_0 ; ring_simplify.
      apply Rplus_le_le_0_compat ; by apply Rmult_le_pos.
      repeat apply Rplus_le_compat_r.
      apply Req_le.
      rewrite ?sum_f_rw_0.
      elim: {1 4 6}n (le_refl n) => [ | k IH] Hk // ;
      rewrite /sum_f_R0 -/sum_f_R0.
      rewrite IH ; try by intuition.
      apply f_equal.
      by rewrite plus_0_r /=.
    apply Rplus_le_compat.
    apply IH ; intuition.
    rewrite -?sum_f_rw_0.
    rewrite MyNat.sub_succ_l ; try by intuition.
    replace (pred (S (n - S m))) with (n - S m)%nat by auto.
    rewrite plus_Sn_m -?plus_n_Sm.
    replace (sum_f 0 (S (S (S (m + n))))
      (fun p : nat => a p * b (S (S (S (m + n))) - p)%nat))
      with (sum_f 1 (S (S (S (m + n))))
      (fun p : nat => a p * b (S (S (S (m + n))) - p)%nat) + a O * b (S (S (S (m + n))))).
    rewrite -(Rplus_0_r (sum_f O _ _)).
    apply Rplus_le_compat.
    rewrite (sum_f_chasles _ O (S m) (S (S (S (m + n))))) ; try by intuition.
    rewrite -(Rplus_0_l (sum_f O _ _)).
    apply Rplus_le_compat.
    rewrite /sum_f.
    elim: (S m - 1)%nat => {IH} [ | k IH] ; rewrite /sum_f_R0 -/sum_f_R0 //.
    by apply Rmult_le_pos.
    apply Rplus_le_le_0_compat.
    by apply IH.
    by apply Rmult_le_pos.
    replace (S (S m)) with (1 + S m)%nat by ring.
    replace (S (S (S (m + n)))) with (S (S n) + S m )%nat by ring.
    rewrite sum_f_u_add.
    rewrite (sum_f_chasles _ O (S (n - S m)) (S (S n))) ; try by intuition.
    rewrite -(Rplus_0_r (sum_f O _ _)).
    apply Rplus_le_compat.
    rewrite sum_f_u_Sk.
    rewrite ?sum_f_rw_0.
    apply Req_le.
    elim: (n - S m)%nat => {IH} [ | k IH] ; rewrite /sum_f_R0 -/sum_f_R0 //.
    apply f_equal2 ; apply f_equal ; intuition.
    rewrite IH ; apply f_equal, f_equal2 ; apply f_equal.
    ring.
    rewrite ?(Coq.Arith.Plus.plus_comm _ (S m)) -minus_plus_simpl_l_reverse //=.
    apply le_O_n.
    rewrite /sum_f.
    elim: (S (S n) - S (S (n - S m)))%nat => {IH} [ | k IH] ;
    rewrite /sum_f_R0 -/sum_f_R0 //.
    by apply Rmult_le_pos.
    apply Rplus_le_le_0_compat => // ; by apply Rmult_le_pos.
    by apply le_n_S, le_O_n.
    by apply Rmult_le_pos.
    rewrite sum_f_Sn_m -?minus_n_O ; try by intuition.
    ring.
    replace (S (S n)) with (S n + 1)%nat.
    rewrite -minus_plus_simpl_l_reverse.
    simpl; apply minus_n_O.
    now rewrite Coq.Arith.Plus.plus_comm.
    elim: n => [ | n IH] //.
    rewrite -plus_n_Sm plus_Sn_m.
    apply lt_n_S ; intuition.
    have H2 : forall n, sum_f_R0 a (Div2.div2 n)%nat * sum_f_R0 b (Div2.div2 n)%nat <=
      sum_f_R0
      (fun k : nat => sum_f_R0 (fun p : nat => a p * b (k - p)%nat) k)
      n.
      move => n.
      case: (even_odd_cor n) => k ; case => -> {n}.
      rewrite div2_double.
      by apply H1.
      rewrite div2_S_double.
      apply Rle_trans with (1 := H1 _).
      apply Rminus_le_0 ; rewrite -sum_f_rw ; try by intuition.
      rewrite /sum_f minus_diag /sum_f_R0 -/sum_f_R0.
      apply cond_pos_sum => l ; by apply Rmult_le_pos.

    change (is_lim_seq (sum_n (fun n : nat => sum_f_R0 (fun k : nat => a k * b (n - k)%nat) n)) (Finite (la * lb))).
    apply is_lim_seq_le_le with (u := fun n => sum_f_R0 a (Div2.div2 n) * sum_f_R0 b (Div2.div2 n))
    (w := fun n => sum_f_R0 a n * sum_f_R0 b n).
    intros n; rewrite sum_n_Reals.
    by split.
    replace (Finite (la * lb)) with (Rbar_mult la lb) by auto.
    suff H : is_lim_seq
      (fun n : nat => sum_f_R0 a n * sum_f_R0 b n)
      (Rbar_mult la lb).
    apply is_lim_seq_spec in H.
    apply is_lim_seq_spec.
    move => eps.
    case: (H eps) => {H} N H.
    exists (S (2 * N))%nat => n Hn.
    apply H.
    apply le_double.
    apply le_S_n.
    apply le_trans with (1 := Hn).
    apply (Div2.ind_0_1_SS (fun n => (n <= S (2 * Div2.div2 n))%nat)).
    by apply le_O_n.
    by apply le_refl.
    move => k Hk.
    replace (Div2.div2 (S (S k))) with (S (Div2.div2 k)) by auto.
    replace (2 * S (Div2.div2 k))%nat with (S (S (2 * Div2.div2 k))) by ring.
    by repeat apply le_n_S.

    apply is_lim_seq_mult'.
    apply filterlim_ext with (2:=Hla); apply sum_n_Reals.
    apply filterlim_ext with (2:=Hlb); apply sum_n_Reals.
    apply is_lim_seq_mult'.
    apply filterlim_ext with (2:=Hla); apply sum_n_Reals.
    apply filterlim_ext with (2:=Hlb); apply sum_n_Reals.
Qed.

Lemma is_series_mult (a b : nat -> R) (la lb : R) :
  is_series  a la -> is_series  b lb
  -> ex_series  (fun n => Rabs (a n)) -> ex_series  (fun n => Rabs (b n))
  -> is_series  (fun n => sum_f_R0 (fun k => a k * b (n - k)%nat) n) (la * lb).
Proof.
  move => Hla Hlb Ha Hb.

  set ap := fun n => (a n + Rabs (a n)) / 2.
  set am := fun n => - (a n - Rabs (a n)) / 2.
  set bp := fun n => (b n + Rabs (b n)) / 2.
  set bm := fun n => - (b n - Rabs (b n)) / 2.

  have Hap : forall n, 0 <= ap n.
    move => n ; apply Rdiv_le_0_compat.
    rewrite Rplus_comm ; apply Rle_minus_l ; rewrite Rminus_0_l.
    apply Rabs_maj2.
    by apply Rlt_0_2.
  assert (Sap : ex_series  ap).
    apply ex_series_scal_r.
    apply (@ex_series_plus ) => //.
    by exists la.
  have Ham : forall n, 0 <= am n.
    move => n ; apply Rdiv_le_0_compat.
    rewrite Ropp_minus_distr'.
    apply (Rminus_le_0 (a _)).
    by apply Rle_abs.
    by apply Rlt_0_2.
  assert (Sam : ex_series  am).
    apply ex_series_scal_r.
    apply @ex_series_opp.
    apply @ex_series_minus => //.
    by exists la.
  have Hbp : forall n, 0 <= bp n.
    move => n ; apply Rdiv_le_0_compat.
    rewrite Rplus_comm ; apply Rle_minus_l ; rewrite Rminus_0_l.
    apply Rabs_maj2.
    by apply Rlt_0_2.
  assert (Sbp : ex_series  bp).
    apply ex_series_scal_r.
    apply @ex_series_plus => //.
    by exists lb.
  have Hbm : forall n, 0 <= bm n.
    move => n ; apply Rdiv_le_0_compat.
    rewrite Ropp_minus_distr'.
    apply (Rminus_le_0 (b _)).
    by apply Rle_abs.
    by apply Rlt_0_2.
  assert (Sbm : ex_series  bm).
    apply ex_series_scal_r.
    apply @ex_series_opp.
    apply @ex_series_minus => //.
    by exists lb.

  apply is_series_ext with (fun n => sum_f_R0 (fun k : nat => ap k * bp (n - k)%nat) n
    - sum_f_R0 (fun k : nat => am k * bp (n - k)%nat) n
    - sum_f_R0 (fun k : nat => ap k * bm (n - k)%nat) n
    + sum_f_R0 (fun k : nat => am k * bm (n - k)%nat) n).
  move => n.
  rewrite -?minus_sum -plus_sum.
  apply sum_eq => k _.
  rewrite /ap /am /bp /bm ; field.
  replace (la*lb) with ((Series ap*Series bp-Series am*Series bp-Series ap*Series bm)+Series am*Series bm).
  apply @is_series_plus.
  apply @is_series_minus.
  apply @is_series_minus.
  apply is_series_mult_pos => // ; by apply Series_correct.
  apply is_series_mult_pos => // ; by apply Series_correct.
  apply is_series_mult_pos => // ; by apply Series_correct.
  apply is_series_mult_pos => // ; by apply Series_correct.
  replace (la) with (Series ap - Series am).
  replace (lb) with (Series bp - Series bm).
  ring.
  rewrite -Series_minus // -(is_series_unique _ _ Hlb) ; apply Series_ext => n.
  rewrite /ap /am /bp /bm ; field.
  rewrite -Series_minus // -(is_series_unique _ _ Hla) ; apply Series_ext => n.
  rewrite /ap /am /bp /bm ; field.
Qed.
*)


From Coq Require Import OrderedType.
From mathcomp Require Import ssreflect ssrbool eqtype.
From BitBlasting Require Import Typ.
From ssrlib Require Import SsrOrder FMaps Tactics FSets.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* A typing environment is a map from a variable to its type *)
Module Type TypEnv <: SsrFMap.

  Include SsrFMap.

  Definition env : Type := t typ.

  (* The default type of a variable not in the typing environment *)
  Parameter deftyp : typ.

  (* Find the type of a variable in a typing environment.
     If a variable is not in the typing environment, return the default type. *)
  Parameter vtyp : SE.t -> env -> typ.

  (* Return the size of a variable in a typing environment.
     If a variable is not in the typing environment, return the size of the
     default type. *)
  Parameter vsize : SE.t -> env -> nat.

  Axiom find_some_vtyp :
    forall {x : SE.t} {ty : typ} {e : env}, find x e = Some ty -> vtyp x e = ty.
  Axiom find_none_vtyp :
    forall {x : SE.t} {e : env}, find x e = None -> vtyp x e = deftyp.
  Axiom vtyp_find :
    forall {x : SE.t} {ty : typ} {e : env},
      (vtyp x e == ty) = (find x e == Some ty) || ((find x e == None) && (ty == deftyp)).
  Axiom vtyp_add_eq :
    forall {x y : SE.t} {ty : typ} {e : env}, x == y -> vtyp x (add y ty e) = ty.
  Axiom vtyp_add_neq :
    forall {x y : SE.t} {ty : typ} {e : env},
      x != y -> vtyp x (add y ty e) = vtyp x e.
  Axiom vsize_add_eq :
    forall {x y : SE.t} {ty : typ} {e : env},
      x == y -> vsize x (add y ty e) = sizeof_typ ty.
  Axiom vsize_add_neq :
    forall {x y : SE.t} {ty : typ} {e : env},
      x != y -> vsize x (add y ty e) = vsize x e.
  Axiom not_mem_vtyp :
    forall {v : SE.t} {e : env}, ~~ mem v e -> vtyp v e = deftyp.
  Axiom vtyp_vsize :
    forall {x : SE.t} {e : env},
      vsize x e = sizeof_typ (vtyp x e).
  Definition eequal : env -> env -> bool := equal typ_eqn.
  Global Instance add_proper_vtyp : Proper (eq ==> (@Equal typ) ==> eq) vtyp.
  Proof.
    move=> x y ? E1 E2 Heq; subst. case H1: (find y E1); case H2: (find y E2).
    - rewrite (find_some_vtyp H1) (find_some_vtyp H2). rewrite -Heq H1 in H2. by case: H2.
    - rewrite -Heq H1 in H2. discriminate.
    - rewrite -Heq H1 in H2. discriminate.
    - rewrite (find_none_vtyp H1) (find_none_vtyp H2). reflexivity.
  Qed.
  Global Instance add_proper_vsize : Proper (eq ==> (@Equal typ) ==> eq) vsize.
  Proof.
    move=> x y ? E1 E2 Heq; subst. rewrite !vtyp_vsize. rewrite -> Heq. reflexivity.
  Qed.

End TypEnv.

Module TypEnvLemmas (TE : TypEnv).

  Include (FMapLemmas TE).

  Lemma find_same_vtyp E1 E2 x :
    TE.find x E1 = TE.find x E2 -> TE.vtyp x E1 = TE.vtyp x E2.
  Proof.
    move=> Hfind. case Hf2: (TE.find x E2) Hfind => Hf1.
    - rewrite (TE.find_some_vtyp Hf1) (TE.find_some_vtyp Hf2). reflexivity.
    - rewrite (TE.find_none_vtyp Hf1) (TE.find_none_vtyp Hf2). reflexivity.
  Qed.

  Lemma find_same_vsize E1 E2 x :
    TE.find x E1 = TE.find x E2 -> TE.vsize x E1 = TE.vsize x E2.
  Proof.
    move=> Hfind. rewrite !TE.vtyp_vsize. rewrite (find_same_vtyp Hfind). reflexivity.
  Qed.

  Lemma equalP x y : reflect (TE.Equal x y) (TE.equal typ_eqn x y).
  Proof.
    have H: forall e e' : typ, (e =? e')%typ = true <-> e = e'.
    { move=> e1 e2; split; [move/typ_eqP => H | move=> H; apply/typ_eqP]; tauto. }
    case Heq: (TE.equal typ_eqn x y).
    - apply: ReflectT. move: Heq. move/equal_iff. move/(Equal_Equivb H). by apply.
    - apply: ReflectF. move=> Hxy. move/negP: Heq; apply.
      apply/equal_iff. apply/(Equal_Equivb H). assumption.
  Qed.

  Lemma eequalP x y : reflect (TE.Equal x y) (TE.eequal x y).
  Proof. exact: equalP. Qed.

End TypEnvLemmas.

Module MakeTypEnv (V : SsrOrder) (VM : SsrFMap with Module SE := V) <:
  TypEnv with Module SE := V.

  Include VM.
  Module Lemmas := FMapLemmas VM.

  Definition env : Type := t typ.

  (* The default type of a variable not in the typing environment *)
  Definition deftyp : typ := Tuint 0.

  (* Find the type of a variable in a typing environment.
     If a variable is not in the typing environment, return the default type. *)
  Definition vtyp (v : V.t) (e : env) : typ :=
    match VM.find v e with
    | None => deftyp
    | Some ty => ty
    end.

  (* Return the size of a variable in a typing environment.
     If a variable is not in the typing environment, return the size of the
     default type. *)
  Definition vsize (v : V.t) (e : env) : nat := sizeof_typ (vtyp v e).

  Lemma find_some_vtyp {x ty e} : find x e = Some ty -> vtyp x e = ty.
  Proof. move=> H. rewrite /vtyp H. reflexivity. Qed.

  Lemma find_none_vtyp {x e} : find x e = None -> vtyp x e = deftyp.
  Proof. move=> H. rewrite /vtyp H. reflexivity. Qed.

  Lemma vtyp_find {x ty e} :
    (vtyp x e == ty) = (find x e == Some ty) || ((find x e == None) && (ty == deftyp)).
  Proof.
    dcase (find x e); case.
    - move=> a Hfind. rewrite (find_some_vtyp Hfind) /= orbF. case Heq: (a == ty).
      + by rewrite (eqP Heq) eqxx.
      + symmetry. apply/eqP => H. case: H => H. rewrite H eqxx in Heq. discriminate.
    - move=> Hnone. rewrite (find_none_vtyp Hnone) eqxx /=. rewrite eq_sym.
      reflexivity.
  Qed.

  Lemma vtyp_add_eq {x y ty e} : x == y -> vtyp x (add y ty e) = ty.
  Proof. rewrite /vtyp /add => H. by rewrite (Lemmas.find_add_eq H). Qed.

  Lemma vtyp_add_neq {x y ty e} : x != y -> vtyp x (add y ty e) = vtyp x e.
  Proof.
    move/negP=> Hxy. rewrite /vtyp /add. by rewrite (Lemmas.find_add_neq Hxy).
  Qed.

  Lemma vsize_add_eq {x y ty e} : x == y -> vsize x (add y ty e) = sizeof_typ ty.
  Proof. rewrite /vsize=> H. by rewrite (vtyp_add_eq H). Qed.

  Lemma vsize_add_neq {x y ty e} : x != y -> vsize x (add y ty e) = vsize x e.
  Proof. rewrite /vsize => H. by rewrite (vtyp_add_neq H). Qed.

  Lemma not_mem_vtyp v e : ~~ mem v e -> vtyp v e = deftyp.
  Proof. rewrite /vtyp => H. by rewrite Lemmas.not_mem_find_none. Qed.

  Lemma vtyp_vsize x e : vsize x e = sizeof_typ (vtyp x e).
  Proof. reflexivity. Qed.

  Definition eequal := equal typ_eqn.

  Global Instance add_proper_vtyp : Proper (eq ==> (@Equal typ) ==> eq) vtyp.
  Proof.
    move=> x y ? E1 E2 Heq; subst. rewrite /vtyp. rewrite Heq. reflexivity.
  Qed.

  Global Instance add_proper_vsize : Proper (eq ==> (@Equal typ) ==> eq) vsize.
  Proof.
    move=> x y ? E1 E2 Heq; subst. rewrite /vsize. rewrite Heq. reflexivity.
  Qed.

End MakeTypEnv.

From ssrlib Require Import Var.

Module TE <: TypEnv := MakeTypEnv VarOrder VM.
Module SSATE <: TypEnv := MakeTypEnv SSAVarOrder SSAVM.

Module TypEnvAgree
       (V : SsrOrder)
       (TE : TypEnv with Module SE := V)
       (VS : SsrFSet with Module SE := V).

  Module MA := MapAgree V TE VS.
  Include MA.

  Lemma agree_mem v vs (E1 E2 : TE.env) :
    agree vs E1 E2 -> VS.mem v vs -> TE.mem v E1 = TE.mem v E2.
  Proof.
    move=> Hag Hmem. move: (Hag _ Hmem).
    rewrite VMLemmas.F.mem_find_b. move=> ->.
    rewrite -VMLemmas.F.mem_find_b. reflexivity.
  Qed.

  Lemma agree_mem_singleton v (E1 E2 : TE.env) :
    agree (VS.singleton v) E1 E2 -> TE.mem v E1 = TE.mem v E2.
  Proof.
    move=> Hag. apply: (agree_mem Hag). apply: VSLemmas.mem_singleton2.
    exact: eqxx.
  Qed.

  Lemma agree_vtyp v vs (E1 E2 : TE.env) :
    agree vs E1 E2 -> VS.mem v vs -> TE.vtyp v E1 = TE.vtyp v E2.
  Proof.
    move=> Hag Hmem. move: (Hag _ Hmem) => Hfind.
    case Hf: (TE.find v E2).
    - rewrite Hf in Hfind. rewrite (TE.find_some_vtyp Hf) (TE.find_some_vtyp Hfind).
      reflexivity.
    - rewrite Hf in Hfind. rewrite (TE.find_none_vtyp Hf) (TE.find_none_vtyp Hfind).
      reflexivity.
  Qed.

  Lemma agree_vtyp_singleton v (E1 E2 : TE.env) :
    agree (VS.singleton v) E1 E2 -> TE.vtyp v E1 = TE.vtyp v E2.
  Proof.
    move=> Hag. apply: (agree_vtyp Hag). apply: VSLemmas.mem_singleton2.
    exact: eqxx.
  Qed.

  Lemma agree_vsize v vs (E1 E2 : TE.env) :
    agree vs E1 E2 -> VS.mem v vs -> TE.vsize v E1 = TE.vsize v E2.
  Proof.
    move=> Hag Hmem. rewrite !TE.vtyp_vsize. rewrite (agree_vtyp Hag Hmem). reflexivity.
  Qed.

  Lemma agree_vsize_singleton v (E1 E2 : TE.env) :
    agree (VS.singleton v) E1 E2 -> TE.vsize v E1 = TE.vsize v E2.
  Proof.
    move=> Hag. rewrite !TE.vtyp_vsize. rewrite (agree_vtyp_singleton Hag). reflexivity.
  Qed.

End TypEnvAgree.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require int.Abs.
Require int.EuclideanDivision.

(* Why3 assumption *)
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.
Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.
Implicit Arguments old.

(* Why3 assumption *)
Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

(* Why3 assumption *)
Inductive term  :=
  | S : term
  | K : term
  | App : term -> term -> term .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_value(t:term) {struct t}: Prop :=
  match t with
  | (K|S) => True
  | ((App K v)|(App S v)) => (is_value v)
  | (App (App S v1) v2) => (is_value v1) /\ (is_value v2)
  | _ => False
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive context  :=
  | Hole : context
  | Left : context -> term -> context
  | Right : term -> context -> context .

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint is_context(c:context) {struct c}: Prop :=
  match c with
  | Hole => True
  | (Left c1 _) => (is_context c1)
  | (Right v c1) => (is_value v) /\ (is_context c1)
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint subst(c:context) (t:term) {struct c}: term :=
  match c with
  | Hole => t
  | (Left c1 t2) => (App (subst c1 t) t2)
  | (Right v1 c2) => (App v1 (subst c2 t))
  end.
Unset Implicit Arguments.

(* Why3 assumption *)
Inductive infix_mnmngt : term -> term -> Prop :=
  | red_K : forall (c:context), (is_context c) -> forall (v1:term) (v2:term),
      (is_value v1) -> ((is_value v2) -> (infix_mnmngt (subst c (App (App K
      v1) v2)) (subst c v1)))
  | red_S : forall (c:context), (is_context c) -> forall (v1:term) (v2:term)
      (v3:term), (is_value v1) -> ((is_value v2) -> ((is_value v3) ->
      (infix_mnmngt (subst c (App (App (App S v1) v2) v3)) (subst c
      (App (App v1 v3) (App v2 v3)))))).

Axiom red_left : forall (t1:term) (t2:term) (t:term), (infix_mnmngt t1 t2) ->
  (infix_mnmngt (App t1 t) (App t2 t)).

Axiom red_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((infix_mnmngt t1 t2) -> (infix_mnmngt (App v t1) (App v t2))).

(* Why3 assumption *)
Inductive relTR : term -> term -> Prop :=
  | BaseTransRefl : forall (x:term), (relTR x x)
  | StepTransRefl : forall (x:term) (y:term) (z:term), (relTR x y) ->
      ((infix_mnmngt y z) -> (relTR x z)).

Axiom relTR_transitive : forall (x:term) (y:term) (z:term), (relTR x y) ->
  ((relTR y z) -> (relTR x z)).

Axiom red_star_left : forall (t1:term) (t2:term) (t:term), (relTR t1 t2) ->
  (relTR (App t1 t) (App t2 t)).

Axiom red_star_right : forall (v:term) (t1:term) (t2:term), (is_value v) ->
  ((relTR t1 t2) -> (relTR (App v t1) (App v t2))).

Axiom reducible_or_value : forall (t:term), (exists tqt:term, (infix_mnmngt t
  tqt)) \/ (is_value t).

(* Why3 assumption *)
Definition irreducible(t:term): Prop := forall (tqt:term), ~ (infix_mnmngt t
  tqt).

Axiom irreducible_is_value : forall (t:term), (irreducible t) <->
  (is_value t).

(* Why3 assumption *)
Inductive only_K : term -> Prop :=
  | only_K_K : (only_K K)
  | only_K_App : forall (t1:term) (t2:term), (only_K t1) -> ((only_K t2) ->
      (only_K (App t1 t2))).

Axiom only_K_reduces : forall (t:term), (only_K t) -> exists v:term, (relTR t
  v) /\ ((is_value v) /\ (only_K v)).

(* Why3 assumption *)
Set Implicit Arguments.
Fixpoint size(t:term) {struct t}: Z :=
  match t with
  | (K|S) => 0%Z
  | (App t1 t2) => ((1%Z + (size t1))%Z + (size t2))%Z
  end.
Unset Implicit Arguments.

Axiom size_nonneg : forall (t:term), (0%Z <= (size t))%Z.

Parameter ks: Z -> term.

Axiom ksO : ((ks 0%Z) = K).

Axiom ksS : forall (n:Z), (0%Z <= n)%Z -> ((ks (n + 1%Z)%Z) = (App (ks n)
  K)).

Axiom ks1 : ((ks 1%Z) = (App K K)).

Axiom only_K_ks : forall (n:Z), (0%Z <= n)%Z -> (only_K (ks n)).

Axiom ks_value : forall (n:Z), (0%Z <= n)%Z -> ((is_value (ks n)) ->
  ((0%Z <= n)%Z /\ (n <= 1%Z)%Z)).

Hint Constructors relTR.
Hint Constructors infix_mnmngt.

(* Why3 goal *)
Theorem ks_even_odd : forall (n:Z), (0%Z <= n)%Z -> ((relTR (ks (2%Z * n)%Z)
  K) /\ (relTR (ks ((2%Z * n)%Z + 1%Z)%Z) (App K K))).
intros n hn; pattern n; apply natlike_ind; intuition.
(* 2*0 *)
simpl.
rewrite ksO; auto.
(* 2*0+1 *)
rewrite ksS; try omega.
simpl.
rewrite ksO; auto.
(* 2*(x+1) *)
replace (2 * Zsucc x)%Z with ((2*x+1)+1)%Z by omega.
rewrite ksS; try omega.
apply StepTransRefl with (App (App K K) K); auto.
apply red_star_left; auto.
apply (red_K Hole); simpl; auto.
(* 2*(x+1)+1 *)
rewrite ksS; try omega.
replace (2 * Zsucc x)%Z with ((2*x+1)+1)%Z by omega.
rewrite ksS; try omega.
apply red_star_left.
apply StepTransRefl with (App (App K K) K); auto.
apply red_star_left; auto.
apply (red_K Hole); simpl; auto.
Qed.


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

Set Implicit Arguments.

From Bignums Require Import DoubleBase DoubleSub DoubleMul DoubleSqrt DoubleLift DoubleDivn1 DoubleDiv.
From Bignums Require Import DoubleCyclic BigN.
Require Import CyclicAxioms Cyclic31.
Require Import ZArith ZCAux.
Import CyclicAxioms DoubleType DoubleBase.

Theorem Zpos_pos: forall x, 0 < Zpos x.
red; simpl; auto.
Qed.
Hint Resolve Zpos_pos: zarith.

Section Mod_op.

 Variable w : Type.

 Record mod_op : Type := mk_mod_op {
   succ_mod   : w -> w;
   add_mod    : w -> w -> w;
   pred_mod   : w -> w;
   sub_mod    : w -> w -> w;
   mul_mod    : w -> w -> w;
   square_mod : w -> w;
   power_mod  : w -> positive -> w
 }.

 Variable w_op : ZnZ.Ops w.

 Let w_digits      := w_op.(ZnZ.digits).
 Let w_zdigits     := w_op.(ZnZ.zdigits).
 Let w_to_Z        := (@ZnZ.to_Z _ w_op).
 Let w_of_pos      := (@ZnZ.of_pos _ w_op).
 Let w_head0       := (@ZnZ.head0 _ w_op).
 Let w0            := (@ZnZ.zero _ w_op).
 Let w1            := (@ZnZ.one _ w_op).
 Let wBm1          := (@ZnZ.minus_one _ w_op).

 Let wWW           := (@ZnZ.WW _ w_op).
 Let wW0           := (@ZnZ.WO _ w_op).
 Let w0W           := (@ZnZ.OW _ w_op).

 Let w_compare     := (@ZnZ.compare _ w_op).
 Let w_opp_c       := (@ZnZ.opp_c _ w_op).
 Let w_opp         := (@ZnZ.opp _ w_op).
 Let w_opp_carry   := (@ZnZ.opp_carry _ w_op).

 Let w_succ        := (@ZnZ.succ _ w_op).
 Let w_succ_c      := (@ZnZ.succ_c _ w_op).
 Let w_add_c       := (@ZnZ.add_c _ w_op).
 Let w_add_carry_c := (@ZnZ.add_carry_c _ w_op).
 Let w_add         := (@ZnZ.add _ w_op).

 Let w_pred_c      := (@ZnZ.pred_c _ w_op).
 Let w_sub_c       := (@ZnZ.sub_c _ w_op).
 Let w_sub_carry   := (@ZnZ.sub_carry _ w_op).
 Let w_sub_carry_c := (@ZnZ.sub_carry_c _ w_op).
 Let w_sub         := (@ZnZ.sub _ w_op).
 Let w_pred        := (@ZnZ.pred _ w_op).

 Let w_mul_c       := (@ZnZ.mul_c _ w_op).
 Let w_mul         := (@ZnZ.mul _ w_op).
 Let w_square_c    := (@ZnZ.square_c _ w_op).

 Let w_div21       := (@ZnZ.div21 _ w_op).
 Let w_add_mul_div := (@ZnZ.add_mul_div _ w_op).

 Variable b : w.
    (* b should be > 1 *)
 Let n := w_head0 b.

 Let b2n := w_add_mul_div n b w0.

 Let bm1 := w_sub b w1.

 Let mb := w_opp b.

 Let wwb := WW w0 b.

 Let low x := match x with WW _ x => x | W0 => w0 end.

 Let w_add2 x y := match w_add_c x y with
                     C0 n => WW w0 n
                    |C1 n => WW w1 n
                    end.
 Let ww_zdigits := w_add2 w_zdigits w_zdigits.

 Let ww_compare :=
  Eval lazy beta delta [ww_compare] in ww_compare w0 w_compare.

 Let ww_sub :=
 Eval lazy beta delta [ww_sub] in
   ww_sub w0 wWW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry.

 Let ww_add_mul_div :=
 Eval lazy beta delta [ww_add_mul_div] in
   ww_add_mul_div w0 wWW wW0 w0W
              ww_compare w_add_mul_div
              ww_sub w_zdigits low (w0W n).

 Let ww_lsl_n :=
   Eval lazy beta delta [ww_add_mul_div] in
    fun ww => ww_add_mul_div  ww W0.

 Let w_lsr_n w :=
     w_add_mul_div (w_sub w_zdigits n) w0 w.

 Open Scope Z_scope.
 Notation "[| x |]" :=
   (@ZnZ.to_Z _ w_op x)  (at level 0, x at level 99).

Notation "[[ x ]]" :=
   (@ww_to_Z _ w_digits w_to_Z x)  (at level 0, x at level 99).

 Section Mod_spec.

   Variable m_op : mod_op.

   Record mod_spec : Prop := mk_mod_spec {
      succ_mod_spec     :
                forall w t, [|w|]= t mod [|b|] ->
                          [|succ_mod m_op w|] = ([|w|] + 1) mod [|b|];
      add_mod_spec      :
            forall w1 w2 t1 t2, [|w1|]= t1 mod [|b|] -> [|w2|]= t2 mod [|b|] ->
                          [|add_mod m_op w1 w2|] = ([|w1|] + [|w2|]) mod [|b|];
      pred_mod_spec     :
                forall w t, [|w|]= t mod [|b|] ->
                          [|pred_mod m_op w|] = ([|w|] - 1) mod [|b|];
      sub_mod_spec      :
            forall w1 w2 t1 t2, [|w1|]= t1 mod [|b|] -> [|w2|]= t2 mod [|b|] ->
                          [|sub_mod m_op w1 w2|] = ([|w1|] - [|w2|]) mod [|b|];
      mul_mod_spec      :
            forall w1 w2 t1 t2, [|w1|]= t1 mod [|b|] -> [|w2|]= t2 mod [|b|] ->
                          [|mul_mod m_op w1 w2|] = ([|w1|] * [|w2|]) mod [|b|];
      square_mod_spec   :
                forall w t, [|w|]= t mod [|b|] ->
                          [|square_mod m_op w|] = ([|w|] * [|w|]) mod [|b|];
      power_mod_spec    :
              forall w t p, [|w|]= t mod [|b|] ->
                          [|power_mod m_op w p|] = (Zpower_pos [|w|] p) mod [|b|]
(*
      shift_spec        :
              forall w p, wf w ->
                          [|shift m_op w p|] = ([|w|] / (Zpower_pos 2 p)) mod [|b|];
      trunc_spec        :
              forall w p, wf w ->
                          [|power_mod m_op w p|] = ([|w1|] mod (Zpower_pos 2 p)) mod [|b|]
*)
    }.

  End Mod_spec.

 Hypothesis b_pos: 1 < [|b|].
 Variable op_spec: ZnZ.Specs w_op.

 Lemma Zpower_n: 0 < 2 ^ [|n|].
 apply Zpower_gt_0; auto with zarith.
 case (ZnZ.spec_to_Z n); auto with zarith.
 Qed.

 Hint Resolve Zpower_n Zmult_lt_0_compat Zpower_gt_0.

 Variable m_op : mod_op.

 Hint Rewrite
    ZnZ.spec_0
    ZnZ.spec_1
    ZnZ.spec_m1
    ZnZ.spec_WW
    ZnZ.spec_opp_c
    ZnZ.spec_opp
    ZnZ.spec_opp_carry
    ZnZ.spec_succ_c
    ZnZ.spec_add_c
    ZnZ.spec_add_carry_c
    ZnZ.spec_add
    ZnZ.spec_pred_c
    ZnZ.spec_sub_c
    ZnZ.spec_sub_carry_c
    ZnZ.spec_sub
    ZnZ.spec_mul_c
    ZnZ.spec_mul
    : w_rewrite.

 Let _succ_mod x :=
  let res :=w_succ x in
  match w_compare res b with
  | Lt => res
  | _ => w0
  end.

 Let split x :=
  match x with
  | W0 => (w0,w0)
  | WW h l => (h,l)
  end.

 Let _w0_is_0: [|w0|] = 0.
 unfold ZnZ.to_Z; rewrite <- ZnZ.spec_0; auto.
 Qed.

 Let _w1_is_1: [|w1|] = 1.
 unfold ZnZ.to_Z; rewrite <-ZnZ.spec_1; simpl; auto.
 Qed.

 Theorem Zmod_plus_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1.
 intros a1 b1 H; rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_same; try rewrite Zplus_0_r; auto with zarith.
 apply Zmod_mod; auto.
 Qed.

 Theorem Zmod_minus_one: forall a1 b1, 0 < b1 -> (a1 - b1) mod b1 = a1 mod b1.
 intros a1 b1 H; rewrite Zminus_mod; auto with zarith.
 rewrite Z_mod_same; try rewrite Zminus_0_r; auto with zarith.
 apply Zmod_mod; auto.
 Qed.

 Lemma without_c_b: forall w2, [|w2|] < [|b|] ->
    [|w_succ w2|] = [|w2|] + 1.
 intros w2 H.
 unfold w_succ;rewrite ZnZ.spec_succ.
 rewrite Zmod_small;auto.
 assert (HH := ZnZ.spec_to_Z w2).
 assert (HH' := ZnZ.spec_to_Z b);auto with zarith.
 Qed.

 Lemma _succ_mod_spec: forall w t, [|w|]= t mod [|b|] ->
    [|_succ_mod w|] = ([|w|] + 1) mod [|b|].
 intros w2 t H; unfold _succ_mod, w_compare; simpl.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 rewrite ZnZ.spec_compare; case Z.compare_spec; intros H1;
 match goal with H: context[w_succ _] |- _ =>
   generalize H; clear H; rewrite (without_c_b _ F); intros H1;
   auto with zarith
 end.
 rewrite H1, Z_mod_same, _w0_is_0; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 Qed.

 Let _add_mod x y :=
  match w_add_c x y with
  | C0 z =>
    match w_compare z b with
    | Lt => z
    | Eq => w0
    | Gt => w_sub z b
    end
  | C1 z => w_add mb z
  end.

 Lemma _add_mod_correct: forall w1 w2, [|w1|] + [|w2|] < 2 * [|b|] ->
     [|_add_mod w1 w2|] = ([|w1|] + [|w2|]) mod [|b|].
 intros w2 w3; unfold _add_mod, w_compare, w_add_c; intros H.
 match goal with |- context[ZnZ.add_c ?x ?y] =>
   generalize (ZnZ.spec_add_c x y); unfold interp_carry;
   case (ZnZ.add_c x y); autorewrite with w_rewrite
 end; auto with zarith.
 intros w4 H2.
 rewrite ZnZ.spec_compare; case Z.compare_spec; intros H1;
 match goal with H: context[b] |- _ =>
   generalize H; clear H; intros H1; rewrite <-H2;
   auto with zarith
 end.
 rewrite H1, Z_mod_same; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z w4); auto with zarith.
 assert (F1: 0 < [|w4|] - [|b|]); auto with zarith.
 assert (F2: [|w4|] < [|b|] + [|b|]); auto with zarith.
 autorewrite with w_rewrite; auto.
 rewrite (fun x y => Zmod_small (x - y)); auto with zarith.
 rewrite <- (Zmod_minus_one [|w4|]); auto with zarith.
 apply sym_equal; apply Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Z.lt_trans with [|b|]; auto with zarith.
 case (ZnZ.spec_to_Z b); unfold base; auto with zarith.
 rewrite Zmult_1_l; intros w4 H2; rewrite <- H2.
 unfold mb, w_add; rewrite ZnZ.spec_add; auto with zarith.
 assert (F1: [|w4|] < [|b|]).
 assert (F2: base (ZnZ.digits w_op) + [|w4|] < base (ZnZ.digits w_op) + [|b|]);
   auto with zarith.
 rewrite H2.
 apply Z.lt_trans with ([|b|] +[|b|]); auto with zarith.
 apply Zplus_lt_compat_r; auto with zarith.
 case (ZnZ.spec_to_Z b); auto with zarith.
 assert (F2: [|b|] < base (ZnZ.digits w_op) + [|w4|]); auto with zarith.
 apply Z.lt_le_trans with (base (ZnZ.digits w_op)); auto with zarith.
 case (ZnZ.spec_to_Z b); auto with zarith.
 case (ZnZ.spec_to_Z w4); auto with zarith.
 assert (F3: base (ZnZ.digits w_op) + [|w4|] < [|b|] + [|b|]); auto with zarith.
 rewrite <- (fun x => Zmod_minus_one (base x + [|w4|])); auto with zarith.
 rewrite (fun x y => Zmod_small (x - y)); auto with zarith.
 unfold w_opp;rewrite (ZnZ.spec_opp b).
 rewrite <- (fun x => Zmod_plus_one (-x)); auto with zarith.
 rewrite (Zmod_small (- [|b|] + base (ZnZ.digits w_op)));auto with zarith.
 2 : assert (HHH := ZnZ.spec_to_Z b);auto with zarith.
 repeat rewrite Zmod_small; auto with zarith.
 Qed.

 Lemma _add_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
     [|_add_mod w1 w2|] = ([|w1|] + [|w2|]) mod [|b|].
 intros w2 w3 t1 t2 H H1.
 apply _add_mod_correct; auto with zarith.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 assert (tmp: forall x, 2 * x = x + x); auto with zarith.
 Qed.

 Let _pred_mod x :=
  match w_compare w0 x with
  | Eq => bm1
  | _ => w_pred x
  end.

 Lemma _pred_mod_spec: forall w t, [|w|] = t mod [|b|] ->
   [|_pred_mod w|] = ([|w|] - 1) mod [|b|].
 intros w2 t H; unfold _pred_mod, w_compare, bm1; simpl.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 rewrite ZnZ.spec_compare; case Z.compare_spec; intros H1;
 match goal with H: context[w2] |- _ =>
   generalize H; clear H; intros H1; autorewrite with w_rewrite;
   auto with zarith
 end; try rewrite _w0_is_0; try rewrite _w1_is_1; auto with zarith.
 rewrite <- H1, _w0_is_0; simpl.
 rewrite <- (Zmod_plus_one (-1)); auto with zarith.
 repeat rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z b); auto with zarith.
 unfold w_pred;rewrite ZnZ.spec_pred; auto.
 assert (HHH := ZnZ.spec_to_Z b);repeat rewrite Zmod_small;auto with
 zarith.
 intros;assert (HHH := ZnZ.spec_to_Z w2);auto with zarith.
 Qed.

 Let _sub_mod x y :=
  match w_sub_c x y with
  | C0 z => z
  | C1 z => w_add z b
  end.

 Lemma _sub_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
   [|_sub_mod w1 w2|] = ([|w1|] - [|w2|]) mod [|b|].
 intros w2 w3 t1 t2; unfold _sub_mod, w_compare, w_sub_c; intros H H1.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[ZnZ.sub_c ?x ?y] =>
   generalize (ZnZ.spec_sub_c x y); unfold interp_carry;
   case (ZnZ.sub_c x y); autorewrite with w_rewrite
 end; auto with zarith.
 intros w4 H2.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 rewrite <- H2; case (ZnZ.spec_to_Z w4); auto with zarith.
 apply Z.le_lt_trans with [|w2|]; auto with zarith.
 case (ZnZ.spec_to_Z w3); auto with zarith.
 intros w4 H2; rewrite <- H2.
 unfold w_add; rewrite ZnZ.spec_add; auto with zarith.
 case (ZnZ.spec_to_Z w4); intros F1 F2.
 assert (F3: 0 <= - 1 *  base (ZnZ.digits w_op) + [|w4|] + [|b|]); auto with zarith.
 rewrite H2.
 case (ZnZ.spec_to_Z w3); case (ZnZ.spec_to_Z w2); auto with zarith.
 rewrite <- (fun x => Zmod_minus_one ([|w4|] + x)); auto with zarith.
 rewrite <- (fun x y => Zmod_plus_one (-y + x)); auto with zarith.
 repeat rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z b); auto with zarith.
 Qed.

 Let _mul_mod x y :=
  let xy := w_mul_c x y in
  match ww_compare xy wwb with
  | Lt => snd (split xy)
  | Eq => w0
  | Gt =>
    let xy2n := ww_lsl_n xy in
    let (h,l) := split xy2n in
    let (q,r) := w_div21 h l b2n in
    w_lsr_n r
  end.

 Theorem high_zero:forall x, [[x]] < base w_digits -> [|fst (split x)|] = 0.
  intros x; case x; simpl; auto.
 intros xh xl H; case (Zle_lt_or_eq 0 [|xh|]); auto with zarith.
 case (ZnZ.spec_to_Z xh); auto with zarith.
 intros H1; contradict H; apply Zle_not_lt.
 assert (HHHH := wB_pos w_digits).
 unfold w_to_Z.
 match goal with |- ?X <= ?Y + ?Z =>
  pattern X at 1; rewrite <- (Zmult_1_l X); auto with zarith;
  apply Z.le_trans with Y; auto with zarith
 end.
 case (ZnZ.spec_to_Z xl); auto with zarith.
 Qed.

 Theorem n_spec: base (ZnZ.digits w_op) / 2 <= 2 ^ [|n|] * [|b|]
                        < base (ZnZ.digits w_op).
 unfold n, w_head0; apply (ZnZ.spec_head0); auto with zarith.
 Qed.

 Theorem b2n_spec: [|b2n|] = 2 ^ [|n|] * [|b|].
 unfold b2n, w_add_mul_div; case n_spec; intros Hp Hp1.
 assert (F1: [|n|] < Zpos (ZnZ.digits w_op)).
 case (Zle_or_lt (Zpos (ZnZ.digits w_op)) [|n|]); auto with zarith.
 intros H1; contradict Hp1; apply Zle_not_lt; unfold base.
 apply Z.le_trans with (2 ^ [|n|] * 1); auto with zarith.
 rewrite Zmult_1_r; apply Zpower_le_monotone; auto with zarith.
 rewrite ZnZ.spec_add_mul_div; auto with zarith.
 rewrite _w0_is_0; rewrite Zdiv_0_l; auto with zarith.
 rewrite Zplus_0_r; rewrite Zmult_comm; apply Zmod_small; auto with zarith.
 Qed.

 Theorem ww_lsl_n_spec: forall w, [[w]] < [|b|] * [|b|] ->
   [[ww_lsl_n w]] = 2 ^ [|n|] * [[w]].
 intros w2 H; unfold ww_lsl_n.
 case n_spec; intros Hp Hp1.
 assert (F0: forall x, 2 * x = x + x); auto with zarith.
 assert (F1: [|n|] < Zpos (ZnZ.digits w_op)).
 case (Zle_or_lt (Zpos (ZnZ.digits w_op)) [|n|]); auto.
 intros H1; contradict Hp1; apply Zle_not_lt; unfold base.
 apply Z.le_trans with (2 ^ [|n|] * 1); auto with zarith.
 rewrite Zmult_1_r; apply Zpower_le_monotone; auto with zarith.
 assert (F2: [|n|] < Zpos (xO (ZnZ.digits w_op))).
 rewrite (Zpos_xO (ZnZ.digits w_op)); rewrite F0; auto with zarith.
 pattern [|n|]; rewrite <- Zplus_0_r; auto with zarith.
 apply Zplus_lt_compat; auto with zarith.
 change
  ([[DoubleLift.ww_add_mul_div w0 wWW wW0 w0W
              ww_compare w_add_mul_div
              ww_sub w_zdigits low (w0W n) w2 W0]] = 2 ^ [|n|] * [[w2]]).
 rewrite (DoubleLift.spec_ww_add_mul_div ); auto with zarith.
 2: apply ZnZ.spec_to_Z; auto.
 2: refine (spec_ww_to_Z _ _ _); auto.
 2: apply ZnZ.spec_to_Z; auto.
 2: apply ZnZ.spec_WW; auto.
 2: apply ZnZ.spec_WO; auto.
 2: apply ZnZ.spec_OW; auto.
 2: refine (spec_ww_compare _ _ _ _ _ _ _); auto.
 2: apply ZnZ.spec_to_Z; auto.
 2: apply ZnZ.spec_compare; auto.
 2: apply ZnZ.spec_add_mul_div; auto.
 2: refine (spec_ww_sub _ _ _ _ _ _ _ _ _ _
                _ _ _ _ _ _ _ _ _ _ _); auto.
 2: apply ZnZ.spec_to_Z; auto.
 2: apply ZnZ.spec_WW; auto.
 2: apply ZnZ.spec_opp_c; auto.
 2: apply ZnZ.spec_opp; auto.
 2: apply ZnZ.spec_opp_carry; auto.
 2: apply ZnZ.spec_sub_c; auto.
 2: apply ZnZ.spec_sub; auto.
 2: apply ZnZ.spec_sub_carry; auto.
 2: apply ZnZ.spec_zdigits; auto.
 replace ([[w0W n]]) with  [|n|].
 change [[W0]] with 0. rewrite Zdiv_0_l; auto with zarith.
 rewrite Zplus_0_r; rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 case spec_ww_to_Z with (w_digits := w_digits) (w_to_Z := w_to_Z) (x:=w2); auto with zarith.
 apply ZnZ.spec_to_Z; auto.
 apply Z.lt_trans with ([|b|] * [|b|] * 2 ^ [|n|]); auto with zarith.
 apply Zmult_lt_compat_r; auto with zarith.
 rewrite <- Zmult_assoc.
 unfold base; unfold base in Hp.
 unfold ww_digits,w_digits;rewrite (Zpos_xO (ZnZ.digits w_op)); rewrite F0; auto with zarith.
 rewrite Zpower_exp; auto with zarith.
 apply Zmult_lt_compat; auto with zarith.
 case (ZnZ.spec_to_Z b); auto with zarith.
 split; auto with zarith.
 rewrite Zmult_comm; auto with zarith.
 unfold w_digits;auto with zarith.
 generalize (ZnZ.spec_OW n).
 unfold ww_to_Z, w_digits; auto.
 intros x; case x; simpl.
 unfold w_to_Z, w_digits, w0; rewrite ZnZ.spec_0; auto.
 intros w3 w4; rewrite Zplus_comm.
 rewrite Z_mod_plus; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z w4); auto with zarith.
 unfold base; auto with zarith.
 unfold ww_to_Z, w_digits, w_to_Z, w0W; auto.
 rewrite ZnZ.spec_OW; auto with zarith.
 Qed.

 Theorem w_lsr_n_spec: forall w, [|w|] < 2 ^ [|n|] *  [|b|]->
   [|w_lsr_n w|] = [|w|] / 2 ^ [|n|].
 intros w2 H.
 case (ZnZ.spec_to_Z w2); intros U1 U2.
 unfold w_lsr_n, w_add_mul_div.
 rewrite ZnZ.spec_add_mul_div; auto with zarith.
 rewrite _w0_is_0; rewrite Zmult_0_l; auto with zarith.
 rewrite Zplus_0_l.
 autorewrite with w_rewrite; auto.
 rewrite (fun x y => Zmod_small (x - y)); auto with zarith.
 unfold w_zdigits; rewrite ZnZ.spec_zdigits; auto.
 assert (tmp: forall p q, p - (p - q) = q); intros; try ring;
  rewrite tmp; clear tmp; auto.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Z.le_lt_trans with (2 := U2); auto with zarith.
 apply Zdiv_le_upper_bound; auto with zarith.
 apply Z.le_trans with ([|w2|] * (2 ^ 0)); auto with zarith.
 simpl Zpower; rewrite Zmult_1_r; auto with zarith.
 apply Zmult_le_compat_l; auto with zarith.
 apply Zpower_le_monotone; auto with zarith.
 case (ZnZ.spec_to_Z n); auto with zarith.
 unfold n.
 assert (HH: 0 < [|b|]); auto with zarith.
 split.
   case (Zle_or_lt [|w_head0 b|] [|w_zdigits|]); auto with zarith.
   unfold w_zdigits; rewrite ZnZ.spec_zdigits; auto; intros H1.
   case (ZnZ.spec_head0 b HH); intros _ H2; contradict H2.
   apply Zle_not_lt; unfold base.
   apply Z.le_trans with (2^[|ZnZ.head0 b|] * 1); auto with zarith.
   rewrite Zmult_1_r; apply Zpower_le_monotone; auto with zarith.
 unfold w_zdigits; rewrite ZnZ.spec_zdigits; auto.
 apply Z.le_lt_trans with (Zpos (ZnZ.digits w_op)); auto with zarith.
    case (ZnZ.spec_to_Z (w_head0 b)); auto with zarith.
 unfold base; apply Zpower2_lt_lin; auto with zarith.
 autorewrite with w_rewrite; auto.
 rewrite Zmod_small; auto with zarith.
 unfold w_zdigits; rewrite ZnZ.spec_zdigits; auto with zarith.
 case (ZnZ.spec_to_Z n); auto with zarith.
 unfold w_zdigits; rewrite ZnZ.spec_zdigits; auto.
 split; auto with zarith.
 case (Zle_or_lt [|n|] (Zpos (ZnZ.digits w_op))); auto with zarith; intros H1.
 case (ZnZ.spec_head0 b); auto with zarith; intros _ H2.
 contradict H2; apply Zle_not_lt; auto with zarith.
 unfold base; apply Z.le_trans with (2 ^ [|ZnZ.head0 b|] * 1);
   auto with zarith.
 rewrite Zmult_1_r; unfold base; apply Zpower_le_monotone; auto with zarith.
 apply Z.le_lt_trans with (Zpos (ZnZ.digits w_op)); auto with zarith.
 case (ZnZ.spec_to_Z n); auto with zarith.
 unfold base; apply Zpower2_lt_lin; auto with zarith.
 Qed.

 Lemma split_correct: forall x, let (xh, xl) := split x in [[WW xh xl]] = [[x]].
 intros x; case x; simpl; unfold w0, w_to_Z;try rewrite ZnZ.spec_0; auto with zarith.
 Qed.

 Lemma _mul_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
   [|_mul_mod w1 w2|] = ([|w1|] * [|w2|]) mod [|b|].
 intros w2 w3 t1 t2 H H1; unfold _mul_mod, wwb.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[ww_compare ?x ?y] =>
   change (ww_compare x y) with (DoubleBase.ww_compare w0 w_compare x y)
 end.
 rewrite (@spec_ww_compare w w0 w_digits w_to_Z w_compare
    ZnZ.spec_0 ZnZ.spec_to_Z ZnZ.spec_compare
    (w_mul_c w2 w3) (WW w0 b)); case Z.compare_spec; intros H2;
 match goal with H: context[w_mul_c] |- _ =>
   generalize H; clear H
 end; try rewrite _w0_is_0; try rewrite !_w1_is_1; auto with zarith.
 unfold w_mul_c, ww_to_Z, w_to_Z, w_digits; rewrite ZnZ.spec_mul_c; auto with zarith.
 simpl; rewrite _w0_is_0, Zmult_0_l, Zplus_0_l.
 intros H2; rewrite H2; simpl.
 rewrite Z_mod_same; auto with zarith.
 generalize (high_zero (w_mul_c w2 w3)).
 unfold w_mul_c; generalize (ZnZ.spec_mul_c w2 w3);
  case (ZnZ.mul_c w2 w3); simpl; auto with zarith.
 intros H3 _  _; rewrite <- H3; autorewrite with w_rewrite; auto.
(*  rewrite Zmod_small; auto with zarith. *)
 intros w4 w5.
 change (w_to_Z w0) with [|w0|]; rewrite _w0_is_0.
 change (w_to_Z w4) with [|w4|].
 change (w_to_Z w5) with [|w5|].
 simpl.
 intros H2 H3 H4.
 assert (E1: [|w4|] = 0).
 apply H3; auto with zarith.
 apply Z.lt_trans with (1 := H4).
 case (ZnZ.spec_to_Z b); auto with zarith.
 generalize H4 H2; rewrite E1; rewrite Zmult_0_l; rewrite Zplus_0_l;
   clear H4 H2; intros H4 H2.
 rewrite <- H2; rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z w5); auto with zarith.
 intros H2.
 match goal with |- context[split ?x] =>
 generalize (split_correct x);
  case (split x); auto with zarith
 end.
 assert (F1: [[w_mul_c w2 w3]] < [|b|] * [|b|]).
 unfold w_to_Z, w_mul_c, ww_to_Z,w_digits;
   rewrite ZnZ.spec_mul_c; auto with zarith.
 apply Zmult_lt_compat; auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 case (ZnZ.spec_to_Z w3); auto with zarith.
 intros w4 w5; rewrite ww_lsl_n_spec; auto with zarith.
 intros H3.
 unfold w_div21; match goal with |- context[ZnZ.div21 ?y ?z ?t] =>
   generalize (ZnZ.spec_div21 y z t);
   case (ZnZ.div21 y z t)
 end.
 rewrite b2n_spec; case (n_spec); auto.
 intros H4 H5 w6 w7 H6.
 case H6; auto with zarith.
 case (Zle_or_lt (2 ^ [|n|] * [|b|]) [|w4|]); auto; intros H7.
 match type of H3 with ?X = ?Y =>
    absurd (Y < X)
 end.
 apply Zle_not_lt; rewrite H3; auto with zarith.
 simpl ww_to_Z.
 match goal with |- ?X < ?Y + _ =>
    apply Z.lt_le_trans with Y; auto with zarith
 end.
 apply Z.lt_trans with (2 ^ [|n|] * ([|b|] * [|b|]));
   auto with zarith.
 apply Zmult_lt_compat_l; auto with zarith.
 rewrite Zmult_assoc.
 apply Zmult_lt_compat2; auto with zarith.
 case (ZnZ.spec_to_Z b); auto with zarith.
 case (ZnZ.spec_to_Z w5); unfold w_to_Z;auto with zarith.
 clear H6; intros H7 H8.
 rewrite w_lsr_n_spec; auto with zarith.
 rewrite <- (Z_div_mult ([|w2|] * [|w3|]) (2 ^ [|n|]));
  auto with zarith; rewrite Zmult_comm.
 rewrite <- ZnZ.spec_mul_c; auto with zarith.
 unfold w_mul_c in H3; unfold ww_to_Z in H3;simpl in H3.
 unfold w_digits,w_to_Z in H3. rewrite <- H3; simpl.
 rewrite H7; rewrite (fun x => Zmult_comm (2 ^ x));
   rewrite Zmult_assoc; rewrite  BigNumPrelude.Z_div_plus_l; auto with zarith.
 rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l; auto with zarith.
 rewrite Zmod_mod; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Zdiv_lt_upper_bound; auto with zarith.
 rewrite Zmult_comm; auto with zarith.
 Qed.

 Let _square_mod x :=
  let x2 := w_square_c x in
  match ww_compare x2 wwb with
  | Lt => snd (split x2)
  | Eq => w0
  | Gt =>
    let x2_2n := ww_lsl_n x2 in
    let (h,l) := split x2_2n in
    let (q,r) := w_div21 h l b2n in
    w_lsr_n r
  end.

 Lemma _square_mod_spec: forall w t, [|w|] = t mod [|b|] ->
    [|_square_mod w|] = ([|w|] * [|w|]) mod [|b|].
 intros w2 t2 H; unfold _square_mod, wwb.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[ww_compare ?x ?y] =>
   change (ww_compare x y) with (DoubleBase.ww_compare w0 w_compare x y)
 end.
 rewrite (@spec_ww_compare w w0 w_digits w_to_Z w_compare
    ZnZ.spec_0 ZnZ.spec_to_Z ZnZ.spec_compare); case Z.compare_spec;
   intros H2;
 match goal with H: context[w_square_c] |- _ =>
   generalize H; clear H
 end; autorewrite with w_rewrite; try rewrite _w0_is_0; try rewrite !_w1_is_1; auto with zarith.
 unfold w_square_c, ww_to_Z, w_to_Z, w_digits; rewrite ZnZ.spec_square_c; auto with zarith.
 intros H2;rewrite H2; simpl.
 rewrite _w0_is_0; simpl.
 rewrite Z_mod_same; auto with zarith.
 generalize (high_zero (w_square_c w2)).
 unfold w_square_c; generalize (ZnZ.spec_square_c w2);
  case (ZnZ.square_c w2); simpl; auto with zarith.
 intros H3 _  _; rewrite <- H3; autorewrite with w_rewrite; auto.
 intros w4 w5.
 change (w_to_Z w0) with [|w0|]; rewrite _w0_is_0; simpl.
 change (w_to_Z w4) with [|w4|].
 change (w_to_Z w5) with [|w5|].
 intros H2 H3 H4.
 assert (E1: [|w4|] = 0).
 apply H3; auto with zarith.
 apply Z.lt_trans with (1 := H4).
 case (ZnZ.spec_to_Z b); auto with zarith.
 generalize H4 H2; rewrite E1; rewrite Zmult_0_l; rewrite Zplus_0_l;
   clear H4 H2; intros H4 H2.
 rewrite <- H2; rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z w5); auto with zarith.
 intros H2.
 match goal with |- context[split ?x] =>
 generalize (split_correct x);
  case (split x); auto with zarith
 end.
 assert (F1: [[w_square_c w2]] < [|b|] * [|b|]).
 unfold w_square_c, ww_to_Z, w_digits, w_to_Z.
 rewrite ZnZ.spec_square_c; auto with zarith.
 apply Zmult_lt_compat; auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 intros w4 w5; rewrite ww_lsl_n_spec; auto with zarith.
 intros H3.
 unfold w_div21; match goal with |- context[ZnZ.div21 ?y ?z ?t] =>
   generalize (ZnZ.spec_div21 y z t);
   case (ZnZ.div21 y z t)
 end.
 rewrite b2n_spec; case (n_spec); auto.
 intros H4 H5 w6 w7 H6.
 case H6; auto with zarith.
 case (Zle_or_lt (2 ^ [|n|] * [|b|]) [|w4|]); auto; intros H7.
 match type of H3 with ?X = ?Y =>
    absurd (Y < X)
 end.
 apply Zle_not_lt; rewrite H3; auto with zarith.
 simpl ww_to_Z.
 match goal with |- ?X < ?Y + _ =>
    apply Z.lt_le_trans with Y; auto with zarith
 end.
 apply Z.lt_trans with (2 ^ [|n|] * ([|b|] * [|b|]));
   auto with zarith.
 apply Zmult_lt_compat_l; auto with zarith.
 rewrite Zmult_assoc.
 apply Zmult_lt_compat2; auto with zarith.
 case (ZnZ.spec_to_Z b); auto with zarith.
 unfold w_to_Z,w_digits;case (ZnZ.spec_to_Z w5); auto with zarith.
 clear H6; intros H7 H8.
 rewrite w_lsr_n_spec; auto with zarith.
 rewrite <- (Z_div_mult ([|w2|] * [|w2|]) (2 ^ [|n|]));
  auto with zarith; rewrite Zmult_comm.
 rewrite <- ZnZ.spec_square_c; auto with zarith.
 unfold w_square_c, ww_to_Z in H3;  unfold w_digits,w_to_Z in H3.
 rewrite <- H3; simpl.
 rewrite H7; rewrite (fun x => Zmult_comm (2 ^ x));
   rewrite Zmult_assoc; rewrite BigNumPrelude.Z_div_plus_l; auto with zarith.
 rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l; auto with zarith.
 rewrite Zmod_mod; auto with zarith.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Zdiv_lt_upper_bound; auto with zarith.
 rewrite Zmult_comm; auto with zarith.
 Qed.

 Let _power_mod :=
   fix pow_mod (x:w) (p:positive) {struct p} : w :=
     match p with
     | xH => x
     | xO p' =>
       let pow := pow_mod x p' in
       _square_mod pow
     | xI p' =>
       let pow := pow_mod x p' in
       _mul_mod (_square_mod pow) x
     end.

 Lemma _power_mod_spec: forall w t p, [|w|] = t mod [|b|] ->
   [|_power_mod w p|] = (Zpower_pos [|w|] p) mod [|b|].
 intros w2 t p; elim p; simpl; auto with zarith.
 intros p' Rec H.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 replace (xI p') with (p' + p' + 1)%positive.
 repeat rewrite Zpower_pos_is_exp; auto with zarith.
 pose (t1 := [|_power_mod w2 p'|]).
 rewrite _mul_mod_spec with (t1 := t1 * t1)
                            (t2 := t); auto with zarith.
 rewrite _square_mod_spec with (t := Zpower_pos [|w2|] p'); auto with zarith.
 rewrite Rec; auto with zarith.
 assert (tmp: forall p, Zpower_pos p 1 = p); try (rewrite tmp; clear tmp).
 intros p1; unfold Zpower_pos; simpl; ring.
 rewrite <- Zmult_mod; auto with zarith.
 rewrite Zmult_mod; auto with zarith.
 rewrite Zmod_mod; auto with zarith.
 rewrite <- Zmult_mod; auto with zarith.
 simpl; unfold t1; apply _square_mod_spec with (t := Zpower_pos [|w2|] p'); auto with zarith.
 rewrite xI_succ_xO; rewrite <- Pplus_diag.
 rewrite Pplus_one_succ_r; auto.
 intros p' Rec H.
 replace (xO p') with (p' + p')%positive.
 repeat rewrite Zpower_pos_is_exp; auto with zarith.
 rewrite _square_mod_spec with (t := Zpower_pos [|w2|] p'); auto with zarith.
 rewrite Rec; auto with zarith.
 rewrite <- Zmult_mod; auto with zarith.
 rewrite <- Pplus_diag; auto.
 intros H.
 assert (tmp: forall p, Zpower_pos p 1 = p); try (rewrite tmp; clear tmp).
 intros p1; unfold Zpower_pos; simpl; ring.
 rewrite Zmod_small; auto with zarith.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t [|b|]); auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 Qed.

 Definition make_mod_op :=
   mk_mod_op
     _succ_mod _add_mod
     _pred_mod _sub_mod
     _mul_mod _square_mod _power_mod.

  Definition make_mod_spec: mod_spec make_mod_op.
  apply mk_mod_spec.
  exact _succ_mod_spec.
  exact _add_mod_spec.
  exact _pred_mod_spec.
  exact _sub_mod_spec.
  exact _mul_mod_spec.
  exact _square_mod_spec.
  exact _power_mod_spec.
  Defined.

(*********** Mersenne special **********)

 Variable p: positive.
 Variable zp: w.

 Hypothesis zp_b: [|zp|] = Zpos p.
 Hypothesis p_lt_w_digits: Zpos p <= Zpos w_digits.

 Let p1 := Pminus (xO w_digits) p.

 Theorem p_p1: Zpos p + Zpos p1 = Zpos (xO w_digits).
 unfold p1.
 rewrite Zpos_minus; auto with zarith.
 rewrite Zmax_right; auto with zarith.
 rewrite Zpos_xO; auto with zarith.
 assert (0 < Zpos w_digits); auto with zarith.
 Qed.

 Let zp1 := ww_sub ww_zdigits (WW w0 zp).

 Let spec_add2: forall x y,
  [[w_add2 x y]] = [|x|] + [|y|].
  unfold w_add2.
  intros xh xl; generalize (ZnZ.spec_add_c xh xl).
  unfold w_add_c; case ZnZ.add_c; unfold interp_carry; simpl ww_to_Z.
    intros w2 Hw2; simpl; unfold w_to_Z; rewrite Hw2.
  unfold w0; rewrite ZnZ.spec_0; simpl; auto with zarith.
  intros w2; rewrite Zmult_1_l; simpl.
  unfold w_to_Z, w1; rewrite ZnZ.spec_1; auto with zarith.
  rewrite Zmult_1_l; auto.
 Qed.

 Let spec_ww_digits:
  [[ww_zdigits]] = Zpos (xO w_digits).
 Proof.
 unfold w_to_Z, ww_zdigits.
 rewrite spec_add2.
 unfold w_to_Z, w_zdigits, w_digits.
 rewrite ZnZ.spec_zdigits; auto.
 rewrite Zpos_xO; auto with zarith.
 Qed.

 Let spec_ww_to_Z := (spec_ww_to_Z _ _ ZnZ.spec_to_Z).
 Let spec_ww_compare := spec_ww_compare _ _ _ _ ZnZ.spec_0
      ZnZ.spec_to_Z ZnZ.spec_compare.
 Let spec_ww_sub :=
         spec_ww_sub w0 zp wWW zp1 w_opp_c w_opp_carry
              w_sub_c w_opp w_sub w_sub_carry w_digits w_to_Z
             ZnZ.spec_0
             ZnZ.spec_to_Z
             ZnZ.spec_WW
             ZnZ.spec_opp_c
             ZnZ.spec_opp
             ZnZ.spec_opp_carry
             ZnZ.spec_sub_c
             ZnZ.spec_sub
             ZnZ.spec_sub_carry.

 Theorem zp1_b: [[zp1]] = Zpos p1.
 change ([[DoubleSub.ww_sub w0 wWW w_opp_c w_opp_carry w_sub_c w_opp w_sub
            w_sub_carry ww_zdigits (WW w0 zp)]] =
          Zpos p1).
 rewrite spec_ww_sub; auto with zarith.
 rewrite spec_ww_digits; simpl ww_to_Z.
 change (w_to_Z w0) with [|w0|].
 unfold w0; rewrite ZnZ.spec_0; autorewrite with rm10; auto.
 change (w_to_Z zp) with [|zp|].
 rewrite zp_b.
 rewrite Zmod_small; auto with zarith.
 rewrite <- p_p1; auto with zarith.
 unfold ww_digits; split; auto with zarith.
 rewrite <- p_p1; auto with zarith.
 assert (0 < Zpos p1); auto with zarith.
 apply Z.le_lt_trans with (Zpos (xO w_digits)); auto with zarith.
 assert (0 < Zpos p); auto with zarith.
 unfold base; apply Zpower2_lt_lin; auto with zarith.
 Qed.

 Hypothesis p_b: [|b|] = 2 ^ (Zpos p) - 1.

 Let w_pos_mod := ZnZ.pos_mod.

 Let add_mul_div :=
   DoubleLift.ww_add_mul_div w0 wWW wW0 w0W
              ww_compare w_add_mul_div
              ww_sub w_zdigits low.

 Let _mmul_mod x y :=
  let xy := w_mul_c x y in
  match xy with
    W0 => w0
  | WW xh xl =>
      let xl1 := w_pos_mod zp xl in
        match add_mul_div zp1 W0 xy with
          W0 => match w_compare xl1 b with
                | Lt => xl1
                | Eq => w0
                | Gt => w1
                end
        | WW _ xl2 => _add_mod xl1 xl2
        end
  end.

 Hint Unfold w_digits.

 Lemma WW_0: forall x y, [[WW x y]] = 0 -> [|x|] = 0 /\ [|y|] =0.
 intros x y; simpl; case (ZnZ.spec_to_Z x); intros H1 H2;
   case (ZnZ.spec_to_Z y); intros H3 H4 H5.
 case Zle_lt_or_eq with (1 := H1); clear H1; intros H1; auto with zarith.
 absurd (0 < [|x|] * base (ZnZ.digits w_op) + [|y|]); auto with zarith.
 unfold w_to_Z, w_digits in H5;auto with zarith.
 match goal with |- _ < ?X + _ =>
  apply Z.lt_le_trans with X; auto with zarith
 end.
 case Zle_lt_or_eq with (1 := H3); clear H3; intros H3; auto with zarith.
 absurd (0 < [|x|] * base (ZnZ.digits w_op) + [|y|]); auto with zarith.
 unfold w_to_Z, w_digits in H5;auto with zarith.
 rewrite <- H1; rewrite Zmult_0_l; auto with zarith.
 Qed.

 Theorem WW0_is_0: [[W0]] = 0.
 simpl; auto.
 Qed.
  Hint Rewrite WW0_is_0: w_rewrite.

 Theorem mmul_aux0: Zpos (xO w_digits) - Zpos p1 = Zpos p.
 unfold w_digits.
 apply trans_equal with (Zpos p + Zpos p1 - Zpos p1); auto with zarith.
 rewrite p_p1; auto with zarith.
 Qed.

 Theorem mmul_aux1: 2 ^ Zpos w_digits =
     2 ^ (Zpos w_digits - Zpos p) * 2 ^ Zpos p.
 rewrite <- Zpower_exp; auto with zarith.
 eq_tac; auto with zarith.
 Qed.

 Theorem mmul_aux2:forall x,
   x mod (2 ^ Zpos p - 1) =
    ((x / 2 ^ Zpos p) + (x mod 2 ^ Zpos p)) mod (2 ^ Zpos p - 1).
 intros x; pattern x at 1; rewrite Z_div_mod_eq with (b := 2 ^ Zpos p); auto with zarith.
 match goal with |- (?X * ?Y + ?Z) mod (?X - 1) = ?T =>
  replace (X * Y + Z) with (Y * (X - 1) + (Y + Z)); try ring
 end.
 rewrite Zplus_mod; auto with zarith.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l.
 rewrite Zmod_mod; auto with zarith.
 Qed.

 Theorem mmul_aux3:forall xh xl,
   [[WW xh xl]] mod (2 ^ Zpos p) = [|xl|] mod (2 ^ Zpos p).
 intros xh xl; simpl ww_to_Z; unfold base.
 rewrite Zplus_mod; auto with zarith.
 generalize mmul_aux1; unfold w_digits; intros tmp; rewrite tmp;
   clear tmp.
 rewrite Zmult_assoc.
 rewrite Z_mod_mult; auto with zarith.
 rewrite Zplus_0_l; apply Zmod_mod; auto with zarith.
 Qed.

 Let spec_low: forall x,
  [|low x|] = [[x]] mod base w_digits.
  intros x; case x; simpl low; auto with zarith.
  intros xh xl; simpl.
  rewrite Zplus_comm; rewrite Z_mod_plus; auto with zarith.
  rewrite Zmod_small; auto with zarith.
  case (ZnZ.spec_to_Z xl); auto with zarith.
  unfold base; auto with zarith.
 Qed.

 Theorem mmul_aux4:forall x,
  [[x]] < [|b|] * 2 ^  Zpos p ->
     match add_mul_div zp1 W0 x with
          W0 => 0
        | WW _ xl2 => [|xl2|]
     end = [[x]] / 2 ^ Zpos p.
 intros x Hx.
 assert (Hp: [[zp1]] <= Zpos (xO w_digits)); auto with zarith.
   rewrite zp1_b; rewrite <- p_p1; auto with zarith.
   assert (0 <= Zpos p); auto with zarith.
 generalize (@DoubleLift.spec_ww_add_mul_div w w0 wWW wW0 w0W
    ww_compare w_add_mul_div ww_sub w_digits w_zdigits low w_to_Z
    ZnZ.spec_0 ZnZ.spec_to_Z spec_ww_to_Z
    ZnZ.spec_WW ZnZ.spec_WO ZnZ.spec_OW
    spec_ww_compare ZnZ.spec_add_mul_div spec_ww_sub
    ZnZ.spec_zdigits spec_low W0 x zp1 Hp).
  unfold add_mul_div;
    case DoubleLift.ww_add_mul_div; autorewrite with w_rewrite; auto.
 rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp.
 rewrite Zmod_small; auto with zarith.
 split; auto with zarith.
 apply Z_div_pos; auto with zarith.
 case (spec_ww_to_Z x); auto with zarith.
 unfold base.
 apply Zdiv_lt_upper_bound; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 apply Z.lt_le_trans with (base (ww_digits (ZnZ.digits w_op))); auto with zarith.
   case (spec_ww_to_Z x); auto with zarith.
 unfold base; apply Zpower_le_monotone; auto with zarith.
 split; auto with zarith.
 assert (0 < Zpos p); auto with zarith.
 intros w2 w3; rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp;
  clear tmp.
 simpl ww_to_Z; rewrite Zmod_small; auto with zarith.
 intros H1;
   generalize (high_zero (WW w2 w3)); unfold w_digits;intros tmp;
   simpl fst in tmp; simpl ww_to_Z in tmp;auto with zarith.
   unfold w_to_Z in *.
   rewrite tmp in H1; auto with zarith. clear tmp.
 simpl ww_to_Z; rewrite H1; apply Zdiv_lt_upper_bound; auto with zarith.
 unfold base; rewrite <- Zpower_exp; auto with zarith.
 apply Z.lt_le_trans with (1 := Hx).
 apply Z.le_trans with (2 ^ Zpos p * 2 ^ Zpos p).
 rewrite p_b; apply Zmult_le_compat_r; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 apply Zpower_le_monotone; auto with zarith.
 split; auto with zarith.
 apply Z_div_pos; auto with zarith.
 case (spec_ww_to_Z  x); auto with zarith.
 unfold base.
 apply Zdiv_lt_upper_bound; auto with zarith.
 rewrite <- Zpower_exp; auto with zarith.
 apply Z.lt_le_trans with (base (ww_digits (ZnZ.digits w_op))); auto with zarith.
   case (spec_ww_to_Z x); auto with zarith.
 unfold base; apply Zpower_le_monotone; auto with zarith.
 split; auto with zarith.
 assert (0 < Zpos p); auto with zarith.
 Qed.

 Theorem mmul_aux5:forall xh xl,
      [[WW xh xl]] < [|b|] * 2 ^  Zpos p ->
      let xl1 := w_pos_mod zp xl in
      let r :=
        match add_mul_div zp1 W0 (WW xh xl) with
          W0 => match w_compare xl1 b with
                | Lt => xl1
                | Eq => w0
                | Gt => w1
                end
        | WW _ xl2 => _add_mod xl1 xl2
        end  in
        [|r|] = [[WW xh xl]] mod [|b|].
 intros xh xl Hx xl1 r; unfold r; clear r.
 generalize (mmul_aux4 _ Hx).
 simpl ww_to_Z; rewrite p_b.
 rewrite mmul_aux2.
 assert (Hp: [[zp1]] <= Zpos (xO w_digits)); auto with zarith.
   rewrite zp1_b; rewrite <- p_p1; auto with zarith.
   assert (0 <= Zpos p); auto with zarith.
 generalize (@DoubleLift.spec_ww_add_mul_div w w0 wWW wW0 w0W
    ww_compare w_add_mul_div ww_sub w_digits w_zdigits low w_to_Z
    ZnZ.spec_0 ZnZ.spec_to_Z spec_ww_to_Z
    ZnZ.spec_WW ZnZ.spec_WO ZnZ.spec_OW
    spec_ww_compare ZnZ.spec_add_mul_div spec_ww_sub
    ZnZ.spec_zdigits spec_low W0 (WW xh xl) zp1 Hp).
  unfold add_mul_div;
    case DoubleLift.ww_add_mul_div; autorewrite with w_rewrite; auto.
 rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp; clear tmp.
 intros H1 H2.
 rewrite <- H2.
 rewrite Zplus_0_l.
 generalize mmul_aux3; simpl ww_to_Z; intros tmp; rewrite tmp; clear tmp;
   auto with zarith.
 unfold xl1; unfold w_pos_mod.
  rewrite <- p_b; rewrite <- zp_b.
  rewrite <- ZnZ.spec_pos_mod; auto with zarith.
 unfold w_compare; rewrite ZnZ.spec_compare;
   case Z.compare_spec; intros Hc;
 match goal with H: context[b] |- _ =>
   generalize H; clear H
 end; try rewrite _w0_is_0.
 intros H3; rewrite H3.
 rewrite Z_mod_same; auto with zarith.
 intros H3; rewrite Zmod_small; auto with zarith.
 case (ZnZ.spec_to_Z (ZnZ.pos_mod zp xl)); unfold w_to_Z; auto with zarith.
 rewrite p_b; rewrite ZnZ.spec_pos_mod; auto with zarith.
 intros H3; assert (HH: [|xl|] mod 2 ^ Zpos p = 2 ^ Zpos p).
 apply Zle_antisym; auto with zarith.
 case (Z_mod_lt ([|xl|]) (2 ^ Zpos p)); auto with zarith.
 rewrite zp_b in H3; auto with zarith.
 rewrite zp_b; rewrite HH.
 rewrite <- Zmod_minus_one; auto with zarith.
 rewrite _w1_is_1; rewrite Zmod_small; auto with zarith.
 rewrite Zmult_0_l; rewrite Zplus_0_l.
 rewrite zp1_b.
 generalize mmul_aux0; unfold w_digits; intros tmp; rewrite tmp; clear tmp.
 intros w2 w3 H1 H2; rewrite <- H2.
 generalize mmul_aux3; simpl ww_to_Z; intros tmp; rewrite tmp; clear tmp;
   auto with zarith.
 rewrite <- p_b; rewrite <- zp_b.
 rewrite <- ZnZ.spec_pos_mod; auto with zarith.
 unfold xl1; unfold w_pos_mod.
 rewrite Zplus_comm.
 apply _add_mod_correct; auto with zarith.
 assert (tmp: forall x, 2 * x = x + x); auto with zarith;
   rewrite tmp; apply Zplus_le_lt_compat; clear tmp; auto with zarith.
 rewrite ZnZ.spec_pos_mod; auto with zarith.
 rewrite p_b; case (Z_mod_lt [|xl|] (2 ^ Zpos p)); auto with zarith.
 rewrite zp_b; auto with zarith.
 rewrite H2; apply Zdiv_lt_upper_bound; auto with zarith.
 Qed.

 Lemma _mmul_mod_spec: forall w1 w2 t1 t2, [|w1|] = t1 mod [|b|] -> [|w2|] = t2 mod [|b|] ->
   [|_mmul_mod w1 w2|] = ([|w1|] * [|w2|]) mod [|b|].
 intros w2 w3 t1 t2; unfold _mmul_mod, w_mul_c; intros H H1.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t1 [|b|]); auto with zarith.
 assert (F': [|w3|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[ZnZ.mul_c ?x ?y] =>
   generalize (ZnZ.spec_mul_c x y); unfold interp_carry;
   case (ZnZ.mul_c x y); autorewrite with w_rewrite
 end; auto with zarith.
 simpl; intros H2; rewrite <- H2; rewrite Zmod_small;
  auto with zarith.
 intros w4 w5 H2.
 rewrite mmul_aux5; auto with zarith.
 rewrite <- H2; auto.
 unfold ww_to_Z,w_digits,w_to_Z; rewrite H2.
 apply Zmult_lt_compat; auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 case (ZnZ.spec_to_Z w3); auto with zarith.
 Qed.

 Let _msquare_mod x :=
  let xy := w_square_c x in
  match xy with
    W0 => w0
  | WW xh xl =>
      let xl1 := w_pos_mod zp xl in
        match add_mul_div zp1 W0 xy with
          W0 =>  match w_compare xl1 b with
                | Lt => xl1
                | Eq => w0
                | Gt => w1
                end
        | WW _ xl2 => _add_mod xl1 xl2
        end
  end.

 Lemma _msquare_mod_spec: forall w1 t1, [|w1|] = t1 mod [|b|] ->
   [|_msquare_mod w1|] = ([|w1|] * [|w1|]) mod [|b|].
 intros w2 t2; unfold _msquare_mod, w_square_c; intros H.
 assert (F: [|w2|] < [|b|]).
 case (Z_mod_lt t2 [|b|]); auto with zarith.
 match goal with |- context[ZnZ.square_c ?x] =>
   generalize (ZnZ.spec_square_c x); unfold interp_carry;
   case (ZnZ.square_c x); autorewrite with w_rewrite
 end; auto with zarith.
 simpl; intros H2; rewrite <- H2; rewrite Zmod_small;
  auto with zarith.
 intros w4 w5 H2.
 rewrite mmul_aux5; auto with zarith.
 unfold ww_to_Z, w_to_Z ,w_digits; rewrite <- H2; auto.
 unfold ww_to_Z,w_to_Z ,w_digits; rewrite H2.
 apply Zmult_lt_compat; auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 case (ZnZ.spec_to_Z w2); auto with zarith.
 Qed.

 Definition mmake_mod_op :=
   mk_mod_op
     _succ_mod _add_mod
     _pred_mod _sub_mod
     _mmul_mod _msquare_mod _power_mod.

 Definition mmake_mod_spec: mod_spec mmake_mod_op.
  apply mk_mod_spec.
  exact _succ_mod_spec.
  exact _add_mod_spec.
  exact _pred_mod_spec.
  exact _sub_mod_spec.
  exact _mmul_mod_spec.
  exact _msquare_mod_spec.
  exact _power_mod_spec.
  Defined.

End Mod_op.