(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Export definition.
Require Import Addition.
Require Import Psatz.
Require Export Lemmes_generaux.
Require Import Axiomes.
Require Import Tactiques.
Require Import Lemmes.
Require Import Absolue.
Require Import Zabs_complements.
Require Import Rind_complements.
Require Import Zind_complements.
Require Import Rabsolu_complements.
Require Import Rbase_doubles_inegalites.
Require Import Rbase_operations.
Require Import Rbase_inegalites.
Require Import powerRZ_complements.
Require Import sg.

Lemma multiplication_correct :
 forall (X Y : R) (XC YC : Reelc),
 encadrement XC X ->
 encadrement YC Y -> encadrement (multiplication_reelc XC YC) (X * Y).

Proof.
unfold encadrement in |- *.
intros.
unfold multiplication_reelc in |- *.
pattern X, Y in |- *.
apply Rind_eq_or.
intro.
elim H1.
intro.
rewrite H2.
do 2 rewrite Rmult_0_l.
replace (XC (p_max YC n)) with 0%Z;
 [ simpl in |- * | symmetry  in |- *; apply xc_nul with X; auto ].
split; lra.
intro.
rewrite H2.
rewrite Rmult_0_r; rewrite Rmult_0_l.
replace (YC (p_max XC n)) with 0%Z;
 [ idtac | symmetry  in |- *; apply xc_nul with Y; auto ].
rewrite <- Zmult_0_r_reverse.
rewrite Zmult_comm.
rewrite <- Zmult_0_r_reverse.
simpl in |- *.
split; lra.
intro H00.
elim H00; clear H00.
intros H01 H02.
pattern (YC (p_max XC n)), (XC (p_max YC n)) in |- *.
apply Zabs_ind_bis.
intros; elim H1; intros; clear H1.
rewrite H2; rewrite H3; simpl in |- *.
RingReplace (0 - 1) (-1); RingReplace (0 + 1) 1.
apply Rbase_doubles_inegalites.Rabsolu_def3.
apply Rmult_lt_reg_l with (B_powerRZ (p_max YC n + p_max XC n - n)).
unfold B_powerRZ in |- *.
apply powerRZ_lt.
apply INR_B_non_nul.
apply Rlt_trans with 1.
rewrite Rabs_mult; replace (Rabs (B_powerRZ n)) with (B_powerRZ n).
rewrite Rmult_comm; rewrite Rmult_assoc; unfold B_powerRZ in |- *.
replace (powerRZ (INR B) n * powerRZ (INR B) (p_max YC n + p_max XC n - n))
 with (powerRZ (INR B) (p_max YC n + p_max XC n)).
replace (powerRZ (INR B) (p_max YC n + p_max XC n)) with
 (powerRZ (INR B) (p_max YC n) * powerRZ (INR B) (p_max XC n)).
rewrite Rabs_mult.
cut (encadrement (absolue_reelc XC) (Rabs X)).
cut (encadrement (absolue_reelc YC) (Rabs Y)).
intros.
generalize (H4 (p_max YC n)); unfold absolue_reelc in |- *; rewrite H3;
 simpl in |- *.
RingReplace (0 - 1) (-1); RingReplace (0 + 1) 1; intros.
decompose [and] H5; clear H5.
generalize (H1 (p_max XC n)); unfold absolue_reelc in |- *; rewrite H2;
 simpl in |- *.
RingReplace (0 - 1) (-1); RingReplace (0 + 1) 1; intros.
decompose [and] H5; clear H5.
RingReplace 1 (1 * 1); rewrite Rmult_mult_mult.
apply Rmult_le.
apply Rle_ge; apply Rmult_le_pos.
apply powerRZ_le.
apply INR_B_non_nul.
apply Rabs_pos.
lra.
rewrite Rmult_comm; auto.
rewrite Rmult_comm; auto.
apply absolue_correct; auto.
apply absolue_correct; auto.
symmetry  in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
pattern (p_max YC n + p_max XC n)%Z at 1 in |- *.
replace (p_max YC n + p_max XC n)%Z with (p_max YC n + p_max XC n - n + n)%Z.
rewrite Rmult_comm; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
ring.
symmetry  in |- *; apply Rabs_right; apply Rgt_ge; unfold B_powerRZ in |- *;
 apply Rlt_gt; apply powerRZ_lt; apply INR_B_non_nul.
unfold B_powerRZ in |- *;
 RingReplace (powerRZ (INR B) (p_max YC n + p_max XC n - n) * 1)
  (powerRZ (INR B) (p_max YC n + p_max XC n - n)).
apply powerRZ_lt_1.
apply INR_lt_1.
generalize B_sup_4.
omega.
apply Z.lt_le_trans with 1%Z.
omega.
apply le_pmax_n.

(*2eme partie*)

intro.
generalize H H0 H01 H02; clear H H0 H01 H02.
pattern X, Y, XC, YC in |- *.
apply
 Zabs_ind_ter
  with (P1 := fun zc wc : Reelc => (0 < Z.abs (zc (p_max wc n)))%Z).
3: tauto.
intros.
generalize (H H2 H0).
intro; clear H H2 H0 H1.
RingReplace (Z.sgn (XC (p_max YC n)) * Z.sgn (YC (p_max XC n)))%Z
 (Z.sgn (YC (p_max XC n)) * Z.sgn (XC (p_max YC n)))%Z.
RingReplace (X * Y) (Y * X).
replace (Z.abs (XC (p_max YC n) * YC (p_max XC n)))
 with (Z.abs (YC (p_max XC n) * XC (p_max YC n))).
RingReplace (p_max YC n + p_max XC n)%Z (p_max XC n + p_max YC n)%Z.
auto.
rewrite Zmult_comm; auto.

(*3eme partie*)

intros.
cut
 (IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n))) *
  / B_powerRZ (p_max yc n + p_max xc n - n) <= 1 * / 2).
intro a.
clear X Y XC YC H1.
pattern (yc (p_max xc n)) in |- *.
apply Zabs_ind_4.
intro.
rewrite H1; rewrite <- Zmult_0_r_reverse; rewrite Zmult_comm;
 rewrite <- Zmult_0_r_reverse; simpl in |- *.
RingReplace (0 - 1) (-1); RingReplace (0 + 1) 1.
apply Rbase_doubles_inegalites.Rabsolu_def3.
do 2 rewrite Rabs_mult.
(**)
apply
 Rlt_trans
  with
    ((1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n)))) *
     / B_powerRZ (p_max yc n + p_max xc n - n) + 1 * / 2).
apply
 Rlt_le_trans
  with
    ((1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) +
      IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n)))) *
     / B_powerRZ (p_max yc n + p_max xc n - n)).
apply Rlt_Rinv_l_to_r.
unfold B_powerRZ in |- *.
apply powerRZ_lt.
apply INR_B_non_nul.
replace (Rabs (B_powerRZ n)) with (B_powerRZ n); unfold B_powerRZ in |- *.
rewrite Rmult_assoc.
replace (powerRZ (INR B) n * powerRZ (INR B) (p_max yc n + p_max xc n - n))
 with (powerRZ (INR B) (p_max yc n + p_max xc n)).
replace (powerRZ (INR B) (p_max yc n + p_max xc n)) with
 (powerRZ (INR B) (p_max yc n) * powerRZ (INR B) (p_max xc n)).
rewrite Rmult_mult_mult.
replace
 (1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) +
  IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n))))
 with
  ((IZR (Z.abs (xc (p_max yc n))) + 1) * (IZR (Z.abs (yc (p_max xc n))) + 1)).
apply Rmult_le.
apply Rle_ge.
apply Rmult_le_pos.
apply Rlt_le; apply powerRZ_lt; apply INR_B_non_nul.
apply Rabs_pos.
apply Rlt_gt; apply Rle_lt_0_plus_1.
RingReplace 0 (IZR 0); apply IZR_le; apply Zabs_pos.
cut (encadrement (absolue_reelc xc) (Rabs x)).
unfold encadrement in |- *; intro.
generalize (H3 (p_max yc n)); clear H3.
unfold absolue_reelc in |- *.
intro.
elim H3; intros; clear H3.
rewrite Rmult_comm; auto.
apply absolue_correct; auto.
cut (encadrement (absolue_reelc yc) (Rabs y)).
unfold encadrement in |- *; intro.
generalize (H3 (p_max xc n)); clear H3.
unfold absolue_reelc in |- *.
intro.
elim H3; intros; clear H3.
rewrite Rmult_comm; auto.
apply absolue_correct; auto.
rewrite Zabs_mult; rewrite plus_IZR; rewrite mult_IZR; ring.
replace (powerRZ (INR B) (p_max yc n) * powerRZ (INR B) (p_max xc n)) with
 (powerRZ (INR B) (p_max yc n + p_max xc n)); auto.
apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
replace (powerRZ (INR B) n * powerRZ (INR B) (p_max yc n + p_max xc n - n))
 with (powerRZ (INR B) (n + (p_max yc n + p_max xc n - n))).
apply powerRZ_trivial.
ring.
apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
symmetry  in |- *; apply Rabs_right.
apply Rle_ge.
apply Rlt_le; apply powerRZ_lt; apply INR_B_non_nul.
rewrite Rmult_plus_distr_r.
apply Rplus_le_compat_l.
auto.
rewrite H1.
rewrite <- Zmult_0_r_reverse; simpl in |- *.
RingReplace (1 + 0) 1.
apply Rlt_add_compatibility3.
replace (1 - 1 * / 2) with (1 * / 2).
rewrite Rmult_comm; rewrite RIneq.Rmult_1_r.
rewrite Rmult_comm; rewrite RIneq.Rmult_1_r.
apply Rinv_1_lt_contravar.
lra.
apply Rlt_le_trans with (INR B).
replace 2 with (INR 2).
apply lt_INR.
generalize B_sup_4; omega.
do 2 rewrite S_INR; simpl in |- *; ring.
unfold B_powerRZ in |- *; apply powerRZ_lt_r_bis.
replace 1 with (INR 1).
apply le_INR.
generalize B_sup_4; omega.
rewrite S_INR; simpl in |- *; ring.
apply le_pmax_n.
field; apply Rgt_not_eq; lra.
intro.
replace (Z.sgn (xc (p_max yc n))) with (sg x).
2: symmetry  in |- *; apply Zsgn_sg; auto; auto.
replace (Z.sgn (yc (p_max xc n))) with (sg y).
2: symmetry  in |- *; apply Zsgn_sg; auto; auto.
pattern (x * y) in |- *.
rewrite sg.Rabsolu_sg_bis.
rewrite Rabs_mult.
rewrite sg_mult; rewrite mult_IZR.
pattern x, y in |- *.
apply sg_ind_bis.
apply sg_Zsgn_abs with xc (p_max yc n).
apply absolue_correct.
auto.
auto.
apply sg_Zsgn_abs with yc (p_max xc n).
apply absolue_correct.
auto.
auto.
intro.
rewrite H3; RingReplace (IZR (-1)) (-1).
apply Rlt_2_monotony_contra with (-1).
lra.
rewrite Rmult_comm; rewrite Rmult_plus_distr_r.
rewrite Rmult_comm; rewrite <- Rmult_assoc.
RingReplace (-1 * -1) 1; RingReplace (1 * -1) (-1).
rewrite Rmult_comm; rewrite RIneq.Rmult_1_r.
replace (-1)%R with (-(1))%R at 1 by auto.
rewrite Rplus_comm; rewrite <- Rsub_sym.
do 2 rewrite <- Rmult_assoc.
RingReplace (-1 * -1) 1.
rewrite Rmult_assoc; rewrite Rmult_comm; rewrite RIneq.Rmult_1_r.
rewrite Rmult_minus_distr_l; rewrite <- Rmult_assoc; RingReplace (-1 * -1) 1.
RingReplace
 (1 *
  IZR
    (gauss_z_sur_B_pow (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n)))
       (p_max yc n + p_max xc n - n)) - -1 * 1)
 (IZR
    (gauss_z_sur_B_pow (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n)))
       (p_max yc n + p_max xc n - n)) + 1).
apply
 Rlt_2_le_lt_and
  with
    (IZR (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n))) *
     / B_powerRZ (p_max yc n + p_max xc n - n) - 1 * / 2)
    (IZR (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n))) *
     / B_powerRZ (p_max yc n + p_max xc n - n) + 1 * / 2).
2: apply Rlt_le_2_gauss.
2: generalize
    (gauss_correct_pow (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n)))
       (p_max yc n + p_max xc n - n)).
2: tauto.
apply
 Rle_2_Rlt_2
  with
    ((1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) -
      IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n)))) *
     / B_powerRZ (p_max yc n + p_max xc n - n))
    ((1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) +
      IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n)))) *
     / B_powerRZ (p_max yc n + p_max xc n - n)).
apply Rlt_2_Rmult_Rinv.
unfold B_powerRZ in |- *.
apply powerRZ_lt.
apply INR_B_non_nul.
unfold B_powerRZ in |- *.
rewrite Rmult_assoc.
replace (powerRZ (INR B) n * powerRZ (INR B) (p_max yc n + p_max xc n - n))
 with (powerRZ (INR B) (p_max yc n + p_max xc n)).
replace (powerRZ (INR B) (p_max yc n + p_max xc n)) with
 (powerRZ (INR B) (p_max yc n) * powerRZ (INR B) (p_max xc n)).
rewrite Rmult_mult_mult.
replace
 (1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) +
  IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n))))
 with
  ((IZR (Z.abs (xc (p_max yc n))) + 1) * (IZR (Z.abs (yc (p_max xc n))) + 1)).
replace
 (1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) -
  IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n))))
 with
  ((IZR (Z.abs (xc (p_max yc n))) - 1) * (IZR (Z.abs (yc (p_max xc n))) - 1)).
apply Rle_mult_lt.
cut (encadrement (absolue_reelc xc) (Rabs x)).
unfold encadrement in |- *; intro.
generalize (H4 (p_max yc n)); clear H4.
unfold absolue_reelc in |- *.
intro.
rewrite Rmult_comm; auto.
apply absolue_correct; auto.
cut (encadrement (absolue_reelc yc) (Rabs y)).
unfold encadrement in |- *; intro.
generalize (H4 (p_max xc n)); clear H4.
unfold absolue_reelc in |- *.
rewrite Rmult_comm; auto.
apply absolue_correct; auto.
apply Rmult_lt_0_compat.
apply powerRZ_lt; apply INR_B_non_nul.
apply sg_Zsgn_abs with xc (p_max yc n).
apply absolue_correct; auto.
auto.
apply Rle_add_compatibility.
RingReplace (0 + 1) 1; RingReplace 1 (IZR (Z.succ 0)).
apply IZR_le.
apply Zlt_le_succ; auto.
apply Rmult_le_pos.
apply Rlt_le; apply powerRZ_lt; apply INR_B_non_nul.
apply Rabs_pos.
apply Rle_lt_0_plus_1.
RingReplace 0 (IZR 0).
apply Rlt_le; apply IZR_lt.
auto.
rewrite Zabs_mult; rewrite mult_IZR; rewrite plus_IZR; ring.
rewrite Zabs_mult; rewrite mult_IZR; rewrite plus_IZR; ring.
replace (powerRZ (INR B) (p_max yc n) * powerRZ (INR B) (p_max xc n)) with
 (powerRZ (INR B) (p_max yc n + p_max xc n)); auto.
apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
replace (powerRZ (INR B) n * powerRZ (INR B) (p_max yc n + p_max xc n - n))
 with (powerRZ (INR B) (n + (p_max yc n + p_max xc n - n))).
apply powerRZ_trivial.
ring.
apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rge_le; rewrite Rmult_comm; rewrite Rmult_minus_distr_l.
rewrite Rmult_comm; apply Rle_ge.
rewrite plus_IZR; RingReplace (IZR 1) 1.
apply Rle_sub_r.
rewrite Rmult_comm; auto.
rewrite Rmult_plus_distr_r.
do 2 rewrite plus_IZR; RingReplace (IZR 1) 1.
apply Rplus_le_compat_l.
rewrite <- plus_IZR; auto.
intro.
rewrite H3.
RingReplace (IZR 1) 1.
rewrite Rmult_assoc; rewrite Rmult_1l.
apply
 Rlt_2_le_lt_and
  with
    (IZR (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n))) *
     / B_powerRZ (p_max yc n + p_max xc n - n) - 1 * / 2)
    (IZR (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n))) *
     / B_powerRZ (p_max yc n + p_max xc n - n) + 1 * / 2).
2: apply Rlt_le_2_gauss.
2: generalize
    (gauss_correct_pow (1 + Z.abs (xc (p_max yc n) * yc (p_max xc n)))
       (p_max yc n + p_max xc n - n)).
2: tauto.
apply
 Rle_2_Rlt_2
  with
    ((1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) -
      IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n)))) *
     / B_powerRZ (p_max yc n + p_max xc n - n))
    ((1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) +
      IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n)))) *
     / B_powerRZ (p_max yc n + p_max xc n - n)).
apply Rlt_2_Rmult_Rinv.
unfold B_powerRZ in |- *.
apply powerRZ_lt.
apply INR_B_non_nul.
rewrite <- Rmult_assoc.
unfold B_powerRZ in |- *.
rewrite Rmult_assoc.
rewrite Rmult_1l.
replace (powerRZ (INR B) n * powerRZ (INR B) (p_max yc n + p_max xc n - n))
 with (powerRZ (INR B) (p_max yc n + p_max xc n)).
replace (powerRZ (INR B) (p_max yc n + p_max xc n)) with
 (powerRZ (INR B) (p_max yc n) * powerRZ (INR B) (p_max xc n)).
rewrite Rmult_mult_mult.
replace
 (1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) +
  IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n))))
 with
  ((IZR (Z.abs (xc (p_max yc n))) + 1) * (IZR (Z.abs (yc (p_max xc n))) + 1)).
replace
 (1 + IZR (Z.abs (xc (p_max yc n) * yc (p_max xc n))) -
  IZR (Z.abs (xc (p_max yc n)) + Z.abs (yc (p_max xc n))))
 with
  ((IZR (Z.abs (xc (p_max yc n))) - 1) * (IZR (Z.abs (yc (p_max xc n))) - 1)).

apply Rle_mult_lt.
cut (encadrement (absolue_reelc xc) (Rabs x)).
unfold encadrement in |- *; intro.
generalize (H4 (p_max yc n)); clear H4.
unfold absolue_reelc in |- *.
intro.
rewrite Rmult_comm; auto.
apply absolue_correct; auto.
cut (encadrement (absolue_reelc yc) (Rabs y)).
unfold encadrement in |- *; intro.
generalize (H4 (p_max xc n)); clear H4.
unfold absolue_reelc in |- *.
rewrite Rmult_comm; auto.
apply absolue_correct; auto.
apply Rmult_lt_0_compat.
apply powerRZ_lt; apply INR_B_non_nul.
apply sg_Zsgn_abs with xc (p_max yc n).
apply absolue_correct; auto.
auto.
apply Rle_add_compatibility.
RingReplace (0 + 1) 1; RingReplace 1 (IZR (Z.succ 0)).
apply IZR_le.
apply Zlt_le_succ; auto.
apply Rmult_le_pos.
apply Rlt_le; apply powerRZ_lt; apply INR_B_non_nul.
apply Rabs_pos.
apply Rle_lt_0_plus_1.
RingReplace 0 (IZR 0).
apply Rlt_le; apply IZR_lt.
auto.
rewrite Zabs_mult; rewrite mult_IZR; rewrite plus_IZR; ring.
rewrite Zabs_mult; rewrite mult_IZR; rewrite plus_IZR; ring.
replace (powerRZ (INR B) (p_max yc n) * powerRZ (INR B) (p_max xc n)) with
 (powerRZ (INR B) (p_max yc n + p_max xc n)); auto.
apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
replace (powerRZ (INR B) n * powerRZ (INR B) (p_max yc n + p_max xc n - n))
 with (powerRZ (INR B) (n + (p_max yc n + p_max xc n - n))).
apply powerRZ_trivial.
ring.
apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rge_le; rewrite Rmult_comm; rewrite Rmult_minus_distr_l.
rewrite Rmult_comm; apply Rle_ge.
rewrite plus_IZR; RingReplace (IZR 1) 1.
apply Rle_sub_r.
rewrite Rmult_comm; auto.
rewrite Rmult_plus_distr_r.
do 2 rewrite plus_IZR; RingReplace (IZR 1) 1.
apply Rplus_le_compat_l.
rewrite <- plus_IZR; auto.

(* 4eme partie *)

clear X Y XC YC H1.
pattern (xc (p_max yc n)) in |- *.
apply Zabs_ind_lt_O.
3: auto.
intros.
pattern (yc (p_max xc n)) in |- *.
apply Zabs_ind_le_1.
intro.
replace (1 * / 2) with (2 * / 4).
apply Rmult_le_compat.
RingReplace 0 (IZR 0); apply IZR_le.
rewrite H1.
apply Zplus_le_0_compat.
RingReplace 1%Z (Z.succ 0); apply Zle_succ.
apply Zabs_pos.
apply Rlt_le; apply Rinv_0_lt_compat; unfold B_powerRZ in |- *;
 apply powerRZ_lt; apply INR_B_non_nul.
rewrite plus_IZR; rewrite H1.
RingReplace (IZR 1) 1.
apply Rplus_le_reg_l with (-1).
rewrite <- Rplus_assoc; RingReplace (-1 + 1) 0; rewrite Rplus_comm;
 rewrite Rplus_0_r; replace (-1 + 2) with (IZR (Z.succ 0)) by (simpl;ring).
apply IZR_le; auto.
apply Rinv_le.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
lra.
apply Rle_trans with (INR B).
replace 4 with (INR 4).
apply le_INR.
generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
unfold B_powerRZ in |- *; apply powerRZ_lt_r_bis.
replace 1 with (INR 1).
apply le_INR.
generalize B_sup_4; omega.
rewrite S_INR; simpl in |- *; ring.
apply le_pmax_n.
field; apply Rgt_not_eq; lra.
intro.
clear H1.
pattern (p_max yc n) in |- *.
apply ind_gt_le with (msd xc).
intro.
apply Rle_trans with (4 * / B_powerRZ (Z.succ (Z.succ 0))).
replace (4 * / B_powerRZ (Z.succ (Z.succ 0))) with
 (4 * INR B * / B_powerRZ (Z.succ (Z.succ (Z.succ 0)))).
apply
 Rle_trans
  with
    (2 * INR B *
     (B_powerRZ n * / B_powerRZ (p_max xc n + msd xc) +
      B_powerRZ n * / B_powerRZ (p_max yc n + msd yc))).
replace
 (2 * INR B *
  (B_powerRZ n * / B_powerRZ (p_max xc n + msd xc) +
   B_powerRZ n * / B_powerRZ (p_max yc n + msd yc))) with
 (2 * INR B *
  (B_powerRZ (p_max yc n - msd xc) + B_powerRZ (p_max xc n - msd yc)) *
  / B_powerRZ (p_max yc n + p_max xc n - n)).
apply Rmult_le_compat_r.
apply Rlt_le; apply Rinv_0_lt_compat; unfold B_powerRZ in |- *;
 apply powerRZ_lt; apply INR_B_non_nul.
rewrite plus_IZR.
rewrite Rmult_comm; rewrite Rmult_plus_distr_r.
apply Rplus_le_compat.
rewrite Rmult_comm; apply msd_ax2 with x; auto.
rewrite Rmult_comm; apply msd_ax2 with y; auto.
apply msd_ax1; auto.
rewrite Rmult_assoc; apply Rmult_eq_compat_l.
rewrite Rmult_plus_distr_r.
apply Rplus_plus_plus.
apply Rinv_Rmult_bis.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ (p_max yc n - msd xc) * B_powerRZ (p_max xc n + msd xc))
 with (B_powerRZ (p_max yc n - msd xc + (p_max xc n + msd xc))).
replace (B_powerRZ (p_max yc n + p_max xc n - n) * B_powerRZ n) with
 (B_powerRZ (p_max yc n + p_max xc n - n + n)).
unfold B_powerRZ in |- *; apply powerRZ_trivial.
ring.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rinv_Rmult_bis.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ (p_max xc n - msd yc) * B_powerRZ (p_max yc n + msd yc))
 with (B_powerRZ (p_max xc n - msd yc + (p_max yc n + msd yc))).
replace (B_powerRZ (p_max yc n + p_max xc n - n) * B_powerRZ n) with
 (B_powerRZ (p_max yc n + p_max xc n - n + n)).
unfold B_powerRZ in |- *; apply powerRZ_trivial.
ring.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
RingReplace (4 * INR B) (2 * INR B * 2).
do 2 rewrite Rmult_assoc; rewrite <- Rmult_assoc.
apply Rmult_le_compat_l.
apply Rmult_le_pos.
lra.
apply Rlt_le; apply INR_B_non_nul.
replace (/ B_powerRZ (p_max xc n + msd xc)) with
 (B_powerRZ (- (p_max xc n + msd xc))).
replace (/ B_powerRZ (p_max yc n + msd yc)) with
 (B_powerRZ (- (p_max yc n + msd yc))).
replace (/ B_powerRZ (Z.succ (Z.succ (Z.succ 0)))) with
 (B_powerRZ (- Z.succ (Z.succ (Z.succ 0)))).
replace (B_powerRZ n * B_powerRZ (- (p_max xc n + msd xc))) with
 (B_powerRZ (n + - (p_max xc n + msd xc))).
replace (B_powerRZ n * B_powerRZ (- (p_max yc n + msd yc))) with
 (B_powerRZ (n + - (p_max yc n + msd yc))).
RingReplace (2 * B_powerRZ (- Z.succ (Z.succ (Z.succ 0))))
 (B_powerRZ (- Z.succ (Z.succ (Z.succ 0))) +
  B_powerRZ (- Z.succ (Z.succ (Z.succ 0)))).
apply Rplus_le_compat.
unfold B_powerRZ in |- *; apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with (INR 4).
do 4 rewrite S_INR.
simpl in |- *; lra.
apply le_INR; generalize B_sup_4; omega.
rewrite Zplus_comm.
apply Zplus_le_reg_r with (Z.succ (Z.succ (Z.succ 0))).
simpl in |- *.
rewrite Zopp_plus_distr.
apply Zplus_le_reg_l with (p_max xc n).
RingReplace (p_max xc n + (- p_max xc n + - msd xc + n + 3))%Z
 (n - msd xc + 3)%Z.
rewrite <- Zplus_0_r_reverse.
unfold p_max in |- *.
apply Zle_max_l.
unfold B_powerRZ in |- *; apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with (INR 4).
do 4 rewrite S_INR.
simpl in |- *; lra.
apply le_INR; generalize B_sup_4; omega.
rewrite Zplus_comm.
apply Zplus_le_reg_r with (Z.succ (Z.succ (Z.succ 0))).
simpl in |- *.
rewrite Zopp_plus_distr.
apply Zplus_le_reg_l with (p_max yc n).
RingReplace (p_max yc n + (- p_max yc n + - msd yc + n + 3))%Z
 (n - msd yc + 3)%Z.
rewrite <- Zplus_0_r_reverse.
unfold p_max in |- *.
apply Zle_max_l.
unfold B_powerRZ in |- *; apply powerRZ_add; apply Rgt_not_eq; apply Rlt_gt;
 apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add; apply Rgt_not_eq; apply Rlt_gt;
 apply INR_B_non_nul.
unfold B_powerRZ in |- *; symmetry  in |- *; apply Rinv_powerRZ.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; symmetry  in |- *; apply Rinv_powerRZ.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; symmetry  in |- *; apply Rinv_powerRZ.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
rewrite Rmult_assoc; apply Rmult_eq_compat_l.
unfold B_powerRZ in |- *.
replace (powerRZ (INR B) (Z.succ (Z.succ (Z.succ 0)))) with
 (powerRZ (INR B) (Z.succ (Z.succ 0)) * INR B).
replace (/ (powerRZ (INR B) (Z.succ (Z.succ 0)) * INR B)) with
 (/ powerRZ (INR B) (Z.succ (Z.succ 0)) * / INR B).
rewrite Rmult_comm; rewrite Rmult_assoc.
replace (/ INR B * INR B) with 1.
rewrite RIneq.Rmult_1_r; auto.
apply Rinv_l_sym.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
symmetry  in |- *; apply Rinv_mult_distr.
apply Rgt_not_eq; apply Rlt_gt; apply powerRZ_lt; apply INR_B_non_nul.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
symmetry  in |- *; apply powerRZ_Zs.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
rewrite Rmult_comm; apply Rle_Rinv_monotony.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
rewrite Rmult_1l.
apply Rle_mult_inv.
lra.
unfold B_powerRZ in |- *.
replace (powerRZ (INR B) (Z.succ (Z.succ 0))) with (INR B * INR B).
apply Rmult_le_compat.
lra.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
apply Rle_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
RingReplace (Z.succ (Z.succ 0)) (Z.succ 0 + Z.succ 0)%Z.
replace (powerRZ (INR B) (Z.succ 0 + Z.succ 0)) with
 (powerRZ (INR B) (Z.succ 0) * powerRZ (INR B) (Z.succ 0)).
rewrite powerRZ_1; auto.
symmetry  in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.

intro.
apply Rle_trans with (3 * / 8).
2: lra.
apply
 Rle_trans
  with (1 * / INR B + 2 * INR B * / B_powerRZ (Z.succ (Z.succ (Z.succ 0)))).
apply
 Rle_trans
  with
    (/ B_powerRZ (p_max yc n + p_max xc n - n) +
     2 * INR B * B_powerRZ n * / B_powerRZ (p_max yc n + msd yc)).
rewrite plus_IZR.
replace
 (/ B_powerRZ (p_max yc n + p_max xc n - n) +
  2 * INR B * B_powerRZ n * / B_powerRZ (p_max yc n + msd yc)) with
 ((1 + 2 * INR B * B_powerRZ (p_max xc n - msd yc)) *
  / B_powerRZ (p_max yc n + p_max xc n - n)).
apply Rmult_le_compat_r.
apply Rlt_le; apply Rinv_0_lt_compat; unfold B_powerRZ in |- *;
 apply powerRZ_lt; apply INR_B_non_nul.
apply Rplus_le_compat.
RingReplace 1 (IZR (Z.succ 0)).
apply IZR_le.
apply msd_ax3.
auto.
apply msd_ax2 with y; auto.
apply msd_ax1; auto.
rewrite Rmult_plus_distr_r; rewrite Rmult_1l; apply Rplus_eq_compat_l.
rewrite Rmult_assoc; symmetry  in |- *; rewrite Rmult_assoc;
 apply Rmult_eq_compat_l.
apply Rinv_Rmult_bis.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ n * B_powerRZ (p_max yc n + p_max xc n - n)) with
 (B_powerRZ (n + (p_max yc n + p_max xc n - n))).
replace (B_powerRZ (p_max yc n + msd yc) * B_powerRZ (p_max xc n - msd yc))
 with (B_powerRZ (p_max yc n + msd yc + (p_max xc n - msd yc))).
unfold B_powerRZ in |- *; apply powerRZ_trivial; ring.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rplus_le_compat.
rewrite Rmult_1l; apply Rinv_le.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
apply INR_B_non_nul.
unfold B_powerRZ in |- *.
pattern (INR B) at 1 in |- *.
replace (INR B) with (powerRZ (INR B) (Z.succ 0)).
apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
apply le_pmax_n.
apply powerRZ_1.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rmult_le_pos.
lra.
apply Rlt_le; apply INR_B_non_nul.
rewrite Rmult_comm; apply Rle_Rinv_monotony.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
apply Rle_mult_inv.
apply Rlt_gt; unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ n * B_powerRZ (Z.succ (Z.succ (Z.succ 0)))) with
 (B_powerRZ (n + Z.succ (Z.succ (Z.succ 0)))).
unfold B_powerRZ in |- *; apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
apply Zplus_le_reg_r with (- msd yc)%Z.
simpl in |- *.
RingReplace (n + 3 + - msd yc)%Z (n - msd yc + 3)%Z.
RingReplace (p_max yc n + msd yc + - msd yc)%Z (p_max yc n).
unfold p_max in |- *.
apply Zle_max_l.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *.
apply Rle_trans with (1 * / 4 + 2 * / powerRZ 4 (Z.succ (Z.succ 0))).
apply Rplus_le_compat.
do 2 rewrite Rmult_1l; apply Rinv_le.
apply INR_B_non_nul.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
rewrite Rmult_assoc; apply Rmult_le_compat_l.
lra.
replace (/ powerRZ (INR B) (Z.succ (Z.succ (Z.succ 0)))) with
 (powerRZ (INR B) (- Z.succ (Z.succ (Z.succ 0)))).
replace (/ powerRZ 4 (Z.succ (Z.succ 0))) with (powerRZ 4 (- Z.succ (Z.succ 0))).
replace (INR B * powerRZ (INR B) (- Z.succ (Z.succ (Z.succ 0)))) with
 (powerRZ (INR B) (Z.succ 0 + - Z.succ (Z.succ (Z.succ 0)))).
simpl in |- *.
do 2 rewrite RIneq.Rmult_1_r.
apply Rinv_le.
apply Rmult_lt_0_compat.
apply INR_B_non_nul.
apply INR_B_non_nul.
lra.
generalize (Rsqr_incr_1 4 (INR B)).
unfold Rsqr in |- *.
intros.
apply H4.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
lra.
apply Rle_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
simpl in |- *.
rewrite RIneq.Rmult_1_r.
symmetry  in |- *; rewrite Rinv_mult_distr.
rewrite <- Rmult_assoc.
symmetry  in |- *; apply Rbase_operations.Rmult_1_r.
apply Rinv_r_sym.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rgt_not_eq; apply Rlt_gt; apply Rmult_lt_0_compat.
apply INR_B_non_nul.
apply INR_B_non_nul.
simpl in |- *.
field.
auto.
simpl in |- *.
lra.

(*derniere partie*)

intro.
pattern (p_max xc n) in |- *.
apply ind_gt_le with (msd yc).
intro.
apply Rle_trans with (4 * / B_powerRZ (Z.succ (Z.succ 0))).
replace (4 * / B_powerRZ (Z.succ (Z.succ 0))) with
 (4 * INR B * / B_powerRZ (Z.succ (Z.succ (Z.succ 0)))).
apply
 Rle_trans
  with
    (2 * INR B *
     (B_powerRZ n * / B_powerRZ (p_max xc n + msd xc) +
      B_powerRZ n * / B_powerRZ (p_max yc n + msd yc))).
replace
 (2 * INR B *
  (B_powerRZ n * / B_powerRZ (p_max xc n + msd xc) +
   B_powerRZ n * / B_powerRZ (p_max yc n + msd yc))) with
 (2 * INR B *
  (B_powerRZ (p_max yc n - msd xc) + B_powerRZ (p_max xc n - msd yc)) *
  / B_powerRZ (p_max yc n + p_max xc n - n)).
apply Rmult_le_compat_r.
apply Rlt_le; apply Rinv_0_lt_compat; unfold B_powerRZ in |- *;
 apply powerRZ_lt; apply INR_B_non_nul.
rewrite plus_IZR.
rewrite Rmult_comm; rewrite Rmult_plus_distr_r.
apply Rplus_le_compat.
rewrite Rmult_comm; apply msd_ax2 with x; auto.
apply msd_ax1; auto.
rewrite Rmult_comm; apply msd_ax2 with y; auto.
rewrite Rmult_assoc; apply Rmult_eq_compat_l.
rewrite Rmult_plus_distr_r.
apply Rplus_plus_plus.
apply Rinv_Rmult_bis.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ (p_max yc n - msd xc) * B_powerRZ (p_max xc n + msd xc))
 with (B_powerRZ (p_max yc n - msd xc + (p_max xc n + msd xc))).
replace (B_powerRZ (p_max yc n + p_max xc n - n) * B_powerRZ n) with
 (B_powerRZ (p_max yc n + p_max xc n - n + n)).
unfold B_powerRZ in |- *; apply powerRZ_trivial.
ring.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rinv_Rmult_bis.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ (p_max xc n - msd yc) * B_powerRZ (p_max yc n + msd yc))
 with (B_powerRZ (p_max xc n - msd yc + (p_max yc n + msd yc))).
replace (B_powerRZ (p_max yc n + p_max xc n - n) * B_powerRZ n) with
 (B_powerRZ (p_max yc n + p_max xc n - n + n)).
unfold B_powerRZ in |- *; apply powerRZ_trivial.
ring.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
RingReplace (4 * INR B) (2 * INR B * 2).
do 2 rewrite Rmult_assoc; rewrite <- Rmult_assoc.
apply Rmult_le_compat_l.
apply Rmult_le_pos.
lra.
apply Rlt_le; apply INR_B_non_nul.
replace (/ B_powerRZ (p_max xc n + msd xc)) with
 (B_powerRZ (- (p_max xc n + msd xc))).
replace (/ B_powerRZ (p_max yc n + msd yc)) with
 (B_powerRZ (- (p_max yc n + msd yc))).
replace (/ B_powerRZ (Z.succ (Z.succ (Z.succ 0)))) with
 (B_powerRZ (- Z.succ (Z.succ (Z.succ 0)))).
replace (B_powerRZ n * B_powerRZ (- (p_max xc n + msd xc))) with
 (B_powerRZ (n + - (p_max xc n + msd xc))).
replace (B_powerRZ n * B_powerRZ (- (p_max yc n + msd yc))) with
 (B_powerRZ (n + - (p_max yc n + msd yc))).
RingReplace (2 * B_powerRZ (- Z.succ (Z.succ (Z.succ 0))))
 (B_powerRZ (- Z.succ (Z.succ (Z.succ 0))) +
  B_powerRZ (- Z.succ (Z.succ (Z.succ 0)))).
apply Rplus_le_compat.
unfold B_powerRZ in |- *; apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with (INR 4).
do 4 rewrite S_INR.
simpl in |- *; lra.
apply le_INR; generalize B_sup_4; omega.
rewrite Zplus_comm.
apply Zplus_le_reg_r with (Z.succ (Z.succ (Z.succ 0))).
simpl in |- *.
rewrite Zopp_plus_distr.
apply Zplus_le_reg_l with (p_max xc n).
RingReplace (p_max xc n + (- p_max xc n + - msd xc + n + 3))%Z
 (n - msd xc + 3)%Z.
rewrite <- Zplus_0_r_reverse.
unfold p_max in |- *.
apply Zle_max_l.
unfold B_powerRZ in |- *; apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with (INR 4).
do 4 rewrite S_INR.
simpl in |- *; lra.
apply le_INR; generalize B_sup_4; omega.
rewrite Zplus_comm.
apply Zplus_le_reg_r with (Z.succ (Z.succ (Z.succ 0))).
simpl in |- *.
rewrite Zopp_plus_distr.
apply Zplus_le_reg_l with (p_max yc n).
RingReplace (p_max yc n + (- p_max yc n + - msd yc + n + 3))%Z
 (n - msd yc + 3)%Z.
rewrite <- Zplus_0_r_reverse.
unfold p_max in |- *.
apply Zle_max_l.
unfold B_powerRZ in |- *; apply powerRZ_add; apply Rgt_not_eq; apply Rlt_gt;
 apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add; apply Rgt_not_eq; apply Rlt_gt;
 apply INR_B_non_nul.
unfold B_powerRZ in |- *; symmetry  in |- *; apply Rinv_powerRZ.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; symmetry  in |- *; apply Rinv_powerRZ.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; symmetry  in |- *; apply Rinv_powerRZ.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
rewrite Rmult_assoc; apply Rmult_eq_compat_l.
unfold B_powerRZ in |- *.
replace (powerRZ (INR B) (Z.succ (Z.succ (Z.succ 0)))) with
 (powerRZ (INR B) (Z.succ (Z.succ 0)) * INR B).
replace (/ (powerRZ (INR B) (Z.succ (Z.succ 0)) * INR B)) with
 (/ powerRZ (INR B) (Z.succ (Z.succ 0)) * / INR B).
rewrite Rmult_comm; rewrite Rmult_assoc.
replace (/ INR B * INR B) with 1.
rewrite RIneq.Rmult_1_r; auto.
apply Rinv_l_sym.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
symmetry  in |- *; apply Rinv_mult_distr.
apply Rgt_not_eq; apply Rlt_gt; apply powerRZ_lt; apply INR_B_non_nul.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
symmetry  in |- *; apply powerRZ_Zs.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
rewrite Rmult_comm; apply Rle_Rinv_monotony.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
rewrite Rmult_1l.
apply Rle_mult_inv.
lra.
unfold B_powerRZ in |- *.
replace (powerRZ (INR B) (Z.succ (Z.succ 0))) with (INR B * INR B).
apply Rmult_le_compat.
lra.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
apply Rle_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
RingReplace (Z.succ (Z.succ 0)) (Z.succ 0 + Z.succ 0)%Z.
replace (powerRZ (INR B) (Z.succ 0 + Z.succ 0)) with
 (powerRZ (INR B) (Z.succ 0) * powerRZ (INR B) (Z.succ 0)).
rewrite powerRZ_1; auto.
symmetry  in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.

intro.
apply Rle_trans with (3 * / 8).
2: lra.
apply
 Rle_trans
  with (1 * / INR B + 2 * INR B * / B_powerRZ (Z.succ (Z.succ (Z.succ 0)))).
apply
 Rle_trans
  with
    (2 * INR B * B_powerRZ n * / B_powerRZ (p_max xc n + msd xc) +
     / B_powerRZ (p_max yc n + p_max xc n - n)).
rewrite plus_IZR.
replace
 (2 * INR B * B_powerRZ n * / B_powerRZ (p_max xc n + msd xc) +
  / B_powerRZ (p_max yc n + p_max xc n - n)) with
 ((2 * INR B * B_powerRZ (p_max yc n - msd xc) + 1) *
  / B_powerRZ (p_max yc n + p_max xc n - n)).
apply Rmult_le_compat_r.
apply Rlt_le; apply Rinv_0_lt_compat; unfold B_powerRZ in |- *;
 apply powerRZ_lt; apply INR_B_non_nul.
apply Rplus_le_compat.
apply msd_ax2 with x; auto.
apply msd_ax1.
auto.
RingReplace 1 (IZR (Z.succ 0)).
apply IZR_le.
apply msd_ax3.
auto.
rewrite Rmult_plus_distr_r.
rewrite Rmult_1l.
rewrite Rplus_comm; symmetry  in |- *; rewrite Rplus_comm;
 apply Rplus_eq_compat_l.
rewrite Rmult_assoc; symmetry  in |- *; rewrite Rmult_assoc;
 apply Rmult_eq_compat_l.
apply Rinv_Rmult_bis.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ (p_max yc n + p_max xc n - n) * B_powerRZ n) with
 (B_powerRZ (p_max yc n + p_max xc n - n + n)).
replace (B_powerRZ (p_max yc n - msd xc) * B_powerRZ (p_max xc n + msd xc))
 with (B_powerRZ (p_max yc n - msd xc + (p_max xc n + msd xc))).
unfold B_powerRZ in |- *; apply powerRZ_trivial; ring.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
rewrite Rplus_comm.
apply Rplus_le_compat.
rewrite Rmult_1l; apply Rinv_le.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
apply INR_B_non_nul.
unfold B_powerRZ in |- *.
pattern (INR B) at 1 in |- *.
replace (INR B) with (powerRZ (INR B) (Z.succ 0)).
apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
apply le_pmax_n.
apply powerRZ_1.
rewrite Rmult_assoc.
apply Rmult_le_compat_l.
apply Rmult_le_pos.
lra.
apply Rlt_le; apply INR_B_non_nul.
rewrite Rmult_comm; apply Rle_Rinv_monotony.
unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
apply Rle_mult_inv.
apply Rlt_gt; unfold B_powerRZ in |- *; apply powerRZ_lt; apply INR_B_non_nul.
replace (B_powerRZ n * B_powerRZ (Z.succ (Z.succ (Z.succ 0)))) with
 (B_powerRZ (n + Z.succ (Z.succ (Z.succ 0)))).
unfold B_powerRZ in |- *; apply Rle_powerRZ.
apply Rlt_le; apply Rlt_le_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
apply Zplus_le_reg_r with (- msd xc)%Z.
simpl in |- *.
RingReplace (n + 3 + - msd xc)%Z (n - msd xc + 3)%Z.
RingReplace (p_max xc n + msd xc + - msd xc)%Z (p_max xc n).
unfold p_max in |- *.
apply Zle_max_l.
unfold B_powerRZ in |- *; apply powerRZ_add.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
unfold B_powerRZ in |- *.
apply Rle_trans with (1 * / 4 + 2 * / powerRZ 4 (Z.succ (Z.succ 0))).
apply Rplus_le_compat.
do 2 rewrite Rmult_1l; apply Rinv_le.
apply INR_B_non_nul.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
rewrite Rmult_assoc; apply Rmult_le_compat_l.
lra.
replace (/ powerRZ (INR B) (Z.succ (Z.succ (Z.succ 0)))) with
 (powerRZ (INR B) (- Z.succ (Z.succ (Z.succ 0)))).
replace (/ powerRZ 4 (Z.succ (Z.succ 0))) with (powerRZ 4 (- Z.succ (Z.succ 0))).
replace (INR B * powerRZ (INR B) (- Z.succ (Z.succ (Z.succ 0)))) with
 (powerRZ (INR B) (Z.succ 0 + - Z.succ (Z.succ (Z.succ 0)))).
simpl in |- *.
do 2 rewrite RIneq.Rmult_1_r.
apply Rinv_le.
apply Rmult_lt_0_compat.
apply INR_B_non_nul.
apply INR_B_non_nul.
lra.
generalize (Rsqr_incr_1 4 (INR B)).
unfold Rsqr in |- *.
intros.
apply H4.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
lra.
apply Rle_trans with 4.
lra.
replace 4 with (INR 4).
apply le_INR; generalize B_sup_4; omega.
do 4 rewrite S_INR; simpl in |- *; ring.
simpl in |- *.
rewrite RIneq.Rmult_1_r.
symmetry  in |- *; rewrite Rinv_mult_distr.
rewrite <- Rmult_assoc.
symmetry  in |- *; apply Rbase_operations.Rmult_1_r.
apply Rinv_r_sym.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rgt_not_eq; apply Rlt_gt; apply INR_B_non_nul.
apply Rgt_not_eq; apply Rlt_gt; apply Rmult_lt_0_compat.
apply INR_B_non_nul.
apply INR_B_non_nul.
simpl in |- *.
field.
auto.
simpl in |- *.
lra.
Qed.

Hint Resolve multiplication_correct: reals.


(****************************************************************************)
(* Copyright 2021 The Project Oak Authors                                   *)
(*                                                                          *)
(* Licensed under the Apache License, Version 2.0 (the "License")           *)
(* you may not use this file except in compliance with the License.         *)
(* You may obtain a copy of the License at                                  *)
(*                                                                          *)
(*     http://www.apache.org/licenses/LICENSE-2.0                           *)
(*                                                                          *)
(* Unless required by applicable law or agreed to in writing, software      *)
(* distributed under the License is distributed on an "AS IS" BASIS,        *)
(* WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. *)
(* See the License for the specific language governing permissions and      *)
(* limitations under the License.                                           *)
(****************************************************************************)

Require Import Coq.Lists.List.
Require Import Coq.NArith.NArith.
Require Import Cava.Util.BitArithmetic.
Require Import Cava.Util.Byte.
Require Import HmacSpec.SHA256.
Require Import HmacSpec.Tests.SHA256TestVectors.
Import ListNotations BigEndianBytes.
Local Open Scope N_scope.

(* Tests for SHA-256 spec *)

(* Helper function for evaluating big-endian lists of words *)
Definition eval_words (x : list N) : N :=
  fold_left (fun acc => N.lor (N.shiftl acc w)) x 0.

(* Uncomment the below for step-by-step tests of intermediate values for test1
   (useful for debugging) *)
(*
(* test padded_msg *)
Goal (let t := test1 in
      eval_words (padded_msg t.(msg_bytes)) = t.(expected_padded_msg)).
Proof. vm_compute. reflexivity. Qed.

(* test first 16 blocks of W for round 0 *)
Goal (let t := test1 in
      let i := 0%nat in
      let expected_W := nth i t.(expected_blocks) [] in
      firstn 16 (W t.(msg_bytes) i) = expected_W).
Proof. vm_compute. reflexivity. Qed.

(* test round 0 *)
Goal (let t := test1 in
      let i := 0%nat in
      let old_H := H0 in
      let expected_H := nth i t.(expected_intermediate_digests) [] in
      sha256_step t.(msg_bytes) old_H i = expected_H).
Proof. vm_compute. reflexivity. Qed.
 *)

(* test final digest *)
Goal (let t := test1 in
      concat_bytes (sha256 t.(msg_bytes)) = t.(expected_digest)).
Proof. vm_compute. reflexivity. Qed.

(* Uncomment the below for step-by-step tests of intermediate values for test2
   (useful for debugging) *)
(*
(* test padded_msg *)
Goal (let t := test2 in
      eval_words (padded_msg t.(msg_bytes)) = t.(expected_padded_msg)).
Proof. vm_compute. reflexivity. Qed.

(* test first 16 blocks of W for round 0 *)
Goal (let t := test2 in
      let i := 0%nat in
      let expected_W := nth i t.(expected_blocks) [] in
      firstn 16 (W t.(msg_bytes) i) = expected_W).
Proof. vm_compute. reflexivity. Qed.

(* test round 0 *)
Goal (let t := test2 in
      let i := 0%nat in
      let old_H := H0 in
      let expected_H := nth i t.(expected_intermediate_digests) [] in
      sha256_step t.(msg_bytes) old_H i = expected_H).
Proof. vm_compute. reflexivity. Qed.

(* test first 16 blocks of W for round 1 *)
Goal (let t := test2 in
      let i := 1%nat in
      let expected_W := nth i t.(expected_blocks) [] in
      firstn 16 (W t.(msg_bytes) i) = expected_W).
Proof. vm_compute. reflexivity. Qed.

(* test round 1 *)
Goal (let t := test2 in
      let i := 1%nat in
      let old_H := nth (i-1) t.(expected_intermediate_digests) [] in
      let expected_H := nth i t.(expected_intermediate_digests) [] in
      sha256_step t.(msg_bytes) old_H i = expected_H).
Proof. vm_compute. reflexivity. Qed.
*)

(* test final digest *)
Goal (let t := test2 in
      concat_bytes (sha256 t.(msg_bytes)) = t.(expected_digest)).
Proof. vm_compute. reflexivity. Qed.

(* test final digest *)
Goal (let t := test3 in
      concat_bytes (sha256 t.(msg_bytes)) = t.(expected_digest)).
Proof. vm_compute. reflexivity. Qed.

(* test final digest *)
Goal (let t := test4 in
      concat_bytes (sha256 t.(msg_bytes)) = t.(expected_digest)).
Proof. vm_compute. reflexivity. Qed.


(** Although [SimulationRelation] includes a lot of properties, many
  of them are straightforward to prove, and many proofs end up being
  very similar. In this file we provide ready-to-use proofs for
  [simrel_components] which satisfy some common properties. *)

Require Export SimrelDefinition.

Section WITHMEM.
  Context `{Hmem: BaseMemoryModel}.
  Context D1 D2 (R: simrel_components D1 D2).

  (** * Trivial Kripke frames *)

  (** Often we use a trivial Kripke frame, then monotonicity wrt. the
    accessibility relation is trivial to prove. *)

  Class TrivialWorld :=
    {
      simrel_trivial_acc:
        le (A := simrel_world R) = eq;
    }.

  Section TRIVIAL_WORLD.
    Context `{HR: TrivialWorld}.

    Global Instance simrel_tw_acc_preorder:
      @PreOrder (simrel_world R) (≤).
    Proof.
      rewrite simrel_trivial_acc.
      typeclasses eauto.
    Qed.

    Global Instance simrel_tw_acc_undef_matches_pointer:
      Monotonic (simrel_undef_matches_block R) ((≤) ++> - ==> impl).
    Proof.
      rewrite simrel_trivial_acc.
      repeat rstep.
      congruence.
    Qed.

    Global Instance simrel_acc_meminj:
      Monotonic (simrel_meminj R) ((≤) ++> - ==> option_le eq).
    Proof.
      rewrite simrel_trivial_acc.
      repeat rstep.
      subst.
      reflexivity.
    Qed.
  End TRIVIAL_WORLD.

  (** * Coreflexive [match_val] *)

  (** ** Definition *)

  (** If [simrel_meminj] is a sub-injection of [inject_id] and the
    relation does not refine [Vundef], then the corresponding
    [match_val] is coreflexive. *)

  Class CoreflexiveInjection :=
    {
      simrel_meminj_corefl w:
        inject_incr (simrel_meminj R w) inject_id;
      simrel_undef_matches_values_corefl:
        simrel_undef_matches_values_bool R = false;
      simrel_undef_matches_block_corefl w b:
        ~ simrel_undef_matches_block R w b;
    }.

  (** ** Properties *)

  Section COREFL_MEMINJ.
    Context `{HR: CoreflexiveInjection}.

    Global Instance simrel_corefl_acc_undef_matches_pointer:
      Monotonic (simrel_undef_matches_block R) ((≤) ++> - ==> impl).
    Proof.
      intros w1 w2 _ b.
      generalize (simrel_undef_matches_block_corefl w1 b).
      generalize (simrel_undef_matches_block_corefl w2 b).
      clear.
      firstorder.
    Qed.

    Global Instance match_ptr_corefl w:
      Coreflexive (match_ptr R w).
    Proof.
      intros ptr1 ptr2 Hptr.
      destruct Hptr.
      apply simrel_meminj_corefl in H.
      inversion H; clear H; subst.
      rewrite Z.add_0_r.
      reflexivity.
    Qed.

    Global Instance match_ptrbits_corefl w:
      Coreflexive (match_ptrbits R w).
    Proof.
      intros ptr1 ptr2 Hptr.
      destruct Hptr.
      apply simrel_meminj_corefl in H.
      inversion H; subst.
      rewrite Ptrofs.add_zero.
      reflexivity.
    Qed.

    Global Instance match_ptrrange_corefl w:
      Coreflexive (match_ptrrange R w).
    Proof.
      intros r1 r2 Hr.
      destruct Hr as [b1 ofs1 b2 ofs2 delta Hptr].
      apply coreflexivity in Hptr.
      inversion Hptr; clear Hptr; subst.
      reflexivity.
    Qed.

    Global Instance match_val_corefl w:
      Coreflexive (match_val R w).
    Proof.
      pose proof simrel_undef_matches_values_corefl as Humvn.
      intros v1 v2 Hv.
      destruct Hv; eauto; try congruence.
      - apply coreflexivity in H.
        congruence.
      - apply simrel_undef_matches_block_corefl in H.
        contradiction.
    Qed.

    Global Instance match_memval_corefl w:
      Coreflexive (match_memval R w).
    Proof.
      pose proof simrel_undef_matches_values_corefl as Humvn.
      intros v1 v2 Hv.
      destruct Hv; eauto; try congruence.
      destruct H; eauto; try congruence.
      - apply coreflexivity in H.
        congruence.
      - apply simrel_undef_matches_block_corefl in H.
        contradiction.
    Qed.

    Global Instance match_block_corefl w:
      Coreflexive (match_block R w).
    Proof.
      intros b1 b2 Hb.
      destruct Hb.
      apply simrel_meminj_corefl in H.
      inversion H.
      reflexivity.
    Qed.

    Global Instance match_block_sameofs_corefl w:
      Coreflexive (match_block_sameofs R w).
    Proof.
      intros b1 b2 Hb.
      red in Hb.
      apply simrel_meminj_corefl in Hb.
      inversion Hb.
      reflexivity.
    Qed.

    Lemma simrel_corefl_undef_matches_values_also_block w ptr1 b2 ofs2:
      simrel_undef_matches_values R ->
      match_ptrbits R w ptr1 (b2, ofs2) ->
      simrel_undef_matches_block R w b2.
    Proof.
      intros Huv _.
      exfalso.
      red in Huv.
      rewrite simrel_undef_matches_values_corefl in Huv.
      discriminate.
    Qed.

    Lemma simrel_corefl_undef_matches_block_also_values w b2:
      simrel_undef_matches_block R w b2 ->
      simrel_undef_matches_values R.
    Proof.
      intros Hub.
      exfalso.
      apply simrel_undef_matches_block_corefl in Hub.
      contradiction.
    Qed.

    Lemma simrel_corefl_undef_matches_block_or_injective w b2:
      forall b1 b1',
        b1' <> b1 ->
        match_block R w b1 b2 ->
        match_block R w b1' b2 ->
        simrel_undef_matches_block R w b2.
    Proof.
      intros b1 b1' Hb1 Hb Hb'.
      exfalso.
      apply coreflexivity in Hb.
      apply coreflexivity in Hb'.
      congruence.
    Qed.

    Lemma simrel_corefl_different_pointers_inject:
      forall w m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2,
        match_mem R w m m' ->
        b1 <> b2 ->
        Mem.valid_pointer m b1 (Ptrofs.unsigned ofs1) = true ->
        Mem.valid_pointer m b2 (Ptrofs.unsigned ofs2) = true ->
        simrel_meminj R w b1 = Some (b1', delta1) ->
        simrel_meminj R w b2 = Some (b2', delta2) ->
        b1' <> b2' \/
        Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta1)) <>
        Ptrofs.unsigned (Ptrofs.add ofs2 (Ptrofs.repr delta2)).
    Proof.
      intros w m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2.
      intros _ Hb _ _ Hb1 Hb2.
      left.
      apply simrel_meminj_corefl in Hb1.
      apply simrel_meminj_corefl in Hb2.
      unfold inject_id in *.
      inversion Hb1; clear Hb1.
      inversion Hb2; clear Hb2.
      congruence.
    Qed.

    Lemma simrel_corefl_weak_valid_pointer_address_inject_weak:
      forall w m1 m2 b1 b2 delta,
        match_mem R w m1 m2 ->
        simrel_meminj R w b1 = Some (b2, delta) ->
        exists delta',
          forall ofs1,
            Mem.weak_valid_pointer m1 b1 (Ptrofs.unsigned ofs1) = true ->
            Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) =
            (Ptrofs.unsigned ofs1 + delta')%Z.
    Proof.
      intros w m1 m2 b1 b2 delta.
      intros _ H.
      exists delta.
      intros ofs1 _.
      apply simrel_meminj_corefl in H.
      inversion H; clear H.
      rewrite Ptrofs.add_zero.
      rewrite Z.add_0_r.
      reflexivity.
    Qed.

    Lemma simrel_corefl_address_inject:
      forall w m1 m2 b1 ofs1 b2 delta pe,
        match_mem R w m1 m2 ->
        Mem.perm m1 b1 (Ptrofs.unsigned ofs1) Cur pe ->
        simrel_meminj R w b1 = Some (b2, delta) ->
        Ptrofs.unsigned (Ptrofs.add ofs1 (Ptrofs.repr delta)) =
        (Ptrofs.unsigned ofs1 + delta)%Z.
    Proof.
      intros w m1 m2 b1 ofs1 b2 delta pe.
      intros _ _ H.
      apply simrel_meminj_corefl in H.
      inversion H; clear H.
      rewrite Ptrofs.add_zero.
      rewrite Z.add_0_r.
      reflexivity.
    Qed.

    Lemma simrel_corefl_aligned_area_inject:
      forall w m m' b ofs al sz b' delta,
        match_mem R w m m' ->
        (al = 1 \/ al = 2 \/ al = 4 \/ al = 8) ->
        sz > 0 ->
        (al | sz) ->
        Mem.range_perm m b ofs (ofs + sz) Cur Nonempty ->
        (al | ofs) ->
        simrel_meminj R w b = Some (b', delta) ->
        (al | ofs + delta).
    Proof.
      intros w m m' b ofs al sz b' delta.
      intros _ _ _ Hsz _ Hofs H.
      apply simrel_meminj_corefl in H.
      inversion H; clear H.
      rewrite Z.add_0_r.
      assumption.
    Qed.

    Lemma simrel_corefl_disjoint_or_equal_inject:
      forall w m m' b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 sz,
        match_mem R w m m' ->
        simrel_meminj R w b1 = Some (b1', delta1) ->
        simrel_meminj R w b2 = Some (b2', delta2) ->
        Mem.range_perm m b1 ofs1
                       (ofs1 + sz) Max Nonempty ->
        Mem.range_perm m b2 ofs2
                       (ofs2 + sz) Max Nonempty ->
        sz > 0 ->
        b1 <> b2 \/
        ofs1 = ofs2 \/
        ofs1 + sz <= ofs2 \/ ofs2 + sz <= ofs1 ->
        b1' <> b2' \/
        (ofs1 + delta1 = ofs2 + delta2)%Z \/
        ofs1 + delta1 + sz <= ofs2 + delta2 \/
        ofs2 + delta2 + sz <= ofs1 + delta1.
    Proof.
      intros w m m' b1 b1' delta' b2 b2' delta2 ofs1 ofs2 sz.
      intros _ H1 H2 _ _ _ H.
      apply simrel_meminj_corefl in H1; inversion H1; clear H1.
      apply simrel_meminj_corefl in H2; inversion H2; clear H2.
      rewrite !Z.add_0_r.
      destruct H; eauto.
      left; congruence.
    Qed.

    (** ** Simplified proof *)

    Class CoreflexiveSimulationRelation :=
      {
        simrel_corefl_acc_preorder:
          @PreOrder (simrel_world R) (≤);

        simrel_corefl_acc_meminj:
          Monotonic (simrel_meminj R) ((≤) ++> - ==> option_le ⊤);

        simrel_corefl_weak_valid_pointer w m1 m2 b ofs:
          match_mem R w m1 m2 ->
          Mem.weak_valid_pointer m1 b (Ptrofs.unsigned ofs) =
          Mem.weak_valid_pointer m2 b (Ptrofs.unsigned ofs);

        simrel_corefl_undef_matches_block_invalid w m1 m2 b ofs:
          match_mem R w m1 m2 ->
          Mem.valid_pointer m1 b (Ptrofs.unsigned ofs) = false ->
          Mem.valid_pointer m2 b (Ptrofs.unsigned ofs) = false;

        corefl_match_undef_global_block_sameofs w b:
          block_is_global b ->
          simrel_meminj R w b <> None;

        simrel_corefl_init_mem {F V}:
          Monotonic
            (Genv.init_mem (F:=F) (V:=V))
            (simrel_program_rel R ++>
             option_le (rexists w, match_mem R w));

        simrel_corefl_alloc w:
          Monotonic
            Mem.alloc
            (match_mem R w ++> - ==> - ==>
             incr w (match_mem R w * match_block_sameofs R w));

        simrel_corefl_free w:
          Monotonic
            Mem.free
            (match_mem R w ++> match_block R w ++> - ==> - ==>
             option_le (incr w (match_mem R w)));

        simrel_corefl_load w:
          Monotonic
            Mem.load
            (- ==> match_mem R w ++> match_block R w ++> - ==>
             option_le (match_val R w));

        simrel_corefl_store w:
          Monotonic
            Mem.store
            (- ==> match_mem R w ++> match_block R w ++> - ==> match_val R w ++>
             option_le (incr w (match_mem R w)));

        simrel_corefl_loadbytes w:
          Monotonic
            Mem.loadbytes
            (match_mem R w ++> match_block R w ++> - ==> - ==>
             option_le (list_rel (match_memval R w)));

        simrel_corefl_storebytes w:
          Monotonic
            Mem.storebytes
            (match_mem R w ++> match_block R w ++> - ==>
             list_rel (match_memval R w) ++>
             option_le (incr w (match_mem R w)));

        simrel_corefl_perm w:
          Monotonic
            Mem.perm
            (match_mem R w ++> match_block R w ++> - ==> - ==> - ==> impl);

        simrel_corefl_valid_block p:
          Monotonic
            Mem.valid_block
            (match_mem R p ++> - ==> iff);
      }.

    Global Instance simrel_corefl_prf `{CoreflexiveSimulationRelation}:
      SimulationRelation R.
    Proof.
      split; try typeclasses eauto.
      - apply simrel_corefl_acc_preorder.
      - intros w1 w2 Hw b.
        pose proof (simrel_corefl_acc_meminj w1 w2 Hw b) as Hb'.
        destruct (simrel_meminj R w1 b) as [[b1' o1]|] eqn:Hb1'; try constructor.
        inversion Hb' as [xb1' | xb1' [b2' o2] _ Hxb1' Hb2']; clear Hb'; subst.
        constructor.
        symmetry in Hb2'.
        apply simrel_meminj_corefl in Hb1'.
        apply simrel_meminj_corefl in Hb2'.
        congruence.
      - apply simrel_corefl_undef_matches_values_also_block.
      - apply simrel_corefl_undef_matches_block_also_values.
      - apply simrel_corefl_undef_matches_block_or_injective.
      - intros w m1 m2 b1 ofs1 b2 ofs2 Hm H1 Hptr H2.
        apply coreflexivity in Hptr.
        inversion Hptr; clear Hptr; subst.
        erewrite simrel_corefl_weak_valid_pointer in H1 by eauto.
        congruence.
      - intros w m1 m2 b1 ofs1 b2 ofs2 Hm H1 Hptr H2.
        apply coreflexivity in Hptr.
        inversion Hptr; clear Hptr; subst.
        eapply simrel_corefl_undef_matches_block_invalid in H1; eauto.
        congruence.
      - intros w b Hb.
        apply (corefl_match_undef_global_block_sameofs w) in Hb.
        unfold Proper, match_block_sameofs.
        destruct (simrel_meminj R w b) as [[b' delta]|] eqn:Hb'; [ | congruence].
        apply simrel_meminj_corefl in Hb'.
        unfold inject_id in Hb'.
        congruence.
      - intros F V.
        apply simrel_corefl_init_mem.
      - apply simrel_corefl_alloc.
      - intros w m1 m2 Hm [[b1 lo1] hi1] [[b2 lo2] hi2] Hrange.
        unfold uncurry.
        pose proof (coreflexivity _ _ Hrange) as Hrange_eq.
        apply match_ptrrange_ptr in Hrange.
        apply match_ptr_block in Hrange.
        inversion Hrange_eq; clear Hrange_eq; subst.
        edestruct (simrel_corefl_free w m1 m2 Hm b2 b2 Hrange lo2 hi2);
          constructor; eauto.
      - intros w chunk m1 m2 Hm [b1 ofs1] [b2 ofs2] Hptr.
        unfold uncurry.
        pose proof (coreflexivity _ _ Hptr) as Hptr_eq.
        inversion Hptr_eq; clear Hptr_eq; subst.
        apply match_ptr_block in Hptr.
        apply simrel_corefl_load; eauto.
      - intros w chunk m1 m2 Hm [b1 ofs1] [b2 ofs2] Hptr v1 v2 Hv.
        unfold uncurry.
        pose proof (match_ptr_block _ _ _ _ _ Hptr) as Hblock.
        apply coreflexivity in Hptr; inversion Hptr; clear Hptr; subst.
        apply simrel_corefl_store; eauto.
      - intros w m1 m2 Hm [b1 ofs1] [b2 ofs2] Hptr sz.
        unfold uncurry.
        pose proof (match_ptr_block _ _ _ _ _ Hptr) as Hblock.
        apply coreflexivity in Hptr; inversion Hptr; clear Hptr; subst.
        apply simrel_corefl_loadbytes; eauto.
      - intros w m1 m2 Hm [b1 ofs1] [b2 ofs2] Hptr bytes1 bytes2 Hbytes.
        unfold uncurry.
        pose proof (match_ptr_block _ _ _ _ _ Hptr) as Hblock.
        apply coreflexivity in Hptr; inversion Hptr; clear Hptr; subst.
        apply simrel_corefl_storebytes; eauto.
      - intros w m1 m2 Hm [b1 ofs1] [b2 ofs2] Hptr k pe.
        unfold uncurry.
        pose proof (match_ptr_block _ _ _ _ _ Hptr) as Hblock.
        apply coreflexivity in Hptr; inversion Hptr; clear Hptr; subst.
        apply (simrel_corefl_perm w); eauto.
      - intros w m1 m2 Hm b1 b2 Hb.
        pose proof Hb as Hblock.
        apply coreflexivity in Hb; subst.
        apply (simrel_corefl_valid_block w); eauto.
      - apply simrel_corefl_different_pointers_inject.
      - intros w m1 m2 b1 ofs1 b2 ofs2 Hm H1 Hptr.
        apply coreflexivity in Hptr; inversion Hptr; clear Hptr; subst.
        erewrite simrel_corefl_weak_valid_pointer in H1 by eauto.
        assumption.
      - apply simrel_corefl_weak_valid_pointer_address_inject_weak.
      - apply simrel_corefl_address_inject.
      - apply simrel_corefl_aligned_area_inject.
      - apply simrel_corefl_disjoint_or_equal_inject.
    Qed.
  End COREFL_MEMINJ.
End WITHMEM.


(************************************************************
* Lambda-calculus with exceptions                           *
* Interpreter in combined pretty-big-step with error rules  *
*************************************************************)

Set Implicit Arguments.
Require Import LambdaExn_Interp LambdaExn_CombiErr.

Implicit Types v : val.
Implicit Types t : trm.
Implicit Types e : ext.
Implicit Types o : out.
Implicit Types b : beh.
Implicit Types r : res.

(*==========================================================*)
(* * Definitions *)

(************************************************************)
(* ** Statement of the theorem *)

(** [result n r o] asserts that it is correct for
    the interpreter to return the result [r] when
    run with max-recursion depth [n] for a term
    whose real behavior is [o]. *)

Definition result n r o :=
  match o with
  | out_ter m b => r = b \/ (r = res_bottom /\ n <= m)
  | out_div => r = res_bottom
  end.

Definition correct_and_complete :=
  forall n t r o,
    run n t = r -> cred t o -> result n r o.

(*==========================================================*)
(* * Proofs *)

Hint Unfold result.
Hint Extern 1 (_ <= _) => math.
Hint Constructors isclo.

(************************************************************)
(* ** Properties of monadic operators *)

(** Monotonicity of [result] *)

Lemma result_before : forall n r o1 o2,
  result n r o1 -> before o1 o2 -> result (S n) r o2.
Proof.
  unfold result. introv R B.
  destruct o1; inverts B.
  destruct R as [?|[? ?]]; eauto.
  auto.
Qed.

(** Partial specification for [if_isclo] *)

Lemma if_isclo_not : forall v k,
  ~ isclo v -> if_isclo v k = beh_err.
Proof.
  introv V. destruct~ v. false~ V.
Qed.

(** Combined specification for
        [if_success] when taking [i=true],
    and [if_fault]   when taking [i=false] *)

Lemma if_result : forall (i:bool) n r o1 r1 o k,
  result n r1 o1 ->
  (if i then if_success else if_fault) r1 k = r ->
  faster o1 o ->
  (match o1 with
   | out_ter _ (beh_ret v1) =>
      if i then result (S n) (k v1) o else before o1 o
   | out_ter _ (beh_exn v1) =>
      if i then before o1 o else result (S n) (k v1) o
   | out_ter _ _ => before o1 o
   | out_div => o = out_div
   end) ->
  result (S n) r o.
Proof.
  introv R I F M. unfold result in R. unfolds if_success.
  destruct o1.
  destruct R as [E|[E L]].
    subst r1. destruct b.
      destruct i. subst~. inverts M. unfolds. left~.
      destruct i. inverts M. unfolds. left~. subst~.
      inverts M. unfolds. left. destruct~ i.
    subst r1 r. unfolds. destruct i;
     (destruct o; [ inverts~ F | auto ]).
  subst o r1 r. unfolds. destruct~ i.
Qed.

Definition if_success_result := @if_result true.
Definition if_fault_result := @if_result false.

(************************************************************)
(* ** Correctness and completeness of the interpreter *)

Lemma specification : correct_and_complete.
Proof.
  unfolds. induction n using peano_induction. introv U R.
  destruct n; simpl in U. destruct~ o.
  lets~ IH: (rm H) n __. destruct t.
  inverts* R.
  inverts* R.
  inverts* R.
  inverts R as R1 R2 [L2 L1]. forwards~ M1: IH R1.
   applys~ if_success_result M1 U. inverts R2 as.
     introv A B. inverts A; inverts B; inverts L2; inverts~ L1.
     introv R3 R4 [L4 L3]. forwards~ M2: IH R3.
     applys if_success_result M2. auto.
       destruct o0; inverts L3; inverts~ L2.
     inverts R4 as.
       introv A B. inverts A; inverts B;
        inverts L4; inverts L2; inverts~ L1.
       introv R5 L5. simpl. forwards~ M3: IH R5.
        applys result_before M3.
        destruct o1; inverts L5; inverts L4; inverts~ L2.
       introv C. rewrite~ if_isclo_not.
        inverts L4; inverts~ L2.
  inverts R as R1 R2 [L2 L1]. forwards~ M1: IH R1.
   applys~ if_fault_result M1 U. inverts R2 as.
     inverts L2. inverts~ L1.
     introv R5 L5. forwards~ M2: IH R5.
      applys~ result_before M2.
       destruct o0; inverts L5; inverts~ L2.
     inverts~ L2.
     inverts L2. inverts~ L1.
  inverts R as R1 R2 [L2 L1]. forwards~ M1: IH R1.
   applys~ if_success_result M1 U. inverts R2 as.
     introv A B. inverts A; inverts B; inverts L2; inverts~ L1.
     inverts L2. inverts~ L1.
  inverts* R.
Qed.

(************************************************************)
(* ** Corollaries, formulated as implications *)

Corollary correct_ter : forall n t b,
  run n t = b -> credbeh t b.
Proof.
  introv U. lets (o&R): (cred_full t).
  forwards M: specification U R.
  destruct o; tryfalse.
  destruct M as [E|[? ?]]; tryfalse.
  unfolds credbeh. inverts* E.
Qed.

Corollary complete_ter : forall t b,
  credbeh t b -> exists m, forall n, n > m -> run n t = b.
Proof.
  introv (m&R). exists m. introv G.
  forwards~ [?|[? ?]]: specification (run n t) R.
  math.
Qed.

Corollary correct_div : forall t,
  (forall n, run n t = res_bottom) -> cdiverge t.
Proof.
  introv H. unfold cdiverge.
  lets (o&R): (cred_full t).
  destruct o as [n b|]; [false|auto].
  forwards [E|[? ?]]: specification (H (S n)) R.
    false.
    math.
Qed.

Corollary complete_div : forall t n,
  cdiverge t -> run n t = res_bottom.
Proof.
  introv H. forwards~: specification (run n t) H.
Qed.

(************************************************************)
(* ** Corollaries, formulated as equivalences *)

Corollary specification_ter : forall t b,
     (exists m, forall n, n > m -> run n t = b)
  <-> credbeh t b.
Proof.
  iff (n&?).
  applys* correct_ter (S n). applys* H. math.
  applys* complete_ter. exists* n.
Qed.

Corollary specification_div : forall t,
      (forall n, run n t = res_bottom)
  <-> cdiverge t.
Proof.
  iff.
  applys* correct_div.
  intros. applys* complete_div.
Qed.


From Coq Require Import Relation_Definitions.
From Relational Require Import OrderEnrichedCategory.
From Mon Require Import SPropBase.
Set Warnings "-notation-overridden,-ambiguous-paths".
From mathcomp Require Import all_ssreflect boolp.
Set Warnings "notation-overridden,ambiguous-paths".
From Crypt Require Import Axioms OrderEnrichedRelativeAdjunctions LaxFunctorsAndTransf LaxMorphismOfRelAdjunctions.

Import SPropNotations.

(*
In this file we implement the following transformations:
- Start with a lax relative monad morphism θ : M1 → M2
- You can obtain a lax morphism of left relative adjunctions between the Kleisli adjunctions:
  Kθ : (L^M1 ⊣ R^M1) → (L^M2 ⊣ R^M2)
- Then transform this morphism to get a new morphism between the transformed left relative adjunctions:
  (L^M1 ∘ L♭ ⊣ R1 ∘ R^M1) → (L^M2 ∘ L♭ ⊣ R2 ∘ R^M2)
- From this we deduce a lax morpihsm between the associated relative monads:
  R1 ∘ M1 ∘ L♭ → R2 ∘ M2 ∘ L♭
*)

Section OrdCatLe.
  Context {C : ord_category}.
  Context {X Y Z : C}.
  Context (f f' : C⦅X ; Y⦆) (g g' : C⦅Y ; Z⦆).
  Lemma ord_cat_le_comp : f ⪷ f' -> g ⪷ g' -> g ∙ f ⪷ g' ∙ f'.
  Proof.
    move=> Hf Hg. eapply Comp_proper. assumption. assumption.
  Qed.

End OrdCatLe.

(*
Take two relative monads and a lax morphism between them. For instance
θ : Prob × Prob → SomeSpecRmonad. Based on θ, we begin by building a lax morphism
between the associated Kleisli relative ajdunctions.
*)
Section LaxMorphBetwKleislis.
  Context {I : ord_category}. (* both rmonads share the same index cat *)
  Context {C1 :ord_category} {J1 : ord_functor I C1} {M1 : ord_relativeMonad J1}.
  Context {C2 :ord_category} {J2 : ord_functor I C2} {M2 : ord_relativeMonad J2}.

  (*  We pack the first Kleisli adjunction  *)
  Let kadj1 := mkLeftAdjunction
  I (relKleisli M1) C1 J1 (KleisliLeftAdjoint M1) (KleisliRightAdjoint M1) (ChiKleisli M1).
  (* and the second *)
  Let kadj2 := mkLeftAdjunction
  I (relKleisli M2) C2 J2 (KleisliLeftAdjoint M2) (KleisliRightAdjoint M2) (ChiKleisli M2).

  Context {KC : ord_functor C1 C2}.
  Context  {bIso : natIso J2 (ord_functor_comp J1 KC)}.

  Context (smTheta :  relativeLaxMonadMorphism KC bIso M1 M2).

  Program Definition Kl_Lfunc : lord_functor (lad_D kadj1) (lad_D kadj2) :=
    mkLordFunctor (fun A => A)  _ _ _ _.
  Next Obligation.
    move=> A B f.
    exact ( smTheta B ∙ (ofmap KC f) ∙ bIso A ).
  Defined.
  Next Obligation.
    move=> A B. move=> f f'. cbv. move=> Hf.
    eapply Comp_proper. eapply Comp_proper.
    reflexivity. eapply ofmap_proper. assumption.
    reflexivity.
  Qed.
  Next Obligation.
    move=> A. cbv. pose (smTheta_laxRet := (rlmm_law1 _ _ _ _ smTheta) A).
    unshelve eapply Comp_proper in smTheta_laxRet. exact (J2 A).
    cbv in smTheta_laxRet.
    move: smTheta_laxRet => /(_ (bIso A) (bIso A)) smTheta_laxRet.
    specialize (smTheta_laxRet ltac: (reflexivity)).
    transitivity ((ord_relmon_unit M2 A ∙ ni_inv bIso A) ∙ bIso A).
    eapply smTheta_laxRet.
    rewrite -ord_cat_law3. rewrite ni_leftinv. rewrite ord_cat_law2.
    reflexivity.
  Qed.
  Next Obligation.
    move=> X Y Z f f'. cbv. rewrite ord_cat_law3. eapply Comp_proper.
    rewrite (ord_functor_law2 _ _ KC). do 2 rewrite ord_cat_law3.
    eapply Comp_proper. eapply rlmm_law2.
    reflexivity. reflexivity.
  Qed.

  Program Definition bbIso :
  natIso (ord_functor_comp (ord_functor_id I) (lad_J kadj2)) (ord_functor_comp (lad_J kadj1) KC).
    eapply natIso_comp. all: swap 1 2. exact (bIso).
    simpl.
    eapply ord_functor_unit_left.
  Defined.

  Notation η := ord_relmon_unit.

  Program Definition Kl_alpha :
  lnatTrans (lord_functor_comp (strict2laxFunc (lad_L kadj1)) Kl_Lfunc)
            (lord_functor_comp (strict2laxFunc (ord_functor_id I))
                             (strict2laxFunc (lad_L kadj2))) :=
    mkLnatTrans _ _.
  Next Obligation.
    exact (η M2).
  Defined.
  Next Obligation.
    intuition. cbv.
    rewrite ord_relmon_law1. rewrite ord_cat_law1.
    rewrite ord_relmon_law2.
    rewrite (ord_functor_law2 _ _ KC).
    rewrite ord_cat_law3.
    assert ( compassoc :
((smTheta B ∙ ofmap KC (η M1 B)) ∙ ofmap KC (ofmap J1 f)) ∙ bIso A
=
smTheta B ∙ ofmap KC (η M1 B) ∙ (ofmap KC (ofmap J1 f) ∙ bIso A)
).
    rewrite !ord_cat_law3. reflexivity.
    rewrite compassoc.
    transitivity (
(η M2 B ∙ (natIso_sym bIso B))  ∙ ( (ofmap KC (ofmap J1 f)) ∙ bIso A)).
    eapply Comp_proper. eapply rlmm_law1. reflexivity.
    rewrite -ord_cat_law3. cbv.
    move: bIso => [bIso_map bIso_inv bIso_nat bIso_law2 bIso_law3].
    cbv in bIso_nat. rewrite -bIso_nat.
    do 2 rewrite ord_cat_law3.
    eapply Comp_proper.
    rewrite -ord_cat_law3. rewrite bIso_law3. rewrite ord_cat_law2.
    reflexivity. reflexivity.
  Qed.

  Program Definition Kl_beta : lnatTrans
                        (lord_functor_comp (strict2laxFunc (lad_R kadj1)) (strict2laxFunc KC))
                        (lord_functor_comp Kl_Lfunc (strict2laxFunc (lad_R kadj2))) :=
    mkLnatTrans _ _.
  Next Obligation.
    exact smTheta.
  Defined.
  Next Obligation.
    cbv. intuition. eapply rlmm_law2.
  Qed.

  Program Definition kleisliLaxMorph : LaxMorphLeftAdj kadj1 kadj2 :=
    mkLaxMorphLeftAdj kadj1 kadj2 Kl_Lfunc KC bIso Kl_alpha Kl_beta _ _.
  Next Obligation.
    cbv ; intuition.
    rewrite !ord_cat_law2. rewrite ord_relmon_law1. rewrite ord_cat_law1.
    transitivity ((η M2 A ∙ (natIso_sym bIso A)) ∙ bIso A).
    eapply Comp_proper. eapply rlmm_law1.
    reflexivity.
    rewrite -ord_cat_law3. cbv. move: bIso => [bIso_map bIso_inv bIso_nat bIso_law1 bIso_law2].
    rewrite bIso_law2. rewrite ord_cat_law2.
    reflexivity.
  Qed.
  Next Obligation.
    cbv ; intuition. rewrite ord_relmon_law2.
    reflexivity.
  Qed.

End LaxMorphBetwKleislis.

(*
From a left relative adjunction we can deduce a relative monad
Similarly from a lax morphism of left relative adjunctions we can
deduce a lax morphism of relative monads.
We implement the latter fact in the following section.
*)
Section FromLaxMorphAdj_TO_LaxMorphRmon.
  Context {I : ord_category}.
  Context {adj1 adj2 : leftAdjunction I}.
  Context (smK : LaxMorphLeftAdj adj1 adj2).

  (*We want to build a lax morphism of relative monads between those two:*)
  Let smM1 := relMon_fromLeftAdj (lad_J adj1) (lad_L adj1) (lad_R adj1) (lad_strucIso adj1).
  Let smM2 := relMon_fromLeftAdj (lad_J adj2) (lad_L adj2) (lad_R adj2) (lad_strucIso adj2).

  Notation α X := (lmlad_alpha _ _ _ X).
  Notation β X := (lmlad_beta _ _ _ X).
  Notation myKC := (ofmap (lmlad_KC _ _ _)).

  (*"relative lax monad morphism from lax morphism of left adjunctions"*)
  Program Definition rlmm_from_lmla :
  relativeLaxMonadMorphism (lmlad_KC _ _ smK) (lmlad_baseIso _ _ smK) smM1 smM2 :=
    mkRelLaxMonMorph (lmlad_KC _ _ smK) (lmlad_baseIso _ _ smK) smM1 smM2 _ _ _.
  Next Obligation.
    exact (paste (lmlad_alpha _ _ smK) (lmlad_beta _ _ smK)).
  Defined.
  Next Obligation.
    unfold rlmm_from_lmla_obligation_1. simpl.
    move=> A.
    pose Hlrp := (lmlad_laxRetPres _ _ smK). move: Hlrp => /(_ A) Hlrp.
    simpl in Hlrp. rewrite ord_cat_law2 in Hlrp.
    rewrite ord_cat_law2.
    transitivity (
((ofmap (lad_R adj2) (lmlad_alpha adj1 adj2 smK A) ∙ lmlad_beta adj1 adj2 smK (lad_L adj1 A))
          ∙ ofmap (lmlad_KC adj1 adj2 smK)
              (OrderEnrichedRelativeAdjunctions.relMon_fromLeftAdj_obligation_1
                 (lad_J adj1) (lad_L adj1) (lad_R adj1) (lad_strucIso adj1) A))
         ∙ (lmlad_baseIso adj1 adj2 smK A ∙  ni_inv (lmlad_baseIso adj1 adj2 smK) A)
).
    rewrite ni_rightinv ord_cat_law2. reflexivity.
    rewrite ord_cat_law3. eapply Comp_proper.
    eapply Hlrp.
    reflexivity.
  Qed.
  Next Obligation.
    (*cleaning*)
    simpl ; move=> A B f.
    unfold rlmm_from_lmla_obligation_1. simpl.
    rewrite !ord_cat_law2.
    unfold OrderEnrichedRelativeAdjunctions.relMon_fromLeftAdj_obligation_2.
    unfold bind_fromLeftAdj.
    (*use beta lax naturality*)
    unshelve epose (betaNat := lnt_lnatural _ _ (lmlad_beta _ _ smK)   ).
      exact (lad_L adj1 A). exact (lad_L adj1 B).
    rewrite -ord_cat_law3. simpl in betaNat.
    specialize (betaNat ((ni_inv (lad_strucIso adj1) ⟨ A, lad_L adj1 B ⟩) ∙1 f)).
    transitivity (
  ofmap (lad_R adj2) (lmlad_alpha adj1 adj2 smK B)
  ∙ ( ofmap (lad_R adj2)
                (lofmap (lmlad_KD adj1 adj2 smK)
                   ((ni_inv (lad_strucIso adj1) ⟨ A, lad_L adj1 B ⟩) ∙1 f))
              ∙ lmlad_beta adj1 adj2 smK (lad_L adj1 A) )
).
    eapply Comp_proper. reflexivity.
    eapply betaNat. clear betaNat.
    (*R2 functoriality*)
    rewrite [ofmap (lad_R adj2) (lmlad_alpha adj1 adj2 smK B) ∙ _] ord_cat_law3.
    rewrite -ord_functor_law2.
    (*KD = ... ; structural iso preservation of smK*)
    pose (myIsoPres := (lmlad_StrucIsoPres _ _ smK)).
    specialize (myIsoPres _ _ ((ni_inv (lad_strucIso adj1) ⟨ A, lad_L adj1 B ⟩) ∙1 f)).
    simpl in myIsoPres. rewrite myIsoPres. clear myIsoPres.
    rewrite [α B ∙ _] ord_cat_law3.
    rewrite [ofmap (lad_R adj2) (_ ∙ α A)] ord_functor_law2.
    rewrite -[(_ ∙ (ofmap (lad_R adj2) (α A))) ∙ β (lad_L adj1 A)] ord_cat_law3.
    (*phi ( phi-1 f ) = f*)
    unshelve epose (rmv_natIso := (ni_rightinv _ _ (lad_strucIso adj1)) ).
      exact ( ⟨ A, lad_L adj1 B ⟩ ).
    simpl in rmv_natIso.
    eapply (f_equal sval) in rmv_natIso. simpl in rmv_natIso.
    unshelve eapply (equal_f) in rmv_natIso.
      exact f.
    simpl in rmv_natIso.
    rewrite rmv_natIso. clear rmv_natIso.
    (*focus on the left part of the members. the right parts are the same*)
    eapply Comp_proper. all: swap 1 2. reflexivity.
    (* f <= f' -> R2 f <= R2 f' *)
    eapply ofmap_proper.
    (*use phi2-1 naturality...*)
    unshelve epose ( Hnat := (ni_natural _ _ (natIso_sym (lad_strucIso adj2)))).
      exact ( ⟨ A, lmlad_KD adj1 adj2 smK (lad_L adj1 B) ⟩ ).
      exact ( ⟨ A, (lad_L adj2) B ⟩ ).
    unshelve epose ( Hnat' := Hnat _).
      unshelve econstructor.
        simpl. eapply Id.
        exact ((lmlad_alpha _ _ smK) B).
    eapply (f_equal sval) in Hnat'. simpl in Hnat'. clear Hnat.
    unfold OrderEnrichedRelativeAdjunctions.oppoF_obligation_1 in Hnat'.
    move: Hnat'. rewrite !ord_functor_law1. move=> Hnat'.
    unshelve eapply equal_f in Hnat'.
      exact (
  (lmlad_beta _ _ smK) (lad_L adj1 B) ∙ ( ofmap (lmlad_KC _ _ smK) f ∙ (lmlad_baseIso _ _ smK) A)
).
    simpl in Hnat'. rewrite !ord_cat_law2 in Hnat'. rewrite -ord_cat_law3.
    rewrite -Hnat'. clear Hnat'.
    rewrite -!ord_cat_law3. reflexivity.
  Qed.

End FromLaxMorphAdj_TO_LaxMorphRmon.

(*
Start with two rmonads and a lax relative monad morphism between them.

*)

Section TransformedLaxMorphAdj.

  Context {I : ord_category} {Lflat : ord_functor I I}.

  (*The first monad*)
  Context {C1 : ord_category} {J1 : ord_functor I C1}.
  Context {M1 : ord_relativeMonad J1}.
  Context {R1 : ord_functor C1 C1}.

  (*The second monad and the second transforming adjunction*)
  Context {C2 : ord_category} {J2 : ord_functor I C2}.
  Context {M2 : ord_relativeMonad J2}.
  Context {R2 : ord_functor C2 C2}.

  (*We have a lax relative monad morphism theta that we wish to transform*)
  Context {KC : ord_functor C1 C2}.
  Context {chi :  natIso J2 (ord_functor_comp J1 KC)}.
  Context (theta :  relativeLaxMonadMorphism KC chi M1 M2).

  (*The first transforming adjunction, and the first transformed adjunction *)
  Context (Chi_RJLflat_1 : leftAdjunctionSituation J1 (ord_functor_comp Lflat J1) R1).
    (*we pack the first transforming adjunction into a record *)
  Let TingAdj1 :=  mkLeftAdjunction I C1 C1 J1 (ord_functor_comp Lflat J1) R1 Chi_RJLflat_1.
  (*The first transformed adjunction *)
  Let tradj1_0 := TransformedAdjunction M1 Lflat R1 Chi_RJLflat_1.
    (*we pack it into a record type (see leftAdjunction)*)
  Let tradj1 :=
  mkLeftAdjunction I (relKleisli M1) C1 J1
  (ord_functor_comp Lflat (KleisliLeftAdjoint M1))
  (ord_functor_comp (KleisliRightAdjoint M1) R1) tradj1_0.

  (*The second transforming adjunction and the second transformed adjunction*)
  Context (Chi_RJLflat_2 : leftAdjunctionSituation J2 (ord_functor_comp Lflat J2) R2).
    (*we pack the second transforming adjunction into a record *)
  Let TingAdj2 :=  mkLeftAdjunction I C2 C2 J2 (ord_functor_comp Lflat J2) R2 Chi_RJLflat_2.
  (*The second transformed adjunction *)
  Let tradj2_0 := TransformedAdjunction M2 Lflat R2 Chi_RJLflat_2.
    (*we pack it into a record type (see leftAdjunction)*)
  Let tradj2 :=
  mkLeftAdjunction I (relKleisli M2) C2 J2
  (ord_functor_comp Lflat (KleisliLeftAdjoint M2))
  (ord_functor_comp (KleisliRightAdjoint M2) R2) tradj2_0.

  (*we begin by extending it into a lax morphism between the Kleisli adjunctions*)
  Let myKtheta :=  kleisliLaxMorph theta.

  (*We also have a "transforming" lax morphism between the 2 transforming adjunctions
   (state relative adjunctions in concrete cases). This lax morphism is compliant with
  the base natural iso of theta, in the sense that its left lax cell is a whiskered inverse
  of chi (= the base nat iso of theta) *)
  Let invChi := strict2laxTransf (natIso_sym chi).
  Let invChiLflat := lnatTrans_whisker_left invChi (strict2laxFunc Lflat).
  Program Definition smAlpha' :
  lnatTrans (lord_functor_comp (strict2laxFunc (lad_L TingAdj1)) (strict2laxFunc KC))
      (lord_functor_comp (strict2laxFunc (ord_functor_id I))
                             (strict2laxFunc (lad_L TingAdj2))) :=
    mkLnatTrans invChiLflat _.
  Next Obligation.
    move=> A B f. pose chiInvNat := (ni_natural _ _ (natIso_sym chi) (ofmap Lflat f)).
    simpl in chiInvNat. rewrite chiInvNat. reflexivity.
  Qed.

  Context (smBeta' : lnatTrans (lord_functor_comp (strict2laxFunc R1) (strict2laxFunc KC))
         (lord_functor_comp (strict2laxFunc KC) (strict2laxFunc R2)) ).

  Hypothesis (laxUnitPres' :
forall A : I,
        (paste smAlpha' smBeta' A
         ∙ lofmap (strict2laxFunc KC)
             (ord_relmon_unit
                (relMon_fromLeftAdj J1 (ord_functor_comp Lflat J1) R1
                   (Chi_RJLflat_1)) A)) ∙ chi A
        ⪷ ord_relmon_unit
            (relMon_fromLeftAdj J2 (ord_functor_comp Lflat J2) R2
               Chi_RJLflat_2) A).

  Hypothesis (StrucIsoPres' :
forall (A : I) (Y : C1) (f : C1 ⦅ J1 (Lflat A) ; Y ⦆),
        lofmap (strict2laxFunc KC) f =
        (natIso_sym (Chi_RJLflat_2) ⟨ A, strict2laxFunc KC Y ⟩) ∙1
          ((smBeta' Y ∙ ofmap KC ((Chi_RJLflat_1 ⟨ A, Y ⟩) ∙1 f)) ∙ chi A) ∙
        smAlpha' A).

(*
  Based on the previous hypotheses there is a lax morphism between twe two transforming
  adjunctions TingAdj1 and TingAdj2. We call it smK'.
*)
  Let smK' :=  mkLaxMorphLeftAdj TingAdj1 TingAdj2 (strict2laxFunc KC) KC
  chi smAlpha' smBeta' laxUnitPres' StrucIsoPres'.

(*
some useful notations in this section
*)

  Notation dnib := (ord_relmon_bind _).
  Notation η := (ord_relmon_unit _).
  Notation Φ1':= ( (Chi_RJLflat_1 _) ).
  Notation Φ2':= ( (Chi_RJLflat_2 _) ).

(*
  And now we have to build the transformed lax morphism.
  We want to build a lax morphism, of this type:
*)
  (*  LaxMorphLeftAdj tradj1 tradj2. *)

  (*Here is its top lax functor*)
  Let Kl_Lfunc_filled :=
  @Kl_Lfunc _ _ _ M1 _ _ M2 KC chi theta.

  (*Here is its left lax cell alpha''*)
  (* Check lmlad_alpha _ _ myKtheta. *)
  (* Check mkLaxMorphLeftAdj tradj1 tradj2 Kl_Lfunc_filled KC chi. *)

  Program Definition pre_smAlpha'' :
  lnatTrans (lord_functor_comp (strict2laxFunc (lad_L tradj1)) Kl_Lfunc_filled)
            (lord_functor_comp
               (strict2laxFunc Lflat)
               (lord_functor_comp (strict2laxFunc (KleisliLeftAdjoint M1)) (Kl_Lfunc theta))) :=
    mkLnatTrans _ _.
  Next Obligation.
    move=> A. exact ( η (Lflat A) ).
  Defined.
  Next Obligation.
    rewrite /OrderEnrichedRelativeAdjunctions.relKleisli_obligation_2.
    rewrite /Kl_Lfunc_obligation_1.
    rewrite /pre_smAlpha''_obligation_1.
    move=> A B f. rewrite ord_relmon_law1. rewrite ord_cat_law1.
    rewrite ord_relmon_law2. reflexivity.
  Qed.

  Program Definition post_smAlpha'' :
  lnatTrans (lord_functor_comp (strict2laxFunc Lflat)
                               (lord_functor_comp (strict2laxFunc (ord_functor_id I))
                                                  (strict2laxFunc (KleisliLeftAdjoint M2))))
            (lord_functor_comp (strict2laxFunc (ord_functor_id I))
                             (strict2laxFunc (lad_L tradj2))) :=
    mkLnatTrans _ _.
  Next Obligation.
    move=> A. exact ( η (Lflat A) ).
  Defined.
  Next Obligation.
    rewrite /OrderEnrichedRelativeAdjunctions.relKleisli_obligation_2.
    rewrite /post_smAlpha''_obligation_1.
    move=> A B f. rewrite ord_relmon_law1. rewrite ord_cat_law1.
    rewrite ord_relmon_law2. reflexivity.
  Qed.

  Let PPre_smAlpha'' :=  lnatTrans_comp
          pre_smAlpha''
          ( lnatTrans_whisker_left (lmlad_alpha _ _ myKtheta) (strict2laxFunc Lflat) ).
  Definition smAlpha'' :
  lnatTrans (lord_functor_comp (strict2laxFunc (lad_L tradj1)) Kl_Lfunc_filled)
                          (lord_functor_comp (strict2laxFunc (ord_functor_id I))
                             (strict2laxFunc (lad_L tradj2))) :=
    lnatTrans_comp PPre_smAlpha'' post_smAlpha''.

  (*The right cell beta'' of the transformed morphism consists of pasting the two lax cells
    beta (coming from the input Kleisli adjunction ) and beta' (coming from the transforming
    adjunction ) *)
  Let myBeta := lmlad_beta _ _ myKtheta.
  Let myBeta' := lmlad_beta _ _ smK'.
  Goal True.
    pose bla := (@lpaste (relKleisli M1) C1 C1 (relKleisli M2) C2 C2
        (KleisliRightAdjoint M1) R1 (KleisliRightAdjoint M2) R2 _ (strict2laxFunc KC) (strict2laxFunc KC) myBeta myBeta').
    simpl in bla. easy. Qed.

  Program Definition pre_smBeta'' :
  lnatTrans
    (lord_functor_comp (strict2laxFunc (lad_R tradj1)) (strict2laxFunc KC))
    (lord_functor_comp (strict2laxFunc (KleisliRightAdjoint M1))
          (lord_functor_comp (strict2laxFunc R1) (strict2laxFunc KC))) :=
    mkLnatTrans _ _.
  Next Obligation.
    move=> A. eapply Id.
  Defined.
  Next Obligation.
    move=> A B f.
    rewrite /pre_smBeta''_obligation_1. rewrite ord_cat_law2.
    rewrite ord_cat_law1.
    reflexivity.
  Qed.

  Program Definition post_smBeta'' :
  lnatTrans
    (lord_functor_comp
          (lord_functor_comp (Kl_Lfunc theta) (strict2laxFunc (KleisliRightAdjoint M2)))
          (strict2laxFunc R2))
    (lord_functor_comp Kl_Lfunc_filled (strict2laxFunc (lad_R tradj2))) :=
    mkLnatTrans _ _.
  Next Obligation.
    move=> A. eapply Id.
  Defined.
  Next Obligation.
    move=> A B f.
    rewrite /post_smBeta''_obligation_1. rewrite !ord_cat_law2.
    rewrite ord_cat_law1. reflexivity.
  Qed.

  Let PPre_smBeta'' := lnatTrans_comp
    pre_smBeta''
    (@lpaste (relKleisli M1) C1 C1 (relKleisli M2) C2 C2
        (KleisliRightAdjoint M1) R1 (KleisliRightAdjoint M2) R2 _ (strict2laxFunc KC) (strict2laxFunc KC) myBeta myBeta').

  Definition smBeta'' :
  lnatTrans
     (lord_functor_comp (strict2laxFunc (lad_R tradj1)) (strict2laxFunc KC))
     (lord_functor_comp Kl_Lfunc_filled (strict2laxFunc (lad_R tradj2)))
   := lnatTrans_comp PPre_smBeta'' post_smBeta''.

  (*Here is the transformed lax morphism of left relative adjunctions...*)
  Program Definition Transformed_lmla : LaxMorphLeftAdj tradj1 tradj2 :=
    mkLaxMorphLeftAdj tradj1 tradj2 Kl_Lfunc_filled KC chi smAlpha'' smBeta'' _ _.
  Next Obligation.
    move=> A. cbv. rewrite !ord_cat_law2.
    rewrite !ord_relmon_law1. rewrite !ord_cat_law1. rewrite !ord_relmon_law1.
    rewrite !ord_functor_law1.
    rewrite !ord_cat_law1.
    (*struc iso Φ1' in terms of right adjoint and η1'*)
    pose (sIso_eq := strucIso_rightAdj Chi_RJLflat_1 (ord_relmon_unit M1 (Lflat A))).
    cbv in sIso_eq.
    rewrite sIso_eq. clear sIso_eq.
    (*struc iso Φ2' in terms of right adjoint and η2'*)
    pose (sIso_eq := strucIso_rightAdj Chi_RJLflat_2 (ord_relmon_unit M2 (Lflat A))).
    cbv in sIso_eq. rewrite sIso_eq. clear sIso_eq.
    (*cleaning*)
    rewrite ord_functor_law2. rewrite ord_cat_law3.
    rewrite -[(_ ∙ _) ∙  ofmap KC (ofmap R1 _)]ord_cat_law3.
    (*beta' laxness*)
    pose (laxnessBeta' := lnt_lnatural _ _ smBeta' (ord_relmon_unit M1 (Lflat A))).
    simpl in laxnessBeta'. (* Check relMon_fromLeftAdj _ _ _ Chi_RJLflat_1. *)
    pose eta1' := ord_relmon_unit (relMon_fromLeftAdj _ _ _ Chi_RJLflat_1).
    pose eta1 := ord_relmon_unit M1.
    transitivity (
ofmap R2 (theta (Lflat A)) ∙
ofmap R2 ( ofmap KC (eta1 (Lflat A)) ) ∙
smBeta' (J1 (Lflat A)) ∙
ofmap KC (eta1' A) ∙
chi A
).
    rewrite -!ord_cat_law3. eapply Comp_proper. reflexivity.
    rewrite !ord_cat_law3. eapply Comp_proper. all: swap 1 2. reflexivity.
    eapply Comp_proper. all: swap 1 2. reflexivity.
    eapply laxnessBeta'.
    clear laxnessBeta'.
    (*R2 func*)
    rewrite -ord_functor_law2.
    (*theta lax unit preservation*)
    pose (thetaUnitLaxness  := rlmm_law1 _ _ _ _ theta (Lflat A)).
    etransitivity.
    eapply Comp_proper. all: swap 1 2. reflexivity.
    eapply Comp_proper. all: swap 1 2. reflexivity.
    eapply Comp_proper. all: swap 1 2. reflexivity.
    eapply ofmap_proper. eapply thetaUnitLaxness.
    clear thetaUnitLaxness.
    (*R2 func*)
    rewrite ord_functor_law2. rewrite -[( ofmap R2 _ ∙ ofmap R2 _ ) ∙ _]ord_cat_law3.
    (*alpha' * beta' lax unit preservation*)
    move: (laxUnitPres' A). cbv. rewrite !ord_cat_law2. move=> BislaxUnitPres'.
    etransitivity.
    eapply Comp_proper. all: swap 1 2. reflexivity.
    rewrite -ord_cat_law3.
    eapply Comp_proper. reflexivity.
    unshelve eapply ord_cat_le_comp in BislaxUnitPres'.
      shelve. exact (invChi A). exact (invChi A). shelve.
    rewrite -ord_cat_law3 in BislaxUnitPres'.
    rewrite ni_rightinv in BislaxUnitPres'. rewrite ord_cat_law2 in BislaxUnitPres'.
    apply BislaxUnitPres'. clear BislaxUnitPres'.
    reflexivity.
    (*chi and invchi are inverses*)
    rewrite -!ord_cat_law3. cbv. rewrite (ni_leftinv _ _ chi). rewrite ord_cat_law2.
    reflexivity.
  Qed.
  Next Obligation.
     cbv. intuition.
    pose (top_isoPres := lmlad_StrucIsoPres _ _ myKtheta). cbv in top_isoPres.
    specialize (top_isoPres (Lflat A) Y f).
    rewrite top_isoPres. clear top_isoPres.
    cbv in StrucIsoPres'. move: StrucIsoPres'. move=> /(_ A (M1 Y) f) BisStrucIsoPres'.
    rewrite {1}BisStrucIsoPres'. clear BisStrucIsoPres'.
    f_equal. f_equal.
    (*cleaning*)
    do 8 rewrite -ord_cat_law3. clear PPre_smBeta'' PPre_smAlpha''.
    simpl in *.
    rewrite (ni_leftinv _ _ chi). rewrite ord_cat_law2.
    rewrite ord_cat_law1.
    (*Phi2' naturality*)
    unshelve epose (naturality_Phi2' := ni_natural _ _ (natIso_sym Chi_RJLflat_2)).
      exact ⟨A, KC ( M1 Y ) ⟩. exact ⟨ A , M2 Y⟩.
    cbv in naturality_Phi2'.
    specialize (naturality_Phi2' ⟨(Id A) , (theta Y)⟩).
    apply (f_equal sval) in naturality_Phi2'. cbv in naturality_Phi2'.
    unshelve eapply equal_f in naturality_Phi2'.
    unshelve eapply Comp. shelve. exact (smBeta' (M1 Y)).
    simpl. unshelve eapply Comp. shelve.
    eapply (ofmap KC). exact (  (Chi_RJLflat_1 ⟨A, M1 Y⟩)∙1 f ).
    simpl. exact (chi A).
    cbv in naturality_Phi2'.
    (*cleaning in naturality_Phi2'*)
    rewrite !ord_functor_law1 in naturality_Phi2'.
    rewrite !ord_cat_law2 in naturality_Phi2'.
    (*rewriting with naturality_Phi2'*)
    rewrite -naturality_Phi2'.
    f_equal. f_equal. rewrite !ord_cat_law1. reflexivity.
    rewrite ord_relmon_law1. rewrite !ord_cat_law1. reflexivity.
  Qed.

  Definition Transformed_rlmm := rlmm_from_lmla Transformed_lmla.

End TransformedLaxMorphAdj.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Category.
From Categories Require Import Functor.Main.
From Categories Require Import Cat.Cat.
From Categories Require Import Basic_Cons.Terminal.
From Categories Require Import Archetypal.Discr.Discr.

(** The unique functor from the initial category to any other. *)
Program Definition Functor_From_Empty_Cat (C' : Category) : (0 –≻ C')%functor :=
{|
  FO := fun x => Empty_rect _ x;
  FA := fun a b f => match a as _ return _ with end
|}.

Local Hint Extern 1 => cbn in *.

(** Empty Cat is the initial category. *)
Program Instance Cat_Init : (𝟘_ Cat)%object :=
{|
  terminal := 0%category;
  t_morph := fun x => Functor_From_Empty_Cat x
|}.


Require Export CalculusSM.
Require Export CalculusSM_tacs.

Section CalculusSMext.

  Context { pd  : @Data }.
  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { pm  : @Msg }.
  Context { qc  : @Quorum_context pn}.
  Context { pat : @AuthTok }.
  Context { paf : @AuthFun pn pk pat pd }.
  Context { pda : @DataAuth pd pn }.
  Context { cad : @ContainedAuthData pd pat pm }.
  Context { dtc : @DTimeContext }.
  Context { iot : @IOTrustedFun }.
  Context { ctp : @ComponentTrust pd pn pat qc iot }.
  Context { cap : @ComponentAuth pd pn pk pat pm dtc iot }.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { base_fun_io       : baseFunIO           }.
  Context { base_state_fun    : baseStateFun        }.
  Context { trusted_state_fun : trustedStateFun     }.
  Context { pkc               : KnowledgeComponents }.
  Context { gms               : MsgStatus           }.

  Local Open Scope kn.

  (* These are the axioms of S5 (R1 is just an instance of the corresponding axiom) *)

  (* K(A) -> A *)
  Lemma A1 :
    forall {eo : EventOrdering} (e : Event) (a : KExpression),
      interpret e (KE_IMPLIES (KE_EXT_KNOW a) a).
  Proof.
    introv h; simpl in *.
    apply h; apply kc_same_state_refl.
  Qed.

  (* K(A) -> K(A->B) -> K(B) *)
  Lemma A2 :
    forall {eo : EventOrdering} (e : Event) (a b : KExpression),
      interpret e (KE_IMPLIES
                     (KE_EXT_KNOW a)
                     (KE_IMPLIES
                        (KE_EXT_KNOW (KE_IMPLIES a b))
                        (KE_EXT_KNOW b))).
  Proof.
    introv h q same; simpl in *; tcsp.
  Qed.

  (* K(A) -> K(K(A)) *)
  Lemma A3 :
    forall {eo : EventOrdering} (e : Event) (a : KExpression),
      interpret e (KE_IMPLIES
                     (KE_EXT_KNOW a)
                     (KE_EXT_KNOW (KE_EXT_KNOW a))).
  Proof.
    introv h same1 same2.
    apply h.
    apply (kc_same_state_trans _ _ eo' e'); auto.
  Qed.

  (* ~K(A) -> K(~K(A)) *)
  Lemma A4 :
    forall {eo : EventOrdering} (e : Event) (a : KExpression),
      interpret e (KE_IMPLIES
                     (KE_NOT (KE_EXT_KNOW a))
                     (KE_EXT_KNOW (KE_NOT (KE_EXT_KNOW a)))).
  Proof.
    introv h same1 q.
    rewrite interp_KE_NOT in h.
    apply interp_KE_FALSE.
    simpl in *.
    destruct h.
    introv same.
    apply q.
    apply (kc_same_state_trans _ _ eo e); auto.
    apply kc_same_state_sym; auto.
  Qed.

  (* k(d) -> K(k(d)) *)
  Lemma R1_know :
    forall {eo : EventOrdering} (e : Event) (d : kc_data),
      interpret e (KE_IMPLIES
                     (KE_KNOWS d)
                     (KE_EXT_KNOW (KE_KNOWS d))).
  Proof.
    introv h same; simpl in *.
    eapply same_state_preserves_knows_after in same; eauto.
  Qed.

End CalculusSMext.