(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext machine_int multi_int uniq_tac.
Import MachineInt.
Require Import mips_seplog mips_frame mips_contrib mips_tactics mapstos.
Require Import mont_mul_strict_prg mont_exp_prg.
Require Import mont_mul_strict_init_triple mont_square_strict_init_triple.

Local Open Scope machine_int_scope.
Local Open Scope eqmod_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope heap_scope.
Import expr_m.
Local Open Scope mips_expr_scope.
Import assert_m.
Local Open Scope mips_assert_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope uniq_scope.
Local Open Scope multi_int_scope.

Lemma mont_exp_specif (k alpha x a' x' i l a ei e one' m one ext int_ X_ Y_ M_ Z_ quot C t s_ : reg) :
  uniq(k, alpha, x, a, a', m, one, ext, int_, X_, Y_, M_, Z_, quot, C, x', t, s_, i, e, ei, l, one', r0) ->
  forall nk valpha M, u2Z (M `32_ 0) * u2Z valpha =m -1 {{ \B^1 }} ->
  forall ve vl, (*vl = number_of_significant_bits of ve*) u2Z ve < 2 ^^ vl -> (vl < 32)%nat ->
  forall va (A : list (int 32)) va' (A' : list (int 32)) vx X vx' vone' ONE' vm,
  size A = nk -> size A' = nk -> size X = nk -> size ONE' = nk -> size M = nk ->
  u2Z va + 4 * Z_of_nat nk.+1 < \B^1 ->
  u2Z va' + 4 * Z_of_nat nk.+1 < \B^1 ->
  u2Z vx' + 4 * Z_of_nat nk.+1 < \B^1 ->
  \S_{ nk } A =m \B^nk {{ \S_{ nk } M }} -> \S_{ nk } A' =m \B^(2 * nk) {{ \S_{ nk } M }} ->
  \S_{ nk } X < \S_{ nk } M -> \S_{ nk } A < \S_{ nk } M -> \S_{ nk } A' < \S_{ nk } M -> \S_{ nk } ONE' < \S_{ nk } M ->
  \S_{ nk } ONE' = 1 -> Zodd (\S_{ nk } M) ->
  {{ fun s h => exists X', size X' = nk /\ [x]_s = vx /\ [a']_s = va' /\
    [x']_s = vx' /\ [m]_s = vm /\ u2Z ([k]_s) = Z_of_nat nk /\ [alpha]_s = valpha /\
    [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\ [a]_s = va /\ [one']_s = vone' /\
    (var_e x |--> X ** var_e a |--> A ++ zero32 :: nil ** var_e a' |--> A' ++ zero32 :: nil **
      var_e x' |--> X' ++ zero32 :: nil ** var_e one' |--> ONE' ** var_e m |--> M ++ zero32 :: nil) s h}}
  mont_exp k alpha x a' x' i l a ei e one' m one ext int_ X_ Y_ M_ Z_ quot C t s_
  {{ fun s h => exists A A' X' new_va new_va',
    size A = nk /\ size A' = nk /\ size X' = nk /\ u2Z [k]_s = Z_of_nat nk /\
    [alpha]_s = valpha /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
    [a]_s = new_va /\ u2Z new_va + 4 * Z_of_nat nk.+1 < \B^1 /\
    [a']_s = new_va' /\ u2Z new_va' + 4 * Z_of_nat nk.+1 < \B^1 /\
    [x]_s = vx /\ [x']_s = vx' /\ [one']_s = vone' /\ [m]_s = vm /\
    (var_e a |--> A ++ zero32 :: nil ** var_e a' |--> A' ++ zero32 :: nil ** var_e x |--> X **
      var_e x' |--> X' ++ zero32 :: nil ** var_e one' |--> ONE' ** var_e m |--> M ++ zero32 :: nil) s h /\
    \S_{ nk } A' =m (\S_{ nk } X) ^^ Z.abs_nat (u2Z [e]_s) {{ \S_{ nk } M }} }}.
Proof.
move=> Hset nk valpha M Halpha ve vl Hvevl Hvl va A va' A' vx X
  vx' vone' ONE' vm HlenA HlenA' HlenX HlenONE' HlenM
  Hna Hna' Hxn' HA HA' HSumXSumM HSumA HSumA'SumM HSumONE' HSumONE'_is_1 HZoddM.
rewrite /mont_exp.

(** mont_mul_strict_init k alpha x a' x' m one ext int_ X_ Y_ M_ Z_ quot C t s_ ; *)

apply (hoare_prop_m.hoare_stren ((fun s h => exists X', size X' = nk /\
  [x]_s = vx /\ [a']_s = va' /\ [x']_s = vx' /\ [m]_s = vm /\
  u2Z ([k]_s) = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e a' |--> A' ** var_e x' |--> X' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h) **
(fun s h => [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\ [a]_s = va /\  [one']_s = vone' /\
  (var_e a |--> A ++ zero32 :: nil **
  var_e a' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32 ** var_e one' |--> ONE') s h))).

move=> s h [X' [HlenX' [r_x [r_a' [r_x' [r_m [r_k [r_alpha [r_e [r_l [r_a [r_one' Hmem]]]]]]]]]]]].

have {}Hmem :
  ((var_e x |--> X ** var_e a' |--> A' ** var_e x' |--> X' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) **
   (var_e a |--> A ++ zero32 :: nil ** var_e a' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32 ** var_e one' |--> ONE')) s h.
  rewrite (decompose_last_equiv _ A') HlenA' in Hmem.
  by assoc_comm Hmem.
case: Hmem => h1 [h2 [Hdisj [Hunion [Hmem1 Hmem2]]]].
exists h1, h2; repeat (split; trivial).
by exists X'.

apply while.hoare_seq with ((fun s h => exists X', size X' = nk /\ [x]_s = vx /\
  [a']_s = va' /\ [x']_s = vx' /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\
  (var_e x |--> X ** var_e a' |--> A' ** var_e x' |--> X' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  \S_{ nk } X' =m \S_{ nk } X * \B^nk {{ \S_{ nk } M }} /\ \S_{ nk } X' < \S_{ nk } M) **
(fun s h => [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\ [a]_s = va /\
  [one']_s = vone' /\
  (var_e a |--> A ++ zero32 :: nil ** (var_e a' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32) ** var_e one' |--> ONE') s h)).

(* TODO: adapt before_frame to work with a sequence
Lemma before_frame : forall R P' Q' P c Q, {{ P' ** R }} c {{ Q' ** R }} ->
  P ===> P' ** R -> Q' ** R ===> Q -> {{ P }} c {{ Q }}.
Proof. move=> R P' Q' P c Q H1 H2 H3; by eapply while.hoare_conseq; eauto. Qed.
*)

apply frame_rule_R.
- apply (hoare_prop_m.hoare_weak (fun s h => exists X', size X' = nk /\
    [x]_s = vx /\ [a']_s = va' /\ [x']_s = vx' /\ [m]_s = vm /\
    u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
    (var_e x |--> X ** var_e a' |--> A' ** var_e x' |--> X' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
    \B^nk * \S_{ nk } X' =m \S_{ nk } X * \S_{ nk } A' {{ \S_{ nk } M }} /\ \S_{ nk } X' < \S_{ nk } M)).
  move=> s h [X' [HlenX' [r_x [r_a' [r_x' [r_m [r_k [r_alpha [Hmem [Sum_X'1 Sum_X'2]]]]]]]]]].
  exists X'; repeat (split; trivial).
  apply: (eqmod_reg_mult' _ _ (\B^nk)).
  apply Zis_gcd_sym; rewrite ZbetaE; exact: Zis_gcd_Zpower_odd.
  rewrite mulZC.
  eapply eqmod_trans; first exact: Sum_X'1.
  rewrite -mulZA.
  apply eqmod_reg_mult_l.
  by rewrite -ZbetaD addnn -mul2n.
  eapply mont_mul_strict_init_triple; eauto.
  by Uniq_uniq r0.
- by Inde_frame.
- move=> ?; by Inde_mult.

apply pull_out_exists_con => X'.

apply (hoare_prop_m.hoare_stren (!(fun s => size X' = nk /\
  \S_{ nk } X' =m \S_{ nk } X * \B^nk {{ \S_{ nk } M }} /\ \S_{ nk } X' < \S_{ nk } M) **
(fun s h => [x]_s = vx /\ [a]_s = va /\ [a']_s = va' /\ [x']_s = vx' /\
  [m]_s = vm /\ [one']_s = vone' /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  [e]_s = ve /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e a |--> A ++ zero32 :: nil ** var_e a' |--> A' ++ zero32::nil ** var_e x' |--> X' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil ** var_e one' |--> ONE') s h))).

move=> s h [h1 [h2 [Hdisj [Hunion [[HlenX' [r_x [r_a' [r_x' [r_m [r_k [r_alpha [Hmem1 [Sum_X'1 Sum_X'2]]]]]]]]] [r_e [r_l [r_a [r_one' Hmem2]]]]]]]]].
exists heap.emp, (h1 \U h2); repeat (split; trivial).
by map_tac_m.Disj.
by map_tac_m.Equal.
move: {Hmem1 Hmem2}(assert_m.con_cons _ _ _ _ _ Hdisj Hmem1 Hmem2) => Hmem.
rewrite (decompose_last_equiv _ A') HlenA'.
by abstract assoc_comm Hmem.

apply pull_out_bang; case=> HlenX' [HSumX'1 HSumX'2].

apply (hoare_prop_m.hoare_stren ((fun s h => u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  [a]_s = va /\ [a']_s = va' /\ [x']_s = vx' /\ [m]_s = vm /\
  (var_e a|--> A ++ zero32 :: nil ** var_e a'|-->A' ++ zero32 :: nil ** var_e x'|-->X' ** var_e m |-->M ++ zero32 :: nil) s h) **
(fun s h => [x]_s = vx /\ [one']_s = vone' /\
  (var_e x|-->X ** var_e x' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32 ** var_e one' |--> ONE') s h))).

move=> s h [r_x [r_a [r_a' [r_x' [r_m [r_one' [r_l [r_e [r_k [r_alpha Hmem]]]]]]]]]].

have {}Hmem : ((var_e a |--> A ++ zero32 :: nil ** var_e a' |--> A' ++ zero32 :: nil ** var_e x' |--> X' ** var_e m |--> M ++ zero32 :: nil) ** (var_e x|--> X ** var_e x' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32 ** var_e one' |--> ONE')) s h.
  rewrite (decompose_last_equiv _ X') HlenX' in Hmem.
  by abstract assoc_comm Hmem.
case: Hmem => h1 [h2 [Hdisj [Hunion [Hmem1 Hmem2]]]].
by exists h1, h2.

apply while.hoare_seq with ((fun s h => exists A A' new_va new_va',
  size A = nk /\ size A' = nk /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  [a]_s = new_va /\ u2Z new_va + 4 * Z_of_nat nk.+1 < \B^1 /\
  [a']_s = new_va' /\ u2Z new_va' + 4 * Z_of_nat nk.+1 < \B^1 /\
  [x']_s = vx' /\ [m]_s = vm /\
  (var_e a|--> A ++ zero32 :: nil ** var_e a'|-->A' ++ zero32::nil ** var_e x'|-->X' ** var_e m|-->M ++ zero32 :: nil) s h /\
    \S_{ nk } A =m \S_{ nk } X ^^ (Z.abs_nat (u2Z ve)) * \B^nk {{ \S_{ nk } M }} /\ \S_{ nk } A < \S_{ nk } M) **
(fun s h => [x]_s = vx /\ [one']_s = vone' /\
  (var_e x|-->X ** var_e x' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32 ** var_e one' |--> ONE') s h)).

apply frame_rule_R.

(** (addiu i l zero16 ; *)

apply hoare_addiu with (fun s h => u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  [i]_s = Z2s 32 (Z_of_nat vl) /\ [a]_s = va /\ [a']_s = va' /\ [x']_s = vx' /\
  [m]_s = vm /\
  (var_e a|--> A ++ zero32 :: nil ** var_e a'|-->A' ++ zero32 :: nil ** var_e x'|-->X' ** var_e m |-->M ++ zero32 :: nil) s h).

move=> s h [r_k [r_alpha [r_e [r_l [r_a [r_a' [r_x' [r_m Hmem]]]]]]]].
rewrite /wp_addiu.
repeat Reg_upd.
repeat (split; trivial).
by rewrite sext_0 addi0.
by Assert_upd.

(** while (bgez i) ( *)

apply hoare_prop_m.hoare_while_invariant with (fun s h =>
  (exists A0 A'0 new_va new_va' ni,
  size A0 = nk /\ size A'0 = nk /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  [a]_s = new_va /\ u2Z new_va + 4 * Z_of_nat nk.+1 < \B^1 /\
  [a']_s = new_va' /\ u2Z new_va' + 4 * Z_of_nat nk.+1 < \B^1 /\
  [x']_s = vx' /\ [m]_s = vm /\ s2Z [i]_s = ni /\ -1 <= ni <= Z_of_nat vl /\
  (var_e a |--> A0 ++ zero32::nil ** var_e a' |--> A'0 ++ zero32::nil ** var_e x' |--> X' ** var_e m |--> M ++ zero32::nil) s h /\
  \S_{ nk } A0 =m \S_{ nk } X ^^ Z.abs_nat (u2Z (ve `>> Z.abs_nat (ni+1))) * \B^nk {{ \S_{ nk } M }} /\ \S_{ nk } A0 < \S_{ nk } M)).

move=> s h [r_k [r_alpha [r_e [r_l [r_i [r_a [r_a' [r_x' [r_m Hmem]]]]]]]]].
exists A, A', va, va', (Z_of_nat vl); repeat (split; trivial).
rewrite r_i Z2sK //.
split.
  apply (@leZ_trans 0); by [| apply Zle_0_nat].
apply (@leZ_ltZ_trans 32); last by [].
rewrite (_ : 32 = Z_of_nat 32) //; by apply/inj_le/leP; rewrite ltnW.
apply (@leZ_trans 0); by [ | apply Zle_0_nat].
exact/leZZ.

have -> : ve `>> Z.abs_nat (Z_of_nat vl + 1) = zero32.
  rewrite shrl_overflow // Zabs_nat_Zplus //; last exact: Zle_0_nat.
  rewrite plus_comm [plus _ _]/= Zabs2Nat.id.
  apply (@ltZ_trans (2 ^^ vl)); by [ | apply expZ_2_lt].
by rewrite Z2uK // [Zmult]lock /= -lock mul1Z.

clear Hna'.
move=> s h [[A0 [A0' [new_va [new_va' [ni [HlenA0 [HlenA0' [r_k [r_alpha [r_e [r_l [r_a [Hnew_na [r_a' [Hna' [r_x' [r_m [r_i [Hi [Hmem [HSumA01 HSumA02]]]]]]]]]]]]]]]]]]]]] r_i'];
  rewrite /= in r_i'. move/leZP in r_i'.

have {}r_i' : s2Z [i]_s < 0.
 apply Znot_ge_lt; contradict r_i'; exact: Z.ge_le.
exists A0, A0', new_va, new_va'; repeat (split; trivial).
have Hni : ni = -1.
  rewrite r_i in r_i'; case: Hi => Hi _; lia.
by rewrite Hni //= shrl_0 in HSumA01.

clear HlenA HA A HSumA HlenA' A' HA' HSumA'SumM va Hna va' Hna'.

(** mont_mul_strict_init k alpha a a a' m one ext int_ X_ Y_ M_ Z_ quot C t s_; *)

apply (hoare_prop_m.hoare_stren (fun s h => (exists A0 ni new_va new_va' A'0,
  size A0 = nk /\ size A'0 = nk /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  [a]_s = new_va /\ u2Z new_va + 4 * Z_of_nat nk.+1 < \B^1 /\
  [a']_s = new_va' /\ u2Z new_va' + 4 * Z_of_nat nk.+1 < \B^1 /\
  [x']_s = vx' /\ [m]_s = vm /\ s2Z [i]_s = ni /\ 0 <= ni <= Z_of_nat vl /\
  (var_e a |--> A0 ++ zero32 :: nil ** var_e a' |--> A'0 ++ zero32 :: nil ** var_e x' |--> X' ** var_e m |--> M ++ zero32 :: nil) s h /\
  \S_{ nk } A0 =m \S_{ nk } X ^^ Z.abs_nat (u2Z (ve `>> Z.abs_nat (ni + 1))) * \B^nk {{\S_{ nk } M}} /\ \S_{ nk } A0 < \S_{ nk } M))).

move=> s h [ [A [A' [va [va' [ni [HlenA [HlenA' [r_k [r_alpha [r_e [r_l [r_a [Hna [r_a' [Hna' [r_x' [r_m [Hni [Hni' [Hmem [HSumA1 HSumA2]]]]]]]]]]]]]]]]]]]]] Hi];
  rewrite /= in Hi. move/Zle_is_le_bool in Hi.
exists A, ni, va, va', A'; repeat (split; trivial).
by rewrite -Hni.
by case: Hni'.

apply pull_out_exists => A.
apply pull_out_exists => ni.
apply pull_out_exists => va.
apply pull_out_exists => va'.

apply (hoare_prop_m.hoare_stren (!(fun s  => size A = nk /\
  \S_{ nk } A =m \S_{ nk } X ^^ Z.abs_nat (u2Z (ve `>> Z.abs_nat (ni + 1))) * \B^nk {{ \S_{ nk } M }} /\
  \S_{ nk } A < \S_{ nk } M /\ 0 <= ni <= Z_of_nat vl /\
  u2Z va + 4 * Z_of_nat nk.+1 < \B^1 /\
  u2Z va' + 4 * Z_of_nat nk.+1 < \B^1) **
(fun s h => (exists A'0, size A'0 = nk /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  [a]_s = va /\ [a']_s = va' /\ [x']_s = vx' /\ [m]_s = vm /\ s2Z [i]_s = ni /\
  (var_e a |--> A ++ zero32 :: nil ** var_e a' |--> A'0 ++ zero32 :: nil ** var_e x' |--> X' ** var_e m |--> M ++ zero32 :: nil) s h)))).

move=> s h [A' [HlenA [HlenA' [r_k [r_alpha [r_e [r_l [r_a [Hna [r_a' [Hna' [r_x' [r_m [r_i [Hni [Hmem [HSumA1 HsumA2]]]]]]]]]]]]]]]]].
exists heap.emp, h; repeat (split; trivial).
by map_tac_m.Disj.
by map_tac_m.Equal.
by exists A'.

apply pull_out_bang; case=> HlenA [HSumA1 [HSumA2 [Hni [Hna Hna']]]].

apply while.hoare_seq with ((fun s h => exists A'0, size A'0 = nk /\ [a]_s = va /\ [a']_s = va' /\
  [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a|-->A ** var_e a'|-->A'0 ++ zero32 :: nil ** var_e m|-->M ++ zero32 :: nil) s h /\
  \B^nk * \S_{ nk } A'0 =m \S_{ nk } A * \S_{ nk } A {{ \S_{ nk } M }} /\ \S_{ nk } A'0 < \S_{ nk } M) **
((fun s h => s2Z [i]_s = ni /\ [x']_s = vx' /\
  [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl)) //\\
(var_e x'|-->X' ** var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32))).

apply (hoare_prop_m.hoare_stren ((fun s h => exists A'0, size A'0 = nk /\ [a]_s = va /\
  [a']_s = va' /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a |--> A ** var_e a' |--> A'0 ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h) **
((fun s h => s2Z [i]_s = ni /\ [x']_s = vx' /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl)) //\\
  (var_e x' |--> X' ** var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32)))).

move=> s h [A' [HlenA' [r_k [r_alpha [r_e [r_l [r_a [r_a' [r_x' [r_m [r_i Hmem]]]]]]]]]]].

have {}Hmem : ((var_e a |--> A  ** var_e a' |--> A' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) **
  (var_e x' |--> X' ** var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32)) s h.
  rewrite (decompose_last_equiv _ A) HlenA in Hmem.
  by abstract assoc_comm Hmem.
case: Hmem => h1 [h2 [Hdisj [Hunion [H1 H2]]]].
exists h1, h2; repeat (split; trivial).
by exists A'.

apply frame_rule_R.
- eapply mont_square_strict_init_triple => //.
  by abstract Uniq_uniq r0.
- by Inde_frame.
- move=> ?; by Inde_mult.

apply pull_out_exists_con => A'.

apply (hoare_prop_m.hoare_stren (!(fun s => size A' = nk /\
  \B^nk * \S_{ nk } A' =m \S_{ nk } A * \S_{ nk } A {{\S_{ nk } M}} /\ \S_{ nk } A' < \S_{ nk } M) **
(fun s h => exists A, size A = nk /\ [a']_s = va' /\ [x']_s = vx' /\ [a]_s = va /\
  [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a' |--> A' ++ zero32 :: nil ** var_e x' |--> X' ** var_e a |--> A ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl)))).

move=> s h [h1 [h2 [Hdisj [Hunion [[HlenA' [r_a [r_a' [r_m [r_k [r_alpha [Hmem [HSumA'1 HSumA'2]]]]]]]] [[r_i [r_x' [r_e H1]]] Hmem2]]]]]].

exists heap.emp, (h1 \U h2); repeat (split; trivial).
by map_tac_m.Disj.
by map_tac_m.Equal.

exists A; repeat (split; trivial).
move: {Hmem Hmem2}(assert_m.con_cons _ _ _ _ _ Hdisj Hmem Hmem2) => Hmem.
rewrite (decompose_last_equiv _ A) HlenA.
by abstract assoc_comm Hmem.

apply pull_out_bang; case=> HlenA' [HSumA'1 HSumA'2].
apply eqmod_sym in HSumA'1.
move: {HSumA'1}(eqmod_rewrite _ _ _ _ _ HSumA1 HSumA'1) => HSumA'1.
rewrite mulZC in HSumA'1.
move: {HSumA1 HSumA'1}(eqmod_rewrite _ _ _ _ _ HSumA1 HSumA'1) => HSumA'1.
apply eqmod_sym in HSumA'1.
rewrite mulZC mulZA in HSumA'1.
apply eqmod_reg_mult' in HSumA'1; last first.
  apply Zis_gcd_sym; rewrite ZbetaE; exact: Zis_gcd_Zpower_odd.
rewrite -(mulZC (\B^nk)) -mulZA -ZpowerD in HSumA'1.
rewrite addnn -mul2n mulZC in HSumA'1.

clear A HlenA HSumA2.

(** srlv ei e i ; *)

apply hoare_srlv with (fun s h => exists A, size A = nk /\ [a']_s = va' /\
  [x']_s = vx' /\ [a]_s = va /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\
  (var_e a' |--> A' ++ zero32 :: nil ** var_e x' |--> X' ** var_e a |--> A ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\ [ei]_s = ve `>> (Z.abs_nat ni)).

move=> s h [A [HlenA [r_a' [r_x' [r_a [r_m [r_k [r_alpha [Hmem [r_i [r_e r_l]]]]]]]]]]].
rewrite /wp_srlv.
repeat Reg_upd.
exists A; repeat (split; trivial).

by Assert_upd.
rewrite u2Z_rem' //; last first.
  rewrite -s2Z_u2Z_pos /= r_i.
  apply (@leZ_ltZ_trans (Z_of_nat vl)); first by case: Hni.
  apply (@ltZ_leZ_trans  (Z_of_nat 32)) => //; exact/inj_lt/ltP.
by case: Hni.
rewrite -s2Z_u2Z_pos; last by rewrite r_i; case: Hni.
by rewrite r_i r_e.

(** andi ei ei one16 ; *)

apply hoare_andi with (fun s h => exists A, size A = nk /\ [a']_s = va' /\
  [x']_s = vx' /\ [a]_s = va /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\
  [alpha]_s = valpha /\
  (var_e a' |--> A' ++ zero32 :: nil ** var_e x' |--> X' ** var_e a |--> A ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  u2Z [ei]_s + 2 * u2Z (ve `>> Z.abs_nat (ni + 1)) = u2Z (ve `>> Z.abs_nat ni) /\
  ([ei]_s = zero32 \/ [ei]_s = one32)).

move=> s h [A [HlenA [r_a' [r_x' [r_a [r_m [r_k [r_alpha [Hmem [r_i [r_e [r_l r_ei]]]]]]]]]]]].
rewrite /wp_andi.
repeat Reg_upd.
exists A; repeat (split; trivial).
by Assert_upd.

rewrite r_ei /one16 zext_Z2u // int_and_rem_1 Zabs_nat_Zplus //; last by exact (proj1 Hni).
rewrite -shrl_comp mulZC addZC u2Z_shrl //; rewrite (_ : Z.abs_nat 1 = 1%nat) //; by repeat constructor.
rewrite zext_Z2u //.
case: (Zeven_odd_dec (u2Z [ei]_s)).
- move/int_even_and_1 => ->; by left.
- move/int_odd_and_1 => ->; by right.

(** ifte_beq ei, r0 thendo *)

apply while.hoare_seq with (fun s h => exists A A' new_va new_va',
  size A = nk /\ size A' = nk /\ [a']_s = new_va' /\
  u2Z new_va' + 4 * Z_of_nat nk.+1 < \B^1 /\
  [x']_s = vx' /\ [a]_s = new_va /\ u2Z new_va + 4 * Z_of_nat nk.+1 < \B^1 /\
  [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a |--> A ++ zero32::nil ** var_e x' |--> X' ** var_e a' |--> A' ++ zero32::nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  \S_{ nk } A =m \S_{ nk } X ^^ Z.abs_nat ((2 * u2Z (ve `>> Z.abs_nat (ni+1))) + u2Z((ve `>> Z.abs_nat ni) `& one32)) * \B^nk {{ \S_{ nk } M }} /\
  \S_{ nk } A < \S_{ nk } M /\ s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  u2Z [ei]_s + 2 * u2Z (ve `>> Z.abs_nat (ni + 1)) = u2Z (ve `>> Z.abs_nat ni)).

apply while.hoare_ifte.

(**  (xor a a a'; *)

apply hoare_xor with (fun s h => exists A, size A = nk /\ [a']_s = va' /\
  [x']_s = vx' /\ [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (((var_e a' |--> A' ++ zero32 :: nil ** var_e x' |--> X') ** int_e va |--> A ++ zero32 :: nil) ** var_e m |--> M ++ zero32 :: nil) s h /\
  s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  u2Z [ei]_s + 2 * u2Z (ve `>> Z.abs_nat (ni + 1)) = u2Z (ve `>> Z.abs_nat ni) /\
  [ei]_s = zero32 /\ [a]_s = va `(+) va').

move=> s h [[A [HlenA [r_a' [r_x' [r_a [r_m [r_k [r_alpha [Hmem [r_i [r_e [r_l [r_ei r_ei']]]]]]]]]]]]] Heqei0];
  rewrite /= in Heqei0. move/eqP in Heqei0.

rewrite /wp_xor.
repeat Reg_upd.
exists A; repeat (split; trivial).
Assert_upd.
assoc_comm Hmem.
move: Hmem.
exact: mapstos_ext.
by move/u2Z_inj : Heqei0.
by rewrite -r_a -r_a'.

(**  xor a' a a'; *)

apply hoare_xor with (fun s h => exists A, size A = nk /\ [x']_s = vx' /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (((int_e va' |--> A' ++ zero32 :: nil ** var_e x' |--> X') ** int_e va |--> A ++ zero32 :: nil) ** var_e m |--> M ++ zero32 :: nil) s h /\
  s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  u2Z [ei]_s + 2 * u2Z (ve `>> Z.abs_nat (ni + 1)) = u2Z (ve `>> Z.abs_nat ni) /\
  [ei]_s = zero32 /\ [a]_s = va `(+) va' /\ [a']_s = va' `(+) (va `(+) va')).

move=> s h [A [HlenA [r_a' [r_x' [r_m [r_k [r_alpha [Hmem [r_i [r_e [r_l [r_ei [r_ei' r_a]]]]]]]]]]]]].

rewrite /wp_xor.
repeat Reg_upd.
exists A; repeat (split; trivial).
Assert_upd.
assoc_comm Hmem.
by move: Hmem; apply mapstos_ext.
by rewrite r_a r_a' int_xorC.

(**  xor a a a')
 elsedo *)

apply hoare_xor'.

move=> s h [A [HlenA [r_x' [r_m [r_k [r_alpha [Hmem [r_i [r_e [r_l [r_ei [r_ei' [r_a r_a']]]]]]]]]]]]].

rewrite /wp_xor.
repeat Reg_upd.
exists A', A, va', va; repeat (split; trivial).
by rewrite r_a' int_xorC int_xorA int_xor_self int_xor_0.
by rewrite r_a' r_a int_xorC int_xorA int_xor_self int_xor_0.

(* NB: here, the "strategy" implemented by Assert_upd fails *)
move: Hmem.
rewrite 2!conAE.
apply monotony => h'.
apply mapstos_ext => //=.
Reg_upd.
by rewrite r_a r_a' /= int_xorC int_xorA int_xor_self int_xor_0.
apply monotony => h''.
apply mapstos_ext => //=.
by Reg_upd.
apply monotony => h'''.
apply mapstos_ext => //=.
Reg_upd.
by rewrite /= r_a' int_xorC int_xorA int_xor_self int_xor_0.
apply mapstos_ext => //=.
by Reg_upd.

rewrite Zabs_nat_Zplus; last 2 first.
  apply mulZ_ge0 => //; exact: min_u2Z.
  exact: min_u2Z.
apply: (eqmod_trans _ _ _ _ HSumA'1).
apply eqmod_reg_mult.
rewrite Zabs_nat_mult (_ : Z.abs_nat 2 = 2%nat); last by [].
rewrite int_even_and_1; last first.
  rewrite -r_ei r_ei' Z2uK // add0Z; exact: Zeven_2.
rewrite Z2uK // [Z.abs_nat 0]/= plusE addn0; exact: eqmod_refl.

(**  mont_mul_strict_init k alpha a' x' a m one ext int_ X_ Y_ M_ Z_ quot C t s_; *)

apply (hoare_prop_m.hoare_stren ((fun s h => exists A, size A = nk /\
  [a']_s = va' /\ [x']_s = vx' /\ [a]_s = va /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a' |--> A' ** var_e x' |--> X' ** var_e a |--> A ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h) **
((fun s _ => s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  u2Z [ei]_s + 2 * u2Z (ve `>> Z.abs_nat (ni + 1)) = u2Z (ve `>> Z.abs_nat ni) /\ [ei]_s = one32) //\\
 (var_e a' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32)))).

move=> s h [ [A [HlenA [r_a' [r_x' [r_a [r_m [r_k [r_alpha [Hmem [r_i [r_e [r_l [r_ei r_ei']]]]]]]]]]]]] Hbneei0];
  rewrite /= in Hbneei0. move/eqP in Hbneei0.

have {}Hmem : ((((var_e a' |--> A' ** var_e x' |--> X') ** var_e a |--> A ++ zero32 :: nil) ** var_e m |--> M ++ zero32 :: nil) ** (var_e a' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32)) s h.
  rewrite (decompose_last_equiv _ A') HlenA' in Hmem.
  by abstract assoc_comm Hmem.
case: Hmem => h1 [h2 [Hdisj [Hunion [Hmem1 Hmem2]]]].
exists h1, h2; repeat (split; trivial).
exists A; repeat (split; trivial).
by rewrite -2!conAE.
case: r_ei' => r_ei' //.
by rewrite store.get_r0 r_ei' in Hbneei0.

apply hoare_prop_m.hoare_weak with ((fun s h => exists A, size A = nk /\
  [a']_s = va' /\ [x']_s = vx' /\ [a]_s = va /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a' |--> A' ** var_e x' |--> X' ** var_e a |--> A ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  \B^nk * \S_{ nk } A =m \S_{ nk } A' * \S_{ nk } X' {{ \S_{ nk } M }} /\ \S_{ nk } A < \S_{ nk } M) **
((fun s m => s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  u2Z [ei]_s + 2 * u2Z (ve `>> Z.abs_nat (ni + 1)) = u2Z (ve `>> Z.abs_nat ni) /\ [ei]_s = one32) //\\
 (var_e a' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32))).

move=> s h [h1 [h2 [Hdisj [Hunion [[A [HlenA [r_a' [r_x' [r_a [r_m [r_k [r_alpha [Hmem1 [Sum_A1 Sum_A2]]]]]]]]]] [[r_i [r_e [r_l [r_ei r_ei']]]] Hmem2]]]]]].

exists A, A', va, va'; repeat (split; trivial).
rewrite (decompose_last_equiv _ A') HlenA'.
move: {Hmem1 Hmem2}(assert_m.con_cons _ _ _ _ _ Hdisj Hmem1 Hmem2) => Hmem.
rewrite -Hunion in Hmem.
by abstract assoc_comm Hmem.

apply: (eqmod_reg_mult_beta_odd _ _ nk _ HZoddM).
apply: (eqmod_trans _ _ _ _ Sum_A1).
apply eqmod_sym in HSumA'1; apply: (eqmod_rewrite _ _ _ _ _ HSumA'1).
rewrite mulZC.
apply eqmod_sym in HSumX'1; apply: (eqmod_rewrite _ _ _ _ _ HSumX'1).

rewrite mulZA mulZC.

apply eqmod_reg_mult_l.
rewrite mulZC mulZA.
apply eqmod_reg_mult.
rewrite mulZC -ZpowerS int_odd_and_1; last first.
  rewrite -r_ei r_ei' Z2uK // addZC.
  exact: Zodd_1.
rewrite Z2uK //.
apply eqmod_sym.
rewrite Zabs_nat_Zplus //; last by apply mulZ_ge0; [ | exact: min_u2Z].
rewrite Zabs_nat_mult plusE addnC; exact: eqmod_refl.

apply frame_rule_R.
- eapply mont_mul_strict_init_triple => //.
  by abstract Uniq_uniq r0.
- by Inde_frame.
- move=> ?; by Inde_mult.

clear HSumA'1 HSumA'2 HlenA' A'.

apply pull_out_exists => A.
apply pull_out_exists => A'.
clear va Hna va' Hna'.
apply pull_out_exists => va.
apply pull_out_exists => va'.

apply (hoare_prop_m.hoare_stren (!(fun s  => size A = nk /\ size A' = nk /\
    u2Z va + 4 * Z_of_nat nk.+1 < \B^1 /\ u2Z va' + 4 * Z_of_nat nk.+1 < \B^1 /\
    \S_{ nk } A =m \S_{ nk } X ^^ Z.abs_nat (2 * u2Z (ve `>> Z.abs_nat (ni + 1)) + u2Z ((ve `>> Z.abs_nat ni) `& one32)) * \B^nk {{\S_{ nk } M}} /\
    \S_{ nk } A < \S_{ nk } M) **
(fun s h => [a']_s = va' /\ [x']_s = vx' /\ [a]_s = va /\
  [m]_s = vm /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  s2Z [i]_s = ni /\ [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\
  u2Z [ei]_s + 2 * u2Z (ve `>> Z.abs_nat (ni + 1)) = u2Z (ve `>> Z.abs_nat ni) /\
  ((((var_e a' |--> A' ** var_e x' |--> X') ** var_e a |--> A ++ zero32 :: nil) ** var_e m |--> M ++ zero32 :: nil) **
    (var_e a' \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32)) s h))).

move=> s h [HlenA [HlenA' [r_a' [Hna' [r_x' [r_a [Hna [r_m [r_k [r_alpha [Hmem [Sum_A1 [Sum_A2 [r_i [Hgpe [r_l r_ei]]]]]]]]]]]]]]]].
exists heap.emp, h; repeat (split; trivial).
by map_tac_m.Disj.
by map_tac_m.Equal.
rewrite (decompose_last_equiv _ A') HlenA' in Hmem.
by abstract assoc_comm Hmem.

apply pull_out_bang; case => HlenA [HlenA' [Hna [Hna' [HSumA1 HSumA2]]]].

(** addiu i i mone16)); *)

apply hoare_addiu'.

move=> s h [r_a' [r_x' [r_a [r_m [r_k [r_alpha [r_i [r_e [r_l [ r_ei Hmem]]]]]]]]]].

rewrite /wp_addiu.
exists A, A', va, va', (ni - 1).
repeat Reg_upd.
repeat (split; trivial).

rewrite /mone16 s2Z_add.
by rewrite (@sext_s2Z 16) Z2sK // r_i.
rewrite (@sext_s2Z 16) Z2sK // r_i.
split.
  apply (@leZ_trans (-1)); first by [].
  rewrite -{1}(add0Z (-1)) leZ_add2r; by case: Hni.
move: (max_s2Z [i]_s) => Y.
rewrite r_i in Y.
  apply (@ltZ_trans (2 ^^ 31 + -1)); by [exact: ltZ_le_add | ].
rewrite -{1}(add0Z (-1)) leZ_add2r; by case: Hni.
apply (@leZ_trans ni); by [ apply Zminus_le_decr | case: Hni].

rewrite (decompose_last_equiv _ A') HlenA'.
Assert_upd.
by abstract assoc_comm Hmem.

rewrite addZC Zplus_minus.
apply (eqmod_trans _ _ _ _ HSumA1), eqmod_reg_mult.
rewrite (Zabs_nat_Zplus ni _ (proj1 Hni)) // -shrl_comp int_and_rem_1 -(@u2Z_shrl _ (ve `>> Z.abs_nat ni) 1%nat); last by repeat constructor.
rewrite mulZC [2 ^^ 1]/=; exact: eqmod_refl.
by Inde_frame.
move=> ?; by Inde_mult.

clear HlenA HlenA' HA HA' HSumA HSumA'SumM A A' Hna va Hna' va'.

apply pull_out_exists_con => A.
apply pull_out_exists_con => A'.
apply pull_out_exists_con => va.
apply pull_out_exists_con => va'.

(** mont_mul_strict_init k alpha a one' a' m one ext int_ X_ Y_ M_ Z_ quot C t s_. *)

apply (hoare_prop_m.hoare_stren (!(fun s => ((size A = nk /\ size A' = nk /\
  u2Z va + 4 * Z_of_nat nk.+1 < \B^1 /\
  u2Z va' + 4 * Z_of_nat nk.+1 < \B^1 /\
  \S_{ nk } A =m \S_{ nk } X ^^ Z.abs_nat (u2Z ve) * \B^nk {{\S_{ nk } M}} /\ \S_{ nk } A < \S_{ nk } M))) **
(fun s h => u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\ [e]_s = ve /\
  [l]_s = Z2s 32 (Z_of_nat vl) /\ [a]_s = va /\ [a']_s = va' /\
  [x']_s = vx' /\ [m]_s = vm /\ [x]_s = vx /\ [one']_s = vone' /\
  (var_e x|-->X ** var_e a |--> A ++ zero32 :: nil ** var_e a' |--> A' ++ zero32 :: nil ** var_e x' |--> X' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil ** var_e one' |--> ONE') s h))).

move=> s h [h1 [h2 [Hdisj [Hunion [[HlenA [HlenA' [r_k [r_alpha [r_e [r_l [r_a [Hna [r_a' [Hna' [r_x' [r_m [Hmem [HSumA1 HSumA2]]]]]]]]]]]]]] [r_x [r_one' Hmem2]]]]]]].

exists heap.emp, (h1 \U h2); repeat (split; trivial).
by map_tac_m.Disj.
by map_tac_m.Equal.
move: {Hmem Hmem2}(assert_m.con_cons _ _ _ _ _ Hdisj Hmem Hmem2) => Hmem.
rewrite (decompose_last_equiv _ X') HlenX'.
by abstract assoc_comm Hmem.

apply pull_out_bang; case => HlenA [HlenA' [Hna [Hna' [HSumA1 HSumA2]]]].

apply (hoare_prop_m.hoare_stren ((fun s h => exists A', size A' = nk /\
  [a]_s = va /\ [one']_s = vone' /\ [a']_s = va' /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a |--> A ** var_e one' |--> ONE' ** var_e a' |--> A' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h) **
(fun s h => [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\ [x]_s = vx /\  [x']_s = vx' /\
  (var_e x|-->X ** var_e x' |--> X' ++ zero32 :: nil ** var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32) s h))).

move=> s h [r_k [r_alpha [r_e [r_l [r_a [r_a' [r_x' [r_m [hgprx [rone' Hmem]]]]]]]]]].

have {}Hmem : ((var_e a |--> A ** var_e a' |--> A' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil ** var_e one' |--> ONE') ** (var_e x|-->X**var_e x' |--> X' ++ zero32 :: nil ** var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32)) s h.
  rewrite (decompose_last_equiv _ A) HlenA in Hmem.
  by abstract assoc_comm Hmem.
case:Hmem => [h1 [h2 [Hdisj [Hunion [Hmem1 Hmem2]]]]].
exists h1, h2; repeat (split; trivial).
exists A'; repeat (split; trivial).
by abstract assoc_comm Hmem1.

clear A' HlenA'.

apply hoare_prop_m.hoare_weak with ((fun s h => exists A', size A' = nk /\
  [a]_s = va /\ [one']_s = vone' /\ [a']_s = va' /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a |--> A ** var_e one' |--> ONE' ** var_e a' |--> A' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  \S_{ nk } A' =m \S_{ nk } X ^^ (Z.abs_nat (u2Z ve)) {{ \S_{ nk } M }} /\ \S_{ nk } A' < \S_{ nk } M) **
(fun s h => [e]_s = ve /\ [l]_s = Z2s 32 (Z_of_nat vl) /\ [x]_s = vx /\  [x']_s = vx' /\
  (var_e x|-->X ** var_e x' |--> X' ++ zero32 :: nil ** var_e a \+ int_e (Z2u 32 (Z_of_nat (4 * nk))) |~> int_e zero32) s h)).

move=> s h [h1 [h2 [Hdisj [Hunion [[A' [HlenA' [r_a [r_one' [r_a' [r_m [r_k [r_alpha [Hmem [HSumA'1 HSumA'2]]]]]]]]]] [r_e [r_l [r_x [r_x' Hmem2]]]]]]]]].

exists A, A', X', va, va'; repeat (split; trivial).
move: {Hmem Hmem2}(assert_m.con_cons _ _ _ _ _ Hdisj Hmem Hmem2) => Hmem.
rewrite (decompose_last_equiv _ A) HlenA Hunion.
by abstract assoc_comm Hmem.
by rewrite r_e.

apply frame_rule_R.

apply hoare_prop_m.hoare_weak with (fun s h => exists A', size A' = nk /\ [a]_s = va /\
  [one']_s = vone' /\ [a']_s = va' /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e a |--> A ** var_e one' |--> ONE' ** var_e a' |--> A' ++ zero32 :: nil ** var_e m |--> M ++ zero32 :: nil) s h /\
  \B^nk * \S_{ nk } A' =m \S_{ nk } A * \S_{ nk } ONE' {{ \S_{ nk } M }} /\ \S_{ nk } A' < \S_{ nk } M).

move=> s h [A' [HlenA' [r_a [r_one' [r_a' [r_m [r_k [r_alpha [Hmem [Sum_A1' Sum_A2']]]]]]]]]].
exists A'; repeat (split; trivial).

apply eqmod_reg_mult' with (\B^nk).
apply Zis_gcd_sym.
rewrite ZbetaE.
apply Zis_gcd_Zpower_odd; first by [].
eapply eqmod_trans.
rewrite mulZC; exact: Sum_A1'.
by rewrite HSumONE'_is_1 mulZ1.

eapply mont_mul_strict_init_triple; eauto.
by abstract Uniq_uniq r0.
by Inde_frame.
move=> ?; by Inde_mult.
Qed.


Require Import Iron.Language.SystemF2Effect.Type.Exp.
Require Import Iron.Language.SystemF2Effect.Type.Relation.KindT.
Require Import Iron.Language.SystemF2Effect.Type.Relation.SubsTs.
Require Import Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Import Iron.Language.SystemF2Effect.Type.Operator.SubstTT.
Require Import Iron.Language.SystemF2Effect.Type.Operator.MaskOnT.
Require Import Iron.Language.SystemF2Effect.Type.Operator.BunchT.
Require Import Iron.Language.SystemF2Effect.Type.Operator.FlattenT.

(********************************************************************)
(* Like maskOnT, but work with a list of types instead of a
   bunched type with TSum constructors. *)
Fixpoint maskOnTs (p : ty -> bool) (tt : list ty) : list ty
 := match tt with
    | nil            => nil

    | TCon1 tc t1   :: ts
    => if p (TCon1 tc t1) then                maskOnTs p ts
                          else TCon1 tc t1 :: maskOnTs p ts

    |  t :: ts
    => t :: maskOnTs p ts
    end.

(********************************************************************)
Lemma maskOnTs_cases
 :  forall   p t ts ts'
 ,  maskOnTs p (t :: ts) = ts'
 -> (ts' =      maskOnTs p ts)
 \/ (ts' = t :: maskOnTs p ts).
Proof.
 intros.
 simpl in H.
 destruct t; try auto.
  split_if; auto.
Qed.

(* Structural lemmas. *)
Lemma maskOnTs_app
 :  forall p ts1 ts2
 ,  maskOnTs p ts1 ++ maskOnTs p ts2
 =  maskOnTs p (ts1 ++ ts2).
Proof.
 induction ts1; intros.
 - snorm.
 - rrwrite (ts2 >< (ts1 :> a) = (ts2 >< ts1) :> a).
   destruct a;
    try (solve [simpl; rewritess; auto]).
   + simpl.
     split_if.
     * auto.
     * simpl. rewritess. auto.
Qed.
Hint Resolve maskOnTs_app.

Lemma maskOnTs_flattenT
 :  forall p t
 ,  flattenT (maskOnT p t) = maskOnTs p (flattenT t).
Proof.
 intros.
 induction t; snorm.
 - repeat rewritess.
   apply maskOnTs_app.
 - unfold maskOnT.
   split_if.
   + snorm.
   + nope.
 - unfold maskOnT.
   split_if.
   + nope.
   + snorm.
Qed.
Hint Resolve maskOnTs_flattenT.

(* Kind preservation. *)
Lemma maskOnTs_kind
 :  forall ke sp ts k p
 ,  KindTs ke sp ts k
 -> KindTs ke sp (maskOnTs p ts) k.
Proof.
 intros.
 induction ts.
 - simpl. auto.
 - apply kindTs_snoc in H. rip.
   remember (maskOnTs p (ts :> a)) as ts2.
    symmetry in Heqts2.
    apply maskOnTs_cases in Heqts2.
    inverts Heqts2; auto.
Qed.
Hint Resolve maskOnTs_kind.

(* Equivalence *)
Lemma maskOnTs_maskOnT_equivTs
 :  forall ke sp p t k
 ,  SumKind k
 -> KindT   ke sp t k
 -> EquivTs ke sp (flattenT (maskOnT p t)) (maskOnTs p (flattenT t)) k.
Proof.
 intros. gen k.
 induction t; intros;
   try (solve [simpl; eapply equivTs_refl; auto]).

 - Case "TSum".
   inverts H0.
    spec IHt1 H6; auto.
    spec IHt2 H8; auto.
    simpl.
    rewrite <- maskOnTs_app.
    eauto.

 - Case "TCon1".
   simpl.
   split_if.
   + unfold maskOnT.
     rewrite <- HeqH1.
     simpl. auto.
   + unfold maskOnT.
     rewrite <- HeqH1.
     simpl. auto.
Qed.
Hint Resolve maskOnTs_maskOnT_equivTs.

(* Subsumption *)
Lemma maskOnTs_subsTs_below
 :  forall ke sp ts1 ts2 k p
 ,  SubsTs ke sp ts1 ts2 k
 -> SubsTs ke sp ts1 (maskOnTs p ts2) k.
Proof.
 intros.
 inverts H.
 eapply SbsSum; auto.
 - induction ts2.
   + snorm.
   + eapply kindTs_snoc in H2. rip.
     apply Forall_split_cons in H3.
     remember (maskOnTs p (ts2 :> a)) as ts'.
      symmetry in Heqts'.
      apply maskOnTs_cases in Heqts'.
      rip. inverts Heqts'.
       auto. auto.
Qed.
Hint Resolve maskOnTs_subsTs_below.

Lemma maskOnT_subsT_below
 :  forall ke sp p e1 e2
 ,  SubsT  ke sp e1 e2             KEffect
 -> SubsT  ke sp e1 (maskOnT p e2) KEffect.
Proof.
 intros.

 have  HE1: (EquivT ke sp (bunchT KEffect (flattenT e1))
                          e1                                         KEffect).
 eapply subsT_equiv_above; eauto.
 clear HE1.

 have  HE2: (EquivT ke sp (maskOnT p e2)
                          (bunchT KEffect (flattenT (maskOnT p e2))) KEffect)
  by (eapply EqSym; [eapply bunchT_kindT; eauto | eauto | eauto]).
 eapply subsT_equiv_below.
  eapply EqSym in HE2; eauto.
 clear HE2.

 eapply subsTs_subsT.

 rrwrite (flattenT (maskOnT p e2) = maskOnTs p (flattenT e2)).
 eapply maskOnTs_subsTs_below.

 eapply subsT_subsTs; eauto.
Qed.
Hint Resolve maskOnT_subsT_below.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Div.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)
From Coq Require Import ArithRing.
From Coq Require Export Arith.
From Bertrand Require Export Power Divides.
From Bertrand Require Import Misc.

(** Auxillary function to compute the quotient and rest of a division *)

Fixpoint pdiv_aux (m n p : nat) {struct p} : nat * nat :=
  match ominus m n with
  | None => (0, m)
  | Some m1 =>
      match p with
      | O => (m, n)
      | S p1 => match pdiv_aux m1 n p1 with
                | (q, r) => (S q, r)
                end
      end
  end.

Theorem ominus_id : forall n : nat, ominus n n = Some 0.
Proof.
simple induction n; auto.
Qed.

Theorem pdiv_aux_def :
 forall m n p : nat,
 m <= p ->
 0 < n -> match pdiv_aux m n p with
          | (q, r) => m = q * n + r /\ r < n
          end.
Proof.
intros m n p; generalize m n; clear m n; elim p; clear p; simpl in |- *.
intros m n H; inversion H; simpl in |- *; case n; simpl in |- *;
 auto with arith.
intros p1 Rec m n H1 H2.
generalize (ominus_def m n); case (ominus m n); auto with arith.
intros s Hs; generalize (Rec s n); case (pdiv_aux s n p1).
intros q r H3; case H3; auto with arith.
apply Nat.lt_succ_r.
apply Nat.lt_le_trans with (2 := H1).
rewrite Hs.
pattern s at 1 in |- *; replace s with (0 + s); auto with arith.
intros H4 H5; split; auto.
rewrite Hs; rewrite H4; simpl in |- *; auto with arith.
Qed.

(** Function that computes quotient and rest of a division *)

Definition pdiv (m n : nat) := pdiv_aux m n m.

Theorem pdiv_def :
 forall m n : nat,
 0 < n -> match pdiv m n with
          | (q, r) => m = q * n + r /\ r < n
          end.
Proof.
intros m n H; unfold pdiv in |- *; apply pdiv_aux_def with (p := m);
 auto with arith.
Qed.

(* Division : returns the quotient *)

Definition div (m n : nat) := fst (pdiv m n).

Theorem div_le : forall m n : nat, 0 < n -> n * div m n <= m.
Proof.
intros m n H; unfold div in |- *; generalize (pdiv_def m n H);
 case (pdiv m n); simpl in |- *.
intros q r (H1, H2); rewrite H1; auto with arith.
rewrite (Nat.mul_comm n); auto with arith.
Qed.

Theorem div_lt : forall m n : nat, 0 < n -> m < n * (1 + div m n).
Proof.
intros m n H; unfold div in |- *; generalize (pdiv_def m n H);
 case (pdiv m n); simpl in |- *.
intros q r (H1, H2); rewrite H1; auto with arith.
rewrite (Nat.mul_comm n); simpl in |- *; auto with arith.
rewrite (Nat.add_comm n); simpl in |- *; auto with arith.
Qed.

Theorem div_unique :
 forall m n p : nat, 0 < n -> n * p <= m -> m < n * (1 + p) -> p = div m n.
Proof.
intros m n p H H0 H1.
case (Nat.le_gt_cases p (div m n)); intros H2.
case ((proj1 (Nat.lt_eq_cases _ _)) H2); intros H3; auto.
absurd (n * div m n <= m).
apply Nat.lt_nge; apply Nat.lt_le_trans with (1 := H1); auto with arith.
apply div_le; auto.
absurd (m < n * (1 + div m n)).
apply Nat.le_ngt; apply Nat.le_trans with (2 := H0); auto with arith.
apply div_lt; auto.
Qed.

Theorem div_mult_le :
 forall m n p : nat, 0 < n -> p * div m n <= div (p * m) n.
Proof.
intros m n p H1.
apply Nat.lt_succ_r; change (p * div m n < 1 + div (p * m) n) in |- *.
apply lt_mult_right_anti with (z := n).
apply Nat.le_lt_trans with (p * m).
replace (n * (p * div m n)) with (p * (n * div m n));
 [ idtac | repeat rewrite Nat.mul_assoc; rewrite (Nat.mul_comm p); auto ].
apply (fun m n p : nat => Nat.mul_le_mono_l p n m).
apply div_le; auto.
apply div_lt; auto.
Qed.

Theorem div_mult_lt :
 forall m n p : nat, 0 < n -> 0 < p -> div (p * m) n < p * (1 + div m n).
Proof.
intros m n p H H1; apply lt_mult_right_anti with (z := n).
apply Nat.le_lt_trans with (p * m).
apply div_le; auto.
replace (n * (p * (1 + div m n))) with (p * (n * (1 + div m n)));
 [ idtac | repeat rewrite Nat.mul_assoc; rewrite (Nat.mul_comm p); auto ].
apply mult_lt_bis; try apply div_lt; auto.
Qed.

(* Correspond to Proposition 1 of page 1 *)

Theorem div_mult_lt2 :
 forall m n p : nat, 0 < n -> div (2 * m) n <= 2 * div m n + 1.
Proof.
intros m n p H.
apply Nat.lt_succ_r.
replace (S (2 * div m n + 1)) with (2 * (1 + div m n));
 [ apply div_mult_lt
 | repeat (rewrite <- plus_n_O || rewrite <- plus_n_Sm; simpl in |- *) ];
 auto.
Qed.

Theorem div_divides_S :
 forall p q : nat, 0 < q -> divides q (S p) -> div (S p) q = S (div p q).
Proof.
intros p q H (qr, H1); apply sym_equal; auto.
apply trans_equal with qr.
generalize (pdiv_def p q H); unfold div in |- *; case (pdiv p q);
 simpl in |- *.
intros q1 r1 (H2, H3).
apply eq_mult with q; auto with arith.
apply sym_not_equal; auto with arith.
repeat rewrite (Nat.mul_comm q); auto with arith.
rewrite <- H1; rewrite H2.
cut (S r1 = q); [ intros H4 | idtac ].
rewrite plus_n_Sm; rewrite H4; simpl in |- *; ring.
apply Nat.le_antisymm; auto with arith.
apply divides_le; auto with arith.
apply divides_plus2 with (b := q1 * q).
exists q1; auto with arith.
rewrite <- plus_n_Sm; rewrite <- H2; auto.
rewrite H1; exists qr; auto.
apply div_unique; auto with arith.
rewrite H1; rewrite (Nat.mul_comm q); auto with arith.
rewrite H1; repeat rewrite (Nat.mul_comm qr); auto with arith.
Qed.

Theorem div_not_divides_S :
 forall p q : nat, 0 < q -> ~ divides q (S p) -> div (S p) q = div p q.
Proof.
intros p q H H1; apply sym_equal; apply div_unique; auto.
apply Nat.le_trans with p; auto with arith.
apply div_le; auto with arith.
generalize (pdiv_def p q H); unfold div in |- *; case (pdiv p q);
 simpl in |- *.
intros q1 r1 (H2, H3).
rewrite H2.
rewrite plus_n_Sm; auto.
rewrite <- mult_n_Sm; auto.
repeat rewrite (Nat.mul_comm q); auto with arith.
apply Nat.add_lt_mono_l; auto with arith.
case (proj1 (Nat.lt_eq_cases (S r1) q)); auto.
intros H4; case H1; exists (S q1).
rewrite H2.
rewrite plus_n_Sm; auto.
rewrite H4; simpl in |- *; ring.
Qed.

Theorem divides_pdiv :
 forall p q : nat, 0 < q -> divides q p -> snd (pdiv p q) = 0.
Proof.
intros p q H (q1, H1); generalize (pdiv_def p q H); case (pdiv p q);
 simpl in |- *.
intros q2 r2 (H2, H3).
apply (div_unic_r p q q2 q1); split; auto.
rewrite H1; ring.
Qed.

Theorem not_divides_pdiv :
 forall p q : nat, 0 < q -> ~ divides q p -> snd (pdiv p q) <> 0.
Proof.
intros p q H; generalize (pdiv_def p q H); case (pdiv p q); simpl in |- *.
intros q1 r1 (H1, H2) H3; red in |- *; intros H4; case H3; exists q1;
 rewrite H1; rewrite H4; ring.
Qed.

Theorem pdiv_divides :
 forall n m : nat, 0 < m -> snd (pdiv n m) = 0 -> divides m n.
Proof.
intros n m H; generalize (pdiv_def n m H); case (pdiv n m); simpl in |- *.
intros n1 m1 (H1, H2) H3; exists n1; rewrite H1; rewrite H3;
 rewrite <- plus_n_O; auto.
Qed.

Theorem pdiv_not_divides :
 forall n m : nat, 0 < m -> snd (pdiv n m) <> 0 -> ~ divides m n.
Proof.
intros n m H H0; red in |- *; intros H1; case H0; apply divides_pdiv; auto.
Qed.

(* Divisibility is decidable *)

Definition divides1_dec : forall n m : nat, {divides n m} + {~ divides n m}.
intros n m; case n.
case m.
left; exists 0; auto.
intros n1; right; red in |- *; intros (x, H1); rewrite Nat.mul_comm in H1;
 discriminate.
intros n1; generalize (pdiv_divides m (S n1));
 generalize (pdiv_not_divides m (S n1)); case (pdiv m (S n1));
 simpl in |- *.
intros p q; case q.
intros H1 H2; left; auto with arith.
intros q1 H1 H2; right; auto with arith.
Defined.

Theorem divides_div :
 forall p q : nat, 0 < p -> divides p q -> q = div q p * p.
Proof.
intros p q Hp (x, H); rewrite H.
apply f_equal2 with (f := mult); auto with arith.
apply div_unique; auto with arith.
rewrite (Nat.mul_comm x); auto with arith.
rewrite (Nat.mul_comm x); auto with arith.
Qed.

Theorem lt_div_O : forall p q : nat, p < q -> div p q = 0.
Proof.
intros p q H.
generalize (pdiv_def p q); unfold div in |- *; case (pdiv p q); simpl in |- *.
intros q1 r1; case q1; simpl in |- *; auto with arith.
intros n H0; (absurd (q <= p); auto with arith).
case H0; auto with arith.
apply Nat.le_lt_trans with (2 := H); auto with arith.
intros H1 H2; rewrite H1; auto with arith.
Qed.


Require Import Coqlib.
Require Import EvalTac.
Require Import Semantics.
Require Import Values.
Require Import AST.
Require Import BuiltinTest.

Lemma eval_mod :
  eval_expr ge empty (EVar (246,"mod")) (bits (v 5)).
Proof.
  repeat e.
  Unshelve.
  all: exact nz.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

From QArithSternBrocot Require Export Qpositive.

Definition Qpositive_plus (w w' : Qpositive) : Qpositive :=
  let (p, q) := Qpositive_i w in
  let (p', q') := Qpositive_i w' in
  Qpositive_c (p * q' + p' * q) (q * q') (p * q' + p' * q + q * q').

Theorem Qpositive_plus_1 : forall w : Qpositive, Qpositive_plus One w = nR w.
intros w; elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq.
unfold Qpositive_plus in |- *.
replace (Qpositive_i One) with (1, 1).
rewrite Heq.
rewrite Nat.mul_1_r; rewrite Nat.mul_1_l.
rewrite (Nat.add_comm (S q)).
replace (S p + S q + S q) with (S (p + S q + S q)).
rewrite (Qpositive_c_unfold1 p q).
rewrite (construct_correct w); auto with *.
auto.
auto.
auto.
Qed.

Theorem Qpositive_plus_sym :
 forall w w' : Qpositive, Qpositive_plus w w' = Qpositive_plus w' w.
intros w w'; elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq;
 clear Hex.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq'; clear Hex.
unfold Qpositive_plus in |- *.
rewrite Heq; rewrite Heq'.
repeat rewrite (Nat.mul_comm (S q')).
repeat rewrite (Nat.mul_comm (S p')).
repeat rewrite (Nat.add_comm (S p * S q')).
auto.
Qed.

Theorem Qpositive_plus_assoc :
 forall w w' w'' : Qpositive,
 Qpositive_plus (Qpositive_plus w w') w'' =
 Qpositive_plus w (Qpositive_plus w' w'').
intros w w' w''; elim (interp_non_zero w); intros p Hex; elim Hex;
 intros q Heq; clear Hex.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq'; clear Hex.
elim (interp_non_zero w''); intros p'' Hex; elim Hex; intros q'' Heq'';
 clear Hex.
unfold Qpositive_plus in |- *.
rewrite Heq; rewrite Heq'; rewrite Heq''.
elim
 (construct_correct2' (S p * S q' + S p' * S q + S q * S q')
    (S p * S q' + S p' * S q) (S q * S q')).
intros d;
 elim
  (interp_non_zero
     (Qpositive_c (S p * S q' + S p' * S q) (S q * S q')
        (S p * S q' + S p' * S q + S q * S q'))); intros p3 Hex;
 elim Hex; intros q3 Heq3; rewrite Heq3; clear Hex.
intros (Heq1, Heq2).
elim
 (construct_correct2' (S p' * S q'' + S p'' * S q' + S q' * S q'')
    (S p' * S q'' + S p'' * S q') (S q' * S q'')).
intros d';
 elim
  (interp_non_zero
     (Qpositive_c (S p' * S q'' + S p'' * S q') (S q' * S q'')
        (S p' * S q'' + S p'' * S q' + S q' * S q'')));
 intros p4 Hex; elim Hex; intros q4 Heq6; rewrite Heq6;
 clear Hex.
intros (Heq4, Heq5).
apply construct_correct4'.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
auto.
unfold snd, fst in Heq5, Heq1, Heq2, Heq4, Heq5.
apply mult_reg_l with d'.
rewrite Nat.mul_add_distr_r.
rewrite (Nat.mul_comm (S d')).
rewrite Nat.mul_add_distr_r.
repeat rewrite <- Nat.mul_assoc.
rewrite <- Heq5.
rewrite Nat.mul_add_distr_r.
rewrite (Nat.mul_comm (S d')).
rewrite Nat.mul_add_distr_r.
rewrite (Nat.mul_comm (S p * S q4)).
rewrite (Nat.mul_comm (S p4 * S q)).
rewrite (Nat.mul_comm (S p4)).
repeat rewrite <- Nat.mul_assoc.
rewrite <- Heq5.
rewrite <- Heq4.
rewrite (Nat.mul_assoc (S p'')).
rewrite <- (Nat.mul_comm (S q3)).
rewrite <- Nat.mul_assoc.
apply mult_reg_l with d.
repeat rewrite (Nat.mul_comm (S d)); repeat rewrite Nat.mul_add_distr_r;
 repeat rewrite <- (Nat.mul_comm (S d)); repeat rewrite (Nat.mul_assoc (S d));
 repeat rewrite (Nat.mul_comm (S d)); rewrite <- Heq1;
 rewrite <- Heq2.
ring.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
Qed.

Definition Qpositive_mult (w w' : Qpositive) :=
  match Qpositive_i w with
  | (p, q) =>
      match Qpositive_i w' with
      | (p', q') => Qpositive_c (p * p') (q * q') (p * p' + q * q')
      end
  end.

Theorem Qpositive_mult_One : forall w : Qpositive, Qpositive_mult One w = w.
intros w; elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq.
unfold Qpositive_mult in |- *.
replace (Qpositive_i One) with (1, 1).
rewrite Heq.
repeat rewrite Nat.mul_1_l.
apply construct_correct; auto with *.
simpl in |- *; auto.
Qed.

Theorem Qpositive_mult_sym :
 forall w w' : Qpositive, Qpositive_mult w w' = Qpositive_mult w' w.
intros w w'.
elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq; clear Hex.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq'; clear Hex.
unfold Qpositive_mult in |- *; rewrite Heq; rewrite Heq';
 repeat rewrite <- (Nat.mul_comm (S p)); repeat rewrite <- (Nat.mul_comm (S q));
 auto.
Qed.

Theorem Qpositive_mult_assoc :
 forall w w' w'' : Qpositive,
 Qpositive_mult (Qpositive_mult w w') w'' =
 Qpositive_mult w (Qpositive_mult w' w'').
intros w w' w''.
elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq; clear Hex.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq'; clear Hex.
elim (interp_non_zero w''); intros p'' Hex; elim Hex; intros q'' Heq'';
 clear Hex.
unfold Qpositive_mult in |- *.
rewrite Heq; rewrite Heq'; rewrite Heq''.
elim
 (construct_correct2' (S p * S p' + S q * S q') (S p * S p') (S q * S q')).
intros d;
 elim
  (interp_non_zero
     (Qpositive_c (S p * S p') (S q * S q') (S p * S p' + S q * S q')));
 intros p3 Hex; elim Hex; intros q3 Heq3; rewrite Heq3;
 clear Hex.
intros (Heq1, Heq2).
elim
 (construct_correct2' (S p' * S p'' + S q' * S q'')
    (S p' * S p'') (S q' * S q'')).
intros d';
 elim
  (interp_non_zero
     (Qpositive_c (S p' * S p'') (S q' * S q'') (S p' * S p'' + S q' * S q'')));
 intros p4 Hex; elim Hex; intros q4 Heq6; rewrite Heq6;
 clear Hex.
intros (Heq4, Heq5).
apply construct_correct4'.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
auto.
unfold fst, snd in Heq1, Heq2, Heq4, Heq5.
apply mult_reg_l with d'.
rewrite (Nat.mul_comm (S p * S p4)).
repeat rewrite (Nat.mul_comm (S d')); repeat rewrite <- Nat.mul_assoc;
 rewrite <- Heq4; rewrite <- Heq5.
clear Heq4 Heq5 Heq6.
apply mult_reg_l with d; repeat rewrite (Nat.mul_assoc (S d));
 repeat rewrite (Nat.mul_comm (S d)); rewrite <- Heq1;
 rewrite <- Heq2; ring.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
Qed.

Theorem Qpositive_mult_distr :
 forall w w' w'' : Qpositive,
 Qpositive_mult (Qpositive_plus w w') w'' =
 Qpositive_plus (Qpositive_mult w w'') (Qpositive_mult w' w'').
intros w w' w''.
elim (interp_non_zero w); intros p Hex; elim Hex; intros q Heq; clear Hex.
elim (interp_non_zero w'); intros p' Hex; elim Hex; intros q' Heq'; clear Hex.
elim (interp_non_zero w''); intros p'' Hex; elim Hex; intros q'' Heq'';
 clear Hex.
unfold Qpositive_mult, Qpositive_plus in |- *.
rewrite Heq; rewrite Heq'; rewrite Heq''.
elim
 (construct_correct2' (S p * S q' + S p' * S q + S q * S q')
    (S p * S q' + S p' * S q) (S q * S q')).
intros d;
 elim
  (interp_non_zero
     (Qpositive_c (S p * S q' + S p' * S q) (S q * S q')
        (S p * S q' + S p' * S q + S q * S q'))); intros p3 Hex;
 elim Hex; intros q3 Heq3; rewrite Heq3; intros (Heq1, Heq2);
 clear Hex.
elim
 (construct_correct2' (S p * S p'' + S q * S q'') (S p * S p'') (S q * S q'')).
intros d';
 elim
  (interp_non_zero
     (Qpositive_c (S p * S p'') (S q * S q'') (S p * S p'' + S q * S q'')));
 intros p4 Hex; elim Hex; intros q4 Heq6; rewrite Heq6;
 intros (Heq4, Heq5); clear Hex.
elim
 (construct_correct2' (S p' * S p'' + S q' * S q'')
    (S p' * S p'') (S q' * S q'')).
intros d'';
 elim
  (interp_non_zero
     (Qpositive_c (S p' * S p'') (S q' * S q'') (S p' * S p'' + S q' * S q'')));
 intros p5 Hex; elim Hex; intros q5 Heq9; rewrite Heq9;
 intros (Heq7, Heq8); clear Hex.
apply construct_correct4'.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
auto.
unfold fst, snd in Heq1, Heq2, Heq4, Heq5, Heq7, Heq8.
apply mult_reg_l with d''.
rewrite (Nat.mul_comm (S p5)).
rewrite Nat.mul_add_distr_r.
repeat
 (rewrite <- Nat.mul_assoc; try rewrite (Nat.mul_comm (S p5));
   try rewrite (Nat.mul_comm (S q5))).
repeat rewrite (Nat.mul_comm (S d'')); rewrite Nat.mul_add_distr_r;
 repeat rewrite <- Nat.mul_assoc; rewrite <- Heq7; rewrite <- Heq8.
repeat
 (repeat rewrite (Nat.mul_comm (S p4)); repeat rewrite (Nat.mul_comm (S q4));
   rewrite <- Nat.mul_assoc).
apply mult_reg_l with d'; repeat rewrite (Nat.mul_comm (S d'));
 rewrite Nat.mul_add_distr_r; repeat rewrite <- Nat.mul_assoc.
rewrite <- Heq4; rewrite <- Heq5.
apply mult_reg_l with d; repeat rewrite (Nat.mul_comm (S d));
 rewrite Nat.mul_add_distr_r; repeat rewrite (Nat.mul_comm (S q3));
 rewrite (Nat.mul_comm (S p3)); repeat rewrite <- Nat.mul_assoc.
rewrite <- Heq1; rewrite <- Heq2.
ring.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
Qed.

Theorem Qpositive_mult_inv :
 forall w : Qpositive, Qpositive_mult w (Qpositive_inv w) = One.
intros w; elim w; clear w.

intros w' Hrec; simpl in |- *.
elim (interp_non_zero w'); intros p Hex; elim Hex; intros q Heq; clear Hex.
unfold Qpositive_mult in |- *.
simpl in |- *.
rewrite (inv_correct _ _ _ Heq).
rewrite Heq.
simpl in |- *.
replace (q + (p + S q) * S q - (q + S p + q * S (q + S p))) with 0;
 [ replace (q + S p + q * S (q + S p) - (q + (p + S q) * S q)) with 0;
    [ auto | idtac ]
 | idtac ];
 (repeat (rewrite <- plus_n_Sm; repeat rewrite <- mult_n_Sm); simpl in |- *;
   match goal with
   |  |- (0 = ?X1 - ?X2 :>nat) =>
       replace X1 with X2; [ auto with arith | ring ]
   end).
intros w' Hrec; simpl in |- *.
elim (interp_non_zero w'); intros p Hex; elim Hex; intros q Heq; clear Hex.
unfold Qpositive_mult in |- *.
simpl in |- *.
rewrite (inv_correct _ _ _ Heq).
rewrite Heq.
simpl in |- *.
replace (q + S p + p * S (q + S p) - (p + (p + S q) * S p)) with 0;
 [ replace (p + (p + S q) * S p - (q + S p + p * S (q + S p))) with 0;
    [ auto | idtac ]
 | idtac ];
 (repeat (rewrite <- plus_n_Sm; repeat rewrite <- mult_n_Sm); simpl in |- *;
   match goal with
   |  |- (0 = ?X1 - ?X2 :>nat) =>
       replace X1 with X2; [ auto with arith | ring ]
   end).

simpl in |- *; auto.
Qed.

Theorem Qpositive_plus_diff :
 forall w w' : Qpositive, w <> Qpositive_plus w w'.
intros w w'; unfold Qpositive_plus in |- *; elim (interp_non_zero w);
 intros p (q, Heq); elim (interp_non_zero w'); intros p' (q', Heq');
 rewrite Heq; rewrite Heq'.
rewrite <- (construct_correct w _ _ (S p + S q) Heq).
red in |- *; intros Heq2;
 cut (S p * (S q * S q') = (S p * S q' + S p' * S q) * S q).
rewrite Nat.mul_add_distr_r.
rewrite <- Nat.mul_assoc.
rewrite (Nat.mul_comm (S q')).
pattern (S p * (S q * S q')) at 1 in |- *.
rewrite plus_n_O.
intros H; apply Nat.add_cancel_l in H;
 simpl in |- *; discriminate H.
apply
 Qpositive_c_equiv' with (S p + S q) (S p * S q' + S p' * S q + S q * S q').
auto with arith.
auto with arith.
simpl in |- *; auto with arith.
simpl in |- *; auto with arith.
auto.
auto.
auto.
auto.
Qed.


From Coq Require Export ssreflect.
From stdpp Require Export prelude gmap numbers.
From iris.heap_lang Require Export locations.
Set Default Proof Using "Type".

(* A location + offset type, used to look up in the store type where each
   location is associated to a list of values *)

(* Code adapted from Cosmo https://gitlab.inria.fr/cambium/cosmo
   (theories/lang/model.v) *)

Notation offset := Z (only parsing).
Record locoff : Type := Locoff {
  locoff_loc : loc;
  locoff_off : offset;
}.

(* TODO remove *)
Declare Scope loc_scope.
Delimit Scope loc_scope with L.

Definition locoff_to_pair '(Locoff ℓ i) := (ℓ, i).
Definition pair_to_locoff '(ℓ, i) := Locoff ℓ i.
Global Instance pair_to_locoff_inj : Inj eq eq pair_to_locoff.
Proof. by intros [] [] [= -> ->]. Qed.
Global Instance locoff_to_pair_inj : Inj eq eq locoff_to_pair.
Proof. by intros [] [] [= -> ->]. Qed.
Global Instance locoff_eq_dec : EqDecision locoff.
Proof. eapply (inj_eq_dec locoff_to_pair). Defined.
Global Instance locoff_countable : Countable locoff.
Proof. apply (inj_countable' locoff_to_pair pair_to_locoff). by intros []. Qed.
Definition loc_to_locoff ℓ := Locoff ℓ 0.

Coercion loc_to_locoff : loc >-> locoff.
Notation "ℓ .[ i ]" := (Locoff ℓ i) (at level 2, i at level 200, left associativity, format "ℓ .[ i ]").

Bind Scope loc_scope with locoff.

Section store.
Context {val : Type}.

Local Notation store := (gmap loc (option (list val))).

Global Instance store_lookup : Lookup locoff val store :=
  λ '(Locoff ℓ i) σ,
    if bool_decide (0 ≤ i)%Z then
      σ !! ℓ ≫= λ oblk, oblk ≫= λ (blk : list _), blk !! Z.to_nat i
    else None.

Global Instance store_insert : Insert locoff val store :=
  λ '(Locoff ℓ i) s σ,
    if bool_decide (0 ≤ i)%Z then
      match σ !! ℓ with
      | None            => σ
      | Some None       => σ
      | Some (Some blk) => <[ℓ := Some (<[Z.to_nat i := s]> blk)]> σ
      end
    else σ.

Lemma store_lookup_eq (σ : store) (ℓ : loc) (i : offset) :
  σ !! (ℓ.[i])%L =
    if bool_decide (0 ≤ i)%Z then
      σ !! ℓ ≫= λ oblk, oblk ≫= λ (blk : list _), blk !! Z.to_nat i
    else None.
Proof. reflexivity. Qed.

Lemma store_lookup_insert (σ : store) (ℓi : locoff) (v0 v : val) :
  σ !! ℓi = Some v0 →
  <[ℓi := v]> σ !! ℓi = Some v.
Proof.
  destruct ℓi as [ℓ i]. rewrite /lookup /insert /=.
  case_bool_decide ; last done.
  do 2 (case_match ; last done). cbn=>?.
  rewrite lookup_insert /= list_lookup_insert//. by eapply lookup_lt_Some.
Qed.

Lemma store_lookup_insert_ne (σ : store) (ℓi ℓi' : locoff) (v : val) :
  ℓi ≠ ℓi' →
  <[ℓi := v]> σ !! ℓi' = σ !! ℓi'.
Proof.
  destruct ℓi as [ℓ i], ℓi' as [ℓ' i']. rewrite /lookup /insert /=.
  intros ?. case_bool_decide ; last done.
  case_bool_decide ; last done.
  destruct (σ !! ℓ) as [[blk|]|] eqn:Hσℓ ; last done. 2:done.
  destruct (decide (ℓ = ℓ')) as [<-|].
  - destruct (decide (i = i')) as [<-|] ; first done.
    assert (Z.to_nat i ≠ Z.to_nat i') by lia.
    by rewrite Hσℓ lookup_insert /= list_lookup_insert_ne.
  - by rewrite lookup_insert_ne.
Qed.

Lemma store_insert_offset (σ : store) (ℓ : loc) (i : offset) (vs : list val) (w : val):
  σ !! ℓ = Some (Some vs) →
  (0 ≤ i < length vs)%Z →
  <[(ℓ.[i])%L := w]> σ = <[ℓ := Some (<[Z.to_nat i := w]> vs)]> σ.
Proof.
  intros Hvs Hi. rewrite /insert /store_insert -/(insert _ _ _).
  case_bool_decide; [|lia]. by simplify_map_eq.
Qed.

End store.