(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)
(* begin hide *)
Require Export CoRN.reals.Q_in_CReals.

(*----- Opaque_algebra.v will be loaded in line 151 -----*)

Lemma or_not_and :
 forall (A : CProp) (B : Prop), Not A \/ ~ B -> Not (A and B).
Proof.
 intros.
 intro H0.
 elim H0.
 intros.
 case H.
  intro H3.
  apply H3.
  assumption.
 intro H3.
 apply H3.
 assumption.
Qed.

Section Interval_definition.
 Variable OF : COrdField.

 Record Interval : Type :=
   {pair_crr :> prodT OF OF; is_interval : fstT pair_crr[<]sndT pair_crr}.

Definition Length (I1 : Interval) : OF := sndT I1[-]fstT I1.

End Interval_definition.

Definition Rat_Interval := Interval Q_as_COrdField.

(* we have this in Q_COrdField... *)
Lemma Qlt_eq_gt_dec' :
 forall q1 q2 : Q_as_COrdField, ((q1[<]q2) or (q2[<]q1)) or (q1[=]q2).
Proof.
 intros.
 case (Q_dec q1 q2); intuition.
Qed.

(*
Lemma ex_informative_on_Q:(P:Q_as_COrdField->Prop)(Ex [q:Q_as_COrdField](P q))
                             ->{q:Q_as_COrdField | (P q)}.
Proof.
 Intro.
 Intro.
 Apply ex_informative.
 Assumption.
Qed.
*)

Section COrdField_extra.

Variable OF : COrdField.

Lemma AbsSmall_pos_reflexive : forall x : OF, ([0][<=]x) -> AbsSmall x x.
Proof.
 intros.
 split.
  apply leEq_transitive with (y := [0]:OF).
   apply inv_cancel_leEq.
   rstepl ([0]:OF).
   rstepr x.
   assumption.
  assumption.
 apply leEq_reflexive.
Qed.

Lemma AbsSmall_neg_reflexive : forall x : OF, ([0][<=]x) -> AbsSmall x [--]x.
Proof.
 intros.
 split.
  apply leEq_reflexive.
 apply leEq_transitive with (y := [0]:OF).
  apply inv_cancel_leEq.
  rstepl ([0]:OF).
  rstepr x.
  assumption.
 assumption.
Qed.

Lemma AbsSmall_subinterval :
 forall a b x y : OF,
 (a[<=]x) -> (a[<=]y) -> (x[<=]b) -> (y[<=]b) -> AbsSmall (b[-]a) (x[-]y).
Proof.
 intros.
 split.
  rstepl (a[+][--]b).
  rstepr (x[+][--]y).
  apply plus_resp_leEq_both.
   assumption.
  apply inv_resp_leEq.
  assumption.
 rstepl (x[+][--]y).
 rstepr (b[+][--]a).
 apply plus_resp_leEq_both.
  assumption.
 apply inv_resp_leEq.
 assumption.
Qed.

End COrdField_extra.

Section Rational_sequence.
Load "Opaque_algebra".  (* WARNING: A file is being loaded *)
Variable R1 : CReals.

Definition start_l (x : R1) := let (N, _) := start_of_sequence _ x in N.

Lemma start_of_sequence2 :
 forall x : R1,
 {q2 : Q_as_COrdField | inj_Q R1 (start_l x)[<]x | x[<]inj_Q R1 q2}.
Proof.
 intro.
 apply (ProjT2 (start_of_sequence _ x)).
Qed.

Definition start_r (x : R1) := let (N, _, _) := start_of_sequence2 x in N.

Lemma start_of_sequence_property :
 forall x : R1, (inj_Q R1 (start_l x)[<]x) and (x[<]inj_Q R1 (start_r x)).
Proof.
 intro.
 unfold start_l, start_r in |- *.
 elim start_of_sequence2; auto.
Qed.

Lemma l_less_r : forall x : R1, start_l x[<]start_r x.
Proof.
 intro.
 apply less_inj_Q with (R1 := R1).
 elim (start_of_sequence_property x).
 apply less_transitive_unfolded.
Qed.

Lemma shrink23 :
 forall q1 q2 : Q_as_COrdField,
 (q1[<]q2) -> q1[+](q2[-]q1) [/]ThreeNZ[<]q2[-](q2[-]q1) [/]ThreeNZ.
Proof.
 intros.
 apply plus_cancel_less with (R := Q_as_COrdField) (z := (q2[-]q1) [/]ThreeNZ).
 rstepl (q2[-](q2[-]q1) [/]ThreeNZ).
 rstepr q2.
 apply plus_cancel_less with (R := Q_as_COrdField) (z := [--]q2).
 rstepr [--]([0]:Q_as_COrdField).
 rstepl [--]((q2[-]q1) [/]ThreeNZ).
 apply inv_resp_less.
 apply mult_cancel_less with (R := Q_as_COrdField) (z := Three:Q_as_COrdField).
  apply pos_nring_S.
 rstepl ([0]:Q_as_COrdField).
 rstepr (q2[-]q1).
 apply shift_zero_less_minus.
 assumption.
Qed.

Lemma shrink13 :
 forall q1 q2 : Q_as_COrdField, (q1[<]q2) -> q1[<]q2[-](q2[-]q1) [/]ThreeNZ.
Proof.
 intros.
 apply less_transitive_unfolded with (q1[+](q2[-]q1) [/]ThreeNZ).
  astepl (q1[+][0]).
  apply plus_resp_less_lft.
  apply div_resp_pos.
   apply pos_three.
  apply shift_zero_less_minus.
  assumption.
 apply shrink23.
 assumption.
Qed.

Lemma shrink24 :
 forall q1 q2 : Q_as_COrdField, (q1[<]q2) -> q1[+](q2[-]q1) [/]ThreeNZ[<]q2.
Proof.
 intros.
 apply less_transitive_unfolded with (q2[-](q2[-]q1) [/]ThreeNZ).
  apply shrink23.
  assumption.
 astepl (q2[+][--]((q2[-]q1) [/]ThreeNZ)).
 astepr (q2[+][0]).
 apply plus_resp_less_lft.
 apply inv_cancel_less.
 rstepl ([0]:Q_as_COrdField).
 rstepr ((q2[-]q1) [/]ThreeNZ).
 apply div_resp_pos.
  apply pos_three.
 apply shift_zero_less_minus.
 assumption.
Qed.

Definition cotrans_analyze :
  forall (x : R1) (q1 q2 : Q_as_COrdField), (q1[<]q2) -> Q_as_COrdField.
Proof.
 intros.
 cut (inj_Q R1 q1[<]inj_Q R1 q2).
  intro H0.
  case (less_cotransitive_unfolded R1 (inj_Q R1 q1) (inj_Q R1 q2) H0 x).
   intro.
   exact q1.
  intro.
  exact q2.
 apply inj_Q_less.
 assumption.
Defined.

Lemma cotrans_analyze_strong :
 forall (q1 q2 : Q_as_COrdField) (x : R1) (H : q1[<]q2),
 ((inj_Q R1 q1[<]x) and (cotrans_analyze x q1 q2 H[=]q1))
 or (x[<]inj_Q R1 q2) and (cotrans_analyze x q1 q2 H[=]q2).
Proof.
 intros.
 unfold cotrans_analyze in |- *.
 elim (less_cotransitive_unfolded R1 (inj_Q R1 q1) (inj_Q R1 q2) (inj_Q_less R1 q1 q2 H) x).
  intros.
  left.
  split.
   assumption.
  algebra.
 intros.
 right.
 split.
  assumption.
 algebra.
Qed.

Definition trichotomy :
  R1 -> Q_as_COrdField -> Q_as_COrdField -> Q_as_COrdField.
Proof.
 intros x q1 q2.
 case (Qlt_eq_gt_dec' q1 q2).
  intro s.
  elim s.
   intro a.
   exact (cotrans_analyze x (q1[+](q2[-]q1) [/]ThreeNZ) (q2[-](q2[-]q1) [/]ThreeNZ) (shrink23 q1 q2 a)).
  intro.
  exact [0].
 intro.
 exact q1.
Defined.

Lemma trichotomy_strong1 :
 forall (q1 q2 : Q_as_COrdField) (x : R1) (H : q1[<]q2),
 ((inj_Q R1 (q1[+](q2[-]q1) [/]ThreeNZ)[<]x)
  and (trichotomy x q1 q2[=]q1[+](q2[-]q1) [/]ThreeNZ))
 or (x[<]inj_Q R1 (q2[-](q2[-]q1) [/]ThreeNZ))
    and (trichotomy x q1 q2[=]q2[-](q2[-]q1) [/]ThreeNZ).
Proof.
 intros.
 unfold trichotomy in |- *.
 elim (Qlt_eq_gt_dec' q1 q2).
  intro y.
  elim y.
   intro y0.
   simpl in |- *.
   apply cotrans_analyze_strong.
  intro.
  apply False_rect.
  generalize b.
  change (Not (q2[<]q1)) in |- *.
  apply less_antisymmetric_unfolded.
  assumption.
 intro.
 exfalso.
 generalize b.
 change (q1[~=]q2) in |- *.
 apply ap_imp_neq.
 apply less_imp_ap.
 assumption.
Qed.

Notation "( A , B )" := (pairT A B).
Definition if_cotrans : forall (x : R1) (I1 : Rat_Interval), Rat_Interval.
Proof.
 intros.
 case I1.
 intros i pi.
 elim (trichotomy_strong1 (fstT i) (sndT i) x pi).
  intro.
  exact (Build_Interval _ (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ, sndT i)
    (shrink24 (fstT i) (sndT i) pi)).
 intro.
 exact (Build_Interval _ (fstT i, sndT i[-](sndT i[-]fstT i) [/]ThreeNZ)
   (shrink13 (fstT i) (sndT i) pi)).
Defined.

Lemma if_cotrans_strong :
 forall (x : R1) (I1 : Rat_Interval),
 ((inj_Q R1 (fstT I1[+](sndT I1[-]fstT I1) [/]ThreeNZ)[<]x)
  and if_cotrans x I1 =
      Build_Interval _ (fstT I1[+](sndT I1[-]fstT I1) [/]ThreeNZ, sndT I1)
        (shrink24 (fstT I1) (sndT I1) (is_interval _ I1)))
 or (x[<]inj_Q R1 (sndT I1[-](sndT I1[-]fstT I1) [/]ThreeNZ))
    and if_cotrans x I1 =
        Build_Interval _ (fstT I1, sndT I1[-](sndT I1[-]fstT I1) [/]ThreeNZ)
          (shrink13 (fstT I1) (sndT I1) (is_interval _ I1)).
Proof.
 intros.
 case I1.
 intros i pi.
 elim (trichotomy_strong1 (fstT i) (sndT i) x pi).
  intro y.
  elim y.
  intros H H0.
  left.
  split.
   exact H.
  cut (if_cotrans x (Build_Interval Q_as_COrdField i pi) = Build_Interval Q_as_COrdField
    (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ, sndT i) (shrink24 (fstT i) (sndT i) pi)).
   intro H1.
   rewrite H1.
   simpl in |- *.
   reflexivity.
  unfold if_cotrans in |- *.
  apply not_r_cor_rect.
  apply or_not_and.
  right.
  change (trichotomy x (fstT i) (sndT i)[~=]sndT i[-](sndT i[-]fstT i) [/]ThreeNZ) in |- *.
  apply ap_imp_neq.
  astepl (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ).
  apply less_imp_ap.
  apply shrink23.
  assumption.
 intro.
 elim b.
 intros H H0.
 right.
 split.
  exact H.
 cut (if_cotrans x (Build_Interval Q_as_COrdField i pi) = Build_Interval Q_as_COrdField
   (fstT i, sndT i[-](sndT i[-]fstT i) [/]ThreeNZ) (shrink13 (fstT i) (sndT i) pi)).
  intro H1.
  rewrite H1.
  simpl in |- *.
  reflexivity.
 unfold if_cotrans in |- *.
 apply not_l_cor_rect.
 apply or_not_and.
 right.
 change (trichotomy x (fstT i) (sndT i)[~=] (fstT i)[+]((sndT i[-]fstT i) [/]ThreeNZ)) in |- *.
 apply ap_imp_neq.
 astepl (sndT i[-](sndT i[-]fstT i) [/]ThreeNZ).
 apply Greater_imp_ap.
 apply shrink23.
 assumption.
Qed.

Fixpoint Intrvl (x : R1) (n : nat) {struct n} : Rat_Interval :=
  match n with
  | O => Build_Interval _ (start_l x, start_r x) (l_less_r x)
  | S p => if_cotrans x (Intrvl x p)
  end.

Definition G (x : R1) (n : nat) :=
  (fstT (Intrvl x n)[+]sndT (Intrvl x n)) [/]TwoNZ.

Opaque Q_as_CField.

Lemma delta_Intrvl :
 forall (x : R1) (n : nat),
 Length _ (Intrvl x (S n))[=]Two [/]ThreeNZ[*]Length _ (Intrvl x n).
Proof.
 intros.
 case (if_cotrans_strong x (Intrvl x n)).
  intro H.
  elim H.
  intros H0 H1.
  simpl in |- *.
  rewrite H1.
  unfold Length in |- *.
  simpl in |- *.
  rational.
 intro H.
 elim H.
 intros H0 H1.
 simpl in |- *.
 rewrite H1.
 unfold Length in |- *.
 simpl in |- *.
 rational.
Qed.

Lemma Length_Intrvl :
 forall (x : R1) (n : nat),
 Length _ (Intrvl x n)[=](Two [/]ThreeNZ)[^]n[*](start_r x[-]start_l x).
Proof.
 intros.
 induction  n as [| n Hrecn].
  (* n=0 *)
  unfold Length in |- *.
  simpl in |- *.
  rational.
 (* n=(S n0) & induction hypothesis *)
 astepr (Two [/]ThreeNZ[*]((Two [/]ThreeNZ)[^]n[*](start_r x[-]start_l x))).
  astepr (Two [/]ThreeNZ[*]Length Q_as_COrdField (Intrvl x n)).
  apply delta_Intrvl.
 astepr ((Two [/]ThreeNZ)[^]n[*]Two [/]ThreeNZ[*](start_r x[-]start_l x)).
 rational.
Qed.

Lemma Intrvl_inside_l_n :
 forall (x : R1) (m n : nat),
 m <= n -> fstT (Intrvl x m)[<=]fstT (Intrvl x n).
Proof.
 intros.
 induction  n as [| n Hrecn].
  (* n=0 *)
  cut (m = 0).
   intro.
   rewrite H0.
   apply leEq_reflexive.
  symmetry  in |- *.
  apply le_n_O_eq.
  assumption.
 (* n=(S n0) *)
 cut ({m = S n} + {m <= n}).
  intro.
  case H0.
   intro H1.
   rewrite H1.
   apply leEq_reflexive.
  intro.
  apply leEq_transitive with (fstT (Intrvl x n)).
   apply Hrecn.
   assumption.
  case (if_cotrans_strong x (Intrvl x n)).
   intro H2.
   elim H2.
   intros H3 H4.
   change (fstT (Intrvl x n)[<=]fstT (if_cotrans x (Intrvl x n))) in |- *.
   rewrite H4.
   astepl (fstT (Intrvl x n)[+][0]).
   simpl.
   apply (plus_resp_leEq_both Q_as_COrdField).
    apply leEq_reflexive.
   apply less_leEq.
   apply (div_resp_pos Q_as_COrdField).
    apply (pos_three Q_as_COrdField).
   apply (shift_zero_less_minus Q_as_COrdField).
   apply (is_interval Q_as_COrdField).
  intro H2.
  elim H2.
  intros H3 H4.
  change (fstT (Intrvl x n)[<=]fstT (if_cotrans x (Intrvl x n))) in |- *.
  rewrite H4.
  apply leEq_reflexive.
 case (le_lt_eq_dec m (S n) H).
  intro.
  right.
  apply lt_n_Sm_le.
  assumption.
 intro.
 left.
 assumption.
Qed.

Lemma Intrvl_inside_r_n :
 forall (x : R1) (m n : nat),
 m <= n -> sndT (Intrvl x n)[<=]sndT (Intrvl x m).
Proof.
 intros.
 induction  n as [| n Hrecn].
  (* n=0 *)
  cut (m = 0).
   intro.
   rewrite H0.
   apply leEq_reflexive.
  symmetry  in |- *.
  apply le_n_O_eq.
  assumption.
 (* n=(S n0) *)
 cut ({m = S n} + {m <= n}).
  intro H0.
  case H0.
   intro H1.
   rewrite H1.
   apply leEq_reflexive.
  intro.
  apply leEq_transitive with (sndT (Intrvl x n)).
   case (if_cotrans_strong x (Intrvl x n)).
    intro H2.
    elim H2.
    intros H3 H4.
    change (sndT (if_cotrans x (Intrvl x n))[<=]sndT (Intrvl x n)) in |- *.
    rewrite H4.
    apply leEq_reflexive.
   intro H2.
   elim H2.
   intros H3 H4.
   change (sndT (if_cotrans x (Intrvl x n))[<=]sndT (Intrvl x n)) in |- *.
   rewrite H4.
   astepr (sndT (Intrvl x n)[+][0]).
   astepl (sndT (Intrvl x n)[+] [--]((sndT (Intrvl x n)[-]fstT (Intrvl x n)) [/]ThreeNZ)).
   apply plus_resp_leEq_both.
    apply leEq_reflexive.
   apply inv_cancel_leEq.
   astepl ([0]:Q_as_COrdField).
   astepr ((sndT (Intrvl x n)[-]fstT (Intrvl x n)) [/]ThreeNZ).
   apply less_leEq.
   apply div_resp_pos.
    apply pos_three.
   apply shift_zero_less_minus.
   apply is_interval.
  apply Hrecn.
  assumption.
 case (le_lt_eq_dec m (S n) H).
  intro.
  right.
  apply lt_n_Sm_le.
  assumption.
 intro.
 left.
 assumption.
Qed.

Lemma G_m_n_lower :
 forall (x : R1) (m n : nat), m <= n -> fstT (Intrvl x m)[<]G x n.
Proof.
 intros.
 unfold G in |- *.
 apply leEq_less_trans with (fstT (Intrvl x n)).
  apply Intrvl_inside_l_n.
  assumption.
 apply Smallest_less_Average.
 apply is_interval.
Qed.

Lemma G_m_n_upper :
 forall (x : R1) (m n : nat), m <= n -> G x n[<]sndT (Intrvl x m).
Proof.
 intros.
 unfold G in |- *.
 apply less_leEq_trans with (sndT (Intrvl x n)).
  apply Average_less_Greatest.
  apply is_interval.
 apply Intrvl_inside_r_n.
 assumption.
Qed.

Opaque Q_as_COrdField.

Lemma a_simple_inequality :
 forall m : nat,
 4 <= m ->
 (Two [/]ThreeNZ)[^]m[<]
 (([1]:Q_as_COrdField)[/] nring (S m)[//]nringS_ap_zero _ m).
Proof.
 intros.
 induction  m as [| m Hrecm].
  apply False_rect.
  generalize H.
  change (~ 4 <= 0) in |- *.
  apply le_Sn_O.
 case (le_lt_eq_dec 4 (S m) H).
  intro.
  apply less_transitive_unfolded with (Two [/]ThreeNZ[*]
    (([1]:Q_as_COrdField)[/] nring (S m)[//]nringS_ap_zero _ m)).
   astepl (((Two:Q_as_COrdField) [/]ThreeNZ)[^]m[*]Two [/]ThreeNZ).
   astepl ((Two:Q_as_COrdField) [/]ThreeNZ[*](Two [/]ThreeNZ)[^]m).
   apply mult_resp_less_lft.
    apply Hrecm.
    apply lt_n_Sm_le.
    assumption.
   apply div_resp_pos.
    apply pos_three.
   apply pos_two.
  (* astepl ((Two::Q_as_COrdField)[/]ThreeNZ)[*](Two[/]ThreeNZ)[^]m.
  Apply nexp_Sn with ((Two::Q_as_COrdField)[/]ThreeNZ). *)
  apply mult_cancel_less with ((Three:Q_as_COrdField)[*]nring (S m)[*]nring (S (S m))).
   apply mult_resp_pos.
    apply mult_resp_pos.
     apply pos_three.
    apply pos_nring_S.
   apply pos_nring_S.
  rstepl ((Two:Q_as_COrdField)[*]nring (S (S m))).
  rstepr ((Three:Q_as_COrdField)[*]nring (S m)).
  astepl ((Two:Q_as_COrdField)[*](nring m[+]Two)).
   astepr ((Three:Q_as_COrdField)[*](nring m[+][1])).
   apply plus_cancel_less with ([--]((Two:Q_as_COrdField)[*]nring m[+]Three)).
   rstepl ([1]:Q_as_COrdField).
   rstepr (nring (R:=Q_as_COrdField) m).
   astepl (nring (R:=Q_as_COrdField) 1).
   apply nring_less.
   apply lt_trans with (m := 3).
    constructor.
    constructor.
   apply lt_S_n.
   assumption.
  simpl in |- *.
  rational.
 intro.
 rewrite <- e.
 apply mult_cancel_less with (nring (R:=Q_as_COrdField) 5[*]Three[^]4).
  apply mult_resp_pos.
   apply pos_nring_S.
  rstepr (Three[^]2[*]Three[^]2:Q_as_COrdField).
  apply mult_resp_pos.
   apply pos_square.
   apply nringS_ap_zero.
  apply pos_square.
  apply nringS_ap_zero.
 rstepl (Two[^]4[*]nring (R:=Q_as_COrdField) 5).
 rstepr (Three[^]4:Q_as_COrdField).
 rstepl (nring (R:=Q_as_COrdField) 80).
 rstepr (nring (R:=Q_as_COrdField) 81).
 apply nring_less.
 constructor.
Qed.

Lemma G_conversion_rate2 :
 forall (x : R1) (m n : nat),
 4 <= m ->
 m <= n ->
 AbsSmall (start_r x[-]start_l x[/] nring (S m)[//]nringS_ap_zero _ m)
   (G x m[-]G x n).
Proof.
 intros.
 apply AbsSmall_leEq_trans with (Length _ (Intrvl x m)).
  astepl ((Two [/]ThreeNZ)[^]m[*](start_r x[-]start_l x)).
   rstepr (([1][/] nring (S m)[//]nringS_ap_zero _ m)[*](start_r x[-]start_l x)).
   apply less_leEq.
   apply mult_resp_less.
    apply a_simple_inequality.
    assumption.
   apply shift_zero_less_minus.
   apply l_less_r.
  apply eq_symmetric_unfolded.
  apply Length_Intrvl.
 unfold Length in |- *.
 apply AbsSmall_subinterval; apply less_leEq.
    apply G_m_n_lower.
    constructor.
   apply G_m_n_lower.
   assumption.
  apply G_m_n_upper.
  constructor.
 apply G_m_n_upper.
 assumption.
Qed.

Lemma CS_seq_G : forall x : R1, Cauchy_prop (fun m : nat => G x m).
Proof.
 intros.
 unfold Cauchy_prop in |- *.
 intros e H.
 cut {n : nat | (start_r x[-]start_l x[/] e[//]Greater_imp_ap _ e [0] H)[<]nring n}.
  intro H0.
  case H0.
  intro N.
  intro.
  exists (S (N + 3)).
  intros.
  apply AbsSmall_minus.
  apply AbsSmall_leEq_trans with (start_r x[-]start_l x[/] nring (S (S (N + 3)))[//]
    nringS_ap_zero Q_as_COrdField (S (N + 3))).
   apply less_leEq.
   apply swap_div with (z_ := Greater_imp_ap _ e [0] H).
     apply pos_nring_S.
    assumption.
   apply less_transitive_unfolded with (nring (R:=Q_as_COrdField) N).
    assumption.
   apply nring_less.
   apply le_lt_n_Sm.
   constructor.
   apply le_plus_l.
  apply G_conversion_rate2 with (m := S (N + 3)).
   apply le_n_S.
   apply le_plus_r.
  assumption.
 apply Q_is_archemaedian.  (* Note the use of Q_is_archemaedian *)
Qed.

Definition G_as_CauchySeq (x : R1) :=
  Build_CauchySeq Q_as_COrdField (fun m : nat => G x m) (CS_seq_G x).

Lemma CS_seq_inj_Q_G :
 forall x : R1, Cauchy_prop (fun m : nat => inj_Q R1 (G x m)).
Proof.
 intro.
 change (Cauchy_prop (fun m : nat => inj_Q R1 (CS_seq _ (G_as_CauchySeq x) m))) in |- *.
 apply inj_Q_Cauchy.
Qed.

Definition inj_Q_G_as_CauchySeq (x : R1) :=
  Build_CauchySeq _ (fun m : nat => inj_Q R1 (G x m)) (CS_seq_inj_Q_G x).

Lemma x_in_Intrvl_l :
 forall (x : R1) (n : nat), inj_Q R1 (fstT (Intrvl x n))[<]x.
Proof.
 intros.
 induction  n as [| n Hrecn].
  (* n=0 *)
  simpl in |- *.
  cut ((inj_Q R1 (start_l x)[<]x) and (x[<]inj_Q R1 (start_r x))).
   intro H.
   elim H.
   intros.
   assumption.
  apply start_of_sequence_property.
 (* n= (S n0) *)
 case (if_cotrans_strong x (Intrvl x n)).
  intro H.
  elim H.
  intros H0 H1.
  change (inj_Q R1 (fstT (if_cotrans x (Intrvl x n)))[<]x) in |- *.
  rewrite H1.
  simpl in |- *.
  assumption.
 intro H.
 elim H.
 intros H0 H1.
 change (inj_Q R1 (fstT (if_cotrans x (Intrvl x n)))[<]x) in |- *.
 rewrite H1.
 simpl in |- *.
 assumption.
Qed.

Lemma x_in_Intrvl_r :
 forall (x : R1) (n : nat), x[<]inj_Q R1 (sndT (Intrvl x n)).
Proof.
 intros.
 induction  n as [| n Hrecn].
  (* n=0 *)
  simpl in |- *.
  cut ((inj_Q R1 (start_l x)[<]x) and (x[<]inj_Q R1 (start_r x))).
   intro H.
   elim H.
   intros.
   assumption.
  apply start_of_sequence_property.
 (* n= (S n0) *)
 case (if_cotrans_strong x (Intrvl x n)).
  intro H.
  elim H.
  intros H0 H1.
  change (x[<]inj_Q R1 (sndT (if_cotrans x (Intrvl x n)))) in |- *.
  rewrite H1.
  simpl in |- *.
  assumption.
 intro H.
 elim H.
 intros H0 H1.
 change (x[<]inj_Q R1 (sndT (if_cotrans x (Intrvl x n)))) in |- *.
 rewrite H1.
 simpl in |- *.
 assumption.
Qed.

Lemma G_conversion_rate_resp_x :
 forall (x : R1) (m : nat),
 4 <= m ->
 AbsSmall
   (inj_Q R1 (start_r x[-]start_l x[/] nring (S m)[//]nringS_ap_zero _ m))
   (inj_Q R1 (G x m)[-]x).
Proof.
 intros.
 apply AbsSmall_leEq_trans with (e1 := inj_Q R1 (Length _ (Intrvl x m))).
  apply less_leEq.
  apply inj_Q_less.
  astepl ((Two [/]ThreeNZ)[^]m[*](start_r x[-]start_l x)).
   rstepr (([1][/] nring (S m)[//]nringS_ap_zero _ m)[*](start_r x[-]start_l x)).
   apply mult_resp_less.
    apply a_simple_inequality.
    assumption.
   apply shift_zero_less_minus.
   apply l_less_r.
  apply eq_symmetric_unfolded.
  apply Length_Intrvl.
 unfold Length in |- *.
 astepl (inj_Q R1 (sndT (Intrvl x m))[-]inj_Q R1 (fstT (Intrvl x m))).
 apply AbsSmall_subinterval; apply less_leEq.
    apply inj_Q_less.
    apply G_m_n_lower.
    constructor.
   apply x_in_Intrvl_l.
  apply inj_Q_less.
  apply G_m_n_upper.
  constructor.
 apply x_in_Intrvl_r.
Qed.

Lemma x_is_SeqLimit_G : forall x : R1, SeqLimit (inj_Q_G_as_CauchySeq x) x.
Proof.
 intros.
 unfold SeqLimit in |- *.
 intros e H.
 unfold inj_Q_G_as_CauchySeq in |- *.
 unfold CS_seq in |- *.
 cut {n : nat | (inj_Q R1 (start_r x[-]start_l x)[/] e[//]Greater_imp_ap _ e [0] H)[<] nring n}.
  intro H0.
  case H0.
  intro N.
  intro.
  exists (S (N + 3)).
  intros.
  apply AbsSmall_leEq_trans with (e1 := inj_Q R1 ((start_r x[-]start_l x)[/]nring (S (S (N + 3)))[//]
    nringS_ap_zero Q_as_COrdField (S (N + 3)))).
   apply less_leEq.
   apply less_transitive_unfolded with (y := inj_Q R1
     ((start_r x[-]start_l x)[/]nring (R:=Q_as_COrdField) (S N)[//] nringS_ap_zero _ N)).
    apply inj_Q_less.
    apply mult_cancel_less with (nring (R:=Q_as_COrdField) (S (S (N + 3)))[*]nring (S N)).
     apply mult_resp_pos.
      apply pos_nring_S.
     apply pos_nring_S.
    rstepl ((start_r x[-]start_l x)[*]nring (S N)).
    rstepr ((start_r x[-]start_l x)[*]nring (S (S (N + 3)))).
    apply mult_resp_less_lft.
     apply nring_less.
     apply lt_n_S.
     apply le_lt_n_Sm.
     apply le_plus_l.
    apply shift_zero_less_minus.
    apply l_less_r.
   astepl (inj_Q R1 (start_r x[-]start_l x)[/]nring (S N)[//]nringS_ap_zero R1 N).
    apply swap_div with (z_ := Greater_imp_ap _ e [0] H).
      apply pos_nring_S.
     assumption.
    apply less_transitive_unfolded with (y := nring (R:=R1) N).
     assumption.
    apply nring_less.
    apply le_lt_n_Sm.
    constructor.
   apply mult_cancel_lft with (z := nring (R:=R1) (S N)).
    apply nringS_ap_zero.
   rstepl (inj_Q R1 (start_r x[-]start_l x)).
   astepr (inj_Q R1 (nring (S N))[*] inj_Q R1 ((start_r x[-]start_l x)[/]nring (S N)[//]
     nringS_ap_zero Q_as_COrdField N)).
   astepr (inj_Q R1 (nring (S N)[*] ((start_r x[-]start_l x)[/]nring (S N)[//]
     nringS_ap_zero Q_as_COrdField N))).
   apply inj_Q_wd.
   rational.
  apply AbsSmall_leEq_trans with (e1 := inj_Q R1 ((start_r x[-]start_l x)[/]nring (S m)[//]
    nringS_ap_zero Q_as_COrdField m)).
   apply inj_Q_leEq.
   apply mult_cancel_leEq with (nring (R:=Q_as_COrdField) (S (S (N + 3)))[*]nring (S m)).
    apply mult_resp_pos.
     apply pos_nring_S.
    apply pos_nring_S.
   rstepl ((start_r x[-]start_l x)[*]nring (S (S (N + 3)))).
   rstepr ((start_r x[-]start_l x)[*]nring (S m)).
   apply mult_resp_leEq_lft.
    apply nring_leEq.
    apply le_n_S.
    assumption.
   apply less_leEq.
   apply shift_zero_less_minus.
   apply l_less_r.
  apply G_conversion_rate_resp_x.
  apply le_trans with (m := S (N + 3)).
   apply le_n_S.
   apply le_plus_r.
  assumption.
 apply Archimedes'.
Qed.

End Rational_sequence.

(* end hide *)


From iris.algebra Require Import gmap auth agree gset coPset.
From iris.proofmode Require Import proofmode.
From iris.base_logic.lib Require Import wsat.
From iris.program_logic Require Export weakestpre.
From iris.prelude Require Import options.
Import uPred.

(** This file contains the adequacy statements of the Iris program logic. First
we prove a number of auxilary results. *)

Section adequacy.
Context `{!irisGS_gen hlc Λ Σ}.
Implicit Types e : expr Λ.
Implicit Types P Q : iProp Σ.
Implicit Types Φ : val Λ → iProp Σ.
Implicit Types Φs : list (val Λ → iProp Σ).

Notation wptp s t Φs := ([∗ list] e;Φ ∈ t;Φs, WP e @ s; ⊤ {{ Φ }})%I.

Local Lemma wp_step s e1 σ1 ns κ κs e2 σ2 efs nt Φ :
  prim_step e1 σ1 κ e2 σ2 efs →
  state_interp σ1 ns (κ ++ κs) nt -∗
  £ (S (num_laters_per_step ns)) -∗
  WP e1 @ s; ⊤ {{ Φ }}
    ={⊤,∅}=∗ |={∅}▷=>^(S $ num_laters_per_step ns) |={∅,⊤}=>
    state_interp σ2 (S ns) κs (nt + length efs) ∗ WP e2 @ s; ⊤ {{ Φ }} ∗
    wptp s efs (replicate (length efs) fork_post).
Proof.
  rewrite {1}wp_unfold /wp_pre. iIntros (?) "Hσ Hcred H".
  rewrite (val_stuck e1 σ1 κ e2 σ2 efs) //.
  iMod ("H" $! σ1 ns with "Hσ") as "(_ & H)". iModIntro.
  iApply (step_fupdN_wand with "(H [//] Hcred)"). iIntros ">H".
  by rewrite Nat.add_comm big_sepL2_replicate_r.
Qed.

Local Lemma wptp_step s es1 es2 κ κs σ1 ns σ2 Φs nt :
  step (es1,σ1) κ (es2, σ2) →
  state_interp σ1 ns (κ ++ κs) nt -∗
  £ (S (num_laters_per_step ns)) -∗
  wptp s es1 Φs -∗
  ∃ nt', |={⊤,∅}=> |={∅}▷=>^(S $ num_laters_per_step$ ns) |={∅,⊤}=>
         state_interp σ2 (S ns) κs (nt + nt') ∗
         wptp s es2 (Φs ++ replicate nt' fork_post).
Proof.
  iIntros (Hstep) "Hσ Hcred Ht".
  destruct Hstep as [e1' σ1' e2' σ2' efs t2' t3 Hstep]; simplify_eq/=.
  iDestruct (big_sepL2_app_inv_l with "Ht") as (Φs1 Φs2 ->) "[? Ht]".
  iDestruct (big_sepL2_cons_inv_l with "Ht") as (Φ Φs3 ->) "[Ht ?]".
  iExists _. iMod (wp_step with "Hσ Hcred Ht") as "H"; first done. iModIntro.
  iApply (step_fupdN_wand with "H"). iIntros ">($ & He2 & Hefs) !>".
  rewrite -(assoc_L app) -app_comm_cons. iFrame.
Qed.

(* The total number of laters used between the physical steps number
   [start] (included) to [start+ns] (excluded). *)
Local Fixpoint steps_sum (num_laters_per_step : nat → nat) (start ns : nat) : nat :=
  match ns with
  | O => 0
  | S ns =>
    S $ num_laters_per_step start + steps_sum num_laters_per_step (S start) ns
  end.

Local Lemma wptp_preservation s n es1 es2 κs κs' σ1 ns σ2 Φs nt :
  nsteps n (es1, σ1) κs (es2, σ2) →
  state_interp σ1 ns (κs ++ κs') nt -∗
  £ (steps_sum num_laters_per_step ns n) -∗
  wptp s es1 Φs
  ={⊤,∅}=∗ |={∅}▷=>^(steps_sum num_laters_per_step ns n) |={∅,⊤}=> ∃ nt',
    state_interp σ2 (n + ns) κs' (nt + nt') ∗
    wptp s es2 (Φs ++ replicate nt' fork_post).
Proof.
  revert nt es1 es2 κs κs' σ1 ns σ2 Φs.
  induction n as [|n IH]=> nt es1 es2 κs κs' σ1 ns σ2 Φs /=.
  { inversion_clear 1; iIntros "? ? ?"; iExists 0=> /=.
    rewrite Nat.add_0_r right_id_L. iFrame. by iApply fupd_mask_subseteq. }
  iIntros (Hsteps) "Hσ Hcred He". inversion_clear Hsteps as [|?? [t1' σ1']].
  rewrite -(assoc_L (++)) Nat.iter_add -{1}plus_Sn_m plus_n_Sm.
  rewrite lc_split. iDestruct "Hcred" as "[Hc1 Hc2]".
  iDestruct (wptp_step with "Hσ Hc1 He") as (nt') ">H"; first eauto; simplify_eq.
  iModIntro. iApply step_fupdN_S_fupd. iApply (step_fupdN_wand with "H").
  iIntros ">(Hσ & He)". iMod (IH with "Hσ Hc2 He") as "IH"; first done. iModIntro.
  iApply (step_fupdN_wand with "IH"). iIntros ">IH".
  iDestruct "IH" as (nt'') "[??]".
  rewrite -Nat.add_assoc -(assoc_L app) -replicate_add. by eauto with iFrame.
Qed.

Local Lemma wp_not_stuck κs nt e σ ns Φ :
  state_interp σ ns κs nt -∗ WP e {{ Φ }} ={⊤, ∅}=∗ ⌜not_stuck e σ⌝.
Proof.
  rewrite wp_unfold /wp_pre /not_stuck. iIntros "Hσ H".
  destruct (to_val e) as [v|] eqn:?.
  { iMod (fupd_mask_subseteq ∅); first set_solver. iModIntro. eauto. }
  iSpecialize ("H" $! σ ns [] κs with "Hσ"). rewrite sep_elim_l.
  iMod "H" as "%". iModIntro. eauto.
Qed.

(** The adequacy statement of Iris consists of two parts:
      (1) the postcondition for all threads that have terminated in values
      and (2) progress (i.e., after n steps the program is not stuck).
    For an n-step execution of a thread pool, the two parts are given by
    [wptp_strong_adequacy] and [wptp_progress] below.

    For the final adequacy theorem of Iris, [wp_strong_adequacy_gen], we would
    like to instantiate the Iris proof (i.e., instantiate the
    [∀ {Hinv : !invGS_gen hlc Σ} κs, ...]) and then use both lemmas to get
    progress and the postconditions. Unfortunately, since the addition of later
    credits, this is no longer possible, because the original proof relied on an
    interaction of the update modality and plain propositions. So instead, we
    employ a trick: we duplicate the instantiation of the Iris proof, such
    that we can "run the WP proof twice". That is, we instantiate the
    [∀ {Hinv : !invGS_gen hlc Σ} κs, ...] both in [wp_progress_gen] and
    [wp_strong_adequacy_gen]. In doing  so, we can avoid the interactions with
    the plain modality. In [wp_strong_adequacy_gen], we can then make use of
    [wp_progress_gen] to prove the progress component of the main adequacy theorem.
*)

Local Lemma wptp_postconditions Φs κs' s n es1 es2 κs σ1 ns σ2 nt:
  nsteps n (es1, σ1) κs (es2, σ2) →
  state_interp σ1 ns (κs ++ κs') nt -∗
  £ (steps_sum num_laters_per_step ns n) -∗
  wptp s es1 Φs
  ={⊤,∅}=∗ |={∅}▷=>^(steps_sum num_laters_per_step ns n) |={∅,⊤}=> ∃ nt',
    state_interp σ2 (n + ns) κs' (nt + nt') ∗
    [∗ list] e;Φ ∈ es2;Φs ++ replicate nt' fork_post, from_option Φ True (to_val e).
Proof.
  iIntros (Hstep) "Hσ Hcred He". iMod (wptp_preservation with "Hσ Hcred He") as "Hwp"; first done.
  iModIntro. iApply (step_fupdN_wand with "Hwp").
  iMod 1 as (nt') "(Hσ & Ht)"; simplify_eq/=.
  iExists _. iFrame "Hσ".
  iApply big_sepL2_fupd.
  iApply (big_sepL2_impl with "Ht").
  iIntros "!#" (? e Φ ??) "Hwp".
  destruct (to_val e) as [v2|] eqn:He2'; last done.
  apply of_to_val in He2' as <-. simpl. iApply wp_value_fupd'. done.
Qed.

Local Lemma wptp_progress Φs κs' n es1 es2 κs σ1 ns σ2 nt e2 :
  nsteps n (es1, σ1) κs (es2, σ2) →
  e2 ∈ es2 →
  state_interp σ1 ns (κs ++ κs') nt -∗
  £ (steps_sum num_laters_per_step ns n) -∗
  wptp NotStuck es1 Φs
  ={⊤,∅}=∗ |={∅}▷=>^(steps_sum num_laters_per_step ns n) |={∅}=> ⌜not_stuck e2 σ2⌝.
Proof.
  iIntros (Hstep Hel) "Hσ Hcred He". iMod (wptp_preservation with "Hσ Hcred He") as "Hwp"; first done.
  iModIntro. iApply (step_fupdN_wand with "Hwp").
  iMod 1 as (nt') "(Hσ & Ht)"; simplify_eq/=.
  eapply elem_of_list_lookup in Hel as [i Hlook].
  destruct ((Φs ++ replicate nt' fork_post) !! i) as [Φ|] eqn: Hlook2; last first.
  { rewrite big_sepL2_alt. iDestruct "Ht" as "[%Hlen _]". exfalso.
    eapply lookup_lt_Some in Hlook. rewrite Hlen in Hlook.
    eapply lookup_lt_is_Some_2 in Hlook. rewrite Hlook2 in Hlook.
    destruct Hlook as [? ?]. naive_solver. }
  iDestruct (big_sepL2_lookup with "Ht") as "Ht"; [done..|].
  by iApply (wp_not_stuck with "Hσ").
Qed.
End adequacy.

Local Lemma wp_progress_gen (hlc : has_lc) Σ Λ `{!invGpreS Σ} es σ1 n κs t2 σ2 e2
        (num_laters_per_step : nat → nat)  :
    (∀ `{Hinv : !invGS_gen hlc Σ},
    ⊢ |={⊤}=> ∃
         (stateI : state Λ → nat → list (observation Λ) → nat → iProp Σ)
         (Φs : list (val Λ → iProp Σ))
         (fork_post : val Λ → iProp Σ)
         state_interp_mono,
       let _ : irisGS_gen hlc Λ Σ := IrisG Hinv stateI fork_post num_laters_per_step
                                  state_interp_mono
       in
       stateI σ1 0 κs 0 ∗
       ([∗ list] e;Φ ∈ es;Φs, WP e @ ⊤ {{ Φ }})) →
  nsteps n (es, σ1) κs (t2, σ2) →
  e2 ∈ t2 →
  not_stuck e2 σ2.
Proof.
  iIntros (Hwp ??).
  eapply pure_soundness.
  eapply (step_fupdN_soundness_gen _ hlc (steps_sum num_laters_per_step 0 n)
    (steps_sum num_laters_per_step 0 n)).
  iIntros (Hinv) "Hcred".
  iMod Hwp as (stateI Φ fork_post state_interp_mono) "(Hσ & Hwp)".
  iDestruct (big_sepL2_length with "Hwp") as %Hlen1.
  iMod (@wptp_progress _ _ _
       (IrisG Hinv stateI fork_post num_laters_per_step state_interp_mono) _ []
    with "[Hσ] Hcred  Hwp") as "H"; [done| done |by rewrite right_id_L|].
  iAssert (|={∅}▷=>^(steps_sum num_laters_per_step 0 n) |={∅}=> ⌜not_stuck e2 σ2⌝)%I
    with "[-]" as "H"; last first.
  { destruct steps_sum; [done|]. by iApply step_fupdN_S_fupd. }
  iApply (step_fupdN_wand with "H"). iIntros "$".
Qed.

(** Iris's generic adequacy result *)
(** The lemma is parameterized by [use_credits] over whether to make later credits available or not.
  Below, a concrete instances is provided with later credits (see [wp_strong_adequacy]). *)
Lemma wp_strong_adequacy_gen (hlc : has_lc) Σ Λ `{!invGpreS Σ} s es σ1 n κs t2 σ2 φ
        (num_laters_per_step : nat → nat) :
  (* WP *)
  (∀ `{Hinv : !invGS_gen hlc Σ},
      ⊢ |={⊤}=> ∃
         (stateI : state Λ → nat → list (observation Λ) → nat → iProp Σ)
         (Φs : list (val Λ → iProp Σ))
         (fork_post : val Λ → iProp Σ)
         (* Note: existentially quantifying over Iris goal! [iExists _] should
         usually work. *)
         state_interp_mono,
       let _ : irisGS_gen hlc Λ Σ := IrisG Hinv stateI fork_post num_laters_per_step
                                  state_interp_mono
       in
       stateI σ1 0 κs 0 ∗
       ([∗ list] e;Φ ∈ es;Φs, WP e @ s; ⊤ {{ Φ }}) ∗
       (∀ es' t2',
         (* es' is the final state of the initial threads, t2' the rest *)
         ⌜ t2 = es' ++ t2' ⌝ -∗
         (* es' corresponds to the initial threads *)
         ⌜ length es' = length es ⌝ -∗
         (* If this is a stuck-free triple (i.e. [s = NotStuck]), then all
         threads in [t2] are not stuck *)
         ⌜ ∀ e2, s = NotStuck → e2 ∈ t2 → not_stuck e2 σ2 ⌝ -∗
         (* The state interpretation holds for [σ2] *)
         stateI σ2 n [] (length t2') -∗
         (* If the initial threads are done, their post-condition [Φ] holds *)
         ([∗ list] e;Φ ∈ es';Φs, from_option Φ True (to_val e)) -∗
         (* For all forked-off threads that are done, their postcondition
            [fork_post] holds. *)
         ([∗ list] v ∈ omap to_val t2', fork_post v) -∗
         (* Under all these assumptions, and while opening all invariants, we
         can conclude [φ] in the logic. After opening all required invariants,
         one can use [fupd_mask_subseteq] to introduce the fancy update. *)
         |={⊤,∅}=> ⌜ φ ⌝)) →
  nsteps n (es, σ1) κs (t2, σ2) →
  (* Then we can conclude [φ] at the meta-level. *)
  φ.
Proof.
  iIntros (Hwp ?).
  eapply pure_soundness.
  eapply (step_fupdN_soundness_gen _ hlc (steps_sum num_laters_per_step 0 n)
    (steps_sum num_laters_per_step 0 n)).
  iIntros (Hinv) "Hcred".
  iMod Hwp as (stateI Φ fork_post state_interp_mono) "(Hσ & Hwp & Hφ)".
  iDestruct (big_sepL2_length with "Hwp") as %Hlen1.
  iMod (@wptp_postconditions _ _ _
       (IrisG Hinv stateI fork_post num_laters_per_step state_interp_mono) _ []
    with "[Hσ] Hcred Hwp") as "H"; [done|by rewrite right_id_L|].
  iAssert (|={∅}▷=>^(steps_sum num_laters_per_step 0 n) |={∅}=> ⌜φ⌝)%I
    with "[-]" as "H"; last first.
  { destruct steps_sum; [done|]. by iApply step_fupdN_S_fupd. }
  iApply (step_fupdN_wand with "H").
  iMod 1 as (nt') "(Hσ & Hval) /=".
  iDestruct (big_sepL2_app_inv_r with "Hval") as (es' t2' ->) "[Hes' Ht2']".
  iDestruct (big_sepL2_length with "Ht2'") as %Hlen2.
  rewrite replicate_length in Hlen2; subst.
  iDestruct (big_sepL2_length with "Hes'") as %Hlen3.
  rewrite -plus_n_O.
  iApply ("Hφ" with "[//] [%] [ ] Hσ Hes'");
    (* FIXME: Different implicit types for [length] are inferred, so [lia] and
    [congruence] do not work due to https://github.com/coq/coq/issues/16634 *)
    [by rewrite Hlen1 Hlen3| |]; last first.
  { by rewrite big_sepL2_replicate_r // big_sepL_omap. }
  (* At this point in the adequacy proof, we use a trick: we effectively run the
    user-provided WP proof again (i.e., instantiate the `invGS_gen` and execute the
    program) by using the lemma [wp_progress_gen]. In doing so, we can obtain
    the progress part of the adequacy theorem.
  *)
  iPureIntro. intros e2 -> Hel.
  eapply (wp_progress_gen hlc);
    [ done | clear stateI Φ fork_post state_interp_mono Hlen1 Hlen3 | done|done].
  iIntros (?).
  iMod Hwp as (stateI Φ fork_post state_interp_mono) "(Hσ & Hwp & Hφ)".
  iModIntro. iExists _, _, _, _. iFrame.
Qed.

(** Adequacy when using later credits (the default) *)
Definition wp_strong_adequacy := wp_strong_adequacy_gen HasLc.
Global Arguments wp_strong_adequacy _ _ {_}.

(** Since the full adequacy statement is quite a mouthful, we prove some more
intuitive and simpler corollaries. These lemmas are morover stated in terms of
[rtc erased_step] so one does not have to provide the trace. *)
Record adequate {Λ} (s : stuckness) (e1 : expr Λ) (σ1 : state Λ)
    (φ : val Λ → state Λ → Prop) := {
  adequate_result t2 σ2 v2 :
   rtc erased_step ([e1], σ1) (of_val v2 :: t2, σ2) → φ v2 σ2;
  adequate_not_stuck t2 σ2 e2 :
   s = NotStuck →
   rtc erased_step ([e1], σ1) (t2, σ2) →
   e2 ∈ t2 → not_stuck e2 σ2
}.

Lemma adequate_alt {Λ} s e1 σ1 (φ : val Λ → state Λ → Prop) :
  adequate s e1 σ1 φ ↔ ∀ t2 σ2,
    rtc erased_step ([e1], σ1) (t2, σ2) →
      (∀ v2 t2', t2 = of_val v2 :: t2' → φ v2 σ2) ∧
      (∀ e2, s = NotStuck → e2 ∈ t2 → not_stuck e2 σ2).
Proof.
  split.
  - intros []; naive_solver.
  - constructor; naive_solver.
Qed.

Theorem adequate_tp_safe {Λ} (e1 : expr Λ) t2 σ1 σ2 φ :
  adequate NotStuck e1 σ1 φ →
  rtc erased_step ([e1], σ1) (t2, σ2) →
  Forall (λ e, is_Some (to_val e)) t2 ∨ ∃ t3 σ3, erased_step (t2, σ2) (t3, σ3).
Proof.
  intros Had ?.
  destruct (decide (Forall (λ e, is_Some (to_val e)) t2)) as [|Ht2]; [by left|].
  apply (not_Forall_Exists _), Exists_exists in Ht2; destruct Ht2 as (e2&?&He2).
  destruct (adequate_not_stuck NotStuck e1 σ1 φ Had t2 σ2 e2) as [?|(κ&e3&σ3&efs&?)];
    rewrite ?eq_None_not_Some; auto.
  { exfalso. eauto. }
  destruct (elem_of_list_split t2 e2) as (t2'&t2''&->); auto.
  right; exists (t2' ++ e3 :: t2'' ++ efs), σ3, κ; econstructor; eauto.
Qed.

(** This simpler form of adequacy requires the [irisGS] instance that you use
everywhere to syntactically be of the form
{|
  iris_invGS := ...;
  state_interp σ _ κs _ := ...;
  fork_post v := ...;
  num_laters_per_step _ := 0;
  state_interp_mono _ _ _ _ := fupd_intro _ _;
|}
In other words, the state interpretation must ignore [ns] and [nt], the number
of laters per step must be 0, and the proof of [state_interp_mono] must have
this specific proof term.
*)
(** Again, we first prove a lemma generic over the usage of credits. *)
Lemma wp_adequacy_gen (hlc : has_lc) Σ Λ `{!invGpreS Σ} s e σ φ :
  (∀ `{Hinv : !invGS_gen hlc Σ} κs,
     ⊢ |={⊤}=> ∃
         (stateI : state Λ → list (observation Λ) → iProp Σ)
         (fork_post : val Λ → iProp Σ),
       let _ : irisGS_gen hlc Λ Σ :=
           IrisG Hinv (λ σ _ κs _, stateI σ κs) fork_post (λ _, 0)
                 (λ _ _ _ _, fupd_intro _ _)
       in
       stateI σ κs ∗ WP e @ s; ⊤ {{ v, ⌜φ v⌝ }}) →
  adequate s e σ (λ v _, φ v).
Proof.
  intros Hwp. apply adequate_alt; intros t2 σ2 [n [κs ?]]%erased_steps_nsteps.
  eapply (wp_strong_adequacy_gen hlc Σ _); [ | done]=> ?.
  iMod Hwp as (stateI fork_post) "[Hσ Hwp]".
  iExists (λ σ _ κs _, stateI σ κs), [(λ v, ⌜φ v⌝%I)], fork_post, _ => /=.
  iIntros "{$Hσ $Hwp} !>" (e2 t2' -> ? ?) "_ H _".
  iApply fupd_mask_intro_discard; [done|]. iSplit; [|done].
  iDestruct (big_sepL2_cons_inv_r with "H") as (e' ? ->) "[Hwp H]".
  iDestruct (big_sepL2_nil_inv_r with "H") as %->.
  iIntros (v2 t2'' [= -> <-]). by rewrite to_of_val.
Qed.

(** Instance for using credits *)
Definition wp_adequacy := wp_adequacy_gen HasLc.
Global Arguments wp_adequacy _ _ {_}.

Lemma wp_invariance_gen (hlc : has_lc) Σ Λ `{!invGpreS Σ} s e1 σ1 t2 σ2 φ :
  (∀ `{Hinv : !invGS_gen hlc Σ} κs,
     ⊢ |={⊤}=> ∃
         (stateI : state Λ → list (observation Λ) → nat → iProp Σ)
         (fork_post : val Λ → iProp Σ),
       let _ : irisGS_gen hlc Λ Σ := IrisG Hinv (λ σ _, stateI σ) fork_post
              (λ _, 0) (λ _ _ _ _, fupd_intro _ _) in
       stateI σ1 κs 0 ∗ WP e1 @ s; ⊤ {{ _, True }} ∗
       (stateI σ2 [] (pred (length t2)) -∗ ∃ E, |={⊤,E}=> ⌜φ⌝)) →
  rtc erased_step ([e1], σ1) (t2, σ2) →
  φ.
Proof.
  intros Hwp [n [κs ?]]%erased_steps_nsteps.
  eapply (wp_strong_adequacy_gen hlc Σ); [done| |done]=> ?.
  iMod (Hwp _ κs) as (stateI fork_post) "(Hσ & Hwp & Hφ)".
  iExists (λ σ _, stateI σ), [(λ _, True)%I], fork_post, _ => /=.
  iIntros "{$Hσ $Hwp} !>" (e2 t2' -> _ _) "Hσ H _ /=".
  iDestruct (big_sepL2_cons_inv_r with "H") as (? ? ->) "[_ H]".
  iDestruct (big_sepL2_nil_inv_r with "H") as %->.
  iDestruct ("Hφ" with "Hσ") as (E) ">Hφ".
  by iApply fupd_mask_intro_discard; first set_solver.
Qed.

Definition wp_invariance := wp_invariance_gen HasLc.
Global Arguments wp_invariance _ _ {_}.


(* This program 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 program 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 General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(*                       trivial.v                                          *)
(*                                                                          *)
(* Author: Pierre Casteran.                                                 *)
(*    LABRI, URA CNRS 1304,                                                 *)
(*    Departement d'Informatique, Universite Bordeaux I,                    *)
(*    33405 Talence CEDEX,                                                  *)
(*    e-mail:  casteran@labri.u-bordeaux.fr                                 *)

(* the trivial monoid *)
Require Import monoid.
Require Import Plus.

Lemma trivial : monoid nat.
refine (mkmonoid nat 0 plus _ _ _); auto with arith.
(*
 Realizer (mkmonoid nat O plus).
 Program_all.
*)
Defined.

Lemma obsolete_debug : forall n : nat, power nat trivial n 1 = n.
 simpl in |- *; auto with arith.
Qed.


Require Export heap.
Require Export Omega.
Require Export hetList.
Require Export Coq.Program.Equality.

(*evaluation context decomposition*)
Inductive decompose : term -> ctxt -> term -> Prop :=
|decompApp : forall e1 e2 E e, decompose e1 E e ->
                               decompose (app e1 e2) (appCtxt e2 E) e
|decompAppVal : forall v e2 E e (prf:value v),
                  decompose e2 E e -> decompose (app v e2) (appValCtxt v prf E) e
|appHole : forall e v, value v -> decompose (app (lambda e) v) hole (app (lambda e) v)
|decompGet : forall e E e', decompose e E e' ->
                            decompose (get e) (getCtxt E) e'
|decompGetHole : forall l, decompose (get (loc l)) hole (get (loc l))
|decompPut : forall e1 e2 E e, decompose e1 E e ->
                               decompose (put e1 e2) (putCtxt e2 E) e
|decompPutVal : forall v e2 E e (prf:value v),
                  decompose e2 E e ->
                  decompose (put v e2) (putValCtxt v prf E) e
|decompPutHole : forall n v, value v -> decompose (put (loc n) v) hole (put (loc n) v)
|decompAlloc : forall e E e', decompose e E e' ->
                              decompose (alloc e) (allocCtxt E) e'
|decompAllocHole : forall v, value v -> decompose (alloc v) hole (alloc v)
|decompAtomicHole : forall e, decompose (atomic e) hole (atomic e)
|decompFork : forall e, decompose (fork e) hole (fork e)
|decompInAtomic : forall e e' E, decompose e E e' ->
                            decompose (inatomic e) (inatomicCtxt E) e'
|decompInAtomicHole : forall v, value v -> decompose (inatomic v) hole (inatomic v).

(*values cannot be decomposed*)
Theorem decomposeValFalse : forall t E e, value t -> decompose t E e -> False.
Proof.
  intros t E e v d. inv d; try solve[inv v].
Qed.

(*proves that values cannot be decomposed*)
Ltac decompVal :=
  match goal with
      |H:value ?t, H':decompose ?t ?E ?e |- _ =>
       apply decomposeValFalse in H'; auto; inv H'
      |H:decompose (lambda ?e) ?E ?e' |- _ => inv H
      |H:decompose (loc ?l) ?E ?e |- _ => inv H
  end.

(*inverts a decomposition nested inside another*)
Ltac invertDecomp :=
  match goal with
      |H:decompose (app ?e1 ?e2) ?E ?e |- _ => inv H
      |H:decompose (get ?e) ?E ?e' |- _ => inv H
      |H:decompose (put ?e1 ?e2) ?E ?e |- _ => inv H
      |H:decompose (alloc ?e) ?E ?e' |- _ => inv H
      |H:decompose (fork ?e) ?E ?e' |- _ => inv H
      |H:decompose (inatomic ?e) ?E ?E' |- _ => inv H
  end.

(*evaluation context decomposition is deterministic*)
Theorem decomposeDeterministic : forall t E E' e e',
                                   decompose t E e -> decompose t E' e' ->
                                   E = E' /\ e = e'.
Proof.
  intros t E E' e e' HD1 HD2. genDeps {{ E'; e'}}.
  induction HD1; intros; try(invertDecomp; try decompVal); try solve[auto |
  match goal with
    |H:forall e'0 E', decompose ?e E' e'0 -> ?E = E' /\ ?e' = e'0,
     H':decompose ?e ?E'' ?e'' |- _ =>  apply H in H'; invertHyp; eauto; try (proofsEq; eauto)
  end].
  inv HD2. eauto.
Qed.

(*proves that the results of the same decomposition are the same*)
Ltac decompSame :=
  match goal with
      |H:decompose ?t ?E ?e,H':decompose ?t ?E' ?e' |- _ =>
       eapply decomposeDeterministic in H; eauto; invertHyp
  end.

(*fill an evaluation context*)
Fixpoint fill (E:ctxt) (e:term) :=
  match E with
      |appCtxt e' E => app (fill E e) e'
      |appValCtxt v _ E => app v (fill E e)
      |getCtxt E => get (fill E e)
      |putCtxt e' E => put (fill E e) e'
      |putValCtxt v _ E => put v (fill E e)
      |allocCtxt E => alloc (fill E e)
      |inatomicCtxt E => inatomic (fill E e)
      |hole => e
  end.

(*
commit H ==> indicates the log is valid and H contains the new writes from the log
abort e L ==> log was invalid, resume execution at term e with log L
*)
Inductive validateRes : Type :=
|commit : heap -> validateRes
|abort : term -> log -> validateRes.

(*Transactional log validation*)
Inductive validate : stamp -> log -> heap -> stamp -> validateRes -> Prop :=
|validateNil : forall S S' H, validate S nil H S' (commit H)
|validateCommitRead : forall S S' S'' l v E H H' L,
                        lookup H l = Some(v, S') -> S > S' ->
                        validate S L H S'' (commit H') ->
                        validate S (readItem l E v::L) H S'' (commit H')
|validateAbortPropogate : forall S S' L H x L' e,
                            validate S L H S' (abort e L') ->
                            validate S (x::L) H S' (abort e L')
|validateAbortRead : forall S S' S'' H L E H' l v v',
              validate S L H S'' (commit H') -> lookup H l = Some(v, S') ->
              S' > S -> validate S (readItem l E v'::L) H S''
                                (abort (fill E(get(loc l))) L)
|validateWrite : forall S S' L H H' l v,
                   validate S L H S' (commit H') ->
                   validate S (writeItem l v::L) H S' (commit ((l, v, S')::H'))
.

(*lookup a term in a thread's write set*)
Fixpoint logLookup (L:log) (l:location) :=
  match L with
      |readItem _ _ _::L' => logLookup L' l
      |writeItem l' v::L' => if eq_nat_dec l l'
                            then Some v
                            else logLookup L' l
      |nil => None
  end.

Fixpoint open (e:term) (k:nat) (e':term) :=
  match e with
      |lambda e => lambda (open e (S k) e')
      |loc l => loc l
      |unit => unit
      |var k' => if eq_nat_dec k k'
                then e'
                else var k'
      |app e1 e2 => app (open e1 k e') (open e2 k e')
      |get e => get (open e k e')
      |put e1 e2 => put (open e1 k e') (open e2 k e')
      |alloc e => alloc (open e k e')
      |fork e => fork (open e k e')
      |atomic e => atomic (open e k e')
      |inatomic e => inatomic (open e k e')
  end.

(*transactional step (used by both p_step and f_step)*)
Inductive trans_step (H:heap) : thread -> thread -> Prop :=
|t_readStep : forall S L E l t v e0 S',
                decompose t E (get (loc l)) -> logLookup L l = None ->
                lookup H l = Some(v, S') -> S > S' ->
                trans_step H (Some(S, e0), L, t)
                             (Some(S, e0), readItem l E v::L, fill E v)
|t_readInDomainStep : forall S l v L E t e0,
                      decompose t E (get (loc l)) -> logLookup L l = Some v ->
                      trans_step H (Some(S, e0), L, t) (Some(S, e0), L, fill E v)
|t_writeStep : forall S L E l v t,
               decompose t E (put (loc l) v) -> S <> None ->
               trans_step H (S, L, t) (S, writeItem l v::L, fill E unit)
|t_atomicIdemStep : forall E e t L S,
                     decompose t E (atomic e) -> S <> None ->
                     trans_step H (S, L, t) (S, L, fill E e)
|t_betaStep : forall L E e t v S,
              decompose t E (app (lambda e) v) -> S <> None ->
              trans_step H (S, L, t) (S, L, fill E (open e 0 v))
.

(*same as trans_step with addition of r_readStepInvalid*)
Inductive replay_step H : thread -> thread -> Prop :=
|r_readStepValid : forall S L E l t v e0 S',
                lookup H l = Some(v, S') -> S > S' ->
                decompose t E (get (loc l)) -> logLookup L l = None ->
                replay_step H (Some(S, e0), L, t) (Some(S, e0), readItem l E v::L, fill E v)
|r_readStepInvalid : forall S L E v' l t v e0 S',
                lookup H l = Some(v',S') -> S' >= S ->
                decompose t E (get (loc l)) -> logLookup L l = None ->
                replay_step H (Some(S, e0), L, t) (Some(S, e0), readItem l E v::L, fill E v)
|r_readInDomainStep : forall S l v L E t e0,
                      decompose t E (get (loc l)) -> logLookup L l = Some v ->
                      replay_step H (Some(S, e0), L, t) (Some(S, e0), L, fill E v)
|r_writeStep : forall S L E l v t,
               decompose t E (put (loc l) v) -> S <> None ->
               replay_step H (S, L, t) (S, writeItem l v::L, fill E unit)
|r_atomicIdemStep : forall E e t L S,
                     decompose t E (atomic e) -> S <> None ->
                     replay_step H (S, L, t) (S, L, fill E e)
|r_betaStep : forall L E e t v S,
              decompose t E (app (lambda e) v) -> S <> None ->
              replay_step H (S, L, t) (S, L, fill E (open e 0 v))
.

(*reflexive transitive closure of replay_step*)
Inductive replay H : thread -> thread -> Prop :=
|replayRefl : forall t, replay H t t
|replayStep : forall t t' t'',
                replay_step H t t' -> replay H t' t'' ->
                replay H t t''.

(*left recursive version of replay*)
Inductive rewind H : thread -> thread -> Prop :=
|rewindRefl : forall t, rewind H t t
|rewindStep : forall t t' t'',
                rewind H t t' -> replay_step H t' t'' ->
                rewind H t t''.

(*parital abort STM semantics (single step)*)
Inductive p_step : nat -> heap -> pool -> nat -> heap -> pool -> Prop :=
|p_transStep : forall C H t t', trans_step H t t' ->
                           p_step C H (Single t) C H (Single t')
|p_parLStep : forall C H T1 T2 C' H' T1',
          p_step C H T1 C' H' T1' -> p_step C H (Par T1 T2) C' H' (Par T1' T2)
|p_parRStep : forall C H T1 T2 C' H' T2',
          p_step C H T2 C' H' T2' -> p_step C H (Par T1 T2) C' H' (Par T1 T2')
|p_forkStep : forall C H E e t,
              decompose t E (fork e) ->
              p_step C H (Single(None, nil, t)) C H
                   (Par (Single(None, nil, fill E unit)) (Single(None, nil, e)))
|p_eagerAbort : forall L S H L' C e0 e' t v E l S',
                  lookup H l = Some(v, S') -> S < S' ->
                  validate S (readItem l E v::L) H C (abort e' L') ->
                  decompose t E (get (loc l)) -> logLookup L l = None ->
                  p_step C H (Single (Some(S, e0), L, t))
                         (C+1) H (Single(Some(C, e0), L', e'))
|p_abortStep : forall L S H L' C e e0 e' S',
           validate S L H S' (abort e' L') ->
           p_step C H (Single(Some(S, e0), L, e))
                  (plus 1 C) H (Single(Some(C, e0), L', e'))
|p_allocStep : forall C H v E t l,
               lookup H l = None -> decompose t E (alloc v) ->
               p_step C H (Single(None, nil, t)) (plus 1 C) ((l, v, C)::H)
                    (Single(None, nil, fill E (loc l)))
|p_commitStep : forall C H S L v t E H' e0,
                validate S L H C (commit H') -> decompose t E (inatomic v) ->
                p_step C H (Single(Some(S, e0), L, t)) (plus 1 C) H' (Single(None, nil, fill E v))
|p_atomicStep : forall C H E e t,
                decompose t E (atomic e) ->
                p_step C H (Single(None, nil, t)) (plus 1 C) H
                       (Single(Some(C, fill E(inatomic e)),[],fill E (inatomic e)))
|p_betaStep : forall C H E e t v,
              decompose t E (app (lambda e) v) ->
              p_step C H (Single(None, nil, t)) C H
                     (Single(None, nil, fill E (open e 0 v))).

(*reflexive transitive closure of partial multistep*)
Inductive p_multistep : nat -> heap -> pool -> nat -> heap -> pool -> Prop :=
|p_multi_refl : forall C H T, p_multistep C H T C H T
|p_multi_step : forall C H T C' H' T' C'' H'' T'',
                p_step C H T C' H' T' -> p_multistep C' H' T' C'' H'' T'' ->
                p_multistep C H T C'' H'' T''.

(*full abort STM semantics (single step)*)
Inductive f_step : nat -> heap -> pool -> nat -> heap -> pool -> Prop :=
|f_transStep : forall C H t t', trans_step H t t' ->
                           f_step C H (Single t) C H (Single t')
|f_parLStep : forall C H T1 T2 C' H' T1',
          f_step C H T1 C' H' T1' -> f_step C H (Par T1 T2) C' H' (Par T1' T2)
|f_parRStep : forall C H T1 T2 C' H' T2',
          f_step C H T2 C' H' T2' -> f_step C H (Par T1 T2) C' H' (Par T1 T2')
|f_forkStep : forall C H E e t,
              decompose t E (fork e) ->
              f_step C H (Single(None, nil, t)) C H
                   (Par (Single(None, nil, fill E unit)) (Single(None, nil, e)))
|f_eagerAbort : forall L S H L' C e0 e' t v E l S',
                  lookup H l = Some(v, S') -> S < S' ->
                  validate S (readItem l E v::L) H C (abort e' L') ->
                  decompose t E (get (loc l)) -> logLookup L l = None ->
                  f_step C H (Single (Some(S, e0), L, t))
                         (C+1) H (Single(Some(C, e0), nil, e0))
|f_abortStep : forall L S H L' C e e0 e' S',
           validate S L H S' (abort e' L') ->
           f_step C H (Single(Some(S, e0), L, e)) (plus 1 C) H
                  (Single(Some(C, e0), nil, e0))
|f_allocStep : forall C H v E t l,
               lookup H l = None -> decompose t E (alloc v) ->
               f_step C H (Single(None, nil, t)) (plus 1 C) ((l, v, C)::H)
                    (Single(None, nil, fill E (loc l)))
|f_commitStep : forall C H S L v t E H' e0,
                validate S L H C (commit H') -> decompose t E (inatomic v) ->
                f_step C H (Single(Some(S, e0), L, t)) (plus 1 C) H' (Single(None, nil, fill E v))
|f_atomicStep : forall C H E e t,
                decompose t E (atomic e) ->
                f_step C H (Single(None, nil, t)) (plus 1 C) H
                       (Single(Some(C, fill E (inatomic e)), nil, fill E (inatomic e)))
|f_betaStep : forall C H E e t v,
              decompose t E (app (lambda e) v) ->
              f_step C H (Single(None, nil, t)) C H
                     (Single(None, nil, fill E (open e 0 v))).

(*reflexivie transitive closure of full multistep*)
Inductive f_multistep : nat -> heap -> pool -> nat -> heap -> pool -> Prop :=
|f_multi_refl : forall C H T, f_multistep C H T C H T
|f_multi_step : forall C H T C' H' T' C'' H'' T'',
                f_step C H T C' H' T' -> f_multistep C' H' T' C'' H'' T'' ->
                f_multistep C H T C'' H'' T''.

(*reflexivit transitive closure of trans_step*)
Inductive trans_multistep H : thread -> thread -> Prop :=
|trans_refl : forall t, trans_multistep H t t
|trans_multi_step : forall t t' t'',
                      trans_step H t t' -> trans_multistep H t' t'' ->
                      trans_multistep H t t''.

(*indicates that L1 is a postfix of L2*)
Definition postfix {A:Type} (L1 L2 : list A) := exists diff, L2 = diff ++ L1.

(*all threads can rewind to their initial term of a transaction and have
**a stamp number less than the global clock.  The stamp number
**constraint probably doesn't belong here, but its handy to have*)
Inductive poolRewind C H : pool -> Prop :=
|rewindSingleNoTX : forall e, poolRewind C H (Single(None,nil,e))
|rewindSingleInTX : forall S e0 L e,
                      rewind H (Some(S,e0),nil,e0) (Some(S,e0),L,e) ->
                      S < C -> poolRewind C H (Single(Some(S,e0),L,e))
|rewindPar : forall T1 T2, poolRewind C H T1 -> poolRewind C H T2 -> poolRewind C H (Par T1 T2).

(*inject every step in a multistep derivation into a Par*)
Theorem f_multi_L : forall C H T1 T2 T1' C' H',
                      f_multistep C H T1 C' H' T1' ->
                      f_multistep C H (Par T1 T2) C' H' (Par T1' T2).
Proof.
  intros C H T1 T2 T1' C' H' HYP. induction HYP.
  {constructor. }
  {econstructor. eapply f_parLStep. eassumption. eassumption. }
Qed.

(*inject every step in a multistep derivation into a Par*)
Theorem f_multi_R : forall C H T1 T2 T2' C' H',
                      f_multistep C H T2 C' H' T2' ->
                      f_multistep C H (Par T1 T2) C' H' (Par T1 T2').
Proof.
  intros C H T1 T2 T2' C' H' HYP. induction HYP.
  {constructor. }
  {econstructor. eapply f_parRStep. eassumption. eassumption. }
Qed.

(*validation is idempotent*)
Theorem validateValidate : forall S L H S' L' e,
                             validate S L H S' (abort e L') ->
                             exists H'', validate S L' H S' (commit H'').
Proof.
  intros S L H S' L' e HYP. dependent induction HYP; eauto.
Qed.

(*the log returned in an abort is a postfix of the initial log*)
Theorem abortLogPostfix : forall S L H S' L' e,
                            validate S L H S' (abort e L') ->
                            postfix L' L.
Proof.
  intros S L H S' L' e HYP. remember (abort e L'). induction HYP; try solveByInv.
  {apply IHHYP in Heqv. unfold postfix in *. invertHyp.  exists (x::x0). auto. }
  {inv Heqv. unfold postfix. exists [readItem l E v']. auto. }
Qed.

(*filling an evaluation context with the result of a decomposition
**yields the initial term that was decomposed *)
Theorem decomposeEq : forall E t e, decompose t E e -> t = fill E e.
Proof.
  induction E; intros; try solve[inv H; simpl;erewrite <- IHE; eauto].
  {inv H; auto. }
Qed.

Theorem lengthsEq : forall (A:Type) (x y : list A), x = y -> length x = length y.
Proof.
  induction x; intros.
  {destruct y. auto. inv H. }
  {destruct y. inv H. inv H. simpl. apply f_equal. auto. }
Qed.

(*replay relation is transitive*)
Theorem trans_replay: forall H t t' t'',
                         replay H t' t'' -> replay H t t' ->
                         replay H t t''.
Proof.
  intros H t t' t'' HYP1 HYP2. induction HYP2. auto. econstructor. eauto. auto.
Qed.

(*rewind relation is transitive*)
Theorem rewindTrans : forall H t t' t'',
                        rewind H t t' -> rewind H t' t'' ->
                        rewind H t t''.
Proof.
  intros H t t' t'' HYP1 HYP2. generalize dependent t. induction HYP2; intros; auto.
  econstructor. eapply IHHYP2. assumption. assumption.
Qed.

(*replay and rewind are equivalent*)
Theorem rewindIFFReplay : forall H t t',
                            rewind H t t' <-> replay H t t'.
Proof.
  intros H t t'. split; intros HYP.
  {induction HYP. constructor. eapply trans_replay; eauto.
   econstructor. eauto. constructor. }
  {induction HYP. constructor. eapply rewindTrans; eauto.
   econstructor; eauto. constructor. }
Qed.

(*partial multistep relation is transitive*)
Theorem p_multi_trans : forall C H T C' H' T' C'' H'' T'',
                          p_multistep C H T C' H' T' ->
                          p_multistep C' H' T' C'' H'' T'' ->
                          p_multistep C H T C'' H'' T''.
Proof.
  intros C H T C' H' T' C'' H'' T'' HYP1 HYP2.
  induction HYP1; auto. econstructor; eauto.
Qed.

(*full multistep relation is transitive*)
Theorem f_multi_trans : forall C H T C' H' T' C'' H'' T'',
                          f_multistep C H T C' H' T' ->
                          f_multistep C' H' T' C'' H'' T'' ->
                          f_multistep C H T C'' H'' T''.
Proof.
  intros C H T C' H' T' C'' H'' T'' HYP1 HYP2.
  induction HYP1; auto. econstructor; eauto.
Qed.

(*inject left multistep derivation into a Par*)
Theorem p_multi_L : forall C H T1 T2 T1' C' H',
                      p_multistep C H T1 C' H' T1' ->
                      p_multistep C H (Par T1 T2) C' H' (Par T1' T2).
Proof.
  intros. induction H0.
  {constructor. }
  {econstructor. eapply p_parLStep. eassumption. eassumption. }
Qed.

(*inject right multistep derivation into a Par*)
Theorem p_multi_R : forall C H T1 T2 T2' C' H',
                      p_multistep C H T2 C' H' T2' ->
                      p_multistep C H (Par T1 T2) C' H' (Par T1 T2').
Proof.
  intros. induction H0.
  {constructor. }
  {econstructor. eapply p_parRStep. eassumption. eassumption. }
Qed.


Require Import MirrorCore.Lambda.ExprCore.

Require Import floyd_funcs.

Require Import ExtLib.Core.RelDec.
Require Import MirrorCore.TypesI.
Require Import ExtLib.Tactics.
Require Import ExtLib.Data.Fun.
(*Require Import progs.list_dt. *)
Require Import Coq.FSets.FMapPositive.

Inductive typ :=
| tyArr : typ -> typ -> typ
| tytycontext
| tyc_expr
| tyc_type
| tyenviron
| tyval
| tyshare
| tyident
| tylist : typ -> typ
| tyint
| tyZ
| tynat
| typositive
| tybool
| tycomparison
| tytc_assert
| tyint64
| tyfloat
| tyfloat32
| tyattr
| tysignedness
| tyintsize
| tyfloatsize
| tytypelist
| tyfieldlist
| tybinary_operation
| tyunary_operation
| tyN
| tyoption : typ -> typ
| typrop
| tympred
| tysum : typ -> typ -> typ
| typrod : typ -> typ -> typ
| tyunit
(*| tylistspec : type -> ident -> typ*)
| tyOracleKind
| tystatement
| tyret_assert
| tyexitkind
| typtree : typ -> typ
| tygfield
| tyfunspec
| tyefield
| tytype_id_env
| tyllrr
(*| tyother : positive -> typ*)
.

Fixpoint typD (t : typ) (*(m : PositiveMap.t Type)*): Type :=
    match t with
        | tyArr a b => typD a  -> typD b
        | tytycontext => tycontext
        | tyc_expr => expr
        | tyc_type => type
        | tyenviron => environ
        | tyval => val
        | tyshare => share
        | tyident => ident
        | tylist t => list (typD t )
        | tyint => int
        | tyZ => Z
        | tynat => nat
        | typositive => positive
        | tybool => bool
        | tycomparison => comparison
        | tytc_assert => tc_assert
        | tyint64 => int64
        | tyfloat => float
        | tyfloat32 => float32
        | tyattr => attr
        | tysignedness => signedness
        | tyintsize => intsize
        | tyfloatsize  => floatsize
        | tytypelist => typelist
        | tyfieldlist => fieldlist
        | tybinary_operation => Cop.binary_operation
        | tyunary_operation => Cop.unary_operation
        | tyN => N
        | tyoption t => option (typD t )
        | typrop => Prop
        | tympred => mpred
        | tysum t1 t2 => sum (typD  t1 ) (typD  t2 )
        | typrod t1 t2 => prod (typD  t1 ) (typD  t2 )
        | tyunit => unit
        (*| tylistspec t i => listspec t i *)
        | tyOracleKind => OracleKind
        | tystatement => statement
        | tyret_assert => ret_assert
(*        | tyother p => PositiveMap.find p m *)
        | tyexitkind => exitkind
        | typtree t => PTree.t (typD t)
        | tygfield => gfield
        | tyfunspec => funspec
        | tyefield => efield
        | tytype_id_env => type_id_env
        | tyllrr => LLRR
    end.
(*
Lemma listspec_ext : forall t i (a b: listspec t i), a = b.
intros. destruct a,b.
subst. inversion list_struct_eq0.
subst. f_equal.
apply proof_irr.
apply proof_irr.
apply proof_irr.
Qed.
*)

Definition typ_eq_dec : forall a b : typ, {a = b} + {a <> b}.
  decide equality.
Defined.
(*
  consider (eqb_ident i i0); intros;
  try rewrite eqb_ident_spec in H. auto.
  destruct (eqb_ident_spec i i0). right. intro. intuition. subst.
  congruence.
  consider (eqb_type t t0); intros.
  rewrite eqb_type_spec in H. auto.
  destruct (eqb_type_spec t t0).
  right; intuition; subst; congruence.
 Defined.
*)

Instance RelDec_eq_typ : RelDec (@eq typ) :=
{ rel_dec := fun a b =>
               match typ_eq_dec a b with
                 | left _ => true
                 | right _ => false
               end }.

Instance RelDec_Correct_eq_typ : RelDec_Correct RelDec_eq_typ.
Proof.
  constructor.
  intros.
  unfold rel_dec; simpl.
  destruct (typ_eq_dec x y); intuition.
Qed.

Inductive tyAcc' : typ -> typ -> Prop :=
| tyArrL : forall a b, tyAcc' a (tyArr a b)
| tyArrR : forall a b, tyAcc' b (tyArr a b).

Instance RType_typ : RType typ :=
{ typD := typD
; tyAcc := tyAcc'
; type_cast := fun a b => match typ_eq_dec a b with
                              | left pf => Some pf
                              | _ => None
                            end
}.

Instance RTypeOk_typ : @RTypeOk typ _.
Proof.
  eapply makeRTypeOk.
  { red.
    induction a; constructor; inversion 1.
    subst; auto.
    subst; auto. }
  { unfold type_cast; simpl.
    intros. destruct (typ_eq_dec x x).
    f_equal. compute.
    uip_all. reflexivity. congruence. }
  { unfold type_cast; simpl.
    intros. destruct (typ_eq_dec x y); try congruence. }
Qed.

Instance Typ2_tyArr : Typ2 _ Fun :=
{ typ2 := tyArr
; typ2_cast := fun  _ _ => eq_refl
; typ2_match :=
    fun T  t tr =>
      match t as t return T (TypesI.typD  t) -> T (TypesI.typD  t) with
        | tyArr a b => fun _ => tr a b
        | _ => fun fa => fa
      end
}.

Instance Typ2Ok_tyArr : Typ2Ok Typ2_tyArr.
Proof.
  constructor.
  { reflexivity. }
  { apply tyArrL. }
  { intros; apply tyArrR. }
  { inversion 1; subst; unfold Rty; auto. }
  { destruct x; simpl; eauto.
    left; do 2 eexists; exists eq_refl. reflexivity. }
  { destruct pf. reflexivity. }
Qed.

Instance Typ0_tyProp : Typ0 _ Prop :=
{| typ0 := typrop
 ; typ0_cast :=  eq_refl
 ; typ0_match := fun T  t =>
                   match t as t
                         return T Prop -> T (TypesI.typD  t) -> T (TypesI.typD  t)
                   with
                     | typrop => fun tr _ => tr
                     | _ => fun _ fa => fa
                   end
 |}.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ConstpropOp.
Require Import Constprop.

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable ge: genv.
Variable sp: val.

(** We first show that the dataflow analysis is correct with respect
  to the dynamic semantics: the approximations (sets of values)
  of a register at a program point predicted by the static analysis
  are a superset of the values actually encountered during concrete
  executions.  We formalize this correspondence between run-time values and
  compile-time approximations by the following predicate. *)

Definition val_match_approx (a: approx) (v: val) : Prop :=
  match a with
  | Unknown => True
  | I p => v = Vint p
  | F p => v = Vfloat p
  | L p => v = Vlong p
  | G symb ofs => v = symbol_address ge symb ofs
  | S ofs => v = Val.add sp (Vint ofs)
  | Novalue => False
  end.

Inductive val_list_match_approx: list approx -> list val -> Prop :=
  | vlma_nil:
      val_list_match_approx nil nil
  | vlma_cons:
      forall a al v vl,
      val_match_approx a v ->
      val_list_match_approx al vl ->
      val_list_match_approx (a :: al) (v :: vl).

Ltac SimplVMA :=
  match goal with
  | H: (val_match_approx (I _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (F _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (L _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (G _ _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | H: (val_match_approx (S _) ?v) |- _ =>
      simpl in H; (try subst v); SimplVMA
  | _ =>
      idtac
  end.

Ltac InvVLMA :=
  match goal with
  | H: (val_list_match_approx nil ?vl) |- _ =>
      inv H
  | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ =>
      inv H; SimplVMA; InvVLMA
  | _ =>
      idtac
  end.

(** We then show that [eval_static_operation] is a correct abstract
  interpretations of [eval_operation]: if the concrete arguments match
  the given approximations, the concrete results match the
  approximations returned by [eval_static_operation]. *)

Lemma eval_static_condition_correct:
  forall cond al vl m b,
  val_list_match_approx al vl ->
  eval_static_condition cond al = Some b ->
  eval_condition cond vl m = Some b.
Proof.
  intros until b.
  unfold eval_static_condition.
  case (eval_static_condition_match cond al); intros;
  InvVLMA; simpl; congruence.
Qed.

Remark shift_symbol_address:
  forall symb ofs n,
  symbol_address ge symb (Int.add ofs n) = Val.add (symbol_address ge symb ofs) (Vint n).
Proof.
  unfold symbol_address; intros. destruct (Genv.find_symbol ge symb); auto.
Qed.

Lemma eval_static_addressing_correct:
  forall addr al vl v,
  val_list_match_approx al vl ->
  eval_addressing ge sp addr vl = Some v ->
  val_match_approx (eval_static_addressing addr al) v.
Proof.
  intros until v. unfold eval_static_addressing.
  case (eval_static_addressing_match addr al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  rewrite shift_symbol_address; auto.
  rewrite Val.add_assoc. auto.
  repeat rewrite shift_symbol_address. auto.
  fold (Val.add (Vint n1) (symbol_address ge id ofs)).
  repeat rewrite shift_symbol_address. repeat rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  repeat rewrite Val.add_assoc. decEq; simpl. rewrite Int.add_assoc. auto.
  fold (Val.add (Vint n1) (Val.add sp (Vint ofs))).
  rewrite Val.add_assoc. rewrite Val.add_permut. rewrite Val.add_assoc.
  simpl. rewrite Int.add_assoc; auto.
  rewrite shift_symbol_address. auto.
  rewrite Val.add_assoc. auto.
  rewrite shift_symbol_address. auto.
  rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
Qed.

Lemma eval_static_operation_correct:
  forall op al vl m v,
  val_list_match_approx al vl ->
  eval_operation ge sp op vl m = Some v ->
  val_match_approx (eval_static_operation op al) v.
Proof.
  intros until v.
  unfold eval_static_operation.
  case (eval_static_operation_match op al); intros;
  InvVLMA; simpl in *; FuncInv; try subst v; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  rewrite Int.sub_add_opp. rewrite shift_symbol_address. rewrite Val.sub_add_opp. auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero). inv H0.
    destruct (Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone); inv H0; simpl; auto.
  destruct (Int.eq n2 Int.zero); inv H0; simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n (Int.repr 31)); inv H0. simpl; auto.
  destruct (Int.ltu n2 Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize); simpl; auto.
  destruct (Int.ltu n Int.iwordsize);
  destruct (Int.ltu (Int.sub Int.iwordsize n) Int.iwordsize); simpl; auto.
  eapply eval_static_addressing_correct; eauto.
  unfold eval_static_intoffloat.
  destruct (Float.intoffloat n1) eqn:?; simpl in H0; inv H0.
  simpl; auto.
  destruct (propagate_float_constants tt); simpl; auto.
  unfold eval_static_condition_val. destruct (eval_static_condition c vl0) as [b|] eqn:?.
  rewrite (eval_static_condition_correct _ _ _ m _ H Heqo).
  destruct b; simpl; auto.
  simpl; auto.
Qed.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable app: D.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: forall r, val_match_approx (approx_reg app r) rs#r.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = approx_reg app ?r |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = approx_regs app args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite H0. apply Val.swap_cmp_bool.
  rewrite H. auto.
  rewrite H0. apply Val.swap_cmpu_bool.
  rewrite H. auto.
  auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl,
  vl = approx_regs app args ->
  let (addr', args') := addr_strength_reduction addr args vl in
  eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args.
Proof.
  intros until vl. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl; intros; InvApproxRegs; SimplVMA.
  rewrite shift_symbol_address; congruence.
  rewrite H. rewrite Val.add_assoc; auto.
  rewrite H; rewrite H0. repeat rewrite shift_symbol_address. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. rewrite Int.add_permut. repeat rewrite shift_symbol_address.
  rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Int.add_assoc. auto.
  rewrite H; rewrite H0. repeat rewrite Val.add_assoc. rewrite Val.add_permut.
  rewrite Int.add_assoc. auto.
  rewrite H0. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  decEq; decEq. apply Val.add_commut.
  rewrite H. rewrite shift_symbol_address. repeat rewrite Val.add_assoc.
  rewrite (Val.add_permut (rs#r1)). decEq; decEq. apply Val.add_commut.
  rewrite H0. rewrite Val.add_assoc. rewrite Val.add_permut. auto.
  rewrite H. rewrite Val.add_assoc. auto.
  rewrite H; rewrite H0. rewrite Int.add_assoc. repeat rewrite shift_symbol_address. auto.
  rewrite H0. rewrite shift_symbol_address. rewrite Val.add_assoc. decEq; decEq. apply Val.add_commut.
  rewrite H. auto.
  rewrite H. rewrite shift_symbol_address. auto.
  rewrite H. rewrite shift_symbol_address. rewrite Int.mul_commut; auto.
  auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1,
  let (op, args) := make_shlimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  econstructor; split. simpl. eauto. auto.
Qed.

Lemma make_shrimm_correct:
  forall n r1,
  let (op, args) := make_shrimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  econstructor; split; eauto. simpl. auto.
Qed.

Lemma make_shruimm_correct:
  forall n r1,
  let (op, args) := make_shruimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1,
  let (op, args) := make_mulimm n r1 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). apply make_shlimm_correct; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  replace v with (Val.shru rs#r1 (Vint i)).
  eapply make_shruimm_correct; eauto.
  eapply Val.divu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_moduimm_correct:
  forall n r1 r2 v,
  Val.modu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_moduimm n r1 r2 in
  exists w, eval_operation ge sp op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_moduimm.
  destruct (Int.is_power2 n) eqn:?.
  exists v; split; auto. simpl. decEq. eapply Val.modu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r,
  let (op, args) := make_andimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_mulfimm_correct:
  forall n r1 r2,
  rs#r2 = Vfloat n ->
  let (op, args) := make_mulfimm n r1 r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r1); simpl; auto. rewrite Float.mul2_add; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_mulfimm_correct_2:
  forall n r1 r2,
  rs#r1 = Vfloat n ->
  let (op, args) := make_mulfimm n r2 r1 r2 in
  exists v, eval_operation ge sp op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r2); simpl; auto. rewrite Float.mul2_add; auto.
  rewrite Float.mul_commut; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = approx_regs app args ->
  eval_operation ge sp op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge sp op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* sub *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. rewrite Val.sub_add_opp. apply make_addimm_correct; auto.
(* mul *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H1. rewrite Val.mul_commut. apply make_mulimm_correct; auto.
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_divuimm_correct; auto.
(* modu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVMA; auto.
  apply make_moduimm_correct; auto.
(* and *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H1. rewrite Val.and_commut. apply make_andimm_correct; auto.
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_andimm_correct; auto.
(* or *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H1. rewrite Val.or_commut. apply make_orimm_correct; auto.
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_orimm_correct; auto.
(* xor *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H1. rewrite Val.xor_commut. apply make_xorimm_correct; auto.
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_xorimm_correct; auto.
(* shl *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs. SimplVMA. inv H0; rewrite H. apply make_shruimm_correct; auto.
(* lea *)
  generalize (addr_strength_reduction_correct addr args0 vl0 H).
  destruct (addr_strength_reduction addr args0 vl0) as [addr' args'].
  intro EQ. exists v; split; auto. simpl. congruence.
(* cond *)
  generalize (cond_strength_reduction_correct c args0 vl0 H).
  destruct (cond_strength_reduction c args0 vl0) as [c' args']; intros.
  rewrite <- H1 in H0; auto. econstructor; split; eauto.
(* mulf *)
  inv H0. assert (rs#r2 = Vfloat n2). InvApproxRegs; SimplVMA; auto.
  apply make_mulfimm_correct; auto.
  inv H0. assert (rs#r1 = Vfloat n1). InvApproxRegs; SimplVMA; auto.
  apply make_mulfimm_correct_2; auto.
(* default *)
  exists v; auto.
Qed.

End STRENGTH_REDUCTION.

End ANALYSIS.