(* Inspired by:
   Subjective Auxiliary State for Coarse-Grained Concurrency, Ley-Wild and Nanevski, POPL 2013. *)

Require Import VST.progs.conclib.
Require Import VST.progs.ghosts.
Require Import VST.progs.incrN.

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

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_spec _).
Definition spawn_spec := DECLARE _spawn spawn_spec.
Definition freelock2_spec := DECLARE _freelock2 (freelock2_spec _).
Definition release2_spec := DECLARE _release2 release2_spec.

Instance sum_ghost : Ghost :=
  { G := nat; valid g := True; Join_G a b c := c = (a + b)%nat }.
Proof.
  - exists (fun _ => O).
    + intros.
      hnf.
      auto.
    + auto.
  - constructor.
    + intros; hnf in *.
      subst; auto.
    + intros; hnf in *.
      exists (b + c)%nat; split; hnf; omega.
    + intros; hnf in *.
      omega.
    + intros; hnf in *.
      omega.
  - auto.
Defined.

Instance ctr_ghost : Ghost := ref_PCM sum_ghost.

Definition ghost_ref g n := ghost_reference(P := sum_ghost) g n.
Definition ghost_part g sh n := ghost_part(P := sum_ghost) g sh n.
Definition ghost_both g sh n1 n2 := ghost_part_ref(P := sum_ghost) g sh n1 n2.

Definition cptr_lock_inv g ctr :=
  EX z : nat, data_at Ews tuint (Vint (Int.repr (Z.of_nat z))) ctr * ghost_ref g z.

Definition init_ctr_spec :=
 DECLARE _init_ctr
  WITH gv: globals
  PRE [ ]
         PROP  ()
         LOCAL (gvars gv)
         SEP   (data_at_ Ews tuint (gv _ctr); data_at_ Ews tlock (gv _ctr_lock))
  POST [ tvoid ]
    EX g : gname,
         PROP ()
         LOCAL ()
         SEP (lock_inv Ews (gv _ctr_lock) (cptr_lock_inv g (gv _ctr));
              ghost_part g Tsh O).

Definition dest_ctr_spec :=
 DECLARE _dest_ctr
  WITH g : gname, v : nat, gv: globals
  PRE [ ]
         PROP  ()
         LOCAL (gvars gv)
         SEP   (lock_inv Ews (gv _ctr_lock) (cptr_lock_inv g (gv _ctr));
                ghost_part g Tsh v)
  POST [ tvoid ]
         PROP ()
         LOCAL ()
         SEP (data_at Ews tuint (vint (Z.of_nat v)) (gv _ctr);
              data_at_ Ews tlock (gv _ctr_lock)).

Definition incr_spec :=
 DECLARE _incr
  WITH sh : share, gsh : share, g : gname, n : nat, gv: globals
  PRE [ ]
         PROP  (readable_share sh; gsh <> Share.bot)
         LOCAL (gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g (gv _ctr)); ghost_part g gsh n)
  POST [ tvoid ]
         PROP ()
         LOCAL ()
         SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g (gv _ctr)); ghost_part g gsh (S n)).

Definition thread_lock_R sh gsh g ctr lockc :=
  lock_inv sh lockc (cptr_lock_inv g ctr) * ghost_part g gsh 1%nat.

Definition thread_lock_inv tsh sh gsh g ctr lockc lockt :=
  selflock (thread_lock_R sh gsh g ctr lockc) tsh lockt.

Definition thread_func_spec :=
 DECLARE _thread_func
  WITH y : val, x : share * share * share * gname * val * globals
  PRE [ _args OF (tptr tvoid) ]
         let '(tsh, sh, gsh, g, l, gv) := x in
         PROP  (readable_share tsh; readable_share sh; gsh <> Share.bot)
         LOCAL (temp _args y; gvars gv)
         SEP   (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g (gv _ctr));
                ghost_part g gsh O;
                lock_inv tsh y (thread_lock_inv tsh sh gsh g (gv _ctr) (gv _ctr_lock) y))
  POST [ tptr tvoid ]
         PROP ()
         LOCAL ()
         SEP ().

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

Definition Gprog : funspecs := ltac:(with_library prog [acquire_spec; release_spec; release2_spec; makelock_spec;
  freelock_spec; freelock2_spec; spawn_spec; init_ctr_spec; dest_ctr_spec; incr_spec; thread_func_spec; main_spec]).

Lemma ctr_inv_exclusive : forall lg p,
  exclusive_mpred (cptr_lock_inv lg p).
Proof.
  intros; unfold cptr_lock_inv.
  eapply derives_exclusive, exclusive_sepcon1 with (Q := EX z : nat, _),
    data_at__exclusive with (sh := Ews)(t := tuint); auto; simpl; try omega.
  Intro z; apply sepcon_derives; [cancel|].
  Exists z; apply derives_refl.
Qed.
Hint Resolve ctr_inv_exclusive.

Lemma thread_inv_exclusive : forall tsh sh gsh g ctr lock lockt,
  exclusive_mpred (thread_lock_inv tsh sh gsh g ctr lock lockt).
Proof.
  intros; apply selflock_exclusive.
  unfold thread_lock_R.
  apply exclusive_sepcon1; auto.
Qed.
Hint Resolve thread_inv_exclusive.

Lemma body_init_ctr: semax_body Vprog Gprog f_init_ctr init_ctr_spec.
Proof.
  start_function.
  forward.
  forward.
  ghost_alloc (fun g => ghost_both g Tsh O O).
  { split; auto.
    apply self_completable. }
  Intros g.
  forward_call (gv _ctr_lock, Ews, cptr_lock_inv g (gv _ctr)).
  forward_call (gv _ctr_lock, Ews, cptr_lock_inv g (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv.
    unfold ghost_both; rewrite <- ghost_part_ref_join.
    unfold ghost_ref; Exists O; entailer!. }
  forward.
  unfold ghost_part; Exists g; entailer!.
Qed.

Lemma body_dest_ctr: semax_body Vprog Gprog f_dest_ctr dest_ctr_spec.
Proof.
  start_function.
  forward.
  forward_call (gv _ctr_lock, Ews, cptr_lock_inv g (gv _ctr)).
  forward_call (gv _ctr_lock, Ews, cptr_lock_inv g (gv _ctr)).
  { lock_props. }
  unfold cptr_lock_inv.
  Intros z.
  gather_SEP 2 3. replace_SEP 0 (!!(z = v) && ghost_both g Tsh v v).
  { go_lower; clear.
    rewrite sepcon_comm.
    erewrite (add_andp (_ * _)) by apply (ref_sub(P := sum_ghost)).
    rewrite if_true by auto; entailer!.
    unfold ghost_part, ghost_ref; rewrite ghost_part_ref_join; apply derives_refl. }
  Intros; subst.
  viewshift_SEP 0 emp.
  { go_lower.
    apply own_dealloc. }
  forward.
  cancel.
Qed.

Lemma body_incr: semax_body Vprog Gprog f_incr incr_spec.
Proof.
  start_function.
  forward.
  forward_call (gv _ctr_lock, sh, cptr_lock_inv g (gv _ctr)).
  unfold cptr_lock_inv at 2; simpl.
  Intros z.
  forward.
  forward.
  gather_SEP 2 3.
  viewshift_SEP 0 (ghost_part g gsh (S n) * ghost_ref g (S z)).
  { go_lower.
    rewrite sepcon_comm.
    unfold ghost_part, ghost_ref; rewrite !ghost_part_ref_join.
    apply ref_add with (b := 1%nat); try (hnf; omega).
    intros; exists (c + 1)%nat; hnf; auto. }
  Intros; forward_call (gv _ctr_lock, sh, cptr_lock_inv g (gv _ctr)).
  { lock_props.
    unfold cptr_lock_inv; Exists (S z).
    rewrite Nat2Z.inj_succ.
    entailer!. }
  forward.
Qed.

Lemma body_thread_func : semax_body Vprog Gprog f_thread_func thread_func_spec.
Proof.
  start_function.
  Intros.
  forward.
  forward_call (sh, gsh, g, O, gv).
  forward_call (y, tsh, thread_lock_R sh gsh g (gv _ctr) (gv _ctr_lock),
                thread_lock_inv tsh sh gsh g (gv _ctr) (gv _ctr_lock) y).
  { lock_props.
    unfold thread_lock_inv, thread_lock_R.
    rewrite selflock_eq at 2; cancel. }
  forward.
Qed.

Definition N := 5.

Lemma ghost_part_share_join : forall g sh1 sh2 sh n1 n2, sh1 <> Share.bot -> sh2 <> Share.bot ->
  sepalg.join sh1 sh2 sh ->
  ghost_part g sh1 n1 * ghost_part g sh2 n2 = ghost_part g sh (n1 + n2)%nat.
Proof.
  intros.
  symmetry; apply own_op.
  hnf; simpl.
  repeat (split; auto).
  constructor.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  fold N.
  forward_call gv.
  { rewrite sepcon_comm; apply sepcon_derives; [apply derives_refl | cancel]. }
  Intros g.
  (* need to split off shares for the locks and ghost here *)
  destruct split_Ews as (sh1 & sh2 & ? & ? & Hsh).
  destruct (split_shares (Z.to_nat N) Ews) as (sh0 & shs & ? & ? & ? & Hshs); auto.
  destruct (split_shares (Z.to_nat N) Tsh) as (gsh0 & gshs & ? & ? & ? & Hgshs); auto.
  rewrite Z2Nat.id in * by (unfold N; computable).
  assert_PROP (field_compatible (tarray tlock N) [] (gv _thread_lock)) by entailer!.
  set (thread_lock i := offset_val (sizeof tlock * i) (gv _thread_lock)).
  forward_for_simple_bound N (EX i : Z, EX sh : share, EX gsh : share,
    PROP (sepalg_list.list_join sh0 (sublist i N shs) sh;
          sepalg_list.list_join gsh0 (sublist i N gshs) gsh) LOCAL (gvars gv)
    SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g (gv _ctr));
         ghost_part g gsh O;
         iter_sepcon (fun j => lock_inv sh2 (thread_lock j)
           (thread_lock_inv sh1 (Znth j shs) (Znth j gshs) g (gv _ctr) (gv _ctr_lock) (thread_lock j)))
           (upto (Z.to_nat i));
         data_at_ Ews (tarray tlock (N - i)) (thread_lock i))).
  { unfold N; computable. }
  { Exists Ews Tsh.
    subst thread_lock.
    rewrite !sublist_same by auto; entailer!.
    apply derives_refl. }
  { (* first loop *)
    forward.
    simpl sem_binary_operation'.
    replace (force_val _) with (thread_lock i)
      by (rewrite sem_add_pi_ptr_special; auto; unfold N in *; rep_omega).
    rewrite data_at__tarray.
    destruct (Z.to_nat (N - i)) eqn: Hi.
    { rewrite Z2Nat.inj_sub, Nat.sub_0_le in Hi by omega.
      apply Z2Nat.inj_le in Hi; omega. }
    simpl.
    setoid_rewrite split2_data_at_Tarray_app with (v1 := [default_val tlock]);
      rewrite ?Zlength_cons, ?Zlength_nil, ?Zlength_list_repeat'; auto.
    erewrite data_at_singleton_array_eq by eauto.
    forward_call (thread_lock i, Ews, thread_lock_inv sh1 (Znth i shs) (Znth i gshs) g
      (gv _ctr) (gv _ctr_lock) (thread_lock i)).
    { cancel. }
    rewrite sublist_next in H9, H10 by omega.
    inv H9; inv H10.
    assert (readable_share (Znth i shs)) by (apply Forall_Znth; auto; omega).
    assert (Znth i gshs <> Share.bot).
    { intro X; contradiction bot_unreadable.
      rewrite <- X; apply Forall_Znth; auto; omega. }
    destruct (sepalg_list.list_join_assoc1 (sepalg.join_comm H14) H16) as (sh' & ? & Hsh').
    destruct (sepalg_list.list_join_assoc1 (sepalg.join_comm H13) H17) as (gsh' & ? & Hgsh').
    forward_spawn _thread_func (thread_lock i) (sh1, Znth i shs, Znth i gshs, g, thread_lock i, gv).
    { erewrite <- lock_inv_share_join; try apply Hsh; auto.
      unshelve erewrite <- (lock_inv_share_join _ _ _ _ _ _ _ Hsh'); auto.
      { eapply readable_share_list_join; eauto. }
      unshelve erewrite <- (ghost_part_share_join _ _ _ _ O O _ _ Hgsh'); auto.
      { intro; subst.
        contradiction bot_unreadable.
        eapply readable_share_list_join; eauto. }
      entailer!. }
    { subst thread_lock; simpl.
      apply isptr_is_pointer_or_null; rewrite isptr_offset_val; auto. }
    Exists sh' gsh'; entailer!.
    apply sepcon_derives.
    - rewrite Z2Nat.inj_add, upto_app by omega.
      rewrite iter_sepcon_app; simpl.
      rewrite Z2Nat.id, Z.add_0_r by omega; cancel.
    - rewrite <- Z.sub_add_distr.
      subst thread_lock.
      rewrite field_address0_offset, offset_offset_val.
      rewrite Z.mul_succ_r with (m := i); cancel.
      { rewrite field_compatible0_cons.
        split; [omega|].
        destruct H7 as (? & ? & ? & ? & ?).
        repeat split; auto.
        + hnf.
          destruct (gv _thread_lock); try contradiction; simpl in *.
          rewrite Z.max_r by omega.
          rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr;
            rewrite Ptrofs.unsigned_repr; unfold N in *; try rep_omega.
        + destruct (gv _thread_lock); try contradiction; simpl in *.
          inv H23; try discriminate.
          constructor.
          intros; rewrite Ptrofs.add_unsigned, Ptrofs.unsigned_repr;
            rewrite Ptrofs.unsigned_repr; unfold N in *; try rep_omega.
          simpl; rewrite <- Z.add_assoc, Zred_factor4.
          apply H29; omega. }
    - apply Z2Nat.inj; try omega.
      rewrite Nat2Z.id, Z2Nat.inj_sub by omega; simpl; omega. }
  rewrite !sublist_nil, Zminus_diag; Intros shx gshx.
  inv H8; inv H9.
  forward_for_simple_bound N (EX i : Z, EX sh : share, EX gsh : share,
    PROP (sepalg_list.list_join shx (sublist 0 i shs) sh;
          sepalg_list.list_join gshx (sublist 0 i gshs) gsh) LOCAL (gvars gv)
    SEP (lock_inv sh (gv _ctr_lock) (cptr_lock_inv g (gv _ctr));
         ghost_part g gsh (Z.to_nat i);
         iter_sepcon (fun j => lock_inv sh2 (thread_lock j)
           (thread_lock_inv sh1 (Znth j shs) (Znth j gshs) g (gv _ctr) (gv _ctr_lock) (thread_lock j)))
           (sublist i N (upto (Z.to_nat N)));
         data_at_ Ews (tarray tlock i) (gv _thread_lock))).
  { unfold N; computable. }
  { rewrite !sublist_nil; Exists shx gshx; entailer!.
    { split; constructor. }
    rewrite !data_at__eq, !data_at_zero_array_eq; auto. }
  { (* second loop *)
    forward.
    replace (force_val _) with (thread_lock i)
      by (simpl; rewrite sem_add_pi_ptr_special; auto; unfold N in *; simpl in *; rep_omega).
    Opaque upto.
    rewrite sublist_next with (i0 := i) by (auto; rewrite Zlength_upto, Z2Nat.id; omega); simpl.
    rewrite Znth_upto by (simpl; unfold N in *; omega).
    forward_call (thread_lock i, sh2, thread_lock_inv sh1 (Znth i shs) (Znth i gshs) g
      (gv _ctr) (gv _ctr_lock) (thread_lock i)).
    { cancel. }
    unfold thread_lock_inv at 2; unfold thread_lock_R.
    rewrite selflock_eq; Intros.
    forward_call (thread_lock i, Ews, sh1, thread_lock_R (Znth i shs) (Znth i gshs) g (gv _ctr) (gv _ctr_lock),
      thread_lock_inv sh1 (Znth i shs) (Znth i gshs) g (gv _ctr) (gv _ctr_lock) (thread_lock i)).
    { lock_props.
      unfold thread_lock_inv, thread_lock_R.
      erewrite <- (lock_inv_share_join _ _ Ews); try apply Hsh; auto; cancel. }
    erewrite <- sublist_same with (al := shs) in Hshs by eauto.
    erewrite <- sublist_same with (al := gshs) in Hgshs by eauto.
    rewrite sublist_split with (mid := i) in Hshs, Hgshs by omega.
    rewrite sublist_next with (i0 := i) in Hshs by omega.
    rewrite sublist_next with (i0 := i) in Hgshs by omega.
    rewrite app_cons_assoc in Hshs, Hgshs.
    apply sepalg_list.list_join_unapp in Hshs as (sh' & Hshs1 & ?).
    apply sepalg_list.list_join_unapp in Hgshs as (gsh' & Hgshs1 & ?).
    apply sepalg_list.list_join_unapp in Hshs1 as (? & J & J1).
    apply sepalg_list.list_join_unapp in Hgshs1 as (? & Jg & Jg1).
    apply list_join_eq with (c := sh) in J; auto; subst.
    apply list_join_eq with (c := gsh) in Jg; auto; subst.
    rewrite <- sepalg_list.list_join_1 in J1, Jg1.
    gather_SEP 3 1; erewrite lock_inv_share_join; eauto.
    gather_SEP 3 2; erewrite ghost_part_share_join; eauto.
    rewrite !(sublist_split 0 i (i + 1)), !sublist_len_1 by omega.
    Exists sh' gsh'; entailer!.
    { split; eapply sepalg_list.list_join_app; eauto; econstructor; eauto; constructor. }
    rewrite Z2Nat.inj_add by omega.
    rewrite !sepcon_assoc; apply sepcon_derives; [apply derives_refl|].
    rewrite sepcon_comm, sepcon_assoc; apply sepcon_derives; [apply derives_refl|].
    rewrite !data_at__tarray.
    rewrite Z2Nat.inj_add, <- list_repeat_app by omega.
    erewrite split2_data_at_Tarray_app by (rewrite Zlength_list_repeat; auto; omega).
    rewrite Z.add_simpl_l; cancel.
    simpl; erewrite data_at_singleton_array_eq by eauto.
    rewrite field_address0_offset.
    cancel.
    { rewrite field_compatible0_cons; split; auto; try omega.
      apply field_compatible_array_smaller0 with (n' := N); auto; omega. }
    { intro X; contradiction unreadable_bot.
      rewrite <- X; eapply readable_share_list_join; eauto. }
    { intro X; contradiction unreadable_bot.
      rewrite <- X; apply Forall_Znth; auto; omega. }
    { eapply readable_share_list_join; eauto. }
    { apply Forall_Znth; auto; omega. } }
  Intros sh' gsh'.
  eapply list_join_eq in Hshs; [|erewrite <- (sublist_same 0 N shs) by auto; eauto].
  eapply list_join_eq in Hgshs; [|erewrite <- (sublist_same 0 N gshs) by auto; eauto].
  subst.
  forward_call (g, Z.to_nat N, gv).
  forward.
  rewrite Z2Nat.id; [|unfold N; computable].
  (* We've proved that t is N! *)
  forward.
Qed.

Definition extlink := ext_link_prog prog.

Definition Espec := add_funspecs (Concurrent_Espec unit _ extlink) extlink Gprog.
Existing Instance Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons_ext.
semax_func_cons body_init_ctr.
semax_func_cons body_dest_ctr.
semax_func_cons body_incr.
semax_func_cons body_thread_func.
semax_func_cons body_main.
Qed.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RefinementSpecLemmas.

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

Require Import VerdiRaft.AllEntriesTermSanityInterface.

Section AllEntriesTermSanity.

  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}.

  Lemma handleAppendEntries_currentTerm_monotonic:
    forall h st (d : raft_data)
      (m : msg) (t : term) (n : name) (pli : logIndex)
      (plt : term) (es : list entry) (ci : logIndex),
      handleAppendEntries h st t n pli plt es
                          ci = (d, m) ->
      currentTerm st <= currentTerm d.
  Proof using.
    intros.
    unfold handleAppendEntries in *.
    repeat break_match; simpl in *; do_bool; repeat find_inversion; auto; try omega;
    simpl in *;
    unfold advanceCurrentTerm in *; repeat break_match; do_bool; auto.
  Qed.

  Lemma allEntries_term_sanity_append_entries :
    refined_raft_net_invariant_append_entries allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_eapply_lem_hyp update_elections_data_appendEntries_allEntries_term'; eauto.
    intuition.
    find_apply_lem_hyp handleAppendEntries_currentTerm_monotonic;
      find_apply_hyp_hyp; omega.
  Qed.

  Lemma allEntries_term_sanity_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_apply_lem_hyp handleAppendEntriesReply_type_term. intuition; repeat find_rewrite; eauto.
    find_apply_hyp_hyp. omega.
  Qed.

  Lemma allEntries_term_sanity_request_vote :
    refined_raft_net_invariant_request_vote allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_rewrite_lem update_elections_data_requestVote_allEntries.
    find_apply_lem_hyp handleRequestVote_type_term. intuition; repeat find_rewrite; eauto.
    find_apply_hyp_hyp. omega.
  Qed.

  Lemma allEntries_term_sanity_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_rewrite_lem update_elections_data_requestVoteReply_allEntries.
    find_apply_hyp_hyp.
    unfold handleRequestVoteReply, advanceCurrentTerm.
    repeat break_match; simpl in *; repeat find_inversion; do_bool; simpl in *; auto.
    omega.
  Qed.

  Lemma allEntries_term_sanity_client_request :
    refined_raft_net_invariant_client_request allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_copy_apply_lem_hyp update_elections_data_client_request_allEntries.
    find_apply_lem_hyp handleClientRequest_type.
    intuition; repeat find_rewrite;
    try find_apply_hyp_hyp; auto.
    break_exists.
    intuition; repeat find_rewrite;
    simpl in *.
    intuition; simpl in *;
    try match goal with
      | H : context [ _ :: _ ] |- _ => clear H
    end; repeat tuple_inversion; eauto.
  Qed.

  Lemma allEntries_term_sanity_timeout :
    refined_raft_net_invariant_timeout allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_rewrite_lem update_elections_data_timeout_allEntries.
    find_apply_lem_hyp handleTimeout_type_strong.
    intuition; repeat find_rewrite; eauto.
  Qed.

  Lemma allEntries_term_sanity_do_leader :
    refined_raft_net_invariant_do_leader allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_apply_lem_hyp doLeader_type. intuition.
    repeat find_rewrite. eauto.
  Qed.

  Lemma allEntries_term_sanity_do_generic_server :
    refined_raft_net_invariant_do_generic_server allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
    find_apply_lem_hyp doGenericServer_type. intuition.
    repeat find_rewrite. eauto.
  Qed.

  Lemma allEntries_term_sanity_reboot :
    refined_raft_net_invariant_reboot allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update; simpl in *; eauto.
  Qed.

  Lemma allEntries_term_sanity_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros.
    find_reverse_higher_order_rewrite. eauto.
  Qed.

  Lemma allEntries_term_sanity_init :
    refined_raft_net_invariant_init allEntries_term_sanity.
  Proof using.
    red. unfold allEntries_term_sanity. intros. simpl in *. intuition.
  Qed.

  Instance aetsi : allEntries_term_sanity_interface.
  Proof.
    split.
    intros.
    apply refined_raft_net_invariant; auto.
    - apply allEntries_term_sanity_init.
    - apply allEntries_term_sanity_client_request.
    - apply allEntries_term_sanity_timeout.
    - apply allEntries_term_sanity_append_entries.
    - apply allEntries_term_sanity_append_entries_reply.
    - apply allEntries_term_sanity_request_vote.
    - apply allEntries_term_sanity_request_vote_reply.
    - apply allEntries_term_sanity_do_leader.
    - apply allEntries_term_sanity_do_generic_server.
    - apply allEntries_term_sanity_state_same_packet_subset.
    - apply allEntries_term_sanity_reboot.
  Qed.
End AllEntriesTermSanity.


Require Export Nat.
Require Export ch2o.prelude.orders.
Require Export ch2o.prelude.nmap.
Require Export ch2o.prelude.stringmap.
Require Export ch2o.memory.memory_basics.
Require Export ch2o.abstract_c.architectures.
Require Export ch2o.abstract_c.interpreter.
Require Export ch2o.abstract_c.frontend_sound.
Require Export ch2o.core_c.smallstep.
Require Export ch2o.core_c.restricted_smallstep.
Require Export ch2o.core_c.expression_eval_smallstep.
Require Export bigstep_soundness.
Require Export three_locals.

Definition get_right{A B}(v: A + B)(H: match v with inl _ => False | inr _ => True end): B.
Proof.
destruct v.
elim H.
exact b.
Defined.

Local Open Scope string_scope.

Definition A: architecture := {|
  arch_sizes := architectures.lp64;
  arch_big_endian := false;
  arch_char_signedness := Signed;
  arch_alloc_can_fail := false
|}.
Notation K := (arch_rank A).

Notation M := (error (frontend_state K) string).

Lemma alloc_program_ok: match alloc_program (K:=K) decls empty with inl _ => False | inr _ => True end.
Proof.
exact I.
Qed.

Definition alloc_program_result: frontend_state K.
Proof.
eapply snd.
eapply get_right.
apply alloc_program_ok.
Defined.

(*
Compute (stringmap_to_list (env_t (to_env alloc_program_result))).
Compute (stringmap_to_list (env_f (to_env alloc_program_result))).
*)

Definition to_core_c_program: M (env K * funenv K * state K) :=
  _ ← alloc_program decls;
  Δg ← gets to_globals;
  '(_,σs,σ,_) ← error_of_option (Δg !! "main"≫= maybe4 Fun)
    ("function `main` undeclared`");
  guard (σ = sintT%T ∨ σ = uintT%T) with
    ("function `main` should have return type `int`");
  Γ ← gets to_env;
  δ ← gets to_funenv;
  m ← gets to_mem;
  mret (Γ, δ, initial_state m "main" []).

Definition to_core_c_program_result: string + env K * funenv K * state K :=
  error_eval to_core_c_program ∅.

Lemma to_core_c_program_ok: match to_core_c_program_result with inl _ => False | inr _ => True end.
Proof.
exact I.
Qed.

Definition core_c_program: env K * funenv K * state K := get_right to_core_c_program_result to_core_c_program_ok.

Definition Γ: env K := to_env alloc_program_result.
Definition δ: funenv K := to_funenv alloc_program_result.
Definition m0: mem K := to_mem alloc_program_result.
Definition S0 := initial_state m0 "main" [].

Lemma alloc_program_eq: alloc_program decls empty = mret () alloc_program_result.
Proof.
reflexivity.
Qed.

Lemma Γ_valid: ✓ Γ.
Proof.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma δ_valid: ✓{Γ,'{m0}} δ.
Proof.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Lemma m0_valid: ✓{Γ} m0.
apply alloc_program_valid with (1:=alloc_program_eq).
Qed.

Goal ∀ S, Γ\ δ ⊢ₛ S0 ⇒* S → ¬is_undef_state S.
Proof.
intros.
intro HS.
apply csteps_rcsteps in H.
inv_rcsteps H. elim (is_Some_None HS).
inversion H; clear H; subst.
destruct os; try discriminate.
clear H7 H8.
assert (match Some s with None => s | Some s => s end = s). {
  reflexivity.
}
rewrite <- H6 in H.
simpl in H.
subst.
clear H6.
assert (m0 = ∅). reflexivity.
rewrite H in H1. clear H.
simpl in H1.
apply exec_sound with (z:=2) in H1. {
  destruct H1 as [H1|[m H1]].
  - destruct S as [? [] ?]; try elim (is_Some_None HS).
    inversion H1.
    inversion H.
  - subst.
    elim (is_Some_None HS).
}
apply Γ_valid.
apply δ_valid.
{
  apply type_check_sound.
  - simpl. apply Γ_valid.
  - reflexivity.
}
clear HS H1 S.

econstructor.
econstructor.
- econstructor.
  + simpl; lia.
  + econstructor. split; (unfold int_lower || unfold int_upper); simpl; lia.
- econstructor.
  econstructor.
  + econstructor.
    * simpl; lia.
    * econstructor. split; (unfold int_lower || unfold int_upper); simpl; lia.
  + econstructor.
    econstructor.
    * econstructor.
      -- simpl; lia.
      -- econstructor.
         reflexivity.
    * econstructor.
      -- econstructor.
         reflexivity.
Qed.


Require Import HoareDef SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.
Require Import HTactics ProofMode IPM.
Require Import OpenDef.
Require Import Mem1 MemOpen STB.

Require Import Imp.
Require Import ImpNotations.
Require Import ImpProofs.

Require Import KnotMain0 KnotMainImp.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section SIMMODSEM.

  Import ImpNotations.

  Context `{Σ: GRA.t}.

  Let W: Type := Any.t * Any.t.

  Let wf: unit -> W -> Prop :=
    fun _ '(mrps_src0, mrps_tgt0) =>
      (<<SRC: mrps_src0 = tt↑>>) /\
      (<<TGT: mrps_tgt0 = tt↑>>)
  .

  Theorem correct:
    refines2 [KnotMainImp.KnotMain] [KnotMain0.Main].
  Proof.
    eapply adequacy_local2. econs; ss. i.
    econstructor 1 with (wf:=wf) (le:=top2); et; ss.
    econs; ss.
    { init.
      unfold fibF, fib.
      steps.
      rewrite unfold_eval_imp. steps.
      des_ifs.
      2:{ exfalso; apply n0. solve_NoDup. }
      3:{ exfalso; apply n0. solve_NoDup. }
      - imp_steps.
        unfold unint in *. clarify.

        des_ifs; ss; clarify.
        2:{ lia. }
        imp_steps.
        red. esplits; et.
      - imp_steps.
        unfold unint in *. des_ifs; ss; clarify.
        { lia. }
        imp_steps.
        unfold ccallU. imp_steps.
        red. esplits; et.
    }
    econs; ss.
    { init.
      steps.
      unfold mainF, main.
      steps.
      rewrite unfold_eval_imp. steps.
      des_ifs.
      2:{ exfalso; apply n0. solve_NoDup. }
      imp_steps.
      rewrite _UNWRAPU0. unfold ccallU. imp_steps.
      red. esplits; et.
    }
    Unshelve. all: ss. all: try exact 0.
  Qed.

End SIMMODSEM.


(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2013-09-30

* Translate CPF type into CoLoR type.

*)

Set Implicit Arguments.

(* REMARK : [filter: term -> term'] inside [AFilterTerm] has a same
   name with [filter] in List. *)

Require Import ATrs BinNat cpf cpf_ind cpf_util LogicUtil
  Compare_dec ZUtil AFilterPerm ListUtil NatUtil AProj.

(* REMARK: AProj: raw_pi : Sig -> option nat.
   AFilterPerm: raw_pi : Sig -> list nat.

   Where AFilterPerm is non-collapsing arguments filtering with
   permutations; and AProj is arguments filtering with projections
   only.

   - In old Rainbow used:
   AFilterPerm for : RPO + DP_argumentfilterProc and
   AProj for: SubtermProc in DP_subtermProc. *)

Section S.

  (* TEST collapsing is true. *)

  Definition is_collapsing (t: t3) : bool :=
    match t with
      | T3_collapsing _ => true
      | T3_nonCollapsing _ => false
    end.

  Definition is_noncollapsing (t: t3) : bool :=
    match t with
      | T3_collapsing _ => false
      | T3_nonCollapsing _ => true
    end.

  (* Check both collapsing and nonCollapsing is true *)

  Definition is_col_noncol (t: t3) : bool :=
    match t with
      | T3_collapsing _
      | T3_nonCollapsing _ => true
    end.

  (* TODO: MOVE *)
  (* FIXME: in cpf2color_loop. has the same function of list position
     -> list nat. but in result type *)

  (* Define a function translate positive to nat.
     REMARK: minus 1 because positive in Coq started from 1, when
     natural numbers started from 0. *)

  Definition color_positiveInteger (p: positive) : nat :=
    nat_of_P p - 1.

  (* Define a function taking a list of position of type
     [positiveInteger] and return a list nat.
     For example: if the list of position is : [1 2 3 4]
     then the return value is: [0 1 2 3]. *)

  Definition list_position_nat (ps: list position) : list nat :=
    List.map color_positiveInteger ps.

  Variable arity : symbol -> nat.

  Variable f : symbol.

  (* Define a function transform arity cpf type into type nat. *)

  Definition color_arity (a: cpf.arity) : nat := nat_of_N a.

  (* Define [raw_pi: Sig -> list nat] in AFilterPerm from a list of
     argument filtering. *)

  (* If the list of position in nonCollapsing is equiv
     with the increase list less than of (arity f) (i.e
     if (arity f = 4) then the increase list less than
     of 3 is: 0 1 2 3) then return nil/None otherwise
     return a list of position in nonCollapsing.

     For example: the position list in nonCollapsing is:
     [1 2 3 4] then tranform it to type [nat] by minus 1
     the list become : 0 1 2 3.  Support the (arity f =
     4) then the condition is true, for [0 1 2 3] is
     equivalence with [0 1 2 3] then the return value is
     [nil].  Otherwise if (arity f <> 4) then the
     condition is false and the return value is the list
     of [ps: 0 1 2 3].
     *)

  Fixpoint raw_pi_filter (l: list (symbol * cpf.arity * t3)): list nat :=
    match l with
      | (g, n, t) :: l' =>
        match @eq_symb_dec (Sig arity) g f with
          | left _ =>
            match t with
              | T3_collapsing p => color_positiveInteger p :: nil (* FIXME: nil?*)
              | T3_nonCollapsing ps =>
                if equiv beq_nat (list_position_nat ps) (nats_incr_lt (arity f))
                  then nil
                  else list_position_nat ps
            end
          | right _ => raw_pi_filter l'
        end
      | nil => nats_incr_lt (arity f)
    end.

  (* Define function [raw_pi: option nat] in the case
     projection only from a list of argument filtering. *)

  Fixpoint raw_pi_proj (l: list (symbol * cpf.arity * t3)): option nat :=
    match l with
      | (g, _, t) :: l' =>
        match @eq_symb_dec (Sig arity) g f with
          | left _ =>
            match t with
              | T3_collapsing p => Some (color_positiveInteger p)
              | T3_nonCollapsing _ps => None
            end
          | right _ => raw_pi_proj l'
        end
      | nil => None
    end.

End S.

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

Section raw_pi.

  Variable arity : symbol -> nat.
  Variable l : list (symbol * cpf.arity * t3).

  (* raw_pi filter : Sig -> list nat. *)

  Definition color_raw_pi_filter (f: symbol) : list nat := raw_pi_filter arity f l.

  (* raw_pi projection: Sig -> option nat. *)

  Definition color_raw_pi_proj (f: symbol) : option nat := raw_pi_proj arity f l.

End raw_pi.

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

Section pi.

  Variable arity : symbol -> nat.
  Variable f: symbol.

  (* TODO: proving the lemma [raw_pi_ok]; or make it as a variable and
     then given the boolean function in the cpf2color_argfilter. *)

  (* TODO *)
  Lemma raw_pi_ok : forall ps,
    forallb (bgt_nat (arity f)) (list_position_nat ps) = true.
  Proof.
  Admitted.

  (*Variable raw_pi_ok : forall ps,
    forallb (bgt_nat (arity f)) (list_position_nat ps) = true. *)

  (* Define [pi: forall f: Sig, nat_lts (arity f)] in the case of
  non-collapsing (filtering).*)

  (* REMOVE *)
  Fixpoint pi_filter (l : list (symbol * cpf.arity * t3)): nat_lts (arity f) :=
    match l with
      | (g, _, t3) :: l' =>
        match @eq_symb_dec (Sig arity) g f with
          | left _ =>
            match t3 with
              | T3_collapsing _p => mk_nat_lts (arity f)
              | T3_nonCollapsing ps =>
                build_nat_lts (arity f) (list_position_nat ps) (raw_pi_ok ps)
            end
          | right _ => pi_filter l'
        end
      | nil => mk_nat_lts (arity f) (* FIXME *)
    end.

  (* Define [pi: forall f: Sig arity, option {k:nat | k < arity f}] in
     the case of projection (collapsing) only from an argument af in CPF. *)

  Fixpoint pi_proj (l: list (symbol * cpf.arity * t3)): option {k : nat | k < arity f}:=
    match l with
      | (g, _, t3) :: l' =>
        match @eq_symb_dec (Sig arity) g f with
          | left _ =>
            match t3 with
              | T3_collapsing p =>
                let n := color_positiveInteger p in
                  match lt_dec n (arity f) with
                    | left h => Some (mk_proj (Sig arity) f h)
                    | right _ => None
                  end
              | T3_nonCollapsing ps => None
            end
          | right _ => pi_proj l'
        end
      | nil => None
    end.

End pi.

(******************************************************************************)
(* FIXME: define [color_pi_filter] by using build_pi to be able to use
the lemma bnon_dup_ok in the correctness proof for AF in DP. *)

Section build_pi.

Require Import AFilterPerm.

Variable arity : symbol -> nat.
Variable l: list (symbol * cpf.arity * t3).

Definition Fs : list (Sig arity) := list_split_triple l.

(* TODO *)
Lemma Fs_ok : forall f, In f Fs.

Proof.
Admitted.

(* Use this function for type: Sig -> list nat. *)

Definition color_raw_pi : (Sig arity) -> list nat :=
  color_raw_pi_filter arity l.

(* TODO *)
Lemma color_raw_pi_ok : bvalid color_raw_pi Fs = true.

Proof.

Admitted.

(* REMARK: this is equal to the function [color_pi_filter] below. *)
Definition color_build_pi :=
  build_pi Fs_ok color_raw_pi_ok.

End build_pi.

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

Section color_pi.

  Variable l : list (symbol * cpf.arity * t3).
  Variable arity : symbol -> nat.

  (* TEST: use in the case of rainbow_top_termin. *)

  Definition color_pi_filter (f: symbol) : nat_lts (arity f) :=
    pi_filter arity f l.

  (* Define a function [color_pi_proj] transform CPF type into CoLoR
     type [pi_proj] *)

  Definition color_pi_proj (f: symbol): option {k : nat | k < arity f} :=
    pi_proj arity f l.

  (* Define a function [color_filter] transform CPF type into CoLoR
     type [filter] in non-collpasing. *)

  Notation aterm := (ATerm.term (Sig arity)).

  (* TEST: check the result use in rainbow_top_termin *)

  Definition color_filter (t:aterm) :=
    @AFilterPerm.filter (Sig arity) (color_pi_filter) t.

  (* TEST Replace [color_pi_filter] by [build_pi] to be able to proof non-dup. *)
  (*
  Definition color_filter (t:aterm) :=
    @AFilterPerm.filter (Sig arity) (color_build_pi l) t. *)

  (* Define a function [color_proj] transform CPF type into CoLoR type
     [proj] in projection only. *)

  Definition color_proj (t: aterm) : aterm :=
    @proj (Sig arity) (color_pi_proj) t.

  (* Define a function [color_filter_rules] transform CPF type into
  CoLoR type [filter_rules]. *)

  Notation arules := (list (ATrs.rule (Sig arity))).

  Definition color_filter_rule := @filter_rule (Sig arity).

  Definition color_filter_rules r := List.map (color_filter_rule r).

  (* Define a function [color_proj_rules] transform CPF type into
  CoLoR type [proj_rules]. *)

  Definition color_proj_rules (r:arules) :=
    @proj_rules (Sig arity) (color_pi_proj) r.

  (* Define record type [Perm] in [ARedPair2.v] *)

  Require Import ARedPair2.

  (* TODO *)

  (* Proof this non_dup by using the boolean function in the
     bnon_dup_ok. And declare the boolean non_dup function as a
     variable then add them in the boolean function of
     cpf2color_argfilter.*)

  (*Variable bnon_dup use build_pi to build [nats_lt] *)

  (* FIXME: define the function [non_dup] *)

  (* TEST: used color_pi_filter *)
  Lemma pi_perm_ok: @non_dup (Sig arity) (color_pi_filter).

  Proof.
    unfold color_build_pi.
  Admitted.

  (* Define record type [Proj] in [ARedPair2.v] *)

  (* TEST: with color_pi_filter *)
  Definition color_Perm : Perm (Sig arity) :=
    @mkPerm (Sig arity) (color_pi_filter) (pi_perm_ok).  (* FIXME *)

  (* Definition Sig_perm : Signature := filter_sig (pi_perm perm).*)

  Definition color_Sig_perm : Signature := @Sig_perm (Sig arity) color_Perm.

  (*************)
  (* TEST: use color_build_pi *)
  (*
  Lemma pi_perm_ok2: @non_dup (Sig arity) (color_build_pi l).

  Proof.
    unfold color_build_pi. apply bnon_dup_ok.

  Admitted.

  Definition color_Perm2 : Perm (Sig arity) :=
    @mkPerm (Sig arity) (color_build_pi l) (pi_perm_ok2).  (* FIXME *)

  Definition color_Sig_perm2 : Signature := @Sig_perm (Sig arity) color_Perm2. *)

  (*Record Proj := mkProj {
     pi_proj : forall f: Sig, option {k | k < arity f} }.*)

  Definition color_Proj : Proj (Sig arity) := @mkProj (Sig arity) color_pi_proj.

End color_pi.


(* 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                                                     *)

(** this file contains some cardinal functions, which are message
dependent *)

Require Export reduce.
Require Export DistributedReferenceCounting.machine4.machine.

Section COUNT_MESSAGE.

Definition dec_predicate (m : Message) :=
  match m with
  | dec => true
  | _ => false
  end.

Definition inc_predicate (m : Message) :=
  match m with
  | inc_dec _ => true
  | _ => false
  end.

(* the next one only recognises inc_dec messages related to s0 *)

Variable s0 : Site.

Definition site_inc_predicate (m : Message) :=
  match m with
  | inc_dec s => if eq_site_dec s s0 then true else false
  | _ => false
  end.

Definition copy_predicate (m : Message) :=
  match m with
  | copy => true
  | _ => false
  end.

Definition dec_count (m : Message) :=
  match m with
  | dec => 1%Z
  | _ => 0%Z
  end.

Definition inc_count (m : Message) := 0%Z.

Definition copy_count (m : Message) :=
  match m with
  | copy => 1%Z
  | _ => 0%Z
  end.

Definition cardinal_count :=
  fun_sum Message dec_count (fun_sum Message inc_count copy_count).

Definition cardinal := reduce Message cardinal_count.

Lemma disjoint_cardinal :
 forall q : queue Message,
 cardinal q =
 (reduce Message dec_count q +
  (reduce Message inc_count q + reduce Message copy_count q))%Z.
Proof.
  intro.
  rewrite <- disjoint_reduce.
  rewrite <- disjoint_reduce.
  unfold cardinal in |- *.
  unfold cardinal_count in |- *.
  auto.
Qed.

Lemma cardinal_first_out :
 forall (q : queue Message) (m : Message),
 first Message q = value Message m ->
 cardinal (first_out Message q) = (cardinal q - cardinal_count m)%Z.
Proof.
  intros.
  unfold cardinal in |- *.
  apply reduce_first_out.
  auto.
Qed.

End COUNT_MESSAGE.

Section SIG_WEIGHT.
Let Bag_of_message := Bag_of_Data Message.

Definition sigma_weight (bm : Bag_of_message) :=
  sigma2_table Site LS LS (queue Message) (fun s1 s2 : Site => cardinal) bm.

End SIG_WEIGHT.


(* ------------------------------------------------------- *)
(** #

#
        The double time redundancy (DTR) transformation
#
#
-  ctr block properties during even(1) cycles

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)
(* Add LoadPath "..\..\Common\".
Require Import CirReflect .
Add LoadPath "..\..\TMRProof\".
Require Import tmrMainTh.
Add LoadPath "..\".
Require Import dtrTransform.
Add LoadPath "..\memoryBlocks".
*)

Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".
Add LoadPath "..\memoryBlocks\".

Require Import dtrTransform controlFsmStep.

Set Implicit Arguments.

(* ########################################################## *)
(** Properties of DTR control block during the even(1) cycles  *)
(* ########################################################## *)

(*Normal mode: from the state '001' the control block goes to the states '000' if no fail signal raised*)
(*No glitches*)
Lemma step1_tcbv : forall  t c, step (ctrBlockTMR false false true)  {~0,~0,~0}  t c
                                  -> t={~1,~0,~0,~0,~0} /\ c=(ctrBlockTMR false false false).
Proof.
introv H.
assert ( step (ctrBl_dtr false false true)   (~0)  {~1,~0,~0,~0,~0}(ctrBl_dtr false false false)). (*property of a single ctrBl*)
 - assert ( exists t, exists c', step (ctrBl_dtr false false true) (~0) t c' ). apply step_all_ex.
   Simpl. assert (HA :=  H0). apply fact_stepCtrBl_21 in H0. destruct H0; Simpl.
 - apply tmr_normal in H0. apply tmrVotRelat in H0.
   + Rdet. Simpl.
   + Checkpure.
   + Checkpure.
Qed.

(*Error detection: from the state '001' the control block goes to the states '010' if the fail signal raised*)
(*No glitches*)
Lemma stepr1_tcbv : forall t c, step (ctrBlockTMR false false true)  {~1,~1,~1}  t c
                          -> t={~1,~1,~1,~1,~1} /\ c=(ctrBlockTMR false true false).
Proof.
introv H.
assert ( step (ctrBl_dtr false false true)   (~1)  {~1,~1,~1,~1,~1}(ctrBl_dtr false true false)). (*property of a single ctrBl*)
- assert ( exists t, exists c', step (ctrBl_dtr false false true) (~1) t c' ). apply step_all_ex.
  Simpl. assert (HA :=  H0). apply fact_stepCtrBl_23 in H0. destruct H0; Simpl.
- apply tmr_normal in H0. apply tmrVotRelat in H0.
   + Rdet. Simpl.
   + Checkpure.
   + Checkpure.
Qed.

(*Recovery from internal control block corruption during during the normal mode:
if one of three redundant parts of the control block is corrupted then
the error disappears the next clock cycle thanks to TMR (without starting recovery since fail=0)*)
Lemma step1_tcbv_C: forall  t ctrTMR c, corrupt_1in3_cir (ctrBl_dtr false false true) ctrTMR
                     ->  step (ctrTMR -o- ctrVoting)   {~0,~0,~0}  t  c
                     -> t={~1,~0,~0,~0,~0} /\ c=(ctrBlockTMR false false false).
Proof.
introv H H0. unfold ctrBlockTMR.
apply tmr_corruptc  with (c':=(ctrBl_dtr false false false)) (s:=(~0)) (t:={~1,~0,~0,~0,~0}) in H.
 - Inverts H0. apply det_step with (c1:=c1') (t1:=t0 )  in H. Inverts H.
   + assert (F:  fstep ctrVoting {~ 1, ~ 0, ~ 0, ~ 0, ~ 0,
                                 {~ 1, ~ 0, ~ 0, ~ 0, ~ 0},
                                 {~ 1, ~ 0, ~ 0, ~ 0, ~ 0}}  =
             Some ({~1,~0,~0,~0,~0} ,  ctrVoting)) by
     (vm_compute; try easy). eapply fstep_imp_detstep in F; Simpl.
   + Checkpure.
   + apply H5.
 - Checkpure.
 - assert ( exists t, exists c', step (ctrBl_dtr false false true) (~0) t c' ). apply step_all_ex.
  Simpl. assert (HA :=  H1). apply fact_stepCtrBl_21 in H1. destruct H1; Simpl.
Qed.


Require Import AutoSep Bootstrap Malloc Buffers XmlLex XmlLang Arrays8 ArrayOps.
Require Import RelDb XmlOutput Bags Io Http HttpQ Thread.

Module Type HIDE.
  Parameter heapSize4 : N -> N.
  Axiom heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.

  Parameter to_nat : N -> nat.
  Axiom to_nat_eq : to_nat = N.to_nat.
End HIDE.

Module Hide : HIDE.
  Definition heapSize4 n := (n * 4)%N.
  Theorem heapSize4_eq : forall n, heapSize4 n = (n * 4)%N.
    auto.
  Qed.

  Definition to_nat := N.to_nat.
  Theorem to_nat_eq : to_nat = N.to_nat.
    auto.
  Qed.
End Hide.

Record wf (ts : tables) (pr : program) (buf_size outbuf_size : N) : Prop := {
  WellFormed : XmlLang.wf ts pr;
  NotTooGreedy : (reserved pr <= 86)%nat;

  Buf_size_lower : (buf_size >= 2)%N;
  Buf_size_upper : (buf_size * 4 < Npow2 32)%N;

  Outbuf_size_lower : (outbuf_size >= 2)%N;
  Outbuf_size_upper : (outbuf_size * 4 < Npow2 32)%N;

  ND : NoDup (Names ts);
  GoodSchema : twfs ts;
  UF : uf ts
}.

Module Type S.
  Parameter ts : tables.
  Parameter pr : program.
  Parameters buf_size outbuf_size heapSize : N.

  Axiom Wf : wf ts pr buf_size outbuf_size.

  Parameters port numWorkers : W.
End S.

Module Make(M : S).
Import M.

Module Locations.
  Definition globalSched : W := ((heapSize + 50) * 4)%N.
  Definition globalSock : W := globalSched ^+ $4.
End Locations.

Import Locations.

Module M'''.
  Definition globalSched := globalSched.

  Local Open Scope Sep_scope.

  Definition globalInv (fs : files) : HProp :=
    db ts * Ex fr, globalSock =*> fr * [| fr %in fs |].
End M'''.

Module T := Thread.Make(M''').

Import T M'''.
Export T M'''.

Module MyM.
  Definition sched := sched.
  Definition globalInv := globalInv.

  Definition buf_size := outbuf_size.

  Theorem buf_size_lower : (nat_of_N buf_size >= 2)%nat.
    generalize (Outbuf_size_lower _ _ _ _ M.Wf).
    unfold buf_size; intros; nomega.
  Qed.

  Theorem buf_size_upper : goodSize (4 * nat_of_N buf_size).
    Transparent goodSize.
    unfold goodSize.
    rewrite Nat2N.inj_mul.
    rewrite Nmult_comm.
    rewrite N2Nat.id.
    eapply Outbuf_size_upper; apply M.Wf.
    Opaque goodSize.
  Qed.

  Theorem globalInv_monotone : forall fs fs', fs %<= fs'
    -> globalInv fs ===> globalInv fs'.
    unfold globalInv, M'''.globalInv; sepLemma.
  Qed.
End MyM.

Ltac unf := unfold MyM.sched, MyM.globalInv, M'''.globalSched, M'''.globalInv in *.

Module MyIo := Io.Make(MyM).
Module MyHttpQ := HttpQ.Make(MyM).
Module MyHttp := MyHttpQ.H.

Definition mainS := SPEC reserving 49
  PREmain[_] globalSched =?> 1 * globalSock =?> 1 * db ts * mallocHeap 0.

Definition handlerS := SPEC reserving 99
  Al fs,
  PREmain[_] sched fs * globalInv fs * mallocHeap 0.

Definition bsize := nat_of_N (buf_size * 4)%N.

Inductive unfold_here := UnfoldHere.
Local Hint Constructors unfold_here.

Import MyHttpQ.Httpq.

Theorem httpq_nil : Emp ===> httpq 0.
  eapply Himp_trans; [ | apply httpq_bwd ].
  apply Himp_ex_c; exists nil.
  sepLemma; step SinglyLinkedList.hints.
Qed.

Definition hints : TacPackage.
  prepare buffer_split_tagged (buffer_join_tagged, httpq_nil).
Defined.

Definition m0 := bimport [[ "buffers"!"bmalloc" @ [bmallocS], "sys"!"abort" @ [abortS],
                            "xml_prog"!"main" @ [XmlLang.mainS pr httpq ts],
                            "malloc"!"malloc" @ [mallocS],
                            "http"!"readRequest" @ [MyHttp.readRequestS],
                            "http"!"writeResponse" @ [MyHttp.writeResponseS],
                            "scheduler"!"init" @ [T.Q''.initS], "scheduler"!"listen" @ [T.Q''.listenS],
                            "scheduler"!"accept" @ [T.Q''.acceptS], "scheduler"!"close" @ [T.Q''.closeS],
                            "scheduler"!"spawn" @ [T.Q''.spawnS], "scheduler"!"exit" @ [T.Q''.exitS],
                            "httpq"!"send" @ [MyHttpQ.sendS] ]]
  bmodule "xml_driver" {{
    bfunctionNoRet "handler"("fr", "inbuf", "len", "outbuf", "q", "tmp", "tmp2") [handlerS]
      "inbuf" <-- Call "buffers"!"bmalloc"(buf_size)
      [Al fs, PREmain[_, R] sched fs * globalInv fs * R =?>8 bsize * mallocHeap 0];;

      "outbuf" <-- Call "buffers"!"bmalloc"(buf_size)
      [Al fs, PREmain[V, R] sched fs * globalInv fs * V "inbuf" =?>8 bsize * R =?>8 bsize * mallocHeap 0];;

      "q" <-- Call "malloc"!"malloc"(0, 2)
      [Al fs, PREmain[V, R] sched fs * globalInv fs * R =?> 2
        * V "inbuf" =?>8 bsize * V "outbuf" =?>8 bsize * mallocHeap 0];;

      [Al fs, PREmain[V] sched fs * globalInv fs * V "q" =?> 2
        * V "inbuf" =?>8 bsize * V "outbuf" =?>8 bsize * mallocHeap 0]
      While (1 = 1) {
        "fr" <-- Call "scheduler"!"accept"($[globalSock])
        [Al fs, PREmain[V, R] [| R %in fs |] * sched fs * globalInv fs * V "q" =?> 2
          * V "inbuf" =?>8 bsize * V "outbuf" =?>8 bsize * mallocHeap 0];;

        "len" <-- Call "http"!"readRequest"("fr", "inbuf", bsize)
        [Al fs, PREmain[V, R] [| V "fr" %in fs |] * sched fs * globalInv fs * V "q" =?> 2
          * V "inbuf" =?>8 bsize * V "outbuf" =?>8 bsize * mallocHeap 0];;

        If ("len" > bsize) {
          Call "sys"!"abort"()
          [PREonly[_] [| False |] ];;
          Fail
        } else {
          Assert [Al fs, PREmain[V] [| V "fr" %in fs |] * sched fs * globalInv fs * V "q" =?> 2
            * buffer_splitAt (wordToNat (V "len")) (V "inbuf") bsize
            * V "outbuf" =?>8 bsize * mallocHeap 0
            * [| wordToNat (V "len") <= bsize |]%nat ];;

          Assert [Al fs, PREmain[V] [| V "fr" %in fs |] * sched fs * globalInv fs * V "q" =?> 2
            * V "inbuf" =?>8 wordToNat (V "len")
            * (V "inbuf" ^+ natToW (wordToNat (V "len"))) =?>8 (bsize - wordToNat (V "len"))
            * V "outbuf" =?>8 bsize * mallocHeap 0 * [| wordToNat (V "len") <= bsize |]%nat ];;

          Note [unfold_here];;

          "q" *<- 0;;
          "tmp" <- "inbuf" + "len";;
          "tmp2" <- bsize - "len";;
          "tmp" <-- Call "xml_prog"!"main"("tmp", "tmp2", "outbuf", bsize, "q")
          [Al fs, Al q, PREmain[V, R] [| V "fr" %in fs |] * sched fs * globalInv fs
            * V "q" =*> q * (V "q" ^+ $4) =?> 1 * httpq q
            * V "inbuf" =?>8 wordToNat (V "len")
            * (V "inbuf" ^+ natToW (wordToNat (V "len"))) =?>8 (bsize - wordToNat (V "len"))
            * V "outbuf" =?>8 bsize
            * mallocHeap 0 * [| wordToNat (V "len") <= bsize |]%nat ];;

          Assert [Al fs, Al q, PREmain[V] [| V "fr" %in fs |] * sched fs * globalInv fs
            * V "q" =*> q * (V "q" ^+ $4) =?> 1 * httpq q
            * buffer_joinAt (wordToNat (V "len")) (V "inbuf") bsize
            * V "outbuf" =?>8 bsize * mallocHeap 0 ];;

          Assert [Al fs, Al q, PREmain[V] [| V "fr" %in fs |] * sched fs * globalInv fs
            * V "q" =*> q * (V "q" ^+ $4) =?> 1 * httpq q
            * V "inbuf" =?>8 bsize
            * V "outbuf" =?>8 bsize * mallocHeap 0 ];;

          Call "http"!"writeResponse"("fr", "outbuf", "tmp", bsize)
          [Al fs, Al q, PREmain[V] [| V "fr" %in fs |] * sched fs * globalInv fs
            * V "q" =*> q * (V "q" ^+ $4) =?> 1 * httpq q
            * V "inbuf" =?>8 bsize
            * V "outbuf" =?>8 bsize * mallocHeap 0 ];;

          "tmp" <-* "q";;
          Call "httpq"!"send"("tmp")
          [Al fs, PREmain[V] [| V "fr" %in fs |] * sched fs * globalInv fs
            * V "q" =?> 2
            * V "inbuf" =?>8 bsize
            * V "outbuf" =?>8 bsize * mallocHeap 0 ]
        };;

        Call "scheduler"!"close"("fr")
        [Al fs, PREmain[V] sched fs * globalInv fs * V "q" =?> 2
          * V "inbuf" =?>8 bsize * V "outbuf" =?>8 bsize * mallocHeap 0]
      }
    end with bfunctionNoRet "main"("fr", "x") [mainS]
      Init
      [Al fs, Al v, PREmain[_] sched fs * globalSock =*> v * db ts * mallocHeap 0];;

      "fr" <- 0;;
      [Al fs, PREmain[_] sched fs * globalSock =?> 1 * db ts * mallocHeap 0]
      While ("fr" < numWorkers) {
        Spawn("xml_driver"!"handler", 100)
        [Al fs, PREmain[_] sched fs * globalSock =?> 1 * db ts * mallocHeap 0];;
        "fr" <- "fr" + 1
      };;

      "fr" <-- Call "scheduler"!"listen"(port)
      [Al fs, Al v, PREmain[_, R] [| R %in fs |] * sched fs * globalSock =*> v
        * db ts * mallocHeap 0];;

      globalSock *<- "fr";;

      Exit 50
    end
  }}.

Lemma buf_size_lower'' : (buf_size < Npow2 32)%N.
  eapply Nlt_trans; [ | apply (Buf_size_upper _ _ _ _ Wf) ].
  specialize (Buf_size_lower _ _ _ _ Wf); intros.
  pre_nomega.
  rewrite N2Nat.inj_mul.
  simpl.
  generalize dependent (N.to_nat buf_size); intros.
  change (Pos.to_nat 2) with 2 in *.
  change (Pos.to_nat 4) with 4.
  omega.
Qed.

Lemma buf_size_lower' : natToW 2 <= NToW buf_size.
  unfold NToW.
  rewrite NToWord_nat.
  pre_nomega.
  rewrite wordToNat_natToWord_idempotent.
  generalize (Buf_size_lower _ _ _ _ Wf).
  intros; nomega.
  rewrite N2Nat.id.
  apply buf_size_lower''.
Qed.

Local Hint Immediate buf_size_lower'.

Close Scope Sep_scope.

Lemma bsize_in : (wordToNat (NToW buf_size) * 4) = bsize.
  unfold NToW, bsize.
  rewrite NToWord_nat.
  rewrite N2Nat.inj_mul.
  rewrite wordToNat_natToWord_idempotent.
  auto.
  rewrite N2Nat.id.
  apply buf_size_lower''.
Qed.

Lemma bsize_roundTrip : wordToNat (natToW bsize) = bsize.
  apply wordToNat_natToWord_idempotent.
  unfold bsize.
  rewrite N2Nat.id.
  apply (Buf_size_upper _ _ _ _ Wf).
Qed.

Hint Rewrite bsize_in bsize_roundTrip : sepFormula.
Hint Rewrite bsize_roundTrip : N.

Hint Extern 1 (_ ?X = 0) =>
  match type of X with
    | list ?A => equate X (@nil A); reflexivity
  end.

Lemma inBounds_nil : forall n, RelDb.inBounds n nil.
  constructor.
Qed.

Hint Immediate inBounds_nil.

Lemma freeable8_8 : forall p n,
  n = 8
  -> freeable p 2
  -> freeable8 p n.
  intros; subst; eexists; split; eauto; eauto.
Qed.

Hint Immediate freeable8_8.

Lemma arrays_begone : forall specs P p q,
  himp specs P (P * (array nil p * array nil q))%Sep.
  unfold array; sepLemma.
Qed.

Hint Immediate arrays_begone.

Lemma bsize_bound : forall w : W,
  w <= natToW bsize
  -> (wordToNat w <= bsize)%nat.
  intros.
  nomega.
Qed.

Hint Immediate bsize_bound.

Ltac t0 := sep unf hints; eauto.

Ltac t1 := unf; unfold localsInvariantMain; post; evaluate hints; descend;
  try match_locals; sep unf hints; eauto.

Ltac t :=
  try match goal with
        | [ |- context[unfold_here] ] => unfold buffer; generalize (NotTooGreedy _ _ _ _ Wf)
      end; try solve [ t0 ]; t1.

Ltac u := abstract t.

Theorem ok0 : moduleOk m0.
  vcgen; abstract t.
Qed.

Section boot.
  Definition heapSize' := Hide.to_nat heapSize.

  Hypothesis heapSizeLowerBound : (3 <= heapSize)%N.

  Let heapSizeLowerBound' : (3 <= heapSize')%nat.
    intros; unfold heapSize'; rewrite Hide.to_nat_eq.
    assert (heapSize >= 3)%N by (apply N.le_ge; apply heapSizeLowerBound); nomega.
  Qed.

  Definition size := heapSize' + 50 + 2 + length ts.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize' * 4).
    goodSize.
  Qed.

  Lemma heapSizeLowerBound'' : natToW 3 <= NToW heapSize.
    hnf; intros.
    red in H.
    pre_nomega.
    rewrite wordToNat_natToWord_idempotent in H by reflexivity.
    unfold heapSize' in *.
    rewrite Hide.to_nat_eq in *.
    unfold NToW in *.
    rewrite NToWord_nat in *.
    rewrite wordToNat_natToWord_idempotent in H.
    omega.
    rewrite N2Nat.id.
    eapply goodSize_weaken in mem_size.
    2: instantiate (1 := N.to_nat heapSize); unfold size.
    Transparent goodSize.
    unfold goodSize in *.
    rewrite N2Nat.id in *.
    assumption.
    unfold heapSize'.
    rewrite Hide.to_nat_eq.
    omega.
  Qed.

  Hint Immediate heapSizeLowerBound''.

  Definition bootS := {|
    Reserved := 49;
    Formals := nil;
    Precondition := fun _ => st ~> ![ 0 =?> (heapSize' + 50 + 2) * db ts ] st
  |}.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "xml_driver"!"main" @ [mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%N;;

        Assert [PREmain[_] globalSched =?> 2 * 0 =?> heapSize' * db ts];;

        Call "malloc"!"init"(0, heapSize)
        [PREmain[_] globalSock =?> 1 * globalSched =?> 1 * mallocHeap 0 * db ts];;

        Goto "xml_driver"!"main"
      end
    }}.

  Lemma bootstrap_Sp_nonzero : forall sp : W,
    sp = 0
    -> sp = (heapSize' * 4)%nat
    -> goodSize (heapSize' * 4)
    -> False.
    intros; eapply bootstrap_Sp_nonzero; try eassumption; eauto.
  Qed.

  Lemma bootstrap_Sp_freeable : forall sp : W,
    sp = (heapSize' * 4)%nat
    -> freeable sp 50.
    intros; eapply bootstrap_Sp_freeable; try eassumption; eauto.
    instantiate (1 := 2).
    unfold size in mem_size.
    eapply goodSize_weaken; try apply mem_size.
    omega.
  Qed.

  Lemma noWrap : noWrapAround 4 (wordToNat (NToW heapSize) - 1).
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize' in *; rewrite Hide.to_nat_eq in *.
    rewrite wordToNat_natToWord_idempotent.
    apply noWrap; eauto.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Local Hint Immediate bootstrap_Sp_nonzero bootstrap_Sp_freeable noWrap.

  Lemma break : NToW ((heapSize + 50) * 4)%N = ((heapSize' + 50) * 4)%nat.
    intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; rewrite N2Nat.inj_add; auto.
  Qed.

  Lemma times4 : (Hide.heapSize4 heapSize : W) = (heapSize' * 4)%nat.
    rewrite Hide.heapSize4_eq; intros.
    unfold NToW; rewrite NToWord_nat by auto.
    unfold heapSize'; rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; auto.
  Qed.

  Lemma wordToNat_heapSize : wordToNat (NToW heapSize) = heapSize'.
    unfold heapSize'; rewrite Hide.to_nat_eq.
    unfold NToW.
    rewrite NToWord_nat.
    apply wordToNat_natToWord_idempotent.
    eapply goodSize_weaken.
    2: instantiate (1 := (heapSize' * 4)%nat).
    auto.
    unfold heapSize'; rewrite Hide.to_nat_eq; auto.
  Qed.

  Hint Rewrite break times4 wordToNat_heapSize : sepFormula.

  Lemma globalSched_plus4 :
    Locations.globalSched ^+ natToW 4 = natToW ((heapSize' + 50) * 4 + 4).
    unfold Locations.globalSched, heapSize'.
    rewrite wplus_alt; unfold wplusN, wordBinN.
    unfold NToW; rewrite NToWord_nat by auto.
    rewrite N2Nat.inj_mul; auto.
    rewrite Hide.to_nat_eq; rewrite N2Nat.inj_add; auto.
    change (wordToNat (natToW 4)) with 4.
    change (N.to_nat 4) with 4.
    rewrite wordToNat_natToWord_idempotent.
    reflexivity.
    eapply goodSize_weaken; try apply mem_size.
    unfold size, heapSize'.
    rewrite Hide.to_nat_eq.
    change (N.to_nat 50) with 50.
    omega.
  Qed.

  Hint Rewrite globalSched_plus4 : sepFormula.

  Ltac t := unfold M'''.globalSched, Locations.globalSched, Locations.globalSock, localsInvariantMain;
    genesis; rewrite natToW_plus; reflexivity.

  Theorem okb : moduleOk boot.
    unfold boot; rewrite <- Hide.heapSize4_eq; vcgen; abstract t.
  Qed.

  Global Opaque heapSize'.

  Lemma buf_size_upper' : goodSize (4 * wordToNat (NToWord 32 buf_size)).
    red.
    rewrite Nat2N.inj_mul.
    rewrite NToWord_nat.
    rewrite wordToNat_natToWord_idempotent.
    rewrite N2Nat.id.
    rewrite Nmult_comm.
    apply (Buf_size_upper _ _ _ _ Wf).
    rewrite N2Nat.id.
    clear; generalize (Buf_size_upper _ _ _ _ Wf).
    generalize (Npow2 32).
    Hint Rewrite N2Nat.inj_mul : N.
    intros; nomega.
  Qed.

  Definition m1 := link boot m0.
  Definition m2 := link Buffers.m m1.
  Definition m3 := link XmlLex.m m2.
  Definition m4 := link ArrayOps.m m3.
  Definition m5 := link NumOps.m m4.
  Definition m6 := link MyIo.m m5.
  Definition m7 := link MyHttp.m m6.
  Definition m8 := link MyHttpQ.m m7.
  Definition m9 := link T.m m8.

  Definition m := link (XmlLang.m _ httpq
    buf_size_lower' buf_size_upper'
    (WellFormed _ _ _ _ Wf) (ND _ _ _ _ Wf)
    (GoodSchema _ _ _ _ Wf)) m9.

  Lemma ok1 : moduleOk m1.
    link okb ok0.
  Qed.

  Lemma ok2 : moduleOk m2.
    link Buffers.ok ok1.
  Qed.

  Lemma ok3 : moduleOk m3.
    link XmlLex.ok ok2.
  Qed.

  Lemma ok4 : moduleOk m4.
    link ArrayOps.ok ok3.
  Qed.

  Lemma ok5 : moduleOk m5.
    link NumOps.ok ok4.
  Qed.

  Lemma ok6 : moduleOk m6.
    link MyIo.ok ok5.
  Qed.

  Lemma ok7 : moduleOk m7.
    link MyHttp.ok ok6.
  Qed.

  Lemma ok8 : moduleOk m8.
    link MyHttpQ.ok ok7.
  Qed.

  Lemma ok9 : moduleOk m9.
    link T.ok ok8.
  Qed.

  Lemma ok : moduleOk m.
    link (XmlLang.ok _ httpq buf_size_lower' buf_size_upper' (WellFormed _ _ _ _ Wf)) ok9;
    apply (UF _ _ _ _ Wf).
  Qed.

  Variable stn : settings.
  Variable prog : IL.program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis prec : forall specs, interp specs (Precondition bootS None (stn, st)).

  Import Safety.

  Theorem safe : sys_safe stn prog (w, st).
    eapply safety; try eassumption; [
      link_simp; unfold labelSys, labelSys'; simpl; tauto
      | apply ok
      | apply LabelMap.find_2; link_simp; reflexivity
      | auto ].
  Qed.
End boot.

End Make.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <guoyu@ustc.edu.cn>                                       *)
(*                          School of Computer Science and Technology, USTC   *)
(*                                                                            *)
(*           Yishuai Li <lyishuai@mail.ustc.edu.cn>                           *)
(*                                         School of the Gifted Young, USTC   *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import ListEx.
Require Import Monad.

Require Import Params.
Require Import Nand.
Require Import Data.
Require Import FtlFast.

Open Scope list_scope.

Definition write_command : Set := (block_no * page_off * char) %type.

Import NewNand.
Import NandData.

(* Test NAND *)

Fixpoint nand_write_batch (c: chip) (wl : list write_command)
  : op_result chip :=
  match wl with
    | nil => ret c
    | cons wr wl' =>
      let (pn, char) := wr in
      let (b, off) := pn in
      do c' <== nand_write_page c b off (mkdata_chars (char::nil)) mkoob_empty;
      nand_write_batch c' wl'
  end.

Compute (
  let wl := (0,0,c_a) :: nil in
  do c0 <-- Some nand_init;
  do c <== nand_write_batch c0 wl;
  ret c).

Compute (
  let wl := (0,0,c_a) :: (0,1,c_a) :: nil in
  do c0 <-- Some nand_init;
  do c <== nand_write_batch c0 wl;
  ret c).

Compute (
  let wl := (0,0,c_a) :: (0,1,c_a) :: nil in
  do c0 <-- Some nand_init;
  do c <== nand_write_batch c0 wl;
  do c'<== nand_erase_block c 0;
  ret c').

(* Test NAND *)

Fixpoint ftl_write_batch (c: chip)(f: FTL) (wl : list write_command)
  : op_result (chip * FTL) :=
  match wl with
    | nil => ret (c, f)
    | cons wr wl' =>
      let (pn, char) := wr in
      let (b, off) := pn in
      do [c', f'] <== ftl_write c f b off (mkdata_chars (char::nil));
      ftl_write_batch c' f' wl'
  end.

Let c0 := nand_init.
Let f0 := ftl_init.

Compute (
  let wl := (0,0,c_a) :: nil in
  do [c, f] <== ftl_write_batch c0 f0 wl;
  ret (c, f)).

Compute (
  let wl := (0,0,c_a)::(0,1,c_b)::(0,0,c_c)::(0,0,c_d)::
nil in
  do c0 <-- Some nand_init;
  do f0 <-- Some ftl_init;
  do [c, f] <== ftl_write_batch c0 f0 wl;
  ret (c, f)).


Coq < Section Easy012.

Coq < Require Import Classical.

Coq < Load CptdTactics.
Error: Can't find file CptdTactics.v on loadpath

Coq < Load CpdtTactics.

Coq < Variables I J K L: Prop.
I is assumed
J is assumed
K is assumed
L is assumed

Coq < Goal ((I /\ J) /\ (K /\ L)) -> (I /\ L).
1 subgoal

  I : Prop
  J : Prop
  K : Prop
  L : Prop
  ============================
   (I /\ J) /\ K /\ L -> I /\ L

Unnamed_thm < crush.
No more subgoals.

Unnamed_thm < Qed.
crush.

Unnamed_thm is defined


Require Import
        CertifiedExtraction.Extraction.DeallocSCA
        CertifiedExtraction.Extraction.External.Core.

Lemma CompileWhileFalse:
  forall {av} (env : GLabelMap.t (FuncSpec av)) (ext : StringMap.t (Value av))
    (tenv : Telescope av) tenv' test body,
    TelEq ext tenv tenv' ->
    Lifted_is_false ext tenv test ->
    {{ tenv }} (DFacade.While test body) {{ tenv' }} ∪ {{ ext }} // env.
Proof.
  intros * H **.
  rewrite <- H; clear H.
  repeat match goal with
         | [ H: forall st, st ≲ _ ∪ _ -> _, H': ?st ≲ _ ∪ _ |- _ ] => learn (H _ H')
         | [ H: is_true ?t ?st, H': is_false ?t ?st |- _ ] => exfalso; exact (is_true_is_false_contradiction H H')
         | _ => SameValues_Facade_t_step
         | _ => facade_cleanup_call
         | _ => LiftPropertyToTelescope_t
         | _ => apply SafeWhileFalse
         | [ H: RunsTo _ (DFacade.While _ _) _ _ |- _ ] => inversion H; unfold_and_subst; clear H
         end.
Qed.

Lemma CompileWhileTrue:
  forall {av} (env : GLabelMap.t (FuncSpec av)) (ext : StringMap.t (Value av))
    (tenv : Telescope av) tenv' tenv'' test body,
    Lifted_is_true ext tenv test ->
    {{ tenv }}  body                      {{ tenv' }}  ∪ {{ ext }} // env ->
    {{ tenv' }} (DFacade.While test body) {{ tenv'' }} ∪ {{ ext }} // env ->
    {{ tenv }}  (DFacade.While test body) {{ tenv'' }} ∪ {{ ext }} // env.
Proof.
  repeat match goal with
         | [ H: forall st, st ≲ _ ∪ _ -> _, H': ?st ≲ _ ∪ _ |- _ ] => learn (H _ H')
         | [ H: is_true ?t ?st, H': is_false ?t ?st |- _ ] => exfalso; exact (is_true_is_false_contradiction H H')
         | _ => SameValues_Facade_t_step
         | _ => facade_cleanup_call
         | _ => LiftPropertyToTelescope_t
         | _ => apply SafeWhileTrue
         | [ H: RunsTo _ (DFacade.While _ _) _ _ |- _ ] => inversion H; unfold_and_subst; clear H
         end.
Qed.

Lemma CompileWhileFalse_Loop:
  forall {av} (vtest : StringMap.key)
    (env : GLabelMap.t (FuncSpec av)) (ext : StringMap.t (Value av))
    (tenv : Telescope av) tenv' body,
    TelEq ext tenv tenv' ->
    vtest ∉ ext ->
    NotInTelescope vtest tenv ->
    {{[[`vtest ->> (Word.natToWord 32 1) as _]]::tenv }}
      (DFacade.While (TestE IL.Eq vtest O) body)
    {{ tenv' }} ∪ {{ ext }} // env.
Proof.
  intros * H **.
  rewrite <- H.
  apply CompileDeallocW_discretely; eauto.
  apply CompileWhileFalse.
  reflexivity.
  unfold Lifted_is_false, LiftPropertyToTelescope, is_true, is_false, eval_bool, eval;
  repeat match goal with
         | _ => SameValues_Facade_t_step
         | _ => facade_cleanup_call
         | _ => progress simpl
         end.
Qed.


(* from https://github.com/amintimany/monotone *)
From iris.algebra Require Export cmra auth.
From transfinite.base_logic Require Import base_logic.
Local Arguments validN _ _ _ !_ /.
Local Arguments valid _ _  !_ /.
Local Arguments op _ _ _ !_ /.
Local Arguments pcore _ _ !_ /.
Local Arguments ofe_dist !_ /.
Local Arguments ofe_equiv ! _ /.

Definition monotone {A : Type} (R : relation A) : Type := list A.

Definition principal {A : Type} (R : relation A) (a : A) :
  monotone R := [a].

Section monotone.
Local Set Default Proof Using "Type".
Context `{SI: indexT}.
Context {A : ofe} {R : relation A}.
Implicit Types a b : A.
Implicit Types x y : monotone R.

Definition Below (a : A) (x : monotone R) := ∃ b, b ∈ x ∧ R a b.

Lemma Below_app a x y : Below a (x ++ y) ↔ Below a x ∨ Below a y.
Proof.
  split.
  - intros (b & [|]%elem_of_app & ?); [left|right]; exists b; eauto.
  - intros [(b & Hb1 & Hb2)|(b & Hb1 & Hb2)]; exists b; rewrite elem_of_app; eauto.
Qed.

Lemma Below_principal a b : Below a (principal R b) ↔ R a b.
Proof.
  split.
  - intros (c & ->%elem_of_list_singleton & ?); done.
  - intros Hab; exists b; split; first apply elem_of_list_singleton; done.
Qed.

(* OFE *)
Instance monotone_dist : Dist (monotone R) :=
  λ n x y, ∀ a, Below a x ↔ Below a y.

Instance monotone_equiv : Equiv (monotone R) := λ x y, ∀ n, x ≡{n}≡ y.

Definition monotone_ofe_mixin : OfeMixin (monotone R).
Proof.
  split.
  - rewrite /equiv /monotone_equiv /dist /monotone_dist; intuition auto using O.
  - intros n; split.
    + rewrite /dist /monotone_dist /equiv /monotone_equiv; intuition.
    + rewrite /dist /monotone_dist /equiv /monotone_equiv; intros ? ? Heq a.
      split; apply Heq.
    + rewrite /dist /monotone_dist /equiv /monotone_equiv;
        intros ? ? ? Heq Heq' a.
      split; intros Hxy.
      * apply Heq'; apply Heq; auto.
      * apply Heq; apply Heq'; auto.
  - intros n x y; rewrite /dist /monotone_dist; auto.
Qed.
Canonical Structure monotoneC := Ofe (monotone R) monotone_ofe_mixin.

(* CMRA *)
Instance monotone_validN : ValidN (monotone R) := λ n x, True.
Instance monotone_valid : Valid (monotone R) := λ x, True.

Program Instance monotone_op : Op (monotone R) := λ x y, x ++ y.
Instance monotone_pcore : PCore (monotone R) := Some.

Instance monotone_comm : Comm (≡) (@op (monotone R) _).
Proof.
  intros x y n a; rewrite /Below.
  setoid_rewrite elem_of_app; split=> Ha; firstorder.
Qed.
Instance monotone_assoc : Assoc (≡) (@op (monotone R) _).
Proof.
  intros x y z n a; rewrite /Below /=.
  repeat setoid_rewrite elem_of_app; split=> Ha; firstorder.
Qed.
Lemma monotone_idemp (x : monotone R) : x ⋅ x ≡ x.
Proof.
  intros n a; rewrite /Below.
  setoid_rewrite elem_of_app; split=> Ha; firstorder.
Qed.

Instance monotone_validN_ne n :
  Proper (dist n ==> impl) (@validN _ (monotone R) _ n).
Proof. intros x y ?; rewrite /impl; auto. Qed.
Instance monotone_validN_proper n : Proper (equiv ==> iff) (@validN _ (monotone R) _ n).
Proof. move=> x y /equiv_dist H; auto. Qed.

Instance monotone_op_ne' x : NonExpansive (op x).
Proof.
  intros n y1 y2; rewrite /dist /monotone_dist /equiv /monotone_equiv /Below.
  rewrite /=; setoid_rewrite elem_of_app => Heq a.
  specialize (Heq a); destruct Heq as [Heq1 Heq2].
  split; intros [b [[Hb|Hb] HRb]]; eauto.
  - destruct Heq1 as [? [? ?]]; eauto.
  - destruct Heq2 as [? [? ?]]; eauto.
Qed.
Instance monotone_op_ne : NonExpansive2 (@op (monotone R) _).
Proof. by intros n x1 x2 Hx y1 y2 Hy; rewrite Hy !(comm _ _ y2) Hx. Qed.
Instance monotone_op_proper :
  Proper ((≡) ==> (≡) ==> (≡)) (@op (monotone R) _) := ne_proper_2 _.

Lemma monotone_included (x y : monotone R) : x ≼ y ↔ y ≡ x ⋅ y.
Proof.
  split; [|by intros ?; exists y].
  by intros [z Hz]; rewrite Hz assoc monotone_idemp.
Qed.

Definition monotone_cmra_mixin : CmraMixin (monotone R).
Proof.
  apply cmra_total_mixin; try apply _ || by eauto.
  - intros ?; apply monotone_idemp.
  - rewrite /equiv /monotone_equiv /dist /monotone_dist; eauto.
Qed.
Canonical Structure monotoneR : cmra := Cmra (monotone R) monotone_cmra_mixin.

Global Instance monotone_cmra_total : CmraTotal monotoneR.
Proof. rewrite /CmraTotal; eauto. Qed.
Global Instance monotone_core_id (x : monotone R) : CoreId x.
Proof. by constructor. Qed.

Global Instance monotone_cmra_discrete : CmraDiscrete monotoneR.
Proof.
  split; auto.
  intros ? ?.
  rewrite /dist /equiv /= /cmra_dist /cmra_equiv /=
          /monotone_dist /monotone_equiv /dist /monotone_dist; eauto.
Qed.

Instance monotone_empty : Unit (monotone R) := @nil A.
Lemma auth_ucmra_mixin : UcmraMixin (monotone R).
Proof. split; done. Qed.

Canonical Structure monotoneUR := Ucmra (monotone R) auth_ucmra_mixin.

Global Instance principal_ne
       `{HRne : !∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} :
  NonExpansive (principal R).
Proof. intros n a1 a2 Ha; split; rewrite /= !Below_principal !Ha; done. Qed.

Global Instance principal_proper
       {HRne : ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R} :
  Proper ((≡) ==> (≡)) (principal R) := ne_proper _.

Global Instance principal_discrete a : Discrete (principal R a).
Proof.
  intros y; rewrite /dist /ofe_dist /= /equiv /ofe_equiv /= /monotone_equiv;
    eauto.
Qed.

Lemma principal_injN_general n a b :
  principal R a ≡{n}≡ principal R b → R a a → R a b.
Proof.
  rewrite /principal /dist /monotone_dist => Hab Haa.
  - destruct (Hab a) as [Ha _]; edestruct Ha as [? [?%elem_of_list_singleton ?]];
    subst; eauto.
    eexists _; split; first apply elem_of_list_singleton; eauto.
Qed.

Lemma principal_inj_general a b :
  principal R a ≡ principal R b → R a a → R a b.
Proof. intros Hab; apply (principal_injN_general (@index_zero _)); eauto. Qed.

Global Instance principal_injN_general' `{!Reflexive R} n :
  Inj (λ a b, R a b ∧ R b a) (dist n) (principal R).
Proof.
  intros x y Hxy; split; eapply (principal_injN_general n); eauto.
Qed.

Global Instance principal_inj_general' `{!Reflexive R} :
  Inj (λ a b, R a b ∧ R b a) (≡) (principal R).
Proof.
  intros x y Hxy; specialize (Hxy (@index_zero _)); eapply principal_injN_general'; eauto.
Qed.

Global Instance principal_injN `{!Reflexive R} {Has : AntiSymm (≡) R} n :
  Inj (dist n) (dist n) (principal R).
Proof.
  intros x y [Hxy Hyx]%principal_injN_general'.
  erewrite (@anti_symm _ _ _ Has); eauto.
Qed.
Global Instance principal_inj `{!Reflexive R} `{!AntiSymm (≡) R} :
  Inj (≡) (≡) (principal R).
Proof. intros ???. apply equiv_dist=>n. by apply principal_injN, equiv_dist. Qed.

Lemma principal_R_opN_base `{!Transitive R} n x y :
  (∀ b, b ∈ y → ∃ c, c ∈ x ∧ R b c) → y ⋅ x ≡{n}≡ x.
Proof.
  intros HR; split; rewrite /op /monotone_op Below_app; [|by firstorder].
  intros [(c & (d & Hd1 & Hd2)%HR & Hc2)|]; [|done].
  exists d; split; [|transitivity c]; done.
Qed.

Lemma principal_R_opN `{!Transitive R} n a b :
  R a b → principal R a ⋅ principal R b ≡{n}≡ principal R b.
Proof.
  intros; apply principal_R_opN_base; intros c; rewrite /principal.
  setoid_rewrite elem_of_list_singleton => ->; eauto.
Qed.

Lemma principal_R_op `{!Transitive R} a b :
  R a b → principal R a ⋅ principal R b ≡ principal R b.
Proof. by intros ? ?; apply principal_R_opN. Qed.

Lemma principal_op_RN n a b x :
  R a a → principal R a ⋅ x ≡{n}≡ principal R b → R a b.
Proof.
  intros Ha HR.
  destruct (HR a) as [[z [HR1%elem_of_list_singleton HR2]] _];
    last by subst; eauto.
  rewrite /op /monotone_op /principal Below_app Below_principal; auto.
Qed.

Lemma principal_op_R a b x :
  R a a → principal R a ⋅ x ≡ principal R b → R a b.
Proof. intros ? ?; eapply (principal_op_RN (@index_zero _)); eauto. Qed.

Lemma principal_op_R' `{!Reflexive R} a b x :
  principal R a ⋅ x ≡ principal R b → R a b.
Proof. intros; eapply principal_op_R; eauto. Qed.

Lemma principal_includedN `{!PreOrder R} n a b :
  principal R a ≼{n} principal R b ↔ R a b.
Proof.
  split.
  - intros [z Hz]; eapply principal_op_RN; last by rewrite Hz; eauto.
    reflexivity.
  - intros ?; exists (principal R b); rewrite principal_R_opN; eauto.
Qed.

Lemma principal_included `{!PreOrder R} a b :
  principal R a ≼ principal R b ↔ R a b.
Proof.
  split.
  - intros [z Hz]; eapply principal_op_R; last by rewrite Hz; eauto.
    reflexivity.
  - intros ?; exists (principal R b); rewrite principal_R_op; eauto.
Qed.

(** Internalized properties *)
Lemma monotone_equivI `{!(∀ n : _, Proper (dist n ==> dist n ==> iff) R)}
      `{!Reflexive R} `{!AntiSymm (≡) R} {M} a b :
  principal R a ≡ principal R b ⊣⊢ (a ≡ b : uPred M).
Proof.
  uPred.unseal. do 2 split.
  - intros Hx. exact: principal_injN.
  - intros Hx. exact: principal_ne.
Qed.

Lemma monotone_local_update_grow `{!Transitive R} a q na:
  R a na →
  (principal R a, q) ~l~> (principal R na, principal R na).
Proof.
  intros Hana Hanb.
  apply local_update_unital_discrete.
  intros z _ Habz.
  split; first done.
  intros n; specialize (Habz n).
  intros x; split.
  - intros (y & ->%elem_of_list_singleton & Hy2).
    by exists na; split; first constructor.
  - intros (y & [->|Hy1]%elem_of_cons & Hy2).
    + by exists na; split; first constructor.
    + exists na; split; first constructor.
      specialize (Habz x) as [_ [c [->%elem_of_list_singleton Hc2]]].
      { exists y; split; first (by apply elem_of_app; right); eauto. }
      etrans; eauto.
Qed.

Lemma monotone_local_update_get_frag `{!PreOrder R} a na:
  R na a →
  (principal R a, ε) ~l~> (principal R a, principal R na).
Proof.
  intros Hana.
  apply local_update_unital_discrete.
  intros z _.
  rewrite left_id.
  intros <-.
  split; first done.
  apply monotone_included.
  by apply principal_included.
Qed.

Lemma monotone_update `{!PreOrder R} a b c:
  R a b →
  R c b →
  ● principal R a ~~> ● principal R b ⋅ ◯ principal R c.
Proof.
  intros Hab Hcb.
  etrans.
  { apply auth_update_alloc; apply (monotone_local_update_grow _ _ b); done. }
  etrans; first apply cmra_update_op_l.
  apply auth_update_alloc.
  apply monotone_local_update_get_frag; done.
Qed.

End monotone.

Arguments monotoneC {_ _} _.
Arguments monotoneR {_ _} _.
Arguments monotoneUR {_ _} _.

(** Having an instance of this class for a relation R allows almost
all lemmas provided in this module to be used. See type classes
required by some of preceding the lemmas and instances in the to see
how this works.

The only lemma that requires extra conditions on R is the injectivity
of principal which requires antisymmetry. *)
Class ProperPreOrder {A : Type} `{Dist A} (R : relation A) := {
  ProperPreOrder_preorder :> PreOrder R;
  ProperPreOrder_ne :> ∀ n, Proper ((dist n) ==> (dist n) ==> iff) R
}.


Require Import VST.floyd.proofauto.
Require Import VST.progs.even.
Require Import VST.progs.verif_evenodd_spec.

Local Open Scope assert.

Definition Gprog : funspecs :=
     ltac:(with_library prog [odd_spec; even_spec; main_spec]).

Lemma body_even : semax_body Vprog Gprog f_even even_spec.
Proof.
start_function.
forward_if.
*
 forward.
*
  forward_call (z-1, tt).
  (* Prove that PROP precondition is OK *)
  rep_omega.
  (* After the call *)
  forward.
  entailer!.
  rewrite Z.odd_sub; simpl.
  case_eq (Z.odd z); rewrite Zodd_even_bool; destruct (Z.even z); simpl; try congruence.
Qed.

Lemma body_main : semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
forward_call (42).
rep_omega.
forward.
Qed.

(* The Espec for odd is different from the Espec for even;
  the former has only "even" as an external function, and vice versa. *)
Definition Espec := add_funspecs NullExtension.Espec (ext_link_prog even.prog) Gprog.
Existing Instance Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons_ext.
semax_func_cons body_even.
semax_func_cons body_main.
Qed.


From Coq Require Import List.
Import ListNotations.

From CasperCBC Require Import Lib.ListExtras VLSM.Common.

(** * VLSM Plans *)

Section plans.
  Context
    {message : Type}
    {T : VLSM_type message}.

  (** A plan is a (sequence of actions) which can be attempted on a
  given state to yield a trace.
  A [plan_item] is a singleton plan, and contains a label and an input
  which would allow to transition from any given state
  (note that we don't address validity for now)
  *)
  Record plan_item :=
    { label_a : label;
      input_a : option message
    }.

End plans.

Section apply_plans.

  Context
    {message : Type}
    {T : VLSM_type message}
    {transition : label -> state * option message -> state * option message}
    .

  (** If we don't concern ourselves with the validity of the traces obtained
  upon applying a plan, then a [VLSM_type] and a [transition] function
  suffice for defining plan application and related results.
  The advantage of this approach is that the same definition works for
  pre_loaded versions as well as for all constrained variants of a composition.
  *)

  (** Applying a plan (list of [plan_item]s) to a state we obtain a
  final state and a trace. We define that in the [_apply_plan] definition below
  using a folding operation on the [_apply_plan_folder] function.
  *)
  Definition _apply_plan_folder
    (a : plan_item)
    (sl : state * list transition_item)
    : state * list transition_item
    :=
    let (s, items) := sl in
    match a with {| label_a := l'; input_a := input' |} =>
      let (dest, out) := (transition l' (s, input')) in
      (dest
      , {| l := l';
           input := input';
           output := out;
           destination := dest
         |} :: items)
    end.

  Lemma _apply_plan_folder_additive
    (start : state)
    (aitems : list plan_item)
    (seed_items : list transition_item)
    : let (final, items) := fold_right _apply_plan_folder (start, []) aitems in
      fold_right _apply_plan_folder (start, seed_items) aitems = (final, items ++ seed_items).
  Proof.
    generalize dependent seed_items.
    induction aitems; simpl; intros; try reflexivity.
    destruct (fold_right _apply_plan_folder (start, []) aitems) as (afinal, aitemsX).
    rewrite IHaitems.
    destruct a. simpl. destruct (transition label_a0 (afinal, input_a0)) as (dest, out).
    reflexivity.
  Qed.

  Definition _apply_plan
    (start : state)
    (a : list plan_item)
    : list transition_item * state
    :=
    let (final, items) :=
      fold_right _apply_plan_folder (@pair state _ start []) (rev a) in
    (rev items, final).

  Lemma _apply_plan_last
    (start : state)
    (a : list plan_item)
    (after_a := _apply_plan start a)
    : finite_trace_last start (fst after_a) = snd after_a.
  Proof.
    induction a using rev_ind; try reflexivity.
    unfold after_a. clear after_a. unfold _apply_plan.
    rewrite rev_unit. unfold _apply_plan in IHa.
    simpl in *.
    destruct (fold_right _apply_plan_folder (start, []) (rev a)) as (final, items)
      eqn:Happly.
    simpl in IHa.
    simpl.
    destruct x.
    destruct (transition label_a0 (final, input_a0)) as (dest,out) eqn:Ht.
    unfold fst. unfold snd.
    simpl.
    rewrite finite_trace_last_is_last. reflexivity.
  Qed.

  Lemma _apply_plan_app
    (start : state)
    (a a' : list plan_item)
    : _apply_plan start (a ++ a') =
      let (aitems, afinal) := _apply_plan start a in
      let (a'items, a'final) := _apply_plan afinal a' in
       (aitems ++ a'items, a'final).
  Proof.
    unfold _apply_plan.
    rewrite rev_app_distr.
    rewrite fold_right_app. simpl.
    destruct
      (fold_right _apply_plan_folder (@pair state _ start []) (rev  a))
      as (afinal, aitems) eqn:Ha.
    destruct
      (fold_right _apply_plan_folder (@pair state _ afinal []) (rev a'))
      as (final, items) eqn:Ha'.
    clear - Ha'.
    specialize (_apply_plan_folder_additive afinal (rev a') aitems) as Hadd.
    rewrite Ha' in Hadd.
    rewrite Hadd. rewrite rev_app_distr. reflexivity.
  Qed.

  Lemma _apply_plan_cons
    (start : state)
    (ai : plan_item)
    (a' : list plan_item)
    : _apply_plan start (ai :: a') =
      let (aitems, afinal) := _apply_plan start [ai] in
      let (a'items, a'final) := _apply_plan afinal a' in
       (aitems ++ a'items, a'final).
  Proof.
    replace (ai :: a') with ([ai] ++ a').
    apply _apply_plan_app.
    intuition.
  Qed.

  (** We can forget information from a trace to obtain a plan. *)
  Definition _transition_item_to_plan_item
    (item : transition_item)
    : plan_item
    := {| label_a := l item; input_a := input item |}.

  Definition _trace_to_plan
    (items : list transition_item)
    : list plan_item
    := map _transition_item_to_plan_item items.

  Definition _messages_a
    (a : list plan_item) :
    list message :=
    ListExtras.cat_option (List.map input_a a).

End apply_plans.

Section protocol_plans.

  Context
    {message : Type}
    (X : VLSM message)
    .

  (**
  We define several notations useful when we want to use the results above
  for a specific [VLSM], by instantiating the generic definitions with the
  corresponding [type] and [transition].
  *)

  Definition vplan_item := (@plan_item _ (type X)).
  Definition plan : Type := list vplan_item.
  Definition apply_plan := (@_apply_plan _ (type X) (vtransition X)).
  Definition trace_to_plan := (@_trace_to_plan _ (type X)).
  Definition apply_plan_app
    (start : vstate X)
    (a a' : plan)
    : apply_plan start (a ++ a') =
      let (aitems, afinal) := apply_plan start a in
      let (a'items, a'final) := apply_plan afinal a' in
       (aitems ++ a'items, a'final)
    := (@_apply_plan_app _ (type X) (vtransition X) start a a').
  Definition apply_plan_last
    (start : vstate X)
    (a : plan)
    (after_a := apply_plan start a)
    : finite_trace_last start (fst after_a) = snd after_a
    := (@_apply_plan_last _ (type X) (vtransition X) start a).

  (** A plan is protocol w.r.t. a state if by applying it to that state we
  obtain a protocol trace sequence.
  *)
  Definition finite_protocol_plan_from
    (s : vstate X)
    (a : plan)
    : Prop :=
    finite_protocol_trace_from _ s (fst (apply_plan s a)).

  Lemma finite_protocol_plan_from_app_iff
    (s : vstate X)
    (a b : plan)
    (s_a := snd (apply_plan s a))
    : finite_protocol_plan_from s a /\ finite_protocol_plan_from s_a b <-> finite_protocol_plan_from s (a ++ b).
  Proof.
    unfold finite_protocol_plan_from.
    specialize (apply_plan_app s a b) as Happ.
    specialize (apply_plan_last s a) as Hlst.
    destruct (apply_plan s a) as (aitems, afinal) eqn:Ha.
    subst s_a.
    simpl in *.
    destruct (apply_plan afinal b) as (bitems, bfinal).
    rewrite Happ. simpl. clear Happ. subst afinal.
    apply finite_protocol_trace_from_app_iff.
  Qed.

  Lemma finite_protocol_plan_empty
    (s : vstate X)
    (Hpr : protocol_state_prop X s)  :
    finite_protocol_plan_from s [].
  Proof.
    apply finite_ptrace_empty.
    assumption.
  Qed.

  Lemma apply_plan_last_protocol
    (s : vstate X)
    (Hprs : protocol_state_prop X s)
    (a : plan)
    (Hpra : finite_protocol_plan_from s a)
    (after_a := apply_plan s a) :
    protocol_state_prop X (snd after_a).
  Proof.
    subst after_a.
    rewrite <- apply_plan_last.
    apply finite_ptrace_last_pstate.
    assumption.
  Qed.

  (** By extracting a plan from a [protocol_trace] based on a state @s@
  and reapplying the plan to the same state @s@ we obtain the original trace
  *)
  Lemma trace_to_plan_to_trace
    (s : vstate X)
    (tr : list (vtransition_item X))
    (Htr : finite_protocol_trace_from X s tr)
    : fst (apply_plan s (trace_to_plan tr)) = tr.
  Proof.
    induction Htr using finite_protocol_trace_from_rev_ind
    ;[reflexivity|].
    unfold trace_to_plan, _trace_to_plan.
    rewrite map_app, apply_plan_app.
    change (map _ tr) with (trace_to_plan tr).
    specialize (apply_plan_last s (trace_to_plan tr)) as Hlst.
    destruct (apply_plan s (trace_to_plan tr))
      as (sitems,afinal) eqn:Hapl.
    simpl in *. subst.
    unfold _transition_item_to_plan_item, apply_plan, _apply_plan.
    simpl.
    replace (vtransition X l _) with (sf,oom) by (symmetry;apply Hx).
    reflexivity.
  Qed.

  (** The plan extracted from a protocol trace is protocol w.r.t. the starting
  state of the trace.
  *)
  Lemma finite_protocol_trace_from_to_plan
    (s : vstate X)
    (tr : list (vtransition_item X))
    (Htr : finite_protocol_trace_from X s tr)
    : finite_protocol_plan_from s (trace_to_plan tr).
  Proof.
    unfold finite_protocol_plan_from.
    rewrite trace_to_plan_to_trace; assumption.
  Qed.

  (** Characterization of protocol plans. *)
  Lemma finite_protocol_plan_iff
    (s : vstate X)
    (a : plan)
    : finite_protocol_plan_from s a
    <-> protocol_state_prop X s
    /\ Forall (fun ai => option_protocol_message_prop X (input_a ai)) a
    /\ forall
        (prefa suffa : plan)
        (ai : plan_item)
        (Heqa : a = prefa ++ [ai] ++ suffa)
        (lst := snd (apply_plan s prefa)),
        vvalid X (label_a ai) (lst, input_a ai).
  Proof.
    induction a using rev_ind; repeat split; intros
    ; try
      ( apply finite_protocol_plan_from_app_iff in H
      ; destruct H as [Ha Hx]; apply IHa in Ha as Ha').
    - inversion H. assumption.
    - constructor.
    - destruct prefa; simpl in Heqa; discriminate Heqa.
    - destruct H as [Hs _]. constructor. assumption.
    - destruct Ha' as [Hs _].
      assumption.
    - destruct Ha' as [_ [Hmsgs _]].
      apply Forall_app. split; try assumption.
      repeat constructor. unfold finite_protocol_plan_from in Hx.
      remember (snd (apply_plan s a)) as lst.
      unfold apply_plan, _apply_plan in Hx. simpl in Hx.
      destruct x.
      destruct ( vtransition X label_a0 (lst, input_a0)) as (dest, out).
      simpl. simpl in Hx. inversion Hx. subst.
      destruct H6 as [[_ [Hom _]] _]. assumption.
    - assert (Hsuffa : suffa = [] \/ suffa <> []) by
        (destruct suffa; try (left; congruence); right; congruence).
      destruct Hsuffa.
      + subst. rewrite app_assoc in Heqa. rewrite app_nil_r in Heqa.
        apply app_inj_tail in Heqa. destruct Heqa; subst.
        unfold lst. clear lst.
        remember (snd (apply_plan s prefa)) as lst.
        unfold finite_protocol_plan_from in Hx.
        unfold apply_plan,_apply_plan in Hx. simpl in Hx.
        destruct ai.
        destruct ( vtransition X label_a0 (lst, input_a0)) as (dest, out).
        simpl. simpl in Hx. inversion Hx. subst.
        destruct H6 as [[_ [_ Hv]] _]. assumption.
      + apply exists_last in H. destruct H as [suffa' [x' Heq]]. subst.
        repeat rewrite app_assoc in Heqa.
        apply app_inj_tail in Heqa. rewrite <- app_assoc in Heqa. destruct Heqa; subst.
        destruct Ha' as [_ [_ Ha']].
        specialize (Ha' _ _ _ eq_refl). assumption.
    - destruct H as [Hs [Hinput Hvalid]].
      apply Forall_app in Hinput. destruct Hinput as [Hinput Hinput_ai].
      apply finite_protocol_plan_from_app_iff.
      assert (Ha : finite_protocol_plan_from s a); try (split; try assumption)
      ; try apply IHa; repeat split; try assumption.
      + intros.
        specialize (Hvalid prefa (suffa ++ [x]) ai).
        repeat rewrite app_assoc in *.
        subst a.
        specialize (Hvalid eq_refl). assumption.
      + unfold finite_protocol_plan_from.
        specialize (Hvalid a [] x).
        rewrite app_assoc in Hvalid. rewrite app_nil_r in Hvalid.
        specialize (Hvalid eq_refl).
        remember (snd (apply_plan s a)) as sa.
        unfold apply_plan, _apply_plan. simpl.
        destruct x.
        destruct (vtransition X label_a0 (sa, input_a0)) as (dest, out) eqn:Ht.
        simpl.
        apply Forall_inv in Hinput_ai. simpl in Hinput_ai.
        unfold finite_protocol_plan_from in Ha.
        apply finite_ptrace_last_pstate in Ha.
        specialize (apply_plan_last s a) as Hlst.
        simpl in Hlst, Ha.
        setoid_rewrite Hlst in Ha. setoid_rewrite <- Heqsa in Ha.
        repeat constructor; try assumption.
        exists out.
        replace (@pair (@state message (@type message X)) (option message) dest out)
          with (vtransition X label_a0 (sa, input_a0)).
        destruct Ha as [_oma Hsa].
        destruct Hinput_ai as [_s Hinput_a0].
        apply protocol_generated with _oma _s; assumption.
  Qed.

  (** Characterizing a singleton protocol plan as a protocol transition. *)
  Lemma finite_protocol_plan_from_one
    (s : vstate X)
    (a : plan_item) :
    let res := vtransition X (label_a a) (s, input_a a) in
    finite_protocol_plan_from s [a] <-> protocol_transition X (label_a a) (s, input_a a) res.
  Proof.
    split;
    intros;
    destruct a;
    unfold apply_plan,_apply_plan in *; simpl in *;
    unfold finite_protocol_plan_from in *;
    unfold apply_plan, _apply_plan in *; simpl in *.
    - match type of H with
      | context[let (_, _) := let (_, _) := ?t in _ in _] =>
        destruct t as [dest output] eqn : eq_trans
      end.
      inversion H. subst. setoid_rewrite eq_trans.
      assumption.
    - match type of H with
      | protocol_transition _ _ _ ?t =>
        destruct t as [dest output] eqn : eq_trans
      end.
      setoid_rewrite eq_trans.
      apply finite_ptrace_extend.
      apply finite_ptrace_empty.
      apply protocol_transition_destination in H; intuition.
      assumption.
  Qed.

  Definition preserves
    (a : plan)
    (P : vstate X -> Prop) :
    Prop :=
    forall (s : vstate X),
    (P s -> protocol_state_prop X s -> finite_protocol_plan_from s a -> P (snd (apply_plan s a))).

  Definition ensures
    (a : plan)
    (P : vstate X -> Prop) :
    Prop :=
    forall (s : vstate X),
    (protocol_state_prop X s -> P s -> finite_protocol_plan_from s a).

   (* If some property of a state guarantees a plan `b` applied to the state is protocol,
      and this property is preserved by the application of some other plan `a`,
      then these two plans can be composed and the application of `a ++ b` will also
      be protocol. *)

   Lemma plan_independence
    (a b : plan)
    (Pb : vstate X -> Prop)
    (s : state)
    (Hpr : protocol_state_prop X s)
    (Ha : finite_protocol_plan_from s a)
    (Hhave : Pb s)
    (Hensures : ensures b Pb)
    (Hpreserves : preserves a Pb) :
   finite_protocol_plan_from s (a ++ b).
   Proof.
    unfold ensures in *.
    unfold preserves in *.
    apply finite_protocol_plan_from_app_iff.
    split.
    - assumption.
    - remember (snd (apply_plan s a)) as s'.
      specialize (Hensures s').
      apply Hensures.
      rewrite Heqs'.
      apply apply_plan_last_protocol.
      intuition.
      intuition.
      rewrite Heqs'.
      apply Hpreserves.
      all : intuition.
   Qed.

End protocol_plans.


Ltac remove_unrelevant_last_txn :=
  repeat match goal with
  | [H: context[trace_tid_last ?tid ((?tid0, _) :: ?t) = _] |-_] =>
      unfold trace_tid_last in H; inversion H;
      destruct (Nat.eq_dec tid tid0); subst
  | [H: context[hd _
       (map snd
          (if ?tid0 =? ?tid0
           then (?tid0, ?x) :: trace_filter_tid ?tid0 ?t
           else trace_filter_tid ?tid0 ?t)) = ?y] |-_] =>
      rewrite <- beq_nat_refl in H; simpl in H; inversion H
  | [H: context[?tid <> ?tid0] |-_] =>
      apply not_eq_sym in H; apply Nat.eqb_neq in H
end.

Lemma seq_list_commit tid t:
  sto_trace t ->
  trace_tid_last tid t = seq_point
  -> In tid (seq_list t).
Proof.
  intros.
  induction H; simpl; try discriminate.
  1, 3, 4, 6-8, 10: remove_unrelevant_last_txn; rewrite n in H3; apply IHsto_trace in H3; auto.
  1, 2: remove_unrelevant_last_txn; rewrite n in H4; apply IHsto_trace in H4; auto.
  remove_unrelevant_last_txn.
  apply in_or_app. right. simpl. auto.
  remove_unrelevant_last_txn.
  rewrite n in H4.
  apply IHsto_trace in H4.
  apply in_or_app. left. auto.
Qed.

Lemma trace_seqlist_seqpoint t tid:
  In (tid, seq_point) t
  -> In tid (seq_list t).
Proof.
  intros.
  functional induction seq_list t.
  inversion H.
  destruct (Nat.eq_dec tid tid0); subst; apply in_or_app.
  right. simpl. auto.
  left. apply IHl. apply in_inv in H. destruct H.
  inversion H. apply Nat.eq_sym in H1. contradiction. auto.
  all: destruct (Nat.eq_dec tid tid0); subst; apply IHl; apply in_inv in H; destruct H; try inversion H; auto.
Qed.

Lemma seq_list_no_two_seqpoint t tid:
  sto_trace ((tid, seq_point) :: t)
  -> ~ In (tid, seq_point) t.
Proof.
  intros.
  assert (sto_trace t). { apply sto_trace_app with (tid0 := tid) (action0 := seq_point). auto. }
  inversion H.
  intuition.

  all: unfold trace_no_seq_points in H4; apply in_split in H6;
  destruct H6; destruct H6;
  rewrite H6 in H4; simpl in H4;
  rewrite trace_filter_tid_app in H4;
  simpl in H4;
  rewrite <-beq_nat_refl in H4;
  rewrite map_app in H4;
  rewrite Forall_app in H4;
  destruct H4; simpl in H7;
  apply Forall_inv in H7; simpl in H7; auto.
Qed.