(****************************************************************************

          IEEE754  :  FroundProp

          Laurent Thery, Sylvie Boldo

  ******************************************************************************)
Require Export Fround.
Require Export MSB.
Section FRoundP.
Variable b : Fbound.
Variable radix : Z.
Variable precision : nat.

Let FtoRradix := FtoR radix.
Coercion FtoRradix : float >-> R.
Hypothesis radixMoreThanOne : (1 < radix)%Z.

Let radixMoreThanZERO := Zlt_1_O _ (Zlt_le_weak _ _ radixMoreThanOne).
Hint Resolve radixMoreThanZERO: zarith.
Hypothesis precisionGreaterThanOne : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Definition Fulp (p : float) :=
  powerRZ radix (Fexp (Fnormalize radix b precision p)).

Theorem FulpComp :
 forall p q : float,
 Fbounded b p -> Fbounded b q -> p = q :>R -> Fulp p = Fulp q.
intros p q H' H'0 H'1; unfold Fulp in |- *.
rewrite
 FcanonicUnique
                with
                (p := Fnormalize radix b precision p)
               (q := Fnormalize radix b precision q)
               (3 := pGivesBound); auto with float arith.
apply trans_eq with (FtoR radix p).
apply FnormalizeCorrect; auto.
apply trans_eq with (FtoR radix q); auto.
apply sym_eq; apply FnormalizeCorrect; auto.
Qed.

Theorem FulpLe :
 forall p : float, Fbounded b p -> (Fulp p <= Float 1 (Fexp p))%R.
intros p H'; unfold Fulp, FtoRradix, FtoR, Fnormalize in |- *; simpl in |- *;
 rewrite Rmult_1_l.
case (Z_zerop (Fnum p)); simpl in |- *; auto.
intros H'0; apply (Rle_powerRZ radix (- dExp b) (Fexp p));
 auto with float real zarith.
intros H'0; apply Rle_powerRZ; auto with real zarith arith.
Qed.

Theorem Fulp_zero :
 forall x : float, is_Fzero x -> Fulp x = powerRZ radix (- dExp b).
intros x; unfold is_Fzero, Fulp, Fnormalize in |- *; case (Z_zerop (Fnum x));
 simpl in |- *; auto.
intros H' H'0; Contradict H'; auto.
Qed.

Theorem FulpLe2 :
 forall p : float,
 Fbounded b p ->
 Fnormal radix b (Fnormalize radix b precision p) ->
 (Fulp p <= Rabs p * powerRZ radix (Zsucc (- precision)))%R.
intros p H1 H2; unfold Fulp in |- *.
replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p));
 [ idtac | unfold FtoRradix in |- *; apply FnormalizeCorrect; auto ].
apply Rmult_le_reg_l with (powerRZ radix (Zpred precision)).
apply powerRZ_lt; auto with real arith.
replace
 (powerRZ radix (Zpred precision) *
  (Rabs (Fnormalize radix b precision p) *
   powerRZ radix (Zsucc (- precision))))%R with
 (Rabs (Fnormalize radix b precision p)).
unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with arith real.
unfold Fabs, FtoR in |- *; simpl in |- *.
apply Rmult_le_compat_r; [ apply powerRZ_le | rewrite <- inj_pred ];
 auto with real arith zarith.
rewrite <- Zpower_nat_Z_powerRZ.
replace (Zpower_nat radix (pred precision)) with (nNormMin radix precision);
 auto; apply Rle_IZR.
apply pNormal_absolu_min with b; auto with arith zarith real.
apply
 trans_eq
  with
    (Rabs (Fnormalize radix b precision p) *
     (powerRZ radix (Zpred precision) * powerRZ radix (Zsucc (- precision))))%R;
 [ idtac | ring ].
rewrite <- powerRZ_add; auto with zarith real.
replace (Zpred precision + Zsucc (- precision))%Z with 0%Z;
 [ simpl in |- *; ring | unfold Zsucc, Zpred in |- *; ring ];
 auto with real zarith.
Qed.

Theorem FulpGe :
 forall p : float,
 Fbounded b p -> (Rabs p <= (powerRZ radix precision - 1) * Fulp p)%R.
intros p H.
replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p));
 [ idtac | unfold FtoRradix in |- *; apply FnormalizeCorrect; auto ].
unfold FtoRradix in |- *; rewrite <- Fabs_correct; auto with arith real.
unfold FtoR in |- *; simpl in |- *; unfold Fulp in |- *.
apply Rmult_le_compat_r; [ apply powerRZ_le | idtac ];
 auto with real arith zarith.
apply Rle_trans with (IZR (Zpred (Zpos (vNum b))));
 [ apply Rle_IZR; auto with float zarith | idtac ].
unfold Zpred in |- *; right; rewrite pGivesBound; replace 1%R with (IZR 1);
 auto with real.
rewrite <- Zpower_nat_Z_powerRZ; rewrite Z_R_minus;auto.
Qed.

Theorem LeFulpPos :
 forall x y : float,
 Fbounded b x ->
 Fbounded b y -> (0 <= x)%R -> (x <= y)%R -> (Fulp x <= Fulp y)%R.
intros x y Hx Hy H1 H2; unfold Fulp in |- *.
apply Rle_powerRZ; auto with real zarith.
apply Fcanonic_Rle_Zle with radix b precision; auto with zarith arith.
apply FnormalizeCanonic; auto with zarith arith.
apply FnormalizeCanonic; auto with zarith arith.
repeat rewrite FnormalizeCorrect; auto with zarith arith real.
repeat rewrite Rabs_right; auto with zarith arith real.
apply Rge_trans with (FtoRradix x); auto with real.
Qed.

Theorem FulpSucCan :
 forall p : float,
 Fcanonic radix b p -> (FSucc b radix precision p - p <= Fulp p)%R.
intros p H'.
replace (Fulp p) with (powerRZ radix (Fexp p)).
2: unfold Fulp in |- *; replace (Fnormalize radix b precision p) with p; auto;
    apply sym_equal; apply FcanonicUnique with (3 := pGivesBound);
    auto with arith; apply FnormalizeCanonic || apply FnormalizeCorrect;
    auto with float zarith.
2: apply FcanonicBound with (1 := H'); auto with float zarith.
unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with zarith.
case (Z_eq_dec (Fnum p) (- nNormMin radix precision)); intros H1'.
case (Z_eq_dec (Fexp p) (- dExp b)); intros H2'.
rewrite FSuccDiff2; auto with arith.
unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real.
rewrite FSuccDiff3; auto with arith.
unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l.
apply Rlt_le; apply Rlt_powerRZ; auto with real zarith.
unfold Zpred in |- *; auto with zarith.
rewrite FSuccDiff1; auto with arith.
unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real.
Qed.

Theorem FulpSuc :
 forall p : float,
 Fbounded b p -> (FNSucc b radix precision p - p <= Fulp p)%R.
intros p H'.
replace (Fulp p) with (Fulp (Fnormalize radix b precision p)).
replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)).
unfold FNSucc in |- *; apply FulpSucCan; auto with float arith.
unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
apply FulpComp; auto with float arith.
unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
Qed.

Theorem FulpPredCan :
 forall p : float,
 Fcanonic radix b p -> (p - FPred b radix precision p <= Fulp p)%R.
intros p H'.
replace (Fulp p) with (powerRZ radix (Fexp p)).
2: unfold Fulp in |- *; replace (Fnormalize radix b precision p) with p; auto;
    apply sym_equal; apply FcanonicUnique with (3 := pGivesBound);
    auto with arith; apply FnormalizeCanonic || apply FnormalizeCorrect;
    auto with arith.
unfold FtoRradix in |- *; rewrite <- Fminus_correct; auto with arith.
case (Z_eq_dec (Fnum p) (nNormMin radix precision)); intros H1'.
case (Z_eq_dec (Fexp p) (- dExp b)); intros H2'.
rewrite FPredDiff2; auto with arith.
unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real.
rewrite FPredDiff3; auto with arith.
unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real.
apply Rlt_le; apply Rlt_powerRZ; auto with real zarith.
replace 1%R with (INR 1); auto with real arith.
unfold Zpred in |- *; auto with zarith.
rewrite FPredDiff1; auto with arith.
unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real.
apply FcanonicBound with (1 := H').
Qed.

Theorem FulpPred :
 forall p : float,
 Fbounded b p -> (p - FNPred b radix precision p <= Fulp p)%R.
intros p H'.
replace (Fulp p) with (Fulp (Fnormalize radix b precision p)).
replace (FtoRradix p) with (FtoRradix (Fnormalize radix b precision p)).
unfold FNPred in |- *; apply FulpPredCan; auto with float arith.
unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
apply FulpComp; auto with float arith.
unfold FtoRradix in |- *; apply FnormalizeCorrect; auto.
Qed.

Theorem FSuccDiffPos :
 forall x : float,
 (0 <= x)%R ->
 Fminus radix (FSucc b radix precision x) x = Float 1%nat (Fexp x) :>R.
intros x H.
unfold FtoRradix in |- *; apply FSuccDiff1; auto with arith.
Contradict H; unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite H.
apply Rlt_not_le.
replace 0%R with (0 * powerRZ radix (Fexp x))%R; [ idtac | ring ].
apply Rlt_monotony_exp; auto with real arith.
generalize (nNormPos _ radixMoreThanOne precision);
 replace 0%R with (IZR (- 0%nat)); auto with real zarith arith.
Qed.

Theorem FulpFPredGePos :
 forall f : float,
 Fbounded b f ->
 Fcanonic radix b f ->
 (0 < f)%R -> (Fulp (FPred b radix precision f) <= Fulp f)%R.
intros f Hf1 Hf2 H.
apply LeFulpPos; auto with zarith float; unfold FtoRradix in |- *.
apply R0RltRlePred; auto with arith.
apply Rlt_le; apply FPredLt; auto with arith.
Qed.

Theorem CanonicFulp :
 forall p : float, Fcanonic radix b p -> Fulp p = Float 1%nat (Fexp p).
intros p H; unfold Fulp in |- *.
rewrite FcanonicFnormalizeEq; auto with arith.
unfold FtoRradix, FtoR in |- *; simpl in |- *; ring.
Qed.

Theorem FSuccUlpPos :
 forall x : float,
 Fcanonic radix b x ->
 (0 <= x)%R -> Fminus radix (FSucc b radix precision x) x = Fulp x :>R.
intros x H H0; rewrite CanonicFulp; auto.
apply FSuccDiffPos; auto.
Qed.

Theorem FNSuccUlpPos :
 forall x : float,
 Fcanonic radix b x ->
 (0 <= x)%R -> Fminus radix (FNSucc b radix precision x) x = Fulp x :>R.
intros x H H0.
unfold FNSucc in |- *.
rewrite FcanonicFnormalizeEq; auto with arith.
apply FSuccUlpPos; auto.
Qed.

Theorem FulpFabs : forall f : float, Fulp f = Fulp (Fabs f) :>R.
intros f; unfold Fulp in |- *; case (Rle_or_lt 0 f); intros H'.
replace (Fabs f) with f; auto; unfold Fabs in |- *; apply floatEq;
 simpl in |- *; auto with zarith real.
apply sym_eq; apply Zabs_eq; apply LeR0Fnum with radix; auto with zarith real.
replace (Fabs f) with (Fopp f);
 [ rewrite Fnormalize_Fopp | apply floatEq; simpl in |- * ];
 auto with arith.
apply sym_eq; apply Zabs_eq_opp; apply R0LeFnum with radix;
 auto with zarith real.
Qed.

Theorem RoundedModeUlp :
 forall P,
 RoundedModeP b radix P ->
 forall (p : R) (q : float), P p q -> (Rabs (p - q) < Fulp q)%R.
intros P H' p q H'0.
case (Req_dec p q); intros Eq1.
rewrite <- Eq1.
replace (p - p)%R with 0%R; [ idtac | ring ].
rewrite Rabs_R0; auto.
unfold Fulp, FtoRradix, FtoR in |- *; simpl in |- *; auto with real arith.
case H'.
intros H'1 H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6;
 case H'5 with (1 := H'0); clear H'5 H'4 H'2; intros H'5.
rewrite Rabs_right; auto.
cut (Fbounded b q); [ intros B0 | case H'5; auto ].
apply Rlt_le_trans with (2 := FulpSuc q B0).
apply Rplus_lt_reg_l with (r := FtoR radix q).
repeat rewrite Rplus_minus; auto.
case (Rle_or_lt (FNSucc b radix precision q) p); auto.
intros H'2; absurd (FNSucc b radix precision q <= q)%R; auto.
apply Rgt_not_le; red in |- *; unfold FtoRradix in |- *;
 auto with real float arith.
case H'5; auto.
intros H'4 H'7; elim H'7; intros H'8 H'9; apply H'9; clear H'7; auto.
apply (FcanonicBound radix b); auto with float arith.
apply Rle_ge; apply Rplus_le_reg_l with (r := FtoR radix q).
repeat rewrite Rplus_minus; auto.
rewrite Rplus_0_r; apply isMin_inv1 with (1 := H'5); auto.
rewrite Faux.Rabsolu_left1; auto.
rewrite Ropp_minus_distr; auto.
cut (Fbounded b q); [ intros B0 | case H'5; auto ].
apply Rlt_le_trans with (2 := FulpPred q B0).
apply Ropp_lt_cancel; repeat rewrite Rminus_0_l.
apply Rplus_lt_reg_l with (r := FtoR radix q).
repeat rewrite Rplus_minus; auto.
case (Rle_or_lt p (FNPred b radix precision q)); auto.
intros H'2; absurd (q <= FNPred b radix precision q)%R; auto.
apply Rgt_not_le; red in |- *; unfold FtoRradix in |- *;
 auto with real float arith.
case H'5; auto.
intros H'4 H'7; elim H'7; intros H'8 H'9; apply H'9; clear H'7; auto.
apply (FcanonicBound radix b); auto with float arith.
intros H1; apply Rplus_lt_compat_l; auto with real; apply Ropp_lt_contravar;
 unfold Rminus in |- *; auto with real.
apply Rplus_le_reg_l with (r := FtoR radix q).
repeat rewrite Rplus_minus; auto.
rewrite Rplus_0_r; apply isMax_inv1 with (1 := H'5).
Qed.

Theorem RoundedModeErrorExpStrict :
 forall P,
 RoundedModeP b radix P ->
 forall (p q : float) (x : R),
 Fbounded b p ->
 Fbounded b q ->
 P x p -> q = (x - p)%R :>R -> q <> 0%R :>R -> (Fexp q < Fexp p)%Z.
intros P H p q x H0 H1 H2 H3 H4.
apply Zlt_powerRZ with (e := IZR radix); auto with real zarith.
apply Rle_lt_trans with (FtoRradix (Fabs q)).
replace (powerRZ radix (Fexp q)) with (FtoRradix (Float 1%nat (Fexp q)));
 unfold FtoRradix in |- *;
 [ apply Fop.RleFexpFabs; auto with arith
 | unfold FtoR in |- *; simpl in |- *; ring ].
rewrite (Fabs_correct radix); auto with zarith.
fold FtoRradix in |- *; rewrite H3.
apply Rlt_le_trans with (Fulp p);
 [ apply RoundedModeUlp with P; auto | unfold Fulp in |- * ].
apply Rle_powerRZ; auto with real zarith.
apply FcanonicLeastExp with radix b precision; auto with real arith.
apply sym_eq; apply FnormalizeCorrect; auto.
apply FnormalizeCanonic; auto with zarith.
Qed.

Theorem RoundedModeProjectorIdem :
 forall P (p : float), RoundedModeP b radix P -> Fbounded b p -> P p p.
intros P p H' H.
elim H'; intros H'0 H'1; elim H'1; intros H'2 H'3; elim H'3; intros H'4 H'5;
 clear H'3 H'1.
case (H'0 p).
intros x H'6.
apply (H'2 p p x); auto.
apply sym_eq; apply (RoundedProjector _ _ P H'); auto.
Qed.

Theorem RoundedModeBounded :
 forall P (r : R) (q : float),
 RoundedModeP b radix P -> P r q -> Fbounded b q.
intros P r q H' H'0.
case H'.
intros H'1 H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6;
 case H'5 with (1 := H'0); clear H'4 H'2; intros H;
 case H; auto.
Qed.

Theorem RoundedModeProjectorIdemEq :
 forall (P : R -> float -> Prop) (p q : float),
 RoundedModeP b radix P -> Fbounded b p -> P (FtoR radix p) q -> p = q :>R.
intros P p q H' H'0 H'1.
cut (MinOrMaxP b radix P);
 [ intros Mn; case (Mn p q); auto; intros Mn1 | auto with inv ].
apply sym_eq; apply MinEq with (1 := Mn1); auto.
apply (RoundedModeProjectorIdem (isMin b radix)); auto.
apply MinRoundedModeP with (precision := precision); auto.
apply sym_eq; apply MaxEq with (1 := Mn1); auto.
apply (RoundedModeProjectorIdem (isMax b radix)); auto.
apply MaxRoundedModeP with (precision := precision); auto.
Qed.

Theorem RoundedModeMult :
 forall P,
 RoundedModeP b radix P ->
 forall (r : R) (q q' : float),
 P r q -> Fbounded b q' -> (r <= radix * q')%R -> (q <= radix * q')%R.
intros P H' r q q' H'0 H'1.
replace (radix * q')%R with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat))).
intros H'2; case H'2.
intros H'3; case H'; intros H'4 H'5; elim H'5; intros H'6 H'7; elim H'7;
 intros H'8 H'9; apply H'9 with (1 := H'3); clear H'7 H'5;
 auto.
apply RoundedModeProjectorIdem; auto.
apply FBoundedScale; auto.
intros H'3.
replace (FtoRradix q) with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat)));
 auto with real.
apply (RoundedProjector _ _ P H'); auto.
apply FBoundedScale; auto.
case H'.
intros H'4 H'5; elim H'5; intros H'6 H'7; clear H'5.
apply (H'6 r (Float (Fnum q') (Fexp q' + 1%nat)) q); auto.
apply RoundedModeBounded with (P := P) (r := r); auto.
rewrite (FvalScale _ radixMoreThanOne b).
rewrite powerRZ_1; auto.
Qed.

Theorem RoundedModeMultLess :
 forall P,
 RoundedModeP b radix P ->
 forall (r : R) (q q' : float),
 P r q -> Fbounded b q' -> (radix * q' <= r)%R -> (radix * q' <= q)%R.
intros P H' r q q' H'0 H'1.
replace (radix * q')%R with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat))).
intros H'2; case H'2.
intros H'3; case H'; intros H'4 H'5; elim H'5; intros H'6 H'7; elim H'7;
 intros H'8 H'9; apply H'9 with (1 := H'3); clear H'7 H'5;
 auto.
apply RoundedModeProjectorIdem; auto.
apply FBoundedScale; auto.
intros H'3.
replace (FtoRradix q) with (FtoRradix (Float (Fnum q') (Fexp q' + 1%nat)));
 auto with real.
apply (RoundedProjector _ _ P H'); auto.
apply FBoundedScale; auto.
unfold FtoRradix in H'3; rewrite H'3; auto.
case H'.
intros H'4 H'5; elim H'5; intros H'6 H'7; clear H'5.
unfold FtoRradix in |- *; rewrite FvalScale; auto.
rewrite powerRZ_1; auto.
Qed.

Theorem RleMinR0 :
 forall (r : R) (min : float),
 (0 <= r)%R -> isMin b radix r min -> (0 <= min)%R.
intros r min H' H'0.
rewrite <- (FzeroisZero radix b).
case H'; intros H'1.
apply (MonotoneMin b radix) with (p := FtoRradix (Fzero (- dExp b))) (q := r);
 auto.
unfold FtoRradix in |- *; rewrite (FzeroisZero radix b); auto.
apply (RoundedModeProjectorIdem (isMin b radix)); auto.
apply MinRoundedModeP with (precision := precision); auto with float.
apply FboundedFzero; auto.
replace (FtoR radix (Fzero (- dExp b))) with (FtoRradix min); auto with real.
apply sym_eq; apply (ProjectMin b radix).
apply FboundedFzero; auto.
rewrite <- H'1 in H'0; rewrite <- (FzeroisZero radix b) in H'0; auto.
Qed.

Theorem RleRoundedR0 :
 forall (P : R -> float -> Prop) (p : float) (r : R),
 RoundedModeP b radix P -> P r p -> (0 <= r)%R -> (0 <= p)%R.
intros P p r H' H'0 H'1.
case H'.
intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5;
 case (H'4 r p); auto; intros H'6.
apply RleMinR0 with (r := r); auto.
apply Rle_trans with r; auto; apply isMax_inv1 with (1 := H'6).
Qed.

Theorem RleMaxR0 :
 forall (r : R) (max : float),
 (r <= 0)%R -> isMax b radix r max -> (max <= 0)%R.
intros r max H' H'0.
rewrite <- (FzeroisZero radix b).
case H'; intros H'1.
apply (MonotoneMax b radix) with (q := FtoRradix (Fzero (- dExp b))) (p := r);
 auto.
unfold FtoRradix in |- *; rewrite FzeroisZero; auto.
apply (RoundedModeProjectorIdem (isMax b radix)); auto.
apply MaxRoundedModeP with (precision := precision); auto.
apply FboundedFzero; auto.
replace (FtoR radix (Fzero (- dExp b))) with (FtoRradix max); auto with real.
apply sym_eq; apply (ProjectMax b radix).
apply FboundedFzero; auto.
rewrite H'1 in H'0; rewrite <- (FzeroisZero radix b) in H'0; auto.
Qed.

Theorem RleRoundedLessR0 :
 forall (P : R -> float -> Prop) (p : float) (r : R),
 RoundedModeP b radix P -> P r p -> (r <= 0)%R -> (p <= 0)%R.
intros P p r H' H'0 H'1.
case H'.
intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5;
 case (H'4 r p); auto; intros H'6.
apply Rle_trans with r; auto; apply isMin_inv1 with (1 := H'6).
apply RleMaxR0 with (r := r); auto.
Qed.

Theorem PminPos :
 forall p min : float,
 (0 <= p)%R ->
 Fbounded b p ->
 isMin b radix (/ 2%nat * p) min ->
 exists c : float, Fbounded b c /\ c = (p - min)%R :>R.
intros p min H' H'0 H'1.
cut (min <= / 2%nat * p)%R;
 [ intros Rl1; Casec Rl1; intros Rl1
 | apply isMin_inv1 with (1 := H'1); auto ].
case (eqExpMax _ radixMoreThanOne b min p); auto.
case H'1; auto.
rewrite Fabs_correct; auto with arith.
rewrite Rabs_right; auto.
apply Rle_trans with (/ 2%nat * p)%R; auto.
apply Rlt_le; auto.
apply Rmult_le_reg_l with (r := INR 2); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_ne_r;
 auto with real.
apply Rle_ge; apply RleMinR0 with (r := (/ 2%nat * p)%R); auto.
apply Rmult_le_reg_l with (r := INR 2); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l;
 rewrite Rmult_0_r; auto with real.
intros min' H'2; elim H'2; intros H'3 H'4; elim H'4; intros H'5 H'6;
 clear H'4 H'2.
case (FboundNext _ radixMoreThanOne b precision) with (p := min');
 auto with arith; fold FtoRradix in |- *.
intros Smin H'2; elim H'2; intros H'4 H'7; clear H'2.
exists Smin; split; auto.
rewrite H'7; auto.
unfold FtoRradix in |- *.
rewrite <- H'5; auto.
replace (Float (Zsucc (Fnum min')) (Fexp min')) with
 (Float (Fnum (Fshift radix (Zabs_nat (Fexp p - Fexp min')) p) - Fnum min')
    (Fexp min')); auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite <- Z_R_minus.
rewrite (fun x y z : R => Rmult_comm (x - y) z); rewrite Rmult_minus_distr_l;
 repeat rewrite (fun x : Z => Rmult_comm (powerRZ radix x)).
rewrite Rmult_IZR.
rewrite Zpower_nat_powerRZ_absolu; auto with zarith.
rewrite Rmult_assoc.
rewrite <- (powerRZ_add radix); auto with real zarith.
replace (Fexp p - Fexp min' + Fexp min')%Z with (Fexp p); [ auto | ring ].
apply floatEq; auto; simpl in |- *.
apply Zle_antisym.
apply Zlt_succ_le.
apply Zplus_lt_reg_l with (p := Fnum min'); auto.
cut (forall x y : Z, (x + (y - x))%Z = y);
 [ intros tmp; rewrite tmp; clear tmp | intros; ring ].
replace (Fnum min' + Zsucc (Zsucc (Fnum min')))%Z with
 (2%nat * Zsucc (Fnum min'))%Z.
apply (Rlt_Float_Zlt radix) with (r := Fexp min'); auto;
 fold FtoRradix in |- *.
replace (FtoRradix (Float (2%nat * Zsucc (Fnum min')) (Fexp min'))) with
 (2%nat * Float (Zsucc (Fnum min')) (Fexp min'))%R.
rewrite <- H'7.
replace
 (Float (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - Fexp min')))
    (Fexp min')) with (Fshift radix (Zabs_nat (Fexp p - Fexp min')) p).
unfold FtoRradix in |- *; rewrite FshiftCorrect; auto.
apply Rmult_lt_reg_l with (r := (/ 2%nat)%R); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; rewrite Rmult_1_l;
 auto with real.
case (Rle_or_lt Smin (/ 2%nat * FtoR radix p)); auto.
intros H'2; absurd (min < Smin)%R.
apply Rle_not_lt.
case H'1; auto.
intros H'8 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto.
rewrite H'7; unfold FtoRradix in |- *; rewrite <- H'5; auto.
unfold FtoR in |- *; simpl in |- *; apply Rlt_monotony_exp;
 auto with real zarith.
unfold Fshift in |- *; simpl in |- *.
replace (Fexp p - Zabs_nat (Fexp p - Fexp min'))%Z with (Fexp min'); auto.
rewrite inj_abs; auto.
ring.
auto with zarith.
replace (FtoRradix (Float (2%nat * Zsucc (Fnum min')) (Fexp min'))) with
 ((2%nat * Zsucc (Fnum min'))%Z * powerRZ radix (Fexp min'))%R.
rewrite Rmult_IZR; auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *; ring.
simpl in |- *; auto.
replace (Z_of_nat 2) with (Zsucc (Zsucc 0)).
repeat rewrite <- Zmult_succ_l_reverse; unfold Zsucc in |- *; ring.
simpl in |- *; auto.
apply Zlt_le_succ; auto.
apply Zplus_lt_reg_l with (p := Fnum min'); auto.
cut (forall x y : Z, (x + (y - x))%Z = y);
 [ intros tmp; rewrite tmp; clear tmp | intros; ring ].
replace (Fnum min' + Fnum min')%Z with (2%nat * Fnum min')%Z.
apply (Rlt_Float_Zlt radix) with (r := Fexp min'); auto;
 fold FtoRradix in |- *.
replace (FtoRradix (Float (2%nat * Fnum min') (Fexp min'))) with
 (2%nat * Float (Fnum min') (Fexp min'))%R.
replace
 (Float (Fnum p * Zpower_nat radix (Zabs_nat (Fexp p - Fexp min')))
    (Fexp min')) with (Fshift radix (Zabs_nat (Fexp p - Fexp min')) p).
unfold FtoRradix in |- *; rewrite FshiftCorrect; auto.
apply Rmult_lt_reg_l with (r := (/ 2%nat)%R); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; rewrite Rmult_1_l;
 auto with real.
replace (FtoR radix (Float (Fnum min') (Fexp min'))) with (FtoR radix min);
 auto.
unfold Fshift in |- *; simpl in |- *.
replace (Fexp p - Zabs_nat (Fexp p - Fexp min'))%Z with (Fexp min'); auto.
rewrite inj_abs; auto.
ring.
auto with zarith.
replace (FtoRradix (Float (2%nat * Fnum min') (Fexp min'))) with
 ((2%nat * Fnum min')%Z * powerRZ radix (Fexp min'))%R.
rewrite Rmult_IZR; auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *; ring.
simpl in |- *; auto.
replace (Z_of_nat 2) with (Zsucc (Zsucc 0)).
repeat rewrite <- Zmult_succ_l_reverse; unfold Zsucc in |- *; ring.
simpl in |- *; auto.
exists min; split; auto.
case H'1; auto.
rewrite Rl1.
pattern (FtoRradix p) at 2 in |- *;
 replace (FtoRradix p) with (2%nat * (/ 2%nat * p))%R.
simpl in |- *; ring.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_ne_r;
 auto with real.
Qed.

Theorem div2IsBetweenPos :
 forall p min max : float,
 (0 <= p)%R ->
 Fbounded b p ->
 isMin b radix (/ 2%nat * p) min ->
 isMax b radix (/ 2%nat * p) max -> p = (min + max)%R :>R.
intros p min max P H' H'0 H'1; apply Rle_antisym.
apply Rplus_le_reg_l with (r := (- max)%R).
replace (- max + p)%R with (p - max)%R; [ idtac | ring ].
replace (- max + (min + max))%R with (FtoRradix min); [ idtac | ring ].
rewrite <- (Fminus_correct radix); auto with arith.
case H'0.
intros H'2 H'3; elim H'3; intros H'4 H'5; apply H'5; clear H'3; auto.
apply Sterbenz; auto.
case H'1; auto.
apply Rle_trans with (FtoRradix max); auto.
apply Rmult_le_reg_l with (r := INR 2); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l;
 auto with real.
apply Rledouble; auto.
apply Rle_trans with (FtoRradix min); auto.
apply RleMinR0 with (r := (/ 2%nat * p)%R); auto.
apply Rmult_le_reg_l with (r := INR 2); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l;
 rewrite Rmult_0_r; auto with real.
apply Rle_trans with (/ 2%nat * p)%R; auto; apply isMax_inv1 with (1 := H'1).
case H'1.
intros H'3 H'6; elim H'6; intros H'7 H'8; apply H'8; clear H'6; auto.
apply Rmult_le_reg_l with (r := INR 2); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real; rewrite Rmult_1_l;
 auto with real.
apply Rmult_le_reg_l with (r := (/ 2%nat)%R); auto with real.
rewrite <- Rmult_assoc; rewrite Rinv_l; auto with real; rewrite Rmult_1_l;
 auto with real.
apply isMax_inv1 with (1 := H'1).
rewrite Fminus_correct; auto with arith.
apply Rplus_le_reg_l with (r := FtoR radix max).
replace (FtoR radix max + (FtoR radix p - FtoR radix max))%R with
 (FtoR radix p); [ idtac | ring ].
apply Rplus_le_reg_l with (r := (- (/ 2%nat * p))%R).
replace (- (/ 2%nat * p) + FtoR radix p)%R with (/ 2%nat * p)%R.
replace (- (/ 2%nat * p) + (FtoR radix max + / 2%nat * p))%R with
 (FtoR radix max); [ apply isMax_inv1 with (1 := H'1) | ring ].
replace (FtoR radix p) with (2%nat * (/ 2%nat * p))%R.
simpl in |- *; ring.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real.
apply Rplus_le_reg_l with (r := (- min)%R).
replace (- min + p)%R with (p - min)%R; [ idtac | ring ].
replace (- min + (min + max))%R with (FtoRradix max); [ idtac | ring ].
case (PminPos p min); auto.
intros x H'2; elim H'2; intros H'3 H'4; elim H'4; clear H'2.
case H'1.
intros H'2 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto.
unfold FtoRradix in H'4; rewrite H'4; auto.
fold FtoRradix in |- *; apply Rplus_le_reg_l with (r := FtoRradix min).
replace (min + (p - min))%R with (FtoRradix p); [ idtac | ring ].
apply Rplus_le_reg_l with (r := (- (/ 2%nat * p))%R).
replace (- (/ 2%nat * p) + p)%R with (/ 2%nat * p)%R.
replace (- (/ 2%nat * p) + (min + / 2%nat * p))%R with (FtoRradix min);
 [ apply isMin_inv1 with (1 := H'0) | ring ].
pattern (FtoRradix p) at 3 in |- *;
 replace (FtoRradix p) with (2%nat * (/ 2%nat * p))%R.
simpl in |- *; ring.
rewrite <- Rmult_assoc; rewrite Rinv_r; auto with real.
Qed.

Theorem div2IsBetween :
 forall p min max : float,
 Fbounded b p ->
 isMin b radix (/ 2%nat * p) min ->
 isMax b radix (/ 2%nat * p) max -> p = (min + max)%R :>R.
intros p min max H' H'0 H'1; case (Rle_or_lt 0 p); intros H'2.
apply div2IsBetweenPos; auto.
cut (forall x y : R, (- x)%R = (- y)%R -> x = y);
 [ intros H'3; apply H'3; clear H'3 | idtac ].
replace (- (min + max))%R with (- max + - min)%R; [ idtac | ring ].
repeat rewrite <- (Fopp_correct radix); auto with float.
apply div2IsBetweenPos; auto with float.
rewrite (Fopp_correct radix); auto.
replace 0%R with (-0)%R; try apply Rlt_le; auto with real.
replace (/ 2%nat * Fopp p)%R with (- (/ 2%nat * p))%R; auto with float.
rewrite (Fopp_correct radix); auto; fold FtoRradix; ring.
replace (/ 2%nat * Fopp p)%R with (- (/ 2%nat * p))%R; auto with float.
rewrite (Fopp_correct radix); auto; fold FtoRradix;ring.
intros x y H'3; rewrite <- (Ropp_involutive x);
 rewrite <- (Ropp_involutive y); rewrite H'3; auto.
Qed.

Theorem RoundedModeMultAbs :
 forall P,
 RoundedModeP b radix P ->
 forall (r : R) (q q' : float),
 P r q ->
 Fbounded b q' -> (Rabs r <= radix * q')%R -> (Rabs q <= radix * q')%R.
intros P H' r q q' H'0 H'1 H'2.
case (Rle_or_lt 0 r); intros Rl0.
rewrite Rabs_right; auto.
apply RoundedModeMult with (P := P) (r := r); auto.
rewrite <- (Rabs_right r); auto with real.
apply Rle_ge; apply RleRoundedR0 with (P := P) (r := r); auto.
rewrite Faux.Rabsolu_left1; auto.
replace (radix * q')%R with (- (radix * - q'))%R;
 [ apply Ropp_le_contravar | ring ].
rewrite <- (Fopp_correct radix).
apply RoundedModeMultLess with (P := P) (r := r); auto.
apply oppBounded; auto.
unfold FtoRradix in |- *; rewrite Fopp_correct.
rewrite <- (Ropp_involutive r).
replace (radix * - FtoR radix q')%R with (- (radix * q'))%R;
 [ apply Ropp_le_contravar | fold FtoRradix;ring ]; auto.
rewrite <- (Faux.Rabsolu_left1 r); auto.
apply Rlt_le; auto.
apply RleRoundedLessR0 with (P := P) (r := r); auto.
apply Rlt_le; auto.
Qed.

Theorem isMinComp :
 forall (r1 r2 : R) (min max : float),
 isMin b radix r1 min ->
 isMax b radix r1 max -> (min < r2)%R -> (r2 < max)%R -> isMin b radix r2 min.
intros r1 r2 min max H' H'0 H'1 H'2; split.
case H'; auto.
split.
apply Rlt_le; auto.
intros f H'3 H'4.
case H'; auto.
intros H'5 H'6; elim H'6; intros H'7 H'8; apply H'8; clear H'6; auto.
case (Rle_or_lt (FtoR radix f) r1); auto; intros C1.
absurd (FtoR radix f < max)%R.
apply Rle_not_lt.
case H'0.
intros H'6 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto.
apply Rlt_le; auto.
apply Rle_lt_trans with (2 := H'2); auto.
Qed.

Theorem isMaxComp :
 forall (r1 r2 : R) (min max : float),
 isMin b radix r1 min ->
 isMax b radix r1 max -> (min < r2)%R -> (r2 < max)%R -> isMax b radix r2 max.
intros r1 r2 min max H' H'0 H'1 H'2; split.
case H'0; auto.
split.
apply Rlt_le; auto.
intros f H'3 H'4.
case H'0; auto.
intros H'5 H'6; elim H'6; intros H'7 H'8; apply H'8; clear H'6; auto.
case (Rle_or_lt r1 (FtoR radix f)); auto; intros C1.
absurd (min < FtoR radix f)%R.
apply Rle_not_lt.
case H'.
intros H'6 H'9; elim H'9; intros H'10 H'11; apply H'11; clear H'9; auto.
apply Rlt_le; auto.
apply Rlt_le_trans with (1 := H'1); auto.
Qed.

Theorem roundedModeLessMult :
 forall (P : R -> float -> Prop) (p : float) (r : R),
 RoundedModeP b radix P ->
 P r p -> (Float 1%nat (- dExp b) <= r)%R -> (p <= radix * r)%R.
intros P p r H' H'0 H'1.
cut (0 < Float 1%nat (- dExp b))%R;
 [ intros Rl0
 | unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_l;
    auto with real arith ].
cut (0 < r)%R; [ intros Rl1 | apply Rlt_le_trans with (1 := Rl0) ]; auto.
cut (0 <= r)%R; [ intros Rl2 | apply Rlt_le; auto ].
case H'.
intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5;
 case (H'4 r p); auto; intros H'6.
apply Rle_trans with r; auto with real.
apply isMin_inv1 with (1 := H'6).
rewrite Rmult_comm; pattern r at 1 in |- *; replace r with (r * 1%nat)%R;
 [ apply Rmult_le_compat_l | simpl; ring ]; auto with real arith.
case (MinEx b radix precision) with (r := r); auto with arith;
 intros min Hmin.
cut (Fbounded b (Float (Fnum min) (Zsucc (Fexp min)))); [ intros F2 | idtac ].
cut (FtoRradix (Float (Fnum min) (Zsucc (Fexp min))) = (radix * min)%R :>R);
 [ intros F2Eq | idtac ].
apply Rle_trans with (FtoRradix (Float (Fnum min) (Zsucc (Fexp min)))).
case H'6.
intros H'7 H'8; elim H'8; intros H'9 H'10; apply H'10; clear H'8; auto.
case (Rle_or_lt r (Float (Fnum min) (Zsucc (Fexp min)))); auto; intros Rlt0.
absurd (Float (Fnum min) (Zsucc (Fexp min)) <= min)%R.
apply Rgt_not_le.
rewrite F2Eq; auto with real.
rewrite Rmult_comm.
pattern (FtoRradix min) at 2 in |- *;
 replace (FtoRradix min) with (min * 1%nat)%R; auto with real.
red in |- *; apply Rmult_lt_compat_l; auto with real arith.
case (RleMinR0 r min); auto.
intros H'8; case H'1.
intros H'11; absurd (Float 1%nat (- dExp b) <= min)%R.
apply Rgt_not_le; auto.
rewrite <- H'8; auto.
apply
 (MonotoneMin b radix)
  with (p := FtoRradix (Float 1%nat (- dExp b))) (q := r);
 auto.
apply (RoundedModeProjectorIdem (isMin b radix)); auto.
apply MinRoundedModeP with (precision := precision); auto.
repeat split.
simpl in |- *; auto with zarith.
apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
simpl in |- *; auto with zarith.
intros H'11; absurd (min = Float 1%nat (- dExp b) :>R).
rewrite <- H'8.
apply Rlt_dichotomy_converse; left; auto.
apply (MinUniqueP b radix r); auto.
rewrite <- H'11.
apply (RoundedModeProjectorIdem (isMin b radix)); auto.
apply MinRoundedModeP with (precision := precision); auto.
repeat split.
simpl in |- *; auto with zarith.
apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
simpl in |- *; auto with zarith.
case Hmin.
intros H'8 H'11; elim H'11; intros H'12 H'13; apply H'13; clear H'11; auto.
apply Rlt_le; auto.
rewrite F2Eq.
apply Rmult_le_compat_l; auto with real arith.
replace 0%R with (INR 0); auto with real arith.
apply isMin_inv1 with (1 := Hmin).
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite powerRZ_Zs; auto with real zarith; ring.
cut (Fbounded b min);
 [ unfold Fbounded in |- *; intros Fb0 | case Hmin; auto ].
elim Fb0; intros H H0; auto.
repeat (split; simpl in |- *); auto.
apply Zle_trans with (Fexp min); auto with zarith.
Qed.

Theorem roundedModeMoreMult :
 forall (P : R -> float -> Prop) (p : float) (r : R),
 RoundedModeP b radix P ->
 P r p -> (r <= Float (- 1%nat) (- dExp b))%R -> (radix * r <= p)%R.
intros P p r H' H'0 H'1.
cut (Float (- 1%nat) (- dExp b) < 0)%R;
 [ intros Rl0
 | unfold FtoRradix, FtoR in |- *; simpl in |- *; unfold IZR at 1; rewrite Ropp_mult_distr_l_reverse;
   rewrite Rmult_1_l;
    auto with real arith ].
2: replace 0%R with (-0)%R; auto with real arith; ring.
cut (r < 0)%R; [ intros Rl1 | apply Rle_lt_trans with (2 := Rl0) ]; auto.
cut (r <= 0)%R; [ intros Rl2 | apply Rlt_le; auto ].
case H'.
intros H'2 H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5;
 case (H'4 r p); auto; intros H'6.
case (MaxEx b radix precision) with (r := r); auto with arith;
 intros max Hmax.
cut (Fbounded b (Float (Fnum max) (Zsucc (Fexp max)))); [ intros F2 | idtac ].
cut (FtoRradix (Float (Fnum max) (Zsucc (Fexp max))) = (radix * max)%R :>R);
 [ intros F2Eq | idtac ].
apply Rle_trans with (FtoRradix (Float (Fnum max) (Zsucc (Fexp max)))).
rewrite F2Eq; auto with real.
apply Rmult_le_compat_l; auto with real arith.
replace 0%R with (INR 0); auto with real arith.
apply isMax_inv1 with (1 := Hmax); auto.
case H'6.
intros H'7 H'8; elim H'8; intros H'9 H'10; apply H'10; clear H'8; auto.
case (Rle_or_lt (Float (Fnum max) (Zsucc (Fexp max))) r); auto; intros Rlt0.
absurd (max <= Float (Fnum max) (Zsucc (Fexp max)))%R.
apply Rgt_not_le.
rewrite F2Eq.
replace (radix * max)%R with (- (- max * radix))%R; [ idtac | ring ].
pattern (FtoRradix max) at 1 in |- *;
 replace (FtoRradix max) with (- (- max * 1%nat))%R;
 [ idtac | simpl in |- *; ring ].
apply Ropp_lt_gt_contravar; apply Rmult_lt_compat_l; auto with real.
replace 0%R with (-0)%R; [ apply Ropp_lt_contravar | ring ].
case (RleMaxR0 r max); auto.
intros H'8; case H'1.
intros H'11; absurd (max <= Float (- 1%nat) (- dExp b))%R.
apply Rgt_not_le; auto.
rewrite H'8; auto.
apply
 (MonotoneMax b radix)
  with (q := FtoRradix (Float (- 1%nat) (- dExp b))) (p := r);
 auto.
apply (RoundedModeProjectorIdem (isMax b radix)); auto.
apply MaxRoundedModeP with (precision := precision); auto.
repeat split.
simpl in |- *; auto with zarith.
apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
simpl in |- *; auto with zarith.
intros H'11; absurd (Float (- 1%nat) (- dExp b) = max :>R).
rewrite H'8; auto.
apply Rlt_dichotomy_converse; left; auto.
apply (MaxUniqueP b radix r); auto.
rewrite H'11.
apply (RoundedModeProjectorIdem (isMax b radix)); auto.
apply MaxRoundedModeP with (precision := precision); auto.
repeat split.
simpl in |- *; auto with zarith.
apply (vNumbMoreThanOne radix) with (precision := precision);
 auto with zarith.
simpl in |- *; auto with zarith.
case Hmax.
intros H'8 H'11; elim H'11; intros H'12 H'13; apply H'13; clear H'11; auto.
apply Rlt_le; auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite powerRZ_Zs; auto with real zarith; ring.
cut (Fbounded b max);
 [ unfold Fbounded in |- *; intros Fb0 | case Hmax; auto ].
elim Fb0; intros H H0; repeat (split; simpl in |- *); auto.
apply Zle_trans with (Fexp max); auto with zarith.
apply Rle_trans with r; auto with real.
pattern r at 2 in |- *; replace r with (- (- r * 1%nat))%R; [ idtac | simpl; ring ].
replace (radix * r)%R with (- (- r * radix))%R; [ idtac | ring ].
apply Ropp_le_contravar; apply Rmult_le_compat_l; auto with real arith.
replace 0%R with (-0)%R; auto with real arith.
apply isMax_inv1 with (1 := H'6).
Qed.

Theorem roundedModeAbsMult :
 forall (P : R -> float -> Prop) (p : float) (r : R),
 RoundedModeP b radix P ->
 P r p ->
 (Float 1%nat (- dExp b) <= Rabs r)%R -> (Rabs p <= radix * Rabs r)%R.
intros P p r H' H'0 H'1; case (Rle_or_lt 0 r); intros H'2.
repeat rewrite Rabs_right; auto with real.
apply roundedModeLessMult with (P := P); auto.
rewrite <- (Rabs_right r); auto with real.
apply Rle_ge; apply (RleRoundedR0 P) with (r := r); auto.
repeat rewrite Faux.Rabsolu_left1; auto.
replace (radix * - r)%R with (- (radix * r))%R;
 [ apply Ropp_le_contravar | ring ].
apply roundedModeMoreMult with (P := P); auto.
rewrite <- (Ropp_involutive r); rewrite <- (Faux.Rabsolu_left1 r); auto.
replace (Float (- 1%nat) (- dExp b)) with (Fopp (Float 1%nat (- dExp b))).
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with real.
simpl in |- *; auto.
apply Rlt_le; auto.
apply Rlt_le; auto.
apply (RleRoundedLessR0 P) with (r := r); auto.
apply Rlt_le; auto.
Qed.

Theorem RleBoundRoundl :
 forall P,
 RoundedModeP b radix P ->
 forall (p q : float) (r : R),
 Fbounded b p -> (p <= r)%R -> P r q -> (p <= q)%R.
intros P H' p q r H'0 H'1 H'2; case H'1; intros H'3.
cut (MonotoneP radix P);
 [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ].
apply (Mn p r); auto.
apply RoundedModeProjectorIdem with (P := P); auto.
rewrite RoundedModeProjectorIdemEq with (P := P) (p := p) (q := q);
 auto with real.
cut (CompatibleP b radix P);
 [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ].
apply (Cp r p q); auto.
apply RoundedModeBounded with (P := P) (r := r); auto.
Qed.

Theorem RleBoundRoundr :
 forall P,
 RoundedModeP b radix P ->
 forall (p q : float) (r : R),
 Fbounded b p -> (r <= p)%R -> P r q -> (q <= p)%R.
intros P H' p q r H'0 H'1 H'2; case H'1; intros H'3.
cut (MonotoneP radix P);
 [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ].
apply (Mn r p); auto.
apply RoundedModeProjectorIdem with (P := P); auto.
rewrite RoundedModeProjectorIdemEq with (P := P) (p := p) (q := q);
 auto with real.
cut (CompatibleP b radix P);
 [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ].
apply (Cp r p q); auto.
apply RoundedModeBounded with (P := P) (r := r); auto.
Qed.

Theorem RoundAbsMonotoner :
 forall (P : R -> float -> Prop) (p : R) (q r : float),
 RoundedModeP b radix P ->
 Fbounded b r -> P p q -> (Rabs p <= r)%R -> (Rabs q <= r)%R.
intros P p q r H' H'0 H'1 H'2.
case (Rle_or_lt 0 p); intros Rl1.
rewrite Rabs_right; auto with real.
apply RleBoundRoundr with (P := P) (r := p); auto with real.
rewrite <- (Rabs_right p); auto with real.
apply Rle_ge; apply RleRoundedR0 with (P := P) (r := p); auto.
rewrite Faux.Rabsolu_left1; auto.
rewrite <- (Ropp_involutive r); apply Ropp_le_contravar.
rewrite <- (Fopp_correct radix); auto.
apply RleBoundRoundl with (P := P) (r := p); auto with float.
rewrite (Fopp_correct radix); rewrite <- (Ropp_involutive p);
 rewrite <- (Faux.Rabsolu_left1 p); auto with real;
 apply Rlt_le; auto.
apply RleRoundedLessR0 with (P := P) (r := p); auto; apply Rlt_le; auto.
Qed.

Theorem RoundAbsMonotonel :
 forall (P : R -> float -> Prop) (p : R) (q r : float),
 RoundedModeP b radix P ->
 Fbounded b r -> P p q -> (r <= Rabs p)%R -> (r <= Rabs q)%R.
intros P p q r H' H'0 H'1 H'2.
case (Rle_or_lt 0 p); intros Rl1.
rewrite Rabs_right; auto.
apply RleBoundRoundl with (P := P) (r := p); auto.
rewrite <- (Rabs_right p); auto with real.
apply Rle_ge; apply RleRoundedR0 with (P := P) (r := p); auto.
rewrite Faux.Rabsolu_left1; auto.
rewrite <- (Ropp_involutive r); apply Ropp_le_contravar.
rewrite <- (Fopp_correct radix); auto.
apply RleBoundRoundr with (P := P) (r := p); auto with float.
rewrite (Fopp_correct radix); rewrite <- (Ropp_involutive p);
 rewrite <- (Faux.Rabsolu_left1 p); auto with real;
 apply Rlt_le; auto.
apply RleRoundedLessR0 with (P := P) (r := p); auto; apply Rlt_le; auto.
Qed.
(* Rounded of natural numbers are natural *)

Theorem ZroundZ :
 forall (P : R -> float -> Prop) (z : Z) (p : float),
 RoundedModeP b radix P -> P z p -> exists z' : Z, p = z' :>R.
intros P z p HP H'.
case
 (RoundedModeRep b radix precision)
  with (P := P) (p := Float z 0%nat) (q := p); auto.
cut (CompatibleP b radix P);
 [ intros Cp | apply RoundedModeP_inv2 with (1 := HP); auto ];
 auto.
apply Cp with (1 := H'); auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite Rmult_1_r; auto.
apply RoundedModeBounded with (P := P) (r := IZR z); auto.
intros x H'0; exists x; auto.
unfold FtoRradix in |- *; rewrite H'0.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite Rmult_1_r; auto.
Qed.

Theorem NroundN :
 forall (P : R -> float -> Prop) (n : nat) (p : float),
 RoundedModeP b radix P -> P n p -> exists n' : nat, p = n' :>R.
intros P n p HP H'.
case (ZroundZ P (Z_of_nat n) p); auto.
repeat rewrite <- INR_IZR_INZ; auto.
intros x H'0; exists (Zabs_nat x).
rewrite <- (inj_abs x) in H'0.
rewrite H'0.
repeat rewrite <- INR_IZR_INZ; auto.
apply le_IZR; simpl in |- *.
rewrite <- H'0; auto.
apply RleRoundedR0 with (P := P) (r := INR n); auto.
replace 0%R with (INR 0); auto with real arith.
Qed.
(* Properties of LSB and MSB *)

Theorem FUlp_Le_LSigB :
 forall x : float, Fbounded b x -> (Fulp x <= Float 1%nat (LSB radix x))%R.
intros x H; unfold is_Fzero, Fulp, Fnormalize in |- *;
 case (Z_zerop (Fnum x)); intros ZH.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite Rmult_1_l.
apply Rle_powerRZ.
replace 1%R with (INR 1); auto with real arith.
apply Zle_trans with (Fexp x); auto.
case H; auto.
apply Fexp_le_LSB; auto.
rewrite
 LSB_shift
           with
           (n :=
             min (precision - Fdigit radix x) (Zabs_nat (dExp b + Fexp x)));
 auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *.
rewrite Rmult_1_l.
apply Rle_powerRZ; auto with arith.
replace 1%R with (INR 1); auto with real arith.
exact
 (Fexp_le_LSB radix
    (Fshift radix
       (min (precision - Fdigit radix x) (Zabs_nat (dExp b + Fexp x))) x)).
Qed.

Theorem MSBisMin :
 forall f1 f2 : float,
 (0 <= f1)%R ->
 isMin b radix f1 f2 ->
 ~ is_Fzero f1 -> ~ is_Fzero f2 -> MSB radix f1 = MSB radix f2.
intros f1 f2 H' H'0 H'1 H'2.
apply Zle_antisym.
2: apply MSB_monotone; auto.
2: repeat rewrite Fabs_correct1; auto with arith.
2: apply isMin_inv1 with (1 := H'0).
2: apply RleRoundedR0 with (P := isMin b radix) (r := FtoRradix f1); auto.
2: apply MinRoundedModeP with (precision := precision); auto.
case (Zle_or_lt (MSB radix f1) (MSB radix f2)); auto.
intros H'3; absurd (Float 1%nat (Zsucc (MSB radix f2)) <= f2)%R.
apply Rgt_not_le.
red in |- *; unfold FtoRradix in |- *; rewrite <- Fabs_correct1;
 auto with float arith.
apply abs_lt_MSB; auto.
apply RleRoundedR0 with (P := isMin b radix) (r := FtoRradix f1);
 auto with float.
apply MinRoundedModeP with (precision := precision); auto.
case H'0.
intros H'4 H'5; elim H'5; intros H'6 H'7; apply H'7; clear H'5; auto.
apply (FboundedOne _ radixMoreThanOne b precision); auto with arith.
apply Zle_trans with (Fexp f2).
case H'4; auto.
apply Zle_trans with (MSB radix f2); auto with zarith.
apply Fexp_le_MSB; auto.
apply Rle_trans with (FtoR radix (Float 1%nat (MSB radix f1))); auto.
apply oneExp_le; auto with zarith.
unfold FtoRradix in |- *; rewrite <- Fabs_correct1 with (x := f1);
 auto with float arith.
apply MSB_le_abs; auto.
Qed.

Theorem MSBtoZero :
 forall f1 f2 : float,
 ToZeroP b radix f1 f2 ->
 ~ is_Fzero f1 -> ~ is_Fzero f2 -> MSB radix f1 = MSB radix f2.
intros f1 f2 H' H'0 H'1; Casec H'; intros tmp; Elimc tmp; intros H1 H2.
apply MSBisMin; auto.
rewrite (MSB_opp radix f1).
rewrite (MSB_opp radix f2).
apply MSBisMin; auto with float.
unfold FtoRradix in |- *; rewrite Fopp_correct.
replace 0%R with (-0)%R; auto with real.
unfold FtoRradix in |- *; rewrite Fopp_correct; auto with float.
Qed.

Theorem MSBBoundNotZero :
 forall P : R -> float -> Prop,
 RoundedModeP b radix P ->
 forall f1 f2 : float,
 P f1 f2 -> f1 <> 0%R :>R -> (- dExp b <= MSB radix f1)%Z -> f2 <> 0%R :>R.
intros P H' f1 f2 H'0 H'1 H'2.
case (Rle_or_lt 0 f1); intros Rl1.
apply Rlt_dichotomy_converse; right; red in |- *.
apply Rlt_le_trans with (r2 := FtoRradix (Float 1%nat (MSB radix f1))); auto.
unfold FtoRradix, FtoR in |- *; simpl in |- *; rewrite Rmult_1_l;
 auto with real arith.
cut (Float 1%nat (MSB radix f1) <= Fabs f1)%R; unfold FtoRradix in |- *;
 [ rewrite Fabs_correct; auto with arith; rewrite Rabs_right; auto with real;
    intros Rl2; Casec Rl2; intros Rl2
 | apply MSB_le_abs ]; auto.
cut (MonotoneP radix P);
 [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ].
apply (Mn (Float 1%nat (MSB radix f1)) f1); auto.
apply RoundedModeProjectorIdem; auto.
apply (FboundedOne radix) with (precision := precision);
 auto with real zarith arith.
replace (FtoR radix f2) with (FtoR radix (Float 1%nat (MSB radix f1)));
 auto with float real.
apply RoundedModeProjectorIdemEq with (P := P); auto.
apply (FboundedOne radix) with (precision := precision);
 auto with real zarith arith.
cut (CompatibleP b radix P);
 [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ].
apply (Cp f1) with (p := f2); auto.
apply RoundedModeBounded with (P := P) (r := FtoRradix f1); auto.
Contradict H'1; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto.
apply Rlt_dichotomy_converse; left.
apply Rle_lt_trans with (r2 := FtoRradix (Float (- 1%nat) (MSB radix f1)));
 auto.
cut (MonotoneP radix P);
 [ intros Mn | apply RoundedModeP_inv4 with (1 := H'); auto ].
cut (f1 <= Float (- 1%nat) (MSB radix f1))%R;
 [ intros Rle1; Casec Rle1; intros Rle1 | idtac ].
apply (Mn f1 (Float (- 1%nat) (MSB radix f1))); auto.
apply RoundedModeProjectorIdem; auto.
apply oppBoundedInv; unfold Fopp in |- *; simpl in |- *.
apply (FboundedOne radix) with (precision := precision);
 auto with real zarith arith.
replace (FtoRradix f2) with (FtoRradix (Float (- 1%nat) (MSB radix f1)));
 auto with real.
apply RoundedModeProjectorIdemEq with (P := P); auto.
apply oppBoundedInv; unfold Fopp in |- *; simpl in |- *.
apply (FboundedOne _ radixMoreThanOne b precision);
 auto with real zarith arith.
cut (CompatibleP b radix P);
 [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ].
apply (Cp f1) with (p := f2); auto.
apply RoundedModeBounded with (P := P) (r := FtoRradix f1); auto.
replace (FtoRradix f1) with (- FtoRradix (Fabs f1))%R.
replace (Float (- 1%nat) (MSB radix f1)) with
 (Fopp (Float 1%nat (MSB radix f1))).
unfold FtoRradix in |- *; rewrite Fopp_correct; auto.
apply Ropp_le_contravar; apply MSB_le_abs; auto.
Contradict H'1; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto.
unfold Fopp in |- *; simpl in |- *; auto.
unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith;
 rewrite Faux.Rabsolu_left1; try apply Rlt_le; auto;
 ring.
replace (Float (- 1%nat) (MSB radix f1)) with
 (Fopp (Float 1%nat (MSB radix f1)));
 [ idtac | unfold Fopp in |- *; simpl in |- *; auto ].
replace 0%R with (-0)%R; [ idtac | ring ].
unfold FtoRradix in |- *; repeat rewrite Fopp_correct;
 apply Ropp_lt_contravar.
unfold FtoR in |- *; simpl in |- *; rewrite Rmult_1_l; auto with real arith.
Qed.

Theorem RoundMSBmax :
 forall (P : R -> float -> Prop) (p q : float),
 RoundedModeP b radix P ->
 P p q ->
 p <> 0%R :>R ->
 (- dExp b <= MSB radix p)%Z -> (MSB radix q <= Zsucc (MSB radix p))%Z.
intros P p q H' H'0 H'1 H'2.
apply (oneExp_Zle radix); auto.
apply Rle_trans with (FtoRradix (Fabs q)).
unfold FtoRradix in |- *; apply MSB_le_abs; auto.
red in |- *; intros H'3; absurd (q = 0%R :>R).
apply MSBBoundNotZero with (P := P) (f1 := p); auto.
apply (is_Fzero_rep1 radix); auto.
unfold FtoRradix in |- *; rewrite Fabs_correct; auto with arith;
 fold FtoRradix in |- *.
apply RoundAbsMonotoner with (P := P) (p := FtoRradix p); auto.
apply (FboundedOne _ radixMoreThanOne b precision); auto with zarith.
unfold FtoRradix in |- *; rewrite <- (Fabs_correct radix); auto with arith.
apply Rlt_le; apply abs_lt_MSB; auto.
Qed.

Theorem RoundMSBmin :
 forall (P : R -> float -> Prop) (p q : float),
 RoundedModeP b radix P ->
 P p q ->
 p <> 0%R :>R ->
 (- dExp b <= MSB radix p)%Z -> (MSB radix p <= MSB radix q)%Z.
intros P p q H' H'0 H'1 H'2.
replace (MSB radix p) with (MSB radix (Float 1%nat (MSB radix p))).
apply MSB_monotone; auto.
unfold is_Fzero in |- *; simpl in |- *; red in |- *; intros; discriminate.
red in |- *; intros H'3; absurd (q = 0%R :>R).
apply MSBBoundNotZero with (P := P) (f1 := p); auto.
unfold FtoRradix in |- *; apply is_Fzero_rep1; auto.
replace (Fabs (Float 1%nat (MSB radix p))) with (Float 1%nat (MSB radix p));
 [ idtac | unfold Fabs in |- *; simpl in |- *; auto ].
rewrite Fabs_correct; auto with arith; fold FtoRradix in |- *.
apply RoundAbsMonotonel with (P := P) (p := FtoRradix p); auto.
apply (FboundedOne _ radixMoreThanOne b precision); auto with zarith.
unfold FtoRradix in |- *; rewrite <- (Fabs_correct radix); auto with arith;
 apply MSB_le_abs; auto.
Contradict H'1; unfold FtoRradix in |- *; apply is_Fzero_rep1; auto.
unfold MSB, Fdigit in |- *; simpl in |- *.
case (Zpred (digit radix (Fnum p) + Fexp p)); simpl in |- *; auto with zarith.
intros p0; case p0; simpl in |- *; auto.
intros p1; elim p1; simpl in |- *; auto.
intros p2 H; injection H; intros H1; rewrite <- H1; auto.
intros p0; case p0; simpl in |- *; auto.
intros p1; case p1; simpl in |- *; auto.
intros p2; elim p2; simpl in |- *; auto.
intros p3 H; injection H; intros H1; rewrite H1; auto.
Qed.

Theorem RoundLSBMax :
 forall (P : R -> float -> Prop) (p q : float),
 RoundedModeP b radix P ->
 P p q -> ~ is_Fzero q -> (LSB radix p <= LSB radix q)%Z.
intros P p q H' H'0 H'2.
elim (LSB_rep_min radix) with (p := p); auto; intros z E.
case
 (RoundedModeRep b radix precision)
  with (P := P) (p := Float z (LSB radix p)) (q := q);
 auto.
cut (CompatibleP b radix P);
 [ intros Cp | apply RoundedModeP_inv2 with (1 := H'); auto ].
apply (Cp p (Float z (LSB radix p)) q); auto.
apply RoundedModeBounded with (P := P) (r := FtoRradix p); auto.
intros x H'3.
replace (LSB radix p) with (Fexp (Float x (LSB radix p)));
 [ idtac | simpl in |- *; auto ].
replace (LSB radix q) with (LSB radix (Float x (LSB radix p))).
apply Fexp_le_LSB.
apply LSB_comp; auto.
apply NisFzeroComp with (radix := radix) (x := q); auto.
Qed.
(* General theorem about the binade *)

Theorem InBinade :
 forall (P : R -> float -> Prop) (p q r : float) (e : Z),
 RoundedModeP b radix P ->
 Fbounded b p ->
 Fbounded b q ->
 P (p + q)%R r ->
 (- dExp b <= e)%Z ->
 (Float (Zpower_nat radix (pred precision)) e <= p)%R ->
 (p <= Float (pPred (vNum b)) e)%R ->
 (0%nat < q)%R ->
 (q < powerRZ radix e)%R -> r = p :>R \/ r = (p + powerRZ radix e)%R :>R.
intros P p q r e Rp H' H'0 H'1 H'2 H'3 H'4 H'5 H'6.
cut (p < p + q)%R; [ intros Rlt1 | idtac ].
cut (p + q < FNSucc b radix precision p)%R; [ intros Rlt2 | idtac ].
cut (isMin b radix (p + q) p); [ intros Min1 | idtac ].
cut (isMax b radix (p + q) (FNSucc b radix precision p));
 [ intros Max1 | idtac ].
cut (MinOrMaxP b radix P);
 [ intros MinOrMax | apply RoundedModeP_inv3 with (1 := Rp); auto ].
case (MinOrMax (p + q)%R r); auto; intros H1.
left.
apply (MinUniqueP b radix (p + q)%R); auto.
right.
cut ((p + powerRZ radix e)%R = FNSucc b radix precision p);
 [ intros Eq1; rewrite Eq1 | idtac ].
apply (MaxUniqueP b radix (p + q)%R); auto.
replace (FtoRradix (FNSucc b radix precision p)) with
 (Fnormalize radix b precision p +
  (FNSucc b radix precision p - Fnormalize radix b precision p))%R;
 [ idtac | ring ].
unfold FNSucc in |- *; rewrite <- (Fminus_correct radix); auto with arith;
 rewrite (FSuccDiff1 b radix precision); auto with arith.
rewrite (boundedNorMinGivesExp radix) with (x := e); auto with zarith.
rewrite (FnormalizeCorrect radix); auto; unfold FtoRradix, FtoR in |- *;
 simpl in |- *; ring.
apply sym_not_equal; apply Zlt_not_eq.
apply Zle_lt_trans with 0%Z; auto with zarith.
replace 0%Z with (- (0))%Z; auto with zarith; apply Zle_Zopp;
 apply Zlt_le_weak; apply nNormPos; auto with zarith.
apply (LtR0Fnum radix); auto.
rewrite FnormalizeCorrect; fold FtoRradix in |- *; auto.
apply Rlt_le_trans with (2 := H'3).
apply (LtFnumZERO radix); simpl in |- *;
 (replace 0%Z with (Z_of_nat 0); auto with zarith arith).
apply MinMax; auto with arith.
Contradict Rlt1.
rewrite Rlt1; auto with real.
apply MinBinade with (precision := precision); auto with arith.
apply Rlt_le; auto.
replace (FtoRradix (FNSucc b radix precision p)) with
 (Fnormalize radix b precision p +
  (FNSucc b radix precision p - Fnormalize radix b precision p))%R;
 [ idtac | ring ].
unfold FNSucc in |- *; rewrite <- (Fminus_correct radix); auto with arith;
 rewrite (FSuccDiff1 b radix precision); auto with arith.
rewrite (boundedNorMinGivesExp radix) with (x := e); auto with zarith.
rewrite (FnormalizeCorrect radix); auto; fold FtoRradix in |- *.
replace (FtoRradix (Float 1%nat e)) with (powerRZ radix e); auto with real.
unfold FtoRradix, FtoR in |- *; simpl in |- *; ring.
apply sym_not_equal; apply Zlt_not_eq.
apply Zle_lt_trans with 0%Z; auto with zarith.
replace 0%Z with (- (0))%Z; auto with zarith; apply Zle_Zopp;
 apply Zlt_le_weak; apply nNormPos; auto with zarith.
apply (LtR0Fnum radix); auto.
rewrite FnormalizeCorrect; fold FtoRradix in |- *; auto.
apply Rlt_le_trans with (2 := H'3).
apply (LtFnumZERO radix); simpl in |- *;
 (replace 0%Z with (Z_of_nat 0); auto with zarith arith).
pattern (FtoRradix p) at 1 in |- *; replace (FtoRradix p) with (p + 0)%R;
 [ idtac | ring ].
apply Rplus_lt_compat_l; auto.
Qed.

End FRoundP.
Hint Resolve FulpSucCan FulpSuc FulpPredCan FulpPred: float.


Require Import Coq.ZArith.ZArith.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e291m19_10limbs.Synthesis.
Local Open Scope Z_scope.

(* TODO : change this to field once field isomorphism happens *)
Definition nonzero :
  { nonzero : feBW_small -> BoundedWord.BoundedWord 1 adjusted_bitwidth bound1
  | forall a, (BoundedWord.BoundedWordToZ _ _ _ (nonzero a) =? 0) = (if Decidable.dec (phiM_small a = F.of_Z m 0) then true else false) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_nonzero ().
  Show Ltac Profile.
Time Defined.

Print Assumptions nonzero.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import omega.Omega.
From Coq Require Import Lists.List.
From Coq Require Import Strings.String.
Import ListNotations.

Add LoadPath "./".
Require Import maps.

Module AExp.

(*算術式とブール式の抽象構文
    a ::= nat
        | a + a
        | a - a
        | a * a

    b ::= true
        | false
        | a = a
        | a <= a
        | ~ b
        | b && b
 *)

Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

(*算術式の評価*)
Fixpoint aeval (a : aexp) : nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2 => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Example test_aeval1:
  aeval (APlus (ANum 2) (ANum 2)) = 4.
Proof. reflexivity. Qed.

(*ブール式の評価*)
Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval a1) =? (aeval a2)
  | BLe a1 a2 => (aeval a1) <=? (aeval a2)
  | BNot b1 => negb (beval b1)
  | BAnd b1 b2 => andb (beval b1) (beval b2)
  end.

(*「0 + n」を評価前に最適化*)
Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | ANum n => ANum n
  | APlus (ANum 0) e2 => optimize_0plus e2
  | APlus e1 e2 => APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 => AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 => AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

(*最適化後も評価が変わらない証明*)
Theorem optimize_0plus_sound: forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a. induction a.
  - reflexivity.
  - destruct a1 eqn:Ea1.
    + destruct n eqn:En.
      * simpl. apply IHa2.
      * simpl. rewrite IHa2. reflexivity.
    +
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    +
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
    +
      simpl. simpl in IHa1. rewrite IHa1.
      rewrite IHa2. reflexivity.
  -
    simpl. rewrite IHa1. rewrite IHa2. reflexivity.
  -
    simpl. rewrite IHa1. rewrite IHa2. reflexivity. Qed.

(*-----Tactical: タクティックを引数に取る-------*)

(*try：失敗時に何もしない。*)
Theorem silly1 : forall ae, aeval ae = aeval ae.
Proof. try reflexivity. Qed.

Theorem silly2 : forall (P : Prop), P -> P.
Proof.
  intros P HP.
  try reflexivity.   apply HP. Qed.

(*
「;」を使って
Lemma foo : forall n, 0 <=? n = true.
Proof.
  intros.
  destruct n.
    - simpl. reflexivity.
    - simpl. reflexivity.
Qed.
 これを簡単にする。*)
Lemma foo' : forall n, 0 <=? n = true.
Proof.
  intros.
  destruct n;

  simpl;

  reflexivity.
Qed.

(*tryとの併用*)
Theorem optimize_0plus_sound': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;

    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity).
  - reflexivity.
  -
    destruct a1 eqn:Ea1;

      try (simpl; simpl in IHa1; rewrite IHa1;
           rewrite IHa2; reflexivity).
    + destruct n eqn:En;
        simpl; rewrite IHa2; reflexivity. Qed.

Theorem optimize_0plus_sound'': forall a,
  aeval (optimize_0plus a) = aeval a.
Proof.
  intros a.
  induction a;

    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity);

    try reflexivity.
  -
    destruct a1; try (simpl; simpl in IHa1; rewrite IHa1;
                      rewrite IHa2; reflexivity).
    + destruct n;
      simpl; rewrite IHa2; reflexivity. Qed.

(*repeat*)
Theorem In10 : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (try (left; reflexivity); right).
Qed.

(*失敗しても影響しない。(0回リピートという解釈になる)*)
Theorem In10' : In 10 [1;2;3;4;5;6;7;8;9;10].
Proof.
  repeat (left; reflexivity).
  repeat (right; try (left; reflexivity)).
Qed.

Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2 => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2 => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b => BNot (optimize_0plus_b b)
  | BAnd b1 b2 => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
  end.

Theorem optimize_0plus_b_sound : forall b,
  beval (optimize_0plus_b b) = beval b.
Proof.
  intros b. (*unfold optimize_0plus_b.*) induction b.
   reflexivity.
   reflexivity.
   simpl; repeat (rewrite -> optimize_0plus_sound); reflexivity.
   simpl; repeat (rewrite -> optimize_0plus_sound); reflexivity.
   simpl; rewrite IHb; reflexivity.
   simpl; rewrite IHb1; rewrite IHb2; reflexivity.
Qed.

(*タクティックを作る
以下抜粋
------------
Tactic Notation コマンドは、「略記法タクティック("shorthand tactics")」を定義する簡単な方法を提供します。 「略記法タクティック」は、呼ばれると、いろいろなタクティックを一度に適用します。

より洗練されたプログラミングのために、CoqはLtacと呼ばれる小さな組込みの言語と、証明の状態を調べたり変更したりするためのLtacのプリミティブを提供します。 その詳細はここで説明するにはちょっと複雑過ぎます（しかも、LtacはCoqの設計の一番美しくない部分だというのが共通見解です!）。 しかし、詳細はリファレンスマニュアルにありますし、Coqの標準ライブラリには、読者が参考にできるLtacの定義のたくさんの例があります。

Coqの内部構造のより深いレベルにアクセスする新しいタクティックを作ることができるOCaml API も存在します。 しかしこれは、普通のCoqユーザにとっては、苦労が報われることはほとんどありません。
------------- *)
Tactic Notation "simpl_and_try" tactic(c) :=
  simpl;
  try c.

(*omega
------
omegaタクティックは「プレスバーガー算術」(Presburger arithmetic、「プレスブルガー算術」とも)と呼ばれる一階述語論理のサブセットの決定手続き(decision procedure)を実装します。 William Pugh が発明したOmegaアルゴリズム Pugh 1991 （Bib.v 参照）に基いています。

ゴールが以下の要素から構成された全称限量された論理式とします。以下の要素とは:
・数値定数、加算（+とS）、減算（-とpred）、定数の乗算（これがプレスバーガー算術である条件です）、
・等式（=と<>）および不等式（<=）、
・論理演算子/\, \/, ~, ->
です。 このとき、omegaを呼ぶと、ゴールを解くか、失敗によりそのゴールが偽であることを表すか、いずれかになります。 （ただしゴールが上記の形「ではない」場合にもomegaは失敗します。）
-------
 *)
Example silly_presburger_example : forall m n o p,
  m + n <= n + o /\ o + 3 = p + 3 ->
  m <= p.
Proof.
  intros. omega.
Qed.

Module aevalR_first_try.

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum n :
      aevalR (ANum n) n
  | E_APlus (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat) :
      aevalR e1 n1 ->
      aevalR e2 n2 ->
      aevalR (AMult e1 e2) (n1 * n2).

Module TooHardToRead.

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum n :
      aevalR (ANum n) n
  | E_APlus (e1 e2: aexp) (n1 n2: nat)
      (H1 : aevalR e1 n1)
      (H2 : aevalR e2 n2) :
      aevalR (APlus e1 e2) (n1 + n2)
  | E_AMinus (e1 e2: aexp) (n1 n2: nat)
      (H1 : aevalR e1 n1)
      (H2 : aevalR e2 n2) :
      aevalR (AMinus e1 e2) (n1 - n2)
  | E_AMult (e1 e2: aexp) (n1 n2: nat)
      (H1 : aevalR e1 n1)
      (H2 : aevalR e2 n2) :
      aevalR (AMult e1 e2) (n1 * n2).

End TooHardToRead.

Notation "e '\\' n"
         := (aevalR e n)
            (at level 50, left associativity)
         : type_scope.

End aevalR_first_try.

(*記法の定義の予約をすることで定義内でもその記法が使える。*)
Reserved Notation "e '\\' n" (at level 90, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum (n : nat) :
      (ANum n) \\ n
  | E_APlus (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 \\ n1) -> (e2 \\ n2) -> (APlus e1 e2) \\ (n1 + n2)
  | E_AMinus (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 \\ n1) -> (e2 \\ n2) -> (AMinus e1 e2) \\ (n1 - n2)
  | E_AMult (e1 e2 : aexp) (n1 n2 : nat) :
      (e1 \\ n1) -> (e2 \\ n2) -> (AMult e1 e2) \\ (n1 * n2)

  where "e '\\' n" := (aevalR e n) : type_scope.

Theorem aeval_iff_aevalR : forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
 split.
 -
   intros H.
   induction H; simpl.
   +
     reflexivity.
   +
     rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
   +
     rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
   +
     rewrite IHaevalR1. rewrite IHaevalR2. reflexivity.
 -
   generalize dependent n.
   induction a;
      simpl; intros; subst.
   +
     apply E_ANum.
   +
     apply E_APlus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   +
     apply E_AMinus.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
   +
     apply E_AMult.
      apply IHa1. reflexivity.
      apply IHa2. reflexivity.
Qed.

Theorem aeval_iff_aevalR' : forall a n,
  (a \\ n) <-> aeval a = n.
Proof.
  split.
  -
    intros H; induction H; subst; reflexivity.
  -
    generalize dependent n.
    induction a; simpl; intros; subst; constructor;
       try apply IHa1; try apply IHa2; reflexivity.
Qed.

Reserved Notation "e '//' n" (at level 90, left associativity).
Inductive bevalR: bexp -> bool -> Prop :=
| E_BTrue : BTrue // true
| E_BFalse : BFalse // false
| E_BEq (a1 a2 : aexp) (n1 n2 : nat): (a1 \\ n1) -> (a2 \\ n2) -> (BEq a1 a2) // (beq_nat n1 n2)
| E_BLe (a1 a2 : aexp) (n1 n2 : nat) : (a1 \\ n1) -> (a2 \\ n2) -> (BLe a1 a2) // ( n1 <=? n2 )
| E_BNot (be: bexp) (b: bool) : (be // b) -> (BNot be) // (negb b)
| E_BAnd (be1 be2 : bexp) (b1 b2 : bool): (be1 // b1) -> (be2 // b2) -> (BAnd be1 be2) // (b1 && b2)
where "e '//' n" := (bevalR e n) : type_scope.

Lemma beval_iff_bevalR : forall b bv,
  (b // bv) <-> beval b = bv.
Proof.
  split.
  - intros H; induction H.
    reflexivity. reflexivity.
    simpl; rewrite aeval_iff_aevalR' in H; rewrite aeval_iff_aevalR' in H0; subst; reflexivity.
    simpl; rewrite aeval_iff_aevalR' in H; rewrite aeval_iff_aevalR' in H0; subst; reflexivity.
    simpl; subst; reflexivity. simpl. subst; reflexivity.
  - generalize dependent bv. induction b; simpl; intros; subst.
    + apply E_BTrue.
    + apply E_BFalse.
    + apply E_BEq. apply aeval_iff_aevalR'; reflexivity. apply aeval_iff_aevalR'; reflexivity.

    + apply E_BLe. apply aeval_iff_aevalR'; reflexivity. apply aeval_iff_aevalR'; reflexivity.
    + apply E_BNot. apply IHb. reflexivity.
    + apply E_BAnd. apply IHb1; reflexivity. apply IHb2; reflexivity.
Qed.

End AExp.

Module aevalR_division.

Inductive aexp : Type :=
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp)
  | ADiv (a1 a2 : aexp).

Reserved Notation "e '\\' n"
                  (at level 90, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum (n : nat) :
      (ANum n) \\ n
  | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)
  | E_ADiv (a1 a2 : aexp) (n1 n2 n3 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (n2 > 0) ->
      (mult n2 n3 = n1) -> (ADiv a1 a2) \\ n3

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_division.

Module aevalR_extended.

Reserved Notation "e '\\' n" (at level 90, left associativity).
Inductive aexp : Type :=
  | AAny (*任意の自然数をとる*)
  | ANum (n : nat)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_Any (n : nat) :
      AAny \\ n
  | E_ANum (n : nat) :
      (ANum n) \\ n
  | E_APlus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (APlus a1 a2) \\ (n1 + n2)
  | E_AMinus (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (AMinus a1 a2) \\ (n1 - n2)
  | E_AMult (a1 a2 : aexp) (n1 n2 : nat) :
      (a1 \\ n1) -> (a2 \\ n2) -> (AMult a1 a2) \\ (n1 * n2)

where "a '\\' n" := (aevalR a n) : type_scope.

End aevalR_extended.

Definition state := total_map nat.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AId (x : string) (*変数*)
  | APlus (a1 a2 : aexp)
  | AMinus (a1 a2 : aexp)
  | AMult (a1 a2 : aexp).

Definition W : string := "W".
Definition X : string := "X".
Definition Y : string := "Y".
Definition Z : string := "Z".
(*------------
プログラム変数のこの慣習（X, Y, Z）は、大文字は型を表すのに使うという使用法と衝突します。 Impを構成していく章では多相性を多用はしないので、このことが混乱を招くことはないはずです。
 ------------*)

Inductive bexp : Type :=
  | BTrue
  | BFalse
  | BEq (a1 a2 : aexp)
  | BLe (a1 a2 : aexp)
  | BNot (b : bexp)
  | BAnd (b1 b2 : bexp).

Coercion AId : string >-> aexp.
Coercion ANum : nat >-> aexp.

Definition bool_to_bexp (b : bool) : bexp :=
  if b then BTrue else BFalse.
Coercion bool_to_bexp : bool >-> bexp.

Bind Scope imp_scope with aexp.
Bind Scope imp_scope with bexp.
Delimit Scope imp_scope with imp.

Notation "x + y" := (APlus x y) (at level 50, left associativity) : imp_scope.
Notation "x - y" := (AMinus x y) (at level 50, left associativity) : imp_scope.
Notation "x * y" := (AMult x y) (at level 40, left associativity) : imp_scope.
Notation "x <= y" := (BLe x y) (at level 70, no associativity) : imp_scope.
Notation "x = y" := (BEq x y) (at level 70, no associativity) : imp_scope.
Notation "x && y" := (BAnd x y) (at level 40, left associativity) : imp_scope.
Notation "'~' b" := (BNot b) (at level 75, right associativity) : imp_scope.

Definition example_aexp := (3 + (X * 2))%imp : aexp.
Definition example_bexp := (true && ~(X <= 4))%imp : bexp.

Set Printing Coercions.

Print example_bexp.
(*example_bexp = (bool_to_bexp true && (~ AId X <= ANum 4))%imp
     : bexp*)
Unset Printing Coercions.

Print example_bexp.
(*example_bexp = (true && (~ X <= 4))%imp
     : bexp*)

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2 => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval st a1) =? (aeval st a2)
  | BLe a1 a2 => (aeval st a1) <=? (aeval st a2)
  | BNot b1 => negb (beval st b1)
  | BAnd b1 b2 => andb (beval st b1) (beval st b2)
  end.

Definition empty_st := (_ !-> 0).

Notation "a '!->' x" := (t_update empty_st a x) (at level 100).

Example aexp1 :
    aeval (X !-> 5) (3 + (X * 2))%imp
  = 13.
Proof. reflexivity. Qed.

Example bexp1 :
    beval (X !-> 5) (true && ~(X <= 4))%imp
  = true.
Proof. reflexivity. Qed.

(*
 c ::= SKIP
      | x ::= a
      | c ;; c
      | TEST b THEN c ELSE c FI
      | WHILE b DO c END

階乗計算
     Z ::= X;;
     Y ::= 1;;
     WHILE ~(Z = 0) DO
       Y ::= Y * Z;;
       Z ::= Z - 1
     END
*)

Inductive com : Type :=
  | CSkip
  | CAss (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com).

Bind Scope imp_scope with com.
Notation "'SKIP'" :=
   CSkip : imp_scope.
Notation "x '::=' a" :=
  (CAss x a) (at level 60) : imp_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : imp_scope.
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity) : imp_scope.
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity) : imp_scope.

Definition fact_in_coq : com :=
  (Z ::= X;;
  Y ::= 1;;
  WHILE ~(Z = 0) DO
    Y ::= Y * Z;;
    Z ::= Z - 1
  END)%imp.

Unset Printing Notations.
Print fact_in_coq.
(*
fact_in_coq =
CSeq (CAss Z X)
  (CSeq (CAss Y (S O))
     (CWhile (BNot (BEq Z O))
        (CSeq (CAss Y (AMult Y Z))
           (CAss Z (AMinus Z (S O))))))
     : com
*)
Set Printing Notations.

Set Printing Coercions.
Print fact_in_coq.
(*
fact_in_coq =
(Z ::= AId X;;
 Y ::= ANum 1;;
 WHILE ~ AId Z = ANum 0
 DO Y ::= AId Y * AId Z;; Z ::= AId Z - ANum 1 END)%imp
     : com
*)
Unset Printing Coercions.

(*Locate：Notationの確認方法*)
Locate "&&".
Locate ";;".
Locate "WHILE".

(*--------コマンドの評価------------*)

(*The following declaration is needed to be able to use the notations in match patterns.*)
Open Scope imp_scope.
Fixpoint ceval_fun_no_while (st : state) (c : com)
                          : state :=
  match c with
    | SKIP =>
        st
    | x ::= a1 =>
        (x !-> (aeval st a1) ; st)
    | c1 ;; c2 =>
        let st' := ceval_fun_no_while st c1 in
        ceval_fun_no_while st' c2
    | TEST b THEN c1 ELSE c2 FI =>
        if (beval st b)
          then ceval_fun_no_while st c1
          else ceval_fun_no_while st c2
    | WHILE b DO c END =>
        st
  end.
Close Scope imp_scope.
(*終了しない場合のある定義なので受け付けない*)

(*TypeではなくPropにすることである形式に変換するには証明が必要となる -> 正しさが担保される*)
(*                           -----------------                            (E_Skip)
                           st =[ SKIP ]=> st

                           aeval st a1 = n
                   --------------------------------                     (E_Ass)
                   st =[ x := a1 ]=> (x !-> n ; st)

                           st  =[ c1 ]=> st'
                           st' =[ c2 ]=> st''
                         ---------------------                            (E_Seq)
                         st =[ c1;;c2 ]=> st''

                          beval st b1 = true
                           st =[ c1 ]=> st'
                ---------------------------------------                (E_IfTrue)
                st =[ TEST b1 THEN c1 ELSE c2 FI ]=> st'

                         beval st b1 = false
                           st =[ c2 ]=> st'
                ---------------------------------------               (E_IfFalse)
                st =[ TEST b1 THEN c1 ELSE c2 FI ]=> st'

                         beval st b = false
                    -----------------------------                  (E_WhileFalse)
                    st =[ WHILE b DO c END ]=> st

                          beval st b = true
                           st =[ c ]=> st'
                  st' =[ WHILE b DO c END ]=> st''
                  --------------------------------                  (E_WhileTrue)
                  st  =[ WHILE b DO c END ]=> st''                                 *)

Reserved Notation "st '=[' c ']=>' st'"
                  (at level 40).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ SKIP ]=> st
  | E_Ass : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x ::= a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st =[ c1 ]=> st' ->
      st' =[ c2 ]=> st'' ->
      st =[ c1 ;; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ TEST b THEN c1 ELSE c2 FI ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ WHILE b DO c END ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ WHILE b DO c END ]=> st'' ->
      st =[ WHILE b DO c END ]=> st''

  where "st =[ c ]=> st'" := (ceval c st st').

Example ceval_example1:
  empty_st =[
     X ::= 2;;
     TEST X <= 1
       THEN Y ::= 3
       ELSE Z ::= 4
     FI

  ]=> (Z !-> 4 ; X !-> 2).
Proof.
  apply E_Seq with (X !-> 2).
  -
    apply E_Ass. reflexivity.
  -
    apply E_IfFalse.
    reflexivity.
    apply E_Ass. reflexivity.
Qed.

Example ceval_example2:
  empty_st =[
    X ::= 0;; Y ::= 1;; Z ::= 2
  ]=> (Z !-> 2 ; Y !-> 1 ; X !-> 0).
Proof.
  apply E_Seq with (X !-> 0).
  - apply E_Ass. reflexivity.
  - apply E_Seq with ( Y !-> 1 ; X !-> 0). apply E_Ass. reflexivity.
    + apply E_Ass. reflexivity.
Qed.

Definition pup_to_n : com :=
  Y ::= ANum 0;;
  WHILE ~ AId X = ANum 0
  DO Y ::= AId Y + AId X;; X ::= AId X - ANum 1 END.

Theorem pup_to_2_ceval :
  (X !-> 2) =[
    pup_to_n
  ]=> (X !-> 0 ; Y !-> 3 ; X !-> 1 ; Y !-> 2 ; Y !-> 0 ; X !-> 2).
Proof.
  unfold pup_to_n. apply E_Seq with (Y !-> 0 ; X !-> 2). apply E_Ass. reflexivity.
  apply E_WhileTrue with (X !-> 1; Y !-> 2 ; Y !-> 0; X !-> 2 ). reflexivity.
  apply E_Seq with ( Y !-> 2; Y !->0; X !-> 2). apply E_Ass. reflexivity.
  apply E_Ass. reflexivity.
  apply E_WhileTrue with (X !-> 0; Y !-> 3; X !-> 1; Y !-> 2; Y !-> 0; X !-> 2). reflexivity.

  apply E_Seq with ( Y !-> 3; X !-> 1; Y !-> 2; Y !-> 0; X !-> 2). apply E_Ass; reflexivity.
  apply E_Ass; reflexivity.
  apply E_WhileFalse. reflexivity.
Qed.

(*状態の一意性*)
Theorem ceval_deterministic: forall c st st1 st2,
     st =[ c ]=> st1 ->
     st =[ c ]=> st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.
  induction E1;
           intros st2 E2; inversion E2; subst.
  - reflexivity.
  - reflexivity.
  -
    assert (st' = st'0) as EQ1.
    { apply IHE1_1; assumption. }
    subst st'0.
    apply IHE1_2. assumption.
  -
      apply IHE1. assumption.
  -
      rewrite H in H5. discriminate H5.
  -
      rewrite H in H5. discriminate H5.
  -
      apply IHE1. assumption.
  -
    reflexivity.
  -
    rewrite H in H2. discriminate H2.
  -
    rewrite H in H4. discriminate H4.
  -
      assert (st' = st'0) as EQ1.
      { apply IHE1_1; assumption. }
      subst st'0.
      apply IHE1_2. assumption. Qed.

Definition plus2 : com :=
  X ::= X + 2.

Definition XtimesYinZ : com :=
  Z ::= X * Y.

Definition subtract_slowly_body : com :=
  Z ::= Z - 1 ;;
  X ::= X - 1.

Theorem plus2_spec : forall st n st',
  st X = n ->
  st =[ plus2 ]=> st' ->
  st' X = n + 2.
Proof.
  intros st n st' HX Heval.
  inversion Heval. subst. clear Heval. simpl.
  apply t_update_eq. Qed.

Theorem XtimesYinZ_spec : forall st nx ny st',
    st X = nx -> st Y = ny
        -> st =[ XtimesYinZ ]=> st' -> st' Z = nx * ny.
Proof.
  intros st x y st' Hx Hy Heval. inversion Heval. subst. clear Heval.
  apply t_update_eq. Qed.

Definition loop : com :=
  WHILE true DO
    SKIP
  END.

Theorem loop_never_stops : forall st st',
  ~(st =[ loop ]=> st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE true DO SKIP END)%imp as loopdef eqn:Heqloopdef.
  induction contra; inversion Heqloopdef.
  - (*E_WhileEnd*)
  subst. inversion H.
  - (*E_WhileLoop*)
    apply IHcontra2. subst.  reflexivity.
Qed.

Open Scope imp_scope.
Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP =>
      true
  | _ ::= _ =>
      true
  | c1 ;; c2 =>
      andb (no_whiles c1) (no_whiles c2)
  | TEST _ THEN ct ELSE cf FI =>
      andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END =>
      false
  end.
Close Scope imp_scope.

Inductive no_whilesR: com -> Prop :=
| no_skip : no_whilesR SKIP
| no_ass : forall x a, no_whilesR (x ::= a)
| no_seq : forall c1 c2, no_whilesR c1 -> no_whilesR c2 -> no_whilesR (c1 ;; c2)
| no_if : forall b ct cf, no_whilesR ct -> no_whilesR cf -> no_whilesR (TEST b THEN ct ELSE cf FI).

Theorem no_whiles_eqv:
   forall c, no_whiles c = true <-> no_whilesR c.
Proof.
  split.
  - intros. induction c.
    + apply no_skip.
    + apply no_ass.
    + simpl in H. apply andb_true_iff in H. inversion H.
      apply no_seq; try(apply IHc1); try(apply IHc2); assumption.
    + simpl in H. apply andb_true_iff in H. inversion H. apply no_if.
      * apply IHc1. assumption. * apply IHc2. assumption.
    + simpl in H. discriminate.
  - intros. induction c; try (reflexivity).
    + simpl. apply andb_true_iff. inversion H. split; try(apply IHc1);  try(apply IHc2); assumption.
    + simpl. inversion H. apply IHc1 in H2 ; apply IHc2 in H4. rewrite H2. rewrite H4. reflexivity.
    + inversion H.
Qed.

Theorem no_whiles_terminating : forall st c,
    no_whilesR c -> exists st', st =[c]=> st'.
Proof.
  intros. generalize dependent st. induction H.
  - intros. exists st. apply E_Skip.
  - intros. exists(t_update st x (aeval st a)) . apply E_Ass. reflexivity.
  - intros.  destruct (IHno_whilesR1 st). destruct (IHno_whilesR2 x).
     exists (x0). apply E_Seq with c1 c2 st x x0 in H1.  apply H1. apply H2.
  - intros. remember (beval st b) as bv. destruct bv.
    + destruct (IHno_whilesR1 st). exists x. apply E_IfTrue. rewrite Heqbv. reflexivity. apply H1.
    + destruct (IHno_whilesR2 st). exists x. apply E_IfFalse. rewrite Heqbv. reflexivity. apply H1.
Qed.

(*発展問題*)
(*--------電卓スタック------------*)
Inductive sinstr : Type :=
| SPush (n : nat)
| SLoad (x : string)
| SPlus
| SMinus
| SMult.

Fixpoint s_execute (st : state) (stack : list nat) (prog : list sinstr) : list nat :=
  match prog with
  | [] => stack
  | h :: t => match h with
              | SPush n => s_execute st (n :: stack) t
              | SLoad x => s_execute st ((st x) :: stack) t
              | SPlus => match stack with
                         | n1 :: n2 :: ts => s_execute st ( (n1 + n2) :: ts ) t
                         | _ => []
                         end
              | SMinus => match stack with
                          | n1 :: n2 :: ts => s_execute st ( (n2 - n1) :: ts) t
                          | _ => []
                          end
              | SMult => match stack with
                         | n1 :: n2 :: ts => s_execute st ( (n1 * n2) :: ts) t
                         | _ => []
                         end
              end
  end.

Example s_execute1 :
     s_execute empty_st []
       [SPush 5; SPush 3; SPush 1; SMinus]
   = [2; 5].
Proof. reflexivity. Qed.

Example s_execute2 :
     s_execute (X !-> 3) [3;4]
       [SPush 4; SLoad X; SMult; SPlus]
   = [15; 4].
Proof. reflexivity. Qed.

Fixpoint s_compile (e : aexp) : list sinstr :=
  match e with
  | ANum n => [SPush n]
  | AId x => [SLoad x]
  | APlus a1 a2 => (s_compile a1) ++ (s_compile a2) ++ [SPlus]
  | AMinus a1 a2=> (s_compile a1) ++ (s_compile a2) ++ [SMinus]
  | AMult a1 a2 => (s_compile a1) ++ (s_compile a2) ++ [SMult]
  end.

Example s_compile1 :
  s_compile (X - (2 * Y))%imp
  = [SLoad X; SPush 2; SLoad Y; SMult; SMinus].
Proof. reflexivity. Qed.

Theorem s_compile_correct : forall (st : state) (e : aexp),
  s_execute st [] (s_compile e) = [ aeval st e ].
Proof.
  intros. induction e; intros; try (reflexivity).
  - simpl. Abort.

(*Andの場合先にboolを計算する*)
Fixpoint beval_short (st : state) (b : bexp) : bool :=
  match b with
  | BTrue => true
  | BFalse => false
  | BEq a1 a2 => (aeval st a1) =? (aeval st a2)
  | BLe a1 a2 => (aeval st a1) <=? (aeval st a2)
  | BNot b1 => negb (beval st b1)
  | BAnd b1 b2 => match (beval st b1) with
                  | true => beval st b2
                  | false => false
                  end
  end.

Theorem beval_short_eq : forall (b: bexp) (st: state),
    beval st b = beval_short st b.
Proof.
  induction b; simpl; try(reflexivity). Qed.

Module BreakImp.

Inductive com : Type :=
  | CSkip
  | CBreak
  | CAss (x : string) (a : aexp)
  | CSeq (c1 c2 : com)
  | CIf (b : bexp) (c1 c2 : com)
  | CWhile (b : bexp) (c : com).

Notation "'SKIP'" :=
  CSkip.
Notation "'BREAK'" :=
  CBreak.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'TEST' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Inductive result : Type :=
  | SContinue
  | SBreak.

Reserved Notation "st '=[' c ']=>' st' '/' s"
         (at level 40, st' at next level).

Inductive ceval : com -> state -> result -> state -> Prop :=
  | E_Skip : forall st,
      st =[ CSkip ]=> st / SContinue
  where "st '=[' c ']=>' st' '/' s" := (ceval c st s st').

Theorem break_ignore : forall c st st' s,
     st =[ BREAK;; c ]=> st' / s ->
     st = st'.
Proof.
  intros. inversion H. Qed.

Theorem while_continue : forall b c st st' s,
  st =[ WHILE b DO c END ]=> st' / s ->
  s = SContinue.
Proof.
  intros. inversion H. Qed.

Theorem while_stops_on_break : forall b c st st',
  beval st b = true ->
  st =[ c ]=> st' / SBreak ->
  st =[ WHILE b DO c END ]=> st' / SContinue.
Proof.
  intros. inversion H0. Qed.

Theorem ceval_deterministic: forall (c:com) st st1 st2 s1 s2,
     st =[ c ]=> st1 / s1 ->
     st =[ c ]=> st2 / s2 ->
     st1 = st2 /\ s1 = s2.
Proof.
  intros. inversion H. inversion H0. split. subst. reflexivity. reflexivity. Qed.

End BreakImp.


Require Import
  Coq.Relations.Relations Omega
  Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype
  Ssreflect.ssrnat Ssreflect.seq.

Set Implicit Arguments.

Lemma nseq_rev_id : forall A n (a : A), nseq n a = rev (nseq n a).
Proof.
  move => A n a.
  rewrite /rev -{1}(cats0 (nseq n a)) -[[::]]/(nseq 0 a).
  elim: n 0 => //= n IH m; rewrite -(IH m.+1) {IH}.
  by elim: n => //= n IH; f_equal.
Qed.

Lemma rt1n_trans' : forall A (R : relation A) (x y z : A),
  clos_refl_trans_1n A R x y -> clos_refl_trans_1n A R y z ->
  clos_refl_trans_1n A R x z.
Proof.
  move => A R x y z; move: x y.
  refine (clos_refl_trans_1n_ind A R _ _ _) => //= x x' y H H0 H1 H2.
  apply Relation_Operators.rt1n_trans with x'; tauto.
Qed.

(* well-founded induction *)

Theorem well_founded_lt : well_founded (fun n m => n < m).
Proof.
  move => x.
  move: {2}x (leqnn x) => n.
  elim: n x => [ | n IHn ] x H; constructor => y H0.
  - apply False_ind, notF.
    rewrite -(ltn0 y).
    apply (leq_trans H0 H).
  - apply IHn.
    rewrite -ltnS.
    apply (leq_trans H0 H).
Defined.

(* subst_evars *)
Ltac subst_evars := match goal with |- _ => idtac end.

(* ssromega *)
Ltac arith_hypo_ssrnat2coqnat :=
  match goal with
    | H : context [andb _ _] |- _ => let H0 := fresh in case/andP: H => H H0
    | H : context [orb _ _] |- _ => case/orP: H => H
    | H : context [?L <= ?R] |- _ => move/leP: H => H
    | H : context [addn ?L ?R] |- _ => rewrite -plusE in H
    | H : context [muln ?L ?R] |- _ => rewrite -multE in H
  end.

Ltac arith_goal_ssrnat2coqnat :=
  rewrite ?NatTrec.trecE -?plusE -?minusE -?multE;
  repeat match goal with
    | |- is_true (andb _ _) => apply/andP; split
    | |- is_true (orb _ _) => apply/orP
    | |- is_true (_ <= _) => apply/leP
  end.

Ltac ssromega :=
  repeat arith_hypo_ssrnat2coqnat ;
  arith_goal_ssrnat2coqnat ;
  omega.


(* NEXT: ===> Pairing                                                           *)

Require Import Logic.Set.Set.
Require Import Logic.Set.Incl.
Require Import Logic.Set.Elem.
Require Import Logic.Set.Cons.
Require Import Logic.Set.Equal.
Require Import Logic.Set.ToList.
Require Import Logic.Set.ElemIncl.
Require Import Logic.Set.Extensionality.

(* This module contains a few simple results about the empty set. An empty set  *)
(* is of course a set which has no element. There exists an empty set in our    *)
(* model, namely 'Nil'. The following lemma checks that Nil is indeed empty.    *)
(* It is not quite a set theoretic statement since the primitive 'Nil' is a     *)
(* primitive of the Coq meta-theory and not a primitive of a core language.     *)
Lemma emptyCharac : forall (z:set), ~ (z :: Nil).
Proof.
    intros z H. apply toListElem in H.
    destruct H as [z' [H1 [H2 H3]]]. inversion H1.
Qed.

(* This lemma is useful on a few occasions, allowing us to convert the coq      *)
(* equalty 'x = Nil' to the set theoretic equality 'x == Nil' and vice-versa.   *)
(* This is also a meta-theoretic statement. In effect, this lemma states that   *)
(* the equivalence class of Nil modulo '==' is reduced to a single element.     *)
Lemma emptyIsNil : forall (x:set), x == Nil <-> x = Nil.
Proof.
    intros x. split; intros H.
    - destruct x as [|x xs].
        + reflexivity.
        + exfalso. apply emptyCharac with x. apply elemIncl with (Cons x xs).
            { apply doubleIncl in H. destruct H as [H1 H2]. assumption. }
            { apply consElem. left. apply equalRefl. }
    - rewrite H. apply equalRefl.
Qed.

(* The existence of the empty set is true in our model                          *)
Theorem emptySet : exists (x:set), forall (z:set), ~ (z :: x).
Proof.
    exists Nil. apply emptyCharac.
Qed.

(* The empty set is unique: any other set with no element is equal to Nil.      *)
Lemma emptyUnique : forall (x:set), (forall (y:set), ~(y :: x)) -> x == Nil.
Proof.
    intros x H. apply extensionality. intros z. split; intros H'; exfalso.
    - apply (H z). assumption.
    - apply (emptyCharac z). assumption.
Qed.