From Coq Require Import Reals Psatz.
From Coquelicot Require Import Series Hierarchy Lim_seq Rbar.
From stdpp Require Import option.
From stdpp Require Export countable.
From self.prelude Require Import base Coquelicot_ext Series_ext stdpp_ext classical.
Import Hierarchy.

Open Scope R.

(** A theory of (in)finite series over countable types.  *)
Section countable_sum.
  Context `{Countable A}.

  Implicit Types f g : A → R.

  (** 'Traverses' the type in the order given by decoding [0, 1, 2, ...] *)
  Definition countable_sum (f : A → R) :=
    λ (n : nat), from_option f 0 (encode_inv_nat n).

  Lemma countable_sum_0 f m :
    (∀ n, f n = 0) → countable_sum f m = 0.
  Proof. intros. rewrite /countable_sum. destruct (encode_inv_nat _); eauto. Qed.

  Lemma countable_sum_ge_0 f m :
    (∀ n, 0 <= f n) → 0 <= countable_sum f m.
  Proof. intros. rewrite /countable_sum. destruct (encode_inv_nat _)=>//=. Qed.

  Lemma countable_sum_ext f g m :
    (∀ n, f n = g n) → countable_sum f m = countable_sum g m.
  Proof. intros ?. rewrite /countable_sum. destruct (encode_inv_nat _) => //=. Qed.

  Lemma countable_sum_le f g m :
    (∀ n, f n <= g n) → countable_sum f m <= countable_sum g m.
  Proof. intros ?. rewrite /countable_sum. destruct (encode_inv_nat _) =>//=. Qed.

  Lemma countable_sum_scal c f n :
    countable_sum (λ x, scal c (f x)) n = scal c (countable_sum f n).
  Proof.
    intros. rewrite //= /countable_sum /scal //= /mult //=.
    destruct (encode_inv_nat _) => //=; lra.
  Qed.

  Lemma countable_sum_plus f g n :
    countable_sum (λ x, f x + g x) n = countable_sum f n + countable_sum g n.
  Proof.
    intros. rewrite //=/countable_sum; destruct (encode_inv_nat) => //=. lra.
  Qed.

  Lemma countable_sum_minus f g n :
    countable_sum (λ x, f x - g x) n = countable_sum f n - countable_sum g n.
  Proof.
    intros. rewrite //=/countable_sum; destruct (encode_inv_nat) => //=. lra.
  Qed.

  Lemma countable_sum_mult f g n :
    countable_sum (λ x, f x * g x) n = countable_sum f n * countable_sum g n.
  Proof.
    intros. rewrite //=/countable_sum; destruct (encode_inv_nat) => //=. lra.
  Qed.

  Lemma countable_sum_Rabs f n :
    countable_sum (λ x, Rabs (f x)) n = Rabs (countable_sum f n).
  Proof.
    intros. rewrite //=/countable_sum; destruct (encode_inv_nat _) => //=. rewrite Rabs_R0 //=.
  Qed.

  Lemma countable_sum_scal_l f c n :
    countable_sum (λ x, c * f x) n = c * countable_sum f n.
  Proof. apply countable_sum_scal. Qed.

  Lemma countable_sum_scal_r f c n :
    countable_sum (λ x, f x * c) n = countable_sum f n * c.
  Proof.
    intros. rewrite //=/countable_sum; destruct (encode_inv_nat) => //=. lra. Qed.

  Global Instance countable_sum_Proper:
    Proper (pointwise_relation A (@eq R) ==> pointwise_relation nat (@eq R)) countable_sum.
  Proof. intros ?? ? x. rewrite /countable_sum. destruct (encode_inv_nat _); eauto. Qed.

  Global Instance countable_sum_Proper' :
    Proper (pointwise_relation A (@eq R) ==> eq ==> eq) countable_sum.
  Proof. intros ?? ? ? ??. subst. eapply countable_sum_ext; eauto. Qed.

  (** TODO: more lifted lemmas on [sumC] *)
  Definition sumC_n (f : A → R) := sum_n (countable_sum f).

End countable_sum.

Section series.
  Context `{Countable A}.

  Implicit Types f g : A → R.

  (** Lifting of the Coquliecot predicates for working with series *)
  Definition is_seriesC f := is_series (countable_sum f).
  Definition ex_seriesC f := ∃ a, is_seriesC f a.
  Definition SeriesC f := Series (countable_sum f).

  Lemma is_seriesC_0 f :
    (∀ n, f n = 0) → is_seriesC f 0.
  Proof.
    intros ?. apply is_series_0=> n.
    rewrite /countable_sum. destruct (encode_inv_nat _)=>/=; auto.
  Qed.

  Lemma is_seriesC_ext f g l :
    (∀ n, f n = g n) → is_seriesC g l → is_seriesC f l.
  Proof.
    intros ?. apply is_series_ext=> n. by apply countable_sum_ext.
  Qed.

  Lemma is_seriesC_unique f l :
    is_seriesC f l → SeriesC f = l.
  Proof.
    apply is_series_unique.
  Qed.

  Lemma ex_seriesC_ext f g :
    (∀ n, f n = g n) → ex_seriesC f → ex_seriesC g.
  Proof.
    intros ?. apply ex_series_ext=> n. by apply countable_sum_ext.
  Qed.

  Lemma is_seriesC_chain f g v : is_seriesC g (SeriesC f) → is_seriesC f v → is_seriesC g v.
  Proof.
    intros Hs2 Hs1. apply is_seriesC_unique in Hs1. rewrite -Hs1. done.
  Qed.

  Lemma SeriesC_correct f :
    ex_seriesC f → is_seriesC f (SeriesC f).
  Proof. apply Series_correct. Qed.

  Lemma SeriesC_correct' a v:
    SeriesC a = v → ex_seriesC a → is_seriesC a v.
  Proof. by intros <- ?; apply SeriesC_correct. Qed.

  Lemma SeriesC_0 f :
    (∀ x, f x = 0) → SeriesC f = 0.
  Proof. intros Heq0. apply Series_0=> ?. by apply countable_sum_0. Qed.

  Lemma SeriesC_ge_0 (f : A → R) :
    (∀ x, 0 <= f x) →
    ex_seriesC f →
    0 <= SeriesC f.
  Proof.
    intros Heq0 Hex.
    rewrite -(SeriesC_0 (λ _ : A, 0)); [|done].
    apply Series_le; [|done].
    intros n. split.
    + apply countable_sum_ge_0. intros ?; lra.
    + by apply countable_sum_le.
  Qed.

  Lemma SeriesC_ge_0' (f : A → R) :
    (∀ x, 0 <= f x) →
    0 <= SeriesC f.
  Proof.
    intros Heq0.
    apply series_ge_0=> ?.
    apply countable_sum_ge_0; intros; auto.
  Qed.

  Lemma SeriesC_ext f g :
    (∀ n, f n = g n) → SeriesC f = SeriesC g.
  Proof. intros Hext. apply Series_ext => // n. by apply countable_sum_ext. Qed.

  Lemma SeriesC_le f g :
    (∀ n, 0 <= f n <= g n) →
    ex_seriesC g →
    SeriesC f <= SeriesC g.
  Proof.
    intros Hrange Hex. apply Series_le => // n.
    rewrite /countable_sum.
    destruct (encode_inv_nat _) => //=; lra.
  Qed.

  Lemma SeriesC_le' f g :
    (∀ n, f n <= g n) →
    ex_seriesC f →
    ex_seriesC g →
    SeriesC f <= SeriesC g.
  Proof.
    intros ???. apply Series_le' => //= n.
    rewrite /countable_sum.
    destruct (encode_inv_nat _) => //=.
  Qed.

  Lemma SeriesC_scal_l f c :
    SeriesC (λ x, c * f x) = c * SeriesC f.
  Proof.
    intros. rewrite -Series_scal_l. apply Series_ext. apply countable_sum_scal_l.
  Qed.

  Lemma SeriesC_scal_r f c :
    SeriesC (λ x, f x * c) = SeriesC f * c.
  Proof.
    intros. rewrite -Series_scal_r. apply Series_ext. apply countable_sum_scal_r.
  Qed.

  Lemma SeriesC_plus f g :
    ex_seriesC f →
    ex_seriesC g →
    SeriesC (λ x, f x + g x) = SeriesC f + SeriesC g.
  Proof.
    intros. rewrite -Series_plus //. apply Series_ext. apply countable_sum_plus.
  Qed.

  Lemma SeriesC_minus f g :
    ex_seriesC f →
    ex_seriesC g →
    SeriesC (λ x, f x - g x) = SeriesC f - SeriesC g.
  Proof.
    intros. rewrite -Series_minus //. apply Series_ext. apply countable_sum_minus.
  Qed.

  Lemma ex_seriesC_0 :
    ex_seriesC (λ _, 0).
  Proof.
    eexists; by eapply is_seriesC_0.
  Qed.

  Lemma ex_seriesC_le f g :
    (∀ n, 0 <= f n <= g n) →
    ex_seriesC g →
    ex_seriesC f.
  Proof.
    intros Hle Hex.
    eapply @ex_series_le; [|eauto].
    intros n. rewrite /norm//=/abs//=.
    rewrite -countable_sum_Rabs. apply countable_sum_le.
    intros x. destruct (Hle x); eauto. rewrite Rabs_right; eauto; lra.
  Qed.

  Lemma ex_seriesC_scal_l f c :
    ex_seriesC f →
    ex_seriesC (λ x, c * f x).
  Proof.
    intros. eapply ex_series_ext.
    { intros n. rewrite countable_sum_scal_l. done. }
    by eapply @ex_series_scal_l.
  Qed.

  Lemma ex_seriesC_scal_r f c :
    ex_seriesC f →
    ex_seriesC (λ x, f x * c).
  Proof.
    intros. eapply ex_series_ext.
    { intros n. rewrite countable_sum_scal_r. done. }
    apply: ex_series_scal_r; eauto.
  Qed.

  Lemma ex_seriesC_plus f g :
    ex_seriesC f →
    ex_seriesC g →
    ex_seriesC (λ x, f x + g x).
  Proof.
    intros. eapply ex_series_ext.
    { intros n. rewrite countable_sum_plus. done. }
    apply: ex_series_plus; eauto.
  Qed.

  Lemma is_seriesC_scal_l f c v :
    is_seriesC f v →
    is_seriesC (λ x, c * f x) (c * v).
  Proof.
    intros. eapply is_series_ext.
    { intros n. rewrite countable_sum_scal_l. done. }
    apply: is_series_scal_l; eauto.
  Qed.

  Lemma is_seriesC_scal_r f c v:
    is_seriesC f v →
    is_seriesC (λ x, f x * c) (v * c).
  Proof.
    intros. eapply is_series_ext.
    { intros n. rewrite countable_sum_scal_r. done. }
    apply: is_series_scal_r; eauto.
  Qed.

  Lemma is_seriesC_plus f g v1 v2:
    is_seriesC f v1 →
    is_seriesC g v2 →
    is_seriesC (λ x, f x + g x) (v1 + v2).
  Proof.
    intros. eapply is_series_ext.
    { intros n. rewrite countable_sum_plus. done. }
    apply: is_series_plus; eauto.
  Qed.

  Lemma ex_seriesC_Rabs f :
    ex_seriesC (λ x, Rabs (f x)) →
    ex_seriesC f.
  Proof.
    intros. eapply ex_series_Rabs.
    eapply ex_series_ext.
    { intros n. rewrite -countable_sum_Rabs. done. }
    eauto.
  Qed.

  Global Instance is_series_Proper:
    Proper (pointwise_relation A (@eq R) ==> @eq R ==> iff) is_seriesC.
  Proof. intros ?? ? ?? ?; subst; split; eapply is_seriesC_ext; eauto. Qed.

  Global Instance ex_series_Proper:
    Proper (pointwise_relation A (@eq R) ==> iff) ex_seriesC.
  Proof. intros ?? ?; split; eapply ex_seriesC_ext; eauto. Qed.

  Global Instance Series_Proper:
    Proper (pointwise_relation A (@eq R) ==> eq) SeriesC.
  Proof. intros ?? ?; eapply SeriesC_ext; eauto. Qed.

End series.

Section filter.
  Context `{Countable A, Countable B}.

  Implicit Types P Q : A → Prop.

  Lemma is_seriesC_singleton (a : A) v :
    is_seriesC (λ (n : A), if bool_decide (n = a) then v else 0) v.
  Proof.
    rewrite /is_seriesC.
    eapply is_series_ext; [|apply (is_series_singleton (encode_nat a))].
    intros n =>/=. rewrite /countable_sum.
    case_bool_decide as Hneq=>/=; subst.
    - rewrite encode_inv_encode_nat //= bool_decide_eq_true_2 //.
    - destruct (encode_inv_nat _) eqn:Heq=>//=.
      case_bool_decide; [|done]; subst.
      exfalso. apply Hneq. symmetry. by apply encode_inv_Some_nat.
  Qed.

  Lemma ex_seriesC_singleton (a : A) v :
    ex_seriesC (λ (n : A), if bool_decide (n = a) then v else 0).
  Proof. eexists. eapply is_seriesC_singleton. Qed.

  Lemma SeriesC_singleton (a : A) v :
    SeriesC (λ n, if bool_decide (n = a) then v else 0) = v.
  Proof. apply is_series_unique, is_seriesC_singleton. Qed.

  Lemma is_seriesC_singleton_inj (b : B) (f : A -> B) v `{Inj A B (=) (=) f} :
    (exists a, f a = b) ->
    is_seriesC (λ (a : A), if bool_decide (f a = b) then v else 0) v.
  Proof.
    intros (a & Ha).
    rewrite /is_seriesC.
    eapply is_series_ext; [|apply (is_series_singleton (encode_nat a))].
    intros n =>/=. rewrite /countable_sum.
    case_bool_decide as Hneq=>/=; subst.
    - rewrite (encode_inv_encode_nat a) //= bool_decide_eq_true_2 //.
    - destruct (encode_inv_nat _) eqn:Heq=>//=.
      case_bool_decide; [|done]; subst.
      exfalso.
      specialize (H1 a0 a H2); simplify_eq.
      apply Hneq. symmetry. by apply encode_inv_Some_nat.
  Qed.

  Lemma ex_seriesC_singleton_inj (b : B) (f : A -> B) v `{Inj A B (=) (=) f} :
    (exists a, f a = b) ->
    ex_seriesC (λ (a : A), if bool_decide (f a = b) then v else 0).
  Proof.
    eexists. apply is_seriesC_singleton_inj; auto.
  Qed.

  Lemma SeriesC_singleton_inj (b : B) (f : A -> B) v `{Inj A B (=) (=) f} :
    (exists a, f a = b) ->
    SeriesC (λ (a : A), if bool_decide (f a = b) then v else 0) = v.
  Proof.
    intros. apply is_seriesC_unique, is_seriesC_singleton_inj; auto.
  Qed.

  Lemma SeriesC_ge_elem  (f : A → R) (a : A) :
    (∀ x, 0 <= f x) →
    ex_seriesC f →
    f a <= SeriesC f.
  Proof.
    intros Hf Hex.
    rewrite -(SeriesC_singleton a (f a)).
    apply SeriesC_le; [|done].
    intros a'. specialize (Hf a').
    case_bool_decide; simplify_eq; lra.
  Qed.

  (* These are sometimes convenient *)
  Lemma ex_seriesC_singleton' (a : A) v :
    ex_seriesC (λ (n : A), if bool_decide (a = n) then v else 0).
  Proof.
    apply (ex_seriesC_ext (λ n : A, if bool_decide (n = a) then v else 0)
             (λ n : A, if bool_decide (a = n) then v else 0)).
    + intro a'; rewrite (bool_decide_ext (a = a') (a' = a)); done.
    + apply ex_seriesC_singleton.
  Qed.

  Lemma SeriesC_singleton' (a : A) v :
    SeriesC (λ n, if bool_decide (a = n) then v else 0) = v.
  Proof.
    rewrite (SeriesC_ext (λ n : A, if bool_decide (a = n) then v else 0)
               (λ n : A, if bool_decide (n = a) then v else 0)).
    + apply SeriesC_singleton.
    + intro a'; rewrite (bool_decide_ext (a = a') (a' = a)); done.
  Qed.

  Lemma is_seriesC_filter_pos f v P `{∀ x, Decision (P x)} :
    (∀ n, 0 <= f n) →
    is_seriesC f v →
    ex_seriesC (λ n, if bool_decide (P n) then f n else 0).
  Proof.
    intros Hge Hconv.
    apply: ex_seriesC_le; last by (exists v; eauto).
    intros n. rewrite /norm /= /abs.
    specialize (Hge n). case_bool_decide; lra.
  Qed.

  Lemma is_seriesC_filter_impl f v P Q `{∀ x, Decision (P x), ∀ x, Decision (Q x)} :
    (∀ n, 0 <= f n) →
    is_seriesC (λ n, if bool_decide (P n) then f n else 0) v →
    (∀ n, Q n → P n) →
    ex_seriesC (λ n, if bool_decide (Q n) then f n else 0).
  Proof.
    intros Hge Hconv Himp. apply ex_seriesC_Rabs.
    apply: ex_seriesC_le; last by (exists v; eauto).
    intros n. rewrite /norm//=/abs//=.
    specialize (Hge n). specialize (Himp n).
    do 2 case_bool_decide; try (rewrite Rabs_right; auto; lra).
    tauto.
  Qed.

  Lemma ex_seriesC_filter_impl f P Q `{∀ x, Decision (P x), ∀ x, Decision (Q x)} :
    (∀ n, 0 <= f n) →
    ex_seriesC (λ n, if bool_decide (P n) then f n else 0) →
    (∀ n, Q n → P n) →
    ex_seriesC (λ n, if bool_decide (Q n) then f n else 0).
  Proof. intros ? [? ?] ?. eapply is_seriesC_filter_impl; eauto. Qed.

  Lemma ex_seriesC_filter_pos f P `{∀ x, Decision (P x)} :
    (∀ n, 0 <= f n) →
    ex_seriesC f →
    ex_seriesC (λ n, if bool_decide (P n) then f n else 0).
  Proof. intros ? [v His]. by eapply is_seriesC_filter_pos. Qed.

  (* TODO: make a [SeriesC_minus] lemma and cleanup proof *)
  Lemma is_seriesC_filter_union f v P Q `{∀ x, Decision (P x), ∀ x, Decision (Q x)} :
    (∀ n, 0 <= f n) →
    is_seriesC (λ n, if bool_decide (P n ∨ Q n) then f n else 0) v →
    SeriesC (λ n, if bool_decide (P n) then f n else 0) +
      SeriesC (λ n, if bool_decide (Q n) then f n else 0) -
      SeriesC (λ n, if bool_decide (P n ∧ Q n) then f n else 0) = v.
  Proof.
    intros Hge Hexists.
    rewrite -SeriesC_plus; last first.
    {apply (is_seriesC_filter_impl  _ _ _ _ Hge Hexists); eauto. }
    { apply (is_seriesC_filter_impl  _ _ _ _ Hge Hexists); eauto. }
    rewrite -SeriesC_minus.
    - rewrite -(is_seriesC_unique _ v Hexists).
      apply SeriesC_ext => n.
      do 2 repeat case_bool_decide=>//=; try tauto; lra.
    - apply: (ex_seriesC_le _ (λ a, scal 2 (if bool_decide (P a ∨ Q a) then f a else 0))).
      + intros a. rewrite /scal /= /mult /=.
        specialize (Hge a). do 3 case_bool_decide => /=; try (lra || tauto).
      + eexists. by eapply is_seriesC_scal_l.
    - eapply (is_seriesC_filter_impl  _ _ _ _ Hge Hexists). intros ? []; auto.
  Qed.

  Lemma ex_seriesC_split_elem f (a0 : A) :
    ex_seriesC (λ a, if bool_decide (a ≠ a0) then f a else 0) → ex_seriesC f.
  Proof.
    intros Ha0.
    eapply (ex_seriesC_ext (λ a, (λ a, if bool_decide (a = a0) then f a else 0) a +
                                   (λ a, if bool_decide (a ≠ a0) then f a else 0) a)).
    { intros a. case_bool_decide; simplify_eq.
      - rewrite bool_decide_eq_false_2; [lra|auto].
      - rewrite bool_decide_eq_true_2 //. lra. }
    eapply ex_seriesC_plus; [|done].
    eapply ex_seriesC_ext; [|eapply (ex_seriesC_singleton a0 (f a0))].
    intros a. simpl. by case_bool_decide; simplify_eq.
  Qed.

  Lemma SeriesC_split_elem f (a0 : A) :
    (∀ a, 0 <= f a) →           (* TODO: this requirements should not be necessary? *)
    ex_seriesC f →
    SeriesC f = SeriesC (λ a, if bool_decide (a = a0) then f a else 0) +
                  SeriesC (λ a, if bool_decide (a ≠ a0) then f a else 0).
  Proof.
    intros Hle Hex.
    erewrite SeriesC_ext.
    { eapply SeriesC_plus; [by eapply ex_seriesC_filter_pos|].
      eapply (ex_seriesC_le _ f); [|done].
      intros a'. case_bool_decide; split; (done || lra). }
    intros a. simpl. case_bool_decide as Heq.
    - rewrite bool_decide_eq_false_2; [lra|]. eauto.
    - rewrite bool_decide_eq_true_2 //. lra.
  Qed.

End filter.

Section strict.
  Context `{Countable A}.

  Implicit Types f g : A → R.

  (** Some extra theorems about strict inequalities, etc. **)
  Lemma SeriesC_lt f g :
    (∀ n, 0 <= f n <= g n) →
    (∃ m, f m < g m) →
    ex_seriesC g →
    SeriesC f < SeriesC g.
  Proof.
    intros Hle Hlt Hg.
    assert (ex_seriesC f) as Hf.
    { apply (ex_seriesC_le f g); auto. }
    destruct Hlt as (m & Hlt).
    assert (g m - f m > 0) as Hgtz ; try lra.
    set (d := g m - f m).
    set (h := (λ n, if bool_decide (n = m) then d else 0) ).
    assert (ex_seriesC h) as Hh.
    { apply ex_seriesC_singleton. }
    assert (SeriesC h > 0) as Hhgt.
    { rewrite SeriesC_singleton; auto. }
    assert (SeriesC f + SeriesC h <= SeriesC g); try lra.
    rewrite <- SeriesC_plus; auto.
    apply SeriesC_le; auto.
    intro n.
    specialize (Hle n) as (Hle1 & Hle2).
    rewrite /h /d.
    case_bool_decide as Hnm; split; try lra.
    rewrite Hnm; lra.
  Qed.

  Lemma SeriesC_const0 f :
    (∀ n, 0 <= f n) →
    is_seriesC f 0 →
    (∀ n, f n = 0).
  Proof.
    intros Hf Hz n.
    pose proof (is_seriesC_unique _ _ Hz) as Hz'.
    pose proof (Rtotal_order (f n) 0) as Htri.
    destruct Htri as [H1 | [H2 | H3]] ; try lra.
    + specialize (Hf n); lra.
    + assert (0 < SeriesC f); try lra.
      assert (SeriesC (λ _ : A, 0) = 0) as H4.
      { apply SeriesC_0; auto. }
      destruct H4.
      eapply (SeriesC_lt (λ n, 0) f).
      ++ intro n0; specialize (Hf n0); lra.
      ++ exists n; lra.
      ++ exists 0; done.
  Qed.

  Lemma SeriesC_gtz_ex f :
    (∀ n, 0 <= f n) →
    SeriesC f > 0 →
    ∃ n, f n > 0.
  Proof.
    intro Hf.
    eapply contrapositive. intros Hna.
    assert (∀ a, f a = 0) as Hz.
    { intros a.
      pose proof (not_exists_forall_not _ _ Hna a).
      specialize (Hf a); lra. }
    apply Rge_not_gt. rewrite SeriesC_0 //.
  Qed.

End strict.

Section positive.

  (* Results about positive (non-negative) series *)

  (** Lifting of the Coquliecot predicates for limits *)
  Context `{Countable A}.
  Implicit Types f g : A → R.

  Definition is_sup_seqC f r := is_sup_seq (countable_sum f) r.

  Lemma limC_is_sup (h: A -> R) r :
    (∀ n, 0 <= h n) ->
    is_seriesC h r →
    is_sup_seq (sumC_n h) (Finite r).
  Proof.
    intros Hge Hs.
    rewrite /is_seriesC in Hs.
    eapply (lim_is_sup (countable_sum h) r); auto.
    intro n. rewrite /countable_sum /from_option; edestruct (@encode_inv_nat A _ H n); auto ; lra.
  Qed.

  Lemma sup_is_limC (h: A → R) r :
    (∀ n, 0 <= h n) ->
    is_sup_seq (sumC_n h) (Finite r) ->
    is_seriesC h r.
  Proof.
    intros Hge Hsup.
    rewrite /is_seriesC.
    eapply (sup_is_lim); auto.
    intro n; rewrite /countable_sum /from_option; destruct (encode_inv_nat _); auto; lra.
  Qed.

End positive.

Section fubini.
  Context `{Countable A, Countable B}.

  (*
     The following three lemmas have been proven for
     Series, so the only missing part is lifting them
     to SeriesC
   *)

  Lemma fubini_pos_seriesC_ex (h : A * B → R) :
    (∀ a b, 0 <= h (a, b)) ->
    (∀ a, ex_seriesC (λ b, h (a, b))) ->
    (ex_seriesC (λ a, SeriesC (λ b, h (a, b)))) ->
    (∀ b, ex_seriesC (λ a, h (a, b))).
  Admitted.

  Lemma fubini_pos_seriesC_ex_double (h : A * B → R) :
    (∀ a b, 0 <= h (a, b)) ->
    (∀ a, ex_seriesC (λ b, h (a, b))) ->
    (ex_seriesC (λ a, SeriesC (λ b, h (a, b)))) ->
    (ex_seriesC (λ b, SeriesC (λ a, h (a, b)))).
  Admitted.

  Lemma fubini_pos_seriesC (h : A * B → R) :
    (∀ a b, 0 <= h (a, b)) ->
    (∀ a, ex_seriesC (λ b, h (a, b))) ->
    (ex_seriesC (λ a, SeriesC (λ b, h (a, b)))) ->
    SeriesC (λ b, SeriesC (λ a, h (a, b))) =
      SeriesC (λ a, SeriesC (λ b, h (a, b))).
  Admitted.

  (*
    The rest of the lemmas are admitted without a direct counterpart
    for Series. They should only rely on showing that if a set of
    nonnegative real numbers has a finite sum, then (1) every reordering
    of the sum has the same result and (2) every subset has a sum bounded
    by the sum of the whole set. Both can be derived by proving that the
    sum of a set is the sup of the sums of the finite subsets.
 *)

 (*
 Lemma ex_seriesC_nat (h : nat -> R) :
   ex_seriesC h <-> ex_series h.
 Admitted.

 Lemma SeriesC_nat (h : nat -> R) :
   SeriesC h = Series h.
 Admitted.

 Lemma fubini_pos_seriesC_prod_nat (h : nat * nat -> R) :
    (forall a b, 0 <= h (a, b)) ->
    Sup_seq (sum_n (countable_sum h)) =
    Sup_seq (λ n, Sup_seq (λ m, h (n, m))).
 Admitted.
 *)

  Lemma fubini_pos_seriesC_prod_ex_lr (h : A * B -> R) b :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    ex_seriesC (λ a, SeriesC (λ b, h(a, b))).
  Admitted.

  Lemma fubini_pos_seriesC_prod_ex_rl (h : A * B -> R) b :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    ex_seriesC (λ b, SeriesC (λ a, h(a, b))).
  Admitted.

  Lemma fubini_pos_seriesC_prod_lr (h : A * B -> R) :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    SeriesC h = SeriesC (λ a, SeriesC (λ b, h(a, b))).
  Admitted.

  Lemma fubini_pos_seriesC_prod_rl (h : A * B -> R) :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    SeriesC h = SeriesC (λ b, SeriesC (λ a, h(a, b))).
  Admitted.

  Lemma ex_seriesC_lmarg (h : A * B -> R) a :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    ex_seriesC (λ b, h (a, b)).
  Admitted.

  Lemma seriesC_lmarg_le (h : A * B -> R) a :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    SeriesC (λ b, h (a, b)) <= SeriesC h.
  Admitted.

  Lemma ex_seriesC_rmarg (h : A * B -> R) b :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    ex_seriesC (λ a, h (a, b)).
  Admitted.

  Lemma seriesC_rmarg_le (h : A * B -> R) b :
    (∀ a b, 0 <= h (a, b)) ->
    (ex_seriesC h) ->
    SeriesC (λ a, h (a, b)) <= SeriesC h.
  Admitted.

  Lemma ex_seriesC_prod (h: A * B -> R) :
    (∀ a, ex_seriesC (λ b, h(a,b))) ->
    ex_seriesC (λ a, SeriesC (λ b, h(a,b))) ->
    ex_seriesC h.
  Proof. Admitted.

End fubini.

Section mct.
  Context `{Countable A}.

  (* TODO: Lift the proof from Series_extra *)
  Lemma MCT_seriesC (h : nat -> A → R) (l : nat -> R) (r : R) :
    (∀ n a, 0 <= (h n a)) ->
    (∀ n a, (h n a) <= (h (S n) a)) ->
    (∀ a, exists s, ∀ n, h n a <= s ) ->
    (∀ n, is_seriesC (h n) (l n)) ->
    is_sup_seq l (Finite r) ->
    SeriesC (λ a, Sup_seq (λ n, h n a)) = r.
  Admitted.

  (* TODO: Lift the proof from Series_extra *)
  Lemma MCT_ex_seriesC (h : nat -> A → R) (l : nat -> R) (r : R) :
    (∀ n a, 0 <= (h n a)) ->
    (∀ n a, (h n a) <= (h (S n) a)) ->
    (∀ a, exists s, ∀ n, h n a <= s ) ->
    (∀ n, is_seriesC (h n) (l n)) ->
    is_sup_seq l (Finite r) ->
    ex_seriesC (λ a, Sup_seq (λ n, h n a)).
  Admitted.

End mct.


(*************************************************************)
(*      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      *)
(*************************************************************)

Require Import List.
Require Import ZArith.
Require Import Zorder.
Require Import ZCAux.
Require Import LucasLehmer.
Require Import Pocklington.
Require Import ZArith Znumtheory Zpow_facts.
Require Import CyclicAxioms Cyclic63 Int63Compat.
From Bignums Require Import DoubleCyclic BigN.
Require Import Pmod.
Require Import Mod_op.
Require Import W.
Require Import Lucas.
Require Export PocklingtonCertificat.
Require Import NEll.
Import CyclicAxioms DoubleType DoubleBase List.

Open Scope Z_scope.

Section test.

Variable w: univ_of_cycles.
Variable w_op: ZnZ.Ops w.
Variable op_spec: ZnZ.Specs w_op.
Variable p: positive.
Variable b: w.

Notation "[| x |]" :=
   (ZnZ.to_Z x)  (at level 0, x at level 99).

Hypothesis b_pos: 0 < [|b|].

Variable m_op: mod_op w.
Variable m_op_spec: mod_spec w_op b m_op.

Open Scope positive_scope.
Open Scope P_scope.

Let pow := m_op.(power_mod).
Let times := m_op.(mul_mod).
Let pred:= m_op.(pred_mod).

(* [fold_pow_mod a [q1,_;...;qn,_]] b = a ^(q1*...*qn) mod b *)
(* invariant a mod N = a *)
Definition fold_pow_mod (a: w) l :=
  fold_left
    (fun a' (qp:positive*positive) =>  pow a' (fst qp))
    l a.

Lemma fold_pow_mod_spec : forall l (a:w),
  ([|a|] < [|b|])%Z -> [|fold_pow_mod a l|] = ([|a|]^(mkProd' l) mod [|b|])%Z.
intros l; unfold fold_pow_mod; elim l; simpl fold_left; simpl mkProd'; auto; clear l.
intros a H; rewrite Zpower_1_r; rewrite Zmod_small; auto with zarith.
case (ZnZ.spec_to_Z a); auto with zarith.
intros (p1, q1) l Rec a H.
case (ZnZ.spec_to_Z a); auto with zarith; intros U1 U2.
rewrite Rec.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
rewrite <- Zpower_mod.
rewrite times_Zmult; rewrite Zpower_mult; auto with zarith.
apply Z.le_lt_trans with (2 := H); auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
Qed.

Fixpoint all_pow_mod (prod a: w) (l:dec_prime) {struct l}: w*w :=
  match l with
  | nil => (prod,a)
  | (q,_) :: l =>
    let m := pred (fold_pow_mod a l) in
    all_pow_mod (times prod m) (pow a q) l
  end.

Lemma snd_all_pow_mod :
 forall l (prod a :w), ([|a|] < [|b|])%Z ->
   [|snd (all_pow_mod prod a l)|] = ([|a|]^(mkProd' l) mod [|b|])%Z.
intros l; elim l; simpl all_pow_mod; simpl mkProd'; simpl snd; clear l.
intros _ a H; rewrite Zpower_1_r; auto with zarith.
rewrite Zmod_small; auto with zarith.
case (ZnZ.spec_to_Z a); auto with zarith.
intros (p1, q1) l Rec prod a H.
case (ZnZ.spec_to_Z a); auto with zarith; intros U1 U2.
rewrite Rec; auto with zarith.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
rewrite <- Zpower_mod.
rewrite times_Zmult; rewrite Zpower_mult; auto with zarith.
apply Z.le_lt_trans with (2 := H); auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_op_spec.(power_mod_spec) with (t := [|a|]); auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
Qed.

Lemma fold_aux : forall a N l prod,
  (fold_left
     (fun (r : Z) (k : positive * positive) =>
      r * (a ^(N / fst k) - 1) mod [|b|]) l (prod mod [|b|]) mod [|b|] =
  fold_left
     (fun (r : Z) (k : positive * positive) =>
      r * (a^(N / fst k) - 1)) l prod mod [|b|])%Z.
induction l;simpl;intros.
rewrite Zmod_mod; auto with zarith.
rewrite <- IHl; auto with zarith.
rewrite Zmult_mod; auto with zarith.
rewrite Zmod_mod; auto with zarith.
rewrite <- Zmult_mod; auto with zarith.
Qed.

Lemma fst_all_pow_mod :
 forall l (a:w) (R:positive) (prod A :w),
  [|prod|] = ([|prod|] mod [|b|])%Z ->
  [|A|] = ([|a|]^R mod [|b|])%Z ->
  [|fst (all_pow_mod prod A l)|] =
    ((fold_left
      (fun r (k:positive*positive) =>
        (r * ([|a|] ^ (R* mkProd' l / (fst k)) - 1))) l [|prod|]) mod [|b|])%Z.
intros l; elim l; simpl all_pow_mod; simpl fold_left; simpl fst;
  auto with zarith; clear l.
intros (p1,q1) l Rec; simpl fst.
intros a R prod A H1 H2.
assert (F: (0 <= [|A|] < [|b|])%Z).
rewrite H2.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
assert (F1: ((fun x => x = x mod [|b|])%Z [|fold_pow_mod A l|])).
rewrite Zmod_small; auto.
rewrite fold_pow_mod_spec; auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
assert (F2: ((fun x => x = x mod [|b|])%Z [|pred (fold_pow_mod A l)|])).
rewrite Zmod_small; auto.
rewrite(fun x => m_op_spec.(pred_mod_spec) x [|x|]);
  auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite (Rec a (R * p1)%positive); auto with zarith.
rewrite(fun x y => m_op_spec.(mul_mod_spec) x y [|x|] [|y|]);
  auto with zarith.
rewrite(fun x => m_op_spec.(pred_mod_spec) x [|x|]);
  auto with zarith.
rewrite fold_pow_mod_spec; auto with zarith.
rewrite H2.
repeat rewrite Zpos_mult.
repeat rewrite times_Zmult.
repeat rewrite <- Zmult_assoc.
apply sym_equal; rewrite <- fold_aux; auto with zarith.
apply sym_equal; rewrite <- fold_aux; auto with zarith.
eq_tac; auto.
match goal with |- context[fold_left ?x  _ _] =>
  apply f_equal2 with (f := fold_left x); auto with zarith
end.
rewrite Zmod_mod; auto with zarith.
rewrite (Zmult_comm R); repeat rewrite <- Zmult_assoc;
 rewrite (Zmult_comm p1); rewrite Z_div_mult; auto with zarith.
repeat rewrite (Zmult_mod [|prod|]);auto with zmisc.
eq_tac; [idtac | eq_tac]; auto.
eq_tac; auto.
rewrite Zmod_mod; auto.
repeat rewrite (fun x => Zminus_mod x 1); auto with zarith.
eq_tac; auto; eq_tac; auto.
rewrite Zmult_comm; rewrite <- Zpower_mod; auto with zmisc.
rewrite Zpower_mult; auto with zarith.
rewrite Zmod_mod; auto with zarith.
rewrite Zmod_small; auto.
rewrite(fun x y => m_op_spec.(mul_mod_spec) x y [|x|] [|y|]);
  auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite(fun x => m_op_spec.(power_mod_spec) x [|x|]);
  auto with zarith.
apply trans_equal with ([|A|] ^ p1 mod [|b|])%Z; auto.
rewrite H2.
rewrite Zpos_mult_morphism; rewrite Zpower_mult; auto with zarith.
rewrite <- Zpower_mod; auto with zarith.
rewrite Zmod_small; auto.
Qed.

Fixpoint pow_mod_pred (a:w) (l:dec_prime) {struct l} : w :=
  match l with
  | nil => a
  | (q, p)::l =>
    if (p ?= 1) then pow_mod_pred a l
    else
      let a' := iter_pos _ (fun x => pow x q) a (Pos.pred p) in
      pow_mod_pred a' l
  end.

Lemma iter_pow_mod_spec : forall q p a, [|a|] = ([|a|] mod [|b|])%Z ->
  ([|iter_pos _ (fun x => pow x q) a p|] = [|a|]^q^p mod [|b|])%Z.
intros q1 p1; elim p1; simpl iter_pos; clear p1.
intros p1 Rec a Ha.
rewrite(fun x => m_op_spec.(power_mod_spec) x [|x|]).
repeat rewrite Rec. 2, 4: auto with zarith.
match goal with |- (Zpower_pos ?X ?Y mod ?Z = _)%Z =>
  apply trans_equal with (X ^ Y mod Z)%Z; auto
end.
rewrite <- Zpower_mod by auto with zmisc.
rewrite <- Zpower_mult by auto with zmisc.
rewrite <- Zpower_mod by auto with zmisc.
rewrite <- Zpower_mult by auto with zarith zmisc.
eq_tac; auto.
eq_tac; auto.
rewrite Zpos_xI.
assert (tmp: forall x, (2 * x = x + x)%Z) by auto with zarith; rewrite tmp;
  clear tmp.
repeat rewrite Zpower_exp by auto with zarith.
rewrite Zpower_1_r; try ring; auto with misc.
rewrite Zmod_mod; auto with zarith.
rewrite Rec.
rewrite Zmod_mod. reflexivity.
rewrite Rec by auto with zmisc.
rewrite Zmod_mod; auto with zarith.
intros p1 Rec a Ha.
repeat rewrite Rec. 2, 4: auto with zarith.
rewrite <- Zpower_mod by auto with zmisc.
rewrite <- Zpower_mult by auto with zmisc.
eq_tac; auto.
eq_tac; auto.
rewrite Zpos_xO.
assert (tmp: forall x, (2 * x = x + x)%Z) by auto with zarith; rewrite tmp;
  clear tmp.
repeat rewrite Zpower_exp; auto with zarith.
rewrite Zmod_mod; auto with zarith.
intros a Ha; rewrite Zpower_1_r.
rewrite(fun x => m_op_spec.(power_mod_spec) x [|x|]);
  auto with zarith.
Qed.

Lemma pow_mod_pred_spec : forall l a,
  ([|a|] = [|a|] mod [|b|] ->
  [|pow_mod_pred a l|] = [|a|]^(mkProd_pred l) mod [|b|])%Z.
intros l; elim l; simpl pow_mod_pred; simpl mkProd_pred; clear l.
intros; rewrite Zpower_1_r; auto with zarith.
intros (p1,q1) l Rec a H; simpl snd; simpl fst.
case (q1 ?= 1)%P; auto with zarith.
rewrite Rec; auto.
rewrite iter_pow_mod_spec; auto with zarith.
rewrite times_Zmult; rewrite pow_Zpower.
rewrite <- Zpower_mod; auto with zarith.
rewrite Zpower_mult; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite iter_pow_mod_spec; auto with zarith.
match goal with |- context[(?X mod ?Y)%Z] =>
  case (Z_mod_lt X Y); auto with zarith
end.
Qed.

End test.

Require Import Bits.

Definition test_pock N a dec sqrt :=
  if (2 ?< N) then
    let Nm1 := Pos.pred N in
    let F1 := mkProd dec in
    match (Nm1 / F1)%P with
    | (Npos R1, N0) =>
      if is_odd R1 then
        if is_even F1 then
          if (1 ?< a) then
            let (s,r') := (R1 / (xO F1))%P in
            match r' with
            | Npos r =>
              if (a ?< N) then
              let op := cmk_op (Peano.pred (nat_of_P (get_height 63 (plength N)))) in
              let wN := znz_of_Z op (Zpos N) in
              let wa := znz_of_Z op (Zpos a) in
              let w1 := znz_of_Z op 1 in
              let mod_op := make_mod_op op wN in
              let pow := mod_op.(power_mod) in
              let ttimes := mod_op.(mul_mod) in
              let pred:= mod_op.(pred_mod) in
              let gcd:= ZnZ.gcd in
              let A := pow_mod_pred _ mod_op (pow wa R1) dec in
              match all_pow_mod _ mod_op w1 A dec with
              | (p, aNm1) =>
                match ZnZ.to_Z aNm1 with
                  (Zpos xH) =>
                   match ZnZ.to_Z (gcd p wN) with
                   (Zpos xH) =>
                    if check_s_r s r sqrt then
		      (N ?< (times ((times ((xO F1)+r+1) F1) + r) F1) + 1)
                    else false
                   | _ => false
                   end
                 | _ => false
                end
              end else false
            | _ => false
            end
	  else false
        else false
      else false
    | _=> false
    end
  else false.

Lemma test_pock_correct : forall N a dec sqrt,
   (forall k, In k dec -> prime (Zpos (fst k))) ->
   test_pock N a dec sqrt = true ->
   prime N.
unfold test_pock;intros N a dec sqrt H.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If1; auto
end.
2: intros; discriminate.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
generalize (div_eucl_spec (Pos.pred N) (mkProd dec));
 destruct ((Pos.pred N) / (mkProd dec))%P as (R1,n).
simpl fst; simpl snd; intros (H1, H2).
destruct R1 as [ |R1].
intros; discriminate.
destruct n.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If2; auto
end.
assert (If0: Zodd R1).
apply is_odd_Zodd; auto.
clear If2; rename If0 into If2.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If3; auto
end.
assert (If0: Zeven (mkProd dec)).
apply is_even_Zeven; auto.
clear If3; rename If0 into If3.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If4; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
2: intros; discriminate.
generalize (div_eucl_spec R1 (xO (mkProd dec)));
 destruct ((R1 / xO (mkProd dec))%P) as (s,r'); simpl fst;
 simpl snd; intros (H3, H4).
destruct r' as [ |r].
intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If5; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
2: intros; discriminate.
set (bb := Peano.pred (nat_of_P (get_height 63 (plength N)))).
set (w_op := cmk_op bb).
assert (op_spec: ZnZ.Specs w_op).
unfold bb, w_op; apply cmk_spec; auto.
assert (F0: N < DoubleType.base (ZnZ.digits w_op)).
  apply Z.lt_le_trans with (1 := plength_correct N).
  unfold w_op, DoubleType.base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split; auto with zarith.
  generalize (get_height_correct 63 (plength N)); unfold bb.
  set (p := plength N).
  replace (Z_of_nat (Peano.pred (nat_of_P (get_height 63 p)))) with
       ((Zpos (get_height 63 p) - 1) ). auto with zarith.
  rewrite <-  Nat.sub_1_r; rewrite inj_minus1.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
  generalize (lt_O_nat_of_P (get_height 63 p)); auto with zarith.
assert (F1: ZnZ.to_Z (ZnZ.of_Z N) = N).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F2: 1 < ZnZ.to_Z (ZnZ.of_Z N)).
rewrite F1; auto with zarith.
assert (F3: 0 < ZnZ.to_Z (ZnZ.of_Z N)); auto with zarith.
assert (F4: ZnZ.to_Z (ZnZ.of_Z a) = a).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F5: ZnZ.to_Z (ZnZ.of_Z 1) = 1).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F6: N - 1 = (R1 * mkProd_pred dec)%positive * mkProd' dec).
rewrite Zpos_mult.
rewrite <- Zmult_assoc; rewrite mkProd_pred_mkProd.
simpl in H1; rewrite Zpos_mult in H1; rewrite <- H1; rewrite Ppred_Zminus;
  auto with zarith.
assert (m_spec: mod_spec w_op (znz_of_Z w_op N)
                  (make_mod_op w_op (znz_of_Z w_op N))).
apply make_mod_spec; auto with zarith.
match goal with |- context[all_pow_mod ?x ?y ?z ?t ?u] =>
  generalize (fst_all_pow_mod x w_op op_spec _ F3 _ m_spec
               u (znz_of_Z w_op a) (R1*mkProd_pred dec) z t);
  generalize (snd_all_pow_mod x w_op op_spec _ F3 _ m_spec u z t);
  fold bb w_op;
  case (all_pow_mod x y z t u); simpl fst; simpl snd
end.
intros prod aNm1; intros H5 H6.
case_eq (ZnZ.to_Z aNm1).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If6.
case_eq (ZnZ.to_Z (ZnZ.gcd prod (znz_of_Z w_op N))).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If7.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If8; auto
end.
2: intros; discriminate.
intros If9.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
assert (U1: N - 1 = mkProd dec * R1).
rewrite <- Ppred_Zminus in H1 by auto with zarith.
rewrite H1; simpl.
repeat rewrite Zpos_mult; auto with zarith.
assert (HH:Z_of_N s = R1 / (2 * mkProd dec) /\ Zpos r =  R1 mod (2 * mkProd dec)).
apply mod_unique with (2 * mkProd dec); [auto with zarith | | ].
apply Z_mod_lt; auto with zarith.
rewrite <- Z_div_mod_eq_full.
rewrite H3.
rewrite (Zpos_xO (mkProd dec)).
simpl Z_of_N; ring.
case HH; clear HH; intros HH1 HH2.
apply PocklingtonExtra with (F1:=mkProd dec) (R1:=R1) (m:=1).
2: auto with zmisc zarith.
2: auto with zmisc zarith.
2: auto with zmisc zarith.
2: auto with zmisc zarith.
3: auto with zmisc zarith.
3: auto with zmisc zarith.
case (Zle_lt_or_eq 1 (mkProd dec)); auto with zarith.
simpl in H2; auto with zarith.
intros HH; contradict If3; rewrite <- HH.
apply Zodd_not_Zeven; red; auto.
intros p; case p; clear p.
intros HH; contradict HH.
apply not_prime_0.
2: intros p (V1, _); contradict V1; apply Zle_not_lt; red; simpl; intros;
     discriminate.
intros p Hprime Hdec; exists (Zpos a);repeat split.
auto with zarith.
apply trans_equal with (2 := If6).
rewrite H5.
rewrite pow_mod_pred_spec with (2 := m_spec).
2: auto with zarith.
rewrite F1.
rewrite m_spec.(power_mod_spec) with (t := a).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4.
rewrite <- Zpower_mod; [idtac| auto with zarith].
rewrite <- Zpower_mult; [idtac|auto with zarith |auto with zarith].
rewrite mkProd_pred_mkProd.
rewrite U1; rewrite Zmult_comm.
rewrite Zpower_mult; [idtac|auto with zarith| auto with zarith].
rewrite <- Zpower_mod; auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a).
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec).
2: auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a).
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
match type of H6 with _ -> _ -> ?X =>
  assert (tmp: X); [apply H6 | clear H6; rename tmp into H6]
end.
rewrite F1.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1).
rewrite F5; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec).
2: auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite m_spec.(power_mod_spec) with (t := a).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zpos_mult; rewrite <- Zpower_mod.
2: auto with zarith.
rewrite Zpower_mult; auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
rewrite (power_mod_spec m_spec) with (t := a).
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y)
end.
1: auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4); auto.
rewrite Zmod_small; [auto with zarith|idtac].
change (znz_of_Z w_op N) with (ZnZ.of_Z N); auto with zarith.
change (znz_of_Z w_op a) with (ZnZ.of_Z a) in H6.
change (znz_of_Z w_op N) with (ZnZ.of_Z N) in H6.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1) in H6.
rewrite F5 in H6; rewrite F1 in H6; rewrite F4 in H6.
case in_mkProd_prime_div_in with (3 := Hdec); auto.
intros p1 Hp1.
rewrite <- F6 in H6.
apply Zis_gcd_gcd; auto with zarith.
change (rel_prime (a ^ ((N - 1) / p) - 1) N).
match type of H6 with _ = ?X mod _ =>
  apply rel_prime_div with (p := X); auto with zarith
end.
apply rel_prime_mod_rev; auto with zarith.
red.
pattern 1 at 4; rewrite <- If7; rewrite <- H6.
pattern N at 2; rewrite <- F1.
apply ZnZ.spec_gcd; auto with zarith.
assert (foldtmp: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a b,
  In b l -> (forall x, P (f x b)) ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
assert (foldtmp0: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a,
  P a ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
intros A B f P l; elim l; simpl; auto.
intros A B f P l; elim l; simpl; auto.
intros a1 b HH; case HH.
intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto.
apply foldtmp0; auto.
apply Rec with (b := b); auto with zarith.
match goal with |- context [fold_left ?f _ _] =>
 apply (foldtmp _ _ f (fun k => Z.divide (a ^ ((N - 1) / p) - 1) k))
   with (b := (p, p1)); auto with zarith
end.
rewrite <- HH2.
clear F0; match goal with H: ?X < ?Y |- ?X < ?Z =>
 replace Z with Y; auto
end.
repeat (rewrite Zpos_plus || rewrite Zpos_mult || rewrite times_Zmult).
rewrite Zpos_xO; ring.
rewrite <- HH1; rewrite <- HH2.
apply check_s_r_correct with sqrt; auto.
Qed.

(* Simple version of pocklington for primo *)
Definition test_spock N a dec :=
  if (2 ?< N) then
    let Nm1 := Pos.pred N in
    let F1 := mkProd dec in
    match (Nm1 / F1)%P with
    | (Npos R1, N0) =>
          if (1 ?< a) then
            if (a ?< N) then
              if (N ?< F1 * F1) then
              let op := cmk_op (Peano.pred (nat_of_P (get_height 63 (plength N)))) in
              let wN := znz_of_Z op (Zpos N) in
              let wa := znz_of_Z op (Zpos a) in
              let w1 := znz_of_Z op 1 in
              let mod_op := make_mod_op op wN in
              let pow := mod_op.(power_mod) in
              let ttimes := mod_op.(mul_mod) in
              let pred:= mod_op.(pred_mod) in
              let gcd:= ZnZ.gcd in
              let A := pow_mod_pred _ mod_op (pow wa R1) dec in
              match all_pow_mod _ mod_op w1 A dec with
              | (p, aNm1) =>
                match ZnZ.to_Z aNm1 with
                  (Zpos xH) =>
                   match ZnZ.to_Z (gcd p wN) with
                   (Zpos xH) => true
                   | _ => false
                   end
                 | _ => false
                end
              end else false
           else false
         else false
    | _=> false
    end
  else false.

Lemma test_spock_correct : forall N a dec,
   (forall k, In k dec -> prime (Zpos (fst k))) ->
   test_spock N a dec = true ->
   prime N.
unfold test_spock;intros N a dec H.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If1; auto
end.
2: intros; discriminate.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
generalize (div_eucl_spec (Pos.pred N) (mkProd dec));
 destruct ((Pos.pred N) / (mkProd dec))%P as (R1,n).
simpl fst; simpl snd; intros (H1, H2).
destruct R1 as [ |R1].
intros; discriminate.
destruct n.
2: intros; discriminate.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If2; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
2: intros; discriminate.
(*
set (bb := pred (nat_of_P (get_height 63 (plength N)))).
set (w_op := cmk_op bb).
assert (op_spec: znz_spec w_op).
unfold bb, w_op; apply cmk_spec; auto.
assert (F0: N < Basic_type.base (znz_digits w_op)).
  apply Z.lt_le_trans with (1 := plength_correct N).
  unfold w_op, Basic_type.base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split; auto with zarith.
  generalize (get_height_correct 63 (plength N)); unfold bb.
  set (p := plength N).
  replace (Z_of_nat (pred (nat_of_P (get_height 63 p)))) with
       ((Zpos (get_height 63 p) - 1) ); auto with zarith.
  rewrite pred_of_minus; rewrite inj_minus1; auto with zarith.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
  generalize (lt_O_nat_of_P (get_height 63 p)); auto with zarith.
*)
set (bb := Peano.pred (nat_of_P (get_height 63 (plength N)))).
set (w_op := cmk_op bb).
assert (op_spec: ZnZ.Specs w_op).
unfold bb, w_op; apply cmk_spec; auto.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If3; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
match goal with |- context[if ?x then _ else _] =>
  case_eq x; intros If4; auto
end.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
assert (F0: N < DoubleType.base (ZnZ.digits w_op)).
  apply Z.lt_le_trans with (1 := plength_correct N).
  unfold w_op, DoubleType.base.
  rewrite cmk_op_digits.
  apply Zpower_le_monotone; split; auto with zarith.
  generalize (get_height_correct 63 (plength N)); unfold bb.
  set (p := plength N).
  replace (Z_of_nat (Peano.pred (nat_of_P (get_height 63 p)))) with
       ((Zpos (get_height 63 p) - 1) ). auto with zarith.
  rewrite <- Nat.sub_1_r; rewrite inj_minus1.
  rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P; auto with zarith.
  generalize (lt_O_nat_of_P (get_height 63 p)); auto with zarith.
assert (F1: ZnZ.to_Z (ZnZ.of_Z N) = N).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F2: 1 < ZnZ.to_Z (ZnZ.of_Z N)).
rewrite F1; auto with zarith.
assert (F3: 0 < ZnZ.to_Z (ZnZ.of_Z N)); auto with zarith.
assert (F4: ZnZ.to_Z (ZnZ.of_Z a) = a).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F5: ZnZ.to_Z (ZnZ.of_Z 1) = 1).
rewrite ZnZ.of_Z_correct; auto with zarith.
assert (F6: N - 1 = (R1 * mkProd_pred dec)%positive * mkProd' dec).
rewrite Zpos_mult.
rewrite <- Zmult_assoc; rewrite mkProd_pred_mkProd.
simpl in H1; rewrite Zpos_mult in H1; rewrite <- H1; rewrite Ppred_Zminus;
  auto with zarith.
assert (m_spec: mod_spec w_op (znz_of_Z w_op N)
                  (make_mod_op w_op (znz_of_Z w_op N))).
apply make_mod_spec; auto with zarith.
match goal with |- context[all_pow_mod ?x ?y ?z ?t ?u] =>
  generalize (fst_all_pow_mod x w_op op_spec _ F3 _ m_spec
               u (znz_of_Z w_op a) (R1*mkProd_pred dec) z t);
  generalize (snd_all_pow_mod x w_op op_spec _ F3 _ m_spec u z t);
  fold bb w_op;
  case (all_pow_mod x y z t u); simpl fst; simpl snd
end.
2: intros; discriminate.
intros prod aNm1; intros H5 H6.
case_eq (ZnZ.to_Z aNm1).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If5.
case_eq (ZnZ.to_Z (ZnZ.gcd prod (znz_of_Z w_op N))).
intros; discriminate.
2: intros; discriminate.
intros p; case p; clear p.
intros; discriminate.
intros; discriminate.
intros If6 _.
assert (U1: N - 1 = mkProd dec * R1).
rewrite <- Ppred_Zminus in H1 by auto with zarith.
rewrite H1; simpl.
repeat rewrite Zpos_mult; auto with zarith.
apply PocklingtonCorollary1 with (F1:=mkProd dec) (R1:=R1).
case (Zle_lt_or_eq 1 (mkProd dec)).
simpl in H2; auto with zarith.
easy.
intros HH; contradict If4; rewrite Zpos_mult_morphism;
  rewrite <- HH.
apply Zle_not_lt; auto with zarith.
1-3: auto with zmisc zarith.
intros p; case p; clear p.
intros HH; contradict HH.
apply not_prime_0.
2: intros p (V1, _); contradict V1; apply Zle_not_lt; red; simpl; intros;
     discriminate.
intros p Hprime Hdec; exists (Zpos a);repeat split; auto with zarith.
apply trans_equal with (2 := If5).
rewrite H5.
rewrite pow_mod_pred_spec with (2 := m_spec).
2: auto with zarith.
rewrite F1.
rewrite m_spec.(power_mod_spec) with (t := a).
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4.
rewrite <- Zpower_mod;[idtac | auto with zarith].
rewrite <- Zpower_mult;[idtac|auto with zarith|auto with zarith].
rewrite mkProd_pred_mkProd.
rewrite U1; rewrite Zmult_comm.
rewrite Zpower_mult; [idtac|auto with zarith|auto with zarith].
rewrite <- Zpower_mod; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a).
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a).
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
rewrite F1; rewrite F4; rewrite Zmod_small; auto with zarith.
match type of H6 with _ -> _ -> ?X =>
  assert (tmp: X); [apply H6 | clear H6; rename tmp into H6]
end.
rewrite F1.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1).
rewrite F5; rewrite Zmod_small; auto with zarith.
rewrite pow_mod_pred_spec with (2 := m_spec); auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
repeat (rewrite F1 || rewrite F4).
rewrite m_spec.(power_mod_spec) with (t := a); auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zpos_mult; rewrite <- Zpower_mod; auto with zarith.
rewrite Zpower_mult; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
rewrite Zmod_small; auto with zarith.
rewrite m_spec.(power_mod_spec) with (t := a).
match goal with |- context[?X mod ?Y] =>
  case (Z_mod_lt X Y); auto with zarith
end.
change (znz_of_Z w_op N) with (ZnZ.of_Z N).
change (znz_of_Z w_op a) with (ZnZ.of_Z a).
repeat (rewrite F1 || rewrite F4).
rewrite Zmod_small; auto with zarith.
change (znz_of_Z w_op N) with (ZnZ.of_Z N) in H6.
change (znz_of_Z w_op a) with (ZnZ.of_Z a) in H6.
change (znz_of_Z w_op 1) with (ZnZ.of_Z 1) in H6.
rewrite F5 in H6; rewrite F1 in H6; rewrite F4 in H6.
case in_mkProd_prime_div_in with (3 := Hdec); auto.
intros p1 Hp1.
rewrite <- F6 in H6.
apply Zis_gcd_gcd; auto with zarith.
change (rel_prime (a ^ ((N - 1) / p) - 1) N).
match type of H6 with _ = ?X mod _ =>
  apply rel_prime_div with (p := X); auto with zarith
end.
apply rel_prime_mod_rev; auto with zarith.
red.
pattern 1 at 4; rewrite <- If6; rewrite <- H6.
pattern N at 2; rewrite <- F1.
apply ZnZ.spec_gcd; auto with zarith.
assert (foldtmp: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a b,
  In b l -> (forall x, P (f x b)) ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
assert (foldtmp0: forall (A B: Set) (f: A -> B -> A) (P: A -> Prop) l a,
  P a ->
  (forall x y, P x -> P (f x y)) ->
  P (fold_left f l a)).
intros A B f P l; elim l; simpl; auto.
intros A B f P l; elim l; simpl; auto.
intros a1 b HH; case HH.
intros a1 l1 Rec a2 b [V|V] V1 V2; subst; auto.
apply foldtmp0; auto.
apply Rec with (b := b); auto with zarith.
match goal with |- context [fold_left ?f _ _] =>
 apply (foldtmp _ _ f (fun k => Z.divide (a ^ ((N - 1) / p) - 1) k))
   with (b := (p, p1)); auto with zarith
end.
intros; discriminate.
Qed.

Fixpoint test_Certif (lc : Certif) : bool :=
  match lc with
  | nil => true
  | (Proof_certif _ _) :: lc => test_Certif lc
  | (Lucas_certif n p) :: lc =>
     let xx := test_Certif lc in
     if xx then
     let yy := gt2 p in
     if yy then
       match p with
         Zpos p1 =>
           let zz := Mp p in
           match zz with
          | Zpos n' =>
             if (n ?= n')%P then
               let tt :=  lucas p1 in
               match tt with
               | Z0 => true
               | _ => false
               end
             else false
           | _ => false
           end
         | _ => false
       end
    else false
    else false
  | (Pock_certif n a dec sqrt) :: lc =>
    let xx := test_pock n a dec sqrt in
    if xx then
      let yy := all_in lc dec in
      (if yy then test_Certif lc else false)
    else false
  | (SPock_certif n a dec) :: lc =>
    let xx :=test_spock n a dec in
    if xx then
      let yy := all_in lc dec in
      (if yy then test_Certif lc else false)
    else false
  | (Ell_certif n ss l a b x y) :: lc =>
    let xx := ell_test n ss l a b x y in
    if xx then
     let yy :=  all_in lc l in
     if yy then test_Certif lc else false
    else false
  end.

Lemma test_Certif_In_Prime :
  forall lc, test_Certif lc = true ->
   forall c, In c lc -> prime (nprim c).
intros lc; elim lc; simpl; auto.
intros _ c H; case H.
intros a; case a; simpl; clear a lc.
intros N p l Rec H c [H1 | H1]; subst; auto with arith.
intros n p l; case (test_Certif l); auto with zarith.
2: intros; discriminate.
intros H H1 c [H2 | H2]; subst; auto with arith.
simpl nprim.
generalize H1; clear H1.
case_eq (gt2 p).
2: intros; discriminate.
case p; clear p; try (intros; discriminate; fail).
unfold gt2; intros p H1.
match goal with H: (?X ?< ?Y) = true |- _ =>
  generalize (is_lt_spec X Y); rewrite H; clear H; intros H
end.
unfold Mp; case_eq (2 ^ p  -1); try (intros; discriminate; fail).
intros p1 Hp1.
case_eq (n ?= p1)%P; try rewrite <- Hp1.
2: intros; discriminate.
intros H2.
match goal with H: (?X ?= ?Y)%P = true |- _ =>
  generalize (is_eq_eq _ _ H); clear H; intros H
end.
generalize (lucas_prime H1); rewrite Hp1; rewrite <- H2.
case (lucas p); try (intros; discriminate; fail); auto.
intros N a d p l H.
generalize (test_pock_correct N a d p).
case (test_pock N a d p); auto.
2: intros; discriminate.
generalize (all_in_In l d).
case (all_in l d).
2: intros; discriminate.
intros H1 H2 H3 c [H4 | H4]; subst; simpl; auto.
apply H2; auto.
intros k Hk.
case H1 with (2 := Hk); auto.
intros x (Hx1, Hx2); rewrite Hx2; auto.
intros N a d l H.
generalize (test_spock_correct N a d).
case test_spock; auto.
2: intros; discriminate.
generalize (all_in_In l d).
case (all_in l d).
2: intros; discriminate.
intros H1 H2 H3 c [H4 | H4]; subst; simpl; auto.
apply H2; auto.
intros k Hk.
case H1 with (2 := Hk); auto.
intros x (Hx1, Hx2); rewrite Hx2; auto.
intros N S l A B x y l1.
generalize (all_in_In l1 l).
generalize (ell_test_correct N S l A B x y).
case ell_test.
case all_in; auto.
intros H1 H2 H3 H4 c [H5 | H5]; try subst c; simpl; auto.
apply H1.
intros p Hp; case (H2 (refl_equal true) p); auto.
intros x1 (Hx1, Hx2); rewrite Hx2; auto.
intros; discriminate.
intros; discriminate.
Qed.

Lemma Pocklington_refl :
  forall c lc, test_Certif (c::lc) = true -> prime (nprim c).
Proof.
 intros c lc Heq;apply test_Certif_In_Prime with (c::lc);trivial;simpl;auto.
Qed.


Require Import init.

Require Import int_abstract.
Require Import fraction_base.

Require Export rat.
Require Import set.
Require Import fraction_order.
Require Import nat.
Require Import order_minmax.

Section RatAbstract.

Context {U} `{
    OrderedField U,
    @CharacteristicZero U UP UZ UE
}.
Local Existing Instance characteristic_zero_not_trivial.

Definition rat_to_abstract_base (x : frac_base int)
    := int_to_abstract (fst x) / int_to_abstract [snd x|] : U.

Local Infix "~" := (eq_equal (frac_equiv int)).

Theorem int_to_abstract_nz : ∀ a : frac_base int, 0 ≠ int_to_abstract [snd a|].
Proof.
    intros a.
    intros contr.
    apply [|snd a].
    rewrite <- int_to_abstract_zero in contr.
    apply int_to_abstract_eq in contr.
    exact contr.
Qed.

Theorem rat_to_abstract_wd : ∀ a b, a ~ b →
    rat_to_abstract_base a = rat_to_abstract_base b.
Proof.
    intros a b eq.
    cbn in eq.
    unfold frac_eq in eq; cbn in eq.
    unfold rat_to_abstract_base; cbn.
    rewrite <- mult_rrmove by apply int_to_abstract_nz.
    rewrite (mult_comm (_ (fst b))).
    rewrite <- mult_assoc.
    rewrite <- mult_llmove by apply int_to_abstract_nz.
    do 2 rewrite <- int_to_abstract_mult.
    rewrite mult_comm.
    rewrite eq.
    reflexivity.
Qed.

Definition rat_to_abstract (a : rat) := unary_op rat_to_abstract_wd a.

Theorem rat_to_abstract_eq : ∀ a b,
    rat_to_abstract a = rat_to_abstract b → a = b.
Proof.
    intros a b eq.
    equiv_get_value a b.
    unfold rat_to_abstract in eq.
    equiv_simpl in eq.
    unfold rat; equiv_simpl.
    unfold frac_eq.
    unfold rat_to_abstract_base in eq.
    rewrite <- mult_rrmove in eq by apply int_to_abstract_nz.
    rewrite (mult_comm (_ (fst b))) in eq.
    rewrite <- mult_assoc in eq.
    rewrite <- mult_llmove in eq by apply int_to_abstract_nz.
    do 2 rewrite <- int_to_abstract_mult in eq.
    apply int_to_abstract_eq in eq.
    rewrite <- eq.
    apply mult_comm.
Qed.

Theorem rat_to_abstract_le : ∀ a b,
    rat_to_abstract a ≤ rat_to_abstract b ↔ a ≤ b.
Proof.
    intros a b.
    pose proof (frac_pos_ex int a) as [a1 [a2 [a2_pos a_eq]]].
    pose proof (frac_pos_ex int b) as [b1 [b2 [b2_pos b_eq]]].
    subst a b.
    unfold rat_to_abstract; equiv_simpl.
    pose proof (frac_le int a1 a2 b1 b2 a2_pos b2_pos) as stupid.
    rewrite stupid; clear stupid.
    unfold rat_to_abstract_base; cbn.
    rewrite <- int_to_abstract_lt in a2_pos, b2_pos.
    rewrite int_to_abstract_zero in a2_pos, b2_pos.
    rewrite <- le_mult_lrmove_pos by exact b2_pos.
    rewrite mult_comm, mult_assoc.
    rewrite <- le_mult_rrmove_pos by exact a2_pos.
    do 2 rewrite <- int_to_abstract_mult.
    rewrite int_to_abstract_le.
    rewrite mult_comm.
    rewrite (mult_comm b1).
    reflexivity.
Qed.

Theorem rat_to_abstract_lt : ∀ a b,
    rat_to_abstract a < rat_to_abstract b ↔ a < b.
Proof.
    intros a b.
    unfold strict.
    rewrite rat_to_abstract_le.
    rewrite (f_eq_iff rat_to_abstract_eq).
    reflexivity.
Qed.

Theorem rat_to_abstract_zero : rat_to_abstract 0 = 0.
Proof.
    unfold zero at 1, rat_to_abstract; equiv_simpl.
    unfold rat_to_abstract_base; cbn.
    rewrite int_to_abstract_zero.
    apply mult_lanni.
Qed.

Theorem rat_to_abstract_one : rat_to_abstract 1 = 1.
Proof.
    unfold one at 1, rat_to_abstract; equiv_simpl.
    unfold rat_to_abstract_base; cbn.
    rewrite int_to_abstract_one.
    rewrite div_one.
    apply mult_lid.
Qed.

Theorem rat_to_abstract_plus : ∀ a b,
    rat_to_abstract (a + b) = rat_to_abstract a + rat_to_abstract b.
Proof.
    intros a b.
    equiv_get_value a b.
    unfold plus at 1, rat_to_abstract; equiv_simpl.
    unfold rat_to_abstract_base; cbn.
    rewrite int_to_abstract_plus.
    do 3 rewrite int_to_abstract_mult.
    rewrite div_mult by apply int_to_abstract_nz.
    rewrite mult_assoc.
    do 2 rewrite rdist.
    rewrite mult_rrinv by apply int_to_abstract_nz.
    apply rplus.
    rewrite <- mult_assoc.
    rewrite (mult_comm (/ _ [snd a|])).
    rewrite mult_assoc.
    rewrite mult_rrinv by apply int_to_abstract_nz.
    reflexivity.
Qed.

Theorem rat_to_abstract_neg : ∀ a, rat_to_abstract (-a) = -rat_to_abstract a.
Proof.
    intros a.
    equiv_get_value a.
    unfold neg at 1, rat_to_abstract; equiv_simpl.
    unfold rat_to_abstract_base; cbn.
    rewrite int_to_abstract_neg.
    apply mult_lneg.
Qed.

Theorem rat_to_abstract_mult : ∀ a b,
    rat_to_abstract (a * b) = rat_to_abstract a * rat_to_abstract b.
Proof.
    intros a b.
    equiv_get_value a b.
    unfold mult at 1, rat_to_abstract; equiv_simpl.
    unfold rat_to_abstract_base; cbn.
    do 2 rewrite int_to_abstract_mult.
    do 2 rewrite <- mult_assoc.
    apply lmult.
    rewrite div_mult by apply int_to_abstract_nz.
    do 2 rewrite mult_assoc.
    apply rmult.
    apply mult_comm.
Qed.

Theorem rat_to_abstract_div : ∀ a, 0 ≠ a →
    rat_to_abstract (/a) = /rat_to_abstract a.
Proof.
    intros a a_nz.
    equiv_get_value a.
    unfold div at 1, rat_to_abstract; equiv_simpl.
    unfold zero in a_nz; cbn in a_nz.
    unfold to_frac, rat in a_nz; equiv_simpl in a_nz.
    unfold frac_eq in a_nz; cbn in a_nz.
    rewrite mult_rid, mult_lanni in a_nz.
    destruct (sem (0 = fst a)) as [contr|a_nz']; [>contradiction|].
    unfold rat_to_abstract_base; cbn.
    rewrite div_mult.
    -   rewrite div_div by apply int_to_abstract_nz.
        apply mult_comm.
    -   intros contr.
        rewrite <- int_to_abstract_zero in contr.
        apply int_to_abstract_eq in contr.
        contradiction.
    -   apply div_nz.
        apply int_to_abstract_nz.
Qed.

Theorem int_to_rat_to_abstract : ∀ n,
    rat_to_abstract (int_to_rat n) = int_to_abstract n.
Proof.
    intros n.
    equiv_get_value n.
    unfold int_to_rat, rat_to_abstract; equiv_simpl.
    unfold rat_to_abstract_base, int_to_abstract_base; cbn.
    rewrite int_to_abstract_one.
    rewrite div_one, mult_rid.
    reflexivity.
Qed.

Theorem nat_to_rat_to_abstract : ∀ n,
    rat_to_abstract (nat_to_rat n) = from_nat n.
Proof.
    intros n.
    unfold nat_to_rat.
    rewrite int_to_rat_to_abstract.
    apply nat_to_int_to_abstract.
Qed.

Theorem rat_to_abstract_min : ∀ a b,
    rat_to_abstract (min a b) = min (rat_to_abstract a) (rat_to_abstract b).
Proof.
    intros a b.
    destruct (connex a b) as [leq|leq].
    -   rewrite (min_leq _ _ leq).
        rewrite <- rat_to_abstract_le in leq.
        rewrite (min_leq _ _ leq).
        reflexivity.
    -   rewrite (min_req _ _ leq).
        rewrite <- rat_to_abstract_le in leq.
        rewrite (min_req _ _ leq).
        reflexivity.
Qed.

Theorem rat_to_abstract_max : ∀ a b,
    rat_to_abstract (max a b) = max (rat_to_abstract a) (rat_to_abstract b).
Proof.
    intros a b.
    destruct (connex a b) as [leq|leq].
    -   rewrite (max_req _ _ leq).
        rewrite <- rat_to_abstract_le in leq.
        rewrite (max_req _ _ leq).
        reflexivity.
    -   rewrite (max_leq _ _ leq).
        rewrite <- rat_to_abstract_le in leq.
        rewrite (max_leq _ _ leq).
        reflexivity.
Qed.

End RatAbstract.

Section RatAbstractArch.

Context {U} `{
    UP : Plus U,
    @PlusComm U UP,
    @PlusAssoc U UP,
    UZ : Zero U,
    @PlusLid U UP UZ,
    @PlusRid U UP UZ,
    UN : Neg U,
    @PlusLinv U UP UZ UN,
    @PlusRinv U UP UZ UN,
    UM : Mult U,
    @MultComm U UM,
    @MultAssoc U UM,
    @Ldist U UP UM,
    @Rdist U UP UM,
    UE : One U,
    @MultLid U UM UE,
    @MultRid U UM UE,
    @MultLcancel U UZ UM,
    @MultRcancel U UZ UM,
    UO : Order U,
    @Antisymmetric U le,
    @Transitive U le,
    @Connex U le,
    @OrderLplus U UP UO,
    @OrderRplus U UP UO,
    @OrderMult U UZ UM UO,
    @OrderLmult U UZ UM UO,
    @OrderRmult U UZ UM UO,
    @OrderMultLcancel U UZ UM UO,
    @OrderMultRcancel U UZ UM UO,
    NotTrivial U,
    UD : Div U,
    @MultLinv U UZ UM UE UD,
    @MultRinv U UZ UM UE UD,
    @Archimedean U UP UZ UO
}.

Lemma rat_dense_in_arch_pos : ∀ a b : U, 0 ≤ a → a < b →
    ∃ r : rat, a < rat_to_abstract r ∧ rat_to_abstract r < b.
Proof.
    intros a b a_pos ab.
    apply lt_plus_0_anb_b_a in ab.
    pose proof (archimedean2 _ ab) as [n ltq].
    apply lt_rmult_pos with (from_nat (nat_suc n)) in ltq.
    2: apply from_nat_pos.
    rewrite mult_linv in ltq by apply from_nat_pos.
    remember (from_nat (nat_suc n)) as n'.
    rewrite rdist in ltq.
    apply lt_plus_rrmove in ltq.
    rewrite mult_lneg in ltq.
    rewrite neg_neg in ltq.
    pose proof (archimedean1' (a * n')) as [m' m'_ltq].
    assert (∃ m, a * n' < from_nat m) as S_ex
        by (exists m'; exact m'_ltq).
    pose proof (well_ordered _ S_ex) as [m [m_ltq m_least]].
    clear m' m'_ltq S_ex.
    remember (from_nat m) as m'.
    exists (nat_to_rat m / nat_to_rat (nat_suc n)).
    rewrite rat_to_abstract_mult.
    rewrite rat_to_abstract_div.
    2: {
        change 0 with (nat_to_rat 0).
        intros contr.
        apply nat_to_rat_eq in contr.
        inversion contr.
    }
    do 2 rewrite nat_to_rat_to_abstract.
    rewrite <- Heqn', <- Heqm'.
    split.
    -   apply lt_mult_lrmove_pos.
        1: rewrite Heqn'; apply from_nat_pos.
        exact m_ltq.
    -   apply lt_mult_rrmove_pos.
        1: rewrite Heqn'; apply from_nat_pos.
        nat_destruct m.
        {
            rewrite lt_plus_0_anb_b_a in ab.
            rewrite Heqm'.
            change (from_nat 0) with 0.
            apply lt_mult.
            -   exact (le_lt_trans a_pos ab).
            -   rewrite Heqn'.
                apply from_nat_pos.
        }
        assert (from_nat m ≤ a * n') as m_ltq2.
        {
            classic_contradiction contr.
            rewrite nle_lt in contr.
            specialize (m_least _ contr).
            rewrite <- nlt_le in m_least.
            contradiction (m_least (nat_lt_suc m)).
        }
        apply (le_lt_trans2 ltq).
        rewrite Heqm'.
        change (nat_suc m) with (1 + m).
        setoid_rewrite homo_plus.
        rewrite homo_one.
        apply le_lplus.
        exact m_ltq2.
Qed.
Theorem rat_dense_in_arch : ∀ a b : U, a < b →
    ∃ r : rat, a < rat_to_abstract r ∧ rat_to_abstract r < b.
Proof.
    intros a b ab.
    classic_case (0 ≤ a) as [a_pos|a_neg].
    {
        apply rat_dense_in_arch_pos; assumption.
    }
    rewrite nle_lt in a_neg.
    classic_case (0 < b) as [b_pos|b_neg].
    {
        exists 0.
        rewrite rat_to_abstract_zero.
        split; assumption.
    }
    rewrite nlt_le in b_neg.
    apply neg_pos in b_neg.
    apply lt_neg in ab.
    pose proof (rat_dense_in_arch_pos (-b) (-a) b_neg ab) as [r [r_gt r_lt]].
    exists (-r).
    rewrite rat_to_abstract_neg.
    apply lt_neg in r_gt, r_lt.
    rewrite neg_neg in r_gt, r_lt.
    split; assumption.
Qed.

End RatAbstractArch.


(** Proof Reflection in Coq ; ND_unique_types.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export check_sound.

Set Implicit Arguments.

Section uniqueness_of_types.

Variable l1 l2 : list nat.

Let P := prf l1 l2.
Let F := frm l1 l2.
Let T := trm l1.

Lemma unique_types :
 forall (G : list F) (d : P) (p q : F), ND G d p -> ND G d q -> p = q.
Proof.
intros G d p q H H0.
assert (H1 := ND2check H).
assert (H2 := ND2check H0).
rewrite H1 in H2; injection H2; exact (fun h => h).
Qed.

End uniqueness_of_types.


Require Import Clight.INTEGER. (* Core.Notations. *)
Require Import Coq.Program.Basics.
Require Import Core.Core Core.Tactics. (* Core.PtrLemmas. (* Core.Notations. *) *)
Require Import StructTact.StructTactics.
Require Import Lists.List.
Import ListNotations.

Section AbstractSpec.

  Definition minus_char := 45.
  Definition plus_char := 43.
  Definition zero_char := 48.
  Definition nine_char := 57.

  Definition is_digit (i : byte) : bool :=
    (zero_char <=? Byte.signed i) && (Byte.signed i <=? nine_char).

  Definition Z_of_char (b : byte) : Z :=
    Byte.signed b - 48.

  Definition is_sign (b : byte) : bool :=
    (Byte.signed b =? plus_char) || (Byte.signed b =? minus_char).

  Definition bounded (n : Z) : bool :=
    (Int64.min_signed <=? n) && (n <=? Int64.max_signed).

  Inductive asn_strtox_result_e :=
  | ERROR_RANGE (* Input outside of supported numeric range *)
  | ERROR_INVAL (* Invalid data encountered (e.g., "+-") *)
  | EXPECT_MORE (* More data expected (e.g. "+") *)
  | EXTRA_DATA  (* Conversion succeded, but the string has extra stuff *)
  | OK.         (* Conversion succeded, number ends at (end) *)

  Record Z_of_string_result :=
  { res : asn_strtox_result_e;
    value : Z;
    index : Z;
  }.

Definition app_char (b : bool) v c :=
  if b
  then v * 10 + (Z_of_char c)
  else v * 10 - (Z_of_char c).

 Fixpoint Z_of_string_loop (s : list byte) (v i : Z) (b : bool) :=
    match s with
    | [] => {| res := OK; value := v; index := i |}
    | c :: tl =>
      if is_digit c
      then let v1 := app_char b v c in
           if bounded v1
           then Z_of_string_loop tl v1 (i + 1) b
           else {| res := ERROR_RANGE; value := v1; index := i; |}
      else {| res := EXTRA_DATA; value := v; index := i; |}
    end.

  Definition Z_of_string (s : list byte) : Z_of_string_result :=
      match s with
      |  nil => {| res := ERROR_INVAL; value := 0; index := 0; |}
      | [ch] => if is_sign ch
                then {| res := EXPECT_MORE; value := 0; index := 1; |}
                else Z_of_string_loop s 0 0 true
      |  ch :: tl => if (Byte.signed ch =? plus_char)
                    then  Z_of_string_loop tl 0 1 true
                    else if (Byte.signed ch =? minus_char)
                         then Z_of_string_loop tl 0 1 false
                         else Z_of_string_loop s 0 0 true
      end.

End AbstractSpec.

Section RelationalSpec.

  Definition plus_char_b := Byte.repr plus_char.
  Definition minus_char_b := Byte.repr minus_char.

  (* relation between input string, value, index an asn_strtox_result_e message *)
  Inductive asn_strtoimax_lim_R : list byte -> Z -> Z -> asn_strtox_result_e -> Prop :=
  (* Invalid data encountered *)
  | ERROR_INVAL_R :
      asn_strtoimax_lim_R nil 0 0 ERROR_INVAL

  (* More data expected (e.g. "+") *)
  | EXPECT_MORE_R : forall ls c,
      ls = [c]  ->
      is_sign c = true ->
      asn_strtoimax_lim_R ls 0 1 EXPECT_MORE

  (* Input outside of supported numeric range *)
  | ERROR_RANGE_R : forall b ls z i c,
      asn_strtoimax_lim_R ls z i OK ->
      bounded (app_char b z c) = false ->
      asn_strtoimax_lim_R (ls ++ [c]) (app_char b z c) (i + 1) ERROR_RANGE

  (* non-digit encountered *)
  | ASN_STRTOX_EXTRA_DATA_R : forall c ls z i,
      asn_strtoimax_lim_R ls z i OK ->
      is_digit c = false ->
      asn_strtoimax_lim_R (ls ++ [c]) z i EXTRA_DATA

  (* Conversion succeded *)
  | OK_R : forall ls z i,
      ls <> nil ->
      asn_strtoimax_lim_R_loop true ls z i OK ->
      asn_strtoimax_lim_R ls z i OK

  | OK_R_plus : forall ls ls' z i,
      ls = plus_char_b::ls' ->
      asn_strtoimax_lim_R_loop true ls' z i OK ->
      asn_strtoimax_lim_R ls z i OK

  | OK_R_minus : forall ls ls' z i,
      ls = minus_char_b::ls' ->
      asn_strtoimax_lim_R_loop false ls' z i OK ->
      asn_strtoimax_lim_R ls z i OK

  with asn_strtoimax_lim_R_loop : bool -> list byte -> Z -> Z -> asn_strtox_result_e -> Prop :=

  | OK_R_0 : forall b,
      asn_strtoimax_lim_R_loop b nil 0 0 OK

  | OK_R_Succ : forall b ls z i c,
      asn_strtoimax_lim_R_loop b ls z i OK ->
      bounded (app_char b z c) = true ->
      asn_strtoimax_lim_R_loop b (ls ++ [c]) (app_char b z c) (i + 1) OK.

End RelationalSpec.

Section C_likeSpec.

Definition ASN1_INTMAX_MAX := Int64.max_signed.
Definition upper_boundary := Z.div ASN1_INTMAX_MAX 10.
Definition last_digit_max := Zmod ASN1_INTMAX_MAX 10.
Definition last_digit_max_minus := last_digit_max + 1.

Definition last_digit (b : bool) :=
  if b then last_digit_max else last_digit_max_minus.

Fixpoint Z_of_string_loop_C (s : list byte) (v i : Z) (b : bool):=
    match s with
    | [] => {| res := OK ;
              value := v ;
              index := i |}
    | c :: tl =>
      if is_digit c
      then let d := (Z_of_char c) in
           let v1 := v*10 + d in
           if (v <? upper_boundary)
           then Z_of_string_loop_C tl v1 (i + 1) b
           else if ((v =? upper_boundary)&&(d <=? (last_digit b)))%bool
                then match tl with
                     | [] => {| res := OK ;
                               value := v1 ;
                               index := (i + 1) |}
                     | c :: tl => if is_digit c
                                 then {| res := ERROR_RANGE ;
                                         value := app_char b v1 c;
                                         index := (i + 1) ; |}
                                 else {| res := EXTRA_DATA;
                                         value := v1;
                                         index := (i + 1) ; |}
                     end
                else {| res := ERROR_RANGE ;
                        value := v1 ;
                        index := i ; |}
      else {| res := EXTRA_DATA ;
              value := v ;
              index := i ; |}
    end.

Definition Z_of_string_C (s : list byte) : Z_of_string_result :=
  match s with
  |  nil => {| res := ERROR_INVAL ;
              value := 0 ;
              index := 0 ; |}
  | [ch] => if is_sign ch
           then {| res := EXPECT_MORE ;
                   value := 0 ;
                   index := 1 ; |}
           else Z_of_string_loop_C s 0 0 true
  |  ch :: tl => let result := Z_of_string_loop_C tl 0 1 true in
               if (Byte.signed ch =? plus_char)
               then result
               else if (Byte.signed ch =? minus_char)
                    then let v := value (Z_of_string_loop_C tl 0 1 false) in
                         {| res := res result ;
                            value := if 0 <? v then (-1*v) else v  ;
                            index := index result ; |}
                    else Z_of_string_loop_C s 0 0 true
  end.

End C_likeSpec.

  (* C light outputs int *)

  Definition asn_strtox_result_e_to_int (s : asn_strtox_result_e) : int :=
    match s with
    | ERROR_RANGE => Int.repr (-3)
    | ERROR_INVAL => Int.repr (-2)
    | EXPECT_MORE => Int.repr (-1)
    | EXTRA_DATA => Int.repr 1
    | OK => Int.repr 0
    end.

(* alternative abstract spec, with positive loop *)
Section AbstractSpec'.

  Definition bounded' (b : bool) (n : Z) : bool :=
    if b
    then andb (0 <=? n) (n <=? Int64.max_signed)
    else andb (0 <=? n) (n <=? Int64.max_signed + 1).

  Fixpoint Z_of_string_loop' (s : list byte) (v i : Z) (b : bool):=
    match s with
    | [] => {| res := OK ;
              value := v ;
              index := i |}
    | c :: tl =>
      if is_digit c
      then let v1 := v * 10 + (Z_of_char c) in
           if bounded' b v
           then Z_of_string_loop' tl v1 (i + 1) b
           else {| res := ERROR_RANGE ;
                   value := v1 ;
                   index := i ; |}
      else {| res := EXTRA_DATA ;
              value := v ;
              index := i  ; |}
    end.

  Definition Z_of_string' (s : list byte) : Z_of_string_result :=
      match s with
      |  nil => {| res := ERROR_INVAL ;
                  value := 0 ;
                  index := 0 ; |}
      | [ch] => if is_sign ch
                then {| res := EXPECT_MORE ;
                        value := 0 ;
                        index := 1 ; |}
                else Z_of_string_loop' s 0 0 true
      |  ch :: tl => let result := Z_of_string_loop' tl 0 1 true in
                    if (Byte.signed ch =? plus_char)
                    then result
                    else if (Byte.signed ch =? minus_char)
                         then {| res := res result ;
                                 value := -1* value (Z_of_string_loop' tl 0 1 false)  ;
                                 index := index result ; |}
                         else Z_of_string_loop' s 0 0 true
      end.

End AbstractSpec'.

(* Correctness of C-like spec *)

Lemma abstract_spec_C_spec_equiv_true : forall ls v i, Z_of_string_loop' ls v i true =
                      Z_of_string_loop_C ls v i true.
  Proof.
    induction ls.
    - intuition.
    - simpl.
      intros.
      repeat break_if;
        try eapply IHls.
      break_match.
      -- intuition.
      -- break_if.
         simpl.
         bool_rewrite.
         break_if.
         (* next is out of range *)
         admit.
         intuition.
         simpl.
         bool_rewrite.
         intuition.
      -- (* contradiction *)
        admit.
      -- (* contradiction *)
        admit.
      -- admit.  (* contradiction *)
Admitted.

Ltac Zbool_to_Prop := try (rewrite Z.leb_le ||
                           rewrite Z.leb_gt ||
                           rewrite Z.eqb_eq ||
                           rewrite Z.eqb_neq).

Lemma is_digit_to_Z : forall c, is_digit c = true -> 0 <= Z_of_char c <= 9.
Proof.
  unfold is_digit, Z_of_char.
  intro.
  rewrite andb_true_iff in *.
  repeat Zbool_to_Prop.
  unfold zero_char, nine_char.
  nia.
Qed.

Lemma loop_non_neg : forall ls v i, 0 <= v -> 0 <= value (Z_of_string_loop' ls v i false).
Proof.
  induction ls.
  - intuition.
  - intros.
    simpl.
      repeat break_if;
    simpl; try congruence;
       eapply is_digit_to_Z in Heqb.
    eapply IHls.
    all: nia.
Qed.

Lemma abstract_spec_C_spec_equiv_false_res : forall ls v i,
    res (Z_of_string_loop' ls v i false) =
    res (Z_of_string_loop_C ls v i false).
Proof.
 induction ls.
    - intuition.
    - simpl.
      intros.
      repeat break_if;
        try eapply IHls.
      break_match.
      -- intuition.
      -- break_if.
         simpl.
         bool_rewrite.
         break_if.
         (* next is out of range *)
         admit.
         intuition.
         simpl.
         bool_rewrite.
         intuition.
      -- (* contradiction *)
        admit.
      -- (* contradiction *)
        admit.
      -- admit.  (* contradiction *)
Admitted.

Lemma abstract_spec_C_spec_equiv_false_index : forall ls v i,
    index (Z_of_string_loop' ls v i false) =
    index (Z_of_string_loop_C ls v i false).
Proof.
 induction ls.
    - intuition.
    - simpl.
      intros.
      repeat break_if;
        try eapply IHls.
      break_match.
      -- intuition.
      -- break_if.
         simpl.
         bool_rewrite.
         break_if.
         (* next is out of range *)
         admit.
         intuition.
         simpl.
         bool_rewrite.
         intuition.
      -- (* contradiction *)
        admit.
      -- (* contradiction *)
        admit.
      -- admit.  (* contradiction *)
Admitted.

Lemma abstract_spec_C_spec_equiv_false_value : forall ls v i,
    0 <= v ->
    0 <= value (Z_of_string_loop' ls v i false) ->
    value (Z_of_string_loop' ls v i false) =
    Z.abs (value (Z_of_string_loop_C ls v i false)).
Proof.
    induction ls.
    - simpl.
      intros.
      auto with zarith.
      erewrite Z.abs_eq;
        try nia.
    - simpl.
      intros.
      repeat break_if;
        try eapply IHls.
       eapply is_digit_to_Z in Heqb.
       nia.
      eapply loop_non_neg.
        eapply is_digit_to_Z in Heqb.
       nia.
      break_match.
      -- simpl.
         assert (0 <= v * 10 + Z_of_char a).
         eapply is_digit_to_Z in Heqb.
         nia.
         edestruct  Z.abs_spec with (n :=  v * 10 + Z_of_char a).
         inversion H2.
         nia.
         inversion H2.
         nia.
      -- break_if.
         simpl.
         bool_rewrite.
         break_if.
         (* as before *)
         admit.
         simpl.
         admit.
         simpl.
         bool_rewrite.
         simpl.
          assert (0 <= v * 10 + Z_of_char a).
         eapply is_digit_to_Z in Heqb.
         nia.
         (* replace (- v * 10 - Z_of_char a) with
           (- (v * 10 + Z_of_char a))
                 by auto with zarith.
          Search Z.abs Z.opp.
          erewrite Z.abs_opp. *)
          edestruct  Z.abs_spec with (n :=  v * 10 + Z_of_char a).
          inversion H2.
          nia.
          inversion H2.
          nia.
      -- (* contradiction *)
        admit.
      -- (* contradiction *)
        admit.
      --  (* contradiction *)
        admit.
Admitted.

Lemma Clike_corr : forall ls, Z_of_string' ls = Z_of_string_C ls.
  Proof.
    destruct ls.
    - intuition.
    - simpl.
      repeat break_if;
        try congruence; try eapply aux'.
        simpl. (* contradiction *) admit.
        replace (Z_of_string_loop_C (i0 :: l) 0 1 true) with
            (Z_of_string_loop' (i0 :: l) 0 1 true).
        replace (value (Z_of_string_loop' (i0 :: l) 0 1 false))
                with (Z.abs (value (Z_of_string_loop_C (i0 :: l) 0 1 false))).
        admit.
        erewrite  abstract_spec_C_spec_equiv_false_value.
        auto.
        nia.
        admit.
        eapply  abstract_spec_C_spec_equiv_true.
        erewrite  abstract_spec_C_spec_equiv_false_value.
        admit.
        nia.
        admit.
        admit.
Admitted.


(**
数学ガールの「数学的帰納法」の問題
========================

@suharahiromichi

2020/06/21
 *)

(**
結城浩さんの「数学ガールの秘密ノート」に数学的帰納法の話題があります
（文献 [1][2]）。

数学ガールシリーズにしてはめずらしく、入試問題を題材にしています（文献 [3]）。
なので、解答にチャレンジしたかたもいるのではないかとおもいます。
これを ``Coq/MathComp`` （文献 [4]）で解いてみようと思います。

ひとつ前の値を使う数学的帰納法は、
Coqのような定理証明器（定理証明支援システム）が得意とすることのはずなのですが、
案外と大変でした。

- 与えられた漸化式をCoqの関数で定義しようとすると、停止性の証明が必要となる。

- 自然数をインデックスとする数列の一般項を求める問題だが、
数列の値は有理数（自然数を分母子とする分数）である。

- 一般項を求める過程で、有理数環の補題の証明が必要となる。

- その補題を適用するときに、分子が零ではないことを示す必要があり、
数列の項が ``> 0`` であることを（一般項を使わずに）証明する必要があった。
このとき、完全帰納法 (complete induction, strengthening induction) が必要になった。

- 高校数学なので、1からの自然数を使っているが、
Coqでは自然数は0以上としなければならない。

このファイルは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/math/ssr_ind_of_math_girl_2.v

証明スクリプトは模範回答ではなく、一例として参考程度にしてください。
*)

From mathcomp Require Import all_ssreflect.
From mathcomp Require Import all_algebra.
From common Require Import ssromega.        (* ssromega タクティク *)
Require Import Recdef.                      (* Function コマンド *)

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

Import GRing.Theory.         (* mulrA などを使えるようにする。 *)
Import Num.Theory.           (* unitf_gt0 などを使えるようにする。 *)
Import intZmod.              (* addz など *)
Import intRing.              (* mulz など *)
Open Scope ring_scope.       (* 環の四則演算を使えるようにする。 *)

Section Lemmas.
(**
# 補題

最初に、0でない(1を越える)有理数 p と q に対して、

$$ \frac{p}{\frac{p}{q}} = q $$

であることを証明します。分母を払うためのものですが、
この補題を ``Coq/MathComp`` のルールにしたがって、``divKq`` と命名します。
有理数(q)の割算(div)で、もとに戻る(K, cancel) の意味です。

ここで証明した補題の段階では、``0 < p`` と ``0 < q`` の前提が残ることに注意してください。

``divKq`` を直接証明してもよいのですが、
``divqA`` と ``mulKq`` の別の補題を証明して使っています。
その証明には、MathComp の環 (ring) の補題を使っています（文献 [6]）。
*)

  Lemma divqA (p q r : rat) : 0 < q -> 0 < r -> p / (q / r) = (p * r) / q.
  Proof.
    move=> Hq Hr.
    rewrite invrM.                 (* p * (r^-1^-1 / q) = p * r / q *)
    - rewrite invrK.               (* p * (r / q) = p * r / q *)
      rewrite -div1r.              (* p * (r * (1 / q)) = p * r * (1 / q) *)
        by rewrite !mulrA.
    - by apply: unitf_gt0.                 (* q \is a GRing.unit *)
    - rewrite -invr_gt0 in Hr.             (* r^-1 \is a GRing.unit *)
        by apply: unitf_gt0.
  Qed.

  Lemma mulKq (p q : rat) : 0 < p -> (p * q) / p = q.
  Proof.
    move=> Hp.
    rewrite [p * q]mulrC.                   (* q * p / p = q *)
    (* rewrite -div1r. *)
    rewrite -mulrA.                         (* q * (p / p) = q *)
    (* rewrite div1r. *)
    rewrite divrr.                          (* q * 1 = q *)
    - by rewrite mulr1.
    - by rewrite unitf_gt0.                 (* p \is a GRing.unit *)
  Qed.

  Lemma divKq (p q : rat) : 0 < p -> 0 < q -> p / (p / q) = q.
  Proof.
    move=> Hp Hq.
    rewrite divqA; last done; last done.
    rewrite mulKq; last done.
    done.
  Qed.

End Lemmas.

(**
# 試験問題

本題の試験問題（文献 [3]）を解いていきます。大筋では、数学ガール（文献 [1][2]）と同じです。
ですが、少し異なるとこともあります。

- 数列 a の漸化式を Coq の再帰関数として定義する。
ただし、a_0 を起点とするため、試験問題や数学ガールの記事と比べると、
インデックスがひとつづづずれる。

```math

a_0 = 3\\
a_1 = 3\\
a_2 = 3\\
a_{k+3} = \frac{a_k + a_{k+1}}{a_{k+2}}
```

- 数列 b と 数列 c を 数列 a から定義する。
ただし、試験問題や数学ガールの記事と逆に、
b_k を a_2k （偶数番）、c_k を a_2k+1 （奇数番）とする。

```math

b_k = a_{2k}\\
c_k = a_{2k+1}
```

- 試験問題（と数学ガールの記事）の誘導問題に従い、b_k+2 と c_k+1 の式を求める
(lemma_1 と lemma_2)。

- ``0 < a_k`` であることを証明する。このとき、
帰納法の仮定として、``k0 < k`` であるすべてのk0で ``0 < a_k0`` が成り立つものとして、
``0 < a_k`` であることを証明する（完全帰納法を使う）。

- ``0 < a_k`` から ``0 < b_k`` と ``0 < c_k`` を導く。

- b_k = b_k+1 であること(lemma_3)を、k についての数学的帰納法で証明する。
このとき、 補題 ``divKq`` を使う。
そして、``divKq`` の前提を消すために、a_k, b_k, c_k のそれぞれが ``> 0`` であることを使う。

- 最終的に、bの一般項 b_k が 3 であることを証明することは同じである。

$$ b_k = 3 $$
 *)

Section Question.

(**
## 数列 a_k の漸化式

数列 a_k の漸化式 を Coq の関数で定義します。
自然数 k を引数とする再帰関数として定義することになりますが、
Coq はこの関数が、任意の自然数 k に対して計算できること、
すなわち、再帰が止まって値が求まること（計算の停止性）を
自動判定できない、というエラーを出力します。

そこで、定義に際して、再帰の毎に k の値が減ることを明示してやります
（Function コマンドを使う。文献 [9]）。

すると、Function コマンドは、``k.+2 < k.+3`` と ``k.+1 < k.+3`` と ``k < k.+3``
を証明することを求めてきます（証明責務ですね）。
FunctionコマンドはStarndard Coqのコマンドなので、
StandardCoqの不等式 (例：``(k.+2 < k.+3)%coq_nat``) を出力します。
これは ``apply/ltP`` を使って、
MathCompの不等式（例：``(k.+2 < k.+3)%N``）に変換できます。
Coqの自然数 ``%coq_nat`` が MathCompの自然数 ``%N`` に変わっています。

そして、ssromega タクティク（文献 [7]）を使って証明します。
なお、ここでは文献[7]のうちの sssromega の定義の部分だけを取り出して、
最初に ``Require Import ssromega`` で読み込んでいます。
*)

  (* 【２】の式 (a_k の定義) *)
  Function a (k : nat) {measure id k} : rat :=
    match k with
    | 0 => ratz 3                           (* fracq (3%:Z, 1%:Z) *)
    | 1 => ratz 3                           (* fracq (3%:Z, 1%:Z) *)
    | 2 => ratz 3                           (* fracq (3%:Z, 1%:Z) *)
    | k'.+3 => (a k' + a k'.+1) / a k'.+2
  end.
  - move=> k3 k2 k1 k Hk1 Hk2 Hk3.
    apply/ltP.
      by ssromega.
  - move=> k3 k2 k1 k Hk1 Hk2 Hk3.
    apply/ltP.
      by ssromega.
  - move=> k3 k2 k1 k Hk1 Hk2 Hk3.
    apply/ltP.
      by ssromega.
  Defined.               (* 実際に計算できるように、Defined で終える。 *)

(**
関数をその定義で
展開するときには、``rewrite /a`` (Standard Coq の unfold タクティク)
は使用できず。a_equation による書き換えを使わなければいけません（文献 [9]）。

これは、Function コマンドで定義した関数 a には、
その定義に余計な証明が付随するからです。
*)

(**
## 数列 b_k と c_k

a_k の定義を使います。
*)
  Definition b (k : nat) : rat := a k.*2.   (* a_k の偶数番 *)

  Definition c (k : nat) : rat := a k.*2.+1. (* a_k の奇数番 *)

(**
実際に計算してみます。正しそうですね。
*)
  Compute a 0.                              (* b_0 = 3 *)
  Compute a 1.                              (* c_0 = 3 *)
  Compute a 2.                              (* b_1 = 3 *)
  Compute a 3.                              (* c_1 = 2 *)
  Compute a 4.                              (* b_2 = 3 *)
  Compute a 5.                              (* c_2 = 5/3 *)
  Compute a 6.                              (* b_3 = 3 *)
  Compute a 7.                              (* c_3 = 14/9 *)

(**
## b_k+2 と c_k+1 の式

数学ガールの記事にあるとおり、
誘導問題に従い、b_k+2 と c_k+1 の式を求めます。

a_k の漸化式（の関数）の定義を展開するときは、a_equation を使っています。

補題 doubleS は ``2 * (n + 1)`` と ``2 * n + 2`` との間の書き換えをします。
*)

  Check doubleS : forall n : nat, (n.+1).*2 = n.*2.+2.

  Lemma lemma_1 (k : nat) :                 (* 計算で得た式(1) *)
    b k.+2 = (c k + b k.+1) / c k.+1.
  Proof.
    rewrite /b !doubleS a_equation.
    rewrite /c doubleS.
    done.
  Qed.

  Lemma lemma_2 (k : nat) :                 (* 計算で得た式(2) *)
    c k.+1 = (b k + c k) / b k.+1.
  Proof.
    rewrite /c !doubleS a_equation.
    rewrite /b doubleS.
    done.
  Qed.

(**
## ``0 < a_k`` の証明

- ``0 < a_k`` であることを証明するには、
a_k-1, a_k-2, a_k-3 の値が ``> 0`` であることが必要になります。

そこで、帰納法の仮定 ``k' < k`` の k' に対して ``a_k' < 0`` が成り立つとして、
``k' < k+1`` の k' に対して ``a_k' < 0`` が成り立つことを示す
完全帰納法 (complete induction) を使って証明します。

k についての完全帰納法を使うとき、MathComp の場合は、``elim: k {-2}k (leqnn k)``
というイデオムを使います
（文献 [8]、および、[5] の 3.2.4 Application: strengthening induction）。

- ``[| [| [| k']]]`` はパズルのようですが、a_k' の k' について条件分け（0か1以上か）
を3回繰り返すことで、a_k'+3 を取り出すためのものです。

- 補題 divr_gt0 と addr_gt0 を適用することで、``0 < (a k' + a k'.+1) / a k'.+2`` を
``0 < a k'`` と ``0 < a k'.+1`` と ``0 < a k'.+2`` に分解します。

- 最後に、それぞれに対して（完全）帰納法の仮定を適用することで得られた不等式は、ssromga
で片付けています。
*)
  Lemma ak_gt_0 k : 0 < a k.
  Proof.
    elim: k {-2}k (leqnn k) => [k | k IHk]. (* 完全帰納法のイデオム *)
    - by rewrite leqn0 => /eqP ->.
    - case=> [| [| [| k']]] Hk //. (* 条件分けで a k'+3 を取り出す。 *)
      rewrite a_equation.
      rewrite divr_gt0 //.
      + rewrite addr_gt0 //.
        * apply: IHk.
            by ssromega.
        * apply: IHk.
            by ssromega.
      + apply: IHk.
          by ssromega.
  Qed.

(**
##  ``0 < b_k`` と ``0 < c_k`` の証明

``0 < a_k`` を使います。
*)
  Lemma bk_gt_0 k : 0 < b k.
  Proof.
    rewrite /b.
      by apply: ak_gt_0.
  Qed.

  Lemma ck_gt_0 k : 0 < c k.
  Proof.
    rewrite /c.
      by apply: ak_gt_0.
  Qed.

(**
## ``b_k = b_k+1``

k についての数学的帰納法を使い、
帰納法の仮定 ``b_k = b_k+1`` が成り立つとして、``b_k+1 = b_k+2`` を示すことで証明します。
先に証明した、lemma_1とlemma_2と、帰納法の仮定を使って書き換えることで得られた、
``b_k = (c_k + b_k) / ((c_k + b_k) / b_k)`` から、
divKq で書き換えることで、``(c_k + b_k)`` を消し（分母を払い）ます。

このとき分母 ``(c_k + b_k)`` が ``> 0`` である条件を示すために、前節の補題を使います。
*)
  Lemma lemma_3 (k : nat) : b k = b k.+1.
  Proof.
    elim: k => [| k IHk] //.
    rewrite lemma_1.
    rewrite lemma_2.
    rewrite -[in RHS]IHk.
    rewrite -[in LHS]IHk.
    rewrite [b k + c k]addqC.
    rewrite [RHS]divKq; first by rewrite IHk.
    - apply: addr_gt0.
      + by apply: ck_gt_0.
      + by apply: bk_gt_0.
    - by apply: bk_gt_0.
  Qed.

(**
## 求めたかったもの : b_k の一般項 ``b_k = 3``
*)
  Theorem bk_3 (k : nat) : b k = ratz 3.    (* b の一般項 *)
  Proof.
    elim: k => [| k IHk] //.
      by rewrite -lemma_3.
  Qed.

End Question.

(**
# 文献

[1] 結城浩、数学ガールの秘密ノート - センター試験の数学的帰納法、Cakes

- 第13回 (前編) https://cakes.mu/posts/1095

- 第14回 (後編) https://cakes.mu/posts/1157

[2] 結城浩、数学ガールの秘密ノート/整数で遊ぼう、SBクリエイティブ

[3] 2013年大学入試センター試験 数学II・数学B 第3問、

https://school.js88.com/sd_article/dai/dai_center_data/pdf/2013sugaku2B_q.pdf

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

[5] Mathematical Components Book、

https://math-comp.github.io/mcb/

[6] MathComp, ssralg.v,

https://github.com/math-comp/math-comp/blob/master/mathcomp/algebra/ssralg.v

[7] Affeldt Reynald, Library ssrnat_ext,

https://staff.aist.go.jp/reynald.affeldt/coqdev/ssrnat_ext.html

[8] Coq/SSReflectでたった1行のコマンドで完全帰納法を適用する方法

https://qiita.com/nekonibox/items/514da8edfc6107b57254

[9] Advanced recursive functions

https://coq.inria.fr/refman/language/gallina-extensions.html#advanced-recursive-functions
*)

(* END *)


Require Import Cat.Category.
Require Import Iso.Isomorphism.
Require Import Grph.Graph.
Require Import Grph.GraphCat.
Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.

Theorem grph_iso_impl_srctgt_iso {X Y : Grph}
    (f : GrphHom X Y) (g : GrphHom Y X)
        : Isomorphism GrphIsCat X Y f g
            -> Isomorphism CoqIsCat (vert_of X) (vert_of Y) (vert_fn f) (vert_fn g)
                /\ Isomorphism CoqIsCat (arr_of X) (arr_of Y) (arr_fn f) (arr_fn g).
    intro iso.
    destruct f as [vf af]; destruct g as [vg ag].
    destruct iso as [proof_left proof_right].
    simpl in *.
    inversion proof_left; inversion proof_right.
    split; split; auto.
Qed.

Definition src_or_tgt (is_src : bool) :=
    if is_src then src_of else tgt_of.

Theorem inverse_proof
    {X Y : Grph}
    (f : GrphHom X Y)
    (is_src : bool)
    (vg : vert_of Y -> vert_of X) (ag : arr_of Y -> arr_of X)
    (isoV : Isomorphism CoqIsCat (vert_of X) (vert_of Y) (vert_fn f) vg)
    (isoA : Isomorphism CoqIsCat (arr_of X) (arr_of Y) (arr_fn f) ag)
        : compose (src_or_tgt is_src X) ag = compose vg (src_or_tgt is_src Y).
    destruct isoV as [proof_left_v proof_right_v].
    destruct isoA as [proof_left_a proof_right_a].
    destruct f as [vf af proof_src_f proof_tgt_f].
    destruct X as [VX AX Xgraph]; destruct Y as [VY AY Ygraph].
    pose (sot_X := src_or_tgt is_src (grph Xgraph)).
    fold sot_X.
    pose (sot_Y := src_or_tgt is_src (grph Ygraph)).
    fold sot_Y.
    simpl in *.
    assert (compose sot_Y af = compose vf sot_X).
        unfold sot_Y; unfold sot_X; unfold src_or_tgt;
        case is_src; [ apply proof_src_f | apply proof_tgt_f ].
    rename H into proof_f.
    clear proof_src_f proof_tgt_f.
    assert (compose vg (compose (compose sot_Y af) ag) = compose (compose vg (compose vf sot_X)) ag).
        rewrite proof_f.
        pose (ca := comp_assoc ag (compose vf sot_X) vg);
        rewrite <- ca;
        reflexivity.
    pose (afag := comp_assoc ag af sot_Y); rewrite <- afag in H; clear afag.
    rewrite proof_right_a in H.
    pose (vgvf := comp_assoc sot_X vf vg); rewrite vgvf in H; clear vgvf.
    rewrite proof_left_v in H.
    pose (sy := id_right sot_Y).
    pose (sx := id_left sot_X).
    rewrite sy in H; rewrite sx in H.
    intuition.
Qed.

Theorem srctgt_iso_impl_graph_iso {X Y : Grph}
    (f : GrphHom X Y)
    (vg : vert_of Y -> vert_of X) (ag : arr_of Y -> arr_of X)
    (isoV : Isomorphism CoqIsCat (vert_of X) (vert_of Y) (vert_fn f) vg)
    (isoA : Isomorphism CoqIsCat (arr_of X) (arr_of Y) (arr_fn f) ag)
            : Isomorphism GrphIsCat X Y
                f
                (grph_hom Y X vg ag
                    (inverse_proof f true vg ag isoV isoA)
                    (inverse_proof f false vg ag isoV isoA)).
    destruct isoV as [fv gv left_v right_v].
    destruct isoA as [fa ga left_a right_a].
    destruct f as [vertex_f arr_f f_proof_src f_proof_tgt].
    simpl in *.
    split;
        apply grph_hom_eq;
        assumption.
Qed.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (n : natural) (x : lst) : natural := len (append x (Cons n x)).