(* 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 uniq_tac machine_int multi_int.
Import MachineInt.
Require Import mapstos mips_seplog mips_contrib mips_tactics mont_mul_prg.
Import expr_m.
Import assert_m.

Local Open Scope machine_int_scope.
Local Open Scope eqmod_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope heap_scope.
Local Open Scope mips_expr_scope.
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.

(** printing `* %\ensuremath{\odot}% *)

(** Formal separation-logic triple that specifies the Montgomery
multiplication.  In the post-condition, observe that the %\ensuremath{k+1}th%#k+1
th# word of storage is provided by the register %\coqdocvar{C}%#C#. The
existence in memory of input-words and outputs-words is specified by
a separation logic formula. *)

Lemma mont_mul_triple (k alpha x y z m one ext int_ X_ Y_ M_ Z_ quot C t s_ : reg) :
  uniq(k, alpha, x, y, z, m, one, ext, int_, X_, Y_, M_, Z_, quot, C, t, s_, r0) ->
 forall nk valpha vx vy vm vz X Y M,
  u2Z (M `32_ 0) * u2Z valpha =m -1 {{ \B^1 }} ->
  size X = nk -> size Y = nk -> size M = nk ->
  u2Z vz + 4 * Z_of_nat nk < \B^1 ->
  \S_{ nk } X < \S_{ nk } M -> \S_{ nk } Y < \S_{ nk } M ->
{{ fun s h => [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> nseq nk zero32 ** var_e m |--> M) s h /\
  store.multi_null s }}
montgomery k alpha x y z m one ext int_ X_ Y_ M_ Z_ quot C t s_
{{ fun s h => exists Z, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  \B^nk * \S_{ nk.+1 } (Z ++ [C]_s :: nil) =m
    \S_{ nk } X * \S_{ nk } Y {{ \S_{ nk } M }} /\
  \S_{ nk.+1 } (Z ++ [C]_s :: nil) < 2 * \S_{ nk } M /\
  u2Z [t]_s = u2Z vz + 4 * Z_of_nat nk.-1 }}.
Proof.
move=> Hset nk valpha vx vy vm vz X Y M Halpha Hx Hy Hm Hnz HX HY.
rewrite /montgomery.

(** addiu one r0 one16; *)

NextAddiu.
move=> s h [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem Hmu]]]]]]].
rewrite /wp_addiu.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.multi_null_upd.

(** addiu C r0 zero16; *)

NextAddiu.
move=> s h [[r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem Hmu]]]]]]] r_one].
rewrite /wp_addiu.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.multi_null_upd.

(** addiu ext r0 zero16; *)

NextAddiu.
move=> s h [[[r_x [r_y [r_z [r_m [r_k [rd_galpha [Hmem Hmu]]]]]]] r_one] r_C].
rewrite /wp_addiu.
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite store.multi_null_upd.

(** while (bne ext k) *)

apply hoare_prop_m.hoare_while_invariant with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s <= u2Z [k]_s /\
  [one]_s = one32 /\ (next <> O -> u2Z [t]_s = u2Z vz + 4 * Z_of_nat nk.-1) /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) =
               \S_{next} X * \S_{nk} Y + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} Y + K * \S_{nk} M < 2 * \S_{nk} M * \B^next)).

move=> s h [[[[r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem Hmu]]]]]]] r_one] r_C] r_ext].

exists (nseq nk zero32), O; repeat (split; trivial).
exact: size_nseq.
by rewrite r_ext sext_Z2u // addi0 store.get_r0 Z2uK.
rewrite r_ext sext_Z2u // addi0 store.get_r0 Z2uK //; exact/min_u2Z.
apply u2Z_inj; by rewrite r_one sext_Z2u // store.get_r0 add0i Z2uK.
by case.
exists 0.
have -> : nseq nk zero32 ++ [C ]_ s :: nil = nseq nk.+1 zero32.
  suff -> : [ C ]_s = zero32 by rewrite -nseqS.
  apply u2Z_inj; by rewrite r_C sext_Z2u // addi0 store.get_r0.
rewrite lSum_nseq_0.
split; first by [].
(* about X * Y < M *)
rewrite mulZ1 !mul0Z add0Z.
apply mulZ_gt0 => //.
apply (@leZ_ltZ_trans (\S_{ nk } X)); by [exact: min_lSum | ].

move=> s h [[Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [Hext [Hextk' [Hone [Ht Hinv]]]]]]]]]]]]]] Hextk].
rewrite /= Hext r_k in Hextk; move/negPn/eqP/Z_of_nat_inj in Hextk; subst next.

exists Z; do 8 (split; trivial).
case: Hinv => K [Hinv1 Hinv2].
split; first by exists K.
split.
(* about X * Y < M *)
- apply (ltZ_pmul2r \B^nk) => //.
  exact/Zbeta_gt0.
  rewrite mulZC Hinv1; exact Hinv2.
- apply Ht; by destruct nk.

(** lwxs X ext x; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next).

move=> s h [[Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Ht Hinv]]]]]]]]]]]]]] Hextk].
rewrite /= in Hextk; move/eqP in Hextk.
have {}Hextk : (next < nk)%nat.
  by apply/ltP/Nat2Z.inj_lt; rewrite -r_ext -r_k ltZ_neqAle.
exists (X `32_ next); split.
- Decompose_32 X next X1 X2 HlenX1 HX'; last by rewrite Hx.
  rewrite HX' (decompose_equiv _ _ _ _ _ HlenX1) !assert_m.conAE assert_m.conCE !assert_m.conAE in Hmem.
  move: Hmem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_ext inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists Z, next; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  rewrite r_ext r_k; exact/inj_lt/ltP.

(** lw Y zero16 y; *)

apply hoare_lw_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [mem [r_ext [Hextk' [Hone [Hinv [Hextk r_X_]]]]]]]]]]]]]]].

destruct Y as [| hdy tly]; first by destruct nk.
exists hdy; split.
rewrite /= !assert_m.conAE assert_m.conCE assert_m.conAE in mem.
move: mem; apply monotony => ht //.
apply mapsto_ext => //; by rewrite /= sext_0 addi0.
rewrite /update_store_lw.
exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** lw Z_ zero16 z; *)

apply hoare_lw_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = Y `32_ 0 /\ [Z_]_s = Z `32_ 0).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [mem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ r_Y_]]]]]]]]]]]]]]]].

destruct Z as [| hdz tlz]; first by destruct nk.
exists hdz; split.
rewrite /= in mem.
do 2 rewrite !assert_m.conAE assert_m.conCE in mem; rewrite !assert_m.conAE in mem.
move: mem; apply monotony => ht //.
apply mapsto_ext => //; by rewrite /= sext_0 addi0.
rewrite /update_store_lw.
exists (hdz :: tlz), next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** multu X Y; *)

apply hoare_multu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\ store.utoZ s = u2Z (X `32_ next) * u2Z (Y `32_ 0)).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ r_Z_]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

by rewrite store.utoZ_multu; apply max_u2Z_umul.
by rewrite store.utoZ_multu (@u2Z_umul 32) r_X_ r_Y_.

(** lw M zero16 m; *)

apply hoare_lw_back_alt'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (Y `32_ 0) /\ [M_]_s = M `32_ 0).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [mem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 Hm2]]]]]]]]]]]]]]]]]]].

destruct M as [| hdm tlm]; first by destruct nk.
exists hdm; split.
rewrite /= in mem.
do 3 rewrite assert_m.conCE !assert_m.conAE in mem.
move: mem; apply monotony => h' //.
apply mapsto_ext => //=; by rewrite sext_0 addi0.
exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

(** maddu Z_ one; *)

apply hoare_maddu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  store.utoZ s <= \B^1 * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\ [M_]_s = M `32_ 0).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 r_M_]]]]]]]]]]]]]]]]]]]].
exists Z, next.
have ? : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1).
  exact: (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1))).
repeat Reg_upd.
do 8 (split; trivial).
by Assert_upd.
do 8 (split; trivial).
split.
- rewrite store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) r_Z_.
  apply (@leZ_trans ((\B^1 - 1) + (\B^1 - 1) * (\B^1 - 1))); last by [].
  apply leZ_add; first exact/leZsub1/max_u2Z.
  rewrite Hm2 -u2Z_umul; exact: max_u2Z_umul.
- by rewrite store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) r_Z_ Hm2 addZC.

(** mflo t; *)

apply hoare_mflo with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  store.utoZ s <= \B^1 * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 r_M_]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
apply store.lo_remainder; first by rewrite -addnA leq_addl.
rewrite Hm2 u2Z_add // u2Z_umul u2Z_zext // ZpowerD -Zbeta1E -ZbetaD /=.
apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
apply leZ_add; last exact/leZsub1/max_u2Z.
rewrite -u2Z_umul; exact/max_u2Z_umul.

(** mfhi s; *)

apply hoare_mfhi with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= \B^1 * (\B^1 - 1) /\
  store.utoZ s = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0)).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 [r_M_ r_t]]]]]]]]]]]]]]]]]]]]].
exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
have H : store.lo s = [t]_s.
  rewrite r_t; apply store.lo_remainder.
  + by rewrite -addnA leq_addl.
  + rewrite Hm2 -u2Z_umul u2Z_add.
    * by rewrite u2Z_zext.
    * rewrite u2Z_zext ZpowerD -Zbeta1E -ZbetaD /=.
      apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
      apply leZ_add; [exact: max_u2Z_umul | exact/leZsub1/max_u2Z].
rewrite store.utoZ_def store.utoZ_acx_beta2 in Hm2; last exact: (@leZ_ltZ_trans (\B^1 * (\B^1 - 1))).
rewrite Z2uK in Hm2; last by split; [apply leZZ | exact: expZ_gt0].
rewrite -H u2Z_concat -Zbeta1E -Hm2; ring.

(** multu t alpha; *)

apply hoare_multu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s = u2Z [t]_s * u2Z [alpha]_s).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [Hm2 [r_M_ [r_t Hconcat]]]]]]]]]]]]]]]]]]]]]].
exists Z, next; repeat Reg_upd.
do 7 (split; trivial).
split.
by Assert_upd.
do 8 (split; trivial).
split.
rewrite store.utoZ_multu; exact/max_u2Z_umul.
do 3 (split; trivial).
by rewrite store.utoZ_multu -u2Z_umul.

(** addiu int_ r0 one16; *)

apply hoare_addiu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s = u2Z [t]_s * u2Z [alpha]_s /\ [int_]_s = one32).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [ r_X_ [r_Y_ [r_Z_ [Hm1 [r_M_ [r_t [Hconcat Hm2]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite add0i sext_Z2u.

(** mflo quot; *)

apply hoare_mflo with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K,
    \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{next} X * \S_{nk} Y + K * \S_{nk} M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = Y `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  store.utoZ s <= (\B^1 - 1) * (\B^1 - 1) /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s = u2Z [t]_s * u2Z [alpha]_s /\ [int_]_s = one32 /\
  [quot]_s = (((X `32_ next `* Y `32_ 0) `+ (zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [ r_Z_ [Hm1 [r_M_ [r_t [Hconcat [Hm2 r_int_]]]]]]]]]]]]]]]]]]]]]]].
exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
apply store.lo_remainder.
- by rewrite -addnA leq_addl.
- by rewrite Hm2 r_t -u2Z_umul.

(** mthi s; *)

apply hoare_mthi with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s < \B^2 /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  store.hi s = [s_]_s).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [ r_Z_ [Hm1 [r_M_ [r_t [Hconcat [Hm2 [r_int_ r_quot]]]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_def store.hi_mthi_op store.acx_mthi_op store.lo_mthi_op store.utoZ_acx_beta2; last first.
  rewrite Hm2.
  apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1))); last by [].
  rewrite -u2Z_umul; exact/max_u2Z_umul.
rewrite Z2uK //= addZ0.
apply (@leZ_ltZ_trans ((\B^1 - 1) + (\B^1 - 1) * \B^1)); last by [].
apply leZ_add; first exact/leZsub1/max_u2Z.
apply leZ_wpmul2r => //.
exact/leZsub1/max_u2Z.
exact: store.hi_mthi_op.

(** mtlo t; *)

apply hoare_mtlo with  (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\
  [one]_s = one32 /\ (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\ [Y_]_s = Y `32_ 0 /\
  [Z_]_s = Z `32_ 0 /\ store.utoZ s < \B^2 /\ [M_]_s = M `32_ 0 /\
  [t]_s = ((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32 /\
  u2Z ([s_]_s `|| [t]_s) = u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  store.hi s = [s_]_s /\ store.lo s = [t]_s).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [r_M_ [r_t [Hconcat [r_int_ [r_quot Hm2]]]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_def store.acx_mtlo_op store.lo_mtlo_op store.hi_mtlo_op store.utoZ_acx_beta2 //
  Z2uK //= addZ0.
apply (@leZ_ltZ_trans ((\B^1 - 1) + (\B^1 - 1) * \B^1)); last by [].
apply leZ_add; first exact/leZsub1/max_u2Z.
apply/leZ_wpmul2r => //; exact/leZsub1/max_u2Z.
rewrite -Hm2.
exact/store.hi_mtlo_op.
exact/store.lo_mtlo_op.

(** maddu quot M; *)

apply hoare_maddu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ u2Z [ext]_s < u2Z [k]_s /\ [one]_s = one32 /\
  (exists K, \B^next * \S_{nk.+1} (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = Y `32_ 0 /\ [Z_]_s = Z `32_ 0 /\
  [M_]_s = M `32_ 0 /\ [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  store.utoZ s = u2Z [quot]_s * u2Z (M `32_ 0) +
  u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  store.lo s = zero32).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [Hm1 [r_M_ [r_t [Hconcat [r_int_ [r_quot [Hm2 Hm3]]]]]]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_maddu.
  rewrite r_M_ -u2Z_umul store.utoZ_def store.utoZ_acx_beta2 // Z2uK.
    by rewrite Hm2 Hm3 (addZC (u2Z [t]_s)) -u2Z_concat Hconcat mul0Z addZ0 addZA.
    by split; [apply leZZ | exact: expZ_gt0].
apply (@ltZ_leZ_trans (\B^2 * 1)); first by [].
apply leZ_wpmul2l => //.
rewrite r_quot; apply montgomery_lemma => //.
by rewrite r_M_ r_alpha.
rewrite store.utoZ_def store.utoZ_acx_beta2 // Z2uK.
- rewrite mul0Z addZ0 addZC -u2Z_concat Hm2 Hm3 Hconcat -u2Z_umul u2Z_add.
  by rewrite (u2Z_zext 32) // u2Z_zext.
  apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
  apply leZ_add.
  + exact: (@max_u2Z_umul 32).
  + rewrite (u2Z_zext 32) // leZsub1; exact: max_u2Z.
- split; by [apply leZZ | exact: expZ_gt0].

(** mflhxu Z_; *)

apply hoare_mflhxu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\ u2Z [ext]_s = Z_of_nat next /\
  (exists K, \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = Y `32_ 0 /\ [M_]_s = M `32_ 0 /\ [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  \B^1 * u2Z (store.hi s `|| store.lo s) =
  u2Z [quot]_s * u2Z (M `32_ 0) + u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s < 2 * \B^1 - 2).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [r_k [r_alpha [Hmem [r_ext [Hextk' [Hone [Hinv [Hextk [r_X_ [r_Y_ [r_Z_ [r_M_ [r_int_ [Hquot [Hm2 Hm3]]]]]]]]]]]]]]]]]]]]]] .
exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite u2Z_concat store.hi_mflhxu_op store.lo_mflhxu_op -Hm2 store.utoZ_def.
have -> : \B^2 = \B^1 * \B^1 by rewrite -ZbetaD.
rewrite u2Z_zext Hm3 Z2uK -Zbeta1E //.
repeat Reg_upd; ring.

apply store.mflhxu_kbeta1_utoZ.
apply (@leZ_ltZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1) * (\B^1 - 1) + (\B^1 - 1))); last by [].
Reg_upd.
rewrite Hm2; apply leZ_add; last exact/leZsub1/max_u2Z.
apply leZ_add; rewrite -u2Z_umul; exact: max_u2Z_umul.

(** addiu t z zero16; *)

apply hoare_addiu with  (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (exists K,
    \B^next * \S_{ nk.+1 } (Z ++ [C]_s :: nil) = \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  (next < nk)%nat /\ [X_]_s = X `32_ next /\
  [Y_]_s = Y `32_ 0 /\ [M_]_s = M `32_ 0 /\ [int_]_s = one32 /\
  [quot]_s = ((((X `32_ next `* Y `32_ 0) `+ zext 32 (Z `32_ 0)) `% 32) `* [alpha]_s) `% 32 /\
  \B^1 * u2Z (store.hi s `|| store.lo s) =
  u2Z [quot]_s * u2Z (M `32_ 0) + u2Z (X `32_ next) * u2Z (Y `32_ 0) + u2Z (Z `32_ 0) /\
  store.utoZ s < 2 * \B^1 - 2 /\ [t]_s = vz).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hinv [Hextk [r_X_ [r_Y_ [r_M_  [r_int_ [Hquot [Hm2 Hm3]]]]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
by rewrite sext_Z2u // addi0.

(** while (bne int_ k) *)

apply (hoare_prop_m.hoare_stren (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ [X_]_s = X `32_ next /\
  u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\ u2Z [int_]_s <= u2Z [k]_s /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{ next } X * \S_{ nk } Y + \S_{ nint_ } Y * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next))).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hinv [Hextk [r_X_ [r_Y_ [r_M_ [r_int_ [Hquot [Hm2 [Hm3 r_t]]]]]]]]]]]]]]]]]]]]].

exists Z, next, 1%nat; repeat (split; trivial).
by rewrite r_int_ /one32 Z2uK.
rewrite r_int_ r_k /one32 Z2uK // (_ : 1 = Z_of_nat 1) //;
  by apply/inj_le/leP; apply: leq_ltn_trans Hextk.
exact: (@ltZ_leZ_trans (2 * \B^1 - 2)).
rewrite r_t; ring.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by [].
rewrite Sum_hole_last'; last by rewrite size_cat /= HZ addnC.
have -> : u2Z (store.hi s `|| store.lo s) * \B^(next + 1) =
  \B^next * (\B^1 * u2Z (store.hi s `|| store.lo s)) by rewrite ZbetaD; ring.
rewrite subn1.
have -> : \B^next.+1 * \S_{ nk } (List.tail (Z ++ [C]_s :: nil)) =
  \B^next * (\B^1 * \S_{ nk } (List.tail (Z ++ [C]_s :: nil))) by rewrite Zbeta_S; ring.
rewrite lSum_Zpower_Zmult Hquot.
apply trans_eq with (\B^next *
  (\S_{ nk.+1 } (zero32 :: List.tail (Z ++ [C]_s :: nil))%list + u2Z (Z `32_ 0)) +
  \B^next * (u2Z [quot]_s * u2Z (M `32_ 0) + u2Z (X `32_ next) * u2Z (Y `32_ 0))).
- rewrite Hm2. set tmp := \S_{ _ } _. ring.
- rewrite lSum_head_swap0 tail_app; last by rewrite HZ; apply: leq_ltn_trans Hextk.
  rewrite List.app_comm_cons.
  move: (@list_tail _ zero32 Z) => ->; last by rewrite HZ; destruct nk => //; apply lt_O_Sn.
  rewrite Hquot Hinv1 2!lSum_1 /zero32 /nth' -/(Y `32_ 0) -/(M `32_ 0); ring.

apply while.hoare_seq with (fun s h => (exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ [X_]_s = X `32_ next /\
  u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\ u2Z [int_]_s <= u2Z [k]_s /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{next} X * \S_{ nk } Y + \S_{ nint_ } Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_} M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{next} X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next))
/\ ~~ (eval_b (bne int_ k) s)).

apply while.hoare_while.

(**  lwxs Y int_ y; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{ next } X * \S_{ nk } Y + \S_{ nint_ } Y * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  [Y_]_s = Y `32_ nint_).

move=> s h [ [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [mem [r_ext [Hextk' [r_X_ [r_int_ [Hint_ [r_int_' [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]]] Hint_k].
rewrite /= in Hint_k; move/eqP in Hint_k.
have {}Hint_k : (nint_ < nk)%nat.
  rewrite ltn_neqAle.
  apply/andP; split; [apply/eqP | ].
    rewrite r_int_ r_k in Hint_k; exact: Z_of_nat_inj_neq.
  apply/leP/Nat2Z.inj_le; by rewrite -r_int_ -r_k.

exists (Y `32_ nint_); split.
- Decompose_32 Y nint_ Y1 Y2 HlenY1 HY'; last by rewrite Hy.
  rewrite HY' (decompose_equiv _ _ _ _ _ HlenY1) in mem.
  do 2 rewrite !assert_m.conAE assert_m.conCE in mem.
  rewrite !assert_m.conAE in mem.
  move: mem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_int_ inj_mult mulZC.
- rewrite /update_store_lwxs.
  exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.

(**  lwxs Z int_ z; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z [z]_s + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) =
    \S_{next} X * \S_{ nk } Y + \S_{ nint_ } Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_} M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{next} X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next) /\
  [Y_]_s = Y `32_ nint_ /\ [Z_]_s = Z `32_ nint_).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [mem [r_ext [Hextk' [Hint_' [r_X_ [ r_int_' [Hint_ [Hm2 [r_t [Hinv r_Y_]]]]]]]]]]]]]]]]]]]]].

exists (Z `32_ nint_); split.
- Decompose_32 Z nint_ Z1 Z2 HlenZ1 HZ'; last by rewrite HZ.
  rewrite HZ' (decompose_equiv _ _ _ _ _ HlenZ1) in mem.
  do 3 rewrite !assert_m.conAE assert_m.conCE in mem; rewrite !assert_m.conAE in mem.
  move: mem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_int_' inj_mult mulZC.
- exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.
  by rewrite r_t r_z.

(** maddu X Y; *)

apply hoare_maddu with  (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < \B^2 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = Y `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\ (exists K,
    \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } Y +
    \S_{ nint_ } Y * u2Z (X `32_ next) * \B^next +
    \S_{ nint_ } M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (Y `32_ nint_) * \B^(next + nint_) + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [Hinv [r_Y_ r_Z_]]]]]]]]]]]]]]]]]]]]]].
exists Z, next, nint_.
have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1).
  apply (@ltZ_leZ_trans (2 * \B^1 - 1)); first by [].
  apply (@leZ_trans (\B^2 * (2 ^^ 8 - 1))); first by [].
  apply leZ_pmul2l; [exact: Zbeta_gt0 | exact/leZ_sub].
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_maddu //.
apply (@ltZ_leZ_trans ((\B^1 - 1) * (\B^1 - 1) + (2 * \B^1 - 1))); last by [].
apply leZ_lt_add => //.
exact/max_u2Z_umul.
by rewrite r_t r_z.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
apply trans_eq with (\S_{next} X * \S_{nk} Y +
 \S_{nint_} Y * u2Z (X `32_ next) * \B^next + \S_{nint_} M * u2Z [quot]_s * \B^next +
 K * \S_{nk} M + u2Z (X `32_ next) * u2Z (Y `32_ nint_) * \B^(next + nint_)).
- rewrite store.utoZ_maddu // store.utoZ_def store.utoZ_acx_beta2 //.
    rewrite Z2uK // -u2Z_umul -Hinv1 u2Z_concat addZ0 r_Y_ r_X_ // -addZA.
    f_equal.
    rewrite (addZC (u2Z (X `32_ next `* Y `32_ nint_))) mulZDl mulZDl.
    f_equal.
    by rewrite mulZDl addZC.
  exact: (@ltZ_leZ_trans (2 * \B^1 - 1)).
- ring.

(** lwxs M int_ m; *)

apply hoare_lwxs_back_alt'' with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_ s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s =  Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s =  Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < \B^2 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = Y `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\ (exists K,
    \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } Y +
    \S_{nint_} Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (Y `32_ nint_) * \B^(next + nint_) + K * \S_{ nk } M /\
    \S_{next} X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)
  /\ [M_]_s = M `32_ nint_ ).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [mem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ Hinv]]]]]]]]]]]]]]]]]]]]]] .

exists (M `32_ nint_); split.
- Decompose_32 M nint_ M1 M2 HlenM1 HM'; last by rewrite Hm.
  rewrite HM' (decompose_equiv _ _ _ _ _ HlenM1) in mem.
  do 4 rewrite assert_m.conCE !assert_m.conAE in mem.
  move: mem; apply monotony => // h'.
  apply mapsto_ext => //.
  by rewrite /= shl_Z2u r_int_' inj_mult mulZC.
- exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
  by Assert_upd.

(** maddu Z_ one; *)

apply hoare_maddu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < \B^2 + \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = Y `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\ [M_]_s = M `32_ nint_ /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } Y +
    \S_{nint_} Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (Y `32_ nint_) * \B^(next + nint_) +
    u2Z (Z `32_ nint_) * \B^(next + nint_) + K * \S_{ nk } M /\
    \S_{next} X * \S_{nk} Y + K * \S_{nk} M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ [Hinv r_M_]]]]]]]]]]]]]]]]]]]]]]].
exists Z, next, nint_.
have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1).
  apply (@ltZ_leZ_trans (\B^2 * 1)); first by [].
  rewrite mulZ1.
  apply (@leZ_trans (\B^2 * (2 ^^ 8 - 1))); first by [].
  apply leZ_wpmul2l; [exact: Zbeta_ge0 | exact/leZ_sub].
repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite store.utoZ_maddu //.
apply (@ltZ_leZ_trans ((\B^1 - 1) + \B^2)); last by [].
apply leZ_lt_add => //.
rewrite Hone umul_1 (u2Z_zext 32) //; exact/leZsub1/max_u2Z.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite store.utoZ_maddu // Hone umul_1 (u2Z_zext 32) //.
apply trans_eq with (\B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
  store.utoZ s * \B^(next + nint_) + u2Z (Z `32_ nint_) * \B^(next + nint_)).
by rewrite -r_Z_ {1}(addZC (u2Z [Z_]_s)) mulZDl addZA.
rewrite Hinv1; ring.

(** maddu quot M; *)

apply hoare_maddu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (1 <= nint_)%nat /\
  store.utoZ s < 2 * \B^2 - \B^1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  [Y_]_s = Y `32_ nint_ /\ [Z_]_s = Z `32_ nint_ /\ [M_]_s = M `32_ nint_ /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^(next + nint_) = \S_{ next } X * \S_{ nk } Y +
    \S_{nint_} Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (Y `32_ nint_) * \B^(next + nint_) +
    u2Z (Z `32_ nint_) * \B^(next + nint_) +
    u2Z (M `32_ nint_) * u2Z [quot]_s * \B^(next + nint_) + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} Y + K * \S_{nk} M < 2 * \S_{nk} M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ [r_M_ Hinv]]]]]]]]]]]]]]]]]]]]]]].
exists Z, next, nint_.

have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1).
  apply (@ltZ_leZ_trans (\B^2 + \B^1 - 1)); first by [].
  apply (@leZ_trans (\B^2 * (2 ^^ 8 - 1))); first by [].
  exact/leZ_wpmul2l.

repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
repeat (split; trivial).

rewrite store.utoZ_maddu //.
apply (@ltZ_leZ_trans ((\B^1 - 1) * (\B^1 - 1) + (\B^2 + \B^1 - 1))); last by [].
apply leZ_lt_add => //; exact: max_u2Z_umul.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite store.utoZ_maddu // mulZDl.
apply trans_eq with (\B^next.+1 * Sum_hole nk.+1 nint_.-1 (Z ++ [C]_s :: nil) + store.utoZ s * \B^(next + nint_) + (u2Z ([quot]_s `* [M_]_s) * \B^(next + nint_))).
by rewrite (addZC (u2Z ([quot]_s `* [M_]_s) * \B^(next + nint_))) addZA.
rewrite Hinv1 u2Z_umul r_M_; ring.

(** addiu int_ int_ one16; *)

apply hoare_addiu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ <= nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (2 <= nint_)%nat /\
  store.utoZ s < 2 * \B^2 - \B^1  /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 2) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) +
    store.utoZ s * \B^((next + nint_).-1) = \S_{ next } X * \S_{ nk } Y +
    \S_{nint_.-1} Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_.-1} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (Y `32_ nint_.-1)  * \B^((next + nint_).-1)+
    u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1) +
    u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1) + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} Y + K * \S_{nk} M < 2 * \S_{nk} M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t [r_Y_ [r_Z_ [r_M_ Hinv]]]]]]]]]]]]]]]]]]]]]]].

exists Z, next, nint_.+1; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite sext_Z2u // u2Z_add_Z2u //.
- by rewrite r_int_' Z_S.
- apply: leZ_ltZ_trans; last exact/Hnz.
  apply (@leZ_trans (Z_of_nat nk)).
  + rewrite r_int_' (_ : 1 = Z_of_nat 1) // -inj_plus plus_comm; apply/inj_le/leP; by rewrite plusE add1n.
  + apply leZ_addl; first exact/min_u2Z.
    rewrite mulZC. apply Zle_scale; by [apply Zle_0_nat | ].

rewrite Z_S [Zmult]lock /= -lock r_t; ring.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
by rewrite /= {1}addnS /= Hinv1 addnS.

(** mflhxu Z_; *)

apply hoare_mflhxu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ <= nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (2 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_-2) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 (nint_-2) (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) +
    u2Z [Z_]_s * \B^((next + nint_).-1) = \S_{ next } X * \S_{ nk } Y +
    \S_{nint_.-1} Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_.-1} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (Y `32_ nint_.-1)  * \B^((next + nint_).-1) +
    u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1) +
    u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1) + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} Y + K * \S_{nk} M < 2 * \S_{nk} M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]]].
exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

apply store.mflhxu_kbeta1_utoZ.
apply (@ltZ_leZ_trans (2 * \B^2 - \B^1)); by [Reg_upd | ].

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by [].  (* about X * Y < M *)

rewrite -Hinv1 u2Z_concat store.hi_mflhxu_op store.lo_mflhxu_op u2Z_zext store.utoZ_def -addZA.
f_equal.
by rewrite subn2.
rewrite -Zbeta1E /= 3!mulZDl -3!mulZA -3!ZbetaD.
rewrite 2!add1n add2n prednK; last  by rewrite addn_gt0 (ltn_trans _ Hint_) // orbT.
repeat Reg_upd; ring.

(** addiu t t four16; *)

apply hoare_addiu with (fun s h => exists Z next nint_, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** (var_e m |--> M)) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ (nint_ <= nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nint_ /\ (2 <= nint_)%nat /\
  store.utoZ s < 2 * \B^1 - 1 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nint_ - 1) /\
  (exists K, \B^next.+1 * Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) +
    u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) +
    u2Z [Z_]_s * \B^((next + nint_).-1) = \S_{ next } X * \S_{ nk } Y +
    \S_{nint_.-1} Y * u2Z (X `32_ next) * \B^next +
    \S_{nint_.-1} M * u2Z [quot]_s * \B^next +
    u2Z (X `32_ next) * u2Z (Y `32_ nint_.-1)  * \B^((next + nint_).-1) +
    u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1) +
    u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1) + K * \S_{nk} M /\
    \S_{next} X * \S_{nk} Y + K * \S_{nk} M < 2 * \S_{nk} M * \B^next)).

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]]].

exists Z, next, nint_; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
rewrite sext_Z2u // u2Z_add_Z2u //.
- rewrite r_t; ring.
- rewrite r_t -Zbeta1E.
  apply: (leZ_ltZ_trans _ Hnz).
  rewrite -addZA; apply leZ_add2l.
  rewrite -{2}(mulZ1 4) -mulZDr; apply/leZ_wpmul2l; first by [].
  rewrite -addZA; apply addr_leZ => //; exact/inj_le/leP.
  by rewrite subn2 in Hinv.

(** sw Z_ mfour16 t *)

apply hoare_sw_back'.

move=> s h [Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hint_' [r_X_ [r_int_' [ Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]]].

exists (int_e (Z `32_ nint_.-2)).

have Htmp: [z]_s `+ Z2u 32 (Z_of_nat (4 * nint_.-2)) = [t]_s `+ sext 16 mfour16.
  rewrite /mfour16 sext_Z2s // r_z; apply u2Z_inj.
  rewrite u2Z_add_Z2s //.
  rewrite u2Z_add_Z_of_nat.
  rewrite r_t inj_mult -subn2 inj_minus1 //; last exact/leP.
  ring.
  rewrite -subn2 inj_mult inj_minus1 //; last exact/leP.
  rewrite -Zbeta1E [Z_of_nat _]/=.
  apply: leZ_ltZ_trans; last exact/Hnz.
  apply/leZ_add2l/leZ_wpmul2l => //.
  rewrite -inj_minus1; last exact/leP.
  by apply/inj_le/leP; rewrite minusE leq_subLR (leq_trans Hint_') // leq_addl.
  rewrite r_t -addZA (_ : -4 = 4 * ( -1 )) // -mulZDr.
  apply leZ_addl; first exact/min_u2Z.
  rewrite pmulZ_rge0 // -addZA /= (_ : -2 = - Z_of_nat 2) //.
  exact/Zle_left/inj_le/leP.

Decompose_32 Z (nint_.-2) Z1 Z2 HlenZ1 HZ'; last first.
  by rewrite HZ (leq_trans _ Hint_') // -subn2 -subSn // subn2 leq_pred.
rewrite HZ' (decompose_equiv _ _ _ _ _ HlenZ1) in Hmem.
do 3 rewrite !assert_m.conAE assert_m.conCE in Hmem; rewrite !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // ht.
exact/mapsto_ext.

apply currying => h' H'; simpl app in H'.

exists (upd_nth Z nint_.-2 [Z_]_s), next, nint_; repeat (split; trivial).
exact/size_upd_nth.
rewrite HZ' upd_nth_cat HlenZ1 // subnn /= (decompose_equiv _ _ _ _ _ HlenZ1).
rewrite cat0s in H'.
assoc_comm H'.
move: H'.
exact/mapsto_ext.
by rewrite (ltn_trans _ Hint_).
rewrite r_int_' r_k; by apply/inj_le/leP.
case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)

(* technicalities:

   at this point, we have an hypothesis about K with
   ( z_0 ... z_{nint-2} ... z_{k-1} ++ C::nil )\{nint-2}

   whereas in the goal, we have
   ( z_0 ...     Z      ... z_{k-1} ++ C::nil )\{nint-1}

   we will:
   1. coax the hypothesis and the goal to have the same Sum_hole predicate
      1.a. add z_{nint-1} to the goal
      1.b. use the Sum_hole_shift property to change the Sum_hole predicate in the goal
   2. check that the goal can be obtained from the hypo by rewriting
 *)

(* 1. *)

(* 1.a. *)

apply (eqZ_add2l (\B^next.+1 * u2Z (Z `32_ nint_.-1) * \B^nint_.-2)).
rewrite addZA -mulZA -(mulZDr (\B^next.+1)).

(* 1.b. *)

rewrite (addZC (u2Z (Z `32_ nint_.-1) * \B^nint_.-2)).
have -> : Sum_hole nk.+1 nint_.-1 (upd_nth Z nint_.-2 [Z_]_s ++ [C]_s :: nil) +
    u2Z (Z `32_ nint_.-1) * \B^nint_.-2 =
    Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) + u2Z [Z_]_s * \B^nint_.-2.
  have H_ : size (upd_nth Z nint_.-2 [Z_]_s ++ [C]_s :: nil) = nk.+1.
    by rewrite size_cat (@size_upd_nth _ nk) // addn1.
  have H1__ : (nint_.-1 < nk)%nat by rewrite prednK // (ltn_trans _ Hint_).
  have H1_ : (nint_.-1 < nk.+1)%nat by apply ltnW.
  have H1___ : (nint_.-2 < nk)%nat by rewrite prednK // -ltnS // prednK // (ltn_trans _ Hint_).
  move/(Sum_hole_shift _ _ H_ _) : H1_ => {}H_.
  do 2 rewrite nth_cat (@size_upd_nth _ nk) // in H_.
  rewrite H1__ subn1 H1___ nth_upd_nth' in H_; last first.
    destruct nint_; first by [].
    destruct nint_; first by [].
    destruct nint_ as [|nint_]; first by [].
    apply/eqP; by rewrite neq_ltn /= ltnSn orbT.
  rewrite nth_upd_nth in H_; last by rewrite HZ.
  have -> : Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) =
            Sum_hole nk.+1 nint_.-2 (upd_nth Z nint_.-2 [Z_]_s ++ [C]_s :: nil).
  rewrite -upd_nth_cat'; last by rewrite HZ.
  rewrite -Sum_hole_upd_nth //.
  by rewrite size_cat addn1 /= HZ.
  by rewrite mulnC in H_.
(* 2. *)

have Htmp2 : (next.+1 + nint_.-2 = (next + nint_).-1)%nat.
  rewrite addSnnS prednK //; last by rewrite -ltnS // prednK // (ltn_trans _ Hint_).
  rewrite -[RHS]subn1 -addnBA //; last by rewrite (ltn_trans _ Hint_).
  by rewrite subn1.

apply trans_eq with (\B^next.+1 * Sum_hole nk.+1 nint_.-2 (Z ++ [C]_s :: nil) +
 u2Z (store.hi s `|| store.lo s) * \B^(next + nint_) +
  u2Z [Z_]_s * (\B^next.+1 * \B^nint_.-2)).
ring.

rewrite -ZbetaD Htmp2 {}Hinv1.

apply trans_eq with ((\S_{nint_.-1} Y * u2Z (X `32_ next) * \B^next +
 u2Z (X `32_ next) * u2Z (Y `32_ nint_.-1) * \B^((next + nint_).-1)) +
 (\S_{nint_.-1} M * u2Z [quot]_s * \B^next +
 u2Z (M `32_ nint_.-1) * u2Z [quot]_s * \B^((next + nint_).-1))
 + K * \S_{nk} M
 + \S_{next} X * \S_{nk} Y
 + u2Z (Z `32_ nint_.-1) * \B^((next + nint_).-1)).
ring.

apply trans_eq with (\S_{ nint_ } Y * u2Z (X `32_ next) * \B^next +
 \S_{ nint_ } M * u2Z [quot]_s * \B^next
 + K * \S_{ nk } M + \S_{ next } X * \S_{ nk } Y
 + (u2Z (Z `32_ nint_.-1) * (\B^next.+1 * \B^nint_.-2))); last ring.

f_equal; last by rewrite -ZbetaD Htmp2.

do 3 f_equal.
apply trans_eq with ((\S_{nint_.-1} Y + u2Z (Y `32_ nint_.-1) *
  \B^(nint_.-1)) * (u2Z (X `32_ next) * \B^next)).
- rewrite -(subn1 (next + nint_)) -addnBA; last exact: leq_trans Hint_.
  rewrite subn1 ZbetaD; ring.
- rewrite (mulZC _ (\B^nint_.-1)) {1}/Zbeta -lSum_remove_last.
- rewrite prednK //.
  by rewrite mulZA.
  exact: leq_trans Hint_.

apply trans_eq with ((\S_{nint_.-1} M + u2Z (M `32_ nint_.-1) *
  \B^nint_.-1) * (u2Z [quot]_s * \B^next)).
- rewrite -(subn1 (next + nint_)) -addnBA; last exact: leq_trans Hint_.
  rewrite subn1 ZbetaD; ring.
- rewrite (mulZC _ (\B^nint_.-1)) -lSum_remove_last prednK //.
  by rewrite mulZA.
  exact: leq_trans Hint_.

(** maddu C one; *)

apply hoare_maddu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\
  [X_]_s = X `32_ next /\ u2Z [int_]_s = Z_of_nat nk /\
  store.utoZ s < 3 * \B^1 - 2 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next.+1 * \S_{nk.-1} Z + store.utoZ s * \B^(next + nk) =
    \S_{next} X * \S_{ nk } Y + \S_{ nk } Y * u2Z (X `32_ next) * \B^next +
    \S_{nk} M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{next} X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [[Z [next [nint_ [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [ Hint_' [r_int_' [r_X_ [Hint_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]]]]] Hint_k].

rewrite /= r_int_' r_k in Hint_k. move/negPn/eqP/Z_of_nat_inj in Hint_k; subst nint_.

exists Z, next.

have Htmp : store.utoZ s < \B^2 * (2 ^^ store.acx_size - 1).
  apply (@ltZ_leZ_trans (2 * \B^1 - 1)); first by [].
  exact: (@leZ_trans (\B^2 * (2 ^^ 8 - 1))).

repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) //.
apply (@ltZ_leZ_trans ((\B^1 - 1) + (2 * \B^1 - 1))); last by [].
apply leZ_lt_add => //; exact/leZsub1/max_u2Z.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite -Hinv1 store.utoZ_maddu // Hone umul_1 (@u2Z_zext 32) mulZDl addZA /Sum_hole //.
rewrite subn1 store.utoZ_def store.utoZ_acx_beta2; last exact: (@ltZ_leZ_trans (2 * \B^1 - 1)).
rewrite Z2uK; last by split => //; apply Zpower_0.
rewrite mul0Z addZ0 u2Z_concat.
have [Z' [tl H ] ] : exists Z' tl, Z = Z' ++ tl :: nil.
  clear -HZ r_X_.
  case/lastP : Z HZ r_X_ => /=; first by move=> <-.
  move=> h t _ _; by exists h, t; rewrite -cats1.
rewrite {2}H -catA.
have H0 : size Z' = nk.-1.
  rewrite H size_cat /= addn1 in HZ; by rewrite -HZ.
rewrite (@idel_app _ _ Z' H0 _ tl ([C]_s :: nil)) //.
move: (lSum_remove_last _ (Z' ++ [C]_s :: nil) nk.-1) => H1.
rewrite -(@lSum_beyond _ nk.-1) in H1; last by [].
rewrite nth_cat H0 ltnn subnn [nth _ _ _]/= in H1.
rewrite prednK // in H1.
rewrite H1 (mulZDr (\B^next.+1)).
have <- : \S_{nk.-1} Z = \S_{nk.-1} Z' by rewrite H -lSum_beyond.
rewrite -ZbetaE mulZA -ZbetaD.
by rewrite addSnnS prednK // (mulZC (\B^(next + nk))) (addZC (u2Z (store.lo s))).

(** mflhxu Z_; *)

apply hoare_mflhxu with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (next < nk)%nat /\ [X_]_s = X `32_ next /\
  store.utoZ s < 3  /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next.+1 * \S_{nk.-1} Z + u2Z (store.lo s) * \B^(next + nk + 1) +
    u2Z [Z_]_s * \B^(next + nk) = \S_{ next } X * \S_{ nk } Y +
    \S_{ nk } Y * u2Z (X `32_ next) * \B^next +
    \S_{ nk } M * u2Z [quot]_s * \B^next + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [r_X_ [r_int_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.
apply store.mflhxu_kbeta1_utoZ.
apply (@ltZ_trans (3 * \B^1 - 2)); by [Reg_upd | ].
case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite -Hinv1 store.lo_mflhxu_op store.utoZ_def store.utoZ_acx_beta2; last exact: (@ltZ_leZ_trans (3 * \B^1 -2)).
rewrite Z2uK; last by split; [apply leZZ | exact: expZ_gt0].
rewrite mul0Z addZ0 mulZDl -mulZA -ZbetaD (addnC 1%nat).
Reg_upd; ring.

(** addiu ext ext one16; *)

apply hoare_addiu with (fun s h => exists Z, exists next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (1 <= next <= nk)%nat /\
  store.utoZ s < 3 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next * \S_{ nk.-1 } Z + u2Z (store.lo s) * \B^(next + nk) +
    u2Z [Z_]_s * \B^((next + nk).-1) = \S_{ next.-1 } X * \S_{ nk } Y +
    \S_{ nk } Y * u2Z (X `32_ next.-1) * \B^next.-1 +
    \S_{ nk } M * u2Z [quot]_s * \B^next.-1 + K * \S_{ nk } M /\
    \S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M + (\B^1 - 1) * (\B^next.-1 * \S_{ nk } M) < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [r_X_ [Hm2 [r_t Hinv]]]]]]]]]]]]]]]].

exists Z, next.+1; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite sext_Z2u // u2Z_add_Z2u // r_ext.
by rewrite Z_S.
apply (@leZ_ltZ_trans (Z_of_nat nk)).
rewrite (_ : 1 = Z_of_nat 1) // -inj_plus plusE addn1; exact/inj_le/leP.
rewrite -r_k; exact/max_u2Z.

case: Hinv => K [Hinv1 Hinv2].
exists K; split.
- by rewrite -Hinv1 addSn addnS addn0.
- (* about X * Y < M *)
  rewrite lSum_remove_last mulZDl.
  apply (@ltZ_leZ_trans (2 * \S_{ nk } M * \B^next + u2Z (X `32_ next) * \B^next * \S_{ nk } Y +
    (\B^1 - 1) * \B^(next.+1.-1) * \S_{ nk } M)).
  apply ltZ_le_add; last by rewrite -mulZA; apply leZZ.
  rewrite -ZbetaE (mulZC (\B^next)) /zero32 addZC addZA;
    by apply ltZ_le_add; [rewrite addZC | apply leZZ].
  apply (@leZ_trans (2 * \S_{ nk } M * \B^next + (\B^1 - 1) * \B^next * \S_{ nk } Y +
    (\B^1 - 1) * \B^(next.+1.-1) * \S_{ nk } M)).
  apply leZ_add2r, leZ_add2l.
  rewrite -2!mulZA.
  apply leZ_wpmul2r => //.
  apply mulZ_ge0 => //; exact: min_lSum.
  exact/leZsub1/max_u2Z.
  rewrite -addZA.
  apply (@leZ_trans (2 * \S_{ nk } M * \B^next +
    ((\B^1 - 1) * \B^next * \S_{ nk } M + (\B^1 - 1) * \B^next * \S_{ nk } M))).
  apply/leZ_add2l/leZ_add2r/leZ_wpmul2l; last exact/ltZW.
  apply mulZ_ge0; by [| exact: Zbeta_0'].
  suff: 2 * \S_{ nk } M * \B^next + ((\B^1 - 1) * \B^next * \S_{ nk } M + (\B^1 - 1) * \B^next * \S_{ nk } M)
    = 2 * \S_{ nk } M * \B^next.+1 by move=> ->; apply leZZ.
  rewrite (Zbeta_S next); ring.

(** sw Z_ zero16 t; *)

apply hoare_sw_back'' with (fun s h => exists Z next, size Z = nk /\
  [x]_s = vx /\ [y]_s = vy /\ [z]_s = vz /\ [m]_s = vm /\
  [one]_s = one32 /\ u2Z [k]_s = Z_of_nat nk /\ [alpha]_s = valpha /\
  (var_e x |--> X ** var_e y |--> Y ** var_e z |--> Z ** var_e m |--> M) s h /\
  u2Z [ext]_s = Z_of_nat next /\ (1 <= next <= nk)%nat /\
  store.utoZ s < 3 /\ u2Z [t]_s = u2Z vz + 4 * (Z_of_nat nk - 1) /\
  (exists K, \B^next * \S_{ nk } Z + u2Z (store.lo s) * \B^(next + nk) =
    \S_{next.-1} X * \S_{ nk } Y + \S_{ nk } Y * u2Z (X `32_ next.-1) * \B^next.-1 +
    \S_{nk} M * u2Z [quot]_s * \B^(next - 1) + K * \S_{ nk } M /\
    \S_{next} X * \S_{ nk } Y + K * \S_{ nk } M + (\B^1 - 1) * (\B^next.-1 * \S_{ nk } M) < 2 * \S_{ nk } M * \B^next)).

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [Hone [rk [r_alpha [Hmem [r_ext [Hextk' [Hm2 [r_t Hinv]]]]]]]]]]]]]]].

have [lst1 [last H0]] : exists Z' tl, Z = Z' ++ tl :: nil.
  clear -HZ Hextk'.
  case/lastP : Z HZ Hextk' => [<-|].
    rewrite leqn0; case/andP => H1 /eqP H2; by rewrite H2 in H1.
  move=> h t _ _; by exists h, t; rewrite cats1.
have Hlenlst1 : size lst1 = nk.-1 by rewrite -HZ H0 size_cat /= addn1.
have Htmp : [ var_e t \+ int_e (sext 16 zero16) ]e_ s = [ var_e z \+ int_e (Z2u 32 (Z_of_nat (4 * (nk - 1)))) ]e_ s.
  rewrite /= sext_0 addi0; apply u2Z_inj.
  rewrite u2Z_add_Z_of_nat.
  rewrite inj_mult inj_minus1; last by destruct nk => //; exact/le_n_S/le_O_n.
  rewrite r_t r_z; simpl Z_of_nat; ring.
  rewrite inj_mult inj_minus1; last by destruct nk => //; exact/le_n_S/le_O_n.
  rewrite r_z; simpl Z_of_nat.
  apply: leZ_ltZ_trans; last exact/Hnz.
  apply/leZ_add2l/leZ_pmul2l => //.
  rewrite (_ : 1 = Z_of_nat 1) // -inj_minus1 //; last first.
    by apply/leP; apply leq_trans with next; case/andP: Hextk'.
  apply/inj_le/leP; by rewrite minusE subn1 leq_pred.

exists (int_e last).

rewrite H0 (decompose_equiv _ _ _ _ _ Hlenlst1) in Hmem.
do 3 rewrite !assert_m.conAE assert_m.conCE in Hmem.
rewrite !assert_m.conAE in Hmem.
move: Hmem; apply monotony => // ht.
rewrite -subn1; exact/mapsto_ext.
apply currying => h' H'; simpl assert_m.mapstos in H'.

exists (upd_nth Z nk.-1 [Z_]_s), next.

repeat (split; trivial).
exact/size_upd_nth.
rewrite H0 upd_nth_cat Hlenlst1 // subnn /= (_ : lst1 ++ [Z_]_s :: nil = lst1 ++ ([Z_]_s :: nil) ++ nil) // (decompose_equiv _ _ _ _ _ Hlenlst1).
simpl assert_m.mapstos.
assoc_comm H'.
by move: H'; rewrite -subn1; apply mapsto_ext.

case: Hinv => K [Hinv1 Hinv2].
exists K; split; last by []. (* about X * Y < M *)
rewrite subn1 -Hinv1.
have -> : upd_nth Z nk.-1 [Z_]_s = lst1 ++ [Z_]_s :: nil.
  rewrite H0 upd_nth_cat /=.
  by rewrite Hlenlst1 subnn.
  by rewrite Hlenlst1.
rewrite (lSum_cut_last nk) //; last by rewrite size_cat /= -HZ H0 size_cat.
rewrite mulZDr mulZA -ZbetaD !subn1.
rewrite H0 -(lSum_beyond 32 nk.-1 lst1) //.
rewrite -(subn1 (next + nk)) -addnBA //.
rewrite subn1; ring.
rewrite (@leq_trans next) //.
by case/andP : Hextk'.
by case/andP : Hextk'.

(** mflhxu C *)

apply hoare_mflhxu'.

move=> s h [Z [next [HZ [r_x [r_y [r_z [r_m [Hone [r_k [r_alpha [Hmem [r_ext [Hextk' [Hm2 [r_t Hinv]]]]]]]]]]]]]]].

exists Z, next; repeat Reg_upd; repeat (split; trivial).
by Assert_upd.

rewrite r_ext r_k.

apply/inj_le/leP; by case/andP: Hextk'.

rewrite -subn1 inj_minus1 //; destruct nk => //; exact/le_n_S/le_O_n.

case: Hinv => K [Hinv1 Hinv2].
exists (K + u2Z [quot]_s * \B^next.-1); split.
- rewrite lSum_cut_last; last by rewrite size_cat /= HZ addnC.
  rewrite subn1 mulZDr mulZA -ZbetaD (mulZC (\B^(next + nk))) Hinv1.
  have <- : \S_{next.-1} X + u2Z (X `32_ next.-1) * \B^next.-1 = \S_{ next } X.
    rewrite -(mulZC (\B^next.-1)) /Zbeta -lSum_remove_last //.
    rewrite prednK //.
    by case/andP: Hextk'.
  rewrite subn1; ring.
(* about X * Y < M *)
- apply (@leZ_ltZ_trans (\S_{ next } X * \S_{ nk } Y + K * \S_{ nk } M + ((\B^1 - 1) * \B^next.-1 * \S_{ nk } M))); last by rewrite -mulZA.
  rewrite mulZDl addZA.
  apply/leZ_add2l/leZ_wpmul2r; first exact: min_lSum.
  apply/leZ_wpmul2r => //.
  exact/leZsub1/max_u2Z.
Qed.


Require Export paconotation pacotac pacodef pacotacuser.
Set Implicit Arguments.

(** ** Predicates of Arity 1
*)

(** 1 Mutual Coinduction *)

Section Arg1_1.

Definition monotone1 T0 (gf: rel1 T0 -> rel1 T0) :=
  forall x0 r r' (IN: gf r x0) (LE: r <1= r'), gf r' x0.

Variable T0 : Type.
Variable gf : rel1 T0 -> rel1 T0.
Implicit Arguments gf [].

Theorem paco1_acc: forall
  l r (OBG: forall rr (INC: r <1= rr) (CIH: l <_paco_1= rr), l <_paco_1= paco1 gf rr),
  l <1= paco1 gf r.
Proof.
  intros; assert (SIM: paco1 gf (r \1/ l) x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco1_mon: monotone1 (paco1 gf).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_mult_strong: forall r,
  paco1 gf (paco1 gf r \1/ r) <1= paco1 gf r.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Corollary paco1_mult: forall r,
  paco1 gf (paco1 gf r) <1= paco1 gf r.
Proof. intros; eapply paco1_mult_strong, paco1_mon; eauto. Qed.

Theorem paco1_fold: forall r,
  gf (paco1 gf r \1/ r) <1= paco1 gf r.
Proof. intros; econstructor; [ |eauto]; eauto. Qed.

Theorem paco1_unfold: forall (MON: monotone1 gf) r,
  paco1 gf r <1= gf (paco1 gf r \1/ r).
Proof. unfold monotone1; intros; destruct PR; eauto. Qed.

End Arg1_1.

Hint Unfold monotone1.
Hint Resolve paco1_fold.

Implicit Arguments paco1_acc            [ T0 ].
Implicit Arguments paco1_mon            [ T0 ].
Implicit Arguments paco1_mult_strong    [ T0 ].
Implicit Arguments paco1_mult           [ T0 ].
Implicit Arguments paco1_fold           [ T0 ].
Implicit Arguments paco1_unfold         [ T0 ].

Instance paco1_inst  T0 (gf : rel1 T0->_) r x0 : paco_class (paco1 gf r x0) :=
{ pacoacc    := paco1_acc gf;
  pacomult   := paco1_mult gf;
  pacofold   := paco1_fold gf;
  pacounfold := paco1_unfold gf }.

(** 2 Mutual Coinduction *)

Section Arg1_2.

Definition monotone1_2 T0 (gf: rel1 T0 -> rel1 T0 -> rel1 T0) :=
  forall x0 r_0 r_1 r'_0 r'_1 (IN: gf r_0 r_1 x0) (LE_0: r_0 <1= r'_0)(LE_1: r_1 <1= r'_1), gf r'_0 r'_1 x0.

Variable T0 : Type.
Variable gf_0 gf_1 : rel1 T0 -> rel1 T0 -> rel1 T0.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].

Theorem paco1_2_0_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_0 <1= rr) (CIH: l <_paco_1= rr), l <_paco_1= paco1_2_0 gf_0 gf_1 rr r_1),
  l <1= paco1_2_0 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco1_2_0 gf_0 gf_1 (r_0 \1/ l) r_1 x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco1_2_1_acc: forall
  l r_0 r_1 (OBG: forall rr (INC: r_1 <1= rr) (CIH: l <_paco_1= rr), l <_paco_1= paco1_2_1 gf_0 gf_1 r_0 rr),
  l <1= paco1_2_1 gf_0 gf_1 r_0 r_1.
Proof.
  intros; assert (SIM: paco1_2_1 gf_0 gf_1 r_0 (r_1 \1/ l) x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco1_2_0_mon: monotone1_2 (paco1_2_0 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_2_1_mon: monotone1_2 (paco1_2_1 gf_0 gf_1).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_2_0_mult_strong: forall r_0 r_1,
  paco1_2_0 gf_0 gf_1 (paco1_2_0 gf_0 gf_1 r_0 r_1 \1/ r_0) (paco1_2_1 gf_0 gf_1 r_0 r_1 \1/ r_1) <1= paco1_2_0 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_2_1_mult_strong: forall r_0 r_1,
  paco1_2_1 gf_0 gf_1 (paco1_2_0 gf_0 gf_1 r_0 r_1 \1/ r_0) (paco1_2_1 gf_0 gf_1 r_0 r_1 \1/ r_1) <1= paco1_2_1 gf_0 gf_1 r_0 r_1.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Corollary paco1_2_0_mult: forall r_0 r_1,
  paco1_2_0 gf_0 gf_1 (paco1_2_0 gf_0 gf_1 r_0 r_1) (paco1_2_1 gf_0 gf_1 r_0 r_1) <1= paco1_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco1_2_0_mult_strong, paco1_2_0_mon; eauto. Qed.

Corollary paco1_2_1_mult: forall r_0 r_1,
  paco1_2_1 gf_0 gf_1 (paco1_2_0 gf_0 gf_1 r_0 r_1) (paco1_2_1 gf_0 gf_1 r_0 r_1) <1= paco1_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; eapply paco1_2_1_mult_strong, paco1_2_1_mon; eauto. Qed.

Theorem paco1_2_0_fold: forall r_0 r_1,
  gf_0 (paco1_2_0 gf_0 gf_1 r_0 r_1 \1/ r_0) (paco1_2_1 gf_0 gf_1 r_0 r_1 \1/ r_1) <1= paco1_2_0 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco1_2_1_fold: forall r_0 r_1,
  gf_1 (paco1_2_0 gf_0 gf_1 r_0 r_1 \1/ r_0) (paco1_2_1 gf_0 gf_1 r_0 r_1 \1/ r_1) <1= paco1_2_1 gf_0 gf_1 r_0 r_1.
Proof. intros; econstructor; [ | |eauto]; eauto. Qed.

Theorem paco1_2_0_unfold: forall (MON: monotone1_2 gf_0) (MON: monotone1_2 gf_1) r_0 r_1,
  paco1_2_0 gf_0 gf_1 r_0 r_1 <1= gf_0 (paco1_2_0 gf_0 gf_1 r_0 r_1 \1/ r_0) (paco1_2_1 gf_0 gf_1 r_0 r_1 \1/ r_1).
Proof. unfold monotone1_2; intros; destruct PR; eauto. Qed.

Theorem paco1_2_1_unfold: forall (MON: monotone1_2 gf_0) (MON: monotone1_2 gf_1) r_0 r_1,
  paco1_2_1 gf_0 gf_1 r_0 r_1 <1= gf_1 (paco1_2_0 gf_0 gf_1 r_0 r_1 \1/ r_0) (paco1_2_1 gf_0 gf_1 r_0 r_1 \1/ r_1).
Proof. unfold monotone1_2; intros; destruct PR; eauto. Qed.

End Arg1_2.

Hint Unfold monotone1_2.
Hint Resolve paco1_2_0_fold.
Hint Resolve paco1_2_1_fold.

Implicit Arguments paco1_2_0_acc            [ T0 ].
Implicit Arguments paco1_2_1_acc            [ T0 ].
Implicit Arguments paco1_2_0_mon            [ T0 ].
Implicit Arguments paco1_2_1_mon            [ T0 ].
Implicit Arguments paco1_2_0_mult_strong    [ T0 ].
Implicit Arguments paco1_2_1_mult_strong    [ T0 ].
Implicit Arguments paco1_2_0_mult           [ T0 ].
Implicit Arguments paco1_2_1_mult           [ T0 ].
Implicit Arguments paco1_2_0_fold           [ T0 ].
Implicit Arguments paco1_2_1_fold           [ T0 ].
Implicit Arguments paco1_2_0_unfold         [ T0 ].
Implicit Arguments paco1_2_1_unfold         [ T0 ].

Instance paco1_2_0_inst  T0 (gf_0 gf_1 : rel1 T0->_) r_0 r_1 x0 : paco_class (paco1_2_0 gf_0 gf_1 r_0 r_1 x0) :=
{ pacoacc    := paco1_2_0_acc gf_0 gf_1;
  pacomult   := paco1_2_0_mult gf_0 gf_1;
  pacofold   := paco1_2_0_fold gf_0 gf_1;
  pacounfold := paco1_2_0_unfold gf_0 gf_1 }.

Instance paco1_2_1_inst  T0 (gf_0 gf_1 : rel1 T0->_) r_0 r_1 x0 : paco_class (paco1_2_1 gf_0 gf_1 r_0 r_1 x0) :=
{ pacoacc    := paco1_2_1_acc gf_0 gf_1;
  pacomult   := paco1_2_1_mult gf_0 gf_1;
  pacofold   := paco1_2_1_fold gf_0 gf_1;
  pacounfold := paco1_2_1_unfold gf_0 gf_1 }.

(** 3 Mutual Coinduction *)

Section Arg1_3.

Definition monotone1_3 T0 (gf: rel1 T0 -> rel1 T0 -> rel1 T0 -> rel1 T0) :=
  forall x0 r_0 r_1 r_2 r'_0 r'_1 r'_2 (IN: gf r_0 r_1 r_2 x0) (LE_0: r_0 <1= r'_0)(LE_1: r_1 <1= r'_1)(LE_2: r_2 <1= r'_2), gf r'_0 r'_1 r'_2 x0.

Variable T0 : Type.
Variable gf_0 gf_1 gf_2 : rel1 T0 -> rel1 T0 -> rel1 T0 -> rel1 T0.
Implicit Arguments gf_0 [].
Implicit Arguments gf_1 [].
Implicit Arguments gf_2 [].

Theorem paco1_3_0_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_0 <1= rr) (CIH: l <_paco_1= rr), l <_paco_1= paco1_3_0 gf_0 gf_1 gf_2 rr r_1 r_2),
  l <1= paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco1_3_0 gf_0 gf_1 gf_2 (r_0 \1/ l) r_1 r_2 x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco1_3_1_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_1 <1= rr) (CIH: l <_paco_1= rr), l <_paco_1= paco1_3_1 gf_0 gf_1 gf_2 r_0 rr r_2),
  l <1= paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco1_3_1 gf_0 gf_1 gf_2 r_0 (r_1 \1/ l) r_2 x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco1_3_2_acc: forall
  l r_0 r_1 r_2 (OBG: forall rr (INC: r_2 <1= rr) (CIH: l <_paco_1= rr), l <_paco_1= paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 rr),
  l <1= paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof.
  intros; assert (SIM: paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 (r_2 \1/ l) x0) by eauto.
  clear PR; repeat (try left; do 2 paco_revert; paco_cofix_auto).
Qed.

Theorem paco1_3_0_mon: monotone1_3 (paco1_3_0 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_3_1_mon: monotone1_3 (paco1_3_1 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_3_2_mon: monotone1_3 (paco1_3_2 gf_0 gf_1 gf_2).
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_3_0_mult_strong: forall r_0 r_1 r_2,
  paco1_3_0 gf_0 gf_1 gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2) <1= paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_3_1_mult_strong: forall r_0 r_1 r_2,
  paco1_3_1 gf_0 gf_1 gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2) <1= paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Theorem paco1_3_2_mult_strong: forall r_0 r_1 r_2,
  paco1_3_2 gf_0 gf_1 gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2) <1= paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. paco_cofix_auto; repeat (left; do 2 paco_revert; paco_cofix_auto). Qed.

Corollary paco1_3_0_mult: forall r_0 r_1 r_2,
  paco1_3_0 gf_0 gf_1 gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <1= paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco1_3_0_mult_strong, paco1_3_0_mon; eauto. Qed.

Corollary paco1_3_1_mult: forall r_0 r_1 r_2,
  paco1_3_1 gf_0 gf_1 gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <1= paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco1_3_1_mult_strong, paco1_3_1_mon; eauto. Qed.

Corollary paco1_3_2_mult: forall r_0 r_1 r_2,
  paco1_3_2 gf_0 gf_1 gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2) <1= paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; eapply paco1_3_2_mult_strong, paco1_3_2_mon; eauto. Qed.

Theorem paco1_3_0_fold: forall r_0 r_1 r_2,
  gf_0 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2) <1= paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco1_3_1_fold: forall r_0 r_1 r_2,
  gf_1 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2) <1= paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco1_3_2_fold: forall r_0 r_1 r_2,
  gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2) <1= paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2.
Proof. intros; econstructor; [ | | |eauto]; eauto. Qed.

Theorem paco1_3_0_unfold: forall (MON: monotone1_3 gf_0) (MON: monotone1_3 gf_1) (MON: monotone1_3 gf_2) r_0 r_1 r_2,
  paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 <1= gf_0 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2).
Proof. unfold monotone1_3; intros; destruct PR; eauto. Qed.

Theorem paco1_3_1_unfold: forall (MON: monotone1_3 gf_0) (MON: monotone1_3 gf_1) (MON: monotone1_3 gf_2) r_0 r_1 r_2,
  paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 <1= gf_1 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2).
Proof. unfold monotone1_3; intros; destruct PR; eauto. Qed.

Theorem paco1_3_2_unfold: forall (MON: monotone1_3 gf_0) (MON: monotone1_3 gf_1) (MON: monotone1_3 gf_2) r_0 r_1 r_2,
  paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 <1= gf_2 (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_0) (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_1) (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 \1/ r_2).
Proof. unfold monotone1_3; intros; destruct PR; eauto. Qed.

End Arg1_3.

Hint Unfold monotone1_3.
Hint Resolve paco1_3_0_fold.
Hint Resolve paco1_3_1_fold.
Hint Resolve paco1_3_2_fold.

Implicit Arguments paco1_3_0_acc            [ T0 ].
Implicit Arguments paco1_3_1_acc            [ T0 ].
Implicit Arguments paco1_3_2_acc            [ T0 ].
Implicit Arguments paco1_3_0_mon            [ T0 ].
Implicit Arguments paco1_3_1_mon            [ T0 ].
Implicit Arguments paco1_3_2_mon            [ T0 ].
Implicit Arguments paco1_3_0_mult_strong    [ T0 ].
Implicit Arguments paco1_3_1_mult_strong    [ T0 ].
Implicit Arguments paco1_3_2_mult_strong    [ T0 ].
Implicit Arguments paco1_3_0_mult           [ T0 ].
Implicit Arguments paco1_3_1_mult           [ T0 ].
Implicit Arguments paco1_3_2_mult           [ T0 ].
Implicit Arguments paco1_3_0_fold           [ T0 ].
Implicit Arguments paco1_3_1_fold           [ T0 ].
Implicit Arguments paco1_3_2_fold           [ T0 ].
Implicit Arguments paco1_3_0_unfold         [ T0 ].
Implicit Arguments paco1_3_1_unfold         [ T0 ].
Implicit Arguments paco1_3_2_unfold         [ T0 ].

Instance paco1_3_0_inst  T0 (gf_0 gf_1 gf_2 : rel1 T0->_) r_0 r_1 r_2 x0 : paco_class (paco1_3_0 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0) :=
{ pacoacc    := paco1_3_0_acc gf_0 gf_1 gf_2;
  pacomult   := paco1_3_0_mult gf_0 gf_1 gf_2;
  pacofold   := paco1_3_0_fold gf_0 gf_1 gf_2;
  pacounfold := paco1_3_0_unfold gf_0 gf_1 gf_2 }.

Instance paco1_3_1_inst  T0 (gf_0 gf_1 gf_2 : rel1 T0->_) r_0 r_1 r_2 x0 : paco_class (paco1_3_1 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0) :=
{ pacoacc    := paco1_3_1_acc gf_0 gf_1 gf_2;
  pacomult   := paco1_3_1_mult gf_0 gf_1 gf_2;
  pacofold   := paco1_3_1_fold gf_0 gf_1 gf_2;
  pacounfold := paco1_3_1_unfold gf_0 gf_1 gf_2 }.

Instance paco1_3_2_inst  T0 (gf_0 gf_1 gf_2 : rel1 T0->_) r_0 r_1 r_2 x0 : paco_class (paco1_3_2 gf_0 gf_1 gf_2 r_0 r_1 r_2 x0) :=
{ pacoacc    := paco1_3_2_acc gf_0 gf_1 gf_2;
  pacomult   := paco1_3_2_mult gf_0 gf_1 gf_2;
  pacofold   := paco1_3_2_fold gf_0 gf_1 gf_2;
  pacounfold := paco1_3_2_unfold gf_0 gf_1 gf_2 }.


Require Export CalculusSM2.
Require Export CalculusSM3.
Require Export CalculusSM_derived2.
Require Export ComponentAxiom.
Require Export ComponentSM8.

Section CalculusSM_derived4.

  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.

  Lemma mk_opTrust :
    forall {t a},
      In (kc_trust2data t) (kc_auth2data a)
      -> opTrust a.
  Proof.
    introv i.
    exists (Some t); simpl.
    apply kc_auth2trust_correct.
    exists (kc_trust2data t); dands; auto.
    apply kc_data2trust_correct.
  Defined.

  Definition KE_NODE_DISS (d : kc_data) : KExpression :=
    KE_AND KE_NODE (KE_DISS d).

  (* This is a LoCK representation of our HyLoE communication axiom *)
  Definition ASSUMPTION_authenticated_messages_were_sent_or_byz :=
    KE_ALL_TRUST
      (fun t =>
         KE_IMPLIES
           (KE_TLEARNS t)
           (KE_OR
              (KE_EX_DATA
                 (fun d =>
                    (KE_HAPPENED_BEFORE
                       (KE_ANDS
                          [KE_NODE_DISS d,
                           KE_IN t d,
                           KE_LOCAL_CORRECT_TRACE_BEFORE]))))
              (KE_HAPPENED_BEFORE (KE_TDISS_OWN t)))).

  (* ==================================================== *)
  (* === These 3 axioms relate HyLoE and LoCK abstraction *)
  Definition AXIOM_data_in_auth_implies_from_node :=
    forall {d a n n'},
      In d (kc_auth2data a)
      -> data_auth n a = Some n'
      -> exists k,
          name2node n' = Some k.

  (*Definition AXIOM_data_in_auth_implies_from_node :=
    forall {a d n m},
      In d (kc_auth2data a)
      -> data_auth n a = Some m
      -> exists k, name2node m = Some k /\ kc_data2owner d = Some k.*)

  Definition AXIOM_data_in_auth_implies_protocol :=
    forall {a d m},
      In d (kc_auth2data a)
      -> In a (get_contained_authenticated_data m)
      -> is_protocol_message m = true.

  Definition AXIOM_in_auth2data_implies_in_msg2data :=
    forall {d a m},
      In d (kc_auth2data a)
      -> In a (get_contained_authenticated_data m)
      -> In d (kc_msg2data m).
  (* ==================================================== *)

  Lemma dmsg_is_in_out_implies_trust_data_is_in_out :
    forall d a m dst delay {eo : EventOrdering} {e : Event} {s} (o : event2out s e),
      AXIOM_in_auth2data_implies_in_msg2data
      -> In d (kc_auth2data a)
      -> In a (get_contained_authenticated_data m)
      -> dmsg_is_in_out (MkDMsg m dst delay) o
      -> data_is_in_out d o.
  Proof.
    introv ax i j k.
    unfold dmsg_is_in_out in *.
    unfold data_is_in_out in *.
    unfold event2out in *; remember (trigger e) as trig; destruct trig; simpl in *; tcsp.
    apply in_flat_map; eexists; dands; eauto; simpl.
  Qed.
  Hint Resolve dmsg_is_in_out_implies_trust_data_is_in_out : kc.

  Lemma implies_trust2data_is_in_out :
    forall t (i : ITrusted) {eo : EventOrdering} {e : Event} {s} (o : event2out s e)
           (p : is_trusted_event e i) (x : iot_output (iot_fun (it_name i))),
      trusted_is_in_out p x o
      -> ct_out2trust (it_name i) x = Some t
      -> data_is_in_out (kc_trust2data t) o.
  Proof.
    introv h q.
    unfold trusted_is_in_out in h; subst.
    unfold is_trusted_event in p.
    unfold data_is_in_out.
    revert o q.
    unfold event2out in *; simpl in *; rewrite p; simpl; introv h.
    unfold kc_out2trust; rewrite h; simpl; tcsp.
  Qed.
  Hint Resolve implies_trust2data_is_in_out : kc.

  Lemma ASSUMPTION_authenticated_messages_were_sent_or_byz_true :
    forall (eo : EventOrdering),
      AXIOM_data_in_auth_implies_from_node
      -> AXIOM_data_in_auth_implies_protocol
      -> AXIOM_in_auth2data_implies_in_msg2data
      -> AXIOM_authenticated_messages_were_sent_or_byz eo kc_sys
      -> assume_eo eo ASSUMPTION_authenticated_messages_were_sent_or_byz.
  Proof.
    introv a2n a2p a2m sendbyz lrn; simpl in *.
    unfold learns_data in lrn; exrepnd.
    pose proof (sendbyz e a (mk_opTrust lrn3) lrn2 lrn1) as sendbyz; simpl in *.
    exrepnd; repndors; exrepnd; subst; simpl in *; ginv;[|].

    { pose proof (a2n _ _ _ _ lrn3 sendbyz4) as exe1; exrepnd.
      assert (ex_node_e e') as exe' by (exists k; auto).
      autodimp sendbyz5 hyp; try (complete (eapply a2p; eauto)).
      left.
      exists (kc_trust2data c) (MkEventN e' exe'); simpl; dands; auto;
        try apply kc_data2trust_correct;[| |].

      { apply name2node_cond in exe0; eauto. }

      { unfold disseminate_data; simpl.
        apply in_M_output_sys_on_event_implies_in_byz in sendbyz5; exrepnd.
        exists o; dands; auto.
        eapply dmsg_is_in_out_implies_trust_data_is_in_out; eauto. }

      { apply M_output_sys_on_event_implies_has_correct_trace_before in sendbyz5.
        applydup name2node_cond in exe0 as cond.
        exists k; dands; auto.
        introv lte eql.
        assert (loc e'0 = loc e') as eqloc by congruence.
        pose proof (sendbyz5 e') as cor; repeat (autodimp cor hyp); eauto 2 with eo.
        apply cor; eauto 3 with eo. }
    }

    { inversion sendbyz3; subst.
      right.
      assert (ex_node_e e') as exe'.
      { unfold ex_node_e; allrw; rewrite node2name_cond; eauto. }

      exists (MkEventN e' exe'); simpl; dands; auto.

      { unfold disseminate_data, kc_out2trust; simpl.
        rewrite sendbyz4.
        exists o; dands; auto.
        eapply implies_trust2data_is_in_out; eauto. }

      { eexists; dands; eauto; simpl.
        unfold data_is_owned_by; simpl.
        rewrite kc_same_trust2owner; auto.
        unfold kc_trust2owner; allrw; auto. } }
  Qed.

  Definition ASSUMPTION_disseminate_trusted_if_own :=
    KE_ALL_DATA
      (fun d =>
         KE_ALL_TRUST
           (fun t =>
              KE_IMPLIES
                (KE_NODE_DISS d)
                (KE_IMPLIES
                   (KE_IN t d)
                   (KE_IMPLIES
                      (KE_TOWNS t)
                      (KE_TDISS_OWN t))))).

  Definition ASSUMPTION_learns_trusted_if_own :=
    KE_ALL_DATA
      (fun d =>
         KE_ALL_TRUST
           (fun t =>
              KE_IMPLIES
                (KE_NODE_DISS d)
                (KE_IMPLIES
                   (KE_IN t d)
                   (KE_IMPLIES
                      (KE_NOT (KE_TOWNS t))
                      (KE_TLEARNED t))))).

  (************************************************************************************************)
  Definition DERIVED_RULE_implies_all_trusted_learns_if_gen {eo : EventOrdering} e R H :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ ASSUMPTION_authenticated_messages_were_sent_or_byz @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_disseminate_trusted_if_own              @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_learns_trusted_if_own                   @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_has_owner_dec                           @ e'])
      (⟬R⟭ H ⊢ KE_ALL_TRUST ASSUMPTION_trusted_learns_if_gen @ e).

  Lemma DERIVED_RULE_implies_all_trusted_learns_if_gen_true :
    forall {eo : EventOrdering} e R H,
      rule_true (DERIVED_RULE_implies_all_trusted_learns_if_gen e R H).
  Proof.
    start_proving_derived st.

    LOCKapply PRIMITIVE_RULE_induction_true.
    LOCKintro "ind".
    clear e; rename e0 into e.

    LOCKapply PRIMITIVE_RULE_all_trust_intro_true.
    LOCKintro "lrn".

    LOCKcut "ass1" (ASSUMPTION_authenticated_messages_were_sent_or_byz @ e).
    { inst_hyp e st'; repeat LOCKclear. }

    LOCKelim "ass1" t; try LOCKauto.
    LOCKelim "ass1"; try LOCKauto.
    LOCKelim "ass1"; try LOCKauto.
    LOCKelim "ass1".
    LOCKapply@ "ass1" (PRIMITIVE_RULE_unhappened_before_hyp_true "u").
    LOCKelim "ass1" "diss".
    LOCKelim "ass1" "in".
    LOCKelim "ass1" "cor".

    LOCKcut "dec" (KE_TOWNS_DEC t @ e0).
    { LOCKapply DERIVED_RULE_towns_dec_true.
      { inst_hyp e1 st'; repeat LOCKclear.
        LOCKclear "u". }
      LOCKelim "diss" "x"; try LOCKauto. }

    LOCKelim "dec".
    { LOCKcut "ass2" (ASSUMPTION_disseminate_trusted_if_own @ e0).
      { inst_hyp e0 st'; repeat LOCKclear; LOCKclear "u". }
      LOCKelim "ass2" d.
      LOCKelim "ass2" t.
      repeat (LOCKelim "ass2"; try LOCKauto).

      LOCKapply@ "u" PRIMITIVE_RULE_unhappened_before_if_causal_true; try LOCKauto. }

    LOCKcut "ass2" (ASSUMPTION_learns_trusted_if_own @ e0).
    { inst_hyp e0 st'; repeat LOCKclear; LOCKclear "u". }
    LOCKelim "ass2" d.
    LOCKelim "ass2" t.
    LOCKelim "ass2"; try LOCKauto.
    LOCKelim "ass2"; try LOCKauto.
    LOCKelim "ass2"; try LOCKauto.

    LOCKapply@ "ass2" (DERIVED_RULE_unlocal_before_eq_hyp_true "v").
    LOCKapply@ "u" "ind" PRIMITIVE_RULE_forall_before_elim_trans_true.
    LOCKapply@ "v" "ind" DERIVED_RULE_forall_before_eq_elim_local_eq_true.
    LOCKelim "ind" t.
    LOCKelim "ind"; try LOCKauto.
    LOCKapply@ "u" PRIMITIVE_RULE_unhappened_before_if_causal_trans_eq_true.
    LOCKapply@ "v" DERIVED_RULE_happened_before_if_local_eq_true; try LOCKauto.
  Qed.

  (************************************************************************************************)
  Definition DERIVED_RULE_knows_implies_learned_or_gen_implies_gen2 {eo : EventOrdering} e R H d :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ KE_FORALL_BEFORE_EQ (ASSUMPTION_learns_if_gen d) @ e,
          ⟬R⟭ H ⊢ ASSUMPTION_knows_implies_learned_or_gen d @ e'])
      (⟬R⟭ H ⊢ ASSUMPTION_knows_implies_gen d @ e).

  Lemma DERIVED_RULE_knows_implies_learned_or_gen_implies_gen2_true :
    forall (eo : EventOrdering) e R H d,
      rule_true (DERIVED_RULE_knows_implies_learned_or_gen_implies_gen2 e R H d).
  Proof.
    start_proving_derived st.
    inst_hyp e st'.

    LOCKcut "a" (ASSUMPTION_knows_implies_learned_or_gen d @ e).
    LOCKintro "kn".
    LOCKelim "a"; try LOCKauto.
    LOCKelim "a"; try LOCKauto.

    { LOCKapply@ "a" (DERIVED_RULE_unlocal_before_eq_hyp_true "u" "a").
      inst_hyp e0 st.
      LOCKcut "b" (KE_FORALL_BEFORE_EQ (ASSUMPTION_learns_if_gen d) @ e).
      { repeat LOCKclear; LOCKclear "u". }
      LOCKapply@ "u" "b" DERIVED_RULE_forall_before_eq_elim_local_eq_true.
      LOCKelim "b"; try LOCKauto.
      LOCKapply@ "u" DERIVED_RULE_happened_before_eq_if_local_eq_true.
      LOCKapply DERIVED_RULE_happened_before_implies_happened_before_eq_true; try LOCKauto. }

    LOCKapply@ "a" (DERIVED_RULE_unlocal_before_eq_hyp_true "u").
    LOCKapply@ "u" PRIMITIVE_RULE_localle_if_causalle_true.
    LOCKapply@ "u" DERIVED_RULE_unhappened_before_eq_if_causalle_true; try LOCKauto.
  Qed.

  (************************************************************************************************)
  Definition DERIVED_RULE_KLD_implies_gen2 {eo : EventOrdering} e R H d :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ KE_FORALL_BEFORE_EQ (ASSUMPTION_learns_if_gen d) @ e,
          ⟬R⟭ H ⊢ ASSUMPTION_knew_or_learns_or_gen d @ e'])
      (⟬R⟭ H ⊢ ASSUMPTION_knows_implies_gen d @ e).

  Lemma DERIVED_RULE_KLD_implies_gen2_true :
    forall {eo : EventOrdering} e R H d,
      rule_true (DERIVED_RULE_KLD_implies_gen2 e R H d).
  Proof.
    start_proving_derived st.
    LOCKapply DERIVED_RULE_knows_implies_learned_or_gen_implies_gen2_true.
    { inst_hyp e st. }
    LOCKapply DERIVED_RULE_KLD_implies_or_true.
    inst_hyp e1 st.
  Qed.

  (************************************************************************************************)
  Definition DERIVED_RULE_forall_before_eq_intro u {eo : EventOrdering} e R H t :=
    MkRule1
      (fun e' => [⟬(u ⋈ e' ▶ e) :: R⟭ H ⊢ t @ e'])
      (⟬R⟭ H ⊢ KE_FORALL_BEFORE_EQ t @ e).

  Lemma DERIVED_RULE_forall_before_eq_intro_true :
    forall u {eo : EventOrdering} e R H t,
      rule_true (DERIVED_RULE_forall_before_eq_intro u e R H t).
  Proof.
    start_proving_derived st.
    LOCKintro.
    { LOCKapply (PRIMITIVE_RULE_forall_before_intro_true u).
      LOCKapply@ u PRIMITIVE_RULE_causal_if_causalle_true.
      inst_hyp e0 hyp. }
    inst_hyp e hyp.
    LOCKapply (DERIVED_RULE_add_happenedle_refl_true u e).
  Qed.

  (************************************************************************************************)
  Definition DERIVED_RULE_forall_before_eq_elim u x {eo : EventOrdering} e e' R Q H J t a :=
    MkRule0
      [⟬R ++ (u ⋈ e' ▶ e) :: Q⟭ H • (x › t @ e') » J ⊢ a]
      (⟬R ++ (u ⋈ e' ▶ e) :: Q⟭ H • (x › KE_FORALL_BEFORE_EQ t @ e) » J ⊢ a).

  Lemma DERIVED_RULE_forall_before_eq_elim_true :
    forall u x {eo : EventOrdering} e e' R Q H J t a,
      rule_true (DERIVED_RULE_forall_before_eq_elim u x e e' R Q H J t a).
  Proof.
    start_proving_derived st.
    LOCKelim x "y".
    LOCKapply@ u PRIMITIVE_RULE_split_happened_before_eq2_true.

    { LOCKapply@ u PRIMITIVE_RULE_causal_eq_sym_true.
      LOCKapply@ x u PRIMITIVE_RULE_subst_causal_eq_hyp_true.
      LOCKclear "y".
      LOCKapply@ u PRIMITIVE_RULE_causal_eq_sym_true.
      LOCKapply@ u PRIMITIVE_RULE_beforele_if_eq_true. }

    LOCKapply@ "y" u PRIMITIVE_RULE_forall_before_elim_true.

    LOCKclear x.
    LOCKapply@ "y" (PRIMITIVE_RULE_rename_hyp_true "y" x).
    LOCKapply@ u PRIMITIVE_RULE_causal_if_causalle_true.
  Qed.

  (************************************************************************************************)
  Definition DERIVED_RULE_swap_forall_before_eq_all_trust x {eo : EventOrdering} e f R H J a :=
    MkRule0
      [⟬R⟭ H • (x › KE_ALL_TRUST (fun t => KE_FORALL_BEFORE_EQ (f t)) @ e) » J ⊢ a]
      (⟬R⟭ H • (x › KE_FORALL_BEFORE_EQ (KE_ALL_TRUST f) @ e) » J ⊢ a).

  Lemma DERIVED_RULE_swap_forall_before_eq_all_trust_true :
    forall x {eo : EventOrdering} e f R H J a,
      rule_true (DERIVED_RULE_swap_forall_before_eq_all_trust x e f R H J a).
  Proof.
    start_proving_derived st.
    LOCKcut "x" x (KE_ALL_TRUST (fun t => KE_FORALL_BEFORE_EQ (f t)) @ e).
    { LOCKintro.
      LOCKapply (DERIVED_RULE_forall_before_eq_intro_true "u").
      LOCKapply@ "u" DERIVED_RULE_forall_before_eq_elim_true.
      LOCKelim x t; try LOCKauto. }
    LOCKclear x.
    LOCKapply@ "x" (PRIMITIVE_RULE_rename_hyp_true "x" x).
  Qed.

  (************************************************************************************************)
  Definition DERIVED_RULE_forall_before_eq_trans u {eo : EventOrdering} e e' R Q H t :=
    MkRule0
      [⟬R ++ (u ⋈ e' ▷ e) :: Q⟭ H ⊢ KE_FORALL_BEFORE t @ e]
      (⟬R ++ (u ⋈ e' ▷ e) :: Q⟭ H ⊢ KE_FORALL_BEFORE_EQ t @ e').

  Lemma DERIVED_RULE_forall_before_eq_trans_true :
    forall u {eo : EventOrdering} e e' R Q H t,
      rule_true (DERIVED_RULE_forall_before_eq_trans u e e' R Q H t).
  Proof.
    start_proving_derived st.
    LOCKcut "all" (KE_FORALL_BEFORE t @ e).
    LOCKapply@ u "all" PRIMITIVE_RULE_forall_before_elim_trans_true.
    LOCKapply (DERIVED_RULE_forall_before_eq_intro_true "u").
    LOCKapply@ "u" "all" DERIVED_RULE_forall_before_eq_elim_true; try LOCKauto.
  Qed.

  Definition ASSUMPTION_diss_correct_implies_knows :=
    KE_ALL_DATA
      (fun d =>
         KE_IMPLIES
           (KE_NODE_DISS d)
           (KE_IMPLIES
              KE_LOCAL_CORRECT_TRACE_BEFORE
              (KE_KNOWS d))).

  Definition ASSUMPTION_in_knows_implies_trusted_knows :=
    KE_ALL_DATA
      (fun d =>
         KE_ALL_TRUST
           (fun t =>
              KE_IMPLIES
                (KE_KNOWS d)
                (KE_IMPLIES
                   (KE_IN t d)
                   (KE_TKNOWS t)))).

  (************************************************************************************************)
  Definition DERIVED_RULE_KIK_and_DIS_implies_knows d {eo : EventOrdering} e t R H :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ ASSUMPTION_diss_correct_implies_knows              @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_in_knows_implies_trusted_knows          @ e',
          ⟬R⟭ H ⊢ KE_NODE_DISS d                @ e,
          ⟬R⟭ H ⊢ KE_LOCAL_CORRECT_TRACE_BEFORE @ e,
          ⟬R⟭ H ⊢ KE_IN t d                     @ e])
      (⟬R⟭ H ⊢ KE_TKNOWS t @ e).

  Lemma DERIVED_RULE_KIK_and_DIS_implies_knows_true :
    forall d {eo : EventOrdering} e t R H,
      rule_true (DERIVED_RULE_KIK_and_DIS_implies_knows d e t R H).
  Proof.
    start_proving_derived st.

    inst_hyp e st'; repeat LOCKclear.

    LOCKcut "ass" (ASSUMPTION_in_knows_implies_trusted_knows @ e).
    LOCKelim "ass" d.
    LOCKelim "ass" t.
    repeat (LOCKelim "ass"; try LOCKauto).
    LOCKcut "ass" (ASSUMPTION_diss_correct_implies_knows @ e).
    LOCKelim "ass" d.
    repeat (LOCKelim "ass"; try LOCKauto).
  Qed.

  (************************************************************************************************)
  Definition DERIVED_RULE_implies_all_trusted_learns_if_gen2 {eo : EventOrdering} e R H :=
    MkRule1
      (fun e' =>
         [⟬R⟭ H ⊢ ASSUMPTION_authenticated_messages_were_sent_or_byz @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_diss_correct_implies_knows              @ e',
          ⟬R⟭ H ⊢ ASSUMPTION_in_knows_implies_trusted_knows          @ e',
          ⟬R⟭ H ⊢ KE_ALL_DATA ASSUMPTION_knew_or_learns_or_gen       @ e'])
      (⟬R⟭ H ⊢ KE_ALL_TRUST ASSUMPTION_trusted_learns_if_gen @ e).

  Lemma DERIVED_RULE_implies_all_trusted_learns_if_gen2_true :
    forall {eo : EventOrdering} e R H,
      rule_true (DERIVED_RULE_implies_all_trusted_learns_if_gen2 e R H).
  Proof.
    start_proving_derived st.

    LOCKapply PRIMITIVE_RULE_induction_true.
    LOCKintro "ind".
    clear e; rename e0 into e.

    LOCKintro.
    LOCKintro "lrn".

    LOCKcut "ass1" (ASSUMPTION_authenticated_messages_were_sent_or_byz @ e).
    { inst_hyp e st'; repeat LOCKclear. }

    LOCKapply@ "ass1" (PRIMITIVE_RULE_all_trust_elim_true "ass1" t); try LOCKauto.
    LOCKelim "ass1"; try LOCKauto.
    LOCKelim "ass1"; try LOCKauto.
    LOCKelim "ass1".
    LOCKapply@ "ass1" (PRIMITIVE_RULE_unhappened_before_hyp_true "u").
    LOCKelim "ass1" "diss".
    LOCKelim "ass1" "in".
    LOCKelim "ass1" "cor".

    LOCKcut "tk" (KE_TKNOWS t @ e0).
    { LOCKapply (DERIVED_RULE_KIK_and_DIS_implies_knows_true d); try LOCKauto;
        inst_hyp e1 st'; repeat LOCKclear; LOCKclear "u". }

    LOCKcut "ass3" (ASSUMPTION_knows_implies_gen (kc_trust2data t) @ e0).
    { LOCKapply DERIVED_RULE_KLD_implies_gen2_true.
      { LOCKapply@ "u" "ind" PRIMITIVE_RULE_forall_before_elim_trans_true.
        LOCKapply@ "ind" DERIVED_RULE_swap_forall_before_eq_all_trust_true.
        LOCKelim "ind" t.
        unfold ASSUMPTION_learns_if_gen; try LOCKauto. }
      inst_hyp e1 st'; repeat LOCKclear; LOCKclear "u".
      LOCKcut "ass" (KE_ALL_DATA ASSUMPTION_knew_or_learns_or_gen @ e1).
      LOCKelim "ass" (kc_trust2data t); try LOCKauto. }

    LOCKelim "ass3"; try LOCKauto.
    LOCKapply@ "u" DERIVED_RULE_unhappened_before_if_causal_trans_true; try LOCKauto.
  Qed.

End CalculusSM_derived4.