Definition cong_pair :=
fun (A1 A2 : Type) (B1 : A1 -> Type) (B2 : A2 -> Type) (u1 : A1) (u2 : A2)
  (v1 : B1 u1) (v2 : B2 u2) (hA : A1 ≅ A2) (hB : forall p : Pack A1 A2, B1 (ProjT1 p) ≅ B2 (ProjT2 p))
  (hu : u1 ≅ u2) (hv : v1 ≅ v2) =>
match hA with
| @heqPair _ _ _ _ pT pA =>
    let pA0 : transport eq_refl A1 = A2 :=
      Logic.eq_ind pT (fun pT0 : Type = Type => transport pT0 A1 = A2) pA eq_refl (K pT) in
    match
      pA0 in (_ = y)
      return
        (forall (B3 : y -> Type) (u3 : y) (v3 : B3 u3),
         (forall p : Pack A1 y, B1 (ProjT1 p) ≅ B3 (ProjT2 p)) ->
         u1 ≅ u3 -> v1 ≅ v3 -> epair u1 v1 ≅ epair u3 v3)
    with
    | eq_refl =>
        fun (B3 : A1 -> Type) (u3 : A1) (v3 : B3 u3)
          (hB0 : forall p : Pack A1 A1, B1 (ProjT1 p) ≅ B3 (ProjT2 p)) (hu0 : u1 ≅ u3)
          (hv0 : v1 ≅ v3) =>
        let pB : B1 = B3 :=
          funext
            (fun x : A1 =>
             let h :
               B1 (ProjT1 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})
               ≅ B3 (ProjT2 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |}) :=
               hB0 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |} in
             match h with
             | @heqPair _ _ _ _ pT0 pB =>
                 let pB0 :
                   transport eq_refl
                     (B1 (ProjT1 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})) =
                   B3 (ProjT2 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |}) :=
                   Logic.eq_ind pT0
                     (fun pT1 : Type = Type =>
                      transport pT1 (B1 (ProjT1 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})) =
                      B3 (ProjT2 {| ProjT1 := x; ProjT2 := x; ProjTe := heq_refl x |})) pB eq_refl
                     (K pT0) in
                 pB0
             end) in
        match
          pB in (_ = y)
          return
            (forall v4 : y u3,
             (forall p : Pack A1 A1, B1 (ProjT1 p) ≅ y (ProjT2 p)) ->
             v1 ≅ v4 -> epair u1 v1 ≅ epair u3 v4)
        with
        | eq_refl =>
            fun (v4 : B1 u3) (_ : forall p : Pack A1 A1, B1 (ProjT1 p) ≅ B1 (ProjT2 p))
              (hv1 : v1 ≅ v4) =>
            match hu0 with
            | @heqPair _ _ _ _ pT0 pu =>
                let pu0 : transport eq_refl u1 = u3 :=
                  Logic.eq_ind pT0 (fun pT1 : A1 = A1 => transport pT1 u1 = u3) pu eq_refl (K pT0) in
                match
                  pu0 in (_ = y) return (forall v5 : B1 y, v1 ≅ v5 -> epair u1 v1 ≅ epair y v5)
                with
                | eq_refl =>
                    fun (v5 : B1 u1) (hv2 : v1 ≅ v5) =>
                    match hv2 with
                    | @heqPair _ _ _ _ pT1 pv =>
                        let pv0 : transport eq_refl v1 = v5 :=
                          Logic.eq_ind pT1 (fun pT2 : B1 u1 = B1 u1 => transport pT2 v1 = v5) pv
                            eq_refl (K pT1) in
                        match pv0 in (_ = y) return (epair u1 v1 ≅ epair u1 y) with
                        | eq_refl => heq_refl (epair u1 v1)
                        end
                    end
                end v4 hv1
            end
        end v3 hB0 hv0
    end B2 u2 v2 hB hu hv
end
     : forall (A1 A2 : Type) (B1 : A1 -> Type) (B2 : A2 -> Type) (u1 : A1)
         (u2 : A2) (v1 : B1 u1) (v2 : B2 u2),
       A1 ≅ A2 ->
       (forall p : Pack A1 A2, B1 (ProjT1 p) ≅ B2 (ProjT2 p)) ->
       u1 ≅ u2 -> v1 ≅ v2 -> epair u1 v1 ≅ epair u2 v2.


Require Import TestSuite.admit.
Require Setoid.

Variables P Q : forall {T : Set}, T -> Prop.

Lemma rule{T : Set}{x : T} : Q x <-> P x. admit. Qed.

Goal forall (T : Set)(x : T), Q x <-> P x.
Proof.
intros T x.
setoid_rewrite rule.
reflexivity.
Qed.


From Hammer Require Import Hammer.

From compcert Require Import Raux.
From compcert Require Import Defs.
From compcert Require Import Generic_fmt.
From compcert Require Import Operations.

Section Fprop_Sterbenz.

Variable beta : radix.
Notation bpow e := (bpow beta e).

Variable fexp : Z -> Z.
Context { valid_exp : Valid_exp fexp }.
Context { monotone_exp : Monotone_exp fexp }.
Notation format := (generic_format beta fexp).

Theorem generic_format_plus :
forall x y,
format x -> format y ->
(Rabs (x + y) <= bpow (Z.min (mag beta x) (mag beta y)))%R ->
format (x + y)%R.
Proof. hammer_hook "Sterbenz" "Sterbenz.generic_format_plus".
intros x y Fx Fy Hxy.
destruct (Req_dec (x + y) 0) as [Zxy|Zxy].
rewrite Zxy.
apply generic_format_0.
destruct (Req_dec x R0) as [Zx|Zx].
now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
destruct Hxy as [Hxy|Hxy].
revert Hxy.
destruct (mag beta x) as (ex, Ex). simpl.
specialize (Ex Zx).
destruct (mag beta y) as (ey, Ey). simpl.
specialize (Ey Zy).
intros Hxy.
set (fx := Float beta (Ztrunc (scaled_mantissa beta fexp x)) (fexp ex)).
assert (Hx: x = F2R fx).
rewrite Fx at 1.
unfold cexp.
now rewrite mag_unique with (1 := Ex).
set (fy := Float beta (Ztrunc (scaled_mantissa beta fexp y)) (fexp ey)).
assert (Hy: y = F2R fy).
rewrite Fy at 1.
unfold cexp.
now rewrite mag_unique with (1 := Ey).
rewrite Hx, Hy.
rewrite <- F2R_plus.
apply generic_format_F2R.
intros _.
case_eq (Fplus fx fy).
intros mxy exy Pxy.
rewrite <- Pxy, F2R_plus, <- Hx, <- Hy.
unfold cexp.
replace exy with (fexp (Z.min ex ey)).
apply monotone_exp.
now apply mag_le_bpow.
replace exy with (Fexp (Fplus fx fy)) by exact (f_equal Fexp Pxy).
rewrite Fexp_Fplus.
simpl. clear -monotone_exp.
apply sym_eq.
destruct (Zmin_spec ex ey) as [(H1,H2)|(H1,H2)] ; rewrite H2.
apply Z.min_l.
now apply monotone_exp.
apply Z.min_r.
apply monotone_exp.
apply Zlt_le_weak.
now apply Z.gt_lt.
apply generic_format_abs_inv.
rewrite Hxy.
apply generic_format_bpow.
apply valid_exp.
case (Zmin_spec (mag beta x) (mag beta y)); intros (H1,H2);
rewrite H2; now apply mag_generic_gt.
Qed.

Theorem generic_format_plus_weak :
forall x y,
format x -> format y ->
(Rabs (x + y) <= Rmin (Rabs x) (Rabs y))%R ->
format (x + y)%R.
Proof. hammer_hook "Sterbenz" "Sterbenz.generic_format_plus_weak".
intros x y Fx Fy Hxy.
destruct (Req_dec x R0) as [Zx|Zx].
now rewrite Zx, Rplus_0_l.
destruct (Req_dec y R0) as [Zy|Zy].
now rewrite Zy, Rplus_0_r.
apply generic_format_plus ; try assumption.
apply Rle_trans with (1 := Hxy).
unfold Rmin.
destruct (Rle_dec (Rabs x) (Rabs y)) as [Hxy'|Hxy'].
rewrite Z.min_l.
destruct (mag beta x) as (ex, Hx).
apply Rlt_le; now apply Hx.
now apply mag_le_abs.
rewrite Z.min_r.
destruct (mag beta y) as (ex, Hy).
apply Rlt_le; now apply Hy.
apply mag_le_abs.
exact Zy.
apply Rlt_le.
now apply Rnot_le_lt.
Qed.

Lemma sterbenz_aux :
forall x y, format x -> format y ->
(y <= x <= 2 * y)%R ->
format (x - y)%R.
Proof. hammer_hook "Sterbenz" "Sterbenz.sterbenz_aux".
intros x y Hx Hy (Hxy1, Hxy2).
unfold Rminus.
apply generic_format_plus_weak.
exact Hx.
now apply generic_format_opp.
rewrite Rabs_pos_eq.
rewrite Rabs_Ropp.
rewrite Rmin_comm.
assert (Hy0: (0 <= y)%R).
apply Rplus_le_reg_r with y.
apply Rle_trans with x.
now rewrite Rplus_0_l.
now replace (y + y)%R with (2 * y)%R by ring.
rewrite Rabs_pos_eq with (1 := Hy0).
rewrite Rabs_pos_eq.
unfold Rmin.
destruct (Rle_dec y x) as [Hyx|Hyx].
apply Rplus_le_reg_r with y.
now ring_simplify.
now elim Hyx.
now apply Rle_trans with y.
now apply Rle_0_minus.
Qed.

Theorem sterbenz :
forall x y, format x -> format y ->
(y / 2 <= x <= 2 * y)%R ->
format (x - y)%R.
Proof. hammer_hook "Sterbenz" "Sterbenz.sterbenz".
intros x y Hx Hy (Hxy1, Hxy2).
destruct (Rle_or_lt x y) as [Hxy|Hxy].
rewrite <- Ropp_minus_distr.
apply generic_format_opp.
apply sterbenz_aux ; try easy.
split.
exact Hxy.
apply Rcompare_not_Lt_inv.
rewrite <- Rcompare_half_r.
now apply Rcompare_not_Lt.
apply sterbenz_aux ; try easy.
split.
now apply Rlt_le.
exact Hxy2.
Qed.

End Fprop_Sterbenz.


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq choice fintype.
From mathcomp Require Import finfun bigop finset.
Require Import Reals Fourier Rpower.
Require Import Reals_ext Rssr Ranalysis_ext log2 ln_facts Rbigop.

Local Open Scope reals_ext_scope.

Local Notation "'\rsum_{' C '}' f" :=
  (\rsum_(a | a \in C) f a) (at level 10, format "\rsum_{ C }  f").

Definition log_sum_stmt {A : finType} (C : {set A}) (f g : A -> R+) :=
  f << g ->
  \rsum_{C} f * log (\rsum_{C} f / \rsum_{C} g) <= \rsum_(a | a \in C) f a * log (f a / g a).

Lemma log_sum1 {A : finType} (C : {set A}) (f g : A -> R+) :
  (forall a, a \in C -> 0 < f a) -> log_sum_stmt C f g.
Proof.
move=> fspos fg.
case/boolP : (C == set0) => [ /eqP -> | Hc].
  rewrite !big_set0 mul0R; by apply Rle_refl.
have gspos : forall a, a \in C -> 0 < g a.
  move=> a a_C.
  case/Rle_lt_or_eq_dec : ((Rle0f g) a) => // abs; symmetry in abs; apply fg in abs.
  move: (fspos _ a_C); by rewrite abs; move/Rlt_irrefl.
have Fnot0 : \rsum_{ C } f <> 0.
  move=> abs; symmetry in abs.
  move/(@Req_0_rmul_inv _ (fun x => x \in C) (pos_f f) (Rle0f f)) in abs.
  case/set0Pn : Hc => a a_C.
  move: (fspos _ a_C).
  rewrite -abs //; by move/Rlt_irrefl.
have Gnot0 : \rsum_{ C } g <> 0.
  move=> abs; symmetry in abs.
  move/(@Req_0_rmul_inv _ (fun x => x \in C) (pos_f g) (Rle0f g)) in abs.
  case/set0Pn : Hc => a a_C.
  move: (gspos _ a_C).
  rewrite -abs //; by move/Rlt_irrefl.
wlog : Fnot0 g Gnot0 fg gspos / \rsum_{ C } f = \rsum_{ C } g.
  move=> Hwlog.
  set k := \rsum_{ C } f / \rsum_{ C } g.
  have Fspos : 0 < \rsum_{ C } f.
    suff Fpos : 0 <= \rsum_{ C } f.
      apply Rlt_le_neq => //; by apply not_eq_sym.
    apply: Rle_big_0_P_g => a C_a; by apply Rlt_le, fspos.
  have Gspos : 0 < \rsum_{ C } g.
    suff Gpocs : 0 <= \rsum_{ C } g.
      apply Rlt_le_neq => //; by apply not_eq_sym.
    apply: Rle_big_0_P_g => a C_a; by apply Rlt_le, gspos.
  have kspos : 0 < k by apply Rlt_mult_inv_pos.
  have kg_pos : forall a, 0 <= k * g a.
    move=> a; apply Rmult_le_pos; by [apply Rlt_le | apply Rle0f].
  have kabs_con : forall a, k * g a = 0 -> f a = 0.
    move=> a.
    case/Rmult_integral.
    - move=> Hk; rewrite Hk in kspos; by move/Rlt_irrefl : kspos.
    - by move/fg.
  have kgspos : forall a, a \in C -> 0 < k * g a.
    move=> a a_C; apply Rmult_lt_0_compat => //; by apply gspos.
  have Hkg : \rsum_(a | a \in C) k * g a = \rsum_{C} f.
    by rewrite -big_distrr /= /k /Rdiv -mulRA mulRC Rinv_l // mul1R.
  have Htmp : \rsum_{ C } {| pos_f := fun x : A => k * g x; Rle0f := kg_pos |} <> 0.
    by rewrite /= Hkg.
  symmetry in Hkg.
  move: {Hwlog}(Hwlog Fnot0 (@mkPosFun _ (fun x => (k * g x)) kg_pos) Htmp kabs_con kgspos Hkg) => /= Hwlog.
  rewrite Hkg {1}/Rdiv Rinv_r // log_1 Rmult_0_r in Hwlog.
  set rhs := \rsum_(_ | _) _ in Hwlog.
  rewrite (_ : rhs = \rsum_(a | a \in C) (f a * log (f a / g a) - f a * log k)) in Hwlog; last first.
    rewrite /rhs.
    apply eq_bigr => a a_C.
    rewrite /Rdiv log_mult; last 2 first.
      by apply fspos.
      apply Rinv_0_lt_compat, Rmult_lt_0_compat => //; by apply gspos.
    rewrite log_Rinv; last first.
      apply Rmult_lt_0_compat => //; by apply gspos.
    rewrite log_mult //; last by apply gspos.
    rewrite log_mult //; last 2 first.
      by apply fspos.
      apply Rinv_0_lt_compat; by [apply gspos | apply fspos].
    rewrite log_Rinv; by [field | apply gspos].
  rewrite big_split /= -(big_morph _ morph_Ropp Ropp_0) -big_distrl /= in Hwlog.
  have : forall a b, 0 <= a + - b -> b <= a by move=> *; fourier.
  by apply.
move=> Htmp; rewrite Htmp.
rewrite /Rdiv Rinv_r; last by rewrite -Htmp.
rewrite log_1 mulR0.
suff : 0 <= \rsum_(a | a \in C) f a * ln (f a / g a).
  move=> H.
  rewrite /log /Rdiv.
  set rhs := \rsum_( _ | _ ) _.
  have -> : rhs = \rsum_(H | H \in C) (f H * (ln (f H / g H))) / ln 2.
    rewrite /rhs.
    apply eq_bigr => a a_C; by rewrite /Rdiv -mulRA.
  rewrite -big_distrl /=.
  apply Rmult_le_pos => //; by apply Rlt_le, Rinv_0_lt_compat, ln_2_pos.
apply Rle_trans with (\rsum_(a | a \in C) f a * (1 - g a / f a)).
  apply Rle_trans with (\rsum_(a | a \in C) (f a - g a)).
    rewrite big_split /= -(big_morph _ morph_Ropp Ropp_0); fourier.
  apply Req_le, eq_bigr => a a_C.
  rewrite Rmult_minus_distr_l mulR1.
  case: (Req_EM_T (g a) 0).
    move=> ->; by rewrite /Rdiv mul0R mulR0.
  move=> ga_not_0.
  field.
  move=> abs; move: (fspos _ a_C); rewrite abs; by move/Rlt_irrefl.
apply: Rle_big_P_f_g => a C_a.
apply Rmult_le_compat_l; first by apply Rlt_le, fspos.
apply Ropp_le_cancel.
rewrite -ln_Rinv; last first.
  apply Rlt_mult_inv_pos; by [apply fspos | apply gspos].
rewrite Rinv_mult_distr; last 2 first.
  move=> abs. move: (fspos _ C_a). rewrite abs; by move/Rlt_irrefl.
  apply Rinv_neq_0_compat.
  move=> abs. move: (gspos _ C_a). rewrite abs; by move/Rlt_irrefl.
rewrite Rinv_involutive; last first.
  move=> abs. move: (gspos _ C_a). rewrite abs; by move/Rlt_irrefl.
rewrite mulRC.
eapply Rle_trans.
  apply ln_id_cmp.
  apply Rlt_mult_inv_pos; by [apply gspos | apply fspos].
apply Req_le.
field.
move=> abs; move: (fspos _ C_a); rewrite abs; by move/Rlt_irrefl.
Qed.

(** * The log-sum Inequality *)

Lemma log_sum {A : finType} (C : {set A}) (f g : A -> R+) :
  log_sum_stmt C f g.
Proof.
move=> fg.
set D := [set a | (a \in C) && (f a != 0)].
suff : \rsum_{D} f * log (\rsum_{D} f / \rsum_{D} g) <=
       \rsum_(a | a \in D) f a * log (f a / g a).
  move=> H.
  set D' := [set a in C | f a == 0].
  have DUD' : C = D :|: D'.
    apply/setP => a.
    move Hlhs : (a \in C) => lhs.
    destruct lhs => //.
      symmetry.
      rewrite in_setU /C1 /C1 !in_set Hlhs /=.
      by destruct (f a == 0).
    by rewrite in_setU in_set Hlhs /= /C1 in_set Hlhs.
  have DID' : [disjoint D & D'].
    rewrite -setI_eq0.
    apply/eqP/setP => a.
    rewrite in_set0 /C1 /C1 in_setI !in_set.
    destruct (a \in C) => //=; by rewrite andNb.
  have H1 : \rsum_{C} f = \rsum_{D} f.
    rewrite setUC in DUD'.
    rewrite (rsum_union _ _ _ f DID' DUD').
    rewrite (_ : \rsum_{D'} f = \rsum_(a | a \in D') 0); last first.
      apply eq_bigr => a a_C2.
      rewrite /D' in_set in a_C2.
      by case/andP : a_C2 => _ /eqP.
    by rewrite big_const iter_Rplus mulR0 add0R.
  rewrite -H1 in H.
  have pos_F : 0 <= \rsum_{C} f.
    apply Rle_big_0_P_g => ? ?; by apply Rle0f.
  apply Rle_trans with (\rsum_{C} f * log (\rsum_{C} f / \rsum_{D} g)).
    case/Rle_lt_or_eq_dec : pos_F => pos_F; last first.
      rewrite -pos_F !mul0R; by apply Rle_refl.
    have H2 : 0 <= \rsum_(a | a \in D) g a.
      apply: Rle_big_0_P_g => a _; by apply Rle0f.
    case/Rle_lt_or_eq_dec : H2 => H2; last first.
      have : 0 = \rsum_{D} f.
        transitivity (\rsum_(a | a \in D) 0).
          by rewrite big_const iter_Rplus Rmult_0_r.
        apply eq_bigr => a a_C1.
        rewrite fg //.
        by rewrite -(@Req_0_rmul_inv _ (fun x => x \in D) (pos_f g) (Rle0f g) H2) //.
      move=> abs; rewrite -abs in H1; rewrite H1 in pos_F.
      by move/Rlt_irrefl : pos_F.
    have H3 : 0 < \rsum_(a | a \in C) g a.
      rewrite setUC in DUD'.
      rewrite (rsum_union _ _ _ g DID' DUD').
      apply Rplus_le_lt_0_compat => //.
      apply: Rle_big_0_P_g => *; by apply Rle0f.
    apply Rmult_le_compat_l; first by apply Rlt_le.
    apply log_increasing_le.
      apply Rlt_mult_inv_pos => //; by rewrite -HG.
    apply Rmult_le_compat_l; first by apply Rlt_le.
    apply Rle_Rinv => //.
    rewrite setUC in DUD'.
    rewrite (rsum_union _ _ _ g DID' DUD').
    rewrite -[X in X <= _]add0R.
    apply Rplus_le_compat_r.
    apply: Rle_big_0_P_g => a C2_a; by apply Rle0f.
  eapply Rle_trans; first by apply H.
  rewrite setUC in DUD'.
  rewrite (rsum_union _ _ _ (fun a => f a * log (f a / g a)) DID' DUD').
  rewrite (_ : \rsum_(_ | _ \in D') _ = 0); last first.
    transitivity (\rsum_(a | a \in D') 0).
      apply eq_bigr => a.
      rewrite /D' in_set.
      case/andP => a_C /eqP fa0.
      by rewrite fa0 mul0R.
    by rewrite big_const iter_Rplus Rmult_0_r.
  rewrite add0R; by apply Rle_refl.
apply log_sum1 => // a.
rewrite /C1 in_set.
case/andP => a_C fa_not_0.
case/Rle_lt_or_eq_dec: (Rle0f f a) => // abs.
by rewrite abs eqxx in fa_not_0.
Qed.


Require Import Blech.Defaults.

Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.SetoidClass.

Require Import Blech.Bishop.
Require Import Blech.Category.
Require Import Blech.Groupoid.
Require Import Blech.Monoid.
Require Import Blech.Group.
Require Blech.PointedGroupoid.
Require Blech.Pointed.

Require Blech.Reflect.

Import BishopNotations.
Import CategoryNotations.
Import GroupoidNotations.
Import MonoidNotations.
Import GroupNotations.
Import Pointed.PointedNotations.
Import PointedGroupoid.PointedNotations.

Open Scope category_scope.
Open Scope bishop_scope.
Open Scope monoid_scope.
Open Scope group_scope.

#[local]
Obligation Tactic := Reflect.category_simpl.

#[program]
Definition Λ (C: PointedGroupoid.Groupoid): Group := {|
  M := {|
        S := C PointedGroupoid.pt PointedGroupoid.pt /~ Mor_Setoid _ _ ;
        e := id _ ;
        app := @compose _ _ _ _ ;
      |} ;
  invert := @Groupoid.invert _ _ _ ;
|}.

Next Obligation.
Proof.
  apply compose_invert_left.
Qed.

Next Obligation.
Proof.
  apply compose_invert_right.
Qed.


Require Import Reals Lra Lia.
From mathcomp Require Import all_ssreflect.
From Coquelicot Require Import Coquelicot.
From Actuary Require Import all_Actuary.
Unset Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(****************************************************************************************)

Section Example1.

Variable l:life.
Hypothesis l_fin : (l_finite l).

Notation "\p_{ t & u }" := (\p[l]_{t&u}) (at level 9).
Notation "\ω" := (\ω[l,l_fin]) (at level 8).

Notation "\a''[ i ]_{ x : n }" := (\a''[i,l]_{x:n}) (at level 9, x at level 9).

Lemma ann_due_decr_i : forall (i i' : R) (x n : nat), 0 < i -> 0 < i' -> x < \ω ->
  i <= i' -> \a''[i']_{x:n} <= \a''[i]_{x:n}.
Proof.
  move => i i' x n Hipos Hi'pos Hx Hleii'.
  have Hvpos : 0 < \v[i] by apply /v_pos /Hipos.
  have Hv'pos : 0 < \v[i'] by apply /v_pos /Hi'pos.
  rewrite !ann_due_annual.
  apply Rsum_le_compat => k /andP; case => /leP Hmk /ltP Hkn.
  apply Rmult_le_compat_r; [by apply (p_nonneg _ l_fin) |].
  case: (zerop k) => [Hk0 | Hkpos].
  - rewrite Hk0 !Rpower_O //; lra.
  - case: (Rle_lt_or_eq_dec i i') => // [Hlt | Heq].
    + rewrite /Rpower.
      apply /Rlt_le /exp_increasing.
      apply Rmult_lt_compat_l; [rewrite (_ : 0 = INR 0%N) //; apply lt_INR => // |].
      apply ln_increasing => //.
      rewrite /v_pres.
      apply Rinv_1_lt_contravar; lra.
    + rewrite Heq; lra.
Qed.

End Example1.

(****************************************************************************************)

Section Example2.

Variable i:R.
Hypothesis i_pos : 0 < i.

Variable l:life.
Hypothesis l_fin : (l_finite l).

Notation "\ω" := (\ω[l,l_fin]) (at level 8).
Notation "\A_{ x `1: n }" := (\A[i,l]_{x`1:n}) (at level 9, x at level 9).
Notation "\A_{ x : n `1}" := (\A[i,l]_{x:n`1}) (at level 9, x at level 9).
Notation "\A_{ x : n }" := (\A[i,l]_{x:n}) (at level 9, x at level 9).
Notation "\a''_{ x : n }" := (\a''[i,l]_{x:n}) (at level 9, x at level 9).
Notation "\s''_{ x : n }" := (\s''[i,l]_{x:n}) (at level 9, x at level 9).
Notation "\P_{ x : n }" := (\P[i,l]_{x:n}) (at level 9, x at level 9).
Notation "\V_{ t & x : n }" := (\V[i,l]_{t&x:n}) (at level 9, x at level 9).

Theorem res_eq_pros_retro : forall (t x n : nat), x+t < \ω -> t <= n -> 0 < n ->
  \V_{t & x:n} = \P_{x:n} * \s''_{x:t} - \A_{x`1:t} / \A_{x:t`1}.
Proof.
  move => t x n Hxt Htn Hn.
  have Hx : x < \ω by apply lt_INR; move: Hxt; rewrite -plus_INR => /INR_lt; lia.
  have Ha'' : \a''_{ x : n} <> 0.
  { apply /pos_neq0.
    eapply Rlt_le_trans; [| apply (ann_due_lb _ i_pos _ l_fin) => //].
      by apply Rinv_0_lt_compat. }
  rewrite (_ : \s''_{x:t} = (\a''_{x:n} / \A_{x:t`1} - \a''_{(x+t):(n-t)})).
  2:{ rewrite -(acc_due_plus_ann_due _ _ _ _ t) //.
      rewrite /Rdiv (Rmult_assoc _ \A_{x:t`1}) Rinv_r;
        [| apply /pos_neq0 /(ins_pure_endow_pos _ _ l_fin) => //]; lra. }
  rewrite Rmult_plus_distr_l.
  rewrite {1}/prem_endow_life.
  rewrite /Rdiv -Rmult_assoc (Rmult_assoc \A_{_:_}) Rinv_l // Rmult_1_r.
  rewrite /Rminus Rplus_assoc (Rplus_comm _ (-_)) -Rplus_assoc
    -/(Rminus (_*_) (_*_)) -Rmult_minus_distr_r.
  rewrite (_ : (\A_{x:n} - \A_{x `1:t}) */ \A_{x:t`1} = \A_{(x+t):(n-t)}).
  2:{ rewrite (ins_endow_pure_endow _ _ _ _ t) //.
      rewrite Rplus_comm Ropp_r_simpl_l Rmult_comm -Rmult_assoc Rinv_l;
        [| by apply /pos_neq0 /(ins_pure_endow_pos _ _ l_fin)]; lra. }
  rewrite /res_endow_life; lra.
Qed.

End Example2.

(****************************************************************************************)

Section Example3.

Variable i:R.
Hypothesis i_pos : 0 < i.

Variable l:life.
Hypothesis l_fin : (l_finite l).
Hypothesis l_C1 : forall u:R, ex_derive l u /\ continuous (Derive l) u.

Notation "\δ" := (\δ[i]) (at level 9).
Notation "\v" := (\v[i]) (at level 9).
Notation "\l_ u" := (\l[l]_u) (at level 9).
Notation "\ψ" := (\ψ[l]) (at level 8).
Notation "\μ_ u" := (\μ[l]_u) (at level 9).
Notation "\A_{ u : n `1}" := (\A[i,l]_{u:n`1}) (at level 9, u at level 9).
Notation "\Abar_{ u `1: n }" := (\Abar[i,l]_{u`1:n}) (at level 9, u at level 9).
Notation "\Abar_{ u : n }" := (\Abar[i,l]_{u:n}) (at level 9, u at level 9).
Notation "\abar_{ u : n }" := (\abar[i,l]_{u:n}) (at level 9, u at level 9).
Notation "\Pbar^{p_infty}_{ u : n }" :=
  (\Pbar[i,l]^{p_infty}_{u:n}) (at level 9, u at level 9).
Notation "\Vbar^{p_infty}_{ t & u : n }" :=
  (\Vbar[i,l]^{p_infty}_{t&u:n}) (at level 9, u at level 9).

Theorem Thiele_ODE : forall t u n : R, u+t < \ψ ->
  is_derive (fun t:R => \Vbar^{p_infty}_{t & u:n}) t
    (\Pbar^{p_infty}_{u:n} - \μ_(u+t) + (\δ + \μ_(u+t)) * \Vbar^{p_infty}_{t & u:n}).
Proof.
  move => t u n Hut.
  set (eps := \ψ - (u+t)).
  have Heps : 0 < eps by rewrite /eps; lra.
  set (Reps := mkposreal eps Heps).
  have HexDpowv : ex_derive [eta Rpower \v] t by apply ex_derive_Rpower_snd.
  have Hut'Rbar : forall t':R, u+t' < \ψ -> Rbar_lt (u+t') \ψ
      by move => t' Ht'; rewrite -psi_finite //.
  have Hvneq0 : forall t':R, u+t' < \ψ -> \v^t' <> 0 by move => t' Ht'; apply /pos_neq0 /exp_pos.
  have Hlneq0 : forall t':R, u+t' < \ψ -> \l_(u+t') <> 0
      by move => t' Ht'; apply /pos_neq0 /l_u_pos; auto.
  have HC0vl : forall r:R, continuous (fun r:R => \v^r * \l_(u+r)) r.
  { move => r.
    apply (continuous_mult (Rpower \v)); [apply continuous_Rpower_snd |].
    apply continuous_comp;
      [apply continuous_Rplus_snd | apply (ex_derive_continuous l); apply l_C1]. }
  have HC0vDl : forall r:R, continuous (fun r:R => \v^r * Derive l (u+r)) r.
  { move => r.
    apply (continuous_mult (Rpower \v)); [apply continuous_Rpower_snd |].
    apply continuous_comp; [apply continuous_Rplus_snd | apply l_C1]. }
  have Hterm : forall t':R, u+t' < \ψ ->
    \Abar_{(u+t')`1:(n-t')} =
    - / (\v^t' * \l_(u+t')) * RInt (fun r:R => \v^r * Derive l (u+r)) t' n.
  { move => t' Hut'.
    rewrite /ins_term_life_cont.
    under RInt_ext => s Hs.
    { rewrite Derive_incr; [| apply l_C1].
      rewrite Rplus_assoc (Rplus_comm t' s).
      rewrite {1}(_ : s = s + t' - t'); [| lra].
      rewrite /Rminus Rpower_plus Rpower_Ropp (Rmult_comm _ (/ \v^t')).
      rewrite Rmult_assoc {1}(_ : Rmult = scal) //.
      over. }
    rewrite RInt_scal /scal /= /mult /=.
    2:{ apply ex_RInt_continuous => r _.
          by apply (continuous_comp _ (fun r:R => \v^r * Derive l (u+r)));
            [apply continuous_Rplus_fst |]. }
    rewrite (@RInt_comp_plus _ (fun r:R => \v^r * Derive l (u+r)));
      [| by apply ex_RInt_continuous => r _].
    rewrite Rplus_0_l (_ : n - t' + t' = n); [| lra].
    field; auto. }
  have Hpureendow : forall t':R, u+t' < \ψ ->
    \A_{(u+t'):(n-t')`1} = (\v^n * \l_(u+n)) / (\v^t' * \l_(u+t')).
  { move => t' Ht'.
    rewrite /ins_pure_endow_life /survive.
    rewrite (_ : u+t'+(n-t') = u+n); [| lra].
    rewrite /Rminus Rpower_plus Rpower_Ropp.
    field; auto. }
  have Hann : forall t':R, u+t' < \ψ ->
    \abar_{(u+t'):(n-t')} = / (\v^t' * \l_(u+t')) * RInt (fun r:R => \v^r * \l_(u+r)) t' n.
  { move => t' Hut'.
    rewrite /life_ann_cont /survive.
    under RInt_ext => s Hs.
    { rewrite Rplus_assoc (Rplus_comm t' s).
      rewrite {1}(_ : s = s + t' - t'); [| lra].
      rewrite (_ : \v^(s+t'-t') * (\l_(u+(s+t')) / \l_(u+t')) =
                   / (\v^t' * \l_(u+t')) * (\v^(s+t') * \l_(u+(s+t'))));
        [| rewrite /Rminus Rpower_plus Rpower_Ropp; field; auto].
      over. }
    rewrite {1}(_ : Rmult = scal) // RInt_scal /scal /= /mult /=.
    - rewrite (@RInt_comp_plus _ (fun r:R => \v^r * \l_(u+r)));
        [| by apply ex_RInt_continuous => r _].
      by rewrite Rplus_0_l (_ : n-t'+t' = n); [| lra].
    - apply ex_RInt_continuous => r _.
        by apply (continuous_comp _ (fun r:R => \v^r * \l_(u+r)));
          [apply continuous_Rplus_fst |]. }
  rewrite /res_cont_endow_life_cont /ins_endow_life_cont.
  rewrite Hterm //.
  rewrite Hpureendow //.
  rewrite Hann //.
  apply (is_derive_ext_loc (fun t':R =>
    - /(\v^t'*\l_(u+t')) * RInt (fun r:R => \v^r * Derive l (u+r)) t' n
    + \v^n * \l_(u+n) / (\v^t'*\l_(u+t'))
    - \Pbar^{p_infty}_{u:n} * /(\v^t'*\l_(u+t')) * RInt (fun r:R => \v^r * \l_(u+r)) t' n
  )).
  { exists Reps => t' Ht'.
    have Ht'' : u+t' < \ψ
      by move: Ht'; rewrite /ball /= /AbsRing_ball /abs /minus /plus /opp /= /eps;
      case /Rabs_def2; lra.
    rewrite Hterm //.
    rewrite Hpureendow //.
    rewrite Hann //.
    lra. }
  auto_derive; try repeat split; auto; try apply l_C1.
  1,3 : by apply @ex_RInt_continuous.
  1,2 : by exists Reps => t' Ht'; apply continuity_pt_continuous.
  rewrite (is_derive_unique _ _ _ (is_derive_vpow i_pos t)).
  rewrite /d_force (_ : Derive [eta l] (u+t) = Derive l (u+t)) //.
  field; auto.
Qed.

End Example3.

Section Example4.

(* In this section, we consider verifying a problem of life insurance mathematics. *)

(* Problem 1 (3). *)
(* (Translated from the examination of Life Insurance Mathematics, 2019, *)
(* the Institute of Actuaries of Japan.) *)
(* Suppose \A_x = 0.8499, \A_(x+1) = 0.8573, \i = 0.015. *)
(* Then select the value closest to \p_x among the alternatives. *)
(* (A) 0.9610  (B) 0.9613  (C) 0.9616  (D) 0.9619  (E) 0.9622 *)
(* (F) 0.9625  (G) 0.9628  (H) 0.9631  (I) 0.9634  (J) 0.9637 *)
(* Solution. *)
(* (F) *)

Variable i:R.
Hypothesis i_pos : 0 < i.

Variable l:life.
Hypothesis l_fin : (l_finite l).

Notation "\i" := (\i[i]) (at level 9).
Notation "\v" := (\v[i]) (at level 9).
Notation "\l_ u" := (\l[l]_u) (at level 9).
Notation "\p_ u" := (\p[l]_{1&u}) (at level 9).
Notation "\q_{ f | t & u }" := (\q[l]_{f|t&u}) (at level 9).
Notation "\q_ u" := (\q_{0|1 & u}) (at level 9).
Notation "\ω" := (\ω[l,l_fin]) (at level 8).
Notation "\A_ x" := (\A[i,l,l_fin]_x) (at level 9).

Theorem Exam_2019_1_3 : forall x:nat, x+1 < \ω ->
  \A_x = 0.8499 -> \A_(x+1) = 0.8573 -> \i = 0.015 -> 0.96235 < \p_x < 0.96265.
Proof.
  move => x Hx HAx HAx1 Hi.
  have Hpx : \p_x = (1 - (1+\i)*\A_x) / (1 - \A_(x+1)).
  { move: (ins_whole_rec \i i_pos l l_fin x Hx).
    rewrite (_ : \q_{0|1&x} = 1 - \p_x);
      [| rewrite -{2}(p_q_1 l 1 x); [lra | apply /pos_neq0 /l_x_pos; lra]].
    rewrite /v_pres => ->; field; lra. }
  rewrite Hpx HAx HAx1 Hi; lra.
Qed.

End Example4.

Section Example5.

(* In this section, we consider verifying the formula of a gross premium. *)

Variable i:R.
Hypothesis i_pos : 0 < i.

Variable l:life.
Hypothesis l_fin : (l_finite l).

Notation "\i" := (\i[i]) (at level 9).
Notation "\v" := (\v[i]) (at level 9).
Notation "\ω" := (\ω[l,l_fin]) (at level 8).
Notation "\A_{ x : n }" := (\A[i,l]_{x:n}) (at level 9, x at level 9).
Notation "\a''_{ x : n }" := (\a''[i,l]_{x:n}) (at level 9, x at level 9).

(* initial expense *)
(* The expense α per unit insurance amount is paid at the beginning of the first year. *)
Variable α:R.
Hypothesis alpha_pos : 0 < α.

(* collection expense *)
(* The expense β per unit premium is paid at the beginning of each year. *)
Variable β:R.
Hypothesis beta_in_0_1 : 0 < β < 1.

(* maintenance expense *)
(* The expense γ per unit insurance amount is paid at the beginning of each year. *)
Variable γ:R.
Hypothesis gamma_pos : 0 < γ.

(* annual gross premium of an endowment life insurance *)
Definition gross_prem_endow_life_annual (x n : nat) :=
  (\A_{x:n} + α + γ * \a''_{x:n}) / ((1-β) * \a''_{x:n}).
Notation "\Pstar_{ x : n }" := (gross_prem_endow_life_annual x n) (at level 9, x at level 9).

(* Verify that the gross premium satisfies the equivalence principle. *)
Theorem gross_prem_endow_life_annual_correct : forall x n : nat, x < \ω -> 0 < n ->
  \Pstar_{x:n} * \a''_{x:n} = \A_{x:n} + α + (\Pstar_{x:n}*β + γ) * \a''_{x:n}.
Proof.
  move => x n Hx Hn.
  rewrite /gross_prem_endow_life_annual.
  field; split; [| lra].
  apply pos_neq0; eapply Rlt_le_trans;
    [| apply (ann_due_lb _ i_pos _ l_fin)]; first apply Rinv_0_lt_compat; auto.
Qed.

End Example5.


Require Import Wellfounded.
Require Import reduction.

Require Import proofsystem.
Set Implicit Arguments.

(* A generic soundness proof.
   The proof is parameterized over a semantic interpretation of reachability rules,
   which can be instantiated to show one-path or all-path soundness.

   The semantics of a rule must be further parameterized by some kind of "index"
   with a well-founded approximation order, used to justifying circularity.

   This module reduces showing soundess of the proof system to showing a few
   lemmas about the selected semantics of reachability rules.

   The soundness result proved in this module shows that the conclusion of
   the proof holds with any index. To finish a specific soundness proof this
   should be shown equaivalent to some un-indexed notion of soundenss.
 *)

Lemma clos_true_step : forall {A: Set} (R : A -> A -> Prop) x z, clos R true x z ->
                                   exists y, R x y /\ clos R false y z.
intros.
rewrite clos_iff_left in H;inversion H;subst;rewrite <- ?clos_iff_left in * |-;
eauto using clos_refl, clos_unstrict.
Qed.

Module Type ReachabilitySemantics.
  Parameter cfg : Set.
  Parameter S : cfg -> cfg -> Prop.

  Parameter index : Set.
  (* This is one step of soundness relation *)
  Parameter ix_rel : index -> index -> Prop.

  Parameter holds : bool -> forall env,
                      formula cfg env -> formula cfg env->
                      index -> Prop.

  (*
  Parameter ix_wf : well_founded (fun x y => ix_rel y x).
   *)

  (* Will this lemma be any harder to supply than one that
     distinguishes a one-step and all-step version of ix_rel,
     and only promises immediate successors in the
     argument of the hypothesis? *)
  Parameter ix_rel_ind : forall env (phi phi' : formula cfg env),
      forall i0,
      (forall i, clos ix_rel false i0 i ->
                   (forall i', ix_rel i i' -> holds true phi phi' i') ->
                   holds true phi phi' i)
       -> holds true phi phi' i0.

  Parameter holds_strict_later : forall env phi1 phi2 i,
                                   @holds true env phi1 phi2 i ->
                                   forall i', ix_rel i i' ->
                                   holds true phi1 phi2 i'.

  Parameter holds_unstrict : forall env phi1 phi2 i,
                           @holds true env phi1 phi2 i -> holds false phi1 phi2 i.

  Parameter holds_step : forall env (phi phi' : formula cfg env),
    (forall (e : env) (c : cfg),
      phi e c ->
      (exists c2 : cfg, S c c2) /\ (forall c2 : cfg, S c c2 -> phi' e c2)) ->
    forall i, holds true phi phi' i.
  Parameter holds_refl : forall env phi i, @holds false env phi phi i.

  Parameter holds_trans_strict : forall env phi phi' phi'' i,
    @holds true env phi phi' i ->
    (forall i' : index, ix_rel i i' -> holds false phi' phi'' i') ->
   holds true phi phi'' i.
  Parameter holds_trans : forall env phi phi' phi'' i,
    @holds false env phi phi' i ->
    holds false phi' phi'' i ->
    holds false phi phi'' i.

  Parameter holds_case :
    forall strict env (phi phi1 phi' : formula cfg env) i,
      holds strict phi phi' i -> holds strict phi1 phi' i ->
      holds strict (fun (e : env) (g : cfg) => phi e g \/ phi1 e g) phi' i.

  Parameter holds_mut_conseq :
    forall strict env1 (phi1 phi2 : formula cfg env1)
                  env2 (phi1' phi2' : formula cfg env2),
     (forall gamma rho,
        phi1 rho gamma ->
        exists rho', phi1' rho' gamma /\
                     forall gamma', phi2' rho' gamma' -> phi2 rho gamma') ->
    forall i, holds strict phi1' phi2' i ->
              holds strict phi1 phi2 i.

End ReachabilitySemantics.

Module Type StateBasedReachability.
  Parameter cfg : Set.
  Parameter S : cfg -> cfg -> Prop.

  Parameter index : Set.
  (* This is one step of soundness relation *)
  Parameter ix_rel : index -> index -> Prop.

  Parameter state_reaches : bool -> index -> cfg -> (cfg -> Prop) -> Prop.

  Definition holds strict env (phi phi' : formula cfg env) i :=
    forall rho gamma,
      phi rho gamma ->
      state_reaches strict i gamma (phi' rho).

  Parameter ix_rel_ind : forall env (phi phi' : formula cfg env),
      forall i0,
      (forall i, clos ix_rel false i0 i ->
                   (forall i', ix_rel i i' -> holds true phi phi' i') ->
                   holds true phi phi' i)
       -> holds true phi phi' i0.

  Parameter reach_later : forall i i', ix_rel i i' ->
    forall gamma P,
      state_reaches true i gamma P ->
      state_reaches true i' gamma P.

  Parameter reach_unstrict : forall i gamma P,
    state_reaches true i gamma P -> state_reaches false i gamma P.

  (* These are really from axiom cases, maybe make it generic *)
  Parameter reach_refl : forall i gamma (P : cfg -> Prop),
                           P gamma -> state_reaches false i gamma P.
  Parameter reach_step : forall i gamma (P : cfg -> Prop),
    (exists gamma', S gamma gamma') ->
    (forall gamma', S gamma gamma' -> P gamma') ->
      state_reaches true i gamma P.

  Parameter reach_impl : forall (P Q : cfg -> Prop),
                           (forall c, P c -> Q c) ->
                           forall strict i gamma,
                             state_reaches strict i gamma P ->
                             state_reaches strict i gamma Q.

  Parameter reach_join : forall i gamma P,
    state_reaches false i gamma
     (fun gamma' => state_reaches false i gamma' P) ->
    state_reaches false i gamma P.
  Parameter reach_join_strict : forall i gamma P,
    state_reaches true i gamma
     (fun gamma' => forall i', ix_rel i i' -> state_reaches false i' gamma' P) ->
    state_reaches true i gamma P.

End StateBasedReachability.

Module StateBasedSemantics (Reach : StateBasedReachability)
  <: ReachabilitySemantics.

  Import Reach.

  Definition cfg := cfg.
  Definition S := S.
  Definition index := index.
  Definition ix_rel := ix_rel.
  Definition holds := holds.
  Definition ix_rel_ind := ix_rel_ind.

  Lemma holds_strict_later : forall env phi1 phi2 i,
                                   @holds true env phi1 phi2 i ->
                                   forall i', ix_rel i i' ->
                                   holds true phi1 phi2 i'.
    unfold holds, Reach.holds; eauto using reach_later.
  Qed.

  Lemma holds_unstrict : forall env phi1 phi2 i,
                           @holds true env phi1 phi2 i ->
                           @holds false env phi1 phi2 i.
    unfold holds, Reach.holds; eauto using reach_unstrict.
  Qed.

  Lemma holds_step : forall env (phi phi' : formula cfg env),
    (forall (e : env) (c : cfg),
      phi e c ->
      (exists c2 : cfg, S c c2) /\ (forall c2 : cfg, S c c2 -> phi' e c2)) ->
    forall i, holds true phi phi' i.
    unfold holds, Reach.holds; intros; apply reach_step;firstorder.
  Qed.

  Lemma holds_refl : forall env phi i, @holds false env phi phi i.
    unfold holds, Reach.holds; intros; apply reach_refl;assumption.
  Qed.

  Lemma holds_case :
    forall strict env (phi phi1 phi' : formula cfg env) i,
      holds strict phi phi' i -> holds strict phi1 phi' i ->
      holds strict (fun (e : env) (g : cfg) => phi e g \/ phi1 e g) phi' i.
  Proof.
    firstorder.
  Qed.

  Lemma holds_mut_conseq :
    forall strict env1 (phi1 phi2 : formula cfg env1)
                  env2 (phi1' phi2' : formula cfg env2),
     (forall gamma rho,
        phi1 rho gamma ->
        exists rho', phi1' rho' gamma /\
                     forall gamma', phi2' rho' gamma' -> phi2 rho gamma') ->
    forall i, holds strict phi1' phi2' i ->
              holds strict phi1 phi2 i.
  Proof.
    unfold holds, Reach.holds;intros.
    specialize (H _ _ H1).
    firstorder using reach_impl.
  Qed.

  Lemma holds_trans : forall env phi phi' phi'' i,
    @holds false env phi phi' i ->
    holds false phi' phi'' i ->
    holds false phi phi'' i.
  Proof.
    unfold holds, Reach.holds;intros.
    eauto using reach_join, reach_impl.
  Qed.

  Lemma holds_trans_strict : forall env phi phi' phi'' i,
    @holds true env phi phi' i ->
    (forall i' : index, ix_rel i i' -> holds false phi' phi'' i') ->
   holds true phi phi'' i.
  Proof.
    unfold holds, Reach.holds;intros.
    eauto using reach_join_strict, reach_impl.
  Qed.
End StateBasedSemantics.

Module Soundness(Sem : ReachabilitySemantics).
  Import Sem.

  Definition system_holds (S : system cfg) (i : index) : Prop :=
    forall env phi1 phi2, S env phi1 phi2 -> holds true phi1 phi2 i.

  Lemma system_next (S : system cfg) (i : index) :
    system_holds S i -> forall i', ix_rel i i' -> system_holds S i'.
  Proof. unfold system_holds; eauto using holds_strict_later. Qed.

  Lemma system_later (S : system cfg) (i : index) :
    system_holds S i -> forall i', clos ix_rel false i i' -> system_holds S i'.
  Proof. intros Hsys i' Hpath; revert Hsys; induction Hpath; eauto using system_next. Qed.

  Lemma holds_weak : forall (C : option (system cfg)) env phi1 phi2 i,
                       @holds true env phi1 phi2 i ->
                       holds
                       (match C with
                         | None => false
                         | Some _ => true
                       end) phi1 phi2 i.
  Proof.
    destruct C;auto using holds_unstrict.
  Qed.

  Lemma holds_conseq : forall strict env (phi1 phi2 phi1' phi2' : formula cfg env),
    forall env (phi1 phi2 phi1' phi2' : formula cfg env),
    (forall rho gamma, phi1 rho gamma -> phi1' rho gamma) ->
    (forall rho gamma, phi2' rho gamma -> phi2 rho gamma) ->
    forall i, holds strict phi1' phi2' i ->
              holds strict phi1 phi2 i.
    intros.
    revert H1.
    apply holds_mut_conseq.
    firstorder.
  Qed.

    Ltac spec_ih :=
    let HA := fresh "HA" in
    let HC := fresh "HC" in
    intros ? HA HC;
    match goal with
      | [IHcirc : appcontext C [cons_opt_system] |-_] => idtac
      | _ => repeat match goal with
                        [IH : forall i, system_holds _ i -> _ |- _] =>
                        specialize (IH _ HA HC)
                    end
    end.

  Lemma soundness : forall C A env phi1 phi2,
                      IS cfg S C A env phi1 phi2 ->
                      forall (i : index),
                        system_holds A i ->
                        match C with
                          | None => True
                          | Some S' => forall i', ix_rel i i' -> system_holds S' i'
                        end ->
                        holds (
                        match C with
                          | None => false
                          | Some _ => true
                        end) phi1 phi2 i.
  Proof.
  induction 1;spec_ih.
  + (* step *)
    auto using holds_weak, holds_step.
  + (* axiom *)
    auto using holds_weak.
  + (* refl *)
    destruct C;[destruct H|]; auto using holds_refl.
  + (* trans *)
    destruct C.
    * assert (forall i', ix_rel i i' -> holds false phi' phi'' i') as IH2.
        clear -IHIS2 HA HC.
        intros. apply IHIS2;[clear IHIS2|exact I].
        assert (system_holds A i') by (eauto using system_next).
        firstorder.
      clear -IHIS1 IH2.
      eauto using holds_trans_strict.
    * assert (holds false phi' phi'' i) as IH2 by (clear -IHIS2 HA HC; auto).
      clear -IHIS1 IH2.
      eauto using holds_trans.
  + (* consequence *)
    eauto using holds_conseq.
  + (* case *)
    auto using holds_case.
  + (* abstr *)
    revert IHIS;clear;apply holds_mut_conseq;firstorder.
  + (* abstr' *)
    revert IHIS; clear -H; apply holds_mut_conseq.
    firstorder;eexists;split;[eassumption|];instantiate;firstorder.
  + (* circularity *)
    apply holds_weak.
    apply ix_rel_ind.
    intros i0 Hii0 IHlater.
    apply IHIS; clear H IHIS.
    eauto using system_later.
    simpl.
    intros i' Hi'.
    unfold system_holds.
    intros rho phi1 phi2 H.
    destruct H.
    * (* rules from C *)
      destruct C;[|solve[destruct H]].
      simpl in H.
      assert (forall i', clos ix_rel true i i' -> system_holds s i').
        clear -HC. intros.
        apply clos_true_step in H.
        destruct H as [i1 [Hstep Hrest]].
        eauto using system_later.
      clear HC; rename H0 into HC.
      assert (clos ix_rel true i i').
        clear -Hi' Hii0.
        eauto using clos, clos_cons_rt.
      specialize (HC _ H0).
      auto.
    * (* The added rule *)
      destruct H as [-> [-> ->]].
      unfold eq_rect_r in * |- *; simpl eq_rect in * |- *.
      auto.
  + (* subst *)
    eauto using holds_mut_conseq.
  + (* Logical framing *)
    revert IHIS;
    eapply holds_mut_conseq;
    intuition;
    eauto.
  Qed.
End Soundness.


(*************************************************************)
(*      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 Ring.
Require Import Field_tac.
Require Import Ring_tac.
Require Import Eqdep_dec.
Require Import ZArith.
Require Import ZCAux.
Require Import Ppow.
Require Import GZnZ.
Require Import EGroup.
Require Import SMain.
Require Import Zmod.

Set Implicit Arguments.

Open Scope Z_scope.

Section Nell.

 Variable N: Z.
 Variable (A B: Z).
 Hypothesis N_lt_2: 2 < N.
 Hypothesis N_not_div_2: ~(2 | N).
 Hypothesis NonSingular: rel_prime N (4 * A * A * A  + 27 * B * B).

 Inductive nelt: Set :=
   nzero | ntriple: Z -> Z -> Z  -> nelt.

 Definition nplus x y := (Zmod (x + y) N).
 Definition nmul x y := (Zmod (x * y) N).
 Definition nsub x y := (Zmod (x - y) N).
 Definition ninv x := (Zmod (-x) N).

 Notation "x ++ y " := (nplus x y).
 Notation "x -- y" := (nsub x y) (at level 50, left associativity).
 Notation "x ** y" := (nmul x y) (at level 40, left associativity).
 Notation "-- x" := (ninv x) (at level 40, left associativity).

 Notation "x ?= y" := (Zeq_bool x y).

 Definition ndouble := fun (sc: Z) (p1: nelt) =>
 match p1 with
  nzero => (p1, sc)
 | (ntriple x1 y1 z1) =>
    if (y1 ?= 0) then (nzero, z1 ** sc) else
     (* we do 2p *)
    let m' := 3 ** x1 ** x1 ++ A ** z1 ** z1 in
    let l' := 2 ** y1 ** z1 in
    let m'2 := m' ** m' in
    let l'2 := l' ** l' in
    let l'3 := l'2 ** l' in
    let x3 := m'2 ** z1 -- 2 ** x1 ** l'2 in
    (ntriple
          (l' ** x3)
          (l'2 ** (m' ** x1 -- y1 ** l') -- m' ** x3)
          (z1 ** l'3), sc)
  end.

 Definition nadd := fun (sc: Z) (p1 p2: nelt) =>
 match p1, p2 with
  nzero, _ => (p2, sc)
 | _ , nzero => (p1, sc)
 | (ntriple x1 y1 z1), (ntriple x2 y2 z2) =>
  let d1 := x2 ** z1 in
  let d2 := x1 ** z2 in
  let l := d1 -- d2 in
  let dl := d1 ++ d2 in
  let m := y2 ** z1 -- y1 ** z2 in
  if (l ?= 0) then
   (* we have p1 = p2 o p1 = -p2 *)
   if (m ?= 0) then
    if (y1 ?= 0) then (nzero, z1 ** z2 ** sc) else
     (* we do 2p *)
    let m' := 3 ** x1 ** x1 ++ A ** z1 ** z1 in
    let l' := 2 ** y1 ** z1 in
    let m'2 := m' ** m' in
    let l'2 := l' ** l' in
    let l'3 := l'2 ** l' in
    let x3 := m'2 ** z1 -- 2 ** x1 ** l'2 in
    (ntriple
          (l' ** x3)
          (l'2 ** (m' ** x1 -- y1 ** l') -- m' ** x3)
          (z1 ** l'3), z2 ** sc)
    else (* p - p *)  (nzero, m ** z1 ** z2 ** sc)
  else
     let l2 := l ** l in
     let l3 := l2 ** l in
     let m2 := m ** m in
     let x3 := z1 ** z2 ** m2 -- l2 ** dl in
      (ntriple (l ** x3)
             (z2 ** l2 ** (m ** x1 -- y1 ** l) -- m ** x3)
             (z1 ** z2 ** l3), sc)
  end.

 Definition inversible n x := exists y, Zmod (x * y) n = 1%Z.

 Lemma inversible_1: forall n, 1 < n -> inversible n 1.
 Proof.
 intros n Hn; exists 1%Z; rewrite Zmult_1_r;
   apply Zmod_small; split; auto with zarith.
 Qed.

 Notation "[ x ]" := (inversible N x).

 Lemma inversible_0: ~[0].
 Proof.
 intros HH; inversion_clear HH as [xz H1].
 rewrite Zmod_small in H1; auto with zarith.
 Qed.

 Lemma inversible_mult_inv: forall x y, [x ** y] -> [x] /\ [y].
 Proof.
 assert (F1 := N_lt_2).
 intros x y (z, Hz); split.
 exists (y * z)%Z; rewrite <- Hz.
 unfold nmul.
 rewrite Zmodml; auto with zarith.
 rewrite Zmult_assoc; auto.
 exists (x * z)%Z; rewrite <- Hz.
 unfold nmul.
 rewrite Zmodml; auto with zarith.
 rewrite Zmult_assoc; auto.
 rewrite (Zmult_comm x); auto.
 Qed.

 Inductive nInversible: nelt * Z -> Prop :=
  nInv_z: forall sc, inversible N sc -> nInversible (nzero, sc)
 |nInv_e: forall x y z sc,
     inversible N (sc ** z) -> nInversible (ntriple x y z, sc).

 Notation "[[ x ]]" := (nInversible x).

 Lemma inversible_mult: forall a b, [a] -> [b] -> [a ** b].
 Proof.
 assert (F1 := N_lt_2).
 intros a b (z1, H1) (z2, H2).
 exists (z1 * z2)%Z.
 unfold nmul.
 rewrite Zmodml; auto with zarith.
 replace (a * b * (z1 * z2))%Z with ((a * z1) * (b * z2))%Z; try ring.
 rewrite Zmult_mod; auto with zarith.
 rewrite H1; rewrite H2; rewrite Zmod_small; auto with zarith.
 Qed.

 Ltac itac :=
  match goal with
   H: inversible _ (_ ** _) |- _ =>
        case (inversible_mult_inv _ _ H); clear H;
         let H1 := fresh "NI" in
         let H2 := fresh "NI" in intros H1 H2
 | |- inversible _ (_ ** _) =>
         apply inversible_mult
 end; auto.

 Lemma nInversible_double: forall sc x,
  [[ndouble sc x]] -> [[(x,1%Z)]] /\ [sc].
 Proof.
 assert (F1 := N_lt_2).
 assert (F2: inversible N 1).
   apply inversible_1; auto with zarith.
 unfold ndouble; intros sc x; case x; auto.
   intros H; inversion_clear H.
   repeat split; auto; try constructor; auto.
 intros x1 y1 z1; case Zeq_bool; auto.
   intros H; inversion_clear H.
   repeat split; auto; try constructor; auto; repeat itac.
 intros H; inversion_clear H; auto.
 repeat split; auto; try constructor; repeat itac; auto.
 Qed.

 Lemma nInversible_add: forall sc x y,
  [[nadd sc x y]] -> [[(x,1%Z)]] /\ [[(y,1%Z)]] /\ [sc].
 Proof.
 assert (F1 := N_lt_2).
 assert (F2: inversible N 1).
   apply inversible_1; auto with zarith.
 unfold nadd; intros sc x y; case x; auto.
   intros H; inversion_clear H.
   repeat split; auto; try constructor; auto.
   repeat split; auto; try constructor; repeat itac.
 intros x1 y1 z1; case y; auto.
   intros H; inversion_clear H.
   repeat split; auto; try constructor; repeat itac.
 intros x2 y2 z2; case Zeq_bool.
 case Zeq_bool.
 case Zeq_bool.
 intros H; inversion_clear H; auto.
 repeat split; auto; try constructor; repeat itac.
 intros H; inversion_clear H; auto.
 repeat split; auto; try constructor; repeat itac.
 intros H; inversion_clear H; auto.
 repeat split; auto; try constructor; repeat itac.
 intros H; inversion_clear H; auto.
 repeat split; auto; try constructor; repeat itac.
 Qed.

 Definition nopp p :=
   match p with nzero => p | (ntriple x1 y1 z1) => (ntriple x1 (-- y1) z1) end.

 Fixpoint scalb (sc: Z) (b:bool) (a: nelt) (p: positive) {struct p}:
   nelt * Z :=
   match p with
     xH => if b then ndouble sc a else (a,sc)
   | xO p1 => let (a1, sc1) := scalb sc false a p1 in
              if b then
                let (a2, sc2) := ndouble sc1 a1 in
                nadd sc2 a a2
              else ndouble sc1 a1
   | xI p1 => let (a1, sc1) := scalb sc true a p1 in
              if b then  ndouble sc1 a1
              else
              let (a2, sc2) := ndouble sc1 a1 in
              nadd sc2 (nopp a) a2
   end.

 Definition scal sc a p := scalb sc false a p.

 Lemma nInversible_scalb: forall b sc a1 p1,
  [[scalb sc b a1 p1]] -> [[(a1,1%Z)]] /\ [sc].
 Proof.
 assert (F1 := N_lt_2).
 assert (F2: [1]).
   apply inversible_1; auto with zarith.
 intros b sc a p0; generalize sc b a; elim p0; simpl; auto;
    clear sc b a p0.
 intros p0 Hrec sc b a.
   generalize (Hrec sc true a).
   case scalb.
   intros a1 sc1 H; case b; intros H1; try apply H; clear b H.
     case (nInversible_double sc1 a1 H1); auto; clear H1.
     intros H2 H3; inversion_clear H2; try constructor;
       repeat itac; auto.
     generalize H1 (nInversible_double sc1 a1); case ndouble.
     intros a2 sc2 H2 H3; case H3.
       generalize (nInversible_add sc2 (nopp a) a2 H2).
        intros H4; case H4; intros _ [H5 H6].
        inversion_clear H5; constructor; repeat itac; auto.
        intros H4; inversion_clear H4; constructor; repeat itac; auto.
 intros p0 Hrec sc b a.
   generalize (Hrec sc false a).
   case scalb.
   intros a1 sc1 H; case b; intros H1; try apply H; clear b H.
     generalize H1 (nInversible_double sc1 a1); case ndouble.
     intros a2 sc2 H2 H3; case H3.
       generalize (nInversible_add sc2 a a2 H2).
        intros H4; case H4; intros _ [H5 H6].
        inversion_clear H5; constructor; repeat itac; auto.
        intros H4; inversion_clear H4; constructor; repeat itac; auto.
     case (nInversible_double sc1 a1 H1); auto; clear H1.
     intros H2 H3; inversion_clear H2; try constructor;
       repeat itac; auto.
 intros sc b a; case b; intros H.
   case (nInversible_double _ _ H); auto; clear H.
 inversion_clear H; split; try constructor; repeat itac; auto.
 Qed.

 Lemma nInversible_scal: forall sc a1 p1,
  [[scal sc a1 p1]] -> [[(a1,1%Z)]] /\ [sc].
 Proof.
 exact (nInversible_scalb false).
 Qed.

  Definition scal_list sc a l :=
   List.fold_left
  (fun (asc: nelt * Z) p1 => let (a,sc) := asc in scal sc a p1) l (a,sc).

 Lemma nInversible_scal_list: forall sc a l,
  [[scal_list sc a l]] -> [[(a,1%Z)]] /\ [sc].
 Proof.
 assert (F1 := N_lt_2).
 assert (F2: [1]).
   apply inversible_1; auto with zarith.
 intros sc a l; generalize sc a; unfold scal;
   elim l; simpl; auto;
    clear sc a l.
  intros sc a; unfold scal_list; simpl.
    intros HH; inversion_clear HH; split; auto;
      try constructor; repeat itac; auto.
 intros n1 l1 Hrec sc a.
 unfold scal_list; simpl.
   generalize (nInversible_scal sc a n1).
   case scal.
   intros n z H1 H2.
   case (Hrec _ _ H2).
   intros H3 H4; apply H1; auto.
     inversion_clear H3; constructor; repeat itac; auto.
 Qed.

 Definition Zmull l := List.fold_left Pmult l 1%positive.

 Lemma Zmull_cons: forall a l, Zmull (List.cons a l) = (a * (Zmull l))%positive.
 Proof.
 intros a l.
 assert (F1:= Pmult_assoc).
 assert (F2:= Pmult_comm).
 unfold Zmull.
 repeat rewrite List.fold_symmetric; simpl; auto; intros; rewrite F2; auto.
 Qed.

 Fixpoint scalL (sc:Z) (a: nelt) (l: List.list positive) {struct l}: (nelt * Z) :=
   match l with
     List.nil => (a,sc)
   | List.cons n l1 =>
        let (a1, sc1) := scal sc a n in
        let (a2, sc2) := scal_list sc1 a l1 in
          match a2 with
             nzero => (nzero, 0)
          |  ntriple _ _ z => scalL (sc2 ** z) a1 l1
          end
   end.

 Lemma nInversible_scalL: forall sc a l,
  [[scalL sc a l]] -> [[(a,1%Z)]] /\ [sc].
 Proof.
 assert (F1 := N_lt_2).
 assert (F2: [1]).
   apply inversible_1; auto with zarith.
 intros sc a l; generalize sc a;
   elim l; simpl; auto;
    clear sc a l.
  intros sc a; unfold scal_list; simpl.
    intros HH; inversion_clear HH; split; auto;
      try constructor; repeat itac; auto.
 intros n1 l1 Hrec sc a.
   generalize (nInversible_scal sc a n1).
   case scal.
 intros n z H.
   generalize (nInversible_scal_list z a l1).
   case scal_list.
 intros m z1; case m.
   intros _ HH; inversion_clear HH.
   case inversible_0; auto.
 intros x2 y2 z2 H1 H2.
 case (Hrec _ _ H2).
 intros H3 H4.
 case H1; try intros H5 H6.
  constructor; auto.
 split; auto.
 case H; auto.
 inversion_clear H3; auto; constructor; auto.
 repeat itac.
 Qed.

Local Coercion Zpos : positive >-> Z.

 Lemma Zmull_div: forall a l, List.In a l ->
    Zmull l  = (Zmull l / a) * a :> Z.
 intros a l; generalize a; elim l; clear a l; auto.
 intros a H; inversion H.
 simpl List.In; intros a l Hrec b [H | H]; subst.
   rewrite Zmull_cons.
   repeat rewrite Zpos_mult_morphism.
   rewrite (Zmult_comm b).
   repeat rewrite Z_div_mult; auto.
   red; simpl; auto.
 repeat rewrite Zmull_cons.
 repeat rewrite Zpos_mult_morphism.
 rewrite (Hrec b); auto.
 rewrite Zmult_assoc.
 rewrite Z_div_mult; auto.
 red; simpl; auto.
 Qed.

 Definition Zmullp l :=
    List.fold_left (fun y x => (Pmult (Ppow (fst x) (snd x)) y)) l 1%positive.

 Lemma Zmullp_cons: forall a l,
    Zmullp (List.cons a l) = ((Ppow (fst a) (snd a)) * (Zmullp l))%positive.
 Proof.

 intros a l.
 assert (F1:= Pmult_assoc).
 assert (F2:= Pmult_comm).
 unfold Zmullp.
 simpl.
 rewrite F2; simpl Pmult.
 generalize (Ppow (fst a) (snd a)).
 elim l; simpl; auto.
   intros p; rewrite F2; auto.
 intros a1 l1 Hrec p; rewrite Hrec.
 symmetry; rewrite Hrec.
 symmetry; rewrite F1.
 rewrite (F2 p); rewrite (fun x => (F2 x 1%positive)); auto.
 Qed.

 Fixpoint psplit l: positive * (List.list positive) := match l with
   List.nil => (xH, List.nil)
 | List.cons (a, xH) l1 =>
              let (v, l2) := psplit l1 in (v, (List.cons a l2))
 | List.cons (a, n) l1 =>
              let (v, l2) := psplit l1 in
             (Pmult (Ppow a (Pos.pred n)) v, (List.cons a l2))
 end.

 Lemma psplit_correct: forall l,
   Pmult (fst (psplit l)) (Zmull (snd (psplit l))) = Zmullp l.
 Proof.
 assert (F1:= Pmult_assoc).
 assert (F2:= Pmult_comm).
 intros l; elim l; unfold psplit; fold psplit.
   simpl; auto.
   intros (a, n); case n.
     intros n1 l1; case_eq (psplit l1); simpl fst; simpl snd.
       intros p1 l2 Hp1 H1.
       rewrite Zmullp_cons; simpl fst; simpl snd.
       rewrite Zmull_cons; rewrite <- H1.
       simpl Ppow.
       symmetry; rewrite <- F1; rewrite (F2 a).
       rewrite (F2 a); repeat rewrite F1; auto.
     intros n1 l1; set (u := Pos.pred (xO n1));
       case_eq (psplit l1); simpl fst; simpl snd.
       intros p1 l2 Hp1 H1.
       rewrite Zmullp_cons; simpl fst; simpl snd.
       case (Psucc_pred (xO n1)).
         intros HH; discriminate.
       intros HH; rewrite <- HH.
       rewrite Pplus_one_succ_l; rewrite Ppow_plus.
       fold u; simpl Ppow.
       rewrite Zmull_cons; rewrite <- H1.
       repeat rewrite F1.
       rewrite (F2 a).
       rewrite <- (F1 (Ppow a u)); rewrite (F2 p1).
       repeat rewrite F1; auto.
     intros l1; case_eq (psplit l1); simpl fst; simpl snd.
       intros p1 l2 Hp1 H1.
       rewrite Zmullp_cons; simpl fst; simpl snd.
       rewrite Zmull_cons; rewrite <- H1.
       simpl Ppow.
       repeat rewrite F1.
       rewrite (F2 a); auto.
 Qed.

 Lemma psplit_prime: forall l (p: positive),
  (forall (q: positive * positive), List.In q l -> prime (fst q)) ->
   prime p -> (p | Zmullp l)%Z -> List.In p (snd (psplit l)).
 Proof.
 intros l; elim l.
   unfold Zmullp; simpl.
   intros p _ H1 H2.
    case H1.
    absurd (p <= 1).
      apply Zlt_not_le; case H1; auto.
      apply Zdivide_le; auto with zarith.
   intros (a1, n1) l1 Hrec p Hp Hp1 Hp2.
   rewrite Zmullp_cons in Hp2.
   rewrite Zpos_mult_morphism in Hp2.
   case (prime_mult _ Hp1 _ _ Hp2); intros H1.
     assert (Hap: prime a1).
       change a1 with (fst (a1, n1)); apply Hp; auto with datatypes.
     simpl; case n1; try intros p1; case psplit; intros p2 l2; simpl snd;
      left;
      assert (HH: Zpos a1 = p); try (injection HH; auto);
     symmetry; apply prime_div_Zpower_prime with (Zpos n1); auto with zarith;
       rewrite <- Ppow_correct; auto.
   assert (HH: List.In p (snd (psplit l1))).
     apply Hrec; auto with datatypes.
   generalize HH; simpl.
   case psplit; case n1; simpl snd; auto with datatypes.
 Qed.

 Section pell.

  Variable p: Z.
  Hypothesis p_prime: prime p.
  Hypothesis p_div_N: (p | N)%Z.

  Let p_pos:= GZnZ.p_pos _ p_prime.

  Definition pK := (znz p).

  Let to_p x:pK := mkznz _ _ (modz _  x).

  Notation "x :%p" := (to_p x) (at level 30).

  Definition pkO: pK := (zero _).

  Definition pkI: pK := (one _).

  Definition pkplus: pK -> pK -> pK := (GZnZ.add _).

  Definition pkmul: pK -> pK -> pK := (mul _).

  Definition pksub: pK -> pK -> pK := (sub _).

  Definition pkopp: pK -> pK := (GZnZ.opp _).

  Definition pkinv: pK -> pK := (inv _).

  Definition pkdiv: pK -> pK -> pK := (div _).

  Definition pA: pK := to_p A.

  Definition pB: pK := to_p B.

  Definition pKfth:  field_theory pkO pkI pkplus pkmul pksub pkopp
                      pkdiv pkinv (@eq pK)
               := (FZpZ _ p_prime).

  (* K notations *)
  Notation "x + y" := (pkplus x y).  Notation "x * y " := (pkmul x y).
  Notation "x - y " := (pksub x y). Notation "- x" := (pkopp x).
  Notation "/ x" := (pkinv x). Notation "x / y" := (pkdiv x y).
  Notation "0" := pkO.
  Notation "1" := pkI.
  Notation "2" := (1+1).
  Notation "3" := (1+1 +1).
  (* Non singularity *)
  Notation "4" := (2 * 2).
  Notation "27" := (3 * 3 * 3).

  Add Field KFth : pKfth.

  Lemma pNonSingular: 4 * pA * pA * pA  + 27 * pB * pB <> 0.
  Proof.
  assert (F1 := p_pos).
  intros H; generalize (znz_inj _ _ _ H).
  unfold pkO,pkI,pA, pB, to_p, zero, one, pkplus, GZnZ.add, pkmul, mul, val.
  repeat match goal with |- ?t = 0 mod p -> _ =>
   rmod t; auto
  end.
  rewrite (Zmod_small 0); auto with zarith.
  intros H1.
  apply (fun H HH => rel_prime_mod H HH H1).
  generalize (prime_ge_2 _ p_prime); auto with zarith.
  apply rel_prime_sym; auto.
  apply rel_prime_div with N; try apply p_div_N.
  generalize NonSingular.
  repeat rewrite Zmult_assoc; auto.
  Qed.

  (* Characteristic greater than 3 *)

  Lemma pone_not_zero: 1 <> 0.
  Proof.
  intros H; generalize (znz_inj _ _ _ H); simpl val.
  repeat (rewrite Zmod_small); generalize (prime_ge_2 _ p_prime);
    auto with zarith.
  Qed.

  Lemma ptwo_not_zero: 2 <> 0.
  Proof.
  intros H; generalize (znz_inj _ _ _ H); simpl val.
  repeat (rewrite Zmod_small); generalize (prime_ge_2 _ p_prime);
    auto with zarith.
  intros H1; case (Zle_lt_or_eq _ _ H1); intros H2; auto with zarith.
  case N_not_div_2; rewrite H2; auto.
  Qed.

  Definition pis_zero: pK -> bool.
  intros (k, Hk); case k; [exact true | idtac | idtac];
    intros; exact false.
  Defined.

  Lemma pis_zero_correct: forall k: pK, pis_zero k = true <-> k = 0.
  Proof.
  assert (F0 := p_pos).
  intros (k, Hk); generalize Hk; case k; simpl.
    intros Hk1; split; auto; intros H; unfold pkO, zero.
    apply (zirr p); rewrite Zmod_small; auto with zarith.
  intros Hk1; split; auto; intros H; try discriminate.
  intros Hk1; split; auto; intros H; try discriminate.
  Qed.

  Lemma pell_theory: ell_theory pkO pkI pkplus pkmul pksub pkopp pkinv
                                 pkdiv pA pB pis_zero.
  Proof.
  constructor.
  apply pKfth.
  apply pNonSingular.
  exact pone_not_zero.
  exact ptwo_not_zero.
  exact pis_zero_correct.
  Qed.

  Definition pG:=  (EFGroup pell_theory (uniq_all_znz _ p_pos)
                                         (in_all_znz _ p_pos)).

  Lemma gorder_pG: FGroup.g_order pG <= 2 * p + 1.
  Proof.
  replace p with (Z_of_nat (List.length (all_znz _ p_pos))).
  unfold pG; apply EFGroup_order.
  rewrite all_znz_length.
  generalize (prime_ge_2 _ p_prime).
  case p; simpl; auto.
   intros p1 Hp1; rewrite Zpos_eq_Z_of_nat_o_nat_of_P; auto.
   intros p1 HH; case HH; auto.
  Qed.

  Let pelt := pelt pkI pkplus pkmul pA pB.
  Let mk_pelt := mk_pelt pkI pkplus pkmul pA pB.

  Lemma is_zero_correct: forall x y,
    if (x ?= y) then x = y else x <> y.
  Proof.
  intros x y; unfold Zeq_bool.
  case (Zcompare_Eq_iff_eq x y).
  case Z.compare; auto.
  intros _ H1 H2; assert (H3:= H1 H2); discriminate.
  intros _ H1 H2; assert (H3:= H1 H2); discriminate.
  Qed.

  Lemma inversible_is_not_k0: forall x, [x] -> x :%p  <> 0.
  Proof.
  intros x1 (k, Hk) H1.
  assert (F2: 2 < p).
    case (Zle_lt_or_eq _ _  (prime_ge_2 p p_prime)); auto.
    intros HH1; case N_not_div_2; rewrite HH1.
    apply p_div_N.
  assert (F3:= N_lt_2).
  injection H1; clear H1; rewrite (Zmod_small 0);
    auto with zarith; intros HH.
  absurd ((x1 * k) mod p = ((x1 * k) mod N) mod p).
    rewrite Hk.
    rewrite Zmult_mod; auto with zarith.
    rewrite HH; rewrite Zmult_0_l.
    repeat rewrite Zmod_small; auto with zarith.
  apply Zmod_div_mod; auto with zarith.
  Qed.

  Lemma inversible_is_zero: forall x,
    [x] -> pis_zero (x :%p) = false.
  Proof.
  intros x1 H1.
  case (pis_zero_correct (to_p x1)); case pis_zero; auto.
  intros HH _; generalize (HH (refl_equal true)); clear HH;
    intros HH.
  case (@inversible_is_not_k0 x1); auto.
  Qed.

  Lemma to_p_nmul: forall x y, (x ** y):%p =  x:%p * y:%p.
  Proof.
  intros x y.
  unfold nmul, to_p, pkmul, mul.
  unfold pK; apply zirr; simpl.
  assert (F1:= p_pos).
  rewrite <- Zmod_div_mod; auto.
  rewrite Zmult_mod; auto.
  generalize N_lt_2; auto with zarith.
  Qed.

  Lemma to_p_pow: forall x n,
     (x ^ (Z_of_nat n)):%p  =  pow pkI pkmul (x:%p) n.
  Proof.
  intros x n; elim n; clear n.
    simpl Z_of_nat; simpl pow; rewrite Zpower_0_r; auto.
  intros n Hrec; rewrite inj_S; unfold Z.succ; rewrite Zpower_exp; auto with zarith.
  assert (tmp: forall n x, pow 1 pkmul x (S n) = x * pow 1 pkmul x n).
    intros n1 x1; case n1; simpl; auto; ring.
  rewrite tmp; clear tmp.
  rewrite <- Hrec; rewrite <- to_p_nmul.
  rewrite Zpower_1_r; rewrite Zmult_comm.
  unfold to_p, nmul, pkmul, pK; apply zirr; simpl.
  assert (F1:= p_pos).
  rewrite <- Zmod_div_mod; auto with zarith.
  Qed.

  Lemma to_p_nplus: forall x y, (x ++ y):%p = x:%p + y:%p.
  Proof.
  intros x y.
  unfold nplus, to_p, pkplus, GZnZ.add.
  unfold pK; apply zirr; simpl.
  assert (F1:= p_pos).
  rewrite <- Zmod_div_mod; auto.
  rewrite Zplus_mod; auto.
  generalize N_lt_2; auto with zarith.
  Qed.

  Lemma to_p_nsub: forall x y, (x -- y):%p = x:%p - y:%p.
  Proof.
  intros x y.
  unfold nsub, to_p, pksub, GZnZ.sub.
  unfold pK; apply zirr; simpl.
  assert (F1:= p_pos).
  rewrite <- Zmod_div_mod; auto.
  rewrite Zminus_mod; auto.
  generalize N_lt_2; auto with zarith.
  Qed.

  Lemma to_p_2: 2:%p = 2.
  Proof.
  unfold to_p, pkplus, pkI, GZnZ.add, pK; apply zirr; simpl.
  assert (F1:= p_pos).
  rewrite <- Zplus_mod; auto.
  Qed.

  Lemma to_p_3: 3:%p = 3.
  Proof.
  unfold to_p, pkplus, pkI, GZnZ.add, pK; apply zirr; simpl.
  assert (F1:= p_pos).
  repeat match goal with |- _ = ?t =>
   rmod t; auto
  end.
  Qed.

  Ltac to_p_tac :=  repeat (rewrite to_p_nmul || rewrite to_p_nplus ||
         rewrite to_p_nsub || rewrite to_p_2 ||
         rewrite to_p_3); auto.

  Lemma inversible_kO: forall z1 z2,
     z2 = 0 -> z1:%p = z2 -> [z1] -> False.
  Proof.
  intros z1 z2 H1 H2 H3.
  generalize (inversible_is_not_k0 H3).
  rewrite H2; rewrite H1.
  intros H; case H; auto.
  Qed.

  Let pdouble: pelt -> pelt := pdouble (pell_theory).

  Let padd: pelt -> pelt -> pelt := padd (pell_theory).
  Let elt := (elt pkI pkplus pkmul pA pB).
  Let inf_elt := (inf_elt pkI pkplus pkmul pA pB).
  Let curve_elt := (curve_elt pkI pkplus pkmul pA pB).

  Inductive equiv: nelt -> elt -> Prop :=
     z_equiv:equiv nzero inf_elt
  |  n_equiv: forall x y z x1 y1 H,
      x:%p / z:%p = x1 ->
      y:%p / z:%p  = y1 ->
      equiv (ntriple x y z) (@curve_elt x1 y1 H).

  Infix "=~~=" := equiv (at level 40, no associativity).

  Let pe2e := pe2e pell_theory.
  Let add := add pell_theory.
  Let opp := opp pell_theory.
  Let pow := pow pkI pkmul.

  Lemma nedouble_correct: forall sc n1 p1,
    n1 =~~= p1 -> [[ndouble sc n1]] ->
       fst (ndouble sc n1) =~~= add p1 p1.
  Proof.
  intros sc n1 p1 H; inversion_clear H.
    simpl; intros; constructor.
  intros V1.
  case (nInversible_double _ _ V1); intros V2 _.
  inversion_clear V2.
  simpl.
  case Kdec; [idtac | intros HH; case HH]; auto.
  intros e.
  match goal with |- context[?x ?= ?y] =>
    generalize (is_zero_correct x y); case (Zeq_bool x y)
  end.
  intros HH; case Kdec.
     intros; constructor.
  intros HH1; case HH1; subst y1; rewrite HH.
  change (to_p 0) with pkO.
     field.
     intros HH2; apply inversible_kO with (2 := HH2); itac.
  intros HH1.
  assert (N1: inversible N y).
    inversion V1.
       generalize H3; generalize (Zeq_bool_eq y 0); case Zeq_bool.
         intros; case HH1; auto.
       intros; discriminate.
       generalize H3; case Zeq_bool; clear H3.
         intros; discriminate.
      intros HH; injection HH; clear HH.
      intros _ HH _ _; subst z0.
      repeat itac.
   assert (N2: to_p y <> pkO).
     intros HH; apply inversible_kO with (2 := HH); auto.
   assert (N3: to_p z <> pkO).
     intros HH; apply inversible_kO with (2 := HH); itac.
   case Kdec.
   intros HH; case N2.
     case (Kmult_integral pell_theory (1 + 1) y1).
      apply trans_equal with (y1 + y1); try ring.
      pattern y1 at 1; rewrite HH; ring.
    intros; case ptwo_not_zero; auto.
    intros; subst y1; field_simplify_eq in H3; auto.
   intros; simpl; constructor;
    to_p_tac; subst x1 y1; fold pA;
    set (v3 := (1 + (1 + 1)));
    set (v2 := (1 + 1)); field; repeat split; auto;
    apply ptwo_not_zero.
  Qed.

  Lemma neadd_correct: forall sc n1 p1 n2 p2,
    n1 =~~= p1 -> n2 =~~= p2 -> [[nadd sc n1 n2]] ->
      fst (nadd sc n1 n2) =~~= add p1 p2.
  Proof.
  intros sc n1 p1 n2 p2 H; inversion_clear H.
    simpl; auto.
  intros H; inversion_clear H.
    simpl; intros; constructor; auto.
  intros V1.
  case (nInversible_add _ _ _ V1); intros V2 (V3, _).
  inversion_clear V2.
  inversion_clear V3.
  repeat itac.
  simpl.
  assert (F0:= (inversible_is_not_k0 NI2)).
  assert (F0b:= (inversible_is_not_k0 NI0)).
  generalize V1; simpl.
  repeat match goal with |- context[?x ?= ?y] =>
    generalize (is_zero_correct x y); case (Zeq_bool x y)
  end; repeat case Kdec; auto.
  intros; constructor.
  intros n e K1 K2 K3 U1; subst y.
   match type of K2 with ?X = 0%Z =>
     cut ((to_p X) = pkO); [idtac | rewrite K2; auto];
     to_p_tac; clear K2; intros K2
   end.
   case (Kmult_integral pell_theory (to_p y0) (to_p z)); auto.
     rewrite <- K2; change (to_p 0) with pkO; ring.
   intros HH; case n; subst y1 y2; rewrite HH; auto.
   intros; case F0; auto.
  intros n K1 K2 K3 U1.
   case n; subst x1 x2.
    field_simplify_eq; auto.
    match type of K3 with ?X = 0%Z =>
       cut ((to_p X) = pkO); [idtac | rewrite K3; auto];
       to_p_tac; clear K3; intros K3
    end.
    match goal with |- ?X = _ =>
      apply trans_equal with (X + pkO); try ring
    end.
    rewrite <- K3; ring.
   intros K1 K2 K3 K4 _ U1; subst y1 y2.
   match type of K4 with ?X = 0%Z =>
     cut ((to_p X) = pkO); [idtac | rewrite K4; auto];
     to_p_tac; clear K4; intros K4
   end.
   field_simplify_eq in K1; auto.
  rewrite K1 in K4.
  case (Kmult_integral pell_theory (1 + 1) (to_p z * to_p y0)); auto.
  set (u := to_p z * to_p y0) in * |- *.
  apply trans_equal with (u + u); try ring.
  unfold u; rewrite <- K4; ring.
  intros; case ptwo_not_zero; auto.
  intros HH; case (Kmult_integral pell_theory _ _ HH); clear HH; intros HH.
  case F0; auto.
  rewrite HH in K1; ring_simplify in K1.
  case (Kmult_integral pell_theory (to_p y) (to_p z0)); auto.
(*    rewrite K1; ring. *)
  intros HH1.
  inversion_clear U1.
     repeat itac; auto.
     case (@inversible_is_not_k0 y); auto.
   intros; case F0b; auto.
   intros.
   assert (VV: to_p y <> pkO).
     apply inversible_is_not_k0.
     inversion_clear V0.
     repeat itac; auto.
   intros; simpl fst; constructor;
     to_p_tac; subst x1 y1; fold pA;
     set (v3 := (1 + (1 + 1)));
     set (v2 := (1 + 1)); field; repeat split; auto;
     apply ptwo_not_zero.
   intros n K1 K2 K3; case n; subst x1 x2.
     field_simplify_eq; auto.
     match type of K3 with ?X = 0%Z =>
       cut ((to_p X) = pkO); [idtac | rewrite K3; auto];
       to_p_tac; clear K3; intros K3
     end.
   apply trans_equal with (to_p z * to_p x0 - pkO); try ring.
   rewrite <- K3; try ring.
   intros; simpl fst; constructor.
   intros n K1 K2 K3 K4.
     inversion K4.
     repeat itac.
     case (inversible_is_not_k0 NI3).
     to_p_tac.
     rewrite <- K1 in H3.
     rewrite <- H3 in H0; simpl in H0.
     case (Kmult_integral pell_theory (y1 + y2) (y1 - y2)).
       ring [H0].
       intros HH; case n.
       apply trans_equal with (y1 - pkO); try ring;
         rewrite <- HH; ring.
     intros HH; subst y1 y2.
     assert (HH1:= Keq_minus_eq pell_theory _ _ HH).
     field_simplify_eq in HH1; auto.
     change (znz p) with pK; ring [HH1].
   intros n K1 K2 K3.
     case n; subst x1 x2; field_simplify_eq; auto.
     match type of K2 with ?X = 0%Z =>
       cut ((to_p X) = pkO); [idtac | rewrite K2; auto];
       to_p_tac; clear K2; intros K2
     end.
     assert (HH1:= Keq_minus_eq pell_theory _ _ K2); auto.
     ring [HH1].
   intros K1 K2 K3 K4.
     inversion_clear K4.
     repeat itac.
     case (inversible_is_not_k0 NI6).
     to_p_tac.
     apply (Keq_minus_eq_inv pell_theory).
     subst x1 x2; field_simplify_eq in K2; auto; ring [K2].
   intros K1 K2 K3 K4.
     inversion_clear K4.
     repeat itac.
     case (inversible_is_not_k0 NI6).
     to_p_tac.
     apply (Keq_minus_eq_inv pell_theory).
     subst x1 x2; field_simplify_eq in K2; auto; ring [K2].
   intros; simpl; constructor; to_p_tac;
     subst y2 x2 y1 x1; field; repeat split; auto.
   intros H1; case n; field_simplify_eq; auto.
     ring [(Keq_minus_eq pell_theory _ _ H1)]; auto.
   inversion_clear V0.
     repeat itac.
     intros H2; case (inversible_is_not_k0 NI6).
     to_p_tac.
  Qed.

 Lemma nopp_correct: forall a1 p1,
   a1 =~~= p1 -> [[(a1,1%Z)]] -> nopp a1 =~~= opp p1.
 Proof.
 assert (F0: 0 < p); auto with zarith.
 intros a1 p1 H; inversion_clear H; simpl; constructor; auto.
 rewrite <- H2.
 field_simplify_eq; auto.
 unfold ninv, pkopp, GZnZ.opp, to_p, pK; apply zirr.
 simpl; rewrite <- Zmod_div_mod; auto with zarith.
 pattern y at 1; rewrite (Z_div_mod_eq y p); auto with zarith.
 rewrite Zopp_plus_distr.
 rewrite Zopp_mult_distr_r.
 rewrite Zmult_comm; rewrite Zplus_comm;
   rewrite Z_mod_plus; auto with zarith.
 inversion_clear H.
 case (inversible_mult_inv _ _ H3); intros _ H4.
 intros H5; apply (@inversible_kO z 0); auto.
 Qed.

 Lemma scalb_correct: forall p sc b a1 p1,
   a1 =~~= p1 ->  [[scalb sc b a1 p]] ->
     fst (scalb sc b a1 p) =~~=
     EGroup.gpow p1 pG (if b then (Pos.succ p) else p).
 Proof.
 assert (F0: forall p1, List.In p1 (FGroup.s pG)).
    intros p1.
    apply (FELLK_in pell_theory _ (in_all_znz _ p_pos)).
 intros p0; unfold scalb; elim p0; clear p0; fold scalb.
   intros p0 Hrec sc b a1 p1; case b; clear b; intros H1.
     generalize (Hrec sc true a1 p1 H1)
                (nInversible_scalb true sc a1 p0); case scalb.
     intros a2 sc2 H2 H3.
     generalize (@nedouble_correct sc2 a2)
                (nInversible_double sc2 a2); case ndouble.
     intros a3 sc3 H4 H5 H6.
     case (H5 H6); clear H5; intros H5 H7.
     simpl Pos.succ.
     rewrite ZCmisc.Zpos_xO_add.
     repeat rewrite gpow_add; auto with zarith.
     apply H4; auto.
     apply H2.
     inversion_clear H5; try constructor; repeat itac;
       auto.
     generalize (Hrec sc true a1 p1 H1)
                (nInversible_scalb true sc a1 p0); case scalb.
     intros a2 sc2 H2 H3.
     generalize (@nedouble_correct sc2 a2)
                (nInversible_double sc2 a2); case ndouble.
     intros a3 sc3 H4 H5.
     generalize (fun p1 p2 => (@neadd_correct sc3 (nopp a1) p1 a3 p2))
                (nInversible_add sc3 (nopp a1) a3); case nadd.
     intros a4 sc4 H6 H7 H8.
     case (H7 H8); clear H7; intros H7 [H9 H10].
     case H5; clear H5.
        inversion_clear H9; try constructor; repeat itac; auto.
     intros H11 H12.
     case H3; clear H3.
        inversion_clear H11; try constructor; repeat itac; auto.
     intros H13 H14.
     rewrite ZCmisc.Zpos_xI_add.
     replace (gpow p1 pG (p0 + p0 + 1)) with
             (add (opp p1) (gpow p1 pG ((Pos.succ p0) + (Pos.succ p0)))).
     apply H6; auto.
       apply nopp_correct; auto.
     rewrite gpow_add; auto with zarith.
     apply H4; auto.
     apply H2; auto.
     inversion_clear H11; try constructor; repeat itac; auto.
     inversion_clear H9; try constructor; repeat itac; auto.
     rewrite ZCmisc.Psucc_Zplus.
     repeat rewrite gpow_add; auto with zarith.
     repeat rewrite gpow_1; auto with zarith.
     unfold add.
     repeat rewrite add_assoc.
     apply f_equal2 with (f := SMain.add pell_theory); auto.
     rewrite add_comm with (p2 := p1).
     repeat rewrite add_assoc.
     unfold opp; rewrite add_opp; simpl; auto.
   intros p0 Hrec sc b a1 p1; case b; clear b; intros H1.
     generalize (Hrec sc false a1 p1 H1)
                (nInversible_scalb false sc a1 p0); case scalb.
     intros a2 sc2 H2 H3.
     generalize (@nedouble_correct sc2 a2)
                (nInversible_double sc2 a2); case ndouble.
     intros a3 sc3 H4 H5.
     generalize (fun p1 p2 => (@neadd_correct sc3 a1 p1 a3 p2))
                (nInversible_add sc3 a1 a3); case nadd.
     intros a4 sc4 H6 H7 H8.
     case (H7 H8); clear H7; intros H7 [H9 H10].
     case H5; clear H5.
        inversion_clear H9; try constructor; repeat itac; auto.
     intros H11 H12.
     case H3; clear H3.
        inversion_clear H11; try constructor; repeat itac; auto.
     intros H13 H14.
     simpl Pos.succ.
     rewrite ZCmisc.Zpos_xI_add.
     replace (p0 + p0 + 1)%Z with
             (1 + (p0 + p0))%Z; auto with zarith.
     repeat rewrite gpow_add; auto with zarith.
     repeat rewrite gpow_1; auto with zarith.
     apply H6; auto.
     apply H4; auto.
     apply H2; auto.
     inversion_clear H11; try constructor; repeat itac; auto.
     inversion_clear H9; try constructor; repeat itac; auto.
     generalize (Hrec sc false a1 p1 H1)
                (nInversible_scalb false sc a1 p0); case scalb.
     intros a2 sc2 H2 H3.
     generalize (@nedouble_correct sc2 a2)
                (nInversible_double sc2 a2); case ndouble.
     intros a3 sc3 H4 H5 H6.
     case (H5 H6); clear H5; intros H5 H7.
     rewrite ZCmisc.Zpos_xO_add.
     repeat rewrite gpow_add; auto with zarith.
     apply H4; auto.
     apply H2; auto.
     inversion_clear H5; try constructor; repeat itac; auto.
  intros sc b a1 p1 H1; case b; intros H2; simpl gpow;
    rewrite add_0_r; auto.
  apply nedouble_correct; auto.
  Qed.

 Lemma scal_correct: forall p sc a1 p1,
   a1 =~~= p1 ->  [[scal sc a1 p]] ->
     fst (scal sc a1 p) =~~= EGroup.gpow p1 pG p.
 Proof.
 intros p1 sc; exact (scalb_correct p1 sc false).
 Qed.

 Lemma scal_list_correct: forall l sc a1 p1,
   a1 =~~= p1 ->  [[scal_list sc a1 l]] ->
     fst (scal_list sc a1 l) =~~= EGroup.gpow p1 pG (Zmull l).
 Proof.
 assert (F0: forall p1, List.In p1 (FGroup.s pG)).
    intros p1.
    apply (FELLK_in pell_theory _ (in_all_znz _ p_pos)).
 intros l; elim l; auto; clear l.
 intros sc a1 p1 H H1.
 change (Zmull List.nil) with (1%positive).
 rewrite gpow_1; auto.
 intros a l Hrec sc a1 p1 H1 H2.
 rewrite Zmull_cons.
 rewrite Zpos_mult_morphism.
 rewrite gpow_gpow; auto with zarith.
 unfold scal_list; simpl List.fold_left.
 case_eq (scal sc a1 a); intros a2 sc2 Ha2.
 change (equiv (fst (scal_list sc2 a2 l)) (gpow (gpow p1 pG a) pG (Zmull l))).
 apply Hrec.
   change a2 with (fst (a2, sc2)).
   rewrite <- Ha2.
   apply scal_correct; auto.
   case (nInversible_scal_list sc2 a2 l); auto.
     unfold scal_list; simpl; rewrite <- Ha2; auto.
     intros; rewrite Ha2.
     inversion_clear H; constructor; repeat itac; auto.
   unfold scal_list; simpl; rewrite <- Ha2; auto.
 Qed.

 Lemma scalL_not_1: forall l sc a p1 n,
    a =~~= p1 -> [[scalL sc a l]] ->  List.In n l ->
    gpow p1  pG (Zmull l / n) <> pG.(FGroup.e).
 Proof.
 assert (F0: forall p1, List.In p1 (FGroup.s pG)).
    intros p1.
    apply (FELLK_in pell_theory _ (in_all_znz _ p_pos)).
 intros l; elim l; auto; clear l.
 simpl (List.In).
 intros a l Hrec sc a1 p1 n H H1 [H2 | H2]; subst.
 case (nInversible_scalL _ _ _ H1); intros H3 H4.
 rewrite Zmull_cons.
 repeat rewrite Zpos_mult_morphism.
 rewrite (Zmult_comm n).
 repeat rewrite Z_div_mult; auto.
 generalize H1; simpl scalL.
 case scal.
 intros n1 sc1.
 generalize (@scal_list_correct l sc1 a1 p1 H).
 case scal_list.
 intros n2; case n2; clear n2.
 intros z2 _ HH; inversion HH; case inversible_0; auto.
 intros x1 y1 z1 sc2 H5 H6 H7.
 rewrite H7 in H5.
 simpl fst in H5.
 case (nInversible_scalL _ _ _ H6); intros H8 H9.
 absurd (ntriple x1 y1 z1 =~~= FGroup.e pG).
   intros HH; inversion HH.
 apply H5; constructor; auto.
 red; simpl; auto.
 rewrite Zmull_cons; auto.
 repeat rewrite Zpos_mult_morphism.
 case (nInversible_scalL _ _ _ H1); intros U1 U2.
 rewrite (Zmull_div n); auto.
 rewrite Zmult_assoc.
 rewrite Z_div_mult; auto.
 rewrite gpow_gpow; auto.
 case (nInversible_scalL _ _ _ H1); auto.
 intros H3 H4.
 simpl in H1; revert H1.
   case_eq (scal sc a1 a).
   intros n1 sc1 Hn1.
   case_eq (scal_list sc1 a1 l).
   intros n2 sc2; case n2.
     intros _ HH; inversion HH.
     case inversible_0; auto.
 intros x1 y1 z1 Hn2 H5.
 apply (@Hrec (sc2 ** z1)%Z n1); auto.
   change n1 with (fst (n1, sc1)).
   rewrite <- Hn1.
   apply scal_correct; auto.
   case (nInversible_scalL _ _ _ H5).
   intros H6 H7.
   case (nInversible_scal_list sc1 a1 l).
     rewrite Hn2; constructor; auto.
   intros H8 H9.
   rewrite Hn1; inversion H6; constructor; auto;
      repeat itac.
 red; simpl; auto; intros HH; discriminate.
 apply Z.ge_le; apply Z_div_ge0; red; simpl; auto;
   intros HH; discriminate.
 red; simpl; auto.
 Qed.

 Lemma  scalL_1: forall l sc a p1,
  a =~~= p1 -> [[scalL sc a l]] ->
  fst (scalL sc a l) =~~= gpow p1  pG (Zmull l).
 Proof.
 assert (F0: forall p1, List.In p1 (FGroup.s pG)).
    intros p1.
    apply (FELLK_in pell_theory _ (in_all_znz _ p_pos)).
 intros l; elim l; auto; clear l.
   simpl scalL; simpl fst; simpl Zmull.
     unfold Zmull; simpl List.fold_left.
     intros; rewrite gpow_1; auto.
 intros a l Hrec sc a1 p1 H1 H2.
 rewrite Zmull_cons.
 repeat rewrite Zpos_mult_morphism.
 rewrite gpow_gpow; auto.
   2: red;simpl; auto; intros HH; discriminate.
  2: red;simpl; auto; intros HH; discriminate.
 simpl in H2; revert H2; simpl scalL.
   case_eq (scal sc a1 a).
   intros n1 sc1 Hn1.
   case_eq (scal_list sc1 a1 l).
   intros n2 sc2; case n2.
     intros _ HH; inversion HH.
     case inversible_0; auto.
 intros x1 y1 z1 Hn2 H5.
 apply Hrec; auto.
 change n1 with (fst (n1, sc1)).
 rewrite <- Hn1.
 apply scal_correct; auto.
 case (nInversible_scalL _ _ _ H5).
 intros H6 H7.
 case (nInversible_scal_list sc1 a1 l).
 rewrite Hn2; constructor; auto.
 intros H8 H9.
 rewrite Hn1; inversion H6; constructor; auto; repeat itac.
 Qed.
 End pell.

End Nell.

Section pell.

 Variable N: Z.
 Variable (x y A B: Z).
 Hypothesis N_lt_2: 2 < N.
 Hypothesis N_not_div_2: ~(2 | N).
 Variable lR: List.list (positive * positive).

 Local Coercion Zpos : positive >-> Z.
 Hypothesis lR_prime: forall p, List.In p lR -> prime (fst p).
 Variable F: positive.
 Hypothesis lR_big: (4 * N < ((Zmullp lR) -1) ^2)%Z.
 Hypothesis on_curve: y^2 mod N = (x^3 + A * x + B) mod N.

 Notation "x ++ y " := (nplus N x y).
 Notation "x -- y" := (nsub N x y) (at level 50, left associativity).
 Notation "x ** y" := (nmul N x y) (at level 40, left associativity).
 Notation "x ?= y" := (Zeq_bool x y).

 Ltac itac :=
  match goal with
   H: inversible _ (_ ** _) |- _ =>
        case (inversible_mult_inv  N_lt_2 _ _ H); clear H;
         let H1 := fresh "NI" in
         let H2 := fresh "NI" in intros H1 H2
 | |- inversible _ (_ ** _) =>
         apply inversible_mult
 end; auto.

 Let z2p x := match x with Zpos p => p | Zneg p => p | Z0 => xH end.

 Lemma  scalL_prime:
  let a := ntriple x y 1 in
  let isc := 4 ** A ** A ** A  ++ 27 ** B ** B in
  let (a1, sc1) := scal N A isc a F in
  let (S1,R1) := psplit lR in
  let (a2, sc2) := scal N A sc1 a1 S1 in
  let (a3, sc3) := scalL N A sc2 a2 R1 in
    match a3 with
     nzero => if (Zeq_bool (Z.gcd sc3 N) 1) then prime N
              else True
   | _ => True
   end.
  Proof.
  assert (F0: 0 < N); try auto with zarith.
  intros a isc.
  case_eq (scal N A isc a F); intros a1 sc1 Ha1.
  case_eq (psplit lR); intros S1 R1 HS1.
  case_eq (scal N A sc1 a1 S1); intros a2 sc2 Ha2.
  case_eq (scalL N A sc2 a2 R1); intros a3.
  case a3; auto.
  intros sc3 Hsc3.
  generalize (Zeq_bool_eq (Z.gcd sc3 N) 1); case Zeq_bool; intros Hz; auto.
  case (prime_dec N); auto; intros Hn.
  case (Zdivide_div_prime_le_square N); auto with zarith.
  intros p (Hp, (Hp1, Hp2)).
  pose (p_pos:= GZnZ.p_pos _ Hp).
  pose (to_p := fun x =>  mkznz _ _ (modz p x)).
  assert (Ni1: nInversible N (scalL N A sc2 a2 R1)).
    rewrite Hsc3; constructor.
    assert (tmp: Bezout sc3 N 1).
      apply Zis_gcd_bezout.
      rewrite <- Hz; auto; apply Zgcd_is_gcd.
   inversion_clear tmp as [u v Huv].
   exists u.
   rewrite Zmult_comm.
   rewrite <- Z_mod_plus with (b := v); auto with zarith.
   rewrite Huv; rewrite Zmod_small; auto with zarith.
  case nInversible_scalL with (2 := Ni1); auto with zarith.
  intros Nt1 Nt2.
  assert (Ni2: nInversible N (scal N A sc1 a1 S1)).
    rewrite Ha2.
    inversion_clear Nt1; constructor; auto; repeat itac.
  case nInversible_scal with (2 := Ni2); auto with zarith.
  clear Nt1 Nt2; intros Nt1 Nt2.
  assert (Ni3: nInversible N (scal N A isc a F)).
    rewrite Ha1.
    inversion_clear Nt1; constructor; auto; repeat itac.
  case nInversible_scal with (2 := Ni3); auto with zarith.
  clear Nt1 Nt2; intros Ni4 Ni5.
  assert (Rp: rel_prime N (4 * A * A * A  + 27 * B * B)).
    case Ni5; intros z1 Hz1.
    apply bezout_rel_prime.
    set (d := 4 * A * A * A + 27 * B * B).
    apply Bezout_intro with (- ((d * z1)/N)) z1.
    generalize Hz1; unfold isc.
    unfold nplus, nmul.
    rewrite (Zmodml (4 * A)); auto.
    rewrite (Zmodml (4 * A * A)); auto.
    rewrite (Zmodml (27 * B)); auto.
    rewrite <- Zplus_mod; auto.
    rewrite Zmodml; auto; fold d; clear Hz1; intros Hz1.
    rewrite (Z_div_mod_eq (z1 * d) N); auto with zarith.
    rewrite (Zmult_comm z1).
    rewrite (Zmult_comm N).
    rewrite Zplus_assoc.
    rewrite (fun x y => Zplus_comm (x * y)).
    rewrite <- Zopp_mult_distr_l.
    rewrite Zplus_opp_r; auto.
  pose (pell := pell_theory A B N_not_div_2 Rp Hp Hp1).
  pose (pequiv := @equiv A B p).
  assert (Hoc: pow  (pkI p) (@pkmul p) (to_p y) 2 =
                pkplus
                 (pkplus
                    (pow (pkI p) (@pkmul p) (to_p x) 3)
                    (pkmul (pA A p) (to_p x)))
                 (pB B p)).
    unfold pA, pB, to_p.
    repeat rewrite <- (to_p_pow N_lt_2 Hp); auto.
    simpl Z_of_nat.
    repeat rewrite <- (to_p_nmul N_lt_2 Hp); auto.
    repeat rewrite <- (to_p_nplus N_lt_2 Hp); auto.
    apply (zirr p).
    rewrite (@Zmod_div_mod p N); auto;
       rewrite on_curve; rewrite <- Zmod_div_mod; auto.
       unfold nmul, nplus.
       rewrite (fun xx => @Zmodpr xx (x^3)); auto.
       rewrite Zmodpl; auto; rewrite <- Zmod_div_mod; auto.
  pose (pcurve_elt := curve_elt (pkI p) (@pkplus p)
                                (@pkmul p) (pA A p) (pB B p)).
  assert (E1: pequiv a (pcurve_elt (to_p x) (to_p y) Hoc)).
    unfold pequiv, a, pcurve_elt.
    apply n_equiv.
    unfold pkdiv, div, to_p.
    fold p_pos; set (pp := mkznz p (x mod p) (modz p x)).
    fold p_pos; set (p1 := mkznz p (1 mod p) (modz p 1)).
    pattern pp at 1; rewrite <- ((FZpZ _ Hp).(F_R).(Rmul_1_l) pp).
    unfold one; fold p_pos; fold p1.
    rewrite ((FZpZ _ Hp).(F_R).(Rmul_comm) p1).
    rewrite <- (FZpZ _ Hp).(F_R).(Rmul_assoc).
    rewrite ((FZpZ _ Hp).(F_R).(Rmul_comm) p1).
    rewrite (FZpZ _ Hp).(Finv_l); auto.
    rewrite (FZpZ _ Hp).(F_R).(Rmul_comm).
    rewrite (FZpZ _ Hp).(F_R).(Rmul_1_l); auto.
    apply (FZpZ _ Hp).(F_1_neq_0).
    unfold pkdiv, div, to_p.
    fold p_pos; set (pp := mkznz p (y mod p) (modz p y)).
    fold p_pos; set (p1 := mkznz p (1 mod p) (modz p 1)).
    pattern pp at 1; rewrite <- ((FZpZ _ Hp).(F_R).(Rmul_1_l) pp).
    unfold one; fold p_pos; fold p1.
    rewrite ((FZpZ _ Hp).(F_R).(Rmul_comm) p1).
    rewrite <- (FZpZ _ Hp).(F_R).(Rmul_assoc).
    rewrite ((FZpZ _ Hp).(F_R).(Rmul_comm) p1).
    rewrite (FZpZ _ Hp).(Finv_l); auto.
    rewrite (FZpZ _ Hp).(F_R).(Rmul_comm).
    rewrite (FZpZ _ Hp).(F_R).(Rmul_1_l); auto.
    apply (FZpZ _ Hp).(F_1_neq_0).
    assert(T1 := scal_correct N_lt_2 N_not_div_2 Rp Hp Hp1 _ _ E1 Ni3).
    rewrite Ha1 in T1; simpl fst in T1.
    match type of T1 with equiv _ ?X =>
      set (p1 := X); fold p1 in T1
    end.
    assert(T2 := scal_correct N_lt_2 N_not_div_2 Rp Hp Hp1 _ _ T1 Ni2).
    rewrite Ha2 in T2; simpl fst in T2.
    pose (ppG := pG A B N_not_div_2 Rp Hp Hp1).
    assert (F1: forall p1, List.In p1 (FGroup.s ppG)).
      intros p2.
      apply (FELLK_in pell _ (in_all_znz _ p_pos)).
    assert (F2 := fun u =>
        @scalL_not_1 N A B N_lt_2 N_not_div_2 Rp _ Hp Hp1 R1 sc2 _ _ u T2 Ni1).
    fold ppG in F2.
    assert (F3 :=
        @scalL_1 N A B N_lt_2 N_not_div_2 Rp _ Hp Hp1 R1 sc2 _ _ T2 Ni1).
    fold ppG in F3.
    rewrite <- psplit_correct in lR_big.
    rewrite HS1 in lR_big; simpl fst in lR_big; simpl snd in lR_big.
    assert (E2: e_order (ceqb pell) p1 ppG = (Zmullp lR)).
      apply order_div; auto.
      red; simpl; auto.
      intros z1 Hz1 Hz2.
        assert (E2: Zpos (z2p z1) = z1).
          generalize Hz1; case z1; simpl; auto; try (intros p2 HH || intro HH).
            case not_prime_0; auto.
          generalize (prime_ge_2 _ HH); unfold Z.le; simpl;
              intros HH1; case HH1; auto.
        rewrite <- psplit_correct.
        rewrite HS1; simpl fst; simpl snd.
        assert (Hl: List.In (z2p z1) R1).
          change R1 with (snd (S1, R1)).
          rewrite <- HS1.
          apply psplit_prime; auto.
          rewrite E2; auto.
          rewrite E2; auto.
       rewrite Zpos_mult_morphism.
       rewrite (Zmull_div (z2p z1)); auto.
       rewrite E2; rewrite Zmult_assoc.
       assert (Hpz1: z1 > 0).
         apply Z.lt_gt; apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith.
         red; auto.
       rewrite Z_div_mult; auto.
       rewrite gpow_gpow.
       rewrite <- E2; apply F2; auto.
       apply (FELLK_in pell _ (in_all_znz _ p_pos)); auto.
       red; simpl; intros HH; discriminate.
       apply Z_div_pos; auto with zarith.
       rewrite Hsc3 in F3; simpl fst in F3.
       rewrite <- psplit_correct.
       rewrite HS1; simpl fst; simpl snd.
       rewrite Zpos_mult_morphism; rewrite gpow_gpow; auto.
       set (p2 := gpow (gpow p1 ppG S1) ppG (Zmull R1)).
       fold p2 in F3; inversion F3; auto.
       red; simpl; intros; discriminate.
       red; simpl; intros; discriminate.
    absurd (e_order(ceqb pell) p1 ppG <= (FGroup.g_order ppG)).
      apply Zlt_not_le.
      apply Z.le_lt_trans with (1 := gorder_pG A B N_not_div_2 Rp Hp Hp1).
      rewrite E2.
      replace (Zpos (Zmullp lR)) with ((Zmullp lR - 1) + 1)%Z; try ring.
      apply Zplus_lt_compat_r.
      apply Zlt_square_simpl.
      change 0 with (1-1).
      unfold Zminus; apply Zplus_le_compat_r.
      case Zmullp; try intros p1; red; simpl; intros; discriminate.
      apply Z.le_lt_trans with (4 * N).
      replace (2 * p * (2 * p))%Z with (4 * (p * p))%Z; auto with zarith.
      ring.
      rewrite <- psplit_correct; rewrite HS1; simpl fst; simpl snd; auto.
      assert (tmp: forall x, x ^2 = x * x).
        intros x1; replace 2 with (1 + 1); auto; rewrite Zpower_exp.
        rewrite Zpower_1_r; auto.
        red; simpl; intros; discriminate.
        red; simpl; intros; discriminate.
      rewrite <- tmp; auto.
     apply Zdivide_le; auto.
     apply Zlt_le_weak.
     apply e_order_pos; auto.
     apply FGroup.g_order_pos.
     apply e_order_divide_g_order; auto.
Qed.

End pell.