(* Well-scopedness definition for LambdaANF. Part of the CertiCoq project.
 * Author: Anonymized, 2016
 *)

Require Import LambdaANF.set_util LambdaANF.cps LambdaANF.eval LambdaANF.cps_util LambdaANF.ctx LambdaANF.identifiers.
Require Import Coq.MSets.MSetRBT Coq.Lists.List.
Require Import compcert.lib.Coqlib.

Import PS.

Definition env_subset (rho1 rho2 : env) :=
  forall x v, M.get x rho1 = Some v -> M.get x rho2 = Some v.

(** An expression is well scoped in an environment: [Γ |- e] *)
Inductive well_scoped_exp : env -> exp -> Prop :=
| WS_constr :
    forall x t ys vs e Γ,
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Econstr x t ys e)
| WS_case :
    forall x v te Γ,
      M.get x Γ = Some v ->
      Forall (fun p => well_scoped_exp Γ (snd p)) te ->
      well_scoped_exp Γ (Ecase x te)
| WSproj :
    forall x tau N y v e Γ,
      M.get y Γ = Some v ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Eproj x tau N y e)
| WSletapp :
    forall x tau f ys v e Γ,
      get_list ys Γ = Some v ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Eletapp x f tau ys e)
| WS_app :
    forall x v ys vs ft Γ,
      get_list ys Γ = Some vs ->
      M.get x Γ = Some v ->
      well_scoped_exp Γ (Eapp x ft ys)
| WS_prim :
    forall x f ys vs e Γ,
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp (M.set x v Γ) e) ->
      well_scoped_exp Γ (Eprim x f ys e)
| WS_halt :
    forall x v Γ,
      M.get x Γ = Some v ->
      well_scoped_exp Γ (Ehalt x)
| WS_fun :
    forall defs e Γ,
      well_scoped_fundefs Γ defs ->
      (forall vs Γ',
         set_lists (elements (fundefs_names defs)) vs Γ = Some Γ' ->
         well_scoped_exp Γ' e) ->
      well_scoped_exp Γ (Efun defs e)
with well_scoped_fundefs : env -> fundefs -> Prop :=
| WS_fcons :
    forall f tau xs e defs Γ,
      (forall vs vs' Γ' Γ'',
         set_lists (elements (fundefs_names defs)) vs' Γ = Some Γ' ->
         set_lists xs vs Γ' = Some Γ'' ->
         well_scoped_exp Γ'' e) ->
      (forall v, well_scoped_fundefs (M.set f v Γ) defs) ->
      well_scoped_fundefs Γ (Fcons f tau xs e defs)
| WS_fnil :
    forall Γ,
      well_scoped_fundefs Γ Fnil.

Fixpoint fundefs_ctx_names (cdefs : fundefs_ctx) : FVSet :=
  match cdefs with
    | Fcons1_c f _ _ _ defs => add f (fundefs_names defs)
    | Fcons2_c f _ _ _ cdefs' => add f (fundefs_ctx_names cdefs')
  end.

(** [Γ {[Γ']} |- c  ]: A context is well scoped in an environment Γ, given that
    the expression we put in the hole is well scoped in the environment Γ' *)
Inductive well_scoped_exp_ctx : env -> exp_ctx -> env -> Prop :=
| WSCtx_hole :
    forall Γ Γ',
      env_subset Γ' Γ ->
      well_scoped_exp_ctx Γ Hole_c Γ'
| WSCtx_constr :
    forall x t ys vs c Γ Γ',
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Econstr_c x t ys c) Γ'
| WSCtx_proj :
    forall x tau N y v c Γ Γ',
      M.get y Γ = Some v ->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Eproj_c x tau N y c) Γ'
| WSCtx_letapp :
    forall x tau f ys vs c Γ Γ',
      get_list ys Γ = Some vs->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Eletapp_c x f tau ys c) Γ'
| WSCtx_prim :
    forall x f ys vs c Γ Γ',
      get_list ys Γ = Some vs ->
      (forall v, well_scoped_exp_ctx (M.set x v Γ) c Γ') ->
      well_scoped_exp_ctx Γ (Eprim_c x f ys c) Γ'
| WSCtx_fun1 :
    forall defs c Γ Γ',
      well_scoped_fundefs Γ defs ->
      (forall vs Γ'',
         set_lists (elements (fundefs_names defs)) vs Γ = Some Γ'' ->
         well_scoped_exp_ctx Γ'' c Γ') ->
      well_scoped_exp_ctx Γ (Efun1_c defs c) Γ'
| WSCtx_fun2 :
    forall cdefs e Γ Γ',
      well_scoped_fundefs_ctx Γ cdefs Γ' ->
      (forall vs Γ'',
         set_lists (elements (fundefs_ctx_names cdefs)) vs Γ = Some Γ'' ->
         well_scoped_exp Γ'' e) ->
      well_scoped_exp_ctx Γ (Efun2_c cdefs e) Γ'
with well_scoped_fundefs_ctx : env -> fundefs_ctx -> env -> Prop :=
| WS_fcons1 :
    forall f tau xs c defs Γ Γ',
      (forall vs vs' Γ'' Γ''',
         set_lists (elements (fundefs_names defs)) vs' Γ = Some Γ''->
         set_lists xs vs Γ'' = Some Γ''' ->
         well_scoped_exp_ctx Γ''' c Γ') ->
      (forall v, well_scoped_fundefs (M.set f v Γ) defs) ->
      well_scoped_fundefs_ctx Γ (Fcons1_c f tau xs c defs) Γ'
| WS_fcons2 :
    forall f tau xs e cdefs Γ Γ',
      (forall vs vs' Γ'' Γ''',
         set_lists (elements (fundefs_ctx_names cdefs)) vs' Γ = Some Γ''->
         set_lists xs vs Γ'' = Some Γ''' ->
         well_scoped_exp Γ''' e) ->
      (forall v, well_scoped_fundefs_ctx (M.set f v Γ) cdefs Γ') ->
      well_scoped_fundefs_ctx Γ (Fcons2_c f tau xs e cdefs) Γ'.

Declare Scope env_scope.

Notation "Γ '⊢' e" := (well_scoped_exp Γ e) (at level 30, no associativity)
                      : env_scope.
Notation "Γ '{[' Γ' ']}' '⊢' e " := (well_scoped_exp_ctx Γ e Γ')
                                      (at level 30, no associativity)
                                    : env_scope.
Notation "Γ '⊢*' f" := (well_scoped_fundefs Γ f) (at level 30, no associativity)
                       : env_scope.
Notation "Γ '{[' Γ' ']}' '⊢*' f " := (well_scoped_fundefs_ctx Γ f Γ')
                                       (at level 30, no associativity)
                                     : env_scope.

Open Scope env_scope.
Open Scope ctx_scope.

Lemma env_subset_set Γ Γ' x v :
  env_subset Γ Γ' ->
  env_subset (M.set x v Γ) (M.set x v Γ')
.
Proof.
  intros Hsub x' v' Hget. rewrite M.gsspec in *.
  destruct (peq x' x); eauto.
Qed.

Lemma env_subset_set_lists Γ1 Γ2 Γ1' xs vs :
  env_subset Γ2 Γ1 ->
  Some Γ1' = set_lists xs vs Γ1 ->
  exists Γ2', Some Γ2' = set_lists xs vs Γ2 /\ env_subset Γ2' Γ1'.
Proof.
  revert vs Γ1'.
  induction xs; simpl; intros vs Γ1' Hsub Hset1;
  destruct vs; try discriminate.
  - inv Hset1; eexists; eauto.
  - destruct (set_lists xs vs Γ1) as [Γ1'' | ] eqn:Heq; try discriminate.
    edestruct (IHxs vs Γ1'' Hsub) as [Γ2' [Heq' Ηsub]]; eauto. inv Hset1.
    exists (M.set a v Γ2'). split. rewrite <- Heq'. eauto.
    eapply env_subset_set. eauto.
Qed.

Lemma env_subset_get_list Γ1 Γ2 xs vs :
  env_subset Γ1 Γ2 ->
  get_list xs Γ1 = Some vs ->
  get_list xs Γ2 = Some vs.
Proof.
  revert vs.
  induction xs; simpl; intros vs Hsub Hget; eauto.
  destruct (M.get a Γ1) eqn:Heq; try discriminate.
  destruct (get_list xs Γ1) eqn:Heq'; try discriminate.
  eapply Hsub in Heq. rewrite Heq. inv Hget.
  erewrite IHxs; eauto.
Qed.

Lemma env_subset_get Γ1 Γ2 x v :
  env_subset Γ1 Γ2 ->
  M.get x Γ1 = Some v ->
  M.get x Γ2 = Some v.
Proof.
  intros Henv Hget. eauto.
Qed.

Lemma well_scoped_exp_fundefs_weakening :
  (forall e Γ Γ',
     Γ ⊢ e -> env_subset Γ Γ' -> Γ' ⊢ e) /\
  (forall defs Γ Γ',
     Γ ⊢* defs -> env_subset Γ Γ' -> Γ' ⊢* defs).
Proof.
  exp_defs_induction IHc IHl IHfc; intros Γ Γ' Hws Hsub;
  try (now inv Hws; econstructor; eauto using env_subset_get_list, env_subset_get;
       intros; eapply IHc; eauto using env_subset_set).
  - inv Hws; econstructor; eauto.
    inv H3. constructor; eauto.
    assert (Hsuf : Γ' ⊢ Ecase v l)
      by (eapply IHl; eauto; econstructor; eauto).
    inv Hsuf; eauto.
  - inv Hws. constructor; eauto.
    intros. edestruct env_subset_set_lists as [Γ2 [Hset2 Hsub2]]; eauto.
  - inv Hws. constructor; eauto.
    intros. edestruct env_subset_set_lists as [Γ2 [Hset2 Hsub2]]; eauto.
    edestruct env_subset_set_lists as [Γ3 [Hset3 Hsub3]]; eauto.
    intros. eapply IHfc; eauto using env_subset_set.
Qed.

Lemma fundefs_names_eq fc e :
  eq (fundefs_ctx_names fc) (fundefs_names (fc <[ e ]>)).
Proof.
  induction fc; simpl; intros x; split; intros HIn; eauto;
  eapply add_spec in HIn; inv HIn; eapply add_spec; eauto;
  right; eapply IHfc; eauto.
Qed.

Lemma fundefs_names_elem fc e :
  eq (fundefs_ctx_names fc) (fundefs_names (fc <[ e ]>)).
Proof.
  induction fc; simpl; eauto;
  intros x; split; intros HIn; eauto;
  eapply add_spec in HIn; inv HIn; eapply add_spec; eauto;
  right; eapply IHfc; eauto.
Qed.

Lemma well_scoped_ctx_app :
  (forall c e Γ Γ',
     Γ {[ Γ' ]} ⊢ c  -> Γ' ⊢ e -> Γ  ⊢ c |[ e ]| ) /\
  (forall fc e Γ Γ',
     Γ {[ Γ' ]} ⊢* fc  -> Γ' ⊢ e -> Γ  ⊢* fc <[ e ]>).
Proof.
  exp_fundefs_ctx_induction IHc IHfc;
  try (now intros e' Γ Γ' Hws1 Hws2; inv Hws1;
       simpl; econstructor; eauto).
  - intros e' Γ Γ' Hws1 Hws2. inv Hws1. simpl.
    eapply well_scoped_exp_fundefs_weakening; eauto.
  - intros te e' Γ Γ' Hws1 Hws2. inv Hws1.
  - intros e' Γ Γ' Hws1 Hws2. inv Hws1.
    simpl. econstructor; eauto. intros.
    eapply H4. erewrite elements_eq; eauto.
    apply fundefs_names_eq.
  - intros e' Γ Γ' Hws1 Hws2. inv Hws1.
    simpl. econstructor; eauto. intros.
    eapply H6. erewrite elements_eq; eauto.
    apply fundefs_names_eq. eauto.
Qed.


Require Import Eqdep Lia Framework FSParameters FileDiskLayer. (* LoggedDiskLayer TransactionCacheLayer TransactionalDiskLayer. *)
Require Import FileDiskNoninterference FileDiskRefinement.
Require Import ATCDLayer FileDisk.TransferProofs ATCD_Simulation ATCD_AOE.
Require Import Not_Init HSS ATCD_ORS ATCD_TS_Common ATCD_TS_Recovery ATCD_TS_Transaction.

Import FileDiskLayer.
Set Nested Proofs Allowed.

Opaque File.recover.
Lemma ATCD_TS_InodeAllocator_read:
forall n inum u u' txns1 txns2 hdr1 hdr2,
Termination_Sensitive u
(Simulation.Definitions.compile
 ATCD_Refinement
 (Simulation.Definitions.compile
 ATC_Refinement
(@lift_L2 AuthenticationOperation _ TD _
    (Inode.InodeAllocator.read inum))))
(Simulation.Definitions.compile
 ATCD_Refinement
 (Simulation.Definitions.compile
 ATC_Refinement
(@lift_L2 AuthenticationOperation _ TD _
    (Inode.InodeAllocator.read inum))))
(Simulation.Definitions.compile
 ATCD_Refinement
 (Simulation.Definitions.compile
 ATC_Refinement
 (Simulation.Definitions.compile
    FD.refinement
    (| Recover |))))
(refines_valid ATCD_Refinement
  (refines_valid ATC_Refinement
 AD_valid_state))
(fun s1 s2 =>
refines_related ATCD_Refinement
(fun s1 s2 => refines_related ATC_Refinement
 (fun s1 s2  => exists s1a s2a,
    File.files_inner_rep s1a (fst (snd (snd s1))) /\
    File.files_inner_rep s2a (fst (snd (snd s2))) /\
    FD_related_states u' None s1a s2a) s1 s2 /\
(forall a,
 Transaction.get_first (fst (snd s1)) a = None <->
 Transaction.get_first (fst (snd s2)) a = None)) s1 s2 /\
 equivalent_for_recovery txns1 txns2 Log.Current_Part hdr1 hdr2 s1 s2 /\
 (forall a,
 fst (snd (snd s1)) a = None <->
 fst (snd (snd s2)) a = None) /\
 fst (snd (snd s1)) =
Mem.list_upd_batch empty_mem
  (map Log.addr_list txns1)
  (map Log.data_blocks txns1) /\
fst (snd (snd s2)) =
Mem.list_upd_batch empty_mem
  (map Log.addr_list txns2)
  (map Log.data_blocks txns2))
(ATCD_reboot_list n).
Proof.
Transparent Inode.InodeAllocator.read.
unfold Inode.InodeAllocator.read; simpl; intros.
destruct (Compare_dec.lt_dec inum
Inode.InodeAllocatorParams.num_of_blocks).
2: {
  intros; eapply TS_eqv_impl.
  apply ATCD_TS_ret.
  simpl; intuition eauto.
}
{
  eapply ATCD_TS_compositional; simpl.
  intros; eapply TS_eqv_impl.
  unfold Inode.InodeAllocatorParams.bitmap_addr in *.
  pose proof Inode.InodeAllocatorParams.blocks_fit_in_disk.
  intros; eapply ATCD_TS_Transaction_read.
  lia.
  simpl; intros; cleanup; eauto.
  {
    intros.
    unfold refines_related in *; cleanup.
    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold HC_refines in *; cleanup.

    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.
    unfold Definitions.refines in *; simpl in *.
    rewrite H13, H14.
    unfold LogCache.cached_log_rep in *; cleanup.
    repeat (split; eauto).
  }
  {
    simpl; intros.

    unfold refines_related in *; cleanup.
    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H0.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_simulation.
    2: apply H13.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    edestruct ATCD_simulation.
    2: apply H14.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    simpl in *; cleanup; repeat invert_exec.

    eapply_fresh lift2_invert_exec in H30;
    eapply_fresh lift2_invert_exec in H31; cleanup.

    unfold refines_related in *; cleanup.
    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.

    eapply Transaction.read_finished in H26; eauto.
    eapply Transaction.read_finished in H24; eauto.

    unfold Inode.InodeAllocatorParams.bitmap_addr in *.
    cleanup; repeat split_ors; cleanup; try lia.
    erewrite InodeTS.inode_allocations_are_same with (s2:= fst (snd (snd x2))); eauto.
    destruct_fresh (nth_error
    (value_to_bits
       (fst (snd (snd x2)) Inode.InodeAllocatorParams.bitmap_addr)) inum);
    setoid_rewrite D; simpl.
    2: {
     eapply TS_eqv_impl.
      apply ATCD_TS_ret.
      shelve.
    }
    destruct b; simpl.
    2: {
     eapply TS_eqv_impl.
      apply ATCD_TS_ret.
      shelve.
    }
    eapply ATCD_TS_compositional; simpl.
    2: intros; apply ATCD_TS_ret.
    intros; eapply TS_eqv_impl.
    eapply ATCD_TS_Transaction_read.
    lia.
    shelve.
    intros; shelve.

    destruct (block_allocator_empty inum);
    rewrite H18;
    eapply TS_eqv_impl;
    try apply ATCD_TS_ret.
    shelve.
    shelve.
  }
  {
    simpl; intros; cleanup; eauto.
    unfold refines_related in *; cleanup.
    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H0.
    }
    all: try solve [simpl in *; eauto].
    shelve.

    edestruct ATCD_simulation.
    2: apply H13.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    edestruct ATCD_simulation.
    2: apply H14.
    all: eauto.
    2:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.

    simpl in *; cleanup; repeat invert_exec.

    eapply_fresh lift2_invert_exec in H30;
    eapply_fresh lift2_invert_exec in H31; cleanup.

    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.

    eapply Transaction.read_finished in H26; eauto.
    eapply Transaction.read_finished in H24; eauto.

    unfold Inode.InodeAllocatorParams.bitmap_addr in *.
    pose proof Inode.InodeAllocatorParams.blocks_fit_in_disk.
    cleanup; repeat split_ors; cleanup; try lia; eauto.

    shelve.
  }
}
Unshelve.
all:
try match goal with
| [|- not_init _ ] =>
  unfold Transaction.read;
  destruct (Compare_dec.lt_dec Inode.InodeAllocatorParams.bitmap_addr
  data_length); simpl; intuition eauto;
  try destruct (Transaction.get_first t Inode.InodeAllocatorParams.bitmap_addr);
  simpl; intuition eauto;
  try match goal with
  | [H: eq_dep _ _ _ _ _ _ |- _] =>
  inversion H
  end
end.
5: instantiate (5 := fun _ _ s0 s3 =>
equivalent_for_recovery txns1 txns2 Log.Current_Part hdr1 hdr2 s0 s3 /\
(Transaction.get_first (fst (snd s0)) (inode_blocks_start + S inum) = None <->
 Transaction.get_first (fst (snd s3)) (inode_blocks_start + S inum) = None) /\
(fst (snd (snd s0)) (data_start + (inode_blocks_start + S inum)) = None <->
 fst (snd (snd s3)) (data_start + (inode_blocks_start + S inum)) = None) /\
fst (snd (snd s0)) =
Mem.list_upd_batch empty_mem (map Log.addr_list txns1)
  (map Log.data_blocks txns1) /\
fst (snd (snd s3)) =
Mem.list_upd_batch empty_mem (map Log.addr_list txns2)
  (map Log.data_blocks txns2)); simpl; intuition eauto.
5: simpl; intuition eauto.
9: simpl; intuition eauto.
5: simpl; intuition eauto.
14: simpl; intuition eauto.
10: simpl; intuition eauto.
5: {
  (*
  instantiate (1:= hdr2).
  instantiate (1:= hdr1).
  instantiate (1:= txns2).
  instantiate (1:= txns1).
  *)
  simpl; intuition eauto.
  simpl in *.

  simpl; intros; cleanup; eauto.
  unfold refines_related in *; cleanup.
  edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H18.
    }
    all: try solve [simpl in *; eauto].
    shelve.
    simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    unfold equivalent_for_recovery in *; cleanup.
    eexists (_, (_, _)); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    edestruct ATCD_AOE.
    4: {
      instantiate (1:= RFinished _ _).
      instantiate (6:= []).
      unfold ATCD_reboot_list; simpl.
      econstructor.
      apply H26.
    }
    all: try solve [simpl in *; eauto].
    shelve.
    simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    unfold equivalent_for_recovery in *; cleanup.
    eexists (_, (_, _)); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    unfold equivalent_for_recovery in *; cleanup.
    edestruct ATCD_simulation.
    2: apply H35.
    all: eauto.
    3:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.
    unfold Simulation.Definitions.refines; simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    instantiate (1:= (_, (_, _))); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    edestruct ATCD_simulation.
    2: apply H44.
    all: eauto.
    3:  unfold ATCD_reboot_list; simpl; econstructor; eauto.
    shelve.
    unfold Simulation.Definitions.refines; simpl.
    unfold HC_refines; simpl.
    unfold HC_refines; simpl.
    unfold Definitions.refines, LogCache.cached_log_rep.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general.
    instantiate (1:= (_, (_, _))); simpl; intuition eauto.
    eexists; simpl; intuition eauto.

    simpl in *; cleanup_no_match; repeat invert_exec.

    repeat invert_lift2.
    simpl in *; unfold HC_refines in *; cleanup.
    simpl in *; unfold TransactionToTransactionalDisk.Definitions.refines in *.

    repeat cleanup_pairs.
    (*
    eapply Transaction.read_finished in H80; eauto.
    eapply Transaction.read_finished in H81; eauto.

    cleanup; repeat cleanup_pairs.

    repeat match goal with
    |[H: _ \/ _|- _] =>
    clear H
    end.

    unfold HC_refines in *; simpl in *; cleanup.
    unfold Definitions.refines, LogCache.cached_log_rep in *.
    unfold Log.log_rep, Log.log_header_rep, Log.log_rep_general in *.
    cleanup.

    eexists (_, (_, _)), (_, (_, _)); simpl; split.
    intuition eauto.
    do 2 eexists; split.
    eauto.
    *)
    admit.
}
Admitted.

Lemma ATCD_TS_DiskAllocator_read:
    forall n a1 a2 u u' txns1 txns2 hdr1 hdr2,
    (a1 < File.DiskAllocatorParams.num_of_blocks <-> a2 < File.DiskAllocatorParams.num_of_blocks) ->
    (File.DiskAllocatorParams.bitmap_addr + S a1 <
    data_length <->
    File.DiskAllocatorParams.bitmap_addr + S a2 <
    data_length) ->
    Termination_Sensitive u
  (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
    ATC_Refinement
     (@lift_L2 AuthenticationOperation _ TD _
     (File.DiskAllocator.read a1))))
  (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
    ATC_Refinement
     (@lift_L2 AuthenticationOperation _ TD _
     (File.DiskAllocator.read a2))))
  (Simulation.Definitions.compile
     ATCD_Refinement
     (Simulation.Definitions.compile
    ATC_Refinement
     (Simulation.Definitions.compile
        FD.refinement
        (| Recover |))))
        (refines_valid ATCD_Refinement
        (refines_valid ATC_Refinement
       AD_valid_state))
  (fun s1 s2 => equivalent_for_recovery txns1 txns2 Log.Current_Part hdr1 hdr2 s1 s2 /\
  refines_related ATCD_Refinement (fun s1 s2 => refines_related ATC_Refinement
  (fun s1 s2  => exists s1a s2a,
  File.files_inner_rep s1a (fst (snd (snd s1))) /\
  File.files_inner_rep s2a (fst (snd (snd s2))) /\
  FD_related_states u' None s1a s2a) s1 s2 /\
  (forall a,
     Transaction.get_first (fst (snd s1)) a = None <->
     Transaction.get_first (fst (snd s2)) a = None) /\
  (Transaction.get_first (fst (snd s1)) (File.DiskAllocatorParams.bitmap_addr + S a1) = None <->
   Transaction.get_first (fst (snd s2)) (File.DiskAllocatorParams.bitmap_addr + S a2) = None) /\
   nth_error
            (value_to_bits
               (upd_batch (snd (snd s1)) (rev (map fst (fst (snd s1))))
               (rev (map snd (fst (snd s1)))) File.DiskAllocatorParams.bitmap_addr)) a1 =
               nth_error
            (value_to_bits
               (upd_batch (snd (snd s2)) (rev (map fst (fst (snd s2))))
               (rev (map snd (fst (snd s2)))) File.DiskAllocatorParams.bitmap_addr)) a2) s1 s2)
  (ATCD_reboot_list n).
  Proof.
    unfold File.DiskAllocator.read; intros.
    destruct (Compare_dec.lt_dec a1 File.DiskAllocatorParams.num_of_blocks);
    destruct (Compare_dec.lt_dec a2 File.DiskAllocatorParams.num_of_blocks);
    try lia.
    2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
    simpl.
    eapply ATCD_TS_compositional.

    intros; eapply TS_eqv_impl.
    eapply ATCD_TS_Transaction_read.
    shelve.
    shelve.
    intros; cleanup; eauto.
    2: shelve.
    intros.

    intros; unfold refines_related in *; cleanup.
    intros; unfold refines_related in *; cleanup.
      eapply_fresh ATCD_oracle_refines_finished in H1; eauto.
      eapply_fresh ATCD_oracle_refines_finished in H2; eauto.
      cleanup.

      eapply_fresh ATCD_exec_lift_finished in H1; eauto;
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_finished];
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_crashed].
      cleanup.
      eapply_fresh ATCD_exec_lift_finished in H2; eauto;
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_finished];
      try solve [apply TransactionToTransactionalDisk.Refinement.TC_to_TD_core_simulation_crashed].
      cleanup.
      simpl in *.
      eapply_fresh ATCD_oracle_refines_impl_eq in H14; eauto.
      2: shelve. (* eapply have_same_structure_get_owner; eauto. *)
      2: apply TC_oracle_refines_operation_eq.
      cleanup.

      clear H1 H2.
    repeat invert_lift2; cleanup.
    apply HC_map_ext_eq in H1; subst.
    unfold HC_refines in *; simpl in *; cleanup.

    unfold TransactionToTransactionalDisk.Definitions.refines in *.
    eapply Transaction.read_finished in H18; eauto.
    eapply Transaction.read_finished in H21; eauto.
    cleanup; repeat split_ors; cleanup; try lia.
    unfold Transaction.transaction_rep in *; cleanup.
    setoid_rewrite H9.
    destruct_fresh (nth_error
    (value_to_bits
       (upd_batch (snd (snd x0)) (rev (map fst (fst (snd x0))))
          (rev (map snd (fst (snd x0))))
          File.DiskAllocatorParams.bitmap_addr)) a2); setoid_rewrite D.
          2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
    {
      destruct b.
      2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
      eapply ATCD_TS_compositional.
      2: intros; eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve].
      intros; simpl;
      eapply TS_eqv_impl; [apply ATCD_TS_Transaction_read; eauto | shelve].
      shelve.
    }
    {
      edestruct (block_allocator_empty a1);
      edestruct (block_allocator_empty a2);
      cleanup;  (eapply TS_eqv_impl; [apply ATCD_TS_ret | shelve]).
    }
  Admitted.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*           Layers of PM: Refinement Proof for PThreadIntro           *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between PKContextNew layer and PThreadIntro layer*)
Require Import ShareIntroGenDef.

(** * Definition of the refinement relation*)
Section Refinement.

  Context `{real_params: RealParams}.

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store) (lflatmem_store:= flatmem_store)).
    Proof.
      accessor_prop_tac.
      - eapply flatmem_store_exists; eauto.
      - eapply flatmem_store_match; eauto.
    Qed.

    Lemma passthrough_correct:
      sim (crel HDATA LDATA) mshareintro_passthrough mptnew.
    Proof.
      sim_oplus.
      - apply fload_sim.
      - apply fstore_sim.
      - apply flatmem_copy_sim.
      - apply vmxinfo_get_sim.
      - apply device_output_sim.
      - apply pfree_sim.
      - apply setPT_sim.
      - apply ptRead_sim.
      - apply ptResv_sim.
      - apply ptResv2_sim.
      - apply pt_new_sim.
      - apply pmap_init_sim.
      - apply ptin_sim.
      - apply ptout_sim.
      - apply clearCR2_sim.
      - apply container_get_nchildren_sim.
      - apply container_get_quota_sim.
      - apply container_get_usage_sim.
      - apply container_can_consume_sim.
      - apply alloc_sim.
      - apply trapin_sim.
      - apply trapout_sim.
      - apply hostin_sim.
      - apply hostout_sim.
      - apply trap_info_get_sim.
      - apply trap_info_ret_sim.
      - layer_sim_simpl.
        + eapply load_correct2.
        + eapply store_correct2.
    Qed.

  End WITHMEM.

End Refinement.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM                                          *)
(*                                                                     *)
(*          Refinement proof for MALInit layer                         *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MBoot layer and MALInit layer*)
Require Import ALInitGenDef.

(** * Definition of the refinement relation*)
Section Refinement.

  Context `{real_params: RealParams}.

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    (** ** The low level specifications exist*)
    Section Exists.

      Lemma setPG_exist:
        forall habd habd' labd f,
          setPG0_spec habd = Some habd'
          -> relate_RData f habd labd
          -> exists labd', setPG_spec labd = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold setPG0_spec, setPG_spec; intros until f; exist_simpl.
      Qed.

      Lemma setCR3_exist:
        forall habd habd' labd id ofs f,
          setCR30_spec habd (GLOBP id ofs) = Some habd'
          -> relate_RData f habd labd
          -> exists labd', setCR3_spec labd (GLOBP id ofs) = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold setCR30_spec, setCR3_spec; intros until f; exist_simpl.
      Qed.

      Lemma trapout_exist:
        forall habd habd' labd f,
          trapout0_spec habd = Some habd'
          -> relate_RData f habd labd
          -> exists labd', trapout'_spec labd = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold trapout0_spec, trapout'_spec; intros until f; exist_simpl.
      Qed.

      Lemma hostout_exist:
        forall habd habd' labd f,
          hostout_spec habd = Some habd'
          -> relate_RData f habd labd
          -> exists labd', hostout'_spec labd = Some labd' /\ relate_RData f habd' labd'
                           /\ AT habd' = AT habd /\ nps habd' = nps habd.
      Proof.
        unfold hostout_spec, hostout'_spec; intros until f; exist_simpl.
      Qed.

    End Exists.

    Ltac pattern2_refinement_simpl:=
      pattern2_refinement_simpl' (@relate_AbData).

    Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store') (lflatmem_store:= flatmem_store')).
    Proof.
      accessor_prop_tac.
      - eapply flatmem_store'_exists; eauto.
    Qed.

    Lemma passthrough_correct:
      sim (crel HDATA LDATA) malinit_passthrough mboot.
    Proof.
      sim_oplus.
      - apply fload'_sim.
      - apply fstore'_sim.
      - apply flatmem_copy'_sim.
      - apply vmxinfo_get_sim.
      - apply device_output_sim.
      - apply get_size_sim.
      - apply is_mm_usable_sim.
      - apply get_mm_s_sim.
      - apply get_mm_l_sim.
      - apply bootloader0_sim.
      - (* set_PG *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        exploit setPG_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        match_external_states_simpl. congruence.
      - apply clearCR2_sim.
      - (* set_CR3 *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        inv_val_inject.
        eapply inject_forward_equal' in H8; eauto 1. inv H8.
        exploit setCR3_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        match_external_states_simpl.
        rewrite Int.add_zero; eauto. congruence.
      - apply trapin_sim.
      - (* trapout *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        inv H4. inv match_extcall_states.
        exploit trapout_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        inv match_match. match_external_states_simpl. congruence.
      - apply hostin_sim.
      - (* hostout *)
        layer_sim_simpl; compatsim_simpl (@match_AbData); intros.
        inv H4. inv match_extcall_states.
        exploit hostout_exist; eauto 1; intros [labd' [HP [HM[HAT HN]]]].
        inv match_match. match_external_states_simpl. congruence.
      - apply trap_info_get_sim.
      - apply trap_info_ret_sim.
      - layer_sim_simpl.
        + eapply load_correct1.
        + eapply store_correct1.
    Qed.

  End WITHMEM.

End Refinement.


Require Import Setoid.
From hahn Require Import Hahn.
From imm Require Import AuxDef Events Execution Execution_eco
     imm_bob imm_s_ppo imm_s imm_s_hb CombRelations AuxRel2.
From imm Require Import TraversalConfig Traversal.
Require Import AuxRel.
Require Export ExtTravRelations.
From imm Require Import TraversalProperties.

Set Implicit Arguments.

Section ExtTraversalConfig.
Variable G : execution.
Variable sc : relation actid.

Notation "'acts'" := G.(acts).
Notation "'sb'" := G.(sb).
Notation "'rmw'" := G.(rmw).
Notation "'data'" := G.(data).
Notation "'addr'" := G.(addr).
Notation "'ctrl'" := G.(ctrl).
Notation "'rmw_dep'" := G.(rmw_dep).
Notation "'rf'" := G.(rf).
Notation "'co'" := G.(co).
Notation "'coe'" := G.(coe).
Notation "'fr'" := G.(fr).

Notation "'eco'" := G.(eco).

Notation "'bob'" := G.(bob).
Notation "'fwbob'" := G.(fwbob).
Notation "'ppo'" := G.(ppo).
Notation "'rppo'" := G.(rppo).
Notation "'fre'" := G.(fre).
Notation "'rfi'" := G.(rfi).
Notation "'rfe'" := G.(rfe).
Notation "'deps'" := G.(deps).
Notation "'detour'" := G.(detour).
Notation "'release'" := G.(release).
Notation "'sw'" := G.(sw).
Notation "'hb'" := G.(hb).

Notation "'urr'" := (urr G sc).
Notation "'c_acq'" := (c_acq G sc).
Notation "'c_cur'" := (c_cur G sc).
Notation "'c_rel'" := (c_rel G sc).
Notation "'t_acq'" := (t_acq G sc).
Notation "'t_cur'" := (t_cur G sc).
Notation "'t_rel'" := (t_rel G sc).
Notation "'S_tm'" := G.(S_tm).
Notation "'S_tmr'" := G.(S_tmr).
Notation "'msg_rel'" := (msg_rel G sc).

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

Notation "'E'" := G.(acts_set).
Notation "'R'" := (fun x => is_true (is_r lab x)).
Notation "'W'" := (fun x => is_true (is_w lab x)).
Notation "'F'" := (fun x => is_true (is_f lab x)).
Notation "'RW'" := (R ∪₁ W).
Notation "'FR'" := (F ∪₁ R).
Notation "'FW'" := (F ∪₁ W).
Notation "'R_ex'" := (fun a => is_true (R_ex lab a)).
Notation "'W_ex'" := (W_ex G).
Notation "'W_ex_acq'" := (W_ex ∩₁ (fun a => is_true (is_xacq lab a))).

Notation "'Init'" := (fun a => is_true (is_init a)).
Notation "'Loc_' l" := (fun x => loc x = Some l) (at level 1).
Notation "'Tid_' t" := (fun x => tid x = t) (at level 1).
Notation "'W_' l" := (W ∩₁ Loc_ l) (at level 1).

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

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

Record ext_trav_config :=
  mkETC { etc_TC : trav_config; reserved : actid -> Prop; }.

Definition eissued  T := issued  (etc_TC T).
Definition ecovered T := covered (etc_TC T).

Definition dom_sb_S_rfrmw T rrf P :=
  dom_rel (sb ⨾ ⦗reserved T⦘) ∩₁ codom_rel (⦗P⦘ ⨾ rrf ⨾ rmw).

Record etc_coherent (T : ext_trav_config) :=
  mkETCC {
  etc_tccoh          : tc_coherent G sc (etc_TC T);
  etc_S_in_E         : reserved T ⊆₁ E;
  etc_I_in_S         : eissued T ⊆₁ reserved T;
  etc_S_I_in_W_ex    : reserved T \₁ eissued T ⊆₁ W_ex;
  etc_F_sb_S         : dom_rel (⦗F∩₁Acq/Rel⦘ ⨾ sb ⨾ ⦗reserved T⦘) ⊆₁ ecovered T ;
  etc_dr_R_acq_I     : dom_rel ((detour ∪ rfe) ⨾ (rmw ⨾ rfi)＊ ⨾ ⦗R∩₁Acq⦘ ⨾ sb ⨾ ⦗reserved T⦘) ⊆₁ eissued T ;
  etc_W_ex_sb_I      : dom_rel (⦗W_ex_acq⦘ ⨾ sb ⨾ ⦗reserved T⦘) ⊆₁ eissued T ;
  etc_sb_S           : dom_sb_S_rfrmw T (rf ⨾ ⦗R_ex⦘) (eissued T) ⊆₁ reserved T;
  (* TODO: uncomment the next property for handling FADDs. *)
  (* etc_sb_Acq_S       : dom_rel ((rmw ⨾ rfi)＊ ⨾ ⦗R∩₁Acq⦘ ⨾ sb ⨾ ⦗reserved T⦘) ∩₁ codom_rel (⦗eissued T⦘ ⨾ rf ⨾ rmw); *)
  etc_rppo_S         : dom_rel ((detour ∪ rfe) ⨾ (data ∪ rfi ∪ rmw)＊ ⨾ rppo ⨾ ⦗ reserved T ⦘) ⊆₁ eissued T;
  etc_d_rmw_S        : dom_rel (detour ⨾ rmw ⨾ ⦗ reserved T ⦘) ⊆₁ eissued T;
  etc_S_W_ex_rfrmw_I : reserved T ∩₁ W_ex ⊆₁ codom_rel (⦗eissued T⦘ ⨾ rf ⨾ rmw);
 }.

Section Props.

Variable WF : Wf G.
Variable T : ext_trav_config.
Variable ETCCOH : etc_coherent T.

Lemma etc_rmw_S : dom_rel ((detour ∪ rfe) ⨾ rmw ⨾ ⦗ reserved T ⦘) ⊆₁ eissued T.
Proof using WF ETCCOH.
  rewrite !seq_union_l, dom_union. unionL; [by apply ETCCOH|].
  rewrite rmw_W_ex, !seqA. rewrite <- id_inter. rewrite set_interC.
  rewrite etc_S_W_ex_rfrmw_I; auto. rewrite rfe_in_rf.
  remember (rf ⨾ rmw) as X.
  arewrite (rf ⨾ rmw ⊆ X) by subst.
  unfolder. ins. desf.
  assert (x = z); subst; auto.
  eapply wf_rfrmwf; eauto.
Qed.

Lemma eissuedW : eissued T ⊆₁ W.
Proof using ETCCOH. unfold eissued. eapply issuedW. apply ETCCOH. Qed.

Lemma reservedW : reserved T ⊆₁ W.
Proof using WF ETCCOH.
  arewrite (reserved T ⊆₁ reserved T \₁ eissued T ∪₁ reserved T ∩₁ eissued T).
  2: { rewrite eissuedW at 2; auto. rewrite etc_S_I_in_W_ex; auto.
       rewrite W_ex_in_W; auto. basic_solver. }
  unfolder. ins.
  destruct (classic (eissued T x)); eauto.
Qed.

End Props.
End ExtTraversalConfig.


Require Import VST.floyd.base2.
Require Import VST.floyd.client_lemmas.
Require Import VST.floyd.nested_field_lemmas.
Require Import VST.floyd.efield_lemmas.
Require Import VST.floyd.mapsto_memory_block.
Require Import VST.floyd.reptype_lemmas.
Require Import VST.floyd.data_at_rec_lemmas.
Require Import VST.floyd.field_at.
Require Import VST.floyd.stronger.
Require Import VST.floyd.entailer.
Require Import VST.floyd.closed_lemmas.
Require Import VST.floyd.proj_reptype_lemmas.
Require Import VST.floyd.replace_refill_reptype_lemmas.
Require Import VST.floyd.loadstore_field_at.
Require Import VST.floyd.nested_loadstore.

Local Open Scope logic.

Definition array_with_hole {cs: compspecs} sh (t: type) lo hi n (al': list (reptype t)) p :=
!! field_compatible (tarray t n) nil p &&
(ALL cl: list (reptype t),
(data_at sh (tarray t (hi-lo)) cl (field_address0 (tarray t n) (ArraySubsc lo :: nil) p)
-* data_at sh (tarray t n) (sublist 0 lo al' ++ cl ++ sublist hi n al') p)).

Lemma array_with_hole_local_facts {cs: compspecs}: forall sh t lo hi n (al': list (reptype t)) p,
array_with_hole sh t lo hi n al' p |--
!! (field_compatible (tarray t n) nil p).
Proof.
intros.
unfold array_with_hole. entailer!.
Qed.
#[export] Hint Resolve array_with_hole_local_facts : saturate_local.

Lemma wand_slice_array:
forall {cs: compspecs} lo hi n sh t (al: list (reptype t)) p,
0 <= lo <= hi ->
hi <= n ->
Zlength al = n ->
data_at sh (tarray t n) al p =
!! (field_compatible (tarray t n) nil p) &&
data_at sh (tarray t (hi-lo)) (sublist lo hi al) (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) *
array_with_hole sh t lo hi n al p.
Proof.
  intros until p.
  intros H H0 H1.
  unfold data_at, array_with_hole.
  assert (forall n, reptype (tarray t n) = list (reptype t)).
  {
    intros.
    rewrite reptype_eq.
    auto.
  }
  apply pred_ext.
  + rewrite (add_andp _ _ (field_at_local_facts _ _ _ _ _)).
    normalize.
    rename H3 into H7, H4 into H8.
    erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
    erewrite (split3seg_array_at' _ _ _ 0 lo hi n); try lia.
      2:etransitivity; [exact H1 | lia].
    unfold data_at.
    rewrite (sepcon_comm (array_at _ _ _ _ _ _ _)), sepcon_assoc.
    apply sepcon_derives.
    - apply derives_refl'.
      f_equal.
      rewrite !Z.sub_0_r.
      auto.
    - apply allp_right; intros v. change (list (reptype t)) in v.
      * apply -> wand_sepcon_adjoint.
        rewrite (add_andp _ _ (field_at_local_facts _ _ _ _ _)).
        normalize.
        rewrite value_fits_eq in H4; simpl in H4.
        destruct H4.
        rewrite Z.max_r in H4 by lia.
        change (@Zlength (reptype t) v = hi - lo) in H4.
        erewrite (field_at_Tarray _ (tarray t n)).
          2: constructor.
          2: reflexivity.
          2: lia.
          2: apply JMeq_refl.
        erewrite (split3seg_array_at' _ _ _ 0 lo hi n); try lia.
        2:{
          change (Zlength (sublist 0 lo al ++ v ++ sublist hi n al) = n - 0).
          autorewrite with sublist.
          lia.
        }
        autorewrite with norm.
        change (array_at sh (tarray t n) nil 0 lo (sublist 0 lo al) p *
                array_at sh (tarray t n) nil hi n (sublist hi n al) p *
                field_at sh (tarray t (hi - lo)) nil v (field_address0 (tarray t n) (SUB lo) p)
                |-- array_at sh (tarray t n) nil 0 lo
                      (sublist 0 lo (sublist 0 lo al ++ v ++ sublist hi n al)) p *
                    data_at sh (nested_field_array_type (tarray t n) nil lo hi)
                      (sublist lo hi (sublist 0 lo al ++ v ++ sublist hi n al))
                      (field_address0 (tarray t n) (SUB lo) p) *
                    array_at sh (tarray t n) nil hi n
                      (sublist hi n (sublist 0 lo al ++ v ++ sublist hi n al)) p).
        unfold tarray; autorewrite with sublist.
        rewrite H4.
        replace (hi - lo - (hi - lo) + hi) with hi by lia.
        replace (n - lo - (hi - lo) + hi) with n by lia.
        rewrite !sepcon_assoc.
        apply sepcon_derives; [apply derives_refl |].
        rewrite sepcon_comm.
        apply sepcon_derives; [| apply derives_refl].
        autorewrite with sublist.
        apply derives_refl.
  + normalize.
    clear H2.
    rewrite sepcon_comm.
    apply wand_sepcon_adjoint.
    apply (allp_left _ (sublist lo hi al)); intros.
    apply wand_derives; [apply derives_refl |].
    unfold data_at.
    apply derives_refl'.
    f_equal.
    autorewrite with sublist.
    auto.
Qed.

Module SingletonHole.

Definition array_with_hole {cs: compspecs} sh (t: type) i n (al': list (reptype t)) p :=
ALL v:reptype t,
 (data_at sh t v (field_address (tarray t n) (ArraySubsc i :: nil) p) -* data_at sh (tarray t n) (upd_Znth i al' v) p).

Lemma array_with_hole_intro {cs: compspecs} sh: forall t i n (al: list (reptype t)) p,
  0 <= i < n ->
  data_at sh (tarray t n) al p |--
    data_at sh t (Znth i al) (field_address (tarray t n) (ArraySubsc i :: nil) p) *
      array_with_hole sh t i n al p.
Proof.
  intros.
  unfold data_at, array_with_hole.
  assert (forall n, reptype (tarray t n) = list (reptype t)).
  {
    intros.
    rewrite reptype_eq.
    auto.
  }
  saturate_local.
  assert (Zlength al = n).
  {
    destruct H2 as [? _].
    rewrite Z.max_r in H2 by lia.
    rewrite <- H2.
    reflexivity.
  }
  clear H2.
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 i (i+1) n); try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  autorewrite with sublist.
  rewrite sublist_len_1.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  erewrite array_at_len_1.
      2: apply JMeq_refl.
  rewrite field_at_data_at.
  change ((nested_field_type (tarray t n) (ArraySubsc i :: nil))) with t.
  cancel.
  apply allp_right; intros v.
  apply -> wand_sepcon_adjoint.

  unfold data_at at 2.
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 i (i+1) n); try lia.
      2: autorewrite with sublist; change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  autorewrite with sublist.
  rewrite sublist_len_1.
      2: autorewrite with sublist; change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  erewrite array_at_len_1.
      2: apply JMeq_refl.
  rewrite field_at_data_at.
  change ((nested_field_type (tarray t n) (ArraySubsc i :: nil))) with t.
  rewrite upd_Znth_same.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  rewrite sublist_upd_Znth_l; try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  rewrite sublist_upd_Znth_r; try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  cancel.
Qed.

Lemma array_with_hole_elim {cs: compspecs} sh: forall t i n (a: reptype t) (al: list (reptype t)) p,
  data_at sh t a (field_address (tarray t n) (ArraySubsc i :: nil) p) *
    array_with_hole sh t i n al p |--
      data_at sh (tarray t n) (upd_Znth i al a) p.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint.
  apply (allp_left _ a).
  auto.
Qed.

End SingletonHole.

Definition splice_into_list {A} (lo hi: Z) (source target : list A) : list A :=
   sublist 0 lo target
   ++ source
   ++ sublist hi (Zlength target) target.

Module SegmentHole.

Definition array_with_hole {cs: compspecs} sh (t: type) lo hi n (al': list (reptype t)) p :=
ALL v: list (reptype t),
 (data_at sh (tarray t (hi - lo)) v (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) -* data_at sh (tarray t n) (splice_into_list lo hi v al') p).

Lemma array_with_hole_intro {cs: compspecs} sh: forall t lo hi n (al: list (reptype t)) p,
  0 <= lo <= hi ->
  hi <= n ->
  data_at sh (tarray t n) al p |--
    data_at sh (tarray t (hi - lo)) (sublist lo hi al) (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) *
      array_with_hole sh t lo hi n al p.
Proof.
  intros.
  unfold data_at at 1, array_with_hole.
  assert (forall n, reptype (tarray t n) = list (reptype t)).
  {
    intros.
    rewrite reptype_eq.
    auto.
  }
  saturate_local.
  assert (Zlength al = n).
  {
    destruct H3 as [? _].
    rewrite Z.max_r in H3 by lia.
    rewrite <- H3.
    reflexivity.
  }
  clear H3.
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 lo hi n); try lia.
      2: change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  autorewrite with sublist.
  change (tarray t (hi - lo)) with (nested_field_array_type (tarray t n) nil lo hi).
  erewrite <- array_at_data_at''' by first [reflexivity | lia].
  cancel.
  apply allp_right; intros v.
  apply -> wand_sepcon_adjoint.

  unfold data_at at 2.
  assert_PROP (Zlength v = hi - lo).
  {
    saturate_local.
    destruct H13.
    clear - H H13.
    apply prop_right.
    rewrite Z.max_r in H13 by lia.
    exact H13.
  }
  erewrite field_at_Tarray.
      2: constructor.
      2: reflexivity.
      2: lia.
      2: apply JMeq_refl.
  erewrite (split3seg_array_at _ _ _ 0 lo hi n); try lia.
      2: unfold splice_into_list; autorewrite with sublist; change (nested_field_type (tarray t n) (ArraySubsc 0 :: nil)) with t; lia.
  erewrite <- array_at_data_at''' by first [reflexivity | lia].
  cancel.
  unfold splice_into_list.
  autorewrite with sublist.
  replace (hi - lo - Zlength v + hi) with hi by lia.
  replace (n - lo - Zlength v + hi) with n by lia.
  cancel.
  autorewrite with sublist.
  cancel.
Qed.

Lemma array_with_hole_elim {cs: compspecs} sh: forall t lo hi n (a: list (reptype t)) (al: list (reptype t)) p,
  data_at sh (tarray t (hi - lo)) a (field_address0 (tarray t n) (ArraySubsc lo :: nil) p) *
    array_with_hole sh t lo hi n al p |--
      data_at sh (tarray t n) (splice_into_list lo hi a al) p.
Proof.
  intros.
  rewrite sepcon_comm.
  apply wand_sepcon_adjoint.
  apply (allp_left _ a).
  auto.
Qed.

End SegmentHole.


Require Import String.
Require Import Coq.ZArith.ZArith.
Require Import coqutil.Z.Lia.
Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import riscv.Utility.Encode.
Require Import riscv.Utility.Utility.
Require Import coqutil.Word.LittleEndian.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Tactics.Tactics.
Require Import riscv.Spec.Primitives.
Require Import riscv.Spec.Machine.
Require riscv.Platform.Memory.
Require Import riscv.Spec.PseudoInstructions.
Require Import riscv.Proofs.EncodeBound.
Require Import riscv.Proofs.DecodeEncode.
Require Import riscv.Platform.Run.
Require Import riscv.Utility.MkMachineWidth.
Require Import riscv.Utility.Monads. Import MonadNotations.
Require Import riscv.Utility.runsToNonDet.
Require Import coqutil.Datatypes.PropSet.
Require Import riscv.Platform.RiscvMachine.
Require Import riscv.Platform.MetricRiscvMachine.
Require Import riscv.Spec.MetricPrimitives.
Require Import compiler.RunInstruction.
Require Import compiler.RiscvEventLoop.
Require Import compiler.ForeverSafe.
Require Import compiler.GoFlatToRiscv.
Require Import coqutil.Tactics.Simp.
Require Import processor.KamiWord.
Require Import processor.KamiRiscvStep.
Require Import processor.KamiRiscv.
Require Import bedrock2.Syntax bedrock2.Semantics.
Require Import compiler.Pipeline.
Require Import compilerExamples.MMIO.
Require Import riscv.Platform.FE310ExtSpec.
Require Import compiler.FlatToRiscvDef.
Require Import coqutil.Tactics.rdelta.
Require Import end2end.KamiRiscvWordProperties.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import compiler.SeparationLogic.
Require Import compiler.ToplevelLoop.
Require Import compiler.CompilerInvariant.
Require Import compiler.ExprImpEventLoopSpec.

Local Open Scope Z_scope.

Require Import Coq.Classes.Morphisms.

#[global] Instance word_riscv_ok: @RiscvWordProperties.word.riscv_ok 32 KamiWord.wordW.
refine (@KamiRiscvWordProperties.kami_word_riscv_ok 5 _ _).
all: cbv; congruence.
Qed.

#[global] Existing Instance SortedListString.map.
#[global] Existing Instance SortedListString.ok.

(* TODO these definitions should be in KamiRiscv.v: *)

Definition get_kamiMemInit{memSizeLg: Z}
  (memInit: Syntax.Vec (Syntax.ConstT (Syntax.Bit MemTypes.BitsPerByte)) (Z.to_nat memSizeLg))
  (n: nat): Byte.byte :=
  byte.of_Z (Kami.Lib.Word.uwordToZ
               (Kami.Semantics.evalConstT (kamiMemInit _ memInit) (Kami.Lib.Word.natToWord _ n))).

Definition kami_mem_contains_bytes(bs: list Coq.Init.Byte.byte){memSizeLg}(from: KamiWord.word 32)
           (mem: Syntax.Vec (Syntax.ConstT (Syntax.Bit MemTypes.BitsPerByte)) (Z.to_nat memSizeLg)): Prop :=
  List.map (get_kamiMemInit mem) (seq 0 (List.length bs)) = bs.

Section Connect.

  Context (instrMemSizeLg memSizeLg stack_size_in_bytes: Z).

  Context {Registers: map.map Register (KamiWord.word 32)}
          {Registers_ok: map.ok Registers}
          {mem: map.map (KamiWord.word 32) byte}
          {mem_ok: map.ok mem}.

  Let instrMemSizeBytes: Z := 2 ^ (2 + instrMemSizeLg).

  Definition ml: MemoryLayout (width := 32) := {|
    code_start := word.of_Z 0;
    code_pastend := word.of_Z instrMemSizeBytes;
    heap_start := word.of_Z instrMemSizeBytes;
    heap_pastend := word.of_Z (2 ^ memSizeLg - stack_size_in_bytes);
    stack_start := word.of_Z (2 ^ memSizeLg - stack_size_in_bytes);
    stack_pastend := word.of_Z (2 ^ memSizeLg);
  |}.

  Context (memInit: Syntax.Vec (Syntax.ConstT (Syntax.Bit MemTypes.BitsPerByte))
                               (Z.to_nat memSizeLg)).

  Hypotheses (instrMemSizeLg_bounds: 3 <= instrMemSizeLg <= 30)
             (Hkmem: 2 + instrMemSizeLg < memSizeLg <= 16).

  Lemma memSizeLg_width_trivial: memSizeLg <= 32. Proof. blia. Qed.

  Definition p4mm: Kami.Syntax.Modules :=
    KamiRiscv.p4mm instrMemSizeLg memSizeLg (proj1 instrMemSizeLg_bounds)
                   (proj2 instrMemSizeLg_bounds)
                   memInit.

  Add Ring wring : (word.ring_theory (word := Consistency.word))
      (preprocess [autorewrite with rew_word_morphism],
       morphism (word.ring_morph (word := Consistency.word)),
       constants [word_cst]).

  Goal True.
  epose (_ : PrimitivesParams (FreeMonad.free MetricMinimalMMIO.action MetricMinimalMMIO.result)
                              MetricRiscvMachine).
  Abort.

  Existing Instance MetricMinimalMMIO.MetricMinimalMMIOSatisfiesPrimitives.

  Definition states_related :=
    states_related instrMemSizeLg memSizeLg (proj1 instrMemSizeLg_bounds) (proj2 instrMemSizeLg_bounds).

  Lemma split_ll_trace: forall {t2' t1' t},
      traces_related t (t2' ++ t1') ->
      exists t1 t2, t = t2 ++ t1 /\ traces_related t1 t1' /\ traces_related t2 t2'.
  Proof.
    induction t2'; intros.
    - exists t, nil. simpl in *. repeat constructor. assumption.
    - simpl in H. simp. specialize IHt2' with (1 := H4).
      destruct IHt2' as (t1 & t2 & E & R1 & R2). subst.
      exists t1. exists (e :: t2). simpl. repeat constructor; assumption.
  Qed.

  Lemma states_related_to_traces_related: forall m m' t,
      states_related (m, t) m' -> traces_related t m'.(getLog).
  Proof. intros. inversion H. simpl. assumption. Qed.

  (* for debugging f_equal *)
  Lemma cong_app: forall {A B: Type} (f f': A -> B) (a a': A),
      f = f' ->
      a = a' ->
      f a = f' a'.
  Proof. intros. congruence. Qed.

  Context (spec: ProgramSpec)
          (funimplsList: list (string * (list string * list string * cmd))).

  Hypothesis heap_start_agree: spec.(datamem_start) = ml.(heap_start).
  Hypothesis heap_pastend_agree: spec.(datamem_pastend) = ml.(heap_pastend).
  Hypothesis stack_size_div: stack_size_in_bytes mod bytes_per_word = 0.
  Hypothesis stack_size_bounds: 0 <= stack_size_in_bytes <= 2 ^ memSizeLg - instrMemSizeBytes.

  Lemma mlOk: MemoryLayoutOk ml.
  Proof.
    constructor;
      unfold ml, code_start, code_pastend, heap_start, heap_pastend, stack_start, stack_pastend.
    - reflexivity.
    - rewrite word.unsigned_of_Z.
      unfold word.wrap.
      etransitivity.
      1: exact (ToplevelLoop.mod_2width_mod_bytes_per_word (2 ^ memSizeLg - stack_size_in_bytes)).
      change bytes_per_word with 4.
      apply mod4_0.mod4_0_sub.
      + replace memSizeLg with (memSizeLg - 2 + 2) by blia.
        rewrite Z.pow_add_r by blia.
        apply mod4_0.mod4_mul4_r.
      + exact stack_size_div.
    - rewrite word.unsigned_of_Z.
      unfold word.wrap.
      etransitivity.
      1: exact (ToplevelLoop.mod_2width_mod_bytes_per_word (2 ^ memSizeLg)).
      replace memSizeLg with (memSizeLg - 2 + 2) by blia.
      rewrite Z.pow_add_r by blia.
      apply mod4_0.mod4_mul4_r.
    - rewrite word.unsigned_of_Z. change (word.wrap 0) with 0.
      eapply proj1. eapply word.unsigned_range.
    - reflexivity.
    - rewrite ?word.unsigned_of_Z. unfold word.wrap.
      pose proof (Z.pow_nonneg 2 (2 + instrMemSizeLg)).
      change width with 32 in *.
      assert (2 ^ memSizeLg < 2 ^ 32). {
        apply Z.pow_lt_mono_r; blia.
      }
      rewrite ?Z.mod_small; try split; try apply Z.pow_nonneg; try blia.
    - reflexivity.
    - rewrite ?word.unsigned_of_Z. unfold word.wrap.
      pose proof (Z.pow_nonneg 2 (2 + instrMemSizeLg)).
      change width with 32 in *.
      assert (2 ^ memSizeLg < 2 ^ 32). {
        apply Z.pow_lt_mono_r; blia.
      }
      rewrite ?Z.mod_small; try split; try apply Z.pow_nonneg; try blia.
  Qed.

  Hypothesis funimplsList_NoDup: NoDup (List.map fst funimplsList).

  (* goodTrace in terms of "exchange format" (list Event).
     Only holds at the beginning/end of each loop iteration,
     will be transformed into "exists suffix, ..." form later *)
  Definition goodTraceE(t: list Event): Prop :=
    exists bedrockTrace, traces_related t bedrockTrace /\ spec.(goodTrace) bedrockTrace.

  Definition bedrock2Inv := (fun t m l => forall mc, hl_inv spec t m l mc).

  Let funspecs := WeakestPrecondition.call funimplsList.

  Hypothesis goodTrace_implies_related_to_Events: forall (t: list LogItem),
      spec.(goodTrace) t -> exists t': list Event, traces_related t' t.

  Definition riscvMemInit_all_values: list byte :=
    List.map (get_kamiMemInit memInit) (seq 0 (Z.to_nat (2 ^ memSizeLg))).

  Definition riscvMemInit_values(from len: nat): list byte :=
    List.firstn len (List.skipn from riscvMemInit_all_values).

  Lemma riscvMemInit_to_seplog_aux: forall len from,
      Z.of_nat from + Z.of_nat len <= 2 ^ memSizeLg ->
      LowerPipeline.ptsto_bytes
        (word.of_Z (width := width) (Z.of_nat from))
        (map (get_kamiMemInit memInit) (seq from len))
        (map.of_list (map
          (fun i => (word.of_Z (BinIntDef.Z.of_nat i),
                     byte.of_Z (Word.uwordToZ (Semantics.evalConstT (kamiMemInit memSizeLg memInit)
                         (Word.natToWord (BinIntDef.Z.to_nat memSizeLg) i)))))
          (seq from len))).
  Proof.
    induction len; intros.
    - cbv. auto.
    - unfold LowerPipeline.ptsto_bytes, riscvMemInit_values in *.
      cbn [seq map array map.of_list].
      match goal with
      | |- context [map.put ?m ?k ?v] => pose proof map.put_putmany_commute k v m map.empty as P
      end.
      rewrite map.putmany_empty_r in P.
      rewrite P. clear P.
      eapply sep_comm.
      unfold sep.
      do 2 eexists.
      ssplit; cycle 1.
      + specialize (IHlen (S from)).
        replace (Z.of_nat (S from)) with (Z.of_nat from + 1) in IHlen by blia.
        rewrite word.ring_morph_add in IHlen.
        apply IHlen. blia.
      + unfold ptsto. reflexivity.
      + unfold map.split, map.disjoint. split; [reflexivity|].
        intros.
        rewrite map.get_put_dec in H1.
        destruct_one_match_hyp. 2: {
          rewrite map.get_empty in H1. discriminate.
        }
        subst.
        rewrite get_of_list_not_In in H0.
        * discriminate.
        * simpl. apply Word.weq.
        * exact mem_ok.
        * intro C.
          rewrite map_map in C.
          unfold fst in C.
          apply in_map_iff in C.
          destruct C as [ from' [E C] ].
          apply (f_equal word.unsigned) in E.
          do 2 rewrite word.unsigned_of_Z in E.
          unfold word.wrap in E.
          change width with 32 in *.
          rewrite (Z.mod_small (Z.of_nat from)) in E. 2: {
            split; [blia|].
            eapply Z.le_lt_trans with (m := 2 ^ memSizeLg). 1: blia.
            eapply Z.pow_lt_mono_r; blia.
          }
          apply in_seq in C.
          rewrite (Z.mod_small (Z.of_nat from')) in E. 2: {
            split; [blia|].
            eapply Z.le_lt_trans with (m := 2 ^ memSizeLg). 1: blia.
            eapply Z.pow_lt_mono_r; blia.
          }
          blia.
  Qed.

  Lemma riscvMemInit_to_seplog:
    (LowerPipeline.ptsto_bytes (word.of_Z 0) riscvMemInit_all_values)
    (riscvMemInit memSizeLg memInit).
  Proof.
    intros.
    unfold riscvMemInit_all_values, riscvMemInit.
    pose proof (riscvMemInit_to_seplog_aux (Z.to_nat (2 ^ memSizeLg)) 0) as P.
    change (Z.of_nat 0) with 0 in *.
    (* TODO could adapt riscvMemInit definition to make this not needed *)
    replace (2 ^ BinIntDef.Z.to_nat memSizeLg)%nat with (Z.to_nat (2 ^ memSizeLg)).
    1: eapply P.
    - rewrite Z2Nat.id. 1: blia.
      apply Z.pow_nonneg. blia.
    - rewrite N_Z_nat_conversions.Z2Nat.inj_pow; try blia. reflexivity.
  Qed.

  (* end to end, but still generic over the program *)
  Lemma end2end:
    (* Assumptions on the program logic level: *)
    forall init_code loop_body,
    map.get (map.of_list funimplsList) "init"%string = Some ([], [], init_code) ->
    (forall m, LowerPipeline.mem_available ml.(heap_start) ml.(heap_pastend) m ->
               WeakestPrecondition.cmd funspecs init_code [] m map.empty bedrock2Inv) ->
    map.get (map.of_list funimplsList) "loop"%string = Some ([], [], loop_body) ->
    (forall t m l, bedrock2Inv t m l ->
                   WeakestPrecondition.cmd funspecs loop_body t m l bedrock2Inv) ->
    (* Assumptions on the compiler level: *)
    forall (instrs: list Instruction) positions (required_stack_space: Z),
    compile_prog compile_ext_call ml (map.of_list funimplsList) = Success (instrs, positions, required_stack_space) ->
    required_stack_space <= word.unsigned (word.sub (stack_pastend ml) (stack_start ml)) / bytes_per_word ->
    word.unsigned (code_start ml) + Z.of_nat (Datatypes.length (instrencode instrs)) <=
      word.unsigned (code_pastend ml) ->
    Forall (fun i : Instruction => verify i iset) instrs ->
    ExprImp.valid_funs (map.of_list funimplsList) ->
    (* Assumptions on the Kami level: *)
    kami_mem_contains_bytes (instrencode instrs) ml.(code_start) memInit ->
    forall (t: Kami.Semantics.LabelSeqT) (mFinal: KamiImplMachine),
      (* IF the 4-stage pipelined processor steps to some final state mFinal, producing trace t,*)
      Kami.Semantics.Behavior p4mm mFinal t ->
      (* THEN the trace produced by the kami implementation can be mapped to an MMIO trace
         (this guarantees that the only external behavior of the kami implementation is MMIO)
         and moreover, this MMIO trace satisfies "not yet bad", as in, there exists at
         least one way to complete it to a good trace *)
      exists (t': list Event), KamiLabelSeqR t t' /\
                               exists (suffix: list Event), goodTraceE (suffix ++ t').
  Proof.
    intros *. intros GetInit Establish GetLoop Preserve. intros *. intros C RS L F V M. intros *. intros B.

    set (traceProp := fun (t: list Event) =>
                        exists (suffix: list Event), goodTraceE (suffix ++ t)).
    change (exists t' : list Event,
               KamiLabelSeqR t t' /\ traceProp t').

    (* stack of proofs, bottom-up: *)

    (* 1) Kami pipelined processor to riscv-coq *)
    pose proof @riscv_to_kamiImplProcessor as P1.
    specialize_first P1 traceProp.
    specialize_first P1 (ll_inv compile_ext_call ml spec).
    specialize_first P1 B.
    specialize_first P1 (proj1 Hkmem).
    specialize_first P1 memSizeLg_width_trivial.
    specialize_first P1 (proj2 Hkmem).
    (* destruct spec. TODO why "Error: sat is already used." ?? *)

    (* 2) riscv-coq to bedrock2 semantics *)
    pose proof compiler_invariant_proofs compile_ext_call compile_ext_call_correct as P2.
    specialize_first P2 spec.
    specialize_first P2 ml.
    specialize_first P2 mlOk.
    destruct P2 as [ P2establish [P2preserve P2use] ]. {
      intros. reflexivity.
    }
    eapply P1; clear P1.
    - assumption.
    - assumption.
    - (* establish *)
      intros.
      eapply P2establish.
      unfold initial_conditions.
      exists (map.of_list funimplsList), instrs, positions, required_stack_space.
      destr_RiscvMachine m0RV.
      subst.
      ssplit.
      + (* 3) bedrock2 semantics to bedrock2 program logic *)
        econstructor.
        * exact V.
        * exact GetInit.
        * intros.
          eapply ExprImp.weaken_exec.
          -- match goal with
             | H: LowerPipeline.mem_available ?from ?to _ |- _ =>
               rewrite heap_start_agree in H;
               rewrite heap_pastend_agree in H
             end.
             refine (WeakestPreconditionProperties.sound_cmd _ _ _ _ _ _ _ _ _); eauto.
          -- simpl. clear. intros. unfold bedrock2Inv in *. eauto.
        * exact GetLoop.
        * intros. unfold bedrock2Inv in *.
          eapply ExprImp.weaken_exec.
          -- refine (WeakestPreconditionProperties.sound_cmd _ _ _ _ _ _ _ _ _); eauto.
          -- simpl. clear. intros. eauto.
      + assumption.
      + assumption.
      + assumption.
      + assumption.
      + assumption.
      + assumption.
      + pose proof word.eqb_spec.
        cbv [imem LowerPipeline.mem_available].
        unfold code_start, code_pastend, heap_start, heap_pastend, stack_start, stack_pastend, ml in *.
        assert (Bounds_instrs: 0 <= Z.of_nat (Datatypes.length (instrencode instrs))) by blia.
        assert (Bounds_unused_imem: Z.of_nat (Datatypes.length (instrencode instrs)) <= instrMemSizeBytes). {
          move L at bottom.
          rewrite ?word.unsigned_of_Z in L.
          change (word.wrap 0) with 0 in L.
          unfold word.wrap in L.
          rewrite (Z.mod_small instrMemSizeBytes) in L. 1: blia.
          split.
          - apply Z.pow_nonneg. blia.
          - change width with 32. apply Z.pow_lt_mono_r; blia.
        }
        assert (Bounds_heap: instrMemSizeBytes <= 2 ^ memSizeLg - stack_size_in_bytes) by blia.
        assert (Bounds_stack: 2 ^ memSizeLg - stack_size_in_bytes <= 2 ^ memSizeLg) by blia.
        assert (Bounds_unmapped: 2 ^ memSizeLg < 2 ^ width). {
          change width with 32.
          apply Z.pow_lt_mono_r; try blia.
        }
        assert (Datatypes.length riscvMemInit_all_values = Z.to_nat (2 ^ memSizeLg)). {
          unfold riscvMemInit_all_values.
          rewrite map_length. rewrite seq_length.
          blia.
        }
        clear P2establish P2preserve P2use.
        eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_ex1_r, ?sep_ex1_l; reflexivity. }
        eexists ?[stack].
         eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_ex1_r, ?sep_ex1_l; reflexivity. }
        eexists ?[heap].
        eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_ex1_r, ?sep_ex1_l; reflexivity. }
        eexists ?[unused_imem].
        eapply Proper_iff1_iff1; [|reflexivity..|].
        { progress repeat rewrite ?sep_emp_2, ?sep_emp_l, ?sep_emp_r; reflexivity. }
        eapply sep_emp_l; split.
        2: eapply sep_assoc; eapply sep_emp_l; split.
        3: eapply Proper_iff1_iff1; [|reflexivity..|].
        3: { progress repeat rewrite ?sep_assoc, ?sep_emp_2, ?sep_emp_l, ?sep_emp_r; reflexivity. }
        3: eapply sep_emp_l; split.

        all : cycle 3.
        Unshelve. {
          pose proof riscvMemInit_to_seplog as P.
          unfold LowerPipeline.ptsto_bytes in *.
          remember riscvMemInit_all_values as l. symmetry in Heql. pose proof Heql as E.
          (* 1) chop off instructions *)
          rewrite <- (firstn_skipn (Datatypes.length (instrencode instrs)) l) in E. subst l.
          match type of E with
          | _ = _ ++ ?L => remember L as l
          end.
          (* 2) chop off unused instruction memory *)
          rewrite <- (firstn_skipn (Z.to_nat instrMemSizeBytes - Datatypes.length (instrencode instrs))
                                   l) in E. subst l.
          rewrite List.app_assoc in E.
          match type of E with
          | _ = _ ++ ?L => remember L as l
          end.
          (* 3 chop off heap *)
          rewrite <- (firstn_skipn (Z.to_nat (2 ^ memSizeLg - instrMemSizeBytes - stack_size_in_bytes))
                                   l) in E. subst l.
          rewrite List.app_assoc in E.
          rewrite E in P; clear E.
          use_sep_assumption.
          wseplog_pre.
          simpl_addrs.
          unfold code_start, code_pastend, heap_start, heap_pastend, stack_start, stack_pastend, ml.
          replace (firstn (Datatypes.length (instrencode instrs)) riscvMemInit_all_values)
            with (instrencode instrs). 2: {
            unfold riscvMemInit_all_values.
            rewrite List.firstn_map.
            rewrite List.firstn_seq.
            rewrite Nat.min_l by blia.
            symmetry.
            exact M.
          }
          cancel.
          cancel_seps_at_indices 0%nat 0%nat. {
            f_equal.
            ring.
          }
          cancel_seps_at_indices 0%nat 0%nat. {
            f_equal.
            rewrite firstn_length.
            rewrite skipn_length.
            let word_ok := constr:(_ : word.ok _) in simpl_word_exprs word_ok.
            f_equal.
            blia.
          }
          cancel_seps_at_indices 0%nat 0%nat. {
            f_equal.
            rewrite ?firstn_length.
            rewrite ?skipn_length.
            let word_ok := constr:(_ : word.ok _) in simpl_word_exprs word_ok.
            f_equal.
            blia.
          }
          cbn [seps]. reflexivity.
        }
        all: repeat rewrite ?word.unsigned_sub, ?word.unsigned_add,
                            ?firstn_length, ?skipn_length, ?word.unsigned_of_Z;
             unfold word.wrap;
             change width with 32 in *.
        all: try (
          Z.div_mod_to_equations;
          (* COQBUG (performance) https://github.com/coq/coq/issues/10743#issuecomment-530673037
             cond_hyp_factor: *)
          repeat match goal with
                 | H : ?x -> _, H' : ?x -> _ |- _  =>
                   pose proof (fun u : x => conj (H u) (H' u)); clear H H'
                 end;
          blia).
      + change (word.unsigned (code_start ml)) with 0.
        assert (Hend: code_pastend ml = word.of_Z instrMemSizeBytes) by reflexivity.
        setoid_rewrite Hend.
        rewrite word.unsigned_of_Z.
        cbv [word.wrap].
        rewrite Z.mod_small. 2: {
          split.
          - apply Z.pow_nonneg; blia.
          - apply Z.pow_lt_mono_r; blia.
        }
        assumption.
      + reflexivity.
      + reflexivity.
      + unfold regs_initialized.regs_initialized. intros.
        match goal with
        | |- exists _, ?x = Some _ => destr x; [eauto|exfalso]
        end.
        match goal with
        | H: forall _, _ -> _ <> None |- _ => eapply H; eauto
        end.
      + reflexivity.
      + simpl. split.
        * apply @riscv_init_memory_undef_on_MMIO with (instrMemSizeLg:= instrMemSizeLg).
          { apply instrMemSizeLg_bounds. }
          { apply Hkmem. }
          { cbv [KamiProc.width]; blia. }
          { apply Hkmem. }
          { assumption. }
        * assumption.
    - (* preserve *)
      intros.
      refine (P2preserve _ _). assumption.
    - (* use *)
      intros *. intro Inv.
      subst traceProp. simpl.
      specialize_first P2use Inv.
      destruct P2use as [suff Good].
      unfold goodTraceE.
      pose proof (goodTrace_implies_related_to_Events _ Good) as G.
      destruct G as [t' R].
      pose proof (split_ll_trace R). simp.
      eauto 10.
  Qed.

End Connect.


Require Import Verdi.GhostSimulations.

Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.NoAppendEntriesToSelfInterface.
Require Import VerdiRaft.OneLeaderLogPerTermInterface.
Require Import VerdiRaft.AppendEntriesRequestsCameFromLeadersInterface.
Require Import VerdiRaft.LeadersHaveLeaderLogsInterface.

Require Import VerdiRaft.NoAppendEntriesToLeaderInterface.

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

  Context {rri : raft_refinement_interface}.
  Context {naetsi : no_append_entries_to_self_interface}.
  Context {ollpti : one_leaderLog_per_term_interface}.
  Context {aercfli : append_entries_came_from_leaders_interface}.
  Context {lhlli : leaders_have_leaderLogs_interface}.

  Definition no_append_entries_to_leader' (net : network) : Prop :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      type (snd (nwState net (pDst p))) = Leader ->
      currentTerm (snd (nwState net (pDst p))) = t ->
      False.

  Definition no_append_entries_to_self' (net : network) : Prop :=
    forall p t n pli plt es ci,
      In p (nwPackets net) ->
      pBody p = AppendEntries t n pli plt es ci ->
      pDst p = pSrc p ->
      False.

  Theorem lift_no_append_entries_to_self :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_append_entries_to_self (deghost net).
  Proof using naetsi rri.
    intros.
    eapply lift_prop; eauto using no_append_entries_to_self_invariant.
  Qed.

  Lemma ghost_packet :
    forall (net : network (params := raft_refined_multi_params)) p,
      In p (nwPackets net) ->
      In (deghost_packet p) (nwPackets (deghost net)).
  Proof using.
    unfold deghost.
    simpl. intuition.
    apply in_map_iff.
    eexists; eauto.
  Qed.

  Theorem no_append_entries_to_self'_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_append_entries_to_self' net.
  Proof using naetsi rri.
    unfold no_append_entries_to_self'. intros.
    find_apply_lem_hyp ghost_packet.
    find_eapply_lem_hyp lift_no_append_entries_to_self; auto.
    simpl in *. eauto.
  Qed.

  Lemma no_append_entries_to_leader_invariant' :
    forall net,
      refined_raft_intermediate_reachable net ->
      no_append_entries_to_leader' net.
  Proof using lhlli aercfli ollpti naetsi rri.
    unfold no_append_entries_to_leader'. intros. subst.
    find_copy_eapply_lem_hyp no_append_entries_to_self'_invariant; eauto.
    find_false.
    find_eapply_lem_hyp leaders_have_leaderLogs_invariant; eauto.
    break_exists.
    find_eapply_lem_hyp append_entries_came_from_leaders_invariant; eauto.
    break_exists.
    eapply one_leaderLog_per_term_host_invariant; eauto.
  Qed.

  Lemma deghost_packet_exists :
    forall net p,
      In p (nwPackets (deghost net)) ->
      exists (q : packet (params := raft_refined_multi_params (raft_params := raft_params))),
        In q (nwPackets net) /\ p = deghost_packet q.
  Proof using.
    unfold deghost.
    simpl.
    intros.
    do_in_map.
    eauto.
  Qed.

  Instance noaetli : no_append_entries_to_leader_interface.
  split. intros.
  apply lower_prop; auto.
  intros.
  find_apply_lem_hyp no_append_entries_to_leader_invariant'.
  unfold no_append_entries_to_leader', no_append_entries_to_leader in *.
  intros.
  find_apply_lem_hyp deghost_packet_exists. break_exists. intuition. subst.
  simpl in *. repeat break_match; simpl in *. subst.
  match goal with
    | H : nwState ?h = (?gd, ?d) |- _ =>
      replace gd with (fst (nwState h)) in * by (rewrite H; reflexivity);
        replace d with (snd (nwState h)) in * by (rewrite H; reflexivity);
        clear H
  end. eauto.
  Qed.
End NoAppendEntriesToLeader.


From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution.Test Require Import QCTest.
From ConCert.Examples.BAT Require Import BATCommon.
From ConCert.Examples.BAT Require Import BATPrinters.
From ConCert.Examples.EIP20 Require Import EIP20TokenGens.
From Coq Require Import List.
From Coq Require Import ZArith.
Import ListNotations.
Import MonadNotation.

Module Type BATGensInfo.
  Parameter trace_length : nat.
  Parameter gAccount : G Address.
  Parameter contract_addr : Address.
  Parameter accounts : list Address.
  Parameter accounts_total_balance : Z.
  Parameter bat_addr : Address.
  Parameter fund_addr : Address.
  Parameter bat_addr_refundable : bool.
  Parameter bat_addr_fundable : bool.
  Parameter eip20_transactions_before_finalized : bool.
End BATGensInfo.

Module BATGens (Info : BATGensInfo).
  Import Info.
  Arguments SerializedValue : clear implicits.
  Arguments deserialize : clear implicits.
  Arguments serialize : clear implicits.

  Definition account_balance (env : Environment) (addr : Address) : Amount :=
    (env_account_balances env) addr.

  Definition get_refundable_accounts state : list (G (option Address)) :=
    let balances_list := FMap.elements (balances state) in
    let filtered_balances := filter (fun x => (bat_addr_refundable || (address_neqb bat_addr (fst x))) && (0 <? (snd x))%N) balances_list in
      map returnGen (map Some (map fst filtered_balances)).

  Definition get_fundable_accounts env : G (option Address) :=
    let freq_accounts := map (fun addr => (if bat_addr_fundable || (address_neqb addr bat_addr) then Z.to_nat (account_balance env addr) else 0, returnGenSome addr)) accounts in
      freq_ (returnGen None) freq_accounts.

  Definition gFund_amount env state addr : G Z :=
    (choose (1, Z.min (account_balance env addr) (Z.of_N ((state.(tokenCreationCap) - (total_supply state)) / state.(tokenExchangeRate)))))%Z.

  Definition gCreateTokens (env : Environment) (state : BATCommon.State) : GOpt (Address * Amount * Msg) :=
    let current_slot := S (current_slot (env_chain env)) in
    if (state.(isFinalized)
            || (Nat.ltb current_slot state.(fundingStart))
            || (Nat.ltb state.(fundingEnd) current_slot) (* Funding can only happen in funding period *)
            || (N.ltb (state.(tokenCreationCap) - (total_supply state)) state.(tokenExchangeRate))) (* No funding if cap was hit or if we are too close to it *)
    then
      returnGen None
    else
      from_addr <- get_fundable_accounts env ;;
      value <- bindGen (gFund_amount env state from_addr) returnGenSome ;;
      returnGenSome (from_addr, value, create_tokens).

  Definition gCreateTokensInvalid (env : Environment) (state : BATCommon.State) : GOpt (Address * Amount * Msg) :=
    from_addr <- get_fundable_accounts env ;;
    value <- bindGen (choose (1, account_balance env from_addr)%Z) returnGenSome ;;
    returnGenSome (from_addr, value, create_tokens).

  Definition gRefund (env : Environment) (state : BATCommon.State) : GOpt (Address * Msg) :=
    let current_slot := S (current_slot (env_chain env)) in
    let accounts := get_refundable_accounts state in
    if ((state.(isFinalized)
            || (Nat.leb current_slot state.(fundingEnd))
            || (state.(tokenCreationMin) <=? (total_supply state))%N))
    then
      returnGen None
    else
      from_addr <- oneOf_ (returnGen None) accounts ;;
      returnGenSome (from_addr, refund).

  Definition gRefundInvalid (env : Environment) (state : BATCommon.State) : G (Address * Msg) :=
    from_addr <- gAccount ;;
    returnGen (from_addr, refund).

  Definition gFinalize (env : Environment) (state : BATCommon.State) : GOpt (Address * Msg) :=
    let current_slot := S (current_slot (env_chain env)) in
    if (state.(isFinalized)
          || ((total_supply state) <? state.(tokenCreationMin))%N
          || ((Nat.leb current_slot state.(fundingEnd)) && negb ((total_supply state) =? state.(tokenCreationCap))%N))
    then
      returnGen None
    else
      returnGenSome (fund_addr, finalize).

  Definition gFinalizeInvalid (env : Environment) (state : BATCommon.State) : G (Address * Msg) :=
    from_addr <- gAccount ;;
    returnGen (from_addr, finalize).

  Module EIP20 := EIP20Gens Info.

  Definition gTransfer (env : Environment) (state : BATCommon.State) : GOpt (Address * Msg) :=
    if eip20_transactions_before_finalized || state.(isFinalized)
    then
      '(caller, msg) <- EIP20.gTransfer env (token_state state) ;;
      returnGenSome (caller, tokenMsg msg)
    else
      returnGen None.

  Definition gApprove (state : BATCommon.State) : GOpt (Address * Msg) :=
    if eip20_transactions_before_finalized || state.(isFinalized)
    then
      bindGenOpt (EIP20.gApprove (token_state state))
          (fun '(caller, msg) => returnGenSome (caller, tokenMsg msg))
    else
      returnGen None.

  Definition gTransfer_from (state : BATCommon.State) : GOpt (Address * Msg) :=
    if eip20_transactions_before_finalized || state.(isFinalized)
    then
      bindGenOpt (EIP20.gTransfer_from (token_state state))
          (fun '(caller, msg) => returnGenSome (caller, tokenMsg msg))
    else
      returnGen None.

  (* BAT valid call generator.
    Generator that will always return BAToken contract calls that are valid on their own,
    i.e. guaranteed to be valid if it is the first action executed in the block.
  *)
  Definition gBATActionValid (env : Environment) : GOpt Action :=
    let call contract_addr caller_addr value msg :=
      returnGenSome (build_call caller_addr contract_addr value msg) in
    state <- returnGen (get_contract_state BATCommon.State env contract_addr) ;;
    backtrack [
      (* transfer *)
      (1, bindGenOpt (gTransfer env state)
          (fun '(caller, msg) =>
            call contract_addr caller (0%Z) msg
          )
      );
      (* transfer_from *)
      (2, bindGenOpt (gTransfer_from state)
          (fun '(caller, msg) =>
            call contract_addr caller (0%Z) msg
          )
      );
      (* approve *)
      (1, bindGenOpt (gApprove state)
          (fun '(caller, msg) =>
            call contract_addr caller (0%Z) msg
          )
      );
      (* create_tokens *)
      (5, bindGenOpt (gCreateTokens env state)
          (fun '(caller, value, msg) =>
            call contract_addr caller value msg
          )
      );
      (* refund *)
      (10, bindGenOpt (gRefund env state)
          (fun '(caller, msg) =>
            call contract_addr caller (0%Z) msg
          )
      );
      (* finalize *)
      (10, bindGenOpt (gFinalize env state)
          (fun '(caller, msg) =>
            call contract_addr caller (0%Z) msg
          )
      )
    ].

  (* BAT invalid call generator.
    Generator likely to generate invalid BAToken contract calls.
    It treats the BAToken code mostly as blackbox and only know the expected types of input
      but does not make any assumptions/checks on which values will result in valid or invalid calls
  *)
  Definition gBATActionInvalid (env : Environment) : GOpt Action :=
    let call contract_addr caller_addr value msg :=
      returnGenSome (build_call caller_addr contract_addr value msg) in
    state <- returnGen (get_contract_state BATCommon.State env contract_addr) ;;
    backtrack [
      (* transfer *)
      (1, '(caller, msg) <- EIP20.gTransfer env (token_state state) ;;
          call contract_addr caller (0%Z) (tokenMsg msg)
      ) ;
      (* transfer_from *)
      (2, bindGenOpt (EIP20.gTransfer_from (token_state state))
          (fun '(caller, msg) =>
            call contract_addr caller (0%Z) (tokenMsg msg)
          )
      );
      (* approve *)
      (1, bindGenOpt (EIP20.gApprove (token_state state))
          (fun '(caller, msg) =>
            call contract_addr caller (0%Z) (tokenMsg msg)
          )
      );
      (* create_tokens *)
      (5, bindGenOpt (gCreateTokensInvalid env state)
          (fun '(caller, value, msg) =>
            call contract_addr caller value msg
          )
      );
      (* refund *)
      (1, '(caller, msg) <- gRefundInvalid env state ;;
          call contract_addr caller (0%Z) msg
      );
      (* finalize *)
      (1, '(caller, msg) <- gFinalizeInvalid env state ;;
          call contract_addr caller (0%Z) msg
      )
    ].

  (* BAT call generator
    Has a 7% chance to attempt to generate an invalid contract call
      More specifically it has:
      - 0.5% chance of generating a valid call and then replacing the amount of money sent with that call.
        For BAT contract this is likely to result in an invalid call as most contract calls on BAToken are
        not allowed to include money in them.
      - 6.5% chance of using the invalid action generator. This generator is likely to generate an invalid call
        since it treats the contract as a black box and thus does not check any of the expected requirements for
        a contract call to be valid.
      The remaining 90% of the time it will generate a call that is guaranteed to be valid (only guaranteed to
      be valid on its own, since the generator cannot know what other calls may be included in the same block and
      which order they will be executed in)
  *)
  Definition gBATAction (env : Environment) : GOpt Action :=
    state <- returnGen (get_contract_state BATCommon.State env contract_addr) ;;
    freq [
      (5, bindGenOpt (gBATActionValid env)
          (fun '(action) =>
            match action.(act_body) with
            | act_transfer _ _ => returnGen None
            | act_deploy _ _ _ => returnGen None
            | act_call to _ msg =>
              amount <- choose (0, account_balance env action.(act_from))%Z ;;
              returnGenSome (build_call action.(act_from) to amount msg)
            end
          ));
      (65, gBATActionInvalid env);
      (930, gBATActionValid env)
    ].

  Definition gBATSetup : G Setup :=
    fundingStart <- choose (0, (trace_length - 1)) ;;
    fundingEnd <- choose (0, (trace_length - 1)) ;;
    exchangeRate <- choose (0, Z.to_N accounts_total_balance)%N ;;
    initSupply <- choose (0, Z.to_N accounts_total_balance)%N ;;
    tokenMin <- choose (0, Z.to_N accounts_total_balance)%N ;;
    tokenCap <- choose (0, Z.to_N accounts_total_balance)%N ;;
    returnGen (BATCommon.build_setup initSupply
                              fund_addr
                              bat_addr
                              fundingStart
                              fundingEnd
                              exchangeRate
                              tokenCap
                              tokenMin).

End BATGens.