(*
 * Copyright (c) 2009-2010, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

Require Import msl.base.

Open Local Scope nat_scope.

Record ageable_facts (A:Type) (level: A -> nat) (age1:A -> option A)  :=
{ af_unage : forall x':A, exists x, age1 x = Some x'
; af_level1 : forall x, age1 x = None <-> level x = 0
; af_level2 : forall x y, age1 x = Some y -> level x = S (level y)
}.

Implicit Arguments af_unage [[A] [level] [age1]].
Implicit Arguments af_level1 [[A] [level] [age1]].
Implicit Arguments af_level2 [[A] [level] [age1]].

Class ageable (A:Type) := mkAgeable
{ level : A -> nat
; age1 : A -> option A
; age_facts : ageable_facts A level age1
}.

Definition age {A} `{ageable A} (x y:A) := age1 x = Some y.

Lemma af_wf {A} `{ageable A} :
 well_founded (fun x y => age y x).
Proof.
  intros.
  intro.
  remember (level a).
  revert a Heqn.
  induction n; intros; constructor; intros.
  apply (af_level2 age_facts) in H0.
  rewrite H0 in Heqn.
  inversion Heqn.
  copy H0.
  apply (af_level2 age_facts) in H0.
  apply IHn.
  omega.
Qed.
Implicit Arguments af_wf.

Definition age_induction {A} `{ageable A} :=
  well_founded_induction (af_wf _).

Definition fashionR {A1} `{ageable A1} {A2}`{ageable A2} (x:A1) (y: A2) : Prop :=
  level x = level y.

Lemma fashionR_refl {A} `{ageable A} : reflexive _ fashionR.
Proof.
  repeat intro; hnf; auto.
Qed.

Lemma fashionR_trans {A} `{ageable A} {B} `{ageable B} {C} `{ageable C} :
    forall (x: A) (y: B) (z: C), fashionR x y -> fashionR y z -> fashionR x z.
Proof.
  unfold fashionR; intros; congruence.
Qed.

Lemma fashionR_sym {A} `{ageable A} {B} `{ageable B}:
   forall (x: A) (y: B), fashionR x y -> fashionR y x.
Proof.
  unfold fashionR; intros; auto.
Qed.

Lemma age_level {A} `{ageable A} : forall (x y:A),
  age x y -> level x = S (level y).
Proof.
  intros.
  apply (af_level2 age_facts); auto.
Qed.

Lemma age1_level0 {A} `{ageable A} : forall (x:A),
  age1 x = None <-> level x = 0.
Proof.
  intros; apply (af_level1 age_facts).
Qed.

Section level'.
  Variable A:Type.
  Variable ag:ageable A.

  Require Recdef.
  Function level' (x:A) { wf (transp _ (@age A ag)) x } : nat :=
    match age1 x with
    | None => 0
    | Some x' => S (level' x')
    end.
    hnf; auto.
    unfold transp; apply (af_wf _).
  Defined.

  Theorem level_level' : forall x:A, level x = level' x.
  Proof.
    intro x; induction x using age_induction; intros.
    rewrite level'_equation.
    case_eq (age1 x); intros.
    rewrite (af_level2 age_facts x a); auto.
    rewrite <- age1_level0; auto.
  Qed.
End level'.

Lemma levelS_age1 {A} `{ageable A} : forall (x:A) n,
  level x = S n ->
  exists y, age1 x = Some y.
Proof.
  intros; rewrite level_level' in H0.
  rewrite level'_equation in H0.
  destruct (age1 x); eauto.
  inv H0.
Qed.

Lemma age1_levelS {A} `{ageable A} : forall (x y:A),
  age1 x = Some y ->
  exists n, level x = S n.
Proof.
  intros; rewrite level_level'.
  rewrite level'_equation.
  destruct (age1 x); eauto.
  inv H0.
Qed.

Lemma age1_level0_absurd {A} `{ageable A} : forall (x y:A),
  age1 x = Some y ->
  level x = 0 ->
  False.
Proof.
  intros.
  rewrite <- age1_level0 in H1.
  rewrite H0 in H1; discriminate.
Qed.

Lemma age1None_levelS_absurd {A} `{ageable A} : forall (x:A) n,
  age1 x = None ->
  level x = S n ->
  False.
Proof.
  intros.
  rewrite age1_level0 in H0.
  rewrite H0 in H1; discriminate.
Qed.

Section RtRft.
  Variable A:Type.
  Variable R:relation A.

  Let Rt := clos_trans A R.
  Let Rft := clos_refl_trans A R.

  Lemma Rt_Rft : forall x y, Rt x y -> Rft x y.
  Proof.
    intros; elim H; intros.
    apply rt_step; auto.
    eapply rt_trans; eauto.
  Qed.

  Lemma Rt_Rft_trans : forall x y z, Rt x y -> Rft y z -> Rt x z.
  Proof.
    intros x y z H H1; revert x H; elim H1; intros; auto.
    eapply t_trans; eauto; apply t_step; auto.
  Qed.

  Lemma Rft_Rt_trans : forall x y z, Rft x y -> Rt y z -> Rt x z.
  Proof.
    intros x y z H; revert z; elim H; intros; auto.
    eapply t_trans; eauto; apply t_step; auto.
  Qed.

  Lemma transpose_clos_trans : forall A R x y,
    clos_trans A (transp A R) x y <-> transp A (clos_trans A R) x y.
  Proof.
    unfold transp; intuition.

    elim H; intros.
    apply t_step; auto.
    apply t_trans with y0; auto.

    elim H; intros.
    apply t_step; auto.
    apply t_trans with y0; auto.
  Qed.
End RtRft.

Hint Resolve rt_refl.

Definition laterR {A} `{ageable A} : relation A := clos_trans A age.
Definition necR   {A} `{ageable A} : relation A := clos_refl_trans A age.

Require Wellfounded.
Lemma laterR_wf {A} `{ageable A} :
  well_founded (transp _ laterR).
Proof.
  intros.
  hnf; intro.
  induction a using
    (well_founded_induction (Wellfounded.Transitive_Closure.wf_clos_trans _ (fun x y => age y x) (af_wf _))).
  constructor; intros.
  unfold laterR in H1.
  rewrite <- transpose_clos_trans in H1.
  apply H0; auto.
Qed.

Definition laterR_induction {A} `{ageable A} :=
  @well_founded_induction A (transp A laterR) laterR_wf.

Lemma age_irreflexive {A}  `{ageable A}: forall x, age x x -> False.
Proof.
  intros x.
  induction x using age_induction; intros.
  apply H0 with x; auto.
Qed.

Lemma laterR_irreflexive {A} `{HA: ageable A} : forall x, laterR x x -> False.
Proof.
  intros x.
  induction x using laterR_induction; intros.
  apply H with x; auto.
Qed.

Lemma nec_refl_or_later {A} `{ageable A} : forall x y,
  necR x y -> x = y \/ laterR x y.
Proof.
  intros.
  elim H0; intros; auto.
  right; apply t_step; auto.
  destruct H2; destruct H4; subst; auto.
  right; apply t_trans with y0; auto.
Qed.

Lemma necR_antisym {A} `{ageable A} : forall x y,
  necR x y -> necR y x -> x = y.
Proof.
  intros.
  apply nec_refl_or_later in H0.
  apply nec_refl_or_later in H1.
  intuition.
  elim (laterR_irreflexive x).
  eapply t_trans; eauto.
Qed.

Lemma age_later_nec {A} `{HA: ageable A} : forall x y z,
  age x y ->
  laterR x z ->
  necR y z.
Proof.
  intros x y z H H1; revert y H.
  induction H1; intros.
  replace y0 with y.
  apply rt_refl.
  unfold age in *; congruence.
  apply rt_trans with y; auto.
  apply IHclos_trans1; auto.
  apply Rt_Rft; auto.
Qed.

Lemma necR_level {A} `{X: ageable A} : forall (x y:A),
  necR x y ->
  level x >= level y.
Proof.
  intros x y H; induction H; auto.
  rewrite (age_level x y); auto.
  omega.
Qed.

Lemma laterR_level {A} `{X: ageable A} : forall (x y:A),
  laterR x y ->
  level x > level y.
Proof.
  intros x y H; induction H; auto.
  rewrite (age_level x y); auto.
  omega.
Qed.

Section NAT_AGEABLE.

  Definition natLevel (x:nat) : nat := x.
  Definition natAge1 (x:nat) : option nat :=
    match x with
    | 0 => None
    | S n => Some n
    end.
  Definition natUnage (x:nat) : nat := S x.

  Lemma ag_nat_facts :
    ageable_facts nat natLevel natAge1.
  Proof.
    constructor.
    intros; exists (S x'); compute; auto.
    intro x; destruct x; intuition; inv H.
    firstorder;
      destruct x; inv H; compute; eauto.
  Qed.

  Definition ag_nat : ageable nat :=
    mkAgeable nat natLevel natAge1 ag_nat_facts.

  Lemma nec_nat : forall (n n':nat),
    @necR _ ag_nat n n' <-> n' <= n.
  Proof.
    intros. split; intro.
    induction H.
    destruct x; inv H; auto.
    auto.
    omega.

    induction H.
    apply rt_refl.
    apply rt_trans with m.
    apply rt_step. compute; auto.
    auto.
  Qed.

  Lemma later_nat : forall (n n':nat),
    @laterR _ ag_nat n n' <-> n' < n.
  Proof.
    intros. split; intro.
    induction H.
    destruct x; simpl in H.
    inv H.
    inv H. omega.
    omega.
    hnf in H.
    inv H.
    apply t_step.
    compute; auto.
    apply Rt_Rft_trans with m.
    apply t_step. compute; auto.
    change (@necR _ ag_nat m n').
    rewrite nec_nat.
    omega.
  Qed.

End NAT_AGEABLE.

Lemma laterR_level' {A} `{H : ageable A}: forall {w1 w2: A}, laterR w1 w2 -> @laterR _ ag_nat (level w1) (level w2).
Proof.
induction 1.
constructor 1. apply age_level in H0. rewrite H0; reflexivity.
constructor 2 with (level y); auto.
Qed.

Lemma necR_nat {A} `{H : ageable A}:
    forall {x y: A}, necR x y -> @necR nat ag_nat (level x) (level y).
  Proof.
    intros. apply necR_level in H0.
     induction H0; simpl in *. constructor 2.
     constructor 3 with m. constructor 1. constructor.
     auto.
  Qed.

Section BIJECTION.
  Variable A B : Type.
  Variable ag: ageable A.
  Variable bijAB: bijection A B.

  Let levelB (x:B) : nat :=
    level (bij_g _ _ bijAB x).

  Let age1B  (x: B) : option B :=
     match age1 (bij_g _ _ bijAB x) with
     | Some y => Some (bij_f _ _ bijAB y)
     | None => None
     end.

  Let ageB (x y: B) :=age1B x = Some y.

  Lemma age_bij_unage :
    forall x', exists x, age1B x = Some x'.
  Proof.
    unfold age1B, levelB; simpl; intros.
    destruct bijAB as [f g fg gf]; simpl in *.
    destruct (af_unage age_facts (g x')) as [y ?].
   exists (f y). rewrite gf. rewrite H. f_equal. apply fg.
  Qed.

  Lemma age_bij_level1 :
    forall x, age1B x = None <-> levelB x = 0.
  Proof.
    intros.
    unfold age1B, levelB; simpl.
    destruct bijAB as [f g fg gf]; simpl.
    case_eq (age1 (g x)); intuition; try discriminate.
    rewrite <- age1_level0 in H1.
    rewrite H0 in H1; discriminate.
    rewrite <- age1_level0; auto.
  Qed.

  Lemma age_bij_level2 :
    forall x y, age1B x = Some y -> levelB x = S (levelB y).
  Proof.
    intros.
    unfold age1B, levelB in *; simpl in *.
    destruct bijAB as [f g fg gf]; simpl in *.
    case_eq (age1 (g x)); intros; rewrite H0 in H; inv H.
    rewrite gf.
    apply (af_level2 age_facts); auto.
  Qed.

  Lemma ag_bij_facts : ageable_facts B levelB age1B.
  Proof.
    constructor.
    exact age_bij_unage.
    exact age_bij_level1.
    exact age_bij_level2.
  Qed.

  Definition ag_bij : ageable B :=
    mkAgeable B levelB age1B ag_bij_facts.
End BIJECTION.

Section PROD.
  Variable A B : Type.
  Variable agA: ageable A.

  Let levelAB (x:prod A B) := level (fst x).
  Let age1AB (x:prod A B) :=
    match age1 (fst x) with
    | None => None
    | Some a' => Some (a',snd x)
    end.

  Lemma ag_prod_facts : ageable_facts (prod A B) levelAB age1AB.
  Proof.
    constructor.
    unfold levelAB, age1AB; simpl; intros.
    destruct (af_unage age_facts (fst x')) as [y1 ?].
    exists (y1, snd x'). simpl. rewrite H. f_equal. destruct x'; auto.
    intros [a b]; firstorder.
    unfold age1AB in H; simpl in H.
    case_eq (age1 a); intros; rewrite H0 in H; inv H.
    unfold levelAB; simpl.
    rewrite <- age1_level0; auto.
    unfold levelAB in H.
    simpl in H.
    rewrite <- age1_level0 in H.
    unfold age1AB; simpl.
    rewrite H; auto.
    intros.
    unfold age1AB in H.
    unfold levelAB.
    destruct x; simpl in *.
    case_eq (age1 a); intros; rewrite H0 in H; inv H.
    simpl.
    apply age_level; auto.
  Qed.

  Definition ag_prod :=
    mkAgeable (prod A B) levelAB age1AB ag_prod_facts.

  Lemma prod_nec_split : forall n x n' x',
    @necR (prod A B) ag_prod (n,x) (n',x') <-> necR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (n,x) as w.
    remember (n',x') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H. simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply rt_step. auto.
    inv Heqw'.
    split; auto.
    apply rt_refl.
    spec IHclos_refl_trans1 n x0 (fst y) (snd y).
    spec IHclos_refl_trans1; auto.
    spec IHclos_refl_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_refl_trans2 a b n' x'.
    spec IHclos_refl_trans2; auto.
    spec IHclos_refl_trans2; auto.
    intuition. eapply rt_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply rt_step. hnf.
    hnf in H. simpl.
    unfold age1AB. simpl. rewrite H. auto.
    apply rt_refl.
    eapply rt_trans; eauto.
  Qed.

  Lemma prod_later_split : forall n x n' x',
    @laterR (prod A B) ag_prod (n,x) (n',x') <-> laterR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (n,x) as w.
    remember (n',x') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H; simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply t_step. compute. auto.
    spec IHclos_trans1 n x0 (fst y) (snd y).
    spec IHclos_trans1; auto.
    spec IHclos_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_trans2 a b n' x'.
    spec IHclos_trans2; auto.
    spec IHclos_trans2; auto.
    intuition. eapply t_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply t_step.
    hnf; simpl. unfold age1AB. simpl; rewrite H. auto.
    eapply t_trans; eauto.
  Qed.

End PROD.

Section PROD'.
  Variable A B : Type.
  Variable agB: ageable B.

  Let levelAB (x:prod A B) := level (snd x).
  Let age1AB (x:prod A B) :=
    match age1 (snd x) with
    | None => None
    | Some a' => Some (fst x, a')
    end.

  Lemma ag_prod'_facts : ageable_facts (prod A B) levelAB age1AB.
  Proof.
    constructor.
    unfold levelAB, age1AB; simpl; intros.
    destruct (af_unage age_facts (snd x')) as [y2 ?].
    exists (fst x', y2). simpl. rewrite H. f_equal. destruct x'; auto.
    intros [a b]; firstorder.
    unfold age1AB in H; simpl in H.
    case_eq (age1 b); intros; rewrite H0 in H; inv H.
    unfold levelAB; simpl.
    rewrite <- age1_level0; auto.
    unfold levelAB in H.
    simpl in H.
    rewrite <- age1_level0 in H.
    unfold age1AB; simpl.
    rewrite H; auto.
    intros.
    unfold age1AB in H.
    unfold levelAB.
    destruct x; simpl in *.
    case_eq (age1 b); intros; rewrite H0 in H; inv H.
    simpl.
    apply age_level; auto.
  Qed.

  Definition ag_prod' :=
    mkAgeable (prod A B) levelAB age1AB ag_prod'_facts.

  Lemma prod'_nec_split : forall n x n' x',
    @necR (prod A B) ag_prod' (x,n) (x',n') <-> necR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (x,n) as w.
    remember (x',n') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H. simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply rt_step. auto.
    inv Heqw'.
    split; auto.
    apply rt_refl.
    spec IHclos_refl_trans1 n x0 (snd y) (fst y).
    spec IHclos_refl_trans1; auto.
    spec IHclos_refl_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_refl_trans2 b a n' x'.
    spec IHclos_refl_trans2; auto.
    spec IHclos_refl_trans2; auto.
    intuition. eapply rt_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply rt_step. hnf.
    hnf in H. simpl.
    unfold age1AB. simpl. rewrite H. auto.
    apply rt_refl.
    eapply rt_trans; eauto.
  Qed.

  Lemma prod'_later_split : forall n x n' x',
    @laterR (prod A B) ag_prod' (x,n) (x',n') <-> laterR n n' /\ x = x'.
  Proof.
    intros; split; intro.
    remember (x,n) as w.
    remember (x',n') as w'.
    revert n x n' x' Heqw Heqw'.
    induction H; simpl; intros; subst; auto.
    unfold age in H. simpl in H.
    unfold age1AB in H; simpl in H.
    case_eq (age1 n); intros; rewrite H0 in H; inv H.
    split; auto.
    apply t_step. compute. auto.
    spec IHclos_trans1 n x0 (snd y) (fst y).
    spec IHclos_trans1; auto.
    spec IHclos_trans1; destruct y; auto.
    simpl in *.
    spec IHclos_trans2 b a n' x'.
    spec IHclos_trans2; auto.
    spec IHclos_trans2; auto.
    intuition. eapply t_trans; eauto.
    congruence.

    destruct H; subst.
    induction H.
    apply t_step.
    hnf; simpl. unfold age1AB. simpl; rewrite H. auto.
    eapply t_trans; eauto.
  Qed.

End PROD'.

Fixpoint composeOptN (A: Type) (f: A -> option A)
         (n: nat) (w: A) {struct n} : option A :=
 match n  with
 | S n' => match f w with Some w' => composeOptN A f n' w' | None => None end
 | O => Some w
 end.
Implicit Arguments composeOptN.

Definition ageN {A} `{ageable A}: nat -> A -> option A := composeOptN age1.

Lemma ageN1  {A} `{ageable A}: ageN 1 = age1.
Proof.
intros.
unfold ageN. simpl.
extensionality phi.
case_eq (age1 phi); intros; try rewrite H; auto.
Qed.

Lemma ageN_compose {A} `{agA : ageable A}:
 forall a b c phi1 phi2 phi3,ageN a phi1 = Some phi2 ->
       ageN b phi2 = Some phi3 ->  (a+b=c)%nat ->  ageN c phi1 = Some phi3.
Proof.
unfold ageN in *.
induction a; simpl; intros.
subst. inversion H; clear H. auto.
subst c.
case_eq (age1 phi1); intros; rewrite H1 in H; try discriminate.
simpl.
rewrite H1.
eapply IHa; eauto.
Qed.

Lemma ageN_compose' {A} `{agA : ageable A}:
  forall a b phi1 phi3,
   ageN (a+b)%nat phi1 = Some phi3 -> exists phi2, ageN a phi1 = Some phi2 /\ ageN b phi2 = Some phi3.
Proof.
intros.
case_eq (ageN a phi1); intros.
rename a0 into phi.
exists phi.
split; auto.
case_eq (ageN b phi); intros.
rename a0 into phi0.
generalize (ageN_compose a b (a+b) phi1 _ _ H0 H1 (refl_equal _)); intro.
rewrite H in H2; auto.
elimtype False.
revert phi1 phi H H1 H0; induction a; intros.
simpl in *.
inv H0.
rewrite H in H1; discriminate.
replace (S a + b)%nat with (S (a+b))%nat in H by omega.
unfold ageN in *;
simpl in *.
case_eq (age1 phi1); intros; rewrite H2 in H; try discriminate.
rewrite H2 in H0.
eapply IHa; eauto.
elimtype False.
unfold ageN in *.
revert phi1 H H0; induction a; intros.
simpl in *. discriminate.
replace (S a + b)%nat with (S (a+b))%nat in H by omega.
simpl in *.
revert H H0; case_eq (age1 phi1); intros; try discriminate.
eapply IHa; eauto.
Qed.

Lemma necR_evolve {A} `{agA : ageable A}:
    necR = fun (phi phi': A) => exists n, ageN n phi = Some phi'.
Proof.
extensionality w w'.
apply prop_ext; split; intros.
unfold necR in H.
induction H.
exists 1%nat. rewrite ageN1.
simpl.
auto.
exists O; auto.
destruct IHclos_refl_trans1 as [n1 ?].
destruct IHclos_refl_trans2 as [n2 ?].
exists (n1+n2)%nat.
eapply ageN_compose; eauto.
destruct H as [n ?].
revert w w' H; induction n; intros.
inv H.
constructor 2.
unfold ageN in H.
simpl in H.
revert H; case_eq (age1 w); intros; try discriminate.
constructor 3 with a.
constructor 1; auto.
apply IHn; auto.
Qed.

Lemma age_noetherian  {A} `{ageable A}: forall phi, exists n, ageN n phi = None.
Proof.
  intros.
  induction phi using age_induction.
  rename x into phi.
  case_eq (age1 phi); intros.
  generalize H1; intros.
  apply H0 in H1.
  destruct H1 as [n ?].
  exists (S n).
  unfold ageN; simpl.
  rewrite H2; auto.
  exists (S O); simpl.
  unfold ageN; simpl.
  rewrite H1.
  auto.
Qed.

Lemma predicate_max:
  forall (F: nat -> Prop) (Fdec: forall n, {F n}+{~ F n}) n,
  F 0%nat ->
  ~ F n ->
  exists i, F i /\ (i<n)%nat /\ ~ F (S i).
Proof.
intros.
assert (forall m, (m <= n)%nat ->
         (forall k, (k<m)%nat -> F k) \/
         (exists i, F i /\ (i<m)%nat /\ ~ F (S i))).
induction m.
left; intros.
elimtype False; omega.
intro.
assert (m<=n)%nat; try omega.
destruct (IHm H2).
assert (m < n \/ m = n)%nat; try omega.
destruct H4.
destruct (Fdec m) as [?H|?H].
left.
intros.
assert (k < m \/ k = m)%nat; try omega.
destruct H7.
auto.
subst k; auto.
right.
exists (Peano.pred m).
destruct m.
contradiction.
replace (Peano.pred (S m)) with m; try omega.
split.
apply H3; try omega.
split; try omega.
auto.
subst m.
right.
destruct n.
contradiction.
exists n; repeat split; auto; try omega.
right.
destruct H3 as [i H4].
destruct H4.
destruct H4.
exists i; repeat split; auto; omega.
assert (n <= n)%nat; try omega.
destruct (H1 _ H2).
destruct n; try contradiction.
exists n; repeat split; auto; try omega.
auto.
Qed.

Lemma age_noetherian'  {A} `{agA : ageable A}:
       forall phi, exists! n, exists phi', ageN n phi = Some phi' /\ age1 phi' = None.
Proof.
intros.
destruct (age_noetherian phi) as [n ?].
assert (Fdec: forall n, {ageN n phi <> None}+{~( ageN n phi <> None)})
  by (intros; destruct (ageN n0 phi); auto; left; intro Hx; inversion Hx).
destruct (predicate_max (fun n => ageN n phi <> None) Fdec n) as [i [? [? ?]]].
intro. inv H0.
intro.
rewrite H in H0.
contradiction H0; auto.
exists i.
split.
revert H0; case_eq (ageN i phi); intros.
exists a; split; auto.
revert H2; case_eq (ageN (S i) phi); intros.
contradiction H4.
intro Hx; inv Hx.
clear - H0 H2.
revert phi a H0 H2; induction i; intros.
inv H0.
rewrite ageN1 in H2; auto.
unfold ageN in *.
simpl in H0.
revert H0; case_eq (age1 phi); intros; try discriminate.
simpl in H2.
rewrite H in H2.
eapply IHi.
eauto.
simpl.
auto.
contradiction H3; auto.
intros.
destruct H3 as [phi' [? ?]].
assert (ageN (S i) phi = None).
clear - H2.
revert H2; case_eq (ageN (S i) phi); intros.
contradict H2. intro Hx; inv Hx.
auto. clear H2.
clear - H0 H5 H3 H4.
revert H0; case_eq (ageN i phi); intros.
2: contradiction H0; auto.
clear H0.
assert (age1 a = None).
clear - H H5.
revert phi H5 H; induction i; intros.
inv H; rewrite ageN1 in H5; auto.
unfold ageN in *.
revert H H5; simpl. case_eq (age1 phi); intros; try discriminate.
eapply IHi; eauto.
clear H5.
assert (forall i d phi a a', ageN i phi = Some a -> ageN (i+d) phi = Some a' -> age1 a' = None -> age1 a = None -> d=0%nat).
clear.
induction i; intros.
inv H.
destruct d; auto.
simpl in H0.
unfold ageN in H0. simpl in H0.
rewrite H2 in H0. inv H0.
unfold ageN in H, H0. simpl in *.
revert H; case_eq (age1 phi); intros; try discriminate.
rewrite H in H0.
eauto.
assert (i<x' \/ i=x' \/ i>x')%nat by omega.
destruct H2 as [?| [?| ?]]; auto.
replace x' with (i+(x'-i))%nat in H3 by omega.
specialize (H1 _ _ _ _ _ H H3 H4 H0).
omega.
replace i with (x'+(i-x'))%nat in H by omega.
specialize (H1 _ _ _ _ _ H3 H H0 H4).
omega.
Qed.

Lemma ageable_ext:
   forall A (B C: ageable A),
      @age1 _ B = @age1 _ C -> @level _ B = @level _ C -> B=C.
Proof.
intros.
destruct B; destruct C.
simpl in *.
subst age3. subst level0.
replace age_facts1 with age_facts0; auto.
apply proof_irr.
Qed.

Lemma necR_linear {A} `{H : ageable A}:
  forall {a b c}, necR a b -> necR a c -> necR b c \/ necR c b.
Proof.
intros.
apply trans_rt1n in H0.
apply trans_rt1n in H1.
revert c H1; induction H0; intros; auto.
left; apply rt1n_trans; auto.
inversion H2; subst.
right.
apply rt_trans with y.
constructor 1; auto.
apply rt1n_trans; auto.
unfold age in H0,H3.
rewrite H0 in H3; inv H3.
destruct (IHclos_refl_trans_1n _ H4); auto.
Qed.

Lemma necR_linear' {A} `{H : ageable A}:
   forall {a b c}, necR a b -> necR a c -> level b = level c -> b=c.
Proof.
intros.
destruct (necR_linear H0 H1).
clear - H2 H3.
apply nec_refl_or_later in H3.
destruct H3; auto.
apply laterR_level in H0; unfold fashionR in H2; elimtype False; omega.
apply nec_refl_or_later in H3.
destruct H3; auto.
apply laterR_level in H3; unfold fashionR in H2; elimtype False; omega.
Qed.

Lemma laterR_necR {A} `{agA : ageable A}:
  forall {x y}, laterR x y -> necR x y.
Proof.
induction 1; intros.
constructor; auto.
econstructor 3; auto.
apply rt_trans with y; auto.
Qed.

Lemma necR_refl {A} `{H : ageable A}:
  forall phi, necR phi phi.
Proof.
intros; constructor 2.
Qed.

Hint Resolve @necR_refl.

Lemma necR_trans  {A} `{H : ageable A}:
  forall phi1 phi2 phi3, necR phi1 phi2 -> necR phi2 phi3 -> necR phi1 phi3.
Proof.
intros.
econstructor 3; eauto.
Qed.

Lemma necR_laterR {A} `{agA : ageable A}:
  forall w1 w2 w3, necR w1 w2 -> laterR w2 w3 -> laterR w1 w3.
Proof.
intros.
revert w3 H0; induction H; intros.
econstructor 2. constructor 1; eauto. apply H0.
auto.
auto.
Qed.


Require Export Base.

Definition is_coproduct {C: Category} (a b p: C) (p1: a ~> p) (p2: b ~> p) :=
  forall (z: C) (f: a ~> z) (g: b ~> z), exists! h: p ~> z, h ∘ p1 = f /\ h ∘ p2 = g.

Definition is_coprod_obj {C: Category} (a b p: C) :=
  exists (p1: a ~> p) (p2: b ~> p), is_coproduct a b p p1 p2.

Definition ex_coproduct {C: Category} (a b: C) :=
  exists (p: C), is_coprod_obj a b p.

Instance is_coprod_obj_iso (C: Category): Proper (isomorphic C ==> isomorphic C ==> isomorphic C ==> iff) is_coprod_obj.
Proof.
  enough (Proper (isomorphic C ==> isomorphic C ==> isomorphic C ==> impl) is_coprod_obj).
  now split; apply H.
  intros a x [i] b y [j] p q [k] [p1 [p2 H]].
  exists (k ∘ p1 ∘ i⁻¹), (k ∘ p2 ∘ j⁻¹).
  intros z f' g'.
  assert (exists f: a ~> z, f ∘ i⁻¹ = f').
    exists (f' ∘ i).
    rewrite <- comp_assoc, inv_r.
    apply comp_id_r.
  destruct H0 as [f].
  subst f'.
  assert (exists g: b ~> z, g ∘ j⁻¹ = g').
    exists (g' ∘ j).
    rewrite <- comp_assoc, inv_r.
    apply comp_id_r.
  destruct H0 as [g].
  subst g'.
  specialize (H z f g).
  destruct H as [h [[H1 H2] Hh]].
  subst f g.
  exists (h ∘ k⁻¹).
  repeat split.
  1, 2: rewrite !comp_assoc.
  1, 2: do 2 f_equal.
  1, 2: rewrite <- comp_assoc, inv_l.
  1, 2: apply comp_id_r.
  intros h' [H1 H2].
  rewrite !comp_assoc in H1.
  rewrite !comp_assoc in H2.
  apply iso_epic in H1.
  apply iso_epic in H2.
  apply (iso_epic k).
  rewrite <- comp_assoc, inv_l, comp_id_r.
  now apply Hh.
Qed.

Instance ex_coproduct_iso (C: Category): Proper (isomorphic C ==> isomorphic C ==> iff) ex_coproduct.
Proof.
  intros a x H1 b y H2.
  unfold ex_coproduct.
  f_equiv.
  intros p.
  now f_equiv.
Qed.

Lemma coprod_obj_euniqueness {C: Category} (a b: C): euniqueness (is_coprod_obj a b).
Proof.
  intros p q [p1 [p2 Hp]] [q1 [q2 Hq]].
  destruct (Hq p p1 p2) as [f [Hf _]].
  destruct (Hp q q1 q2) as [g [Hg _]].
  constructor.
  exists g, f.
  all: symmetry.
  + specialize (Hp p p1 p2).
    destruct Hp as [p' [Hp H]].
    transitivity p'.
    symmetry.
    all: apply H.
    all: split.
    1, 2: apply comp_id_l.
    all: rewrite <- comp_assoc.
    now rewrite (proj1 Hg).
    now rewrite (proj2 Hg).
  + specialize (Hq q q1 q2).
    destruct Hq as [q' [Hq H]].
    transitivity q'.
    symmetry.
    all: apply H.
    all: split.
    1, 2: apply comp_id_l.
    all: rewrite <- comp_assoc.
    now rewrite (proj1 Hf).
    now rewrite (proj2 Hf).
Qed.

Lemma ex_coproduct_eunique {C: Category} (a b: C): ex_coproduct a b <-> exists!! p, is_coprod_obj a b p.
Proof.
  rewrite <- eunique_existence.
  split.
  + intros H.
    split.
    now apply is_coprod_obj_iso.
    split.
    exact H.
    apply coprod_obj_euniqueness.
  + intros [_ [H _]].
    exact H.
Qed.

Module CoprodCategory.

Structure mixin_of (C: Category) := Mixin {
  coprod: C -> C -> C;
  merge {a b c: C}: a ~> c -> b ~> c -> coprod a b ~> c;
  in1 {a b: C}: a ~> coprod a b;
  in2 {a b: C}: b ~> coprod a b;
  merge_in {a b c: C} (f: a ~> c) (g: b ~> c) (h: coprod a b ~> c): h = merge f g <-> h ∘ in1 = f /\ h ∘ in2 = g;
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { sort: Category; _: class_of sort }.
Local Coercion sort: type >-> Category.

Variable T: type.
Definition class := match T return class_of T with Pack _ c => c end.

Definition Cat: Cat := T.

End ClassDef.

Lemma mixin_eq {C: Category} (m n: mixin_of C): m = n <-> forall x y, coprod C m x y = coprod C n x y /\ forall (e: coprod C m x y = coprod C n x y), eq_iso e ∘ @in1 C m x y = @in1 C n x y /\ eq_iso e ∘ @in2 C m x y = @in2 C n x y.
Proof.
  split.
  + intros H.
    subst n.
    intros x y.
    split.
    reflexivity.
    intros e.
    rewrite eq_iso_refl; clear e.
    split.
    all: apply comp_id_l.
  + destruct m as [p fp p1 p2 Hp], n as [q fq q1 q2 Hq]; simpl.
    intros H.
    enough (p = q).
    subst q.
    enough (p1 = q1 /\ p2 = q2) as [].
    subst q1 q2.
    enough (fp = fq).
    subst fq.
    f_equal; apply proof_irrelevance.
    - extensionality x.
      extensionality y.
      extensionality z.
      extensionality f.
      extensionality g.
      now apply Hq, Hp.
    - split.
      all: extensionality x.
      all: extensionality y.
      all: specialize (H x y).
      all: apply proj2 in H.
      all: specialize (H eq_refl).
      all: simpl in H.
      all: now rewrite !comp_id_l in H.
    - extensionality x.
      extensionality y.
      apply H.
Qed.

Module Exports.

Coercion sort: type >-> Category.
Coercion Cat: type >-> Category.obj.
Notation CoprodCategory := type.

End Exports.

End CoprodCategory.

Export CoprodCategory.Exports.

Section Coproduct.
Context {C: CoprodCategory}.

Definition coprod: C -> C -> C := CoprodCategory.coprod C (CoprodCategory.class C).
Definition merge: forall {a b c: C}, a ~> c -> b ~> c -> coprod a b ~> c := @CoprodCategory.merge C (CoprodCategory.class C).
Definition in1: forall {a b: C}, a ~> coprod a b := @CoprodCategory.in1 C (CoprodCategory.class C).
Definition in2: forall {a b: C}, b ~> coprod a b := @CoprodCategory.in2 C (CoprodCategory.class C).

Infix "+" := coprod (at level 50, left associativity).
Notation "[ f , g ]" := (merge f g).

Lemma merge_in {a b c: C} (f: a ~> c) (g: b ~> c) (h: a + b ~> c): h = [f, g] <-> h ∘ in1 = f /\ h ∘ in2 = g.
Proof. apply CoprodCategory.merge_in. Qed.

Lemma merge_in1 {a b c: C} (f: a ~> c) (g: b ~> c): [f, g] ∘ in1 = f.
Proof. now apply merge_in with g. Qed.

Lemma merge_in2 {a b c: C} (f: a ~> c) (g: b ~> c): [f, g] ∘ in2 = g.
Proof. now apply merge_in with f. Qed.

Lemma merge_eta {a b c: C} (f: a + b ~> c): [f ∘ in1, f ∘ in2] = f.
Proof.
  symmetry.
  now apply merge_in.
Qed.

Lemma merge_comp {a b c d: C} (f: c ~> d) (g: a ~> c) (h: b ~> c): f ∘ [g, h] = [f ∘ g, f ∘ h].
Proof.
  apply merge_in.
  split.
  all: rewrite <- comp_assoc.
  all: f_equal.
  apply merge_in1.
  apply merge_in2.
Qed.

Lemma merge_inj {a b c: C} (f f': a ~> c) (g g': b ~> c):
  [f, g] = [f', g'] <-> f = f' /\ g = g'.
Proof.
  symmetry.
  split.
  all: intros H.
  now f_equiv.
  split.
  1: rewrite <- (merge_in1 f g).
  2: rewrite <- (merge_in2 f g).
  all: rewrite H.
  apply merge_in1.
  apply merge_in2.
Qed.

Definition fcoprod {a b c d: C} (f: a ~> b) (g: c ~> d): a + c ~> b + d :=
  [in1 ∘ f, in2 ∘ g ].

Infix "(+)" := fcoprod (at level 50, left associativity).

Lemma fcoprod_id (a b: C): id a (+) id b = id (a + b).
Proof.
  symmetry.
  apply merge_in.
  now rewrite !comp_id_l, !comp_id_r.
Qed.

Lemma merge_fcoprod {a a' b b' c} (f: b ~> c) (f': b' ~> c) (g: a ~> b) (g': a' ~> b'): [f, f'] ∘ (g (+) g') = [f ∘ g, f' ∘ g'].
Proof.
  unfold fcoprod.
  rewrite merge_comp.
  f_equal.
  all: rewrite comp_assoc.
  all: f_equal.
  apply merge_in1.
  apply merge_in2.
Qed.

Lemma fcoprod_comp {a a' b b' c c': C} (f: b ~> c) (f': b' ~> c') (g: a ~> b) (g': a' ~> b'): (f ∘ g) (+) (f' ∘ g') = (f (+) f') ∘ (g (+) g').
Proof.
  symmetry.
  unfold fcoprod at 2 3.
  rewrite !comp_assoc.
  apply merge_fcoprod.
Qed.

Lemma fcoprod_inv_l {a b c d: C} (f: a <~> b) (g: c <~> d): (f⁻¹ (+) g⁻¹) ∘ (f (+) g) = id (a + c).
Proof.
  rewrite <- fcoprod_comp, <- fcoprod_id.
  f_equal.
  all: apply inv_l.
Qed.

Lemma fcoprod_inv_r {a b c d: C} (f: a <~> b) (g: c <~> d): (f (+) g) ∘ (f⁻¹ (+) g⁻¹) = id (b + d).
Proof.
  rewrite <- fcoprod_comp, <- fcoprod_id.
  f_equal.
  all: apply inv_r.
Qed.

Definition icoprod {a b c d: C} (f: a <~> b) (g: c <~> d): a + c <~> b + d :=
  Isomorphism.Pack (f (+) g) (Isomorphism.Mixin _ _ _ (f (+) g) (f⁻¹ (+) g⁻¹) (fcoprod_inv_l f g) (fcoprod_inv_r f g)).

Lemma is_iso_fcoprod {a b c d: C} (f: a ~> b) (g: c ~> d): is_iso f -> is_iso g -> is_iso (f (+) g).
Proof.
  intros [f' [Hfl Hfr]] [g' [Hgl Hgr]].
  exists (f' (+) g'); split.
  all: rewrite <- fcoprod_comp, <- fcoprod_id.
  all: now f_equal.
Qed.

Global Instance coprod_iso: Proper (isomorphic C ==> isomorphic C ==> isomorphic C) coprod.
Proof.
  intros x x' [f] y y' [g].
  constructor.
  exact (icoprod f g).
Qed.

Lemma in_is_coproduct (a b: C): is_coproduct a b (a + b) in1 in2.
Proof.
  intros z f g.
  exists [f, g].
  repeat split.
  apply merge_in1.
  apply merge_in2.
  intros h H.
  symmetry.
  now apply merge_in.
Qed.

Lemma coprod_is_coprod_obj (a b: C): is_coprod_obj a b (a + b).
Proof.
  exists in1, in2.
  apply in_is_coproduct.
Qed.

Definition FCoprod: Bifunctor C C C := {|
  bobj a b := a + b;
  bmap a1 a2 b1 b2 f g := f (+) g;
  bmap_id := fcoprod_id;
  bmap_comp a1 a2 a3 b1 b2 b3 f1 f2 g1 g2 := fcoprod_comp f1 g1 f2 g2;
|}.

End Coproduct.

Infix "+" := coprod (at level 50, left associativity).
Infix "(+)" := fcoprod (at level 50, left associativity).
Notation "[ f , g ]" := (merge f g).
Canonical icoprod.

Lemma coproduct_correct C: inhabited (CoprodCategory.mixin_of C) <-> (forall a b: C, ex_coproduct a b).
Proof.
  split.
  + intros [[p merge i1 i2 H]] a b.
    exists (p a b), (i1 a b), (i2 a b).
    intros z f g.
    exists (merge a b z f g); split.
    now apply H.
    intros h Hh.
    symmetry.
    now apply H.
  + intros H.
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [P H].
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [i1 H].
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [i2 H].
    generalize (fun a b z f => proj1 (ex_forall _) (H a b z f)).
    clear H; intros H.
    generalize (fun a b z => proj1 (ex_forall _) (H a b z)).
    clear H; intros H.
    generalize (fun a b => proj1 (ex_forall _) (H a b)).
    clear H; intros H.
    generalize (fun a => proj1 (ex_forall _) (H a)).
    clear H; intros H.
    apply ex_forall in H.
    destruct H as [m H].
    constructor.
    exists P m i1 i2.
    intros a b c f g h.
    specialize (H a b c f g).
    destruct H as [H u].
    split.
    intros Hh.
    now subst h.
    intros Hh.
    symmetry.
    now apply u.
Qed.


Require Import compcert.lib.Coqlib.
Require Import Bvector.
Require Import List.
Require Import compcert.lib.Integers.
Require Import BinNums.
Require Import VST.msl.Axioms.
Require Import fcf.Blist.

Require Import sha.ByteBitRelations.
Require Import sha.hmac_pure_lemmas.
Require Import sha.general_lemmas.
Require Import sha.HMAC_functional_prog.
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_abstract.
Require Import sha.HMAC_equivalence.

(*SHA256-specific Modules*)
Require Import sha.common_lemmas.
Require Import sha.HMAC256_functional_prog.
Require Import sha.sha_padding_lemmas.
Require Import sha.ShaInstantiation.
Require Import sha.hmac_common_lemmas.
Require Import sha.HMAC256_spec_pad.
Require Import sha.HMAC256_spec_concat.
Require Import sha.HMAC256_spec_list. (*for toBlocks*)

(*
Lemma of_length_proof_irrel {A:Set} n (l: list A) M:
      Vector.to_list (@of_list_length _ n l M) = l.
Proof. destruct M. apply Vector.to_list_of_list_opp. Qed.
*)
(*Section EQUIV.*)
(*Definition h_v (iv:Bvector c) (blk:Bvector b): Bvector c :=
  of_list_length _
   (sha_h_length _ _ (VectorToList_length _ iv) (VectorToList_length _ blk)).

Lemma h_eq : forall (block_v : Bvector b) (block_l : Blist)
               (HVL: block_l = Vector.to_list block_v)
               ivA ivB (IV: ivA = Vector.to_list ivB),
               sha_h ivA block_l = Vector.to_list (h_v ivB block_v).
Proof. intros. unfold h_v, of_list_length.
  destruct (sha_h_length (Vector.to_list ivB) (Vector.to_list block_v)
      (VectorToList_length c ivB) (VectorToList_length b block_v)).
  symmetry. subst. apply Vector.to_list_of_list_opp.
Qed.
*)

Definition iv_v : Bvector c := Vector.of_list sha_iv.

Lemma iv_eq : sha_iv = Vector.to_list iv_v.
Proof. unfold iv_v.
  rewrite <- Vector.to_list_of_list_opp.
  reflexivity.
Qed.
(*
Lemma opad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Opad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition opad_v: Bvector b := of_list_length _ opad_length.

Lemma ipad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Ipad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition ipad_v: Bvector b := of_list_length _ ipad_length.
*)
Lemma fpad_length (v:Bvector c): length (fpad (Vector.to_list v)) = p.
Proof. unfold fpad, fpad_inner. rewrite bytesToBits_len.
  repeat rewrite app_length. rewrite length_list_repeat, length_intlist_to_Zlist.
  rewrite (mult_comm 4), plus_comm, Zlength_correct.
  rewrite bitsToBytes_len_gen with (n:=32%nat).
    reflexivity.
    apply VectorToList_length.
Qed.

Definition fpad_v (v:Bvector c): Bvector p := of_list_length _ (fpad_length v).

Lemma fpad_eq : forall (v : Bvector c) (l : Blist),
                  l = Vector.to_list v ->
                  fpad l = Vector.to_list (fpad_v v).
Proof. intros. unfold fpad_v, of_list_length.
  destruct (fpad_length v).
  rewrite Vector.to_list_of_list_opp.
  subst; reflexivity.
Qed.

Fixpoint splitAndPad_aux (m:list Blist) (M: Forall (fun x => length x = 512%nat) m):
           list (Bvector b) :=
(match m as l return (Forall (fun x => length x = 512%nat) l) -> list (Bvector b) with
  nil => fun F => nil
|  cons h t => fun F => cons (of_list_length h (Forall_inv F))
                    (splitAndPad_aux t (Forall_tl _ _ _ _ F))
 end) M.

Lemma splitAndPad_aux_consD h t M:
      splitAndPad_aux (cons h t) M
      = (of_list_length h (Forall_inv M))
         :: (splitAndPad_aux t (Forall_tl _ _ _ _ M)).
Proof. reflexivity. Qed.

Lemma splitAndPad_aux_nil m M: m=nil -> splitAndPad_aux m M= nil.
Proof. intros; subst. reflexivity. Qed.

Lemma length_splitandpad_inner_aux: forall ssm pf,
  Forall2
  (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
  (splitAndPad_aux (toBlocks ssm) pf)
  (toBlocks ssm).
Proof.
  intros ssm. remember (toBlocks ssm). generalize dependent ssm.
  induction l.
  { simpl; intros. constructor. }
  { intros. rewrite toBlocks_equation in Heql.
    destruct ssm. discriminate.
    remember ( Compare_dec.leb (length (b :: ssm)) 511) as d.
    destruct d. exfalso.
           rewrite Heql in pf. apply Forall_inv in pf.  clear Heql.
           rewrite firstn_length in pf.
           symmetry in Heqd. apply leb_complete in Heqd.
           eapply NPeano.Nat.min_l_iff in pf. omega.
    rewrite splitAndPad_aux_consD.
    constructor.
      rewrite of_length_proof_irrel. trivial.
    eapply (IHl (skipn 512 (b :: ssm))).
      remember (firstn 512 (b :: ssm)) as zz.
      remember (toBlocks (skipn 512 (b :: ssm))) as yy.
      clear - Heql. inversion Heql. trivial. }
Qed.

Definition splitAndPad_v (m: Blist): list (Bvector b).
  apply (splitAndPad_aux (sha_splitandpad_blocks m)).
  apply InBlocks_Forall_512. apply sha_splitandpad_inc_InBlocks.
Defined.

Lemma splitAndPad_nil: exists pf,
  splitAndPad_v nil =
  cons (@of_list_length bool 512 (sha_splitandpad_inc nil) pf) nil.
Proof. unfold splitAndPad_v, sha_splitandpad_blocks.
  remember (InBlocks_Forall_512 _ (sha_splitandpad_inc_InBlocks nil)). clear Heqf.
  remember (toBlocks (sha_splitandpad_inc nil)).
  rewrite toBlocks_equation in Heql.
  remember (sha_splitandpad_inc nil) as m.
  destruct m. exfalso. clear Heql f l.
    unfold sha_splitandpad_inc in Heqm.
    assert (@length bool nil = length (bytesToBits (pad_inc (bitsToBytes nil)))).
      rewrite <- Heqm; trivial.
    simpl in H; clear Heqm. omega.
  rewrite leb_correct_conv in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite sublist.firstn_same in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite skipn_short in Heql.
    2: rewrite Heqm; simpl; omega.
  rewrite toBlocks_equation in Heql. subst l.
  simpl. eexists. reflexivity.
Qed.

Lemma length_splitandpad_inner m :
   Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (sha_splitandpad_blocks m).
Proof. apply length_splitandpad_inner_aux. Qed.

Lemma C: NPeano.Nat.divide 8 c.
  exists 32%nat. reflexivity.
Qed.

Module EQ256 <: EQUIV_Inst SHA256.
  Definition c := c.
  Definition C := C.
  Definition p := p.
  Definition b := b.
  Definition B := B.
  Definition BS: (SHA256.BlockSize * 8)%nat = b. reflexivity. Qed.
  Definition h := sha_h.
  Definition h_length := sha_h_length.
(*  Definition h_v := h_v.
  Definition h_eq := h_eq.*)
  Definition ir: list int := SHA256.init_registers.
(*  Definition iv:= sha_iv.*)
  Lemma iv_length: length (HMAC_spec_pad.convert ir) = c.
     apply sha_iv_length. Qed.
  (*Definition iv_length := sha_iv_length.*)
  Definition iv_v: Bvector c := iv_v. (*of_list_length _ iv_length.*)
  Lemma iv_eq: HMAC_spec_pad.convert ir  = Vector.to_list iv_v.
  Proof. reflexivity. Qed.
  (*
  Definition ipd:Z := 54.
  Definition opd:Z:=92.
  Lemma isbyteZ_Ipad: isbyteZ ipd.
    unfold ipd. split; omega. Qed.
  Lemma isbyteZ_Opad: isbyteZ opd.
    unfold opd. split; omega. Qed.*)
  Definition fpad_v := fpad_v.
  Definition fpad := fpad.
  Definition fpad_length msg: length msg = c -> length (fpad msg) = p.
  Proof. apply ShaInstantiation.fpad_length. Qed.
  Definition fpad_eq := fpad_eq.
  Definition splitAndPad := sha_splitandpad.
  Definition splitAndPad_v := splitAndPad_v.
  Definition splitandpad_blocks := sha_splitandpad_blocks.
  Definition sap_fpad:=sha_splitandpad_fpad.
  Definition shasplitandpad_blocks_b:= sha_splitandpad_blocks_512.
  Definition sap' m := concat (splitandpad_blocks m).
  Definition sap_app:forall (l m : Blist),
                         length l = b ->
                         splitAndPad (l ++ m) = l ++ sap' m.
  Proof. intros. rewrite sha_splitandpad_app; trivial.
    f_equal. unfold sap', splitandpad_blocks, sha_splitandpad_blocks.
    rewrite concat_toBlocks_id; trivial.
    apply sha_splitandpad_inc_InBlocks.
  Qed.
  Lemma sap'_InBlocks m: InBlocks b (sap' m).
    apply concat_InBlocks. apply sha_splitandpad_blocks_512. Qed.
  Definition hashblock : list int -> list int -> list int := SHA256.hash_block.
  Lemma HHB : h =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))).
    reflexivity. Qed.

  Definition hashblocks: list int -> list int -> list int:= SHA256.hash_blocks.
  Definition d := 16%nat.

  Definition HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end := SHA256.hash_blocks_equation.
  Lemma D: (d * 32)%nat = b. reflexivity. Qed.

  Definition gap:list Z -> list int := SHA256.generate_and_pad.
  Lemma GAP: forall bits, NPeano.Nat.divide d (length (gap (bitsToBytes bits))).
    intros. rewrite <- pad_compose_equal. apply gap_divide16. Qed.

  Lemma sap_gap: splitAndPad = fun bits => bytesToBits (intlist_to_Zlist (gap (bitsToBytes bits))).
  Proof. apply extensionality. intros l. unfold splitAndPad, sha_splitandpad.
    f_equal. rewrite <- pad_compose_equal. unfold generate_and_pad'.
    rewrite pure_lemmas.Zlist_to_intlist_to_Zlist. trivial.
    destruct (pad_len_64_nat (bitsToBytes l)). rewrite Zlength_correct, H. exists (Z.of_nat(x*16)). do 2 rewrite Nat2Z.inj_mul. rewrite Z.mul_comm, <- Z.mul_assoc. reflexivity.
    apply pad_isbyteZ. eapply bitsToBytes_isbyteZ. reflexivity.
  Qed.

  Lemma HASH m: SHA256.Hash m = intlist_to_Zlist (hashblocks ir (gap m)).
     unfold SHA256.Hash.
     rewrite functional_prog.SHA_256'_eq; reflexivity.
  Qed.

  Lemma FOLD_HB_eq: forall l ls, length l = (c + p)%nat ->
     Forall (fun x => length x = (c + p)%nat) ls ->
     fold_left h (l :: ls) (Vector.to_list iv_v) =
          hash_blocks_bits (HMAC_spec_concat.HMAC_Concat.b c p) B h
          (Vector.to_list iv_v) (l ++ concat ls).
  Proof. intros.
     assert (SH: sha_iv = Vector.to_list iv_v). rewrite <- iv_eq; trivial.
     rewrite <- SH; apply (fold_hash_blocks_eq _ _ H H0).
  Qed.

  Lemma length_splitandpad_inner m:
    Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (splitandpad_blocks m).
  Proof. apply length_splitandpad_inner. Qed.

End EQ256.

Module EQ := HMAC_Equiv SHA256 EQ256.

(* Note we're comparing to HP.HMAC_SHA256.HmacCore, not HMAC. *)
Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.Nat.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC EQ.h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v EQ.opad_v EQ.ipad_v kv m) =
      bytesToBits (HMAC_SHA256.HmacCore (Byte.repr EQ.ipd) (Byte.repr EQ.opd)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  specialize (EQ.Equivalence _ HP kv m); intros.
  unfold EQ.h_v in H.
  unfold EQ256.c, EQ256.p, EQ256.splitAndPad_v in H.
  unfold EQ256.fpad_v in H.
  unfold EQ256.b in H. apply H.
Qed.

(* Earlier explicit proof:
Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v opad_v ipad_v kv m) =
      bytesToBits (HP.HMAC_SHA256.HmacCore (Integers.Byte.repr 54) (Integers.Byte.repr 92)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  assert (LK : length (Vector.to_list kv) = b).
    { apply VectorToList_length. }
  erewrite <- HMAC_Abstract.HMAC_abstract_list; try reflexivity.
  2: apply h_eq.
  2: apply fpad_eq.
  2: apply length_splitandpad_inner.
  erewrite HMAC256_spec_list.HMAC_list_concat_sap_instantiated. (*; trivial.*)
SearchAbout sha_splitandpad_inc.
(*sap' to be instantiated to sha_splitandpad_inc*)
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply fold_hash_blocks_eq.
  2: apply LK.
(*  rewrite <- sha_splitandpad_inc_eq.*)
  rewrite <- HMAC256_spec_concat.HMAC_concat_pad_sap_instantiated; trivial.
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  eapply HMAC256_spec_pad.HMAC_pad_concrete'.

  split; omega.
  split; omega.

  (* key length *)
  { rewrite map_length, bitsToBytes_len_gen with (n:=64%nat).
    reflexivity.
    rewrite LK; reflexivity. }

  (* key length *)
  { rewrite Zlength_map, bitsToBytes_len. reflexivity. apply LK. }

  (* TODO: maybe replace bytes_bits_lists with bytesToBits? Since bytes_bits_comp_ind
     is used a lot *)

  (* key *)
  { rewrite map_unsigned_Brepr_isbyte.
      apply bytes_bits_comp_ind.
      eapply bitsToBytes_isbyteZ; reflexivity.
      rewrite  bits_bytes_bits_id; trivial.
      apply block_8. assumption.
      eapply bitsToBytes_isbyteZ. reflexivity. }

  (* uses fact that message is in blocks of 8 *)
  { apply bytes_bits_comp_ind.
    eapply bitsToBytes_isbyteZ; reflexivity.
    rewrite bits_bytes_bits_id; trivial.
    apply InBlocks_len.
    apply HP. destruct m. simpl; trivial. }

  (* opad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Opad. omega.
    apply of_length_proof_irrel. }

  (* ipad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Ipad. omega.
    apply of_length_proof_irrel. }

Qed.
End EQUIV. *)


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Coq.omega.Omega.
Require Import Rsequence_def.
Require Import Rsequence_base_facts.
Require Import Max Rinterval MyRIneq Ranalysis_def Lra.

Open Scope R_scope.
Open Scope Rseq_scope.

(** printing ~	~ *)
(** * Convergence compatibility. *)

Section Rseq_cv.

(**********)
Lemma Rseq_cv_bound :
  forall Un lu, Rseq_cv Un lu -> exists M, 0 < M /\ Rseq_bound Un M.
Proof.
intros Un lu Hu.
destruct (Hu 1) as [N HN]; [lra|].
destruct (Rseq_partial_bound Un N) as [M HM].
exists (Rmax (1 + (Rabs lu))%R M).
split.
eapply Rlt_le_trans; [|apply RmaxLess1].
apply Rplus_lt_le_0_compat; [lra|apply Rabs_pos].
intros n.
destruct (le_ge_dec n N) as [He|He].
eapply Rle_trans; [apply HM; assumption|apply RmaxLess2].
eapply Rle_trans; [|apply RmaxLess1].
replace (Un n) with ((Un n - lu) + lu)%R by field.
eapply Rle_trans; [apply Rabs_triang|].
apply Rplus_le_compat.
left; apply HN; assumption.
apply Rle_refl.
Qed.

(**********)
Lemma Rseq_constant_cv : forall r, Rseq_cv (Rseq_constant r) r.
intros r eps Heps; exists O; intros n Hn.
unfold R_dist; unfold Rseq_constant.
replace (r - r)%R with 0 by ring.
rewrite Rabs_R0; apply Heps.
Qed.

(**********)
Lemma Rseq_cv_plus_compat :
  forall Un Vn lu lv,
    Rseq_cv Un lu -> Rseq_cv Vn lv -> Rseq_cv (Un + Vn) (lu + lv).
Proof.
intros Un Vn lu lv Hu Hv eps Heps.
destruct (Hu (eps/2)%R) as [Nu HNu]; [lra|].
destruct (Hv (eps/2)%R) as [Nv HNv]; [lra|].
exists (Max.max Nu Nv).
intros n Hn.
unfold R_dist; unfold Rseq_plus.
replace (Un n + Vn n - (lu + lv))%R
  with ((Un n - lu) + (Vn n - lv))%R by field.
eapply Rle_lt_trans; [apply Rabs_triang|].
replace eps with (eps/2 + eps/2)%R by field.
apply Rplus_lt_compat.
apply (HNu n); eapply le_trans; [apply Max.le_max_l|eexact Hn].
apply (HNv n); eapply le_trans; [apply Max.le_max_r|eexact Hn].
Qed.

(**********)
Lemma Rseq_cv_opp_compat :
  forall Un lu, Rseq_cv Un lu -> Rseq_cv (- Un) (- lu).
Proof.
intros Un lu Hu eps Heps.
destruct (Hu eps) as [Nu HNu]; [assumption|].
exists Nu; intros n Hn.
unfold R_dist; unfold Rseq_opp.
replace (- Un n - - lu)%R with (- (Un n - lu))%R by field.
rewrite Rabs_Ropp.
apply HNu; exact Hn.
Qed.

(**********)
Lemma Rseq_cv_mult_compat :
  forall Un Vn lu lv,
    Rseq_cv Un lu -> Rseq_cv Vn lv -> Rseq_cv (Un * Vn) (lu * lv).
Proof.
intros Un Vn lu lv Hu Hv eps Heps.
destruct (Rseq_cv_bound Un lu) as [Mb [HMb Hb]]; [assumption|].
pose (eps1 := (eps / 2 / (Rmax 1 (Rabs lv)))%R).
pose (eps2 := (eps / 2 / Mb)%R).
assert (Heps1 : eps1 > 0).
unfold eps1; repeat apply Rmult_gt_0_compat; try lra.
apply Rinv_0_lt_compat; eapply Rlt_le_trans; [apply Rlt_0_1|apply RmaxLess1].
assert (Heps2 : eps2 > 0).
unfold eps2; repeat apply Rmult_gt_0_compat; try lra.
apply Rinv_0_lt_compat; assumption.
destruct (Hu eps1) as [Nu HNu]; [assumption|].
destruct (Hv eps2) as [Nv HNv]; [assumption|].
exists (Max.max Nu Nv); intros n Hn.
unfold R_dist; unfold Rseq_mult.
replace (Un n * Vn n - lu * lv)%R
  with ((Un n * Vn n - Un n * lv) + (Un n * lv - lu * lv))%R
  by field.
eapply Rle_lt_trans; [apply Rabs_triang|].
replace eps with (eps / 2 + eps / 2)%R by field.
apply Rplus_lt_compat.
rewrite <- Rmult_minus_distr_l; rewrite Rabs_mult.
eapply Rle_lt_trans.
  apply Rmult_le_compat_r; [apply Rabs_pos|].
  apply Hb.
replace (eps / 2)%R with (Mb * (eps / 2 / Mb))%R
  by (field; apply Rgt_not_eq; assumption).
apply Rmult_lt_compat_l; [assumption|].
apply HNv; eapply le_trans; [apply Max.le_max_r|eexact Hn].
unfold Rminus; rewrite <- Ropp_mult_distr_l_reverse.
rewrite <- Rmult_plus_distr_r.
rewrite Rabs_mult.
destruct (Req_dec lv 0) as [Hlv|Hlv].
  rewrite Hlv; rewrite Rabs_R0; rewrite Rmult_0_r; lra.
  eapply Rlt_le_trans.
  apply Rmult_lt_compat_r; [apply Rabs_pos_lt; assumption|].
  apply HNu; eapply le_trans; [apply Max.le_max_l|eexact Hn].
unfold eps1.
unfold Rdiv; rewrite Rmult_assoc; rewrite <- Rmult_1_r.
apply Rmult_le_compat_l; [lra|].
assert (Hmax : Rmax 1 (Rabs lv) > 0).
eapply Rlt_le_trans with 1; [lra|apply RmaxLess1].
pattern 1 at 2; rewrite <- (Rinv_l (Rmax 1 (Rabs lv))).
  apply Rmult_le_compat_l.
    left; apply Rinv_0_lt_compat; assumption.
    apply RmaxLess2.
apply Rgt_not_eq; assumption.
Qed.

(**********)
Lemma Rseq_cv_pow_compat : forall An d l,
  Rseq_cv An l -> Rseq_cv (fun n => An n ^ d) (l ^ d).
Proof.
intros An d ; revert An ; induction d ; intros An l HAn.
 simpl ; apply Rseq_constant_cv.
 simpl ; apply Rseq_cv_mult_compat ; [| apply IHd] ; assumption.
Qed.

(**********)
Lemma Rseq_cv_inv_compat :
  forall Un lu, Rseq_cv Un lu -> lu <> 0 -> Rseq_cv (/ Un) (/ lu).
Proof.
intros Un lu Hu H eps Heps.
destruct (Hu (Rabs lu / 2))%R as [Ninf Hinf].
apply Rmult_lt_0_compat; [apply Rabs_pos_lt|lra]; assumption.
destruct (Hu (/2 * Rabs lu * Rabs lu * eps))%R as [N HN].
repeat apply Rmult_lt_0_compat; (apply Rabs_pos_lt || lra); assumption.
exists (Max.max Ninf N).
intros n Hn.
unfold R_dist; unfold Rseq_inv.
assert (Habs : Rabs lu / 2 <= Rabs (Un n)).
replace (Rabs lu / 2)%R with
  (Rabs lu - Rabs lu / 2)%R by field.
assert (Hr : Rabs (Un n - lu) < Rabs lu / 2).
apply Hinf; eapply le_trans; [apply Max.le_max_l|eexact Hn].
unfold Rabs; repeat destruct Rcase_abs;
unfold Rabs in Hr; repeat destruct Rcase_abs in Hr; lra.
assert (Hpos : Un n <> 0).
unfold Rabs in Habs; repeat destruct Rcase_abs in Habs;
try (apply Rlt_not_eq || apply Rgt_not_eq; lra).
apply Rgt_not_eq; eapply Rlt_le_trans; [|eexact Habs].
unfold Rdiv; rewrite Ropp_mult_distr_l_reverse; lra.
apply Rgt_not_eq; eapply Rlt_le_trans; [|eexact Habs].
unfold Rdiv; apply Rmult_lt_0_compat; auto with real.
destruct (Rle_lt_or_eq_dec 0 lu); auto with real.
subst; elim H; reflexivity.
replace (/ Un n - / lu)%R with
  (/ lu * / Un n * (lu - Un n))%R by (field; tauto).
repeat rewrite Rabs_mult.
repeat rewrite Rabs_Rinv; try assumption.
rewrite Rabs_minus_sym.
eapply Rlt_le_trans.
apply Rmult_lt_compat_l.
apply Rmult_lt_0_compat; apply Rinv_0_lt_compat;
apply Rabs_pos_lt; assumption.
apply HN; eapply le_trans; [apply Max.le_max_r|eexact Hn].
replace (/ Rabs lu * / Rabs (Un n) * (/2 * Rabs lu * Rabs lu * eps))%R
  with (/ Rabs (Un n) * (/2 * Rabs lu) * eps)%R
  by (field; split; apply Rabs_no_R0; assumption).
rewrite <- Rmult_1_l.
apply Rmult_le_compat_r; auto with real.
eapply Rle_trans.
apply Rmult_le_compat_r.
replace 0%R with (0 * 0)%R by field.
apply Rmult_le_compat; auto with real; apply Rabs_pos.
destruct Habs as [Habs|Habs].
left; apply Rinv_lt_contravar; [|eassumption].
repeat apply Rmult_lt_0_compat; auto with real; apply Rabs_pos_lt; assumption.
rewrite Habs; right; reflexivity.
right; field.
apply Rabs_no_R0; assumption.
Qed.

(**********)
Lemma Rseq_cv_minus_compat : forall Un Vn lu lv,
    Rseq_cv Un lu -> Rseq_cv Vn lv -> Rseq_cv (Un - Vn) (lu - lv).
Proof.
intros Un Vn lu lv Hlu Hlv.
apply Rseq_cv_eq_compat with (Un + (-Vn)).
intros n; reflexivity.
apply Rseq_cv_plus_compat; [apply Hlu|].
apply Rseq_cv_opp_compat; apply Hlv.
Qed.

(**********)
Lemma Rseq_cv_div_compat :
  forall Un Vn lu lv,
    Rseq_cv Un lu -> Rseq_cv Vn lv -> lv <> 0 -> Rseq_cv (Un / Vn) (lu / lv).
Proof.
intros Un Vn lu lv Hu Hv H.
unfold Rseq_div, Rdiv.
apply Rseq_cv_eq_compat with (Un * (/ Vn)).
intros n; reflexivity.
apply Rseq_cv_mult_compat; [apply Hu|].
apply Rseq_cv_inv_compat; [apply Hv|apply H].
Qed.

(**********)
Lemma Rseq_cv_continuity_compat :
  forall Un lu f, Rseq_cv Un lu -> continuity_pt f lu -> Rseq_cv (fun n => f (Un n)) (f lu).
Proof.
intros Un lu f Hu Hf eps Heps.
destruct (Hf eps) as [h [Hh H]]; [assumption|simpl in H].
destruct (Hu h) as [N HN]; [assumption|].
exists N; intros n Hn.
destruct (Req_dec lu (Un n)) as [Heq|Heq].
rewrite Heq; rewrite R_dist_eq; assumption.
apply H; split; [compute; tauto|].
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_cv_continuity_interval_compat : forall Un lu f a b,
  interval a b lu -> (forall n, interval a b (Un n)) ->
  Rseq_cv Un lu -> continuity_interval a b f ->
  Rseq_cv (fun n => f (Un n)) (f lu).
Proof.
intros Un lu f a b lu_in Un_in Hu Hf eps eps_pos.
 destruct (Hf _ lu_in _ eps_pos) as [h [h_pos Hh]] ; simpl in Hh.
 destruct (Hu _ h_pos) as [N HN] ; exists N ; intros n n_lb.
  destruct (Req_dec lu (Un n)) as [Heq | Hneq].
   rewrite Heq, R_dist_eq ; assumption.
   apply Hh ; split ; [apply Un_in | apply HN ; assumption].
Qed.

(**********)
Lemma Rseq_cv_abs_compat : forall (Un : nat -> R) (l : R),
    Rseq_cv Un l -> Rseq_cv (|Un|) (Rabs l).
Proof.
intros Un l Hl eps Heps.
destruct (Hl eps Heps) as [N HN].
exists N.
intros n Hn.
unfold R_dist.
apply Rle_lt_trans with (Rabs (Un n - l)).
apply Rabs_triang_inv2.
apply HN; apply Hn.
Qed.

Lemma Rseq_cv_even_odd_compat : forall (Un : Rseq) (l : R),
  Rseq_cv (fun i => Un (2 * i)%nat) l ->
  Rseq_cv (fun i => Un (S (2 * i))%nat) l ->
  Rseq_cv Un l.
Proof.
intros Un l Heven Hodd eps eps_pos ;
 destruct (Heven _ eps_pos) as [N1 HN1] ;
 destruct (Hodd _ eps_pos) as [N2 HN2] ;
 exists (max (2 * N1) (S (2 * N2))) ; intros n n_lb ;
 destruct (n_modulo_2 n) as [[p Hp] | [p Hp]] ; subst.
  apply HN1 ; assert (H := max_lub_l _ _ _ n_lb) ; omega.
  apply HN2 ; assert (H := max_lub_r _ _ _ n_lb) ; omega.
Qed.

End Rseq_cv.

(** * Infinite convergence compatibility. *)

Section Rseq_cv_infty.

Variable Un Vn : nat -> R.

(**********)
Lemma Rseq_cv_pos_infty_plus_compat :
  Rseq_cv_pos_infty Un -> Rseq_cv_pos_infty Vn ->
    Rseq_cv_pos_infty (Un + Vn).
Proof.
intros Hu Hv M.
destruct (Hu (M / 2)%R) as [Nu HNu].
destruct (Hv (M / 2)%R) as [Nv HNv].
exists (Max.max Nu Nv); intros n Hn.
unfold Rseq_plus.
replace M with (M / 2 + M / 2)%R by field.
apply Rplus_lt_compat.
apply HNu; eapply le_trans; [apply Max.le_max_l|eexact Hn].
apply HNv; eapply le_trans; [apply Max.le_max_r|eexact Hn].
Qed.

(**********)
Lemma Rseq_cv_finite_plus_pos_infty_r : forall l,
  Rseq_cv Un l -> Rseq_cv_pos_infty Vn ->
  Rseq_cv_pos_infty (Un + Vn).
Proof.
intros l Hl Hf m.
destruct (Hl 1 ltac:(lra)) as [N HN].
destruct (Hf (m-(l -1))%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rle_lt_trans with ((l-1)+ (m-(l-1)))%R.
ring_simplify; apply Rle_refl.
apply Rplus_lt_compat.
apply Rminus_lt.
unfold Rminus.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (-1 + 1)%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (- Un n+ l)).
apply RRle_abs.
rewrite Rplus_comm.
fold (Rminus l (Un n)).
fold (R_dist l (Un n)).
rewrite R_dist_sym.
apply HN; omega.
apply HN0; omega.
Qed.

(**********)
Lemma Rseq_cv_finite_plus_pos_infty_l : forall l,
  Rseq_cv_pos_infty Vn -> Rseq_cv Un l ->
  Rseq_cv_pos_infty (Vn + Un).
Proof.
intros l Hf Hl m.
destruct (Hl 1 ltac:(lra)) as [N HN].
destruct (Hf (m-(l -1))%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rle_lt_trans with ((m-(l-1))+ (l-1))%R.
ring_simplify; apply Rle_refl.
apply Rplus_lt_compat.
apply HN0; omega.
apply Rminus_lt.
unfold Rminus.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (-1 + 1)%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (- Un n+ l)).
apply RRle_abs.
rewrite Rplus_comm.
fold (Rminus l (Un n)).
fold (R_dist l (Un n)).
rewrite R_dist_sym.
apply HN; omega.
Qed.

(**********)
Lemma Rseq_cv_pos_pos_infty_mult :
  Rseq_cv_pos_infty Un -> Rseq_cv_pos_infty Vn ->
  Rseq_cv_pos_infty (Un * Vn).
Proof.
intros Hu Hv M.
destruct (Hu (Rabs M)) as [Nu HNu].
destruct (Hv 1) as [Nv HNv].
exists (Max.max Nu Nv); intros n Hn.
unfold Rseq_mult.
apply Rle_lt_trans with (Rabs M).
apply RRle_abs.
replace (Rabs M) with ((Rabs M)*1)%R by apply Rmult_1_r.
apply Rmult_le_0_lt_compat.
apply Rabs_pos.
apply Rle_0_1.
apply HNu; eapply le_trans; [apply Max.le_max_l|eexact Hn].
apply HNv; eapply le_trans; [apply Max.le_max_r|eexact Hn].
Qed.

(**********)
Lemma Rseq_cv_neg_neg_infty_mult :
  Rseq_cv_neg_infty Un -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_pos_infty (Un * Vn).
Proof.
intros Hu Hv M.
destruct (Hu (- (Rabs M))%R) as [Nu HNu].
destruct (Hv (-1)) as [Nv HNv].
exists (Max.max Nu Nv); intros n Hn.
unfold Rseq_mult.
apply Rle_lt_trans with (Rabs M).
apply RRle_abs.
replace (Un n * Vn n)%R with ((- Un n) *( - Vn n))%R by ring.
replace (Rabs M)%R with (( - -Rabs M) *( - - 1))%R by ring.
apply Rmult_le_0_lt_compat.
rewrite Ropp_involutive; apply Rabs_pos.
lra.
apply Ropp_lt_contravar; apply HNu; eapply le_trans; [apply Max.le_max_l|eexact Hn].
apply Ropp_lt_contravar; apply HNv; eapply le_trans; [apply Max.le_max_r|eexact Hn].
Qed.

(**********)
Lemma Rseq_cv_pos_neg_infty_mult :
  Rseq_cv_pos_infty Un -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_neg_infty (Un * Vn).
Proof.
intros Hu Hv M.
destruct (Hu (Rabs M)%R) as [Nu HNu].
destruct (Hv (-1)) as [Nv HNv].
exists (Max.max Nu Nv); intros n Hn.
unfold Rseq_mult.
apply Rlt_le_trans with (- Rabs M)%R.
replace (Un n * Vn n)%R with (-(Un n * (- Vn n)))%R by ring.
apply Ropp_lt_contravar.
replace (Rabs M)%R with ((Rabs M) * (- - 1))%R by ring.
apply Rmult_le_0_lt_compat.
apply Rabs_pos.
lra.
apply HNu; eapply le_trans; [apply Max.le_max_l|eexact Hn].
apply Ropp_lt_contravar; apply HNv; eapply le_trans; [apply Max.le_max_r|eexact Hn].
replace M with (- -M)%R by ring; apply Ropp_le_contravar; rewrite Ropp_involutive.
rewrite <- Rabs_Ropp.
apply RRle_abs.
Qed.

Lemma Rseq_cv_neg_pos_infty_mult :
  Rseq_cv_pos_infty Un -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_neg_infty (Vn * Un).
Proof.
intros Hu Hv M.
destruct (Rseq_cv_pos_neg_infty_mult Hu Hv M) as [N HN].
exists N; intros n Hn.
unfold Rseq_mult; rewrite Rmult_comm.
apply HN; apply Hn.
Qed.

(**********)
Lemma Rseq_cv_finite_plus_neg_infty_r : forall l,
  Rseq_cv Un l -> Rseq_cv_neg_infty Vn ->
  Rseq_cv_neg_infty (Un + Vn).
Proof.
intros l Hl Hf M.
destruct (Hl 1 ltac:(lra)) as [N HN].
destruct (Hf (M-(l +1))%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rlt_le_trans with ((l+1)+ (M-(l+1)))%R.
apply Rplus_lt_compat.
apply Rminus_lt.
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (-1 + 1)%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
apply RRle_abs.
apply HN; omega.
apply HN0; omega.
ring_simplify; apply Rle_refl.
Qed.

(**********)
Lemma Rseq_cv_finite_plus_neg_infty_l : forall l,
  Rseq_cv_neg_infty Vn -> Rseq_cv Un l ->
  Rseq_cv_neg_infty (Vn + Un).
Proof.
intros l Hf Hl M.
destruct (Hl 1 ltac:(lra)) as [N HN].
destruct (Hf (M-(l +1))%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rlt_le_trans with ((M-(l+1)) +(l+1))%R.
apply Rplus_lt_compat.
apply HN0; omega.
apply Rminus_lt.
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (-1 + 1)%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
apply RRle_abs.
apply HN; omega.
ring_simplify; apply Rle_refl.
Qed.

(**********)
Lemma Rseq_cv_finite_minus_neg_infty : forall l,
  Rseq_cv Un l -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_pos_infty (Un - Vn).
Proof.
intros l Hl Hf M.
destruct (Hl 1 ltac:(lra)) as [N HN].
destruct (Hf (-M+(l -1))%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rle_lt_trans with ((l-1)+ -(-M+(l -1)))%R.
ring_simplify; apply Rle_refl.
apply Rplus_lt_compat.
apply Rminus_lt.
unfold Rminus.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (-1 + 1)%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (- Un n+ l)).
apply RRle_abs.
rewrite Rplus_comm.
fold (Rminus l (Un n)).
fold (R_dist l (Un n)).
rewrite R_dist_sym.
apply HN; omega.
apply Ropp_gt_lt_contravar.
apply HN0; omega.
Qed.

(**********)
Lemma Rseq_cv_finite_minus_pos_infty : forall l,
  Rseq_cv Un l -> Rseq_cv_pos_infty Vn ->
    Rseq_cv_neg_infty (Un - Vn).
Proof.
intros l Hl Hf M.
destruct (Hl 1 ltac:(lra)) as [N HN].
destruct (Hf ((l +1)+ -M)%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rlt_le_trans with ((l+1)+ -((l +1)+-M))%R.
apply Rplus_lt_compat.
apply Rminus_lt.
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (-1 + 1)%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
apply RRle_abs.
apply HN; omega.
apply Ropp_gt_lt_contravar.
apply HN0; omega.
ring_simplify; apply Rle_refl.
Qed.

(**********)
Lemma Rseq_cv_pos_minus_neg_infty :
  Rseq_cv_pos_infty Un -> Rseq_cv_neg_infty Vn -> Rseq_cv_pos_infty (Un - Vn).
Proof.
intros Hl Hf M.
destruct (Hl M) as [N HN].
destruct (Hf 0%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rle_lt_trans with (M+-0)%R.
ring_simplify; apply Rle_refl.
apply Rplus_lt_compat.
apply HN; omega.
apply Ropp_gt_lt_contravar.
apply HN0; omega.
Qed.

(**********)
Lemma Rseq_cv_neg_minus_pos_infty :
  Rseq_cv_neg_infty Un -> Rseq_cv_pos_infty Vn -> Rseq_cv_neg_infty (Un - Vn).
Proof.
intros Hl Hf M.
destruct (Hl M) as [N HN].
destruct (Hf 0%R) as [N0 HN0].
exists (N+N0)%nat.
intros n Hn.
apply Rlt_le_trans with (M+-0)%R.
apply Rplus_lt_compat.
apply HN; omega.
apply Ropp_gt_lt_contravar.
apply HN0; omega.
ring_simplify; apply Rle_refl.
Qed.

(**********)
Lemma Rseq_cv_finite_pos_mult_pos_infty_r : forall l,
  0 < l -> Rseq_cv Un l -> Rseq_cv_pos_infty Vn ->
    Rseq_cv_pos_infty (Un * Vn).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (l*/2)%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv ((Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rle_lt_trans with ((l*/2)*((Rabs M)*(2*/l)))%R.
replace ((l*/2)*((Rabs M)*(2*/l)))%R with (Rabs M).
apply RRle_abs.
field.
apply Rgt_not_eq; exact Hl.
apply Rmult_le_0_lt_compat.
repeat apply Rmult_gt_0_compat; try lra.
replace 0%R with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
repeat apply Rmult_gt_0_compat; try lra.
apply Rinv_0_lt_compat.
exact Hl.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
rewrite <- Rabs_Ropp.
rewrite Ropp_plus_distr, Ropp_involutive.
apply RRle_abs.
apply HN; omega.
rewrite (Rmult_comm 2 (/l)).
apply HN0; omega.
Qed.

(**********)
Lemma Rseq_cv_finite_neg_mult_pos_infty_r : forall l,
  l < 0 -> Rseq_cv Un l -> Rseq_cv_pos_infty Vn ->
    Rseq_cv_neg_infty (Un * Vn).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (-(l*/2))%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv (-(Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rlt_le_trans with ((l*/2)*(-(Rabs M)*(2*/l)))%R.
replace ((Un * Vn)%Rseq n) with (Un n * Vn n)%R by reflexivity.
apply Ropp_lt_cancel.
rewrite <- Ropp_mult_distr_l_reverse, <- (Ropp_mult_distr_l_reverse (Un n) (Vn n)).
apply Rmult_le_0_lt_compat.
repeat apply Rmult_gt_0_compat; try lra.
replace (-(Rabs M)*(2*/l))%R with ((Rabs M)*(- 2*/l))%R by ring.
replace (IZR 0) with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
Set Printing All.
change (IZR (-2)) with (- (IZR 2))%R.
rewrite Ropp_mult_distr_l_reverse, <- Ropp_mult_distr_r_reverse.
repeat apply Rmult_gt_0_compat; try lra.
apply Ropp_0_gt_lt_contravar.
apply Rinv_lt_0_compat.
exact Hl.
apply Ropp_gt_lt_contravar.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Ropp_plus_distr, Ropp_involutive, <- Rplus_assoc.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_r.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
apply RRle_abs.
apply HN; omega.
rewrite (Rmult_comm 2 (/l)).
apply HN0; omega.
replace (l * /2 * (- Rabs M *(2 * /l)))%R with (- Rabs M)%R.
rewrite <- (Ropp_involutive M).
apply Ropp_ge_le_contravar.
rewrite Rabs_Ropp.
apply Rle_ge.
apply RRle_abs.
field.
apply Rlt_not_eq.
exact Hl.
Qed.

(**********)
Lemma Rseq_cv_finite_pos_mult_neg_infty_r : forall l,
  0 < l -> Rseq_cv Un l -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_neg_infty (Un * Vn).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (l*/2)%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv (-(Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rlt_le_trans with ((l*/2)*(-(Rabs M)*(2*/l)))%R.
replace ((Un * Vn)%Rseq n)%R with (Un n * Vn n)%R by reflexivity.
apply Ropp_lt_cancel.
replace (- (l */2  *(- Rabs M * (2 * /l))))%R
    with (l */2  *( Rabs M * (2 * /l)))%R by ring.
rewrite <- (Ropp_mult_distr_r_reverse (Un n) (Vn n)).
apply Rmult_le_0_lt_compat.
repeat apply Rmult_gt_0_compat; try lra.
replace 0%R with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
repeat apply Rmult_gt_0_compat; try lra.
apply Rinv_0_lt_compat.
exact Hl.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Rplus_comm, <- Rplus_assoc, Rplus_comm.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
rewrite <- Rabs_Ropp, Ropp_plus_distr, Ropp_involutive.
apply RRle_abs.
apply HN; omega.
apply Ropp_lt_cancel.
rewrite (Rmult_comm 2 (/l)), <- Ropp_mult_distr_l_reverse, Ropp_involutive.
apply HN0; omega.
replace (l * /2 * (- Rabs M *(2 * /l)))%R with (- Rabs M)%R.
rewrite <- (Ropp_involutive M).
apply Ropp_ge_le_contravar.
rewrite Rabs_Ropp.
apply Rle_ge.
apply RRle_abs.
field.
apply Rgt_not_eq.
exact Hl.
Qed.

(**********)
Lemma Rseq_cv_finite_neg_mult_neg_infty_r : forall l,
  l < 0 -> Rseq_cv Un l -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_pos_infty (Un * Vn).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (-(l*/2))%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv ((Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rle_lt_trans with (-(l*/2)*(-(Rabs M)*(2*/l)))%R.
replace (-(l*/2)*(-(Rabs M)*(2*/l)))%R with (Rabs M).
apply RRle_abs.
field.
apply Rlt_not_eq.
exact Hl.
replace ((Un * Vn)%Rseq n) with (Un n * Vn n)%R by reflexivity.
replace (Un n * Vn n)%R with ((- Un n) * (- Vn n))%R by ring.
apply Rmult_le_0_lt_compat.
repeat apply Rmult_gt_0_compat; try lra.
replace (-(Rabs M)*(2*/l))%R with ((Rabs M)*(- 2*/l))%R by ring.
replace 0%R with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
change (IZR (-2)) with (- (IZR 2))%R.
rewrite Ropp_mult_distr_l_reverse, <- Ropp_mult_distr_r_reverse.
repeat apply Rmult_gt_0_compat; try lra.
apply Ropp_0_gt_lt_contravar.
apply Rinv_lt_0_compat.
exact Hl.
apply Ropp_lt_contravar.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Ropp_plus_distr, Ropp_involutive, <- Rplus_assoc.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_r.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
apply RRle_abs.
apply HN; omega.
rewrite Ropp_mult_distr_l_reverse.
apply Ropp_gt_lt_contravar.
apply Rlt_gt.
rewrite (Rmult_comm 2 (/l)).
apply HN0; omega.
Qed.

(**********)
Lemma Rseq_cv_finite_pos_mult_pos_infty_l : forall l,
  0 < l -> Rseq_cv Un l -> Rseq_cv_pos_infty Vn ->
    Rseq_cv_pos_infty (Vn * Un).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (l*/2)%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv ((Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rle_lt_trans with ((l*/2)*((Rabs M)*(2*/l)))%R.
replace (l */2 * (Rabs M * (2 * /l)))%R with (Rabs M).
apply RRle_abs.
field.
apply Rgt_not_eq.
exact Hl.
replace ((Vn * Un)%Rseq n) with (Vn n * Un n)%R by reflexivity.
rewrite (Rmult_comm (Vn n) (Un n)).
apply Rmult_le_0_lt_compat.
repeat apply Rmult_gt_0_compat; try lra.
replace 0%R with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
repeat apply Rmult_gt_0_compat; try lra.
apply Rinv_0_lt_compat.
exact Hl.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Rplus_comm.
rewrite <- Rplus_assoc.
rewrite Rplus_comm.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
rewrite <- Rabs_Ropp.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
apply RRle_abs.
apply HN; omega.
rewrite (Rmult_comm 2 (/l)).
apply HN0; omega.
Qed.

(**********)
Lemma Rseq_cv_finite_neg_mult_pos_infty_l : forall l,
  l < 0 -> Rseq_cv Un l -> Rseq_cv_pos_infty Vn ->
    Rseq_cv_neg_infty (Vn * Un).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (-(l*/2))%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv (-(Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rlt_le_trans with ((l*/2)*(-(Rabs M)*(2*/l)))%R.
apply Ropp_lt_cancel.
rewrite <- Ropp_mult_distr_l_reverse.
replace ((Vn * Un)%Rseq n) with (Vn n * Un n)%R by reflexivity.
rewrite (Rmult_comm (Vn n) (Un n)).
rewrite <- (Ropp_mult_distr_l_reverse (Un n) (Vn n)).
apply Rmult_le_0_lt_compat.
apply Rlt_le.
repeat apply Rmult_gt_0_compat; try lra.
replace (-(Rabs M)*(2*/l))%R with ((Rabs M)*(- 2*/l))%R by ring.
replace 0%R with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
change (IZR (-2)) with (- (IZR 2))%R.
rewrite Ropp_mult_distr_l_reverse, <- Ropp_mult_distr_r_reverse.
repeat apply Rmult_gt_0_compat; try lra.
apply Ropp_0_gt_lt_contravar.
apply Rinv_lt_0_compat.
exact Hl.
apply Ropp_gt_lt_contravar.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Ropp_plus_distr.
rewrite Ropp_involutive.
rewrite <- Rplus_assoc.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_r.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
apply RRle_abs.
apply HN; omega.
rewrite (Rmult_comm 2 (/l)).
apply HN0; omega.
replace (l * /2 * (- Rabs M *(2 * /l)))%R with (- Rabs M)%R.
rewrite <- (Ropp_involutive M).
apply Ropp_ge_le_contravar.
rewrite Rabs_Ropp.
apply Rle_ge.
apply RRle_abs.
field.
apply Rlt_not_eq.
exact Hl.
Qed.

(**********)
Lemma Rseq_cv_finite_pos_mult_neg_infty_l : forall l,
  0 < l -> Rseq_cv Un l -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_neg_infty (Vn * Un).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (l*/2)%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv (-(Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rlt_le_trans with ((l*/2)*(-(Rabs M)*(2*/l)))%R.
replace ((Vn * Un)%Rseq n) with (Vn n * Un n)%R by reflexivity.
rewrite (Rmult_comm (Vn n) (Un n)).
apply Ropp_lt_cancel.
rewrite <- (Ropp_mult_distr_r_reverse (Un n) (Vn n)).
rewrite <- Ropp_mult_distr_r_reverse, <- Ropp_mult_distr_l_reverse, Ropp_involutive.
replace (- (l * /2 * (- Rabs M * (2 * /l))))%R with (l * /2 * (Rabs M * (2 * /l)))%R by ring.
apply Rmult_le_0_lt_compat.
repeat apply Rmult_gt_0_compat; try lra.
replace 0%R with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
repeat apply Rmult_gt_0_compat; try lra.
apply Rinv_0_lt_compat.
exact Hl.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Rplus_comm, <- Rplus_assoc, Rplus_comm.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_l.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
rewrite <- Rabs_Ropp, Ropp_plus_distr, Ropp_involutive.
apply RRle_abs.
apply HN; omega.
apply Ropp_lt_cancel.
rewrite (Rmult_comm 2 (/l)), <- Ropp_mult_distr_l_reverse, Ropp_involutive.
apply HN0; omega.
replace (l * /2 * (- Rabs M *(2 * /l)))%R with (- Rabs M)%R.
rewrite <- (Ropp_involutive M).
apply Ropp_ge_le_contravar.
rewrite Rabs_Ropp.
apply Rle_ge.
apply RRle_abs.
field.
apply Rgt_not_eq.
exact Hl.
Qed.

(**********)
Lemma Rseq_cv_finite_neg_mult_neg_infty_l : forall l,
  l < 0 -> Rseq_cv Un l -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_pos_infty (Vn * Un).
Proof.
intros l Hl Hu Hv M.
destruct (Hu (-(l*/2))%R) as [N HN].
repeat apply Rmult_gt_0_compat; try lra.
destruct (Hv ((Rabs M)*(/l*2))%R) as [N0 HN0].
exists (N+N0)%nat; intros n Hn.
apply Rle_lt_trans with (-(l*/2)*(-(Rabs M)*(2*/l)))%R.
replace (-(l*/2)*(-(Rabs M)*(2*/l)))%R with (Rabs M)%R.
apply RRle_abs.
field.
apply Rlt_not_eq.
exact Hl.
replace ((Vn * Un)%Rseq n) with (Vn n * Un n)%R by reflexivity.
replace (Vn n * Un n)%R with (-Un n * -Vn n)%R by ring.
apply Rmult_le_0_lt_compat.
repeat apply Rmult_gt_0_compat; try lra.
replace (- Rabs M * (2 * /l))%R with ( Rabs M * (- 2 * /l))%R by ring.
replace 0%R with (Rabs M * 0)%R by field.
apply Rmult_le_compat_l.
apply Rabs_pos.
apply Rlt_le.
change (IZR (-2)) with (- (IZR 2))%R.
rewrite Ropp_mult_distr_l_reverse, <- Ropp_mult_distr_r_reverse.
repeat apply Rmult_gt_0_compat; try lra.
apply Ropp_0_gt_lt_contravar.
apply Rinv_lt_0_compat.
exact Hl.
apply Ropp_gt_lt_contravar.
replace (l * /2)%R with (l - (l * /2))%R by field.
apply Rminus_lt.
unfold Rminus.
rewrite Ropp_plus_distr, Ropp_involutive, <- Rplus_assoc.
replace 0 with (- (l * /2) + (l * /2))%R by ring.
apply Rplus_lt_compat_r.
apply Rle_lt_trans with (Rabs (Un n+ - l)).
apply RRle_abs.
apply HN; omega.
rewrite Ropp_mult_distr_l_reverse.
apply Ropp_gt_lt_contravar.
apply Rlt_gt.
rewrite (Rmult_comm 2 (/l)).
apply HN0; omega.
Qed.

(**********)
Lemma Rseq_cv_neg_infty_plus_compat :
  Rseq_cv_neg_infty Un -> Rseq_cv_neg_infty Vn ->
    Rseq_cv_neg_infty (Un + Vn).
Proof.
intros Hu Hv M.
destruct (Hu (M / 2)%R) as [Nu HNu].
destruct (Hv (M / 2)%R) as [Nv HNv].
exists (Max.max Nu Nv); intros n Hn.
unfold Rseq_plus.
replace M with (M / 2 + M / 2)%R by field.
apply Rplus_lt_compat.
apply HNu; eapply le_trans; [apply Max.le_max_l|eexact Hn].
apply HNv; eapply le_trans; [apply Max.le_max_r|eexact Hn].
Qed.

(**********)
Lemma Rseq_cv_pos_infty_opp_compat : Rseq_cv_pos_infty Un -> Rseq_cv_neg_infty (- Un).
Proof.
intros H M.
destruct (H (- M)%R) as [N HN].
exists N; intros n Hn.
unfold Rseq_opp.
rewrite <- Ropp_involutive.
apply Ropp_gt_lt_contravar.
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_cv_neg_infty_opp_compat : Rseq_cv_neg_infty Un -> Rseq_cv_pos_infty (- Un).
Proof.
intros H M.
destruct (H (- M)%R) as [N HN].
exists N; intros n Hn.
unfold Rseq_opp.
pattern M; rewrite <- Ropp_involutive.
apply Ropp_lt_gt_contravar.
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_cv_pos_infty_inv_compat : Rseq_cv_pos_infty Un -> Rseq_cv (/ Un) 0.
Proof.
intros H eps Heps.
destruct (H (/eps)%R) as [N HN].
exists N; intros n Hn.
assert (Hpos : Un n > 0).
eapply Rlt_trans; [|apply HN; assumption].
apply Rinv_0_lt_compat; assumption.
unfold R_dist; unfold Rseq_inv.
replace (/Un n - 0)%R with (/ Un n)%R; [|field; auto with real].
rewrite <- Rinv_involutive; [|apply Rgt_not_eq; assumption].
rewrite Rabs_Rinv; [|auto with real].
apply Rinv_lt_contravar.
apply Rmult_gt_0_compat.
apply Rinv_0_lt_compat; assumption.
rewrite Rabs_right; [|left]; assumption.
rewrite Rabs_right; [apply HN|left]; assumption.
Qed.

(**********)
Lemma Rseq_cv_pos_infty_div_compat : forall l,
    Rseq_cv_pos_infty Un -> Rseq_cv Vn l -> Rseq_cv (Vn / Un) 0.
Proof.
intros l HU HV.
assert (H : Rseq_cv (Vn*(/Un)) 0).
rewrite <- Rmult_0_r with l.
apply Rseq_cv_mult_compat.
apply HV.
apply Rseq_cv_pos_infty_inv_compat; apply HU.
unfold Rseq_mult in H.
unfold Rseq_div, Rdiv.
apply H.
Qed.

(**********)
Lemma Rseq_cv_neg_infty_inv_compat : Rseq_cv_neg_infty Un -> Rseq_cv (/ Un) 0.
intros H eps Heps.
destruct (H (-/eps)%R) as [N HN].
exists N; intros n Hn.
assert (Hpos : Un n < 0).
eapply Rlt_trans; [apply HN; assumption|].
apply Ropp_lt_gt_0_contravar; apply Rinv_0_lt_compat; assumption.
unfold R_dist; unfold Rseq_inv.
replace (/ Un n - 0)%R with (/ Un n)%R; [|field; auto with real].
rewrite <- Rinv_involutive; [|apply Rgt_not_eq; assumption].
rewrite Rabs_Rinv; [|auto with real].
apply Rinv_lt_contravar.
apply Rmult_gt_0_compat.
apply Rinv_0_lt_compat; assumption.
apply Rabs_pos_lt; apply Rlt_not_eq; assumption.
rewrite Rabs_left; [|assumption].
pattern (/ eps)%R; rewrite <- Ropp_involutive.
apply Ropp_gt_lt_contravar.
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_cv_neg_infty_div_compat : forall l,
    Rseq_cv_neg_infty Un -> Rseq_cv Vn l -> Rseq_cv (Vn / Un) 0.
Proof.
intros l HU HV.
assert (H : Rseq_cv (Vn*(/Un)) 0).
rewrite <- Rmult_0_r with l.
apply Rseq_cv_mult_compat.
apply HV.
apply Rseq_cv_neg_infty_inv_compat; apply HU.
unfold Rseq_mult in H.
unfold Rseq_div, Rdiv.
apply H.
Qed.

(**********)
Lemma Rseq_cv_0_inv_compat :
  Rseq_cv Un 0 -> Rseq_neq_0 Un ->
    Rseq_cv_pos_infty (|/ Un|).
Proof.
intros Hcv He M.
pose (Mp := Rmax 1 M).
assert (Hp : Mp > 0).
eapply Rlt_le_trans; [apply Rlt_0_1|apply RmaxLess1].
destruct (Hcv (/ Mp)%R) as [N HN].
apply Rinv_0_lt_compat; assumption.
exists N; intros n Hn.
apply Rle_lt_trans with Mp; [apply RmaxLess2|].
pattern Mp; rewrite <- Rinv_involutive; [|auto with real].
assert (Hd : Un n <> 0).
apply He.
unfold Rseq_abs, Rseq_inv.
rewrite Rabs_Rinv; [|assumption].
apply Rinv_lt_contravar.
apply Rmult_lt_0_compat; [|auto with real].
apply Rabs_pos_lt; assumption.
replace (Un n) with (Un n - 0)%R by field.
apply HN; assumption.
Qed.

(**********)
Lemma Rseq_cv_abs_pos_infty : Rseq_cv_pos_infty Un -> Rseq_cv_pos_infty (|Un|).
Proof.
intros HU M.
destruct (HU (Rabs M)) as [N HN].
exists N.
intros n Hn.
apply Rle_lt_trans with (Rabs M).
apply RRle_abs.
apply Rlt_le_trans with (Un n).
apply (HN _ Hn).
apply RRle_abs.
Qed.

(**********)
Lemma Rseq_cv_abs_neg_infty : Rseq_cv_neg_infty Un -> Rseq_cv_pos_infty (|Un|).
Proof.
intros HU M.
assert (H : Rseq_cv_pos_infty (-Un)).
apply Rseq_cv_neg_infty_opp_compat.
apply HU.
destruct (H (Rabs M)) as [N HN].
exists N.
intros n Hn.
apply Rle_lt_trans with (Rabs M).
apply RRle_abs.
apply Rlt_le_trans with (- (Un n))%R.
apply (HN _ Hn).
unfold Rseq_abs.
rewrite <- Rabs_Ropp.
apply RRle_abs.
Qed.

End Rseq_cv_infty.

Section Rseq_cv_others.

(** * Uniqueness of limit. *)

(**********)
Lemma Rseq_cv_unique : forall Un lu1 lu2, Rseq_cv Un lu1 -> Rseq_cv Un lu2 -> lu1 = lu2.
Proof.
intros Un lu1 lu2 H1 H2.
assert (H: forall eps, eps > 0 -> Rabs (lu1 - lu2) <= eps).
  intros eps Heps.
  destruct (H1 (eps / 2)%R) as [N1 HN1]; [lra|].
  destruct (H2 (eps / 2)%R) as [N2 HN2]; [lra|].
  pose (N := Max.max N1 N2).
  replace (lu1 - lu2)%R
    with ((lu1 - Un N) + (Un N - lu2))%R by field.
  replace eps with (eps / 2 + eps / 2)%R by field.
  eapply Rle_trans; [apply Rabs_triang|].
  apply Rplus_le_compat.
    left; rewrite Rabs_minus_sym; apply HN1; apply Max.le_max_l.
    left; apply HN2; apply Max.le_max_r.
apply Rle_antisym; apply le_epsilon;
intros eps Heps; apply H in Heps;
unfold Rabs in Heps; destruct Rcase_abs; lra.
Qed.

Lemma Rseq_cv_Rseq_cv_pos_infty_incompat : forall An l,
  Rseq_cv An l -> Rseq_cv_pos_infty An -> False.
Proof.
intros An l Hl Hinfty ; destruct (Hl _ Rlt_0_1) as [M HM] ;
 destruct (Hinfty (Rabs l + 1)%R) as [N HN] ;
 apply (Rlt_irrefl (An (max M N))) ; transitivity (Rabs l + 1)%R.
 rewrite <- (Rabs_right (An _)).
 apply Rminus_lt_compat_l_rev, Rle_lt_trans with (R_dist (An (max M N)) l).
  apply Rabs_triang_inv.
  apply HM, le_max_l.
  apply Rle_ge ; transitivity (Rabs l + 1)%R.
   apply Rplus_le_le_0_compat ; [apply Rabs_pos | lra].
   left ; apply HN, le_max_r.
  apply HN, le_max_r.
Qed.

Lemma Rseq_cv_Rseq_cv_neg_infty_incompat : forall An l,
  Rseq_cv An l -> Rseq_cv_neg_infty An -> False.
Proof.
intros ; eapply Rseq_cv_Rseq_cv_pos_infty_incompat.
 eapply Rseq_cv_opp_compat ; eassumption.
 eapply Rseq_cv_neg_infty_opp_compat ; eassumption.
Qed.

(** * Sandwich theorem. *)

(**********)
Lemma Rseq_sandwich_theorem :
  forall Un Vn Wn l,
    (Rseq_cv Un l) -> (Rseq_cv Wn l) -> (forall n, Un n <= Vn n <= Wn n) -> Rseq_cv Vn l.
Proof.
intros Un Vn Wn l Hu Hw H eps Heps.
destruct (Hu eps Heps) as [Nu HNu].
destruct (Hw eps Heps) as [Nw HNw].
exists (Max.max Nu Nw); intros n Hn.
eapply Rle_lt_trans.
  apply RmaxAbs; apply Rplus_le_compat_r; apply (H n).
  unfold Rmax; destruct Rle_dec as [_|_].
  apply HNw; eapply le_trans; [apply Max.le_max_r|eassumption].
  apply HNu; eapply le_trans; [apply Max.le_max_l|eassumption].
Qed.

(** * Limit of (non) negative terms *)

(**********)
Lemma Rseq_positive_limit : forall (An : nat -> R) (a : R),
      (forall n, 0 <= An n) ->
       Rseq_cv An a ->
       0 <= a.
Proof.
intros An a Hpos Ha.
apply Rnot_lt_le; intro Na.
destruct (Ha (Ropp (Rdiv a 2))) as [N HN]; [lra | ].
pose proof (HN N (le_n N)).
generalize dependent H.
unfold R_dist, Rabs.
pose proof Hpos N as Hposn.
destruct (Rcase_abs (An N - a)); intro; lra.
Qed.

(**********)
Lemma Rseq_negative_limit : forall (An : nat -> R) (a : R),
  (forall n, An n <= 0) -> Rseq_cv An a -> a <= 0.
Proof.
intros An a Hneg Ha ; apply Ropp_le_cancel ; rewrite Ropp_0 ;
 eapply Rseq_positive_limit, Rseq_cv_opp_compat, Ha.
 intro n ; apply Ropp_0_ge_le_contravar, Rle_ge, Hneg.
Qed.

(** * Compatibility of Rle and interval with the limit *)

(**********)
Lemma Rseq_limit_comparison: forall (An Bn : nat -> R) (a b : R),
      (forall n, An n <= Bn n) ->
       Rseq_cv An a -> Rseq_cv Bn b ->
       a <= b.
Proof.
intros An Bn a b Hcomp Ha Hb.
assert (0 <= b - a).
 apply Rseq_positive_limit with (fun n => (Bn n - An n)%R).
  intro n; pose proof Hcomp n; lra.
  apply Rseq_cv_minus_compat; auto.
 lra.
Qed.

Lemma Rseq_interval_compat : forall (An : Rseq) (a lb ub : R),
  (forall n, interval lb ub (An n)) -> Rseq_cv An a ->
  interval lb ub a.
Proof.
intros An a lb ub Hcomp Ha ; split ; eapply Rseq_limit_comparison.
 intro ; apply (proj1 (Hcomp n)).
  apply Rseq_constant_cv.
  assumption.
 intro n ; apply (proj2 (Hcomp n)).
  assumption.
  apply Rseq_constant_cv.
Qed.

End Rseq_cv_others.

(* begin hide *)
Hint Resolve Rseq_constant_cv : Rseq.
Hint Resolve Rseq_cv_0_inv_compat : Rseq.
Hint Resolve Rseq_cv_abs_compat: Rseq.
Hint Resolve Rseq_cv_abs_neg_infty : Rseq.
Hint Resolve Rseq_cv_abs_pos_infty : Rseq.
Hint Resolve Rseq_cv_continuity_compat : Rseq.
Hint Resolve Rseq_cv_div_compat : Rseq.
Hint Resolve Rseq_cv_finite_minus_neg_infty : Rseq.
Hint Resolve Rseq_cv_finite_minus_pos_infty : Rseq.
Hint Resolve Rseq_cv_finite_neg_mult_neg_infty_l : Rseq.
Hint Resolve Rseq_cv_finite_neg_mult_neg_infty_r : Rseq.
Hint Resolve Rseq_cv_finite_neg_mult_pos_infty_l : Rseq.
Hint Resolve Rseq_cv_finite_neg_mult_pos_infty_r : Rseq.
Hint Resolve Rseq_cv_finite_plus_neg_infty_l : Rseq.
Hint Resolve Rseq_cv_finite_plus_neg_infty_l: Rseq.
Hint Resolve Rseq_cv_finite_plus_neg_infty_r : Rseq.
Hint Resolve Rseq_cv_finite_plus_neg_infty_r: Rseq.
Hint Resolve Rseq_cv_finite_plus_pos_infty_l : Rseq.
Hint Resolve Rseq_cv_finite_plus_pos_infty_r : Rseq.
Hint Resolve Rseq_cv_finite_pos_mult_neg_infty_l : Rseq.
Hint Resolve Rseq_cv_finite_pos_mult_neg_infty_r : Rseq.
Hint Resolve Rseq_cv_finite_pos_mult_pos_infty_l : Rseq.
Hint Resolve Rseq_cv_finite_pos_mult_pos_infty_r : Rseq.
Hint Resolve Rseq_cv_inv_compat : Rseq.
Hint Resolve Rseq_cv_minus_compat : Rseq.
Hint Resolve Rseq_cv_mult_compat : Rseq.
Hint Resolve Rseq_cv_neg_infty_div_compat : Rseq.
Hint Resolve Rseq_cv_neg_infty_inv_compat : Rseq.
Hint Resolve Rseq_cv_neg_infty_opp_compat : Rseq.
Hint Resolve Rseq_cv_neg_infty_plus_compat : Rseq.
Hint Resolve Rseq_cv_neg_infty_plus_compat : Rseq.
Hint Resolve Rseq_cv_neg_minus_pos_infty : Rseq.
Hint Resolve Rseq_cv_neg_neg_infty_mult : Rseq.
Hint Resolve Rseq_cv_neg_pos_infty_mult : Rseq.
Hint Resolve Rseq_cv_opp_compat : Rseq.
Hint Resolve Rseq_cv_plus_compat : Rseq.
Hint Resolve Rseq_cv_pos_infty_inv_compat : Rseq.
Hint Resolve Rseq_cv_pos_infty_opp_compat : Rseq.
Hint Resolve Rseq_cv_pos_infty_plus_compat : Rseq.
Hint Resolve Rseq_cv_pos_minus_neg_infty : Rseq.
Hint Resolve Rseq_cv_pos_neg_infty_mult : Rseq.
Hint Resolve Rseq_cv_pos_pos_infty_mult : Rseq.
(* end hide *)