Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import Coq.Lists.List. Import ListNotations.
Require Import sha.general_lemmas.

Require Import tweetnacl20140427.split_array_lemmas.
Require Import ZArith.
Local Open Scope Z.
From tweetnacl20140427
 Require Import tweetNaclBase Salsa20 verif_salsa_base
      tweetnaclVerifiableC Snuffle spec_salsa
     verif_crypto_stream_salsa20_xor1.
Opaque Snuffle.Snuffle.

Definition Inv cInit mInit bInit k nonce x z Nonce K mcont zcont gv:=
(EX rounds:nat, EX m:_, EX zbytesR:list byte, EX srbytes:list byte,
 let r64 := (Z.of_nat rounds * 64)%Z in
 let c := offset_val r64 cInit in
 let b := Int64.sub bInit (Int64.repr r64) in
  (PROP  (0 <= r64 <= Int64.unsigned bInit /\ null_or_offset mInit r64 m
          /\ CONTENT SIGMA K mInit mcont zcont rounds zbytesR srbytes)
   LOCAL  (lvar _x (Tarray tuchar 64 noattr) x;
           lvar _z (Tarray tuchar 16 noattr) z; temp _c c; temp _m m;
           temp _b (Vlong b); temp _k k; gvars gv)
   SEP (data_at Tsh (Tarray tuchar 16 noattr) (Bl2VL zbytesR) z;
     data_at_ Tsh (Tarray tuchar 64 noattr) x; Sigma_vector (gv _sigma);
     data_at Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList Nonce) nonce;
     ThirtyTwoByte K k;
     data_at Tsh (Tarray tuchar  (Z.of_nat rounds * 64) noattr) (Bl2VL srbytes) cInit;
     data_at_ Tsh (Tarray tuchar (Int64.unsigned bInit - Z.of_nat rounds * 64) noattr) c;
     message_at mcont mInit))).

Definition IfPost z x b Nonce K mCont cLen nonce c k m zbytes gv :=
  PROP ()
  LOCAL (lvar _x (Tarray tuchar 64 noattr) x;
   lvar _z (Tarray tuchar 16 noattr) z;
   temp _k k; gvars gv)
  SEP (data_at_ Tsh (Tarray tuchar 16 noattr) z;
      data_at_ Tsh (Tarray tuchar 64 noattr) x; Sigma_vector (gv _sigma);
      SByte Nonce nonce; ThirtyTwoByte K k; message_at mCont m;
      (if Int64.eq b Int64.zero
       then data_at_ Tsh (Tarray tuchar cLen noattr) c
       else EX COUT:_, !!ContSpec b SIGMA K m mCont zbytes COUT &&
            data_at Tsh (Tarray tuchar cLen noattr) (Bl2VL COUT) c)).

Lemma crypto_stream_salsa20_xor_ok: semax_body SalsaVarSpecs SalsaFunSpecs
      f_crypto_stream_salsa20_tweet_xor
      crypto_stream_salsa20_xor_spec.
Proof.
start_function.
rename H into MLEN.
(*assert_PROP (isptr v_z) as isptrZ by entailer!.*)

forward_if (b <> Int64.zero).
{ forward.
  change (Int64.unsigned _) with 0.
  unfold crypto_stream_xor_postsep.
  rewrite Int64.eq_true. cancel.
 }
{ forward. entailer!!. }
Intros. rename H into B.
assert_PROP (field_compatible (Tarray tuchar (Int64.unsigned b) noattr) [] c) as FC by entailer!.
freeze FR1 := - (data_at_ _ _ v_z).
forward_for_simple_bound 16 (EX i:Z,
  (PROP  ()
   LOCAL  (lvar _x (tarray tuchar 64) v_x; lvar _z (tarray tuchar 16) v_z;
   temp _c c; temp _m m; temp _b (Vlong b); temp _n nonce; temp _k k; gvars gv)
   SEP  (FRZL FR1; EX l:_, !!(Zlength l + i = 16) && data_at Tsh (tarray tuchar 16)
          ((Zrepeat (Vint Int.zero) i) ++ l) v_z))).
{Exists  (default_val (tarray tuchar 16)). simpl app. entailer!!. }
{ rename H into I. Intros l. rename H into LI16.
  forward. Exists (sublist 1 (Zlength l) l). entailer!!. list_solve. list_simplify.
}
Intros l. destruct l; [clear H | list_solve].
rewrite app_nil_r.
thaw FR1.
freeze FR2 := - (SByte Nonce _) (data_at _ _ _ v_z).
unfold SByte.
forward_for_simple_bound 8 (EX i:Z,
  (PROP  ()
   LOCAL  (lvar _x (Tarray tuchar 64 noattr) v_x;
   lvar _z (Tarray tuchar 16 noattr) v_z; temp _c c; temp _m m;
   temp _b (Vlong b); temp _n nonce; temp _k k; gvars gv)
   SEP
   (FRZL FR2; data_at Tsh (Tarray tuchar 16 noattr)
        (sublist 0 i (SixteenByte2ValList Nonce) ++
         (Zrepeat (Vint Int.zero) (16-i))) v_z;
   data_at Tsh (Tarray tuchar 16 noattr) (SixteenByte2ValList Nonce) nonce))).
{ entailer!!. }
{ rename H into I.
  assert (ZWS: Int.zwordsize = 32) by reflexivity.
  destruct (SixteenByte2ValList_bytes Nonce) as [NBytes [NBytesL NB]]; rewrite NB.
  assert (NBytesZL: Zlength NBytes = 16). apply Zlength_length; simpl; lia.
  destruct (Znth_mapVint (map Int.repr (map Byte.unsigned NBytes)) i) as [v V].
    repeat rewrite Zlength_map. rewrite NBytesZL. lia.
  assert (v = Int.repr (Byte.unsigned (Znth i NBytes))). {
    rewrite Znth_map in V by list_solve. inv V. list_simplify.
  }
  subst v.
  destruct (Byte.unsigned_range_2 (Znth i NBytes)) as [VBmin VBmax].
  specialize Byte_max_unsigned_Int_max_unsigned; intros ByteIntMaxUnsigned.
  simpl.
  forward.
  change (@Znth val Vundef) with (@Znth val _); rewrite V.
  entailer!!.
  forward.
  rewrite NB.
  entailer!!.
  list_simplify. subst i0. simpl.
  rewrite zero_ext8_byte; auto.
}
deadvars!.

(*Verification of loop while (b >=64) ...*)
rename c into cInit. rename m into mInit. rename b into bInit. thaw FR2.
set (ZeroQuadByte := (Byte.zero, Byte.zero, Byte.zero, Byte.zero):QuadByte).
destruct Nonce as [[[N0 N1] N2] N3].
  assert (sublist 0 8 (SixteenByte2ValList (N0, N1, N2, N3)) ++
       Zrepeat (Vint Int.zero) (16 - 8)
     = (SixteenByte2ValList (((N0, N1), ZeroQuadByte), ZeroQuadByte))).
  { do 2 rewrite SixteenByte2ValList_char.
   assert (Zlength (QuadByte2ValList N0) = 4)
      by (rewrite Zlength_correct, QuadByteValList_length; reflexivity).
   assert (Zlength (QuadByte2ValList N1) = 4)
      by (rewrite Zlength_correct, QuadByteValList_length; reflexivity).
   assert (Zlength (QuadByte2ValList ZeroQuadByte) = 4)
      by (rewrite Zlength_correct, QuadByteValList_length; reflexivity).
  rewrite app_assoc.
  rewrite sublist_app1 by list_solve.
  rewrite app_assoc.
  f_equal. list_solve.
 }
  rewrite H; clear H.
  assert (I64MAX: Int64.max_unsigned = ltac:(let x := eval compute in Int64.max_unsigned in exact x))
     by reflexivity.
  destruct (SixteenByte2ValList_bytes (N0, N1, ZeroQuadByte, ZeroQuadByte)) as [zbytes [Lzbytes ZBytes]].
  rewrite ZBytes.
forward_while (Inv cInit mInit bInit k nonce v_x v_z (N0, N1,N2,N3) K mCont zbytes gv).
{ (*precondition*)
  Exists O mInit zbytes (@nil byte).
  unfold Bl2VL, tarray.
  rewrite Tarray_0_emp_iff
   by (pose proof (Int64.unsigned_range bInit); auto with field_compatible).
  entailer!.
  2:cancel. (* why didn't the entailer! do this? *)
  split; [split|].
  + destruct mInit; simpl in *; try contradiction. subst i; auto.
           rewrite Ptrofs.add_zero; trivial.
  + constructor.
  + simpl. rewrite Int64.sub_zero_l; auto.
}
{ entailer!!. }
{ remember (Z.of_nat rounds * 64)%Z as r64.
  destruct (zle (r64 + 64) (Int64.unsigned bInit)).
  2:{ exfalso. assert (X: 64 > Int64.unsigned bInit - r64) by lia. clear g.
           pose proof (Int64.unsigned_range_2 bInit).
           unfold Int64.sub in HRE. rewrite (Int64.unsigned_repr r64) in HRE by lia.
           rewrite Int64.unsigned_repr in HRE; lia.
  }
  destruct H as [R64old [M CONT]]. rename l into R64next.

  destruct (SixteenByte2ValList_exists zbytesR) as [d D].
  { apply CONTCONT in CONT. rewrite <- CONT.
    eapply Zlength_ZCont. rewrite Zlength_correct, Lzbytes. reflexivity. }

  forward_call (gv _sigma, k, v_z, v_x, (d, SIGMA, K)).
  { unfold CoreInSEP, SByte, Sigma_vector, tarray.
    rewrite D; unfold Bl2VL. cancel. }
Intros snuff. rename H into Snuff.

destruct (QuadChunks2ValList_bytes (map littleendian_invert snuff)) as [sr_bytes [SRBL SNR]].
assert (SRL: Zlength sr_bytes = 64). {
  rewrite map_length, (Snuffle20_length _ _ Snuff) in SRBL.
  rewrite Zlength_correct, SRBL. reflexivity.
  apply prepare_data_length.
}
freeze [0;2;3] FR3.
remember (offset_val r64 cInit) as c.

assert(INT64SUB: Int64.sub bInit (Int64.repr (r64 + 64)) =
           Int64.sub (Int64.sub bInit (Int64.repr r64)) (Int64.repr 64)).
{ clear - R64next R64old HRE Heqr64 I64MAX.
  destruct (Int64.unsigned_range_2 bInit).
  unfold Int64.sub.
  repeat rewrite Int64.unsigned_repr; try lia. f_equal; lia.
}

rewrite SNR.
forward_seq.
apply (loop1 Espec (FRZL FR3) v_x v_z c mInit (Vlong (Int64.sub bInit (Int64.repr r64))) k m sr_bytes mCont).
    eassumption.
    clear - SRL R64next R64old HRE Heqr64 MLEN; lia. lia.

(*continuation after the FOR(i,64) loop*)
Opaque prepare_data.
deadvars!.
Intros xorlist. rename H into XOR.
rewrite sublist_same in XOR; try lia.
forward.
thaw FR3. unfold CoreInSEP. repeat flatten_sepcon_in_SEP.
freeze [1;2;3;4;5;6;7] FR4.
unfold SByte.
forward_seq. rewrite D.
  apply (For_i_8_16_loop Espec (FRZL FR4) v_x v_z c m
           (Vlong (Int64.sub bInit (Int64.repr r64))) k zbytesR gv).
freeze [0;1] FR5.
forward.
forward.
rewrite Heqc. simpl.

forward_if (EX m:_,
  (PROP  (null_or_offset mInit (r64+64) m)
   LOCAL
   (temp _c
      (force_val
         (sem_add_ptr_int tuchar Signed (offset_val r64 cInit)
            (Vint (Int.repr 64))));
   temp _b
     (Vlong
        (Int64.sub (Int64.sub bInit (Int64.repr r64))
           (Int64.repr (Int.signed (Int.repr 64)))));
   lvar _x (Tarray tuchar 64 noattr) v_x; lvar _z (Tarray tuchar 16 noattr) v_z;
   temp _m m; temp _k k; gvars gv)  SEP  (FRZL FR5))).
{  clear H v. apply denote_tc_test_eq_split; auto with valid_pointer.
   destruct mInit; simpl in M; try contradiction.
   destruct M as [II M]; rewrite M in *; auto with valid_pointer.
   rewrite M in *.
     thaw FR5; thaw FR4.
  assert (message_at mCont (Vptr b i)
      |-- valid_pointer
            (Vptr b (Ptrofs.add i (Ptrofs.repr (Z.of_nat rounds * 64))))). {
        unfold message_at. eapply derives_trans. apply data_at_memory_block.
        eapply derives_trans. apply memory_block_valid_pointer. simpl.
        3: apply derives_refl'. 3: reflexivity. rep_lia.
        apply top_share_nonidentity.
   }
  auto 50 with valid_pointer.
}
{ forward.
  Exists (force_val (sem_add_ptr_int tuchar Signed m (Vint (Int.repr 64)))).
  entailer!!.
  destruct mInit; simpl in M; try contradiction.
  destruct M as [II M]; rewrite M in *. contradiction.
  rewrite M in *.  simpl. rewrite Ptrofs.add_assoc, ptrofs_add_repr. trivial. }
{ forward. Exists m. entailer!!. destruct mInit; simpl in M; try contradiction.
  simpl. apply M. inv M. }
intros.
thaw FR5. thaw FR4.
Intros x.
destruct cInit; try solve [destruct FC as [? _]; contradiction].
Exists (S rounds, x, snd (ZZ (ZCont rounds zbytes) 8), srbytes ++ xorlist).
unfold fst, snd.
rewrite  Nat2Z.inj_succ, <- Zmult_succ_l_reverse.
assert_PROP (field_compatible0
     (Tarray tuchar (Int64.unsigned bInit - r64) noattr)
      (SUB 64) (Vptr b (Ptrofs.add i (Ptrofs.repr r64))))
   as FC2 by (entailer!; auto with field_compatible).
entailer!!.
rewrite INT64SUB.
split; auto.
specialize (CONTCONT _ _ _ _ _ _ _ _ CONT); intros; subst zbytesR.
 assert (Hx := CONT_succ SIGMA K mInit mCont zbytes rounds _ _ CONT _ D
    _ _ _ Snuff SNR XOR).
 unfold snd in Hx; exact Hx. (* why is this necessary? *)
 rewrite (CONTCONT _ _ _ _ _ _ _ _ CONT).
  unfold SByte, Sigma_vector.
  cancel.

  assert (Zlength xorlist = 64). {
     unfold bxorlist in XOR; destruct (combinelist_Zlength _ _ _ _ _ XOR).
     rewrite H0. unfold bytes_at.
    destruct mInit; list_solve.
  }
  assert (Zlength (Bl2VL xorlist) = 64) by (rewrite Zlength_Bl2VL; lia).
  remember (Z.of_nat rounds * 64)%Z as r64.
  apply CONT_Zlength in CONT.

  assert (field_compatible (Tarray tuchar (Z.of_nat rounds * 64 + 64) noattr) [] (Vptr b i)).
  { eapply field_compatible_array_smaller0. apply FC. lia. }

  erewrite (split2_data_at_Tarray_tuchar _ (Int64.unsigned bInit - r64) (Zlength (Bl2VL xorlist)))
    by list_solve.
  autorewrite with sublist. rewrite H1.
  rewrite field_address0_clarify by (unfold field_address0; simpl; rewrite if_true; simpl; trivial).
  simpl.
  assert (II:Int64.unsigned bInit - (Z.of_nat rounds * 64 + 64) = Int64.unsigned bInit - (Z.of_nat rounds * 64) - 64) by  lia.
  rewrite Heqr64.
  rewrite II, Ptrofs.add_assoc, ptrofs_add_repr. cancel.

  unfold Bl2VL. repeat rewrite map_app.
  erewrite (split2_data_at_Tarray_tuchar Tsh (Z.of_nat rounds * 64 + 64) (Z.of_nat rounds * 64))
      by list_solve.
  rewrite sublist_app1       by list_solve.
  rewrite sublist_same by list_solve.
  replace (Z.of_nat rounds * 64 + 64 - Z.of_nat rounds * 64) with 64 by lia.
  rewrite sublist_app2       by list_solve.
  rewrite sublist_same by list_solve.
  rewrite field_address0_clarify; simpl. rewrite Zplus_0_l, Z.mul_1_l; trivial.
  unfold field_address0; simpl. rewrite if_true; simpl; trivial.
  auto with field_compatible.
}

(*continuation if (b) {...} *)
remember (Z.of_nat rounds * 64)%Z as r64.
 assert (R64b: r64+64 > Int64.unsigned bInit).
           destruct (Int64.unsigned_range_2 bInit) as [X1 X2].
           unfold Int64.sub in HRE. rewrite (Int64.unsigned_repr r64) in HRE by lia.
           rewrite Int64.unsigned_repr in HRE; lia.
destruct H as [R64a [M CONT]].
  assert (RR: Int64.unsigned (Int64.sub bInit (Int64.repr r64)) = Int64.unsigned bInit - r64).
  { destruct (Int64.unsigned_range_2 bInit).
    unfold Int64.sub.
    repeat rewrite Int64.unsigned_repr; try lia. }
forward_if (IfPost v_z v_x bInit (N0, N1, N2, N3) K mCont (Int64.unsigned bInit) nonce cInit k mInit zbytes gv).
{ rename H into BR.
  destruct (SixteenByte2ValList_exists zbytesR) as [d D].
  { apply CONTCONT in CONT. rewrite <- CONT.
    eapply Zlength_ZCont. rewrite Zlength_correct, Lzbytes. reflexivity. }
  forward_call (gv _sigma, k, v_z, v_x, (d, SIGMA, K)).
  { unfold CoreInSEP, SByte, Sigma_vector, tarray.
    unfold Bl2VL; rewrite D. cancel. }
  Intros snuff. rename H into Snuff.
  destruct (QuadChunks2ValList_bytes (map littleendian_invert snuff)) as [sr_bytes [SRBL SNR]].
  assert (Zlength sr_bytes = 64).
    rewrite map_length, (Snuffle20_length _ _ Snuff) in SRBL.
    rewrite Zlength_correct, SRBL. reflexivity.
    apply prepare_data_length.
  rename H into SRL.
  freeze [0;2;3] FR1.
  remember (offset_val r64 cInit) as c.
  assert (BB: Int64.unsigned (Int64.sub bInit (Int64.repr r64)) < Int.max_unsigned).
     rep_lia.
  rewrite SNR, <- RR.
  eapply semax_post_flipped'.
  eapply (loop2 Espec (FRZL FR1) v_x v_z c mInit); try eassumption; try lia.
  unfold IfPost.
  Intros l.
  unfold typed_true in BR. inversion BR; clear BR.
  entailer!!.
   rename H1 into H8.
  rewrite RR in *. eapply negb_true_iff in H8.
  unfold Int64.eq in H8. rewrite RR in H8. unfold Int64.zero in H8.
  rewrite Int64.unsigned_repr in H8. 2: lia.
  if_tac in H8. inv H8. clear H8. thaw FR1.
  unfold CoreInSEP.
  rewrite Int64.eq_false. 2: assumption.
  Exists (srbytes ++ l). unfold SByte.
  specialize (CONT_Zlength _ _ _ _ _ _ _ _ CONT); intros CZ.
  entailer!.
  + red.
    assert (R: rounds = Z.to_nat (Int64.unsigned bInit / 64)).
    { remember (Int64.unsigned bInit) as p.
      erewrite <- Z.div_unique with (q:= Z.of_nat rounds).
       rewrite Nat2Z.id. trivial.
      instantiate (1:= p- 64 * Z.of_nat rounds). 2: lia.
      left. lia. }
    rewrite <- R.
    assert (Arith1: (Int64.unsigned bInit / 64 * 64 = Z.of_nat rounds * 64)%Z).
        rewrite R; rewrite Z2Nat.id; trivial.
        apply Z_div_pos; lia.
    assert (Arith2: Int64.unsigned bInit mod 64 = Int64.unsigned bInit - Z.of_nat rounds * 64).
    { symmetry; eapply Zmod_unique. lia. instantiate (1:=Z.of_nat rounds); lia. }
    rewrite Arith1, Arith2, (CONTCONT _ _ _ _ _ _ _ _ CONT).
    rewrite if_false.
    - exists zbytesR, srbytes, d, snuff, sr_bytes, l.
      intuition.
    - trivial.
  + erewrite (split2_data_at_Tarray_tuchar _ (Int64.unsigned bInit) (Z.of_nat rounds * 64)).
    2: lia.
    2: rewrite Zlength_Bl2VL in *; rewrite Zlength_app. 2: lia.
    rewrite Zlength_Bl2VL in *; unfold Bl2VL in *.
    repeat rewrite map_app. autorewrite with sublist.
    unfold Sigma_vector. cancel.
    rewrite field_address0_clarify; simpl.
    rewrite Zplus_0_l, Z.mul_1_l; trivial.
    unfold field_address0; simpl.
    rewrite Zplus_0_l, Z.mul_1_l, if_true; trivial.
    apply field_compatible_isptr in H13.
    destruct cInit; simpl in *; try contradiction; trivial.
    auto with field_compatible.
}
{ forward.
  hnf in H. inversion H; clear H. rewrite RR in *. eapply negb_false_iff in H1.
  unfold Int64.eq in H1. rewrite RR in H1. unfold Int64.zero in H1.
  rewrite Int64.unsigned_repr in H1 by lia.
  if_tac in H1. 2: inv H1. clear H1.
  assert (XX: Int64.unsigned bInit = r64) by lia.
  rewrite XX in *. clear H RR.
  unfold IfPost, CoreInSEP.
  entailer!.
  rewrite Zminus_diag in *; rewrite Tarray_0_emp_iff_; try assumption.
  rewrite Int64.eq_false. 2: assumption.
  unfold SByte. simpl. cancel.
  Exists srbytes. apply andp_right; trivial.
  apply prop_right. red. rewrite XX, Heqr64.
  rewrite if_true.
  + exists zbytesR. rewrite Z_div_mult_full, Nat2Z.id. assumption. lia.
  + symmetry. eapply Zdiv.Zmod_unique. lia.
    rewrite Z.mul_comm, Zplus_0_r. reflexivity.
}
unfold IfPost.
forward.
unfold crypto_stream_xor_postsep.
unfold tarray; entailer!!.
destruct (Int64.eq bInit Int64.zero). trivial.
Intros l. Exists l. entailer!!.
exists zbytes. split; assumption.
all: fail.  (* make sure we're really done *)
Admitted.  (* Qed blows up *)


Require Import Coqlib.
Require Import ITreelib.
Require Import ImpPrelude.
Require Import STS.
Require Import Behavior.
Require Import ModSem.
Require Import Skeleton.
Require Import PCM.
Require Import Hoare.
Require Import STB KnotHeader.
Require Import KnotMainImp KnotMain0 KnotMain1 KnotImp Knot0 Knot1 Mem0 Mem1.
Require Import KnotMainImp0proof KnotImp0proof KnotMain01proof Knot01proof Mem01proof.
Require Import ProofMode.

Require Import Invariant Weakening.

Set Implicit Arguments.

Section PROOF.

  Let Σ: GRA.t := GRA.of_list [invRA; knotRA; memRA].
  Local Existing Instance Σ.

  Let invRA_inG: @GRA.inG invRA Σ.
  Proof. exists 0. ss. Defined.
  Local Existing Instance invRA_inG.

  Let knotRA_inG: @GRA.inG knotRA Σ.
  Proof. exists 1. ss. Defined.
  Local Existing Instance knotRA_inG.

  Let memRA_inG: @GRA.inG memRA Σ.
  Proof. exists 2. ss. Defined.
  Local Existing Instance memRA_inG.

  Let RecStb: Sk.t -> gname -> option fspec :=
    fun sk => to_stb KnotRecStb.
  Hint Unfold RecStb: stb.

  Let FunStb: Sk.t -> gname -> option fspec :=
    fun sk => to_stb (MainFunStb RecStb sk).
  Hint Unfold FunStb: stb.

  Let smds := [SMain RecStb; SKnot RecStb FunStb; SMem (fun _ => true)].
  Let GlobalStb := fun sk => to_stb (SMod.get_stb smds sk).
  Hint Unfold GlobalStb: stb.

  Definition KnotAllImp: list Mod.t := [KnotMainImp.KnotMain; KnotImp.Knot; Mem0.Mem (fun _ => false)].
  Definition KnotAll0: list Mod.t := [KnotMain0.Main; Knot0.Knot; Mem0.Mem (fun _ => false)].
  Definition KnotAll1: list Mod.t := List.map (SMod.to_tgt GlobalStb) smds.
  Definition KnotAll2: list Mod.t := List.map SMod.to_src smds.

  Lemma KnotAll01_correct:
    refines2 KnotAll0 KnotAll1.
  Proof.
    eapply refines2_cons.
    { eapply KnotMain01proof.correct with (RecStb:=RecStb) (FunStb:=FunStb) (GlobalStb:=GlobalStb).
      { stb_incl_tac. }
      { ii. econs; ss. refl. }
      { ii. econs; ss. refl. }
    }
    eapply refines2_cons.
    { eapply Knot01proof.correct with (RecStb:=RecStb) (FunStb:=FunStb) (GlobalStb:=GlobalStb).
      + stb_incl_tac.
      + stb_incl_tac.
      + stb_incl_tac; ors_tac.
    }
    etrans.
    { eapply Mem01proof.correct. }
    { eapply Weakening.adequacy_weaken. ss. }
  Qed.

  Lemma KnotAll12_correct:
    refines_closed (Mod.add_list KnotAll1) (Mod.add_list KnotAll2).
  Proof.
    eapply adequacy_type.
    { instantiate (1:=GRA.embed inv_token ⋅ GRA.embed (Auth.white (Some None: Excl.t (option (nat -> nat))): knotRA)).
      g_wf_tac.
      { Local Transparent Sk.load_skenv _points_to string_dec.
        ur. unfold var_points_to, initial_mem_mr. ss. uo. split.
        2: { ur. i. ur. i. ur. des_ifs. }
        { repeat rewrite URA.unit_id. ur. eexists ε.
          repeat rewrite URA.unit_id. extensionality k. extensionality n.
          unfold sumbool_to_bool, andb. des_ifs.
          { ss. clarify. }
          { ss. clarify. exfalso. lia. }
          { repeat (destruct k; ss). }
        }
      }
      { unfold knot_full. ur. splits; auto.
        { rewrite URA.unit_id. refl. }
        { ur. ss. }
      }
      { ur. ss. }
    }
    { i. ss. clarify. ss. exists id. splits; auto.
      { iIntros "[H0 H1]". iFrame. iSplits; ss. }
      { i. iPureIntro. i. des; auto. }
    }
  Qed.

  Theorem Knot_correct:
    refines_closed (Mod.add_list KnotAllImp) (Mod.add_list KnotAll2).
  Proof.
    transitivity (Mod.add_list KnotAll0).
    { eapply refines_close. eapply refines2_pairwise. econs; simpl.
      { eapply KnotMainImp0proof.correct. }
      econs; simpl.
      { eapply KnotImp0proof.correct. }
      econs; ss.
    }
    etrans.
    { eapply refines_close. eapply KnotAll01_correct. }
    { eapply KnotAll12_correct. }
  Qed.

End PROOF.


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

(** * algoTrace

Pierre Letouzey & Laurent Thery
*)

From Stalmarck Require Export trace.
From Stalmarck Require Export algoDotriplet.
From Stalmarck Require Export interImplement2.
From Stalmarck Require Import makeTriplet.

(** Append inside a triplet *)
Definition appL (L : list rZ) (d : mbD) : mbD :=
  match d with
  | triple a b l => triple _ _ _ a b (appendRz L l)
  end.

(** To make Coq run faster *)
Opaque addEqMem.
Opaque doTripletF.
Opaque interMem.

(** Evaluation of a dotriplet trace *)
Fixpoint evalTraceF (T : Trace) : rArray vM -> mbD :=
  fun Ar =>
  match T with
  | emptyTrace => triple _ _ _ Ar false nil
  | tripletTrace t =>
      match doTripletF Ar t with
      | None => triple _ _ _ Ar false nil
      | Some T => T
      end
  | seqTrace T1 T2 =>
      match evalTraceF T1 Ar with
      | triple Ar' true L' => triple _ _ _ Ar' true L'
      | triple Ar' false L' => appL L' (evalTraceF T2 Ar')
      end
  | dilemmaTrace a b T1 T2 =>
      match addEqMem Ar a b with
      | triple Ar1 true L1 =>
          match addEqMem Ar a (rZComp b) with
          | triple Ar2 true L2 => triple _ _ _ Ar true nil
          | triple Ar2 false L2 => appL L2 (evalTraceF T2 Ar2)
          end
      | triple Ar1 false L1 =>
          match addEqMem Ar a (rZComp b) with
          | triple Ar2 true L2 => appL L1 (evalTraceF T1 Ar1)
          | triple Ar2 false L2 =>
              match evalTraceF T1 Ar1 with
              | triple Ar1' true L1' => appL L2 (evalTraceF T2 Ar2)
              | triple Ar1' false L1' =>
                  match evalTraceF T2 Ar2 with
                  | triple Ar2' true L2' =>
                      triple _ _ _ Ar1' false (appendRz L1 L1')
                  | triple Ar2' false L2' =>
                      match
                        interMem Ar1' Ar2' Ar (appendRz L1 L1')
                          (appendRz L2 L2')
                      with
                      | (Ar', L') => triple _ _ _ Ar' false L'
                      end
                  end
              end
          end
      end
  end.

Theorem TraceCorrect :
 forall (Ar : rArray vM) (T : Trace) (LL : list triplet),
 TraceInList T LL ->
 forall S : State,
 wellFormedArray Ar ->
 rArrayState Ar S ->
 match evalTraceF T Ar with
 | triple Ar' false L =>
     wellFormedArray Ar' /\
     (exists S' : State, stalmarckP S LL S' /\ rArrayState Ar' S') /\
     OlistRz L /\
     (forall e : rNat,
      ~ InRz (rZPlus e) L -> rArrayGet _ Ar' e = rArrayGet _ Ar e)
 | triple Ar' true L =>
     exists S' : State, stalmarckP S LL S' /\ contradictory S'
 end.
Proof.
intros Ar T; generalize Ar; clear Ar; elim T; simpl in |- *.
intros Ar LL H' S H'0 H'1; repeat (split; auto with stalmarck).
exists S; split; auto with stalmarck.
red in |- *; apply OlistNil; auto with stalmarck.
intros t Ar LL H' S H'0 H'1.
generalize (doTripletFCorrect Ar t S H'0 H'1).
case (doTripletF Ar t).
intros x; case x; auto with stalmarck.
intros Ar' b' L'; case b'.
intros H'3; Elimc H'3; intros S' E; Elimc E; intros H'3 H'4.
exists S'; split; auto with stalmarck.
apply stalmarckPref; auto with stalmarck.
apply doTripletsTrans with (S2 := S') (t := t); auto with stalmarck.
intros H'3; Elimc H'3; intros H'3 H'4; Elimc H'4; intros H'4 H'5; Elimc H'5;
 intros H'5 H'6.
Elimc H'4; intros S' E; Elimc E; intros H'4 H'7.
repeat (split; auto with stalmarck).
exists S'; split; auto with stalmarck.
apply stalmarckTrans with (S2 := S'); auto with stalmarck.
apply stalmarckPref; auto with stalmarck.
apply doTripletsTrans with (S2 := S') (t := t); auto with stalmarck.
intros H'2; repeat (split; auto with stalmarck).
exists S; split; auto with stalmarck.
red in |- *; apply OlistNil; auto with stalmarck.
intros t H' t0 H'0 Ar LL H'1 S H'2 H'3.
elim H'1; intros H'4 H'5; clear H'1.
generalize (H' Ar LL H'4 S H'2 H'3).
case (evalTraceF t Ar).
intros Ar'' b'' L''; case b''; simpl in |- *; auto with stalmarck.
intros H'1; elim H'1; intros H'6 H'7; elim H'7; intros H'8 H'9; elim H'9;
 intros H'10 H'11; clear H'9 H'7 H'1.
elim H'8; intros S' E; elim E; intros H'1 H'7; clear E H'8.
generalize (H'0 Ar'' LL H'5 S' H'6 H'7).
case (evalTraceF t0 Ar''); auto with stalmarck.
intros Ar''' b''' L'''; case b'''; simpl in |- *; auto with stalmarck.
intros H'8; elim H'8; intros S'0 E; elim E; intros H'9 H'12; clear E H'8.
exists S'0; split; auto with stalmarck.
apply stalmarckTrans with (S2 := S'); auto with stalmarck.
intros H'8; elim H'8; intros H'9 H'12; elim H'12; intros H'13 H'14; elim H'14;
 intros H'15 H'16; clear H'14 H'12 H'8.
repeat (split; auto with stalmarck).
elim H'13; intros S'0 E; elim E; intros H'8 H'12; clear E H'13.
exists S'0; split; auto with stalmarck.
apply stalmarckTrans with (S2 := S'); auto with stalmarck.
unfold appendRz in |- *; red in |- *; apply appendfOlist; auto with stalmarck.
try exact rZltEqComp.
intros e H'14.
rewrite H'16.
apply H'11; auto with stalmarck.
Contradict H'14; auto with stalmarck.
cut (InclEq _ eqRz L'' (appendf _ rZlt eqRz rZltEDec L'' L''')).
intros H'8; inversion H'8; red in |- *; auto with stalmarck.
apply appendfInclEq1; auto with stalmarck.
Contradict H'14; auto with stalmarck.
cut (InclEq _ eqRz L''' (appendf _ rZlt eqRz rZltEDec L'' L''')).
intros H'8; inversion H'8; red in |- *; auto with stalmarck.
apply appendfInclEq2; auto with stalmarck.
intros a b t H' t0 H'0 Ar LL H'1 S H'2 H'3.
generalize (addEqMemCorrect Ar a b S H'2 H'3).
case (addEqMem Ar a b).
intros Ar1 b1 L1; case b1.
intros H'4.
generalize (addEqMemCorrect Ar a (rZComp b) S H'2 H'3); auto with stalmarck.
case (addEqMem Ar a (rZComp b)); auto with stalmarck.
intros Ar2 b2 L2; case b2.
intros H'5; exists S; split; auto with stalmarck.
red in |- *.
exists a.
apply eqStateRzTrans with (b := rZComp (rZComp b)); auto with stalmarck.
apply eqStateRzInv; auto with stalmarck.
apply eqStateRzSym; auto with stalmarck.
intros H'5; Elimc H'5; intros H'5 H'6; Elimc H'6; intros H'6 H'7; Elimc H'7;
 intros H'7 H'8.
Elimc H'1; intros H'1 H'9.
generalize (H'0 Ar2 LL H'9 _ H'5 H'6).
case (evalTraceF t0 Ar2); auto with stalmarck.
intros Ar2' b2' L2'; case b2'; simpl in |- *; auto with stalmarck.
intros H'10; Elimc H'10; intros S' E; Elimc E; intros H'10 H'11.
exists S'; split; auto with stalmarck.
apply stalmarckTrans with (S2 := S'); auto with stalmarck.
apply
 stalmarckPSplit with (a := a) (b := b) (S2 := addEq (a, b) S) (S3 := S');
 auto with stalmarck.
red in |- *; split; auto with stalmarck.
red in |- *.
intros i j H'12.
apply interMemEqStateRz; auto with stalmarck.
case H'4.
intros x H'13.
apply eqStateRzContr with (a := x); auto with stalmarck.
intros H'10; Elimc H'10; intros H'10 H'11; Elimc H'11; intros H'11 H'12;
 Elimc H'12; intros H'12 H'13.
Elimc H'11; intros S' E; Elimc E; intros H'11 H'14.
repeat (split; auto with stalmarck).
exists S'; split; auto with stalmarck.
apply
 stalmarckPSplit with (a := a) (b := b) (S2 := addEq (a, b) S) (S3 := S');
 auto with stalmarck.
red in |- *; split; auto with stalmarck.
red in |- *.
intros i j H'15.
apply interMemEqStateRz; auto with stalmarck.
case H'4.
intros x H'16.
apply eqStateRzContr with (a := x); auto with stalmarck.
unfold appendRz in |- *; red in |- *; apply appendfOlist; auto with stalmarck.
try exact rZltEqComp.
intros e H'15.
rewrite H'13.
apply H'8; auto with stalmarck.
Contradict H'15; auto with stalmarck.
cut (InclEq _ eqRz L2 (appendf _ rZlt eqRz rZltEDec L2 L2')).
intros H'16; inversion H'16; red in |- *; auto with stalmarck.
apply appendfInclEq1; auto with stalmarck.
Contradict H'15; auto with stalmarck.
cut (InclEq _ eqRz L2' (appendf _ rZlt eqRz rZltEDec L2 L2')).
intros H'16; inversion H'16; red in |- *; auto with stalmarck.
apply appendfInclEq2; auto with stalmarck.
intros H'4; Elimc H'4; intros H'4 H'5; Elimc H'5; intros H'5 H'6; Elimc H'6;
 intros H'6 H'7.
Elimc H'1; intros H'1 H'8.
generalize (addEqMemCorrect Ar a (rZComp b) S H'2 H'3); auto with stalmarck.
case (addEqMem Ar a (rZComp b)); auto with stalmarck.
intros Ar2 b2 L2; case b2.
intros H'9.
generalize (H' Ar1 LL H'1 _ H'4 H'5).
case (evalTraceF t Ar1).
intros Ar1' b1' L1'; case b1'; simpl in |- *; auto with stalmarck.
intros H'10; Elimc H'10; intros S' E; Elimc E; intros H'10 H'11.
exists S'; split; auto with stalmarck.
apply
 stalmarckPSplit
  with (a := a) (b := b) (S2 := S') (S3 := addEq (a, rZComp b) S);
 auto with stalmarck.
red in |- *; split; auto with stalmarck; auto with stalmarck.
red in |- *.
intros i j H'12.
apply interMemEqStateRz; auto with stalmarck.
case H'9.
intros x H'13.
apply eqStateRzContr with (a := x); auto with stalmarck.
intros H'10; Elimc H'10; intros H'10 H'11; Elimc H'11; intros H'11 H'12;
 Elimc H'12; intros H'12 H'13.
repeat (split; auto with stalmarck).
Elimc H'11; intros S' E; Elimc E; intros H'11 H'14.
exists S'; split; auto with stalmarck.
apply
 stalmarckPSplit
  with (a := a) (b := b) (S2 := S') (S3 := addEq (a, rZComp b) S);
 auto with stalmarck.
red in |- *; split; auto with stalmarck; auto with stalmarck.
red in |- *.
intros i j H'15.
apply interMemEqStateRz; auto with stalmarck.
case H'9.
intros x H'16.
apply eqStateRzContr with (a := x); auto with stalmarck.
unfold appendRz in |- *; red in |- *; apply appendfOlist; auto with stalmarck.
try exact rZltEqComp.
intros e H'14.
rewrite H'13.
apply H'7; auto with stalmarck.
Contradict H'14; auto with stalmarck.
cut (InclEq _ eqRz L1 (appendf _ rZlt eqRz rZltEDec L1 L1')).
intros H'15; inversion H'15; red in |- *; auto with stalmarck.
apply appendfInclEq1; auto with stalmarck.
Contradict H'14; auto with stalmarck.
cut (InclEq _ eqRz L1' (appendf _ rZlt eqRz rZltEDec L1 L1')).
intros H'15; inversion H'15; red in |- *; auto with stalmarck.
apply appendfInclEq2; auto with stalmarck.
intros H'9; Elimc H'9; intros H'9 H'10; Elimc H'10; intros H'10 H'11;
 Elimc H'11; intros H'11 H'12.
generalize (H' Ar1 LL H'1 _ H'4 H'5).
case (evalTraceF t Ar1).
intros Ar1' b1' L1'; case b1'; simpl in |- *; auto with stalmarck.
intros H'13; Elimc H'13; intros S' E; Elimc E; intros H'13 H'14.
generalize (H'0 Ar2 LL H'8 _ H'9 H'10).
case (evalTraceF t0 Ar2).
intros Ar2' b2' L2'; case b2'; simpl in |- *; auto with stalmarck.
intros H'15; Elimc H'15; intros S'0 E; Elimc E; intros H'15 H'16.
exists S'; split; auto with stalmarck.
apply stalmarckPSplit with (a := a) (b := b) (S2 := S') (S3 := S'0); auto with stalmarck.
split; auto with stalmarck.
red in |- *.
intros i j H'17.
apply interMemEqStateRz; auto with stalmarck.
case H'16.
intros x H'18.
apply eqStateRzContr with (a := x); auto with stalmarck.
intros H'15; Elimc H'15; intros H'15 H'16; Elimc H'16; intros H'16 H'17;
 Elimc H'17; intros H'17 H'18.
Elimc H'16; intros S'0 E; Elimc E; intros H'16 H'19.
repeat (split; auto with stalmarck).
exists S'0; split; auto with stalmarck.
apply stalmarckPSplit with (a := a) (b := b) (S2 := S') (S3 := S'0); auto with stalmarck.
split; auto with stalmarck.
red in |- *.
intros i j H'20.
apply interMemEqStateRz; auto with stalmarck.
case H'14.
intros x H'21.
apply eqStateRzContr with (a := x); auto with stalmarck.
unfold appendRz in |- *; red in |- *; apply appendfOlist; auto with stalmarck.
try exact rZltEqComp.
intros e H'20.
rewrite H'18.
apply H'12; auto with stalmarck.
Contradict H'20; auto with stalmarck.
cut (InclEq _ eqRz L2 (appendf _ rZlt eqRz rZltEDec L2 L2')).
intros H'21; inversion H'21; red in |- *; auto with stalmarck.
apply appendfInclEq1; auto with stalmarck.
Contradict H'20; auto with stalmarck.
cut (InclEq _ eqRz L2' (appendf _ rZlt eqRz rZltEDec L2 L2')).
intros H'21; inversion H'21; red in |- *; auto with stalmarck.
apply appendfInclEq2; auto with stalmarck.
intros H'13; Elimc H'13; intros H'13 H'14; Elimc H'14; intros H'14 H'15;
 Elimc H'15; intros H'15 H'16.
cut (OlistRz (appendRz L1 L1')); [ intros O1 | idtac ].
2: unfold appendRz in |- *; red in |- *; apply appendfOlist; auto with stalmarck.
2: try exact rZltEqComp.
cut
 (forall e : rNat,
  ~ InRz (rZPlus e) (appendRz L1 L1') ->
  rArrayGet vM Ar1' e = rArrayGet vM Ar e); [ intros E1 | idtac ].
2: intros e H'17.
2: rewrite H'16; auto with stalmarck.
2: apply H'7; auto with stalmarck.
2: Contradict H'17; auto with stalmarck.
2: cut (InclEq _ eqRz L1 (appendf _ rZlt eqRz rZltEDec L1 L1')).
2: intros H'18; inversion H'18; red in |- *; auto with stalmarck.
2: apply appendfInclEq1; auto with stalmarck.
2: Contradict H'17; auto with stalmarck.
2: cut (InclEq _ eqRz L1' (appendf _ rZlt eqRz rZltEDec L1 L1')).
2: intros H'18; inversion H'18; red in |- *; auto with stalmarck.
2: apply appendfInclEq2; auto with stalmarck.
generalize (H'0 Ar2 LL H'8 _ H'9 H'10).
case (evalTraceF t0 Ar2).
intros Ar2' b2' L2'; case b2'; simpl in |- *; auto with stalmarck.
intros H'17; Elimc H'17; intros S' E; Elimc E; intros H'17 H'18.
repeat (split; auto with stalmarck).
Elimc H'14; intros S'0 E; Elimc E; intros H'14 H'19.
exists S'0; split; auto with stalmarck.
apply stalmarckPSplit with (a := a) (b := b) (S2 := S'0) (S3 := S'); auto with stalmarck.
split; auto with stalmarck.
red in |- *.
intros i j H'20.
apply interMemEqStateRz; auto with stalmarck.
case H'18.
intros x H'21.
apply eqStateRzContr with (a := x); auto with stalmarck.
intros H'17; Elimc H'17; intros H'17 H'18; Elimc H'18; intros H'18 H'19;
 Elimc H'19; intros H'19 H'20.
cut (OlistRz (appendRz L2 L2')); [ intros O2 | idtac ].
2: unfold appendRz in |- *; red in |- *; apply appendfOlist; auto with stalmarck.
2: try exact rZltEqComp.
cut
 (forall e : rNat,
  ~ InRz (rZPlus e) (appendRz L2 L2') ->
  rArrayGet vM Ar2' e = rArrayGet vM Ar e); [ intros E2 | idtac ].
2: intros e H'21.
2: rewrite H'20; auto with stalmarck.
2: apply H'12; auto with stalmarck.
2: Contradict H'21; auto with stalmarck.
2: cut (InclEq _ eqRz L2 (appendf _ rZlt eqRz rZltEDec L2 L2')).
2: intros H'22; inversion H'22; red in |- *; auto with stalmarck.
2: apply appendfInclEq1; auto with stalmarck.
2: Contradict H'21; auto with stalmarck.
2: cut (InclEq _ eqRz L2' (appendf _ rZlt eqRz rZltEDec L2 L2')).
2: intros H'22; inversion H'22; red in |- *; auto with stalmarck.
2: apply appendfInclEq2; auto with stalmarck.
Elimc H'18; intros S'0 E; Elimc E; intros H'18 H'21.
Elimc H'14; intros S' E; Elimc E; intros H'14 H'22.
cut (inclState S S'); [ intros I1 | idtac ].
cut (inclState S S'0); [ intros I2 | idtac ].
generalize
 (interMemProp Ar1' Ar2' Ar H'13 H'17 H'2 (appendRz L1 L1')
    (appendRz L2 L2') O1 O2 _ _ _ H'22 H'21 H'3 I1 I2 E1 E2).
case (interMem Ar1' Ar2' Ar (appendRz L1 L1') (appendRz L2 L2')).
intros Ar' L' H'23; Elimc H'23; intros H'23 H'24; Elimc H'24;
 intros H'24 H'25; Elimc H'25; intros H'25 H'26.
repeat (split; auto with stalmarck).
exists (interState S' S'0); split; auto with stalmarck.
apply stalmarckPSplit with (a := a) (b := b) (S2 := S') (S3 := S'0); auto with stalmarck.
apply inclStateTrans with (addEq (a, rZComp b) S); auto with stalmarck.
apply stalmarckIncl with (L := LL); auto with stalmarck.
apply inclStateTrans with (addEq (a, b) S); auto with stalmarck.
apply stalmarckIncl with (L := LL); auto with stalmarck.
Qed.

(** A computable InDec *)
Definition InDec :
  forall A : Type,
  (forall x y : A, {x = y :>A} + {x <> y :>A}) ->
  forall (a : A) (l : list A), {In a l} + {~ In a l}.
fix InDec 4.
intros A H' a l; case l.
right; red in |- *; intros H'0; inversion H'0.
intros a0 l0; case (H' a a0).
intros H'0; left; rewrite H'0; auto with datatypes stalmarck.
intros H'0; case (InDec A H' a l0).
intros H'1; left; auto with datatypes stalmarck.
intros H'1; right; simpl in |- *; red in |- *; intros H'2; case H'2; auto with stalmarck.
Defined.

(** the function f returns given a signed variable the triplets that contains this variable
    fIn just check if all triplets in the trace are in the image of f *)
Fixpoint fInT (f : rZ -> list triplet) (T : Trace) {struct T} : bool :=
  match T with
  | emptyTrace => true
  | tripletTrace (Triplet b p q r) =>
      match InDec _ tripletDec (Triplet b p q r) (f p) with
      | left _ => true
      | right _ => false
      end
  | seqTrace T1 T2 =>
      match fInT f T1 with
      | true => fInT f T2
      | false => false
      end
  | dilemmaTrace _ _ T1 T2 =>
      match fInT f T1 with
      | true => fInT f T2
      | false => false
      end
  end.

Theorem fInTCorrect :
 forall (LL : list triplet) (f : rZ -> _) (T : Trace),
 (forall n : rZ, incl (f n) LL) -> fInT f T = true -> TraceInList T LL.
Proof.
intros LL f T H'; elim T; simpl in |- *; auto with stalmarck.
intros t; case t; auto with stalmarck.
intros r r0 r1 r2; case (InDec _ tripletDec (Triplet r r0 r1 r2) (f r0));
 auto with stalmarck.
intros H'0 H'1; apply (H' r0); auto with stalmarck.
intros; discriminate.
intros t; case (fInT f t); auto with stalmarck.
intros; discriminate.
intros a b t; case (fInT f t); auto with stalmarck.
intros; discriminate.
Qed.

(** Build the hashtable *)
Fixpoint buildL (L : list triplet) : rArray (list triplet) :=
  match L with
  | nil => rArrayMake _ (rEmpty _) (fun r => nil)
  | t :: L1 =>
      match t with
      | Triplet _ p q r =>
          letP _ _
            (letP _ _
               (letP _ _ (buildL L1)
                  (fun Ar1 =>
                   rArraySet _ Ar1 (valRz p) (t :: rArrayGet _ Ar1 (valRz p))))
               (fun Ar2 =>
                rArraySet _ Ar2 (valRz q) (t :: rArrayGet _ Ar2 (valRz q))))
            (fun Ar3 =>
             rArraySet _ Ar3 (valRz r) (t :: rArrayGet _ Ar3 (valRz r)))
      end
  end.

Definition getT (Ar : rArray (list triplet)) (r : rZ) :=
  rArrayGet _ Ar (valRz r).

Theorem getTCorrect :
 forall (L : list triplet) (a : rZ), incl (getT (buildL L) a) L.
Proof.
unfold getT in |- *; intros L; elim L; simpl in |- *.
intros a; elim a; simpl in |- *.
intros r; case r; simpl in |- *; auto with datatypes stalmarck.
intros r; case r; simpl in |- *; auto with datatypes stalmarck.
intros t; case t; auto with stalmarck.
intros r r0 r1 r2 l H' a; unfold letP, getT in |- *; simpl in |- *.
case (rNatDec (valRz r2) (valRz a)); intros Eq1.
repeat rewrite Eq1.
repeat rewrite rArrayDef1 with (m := valRz a).
case (rNatDec (valRz r1) (valRz a)); intros Eq2.
repeat rewrite Eq2.
repeat rewrite rArrayDef1 with (m := valRz a).
case (rNatDec (valRz r0) (valRz a)); intros Eq3.
repeat rewrite Eq3.
repeat rewrite rArrayDef1 with (m := valRz a); auto with datatypes stalmarck.
repeat rewrite rArrayDef2 with (m2 := valRz a); auto with datatypes stalmarck.
rewrite rArrayDef2 with (m2 := valRz a); auto with stalmarck.
case (rNatDec (valRz r0) (valRz a)); intros Eq3.
repeat rewrite Eq3.
repeat rewrite rArrayDef1 with (m := valRz a); auto with datatypes stalmarck.
rewrite rArrayDef2 with (m2 := valRz a); auto with datatypes stalmarck.
rewrite rArrayDef2 with (m2 := valRz a); auto with datatypes stalmarck.
case (rNatDec (valRz r1) (valRz a)); intros Eq2.
repeat rewrite Eq2.
repeat rewrite rArrayDef1 with (m := valRz a).
case (rNatDec (valRz r0) (valRz a)); intros Eq3.
repeat rewrite Eq3.
repeat rewrite rArrayDef1 with (m := valRz a); auto with datatypes stalmarck.
repeat rewrite rArrayDef2 with (m2 := valRz a); auto with datatypes stalmarck.
rewrite rArrayDef2 with (m2 := valRz a); auto with stalmarck.
case (rNatDec (valRz r0) (valRz a)); intros Eq3.
repeat rewrite Eq3.
repeat rewrite rArrayDef1 with (m := valRz a); auto with datatypes stalmarck.
rewrite rArrayDef2 with (m2 := valRz a); auto with datatypes stalmarck.
Qed.

(** The initial array is well-formed *)
Theorem rIwF : wellFormedArray (rArrayInit vM (fun _ : rNat => class nil)).
Proof.
apply wellFormedArrayDef; auto with stalmarck.
apply pointerDecreaseDef; simpl in |- *; auto with stalmarck.
intros r; case r; simpl in |- *; intros; discriminate.
apply pointToClassRefDef; simpl in |- *; auto with stalmarck.
intros r; case r; simpl in |- *; intros; discriminate.
apply pointToClassClassRef; simpl in |- *; auto with stalmarck.
intros r; case r; simpl in |- *.
intros p s Lr H'; inversion H'.
intros H'0; inversion H'0.
intros p s Lr H'; inversion H'.
intros H'0; inversion H'0.
intros s Lr H'; inversion H'.
intros H'0; inversion H'0.
intros r; case r; simpl in |- *; intros; discriminate.
apply OlistArrayDef; simpl in |- *; auto with stalmarck.
intros r; case r; simpl in |- *.
intros H' Lr H'0; inversion H'0; red in |- *; apply OlistNil; auto with stalmarck.
intros H' Lr H'0; inversion H'0; red in |- *; apply OlistNil; auto with stalmarck.
intros Lr H'; inversion H'; red in |- *; apply OlistNil; auto with stalmarck.
Qed.

(** The correction of our checker *)
Theorem checkTrace :
 forall (e : Expr) (T : Trace),
 match makeTriplets (norm e) with
 | tRC L r n =>
     match fInT (getT (buildL L)) T with
     | true =>
         match addEqMem (rArrayInit _ (fun r => class nil)) r rZFalse with
         | triple Ar1 true L1 => Tautology e
         | triple Ar1 false L1 =>
             match evalTraceF T Ar1 with
             | triple Ar' false L => True
             | triple Ar' true L => Tautology e
             end
         end
     | false => True
     end
 end.
Proof.
intros e T; CaseEq (makeTriplets (norm e)).
intros l r r0.
CaseEq (fInT (getT (buildL l)) T); auto with stalmarck.
CaseEq (addEqMem (rArrayInit vM (fun _ : rNat => class nil)) r rZFalse).
intros r1 b; case b; auto with stalmarck.
intros l0 H' H'0 H'1.
case (TautoRTauto e).
intros H'3 H'4; apply H'4; auto with stalmarck.
case (rTautotTauto (norm e)).
intros H'5 H'6; apply H'6; auto with stalmarck.
red in |- *; rewrite H'1.
apply stalmarckGivesValidEquation with (S := addEq (r, rZFalse) nil); auto with stalmarck.
generalize
 (addEqMemCorrect (rArrayInit vM (fun _ : rNat => class nil)) r rZFalse nil).
rewrite H'; auto with stalmarck.
intros H'2; apply H'2; auto with stalmarck.
apply rIwF; auto with stalmarck.
exact initCorrect; auto with stalmarck.
CaseEq (evalTraceF T r1).
intros r2 b0; case b0; auto with stalmarck.
intros l0 H' l1 H'0 H'1 H'2.
case (TautoRTauto e).
intros H'3 H'4; apply H'4; auto with stalmarck.
case (rTautotTauto (norm e)).
intros H'5 H'6; apply H'6; auto with stalmarck.
red in |- *; rewrite H'2.
generalize (TraceCorrect r1 T l).
rewrite H'; auto with stalmarck.
generalize
 (addEqMemCorrect (rArrayInit vM (fun _ : rNat => class nil)) r rZFalse nil).
rewrite H'0; auto with stalmarck.
intros H'7; Elimc H'7;
 [ intros H'7 H'8; Elimc H'8; intros H'8 H'9; Elimc H'9; intros H'9 H'10
 | idtac
 | idtac ]; auto with stalmarck.
intros H'11; lapply H'11;
 [ intros H'12; elim (H'12 (addEq (r, rZFalse) nil));
    [ intros S' E; Elimc E; intros H'13 H'14; clear H'11
    | clear H'11
    | clear H'11 ]
 | clear H'11 ]; auto with stalmarck.
apply stalmarckGivesValidEquation with (S := S'); auto with stalmarck.
apply fInTCorrect with (f := getT (buildL l)); auto with stalmarck.
intros n; apply getTCorrect; auto with stalmarck.
apply rIwF; auto with stalmarck.
exact initCorrect; auto with stalmarck.
Qed.

Transparent addEqMem.
Transparent doTripletF.
Transparent interMem.

(** How to prove a\/ ~a *)
#[local] Definition t1 :
  Tautology (Node Or (V (rnext zero)) (normalize.N (V (rnext zero)))) :=
  checkTrace (Node Or (V (rnext zero)) (normalize.N (V (rnext zero))))
    (seqTrace
       (tripletTrace
          (Triplet rAnd (rZPlus (rnext (rnext zero)))
             (rZMinus (rnext zero)) (rZPlus (rnext zero)))) emptyTrace).

(** A function to check trace *)
Definition checkTracef (e : Expr) (T : Trace) :=
  match makeTriplets (norm e) with
  | tRC L r n =>
      match fInT (getT (buildL L)) T with
      | true =>
          match addEqMem (rArrayInit _ (fun r => class nil)) r rZFalse with
          | triple Ar1 true L1 => true
          | triple Ar1 false L1 =>
              match evalTraceF T Ar1 with
              | triple Ar' false L => false
              | triple Ar' true L => true
              end
          end
      | false => false
      end
  end.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal50.

From lfind Require Import LFind.
Require Import Arith.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal50_count_insort_diff_163_count_cons_diff/goal50_lfind_orig.ml"  Coq.Init.Logic.not adtind.goal50.insort adtind.goal50.less adtind.goal50.eqb adtind.goal50.count.
Success.


Require Import floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Local Open Scope nat.
Local Open Scope logic.

Definition update_inner_if_then :=
  (Ssequence
      (Scall None
           (Evar _memcpy
              (Tfunction
                 (Tcons (tptr tvoid) (Tcons (tptr tvoid) (Tcons tuint Tnil)))
                 (tptr tvoid) cc_default))
           [Ebinop Oadd (Etempvar _p (tptr tuchar)) (Etempvar _n tuint)
              (tptr tuchar), Etempvar _data (tptr tuchar),
           Etempvar _fragment tuint])
     (Ssequence
        (Scall None
           (Evar _sha256_block_data_order
              (Tfunction
                 (Tcons (tptr t_struct_SHA256state_st)
                    (Tcons (tptr tvoid) Tnil)) tvoid cc_default))
           [Etempvar _c (tptr t_struct_SHA256state_st),
           Etempvar _p (tptr tuchar)])
        (Ssequence
           (Sset _data
              (Ebinop Oadd (Etempvar _data (tptr tuchar))
                 (Etempvar _fragment tuint) (tptr tuchar)))
           (Ssequence
              (Sset _len
                 (Ebinop Osub (Etempvar _len tuint)
                    (Etempvar _fragment tuint) tuint))
                 (Scall None
                    (Evar _memset
                       (Tfunction
                          (Tcons (tptr tvoid) (Tcons tint (Tcons tuint Tnil)))
                          (tptr tvoid) cc_default))
                    [Etempvar _p (tptr tuchar), Econst_int (Int.repr 0) tint,
                    Ebinop Omul (Econst_int (Int.repr 16) tint)
                      (Econst_int (Int.repr 4) tint) tint]))))).

Definition  update_inner_if_else :=
                (Ssequence
                    (Scall None
                      (Evar _memcpy (Tfunction
                                      (Tcons (tptr tvoid)
                                        (Tcons (tptr tvoid)
                                          (Tcons tuint Tnil))) (tptr tvoid) cc_default))
                      ((Ebinop Oadd (Etempvar _p (tptr tuchar))
                         (Etempvar _n tuint) (tptr tuchar)) ::
                       (Etempvar _data (tptr tuchar)) ::
                       (Etempvar _len tuint) :: nil))
                  (Ssequence
                    (Sassign
                      (Efield
                        (Ederef (Etempvar _c (tptr t_struct_SHA256state_st))
                          t_struct_SHA256state_st) _num tuint)
                      (Ebinop Oadd (Etempvar _n tuint)
                        (Ecast (Etempvar _len tuint) tuint) tuint))
                    (Sreturn None))).

Definition update_inner_if :=
        Sifthenelse (Ebinop Oge (Etempvar _len tuint)
                             (Etempvar _fragment tuint) tint)
         update_inner_if_then
         update_inner_if_else.

Definition inv_at_inner_if sh hashed len c d dd data kv hi lo:=
 (PROP ()
   (LOCAL
   (`(eq (Vint (Int.repr (64- Zlength dd)))) (eval_id _fragment);
   `(eq  (offset_val (Int.repr 40) c)) (eval_id _p);
   `(eq (Vint (Int.repr (Zlength dd)))) (eval_id _n);
   `(eq c) (eval_id _c); `(eq d) (eval_id _data);
   `(eq (Vint (Int.repr (Z.of_nat len)))) (eval_id _len);
   `(eq kv) (eval_var _K256 (tarray tuint CBLOCKz)))
   SEP  (`(array_at tuint Tsh (tuints (hash_blocks init_registers hashed)) 0 8 c);
    `(sha256_length (hilo hi lo + (Z.of_nat len)*8) c);
   `(array_at tuchar Tsh (ZnthV tuchar (map Vint (map Int.repr dd))) 0 64 (offset_val (Int.repr 40) c));
   `(field_at Tsh t_struct_SHA256state_st [_num] (Vint (Int.repr (Zlength dd))) c);
   `(K_vector kv);
   `(data_block sh data d)))).

Definition sha_update_inv sh hashed len c d (frag: list Z) (data: list Z) kv r_Nh r_Nl (done: bool) :=
   (EX blocks:list int,
   PROP  (len >= length blocks*4 - length frag /\
              (LBLOCKz | Zlength blocks) /\
              intlist_to_Zlist blocks = frag ++ firstn (length blocks * 4 - length frag) data /\
             if done then len-(length blocks*4 - length frag) < CBLOCK else True)
   LOCAL  (`(eq (offset_val (Int.repr 40) c)) (eval_id _p);
   `(eq c) (eval_id _c); `(eq (offset_val (Int.repr (Z.of_nat (length blocks*4-length frag))) d)) (eval_id _data);
   `(eq (Vint (Int.repr (Z.of_nat (len- (length blocks*4 - length frag)))))) (eval_id _len);
   `(eq kv) (eval_var _K256 (tarray tuint CBLOCKz)))
   SEP  (`(K_vector kv);
    `(array_at tuint Tsh (tuints (hash_blocks init_registers (hashed ++ blocks))) 0 8 c);
    `(sha256_length (hilo r_Nh r_Nl + (Z.of_nat len)*8) c);
   `(array_at_ tuchar Tsh 0 64 (offset_val (Int.repr 40) c));
   `(field_at_ Tsh t_struct_SHA256state_st [_num] c);
   `(data_block sh data d))).

Lemma closed_make_args:
  forall (Q: environ -> mpred) funsig el,
     closed_wrt_vars (fun _ => True) Q ->
  `Q (make_args' funsig el) = Q.
Proof.
intros.
extensionality rho.
unfold_lift.
hnf in H.
unfold make_args'.
specialize (H rho (te_of (make_args (map fst (fst funsig)) (el rho) rho))).
rewrite H.
f_equal.
destruct rho; simpl.
forget (el (mkEnviron ge ve te)) as vl.
forget (map fst (fst funsig)) as il.
induction il; destruct vl; simpl.
unfold globals_only. simpl.
Abort.  (* need to be closed for addressable locals, too *)

Definition Delta_update_inner_if : tycontext.
simplify_Delta_from
  (initialized _fragment
     (initialized _p
        (initialized _n
           (initialized _data (func_tycontext f_SHA256_Update Vprog Gtot))))).
Defined.

Lemma update_inner_if_then_proof:
 forall (Espec : OracleKind) (hashed : list int)
          (dd data : list Z) (c d: val) (sh: share) (len: nat) kv
          (hi lo: int)
   (H : (Z.of_nat len <= Zlength data)%Z)
   (H7 : ((Zlength hashed * 4 + Zlength dd) * 8)%Z = hilo hi lo)
   (H3 : (Zlength dd < CBLOCKz)%Z)
   (H3' : Forall isbyteZ dd)
   (H4 : (LBLOCKz | Zlength hashed))
   (Hlen : (Z.of_nat len <= Int.max_unsigned)%Z)
   (c' : name _c) (data_ : name _data) (len' : name _len)
   (data' : name _data) (p : name _p) (n : name _n)
   (fragment_ : name _fragment),
  let j := (40 + Zlength dd)%Z in
  let k := (64 - Zlength dd)%Z in
  forall (H0: (0 < k <= 64)%Z)
       (H1: (64 < Int.max_unsigned)%Z)
       (DBYTES: Forall isbyteZ data),
semax Delta_update_inner_if
  (PROP  ()
   LOCAL
   (`(typed_true tint)
      (eval_expr
         (Ebinop Oge (Etempvar _len tuint) (Etempvar _fragment tuint) tint));
   `(eq (Vint (Int.repr k))) (eval_id _fragment);
   `(eq (offset_val (Int.repr 40) c)) (eval_id _p);
   `(eq (Vint (Int.repr (Zlength dd)))) (eval_id _n); `(eq c) (eval_id _c);
   `(eq d) (eval_id _data);
   `(eq (Vint (Int.repr (Z.of_nat len)))) (eval_id _len);
   `(eq kv) (eval_var _K256 (tarray tuint CBLOCKz)))
   SEP
   (`(array_at tuint Tsh (tuints (hash_blocks init_registers hashed)) 0 8 c);
   `(sha256_length (hilo hi lo + Z.of_nat len * 8) c);
   `(array_at tuchar Tsh (ZnthV tuchar (map Vint (map Int.repr dd))) 0 64
       (offset_val (Int.repr 40) c));
   `(field_at Tsh t_struct_SHA256state_st [_num] (Vint (Int.repr (Zlength dd)))
       c); `(K_vector kv);
   `(array_at tuchar sh (tuchars (map Int.repr data)) 0 (Zlength data) d)))
  update_inner_if_then
  (overridePost (sha_update_inv sh hashed len c d dd data kv hi lo false)
     (function_body_ret_assert tvoid
        (EX  a' : s256abs,
         PROP  (update_abs (firstn len data) (S256abs hashed dd) a')
         LOCAL ()
         SEP  (`(K_vector kv); `(sha256state_ a' c); `(data_block sh data d))))).
Proof.
 intros.
 simplify_Delta; abbreviate_semax.
  unfold update_inner_if_then.
  apply (remember_value (eval_id _fragment)); intro fragment.
  forward_call (* memcpy (p+n,data,fragment); *)
   ((sh,Tsh),
    offset_val (Int.repr (Zlength dd)) (offset_val (Int.repr 40) c),
    d,
    Int.unsigned (force_int fragment),
    Basics.compose force_int (ZnthV tuchar (map Vint (map Int.repr data)))).
 fold j; fold k.
 entailer!.
 clear fragment H5.
 rewrite negb_true_iff in H6.
 apply ltu_repr_false in H6; [ | repable_signed | omega].
 clear TC.
 unfold j,k in *; clear j k.
rewrite cVint_force_int_ZnthV
 by (rewrite initial_world.Zlength_map; omega).
 rewrite memory_block_array_tuchar by omega.
 rewrite split_offset_array_at with (contents :=ZnthV tuchar (map Vint (map Int.repr dd))) (lo := Zlength dd); [| omega | simpl; omega | reflexivity].
 rewrite (split_array_at (64-Zlength dd) _ _ (tuchars (map Int.repr data)))
    by omega.

 replace (offset_val (Int.repr (40 + Zlength dd)) c)
          with (offset_val (Int.repr (sizeof tuchar * Zlength dd)) (offset_val (Int.repr 40) c))
  by (change (sizeof tuchar) with 1%Z; rewrite Z.mul_1_l; rewrite offset_offset_val, add_repr; auto).
 cancel.

 after_call.
 fold j k.
 rename H5 into H2'.
 gather_SEP 4%Z 1%Z.
 replace_SEP 0%Z (`(array_at tuchar Tsh (ZnthV tuchar (map Vint (map Int.repr (dd ++ data) ))) 0
        64 (offset_val (Int.repr 40) c))).
 entailer!.
 rewrite negb_true_iff in H8;
 apply ltu_repr_false in H8; [ | omega..].
 unfold j,k in *.
 rename c' into c.
 rewrite cVint_force_int_ZnthV
 by (rewrite initial_world.Zlength_map; omega).
 replace (offset_val (Int.repr (40 + Zlength dd)) c)
          with (offset_val (Int.repr (sizeof tuchar * Zlength dd)) (offset_val (Int.repr 40) c))
  by (change (sizeof tuchar) with 1%Z; rewrite Z.mul_1_l; rewrite offset_offset_val, add_repr; auto).
 rewrite split_offset_array_at with (lo := Zlength dd) (contents := (ZnthV tuchar (map Vint (map Int.repr (dd ++ data))))); [| omega | simpl; omega | reflexivity].
  normalize.
 apply sepcon_derives; apply derives_refl'; apply equal_f; apply array_at_ext; intros.
 unfold ZnthV. repeat rewrite if_false by omega.
 repeat rewrite map_app.
 rewrite app_nth1; auto. repeat rewrite map_length. apply Nat2Z.inj_lt.
 rewrite Z2Nat.id by omega. rewrite <- Zlength_correct; omega.
 repeat rewrite map_app.
 unfold ZnthV. repeat rewrite if_false by omega.
 rewrite app_nth2; auto. f_equal.
 rewrite !map_length. rewrite Zlength_correct.
 rewrite Z2Nat.inj_add by omega.
 rewrite Nat2Z.id. omega.
 rewrite map_length; auto.
 repeat rewrite map_length. apply Nat2Z.inj_ge.
 rewrite Z2Nat.id by omega. rewrite <- Zlength_correct; omega.

 forward_call (* sha256_block_data_order (c,p); *)
   (hashed, Zlist_to_intlist (dd++(firstn (Z.to_nat k) data)), c, (offset_val (Int.repr 40) c), Tsh, kv).
 entailer.
 unfold j,k in *|-.
 rewrite negb_true_iff in H9; apply ltu_repr_false in H9; [ | omega..].
 assert (length (dd ++ firstn (Z.to_nat k) data) = 64). {
  unfold k.
  rewrite app_length.
  rewrite firstn_length, min_l.
  apply Nat2Z.inj. rewrite Nat2Z.inj_add.
  rewrite Z2Nat.id.
  change (Z.of_nat 64) with 64%Z.
  rewrite <- Zlength_correct; omega.
  omega.
  apply Nat2Z.inj_le.  rewrite Z2Nat.id.  rewrite <- Zlength_correct; omega.
  omega.
}
 assert (length (Zlist_to_intlist (dd ++ firstn (Z.to_nat k) data)) = LBLOCK). {
  apply length_Zlist_to_intlist. assumption.
}
 apply andp_right; [apply prop_right |].
 rewrite Zlength_correct, H12. reflexivity.
 replace (data_block Tsh
      (intlist_to_Zlist (Zlist_to_intlist (dd ++ firstn (Z.to_nat k) data)))
      (offset_val (Int.repr 40) c))
    with (array_at tuchar Tsh (ZnthV tuchar (map Vint (map Int.repr (dd ++ data)))) 0
  64 (offset_val (Int.repr 40) c)).
 cancel.
 unfold data_block.
 rewrite prop_true_andp.
 replace (Zlength
     (intlist_to_Zlist (Zlist_to_intlist (dd ++ firstn (Z.to_nat k) data))))
  with 64%Z
 by (rewrite Zlength_correct;
      change 64%Z with (Z.of_nat 64); symmetry; f_equal;
       rewrite length_intlist_to_Zlist, H12; reflexivity).
  apply equal_f; apply array_at_ext; intros.
 unfold tuchars, ZnthV. repeat rewrite if_false by omega.
 rewrite Zlist_to_intlist_to_Zlist.
  repeat rewrite map_map.
  repeat rewrite (@nth_map' Z val _ _ 0%Z).
  f_equal. f_equal.
 destruct (zlt i (Zlength dd)).
 assert (Z.to_nat i < length dd)
  by (apply Nat2Z.inj_lt; rewrite Z2Nat.id by omega; rewrite <- Zlength_correct; auto).
  repeat rewrite app_nth1 by auto; auto.
 assert (Z.to_nat i >= length dd)
  by (apply Nat2Z.inj_ge; rewrite Z2Nat.id by omega; rewrite <- Zlength_correct; auto).
  repeat rewrite app_nth2 by auto; auto.
  symmetry; apply nth_firstn_low.
  unfold k.
  split. apply Nat2Z.inj_lt. rewrite Nat2Z.inj_sub by omega.
  repeat rewrite Z2Nat.id by omega. rewrite <- Zlength_correct;omega.
 apply Nat2Z.inj_ge.
  repeat rewrite Z2Nat.id by omega. rewrite <- Zlength_correct;omega.
  rewrite app_length. rewrite firstn_length. rewrite min_l.
  unfold k; apply Nat2Z.inj_lt.
 rewrite Z2Nat.id by omega; rewrite Nat2Z.inj_add;
 rewrite Z2Nat.id by omega; rewrite <- Zlength_correct.
 omega.
 unfold k.
 apply Nat2Z.inj_le; rewrite Z2Nat.id by omega.
  rewrite <- Zlength_correct; omega.
  apply Nat2Z.inj_lt; rewrite  Z2Nat.id by omega.
  rewrite app_length, Nat2Z.inj_add.
 repeat rewrite <- Zlength_correct.
  omega.
 rewrite H11; exists LBLOCK; reflexivity.
 rewrite Forall_app; split; auto.
 apply Forall_firstn; auto.
 apply isbyte_intlist_to_Zlist.
 after_call.
 forward. (* data  += fragment; *)
entailer!.
 forward. (* len -= fragment; *)
      normalize_postcondition.
 forward_call (* memset (p,0,SHA_CBLOCK); *)
    (Tsh, offset_val (Int.repr 40) c, 64%Z, Int.zero). {
 fold k. fold j.
 unfold data_block.
 entailer!.
 simpl.
 rewrite <- H12 in H8, H10; clear len'0 H12.
 simpl in H8.
 inversion H8; clear H8; subst len'.
 simpl in H10.
 rewrite memory_block_array_tuchar by omega.
 replace  (Zlength
     (intlist_to_Zlist (Zlist_to_intlist (dd ++ firstn (Z.to_nat k) data))))
    with 64%Z.
 cancel.
 rewrite Zlength_intlist_to_Zlist.
 rewrite Zlength_correct.
 change 64%Z with (4*16)%Z; f_equal.
 rewrite length_Zlist_to_intlist with (n:=16).
 reflexivity.
 simpl.
 rewrite app_length, firstn_length.
 rewrite min_l.
 unfold k in *.
 apply Nat2Z.inj.
 rewrite Nat2Z.inj_add.
 rewrite Z2Nat.id by omega.
 rewrite <- Zlength_correct.
 change (Z.of_nat 64) with 64%Z; omega.
 unfold k in *.
 apply Nat2Z.inj_le; rewrite Z2Nat.id by omega.
 rewrite <- Zlength_correct.
 fold k in H10;  simpl in H10.
 unfold Int.ltu in H10; if_tac in H10; try inv H10.
 unfold k in H8; repeat rewrite Int.unsigned_repr in H8 by omega.
 omega.
}

 after_call.
 unfold sha_update_inv.
 entailer.
 rewrite negb_true_iff in H9.
 apply ltu_repr_false in H9; [ | omega..].
 clear TC  TC1.
 apply exp_right with (Zlist_to_intlist (dd ++ firstn (Z.to_nat k) data)).
 assert (LL: length (dd ++ firstn (Z.to_nat k) data) = CBLOCK). {
 rewrite app_length. rewrite firstn_length. rewrite min_l.
 unfold k in *;
 apply Nat2Z.inj. rewrite Nat2Z.inj_add.
 rewrite Z2Nat.id by omega.
 rewrite <- Zlength_correct. change (Z.of_nat (CBLOCK)) with 64%Z.
 omega.
 apply Nat2Z.inj_le;  rewrite Z2Nat.id by omega; rewrite <- Zlength_correct; omega.
}
assert (length (Zlist_to_intlist (dd ++ firstn (Z.to_nat k) data)) = LBLOCK). {
 apply length_Zlist_to_intlist. change (4*LBLOCK)%nat with CBLOCK.
 apply LL.
}
 assert (KK: k = Z.of_nat (LBLOCK * 4 - length dd)). {
 unfold k.
 rewrite Nat2Z.inj_sub. rewrite Zlength_correct; reflexivity.
 unfold k in H0. clear - H0.
 apply Nat2Z.inj_le.
 change (Z.of_nat (LBLOCK*4)) with 64%Z.
 rewrite <- Zlength_correct.
 omega.
}
 entailer!.
 *
  rewrite H6.
  apply Nat2Z.inj_ge.
  rewrite Nat2Z.inj_sub.
  change (Z.of_nat (LBLOCK*4)) with 64%Z.
  rewrite <- Zlength_correct; omega.
  clear - H3. apply Nat2Z.inj_le. rewrite <- Zlength_correct.
  change (Z.of_nat (LBLOCK*4)%nat) with CBLOCKz; clear - H3; omega.
 *
  apply Zlength_length in H6; auto.
  rewrite H6. exists 1%Z; reflexivity.
 *
  rewrite H6. rewrite Zlist_to_intlist_to_Zlist.
  f_equal. f_equal. clear - H0.
  rewrite Z2Nat.inj_sub by omega.
  rewrite Zlength_correct, Nat2Z.id.
  reflexivity.
  rewrite LL. exists 16; reflexivity.
  rewrite Forall_app; split; auto.
  apply Forall_firstn; auto.
 *
  rewrite H6. f_equal.
  f_equal.
  auto.
 *
  rewrite H6. do 2 f_equal.
  rewrite Nat2Z.inj_sub. f_equal; auto.
  apply Nat2Z.inj_le.
  rewrite <- KK. omega.
 *
  unfold data_block.
  rewrite prop_true_andp by auto.
  rewrite cVint_force_int_ZnthV.
  rewrite <- split_array_at.
 auto.
 omega. rewrite initial_world.Zlength_map. omega.
Qed.


Require Import VST.floyd.proofauto.
Require Import VST.progs.logical_compare.

Instance CompSpecs : compspecs. Proof. make_compspecs prog. Defined.

(****  START *)

Definition logical_and_result v1 v2 : int :=
   if Int.eq v1 Int.zero then Int.zero else v2.

Definition logical_or_result v1 v2 : int :=
  if Int.eq v1 Int.zero then v2 else Int.one.

Fixpoint quick_shortcut_logical (s: statement) : option ident :=
match s with
| Sifthenelse _
     (Sset id (Econst_int _ (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
     s2 => match quick_shortcut_logical s2 with None => None | Some id2 =>
                 if ident_eq id id2 then Some id else None
                end
| Sifthenelse e1 s2
     (Sset id (Econst_int _ (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
      => match quick_shortcut_logical s2 with None => None | Some id2 =>
                 if ident_eq id id2 then Some id else None
            end
| Sset id (Ecast _ (Tint IBool Unsigned {| attr_volatile := false; attr_alignas := None |})) =>
        Some id
| _ => None
end.

Fixpoint shortcut_logical (eval: expr -> option val) (tid: ident) (s: statement)
            : option (int * list expr) :=
match s with
| Sifthenelse e1
     (Sset id (Econst_int one (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
     s2 => if andb (eqb_ident id tid) (Int.eq one Int.one)
                then match eval e1 with
                        | Some (Vint v1) =>
                           match shortcut_logical eval tid s2 with
                           | Some (v2, el) => Some (logical_or_result v1 v2, e1 :: el)
                           | _ => None
                           end
                        | _ => None
                        end
                else None
| Sifthenelse e1 s2
     (Sset id (Econst_int zero (Tint I32 Signed {| attr_volatile := false; attr_alignas := None |})))
      => if andb (eqb_ident id tid) (Int.eq zero Int.zero)
            then match eval e1 with
                     | Some (Vint v1) =>
                      match shortcut_logical eval tid s2 with
                      | Some (v2, el) => Some (logical_and_result v1 v2, e1 :: el)
                      | _ => None
                      end
                   | _ => None
                end
            else None
| Sset id (Ecast e (Tint IBool Unsigned {| attr_volatile := false; attr_alignas := None |})) =>
        if eqb_ident id tid
        then match eval (Ecast e tbool) with
                 | Some (Vint v) => Some (v, (Ecast e tbool :: nil))
                 | _ => None
                end
        else None
| _ => None
end.

Lemma semax_shortcut_logical:
  forall Espec {cs: compspecs} Delta P Q R tid s v Qtemp Qvar GV el,
   quick_shortcut_logical s = Some tid ->
   typeof_temp Delta tid = Some tint ->
   local2ptree Q = (Qtemp, Qvar, nil, GV) ->
   Qtemp ! tid = None ->
   shortcut_logical (msubst_eval_expr Delta Qtemp Qvar GV) tid s = Some (v, el) ->
   ENTAIL Delta, PROPx P (LOCALx Q (SEPx R)) |-- fold_right (fun e q => tc_expr Delta e && q) TT el ->
   @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R)))
          s (normal_ret_assert (PROPx P (LOCALx (temp tid (Vint v) :: Q) (SEPx R)))).
Admitted.

(***** END *)

Definition do_or_spec :=
 DECLARE _do_or
  WITH a: int, b : int
  PRE [ tbool, tbool ]
        PROP () PARAMS (Vint a; Vint b) SEP ()
  POST [ tbool ]
        PROP() RETURN (Vint (logical_or_result a b))
        SEP().

Definition do_and_spec :=
 DECLARE _do_and
  WITH a: int, b : int
  PRE [ tbool, tbool ]
        PROP () PARAMS (Vint a; Vint b) SEP ()
  POST [ tbool ]
        PROP() RETURN (Vint (logical_and_result a b))
        SEP().

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog tt gv
  POST [ tint ] main_post prog gv.

Definition Vprog : varspecs := nil.

Definition Gprog : funspecs :=
      ltac:(with_library prog [do_or_spec; do_and_spec; main_spec]).

Ltac do_semax_shortcut_logical :=
 eapply semax_shortcut_logical;
   [ reflexivity | reflexivity | prove_local2ptree
   | reflexivity | reflexivity
   | unfold fold_right; entailer  ].

Lemma body_do_or: semax_body Vprog Gprog f_do_or do_or_spec.
Proof.
start_function.

eapply semax_seq'; [do_semax_shortcut_logical | abbreviate_semax].
forward.
destruct H,H0; subst; simpl; entailer!.
Qed.

Lemma body_do_and: semax_body Vprog Gprog f_do_and do_and_spec.
Proof.
start_function.
eapply semax_seq'; [do_semax_shortcut_logical | abbreviate_semax].
forward.
destruct H,H0; subst; simpl; entailer!.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward.
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog tt Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_do_or.
semax_func_cons body_do_and.
semax_func_cons body_main.
Qed.


(* bad *)
From Coq Require Import
  Lists.List Logic.ProofIrrelevance ZArith.ZArith.
From DEZ.Has Require Export
  OneSortedEnumeration OneSortedCardinality.
From DEZ.Is Require Export
  OneSortedFinite Isomorphic TwoSortedBimodule
  Ring TwoSortedUnitalAssociativeAlgebra.
From DEZ.Justifies Require Export
  OneSortedPositiveOperations OneSortedNaturalOperations
  OneSortedIntegerOperations.
From DEZ.Justifies Require Export
  ZTheorems.
From DEZ.Supports Require Import
  OneSortedArithmeticNotations.
From DEZ.Supports Require Import
  OneSortedMultiplicativeOperationNotations.

Import ListNotations.

Import Addition.Subclass Zero.Subclass Negation.Subclass
  Multiplication.Subclass One.Subclass.

Definition Nseq (start len : N) : list N :=
  map N.of_nat (seq (N.to_nat start) (N.to_nat len)).

(* From Coq Require Import
  FSets.FMapAVL Structures.OrderedTypeEx.
Module Import Map := FMapAVL.Make Positive_as_OT. *)

From Coq Require Import
  FSets.FMapList Structures.OrderedTypeEx.
Module Import Map := FMapList.Make Positive_as_OT.

From Coq Require Import
  FSets.FMapFacts.

Module Props := WProperties_fun Positive_as_OT Map.
Module Mapper := Props.F.

Definition Map_max_key {A : Type} (xs : Map.t A) : option key :=
  Map.fold (fun (n : key) (x : A) (ms : option key) =>
    match ms with
    | Some m => Some (Pos.max n m)
    | None => Some n
    end) xs None.

Definition Map_max_key_def {A : Type} (d : key) (xs : Map.t A) : key :=
  Map.fold (fun (n : key) (x : A) (m : key) => Pos.max n m) xs d.

Section Context.

Context (A B : Type) `{IsTwoBimod A B}.

Record tensor : Type := {
  ht : A;
  tt : Map.t (list B);
}.

Definition proper (p : tensor) : Prop :=
  forall (k : key) (x : list B),
  MapsTo k x (tt p) -> length x = Pos.to_nat k.

Definition Add (p q : tensor) : tensor := {|
  ht := Addition.add (ht p) (ht q);
  tt := Map.map2 (fun (as' bs : option (list B)) => match as', bs with
    | Some a, Some b => Some (List.map (prod_uncurry Addition.add) (combine a b))
    | Some a, None => Some a
    | None, Some b => Some b
    | None, None => None
    end) (tt p) (tt q)
|}.

Definition Zero : tensor := {|
  ht := zero;
  tt := Map.empty (list B);
|}.

Definition Neg (p : tensor) : tensor :={|
  ht := neg (ht p);
  tt := Map.map (List.map neg) (tt p);
|}.

Definition ActL (a : A) (p : tensor) : tensor :=
  {| ht := ht p; tt := Map.map (List.map (act_l a)) (tt p) |}.

Definition ActR (p : tensor) (a : A) : tensor :=
  {| ht := ht p; tt := Map.map (List.map (flip act_r a)) (tt p) |}.

Global Instance N_has_bin_op : HasBinOp N := N.add.

Global Instance N_has_null_op : HasNullOp N := N.zero.

(** Instant tensor algebra; just add water. *)

End Context.

(* Section Tests.

Local Open Scope Z_scope.

Instance positive_has_one : HasOne positive := xH.

Instance Z3_has_add : HasAdd (Z * Z * Z) :=
  fun x y : Z * Z * Z =>
  match x, y with
  | (x0, x1, x2), (y0, y1, y2) => (x0 + y0, x1 + y1, x2 + y2)
  end.

Instance Z3_has_neg : HasNeg (Z * Z * Z) :=
  fun x : Z * Z * Z =>
  match x with
  | (x0, x1, x2) => (- x0, - x1, - x2)
  end.

Instance Z3_has_act_l : HasActL Z (Z * Z * Z) :=
  fun (a : Z) (x : Z * Z * Z) =>
  match x with
  | (x0, x1, x2) => (a * x0, a * x1, a * x2)
  end.

Instance Z3_has_act_r : HasActR Z (Z * Z * Z) :=
  fun (x : Z * Z * Z) (a : Z) =>
  match x with
  | (x0, x1, x2) => (x0 * a, x1 * a, x2 * a)
  end.

Let p : tensor := {|
  ht := Z.zero;
  tt := Props.of_list [
    (1%positive, [(0, 0, 0)]);
    (2%positive, [(1, 0, 0); (1, 0, 0)]);
    (3%positive, [(0, 0, 7); (0, 1, 0); (1, 0, 0)])];
|}.

Let q : tensor := {|
  ht := Z.zero;
  tt := Props.of_list [
    (1%positive, [(2, 1, 0)]);
    (2%positive, [(1, 0, 0); (1, 0, 0)]);
    (3%positive, [(0, 1, 0); (0, 1, 0); (0, 0, 1)])];
|}.

Let r : tensor := {|
  ht := Z.zero;
  tt := Props.of_list [
    (1%positive, [(0, 0, 0)]);
    (2%positive, [(0, 0, 0); (0, 0, 0)]);
    (3%positive, [(1, 0, 0); (1, 0, 0); (2, 1, 0)]);
    (4%positive, [(0, 0, 7); (0, 1, 0); (1, 0, 0); (2, 1, 0)]);
    (5%positive, [(1, 0, 0); (1, 0, 0); (0, 1, 0); (0, 1, 0); (0, 0, 1)]);
    (6%positive, [(0, 0, 7); (0, 1, 0); (1, 0, 0); (0, 1, 0); (0, 1, 0); (0, 0, 1)])];
|}.

Compute GrdMul p q.
Compute r.

End Tests. *)


Load "Pi4.v".

(**************************************************************************************************)

Theorem DDH_two_RRS1 : phi11 ~ phi31.

Proof.  try (unfold phi11, phi21, phi10, phi20, t10, t20, t11,t12, t21,t22). unfold qa0000, qb0000, mphi10, mphi20, phi10. try (unfold phi11, phi21, phi10, phi20, t10, t20, t11,t12, t21,t22). simpl.  try unfold grn21, grn21, msgt10, msgt11, msgt20, msgt21. simpl. reflexivity. Qed.

Theorem DDH_two_RRS2 : phi12 ~ phi22.
Proof. repeat (try (unfold phi12, phi22 ,phi11, phi21, phi10, phi20, t10, t20, t11,t12, t21,t22, t13, t23)). simpl. unfold qa0000, qb0000, qa1000, qa0010, qa0001, qa0100,qb1000, qb0010, qb0001, qb0100, mphi10, mphi20, phi10. simpl. try (unfold phi11, phi21, phi10, phi20, t10, t20, t11,t12, t21,t22, t13). simpl.  try unfold  grn2, grn22, grn21, grn21, msgt10, msgt11, msgt20, msgt21, mphi21, mphi11. simpl. reflexivity. Qed.

Theorem DDH_two_RRS3: phi13~ phi23.
Proof.  reflexivity. Qed.

Theorem DDH_two_RRS4: (Fresh [0; 1;2; 3] [] = true) -> phi14 ~ phi24.
Proof .  intros; pose proof (DDH); apply DDH in H;  repeat try unfold phi15, phi25, phi14, phi24, phi13, phi23, phi12, phi22 ,phi11, phi21, phi10, phi20 . repeat try unfold t10, t20, t11,t12, t21,t22, t13, t23, t14, t24, t15, t25, t16, t26.  try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10. try simpl.  try unfold mphi25,mphi24,  mphi23,mphi22 . try unfold mphi21,  mphi20. simpl.
repeat try unfold msgt10, msgt20, msgt11, msgt12, msgt21, msgt22, msgt13, msgt23, msgt14, msgt24, msgt15, msgt25, msgt16, msgt26;
 repeat try unfold grn21, grn2, grn3, grn4, grn21, grn22, grn23, grn24; repeat try unfold mf1ph10rn1,  mf2ph110rn1,   mf2ph11rn1,  mf2ph11rn2,  mf3ph12rn1, mf3ph12rn2,  mf1ph20rn1,  mf2ph20rn1,   mf2ps1rn1,  mf2ps1rn2,  mf3ps2rn1, mf3ps2rn2; repeat try simpl;
repeat try unfold q0000, q1000 , q0010,q0100,q0001 ,q2000,q1100 ,q1001 ,q0110,q0200,q1000_s,q0010_s,q0100_s,q0001_s,q2100,q1200,q2001,q0210,
 q0120,q2000_s, q1100_s, q1001_s, q0110_s,q0200_s,q1000_ss,q0010_ss, q0100_ss,q0001_ss,q2200,q2100_s,q1200_s,q2001_s,q0210_s,q0120_s,q2000_ss,q1100_ss ,q1001_ss,q0110_ss,q0200_ss,
 q1000_sss,q0010_sss,q0100_sss,q0001_sss;
repeat try unfold qb0000, qb1000 , qb0010,qb0100,qb0001 ,qb2000,qb1100 ,qb1001 ,qb0110,qb0200,qb1000_s,qb0010_s,qb0100_s,qb0001_s,qb2100,qb1200,qb2001,qb0210,
 qb0120,qb2000_s, qb1100_s, qb1001_s, qb0110_s,qb0200_s,qb1000_ss,qb0010_ss, qb0100_ss,qb0001_ss,qb2200,qb2100_s,qb1200_s,qb2001_s,qb0210_s,qb0120_s,qb2000_ss,qb1100_ss ,qb1001_ss,qb0110_ss,qb0200_ss,
 qb1000_sss,qb0010_sss,qb0100_sss,qb0001_sss.

 repeat try unfold phi15, phi25, phi14, phi24, phi13, phi23, phi12, phi22 ,phi11, phi21, phi10, phi20 ;  repeat try unfold t10, t20, t11,t12, t21,t22, t13, t23, t14, t24, t15, t25, t16, t26. repeat try unfold mphi15, mphi25, mphi14, mphi24, mphi13, mphi23, mphi12, mphi22 ,mphi11, mphi21, mphi10, mphi20.
 try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10. try simpl.  try unfold mphi25,mphi24,  mphi23,mphi22 . try unfold mphi21,  mphi20. simpl.
repeat try unfold msgt10, msgt20, msgt11, msgt12, msgt21, msgt22, msgt13, msgt23, msgt14, msgt24, msgt15, msgt25, msgt16, msgt26;
 repeat try unfold grn1, grn2, grn3, grn4, grn21, grn22, grn23, grn24; repeat try unfold mf1ph10rn1,  mf2ph10rn1,   mf2ph11rn1,  mf2ph11rn2,  mf3ph12rn1, mf3ph12rn2, mf3ph11rn2,  mf1ph20rn1,  mf2ph20rn1,   mf2ps1rn1,  mf2ps1rn2,  mf3ps2rn1, mf3ps2rn2, mf3ps1rn2; repeat try simpl;
repeat try unfold q0000, q1000 , q0010,q0100,q0001 ,q2000,q1100 ,q1001 ,q0110,q0200,q1000_s,q0010_s,q0100_s,q0001_s,q2100,q1200,q2001,q0210,
 q0120,q2000_s, q1100_s, q1001_s, q0110_s,q0200_s,q1000_ss,q0010_ss, q0100_ss,q0001_ss,q2200,q2100_s,q1200_s,q2001_s,q0210_s,q0120_s,q2000_ss,q1100_ss ,q1001_ss,q0110_ss,q0200_ss,
 q1000_sss,q0010_sss,q0100_sss,q0001_sss;
repeat try unfold qb0000, qb1000 , qb0010,qb0100,qb0001 ,qb2000,qb1100 ,qb1001 ,qb0110,qb0200,qb1000_s,qb0010_s,qb0100_s,qb0001_s,qb2100,qb1200,qb2001,qb0210,
 qb0120,qb2000_s, qb1100_s, qb1001_s, qb0110_s,qb0200_s,qb1000_ss,qb0010_ss, qb0100_ss,qb0001_ss,qb2200,qb2100_s,qb1200_s,qb2001_s,qb0210_s,qb0120_s,qb2000_ss,qb1100_ss ,qb1001_ss,qb0110_ss,qb0200_ss,
 qb1000_sss,qb0010_sss,qb0100_sss,qb0001_sss.

 try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10. try simpl.  try unfold mphi25,mphi24,  mphi23,mphi22 . try unfold mphi21,  mphi20. simpl.

Admitted.

Theorem DDH_two_RRS5: [t15] ~ [t25].

Proof.    repeat try unfold phi15, phi25, phi14, phi24, phi13, phi23, phi12, phi22 ,phi11, phi21, phi10, phi20 . repeat try unfold t10, t20, t11,t12, t21,t22, t13, t23, t14, t24, t15, t25, t16, t26.  try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10. try simpl.  try unfold mphi25,mphi24,  mphi23,mphi22 . try unfold mphi21,  mphi20. simpl.
repeat try unfold msgt10, msgt20, msgt11, msgt12, msgt21, msgt22, msgt13, msgt23, msgt14, msgt24, msgt15, msgt25, msgt16, msgt26;
 repeat try unfold grn1, grn2, grn3, grn4, grn21, grn22, grn23, grn24; repeat try unfold mf1ph10rn1,  mf2ph10rn1,   mf2ph11rn1,  mf2ph11rn2,  mf3ph12rn1, mf3ph12rn2,  mf1ph20rn1,  mf2ph20rn1,   mf2ps1rn1,  mf2ps1rn2,  mf3ps2rn1, mf3ps2rn2; repeat try simpl;
repeat try unfold q0000, q1000 , q0010,q0100,q0001 ,q2000,q1100 ,q1001 ,q0110,q0200,q1000_s,q0010_s,q0100_s,q0001_s,q2100,q1200,q2001,q0210,
 q0120,q2000_s, q1100_s, q1001_s, q0110_s,q0200_s,q1000_ss,q0010_ss, q0100_ss,q0001_ss,q2200,q2100_s,q1200_s,q2001_s,q0210_s,q0120_s,q2000_ss,q1100_ss ,q1001_ss,q0110_ss,q0200_ss,
 q1000_sss,q0010_sss,q0100_sss,q0001_sss;
repeat try unfold qb0000, qb1000 , qb0010,qb0100,qb0001 ,qb2000,qb1100 ,qb1001 ,qb0110,qb0200,qb1000_s,qb0010_s,qb0100_s,qb0001_s,qb2100,qb1200,qb2001,qb0210,
 qb0120,qb2000_s, qb1100_s, qb1001_s, qb0110_s,qb0200_s,qb1000_ss,qb0010_ss, qb0100_ss,qb0001_ss,qb2200,qb2100_s,qb1200_s,qb2001_s,qb0210_s,qb0120_s,qb2000_ss,qb1100_ss ,qb1001_ss,qb0110_ss,qb0200_ss,
 qb1000_sss,qb0010_sss,qb0100_sss,qb0001_sss.

repeat try unfold phi15, phi25, phi14, phi24, phi13, phi23, phi12, phi22 ,phi11, phi21, phi10, phi20 ;  repeat try unfold t10, t20, t11,t12, t21,t22, t13, t23, t14, t24, t15, t25, t16, t26. repeat try unfold mphi15, mphi25, mphi14, mphi24, mphi13, mphi23, mphi12, mphi22 ,mphi11, mphi21, mphi10, mphi20.
 try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10. try simpl.  try unfold mphi25,mphi24,  mphi23,mphi22 . try unfold mphi21,  mphi20. simpl.
repeat try unfold msgt10, msgt20, msgt11, msgt12, msgt21, msgt22, msgt13, msgt23, msgt14, msgt24, msgt15, msgt25, msgt16, msgt26;
 repeat try unfold grn1, grn2, grn3, grn4, grn21, grn22, grn23, grn24; repeat try unfold mf1ph10rn1,  mf2ph10rn1,   mf2ph11rn1,  mf2ph11rn2,  mf3ph12rn1, mf3ph12rn2, mf3ph11rn2,  mf1ph20rn1,  mf2ph20rn1,   mf2ps1rn1,  mf2ps1rn2,  mf3ps2rn1, mf3ps2rn2, mf3ps1rn2; repeat try simpl;
repeat try unfold q0000, q1000 , q0010,q0100,q0001 ,q2000,q1100 ,q1001 ,q0110,q0200,q1000_s,q0010_s,q0100_s,q0001_s,q2100,q1200,q2001,q0210,
 q0120,q2000_s, q1100_s, q1001_s, q0110_s,q0200_s,q1000_ss,q0010_ss, q0100_ss,q0001_ss,q2200,q2100_s,q1200_s,q2001_s,q0210_s,q0120_s,q2000_ss,q1100_ss ,q1001_ss,q0110_ss,q0200_ss,
 q1000_sss,q0010_sss,q0100_sss,q0001_sss;
repeat try unfold qb0000, qb1000 , qb0010,qb0100,qb0001 ,qb2000,qb1100 ,qb1001 ,qb0110,qb0200,qb1000_s,qb0010_s,qb0100_s,qb0001_s,qb2100,qb1200,qb2001,qb0210,
 qb0120,qb2000_s, qb1100_s, qb1001_s, qb0110_s,qb0200_s,qb1000_ss,qb0010_ss, qb0100_ss,qb0001_ss,qb2200,qb2100_s,qb1200_s,qb2001_s,qb0210_s,qb0120_s,qb2000_ss,qb1100_ss ,qb1001_ss,qb0110_ss,qb0200_ss,
 qb1000_sss,qb0010_sss,qb0100_sss,qb0001_sss.

repeat try unfold phi15, phi25, phi14, phi24, phi13, phi23, phi12, phi22 ,phi11, phi21, phi10, phi20 ;  repeat try unfold t10, t20, t11,t12, t21,t22, t13, t23, t14, t24, t15, t25, t16, t26. repeat try unfold mphi15, mphi25, mphi14, mphi24, mphi13, mphi23, mphi12, mphi22 ,mphi11, mphi21, mphi10, mphi20.
 try unfold mphi15 , mphi14 , mphi13 , mphi12. try unfold mphi11, mphi10. try simpl.  try unfold mphi25,mphi24,  mphi23,mphi22 . try unfold mphi21,  mphi20. simpl.
repeat try unfold msgt10, msgt20, msgt11, msgt12, msgt21, msgt22, msgt13, msgt23, msgt14, msgt24, msgt15, msgt25, msgt16, msgt26;
 repeat try unfold grn1, grn2, grn3, grn4, grn21, grn22, grn23, grn24; repeat try unfold mf1ph10rn1,  mf2ph10rn1,   mf2ph11rn1,  mf2ph11rn2,  mf3ph12rn1, mf3ph12rn2, mf3ph11rn2,  mf1ph20rn1,  mf2ph20rn1,   mf2ph21rn1,  mf2ph21rn2,  mf3ps2rn1, mf3ps2rn2, mf3ph21rn2; repeat try simpl;
repeat try unfold q0000, q1000 , q0010,q0100,q0001 ,q2000,q1100 ,q1001 ,q0110,q0200,q1000_s,q0010_s,q0100_s,q0001_s,q2100,q1200,q2001,q0210,
 q0120,q2000_s, q1100_s, q1001_s, q0110_s,q0200_s,q1000_ss,q0010_ss, q0100_ss,q0001_ss,q2200,q2100_s,q1200_s,q2001_s,q0210_s,q0120_s,q2000_ss,q1100_ss ,q1001_ss,q0110_ss,q0200_ss,
 q1000_sss,q0010_sss,q0100_sss,q0001_sss;
repeat try unfold qb0000, qb1000 , qb0010,qb0100,qb0001 ,qb2000,qb1100 ,qb1001 ,qb0110,qb0200,qb1000_s,qb0010_s,qb0100_s,qb0001_s,qb2100,qb1200,qb2001,qb0210,
 qb0120,qb2000_s, qb1100_s, qb1001_s, qb0110_s,qb0200_s,qb1000_ss,qb0010_ss, qb0100_ss,qb0001_ss,qb2200,qb2100_s,qb1200_s,qb2001_s,qb0210_s,qb0120_s,qb2000_ss,qb1100_ss ,qb1001_ss,qb0110_ss,qb0200_ss,
 qb1000_sss,qb0010_sss,qb0100_sss,qb0001_sss.

Admitted.


Require Import Coq.ZArith.BinInt.
Require Import riscv.util.BitWidths.
Require Import riscv.util.Monads.
Require Import riscv.Decode.
Require Import riscv.util.BitWidths.
Require Import riscv.Memory. (* should go before Program because both define loadByte etc *)
Require Import riscv.Program.
Require Import riscv.Execute.
Require Import riscv.util.PowerFunc.
Require Import riscv.Utility.

Section Riscv.

  Context {B: BitWidths}.
  Context {mword: Set}.
  Context {MW: MachineWidth mword}.

  Context {M: Type -> Type}.
  Context {MM: Monad M}.
  Context {MP: MonadPlus M}.
  Context {RVP: RiscvProgram M mword}.
  Context {RVS: RiscvState M mword}.

  Definition RV_wXLEN_IM: InstructionSet :=
    match bitwidth with
    | BW32 => RV32IM
    | BW64 => RV64IM
    end.

  Definition run1:
    M unit :=
    pc <- getPC;
    inst <- loadWord pc;
    execute (decode RV_wXLEN_IM (uwordToZ inst));;
    step.

  Definition run: nat -> M unit :=
    fun n => power_func (fun m => run1 ;; m) n (Return tt).

End Riscv.