(* 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 ssrnat_ext uniq_tac machine_int.
Require Import multi_int.
Import MachineInt.
Require Import mips_bipl mips_seplog mips_mint.
Import expr_m.
Require Import simu.
Import simu_m.
From mathcomp Require Import seq.
Require Import multi_add_s_u_prg multi_add_s_u_triple.

Local Open Scope machine_int_scope.
Local Open Scope asm_expr_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope assoc_scope.
Local Open Scope heap_scope.
Local Open Scope simu_scope.
Local Open Scope asm_cmd_scope.
Local Open Scope uniq_scope.

(** x <- x + y, x signed, y unsigned *)

Lemma pfwd_sim_multi_add_s_u (x y : assoc.l) d k rk rx ry a0 a1 a2 a3 a4 a5 rX :
  uniq(x, y) ->
  uniq(rk, rx, ry, a0, a1, a2, a3, a4, a5, rX, r0) ->
  disj (mints_regs (assoc.cdom d)) (a0 :: a1 :: a2 :: a3 :: a4 :: a5 :: rX :: nil) ->
  x \notin assoc.dom d -> y \notin assoc.dom d ->
  signed k rx \notin assoc.cdom d -> unsign rk ry \notin assoc.cdom d ->
  (x <- var_e x \+ var_e y)%pseudo_expr%pseudo_cmd
    <=p( state_mint (x |=> signed k rx \U+ (y |=> unsign rk ry \U+ d)),
         fun st s _ => [rk ]_ s <> zero32 /\
                        u2Z ([rk ]_ s) < 2 ^^ 31 /\
                        k = '|u2Z ([rk ]_ s)| /\
                        `| ([x ]_ st)%pseudo_expr | < \B^k /\
                        0 <= ([y ]_ st)%pseudo_expr < \B^k /\
                        `| ([x ]_ st + [y ]_ st)%pseudo_expr | < \B^k)
  multi_add_s_u rk rx ry a0 a1 a2 a3 a4 a5 rX.
Proof.
move=> Hvars Hregs Hd x_d y_d rx_d rk_ry_d.
rewrite /pfwd_sim.
move=> st s h [st_s_h [rk_st_neq0 [rk_st_max [k_rk [x_k [y_st x_y_st]]]]]] st' exec_pseudo s' h' exec_asm.

have Hd_unchanged : forall v r, assoc.get v d = Some r ->
  disj (mint_regs r) (mips_frame.modified_regs (multi_add_s_u rk rx ry a0 a1 a2 a3 a4 a5 rX)).
  move=> v r Hvr; rewrite [mips_frame.modified_regs _]/=; Disj_remove_dup.
  apply (disj_incl_LR Hd); last by apply incl_refl_Permutation; PermutProve.
  apply/incP/inc_mint_regs.
  by move/assoc.get_Some_in_cdom : Hvr.
set vx := [rx ]_ s.
set vy := [ry ]_ s.

lapply (state_mint_var_mint _ _ _ _ x (signed k rx) st_s_h); [move=> var_mint_x | by assoc_get_Some].
rewrite /var_mint in var_mint_x.
case: var_mint_x => slen ptr X vx_fit [X_k Hlen Hsgn Sum_X] ptr_fit Hmem.

have : k <> 0%nat.
  contradict rk_st_neq0. apply u2Z_inj. rewrite rk_st_neq0 in k_rk.
  symmetry in k_rk. apply Zabs_nat_0_inv in k_rk. by rewrite Z2uK.
move/(multi_add_s_u_triple_gen rk rx ry a0 a1 a2 a3 a4 a5 rX Hregs).
move/(_ vx vy ptr).
have : Z<=nat k < 2 ^^ 31.
  rewrite k_rk Z_of_nat_Zabs_nat //; by apply min_u2Z.
let x := fresh in move=> x; move/(_ x); clear x.
move/(_ ptr_fit).
have : Z<=u vy + 4 * Z<=nat k < \B^1.
  rewrite assoc_prop_m.swap_heads in st_s_h; last by [].
  move: (state_mint_head_unsign_fit _ _ _ _ _ _ _ st_s_h); by rewrite k_rk.
let x := fresh in move=> x; move/(_ x); clear x.
move/(_ X (Z2ints 32 k ([ y ]_ st)%pseudo_expr) X_k).
rewrite size_Z2ints.
move/(_ Logic.eq_refl slen Hlen).
rewrite -Sum_X.
move/(_ Hsgn) => Hhoare_multi_add_s_u.

have [s'' [h'' exec_asm_proj]] : exists s'' h'',
  (Some (s, h |P| heap.dom (heap_mint (unsign rk ry) s h \U heap_mint (signed k rx) s h))
    -- multi_add_s_u rk rx ry a0 a1 a2 a3 a4 a5 rX --->
    Some (s'', h''))%asm_cmd.
  exists s', (h' |P| heap.dom (heap_mint (unsign rk ry) s h \U heap_mint (signed k rx) s h)).
  apply (mips_syntax.triple_exec_proj _ _ _ Hhoare_multi_add_s_u) => {Hhoare_multi_add_s_u} //.
  split; first by [].
  split; first by [].
  split.
    rewrite k_rk Z_of_nat_Zabs_nat //; exact/min_u2Z.
  rewrite heap.proj_dom_union; last first.
    apply (proj2 st_s_h y x); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
  rewrite heap.unionC; last first.
    apply heap.dis_disj_proj.
    rewrite -heap.disjE.
    apply (proj2 st_s_h y x); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
  apply assert_m.con_cons.
    apply heap.dis_disj_proj.
    rewrite -heap.disjE.
    apply (proj2 st_s_h x y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
  move: (heap_inclu_heap_mint_signed h s k rx).
  move/heap.incluE => ->; exact Hmem.
  (* TODO: can't use heap_inclu_heap_mint_unsign? like in copy_signed_unsign? *)
  have y_ry : var_mint y (unsign rk ry) st s (heap_mint (unsign rk ry) s h).
    apply (state_mint_var_mint _ _ _ _ _ _ st_s_h); by assoc_get_Some.
  case: (y_ry) => _ [] _ Hry.
  rewrite /heap_mint /heap_cut in y_ry.
  by rewrite k_rk (var_mint_unsign_dom_heap_mint _ _ _ _ _ _ y_ry).
have ry_s_s' : [ry]_ s = [ry]_ s'.
  mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs. by Uniq_not_In.
have rk_s_s' : [rk ]_ s = [rk ]_ s'.
  mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs. by Uniq_not_In.
have y_st_st' : ([y ]_ st = [y ]_ st')%pseudo_expr.
  Var_unchanged. simpl syntax_m.seplog_m.modified_vars.
  move/inP.
  rewrite -/(~ _).
  by Uniq_not_In.
have rx_s_s' : [rx ]_ s = [rx ]_ s'.
  mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs. by Uniq_not_In.
set postcond := (fun s h => exists _, _) in Hhoare_multi_add_s_u.
have {Hhoare_multi_add_s_u}hoare_triple_post_condition : (
  postcond ** assert_m.TT)%asm_assert s' h'.
    move: {Hhoare_multi_add_s_u}(mips_frame.frame_rule_R _ _ _ Hhoare_multi_add_s_u assert_m.TT (assert_m.inde_TT _) (mips_frame.inde_cmd_mult_TT _)).
    move/mips_seplog.hoare_prop_m.soundness.
    rewrite /while.hoare_semantics.
    move/(_ s h) => Hmulti_add_s_u.
    lapply Hmulti_add_s_u; last first.
      exists (heap_mint (signed k rx) s h \U heap_mint (unsign rk ry) s h),
       (h \D\ heap.dom (heap_mint (signed k rx) s h \U heap_mint (unsign rk ry) s h)).
      split; first by apply heap.disj_difs', seq_ext.inc_refl.
      split.
        apply heap.union_difsK; last by [].
        apply heap_prop_m.inclu_union; by [apply heap_inclu_heap_mint_signed | apply heap.inclu_proj].
      split; last by [].
      repeat (split=> //).
      rewrite k_rk Z_of_nat_Zabs_nat //; by apply min_u2Z.
      apply assert_m.con_cons.
      + apply (proj2 st_s_h x y); by [Uniq_neq | assoc_get_Some | assoc_get_Some].
      + exact Hmem.
      + move: (proj1 st_s_h y (unsign rk ry)).
        rewrite assoc.get_union_sing_neq; last by Uniq_neq.
        rewrite assoc.get_union_sing_eq.
        case/(_ (refl_equal _))=> _ [] _; by rewrite -k_rk.
    case=> _.
    by move/(_ _ _ exec_asm).
rewrite /state_mint; split.
- move=> z rz z_rz.
  have [z_d | z_x ] : z \in assoc.dom (y |=> unsign rk ry \U+ d) \/ z = x.
    rewrite assoc.unionC in z_rz; last first.
      apply assoc.disjhU.
      apply assoc.disj_sing.
      apply/eqP; by Uniq_neq.
      by apply assoc.disj_sym, assoc.disj_sing_R.
    case/assoc.get_union_Some_inv : z_rz => z_rz.
    left.
    by apply assoc.get_Some_in_dom with rz.
    case/assoc.get_sing_inv : z_rz => ? ?; subst z rz.
    by right.
  + (* NB: it is about proving that x is unchanged, which is true since
       neither y nor d are touched by execution *)
    have z_x : z <> x.
      move=> ?; subst z.
      case/assoc.in_dom_union_inv : z_d.
      * case/assoc.in_dom_get_Some => z.
        case/assoc.get_sing_inv => z_d _.
        move: z_d.
        rewrite -/(~ _); by Uniq_neq.
      * by rewrite (negbTE x_d).
    case/orP : (orbN (z == y)) => z_y.
    * (* z = y *) move/eqP : z_y => ?; subst z.
      rewrite assoc.unionC in z_rz; last first.
        apply assoc.disjhU.
        apply assoc.disj_sing; by apply/eqP/nesym.
        by apply assoc.disj_sym, assoc.disj_sing_R.
      rewrite -assoc.unionA assoc.get_union_sing_eq in z_rz.
      case: z_rz => ?; subst rz.
      case : hoare_triple_post_condition => h1 [h2 [h1_d_h2 [h1_U_h2 [Hh1 Hh2]]]].
      case: Hh1 => X' [slen' Hh1].
      decompose [and] Hh1; clear Hh1.
      case: H4 => h11 [h12 [h11_d_h12 [h11_U_h12 [Hh11 Hh12]]]].
      move: (proj1 st_s_h y (unsign rk ry)).
      rewrite assoc.get_union_sing_neq; last by Uniq_neq.
      rewrite assoc.get_union_sing_eq.
      move/(_ (refl_equal _)).
      have <- : heap_mint (unsign rk ry) s h = heap_mint (unsign rk ry) s' h'.
        rewrite {2}/heap_mint /heap_cut h1_U_h2 h11_U_h12.
        move/assert_m.mapstos_inv_dom : (Hh12) => Hh12'.
        have : u2Z [var_e ry ]e_ s' +
          4 * Z_of_nat (size (Z2ints 32 k ([y ]_ st)%pseudo_expr)) < \B^1.
          rewrite [u2Z _]/= size_Z2ints -ry_s_s'.
          move: (proj1 st_s_h y (unsign rk ry)).
          rewrite assoc.get_union_sing_neq; last by Uniq_neq.
          rewrite assoc.get_union_sing_eq k_rk.
          by case/(_ (refl_equal _)).
        move/Hh12' => {}Hh12'.
        rewrite size_Z2ints k_rk rk_s_s' in Hh12'.
        rewrite {}Hh12'.
        rewrite heap.proj_union_L; last by rewrite -heap.disjE; heap_tac_m.Disj.
        rewrite heap.proj_union_R_dom; last by heap_tac_m.Disj.
        move: (proj1 st_s_h y (unsign rk ry)).
        rewrite assoc.get_union_sing_neq; last by auto.
        rewrite assoc.get_union_sing_eq.
        move/(_ (refl_equal _)).
        case=> X1 X2 X3.
        rewrite -k_rk in X3.
        rewrite heap.proj_itself.
        apply: (assert_m.strictly_exact_mapstos (Z2ints 32 k ([y ]_ st)%pseudo_expr) (var_e ry) s).
        split; first by [].
        move: Hh12; by apply assert_m.mapstos_ext.
        apply var_mint_invariant_unsign; [exact ry_s_s' | exact rk_s_s' | exact y_st_st'].
    * (* z <> y *) move: {st_s_h}(proj1 st_s_h _ _ z_rz) (proj2 st_s_h) => st_s_h1 st_s_h2.
      have z_unchanged : ( [ z ]_ st = [ z ]_ st' )%pseudo_expr.
        Var_unchanged. rewrite /= mem_seq1; exact/negP/eqP.
      case: (mips_syntax.exec_deter_proj _ _ _ _ _ exec_asm
        (heap.dom (heap_mint (unsign rk ry) s h \U heap_mint (signed k rx) s h)) _ _
        exec_asm_proj) => H4 [H5 H_h_h'].
      have <- : heap_mint rz s h = heap_mint rz s' h'.
        apply (heap_mint_state_invariant (heap_mint (unsign rk ry) s h \U
          heap_mint (signed k rx) s h) z st) => //.
        move=> rx0 Hrx0; mips_syntax.Reg_unchanged.
        apply (@disj_not_In _ (mint_regs rz)); last by [].
        apply/disj_sym/(Hd_unchanged z).
        rewrite assoc.get_union_sing_neq in z_rz; last by [].
        rewrite assoc.get_union_sing_neq // in z_rz.
        by apply/eqP.
        apply heap.disjhU.
        apply st_s_h2 with z y => //.
        by apply/eqP.
        rewrite assoc.get_union_sing_neq; last by Uniq_neq.
        by rewrite assoc.get_union_sing_eq.
        apply st_s_h2 with z x => //.
      by rewrite assoc.get_union_sing_eq.
      move: st_s_h1; apply var_mint_invariant; last exact z_unchanged.
      move=> rx0 Hrx0; mips_syntax.Reg_unchanged.
      apply (@disj_not_In _ (mint_regs rz)); last by [].
      apply/disj_sym/(Hd_unchanged z) => //.
      rewrite assoc.get_union_sing_neq in z_rz; last by [].
      rewrite assoc.get_union_sing_neq // in z_rz.
      by apply/eqP.
  + (* NB: z is changed but stays a mint *) subst z.
    have rz_rx : rz = signed k rx.
      rewrite assoc.get_union_sing_eq in z_rz; by case: z_rz.
    subst rz.
    move: (proj1 st_s_h x (signed k rx) z_rz).
    rewrite /var_mint.
    case: hoare_triple_post_condition => [h1 [h2 [Hdisj [Hunion [[X' [slen' [Hadd_s_us_1 [r_x [r_y [Hadd_s_us_2 [Hadd_s_us_3 [Hadd_s_us_4 [Hadd_s_us_5 Hadd_s_us_6]]]]]]]]]] HTT]]]].
    move=> ?.
    have x'_x_y : ([ x ]_ st' = [ x ]_ st + [y ]_ st )%pseudo_expr.
      move/syntax_m.seplog_m.semop_prop_m.exec_cmd0_inv : exec_pseudo.
      case/syntax_m.seplog_m.exec0_assign_inv => _ -> /=.
      by syntax_m.seplog_m.assert_m.expr_m.Store_upd.
    apply (mkVarSigned _ _ _ _ _ slen' ptr X') => //.
    + by rewrite /vx -rx_s_s'.
    + apply mkSignMagn.
      * exact Hadd_s_us_1.
      * exact Hadd_s_us_2.
      * rewrite !lSum_Z2ints_pos in Hadd_s_us_6 Hadd_s_us_3; last by exact y_st.
        by rewrite Hadd_s_us_3 x'_x_y.
      * rewrite !lSum_Z2ints_pos in Hadd_s_us_6 Hadd_s_us_3; last by exact y_st.
        rewrite -x'_x_y in Hadd_s_us_6.
        case: (Z_zerop (s2Z slen')) => slen'_neq0.
          rewrite -Hadd_s_us_6 slen'_neq0 /=; ring.
        have Hi : u2Z [a3 ]_ s' = 0.
          have : `| sgZ (s2Z slen') * (lSum k X' + u2Z [ a3 ]_ s' * \B^k) | < \B^k.
            by rewrite Hadd_s_us_6 x'_x_y.
          rewrite Zabs_Zmult Zabs_Zsgn_1 // mul1Z addZC.
          apply: poly_Zlt1_Zabs_inv => //.
          by apply min_lSum.
          by apply min_u2Z.
        by rewrite Hi mul0Z addZ0 in Hadd_s_us_6.
    + case: Hadd_s_us_4 => h11 [h12 [h11_d_h12 [h11_U_h12 [Hh11 Hh12]]]].
      apply con_heap_mint_signed_cons with h11.
      * rewrite Hunion.
        apply heap.inclu_union_L => //.
        rewrite h11_U_h12.
        apply heap.inclu_union_L => //.
        exact/heap.inclu_refl.
      * by rewrite -rx_s_s'.
      * by rewrite Hadd_s_us_1.
      * exact Hadd_s_us_1.
      * exact Hh11.
- case: hoare_triple_post_condition => [h1 [h2 [Hdisj [Hunion [[X' [slen' [Hadd_s_us_1 [r_x [r_y [Hadd_s_us_2 [Hadd_s_us_3 [Hadd_s_us_4 [Hadd_s_us_5 Hadd_s_us_6]]]]]]]]]] HTT]]]].
  have Hslen' : heap.get '|u2Z ([ rx ]_ s') / 4| h' = Some slen'.
    rewrite Hunion.
    apply heap.get_union_L => //.
    rewrite assert_m.conAE in Hadd_s_us_4.
    by apply assert_m.mapstos_get1 in Hadd_s_us_4.
  have Hptr : heap.get '|u2Z ([ rx ]_ s' `+ four32) / 4| h' = Some ptr.
    rewrite Hunion.
    apply heap.get_union_L => //.
    rewrite assert_m.conAE in Hadd_s_us_4.
    by apply assert_m.mapstos_get2 in Hadd_s_us_4.
  apply state_mint_part2_two_variables with st s h => //.
  + move/assert_m.mapstos_get2 : (Hmem).
    move/heap_get_heap_mint_inv => ptr_vx4.
    move/assert_m.mapstos_get1 : (Hmem).
    move/heap_get_heap_mint_inv => slen_vx.
    symmetry.
    apply dom_heap_mint_sign_state_invariant with x st slen slen'.
    exact rx_s_s'.
    exact slen_vx.
    exact Hslen'.
    by rewrite Hptr.
    rewrite assoc_prop_m.swap_heads in st_s_h; last by [].
    apply (state_mint_var_mint _ _ _ _ _ _ st_s_h).
    rewrite assoc.get_union_sing_neq; last by Uniq_neq.
    by rewrite assoc.get_union_sing_eq.
    by apply (mips_syntax.dom_heap_invariant _ _ _ _ _ exec_asm).
  + symmetry.
    apply dom_heap_mint_unsign_state_invariant with y st.
    exact rk_s_s'.
    exact ry_s_s'.
    apply (state_mint_var_mint _ _ _ _ _ _ st_s_h).
    rewrite assoc.get_union_sing_neq; last by Uniq_neq.
    by rewrite assoc.get_union_sing_eq.
    by apply (mips_syntax.dom_heap_invariant _ _ _ _ _ exec_asm).
  + move=> t Ht x0 Hx0.
    mips_syntax.Reg_unchanged. simpl mips_frame.modified_regs.
    case/assoc.in_cdom_union_inv : Ht => Ht.
    * rewrite assoc.cdom_sing /= seq.mem_seq1 in Ht.
      move/eqP in Ht; subst t.
      apply (@disj_not_In _ (mint_regs (signed k rx))); last by [].
      Disj_remove_dup.
      rewrite /=.
      apply uniq_disj. rewrite [cat _ _]/=. by Uniq_uniq r0.
    * case/assoc.in_cdom_union_inv : Ht => Ht.
      - rewrite assoc.cdom_sing /= seq.mem_seq1 in Ht.
        move/eqP : Ht => Ht; subst t.
        apply (@disj_not_In _ (mint_regs (unsign rk ry))); last by [].
        Disj_remove_dup.
        rewrite /=.
        apply uniq_disj. rewrite [cat _ _]/=. by Uniq_uniq r0.
      - apply (@disj_not_In _ (mint_regs t)); last by [].
        Disj_remove_dup.
        apply disj_sym.
        apply (disj_incl_LR Hd); last by apply incl_refl_Permutation; PermutProve.
        exact/incP/inc_mint_regs.
  + by Uniq_neq.
  + move: (mips_syntax.exec_deter_proj _ _ _ _ _ exec_asm _ _ _ exec_asm_proj); tauto.
Qed.

Lemma pfwd_sim_multi_add_s_u_wo_overflow (x y : assoc.l) d k rk rx ry a0 a1 a2 a3 a4 a5 rX :
  uniq(x, y) ->
  uniq(rk, rx, ry, a0, a1, a2, a3, a4, a5, rX, r0) ->
  disj (mints_regs (assoc.cdom d)) (a0 :: a1 :: a2 :: a3 :: a4 :: a5 :: rX :: nil)%list ->
  x \notin assoc.dom d -> y \notin assoc.dom d ->
  signed k rx \notin assoc.cdom d -> unsign rk ry \notin assoc.cdom d ->
  (x <- var_e x \+ var_e y)%pseudo_expr%pseudo_cmd
    <=p( state_mint (x |=> signed k rx \U+ (y |=> unsign rk ry \U+ d)),
         fun s st _ => [rk ]_ st <> zero32 /\
         u2Z ([rk ]_ st) < 2 ^^ 31 /\
         k = '|u2Z ([rk ]_ st)| /\
         `| ([x ]_ s)%pseudo_expr | < \B^(k - 1) /\
         0 <= ([y ]_ s)%pseudo_expr < \B^(k - 1))
  multi_add_s_u rk rx ry a0 a1 a2 a3 a4 a5 rX.
Proof.
move=> Hvars Hregs Hd A_d y_d rA_d rk_ry_d.
eapply pfwd_sim_stren; last by apply pfwd_sim_multi_add_s_u.
move=> s st h [rk_neq0 [rk_max [k_rk [A_max y_bounds]]]].
split; first by [].
split; first by [].
split; first by [].
have k_neq0 : k <> O.
  rewrite k_rk.
  contradict rk_neq0.
  apply Zabs_nat_0_inv in rk_neq0.
  rewrite (_ : 0 = u2Z (Z2u 32 0)) in rk_neq0; last by rewrite Z2uK.
  by move/u2Z_inj : rk_neq0.
split.
  apply/(ltZ_trans A_max)/Zbeta_lt; ssromega.
split.
  split; first tauto.
  apply/(ltZ_trans (proj2 y_bounds))/Zbeta_lt; ssromega.
apply: leZ_ltZ_trans; first exact: Z.abs_triangle.
rewrite (geZ0_norm ([y ]_ s)%pseudo_expr); last lia.
apply: ltZ_trans.
  apply: ltZ_add; [exact: A_max | exact: (proj2 y_bounds)].
rewrite /Zbeta Zpower_plus.
apply expZ_2_lt; ssromega.
Qed.


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect.
Require Import SquiggleEq.substitution.
Import ListNotations.
Open Scope string_scope.

Definition capture (T: nat -> Set) (x:nat) (x: T x) := x.

Run TemplateProgram (printTermSq "capture").

Definition captureSyntax :=
(mkLamS (0, nNamed "T")
   (mkPiS (0, nAnon) (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
      (Some sSet) (mkSort sSet) None) None
   (mkLamS (3, nNamed "x") (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
      (Some sSet)
      (mkLamS (3, nNamed "x") (* changed 6 to 3*)
         (oterm (CApply 1)
            [bterm [] (vterm (0, nNamed "T")); bterm [] (vterm (3, nNamed "x"))])
         (Some sSet) (vterm (3, nNamed "x"))))).

Eval vm_compute in (inBarendredgtConvention captureSyntax). (* false *)

Eval vm_compute in (translate false [] captureSyntax).

Definition captureTranslateSyntax
     := mkLamS (0, nNamed "T")
         (mkPiS (0, nAnon) (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
            (Some sSet) (mkSort sSet) None) None
         (mkLamS (1, nNamed "T₂")
            (mkPiS (1, nAnon) (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
               (Some sSet) (mkSort sSet) None) None
            (mkLamS (2, nNamed "T_R")
               (oterm (CApply 2)
                  [bterm []
                     (mkLamS (30, nNamed "ff")
                        (mkPiS (0, nAnon) (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
                           None
                           (oterm (CApply 1)
                              [bterm []
                                 (mkLamS (0, nAnon)
                                    (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0)) None
                                    (mkSort sSet)); bterm [] (vterm (0, nAnon))]) None) None
                        (mkLamS (31, nNamed "ff₂")
                           (mkPiS (1, nAnon) (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
                              None
                              (oterm (CApply 1)
                                 [bterm []
                                    (mkLamS (1, nAnon)
                                       (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0)) None
                                       (mkSort sSet)); bterm [] (vterm (1, nAnon))]) None)
                           None
                           (mkPiS (0, nAnon) (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
                              None
                              (mkPiS (1, nAnon)
                                 (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0)) None
                                 (mkPiS (2, nAnon)
                                    (oterm (CApply 2)
                                       [bterm [] (mkConst "Coq_Init_Datatypes_nat_RR0");
                                       bterm [] (vterm (0, nAnon));
                                       bterm [] (vterm (1, nAnon))]) None
                                    (oterm (CApply 2)
                                       [bterm []
                                          (oterm (CApply 3)
                                             [bterm []
                                                (mkLamS (0, nAnon)
                                                   (mkConstInd
                                                      (mkInd "Coq.Init.Datatypes.nat" 0))
                                                   None
                                                   (mkLamS (1, nAnon)
                                                      (mkConstInd
                                                         (mkInd "Coq.Init.Datatypes.nat" 0))
                                                      None
                                                      (mkLamS (2, nAnon)
                                                         (oterm
                                                            (CApply 2)
                                                            [bterm []
                                                               (mkConst
                                                               "Coq_Init_Datatypes_nat_RR0");
                                                            bterm [] (vterm (0, nAnon));
                                                            bterm [] (vterm (1, nAnon))])
                                                         None
                                                         (mkLamS
                                                            (0, nAnon)
                                                            (mkSort sSet) None
                                                            (mkLamS
                                                               (3, nAnon)
                                                               (mkSort sSet) None
                                                               (mkPiS
                                                               (6, nAnon)
                                                               (vterm (0, nAnon)) None
                                                               (mkPiS
                                                               (9, nAnon)
                                                               (vterm (3, nAnon)) None
                                                               (mkSort sProp) None) None))))));
                                             bterm [] (vterm (0, nAnon));
                                             bterm [] (vterm (1, nAnon));
                                             bterm [] (vterm (2, nAnon))]);
                                       bterm []
                                         (oterm (CApply 1)
                                            [bterm [] (vterm (30, nNamed "ff"));
                                            bterm [] (vterm (0, nAnon))]);
                                       bterm []
                                         (oterm (CApply 1)
                                            [bterm [] (vterm (31, nNamed "ff₂"));
                                            bterm [] (vterm (1, nAnon))])]) None) None) None)));
                  bterm [] (vterm (0, nNamed "T")); bterm [] (vterm (1, nNamed "T₂"))]) None
               (mkLamS (3, nNamed "x") (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0)) None
                  (mkLamS (4, nNamed "x₂") (mkConstInd (mkInd "Coq.Init.Datatypes.nat" 0))
                     None
                     (mkLamS (5, nNamed "x_R")
                        (oterm (CApply 2)
                           [bterm [] (mkConst "Coq_Init_Datatypes_nat_RR0");
                           bterm [] (vterm (3, nNamed "x"));
                           bterm [] (vterm (4, nNamed "x₂"))]) None
                        (mkLamS (3, nNamed "x")
                           (oterm (CApply 1)
                              [bterm [] (vterm (0, nNamed "T"));
                              bterm [] (vterm (3, nNamed "x"))]) None
                           (mkLamS (4, nNamed "x₂")
                              (oterm (CApply 1)
                                 [bterm [] (vterm (1, nNamed "T₂"));
                                 bterm [] (vterm (4, nNamed "x₂"))]) None
                              (mkLamS (5, nNamed "x_R")
                                 (oterm (CApply 2)
                                    [bterm []
                                       (oterm (CApply 3)
                                          [bterm [] (vterm (2, nNamed "T_R"));
                                          bterm [] (vterm (3, nNamed "x"));
                                          bterm [] (vterm (4, nNamed "x₂")); (* capture *)
                                          bterm [] (vterm (5, nNamed "x_R"))]);
                                    bterm [] (vterm (3, nNamed "x"));
                                    bterm [] (vterm (4, nNamed "x₂"))]) None
                                 (vterm (5, nNamed "x_R")))))))))).

Run TemplateProgram (genParam [] false true "capture").
Print capture_RR.
Run TemplateProgram (tmMkDefinitionSq "captureFromSyn" captureSyntax).
Run TemplateProgram (tmMkDefinitionSq "captureTranslate" captureTranslateSyntax).
(*
In environment
T : nat -> Set
T₂ : nat -> Set
T_R : forall H H0 : nat, Coq_Init_Datatypes_nat_RR0 H H0 -> T H -> T₂ H0 -> Prop
x : nat
x₂ : nat
x_R : Coq_Init_Datatypes_nat_RR0 x x₂
x0 : T x
x₂0 : T₂ x₂
The term "x0" has type "T x" while it is expected to have type "nat".
*)


(** * Facts about H-VHDL Environment *)

Require Import common.CoqLib.
Require Import common.proofs.CoqTactics.
Require Import common.NatSet.

Require Import common.NatMap.
Require Import common.proofs.NatMapTactics.
Require Import common.NatSet.

Require Import hvhdl.HVhdlTypes.
Require Import hvhdl.Environment.
Require Import hvhdl.SemanticalDomains.

(** ** Equivalence Relations between Elaborated Designs *)

(** *** Generic Constant Set Equivalence *)

Definition EqGens (Δ Δ' : ElDesign) :=
  forall id t v,
    MapsTo id (Generic t v) Δ <-> MapsTo id (Generic t v) Δ'.

Definition EqGens_refl : forall (Δ : ElDesign), EqGens Δ Δ. firstorder. Defined.
Definition EqGens_trans : forall (Δ Δ' Δ'' : ElDesign), EqGens Δ Δ' -> EqGens Δ' Δ'' -> EqGens Δ Δ''.
  unfold EqGens; intros; transitivity (MapsTo id (Generic t0 v) Δ'); auto.
Defined.
Definition EqGens_sym : forall (Δ Δ' : ElDesign), EqGens Δ Δ' -> EqGens Δ' Δ.
  unfold EqGens; symmetry; auto.
Defined.

Add Parametric Relation : (ElDesign) (EqGens)
    reflexivity proved by EqGens_refl
    symmetry proved by EqGens_sym
    transitivity proved by EqGens_trans
      as EqGens_rel.

(** Enable rewriting [MapsTo id (Generic t v) Δ1] into
    [MapsTo id (Generic t) Δ2] if [EqGens Δ1 Δ2]. *)

Add Parametric Morphism (id : ident) (t : type) (v : value) : (MapsTo id (Generic t v))
    with signature (@EqGens ==> impl) as eqgens_mapsto_mor.
Proof. intros x y H; rewrite (H id t); unfold impl; auto. Qed.

#[export] Hint Resolve EqGens_refl : hvhdl.
#[export] Hint Resolve EqGens_trans : hvhdl.
#[export] Hint Resolve EqGens_sym : hvhdl.

(** *** Input Port Set Equivalence *)

Definition EqIns (Δ Δ' : ElDesign) :=
  forall id t,
    MapsTo id (Input t) Δ <-> MapsTo id (Input t) Δ'.

Definition EqIns_refl : forall (Δ : ElDesign), EqIns Δ Δ. firstorder. Defined.
Definition EqIns_trans : forall (Δ Δ' Δ'' : ElDesign), EqIns Δ Δ' -> EqIns Δ' Δ'' -> EqIns Δ Δ''.
  unfold EqIns; intros; transitivity (MapsTo id (Input t0) Δ'); auto.
Defined.
Definition EqIns_sym : forall (Δ Δ' : ElDesign), EqIns Δ Δ' -> EqIns Δ' Δ.
  unfold EqIns; symmetry; auto.
Defined.

Add Parametric Relation : (ElDesign) (EqIns)
    reflexivity proved by EqIns_refl
    symmetry proved by EqIns_sym
    transitivity proved by EqIns_trans
      as EqIns_rel.

(** Rewrite [MapsTo id (Input t) Δ1] into
    [MapsTo id (Input t) Δ2] if [EqIns Δ1 Δ2]. *)

Add Parametric Morphism (id : ident) (t : type) : (MapsTo id (Input t))
    with signature (@EqIns ==> impl) as eqins_mapsto_in_mor.
Proof. intros x y H; rewrite (H id t); unfold impl; auto. Qed.

(** *** Output Port Set Equivalence *)

Definition EqOuts (Δ Δ' : ElDesign) :=
  forall id t,
    MapsTo id (Output t) Δ <-> MapsTo id (Output t) Δ'.

Definition EqOuts_refl : forall (Δ : ElDesign), EqOuts Δ Δ. firstorder. Defined.
Definition EqOuts_trans : forall (Δ Δ' Δ'' : ElDesign), EqOuts Δ Δ' -> EqOuts Δ' Δ'' -> EqOuts Δ Δ''.
  unfold EqOuts; intros; transitivity (MapsTo id (Output t0) Δ'); auto.
Defined.
Definition EqOuts_sym : forall (Δ Δ' : ElDesign), EqOuts Δ Δ' -> EqOuts Δ' Δ.
  unfold EqOuts; symmetry; auto.
Defined.

Add Parametric Relation : (ElDesign) (EqOuts)
    reflexivity proved by EqOuts_refl
    symmetry proved by EqOuts_sym
    transitivity proved by EqOuts_trans
      as EqOuts_rel.

(** Rewrite [MapsTo id (Output t) Δ1] into
    [MapsTo id (Output t) Δ2] if [EqOuts Δ1 Δ2]. *)

Add Parametric Morphism (id : ident) (t : type) : (MapsTo id (Output t))
    with signature (@EqOuts ==> impl) as eqouts_mapsto_out_mor.
Proof. intros x y H; rewrite (H id t); unfold impl; auto. Qed.

(** *** Internal Signal Set Equivalence *)

Definition EqDecls (Δ Δ' : ElDesign) :=
  forall id t,
    MapsTo id (Internal t) Δ <-> MapsTo id (Internal t) Δ'.

Definition EqDecls_refl : forall (Δ : ElDesign), EqDecls Δ Δ. firstorder. Defined.
Definition EqDecls_trans : forall (Δ Δ' Δ'' : ElDesign), EqDecls Δ Δ' -> EqDecls Δ' Δ'' -> EqDecls Δ Δ''.
  unfold EqDecls; intros; transitivity (MapsTo id (Internal t0) Δ'); auto.
Defined.
Definition EqDecls_sym : forall (Δ Δ' : ElDesign), EqDecls Δ Δ' -> EqDecls Δ' Δ.
  unfold EqDecls; symmetry; auto.
Defined.

Add Parametric Relation : (ElDesign) (EqDecls)
    reflexivity proved by EqDecls_refl
    symmetry proved by EqDecls_sym
    transitivity proved by EqDecls_trans
      as EqDecls_rel.

(** Enable rewriting [MapsTo id (Internal t) Δ1] into
    [MapsTo id (Internal t) Δ2] if [EqDecls Δ1 Δ2]. *)

Add Parametric Morphism (id : ident) (t : type) : (MapsTo id (Internal t))
    with signature (@EqDecls ==> impl) as eqdecls_mapsto_decl_mor.
Proof. intros x y H; rewrite (H id t); unfold impl; auto. Qed.

(** *** Signal (Input, Output and Internal) Set Equivalence *)

Definition EqSigs (Δ Δ' : ElDesign) :=
  EqIns Δ Δ' /\ EqOuts Δ Δ' /\ EqDecls Δ Δ'.

Definition EqSigs_refl : forall (Δ : ElDesign), EqSigs Δ Δ. firstorder. Defined.
Definition EqSigs_trans : forall (Δ Δ' Δ'' : ElDesign), EqSigs Δ Δ' -> EqSigs Δ' Δ'' -> EqSigs Δ Δ''.
  unfold EqSigs; intros; decompose [and] H; decompose [and] H0.
  split_and; transitivity Δ'; auto.
Defined.
Definition EqSigs_sym : forall (Δ Δ' : ElDesign), EqSigs Δ Δ' -> EqSigs Δ' Δ.
  unfold EqSigs; intros; decompose [and] H.
  split_and; symmetry; auto.
Defined.

Add Parametric Relation : (ElDesign) (EqSigs)
    reflexivity proved by EqSigs_refl
    symmetry proved by EqSigs_sym
    transitivity proved by EqSigs_trans
      as EqSigs_rel.

(** Enable rewriting [MapsTo id (Internal t) Δ1] into
    [MapsTo id (Internal t) Δ2] if [EqSigs Δ1 Δ2]. *)

Add Parametric Morphism (id : ident) (t : type) : (MapsTo id (Internal t))
    with signature (@EqSigs ==> impl) as eqsigs_mapsto_decl_mor.
Proof. intros x y H; do 2 (apply proj2 in H); rewrite (H id t); unfold impl; auto. Qed.

(** Enable rewriting [MapsTo id (Output t) Δ1] into
    [MapsTo id (Output t) Δ2] if [EqSigs Δ1 Δ2]. *)

Add Parametric Morphism (id : ident) (t : type) : (MapsTo id (Output t))
    with signature (@EqSigs ==> impl) as eqsigs_mapsto_out_mor.
Proof. intros x y H; apply proj2, proj1 in H. rewrite (H id t); unfold impl; auto. Qed.

(** Enable rewriting [MapsTo id (Input t) Δ1] into
    [MapsTo id (Input t) Δ2] if [EqSigs Δ1 Δ2]. *)

Add Parametric Morphism (id : ident) (t : type) : (MapsTo id (Input t))
    with signature (@EqSigs ==> impl) as eqsigs_mapsto_in_mor.
Proof. intros x y H; apply proj1 in H; rewrite (H id t); unfold impl; auto. Qed.

(** *** Process and Component Instance Set Equivalence *)

Definition EqPs (Δ Δ' : ElDesign) :=
  forall id Λ,
    MapsTo id (Process Λ) Δ <-> MapsTo id (Process Λ) Δ'.

Definition EqComps (Δ Δ' : ElDesign) :=
  forall id Δ__c,
    MapsTo id (Component Δ__c) Δ <-> MapsTo id (Component Δ__c) Δ'.

(** ** Equivalence Relations between Design States *)

(** *** Signal Store Equivalence *)

Definition EqSStore (σ σ' : DState) :=
  forall id v,
    MapsTo id v (sstore σ) <-> MapsTo id v (sstore σ').

Definition EqSStore_refl : forall (σ : DState), EqSStore σ σ. firstorder. Defined.
Definition EqSStore_trans : forall (σ σ' σ'' : DState), EqSStore σ σ' -> EqSStore σ' σ'' -> EqSStore σ σ''.
  unfold EqSStore; intros; transitivity (MapsTo id v (sstore σ')); auto.
Defined.
Definition EqSStore_sym : forall (σ σ' : DState), EqSStore σ σ' -> EqSStore σ' σ.
  unfold EqSStore; symmetry; auto.
Defined.

Add Parametric Relation : (DState) (EqSStore)
    reflexivity proved by EqSStore_refl
    symmetry proved by EqSStore_sym
    transitivity proved by EqSStore_trans
      as EqSStore_rel.

(** Enable rewriting [MapsTo id v (sstore σ1)] into
    [MapsTo id v (sstore σ2)] if [EqSStore σ1 σ2]. *)

Add Parametric Morphism (id : ident) (v : value) : (fun σ => MapsTo id v (sstore σ))
    with signature (@EqSStore ==> impl) as eqsstore_mapsto_mor.
Proof. intros x y H; unfold EqSStore in H; erewrite H; unfold impl; eauto. Qed.

(** *** Component Store Equivalence *)

Definition EqCStore (σ σ' : DState) :=
  forall id σ__c,
    MapsTo id σ__c (cstore σ) <-> MapsTo id σ__c (cstore σ').

Definition EqCStore_refl : forall (σ : DState), EqCStore σ σ. firstorder. Defined.
Definition EqCStore_trans : forall (σ σ' σ'' : DState), EqCStore σ σ' -> EqCStore σ' σ'' -> EqCStore σ σ''.
  unfold EqCStore; intros; transitivity (MapsTo id σ__c (cstore σ')); auto.
Defined.
Definition EqCStore_sym : forall (σ σ' : DState), EqCStore σ σ' -> EqCStore σ' σ.
  unfold EqCStore; symmetry; auto.
Defined.

Add Parametric Relation : (DState) (EqCStore)
    reflexivity proved by EqCStore_refl
    symmetry proved by EqCStore_sym
    transitivity proved by EqCStore_trans
      as EqCStore_rel.

(** Enable rewriting [MapsTo id v (cstore σ1)] into
    [MapsTo id v (cstore σ2)] if [EqSStore σ1 σ2]. *)

Add Parametric Morphism (id : ident) (σ__c : DState) : (fun σ => MapsTo id σ__c (cstore σ))
    with signature (@EqCStore ==> impl) as eqcstore_mapsto_mor.
Proof. intros x y H; unfold EqCStore in H; erewrite H; unfold impl; eauto. Qed.

(** *** Design State Equivalence *)

Definition EqDState (σ σ' : DState) :=
  EqSStore σ σ' /\ EqCStore σ σ'.

Definition EqDState_refl : forall (σ : DState), EqDState σ σ. firstorder. Defined.
Definition EqDState_trans : forall (σ σ' σ'' : DState), EqDState σ σ' -> EqDState σ' σ'' -> EqDState σ σ''.
  unfold EqDState; intros; decompose [and] H; decompose [and] H0.
  split_and; transitivity σ'; auto.
Defined.
Definition EqDState_sym : forall (σ σ' : DState), EqDState σ σ' -> EqDState σ' σ.
  unfold EqDState; intros; decompose [and] H.
  split_and; symmetry; auto.
Defined.

Add Parametric Relation : (DState) (EqDState)
    reflexivity proved by EqDState_refl
    symmetry proved by EqDState_sym
    transitivity proved by EqDState_trans
      as EqDState_rel.

(** Enable rewriting [MapsTo id v (sstore σ1)] into
    [MapsTo id v (sstore σ2)] if [EqDState σ1 σ2]. *)

Add Parametric Morphism (id : ident) (v : value) : (fun σ => MapsTo id v (sstore σ))
    with signature (@EqDState ==> impl) as eqdstate_mapsto_sstore_mor.
Proof. intros x y H; apply proj1 in H; intro; pattern y; rewrite <- H; auto. Qed.

(** Enable rewriting [MapsTo id σ__c (cstore σ1)] into
    [MapsTo id σ__c (cstore σ2)] if [EqDState σ1 σ2]. *)

Add Parametric Morphism (id : ident) (σ__c : DState) : (fun σ => MapsTo id σ__c (cstore σ))
    with signature (@EqDState ==> impl) as eqdstate_mapsto_cstore_mor.
Proof. intros x y H; apply proj2 in H; intro; pattern y; rewrite <- H; auto. Qed.

(** ** Facts about [EqualDom] equivalence *)

Lemma EqualDom_add_1 :
  forall {A : Type} {k} {e : A} {m},
    NatMap.In k m ->
    EqualDom m (NatMap.add k e m).
Proof.
  split; intros.
  destruct (Nat.eq_dec k k0); try subst.
  exists e; apply NatMap.add_1; auto.
  rewrite add_in_iff; right; auto.
  destruct (Nat.eq_dec k k0); try subst; auto.
  erewrite add_in_iff in *; firstorder.
Qed.

(** ** Facts about [merge_natmap] *)

(* Ltac simpl_merge_map := *)
(*   unfold merge_natmap; *)
(*   unfold fold; *)
(*   unfold Raw.fold; *)
(*   unfold flip; *)
(*   try (progress simpl). *)

(* Lemma merge_natmap_id_notin_set : *)
(*   forall {A : Type} (s : list ident) (m1 m2 : IdMap A) (k : ident) (a : A), *)
(*     let f := fun m k1 => *)
(*                match find k1 m1 with *)
(*                | Some a1 => NatMap.add k1 a1 m *)
(*                | _ => m *)
(*                end *)
(*     in *)
(*     ~InA Logic.eq k s -> *)
(*     MapsTo k a m2 -> *)
(*     MapsTo k a (fold_left f s m2). *)
(* Proof. *)
(*   induction s. *)

(*   (* BASE CASE *) *)
(*   - simpl; auto. *)

(*   (* IND. CASE *) *)
(*   - simpl; intros. *)
(*     eapply IHs; eauto. *)
(*     destruct (find (elt:=A) a m1); auto. *)
(*     eapply NatMap.add_2; eauto. *)
(* Qed. *)

(* Lemma merge_natmap_id_notin_set_2 : *)
(*   forall {A : Type} {s m1 m2 k} {x y : A}, *)
(*     let f := fun m k1 => match find k1 m1 with *)
(*                          | Some a1 => NatMap.add k1 a1 m *)
(*                          | _ => m *)
(*                          end *)
(*     in *)
(*     ~InA Logic.eq k s -> *)
(*     MapsTo k x m2 -> *)
(*     MapsTo k y (fold_left f s m2) -> *)
(*     x = y. *)
(* Proof. *)
(*   induction s. *)

(*   (* BASE CASE *) *)
(*   - simpl; intros; eapply MapsTo_fun; eauto. *)

(*   (* IND. CASE *) *)
(*   - simpl; intros. *)
(*     eapply IHs with (m2 := match find (elt:=A) a m1 with *)
(*             | Some a1 => NatMap.add a a1 m2 *)
(*             | None => m2 *)
(*                            end); *)
(*       eauto. *)
(*     destruct (find (elt:=A) a m1); auto. *)
(*     eapply NatMap.add_2; eauto. *)
(* Qed. *)

(* Lemma merge_natmap_notin_m1 : *)
(*   forall {A : Type} {s m1 m2 k} {a : A}, *)
(*     let f := fun m k1 => match find k1 m1 with *)
(*                          | Some a1 => NatMap.add k1 a1 m *)
(*                          | _ => m *)
(*                          end *)
(*     in *)
(*     ~NatMap.In k m1 -> *)
(*     MapsTo k a (fold_left f s m2) -> *)
(*     NatMap.In k m2. *)
(* Proof. *)
(*   induction s; simpl; intros. *)
(*   (* BASE CASE *) *)
(*   - exists a; auto. *)
(*   (* IND. CASE *) *)
(*   - case_eq (find (elt:=A) a m1). *)
(*     (* find = Some x *) *)
(*     intros x e. *)
(*     erewrite <- add_neq_in_iff with (x := a) (e := x); eauto. *)
(*     rewrite e in *; eapply IHs; eauto. *)
(*     intros e1; try subst. *)
(*     match goal with *)
(*     | [ H: ~NatMap.In _ _ |- _ ] => *)
(*       apply H; exists x; eapply find_2; eauto *)
(*     end.     *)
(*     (* find = None *) *)
(*     intros e; rewrite e in *; eapply IHs; eauto. *)
(* Qed. *)

(* Lemma merge_natmap_EqualDom_1 : *)
(*   forall {A: Type} {s m1 m2 m3}, *)
(*     EqualDom m3 m1 -> *)
(*     EqualDom m3 m2 -> *)
(*     EqualDom m1 (@merge_natmap A s m2 m3). *)
(* Proof. *)
(*   destruct s; induction this0. *)
(*   (* BASE CASE *) *)
(*   - simpl_merge_map; intros; firstorder.  *)
(*   (* IND. CASE *) *)
(*   - simpl_merge_map; intros; case_eq (find (elt:=A) a m2); intros; eapply IHthis0; eauto. *)
(*     rewrite <- H; symmetry; eapply EqualDom_add_1; eauto. *)
(*     rewrite (H0 a); exists a0; eapply find_2; eauto. *)
(*     rewrite <- H0; symmetry; eapply EqualDom_add_1; eauto. *)
(*     rewrite (H0 a); exists a0; eapply find_2; eauto. *)
(*     Unshelve. *)
(*     inversion_clear is_ok0; auto. *)
(*     inversion_clear is_ok0; auto. *)
(* Qed. *)

(* Lemma merge_natmap_compl_1 : *)
(*   forall {A : Type} s m1 m2 k (a : A), *)
(*     NatSet.In k s -> *)
(*     MapsTo k a m1 -> *)
(*     MapsTo k a (merge_natmap s m1 m2). *)
(* Proof. *)
(*   destruct s; induction this0. *)
(*   (* BASE CASE *) *)
(*   - inversion 1. *)
(*   (* IND. CASE *) *)
(*   - intros; unfold merge_natmap; unfold fold; unfold Raw.fold; unfold flip. *)
(*     simpl. *)
(*     inversion_clear H; try subst. *)
(*     (* k = a *) *)
(*     + erewrite find_1; eauto. *)
(*       eapply merge_natmap_id_notin_set; eauto. *)
(*       inversion_clear is_ok0; auto. *)
(*       eapply NatMap.add_1; eauto. *)
(*     (* use ind. hyp. *) *)
(*     + eapply IHthis0; eauto. *)
(*       Unshelve. *)
(*       inversion_clear is_ok0; auto. *)
(* Qed. *)

(* Lemma merge_natmap_compl_2 : *)
(*   forall {A : Type} s m1 m2 k (a : A), *)
(*     ~NatSet.In k s -> *)
(*     MapsTo k a m2 -> *)
(*     MapsTo k a (merge_natmap s m1 m2). *)
(* Proof. *)
(*   unfold merge_natmap; unfold fold; unfold Raw.fold; unfold flip. *)
(*   intros; eapply merge_natmap_id_notin_set; eauto. *)
(* Qed. *)

(* Lemma merge_natmap_sound_1 : *)
(*   forall {A : Type} s m1 m2 k (a : A), *)
(*     NatSet.In k s -> *)
(*     EqualDom m1 m2 -> *)
(*     MapsTo k a (merge_natmap s m1 m2) -> *)
(*     MapsTo k a m1. *)
(* Proof. *)
(*   destruct s; induction this0. *)
(*   (* BASE CASE *) *)
(*   - inversion 1. *)
(*   (* IND. CASE *) *)
(*   - simpl_merge_map; inversion_clear 1; try subst. *)
(*     (* CASE k = a *) *)
(*     + case_eq (find (elt:=A) a m1).  *)
(*       (* find = Some a *) *)
(*       intros x e EqualDom_m1m2 MapsTo_foldl. *)
(*       erewrite <- @merge_natmap_id_notin_set_2 with (k := a) (x := x) (y := a0); eauto; *)
(*         [ eapply find_2; eauto | inversion is_ok0; auto | eapply NatMap.add_1; eauto]. *)
(*       (* find = None *) *)
(*       intros e EqualDom_m1m2 MapsTo_foldl. *)
(*       assert (NatMap.In a m2) by (eapply merge_natmap_notin_m1; eauto; *)
(*                                   erewrite not_find_in_iff; eauto). *)
(*       assert (~NatMap.In a m1) by (erewrite not_find_in_iff; eauto). *)
(*       assert (NatMap.In a m1) by (unfold EqualDom in EqualDom_m1m2; erewrite EqualDom_m1m2; eauto). *)
(*       contradiction. *)

(*     (* CASE use ind. hyp. *) *)
(*     + intros EqualDom_m1m2 MapsTo_foldl; *)
(*         eapply IHthis0 with (m2 := match find (elt:=A) a m1 with *)
(*                                    | Some a1 => NatMap.add a a1 m2 *)
(*                                    | None => m2 end); *)
(*         eauto. *)
(*       case_eq (find (elt:=A) a m1); auto. *)
(*       intros x e; split; erewrite add_in_iff. *)
(*       right; unfold EqualDom in EqualDom_m1m2; erewrite <- EqualDom_m1m2; assumption. *)
(*       inversion_clear 1; [ try subst | unfold EqualDom in EqualDom_m1m2; erewrite EqualDom_m1m2; assumption]. *)
(*       exists x; eapply find_2; assumption. *)
(*       Unshelve. inversion_clear is_ok0; auto. *)
(* Qed. *)

(* Lemma merge_natmap_sound_2 : *)
(*   forall {A : Type} s m1 m2 k (a : A), *)
(*     ~NatSet.In k s -> *)
(*     EqualDom m1 m2 -> *)
(*     MapsTo k a (merge_natmap s m1 m2) -> *)
(*     MapsTo k a m2. *)
(* Proof. *)
(*   destruct s; induction this0. *)
(*   (* BASE CASE *) *)
(*   - simpl_merge_map; auto. *)
(*   (* IND. CASE *) *)
(*   - simpl_merge_map; do 5 intro; intros EqualDom_m1m2; intros. *)
(*     case_eq (find (elt:=A) a m1).  *)
(*     (* find = Some a *) *)
(*     intros x e; rewrite e in *. *)
(*     eapply NatMap.add_3 with (x := a) (e' := x). *)
(*     intro; try subst; apply H; auto with set. *)
(*     eapply IHthis0; eauto. *)
(*     intro; apply H; eapply InA_cons_tl; auto. *)
(*     erewrite EqualDom_m1m2. *)
(*     eapply EqualDom_add_1. *)
(*     unfold  EqualDom in EqualDom_m1m2. *)
(*     erewrite <- EqualDom_m1m2. *)
(*     exists x; eapply find_2; eauto. *)
(*     (* find = None *) *)
(*     intros e; rewrite e in *. *)
(*     eapply IHthis0; eauto. *)
(*     intro; apply H; eapply InA_cons_tl; auto. *)
(*     Unshelve. inversion_clear is_ok0; auto. *)
(*     inversion_clear is_ok0; auto. *)
(* Qed. *)

(* Lemma merge_sstore_compl_1 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     In id (events σ) -> *)
(*     MapsTo id v (sstore σ) -> *)
(*     MapsTo id v (merge_sstore σ__o σ σ'). *)
(* Proof. *)
(*   unfold merge_sstore; intros. *)
(*   eapply merge_natmap_compl_1; eauto. *)
(* Qed. *)

(* Lemma merge_sstore_compl_2 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     ~In id (events σ) -> *)
(*     In id (events σ') -> *)
(*     MapsTo id v (sstore σ') -> *)
(*     MapsTo id v (merge_sstore σ__o σ σ'). *)
(* Proof. *)
(*   unfold merge_sstore; intros. *)
(*   eapply merge_natmap_compl_2; eauto. *)
(*   eapply merge_natmap_compl_1; eauto. *)
(* Qed. *)

(* Lemma merge_sstore_compl_3 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     ~In id (events σ U events σ') -> *)
(*     MapsTo id v (sstore σ__o) -> *)
(*     MapsTo id v (merge_sstore σ__o σ σ'). *)
(* Proof. *)
(*   intros; eapply merge_natmap_compl_2; eauto. *)
(*   eapply proj1; eapply not_in_union_2; eauto. *)
(*   eapply merge_natmap_compl_2; eauto. *)
(*   eapply proj2; eapply not_in_union_2; eauto. *)
(* Qed. *)

(* Lemma merge_sstore_sound_1 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     EqualDom (sstore σ__o) (sstore σ) -> *)
(*     EqualDom (sstore σ__o) (sstore σ') -> *)
(*     In id (events σ) -> *)
(*     MapsTo id v (merge_sstore σ__o σ σ') -> *)
(*     MapsTo id v (sstore σ). *)
(* Proof. *)
(*   intros; eapply merge_natmap_sound_1; eauto. *)
(*   eapply merge_natmap_EqualDom_1; eauto. *)
(* Qed. *)

(* Lemma merge_sstore_sound_2 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     EqualDom (sstore σ__o) (sstore σ) -> *)
(*     EqualDom (sstore σ__o) (sstore σ') -> *)
(*     In id (events σ') -> *)
(*     ~In id (events σ) -> *)
(*     MapsTo id v (merge_sstore σ__o σ σ') -> *)
(*     MapsTo id v (sstore σ'). *)
(* Proof. *)
(*   intros; eapply merge_natmap_sound_1 with (m2 := (sstore σ__o)); eauto. *)
(*   symmetry; auto. *)
(*   eapply merge_natmap_sound_2; eauto. *)
(*   eapply merge_natmap_EqualDom_1; eauto. *)
(* Qed. *)

(* Lemma merge_sstore_sound_3 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     EqualDom (sstore σ__o) (sstore σ) -> *)
(*     EqualDom (sstore σ__o) (sstore σ') -> *)
(*     ~In id (events σ U events σ') -> *)
(*     MapsTo id v (merge_sstore σ__o σ σ') -> *)
(*     MapsTo id v (sstore σ__o). *)
(* Proof. *)
(*   unfold merge_sstore; intros. *)
(*   eapply merge_natmap_sound_2 with (s := events σ') (m1 := sstore σ'); eauto. *)
(*   eapply not_in_union_2; eauto. *)
(*   symmetry; assumption. *)
(*   eapply merge_natmap_sound_2 with (s := events σ) (m1 := sstore σ); eauto. *)
(*   eapply not_in_union_2 with (s := events σ) (s' := events σ'); eauto. *)
(*   eapply merge_natmap_EqualDom_1; eauto. *)
(* Qed. *)

(* Lemma merge_cstore_compl_1 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     In id (events σ) -> *)
(*     MapsTo id v (cstore σ) -> *)
(*     MapsTo id v (merge_cstore σ__o σ σ'). *)
(* Proof. *)
(*   intros; eapply merge_natmap_compl_1; eauto. *)
(* Qed. *)

(* Lemma merge_cstore_compl_2 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     ~In id (events σ) -> *)
(*     In id (events σ') -> *)
(*     MapsTo id v (cstore σ') -> *)
(*     MapsTo id v (merge_cstore σ__o σ σ'). *)
(* Proof. *)
(*   intros; eapply merge_natmap_compl_2; eauto. *)
(*   eapply merge_natmap_compl_1; eauto. *)
(* Qed. *)

(* Lemma merge_cstore_compl_3 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     ~In id (events σ U events σ') -> *)
(*     MapsTo id v (cstore σ__o) -> *)
(*     MapsTo id v (merge_cstore σ__o σ σ'). *)
(* Proof. *)
(*   intros; eapply merge_natmap_compl_2; eauto. *)
(*   eapply proj1; eapply not_in_union_2; eauto. *)
(*   eapply merge_natmap_compl_2; eauto. *)
(*   eapply proj2; eapply not_in_union_2; eauto. *)
(* Qed. *)

(* Lemma merge_cstore_sound_1 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     EqualDom (cstore σ__o) (cstore σ) -> *)
(*     EqualDom (cstore σ__o) (cstore σ') -> *)
(*     In id (events σ) -> *)
(*     MapsTo id v (merge_cstore σ__o σ σ') -> *)
(*     MapsTo id v (cstore σ). *)
(* Proof. *)
(*   intros; eapply merge_natmap_sound_1; eauto. *)
(*   eapply merge_natmap_EqualDom_1; eauto. *)
(* Qed. *)

(* Lemma merge_cstore_sound_2 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     EqualDom (cstore σ__o) (cstore σ) -> *)
(*     EqualDom (cstore σ__o) (cstore σ') -> *)
(*     In id (events σ') -> *)
(*     ~In id (events σ) -> *)
(*     MapsTo id v (merge_cstore σ__o σ σ') -> *)
(*     MapsTo id v (cstore σ'). *)
(* Proof. *)
(*   unfold merge_sstore; intros. *)
(*   eapply merge_natmap_sound_1 with (m2 := (cstore σ__o)); eauto. *)
(*   symmetry; auto. *)
(*   eapply merge_natmap_sound_2; eauto. *)
(*   eapply merge_natmap_EqualDom_1; eauto. *)
(* Qed. *)

(* Lemma merge_cstore_sound_3 : *)
(*   forall {id v σ__o σ σ'}, *)
(*     EqualDom (cstore σ__o) (cstore σ) -> *)
(*     EqualDom (cstore σ__o) (cstore σ') -> *)
(*     ~In id (events σ U events σ') -> *)
(*     MapsTo id v (merge_cstore σ__o σ σ') -> *)
(*     MapsTo id v (cstore σ__o). *)
(* Proof. *)
(*   unfold merge_sstore; intros. *)
(*   eapply merge_natmap_sound_2 with (s := events σ') (m1 := cstore σ'); eauto. *)
(*   eapply not_in_union_2; eauto. *)
(*   symmetry; assumption. *)
(*   eapply merge_natmap_sound_2 with (s := events σ) (m1 := cstore σ); eauto. *)
(*   eapply not_in_union_2 with (s := events σ) (s' := events σ'); eauto. *)
(*   eapply merge_natmap_EqualDom_1; eauto. *)
(* Qed. *)

(* (** ** Facts about the [IsMergedDState] relation *) *)

(* Ltac decompose_IMDS := *)
(*   match goal with *)
(*   | [ H: IsMergedDState _ _ _ _ |- _ ] => *)
(*     unfold IsMergedDState in H; decompose [and] H; clear H *)
(*   end. *)

(* Lemma IsMergedDState_comm : *)
(*   forall {σ__o σ σ' σ__m}, *)
(*     IsMergedDState σ__o σ σ' σ__m <-> *)
(*     IsMergedDState σ__o σ' σ σ__m. *)
(* Proof. *)
(*   split; intros; decompose_IMDS; *)
(*     let rec solve_imds := *)
(*         match goal with *)
(*         | |- IsMergedDState _ _ _ _ => split; solve_imds *)
(*         | |- _ /\ _ => split; [solve_imds | solve_imds] *)
(*         | |- _ -> _ -> ~NatSet.In _ (_ U _) -> _ <-> _ => *)
(*           intros; *)
(*             match goal with *)
(*             | [ H: _ -> _ -> ~NatSet.In _ _ -> _ <-> MapsTo _ _ (?f _), H': ~NatSet.In _ _ |- _ <-> MapsTo _ _ (?f _) ] => *)
(*               apply H; auto; do 1 intro; apply H'; *)
(*                 match goal with *)
(*                 | [ H'': NatSet.In _ (_ U _) |- _ ] => *)
(*                   rewrite union_spec in H''; inversion H''; rewrite union_spec; [right; assumption | left; assumption] *)
(*                 end *)
(*             end *)
(*         | |- Equal _ (events ?σ U events ?σ') => *)
(*           transitivity (events σ' U events σ); auto with set *)
(*         | _ => firstorder *)
(*         end in solve_imds. *)
(* Qed. *)

(* Lemma IsMergedDState_ex : *)
(*   forall {σ__o σ σ'}, *)
(*     EqualDom (sstore σ__o) (sstore σ) -> *)
(*     EqualDom (sstore σ__o) (sstore σ') -> *)
(*     EqualDom (cstore σ__o) (cstore σ) -> *)
(*     EqualDom (cstore σ__o) (cstore σ') -> *)
(*     Equal (inter (events σ) (events σ')) {[]} ->  *)
(*     exists σ__m, IsMergedDState σ__o σ σ' σ__m. *)
(* Proof. *)
(*   unfold IsMergedDState; intros. *)
(*   exists (MkDState (merge_sstore σ__o σ σ') (merge_cstore σ__o σ σ') (events σ U events σ')). *)
(*   simpl; split_and; (auto || (try reflexivity)). *)
(*   - eapply merge_natmap_EqualDom_1; symmetry; *)
(*       eapply merge_natmap_EqualDom_1; (eauto || reflexivity). *)
(*   - eapply merge_natmap_EqualDom_1; symmetry; *)
(*       eapply merge_natmap_EqualDom_1; (eauto || reflexivity). *)
(*   - split; [eapply merge_sstore_compl_1; eauto | eapply merge_sstore_sound_1; eauto]. *)
(*   - split; [ eapply merge_sstore_compl_2; eauto; eapply inter_empty_2; eauto *)
(*            | eapply merge_sstore_sound_2; eauto; eapply inter_empty_2; eauto]. *)
(*   - split; [ eapply merge_sstore_compl_3; eauto | eapply merge_sstore_sound_3; eauto]. *)
(*   - split; [ eapply merge_cstore_compl_1; eauto | eapply merge_cstore_sound_1; eauto]. *)
(*   - split; [ eapply merge_cstore_compl_2; eauto; eapply inter_empty_2; eauto *)
(*            | eapply merge_cstore_sound_2; eauto; eapply inter_empty_2; eauto ]. *)
(*   - split; [ eapply merge_cstore_compl_3; eauto | eapply merge_cstore_sound_3; eauto ]. *)
(* Qed. *)

(* Lemma IsMergedDState_assoc_1 : *)
(*   forall {σ σ0 σ1 σ2 σ12 σ01 σ012}, *)
(*     IsMergedDState σ σ1 σ2 σ12 -> *)
(*     IsMergedDState σ σ0 σ12 σ012 -> *)
(*     IsMergedDState σ σ0 σ1 σ01 -> *)
(*     IsMergedDState σ σ01 σ2 σ012. *)
(* Proof. *)
(*   intros; *)
(*     do 3 decompose_IMDS; *)
(*     let rec solve_imds := *)
(*         match goal with *)
(*         | |- IsMergedDState _ _ _ _ => split; solve_imds *)
(*         | |- _ /\ _ => split; [solve_imds | solve_imds] *)
(*         | |- Equal _ (events ?σ U events ?σ') =>  *)
(*           match goal with *)
(*           | [ H: Equal ?ev012 (_ U ?ev12), H': Equal ?ev01 _, H'': Equal ?ev12 _ *)
(*               |- Equal ?ev012 (?ev01 U _) ] => *)
(*             rewrite H; rewrite H'; rewrite H''; auto with set *)
(*           end *)
(*         | _ => auto *)
(*         end in solve_imds. *)

(*         (* [∀ id ∈ (events σ01) -> (sstore σ01) (id) = (sstore σ012) (id)] *) *)
(*         - intros; *)
(*             match goal with *)
(*             | [ H: Equal (events ?σ) (_ U _), H': NatSet.In _ (_ ?σ) |- MapsTo _ _ (_ ?σ) <-> _ ] => *)
(*               rewrite H, union_spec in H'; inversion H' *)
(*             end. *)

(*           (* CASE [id ∈ (events σ0)] *) *)
(*           transitivity (MapsTo id v (sstore σ0)); rw_mapsto. *)

(*           (* CASE [id ∈ (events σ1) ] *) *)
(*           transitivity (MapsTo id v (sstore σ1)); [rw_mapsto | auto]. *)
(*           transitivity (MapsTo id v (sstore σ12)); rw_mapsto; *)
(*             match goal with *)
(*             | [ H: Equal (events ?σ12) _ |- NatSet.In _ (events ?σ12) ] => *)
(*               rewrite H; auto with set *)
(*             end. *)

(*         (* [∀ id ∈ (events σ2) -> (sstore σ2) (id) = (sstore σ012) (id)] *) *)
(*         - intros; *)
(*             transitivity (MapsTo id v (sstore σ12)); rw_mapsto; *)
(*               match goal with *)
(*               | [ H: Equal (events ?σ12) _ |- NatSet.In _ (events ?σ12) ] => *)
(*                 rewrite H; auto with set *)
(*               end. *)

(*         (* [∀ id ∉ (events σ01) U (events σ2) -> (sstore σ) (id) = (sstore σ012) (id)] *) *)
(*         - intros id v; intros; rw_mapsto. *)
(*           match goal with *)
(*           | [ H: Equal (events ?σ12) _, H': Equal (events ?σ01) _, H'': ~NatSet.In _ (events ?σ01 U _) *)
(*               |- ~NatSet.In _ (_ U events ?σ12) ] => *)
(*             rewrite H' in H''; rewrite H; erewrite <- union_assoc; eauto *)
(*           end. *)

(*         (* [∀ id ∈ (events σ01) -> (cstore σ01) (id) = (cstore σ012) (id)] *) *)
(*         - intros id v; intros; *)
(*             match goal with *)
(*             | [ H: Equal (events ?σ) (_ U _), H': NatSet.In _ (_ ?σ) |- MapsTo _ _ (_ ?σ) <-> _ ] => *)
(*               rewrite H, union_spec in H'; inversion H' *)
(*             end. *)

(*           (* CASE [id ∈ (events σ0)] *) *)
(*           transitivity (MapsTo id v (cstore σ0)); rw_mapsto. *)

(*           (* CASE [id ∈ (events σ1) ] *) *)
(*           transitivity (MapsTo id v (cstore σ1)); [rw_mapsto | auto]. *)
(*           transitivity (MapsTo id v (cstore σ12)); rw_mapsto; *)
(*             match goal with *)
(*             | [ H: Equal (events ?σ12) _ |- NatSet.In _ (events ?σ12) ] => *)
(*               rewrite H; auto with set *)
(*             end. *)

(*         (* [∀ id ∈ (events σ2) -> (cstore σ2) (id) = (cstore σ012) (id)] *) *)
(*         - intros id v; intros; *)
(*             transitivity (MapsTo id v (cstore σ12)); rw_mapsto; *)
(*               match goal with *)
(*               | [ H: Equal (events ?σ12) _ |- NatSet.In _ (events ?σ12) ] => *)
(*                 rewrite H; auto with set *)
(*               end. *)

(*         (* [∀ id ∉ (events σ01) U (events σ2) -> (cstore σ) (id) = (cstore σ012) (id)] *) *)
(*         - intros id v; intros; rw_mapsto. *)
(*           match goal with *)
(*           | [ H: Equal (events ?σ12) _, H': Equal (events ?σ01) _, H'': ~NatSet.In _ (events ?σ01 U _) *)
(*               |- ~NatSet.In _ (_ U events ?σ12) ] => *)
(*             rewrite H' in H''; rewrite H; erewrite <- union_assoc; eauto *)
(*           end. *)
(* Qed. *)

(* Lemma IsMergedDState_assoc_2 : *)
(*   forall {σ σ0 σ1 σ2 σ12 σ01 σ012}, *)
(*     IsMergedDState σ σ0 σ1 σ01 -> *)
(*     IsMergedDState σ σ01 σ2 σ012 -> *)
(*     IsMergedDState σ σ1 σ2 σ12 -> *)
(*     IsMergedDState σ σ0 σ12 σ012. *)
(* Proof. *)
(*   intros; *)
(*     do 3 decompose_IMDS; *)
(*     let rec solve_imds := *)
(*         match goal with *)
(*         | |- IsMergedDState _ _ _ _ => split; solve_imds *)
(*         | |- _ /\ _ => split; [solve_imds | solve_imds] *)
(*         | |- Equal _ (events ?σ U events ?σ') => *)
(*           match goal with *)
(*           | [ H: Equal ?ev012 (?ev01 U _), H': Equal ?ev01 _, H'': Equal ?ev12 _ *)
(*               |- Equal ?ev012 (_ U ?ev12) ] => *)
(*             rewrite H; rewrite H'; rewrite H''; auto with set *)
(*           end *)
(*         | _ => auto *)
(*         end in solve_imds. *)

(*         (* [∀ id ∈ (events σ0) -> (sstore σ0) (id) = (sstore σ012) (id)] *) *)
(*         - intros; *)
(*             transitivity (MapsTo id v (sstore σ01)); rw_mapsto; *)
(*               match goal with *)
(*               | [ H: Equal (events ?σ01) _ |- NatSet.In _ (events ?σ01) ] => *)
(*                 rewrite H; auto with set *)
(*               end. *)

(*         (* [∀ id ∈ (events σ12) -> (sstore σ12) (id) = (sstore σ012) (id)] *) *)
(*         - intros; *)
(*           match goal with *)
(*           | [ H: Equal (events ?σ) (_ U _), H': NatSet.In _ (_ ?σ) |- MapsTo _ _ (_ ?σ) <-> _ ] => *)
(*             rewrite H, union_spec in H'; inversion H' *)
(*           end. *)

(*           (* CASE [id ∈ (events σ1)] *) *)
(*           transitivity (MapsTo id v (sstore σ1)); [ rw_mapsto | auto]. *)
(*           transitivity (MapsTo id v (sstore σ01)); rw_mapsto; *)
(*             match goal with *)
(*             | [ H: Equal (events ?σ12) _ |- NatSet.In _ (events ?σ12) ] => *)
(*               rewrite H; auto with set *)
(*             end. *)

(*           (* CASE [id ∈ (events σ2) ] *) *)
(*           transitivity (MapsTo id v (sstore σ2)); rw_mapsto. *)

(*         (* [∀ id ∉ (events σ0) U (events σ12) -> (sstore σ) (id) = (sstore σ012) (id)] *) *)
(*         - intros id v; intros; rw_mapsto. *)
(*           match goal with *)
(*           | [ H: Equal (events ?σ01) _, H': Equal (events ?σ12) _, H'': ~NatSet.In _ (_ U events ?σ12) *)
(*               |- ~NatSet.In _ (events ?σ01 U _) ] => *)
(*             rewrite H' in H''; rewrite H; erewrite union_assoc; eauto *)
(*           end. *)

(*         (* [∀ id ∈ (events σ0) -> (cstore σ0) (id) = (cstore σ012) (id)] *) *)
(*         - intros id v; intros; *)
(*             transitivity (MapsTo id v (cstore σ01)); rw_mapsto; *)
(*               match goal with *)
(*               | [ H: Equal (events ?σ01) _ |- NatSet.In _ (events ?σ01) ] => *)
(*                 rewrite H; auto with set *)
(*               end. *)

(*         (* [∀ id ∈ (events σ12) -> (cstore σ12) (id) = (cstore σ012) (id)] *) *)
(*         - intros id v; intros; *)
(*             match goal with *)
(*             | [ H: Equal (events ?σ) (_ U _), H': NatSet.In _ (_ ?σ) |- MapsTo _ _ (_ ?σ) <-> _ ] => *)
(*               rewrite H, union_spec in H'; inversion H' *)
(*             end. *)

(*           (* CASE [id ∈ (events σ1)] *) *)
(*           transitivity (MapsTo id v (cstore σ1)); [ rw_mapsto | auto]. *)
(*           transitivity (MapsTo id v (cstore σ01)); rw_mapsto; *)
(*             match goal with *)
(*             | [ H: Equal (events ?σ12) _ |- NatSet.In _ (events ?σ12) ] => *)
(*               rewrite H; auto with set *)
(*             end. *)

(*           (* CASE [id ∈ (events σ2) ] *) *)
(*           transitivity (MapsTo id v (cstore σ2)); rw_mapsto. *)

(*         (* [∀ id ∉ (events σ0) U (events σ12) -> (cstore σ) (id) = (cstore σ012) (id)] *) *)
(*         - intros id v; intros; rw_mapsto. *)
(*           match goal with *)
(*           | [ H: Equal (events ?σ01) _, H': Equal (events ?σ12) _, H'': ~NatSet.In _ (_ U events ?σ12) *)
(*               |- ~NatSet.In _ (events ?σ01 U _) ] => *)
(*             rewrite H' in H''; rewrite H; erewrite union_assoc; eauto *)
(*           end. *)
(* Qed. *)


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.
Require Import depoolContract.Lib.CommonStateProofs.
(* Require Import depoolContract.Lib.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.

(* function getProxy(uint64 roundId) internal view inline returns (address) {
        return m_proxies[roundId % 2];
    } *)
(* Definition ProxyBase_Ф_getProxy ( Л_roundId : XInteger64 ) : LedgerT XAddress :=
        ↑3 D2! ProxyBase_ι_m_proxies [[  $ Л_roundId !% $xInt2 ]].

*)

 Lemma ProxyBase_Ф_getProxy_exec : forall ( Л_roundId : XInteger64 ) (l: Ledger) ,
 	 exec_state (ProxyBase_Ф_getProxy Л_roundId ) l = l .
 Proof.
   intros. unfold ProxyBase_Ф_getProxy.
   compute. destructIf; auto; destruct l ; auto.
Qed.

Lemma ProxyBase_Ф_getProxy_eval : forall ( Л_roundId : XInteger64 ) (l: Ledger) ,
    eval_state (ProxyBase_Ф_getProxy Л_roundId) l =
       ( eval_state ( ↑3 ε ProxyBase_ι_m_proxies ) l ) [ xIntMod Л_roundId 2 ] .
Proof.
   intros.
   compute; destructIf; auto.
Qed.

 (* function ProxyBase._recoverStake ( address proxy ,  uint64 requestId ,  address elector )  internal  {
        IProxy ( proxy )  . recover_stake { value :  DePoolLib . ELECTOR_FEE  +  DePoolLib . PROXY_FEE }  ( requestId ,  elector )  ;
     } *)
(* Definition ProxyBase_Ф__recoverStake ( Л_proxy : XAddress )( Л_requestId : XInteger64 )( Л_elector : XAddress ) : LedgerT True :=
U0! Л_value := ↑ε9 DePoolLib_ι_ELECTOR_FEE !+ ↑ε9 DePoolLib_ι_PROXY_FEE ;
sendMessage {| contractAddress :=  Л_proxy;
               contractFunction := DePoolProxyContract_Ф_recover_stakeF Л_requestId Л_elector ;
			   contractMessage := {$ default with  messageValue := Л_value $} |}  .
*)

 Lemma ProxyBase_Ф__recoverStake_exec : forall ( Л_proxy : XAddress ) ( Л_requestId : XInteger64 ) ( Л_elector : XAddress ) (l: Ledger) ,
    let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
    let value := eval_state (↑9 D2! DePoolLib_ι_ELECTOR_FEE) l +
                 eval_state (↑9 D2! DePoolLib_ι_PROXY_FEE) l in
    let newMessage  := {| contractAddress :=  Л_proxy;
                          contractFunction := DePoolProxyContract_Ф_recover_stakeF Л_requestId Л_elector ;
                          contractMessage := {$ default with messageValue := value $} |} in
    exec_state (ProxyBase_Ф__recoverStake Л_proxy Л_requestId Л_elector ) l =
    {$ l With VMState_ι_messages := newMessage :: oldMessages $} .
 Proof.
   intros. auto.
 Qed.

Lemma ProxyBase_Ф__recoverStake_eval : forall ( Л_proxy : XAddress ) ( Л_requestId : XInteger64 ) ( Л_elector : XAddress ) (l: Ledger) ,
 	 eval_state (  ProxyBase_Ф__recoverStake Л_proxy Л_requestId Л_elector ) l = I .
 Proof.
   intros.  auto.
 Qed.

 (* function ProxyBase._sendElectionRequest (
        address proxy ,
        uint64 requestId ,
        uint64 validatorStake ,
        DePoolLib . Request req ,
        address elector
     )
        internal
     {
                        IProxy ( proxy )  . process_new_stake { value :  validatorStake  +  DePoolLib . ELECTOR_FEE  +  DePoolLib . PROXY_FEE }  (
            requestId ,
            req . validatorKey ,
            req . stakeAt ,
            req . maxFactor ,
            req . adnlAddr ,
            req . signature ,
            elector
         )  ;
     } *)

(*  Definition ProxyBase_Ф__sendElectionRequest ( Л_proxy : XAddress )
                                            ( Л_requestId : XInteger64 )
                                            ( Л_validatorStake : XInteger64 )
                                            ( Л_req : DePoolLib_ι_Request )
                                            (Л_elector: XAddress)
: LedgerT True :=
	U0! Л_value := $ Л_validatorStake !+ ↑ε9 DePoolLib_ι_ELECTOR_FEE !+ ↑ε9 DePoolLib_ι_PROXY_FEE  ;
	sendMessage {| contractAddress := Л_proxy;
	               contractFunction := DePoolProxyContract_Ф_process_new_stakeF  Л_requestId (Л_req ->> DePoolLib_ι_Request_ι_validatorKey) (Л_req ->> DePoolLib_ι_Request_ι_stakeAt) (Л_req ->> DePoolLib_ι_Request_ι_maxFactor) (Л_req ->> DePoolLib_ι_Request_ι_adnlAddr) (Л_req ->> DePoolLib_ι_Request_ι_signature) Л_elector;
				   contractMessage := {$ default with  messageValue := Л_value $} |}.  *)

 Lemma ProxyBase_Ф__sendElectionRequest_exec : forall ( Л_proxy : XAddress )
                                                      ( Л_requestId : XInteger64 )
                                                      ( Л_validatorStake : XInteger64 )
                                                      ( Л_req : DePoolLib_ι_Request )
                                                      ( Л_elector : XAddress ) (l: Ledger) ,
 let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
 let value := Л_validatorStake +
              eval_state (↑9 D2! DePoolLib_ι_ELECTOR_FEE) l +
              eval_state (↑9 D2! DePoolLib_ι_PROXY_FEE) l in
 let newMessage  := {| contractAddress :=  Л_proxy;
                       contractFunction := DePoolProxyContract_Ф_process_new_stakeF  Л_requestId
                                                                                (Л_req ->> DePoolLib_ι_Request_ι_validatorKey)
                                                                                (Л_req ->> DePoolLib_ι_Request_ι_stakeAt)
                                                                                (Л_req ->> DePoolLib_ι_Request_ι_maxFactor)
                                                                                (Л_req ->> DePoolLib_ι_Request_ι_adnlAddr)
                                                                                (Л_req ->> DePoolLib_ι_Request_ι_signature)
                                                                                Л_elector ;
                       contractMessage := {$ default with messageValue := value $} |} in
    exec_state (ProxyBase_Ф__sendElectionRequest Л_proxy Л_requestId Л_validatorStake Л_req Л_elector) l =
    {$ l With VMState_ι_messages := newMessage :: oldMessages $} .
 Proof.
   intros. auto.
 Qed.

 Lemma ProxyBase_Ф__sendElectionRequest_eval : forall ( Л_proxy : XAddress )
                                                      ( Л_requestId : XInteger64 )
                                                      ( Л_validatorStake : XInteger64 )
                                                      ( Л_req : DePoolLib_ι_Request )
                                                      ( Л_elector : XAddress ) (l: Ledger) ,
 	 eval_state (ProxyBase_Ф__sendElectionRequest Л_proxy Л_requestId Л_validatorStake Л_req Л_elector ) l = I .
 Proof.
   intros. auto.
 Qed.


Require Import floyd.proofauto.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha.
Require Export sha.pure_lemmas.
Require Export sha.general_lemmas.
Export ListNotations.

Local Open Scope logic.

Global Opaque K256.

Transparent peq.

Lemma mapsto_tc_val:
  forall sh t p v,
  readable_share sh ->
  v <> Vundef ->
  mapsto sh t p v = !! tc_val t v && mapsto sh t p v .
Proof.
intros.
apply pred_ext.
apply andp_right; auto.
unfold mapsto; simpl.
destruct (access_mode t); try apply FF_left.
destruct (type_is_volatile t); try apply FF_left.
destruct p; try apply FF_left.
if_tac; try contradiction. apply orp_left.
normalize.
normalize.
normalize.
Qed.

Fixpoint loops (s: statement) : list statement :=
 match s with
  | Ssequence a b => loops a ++ loops b
  | Sloop _ _ => [s]
  | Sifthenelse _ a b => loops a ++ loops b
  | _ => nil
  end.

Lemma nth_big_endian_integer:
  forall i bl w,
   nth_error bl i = Some w ->
    w = big_endian_integer
                   (sublist (Z.of_nat i * WORD)
                        (Z.succ (Z.of_nat i) * WORD)
                   (map Int.repr (intlist_to_Zlist bl))).
Proof.
induction i; destruct bl; intros; inv H.
*
 unfold sublist; simpl.
 rewrite big_endian_integer4.
 repeat rewrite Int.repr_unsigned.
 assert (Int.zwordsize=32)%Z by reflexivity.
 unfold Z_to_Int, Shr; simpl.
 change 255%Z with (Z.ones 8).
 apply Int.same_bits_eq; intros;
 autorewrite with testbit.
 if_tac; simpl.
 if_tac; simpl.
 if_tac; simpl; autorewrite with testbit. auto. f_equal; omega.
 rewrite if_false by omega. autorewrite with testbit. f_equal; omega.
 rewrite if_false by omega. rewrite if_false by omega.
 autorewrite with testbit. f_equal; omega.
*
specialize (IHi _ _ H1); clear H1.
simpl map.
rewrite IHi.
unfold sublist.
replace (Z.to_nat (Z.of_nat (S i) * WORD)) with (4 + Z.to_nat (Z.of_nat i * WORD))%nat
  by (rewrite plus_comm, inj_S; unfold Z.succ; rewrite Z.mul_add_distr_r;
        rewrite Z2Nat.inj_add by (change WORD with 4; omega); reflexivity).
rewrite <- skipn_skipn.
simpl skipn.
f_equal. f_equal. f_equal. rewrite inj_S.  unfold Z.succ.
rewrite !Z.mul_add_distr_r; omega.
Qed.

Lemma Znth_big_endian_integer:
  forall i bl,
   0 <= i < Zlength bl ->
   Znth i bl Int.zero =
     big_endian_integer
                   (sublist (i * WORD) (Z.succ i * WORD)
                   (map Int.repr (intlist_to_Zlist bl))).
Proof.
intros.
unfold Znth.
 rewrite if_false by omega.
pose proof (nth_error_nth _ Int.zero (Z.to_nat i) bl).
rewrite <- (Z2Nat.id i) at 2 3 by omega.
apply nth_big_endian_integer.
apply H0.
apply Nat2Z.inj_lt.
rewrite Z2Nat.id by omega.
rewrite <- Zlength_correct; omega.
Qed.

Fixpoint sequence (cs: list statement) s :=
 match cs with
 | nil => s
 | c::cs' => Ssequence c (sequence cs' s)
 end.

Fixpoint rsequence (cs: list statement) s :=
 match cs with
 | nil => s
 | c::cs' => Ssequence (rsequence cs' s) c
 end.

Lemma sequence_rsequence:
 forall Espec CS Delta P cs s0 s R,
    @semax CS Espec Delta P (Ssequence s0 (sequence cs s)) R  <->
  @semax CS Espec Delta P (Ssequence (rsequence (rev cs) s0) s) R.
Proof.
intros.
revert Delta P R s0 s; induction cs; intros.
simpl. apply iff_refl.
simpl.
rewrite seq_assoc.
rewrite IHcs; clear IHcs.
replace (rsequence (rev cs ++ [a]) s0) with
    (rsequence (rev cs) (Ssequence s0 a)); [apply iff_refl | ].
revert s0 a; induction (rev cs); simpl; intros; auto.
rewrite IHl. auto.
Qed.

Lemma seq_assocN:
  forall {Espec: OracleKind} CS,
   forall Q Delta P cs s R,
        @semax CS Espec Delta P (sequence cs Sskip) (normal_ret_assert Q) ->
         @semax CS Espec
       (update_tycon Delta (sequence cs Sskip)) Q s R ->
        @semax CS Espec Delta P (sequence cs s) R.
Proof.
intros.
rewrite semax_skip_seq.
rewrite sequence_rsequence.
rewrite semax_skip_seq in H.
rewrite sequence_rsequence in H.
rewrite <- semax_seq_skip in H.
eapply semax_seq'; [apply H | ].
eapply semax_extensionality_Delta; try apply H0.
clear.
revert Delta; induction cs; simpl; intros.
apply tycontext_sub_refl.
eapply tycontext_sub_trans; [apply IHcs | ].
clear.
revert Delta; induction (rev cs); simpl; intros.
apply tycontext_sub_refl.
apply update_tycon_sub.
apply IHl.
Qed.

Fixpoint sequenceN (n: nat) (s: statement) : list statement :=
 match n, s with
 | S n', Ssequence a s' => a::sequenceN n' s'
 | _, _ => nil
 end.

Lemma data_block_local_facts:
 forall {cs: compspecs} sh f data,
  data_block sh f data |--
   prop (field_compatible (tarray tuchar (Zlength f)) [] data
           /\ Forall isbyteZ f).
Proof.
intros. unfold data_block, array_at.
simpl.
entailer.
Qed.
Hint Resolve @data_block_local_facts : saturate_local.

Require Import JMeq.

Lemma reptype_tarray {cs: compspecs}:
   forall t len, reptype (tarray t len) = list (reptype t).
Proof.
intros.
rewrite reptype_eq. simpl. reflexivity.
Qed.

Local Open Scope nat.

(*** Application of Omega stuff ***)

Lemma CBLOCKz_eq : CBLOCKz = 64%Z.
Proof. reflexivity. Qed.
Lemma LBLOCKz_eq : LBLOCKz = 16%Z.
Proof. reflexivity. Qed.

Ltac helper2 :=
 match goal with
   | |- context [CBLOCK] => add_nonredundant (CBLOCK_eq)
   | |- context [LBLOCK] => add_nonredundant (LBLOCK_eq)
   | |- context [CBLOCKz] => add_nonredundant (CBLOCKz_eq)
   | |- context [LBLOCKz] => add_nonredundant (LBLOCKz_eq)
   | H: context [CBLOCK] |- _ => add_nonredundant (CBLOCK_eq)
   | H: context [LBLOCK] |- _ => add_nonredundant (LBLOCK_eq)
   | H: context [CBLOCKz] |- _ => add_nonredundant (CBLOCKz_eq)
   | H: context [LBLOCKz] |- _ => add_nonredundant (LBLOCKz_eq)
  end.

Ltac Omega1 := Omega (helper1 || helper2).

Ltac MyOmega :=
  rewrite ?length_list_repeat, ?skipn_length, ?map_length,
   ?Zlength_map, ?Zlength_nil;
  pose proof CBLOCK_eq;
  pose proof CBLOCKz_eq;
  pose proof LBLOCK_eq;
  pose proof LBLOCKz_eq;
  Omega1.
(*** End Omega stuff ***)

Local Open Scope Z.

Local Open Scope logic.

Lemma data_block_valid_pointer sh l p: sepalg.nonidentity sh -> Zlength l > 0 ->
      data_block sh l p |-- valid_pointer p.
Proof. unfold data_block. simpl; intros.
  apply andp_valid_pointer2. apply data_at_valid_ptr; auto; simpl.
  rewrite Z.max_r, Z.mul_1_l; omega.
Qed.

Lemma data_block_isbyteZ:
 forall sh data v, data_block sh data v = !! Forall isbyteZ data && data_block sh data v.
Proof.
unfold data_block; intros.
simpl.
normalize.
f_equal. f_equal. apply prop_ext. intuition.
Qed.

Lemma sizeof_tarray_tuchar:
 forall (n:Z), (n>=0)%Z -> (sizeof (tarray tuchar n) =  n)%Z.
Proof. intros.
 unfold sizeof,tarray; cbv beta iota.
  rewrite Z.max_r by omega.
  unfold alignof, tuchar; cbv beta iota.
  rewrite Z.mul_1_l. auto.
Qed.

Lemma isbyte_value_fits_tuchar:
  forall x, isbyteZ x -> value_fits tuchar (Vint (Int.repr x)).
Proof.
intros. hnf in H|-*; intros.
simpl. rewrite Int.unsigned_repr by repable_signed.
  change Byte.max_unsigned with 255%Z. omega.
Qed.

Lemma Zlength_Zlist_to_intlist:
  forall (n:Z) (l: list Z),
   (Zlength l = WORD*n)%Z -> Zlength (Zlist_to_intlist l) = n.
Proof.
intros.
rewrite Zlength_correct in *.
assert (0 <= n)%Z by ( change WORD with 4%Z in H; omega).
rewrite (length_Zlist_to_intlist (Z.to_nat n)).
apply Z2Nat.id; auto.
apply Nat2Z.inj. rewrite H.
rewrite Nat2Z.inj_mul.
f_equal. rewrite Z2Nat.id; omega.
Qed.

Lemma nth_intlist_to_Zlist_eq:
 forall d (n i j k: nat) al, (i < n)%nat -> (i < j*4)%nat -> (i < k*4)%nat ->
    nth i (intlist_to_Zlist (firstn j al)) d = nth i (intlist_to_Zlist (firstn k al)) d.
Proof.
 induction n; destruct i,al,j,k; simpl; intros; auto; try omega.
 destruct i; auto. destruct i; auto. destruct i; auto.
 apply IHn; omega.
Qed.

Hint Resolve isbyteZ_sublist.

Lemma split2_data_block:
  forall  {cs: compspecs}  n sh data d,
  (0 <= n <= Zlength data)%Z ->
  data_block sh data d =
  (data_block sh (sublist 0 n data) d *
   data_block sh (sublist n (Zlength data) data)
   (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc n] d))%logic.
Proof.
  intros.
  unfold data_block. simpl. normalize.
  f_equal. f_equal.
  apply prop_ext.
  split; intro. split; apply Forall_sublist; auto.
  erewrite <- (sublist_same 0 (Zlength data)); auto.
  rewrite (sublist_split 0 n) by omega.
  apply Forall_app; auto.
  rewrite <- !sublist_map.
  unfold tarray.
  rewrite split2_data_at_Tarray_tuchar with (n1:=n) by (autorewrite with sublist; auto).
  autorewrite with sublist.
  reflexivity.
Qed.

Lemma split3_data_block:
  forall  {cs: compspecs} lo hi sh data d,
  0 <= lo <= hi ->
  hi <= Zlength data  ->
  data_block sh data d =
  (data_block sh (sublist 0 lo data) d *
   data_block sh (sublist lo hi data)
   (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc lo] d) *
   data_block sh (sublist hi (Zlength data) data)
   (field_address0 (tarray tuchar (Zlength data)) [ArraySubsc hi] d))%logic.
Proof.
  intros.
  unfold data_block. simpl. normalize.
  f_equal. f_equal.
  apply prop_ext.
  split; intro. split3; apply Forall_sublist; auto.
  erewrite <- (sublist_same 0 (Zlength data)); auto.
  rewrite (sublist_split 0 lo (Zlength data)) by omega.
  rewrite (sublist_split lo hi (Zlength data)) by omega.
  destruct H1 as [? [? ?]].
  repeat (apply Forall_app; split);  auto.
  rewrite <- !sublist_map.
  unfold tarray.
  rewrite split3_data_at_Tarray_tuchar with (n1:=lo)(n2:=hi) by (autorewrite with sublist; auto).
  autorewrite with sublist.
  reflexivity.
Qed.

Global Opaque WORD.

Lemma S256abs_data:
  forall hashed data,
   (LBLOCKz | Zlength hashed) ->
   Zlength data < CBLOCKz ->
   s256a_data (S256abs hashed data) = data.
Proof.
intros. unfold S256abs, s256a_data.
rewrite Zlength_app.
rewrite Zlength_intlist_to_Zlist.
destruct H as [n ?].
rewrite H.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (n * CBLOCKz + Zlength data) CBLOCKz H1).
pose proof (Zmod_eq (Zlength data) CBLOCKz H1).
pose proof (Zlength_nonneg data).
rewrite sublist_app2; rewrite Zlength_intlist_to_Zlist; rewrite H;
 rewrite <- Z.mul_assoc; change (LBLOCKz * 4)%Z with CBLOCKz.
apply sublist_same.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega. omega.
omega.
rewrite Z.div_add_l by  omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.
split; [ | omega].
apply Z.mul_nonneg_nonneg.
clear - H.
assert (n < 0 \/ 0 <= n) by omega.
destruct H0; auto.
pose proof (Zlength_nonneg hashed).
assert (n * LBLOCKz < 0).
apply Z.mul_neg_pos; auto.
omega.
omega.
Qed.

Lemma S256abs_hashed:
  forall hashed data,
   (LBLOCKz | Zlength hashed) ->
   Zlength data < CBLOCKz ->
   s256a_hashed (S256abs hashed data) = hashed.
Proof.
intros;  unfold S256abs, s256a_hashed.
rewrite Zlength_app.
rewrite Zlength_intlist_to_Zlist.
destruct H as [n ?].
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (n * CBLOCKz + Zlength data) CBLOCKz H1).
pose proof (Zmod_eq (Zlength data) CBLOCKz H1).
pose proof (Zlength_nonneg data).
rewrite sublist_app1; rewrite ?Zlength_intlist_to_Zlist;
  rewrite H.
rewrite sublist_same; try omega.
apply intlist_to_Zlist_to_intlist.
rewrite Zlength_intlist_to_Zlist.
  rewrite H.
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.  omega.
split; [omega | ].
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.
clear - H.
assert (n < 0 \/ 0 <= n) by omega.
simpl.
destruct H0.
pose proof (Zlength_nonneg hashed).
assert (n * LBLOCKz < 0).
apply Z.mul_neg_pos; auto.
omega.
rewrite Z.add_0_r.
apply Z.mul_nonneg_nonneg; auto.
rewrite <- Z.mul_assoc; change (LBLOCKz*4)%Z with CBLOCKz.
rewrite Z.div_add_l by omega.
rewrite Z.mul_add_distr_r.
rewrite Z.div_small by omega.  omega.
Qed.

Lemma s256a_hashed_divides:
  forall a, (LBLOCKz | Zlength (s256a_hashed a)).
Proof.
intros. unfold s256a_hashed.
exists (Zlength a / CBLOCKz)%Z.
erewrite Zlength_Zlist_to_intlist; [reflexivity |].
rewrite Zlength_sublist.
rewrite (Z.mul_comm WORD).
rewrite <- Z.mul_assoc.
change (LBLOCKz * WORD)%Z with CBLOCKz.
omega.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
rewrite CBLOCKz_eq; omega.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
Qed.

Lemma s256a_data_len:
  forall a: s256abs,
  Zlength (s256a_data a) = Zlength a mod CBLOCKz.
Proof.
intros.
unfold s256a_data.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
rewrite H0.
rewrite Zlength_sublist; try omega.
split; try omega.
apply Z.mul_nonneg_nonneg.
apply Z.div_pos.
apply Zlength_nonneg.
omega. omega.
Qed.

Lemma s256a_data_Zlength_less:
  forall a, Zlength (s256a_data a) < CBLOCKz.
Proof.
intros.
rewrite s256a_data_len.
apply Z_mod_lt.
rewrite CBLOCKz_eq; omega.
Qed.

Lemma hashed_data_recombine:
  forall a,
     Forall isbyteZ a ->
    intlist_to_Zlist (s256a_hashed a) ++ s256a_data a = a.
Proof.
intros. rename H into BYTES.
unfold s256a_hashed, s256a_data.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
rewrite Zlist_to_intlist_to_Zlist.
rewrite sublist_rejoin.
autorewrite with sublist. auto.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
rewrite CBLOCKz_eq; omega.
assert (CBLOCKz > 0) by (rewrite CBLOCKz_eq; omega).
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
rewrite Zlength_sublist.
rewrite Z.sub_0_r.
apply Z.divide_mul_r.
exists LBLOCKz. reflexivity.
split; [ omega  |] .
apply Z.mul_nonneg_nonneg; auto.
apply Z.div_pos.
apply Zlength_nonneg.
omega.
pose proof (Zmod_eq (Zlength a) CBLOCKz H).
pose proof (Z_mod_lt (Zlength a) CBLOCKz H).
omega.
apply Forall_sublist.
auto.
Qed.

Definition bitlength (hashed: list int) (data: list Z) : Z :=
   ((Zlength hashed * WORD + Zlength data) * 8)%Z.

Lemma bitlength_eq:
  forall hashed data,
  bitlength hashed data = s256a_len (S256abs hashed data).
Proof.
intros.
unfold bitlength, s256a_len, S256abs.
rewrite Zlength_app.
rewrite Zlength_intlist_to_Zlist.
reflexivity.
Qed.

Lemma S256abs_recombine:
 forall a, Forall isbyteZ a ->
    S256abs (s256a_hashed a) (s256a_data a) = a.
Proof.
intros.
apply hashed_data_recombine; auto.
Qed.

Lemma Zlist_to_intlist_app:
  forall a b,
  (WORD | Zlength a) ->
   Zlist_to_intlist (a++b) = Zlist_to_intlist a ++ Zlist_to_intlist b.
Proof.
intros.
destruct H as [na H].
rewrite <- (Z2Nat.id na) in H.
Focus 2.
destruct (zlt na 0); try omega.
assert (na * WORD < 0); [apply Z.mul_neg_pos; auto | ].
pose proof (Zlength_nonneg a); omega.
revert a H; induction (Z.to_nat na); intros.
simpl in H. destruct a. simpl. auto. rewrite Zlength_cons in H.
pose proof (Zlength_nonneg a); omega.
rewrite inj_S in H.
unfold Z.succ in H. rewrite Z.mul_add_distr_r in H.
change (1*WORD)%Z with 4 in H.
assert (Zlength a >= 4).
assert (0 <= Z.of_nat n * WORD); [ | omega].
apply Z.mul_nonneg_nonneg; try omega.
change WORD with 4%Z; omega.
do 4 (destruct a; [rewrite Zlength_nil in H0; omega | rewrite Zlength_cons in H,H0  ]).
simpl.
do 4 f_equal. apply IHn.
omega.
Qed.

Lemma round_range:
 forall {A} (a: list A) (N:Z),
  N > 0 ->
   0 <= Zlength a / N * N <= Zlength a.
Proof.
intros.
split.
apply Z.mul_nonneg_nonneg; auto; try omega.
apply Z.div_pos; try omega.
apply Zlength_nonneg.
pose proof (Zmod_eq (Zlength a) N H).
pose proof (Z_mod_lt (Zlength a) N H).
omega.
Qed.

Lemma CBLOCKz_gt: CBLOCKz > 0.
Proof. rewrite CBLOCKz_eq; omega.
Qed.

Lemma Zlist_to_intlist_inj:
  forall a b,
   (WORD | Zlength a) ->
   (WORD | Zlength b) ->
   Forall isbyteZ a ->
   Forall isbyteZ b ->
   Zlist_to_intlist a = Zlist_to_intlist b ->
   a=b.
Proof.
intros.
rewrite <- (Zlist_to_intlist_to_Zlist a) by auto.
rewrite H3.
apply Zlist_to_intlist_to_Zlist; auto.
Qed.

Definition update_abs (incr: list Z) (a: list Z) (a': list Z) :=
    a' = a ++ incr.

Lemma update_abs_eq:
  forall msg a a',
 Forall isbyteZ (a++msg) ->
 Forall isbyteZ a' ->
 (update_abs msg a a' <->
  exists blocks,
    s256a_hashed a' = s256a_hashed a ++ blocks /\
    s256a_data a ++ msg = intlist_to_Zlist blocks ++ s256a_data a').
Proof.
intros. rename H0 into H'.
unfold update_abs.
assert (0 <= 0 <= Zlength a / CBLOCKz * CBLOCKz). {
 split; [omega | ].
 apply Z.mul_nonneg_nonneg.
 apply Z.div_pos.
 apply Zlength_nonneg.
 rewrite CBLOCKz_eq; omega.
 rewrite CBLOCKz_eq; omega.
}
pose proof (round_range a _ CBLOCKz_gt).
pose proof (round_range (a++msg) _ CBLOCKz_gt).
split; intro.
*
subst a'.
unfold s256a_hashed.
exists (Zlist_to_intlist
            (sublist (Zlength a / CBLOCKz * CBLOCKz) (Zlength (a++msg) / CBLOCKz * CBLOCKz)
                  (a++msg))).
split.
 +
 rewrite (sublist_split 0 (Zlength a / CBLOCKz * CBLOCKz)); auto.
 rewrite Zlist_to_intlist_app.
 f_equal.
 rewrite sublist_app1; auto. omega.
 rewrite Zlength_sublist; auto.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 rewrite Zlength_app.
 pose proof (Zlength_nonneg msg); omega.
 split; [ | apply round_range; apply CBLOCKz_gt].
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
 rewrite Zlength_app; Omega1.
 +
 rewrite Zlist_to_intlist_to_Zlist.
 Focus 2. rewrite Zlength_sublist. rewrite <- Z.mul_sub_distr_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [Omega1 | ].
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
 rewrite Zlength_app; Omega1.
 apply round_range. apply CBLOCKz_gt.
 2: apply Forall_sublist; auto.
 unfold s256a_data.
 destruct (zlt   (Zlength (a ++ msg) / CBLOCKz * CBLOCKz) (Zlength a) ).
  -
   rewrite sublist_app1; try omega.
   rewrite (sublist_split (Zlength (a ++ msg) / CBLOCKz * CBLOCKz)
               (Zlength a) (Zlength (a ++ msg))); try omega.
   rewrite sublist_app1; try omega.
   rewrite sublist_app2 by omega.
   autorewrite with sublist.
   rewrite (sublist_same 0) by omega.
   rewrite <- app_ass. f_equal.
   rewrite sublist_rejoin; try omega. auto.
   split. apply round_range; apply CBLOCKz_gt.
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
  Omega1.
  rewrite Zlength_app in l; omega.
  rewrite Zlength_app; Omega1.
   split. apply round_range; apply CBLOCKz_gt.
 apply Zmult_le_compat_r; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_le_mono; [rewrite CBLOCKz_eq; omega| ].
  rewrite Zlength_app; Omega1.
 -
   rewrite (sublist_split (Zlength a / CBLOCKz * CBLOCKz) (Zlength a)
                  (Zlength (a ++ msg) / CBLOCKz * CBLOCKz) ); auto.
   rewrite app_ass.
   rewrite sublist_app1; try omega.
   rewrite sublist_app2; try omega.
   rewrite Z.sub_diag.
   f_equal.
   rewrite sublist_app2; try omega.
   rewrite sublist_rejoin.
   autorewrite with sublist. auto.
   omega.
  split; try omega. rewrite Zlength_app; Omega1.
   omega.
*
destruct H3 as [blocks [? ?]].
match type of H3 with ?A = ?B =>
  assert (Zlength A * WORD = Zlength B * WORD)%Z by congruence
end.
match type of H4 with ?A = ?B =>
  assert (sublist 0 (Zlength a / CBLOCKz * CBLOCKz) a ++ A =
              sublist 0 (Zlength a / CBLOCKz * CBLOCKz) a ++ B) by congruence
end.
unfold s256a_hashed, s256a_data in *.
rewrite <- app_ass in H6.
rewrite sublist_rejoin in H6 by omega.
rewrite sublist_same in H6 by omega.
rewrite H6.
clear H6 H4.
rewrite <- (sublist_same 0 (Zlength a') a') at 1; auto.
rewrite <- app_ass.
rewrite (sublist_split 0 (Zlength a' / CBLOCKz * CBLOCKz) (Zlength a')); try omega.
f_equal.
apply Zlist_to_intlist_inj.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [clear; omega | ].
 apply Z.mul_nonneg_nonneg; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_pos; [ | rewrite CBLOCKz_eq; omega].
 apply Zlength_nonneg.
 apply round_range; apply CBLOCKz_gt.
 rewrite Zlength_app.
 apply Z.divide_add_r.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 split; [clear; omega | ].
 apply Z.mul_nonneg_nonneg; [ | rewrite CBLOCKz_eq; omega].
 apply Z.div_pos; [ | rewrite CBLOCKz_eq; omega].
 apply Zlength_nonneg.
 apply round_range; apply CBLOCKz_gt.
 exists (Zlength blocks).
 apply Zlength_intlist_to_Zlist.
 apply Forall_sublist; auto.
 apply Forall_app; split.
 apply Forall_app in H; destruct H;
 apply Forall_sublist; auto.
 apply isbyte_intlist_to_Zlist.
 rewrite H3.
 rewrite Zlist_to_intlist_app. f_equal.
 symmetry; apply intlist_to_Zlist_to_intlist.
rewrite Zlength_sublist.
 rewrite Z.sub_0_r.
 apply Z.divide_mul_r.
 exists LBLOCKz; reflexivity.
 auto.
 omega.
 split; [clear; omega |].
 apply round_range; apply CBLOCKz_gt.
 split; [ | clear; omega].
 apply round_range; apply CBLOCKz_gt.
Qed.

Lemma array_at_memory_block:
 forall {cs: compspecs} sh t gfs lo hi v p n,
  sizeof (nested_field_array_type t gfs lo hi) = n ->
  lo <= hi ->
  array_at sh t gfs lo hi v p |--
  memory_block sh n (field_address0 t (ArraySubsc lo :: gfs) p).
Proof.
intros.
rewrite  array_at_data_at by auto.
normalize.
unfold at_offset.
rewrite field_address0_offset by auto.
subst n.
apply data_at_memory_block.
Qed.

Hint Extern 2 (array_at _ _ _ _ _ _ _ |-- memory_block _ _ _) =>
   (apply array_at_memory_block; try reflexivity; try omega) : cancel.


Require Import floyd.proofauto.
Require Import progs.field_loadstore.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope logic.

Lemma Znth_map: forall {A B} n xs d (f: A -> B),
  Znth n (map f xs) (f d) = f (Znth n xs d).
Proof.
  intros.
  unfold Znth.
  if_tac.
  + reflexivity.
  + apply map_nth.
Qed.

Lemma legal_Znth_map: forall {A B} n xs dA dB (f: A -> B),
  0 <= n < Zlength xs ->
  Znth n (map f xs) dB = f (Znth n xs dA).
Proof.
  intros.
  unfold Znth.
  if_tac.
  + omega.
  + apply nth_map'.
    rewrite Zlength_correct in H.
    destruct H.
    apply Z2Nat.inj_lt in H1; [ | omega | omega].
    rewrite Nat2Z.id in H1.
    exact H1.
Qed.

Definition t_struct_b := Tstruct _b noattr.

Definition sub_spec (sub_id: ident) :=
 DECLARE sub_id
  WITH v : val * list (val*val) , p: val
  PRE  []
        PROP  (is_int I8 Signed (snd (nth 1%nat (snd v) (Vundef, Vundef))))
        LOCAL (gvar _p p)
        SEP   (data_at Ews t_struct_b v p)
  POST [ tint ]
        PROP() LOCAL()
        SEP(data_at Ews t_struct_b (snd (nth 1%nat (snd v) (Vundef, Vundef)), snd v) p).

Definition sub_spec' (sub_id: ident) :=
 DECLARE sub_id
  WITH v : reptype t_struct_b, p: val
  PRE  []
        PROP  (is_int I8 Signed (proj_reptype _ (DOT _y2 SUB 1 DOT _x2) v))
        LOCAL (gvar _p p)
        SEP   (data_at Ews t_struct_b v p)
  POST [ tint ]
        PROP() LOCAL()
        SEP(data_at Ews t_struct_b
           (upd_reptype t_struct_b (DOT _y1) v
             (proj_reptype t_struct_b (StructField _x2 :: ArraySubsc 1 :: StructField _y2 :: nil) v))
           p).

Lemma spec_coincide: sub_spec' = sub_spec.
Proof.
(*reflexivity.*)
Abort.

Definition Gprog : funspecs :=   ltac:(with_library prog [
    sub_spec _sub1; sub_spec _sub2; sub_spec _sub3]).

Lemma body_sub1:  semax_body Vprog Gprog f_sub1 (sub_spec _sub1).
Proof.
  unfold sub_spec.
  start_function.
  forward.
  forward.
  forward.
Qed.

Lemma body_sub2:  semax_body Vprog Gprog f_sub2 (sub_spec _sub2).
Proof.
  unfold sub_spec.
  start_function.
  forward.
  forward.
  forward.
Qed.

Lemma body_sub3:  semax_body Vprog Gprog f_sub3 (sub_spec _sub3).
Proof.
  unfold sub_spec.
  start_function.
  forward.
  forward.
  forward.
  forward.
Qed.