(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext machine_int multi_int uniq_tac.
Import MachineInt.
Require Import mips_seplog mips_contrib mips_frame mips_tactics.
Import expr_m.
Import assert_m.
Require Import multi_sub_s_u_prg multi_add_s_u_triple pick_sign_triple.
Require Import copy_u_u_triple multi_is_zero_u_triple multi_negate_triple.
Require Import multi_sub_u_u_L_triple multi_sub_u_u_R_triple.
Require Import multi_add_u_u_triple.

Local Open Scope zarith_ext_scope.
Local Open Scope uniq_scope.
Local Open Scope heap_scope.
Local Open Scope machine_int_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope mips_assert_scope.
Local Open Scope multi_int_scope.

(* TODO: rename registers *)
Lemma multi_sub_s_u0_triple k a b a0 a1 a2 a3 a4 ret X :
uniq(k, a, b, a0, a1, a2, a3, a4, ret, X, r0) ->
forall nk va vb ptr, nk <> O -> Z_of_nat nk < 2 ^^ 31 ->
  u2Z ptr + 4 * Z_of_nat nk < \B^1 ->
forall A B, size A = nk -> size B = nk -> 0 < \S_{ nk } B ->
forall slen, s2Z slen = sgZ (s2Z slen) * Z_of_nat nk ->
{{ fun s h => [ a ]_s = va /\ [ b ]_s = vb /\  u2Z [ k ]_s = Z_of_nat nk /\
   ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h }}
multi_sub_s_u0 k a b a0 a1 a2 a3 a4 ret X
{{ fun s h => exists A' slen', size A' = nk /\ [ a ]_s = va /\
  [ b ]_s = vb /\ s2Z slen' = sgZ (s2Z slen') * Z_of_nat nk /\
  sgZ (s2Z slen') = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> slen' :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B ) s h /\
  u2Z ([ a3 ]_ s) <= 1 /\
  sgZ (s2Z slen') * (\S_{ nk } A' + u2Z ([ a3 ]_s) * \B^nk) =
    sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B }}.
Proof.
move=> Hregs nk va vb ptr Hnk Hnk' ptr_fit A B len_A len_B nk_B slen slen_not_weird.
rewrite /multi_sub_s_u0.

(** lw X four16 a *)

apply hoare_lw_back_alt'' with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_s = ptr /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

rewrite /while.entails => s h [r_a [r_b [r_k Hmem]]].
exists ptr; split.
- rewrite conCE !conAE conCE !conAE
  conCE !conAE in Hmem.
  move: Hmem; apply monotony => // h'; apply mapsto_ext => //.
  by rewrite sext_Z2u.
- rewrite /update_store_lw.
  repeat Reg_upd; repeat (split => //).
  by Assert_upd.

(** pick_sign a a0 a1 *)

apply while.hoare_seq with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_s = ptr /\ [a0]_s = slen /\ sgZ (s2Z [a1 ]_ s) = sgZ (s2Z slen) /\
  (s2Z [ a1 ]_ s = 0 \/ s2Z [ a1 ]_ s = 1 \/ s2Z [ a1 ]_s = - 1) /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

eapply while.hoare_conseq; last first.
(* TODO: use machine_int notation *)
- apply (pick_sign_triple (fun s h =>
    [b ]_ s = vb /\ u2Z [k ]_ s = Z_of_nat nk /\
    [X ]_ s = ptr) (((var_e a \+ int_e four32 |~> int_e ptr **
      (fun st h0 => u2Z (([a ]_ st `+ four32) `+ four32) mod 4 = 0 /\
        emp st h0)) ** int_e ptr |--> A) ** var_e b |--> B) va slen).
  + by Uniq_uniq r0.
  + Inde.
    move=> s h x v /= [] //.
    move=> ?; subst a1; by Reg_upd.
    case=> // ?; subst a0; by Reg_upd.
  + by Inde.
- move=> s h /= [Ha [Hb [Hk [HX Hmem]]]].
  by rewrite !conAE in Hmem *.
- move=> s h [Ha [Ha0 [Ha1 [Ha1' [Hmem [Hb [Hk HX]]]]]]].
  by rewrite !conAE in Hmem *.

(** while.ifte (bgez a1) *)

apply while.hoare_ifte.

apply while.hoare_ifte.

apply while.hoare_seq with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ 0 = sgZ (s2Z slen) /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h).

(** copy k X b a2 a3 a4 *)

apply (before_frame
  (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\ [a0 ]_ s = slen /\
    sgZ (s2Z slen) = 0 /\ (var_e a |--> slen :: ptr :: nil) s h)
  (fun s h => [X]_s = ptr /\ u2Z [k]_s = Z_of_nat nk /\
    (var_e b |--> B ** var_e X |--> A) s h)
  (fun s h => [X]_s = ptr /\ u2Z [k]_s = Z_of_nat nk /\
    (var_e b |--> B ** var_e X |--> B) s h)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply copy_u_u_triple => //; by Uniq_uniq r0.

move=> s h [ [ [Ha [Hb [Hk [HX [Ha0 [a1_slen [Ha1' mem]]]]]] _] Ha1] ].
rewrite conAE in mem.
case: mem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
exists h2, h1.
split; first by heap_tac_m.Disj.
split; first by heap_tac_m.Equal.
repeat (split => //).
rewrite conCE.
move: Hh2; apply monotony => // h'; exact: mapstos_ext.
rewrite /= in Ha1; move/eqP/u2Z_inj in Ha1.
rewrite store.get_r0 /= in Ha1.
rewrite -a1_slen Ha1 s2Z_u2Z_pos'; by rewrite Z2uK.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh2 => [Ha [Hb [Ha0 [Ha1' Hh2]]]].
case: Hh1 => Hx [Hk Hh1].
repeat (split => //).
rewrite conAE.
exists h2, h1.
split; first by heap_tac_m.Disj.
split; first by heap_tac_m.Equal.
repeat (split => //).
rewrite conCE.
move: Hh1; apply monotony => h' //; exact: mapstos_ext.

(** addiu a3 r0 zero16 *)

apply hoare_addiu with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a3]_s = zero32 /\
  0 = sgZ (s2Z slen) /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h).
move=> s h [Ha [Hb [Hk [HX [Hslen mem]]]]].
rewrite /wp_addiu.
repeat Reg_upd.
repeat (split=> //).
by rewrite sext_Z2u // addi0.
by Assert_upd.

(** sw k zero16 a *)

apply hoare_sw_back'' with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
 u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a3 ]_ s = zero32 /\
 0 = sgZ (s2Z slen) /\
 ((var_e a |--> Z2s 32 (Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h).

move=> s h [Ha [Hb [Hk [HX [Ha3 [Hslen mem]]]]]].
exists (int_e slen).
rewrite !conAE /= in mem.
move: mem; apply monotony => // h'.
apply mapsto_ext => //; by rewrite /= sext_Z2u // addi0.
apply currying => h'' Hh''.
repeat (split => //).
rewrite conCE in Hh''.
rewrite /= !conAE.
move: Hh''; apply monotony => // h'''.
apply mapsto_ext => /=.
by rewrite sext_Z2u // addi0.
apply u2Z_inj.
rewrite Hk u2Z_Z2s_pos //.
split; by [apply Zle_0_nat |(apply: @ltZ_leZ_trans; [exact: Hnk'|])].

(** negate a a0 *)

apply hoare_prop_m.hoare_weak with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\
  sgZ (- Z_of_nat nk) = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> Z2s 32 (- Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> B) ** var_e b |--> B) s h /\
  u2Z [a3 ]_ s <= 1 /\ 0 = sgZ (s2Z slen) /\
  sgZ (- Z_of_nat nk) * (\S_{ nk } B + u2Z [a3 ]_ s * \B^nk) = sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B).
move=> s h [Ha [Hb [Hsgn [mem [Ha3 [Hslen HSum]]]]]].
exists B, (Z2s 32 (- Z_of_nat nk)).
repeat (split=> //).

rewrite Z2sK //; last lia.
rewrite (proj2 (Zsgn_neg (- Z_of_nat nk))) //; lia.
rewrite Z2sK //; lia.
rewrite Z2sK //; lia.

apply (before_frame
  (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\ (var_e b |--> B) s h /\
    u2Z [a3 ]_ s <= 1 /\ 0 = sgZ (s2Z slen) /\
    - sgZ (Z_of_nat nk) * (\S_{ nk } B + u2Z [a3 ]_ s * \B^nk) =
    sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B)
  (var_e a |--> Z2s 32 (Z_of_nat nk) :: ptr :: nil ** int_e ptr |--> B)
  (var_e a |--> cplt2 (Z2s 32 (Z_of_nat nk)) :: ptr :: nil ** int_e ptr |--> B)).

apply frame_rule_R.
- apply multi_negate_triple => //; by Uniq_uniq r0.
  Inde_frame; rewrite /inde => s h x v /= [] // ?; subst x; by Reg_upd.
- move=> ?; by Inde_mult.

move=> s h [Ha [Hb [Hk [HX [Ha3 [Hsgn mem]]]]]].
case: mem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h1 h2; first by exact Hh1.
repeat (split=> //).
by rewrite Ha3 Z2uK.
rewrite -Hsgn mul0Z /= Ha3 Z2uK // mul0Z addZ0 (proj2 (Zsgn_pos (Z_of_nat nk))) //; lia.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh2 => [Ha [Hb [hSgn [Ha3 [Hslen HSum]]]]].
repeat (split => //).
rewrite -Hslen mul0Z /= in HSum *.
rewrite (proj2 (Zsgn_neg (- Z_of_nat nk))); last lia.
rewrite (proj2 (Zsgn_neg (- \S_{ nk } B))); lia.
Compose_sepcon h1 h2; last by [].
rewrite (_ : Z2s 32 (- Z_of_nat nk) = cplt2 (Z2s 32 (Z_of_nat nk))) //.
apply s2Z_inj.
rewrite s2Z_cplt2; last first.
  rewrite weirdE2 Z2sK; lia.
rewrite Z2sK; last lia.
rewrite Z2sK //; lia.
rewrite (proj2 (Zsgn_pos (Z_of_nat nk))) in HSum; last lia.
rewrite (proj2 (Zsgn_neg (- Z_of_nat nk))); last lia.
rewrite -HSum; ring.

(** multi_lt k X b a0 a1 ret a2 a3 a4 *)

apply while.hoare_seq with (fun s h =>
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h /\
  ((\S_{ nk } A < \S_{ nk } B /\ [ret]_s = one32 /\ [a2]_s = zero32) \/
   (\S_{ nk } A > \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = one32) \/
   (\S_{ nk } A = \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = zero32))).

eapply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = 1 /\ (var_e a |--> slen :: ptr :: nil) s h)
  (fun s h => u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_ s = ptr /\ [b ]_ s = vb /\
    (var_e X |--> A ** var_e b |--> B) s h )
  (fun s h =>u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_ s = ptr  /\ [b ]_ s = vb /\
    (((\S_{ nk } A < \S_{ nk } B /\ [ret]_s = one32 /\ [a2]_s = zero32) \/
      (\S_{ nk } A > \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = one32) \/
      (\S_{ nk } A = \S_{ nk } B /\ [ret]_s = zero32 /\ [a2]_s = zero32)) /\
    (var_e X |--> A ** var_e b |--> B) s h))).

apply frame_rule_R.
apply multi_lt_triple.multi_lt_triple => //; by Uniq_uniq r0.
by Inde_frame.
move=> ?; by Inde_mult.

rewrite /while.entails => s h [[[Ha [Hb [Hk [HX [Ha0 [HZsgn [Ha1 Hmem]]]]]]] Ha1''] Ha1'].
move/leZP in Ha1''. rewrite /= in Ha1'. move/eqP in Ha1'.
rewrite store.get_r0 Z2uK // in Ha1'.
case: Ha1 => Ha1.
  by rewrite s2Z_u2Z_pos // in Ha1.
case: Ha1 => Ha1; last first.
  rewrite Ha1 in Ha1''. by move/leZP : Ha1''.
rewrite conAE in Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h2 h1.
repeat (split=> //).
move: Hh2; apply monotony => // h'; exact: mapstos_ext.
repeat (split=> //).
by rewrite -HZsgn Ha1.

rewrite /while.entails => s h Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
case: Hh1 => Hk [Hb [HX [HSum Hmem]]].
case: Hh2 => Ha [Hsgn Hh2].
repeat (split=> //).
rewrite conAE.
Compose_sepcon h2 h1; first by [].
move: Hmem. apply monotony => // h'; exact: mapstos_ext.

(** ifte_beq ret, r0 *)

apply while.hoare_ifte.

apply while.hoare_ifte.

apply hoare_addiu with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a3]_s = zero32 /\
  sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h /\
  \S_{ nk } A = \S_{ nk } B).

move=> s h [ [ [Ha [Hb [Hk [HX [Hslen [mem HSum]]]]]] Hret] Ha2].
rewrite /wp_addiu.
repeat Reg_upd.
repeat (split => //).
by rewrite sext_Z2u // addi0.
by Assert_upd.
rewrite /= in Hret Ha2.
move/eqP/u2Z_inj in Hret.
move/eqP/u2Z_inj in Ha2.
rewrite store.get_r0 in Hret Ha2.
case: HSum => Hsum.
  rewrite Hret Ha2 in Hsum.
  case: Hsum => _ [Hsum _].
  by apply Z2u_dis in Hsum.
case: Hsum => Hsum; last by tauto.
rewrite Ha2 in Hsum.
case: Hsum => _ [_ Hsum].
by apply Z2u_dis in Hsum.

(** sw r0 zero16 a *)

apply hoare_sw_back'.
move=> s h [Ha [Hb [Hk [HX [Ha3 [Hslen [mem HSum]]]]]]].
exists (int_e slen).
rewrite !conAE /= in mem.
move: mem; apply monotony => // h'.
apply mapsto_ext => //=; by rewrite sext_Z2u // addi0.
apply currying => h'' Hh''.
exists A (* NB: whatever *), (Z2s 32 0).
repeat (split => //).

by rewrite Z2sK.

by rewrite Z2sK //= Hslen mul1Z HSum subZZ.

rewrite conCE in Hh''.
rewrite !conAE /=.
move: Hh''; apply monotony => // h3.
apply mapsto_ext => /=.
by rewrite sext_Z2u // addi0.
rewrite store.get_r0.
apply u2Z_inj.
by rewrite u2Z_Z2s_pos // Z2uK.
by rewrite Ha3 Z2uK.
by rewrite Z2sK //= Hslen mul1Z HSum subZZ.

(** multi_sub k X b X a0 a1 a2 a3 a4 ret *)

apply hoare_prop_m.hoare_stren with (fun s h => \S_{ nk } A > \S_{ nk } B /\
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

rewrite /while.entails => s h [[[Ha [Hb [Hk [HX [HZsgn [Hmem HSum]]]]]] Hret] Ha2].
rewrite /= store.get_r0 Z2uK // in Hret.
move/eqP in Hret.
case: HSum => HSum.
  case: HSum => _ [HSum _].
  by rewrite HSum Z2uK in Hret.
split; last by [].
rewrite /= in Ha2.
move/eqP in Ha2.
rewrite store.get_r0 Z2uK // in Ha2.
case: HSum => HSum; first by tauto.
case: HSum => _ [_ HSum].
by rewrite HSum Z2uK in Ha2.

(** multi_sub k X b X a0 a1 a2 a3 a4 ret *)

apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => HAB.

apply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = 1 /\
    (var_e a |--> slen :: ptr :: nil) s h )
  (fun s h => [X ]_ s = ptr /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    (var_e X |--> A ** var_e b |--> B) s h)
  (fun s h => exists A', size A' = nk /\
    [X ]_ s = ptr /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    [a3]_s = zero32 /\
    (var_e X |--> A' ** var_e b |--> B) s h /\
    \S_{ nk } A' = \S_{ nk } A - \S_{ nk } B)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_sub_u_u_L_triple_B_le_A => //.
by Uniq_uniq r0.
lia.

rewrite /while.entails => s h [Ha [Hb [Hk [HX [HZsgn Hmem]]]]].
rewrite conAE in Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h2 h1; last by [].
repeat (split => //).
move: Hh2. apply monotony => // h'; exact:  mapstos_ext.

rewrite /while.entails => s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh1 => A' [A'_nk [Hb [HX [Hk [Ha3 [Hh1 HSum]]]]]].
case: Hh2 => [Ha [HZsgn Hh2]].
exists A', slen.
rewrite Ha3 Z2uK // HZsgn !mul1Z mul0Z addZ0.
repeat (split => //).

rewrite slen_not_weird HZsgn; ring.

rewrite (proj2 (Zsgn_pos (\S_{ nk } A - \S_{ nk } B))) //; lia.
rewrite conAE.
Compose_sepcon h2 h1; first by [].
move: Hh1. apply monotony => // h'; exact: mapstos_ext.

(** multi_sub k b X X a0 a1 a2 a3 a4 ret; *)

apply hoare_prop_m.hoare_stren with (fun s h => \S_{ nk } A < \S_{ nk } B /\
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

rewrite /while.entails => s h [[Ha [Hb [Hk [HX [HZsgn [Hmem HSum]]]]]] Hret].
rewrite /= store.get_r0 Z2uK // in Hret.
move/eqP in Hret.
case: HSum => HSum; last first.
  have {}HSum : [ret ]_ s = zero32 by tauto.
  by rewrite HSum Z2uK in Hret.
split; by [tauto | ].

apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => HAB.

apply while.hoare_seq with (fun s h => exists A', size A' = nk /\
  [a ]_ s = va /\ [b ]_ s = vb /\ u2Z ([k ]_ s) = Z_of_nat nk /\
  [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B) s h /\
  \S_{ nk } A < \S_{ nk } B /\ [a3]_s = zero32 /\
  \S_{ nk } A' = \S_{ nk } B - \S_{ nk } A).

apply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = 1 /\
    (var_e a |--> slen :: ptr :: nil) s h )
  (fun s h => ([b ]_ s) = vb /\ ([X ]_ s) = ptr  /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    (var_e b |--> B ** var_e X |--> A) s h)
  (fun s h => exists A', size A' = nk /\
    [b ]_ s = vb /\ [X ]_ s = ptr /\ u2Z ([k ]_ s) = Z_of_nat nk/\
    [a3]_s = zero32 /\
    (var_e b |--> B ** var_e X |--> A') s h /\
    \S_{ nk } A' = \S_{ nk } B - \S_{ nk } A)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_sub_u_u_R_triple_B_le_A => //.
by Uniq_uniq r0.
exact/ltZW.

move=> s h [Ha [Hb [Hk [HX [HZsgn Hmem]]]]].
rewrite conAE in Hmem.
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h2 h1; last by [].
repeat (split => //).
rewrite conCE.
move: Hh2; apply monotony => h' //; exact: mapstos_ext.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh1 => A' [A'_nk [Hb [HX [Hk [Ha3 [Hh1 HSum]]]]]].
case: Hh2 => Ha [HZsgn Hh2].
exists A'; repeat (split => //).
rewrite conAE.
Compose_sepcon h2 h1; first by [].
rewrite conCE.
move: Hh1; apply monotony => h' //; exact: mapstos_ext.

apply (hoare_prop_m.extract_exists extract_exists0) => A'.

(** multi_negate_prg.negate a a0 *)

apply (before_frame
  (fun s h => size A' = nk /\ [a ]_ s = va /\ [b ]_ s = vb /\
    u2Z ([k ]_ s) = Z_of_nat nk /\ [X ]_ s = ptr /\ sgZ (s2Z slen) = 1 /\
    (var_e b |--> B) s h /\ \S_{ nk } B > \S_{ nk } A /\
    ([a3 ]_ s) = zero32 /\ \S_{ nk } A' = \S_{ nk } B - \S_{ nk } A)
  (var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A')
  (var_e a |--> cplt2 slen :: ptr :: nil ** int_e ptr |--> A')).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_negate_triple; by Uniq_uniq r0.

move=> s h [A'_nk [Ha [Hb [Hk [HX [Hsgn [Hmem [B_A [Ha3 HSum]]]]]]]]].
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
Compose_sepcon h1 h2; first by [].
repeat (split => //).
exact: Z.lt_gt.

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case : Hh2 => A'_nk [Ha [Hb [Hk [HX [HZsgn [Hh2 [B_A [Ha3 HSum']]]]]]]].
exists (cplt2 slen).
rewrite s2Z_cplt2; last first.
  rewrite weirdE2 slen_not_weird HZsgn; lia.
rewrite Zsgn_Zopp Ha3 Z2uK // mul0Z addZ0.
repeat (split => //).
rewrite slen_not_weird HZsgn mul1Z (proj2 (Zsgn_pos (Z_of_nat nk))) //; lia.
rewrite HZsgn mul1Z (proj2 (Zsgn_neg (\S_{ nk } A - \S_{ nk } B))) //; lia.
by Compose_sepcon h1 h2.
rewrite HZsgn mul1Z HSum'; ring.

(** addiu a3 r0 one16; *)

apply hoare_addiu with (fun s h => [a ]_ s = va /\ [b ]_ s = vb /\
  u2Z [k ]_ s = Z_of_nat nk /\ [X ]_ s = ptr /\ [a0 ]_ s = slen /\
  sgZ (s2Z slen) = - 1 /\ [a3]_s = one32 /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h).

move=> s h /= [[Ha [Hb [Hk [HX [Ha0 [Ha1' [Ha1'' Hmem]]]]]]] Ha1].
move/leZP in Ha1.
rewrite /wp_addiu.
repeat Reg_upd; repeat (split => //).
case: Ha1'' => Ha1''.
lia.
case: Ha1'' => Ha1''.
lia.
by rewrite -Ha1' Ha1''.
by rewrite add0i sext_Z2u.
Assert_upd.
move=> s' h' x v /= [] // ?; subst a3; by Reg_upd.

(** multi_add k a3 b X X a0 a1 a2 *)

apply while.hoare_seq with (fun s h => exists A' slen',
  size A' = nk /\ [a]_s = va /\ [b]_s = vb /\ s2Z slen' = sgZ (s2Z slen') * Z_of_nat nk /\
  sgZ (s2Z slen') = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> slen' :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B) s h /\
  u2Z (store.lo s) <= 1 /\
  sgZ (s2Z slen') * (\S_{ nk } A' + u2Z (store.lo s) * \B^nk) =
  sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B).

apply (before_frame
  (fun s h => [a ]_ s = va /\ sgZ (s2Z slen) = -1 /\
    (var_e a |--> slen :: ptr :: List.nil) s h)
  (fun s h => [a3]_s = one32 /\ [b ]_ s = vb /\ [X ]_ s = ptr /\
    u2Z ([k ]_ s) = Z_of_nat nk /\ (var_e b |--> B ** var_e X |--> A) s h)
  (fun s h => exists A', size A' = nk /\ [b ]_ s = vb /\ [X ]_ s = ptr /\
    (var_e b |--> B ** var_e X |--> A') s h/\ u2Z (store.lo s) <= 1 /\
    \S_{ nk } A' + u2Z (store.lo s) * \B^nk = \S_{ nk } B + \S_{ nk } A)).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
apply multi_add_u_u_triple => //; by Uniq_uniq r0.

move=> s h /= [Ha [Hb [Hk [HX [Ha0 [Ha1' [Ha3 Hmem]]]]]]].
case: Hmem => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
case: Hh1 => h11 [h12 [h11_d_h12 [h11_U_h12 [Hh11 Hh12]]]].
Compose_sepcon (h12 \U h2) h11.
repeat (split=> //).
Compose_sepcon h2 h12; first by [].
exact: assert_m.mapstos_ext Hh12.
by [].

move=> s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
case: Hh1 => A' [A'_nk [r_b [HX [Hh1 [Hm HSum]]]]].
case: Hh2 => Ha [HZsgn Hh2].
exists A', slen; repeat (split => //).
rewrite HZsgn mulN1Z (proj2 (Zsgn_neg (- \S_{ nk } A - \S_{ nk } B))) //.
move: (min_lSum nk A) => ?; lia.
rewrite conAE .
Compose_sepcon h2 h1; first by [].
rewrite conCE.
move: Hh1; apply assert_m.monotony => // h'; exact: assert_m.mapstos_ext.
rewrite HZsgn HSum; ring.

(** mflo a3 *)

apply hoare_mflo'.
move=> s h /= [A' [slen' [A'_nk [r_a [r_b [slen'_nk [HZsgn [Hmem [Hlo HSum]]]]]]]]].
rewrite /wp_mflo.
exists A', slen'.
repeat Reg_upd.
repeat (split => //).
Assert_upd.
move=> s' h' x v /= [] // ?; subst a3; by Reg_upd.
Qed.

Lemma multi_sub_s_u_triple : forall k a b a0 a1 a2 a3 a4 ret X,
uniq(k, a, b, a0, a1, a2, a3, a4, ret, X, r0) ->
forall nk va vb ptr, nk <> O -> Z_of_nat nk < 2 ^^ 31 ->
  u2Z ptr + 4 * Z_of_nat nk < \B^1 -> u2Z vb + 4 * Z_of_nat nk < \B^1 ->
forall A B, size A = nk -> size B = nk ->
forall slen, s2Z slen = sgZ (s2Z slen) * Z_of_nat nk ->
    sgZ (s2Z slen) = sgZ (sgZ (s2Z slen) * \S_{ nk } A) ->
{{ fun s h => [ a ]_s = va /\ [ b ]_s = vb /\ u2Z [ k ]_s = Z_of_nat nk /\
   ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h }}
multi_sub_s_u k a b a0 a1 a2 a3 a4 ret X
{{ fun s h => exists A', exists slen', size A' = nk /\ [a]_s = va /\ [b]_s = vb /\
  s2Z slen' = sgZ (s2Z slen') * Z_of_nat nk /\
  sgZ (s2Z slen') = sgZ (sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B) /\
  ((var_e a |--> slen' :: ptr :: nil ** int_e ptr |--> A') ** var_e b |--> B ) s h /\
  u2Z ([a3]_ s) <= 1 /\
  sgZ (s2Z slen') * (\S_{ nk } A' + u2Z ([a3]_s) * \B^nk) =
  sgZ (s2Z slen) * \S_{ nk } A - \S_{ nk } B }}.
Proof.
(* NB: similar to multi_add_s_u_triple *)
move=> k a b a0 a1 a2 a3 a4 ret X Hregs nk va vb ptr Hnk Hnk' ptr_fit vb_fit A B
  len_A len_B slen slen_no_weird valid_A.
rewrite /multi_sub_s_u.

(** multi_is_zero k b a0 a1 a2 *)

apply while.hoare_seq with (fun s h => [a]_s = va /\ [b]_s = vb /\
  u2Z [k]_s = Z_of_nat nk /\
  ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h /\
  ((0 = \S_{ nk } B -> [a2]_s = one32) /\ (0 < \S_{ nk } B -> [a2]_s = zero32))).

apply (before_frame
  (fun s h => [a ]_ s = va /\ (var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) s h)
  (fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [b]_s = vb /\ (var_e b |--> B) s h)
  (fun s h => u2Z [ k ]_s = Z_of_nat nk /\ [b]_s = vb /\ (var_e b |--> B) s h  /\
    ((0 = \S_{ nk } B -> [a2]_s = one32) /\ (0 < \S_{ nk } B -> [a2]_s = zero32)))).

apply frame_rule_R; last 2 first.
  by Inde_frame.
  move=> ?; by Inde_mult.
  apply multi_is_zero_u_triple => //; by Uniq_uniq r0.

move=> s h [Ha [Hb [Hk mem]]].
case: mem =>  h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
by Compose_sepcon h2 h1.

move => s h [h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]]].
repeat (split; first by tauto).
split; last by tauto.
Compose_sepcon h2 h1; tauto.

(** ifte (bne a2 r0) *)

apply while.hoare_ifte.

(** addiu a3 r0 zero16 *)

apply hoare_addiu'.
move=> s h [ [Ha [Hb [Hk [mem Hret]]]] Ha2].
rewrite /= in Ha2.
move/eqP in Ha2.
move: (min_lSum nk B).
case/Z_le_lt_eq_dec => Hsum.
apply (proj2 Hret) in Hsum.
by rewrite Hsum Z2uK // store.get_r0 Z2uK // in Ha2.
exists A, slen.
repeat Reg_upd; repeat (split => //).
rewrite -Hsum subZ0; exact valid_A.
by Assert_upd.
by rewrite sext_Z2u // addi0 Z2uK.
rewrite sext_Z2u // addi0 Z2uK // mul0Z addZ0 -Hsum; ring.

(** multi_sub_s_u0 k a b a0 a1 a2 a3 a4 ret X *)

apply hoare_prop_m.hoare_stren with (!(fun s => 0 < \S_{ nk } B) **
  (fun s h => [a ]_ s = va /\[b ]_ s = vb /\ u2Z [k ]_ s = Z_of_nat nk /\
    ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) ** var_e b |--> B) s h)).

move=> s h [[Ha [Hb [Hk [mem Hret]]]] Ha2].
rewrite /= negbK in Ha2.
move/eqP/u2Z_inj in Ha2.
move: (min_lSum nk B).
case/Z_le_lt_eq_dec => Hsum; last first.
 apply (proj1 Hret) in Hsum.
 rewrite Hsum store.get_r0 in Ha2.
 by apply Z2u_dis in Ha2.
by Compose_sepcon heap.emp h.

apply pull_out_bang => nk_B.
exact: multi_sub_s_u0_triple.
Qed.


Require Import Platform.AutoSep Platform.Wrap Platform.StringOps Platform.Malloc Platform.ArrayOps Platform.Buffers Platform.Bags.
Require Import Platform.SinglyLinkedList Platform.ListSegment Platform.RelDb Platform.RelDbCondition.

Set Implicit Arguments.

Local Hint Extern 1 (@eq W _ _) => words.

(** * Iterating over matching rows of a table *)

Opaque mult.
Local Infix ";;" := SimpleSeq : SP_scope.

Section Select.
  Variable A : Type.
  Variable invPre : A -> vals -> HProp.
  Variable invPost : A -> vals -> W -> HProp.

  Variable tptr : W.
  Variable sch : schema.

  (* Store a pointer to the current linked list node and actual row data, respectively,
   * in these variables. *)
  Variables rw data : string.

  (* Test to use in filtering rows *)
  Variable cond : condition.

  (* Run this command on every matching row. *)
  Variable body : chunk.

  Definition inv (V_rw V_data : W) := (Ex head, Ex done, Ex remaining, Ex p,
    tptr =*> head * lseg done head V_rw
    * (V_rw ==*> V_data, p) * sll remaining p
    * rows sch head done * rows sch head remaining
    * [| freeable V_rw 2 |] * [| V_rw <> 0 |])%Sep.

  Definition Select' : chunk := (
    rw <-* tptr;;

    [Al bs, Al a : A, Al head, Al done, Al remaining,
      PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
        * tptr =*> head * lseg done head (V rw) * sll remaining (V rw)
        * rows sch head done * rows sch head remaining * invPre a V
      POST[R] array8 bs (V "buf") * invPost a V R]
    While (rw <> 0) {
      data <-* rw;;

      Assert [Al bs, Al a : A, Al head, Al done, Al remaining,
        PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
          * [| V rw <> 0 |] * tptr =*> head * lseg done head (V rw) * sll (V data :: remaining) (V rw)
          * rows sch head remaining * rows sch head done * row sch (V data) * invPre a V
        POST[R] array8 bs (V "buf") * invPost a V R];;

      compileEqualities
      (fun a V => invPre a V
        * Ex head, Ex done, Ex remaining,
          [| V rw <> 0 |] * tptr =*> head * lseg done head (V rw) * sll (V data :: remaining) (V rw)
          * rows sch head remaining * rows sch head done)%Sep
      invPost
      sch data cond cond;;

      If ("matched" = 0) {
        Skip
      } else {
        body
      };;

      rw <-* rw + 4;;

      Assert [Al bs, Al a : A, Al head, Al done, Al remaining,
        PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
          * tptr =*> head * lseg_append (done ++ V data :: nil) head (V rw) * sll remaining (V rw)
          * rows sch head (done ++ V data :: nil) * rows sch head remaining * invPre a V
        POST[R] array8 bs (V "buf") * invPost a V R]
    }
  )%SP.

  Definition sinvar :=
    Al bs, Al a : A,
    PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
      * table sch tptr * invPre a V
    POST[R] array8 bs (V "buf") * invPost a V R.

  Definition spost :=
    Al bs, Al a : A,
    PRE[V] array8 bs (V "buf") * [| length bs = wordToNat (V "len") |] * [| inputOk V (exps cond) |]
      * row sch (V data) * inv (V rw) (V data) * invPre a V
    POST[R] array8 bs (V "buf") * invPost a V R.

  Notation svars := (rw :: data :: nil).

  Definition noOverlapExp (e : exp) :=
    match e with
      | Const _ => True
      | Input pos len => pos <> rw /\ pos <> data /\ len <> rw /\ len <> data
    end.

  Definition noOverlapExps := List.Forall noOverlapExp.

  Notation SelectVcs := (fun im ns res =>
    (~In "rp" ns) :: incl svars ns :: (rw <> "rp")%type :: (data <> "rp")%type
    :: incl baseVars ns
    :: (rw <> data)%type
    :: (forall a V V', (forall x, x <> rw -> x <> data
      -> x <> "ibuf" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> x <> "matched" -> sel V x = sel V' x)
      -> invPre a V ===> invPre a V')
    :: (forall a V V' R, (forall x, x <> rw -> x <> data
      -> x <> "ibuf" -> x <> "ilen" -> x <> "tmp"
      -> x <> "ipos" -> x <> "overflowed" -> x <> "matched" -> sel V x = sel V' x)
      -> invPost a V R = invPost a V' R)
    :: (forall pre mn H,
      (forall specs st, interp specs (pre st)
        -> interp specs (spost true (fun w => w) ns res st))
      -> vcs (VerifCond (toCmd body mn (im := im) H ns res pre)))
    :: (forall specs pre mn H st,
      (forall specs st, interp specs (pre st)
        -> interp specs (spost true (fun w => w) ns res st))
      -> interp specs (Postcondition (toCmd body mn (im := im) H ns res pre) st)
      -> interp specs (spost true (fun w => w) ns res st))
    :: "array8"!"equal" ~~ im ~~> ArrayOps.equalS
    :: (res >= 10)%nat
    :: wfEqualities ns sch cond
    :: ("matched" <> rw)%type
    :: ("matched" <> data)%type
    :: (data <> "ibuf")%type
    :: (data <> "overflowed")%type
    :: (data <> "ipos")%type
    :: (data <> "ilen")%type
    :: (data <> "tmp")%type
    :: (data <> "len")%type
    :: (data <> "buf")%type
    :: In data ns
    :: (rw <> "rp")%type
    :: (rw <> "ibuf")%type
    :: (rw <> "ipos")%type
    :: (rw <> "ilen")%type
    :: (rw <> "tmp")%type
    :: (rw <> "len")%type
    :: (rw <> "buf")%type
    :: (rw <> "overflowed")%type
    :: goodSize (length sch)
    :: noOverlapExps (exps cond)
    :: nil).

  Hint Immediate incl_refl.

  Theorem Forall_impl3 : forall A (P Q R S : A -> Prop) ls,
    List.Forall P ls
    -> List.Forall Q ls
    -> List.Forall R ls
    -> (forall x : A, P x -> Q x -> R x -> S x)
    -> List.Forall S ls.
    induction 1; inversion 1; inversion 1; auto.
  Qed.

  Theorem inputOk_weaken_params : forall ns V V' es,
    inputOk V es
    -> noOverlapExps es
    -> wfExps ns es
    -> (forall x, x <> rw -> x <> data -> sel V x = sel V' x)
    -> rw <> "len"
    -> data <> "len"
    -> inputOk V' es.
    intros; eapply Forall_impl3; [ apply H | apply H0 | apply H1 | ].
    intro e; destruct e; simpl; intuition idtac.
    repeat rewrite <- H2 by (simpl; congruence); assumption.
  Qed.

  Hint Extern 2 (inputOk _ _) => eapply inputOk_weaken_params; try eassumption;
    try (eapply wfEqualities_wfExps; eassumption); [ descend ].

  Ltac q :=
    repeat match goal with
             | [ H : interp ?x ?y, _ : context[Binop _ _ Plus (immInR (natToW 4) _)] |- _ ] =>
               apply compileEqualities_post in H; auto; intros;
                 try match goal with
                       | [ H : interp x y |- _ ] => clear H
                     end;
                 try match goal with
                       | [ |- context[_ ===> _] ] => intros;
                         match goal with
                           | [ H : importsGlobal _ |- _ ] => clear dependent H
                         end
                     end;
                 pre; prep; evalu;
                 try match goal with
                       | [ _ : _ = _ :: ?ls |- _ ] => do 4 eexists; exists ls
                     end
             | [ H : interp ?x ?y |- _ ] => apply compileEqualities_post in H; auto; intros;
               try match goal with
                     | [ H : interp x y |- _ ] => clear H
                   end
             | [ H : _ |- vcs _ ] => apply H; intros; pre; unfold inv
             | [ |- vcs _ ] => apply compileEqualities_vcs; auto; intros
             | [ H : interp _ (Postcondition (toCmd body _ _ _ _ _) _) |- _ ] =>
               invoke1; unfold inv in *
           end; t.

  Definition Select : chunk.
    refine (WrapC Select'
      sinvar
      sinvar
      SelectVcs
      _ _); abstract (wrap0; abstract q).
  Defined.
End Select.

Global Opaque inv.


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

(** * The whole compiler and its proof of semantic preservation *)

(** Libraries. *)
Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Globalenvs.
Require Import Smallstep.

Require Import compcert.cfrontend.Clight.
(*WE NEED THIS: Require Import VST.sepcomp.Clight_eff.*)

Require Import VST.ccc26x86.Asm.
Require Import VST.ccc26x86.Asm_eff.

Require Import VST.sepcomp.simulations.
Require Import VST.sepcomp.effect_semantics.

Axiom transf_clight_program : Clight.program -> res Asm.program.

(*WE NEED THIS:*) Axiom CL_core : Type.
(*WE NEED THIS:*) Axiom CL_eff_sem1 : @EffectSem (Genv.t Clight.fundef cfrontend.Ctypes.type) CL_core.

(* Axiomatization of Theorem 18, Compiler Correctness: *)
Axiom transf_clight_program_correct:
  forall p tp (LNR: list_norepet (map fst (prog_defs p))),
  transf_clight_program p = OK tp ->
  SM_simulation.SM_simulation_inject
    CL_eff_sem1 Asm_eff_sem (Genv.globalenv p) (Genv.globalenv tp).


From hahn Require Import Hahn.
Require Import PromisingLib.
From Promising Require Import Configuration TView View Time Event Cell Thread Memory.
From imm Require Import Events.
From imm Require Import Execution.
From imm Require Import Execution_eco.
From imm Require Import imm_s_hb.
From imm Require Import imm_s.
From imm Require Import imm_bob imm_s_ppo.

Require Import PArith.
From imm Require Import CombRelations.
From imm Require Import CombRelationsMore.

From imm Require Import TraversalConfig.
From imm Require Import Traversal.
From imm Require Import SimTraversal.

Require Import MaxValue.
Require Import ViewRel.
From imm Require Import ViewRelHelpers.
Require Import SimulationRel.
Require Import SimulationPlainStepAux.
Require Import SimulationRelAux.
Require Import MemoryAux.
Require Import SimState.

Set Implicit Arguments.

(* It's a version of Configuration.step which doesn't require
   consistency of the new configuration. *)
Inductive plain_step :
  forall (e:option Event.t) (tid:Ident.t)
         (c1 c2:Configuration.t), Prop :=
| plain_step_intro
    pf e tid c1 lang st1 lc1 e2 st3 lc3 sc3 memory3
    (TID: IdentMap.find tid c1.(Configuration.threads) = Some (existT _ lang st1, lc1))
    (STEPS: rtc (@Thread.tau_step _) (Thread.mk _ st1 lc1 c1.(Configuration.sc) c1.(Configuration.memory)) e2)
    (STEP: Thread.step pf e e2 (Thread.mk _ st3 lc3 sc3 memory3)):
    plain_step (ThreadEvent.get_event e) tid c1 (Configuration.mk (IdentMap.add tid (existT _ _ st3, lc3) c1.(Configuration.threads)) sc3 memory3)
.

Lemma pair_app :
  forall (A B : Prop), A -> (A -> A /\ B) -> A /\ B.
Proof using. ins. intuition. Qed.

Section PlainStepBasic.

Variable G : execution.
Variable WF : Wf G.
Variable sc : relation actid.
Variable CON : imm_consistent G sc.

Notation "'E'" := G.(acts_set).
Notation "'sb'" := G.(sb).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).

Notation "'fr'" := G.(fr).
Notation "'coe'" := G.(coe).
Notation "'coi'" := G.(coi).
Notation "'deps'" := G.(deps).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'detour'" := G.(detour).
Notation "'hb'" := G.(hb).
Notation "'sw'" := G.(sw).

Notation "'lab'" := G.(lab).
(* Notation "'loc'" := (loc lab). *)
(* Notation "'val'" := (val lab). *)
(* Notation "'mod'" := (mod lab). *)
(* Notation "'same_loc'" := (same_loc lab). *)

Notation "'R'" := (fun a => is_true (is_r lab a)).
Notation "'W'" := (fun a => is_true (is_w lab a)).
Notation "'F'" := (fun a => is_true (is_f lab a)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).

Notation "'Pln'" := (fun a => is_true (is_only_pln lab a)).
Notation "'Rlx'" := (fun a => is_true (is_rlx lab a)).
Notation "'Rel'" := (fun a => is_true (is_rel lab a)).
Notation "'Acq'" := (fun a => is_true (is_acq lab a)).
Notation "'Acqrel'" := (fun a => is_true (is_acqrel lab a)).
Notation "'Acq/Rel'" := (fun a => is_true (is_ra lab a)).
Notation "'Sc'" := (fun a => is_true (is_sc lab a)).

Notation "'Loc_' l" := (fun x => loc lab x = Some l) (at level 1).
Notation "'W_ex'" := G.(W_ex).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).

Definition msg_preserved memory memory' :=
  forall loc ts from msg (INMEM : Memory.get loc ts memory = Some (from, msg)),
    exists from', Memory.get loc ts memory' = Some (from', msg).

Definition msg_preserved_refl memory : msg_preserved memory memory.
Proof using. red. ins. eauto. Qed.

Definition msg_preserved_add memory memory' loc from to val released
           (ADD : Memory.add memory loc from to val released memory') :
  msg_preserved memory memory'.
Proof using. red. ins. exists from0. eapply memory_add_le; eauto. Qed.

Definition msg_preserved_split memory memory'
           loc ts1 ts2 ts3 val2 val3 released2 release3
           (SPLIT : Memory.split
                      memory loc ts1 ts2 ts3
                      val2 val3 released2 release3 memory'):
  msg_preserved memory memory'.
Proof using.
  red. ins.
  erewrite Memory.split_o; eauto.
  edestruct Memory.split_get0 as [HH BB]; eauto.
  destruct (loc_ts_eq_dec (loc0, ts) (loc, ts2)) as [EQ|NEQ].
  { simpls. desf. rewrite HH in INMEM. desf. }
  simpls.
  destruct (loc_ts_eq_dec (loc0, ts) (loc, ts3)) as [EQ|NNEQ].
  { simpls. desf. rewrite BB in INMEM. inv INMEM. eauto. }
  eauto.
Qed.

Lemma full_simrel_step thread PC PC' T T' label f_to f_from
      (COVE  : covered T' ⊆₁ E)
      (ISSE  : issued  T' ⊆₁ E)
      (COVIN : covered T ⊆₁ covered T')
      (ISSIN : issued T ⊆₁ issued T')
      (NINCOV : covered T' \₁ covered T ⊆₁ Tid_ thread)
      (NINISS : issued  T' \₁ issued  T ⊆₁ Tid_ thread)
      (PCSTEP : plain_step label thread PC PC')
      (CLOSED_PRES :
         closedness_preserved PC.(Configuration.memory) PC'.(Configuration.memory))
      (MSG_PRES :
         msg_preserved PC.(Configuration.memory) PC'.(Configuration.memory))
      (TPEQ : forall thread,
          IdentMap.In thread PC.(Configuration.threads) <->
          IdentMap.In thread PC'.(Configuration.threads))
      (SIMREL_THREAD : simrel_thread G sc PC' thread T' f_to f_from sim_normal)
      (SIMREL : simrel G sc PC T f_to f_from) :
  simrel G sc PC' T' f_to f_from.
Proof using WF.
  red. splits; auto.
  { apply SIMREL_THREAD. }
  cdes SIMREL.
  intros thread' TP'.
  destruct (Ident.eq_dec thread thread') as [|NEQ]; subst.
  { apply SIMREL_THREAD. }
  assert (IdentMap.In thread' PC.(Configuration.threads)) as TP.
  { by apply TPEQ. }
  specialize (THREADS thread' TP).
  cdes THREADS.
  assert (IdentMap.find thread' (Configuration.threads PC') =
          Some (existT _ (PromiseLTS.thread_lts thread') state,
                local)) as TID.
  { destruct PCSTEP. simpls. rewrite IdentMap.gso; auto. }
  assert
  (forall a : actid, tid a = thread' -> covered T' a -> covered T a) as PP.
  { intros a TT YY.
    destruct (classic (covered T a)) as [GG|GG]; [done|].
    exfalso.
    assert (tid a = thread) as RR; [|by subst].
    by apply NINCOV; split. }
  cdes SIMREL_THREAD. cdes COMMON. cdes LOCAL.
  red; splits; simpls.
  rewrite TID.
  exists state; exists local; splits; auto.
  2: { red. ins.
       edestruct SIM_PROM as [w H]; eauto.
       des. exists w; splits; auto. }
  5: { eapply sim_state_other_thread_step; eauto; desf. }
  4: { by red; splits; ins; apply CLOSED_PRES; apply MEM_CLOSE. }
  3: { destruct T as [C I]. destruct T' as [C' I'].
       eapply sim_tview_other_thread_step.
       2: by apply COVIN.
       all: eauto.
       etransitivity; [apply TCCOH|]. done. }
  { clear TNNULL0 TNNULL.
    ins. destruct (classic (thread'0 = thread)) as [|TNEQ']; subst.
    { apply or_comm. cdes SIMREL_THREAD.
      rewrite LLH0 in TID'. inv TID'. clear TID'.
      eapply PROM_DISJOINT0; eauto. }
    assert (IdentMap.find thread'0 (Configuration.threads PC) = Some (langst', local'))
      as TT.
    { destruct PCSTEP. simpls. rewrite IdentMap.gso in TID'; auto. }
    eapply PROM_DISJOINT; eauto. }
  red. ins. unnw.
  edestruct SIM_MEM0 as [rel]; eauto.
  simpls; desc.
  exists rel; splits; auto.
  intros BTID.
  assert (~ covered T' b <-> ~ covered T b) as CCB.
  { split; intros CC1 CC2.
      by apply COVIN in CC2.
      assert (tid b = thread) as TT.
      2: by subst; desf.
        by apply NINCOV; split. }
  assert (issued T' b <-> issued T b) as IIB.
  { split; auto.
    intros II.
    destruct (classic (issued T b)) as [|NN]; [done|].
    assert (tid b = thread) as TT.
    2: by subst; desf.
      by apply NINISS; split. }
  rewrite CCB.
  edestruct SIM_MEM as [rel']; eauto.
  { by apply IIB. }
  simpls; desc.
  intros CC.
  destruct H2; auto.
  assert (rel' = rel); [|subst; split; vauto].
  { cdes COMMON0. eapply PROM_IN_MEM0 in H; eauto.
    rewrite INMEM in H. inv H. }
  destruct H0 as [p_rel H0]; desc.
  eexists; split; eauto.
  desf.
  { left; splits; auto.
    intros [y HH]. apply NINRMW.
    exists y. apply seq_eqv_l in HH; destruct HH as [ISSY HH].
    apply seq_eqv_l; split; auto.
    destruct (classic (issued T y)) as [|NISS]; [done|exfalso].
    destruct (classic (tid y = thread)) as [|TNEQ]; subst.
    2: by apply TNEQ; apply NINISS; split.
    assert ((rfe ⨾ rmw) y b) as RFERMW.
    2: { apply NISS.
         apply IIB in ISSB. apply TCCOH in ISSB.
         apply ISSB.
         exists b; apply seq_eqv_r; split; auto.
         destruct RFERMW as [oo [RFE RMW]].
         apply (dom_l WF.(wf_rfeD)) in RFE.
         apply seq_eqv_l in RFE. destruct RFE as [WY RFE].
         apply seq_eqv_l. split; auto.
         apply ct_step. right.
         exists oo. split; [by apply RFE|].
           by apply rmw_in_ppo_loc. }
    hahn_rewrite rfi_union_rfe in HH. hahn_rewrite seq_union_l in HH.
    destruct HH as [HH|]; [exfalso|done].
    assert (W y) as WY.
    { cdes COMMON0. by apply TCCOH0. }
    assert (~ is_init y) as NIN.
    { intros DD. apply NISS. eapply w_covered_issued; eauto.
      split; auto. apply TCCOH.
      split; auto. }
    assert (sb y b) as SBYB.
    { edestruct HH as [z [RFI RMW]].
      eapply (@sb_trans G); [by apply WF.(rfi_in_sbloc'); eauto|].
        by apply WF.(rmw_in_sb). }
    edestruct (sb_tid_init SBYB); desf. }
  right. exists p; splits; auto.
  assert (issued T' p) as ISSP'.
  { apply ISSIN. apply ISSP. }
  assert (loc lab p = Some l) as LOCP.
  { simpls. erewrite wf_rfrmwl; eauto. }
  assert (exists p_v', val lab p = Some p_v') as [p_v' VALP].
  { apply WF.(wf_rfrmwD) in INRMW.
    unfold val, is_w in *. desf.
    all: eexists; eauto. }
  eapply MSG_PRES in P_INMEM. desc.
  edestruct (SIM_MEM0 l) as [p_rel''].
  { cdes COMMON0. apply TCCOH0. apply ISSP'. }
  all: eauto; simpls.
  desc.
  rewrite P_INMEM in INMEM1. inv INMEM1.
  eexists; eexists; splits; eauto.
Qed.

Lemma max_event_cur PC T f_to f_from l e thread foo local smode
      (SIMREL_THREAD : simrel_thread G sc PC thread T f_to f_from smode)
      (NEXT : next G (covered T) e)
      (TID_E : tid e = thread)
      (LOC : loc lab e = Some l)
      (TID: IdentMap.find thread PC.(Configuration.threads) = Some (foo, local)):
  exists p_max,
    ⟪ NEQ : p_max <> e ⟫ /\
    ⟪ CCUR : urr G sc l p_max e ⟫ /\
    ⟪ LB : Time.le
      (View.rlx (TView.cur (Local.tview local)) l)
      (f_to p_max) ⟫.
Proof using WF CON.
  cdes SIMREL_THREAD. cdes COMMON. cdes LOCAL.
  red in SIM_TVIEW; desf.
  red in CUR; desf.
  specialize (CUR l); red in CUR; desc.

  assert (E e) as EE.
  { apply NEXT. }
  assert (~ is_init e) as NINE.
  { intros HH. apply NEXT. by apply TCCOH. }

  destruct MAX as [[MAX MAX'] | MAX].
  { unfold LocFun.find in MAX'.
    rewrite MAX'; ins.
    exists (InitEvent l); splits; [ | | by apply Time.bot_spec].
    { intros H; subst; simpls. }
    apply hb_in_urr.
    apply seq_eqv_l; split; red; [|right].
    { by unfold is_w, loc; rewrite WF.(wf_init_lab). }
    apply sb_in_hb.
    apply init_ninit_sb; auto.
    apply WF.(wf_init). eexists; eauto. }
  desf.
  exists a_max. apply and_assoc; split; auto.
  red in INam; red in INam.
  destruct INam as [y CCUR].
  red in CCUR; hahn_rewrite <- seqA in CCUR.
  apply seq_eqv_r in CCUR; destruct CCUR as [CCUR Y'].
  apply seq_eqv_r in CCUR; destruct CCUR as [CCUR Y].
  assert (hb y e) as HBYE.
  { apply sb_in_hb.
    assert (E y) as EY.
    { eapply (@coveredE G) in Y'; eauto. }
    destruct Y as [Y | Y].
    2: by apply init_ninit_sb.
    destruct (same_thread G e y) as [[ZZ|ZZ]|ZZ]; subst; auto.
    { by apply NEXT in Y'. }
    exfalso.
    assert (covered T e) as Z.
    { apply TCCOH in Y'.
      apply Y'. eexists; apply seq_eqv_r; split; eauto. }
      by apply NEXT in Z. }
  assert ((urr G sc l ⨾ hb) a_max e) as UH.
  { exists y; split; auto. }
  splits.
  { intros H; subst; eapply urr_hb_irr; eauto.
    all: apply CON. }
  apply urr_hb.
  destruct UH as [z [UH HH]].
  eexists; split; eauto.
Qed.

End PlainStepBasic.


Require Import Coq.omega.Omega.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Eq.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.ListMapT.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.Util.HListBuild.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Instantiate.

Set Implicit Arguments.
Set Strict Implicit.

Polymorphic Inductive hlist_Forall2@{A B C}
            {T : Type@{A}} (F : T -> Type@{B}) (G : T -> Type@{C}) (P : forall t, F t -> G t -> Prop)
: forall ls, hlist F ls -> hlist G ls -> Prop :=
| hlist_Forall2_nil : hlist_Forall2 P Hnil Hnil
| hlist_Forall2_cons : forall l ls x xs y ys,
                         @P l x y ->
                         hlist_Forall2 (ls := ls) P xs ys ->
                         hlist_Forall2 P (Hcons x xs) (Hcons y ys).

Section subst.
  Variable T : Type.
  Variable typ : Set.
  Variable expr : Set.
  Context {RType_type : RType typ}.
  Context {RTypeOk_type : RTypeOk}.
  Context {Expr_expr : Expr _ expr}.
  Context {ExprOk_expr : ExprOk _}.

  Class Subst :=
  { subst_lookup : uvar -> T -> option expr
  ; subst_domain : T -> list uvar
  }.

  Class SubstOk (S : Subst) : Type :=
  { WellFormed_subst : T -> Prop
  ; substD : forall (tus tvs : tenv typ), T -> option (exprT tus tvs Prop)
  ; substD_lookup
    : forall s uv e,
        WellFormed_subst s ->
        subst_lookup uv s = Some e ->
        forall tus tvs sD,
          substD tus tvs s = Some sD ->
          exists t val get,
            nth_error_get_hlist_nth _ tus uv = Some (@existT _ _ t get) /\
            exprD tus tvs t e = Some val /\
            forall us vs,
              sD us vs ->
              get us = val us vs
  ; WellFormed_domain : forall s ls,
      WellFormed_subst s ->
      subst_domain s = ls ->
      (forall n, In n ls <-> subst_lookup n s <> None)
  ; lookup_normalized : forall s e u,
      WellFormed_subst s ->
      subst_lookup u s = Some e ->
      forall u' e',
        subst_lookup u' s = Some e' ->
        mentionsU u' e = false
  }.

  Class SubstUpdate :=
  { subst_set : uvar -> expr -> T -> option T
  }.

  Class SubstUpdateOk (S : Subst) (SU : SubstUpdate) (SOk : SubstOk S) :=
  { substR : forall (tus tvs : tenv typ), T -> T -> Prop
  ; Reflexive_substR :> forall tus tvs, Reflexive (substR tus tvs)
  ; Transitive_substR :> forall tus tvs, Transitive (substR tus tvs)
  ; set_sound
      (** TODO(gmalecha): This seems to need to be rephrased as well **)
    : forall uv e s s',
        subst_set uv e s = Some s' ->
        WellFormed_subst s ->
        WellFormed_subst s' /\
        (subst_lookup uv s = None -> (* How important is this? *)
         forall tus tvs t val get sD,
           substD tus tvs s = Some sD ->
           nth_error_get_hlist_nth typD tus uv = Some (@existT _ _ t get) ->
           exprD tus tvs t e = Some val ->
           exists sD',
             substD tus tvs s' = Some sD' /\
             substR tus tvs s s' /\
             forall us vs,
               sD' us vs <->
               (sD us vs /\ get us = val us vs))
  }.

  Class SubstOpen : Type :=
  { subst_drop : uvar -> T -> option T
  ; subst_weakenU : nat -> T -> T
  }.

  Fixpoint models (tus tvs : tenv typ) (tus' : tenv typ) (es : list (option expr))
  : option (hlist typD tus' -> exprT tus tvs Prop) :=
    match tus' as tus' , es
          return option (hlist typD tus' -> exprT tus tvs Prop)
    with
      | nil , nil => Some (fun _ _ _ => True)
      | tu' :: tus' , None :: es =>
        match models (tus ++ tu' :: nil) tvs tus' es with
          | None => None
          | Some x => Some (fun h us vs =>
                              x (hlist_tl h) (hlist_app us (Hcons (hlist_hd h) Hnil)) vs)
        end
      | tu' :: tus' , Some e :: es =>
        match models (tus ++ tu' :: nil) tvs tus' es with
          | None => None
          | Some x =>
            match exprD (tus ++ tu' :: tus') tvs tu' e with
              | None => None
              | Some eD =>
                Some (fun h us vs =>
                           hlist_hd h = eD (hlist_app us h) vs
                        /\ x (hlist_tl h) (hlist_app us (Hcons (hlist_hd h) Hnil)) vs)
            end
        end
      | _ , _ => None
    end.

  Class SubstOpenOk (S : Subst) (SO : SubstOk S) (OS : SubstOpen) : Type :=
  { drop_sound
    : forall s s' u,
        subst_drop u s = Some s' ->
        WellFormed_subst s ->
        WellFormed_subst s' /\
        exists e,
          subst_lookup u s = Some e /\
          subst_lookup u s' = None /\
          (forall u', u' <> u -> subst_lookup u' s = subst_lookup u' s') /\
          forall tus tu tvs sD,
            u = length tus ->
            substD (tus ++ tu :: nil) tvs s = Some sD ->
            exists sD',
              substD tus tvs s' = Some sD' /\
              exists eD,
                exprD tus tvs tu e = Some eD /\
                forall us vs,
                  sD' us vs <->
                  sD (hlist_app us (Hcons (eD us vs) Hnil)) vs
  ; substD_weakenU
    : forall n s s',
        subst_weakenU n s = s' ->
        forall tus tvs tus' sD,
          n = length tus' ->
          substD tus tvs s = Some sD ->
          exists sD',
            substD (tus ++ tus') tvs s' = Some sD' /\
            forall us us' vs,
              sD us vs <-> sD' (hlist_app us us') vs
  }.

  Context {Subst_subst : Subst}.
  Context {SubstOk_subst : SubstOk Subst_subst}.
  Context {SubstUpdate_subst : SubstUpdate}.
  Context {SubstUpdateOk_subst : SubstUpdateOk SubstUpdate_subst SubstOk_subst}.
  Context {SubstOpen_subst : SubstOpen}.
  Context {SubstOpenOk_subst : @SubstOpenOk _ _ _}.

  Lemma substD_conv
  : forall tus tus' tvs tvs' (pfu : tus' = tus) (pfv : tvs' = tvs) s,
      substD tus tvs s =
      match pfu in _ = u' return option (exprT u' _ Prop) with
        | eq_refl =>
          match pfv in _ = v' return option (exprT _ v' Prop) with
            | eq_refl => substD tus' tvs' s
          end
      end.
  Proof.
    clear. destruct pfu. destruct pfv. reflexivity.
  Qed.

  Fixpoint all_Some (ls : list (option expr)) : bool :=
    match ls with
    | nil => true
    | None :: _ => false
    | Some _ :: ls => all_Some ls
    end.

  Fixpoint all_defined (from : uvar) (len : nat) (s : T) : bool :=
    match len with
    | 0 => true
    | S len =>
      match subst_lookup from s with
      | None => false
      | Some _ => all_defined (S from) len s
      end
    end.

  (** This is the "obvious" extension of [drop] **)
  Fixpoint subst_pull (from : uvar) (len : nat) (s : T) : option T :=
    match len with
    | 0 => Some s
    | S len' => match subst_pull (S from) len' s with
               | None => None
               | Some s' => subst_drop from s'
               end
    end.

  Fixpoint seq (start : nat) (len : nat) : list nat :=
    match len with
    | 0 => nil
    | S len => start :: seq (S start) len
    end.

  Lemma getInstantiation_syntactic
  : forall (s : T) tus tvs t (e : expr) sD,
      subst_lookup (length tus) s = Some e ->
      WellFormed_subst s ->
      substD (tus ++ t :: nil) tvs s = Some sD ->
      exists eD,
        exprD tus tvs t e = Some eD /\
        forall us vs x,
          sD (hlist_app us (Hcons x Hnil)) vs ->
          x = eD us vs.
  Proof.
    intros.
    eapply substD_lookup in H1; eauto.
    forward_reason.
    eapply exprD_strengthenU_single in H2; eauto.
    { forward_reason.
      eapply nth_error_get_hlist_nth_appR in H1; simpl in *; try omega.
      rewrite Minus.minus_diag in H1.
      forward_reason; inv_all; subst.
      eexists; split; eauto.
      intros. eapply H3 in H1; clear H3.
      rewrite H4 in H1. rewrite H5 in H1. subst.
      assumption. }
    { apply (@lookup_normalized _ _ _ _ _ H0 H _ _ H). }
  Qed.

(*
  Lemma getInstantiation_syntactic_multi
  : forall (s : T) (tus tvs ts : tenv typ) (es : list expr) sD,
      mapT (fun u => subst_lookup u s) (seq (length tus) (length ts)) = Some es ->
      WellFormed_subst s ->
      substD (tus ++ ts) tvs s = Some sD ->
      exists esD : hlist@{Set Urefl} (fun t => exprT tus tvs (typD t)) ts,
        @hlist_build_option typ (fun t => exprT tus tvs (typD t)) expr
                     (fun t e => exprD tus tvs t e) ts es = Some esD /\
        forall (us : hlist@{Set Urefl} _ _)
          (vs : hlist@{Set Urefl} _ _)
          (us' : hlist@{Set Urefl} (fun _ : typ => _) ts),
          sD (hlist_app us (hlist_map (fun t (x : exprT tus tvs (typD t)) => x us vs) us')) vs ->
          hlist_Forall2 (fun t (x : exprT tus tvs (typD t))
                             (y : exprT tus tvs (typD t)) =>
                           x us vs = y us vs) us' esD.
  Proof.
  Abort.
*)

  Theorem pull_sound
  : forall n s s' u,
      subst_pull u n s = Some s' ->
      WellFormed_subst s ->
      WellFormed_subst s' /\
      forall (tus tus' tvs : tenv typ) sD,
        u = length tus ->
        n = length tus' ->
        substD (tus ++ tus') tvs s = Some sD ->
        exists eus',
          mapT (fun u => subst_lookup u s) (seq u n) = Some eus' /\
          (forall u', u' < u \/ u' > u + n -> subst_lookup u' s = subst_lookup u' s') /\
          (forall u', u' < n -> subst_lookup (u + u') s' = None) /\
        exists sD',
          substD tus tvs s' = Some sD' /\
          exists us' : hlist@{Set Urefl} (fun t => hlist typD tus -> hlist typD tvs -> typD t) tus',
            @hlist_build_option _ _ _ (fun t e => exprD tus tvs t e) tus' eus' = Some us' /\
            forall us vs,
              let us' := hlist_map (fun t (x : hlist typD tus -> hlist typD tvs -> typD t) => x us vs) us' in
              sD' us vs <->
              sD (hlist_app us us') vs.
  Proof.
    Opaque mapT.
    induction n.
    { intros. simpl in *.
      inv_all. subst.
      split; auto.
      intros. subst.
      destruct tus'; try solve [ simpl in * ; congruence ].
      clear H1.
      exists nil. split; [ reflexivity | ].
      split; try reflexivity.
      split; [ inversion 1 | ].
      rewrite substD_conv with (pfu := eq_sym (app_nil_r_trans tus)) (pfv := eq_refl) in H2.
      autorewrite_with_eq_rw_in H2.
      forward.
      eexists; split; eauto.
      simpl. eexists; split; eauto.
      inv_all. subst.
      simpl. intros. rewrite hlist_app_nil_r.
      autorewrite with eq_rw. reflexivity. }
    { simpl. intros. forward.
      eapply IHn in H; clear IHn; auto.
      forward_reason.
      eapply drop_sound in H1; auto.
      forward_reason; split; auto.
      intros; subst.
      rewrite list_mapT_cons.
      destruct tus'; try solve [ simpl in *; congruence ].
      specialize (H2 (tus ++ t0 :: nil) tus' tvs).
      rewrite substD_conv with (pfv := eq_refl)
                               (pfu := app_ass_trans tus (t0 :: nil) tus') in H9.
      autorewrite_with_eq_rw_in H9.
      forwardy.
      assert (S (length tus) = length (tus ++ t0 :: nil)).
      { rewrite app_length. simpl. omega. }
      assert (n = length tus').
      { simpl in *; congruence. }
      specialize (H2 _ H10 H11 H7); clear H10 H11.
      forward_reason.
      rewrite H10 by omega. rewrite H3.
      change_rewrite H2.
      eexists; split; eauto.
      split; [ | split ].
      { destruct 1.
        { rewrite H10; eauto. rewrite H5 by omega. reflexivity. }
        { rewrite H10 by omega. rewrite H5 by omega. reflexivity. } }
      { intros. destruct u'.
        { replace (length tus + 0) with (length tus) by omega.
          assumption. }
        { replace (length tus + S u') with (S (length tus) + u') by omega.
          rewrite <- H5 by omega.
          eapply H11. omega. } }
      { specialize (H6 tus _ tvs _ eq_refl H12).
        forward_reason.
        eexists; split; eauto.
        simpl. rewrite H15.
        assert (exists us',
                  hlist_build_option
                    (fun t1 : typ =>
                       hlist typD tus -> hlist typD tvs -> typD t1)
                    (fun (t1 : typ) (e : expr) => exprD tus tvs t1 e) tus' x0 = Some us' /\
                  forall us vs val,
                    hlist_Forall2 (fun (t : typ)
                                       (x : hlist typD tus -> hlist typD tvs -> typD t)
                                       (y : hlist typD (tus ++ _ :: nil) -> hlist typD tvs -> typD t) =>
                                     x us vs = y (hlist_app us (Hcons val Hnil)) vs) us' x2).
        { clear H14. generalize dependent x2.
          assert (forall e, In e x0 ->
                            mentionsU (length tus) e = false).
          { intros.
            eapply mapT_In in H13; try eassumption.
            simpl in H13.
            forward_reason.
            eapply lookup_normalized.
            2: eassumption. eassumption.
            rewrite <- H10 in H3. eapply H3.
            left. omega. }
          generalize tus'. clear H7 H2.
          induction x0.
          { intros. destruct tus'0; simpl in *; try congruence.
            inv_all; subst. eexists; split; eauto.
            intros. constructor. }
          { intros. destruct tus'0; simpl in *; try congruence.
            forwardy. inv_all; subst.
            eapply IHx0 in H2; eauto.
            forward_reason.
            change_rewrite H2.
            assert (exists val, exprD tus tvs t1 a = Some val /\
                                forall us vs v,
                                  val us vs = y1 (hlist_app us (Hcons v Hnil)) vs).
            { eapply exprD_strengthenU_single in H7; eauto.
              forward_reason. eauto. }
            forward_reason. rewrite H9.
            eexists; split; eauto. intros.
            constructor; eauto. } }
        { forward_reason.
          change_rewrite H17.
          eexists; split; eauto.
          intros.
          inv_all; subst. clear H10 H11.
          rewrite H16; clear H16.
          rewrite H14; clear H14.
          simpl.
          rewrite hlist_app_assoc. simpl.
          autorewrite with eq_rw.
          match goal with
            | |- _ ?X _ <-> _ ?Y _ =>
              cutrewrite (X = Y); try reflexivity
          end.
          apply match_eq_match_eq.
          f_equal. f_equal.
          revert H13 H17.
          specialize (H18 us vs (x4 us vs)).
          clear - H18.
          generalize dependent x0.
          revert H18; revert x2; revert x5; revert tus'.
          refine (@hlist_Forall2_ind _ _ _ _ _ _ _).
          { simpl. reflexivity. }
          { simpl; intros.
            destruct x0; try congruence.
            specialize (H1 x0).
            repeat match goal with
                     | H : context [ ?X ] , H' : match ?Y with _ => _ end = _ |- _ =>
                       change Y with X in H' ; destruct X ; try congruence
                   end.
            forwardy. inv_all. subst.
            rewrite H1; auto. rewrite H. reflexivity. } } } }
  Qed.

  Lemma In_seq : forall a c b,
      In a (seq b c) <-> (b <= a /\ a < b + c).
  Proof.
    clear.
    induction c; simpl; intros.
    { split. destruct 1. intros. omega. }
    { split; intros.
      { destruct H. subst. omega. eapply IHc in H. omega. }
      { consider (b ?[ eq ] a).
        { intros. subst; auto. }
        { right. eapply IHc. omega. } } }
  Qed.

  Lemma sem_preserves_if_substD
  : forall tus tvs s sD,
      WellFormed_subst s ->
      substD tus tvs s = Some sD ->
      sem_preserves_if_ho (fun P => forall us vs, sD us vs -> P us vs)
                          (fun u => subst_lookup u s).
  Proof.
    red. intros.
    eapply substD_lookup in H1; eauto.
    forward_reason.
    change_rewrite H2 in H1.
    inv_all; subst.
    eapply nth_error_get_hlist_nth_Some in H2.
    forward_reason. simpl in *.
    eexists; split; eauto.
  Qed.

End subst.

Arguments SubstOk T typ expr {_ _ _}.
Arguments SubstUpdateOk T typ expr {_ _ _ _ _}.
Arguments subst_pull {T SO} _ _ _ : rename.


(******************************************************************************)
(* A bit library for Coq: extraction to machine words.                        *)
(******************************************************************************)
(*                                                                            *)
(* (c) 2016, ENS Lyon, LIP6, MINES ParisTech                                  *)
(*                                                                            *)
(* Written by Arthur Blot                                                     *)
(*            Pierre-Evariste Dagand                                          *)
(*            Emilio J. Gallego Arias                                         *)
(*                                                                            *)
(* LICENSE: Dual CECILL-B / Apache 2.0                                        *)
(*                                                                            *)
(******************************************************************************)

From mathcomp
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype.

From mathcomp
Require Import tuple ssralg ssrnum zmodp.

From CoqEAL
Require Import hrel param refinements.

From ssrbit
Require Import bitseq notation.

From Coq
Require Import ZArith.ZArith ExtrOcamlBasic.

Import Refinements.Op.
Import Logical.Op.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * An axiomatization of OCaml native integers *)

(** This module should not be used directly. *)
Module Native.

(** We assume that we are running on a 64 bit machine. *)
Axiom Int : Type.
Axiom eq  : Int -> Int -> bool.

Axiom zero : Int.
Axiom one  : Int.
Axiom opp  : Int -> Int.
Axiom sub  : Int -> Int -> Int.
Axiom add  : Int -> Int -> Int.

Axiom lnot : Int -> Int.
Axiom lor  : Int -> Int -> Int.
Axiom land : Int -> Int -> Int.
Axiom lxor : Int -> Int -> Int.
Axiom lsr  : Int -> Int -> Int.
Axiom lsl  : Int -> Int -> Int.

Extract Inlined Constant Int  => "int".
Extract Inlined Constant eq   => "(=)".
Extract Inlined Constant zero => "0".
Extract Inlined Constant one  => "1".
Extract Inlined Constant lor  => "(lor)".
Extract Inlined Constant land => "(land)".
Extract Inlined Constant lsr  => "(lsr)".
Extract Inlined Constant lxor => "(lxor)".

(** One must be careful to re-normalize the following operations when
using them at smaller wordsize: *)

Extract Inlined Constant lsl  => "(lsl)".
Extract Inlined Constant lnot => "lnot".
Extract Inlined Constant add  => "(+)".
Extract         Constant opp  => "(fun x -> -x)".
Extract Inlined Constant sub  => "(-)".

End Native.

Import Native.

Global Instance   eq_Native : eq_of   Int := eq.

Global Instance zero_Native : zero_of Int := zero.
Global Instance  one_Native : one_of  Int := one.
Global Instance  opp_Native : opp_of  Int := opp.
Global Instance  sub_Native : sub_of  Int := sub.
Global Instance  add_Native : add_of  Int := add.

Global Instance  not_Native : not_of  Int := lnot.
Global Instance   or_Native : or_of   Int := lor.
Global Instance  and_Native : and_of  Int := land.
Global Instance  xor_Native : xor_of  Int := lxor.
Global Instance  shl_Native : shl_of  Int Int := lsl.
Global Instance  shr_Native : shr_of  Int Int := lsr.

Section BitExtract.

Variable n : nat.
Implicit Types (s : bitseq) (b : 'B_n).

Fixpoint bitsToInt s : Int :=
  (match s with
    | [::]           => 0
    | [:: false & s] =>      bitsToInt s :<<: 1
    | [:: true  & s] => 1 || (bitsToInt s :<<: 1)
  end)%C.

Fixpoint bitsFromInt (k: nat) (n: Int) : bitseq :=
  (match k with
    | 0 => [::]
    | k.+1 =>
      let p := bitsFromInt k (n :>>: 1) in
      ((n && 1) == 1) :: p
  end)%C.

Lemma bitsFromIntP {k} (i: Int): size (bitsFromInt k i) == k.
Proof.
  elim: k i => // [k IH] i //=; rewrite eqSS //.
Qed.

Canonical bitsFromInt_tuple (i: Int): 'B_n
  := Tuple (bitsFromIntP i).

End BitExtract.

(** * Extraction  *)

(* Following CompCert's Integer module *)
Module Type WORDSIZE.
  Variable wordsize: nat.
End WORDSIZE.

Module MakeOps (WS: WORDSIZE).

Definition w := WS.wordsize.

Definition Int  := Native.Int.
Definition eq   := Native.eq.
Definition zero := Native.zero.
Definition one  := Native.one.
Definition lor  := Native.lor.
Definition land := Native.land.
Definition lsr  := Native.lsr.
Definition lxor := Native.lxor.

Definition wordsize := bitsToInt (bitn 63 WS.wordsize).

Definition bitmask := ((1 :<<: wordsize) - 1: Int)%C.

Definition mask_unop  (f : Int -> Int) x := (bitmask && f x)%C.
Definition mask_binop (f : Int -> Int -> Int) x y := (bitmask && f x y)%C.

Definition lnot := mask_unop Native.lnot.
Definition opp  := mask_unop Native.opp.

Definition lsl := mask_binop Native.lsl.
Definition add := mask_binop Native.add.
Definition sub := mask_binop Native.sub.

End MakeOps.

Module Wordsize_32.
  Definition wordsize := 32.
End Wordsize_32.

Module Int32 := MakeOps(Wordsize_32).

Module Wordsize_16.
  Definition wordsize := 16.
End Wordsize_16.

Module Int16 := MakeOps(Wordsize_16).

Module Wordsize_8.
  Definition wordsize := 8.
End Wordsize_8.

Module Int8 := MakeOps(Wordsize_8).


Require Import Verdi.TraceRelations.

Require Import VerdiRaft.Raft.
Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.OutputCorrectInterface.
Require Import VerdiRaft.AppliedEntriesMonotonicInterface.
Require Import VerdiRaft.TraceUtil.

Require Import VerdiRaft.StateMachineCorrectInterface.
Require Import VerdiRaft.SortedInterface.
Require Import VerdiRaft.LastAppliedCommitIndexMatchingInterface.
Require Import VerdiRaft.LogMatchingInterface.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Section OutputCorrect.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {aemi : applied_entries_monotonic_interface}.
  Context {smci : state_machine_correct_interface}.
  Context {si : sorted_interface}.
  Context {lacimi : lastApplied_commitIndex_match_interface}.
  Context {lmi : log_matching_interface}.

  Section inner.
  Variable client : clientId.
  Variables id : nat.
  Variable out : output.

  Theorem in_output_trace_dec :
    forall tr : list (name * (raft_input + list raft_output)),
      {in_output_trace client id out tr} + {~ in_output_trace client id out tr}.
  Proof using.
    unfold in_output_trace.
    intros.
    destruct (find (fun p => match snd p with
                               | inr l => match find (is_client_response client id out) l with
                                            | Some x => true
                                            | None => false
                                          end
                               | _ => false
                             end) tr) eqn:?.
    - find_apply_lem_hyp find_some. break_and.
      repeat break_match; try discriminate.
      find_apply_lem_hyp find_some. break_and.
      unfold is_client_response, in_output_list in *.
      break_match; try discriminate. break_if; try discriminate. do_bool. break_and. do_bool. subst.
      left. exists l, (fst p). clean.
      break_and. do_bool.
      break_if; try congruence. subst. intuition.
      find_reverse_rewrite.
      rewrite <- surjective_pairing.
      auto.
    - right. intro. break_exists. break_and.
      eapply find_none in Heqo; eauto.
      simpl in *. break_match; try discriminate.
      unfold in_output_list in *. break_exists.
      find_eapply_lem_hyp find_none; eauto.
      simpl in *. find_apply_lem_hyp Bool.andb_false_elim.
      break_if; repeat (intuition; do_bool).
      break_if; congruence.
  Qed.

  Lemma in_output_changed :
    forall tr o,
      ~ in_output_trace client id out tr ->
      in_output_trace client id out (tr ++ o) ->
      in_output_trace client id out o.
  Proof using.
    intros. unfold in_output_trace in *.
    break_exists_exists.
    intuition. do_in_app; intuition.
    exfalso. eauto.
  Qed.

  Lemma in_output_list_split :
    forall l l',
      in_output_list client id out (l ++ l') ->
      in_output_list client id out l \/ in_output_list client id out l'.
  Proof using.
    intros.
    unfold in_output_list in *.
    break_exists; do_in_app; intuition eauto.
  Qed.

  Lemma in_output_list_empty :
    ~ in_output_list client id out [].
  Proof using.
    intuition.
  Qed.

  Lemma doLeader_key_in_output_list :
    forall st h os st' m,
      doLeader st h = (os, st', m) ->
      ~ in_output_list client id out os.
  Proof using.
    intros. unfold doLeader, advanceCommitIndex in *.
    repeat break_match; find_inversion; intuition eauto using key_in_output_list_empty.
  Qed.

  Lemma handleInput_key_in_output_list :
    forall st h i os st' m,
      handleInput h i st = (os, st', m) ->
      ~ in_output_list client id out os.
  Proof using.
    intros. unfold handleInput, handleTimeout, handleClientRequest, tryToBecomeLeader in *.
    repeat break_match; find_inversion; intuition eauto using in_output_list_empty;
    unfold in_output_list in *; break_exists; simpl in *; intuition; congruence.
  Qed.

  Lemma deduplicate_log'_app :
    forall l l' ks,
      exists l'',
        deduplicate_log' (l ++ l') ks = deduplicate_log' l ks ++ l''.
  Proof using.
    induction l; intros; simpl in *; intuition; eauto.
    repeat break_match; simpl in *; eauto;
    repeat find_insterU; break_exists; eexists; f_equal; eauto.
  Qed.

  Lemma deduplicate_log_app :
    forall l l',
      exists l'',
        deduplicate_log (l ++ l') = deduplicate_log l ++ l''.
  Proof using.
    eauto using deduplicate_log'_app.
  Qed.

  Lemma in_output_trace_not_nil :
      in_output_trace client id out [] -> False.
  Proof using.
    unfold in_output_trace.
    simpl. intros. break_exists. intuition.
  Qed.

  Lemma in_output_trace_singleton_inv :
    forall h l,
      in_output_trace client id out [(h, inr l)] ->
      in_output_list client id out l.
  Proof using.
    unfold in_output_trace.
    intuition.
    break_exists. simpl in *. intuition.
    find_inversion. auto.
  Qed.

  Lemma in_output_list_app_or :
    forall c i o l1 l2,
      in_output_list c i o (l1 ++ l2) ->
      in_output_list c i o l1 \/
      in_output_list c i o l2.
  Proof using.
    unfold in_output_list.
    intuition.
  Qed.

  Lemma in_output_trace_inp_inv :
    forall h i tr,
      in_output_trace client id out ((h, inl i) :: tr) ->
      in_output_trace client id out tr.
  Proof using.
    unfold in_output_trace.
    intuition. break_exists_exists. simpl in *. intuition.
    find_inversion.
  Qed.

  Lemma in_output_list_not_leader_singleton :
    forall a b,
      ~ in_output_list client id out [NotLeader a b].
  Proof using.
    unfold in_output_list. simpl. intuition. discriminate.
  Qed.

  Lemma handleInput_in_output_list :
    forall h i st os st' ms,
      handleInput h i st = (os, st', ms) ->
      ~ in_output_list client id out os.
  Proof using.
    unfold handleInput, handleTimeout, handleInput, tryToBecomeLeader, handleClientRequest.
    intuition.
    repeat break_match; repeat find_inversion; eauto using in_output_trace_not_nil.
    - exfalso. eapply in_output_list_not_leader_singleton; eauto.
    - exfalso. eapply in_output_list_not_leader_singleton; eauto.
  Qed.

  Lemma in_output_list_cons_or :
    forall a b c l,
      in_output_list client id out (ClientResponse a b c :: l) ->
      (a = client /\ b = id /\ c = out) \/
      in_output_list client id out l.
  Proof using.
    unfold in_output_list.
    simpl. intuition.
    find_inversion. auto.
  Qed.

  Lemma assoc_Some_In :
    forall K V (K_eq_dec : forall k k' : K, {k = k'} + {k <> k'}) k v l,
      assoc (V:=V) K_eq_dec l k = Some v ->
      In (k, v) l.
  Proof using.
    induction l; simpl; intros; repeat break_match.
    - discriminate.
    - find_inversion. auto.
    - intuition.
  Qed.

  Lemma getLastId_Some_In :
    forall st c n o,
      getLastId st c = Some (n, o) ->
      In (c, (n, o)) (clientCache st).
  Proof using.
    unfold getLastId.
    eauto using assoc_Some_In.
  Qed.

  Lemma middle_app_assoc :
    forall A xs (y : A) zs,
      xs ++ y :: zs = (xs ++ [y]) ++ zs.
  Proof using.
    induction xs; intros; simpl; auto using f_equal.
  Qed.

  Lemma deduplicate_log'_snoc_drop_keys :
    forall es ks e n,
      assoc clientId_eq_dec ks (eClient e) = Some n ->
      eId e <= n ->
      deduplicate_log' (es ++ [e]) ks = deduplicate_log' es ks.
  Proof using.
    induction es; simpl; intuition; repeat break_match; repeat find_inversion; do_bool.
    - lia.
    - auto.
    - discriminate.
    - f_equal. destruct (clientId_eq_dec (eClient a) (eClient e)).
      + repeat find_rewrite. find_injection.
        eapply IHes with (n := eId a); auto with *.
        now rewrite get_set_same.
      + eapply IHes; eauto.
        rewrite get_set_diff by auto. auto.
    - eauto.
    - f_equal. destruct (clientId_eq_dec (eClient a) (eClient e)).
      + repeat find_rewrite. discriminate.
      + eapply IHes; eauto.
        rewrite get_set_diff by auto. auto.
  Qed.

  Lemma deduplicate_log'_snoc_drop_es :
    forall es ks e e',
      In e' es ->
      eClient e = eClient e' ->
      eId e <= eId e' ->
      deduplicate_log' (es ++ [e]) ks = deduplicate_log' es ks.
  Proof using.
    induction es; simpl; intuition; repeat break_match; eauto using f_equal;
    repeat find_reverse_rewrite.
    - f_equal. subst. eapply deduplicate_log'_snoc_drop_keys; eauto.
      now rewrite get_set_same.
    - subst. do_bool. eapply deduplicate_log'_snoc_drop_keys; eauto; auto with *.
    - f_equal. subst. eapply deduplicate_log'_snoc_drop_keys; eauto.
      now rewrite get_set_same.
  Qed.

  Lemma deduplicate_log_snoc_drop :
    forall es e e',
      In e' es ->
      eClient e = eClient e' ->
      eId e <= eId e' ->
      deduplicate_log (es ++ [e]) = deduplicate_log es.
  Proof using.
    intros. eapply deduplicate_log'_snoc_drop_es; eauto.
  Qed.

  Lemma deduplicate_log'_snoc_split :
    forall es ks e,
      (forall e', In e' es -> eClient e' = eClient e -> eId e' < eId e) ->
      (forall i, assoc clientId_eq_dec ks (eClient e) = Some i -> i < eId e) ->
      deduplicate_log' (es ++ [e]) ks = deduplicate_log' es ks ++ [e].
  Proof using.
    induction es; intros; simpl in *; intuition.
    - break_match; simpl in *; auto.
      break_if; simpl in *; auto.
      do_bool.
      find_insterU. conclude_using eauto. lia.
    - repeat break_match; simpl in *; auto.
      + f_equal. eapply IHes; eauto.
        intros. do_bool.
        destruct (clientId_eq_dec (eClient a) (eClient e)).
        * repeat find_rewrite.
          find_rewrite_lem get_set_same. find_injection.
          find_insterU. conclude_using eauto. intuition.
        * find_erewrite_lem get_set_diff.
          eauto.
      + f_equal. eapply IHes; eauto.
        intros. do_bool.
        destruct (clientId_eq_dec (eClient a) (eClient e)).
        * repeat find_rewrite.
          find_rewrite_lem get_set_same. find_injection.
          match goal with
            | H : forall _, ?x = _ \/ _ -> _ |- _ =>
              specialize (H x)
          end.
          intuition.
        * find_erewrite_lem get_set_diff.
          eauto.
  Qed.

  Lemma deduplicate_log_snoc_split :
    forall es e,
      (forall e', In e' es -> eClient e' = eClient e -> eId e' < eId e) ->
      deduplicate_log (es ++ [e]) = deduplicate_log es ++ [e].
  Proof using.
    intros.
    eapply deduplicate_log'_snoc_split; eauto.
    intros. simpl in *. congruence.
  Qed.

  Lemma execute_log_app :
    forall xs ys,
      execute_log (xs ++ ys) = let (tr, st) := execute_log xs in execute_log' ys st tr.
  Proof using.
    unfold execute_log.
    intros.
    rewrite execute_log'_app. auto.
  Qed.

  Lemma applyEntry_stateMachine_correct :
    forall st e l st' es,
      applyEntry st e = (l, st') ->
      stateMachine st = snd (execute_log (deduplicate_log es)) ->
      (forall e', In e' es -> eClient e' = eClient e -> eId e' < eId e) ->
      stateMachine st' = snd (execute_log (deduplicate_log es ++ [e])).
  Proof using.
    unfold applyEntry.
    intros.
    repeat break_match; repeat find_inversion. simpl.
    rewrite execute_log_app. simpl. repeat break_let.
    simpl in *. congruence.
  Qed.

  Lemma deduplicate_log_cases :
    forall es e,
      (deduplicate_log (es ++ [e]) = deduplicate_log es /\
       exists e', In e' es /\ eClient e' = eClient e /\ eId e <= eId e') \/
      (deduplicate_log (es ++ [e]) = deduplicate_log es ++ [e] /\
       (forall e', In e' es -> eClient e' = eClient e -> eId e' < eId e)).
  Proof using.
    intros.
    destruct (find (fun e' => andb (if clientId_eq_dec (eClient e') (eClient e) then true else false)
                                  (eId e <=? eId e')) es) eqn:?.
    - left. find_apply_lem_hyp find_some.
      break_if; repeat (break_and; do_bool); try congruence.
      intuition eauto using deduplicate_log_snoc_drop.
    - right.
      match goal with
        | |- _ /\ ?P =>
          assert P; [|intuition; eauto using deduplicate_log_snoc_split]
      end.
      intros.
      find_eapply_lem_hyp find_none; eauto.
      simpl in *. break_if; repeat (do_bool; intuition); try congruence.
  Qed.

  (* FIXME: move to StructTact *)
  Lemma assoc_None :
    forall K V K_eq_dec (l : list (K * V)) k v,
      assoc K_eq_dec l k = None ->
      In (k, v) l ->
      False.
  Proof using.
    intros; induction l; simpl in *; intuition.
    - subst. break_if; congruence.
    - break_match. subst. break_if; try congruence.
      auto.
  Qed.

  Lemma getLastId_None :
    forall st c i o,
      getLastId st c = None ->
      In (c, (i, o)) (clientCache st) ->
      False.
  Proof using.
    intros.
    unfold getLastId in *.
    eauto using assoc_None.
  Qed.

  Lemma output_correct_monotonic :
    forall c i o xs ys,
      output_correct c i o xs ->
      output_correct c i o (xs ++ ys).
  Proof using.
    unfold output_correct.
    intros.
    break_exists.
    intuition.
    pose proof (deduplicate_log_app xs ys). break_exists.
    repeat find_rewrite.
    rewrite app_ass in *. simpl in *.
    eexists. eexists. eexists. eexists. eexists.
    intuition eauto.
  Qed.

  Lemma applyEntry_output_correct :
    forall st e l st' o es,
      applyEntry st e = (l, st') ->
      In o l ->
      stateMachine st = snd (execute_log (deduplicate_log es)) ->
      (forall e', In e' es -> eClient e' = eClient e -> eId e' < eId e) ->
      output_correct (eClient e) (eId e) o (es ++ [e]).
  Proof using.
    unfold applyEntry.
    intros.
    repeat break_match; repeat find_inversion.
    simpl in *. intuition.
    subst.
    unfold output_correct.
    rewrite deduplicate_log_snoc_split by auto.
    destruct (execute_log (deduplicate_log es)) eqn:?.
    eexists. eexists. exists []. eexists. eexists. intuition eauto.
    - rewrite execute_log_app. repeat find_rewrite. simpl in *. find_rewrite. eauto.
    - rewrite rev_app_distr. simpl. auto.
  Qed.

  Lemma cacheApplyEntry_output_correct :
    forall e es st l st' o,
      cacheApplyEntry st e = (l, st') ->
      In o l ->
      (forall c i o,
         getLastId st c = Some (i, o) ->
         output_correct c i o es) ->
      stateMachine st = snd (execute_log (deduplicate_log es)) ->
      (forall c i o e',
         getLastId st c = Some (i, o) ->
         In e' es ->
         eClient e' = c ->
         eId e' <= i) ->
      (forall e',
         In e' es ->
         exists i o,
           getLastId st (eClient e') = Some (i, o) /\
           eId e' <= i) ->
      output_correct (eClient e) (eId e) o (es ++ [e]).
  Proof using.
    unfold cacheApplyEntry.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; intuition.
    - do_bool. subst. eauto using output_correct_monotonic, getLastId_Some_In.
    - eapply applyEntry_output_correct; eauto.
      do_bool. assert (n < eId e) by auto with *.
      intros. assert (eId e' <= n) by eauto. lia.
    - eapply applyEntry_output_correct; eauto.
      intros.
      find_apply_hyp_hyp.
      break_exists. break_and.
      repeat find_rewrite. discriminate.
  Qed.

  Lemma cacheApplyEntry_stateMachine_correct :
    forall st e l st' es,
      cacheApplyEntry st e = (l, st') ->
      stateMachine st = snd (execute_log (deduplicate_log es)) ->
      (forall c i o,
         getLastId st c = Some (i, o) ->
         exists e,
           In e es /\
           eClient e = c /\
           eId e = i) ->
      (forall c i o e',
         getLastId st c = Some (i, o) ->
         In e' es ->
         eClient e' = c ->
         eId e' <= i) ->
      (forall e',
         In e' es ->
         exists i o,
           getLastId st (eClient e') = Some (i, o) /\
           eId e' <= i) ->
      stateMachine st' = snd (execute_log (deduplicate_log (es ++ [e]))).
  Proof using.
    intros.
    unfold cacheApplyEntry in *.
    repeat break_match; repeat find_inversion.
    - find_apply_hyp_hyp. break_exists. break_and.
      erewrite deduplicate_log_snoc_drop; eauto.
      do_bool. lia.
    - find_apply_hyp_hyp. break_exists. break_and.
      erewrite deduplicate_log_snoc_drop; eauto.
      do_bool. lia.
    - find_copy_apply_hyp_hyp. break_exists. break_and.
      pose proof (deduplicate_log_cases es e).
      intuition; break_exists; intuition; repeat find_rewrite.
      + do_bool. assert (eId x0 <= n) by eauto. lia.
      + eapply applyEntry_stateMachine_correct; eauto.
    - pose proof (deduplicate_log_cases es e).
      intuition; break_exists; intuition; repeat find_rewrite.
      + eapply_prop_hyp In In. break_exists. break_and.
        repeat find_rewrite. discriminate.
      + eapply applyEntry_stateMachine_correct; eauto.
  Qed.

  Lemma deduplicate_log_In_if :
    forall e l,
      In e (deduplicate_log l) ->
      In e l.
  Proof using.
    unfold deduplicate_log.
    intros. eauto using deduplicate_log'_In_if.
  Qed.

  Lemma applyEntry_clientCache :
    forall st e l st',
      applyEntry st e = (l, st') ->
      let (out, _) := handler (eInput e) (stateMachine st)
      in (clientCache st' = assoc_set clientId_eq_dec (clientCache st) (eClient e) (eId e, out) /\
          In out l).
  Proof using.
    unfold applyEntry.
    intros.
    repeat break_match; repeat find_inversion. intuition.
  Qed.

  Lemma cacheApplyEntry_clientCache :
    forall st e l st',
      cacheApplyEntry st e = (l, st') ->
      (clientCache st' = clientCache st /\
       (exists i o, getLastId st (eClient e) = Some (i, o) /\
                    eId e <= i) ) \/
      ((let (out, _) := handler (eInput e) (stateMachine st)
       in (clientCache st' = assoc_set clientId_eq_dec (clientCache st) (eClient e) (eId e, out) /\
          In out l)) /\ (getLastId st (eClient e) = None \/
                       (exists i o, getLastId st (eClient e) = Some (i, o) /\
                                    i < eId e))).
  Proof using.
    unfold cacheApplyEntry.
    intros.
    repeat break_match_hyp; repeat find_inversion; do_bool; intuition eauto with *;
    right; (split; [solve [apply applyEntry_clientCache; auto]|]); auto.
    right. do_bool. eexists. eexists. intuition eauto. lia.
  Qed.

  Lemma getLastId_ext :
    forall st st' c,
      clientCache st' = clientCache st ->
      getLastId st' c = getLastId st c.
  Proof using.
    unfold getLastId.
    intros.
    congruence.
  Qed.

  Lemma cacheAppliedEntry_clientCache_preserved :
    forall st e l st' c i o,
      cacheApplyEntry st e = (l, st') ->
      getLastId st c = Some (i, o) ->
      exists i' o',
        getLastId st' c = Some (i', o') /\
        i <= i'.
  Proof using.
    intros.
    unfold cacheApplyEntry in *.
    repeat break_match; try find_inversion; simpl in *; repeat find_rewrite; eauto.
    - do_bool.
      unfold applyEntry in *.
      repeat break_match; find_inversion.
      unfold getLastId in *. simpl in *.
      destruct (clientId_eq_dec (eClient e) c); subst.
      + rewrite get_set_same. find_rewrite.
        find_inversion. eauto.
      + rewrite get_set_diff in *; auto.
        repeat find_rewrite. eauto.
    - unfold applyEntry in *.
      repeat break_match; find_inversion.
      unfold getLastId in *. simpl in *.
      destruct (clientId_eq_dec (eClient e) c); subst.
      + repeat find_rewrite.  congruence.
      + rewrite get_set_diff in *; auto.
        repeat find_rewrite. eauto.
  Qed.

  Lemma cacheAppliedEntry_clientCache_nondecreasing :
    forall st e l st' c i o i' o',
      cacheApplyEntry st e = (l, st') ->
      getLastId st c = Some (i, o) ->
      getLastId st' c = Some (i', o') ->
      i <= i'.
  Proof using.
    intros.
    eapply cacheAppliedEntry_clientCache_preserved in H; eauto.
    break_exists. intuition. repeat find_rewrite. find_inversion. auto.
  Qed.

  Lemma applyEntries_output_correct :
    forall l c i o h st os st' es,
      applyEntries h st l = (os, st') ->
      in_output_list c i o os ->
      (stateMachine st = snd (execute_log (deduplicate_log es))) ->
      (forall c i o,
         getLastId st c = Some (i, o) ->
         output_correct c i o es) ->
      (forall c i o e',
         getLastId st c = Some (i, o) ->
         In e' es -> eClient e' = c -> eId e' <= i) ->
      (forall e',
         In e' es ->
         exists i o,
           getLastId st (eClient e') = Some (i, o) /\ eId e' <= i) ->
      output_correct c i o (es ++ l).
  Proof using out id client.
    induction l; intros; simpl in *.
    - find_inversion. exfalso. eapply in_output_list_empty; eauto.
    - repeat break_let. find_inversion.
      find_apply_lem_hyp in_output_list_app_or.
      break_or_hyp.
      + break_if.
        * unfold in_output_list in *.
          do_in_map. find_inversion.
          rewrite middle_app_assoc. apply output_correct_monotonic.
          eapply cacheApplyEntry_output_correct; eauto.
        * exfalso. eapply in_output_list_empty; eauto.
      + rewrite middle_app_assoc. eapply IHl.
        * eauto.
        * auto.
        * eapply cacheApplyEntry_stateMachine_correct; eauto.
          intros.
          find_apply_hyp_hyp. unfold output_correct in *.
          break_exists. break_and.
          eexists. intuition eauto.
          eapply deduplicate_log_In_if.
          eauto with *.
        * find_copy_apply_lem_hyp cacheApplyEntry_clientCache.
          { intros. break_or_hyp.
            - break_and.
              apply output_correct_monotonic.
              unfold getLastId in *. repeat find_rewrite. eauto.
            - break_let. break_and.
              unfold getLastId in *.
              repeat find_rewrite.
              destruct (clientId_eq_dec (eClient a) c0).
              + subst.  rewrite get_set_same in *. find_inversion.
                eapply cacheApplyEntry_output_correct; eauto.
              + rewrite get_set_diff in * by auto. eauto using output_correct_monotonic.
          }
        * intros.
          do_in_app. simpl in *.
          { intuition.
            - eapply_prop_hyp In In. break_exists. break_and. subst.
              eauto using Nat.le_trans, cacheAppliedEntry_clientCache_nondecreasing.
            - subst. find_copy_apply_lem_hyp cacheApplyEntry_clientCache.
              intuition.
              + break_exists. break_and.
                eauto using Nat.le_trans, cacheAppliedEntry_clientCache_nondecreasing.
              + unfold getLastId in *. break_let. break_and. repeat find_rewrite.
                rewrite get_set_same in *. find_inversion. auto.
              + unfold getLastId in *. break_let. break_and.
                repeat find_rewrite.
                rewrite get_set_same in *. find_inversion. auto.
          }
        * intros.
          do_in_app. simpl in *.
          { intuition.
            - eapply_prop_hyp In In. break_exists. break_and.
              find_copy_eapply_lem_hyp cacheAppliedEntry_clientCache_preserved; eauto.
              break_exists_exists. intuition.
            - subst. find_copy_apply_lem_hyp cacheApplyEntry_clientCache.
              intuition.
              + break_exists. break_and.
                find_copy_eapply_lem_hyp cacheAppliedEntry_clientCache_preserved; eauto.
                break_exists_exists. intuition.
              + break_let. break_and. unfold getLastId. repeat find_rewrite.
                eexists. eexists. rewrite get_set_same. intuition eauto.
              + break_let. break_and. unfold getLastId. repeat find_rewrite.
                eexists. eexists. rewrite get_set_same. intuition eauto.
          }
  Qed.

  Lemma cacheApplyEntry_spec :
    forall st a l st',
      cacheApplyEntry st a = (l, st') ->
      log st' = log st /\
      lastApplied st' = lastApplied st /\
      commitIndex st' = commitIndex st.
  Proof using.
    intros. unfold cacheApplyEntry, applyEntry in *.
    repeat break_match; find_inversion; auto.
  Qed.

  Lemma applyEntries_spec :
    forall es h st os st',
      applyEntries h st es = (os, st') ->
      log st' = log st /\
      lastApplied st' = lastApplied st /\
      commitIndex st' = commitIndex st.
  Proof using.
    induction es; intros; simpl in *.
    - find_inversion. auto.
    - repeat break_match; find_inversion;
      find_apply_hyp_hyp;
      find_apply_lem_hyp cacheApplyEntry_spec;
      intuition; repeat find_rewrite; auto.
  Qed.

  Lemma output_correct_prefix :
    forall l1 l2 client id out,
      Prefix l1 l2 ->
      output_correct client id out l1 ->
      output_correct client id out l2.
  Proof using.
    intros.
    find_apply_lem_hyp Prefix_exists_rest.
    break_exists. subst.
    eauto using output_correct_monotonic.
  Qed.

  Lemma entries_contiguous :
    forall net,
      raft_intermediate_reachable net ->
      (forall h, contiguous_range_exact_lo (log (nwState net h)) 0).
  Proof using lmi.
    intros. find_apply_lem_hyp log_matching_invariant.
    unfold log_matching, log_matching_hosts in *.
    intuition.
    unfold contiguous_range_exact_lo. intuition; eauto.
    find_apply_hyp_hyp. lia.
  Qed.

  Lemma doGenericServer_output_correct :
    forall h ps sigma os st' ms,
      raft_intermediate_reachable (mkNetwork ps sigma) ->
      doGenericServer h (sigma h) = (os, st', ms) ->
      in_output_list client id out os ->
      output_correct client id out (applied_entries (update name_eq_dec sigma h st')).
  Proof using lmi lacimi si smci.
    intros.
    find_copy_apply_lem_hyp logs_sorted_invariant.
    pose proof entries_contiguous.
    match goal with
      | H : context [contiguous_range_exact_lo] |- _ =>
        specialize (H ({| nwPackets := ps; nwState := sigma |}))
    end.
    concludes. simpl in *.
    find_copy_apply_lem_hyp state_machine_correct_invariant.
    unfold state_machine_correct in *. intuition.
    unfold logs_sorted in *. intuition.
    unfold doGenericServer in *.
    break_let. find_inversion.
    find_copy_apply_lem_hyp applyEntries_spec. intuition. repeat find_rewrite.
    eapply applyEntries_output_correct
    with (es := rev (removeAfterIndex (log (sigma h)) (lastApplied (sigma h)))) in Heqp; eauto.
    - rewrite <- rev_app_distr in *.
      eapply output_correct_prefix; eauto.
      break_if.
      + do_bool.
        erewrite findGtIndex_removeAfterIndex_i_lt_i' in *; eauto.
        match goal with
          | |- context [applied_entries (update _ ?sigma ?h ?st)] =>
            pose proof applied_entries_update sigma h st
        end. conclude_using intuition.
        intuition; simpl in *;
        unfold raft_data in *; simpl in *; find_rewrite; auto using Prefix_refl.
        unfold applied_entries in *.
        break_exists. intuition. repeat find_rewrite.
        eapply contiguous_sorted_subset_prefix; eauto using removeAfterIndex_contiguous, removeAfterIndex_sorted.
        intros.
        find_copy_apply_lem_hyp removeAfterIndex_In_le; eauto.
        find_apply_lem_hyp removeAfterIndex_in.
        apply removeAfterIndex_le_In; eauto; try lia.
        find_copy_apply_lem_hyp commitIndex_lastApplied_match_invariant.
        unfold commitIndex_lastApplied_match in *. simpl in *.
        match goal with
          | _ : ?x >= ?y |- _ =>
            assert (y <= x) by lia
        end.
        eapply_prop_hyp le le; eauto. intuition.
      + do_bool.
        erewrite findGtIndex_removeAfterIndex_i'_le_i in *; eauto.
        match goal with
          | |- context [applied_entries (update _ ?sigma ?h ?st)] =>
            pose proof applied_entries_update sigma h st
        end. conclude_using intuition.
        intuition; simpl in *;
        unfold raft_data in *; simpl in *; find_rewrite; auto using Prefix_refl.
        unfold applied_entries in *.
        break_exists. intuition. repeat find_rewrite.
        eapply contiguous_sorted_subset_prefix; eauto using removeAfterIndex_contiguous, removeAfterIndex_sorted.
        intros.
        find_copy_apply_lem_hyp removeAfterIndex_In_le; eauto.
        find_apply_lem_hyp removeAfterIndex_in.
        apply removeAfterIndex_le_In; eauto; try lia.
        find_copy_apply_lem_hyp lastApplied_lastApplied_match_invariant.
        unfold lastApplied_lastApplied_match in *. simpl in *.
        match goal with
          | _ : ?x >= ?y |- _ =>
            assert (y <= x) by lia
        end.
        eapply_prop_hyp le le; eauto. intuition.
    - unfold client_cache_complete in *.
      simpl in *.
      intros. subst.
      find_apply_lem_hyp In_rev. find_apply_hyp_hyp.
      break_exists. intuition. repeat find_rewrite.
      match goal with
        | H : Some _ = Some _ |- _ =>
          invcs H
      end. auto.
    - intros. find_apply_lem_hyp In_rev. eauto.
  Qed.

  Ltac intermediate_networks :=
    match goal with
      | Hdgs : doGenericServer ?h ?st' = _,
               Hdl : doLeader ?st ?h = _ |- context [update _ (nwState ?net) ?h ?st''] =>
        replace st with (update name_eq_dec (nwState net) h st h) in Hdl by eauto using update_eq;
          replace st' with (update name_eq_dec (update name_eq_dec (nwState net) h st) h st' h) in Hdgs by eauto using update_eq;
          let H := fresh "H" in
          assert (update name_eq_dec (nwState net) h st'' =
                  update name_eq_dec (update name_eq_dec (update name_eq_dec (nwState net) h st) h st') h st'') by (repeat rewrite update_overwrite; auto); unfold data in *; simpl in *; rewrite H; clear H
    end.

  Lemma in_output_trace_step_output_correct :
    forall failed failed' (net net' : network (params := @multi_params _ _ raft_params)) os,
      in_output_trace client id out os ->
      @raft_intermediate_reachable _ _ raft_params net ->
      step_failure (failed, net) (failed', net') os ->
      output_correct client id out (applied_entries (nwState net')).
  Proof using lmi lacimi si smci.
    intros.
    match goal with
      | [ H : context [ step_failure _ _ _ ] |- _ ] => invcs H
    end.
    - unfold RaftNetHandler in *. repeat break_let. repeat find_inversion.
      find_apply_lem_hyp in_output_trace_singleton_inv.
      find_apply_lem_hyp in_output_list_app_or.
      intuition.
      + exfalso. eapply doLeader_key_in_output_list; eauto.
      + find_copy_eapply_lem_hyp RIR_handleMessage; eauto.
        find_copy_eapply_lem_hyp RIR_doLeader; simpl; rewrite_update; eauto.
        intermediate_networks.
        find_copy_apply_lem_hyp doLeader_appliedEntries.
        eapply doGenericServer_output_correct; eauto.
    - unfold RaftInputHandler in *. repeat break_let. repeat find_inversion.
      find_apply_lem_hyp in_output_trace_inp_inv.
      find_apply_lem_hyp in_output_trace_singleton_inv.
      find_apply_lem_hyp in_output_list_app_or.
      intuition.
      + exfalso. eapply handleInput_in_output_list; eauto.
      + find_apply_lem_hyp in_output_list_app_or.
        intuition.
        * exfalso. eapply doLeader_key_in_output_list; eauto.
          * find_copy_eapply_lem_hyp RIR_handleInput; eauto.
            find_copy_eapply_lem_hyp RIR_doLeader; simpl; rewrite_update; eauto.
            intermediate_networks.
            find_copy_apply_lem_hyp doLeader_appliedEntries.
            eapply doGenericServer_output_correct; eauto.
    - exfalso. eauto using in_output_trace_not_nil.
    - exfalso. eauto using in_output_trace_not_nil.
    - exfalso. eauto using in_output_trace_not_nil.
    - exfalso. eauto using in_output_trace_not_nil.
  Qed.

  Program Instance TR : TraceRelation step_failure :=
    {
      init := step_failure_init;
      T := in_output_trace client id out ;
      T_dec := in_output_trace_dec ;
      R := fun s => let (_, net) := s in
                    output_correct client id out (applied_entries (nwState net))
    }.
  Next Obligation.
    repeat break_let. subst.
    find_eapply_lem_hyp applied_entries_monotonic';
      eauto using step_failure_star_raft_intermediate_reachable.
    unfold output_correct in *.
    break_exists.
    repeat find_rewrite.
    match goal with
    | [ |- context [ deduplicate_log (?l ++ ?l') ] ] =>
      pose proof deduplicate_log_app l l'; break_exists; find_rewrite
    end.
    repeat eexists; intuition eauto; repeat find_rewrite; auto.
    rewrite app_ass. simpl. repeat f_equal.
  Defined.
  Next Obligation.
    unfold in_output_trace in *. intuition.
    break_exists; intuition.
  Defined.
  Next Obligation.
    find_apply_lem_hyp in_output_changed; auto.
    eauto using in_output_trace_step_output_correct, step_failure_star_raft_intermediate_reachable.
  Defined.

  Theorem output_correct :
    forall  failed net tr,
      step_failure_star step_failure_init (failed, net) tr ->
      in_output_trace client id out tr ->
      output_correct client id out (applied_entries (nwState net)).
  Proof using lmi lacimi si smci aemi.
    intros. pose proof (trace_relations_work (failed, net) tr).
    repeat concludes.
    auto.
  Qed.
  End inner.

  Instance oci : output_correct_interface.
  Proof using smci si lmi lacimi aemi.
    split.
    exact output_correct.
  Qed.
End OutputCorrect.