Require Import Arith.
Require Import Omega.
Require FunctionalExtensionality.
Require Import List.
Import List.ListNotations.

Require Import mathcomp.ssreflect.ssreflect.
Require Import mathcomp.ssreflect.ssrbool.
Set Bullet Behavior "Strict Subproofs".

Require Import StructTact.StructTactics.
Require Import StructTact.Util.

Require Import InfSeqExt.infseq.

Require Import Chord.Chord.
Require Import Chord.HandlerLemmas.

Definition live_node_bool (gst : global_state) (h : addr) : bool :=
  if sigma gst h is Some st then
    joined st && in_dec addr_eq_dec h (nodes gst) && ~~ in_dec addr_eq_dec h (failed_nodes gst)
  else false.

Ltac break_live_node_name var :=
  match goal with
  | H : live_node _ _ |- _ =>
    unfold live_node in H; repeat break_and; break_exists_name var; repeat break_and
  end.

Ltac break_live_node_exists_exists :=
  match goal with
  | H : live_node _ _ |- _ =>
    unfold live_node in H; repeat break_and; break_exists_exists; repeat break_and
  end.

Ltac break_dead_node :=
  match goal with
  | H : dead_node _ _ |- _ =>
    unfold dead_node in H; repeat break_and; break_exists; repeat break_and
  end.

Ltac break_dead_node_name var :=
  match goal with
  | H : dead_node _ _ |- _ =>
    unfold dead_node in H; repeat break_and; break_exists_name var; repeat break_and
  end.

Ltac break_dead_node_exists_exists :=
  match goal with
  | H : dead_node _ _ |- _ =>
    unfold dead_node in H; repeat break_and; break_exists_exists; repeat break_and
  end.

Ltac break_live_node :=
  match goal with
  | H : live_node _ _ |- _ =>
    unfold live_node in H; repeat break_and; break_exists; repeat break_and
  end.

Theorem live_node_characterization :
  forall gst h st,
    sigma gst h = Some st ->
    joined st = true ->
    In h (nodes gst) ->
    ~ In h (failed_nodes gst) ->
    live_node gst h.
Proof using.
  unfold live_node.
  intuition.
  match goal with
  | x : data |- exists _ : data, _ => exists x
  end.
  intuition.
Qed.

Definition live_node_dec :
  forall gst h,
    {live_node gst h} + {~ live_node gst h}.
Proof.
  intros.
  destruct (In_dec addr_eq_dec h (nodes gst));
    destruct (In_dec addr_eq_dec h (failed_nodes gst));
    destruct (sigma gst h) as [st|] eqn:?;
    try destruct (joined st) eqn:?;
        try solve [left; eapply live_node_characterization; eassumption
                  |right; intro; inv_prop live_node; expand_def; congruence].
Defined.

Definition live_addrs (gst : global_state) : list addr :=
  filter (live_node_bool gst) (nodes gst).

Definition live_ptrs (gst : global_state) : list pointer :=
  map make_pointer (live_addrs gst).

Definition live_ptrs_with_states (gst : global_state) : list (pointer * data) :=
  FilterMap.filterMap (fun p =>
                         match sigma gst (addr_of p) with
                         | Some st => Some (p, st)
                         | None => None
                         end)
                      (live_ptrs gst).

Theorem live_node_equiv_live_node_bool :
  forall gst h,
    live_node gst h <-> live_node_bool gst h = true.
Proof using.
  unfold live_node_bool.
  intuition.
  - repeat break_match; break_live_node; last by congruence.
    find_rewrite.
    find_injection.
    apply/andP; split; first by apply/andP; split => //; case in_dec.
    by case in_dec.
  - repeat break_match; last by congruence.
    move/andP: H => [H H_f]; move/andP: H => [H H_n].
    apply: live_node_characterization; eauto.
    * by move: H_n; case in_dec.
    * by move: H_f; case in_dec.
Qed.

Lemma live_addr_In_live_addrs :
  forall gst h,
    live_node gst h ->
    In h (live_addrs gst).
Proof.
  unfold live_addrs.
  intros.
  apply filter_In; split.
  - unfold live_node in *; break_and; auto.
  - apply live_node_equiv_live_node_bool; auto.
Qed.

Lemma In_live_addrs_live :
  forall gst h,
    In h (live_addrs gst) ->
    live_node gst h.
Proof.
  unfold live_addrs.
  intros.
  find_apply_lem_hyp filter_In; break_and.
  apply live_node_equiv_live_node_bool; auto.
Qed.

Lemma In_live_ptrs_live :
  forall gst h,
    In h (live_ptrs gst) ->
    live_node gst (addr_of h).
Proof.
  unfold live_ptrs.
  intros.
  apply In_live_addrs_live.
  now find_apply_lem_hyp in_map_iff; expand_def.
Qed.

Lemma when_apply_handler_result_preserves_live_node :
  forall h h0 st st' gst gst' e ms cts nts,
    live_node gst h ->
    sigma gst h = Some st ->
    sigma gst' h = Some st' ->
    joined st' = true ->
    gst' = apply_handler_result h0 (st', ms, cts, nts) e gst ->
    live_node gst' h.
Proof using.
  intuition.
  eapply live_node_characterization.
  - eauto.
  - break_live_node.
    repeat find_rewrite.
    find_inversion; eauto.
  - find_apply_lem_hyp apply_handler_result_preserves_nodes.
    find_inversion.
    break_live_node; auto.
  - find_apply_lem_hyp apply_handler_result_preserves_failed_nodes.
    find_inversion.
    break_live_node; auto.
Qed.

Theorem live_node_preserved_by_recv_step :
  forall gst h src st msg gst' e st' ms nts cts,
    live_node gst h ->
    Some st = sigma gst h ->
    recv_handler src h st msg = (st', ms, nts, cts) ->
    gst' = apply_handler_result h (st', ms, nts, cts) e gst ->
    live_node gst' h.
Proof using.
  intuition.
  eapply when_apply_handler_result_preserves_live_node; eauto.
  - eauto using apply_handler_result_updates_sigma.
  - eapply joined_preserved_by_recv_handler.
    * eauto.
    * break_live_node.
      find_rewrite.
      find_injection.
      auto.
Qed.

Theorem live_node_preserved_by_timeout_step :
  forall gst h st st' t ms nts cts e gst',
    live_node gst h ->
    sigma gst h = Some st ->
    timeout_handler h st t = (st', ms, nts, cts) ->
    gst' = apply_handler_result h (st', ms, nts, t :: cts) e gst ->
    live_node gst' h.
Proof using.
  intuition.
  eapply when_apply_handler_result_preserves_live_node; eauto.
  - eauto using apply_handler_result_updates_sigma.
  - break_live_node.
    unfold timeout_handler, fst in *; break_let.
    repeat find_rewrite.
    find_apply_lem_hyp joined_preserved_by_timeout_handler_eff.
    repeat find_rewrite.
    find_injection.
    eauto.
Qed.

Definition best_succ_of (gst : global_state) (h : addr) : option addr :=
  match (sigma gst) h with
  | Some st => head (filter (live_node_bool gst) (map addr_of (succ_list st)))
  | None => None
  end.

Lemma live_node_specificity :
  forall gst gst',
    nodes gst = nodes gst' ->
    failed_nodes gst = failed_nodes gst' ->
    sigma gst = sigma gst' ->
    live_node gst = live_node gst'.
Proof using.
  intuition.
  unfold live_node.
  repeat find_rewrite.
  auto.
Qed.

Lemma live_node_joined :
  forall gst h,
    live_node gst h ->
    exists st,
      sigma gst h = Some st /\
      joined st = true.
Proof using.
  intuition.
    by break_live_node_exists_exists.
Qed.

Lemma live_node_in_nodes :
  forall gst h,
    live_node gst h ->
    In h (nodes gst).
Proof using.
  intuition.
    by break_live_node.
Qed.
Hint Resolve live_node_in_nodes.

Lemma live_node_not_in_failed_nodes :
  forall gst h,
    live_node gst h ->
    ~ In h (failed_nodes gst).
Proof using.
  intuition.
    by break_live_node.
Qed.
Hint Resolve live_node_not_in_failed_nodes.

Lemma live_node_equivalence :
  forall gst gst' h st st',
    live_node gst h ->
    nodes gst = nodes gst' ->
    failed_nodes gst = failed_nodes gst' ->
    sigma gst h = Some st ->
    sigma gst' h = Some st' ->
    joined st = joined st' ->
    live_node gst' h.
Proof using.
  intuition.
  break_live_node.
  eapply live_node_characterization.
  * eauto.
  * repeat find_rewrite.
    find_injection.
    eauto.
  * repeat find_rewrite; auto.
  * repeat find_rewrite; auto.
Qed.

Lemma live_node_means_state_exists :
  forall gst h,
    live_node gst h ->
    exists st, sigma gst h = Some st.
Proof using.
  intuition.
  find_apply_lem_hyp live_node_joined.
  break_exists_exists.
    by break_and.
Qed.
Hint Resolve live_node_means_state_exists.

Lemma coarse_live_node_characterization :
  forall gst gst' h,
    live_node gst h ->
    nodes gst = nodes gst' ->
    failed_nodes gst = failed_nodes gst' ->
    sigma gst = sigma gst' ->
    live_node gst' h.
Proof using.
  intuition.
  find_copy_apply_lem_hyp live_node_means_state_exists.
  break_exists.
  eapply live_node_equivalence.
  * repeat find_rewrite; eauto.
  * repeat find_rewrite; eauto.
  * repeat find_rewrite; eauto.
  * repeat find_rewrite; eauto.
  * repeat find_rewrite; eauto.
  * repeat find_rewrite; eauto.
Qed.

Lemma adding_nodes_does_not_affect_live_node :
  forall gst gst' h n st,
    ~ In n (nodes gst) ->
    sigma gst' = update addr_eq_dec (sigma gst) n (Some st) ->
    nodes gst' = n :: nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    live_node gst h ->
    live_node gst' h.
Proof using.
  intuition.
  break_live_node_name d.
  repeat split.
  * repeat find_rewrite.
    now apply in_cons.
  * by find_rewrite.
  * exists d.
    split => //.
    repeat find_reverse_rewrite.
    find_rewrite.
    find_rewrite.
    apply update_diff.
    congruence.
Qed.

(* reverse of the above, with additional hypothesis that h <> n. *)
Lemma adding_nodes_did_not_affect_live_node :
  forall gst gst' h n st,
    ~ In n (nodes gst) ->
    sigma gst' = update addr_eq_dec (sigma gst) n st ->
    nodes gst' = n :: nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    live_node gst' h ->
    h <> n ->
    live_node gst h.
Proof using.
  intuition.
  unfold live_node.
  break_live_node_name d.
  repeat split.
  * repeat find_rewrite.
    find_apply_lem_hyp in_inv.
    break_or_hyp; congruence.
  * repeat find_rewrite.
    auto.
  * exists d.
    split => //.
    repeat find_reverse_rewrite.
    find_rewrite.
    find_rewrite.
    find_rewrite.
    find_rewrite.
    symmetry.
    apply update_diff; auto.
Qed.

Lemma adding_nodes_does_not_affect_dead_node :
  forall gst gst' h n st,
    ~ In n (nodes gst) ->
    sigma gst' = update addr_eq_dec (sigma gst) n st ->
    nodes gst' = n :: nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    dead_node gst h ->
    dead_node gst' h.
Proof using.
  intuition.
  break_dead_node_name d.
  repeat split.
  - find_rewrite.
    eauto using in_cons.
  - find_rewrite; auto.
  - exists d.
    repeat find_reverse_rewrite.
    find_rewrite.
    find_rewrite.
    eapply update_diff.
    congruence.
Qed.

(* use lemma from Update.v instead *)
Lemma update_determined_by_f :
  forall A (f : addr -> A) x d d' y,
    y <> x ->
    update addr_eq_dec f x d y = d' ->
    f y = d'.
Proof using.
  intuition.
  symmetry.
  repeat find_reverse_rewrite.
  apply update_diff.
  now apply not_eq_sym.
Qed.

Lemma adding_nodes_did_not_affect_dead_node :
  forall gst gst' h n st,
    ~ In n (nodes gst) ->
    In h (nodes gst) ->
    sigma gst' = update addr_eq_dec (sigma gst) n st ->
    nodes gst' = n :: nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    dead_node gst' h ->
    dead_node gst h.
Proof using.
  intuition.
  break_dead_node_name d.
  unfold dead_node.
  repeat split.
  - find_rewrite.
    eauto using in_cons.
  - now repeat find_rewrite.
  - eexists.
    eapply update_determined_by_f.
    * instantiate (1 := n).
      eauto using In_notIn_implies_neq.
    * repeat find_rewrite; eauto.
Qed.

Lemma coarse_dead_node_characterization :
  forall gst gst' h,
    dead_node gst h ->
    sigma gst' = sigma gst ->
    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    dead_node gst' h.
Proof using.
  intuition.
  break_dead_node_name d.
  repeat split; try (find_rewrite; auto).
  now exists d.
Qed.

Lemma coarse_best_succ_characterization :
  forall gst gst' h s,
    best_succ gst h s ->
    sigma gst' = sigma gst ->
    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    best_succ gst' h s.
Proof using.
  unfold best_succ in *.
  intuition.
  break_exists_exists.
  break_and.
  repeat break_and_goal.
  - eapply live_node_equivalence; eauto.
    now repeat find_rewrite.
  - now repeat find_rewrite.
  - easy.
  - move => o H_in.
    find_apply_hyp_hyp.
    eapply coarse_dead_node_characterization; eauto.
  - eapply coarse_live_node_characterization; eauto.
Qed.

Lemma adding_nodes_does_not_affect_best_succ :
  forall gst gst' h s n st,
    best_succ gst h s ->
    ~ In n (nodes gst) ->
    sigma gst' = update addr_eq_dec (sigma gst) n (Some st) ->
    nodes gst' = n :: nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    best_succ gst' h s.
Proof using.
  unfold best_succ.
  intuition.
  break_exists_exists.
  break_and.
  repeat break_and_goal;
    eauto using adding_nodes_does_not_affect_live_node.
  - repeat break_live_node.
    repeat find_rewrite.
    match goal with
    | H: sigma gst h = Some _ |- _ = Some _ => rewrite <- H
    end.
    eapply update_diff.
    congruence.
  - intuition.
    find_copy_apply_hyp_hyp.
    break_dead_node.
    eauto using adding_nodes_does_not_affect_dead_node.
Qed.

Lemma global_state_eq_ext :
  forall gst gst',
    nodes gst = nodes gst' ->
    failed_nodes gst = failed_nodes gst' ->
    timeouts gst = timeouts gst' ->
    sigma gst = sigma gst' ->
    msgs gst = msgs gst' ->
    trace gst = trace gst' ->
    gst = gst'.
Proof using.
  intros.
  destruct gst, gst'.
  simpl in *.
  subst_max.
  tauto.
Qed.

Definition channel (gst : global_state) (src dst : addr) : list payload :=
  filterMap
    (fun m =>
       if (addr_eq_dec (fst m) src) && (addr_eq_dec (fst (snd m)) dst)
       then Some (snd (snd m))
       else None)
    (msgs gst).

Lemma in_msgs_in_channel :
  forall gst src dst p,
    In (src, (dst, p)) (msgs gst) ->
    In p (channel gst src dst).
Proof.
  unfold channel.
  intros.
  eapply filterMap_In; eauto.
  by case addr_eq_dec, addr_eq_dec.
Qed.
Hint Resolve in_msgs_in_channel.

Lemma in_channel_in_msgs :
  forall gst src dst p,
    In p (channel gst src dst) ->
    In (src, (dst, p)) (msgs gst).
Proof.
  unfold channel.
  intros.
  find_eapply_lem_hyp In_filterMap; eauto.
  break_exists.
  break_and.
  assert (x = (src, (dst, p))).
  { break_if; try discriminate.
    find_apply_lem_hyp Bool.andb_true_iff; break_and.
    repeat find_apply_lem_hyp addr_eqb_true.
    find_injection.
    move: H1 H2.
    case addr_eq_dec, addr_eq_dec => H_a H_a' //=.
    by destruct x, p; subst. }
  now find_reverse_rewrite.
Qed.
Hint Resolve in_channel_in_msgs.

Lemma channel_contents :
  forall gst src dst p,
    In (src, (dst, p)) (msgs gst) <-> In p (channel gst src dst).
Proof using.
  intuition.
Qed.

Lemma sigma_apply_handler_result_same :
  forall h res es gst,
    sigma (apply_handler_result h res es gst) h =
    Some (fst (fst (fst res))).
Proof.
  intros. unfold apply_handler_result.
  repeat break_match. subst. simpl.
  now rewrite_update.
Qed.

Lemma sigma_apply_handler_result_diff :
  forall h h' res es gst,
    h <> h' ->
    sigma (apply_handler_result h res es gst) h' =
    sigma gst h'.
Proof.
  intros. unfold apply_handler_result.
  repeat break_match. subst. simpl.
  now rewrite_update.
Qed.

Lemma sigma_initial_st_start_handler :
  forall gst h st,
    initial_st gst ->
    sigma gst h = Some st ->
    st = fst (fst (start_handler h (nodes gst))).
Proof.
  intros.
  inv_prop initial_st.
  break_and.
  destruct (start_handler _ _) as [[d ?] ?] eqn:?.
  simpl.
  destruct (In_dec addr_eq_dec h (nodes gst)).
  - apply_prop_hyp sigma start_handler;
      intuition congruence.
  - find_higher_order_rewrite; congruence.
Qed.

Lemma timeouts_apply_handler_result_diff :
  forall h h' res es gst,
    h <> h' ->
    timeouts (apply_handler_result h res es gst) h' =
    timeouts gst h'.
Proof.
  intros. unfold apply_handler_result.
  repeat break_match. subst. simpl.
  now rewrite_update.
Qed.

Definition active_nodes (gst : global_state) :=
  RemoveAll.remove_all addr_eq_dec (failed_nodes gst) (nodes gst).

Lemma labeled_step_dynamic_preserves_active_nodes :
  forall gst l gst',
    labeled_step_dynamic gst l gst' ->
    active_nodes gst = active_nodes gst'.
Proof.
  intros; unfold active_nodes.
  erewrite labeled_step_dynamic_preserves_failed_nodes; eauto.
  erewrite labeled_step_dynamic_preserves_nodes; eauto.
Qed.

Lemma active_nodes_always_identical :
  forall l ex,
    lb_execution ex ->
    active_nodes (occ_gst (hd ex)) = l ->
    always (fun ex' => l = active_nodes (occ_gst (hd ex'))) ex.
Proof.
  cofix c. intros.
  constructor; destruct ex.
  - easy.
  - apply c; eauto using lb_execution_invar.
    inv_prop lb_execution.
    find_apply_lem_hyp labeled_step_dynamic_preserves_active_nodes.
    cbn; congruence.
Qed.

Definition has_succs (gst : global_state) (h : addr) (succs : list pointer) :=
  exists st,
    sigma gst h = Some st /\
    succ_list st = succs.

Lemma has_succs_intro :
  forall gst h succs st,
    sigma gst h = Some st ->
    succ_list st = succs ->
    has_succs gst h succs.
Proof.
  eexists; eauto.
Qed.

Lemma initial_nodes_large :
  forall gst,
    initial_st gst ->
    3 <= length (nodes gst).
Proof.
  unfold initial_st.
  intros.
  break_and.
  assert (2 <= Chord.SUCC_LIST_LEN)
    by apply Chord.succ_list_len_lower_bound.
  omega.
Qed.

Lemma Tick_in_initial_st :
  forall gst h,
    initial_st gst ->
    In h (nodes gst) ->
    timeouts gst h = [Tick].
Proof.
  intros.
  find_copy_eapply_lem_hyp initial_nodes_large.
  unfold initial_st in *.
  break_and.
  destruct (start_handler h (nodes gst)) as [[? ?] nts] eqn:?.
  assert ([Tick] = nts).
  {
    pose proof (sort_by_between_permutes h (map make_pointer (nodes gst)) _ eq_refl).
    find_copy_apply_lem_hyp Permutation.Permutation_length.
    find_rewrite_lem map_length.
    destruct (sort_by_between h (map make_pointer (nodes gst))) as [| ? [|? ?]] eqn:? in *;
      change ChordIDParams.name with addr in *;
      simpl in *; try omega.
    unfold start_handler in *.
    change ChordIDParams.name with addr in *;
      repeat find_rewrite.
    now find_inversion.
  }
  find_rewrite.
  eapply_prop_hyp start_handler start_handler; auto.
  tauto.
Qed.

Lemma in_nodes_sigma_some :
  forall gst h,
    initial_st gst ->
    In h (nodes gst) ->
    exists st,
      sigma gst h = Some st.
Proof.
  intros. unfold initial_st in *. intuition.
  match goal with
  | H : context [start_handler] |- _ =>
    remember H as Hsh; clear HeqHsh; clear H
  end.
  specialize (Hsh h). concludes.
  destruct (start_handler h (nodes gst)) as [[st ms] nts].
  specialize (Hsh st ms nts). intuition.
  eauto.
Qed.

Lemma exists_node_in_initial_st :
  forall gst,
    initial_st gst ->
    exists h,
      In h (nodes gst) /\ ~ In h (failed_nodes gst).
Proof.
  intros. unfold initial_st in *. intuition.
  destruct (nodes gst); simpl in *; [omega|].
  repeat find_rewrite.
  eexists; intuition; eauto.
Qed.

Lemma start_handler_init_state_preset :
  forall h knowns,
    length knowns > 1 ->
    start_handler h knowns =
    (init_state_preset h
                       (find_pred h (sort_by_between h (map make_pointer knowns)))
                       (chop_succs (List.tl (sort_by_between h (map make_pointer knowns)))),
     nil,
     Tick :: nil).
Proof.
  intros.
  unfold start_handler.
  repeat break_match;
    match goal with H : _ = _ |- _ => symmetry in H end;
    find_copy_apply_lem_hyp sort_by_between_permutes;
    [| | reflexivity];
    find_apply_lem_hyp Permutation.Permutation_length;
    rewrite map_length in H0; simpl in *; repeat find_reverse_rewrite;
      exfalso; eapply gt_irrefl; eauto.
Qed.

Lemma live_node_in_initial_st :
  forall gst,
    initial_st gst ->
    exists h,
      live_node gst h.
Proof.
  intros.
  find_copy_apply_lem_hyp exists_node_in_initial_st.
  break_exists_name h; exists h. intuition.
  find_copy_eapply_lem_hyp in_nodes_sigma_some; eauto.
  break_exists_name st. unfold live_node. intuition.
  exists st. intuition.
  find_apply_lem_hyp sigma_initial_st_start_handler; auto. subst.
  pose proof succ_list_len_lower_bound.
  rewrite start_handler_init_state_preset;
    [|unfold initial_st in *; intuition].
  reflexivity.
Qed.

Lemma sorted_knowns_same_length :
  forall h ks,
    length (sort_by_between h (map make_pointer ks)) = length ks.
Proof.
  intros.
  pose proof (sort_by_between_permutes h (map make_pointer ks) ltac:(eauto) ltac:(eauto)).
  find_apply_lem_hyp Permutation.Permutation_length.
  find_reverse_rewrite.
  apply map_length.
Qed.
Hint Rewrite sorted_knowns_same_length.

Lemma initial_start_handler_st_joined :
  forall h ks st ms nts,
    start_handler h ks = (st, ms, nts) ->
    length ks > 1 ->
    joined st = true.
Proof.
  intros.
  unfold start_handler, empty_start_res, init_state_join, init_state_preset in *.
  repeat break_match; try find_injection.
  - rewrite <- (sorted_knowns_same_length h) in *.
    find_rewrite.
    simpl in *; omega.
  - rewrite <- (sorted_knowns_same_length h) in *.
    find_rewrite.
    simpl in *; omega.
  - reflexivity.
Qed.

Lemma initial_nodes_live :
  forall gst h,
    initial_st gst ->
    In h (nodes gst) ->
    live_node gst h.
Proof.
  intros.
  destruct (start_handler h (nodes gst)) as [[?st ?ms] ?nts] eqn:?.
  inv_prop initial_st; break_and.
  eapply live_node_characterization.
  - apply_prop_hyp sigma start_handler; break_and; eauto.
  - find_copy_apply_lem_hyp initial_nodes_large.
    eapply initial_start_handler_st_joined; eauto; omega.
  - auto.
  - repeat find_rewrite; in_crush.
Qed.
Hint Resolve initial_nodes_live.

Theorem initial_succ_list :
  forall h gst st,
    initial_st gst ->
    In h (nodes gst) ->
    sigma gst h = Some st ->
    succ_list st = chop_succs (List.tl (sort_by_between h (map make_pointer (nodes gst)))).
Proof.
  intros.
  inv_prop initial_st; break_and.
  find_copy_apply_lem_hyp initial_nodes_large.
  destruct (start_handler h (nodes gst)) as [[?st ?ms] ?nts] eqn:?.
  copy_eapply_prop_hyp start_handler start_handler; auto; break_and.
  rewrite start_handler_init_state_preset in Heqp; eauto with arith.
  repeat find_rewrite; repeat find_injection.
  simpl in *; eauto.
Qed.
Hint Rewrite initial_succ_list.

Lemma NoDup_map_make_pointer :
  forall l, NoDup l ->
  NoDup (map make_pointer l).
Proof.
elim => //=.
move => a l IH H_nd.
inversion H_nd; subst.
find_apply_lem_hyp IH.
apply NoDup_cons => //.
move {H2 H_nd IH}.
elim: l H1 => //=.
move => a' l IH H_in H_in'.
have H_neq: a' <> a by auto.
have H_nin: ~ In a l by auto.
break_or_hyp.
- unfold make_pointer in H.
  by find_injection.
- by apply IH.
Qed.

Lemma initial_successor_lists_full :
  forall h gst,
    initial_st gst ->
    length (chop_succs (List.tl (sort_by_between h (map make_pointer (nodes gst))))) = SUCC_LIST_LEN.
Proof.
  intros.
  pose proof (sorted_knowns_same_length h (nodes gst)).
  inv_prop initial_st; break_and.
  rewrite -H0 in H1.
  move: H1 H0.
  set mm := map _ _.
  move => H_le H_eq.
  have H_pm := sort_by_between_permutes h mm (sort_by_between h mm) (eq_refl _).
  have H_nd := NoDup_map_make_pointer _ H2.
  rewrite -/mm in H_nd.
  apply NoDup_Permutation_NoDup in H_pm => //.
  move: H_pm H_le.
  destruct (sort_by_between _ _) eqn:?.
  - subst; move => H_nd' H_le.
    simpl in *; omega.
  - intros.
    simpl in *.
    rewrite /chop_succs.
    rewrite firstn_length /=.
    rewrite min_l; omega.
Qed.

Lemma best_succ_preserved :
  forall gst gst' h h0 s st st',
    In h (nodes gst) ->
    ~ In h (failed_nodes gst) ->
    sigma gst h = Some st ->
    sigma gst' = update (addr_eq_dec) (sigma gst) h (Some st') ->
    (joined st = true -> joined st' = true) ->
    succ_list st = succ_list st' \/ h <> h0 ->
    nodes gst' = nodes gst ->
    failed_nodes gst = failed_nodes gst' ->
    best_succ gst h0 s ->
    best_succ gst' h0 s.
Proof.
  unfold best_succ.
  intros.
  destruct (addr_eq_dec h h0).
  {
    symmetry in e; subst.
    expand_def.
    repeat find_rewrite; rewrite_update.
    find_inversion.
    do 3 eexists.
    repeat break_and_goal.
    - repeat break_live_node.
      eapply live_node_characterization; try congruence.
      + repeat find_rewrite; rewrite_update; eauto.
      + find_eapply_prop joined; congruence.
    - reflexivity.
    - find_rewrite; eauto.
    - intros.
      assert (dead_node gst o) by auto.
      inv_prop dead_node; expand_def; unfold dead_node; repeat find_rewrite.
      rewrite_update; eauto.
    - inv_prop live_node; expand_def.
      destruct (addr_eq_dec h s); subst.
      + eapply live_node_characterization;
          repeat find_rewrite; rewrite_update; eauto.
        find_injection; auto.
      + eapply live_node_equivalence; eauto.
        repeat find_rewrite; rewrite_update; auto.
  }
  break_exists_exists.
  repeat break_and_goal; break_and;
    repeat find_rewrite; rewrite_update.
  - repeat break_live_node.
    eapply live_node_characterization; try congruence.
    + repeat find_rewrite; rewrite_update; eauto.
    + congruence.
  - auto.
  - auto.
  - intros.
    assert (dead_node gst o) by auto.
    inv_prop dead_node; expand_def; unfold dead_node; repeat find_rewrite;
      rewrite_update; eauto.
  - repeat break_live_node.
    destruct (addr_eq_dec s h);
      eapply live_node_characterization; try congruence;
        try solve [repeat find_rewrite; rewrite_update; eauto
                  |congruence
                  |find_eapply_prop joined; congruence].
Qed.
Hint Resolve best_succ_preserved.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sovar_alpha.
Require Export list_tacs.

Lemma get_utokens_swap {o} :
  forall s (t : @NTerm o),
    get_utokens (swap s t) = get_utokens t.
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; simpl; auto.
  apply app_if; auto.
  rw flat_map_map; unfold compose.
  apply eq_flat_maps; introv i.
  destruct x; simpl.
  eapply ind; eauto.
Qed.

Lemma get_utokens_cswap {o} :
  forall s (t : @NTerm o),
    get_utokens (cswap s t) = get_utokens t.
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; simpl; auto.
  apply app_if; auto.
  rw flat_map_map; unfold compose.
  apply eq_flat_maps; introv i.
  destruct x; simpl.
  eapply ind; eauto.
Qed.

Lemma swapbvars_remove_nvars :
  forall vs1 vs2 l vs,
    no_repeats vs2
    -> disjoint vs1 vs2
    -> swapbvars (mk_swapping vs1 vs2) (remove_nvars l vs)
       = remove_nvars (swapbvars (mk_swapping vs1 vs2) l)
                      (swapbvars (mk_swapping vs1 vs2) vs).
Proof.
  induction vs; introv norep disj; simpl.
  - allrw remove_nvars_nil_r; simpl; auto.
  - allrw remove_nvars_cons_r; boolvar; tcsp; try (rw <- IHvs; auto); allsimpl; tcsp.
    + provefalse.
      allrw in_swapbvars.
      destruct Heqb0.
      exists a; sp.
    + provefalse.
      allrw in_swapbvars; exrepnd.
      apply swapvars_eq in Heqb1; auto; subst; tcsp.
Qed.

Lemma free_vars_swap {o} :
  forall (t : @NTerm o) vs1 vs2,
    no_repeats vs2
    -> disjoint vs1 vs2
    -> free_vars (swap (mk_swapping vs1 vs2) t)
       = swapbvars (mk_swapping vs1 vs2) (free_vars t).
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv norep disj; allsimpl; auto.

  Case "oterm".
  rw flat_map_map; unfold compose.
  rw @swapbvars_flat_map.
  apply eq_flat_maps; introv i.
  destruct x as [l t]; simpl.
  rw swapbvars_remove_nvars; auto.
  erewrite ind; eauto.
Qed.

Lemma free_vars_cswap {o} :
  forall (t : @NTerm o) vs1 vs2,
    no_repeats vs2
    -> disjoint vs1 vs2
    -> free_vars (cswap (mk_swapping vs1 vs2) t)
       = swapbvars (mk_swapping vs1 vs2) (free_vars t).
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv norep disj; allsimpl; auto.

  Case "oterm".
  rw flat_map_map; unfold compose.
  rw @swapbvars_flat_map.
  apply eq_flat_maps; introv i.
  destruct x as [l t]; simpl.
  rw swapbvars_remove_nvars; auto.
  erewrite ind; eauto.
Qed.

Lemma subvars_d :
  forall vs1 vs2, decidable (subvars vs1 vs2).
Proof.
  introv.
  unfold decidable, subvars, assert.
  destruct (sub_vars vs1 vs2); sp.
  right; sp.
Defined.

Fixpoint bound_vars_ncl {p} (t : @NTerm p) : list NVar :=
  match t with
    | vterm v => []
    | sterm f => []
    | oterm op bts => flat_map bound_vars_bterm_ncl bts
  end
 with bound_vars_bterm_ncl {p} (bt : BTerm) :=
  match bt with
  | bterm lv nt =>
    if subvars_d (free_vars nt) lv
    then []
    else lv ++ bound_vars_ncl nt
  end.

Lemma bound_vars_ncl_swap {o} :
  forall (t : @NTerm o) (vs1 vs2 : list NVar),
    no_repeats vs2
    -> disjoint vs1 vs2
    -> bound_vars_ncl (swap (mk_swapping vs1 vs2) t)
       = swapbvars (mk_swapping vs1 vs2) (bound_vars_ncl t).
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv norep disj; allsimpl; auto.

  Case "oterm".
  rw @swapbvars_flat_map.
  rw flat_map_map; unfold compose.
  apply eq_flat_maps; introv i.
  destruct x as [l t]; allsimpl.
  rw @free_vars_swap; auto.
  boolvar; allsimpl; tcsp.

  - destruct n.
    allrw subvars_prop; introv j.
    pose proof (s (swapvar (mk_swapping vs1 vs2) x)) as h.
    autodimp h hyp.
    { allrw in_swapbvars.
      exists x; dands; auto. }
    allrw in_swapbvars; exrepnd.
    apply swapvars_eq in h0; subst; auto.

  - destruct n.
    allrw subvars_prop; introv j.
    allrw in_swapbvars; exrepnd; subst.
    applydup s in j1.
    eexists; dands; eauto.

  - rw swapbvars_app; f_equal.
    apply (ind t l); auto.
Qed.

Lemma bound_vars_ncl_cswap {o} :
  forall (t : @NTerm o) (vs1 vs2 : list NVar),
    no_repeats vs2
    -> disjoint vs1 vs2
    -> bound_vars_ncl (cswap (mk_swapping vs1 vs2) t)
       = swapbvars (mk_swapping vs1 vs2) (bound_vars_ncl t).
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv norep disj; allsimpl; auto.

  Case "oterm".
  rw @swapbvars_flat_map.
  rw flat_map_map; unfold compose.
  apply eq_flat_maps; introv i.
  destruct x as [l t]; allsimpl.
  rw @free_vars_cswap; auto.
  boolvar; allsimpl; tcsp.

  - destruct n.
    allrw subvars_prop; introv j.
    pose proof (s (swapvar (mk_swapping vs1 vs2) x)) as h.
    autodimp h hyp.
    { allrw in_swapbvars.
      exists x; dands; auto. }
    allrw in_swapbvars; exrepnd.
    apply swapvars_eq in h0; subst; auto.

  - destruct n.
    allrw subvars_prop; introv j.
    allrw in_swapbvars; exrepnd; subst.
    applydup s in j1.
    eexists; dands; eauto.

  - rw swapbvars_app; f_equal.
    apply (ind t l); auto.
Qed.

Lemma sub_free_vars_swap_sub {o} :
  forall vs1 vs2 (sub : @Sub o),
    no_repeats vs2
    -> disjoint vs1 vs2
    -> sub_free_vars (swap_sub (mk_swapping vs1 vs2) sub)
       = swapbvars (mk_swapping vs1 vs2) (sub_free_vars sub).
Proof.
  induction sub; introv norep disj; allsimpl; auto.
  destruct a.
  rw swapbvars_app; f_equal; tcsp.
  rw @free_vars_swap; auto.
Qed.

Lemma sub_free_vars_cswap_sub {o} :
  forall vs1 vs2 (sub : @Sub o),
    no_repeats vs2
    -> disjoint vs1 vs2
    -> sub_free_vars (cswap_sub (mk_swapping vs1 vs2) sub)
       = swapbvars (mk_swapping vs1 vs2) (sub_free_vars sub).
Proof.
  induction sub; introv norep disj; allsimpl; auto.
  destruct a.
  rw swapbvars_app; f_equal; tcsp.
  rw @free_vars_cswap; auto.
Qed.

Lemma alphaeq_oterm_implies_combine {o} :
  forall op bs (t : @NTerm o),
    alphaeq (oterm op bs) t
    -> {bs' : list BTerm
        & t = oterm op bs'
        # length bs = length bs'
        # (forall b1 b2 : BTerm,
             LIn (b1, b2) (combine bs bs')
             -> alphaeqbt b1 b2)}.
Proof.
  introv aeq.
  apply alphaeq_eq in aeq.
  apply alpha_eq_oterm_implies_combine in aeq; exrepnd.
  exists bs'; dands; auto.
  introv i.
  apply aeq0 in i.
  apply alphaeqbt_eq; auto.
Qed.

Lemma alphaeq_oterm_combine {o} :
  forall op (bs1 bs2 : list (@BTerm o)),
    alphaeq (oterm op bs1) (oterm op bs2)
    <=>
    (length bs1 = length bs2
     # (forall b1 b2 : BTerm,
          LIn (b1, b2) (combine bs1 bs2) -> alphaeqbt b1 b2)).
Proof.
  introv.
  rw @alphaeq_eq.
  rw @alpha_eq_oterm_combine.
  split; intro k; exrepnd; dands; auto; introv i; apply k in i;
  apply alphaeqbt_eq; auto.
Qed.

Lemma disjoint_swapbvars3 :
  forall bvs vs vs1 vs2 : list NVar,
    disjoint vs1 vs2
    -> no_repeats vs2
    -> disjoint vs2 bvs
    -> disjoint (remove_nvars vs1 bvs) vs
    -> disjoint vs2 vs
    -> length vs1 = length vs2
    -> disjoint vs (swapbvars (mk_swapping vs1 vs2) bvs).
Proof.
  introv d1 norep d2 d3 d4 len i j.
  apply disjoint_sym in d3.
  applydup d3 in i as k.
  rw in_remove_nvars in k.
  rw in_swapbvars in j; exrepnd; subst.
  apply disjoint_sym in d2.
  applydup d2 in j1 as q.
  destruct (in_deq _ deq_nvar v' vs1) as [d|d].
  - pose proof (swapvar_in vs1 vs2 v') as h.
    repeat (autodimp h hyp).
    apply d4 in h; sp.
  - rw swapvar_not_in in i; auto.
    rw swapvar_not_in in k; auto.
Qed.

Lemma map_combine_left :
  forall (T1 T2 T3 : tuniv)
         (f : T1 -> T3) (l1 : list T1) (l2 : list T2),
    map (fun x => (f (fst x), snd x)) (combine l1 l2)
    = combine (map f l1) l2.
Proof.
  induction l1; introv; allsimpl; auto.
  destruct l2; allsimpl; auto.
  rw IHl1; auto.
Qed.

Lemma alphaeq_cswap_disj_free_vars {o} :
  forall (t : @NTerm o) vs1 vs2,
    length vs1 = length vs2
    -> no_repeats vs2
    -> disjoint (free_vars t) vs1
    -> disjoint (allvars t) vs2
    -> disjoint vs1 vs2
    -> alphaeq (cswap (mk_swapping vs1 vs2) t) t.
Proof.
  nterm_ind1s t as [v|f ind|op bs ind] Case;
  introv len norep d1 d2 d3; allsimpl; eauto 3 with slow.

  - Case "vterm".
    allrw disjoint_singleton_l.
    rw swapvar_not_in; eauto with slow.

  - Case "oterm".
    apply alphaeq_oterm_combine; allrw map_length; dands; auto.
    introv i.
    rw <- map_combine_left in i; rw in_map_iff in i; exrepnd; cpx.
    rw in_combine_same in i1; repnd; subst; allsimpl.
    destruct a as [l t]; allsimpl.
    pose proof (fresh_vars (length l)
                           ((swapbvars (mk_swapping vs1 vs2) l)
                              ++ l
                              ++ vs1
                              ++ vs2
                              ++ (free_vars t)
                              ++ (allvars (cswap (mk_swapping vs1 vs2) t))
                              ++ (allvars t))) as fv; exrepnd.
    allrw disjoint_app_r; repnd.

    apply (aeqbt _ lvn); allsimpl; allrw length_swapbvars; auto;
    allrw disjoint_app_r; tcsp.
    disj_flat_map; allsimpl; allrw disjoint_app_l; repnd.

    rw @cswap_cswap.
    rw mk_swapping_app; auto.
    rw <- @cswap_app_cswap; eauto with slow.
    rw <- mk_swapping_app; auto.
    rw <- @cswap_cswap.
    apply (ind t _ l); allrw @osize_cswap; eauto 3 with slow.

    + rw @free_vars_cswap; eauto with slow.
      apply disjoint_sym.
      apply disjoint_swapbvars3; eauto with slow.

    + apply disjoint_sym.
      apply disjoint_allvars_cswap; eauto with slow.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "../util/")
*** End:
*)


From Coq Require Import List Vectors.Fin Arith.Compare_dec Lia Program.
Import ListNotations.

From CasperCBC Require Import Preamble ListExtras VLSM.Common VLSM.Equivocators.Common.

(** * VLSM Projecting Equivocator Traces *)

Section equivocator_vlsm_projections.

(**
Given an [equivocator_vlsm] trace ending in a state <<s>>, we can obtain a
trace in the original vlsm leading to the <<si>>, the  <<i>>th internal
state in <<s>>, by extracting a path leading to si.

This section is devoting to formalizing this projects studying its
properties. In particular, we show that given a [protocol_trace] for
the [equivocator_vlsm], we can always extract such a trace for any valid
index, and, furthermore, that the trace extracted is protocol for the
original machine.
*)

Context
  {message : Type}
  (X : VLSM message)
  (equivocator_vlsm := equivocator_vlsm X)
  (MachineDescriptor := MachineDescriptor X)
  .

Local Ltac unfold_transition H :=
  ( unfold transition in H; unfold equivocator_vlsm in H
  ; unfold Common.equivocator_vlsm in H
  ; unfold mk_vlsm in H; unfold machine in H
  ; unfold projT2 in H; unfold equivocator_vlsm_machine in H
  ; unfold equivocator_transition in H).

(** Given a [transition_item] <<item>> for the [equivocator_vlsm] and a
[MachineDescriptor] referring to a position in the [destination] of <<item>>,
it returns a transition item for the original machine (if the descriptor
matches the copy affected by this transition) and a new machine descriptor
referring to a position in the state prior to the transition.
*)
Definition equivocator_vlsm_transition_item_project
  (item : vtransition_item equivocator_vlsm)
  (descriptor : MachineDescriptor)
  : option (option (vtransition_item X) * MachineDescriptor)
  :=
  match descriptor with
  | NewMachine _ _ => Some (None, descriptor)
  | Existing _ j _ =>
    match item with {| l := (lx, descriptor); input := im; output := om; destination := s |} =>
      let (n, bs) := s in
      match (le_lt_dec (S n) j) with
      | right lt_jn =>
        let nj := of_nat_lt lt_jn in
        let item' := {| l := lx; input := im; output := om; destination := bs nj|} in
        match descriptor with
        | NewMachine _ s =>
          if nat_eq_dec (S j) (S n) then (* this is the first state *)
            Some ( None, descriptor)
          else Some (None, Existing _ j false)
        | Existing _ i is_equiv =>
          match is_equiv with
          | false => (* no equivocation *)
            if nat_eq_dec i j then
              Some ( Some item', descriptor)
            else Some (None, Existing _ j false)
          | true => (* equivocation: transition happens on the copy *)
            if nat_eq_dec (S j) (S n) then
              Some (Some item', descriptor)
            else Some (None, Existing _ j false)
          end
        end
      | _ => None
      end
    end
  end.

(**
Since equivocators always have machine 0, We can always project a 'valid'
equivocator 'transition item' to component 0.
*)

Lemma equivocators_vlsm_transition_item_project_zero_descriptor
  (item : vtransition_item equivocator_vlsm)
  s
  (Ht : vtransition equivocator_vlsm (l item) (s, input item) = (destination item, output item))
  (Hv : vvalid equivocator_vlsm (l item) (s, input item))
  : exists oitem, equivocator_vlsm_transition_item_project item (Existing _ 0 false) = Some (oitem, Existing _ 0 false).
Proof.
  unfold equivocator_vlsm_transition_item_project.
  destruct item.
  destruct l as (l, dl). destruct destination as (ndest, bdest).
  destruct (le_lt_dec (S ndest) 0); [lia|].
  destruct dl as [ndl | idl fdl]
  ; [destruct (nat_eq_dec 1 (S ndest))| destruct fdl; [destruct (nat_eq_dec 1 (S ndest))| destruct (nat_eq_dec idl 0)]]
  ; simpl in Ht; unfold vtransition in Ht; unfold_transition Ht; unfold snd in Ht
  ; destruct Hv as [Hidl _].
  - inversion Ht. subst. destruct s; inversion H0. lia.
  - exists None. reflexivity.
  - destruct (le_lt_dec (S (projT1 s)) idl); [lia|].
    match type of Ht with
    | (let (_, _) := ?t in _) = _ => destruct t
    end.
    inversion Ht. subst. destruct s; inversion H0. lia.
  - exists None. reflexivity.
  - subst idl. eexists _. reflexivity.
  - exists None. reflexivity.
Qed.

(**
An injectivity result for [equivocator_vlsm_transition_item_project].
*)
Lemma equivocator_vlsm_transition_item_project_some_inj
  {item : vtransition_item equivocator_vlsm}
  {itemX itemX' : vtransition_item X}
  {i i' : nat}
  {fi fi' : bool}
  (idescriptor := Existing _ i fi)
  (idescriptor' := Existing _ i' fi')
  {odescriptor odescriptor' : MachineDescriptor}
  (HitemX : equivocator_vlsm_transition_item_project item idescriptor = Some (Some itemX, odescriptor))
  (HitemX' : equivocator_vlsm_transition_item_project item idescriptor' = Some (Some itemX', odescriptor'))
  : i = i' /\ itemX = itemX' /\ odescriptor = odescriptor'.
Proof.
  unfold equivocator_vlsm_transition_item_project in *.
  unfold idescriptor in *. clear idescriptor.
  unfold idescriptor' in *. clear idescriptor'.
  destruct item.
  destruct l as (ls, descriptor).
  destruct destination as (ndest, bdest).
  destruct (le_lt_dec (S ndest) i); [congruence|].
  destruct (le_lt_dec (S ndest) i'); [congruence|].
  destruct descriptor as [sn | j fj].
  - destruct (nat_eq_dec (S i) (S ndest)); congruence.
  - destruct fj as [|] eqn:Hfj.
    + destruct (nat_eq_dec (S i) (S ndest)); [|congruence].
      inversion HitemX; subst. clear HitemX.
      inversion e. subst i. clear e.
      destruct (nat_eq_dec (S i') (S ndest)); [|congruence].
      inversion HitemX'; subst. clear HitemX'.
      inversion e; subst i'; clear e.
      replace (of_nat_lt l0) with (of_nat_lt l) by apply of_nat_ext.
      repeat split; reflexivity.
    + destruct (nat_eq_dec j i); [|congruence].
      destruct (nat_eq_dec j i'); [|congruence].
      inversion HitemX. inversion HitemX'. subst.
      replace (of_nat_lt l0) with (of_nat_lt l) by apply of_nat_ext.
      repeat split; reflexivity.
Qed.

(**
[equivocator_vlsm_transition_item_project] only fails for an out-of-range
descriptor.
*)
Lemma equivocator_transition_item_project_inv_none
  (item : vtransition_item equivocator_vlsm)
  (descriptor : MachineDescriptor)
  (Hitem: equivocator_vlsm_transition_item_project item descriptor = None)
  : exists
    (i : nat)
    (is_equiv : bool)
    (Hdescriptor : descriptor = Existing _ i is_equiv),
    projT1 (destination item) < i.
Proof.
  unfold equivocator_vlsm_transition_item_project in Hitem.
  destruct item.
  destruct descriptor as [s|i is_equiv]; [congruence|].
  exists i. exists is_equiv. exists eq_refl.
  destruct destination as (n, bs).
  destruct (le_lt_dec (S n) i); [assumption|].
  destruct l as (ls, [is | ix [|]]).
  - destruct (nat_eq_dec (S i) (S n)); congruence.
  - destruct (nat_eq_dec (S i) (S n)); congruence.
  - destruct (nat_eq_dec ix i); congruence.
Qed.

Lemma equivocator_transition_item_project_proper
  (item : vtransition_item equivocator_vlsm)
  (descriptor : MachineDescriptor)
  (Hproper : proper_descriptor X descriptor (destination item))
  : equivocator_vlsm_transition_item_project item descriptor <> None.
Proof.
  intro contra.
  apply equivocator_transition_item_project_inv_none in contra.
  destruct contra as [id [fd [Heqd Hd]]].
  subst. simpl in *. lia.
Qed.

(**
If [equivocator_vlsm_transition_item_project] produces a transition item,
then that item has the same [input] and [output] as the argument item.
*)
Lemma equivocator_transition_item_project_inv_messages
  (item : vtransition_item equivocator_vlsm)
  (itemX : vtransition_item X)
  (idescriptor odescriptor : MachineDescriptor)
  (Hitem : equivocator_vlsm_transition_item_project item idescriptor = Some (Some itemX, odescriptor))
  : exists
    (i : nat)
    (is_equiv : bool),
    idescriptor = Existing _ i is_equiv /\
    proper_descriptor X idescriptor (destination item) /\
    input item = input itemX /\ output item = output itemX.
Proof.
  unfold equivocator_vlsm_transition_item_project in Hitem.
  destruct idescriptor as [s|j fj]; [congruence|].
  exists j. exists fj. split; [reflexivity|].
  destruct item.
  destruct destination as (n, bs).
  destruct l as (lx, descriptorx).
  destruct (le_lt_dec (S n) j); [congruence|].
  destruct descriptorx as [s | i' [|]] eqn:Hl; simpl.
  - destruct (nat_eq_dec (S j) (S n)); congruence.
  - destruct (nat_eq_dec (S j) (S n)); [|congruence].
    split; [assumption|].
    inversion Hitem. subst. repeat split; reflexivity.
  - destruct (nat_eq_dec i' j); [|congruence].
    split; [assumption|].
    inversion Hitem. subst. repeat split; reflexivity.
Qed.

(**
If the 'destination' of a 'valid' equivocator 'transition_item' is singleton,
then by projecting the item to component 0 we actually obtain a
'transition_item' for the original machine.
*)
Lemma no_equivocating_equivocator_transition_item_project
  (item : vtransition_item equivocator_vlsm)
  (Hno_equiv_item : is_singleton_state X (destination item))
  (s : vstate equivocator_vlsm)
  (Hv : vvalid equivocator_vlsm (l item) (s, input item))
  (Ht : vtransition equivocator_vlsm (l item) (s, input item) = (destination item, output item))
  : equivocator_vlsm_transition_item_project item (Existing _ 0 false) =
      Some (Some
        {| l := fst (l item); input := input item; output := output item; destination := equivocator_state_descriptor_project X (destination item) (Existing _ 0 false) |}
        , Existing _ 0 false).
Proof.
  destruct item.
  unfold Common.l, Common.input, Common.output, Common.destination in *.
  unfold equivocator_vlsm_transition_item_project.
  destruct l as (li, eqvi).
  destruct destination as (ni, bsi) eqn:Hdesti.
  destruct (le_lt_dec (S ni) 0); [lia|].
  specialize
    (equivocator_transition_no_equivocation_zero_descriptor X _ _ _ _ _ Hv Ht Hno_equiv_item)
    as Heq_eqvi.
  simpl in Heq_eqvi. subst eqvi.
  destruct (nat_eq_dec 0 0); [|congruence].
  reflexivity.
Qed.

Lemma equivocator_transition_item_project_proper_characterization
  (item : vtransition_item equivocator_vlsm)
  (descriptor : MachineDescriptor)
  (Hproper : proper_descriptor X descriptor (destination item))
  : exists oitem descriptor',
    equivocator_vlsm_transition_item_project item descriptor = Some (oitem, descriptor')
    /\ match oitem with
      | Some itemx =>
        l itemx = fst (l item) /\  input item = input itemx /\ output item = output itemx /\
        (equivocator_state_descriptor_project X (destination item) descriptor = destination itemx)
      | None => True
      end
    /\ forall
      (s : vstate equivocator_vlsm)
      (Hv : vvalid equivocator_vlsm (l item) (s, input item))
      (Ht : vtransition equivocator_vlsm (l item) (s, input item) = (destination item, output item)),
      proper_descriptor X descriptor' s /\
      match oitem with
      | Some itemx =>
        forall (sx : vstate X)
          (Hsx : sx = equivocator_state_descriptor_project X s descriptor'),
          vvalid X (l itemx) (sx, input itemx) /\
          vtransition X (l itemx) (sx, input itemx) = (destination itemx, output itemx)
      | None =>
        equivocator_state_descriptor_project X (destination item) descriptor = equivocator_state_descriptor_project X s descriptor'
      end.
Proof.
  destruct item. simpl. simpl in Hproper.
  unfold equivocator_vlsm_transition_item_project.
  destruct descriptor eqn:Heqvi.
  - exists None. eexists _. split; [reflexivity|].
    intros. split; [exact I|]. intros.
    split; [|reflexivity].
    assumption.
  - destruct l as (li, eqvi).
    simpl in Hproper.
    destruct destination as (ni, bsi) eqn:Hdesti.
    simpl in Hproper.
    destruct (le_lt_dec (S ni) n); [lia|].
    destruct eqvi as [nsi | ieqvi feqvi].
    + destruct (nat_eq_dec (S n) (S ni)).
      * exists None. eexists _. split; [reflexivity|]. split; [exact I|].
        intros.
        inversion e. subst. clear e.
        split; [apply Hv|].
        apply
          (new_machine_label_equivocator_state_project_last X (li, NewMachine X nsi) s input _ output Ht nsi eq_refl b).
      * exists None. eexists _. split; [reflexivity|]. split; [exact I|].
        intros.
        apply and_comm.
        split.
        { apply
          (new_machine_label_equivocator_state_project_not_last X (li, NewMachine X nsi) s input _ output Ht nsi eq_refl).
          simpl. lia.
        }
        simpl.
        unfold vtransition in Ht. unfold_transition Ht. unfold snd in Ht.
        inversion Ht. subst. clear Ht.
        destruct s as (neqv, seqv). simpl in *. inversion H0.
        subst ni. lia.
    + destruct feqvi; [destruct (nat_eq_dec (S n) (S ni))|destruct (nat_eq_dec ieqvi n)].
      * inversion e. subst ni. clear e.
        eexists _. eexists _. split; [reflexivity|]. split; [repeat split|].
        -- unfold equivocator_state_descriptor_project.
          unfold equivocator_state_project.
          destruct (le_lt_dec (S n) n); [lia|]. simpl. f_equal. apply of_nat_ext.
        -- intros.
          destruct Hv as [Heqv Hv].
          split; [assumption|].
          intros.
          unfold equivocator_state_descriptor_project in Hsx.
          unfold equivocator_state_project in Hsx.
          simpl.
          unfold fst in Hv.
          unfold vvalid in Hv.
          unfold vtransition in Ht.
          unfold_transition Ht. unfold snd in Ht.
          destruct (le_lt_dec (S (projT1 s)) ieqvi); [lia|].
          replace (of_nat_lt l0) with (of_nat_lt Heqv) in * by apply of_nat_ext.
          clear l0.
          assert (Hsxi : sx = projT2 s (of_nat_lt Heqv)).
          { subst.
            destruct s as (nsi, si). unfold projT2.
            simpl in Heqv.
            destruct (le_lt_dec (S nsi) ieqvi); [lia|].
            f_equal. apply of_nat_ext.
          }
          rewrite Hsxi. split; [assumption|].
          unfold fst in Ht.
          destruct (vtransition X li (projT2 s (of_nat_lt Heqv), input))
            as (si'', om') eqn:Ht'.
          inversion Ht.
          f_equal.
          destruct s as (ns, bs).
          inversion H0. subst n. simpl_existT. subst bsi.
          rewrite to_nat_of_nat.
          destruct (nat_eq_dec (S ns) (S ns)); [|congruence].
          reflexivity.
      * eexists _. eexists _. split; [reflexivity|]. split; [exact I|].
        intros.
        apply and_comm.
        split.
        { apply
            (existing_true_label_equivocator_state_project_not_last X (li, Existing X ieqvi true) s input _ output Ht _ eq_refl )
          ; [|simpl; lia].
          apply Hv.
        }
        destruct Hv as [Heqv Hv].
        unfold vtransition in Ht. unfold_transition Ht. unfold snd in Ht.
        destruct (le_lt_dec (S (projT1 s)) ieqvi); [lia|].
        destruct (vtransition X (fst (li, Existing X ieqvi true))
        (projT2 s (of_nat_lt l0), input))
          as (si', om').
        inversion Ht. subst.
        destruct s as (neqv, seqv). simpl in *.
        inversion H0. subst ni. lia.
      * subst ieqvi.
        eexists _. eexists _. split; [reflexivity|].
        split; [repeat split|].
        -- unfold equivocator_state_descriptor_project.
          unfold equivocator_state_project.
          destruct (le_lt_dec (S ni) n); [lia|]. simpl. f_equal. apply of_nat_ext.
        -- intros.  destruct Hv as [Heqv Hv].
          split; [assumption|].
          intros. simpl.
          unfold equivocator_state_descriptor_project in Hsx.
          unfold equivocator_state_project in Hsx.
          unfold fst in Hv.
          unfold vvalid in Hv.
          unfold vtransition in Ht. unfold_transition Ht. unfold snd in Ht.
          destruct (le_lt_dec (S (projT1 s)) n); [lia|].
          replace (of_nat_lt l0) with (of_nat_lt Heqv) in * by apply of_nat_ext.
          clear l0.
          assert (Hsxi : sx = projT2 s (of_nat_lt Heqv)).
          { subst.
            destruct s as (nsi, si). unfold projT2.
            simpl in Heqv.
            destruct (le_lt_dec (S nsi) n); [lia|].
            f_equal. apply of_nat_ext.
          }
          rewrite Hsxi. split; [assumption|].
          unfold fst in Ht.
          destruct (vtransition X li (projT2 s (of_nat_lt Heqv), input))
            as (si'', om') eqn:Ht'.
          inversion Ht. clear Ht. subst ni.
          simpl_existT. subst bsi.
          f_equal.
          rewrite eq_dec_if_true; [reflexivity|].
          apply of_nat_ext.
      * eexists _. eexists _. split; [reflexivity|]. split; [exact I|].
        intros.
        apply and_comm.
        split.
        { apply
            (existing_false_label_equivocator_state_project_not_same X (li, Existing X ieqvi false) s input _ output Ht _ eq_refl)
          ; [| simpl; lia|assumption].
          destruct Hv as [Hieqvi Hv].
          assumption.
        }
        destruct Hv as [Heqv Hv].
        unfold vtransition in Ht. unfold_transition Ht. unfold snd in Ht.
        destruct (le_lt_dec (S (projT1 s)) ieqvi); [lia|].
        unfold fst in Ht.
        destruct (vtransition X li (projT2 s (of_nat_lt l0), input))
          as (si', om').
        inversion Ht. subst. simpl. lia.
Qed.

Lemma equivocator_transition_item_project_inv_characterization
  (item : vtransition_item equivocator_vlsm)
  (itemx : vtransition_item X)
  (descriptor descriptor' : MachineDescriptor)
  (Hitem : equivocator_vlsm_transition_item_project item descriptor = Some (Some itemx, descriptor'))
  : l itemx = fst (l item) /\  input item = input itemx /\ output item = output itemx /\
    (equivocator_state_descriptor_project X (destination item) descriptor = destination itemx)
    .
Proof.
  apply equivocator_transition_item_project_inv_messages in Hitem as Hitem'.
  destruct Hitem' as [_ [_ [_ [Hproper _]]]].
  apply equivocator_transition_item_project_proper_characterization in Hproper.
  destruct Hproper as [oitem [odescriptor [Hpr' H]]].
  rewrite Hpr' in Hitem.
  inversion Hitem. subst. apply H.
Qed.

(**
The projection of an [equivocator_vlsm] trace is obtained by traversing the
trace from right to left guided by the descriptors produced by
[equivocator_vlsm_transition_item_project] and gathering all non-empty
[transition_item]s it produces.
*)
Definition equivocator_vlsm_trace_project
  (tr : list (vtransition_item equivocator_vlsm))
  (descriptor : MachineDescriptor)
  : option (list (vtransition_item X) * MachineDescriptor)
  :=
  fold_right
    (fun item result =>
      match result with
      | None => None
      | Some (r, idescriptor) =>
        match equivocator_vlsm_transition_item_project item idescriptor with
        | None => None
        | Some (None, odescriptor) => Some (r, odescriptor)
        | Some (Some item', odescriptor) => Some (item' :: r, odescriptor)
        end
      end
    )
    (Some ([], descriptor))
    tr.

(**
Projecting on a [NewMachine] descriptor yields an empty trace and the same
descriptor.
*)
Lemma equivocator_vlsm_trace_project_on_new_machine
  (tr : list (vtransition_item equivocator_vlsm))
  (s : vstate X)
  : equivocator_vlsm_trace_project tr (NewMachine _ s) = Some ([], NewMachine _ s).
Proof.
  induction tr; [reflexivity|].
  simpl. rewrite IHtr. reflexivity.
Qed.

(** [equivocator_vlsm_trace_project] acts like a morphism w.r.t. concatenation
(single element in left operand case).
*)
Lemma equivocator_vlsm_trace_project_cons
  (bprefix : vtransition_item equivocator_vlsm)
  (bsuffix : list (vtransition_item equivocator_vlsm))
  (dstart dlast : MachineDescriptor)
  (tr : list (vtransition_item X))
  (Hproject : equivocator_vlsm_trace_project ([bprefix] ++ bsuffix) dlast = Some (tr, dstart))
  : exists
    (dmiddle : MachineDescriptor)
    (prefix suffix : list (vtransition_item X))
    (Hprefix : equivocator_vlsm_trace_project [bprefix] dmiddle = Some (prefix, dstart))
    (Hsuffix : equivocator_vlsm_trace_project bsuffix dlast = Some (suffix, dmiddle)),
    tr = prefix ++ suffix.
Proof.
  simpl in Hproject.
  destruct (equivocator_vlsm_trace_project bsuffix dlast) as [(suffix, dmiddle)|]
    eqn:Hsuffix
  ; [|congruence].
  exists dmiddle.
  destruct (equivocator_vlsm_transition_item_project bprefix dmiddle) as [[[prefix|] i]|]
    eqn:Hprefix
  ; inversion Hproject; subst; clear Hproject.
  - exists [prefix]. exists suffix.
    repeat split.
    simpl in *. rewrite Hprefix. reflexivity.
  -  exists []. exists tr.
    repeat split.
    simpl in *. rewrite Hprefix. reflexivity.
Qed.

(** [equivocator_vlsm_trace_project] acts like a morphism w.r.t. concatenation
*)
Lemma equivocator_vlsm_trace_project_app
  (bprefix bsuffix : list (vtransition_item equivocator_vlsm))
  (dlast dstart : MachineDescriptor)
  (tr : list (vtransition_item X))
  (Hproject : equivocator_vlsm_trace_project (bprefix ++ bsuffix) dlast = Some (tr, dstart))
  : exists
    (dmiddle : MachineDescriptor)
    (prefix suffix : list (vtransition_item X))
    (Hprefix : equivocator_vlsm_trace_project bprefix dmiddle = Some (prefix, dstart))
    (Hsuffix : equivocator_vlsm_trace_project bsuffix dlast = Some (suffix, dmiddle)),
    tr = prefix ++ suffix.
Proof.
  generalize dependent dstart. generalize dependent tr.
  induction bprefix; intros.
  - exists dstart. exists []. exists tr. exists eq_refl. exists Hproject. reflexivity.
  - rewrite <- app_comm_cons in Hproject.
    apply equivocator_vlsm_trace_project_cons in Hproject.
    destruct Hproject as [da [prefixa [tr' [Ha [Hproject Heq]]]]].
    spec IHbprefix tr' da Hproject.
    destruct IHbprefix as [dmiddle [prefix' [suffix [Hprefix [Hsuffix Htr']]]]].
    exists dmiddle.
    exists (prefixa ++ prefix'). exists suffix.
    repeat split; [|assumption|].
    + simpl. rewrite Hprefix.
      simpl in Ha.
      destruct (equivocator_vlsm_transition_item_project a da)
        as [(oitem', i)|]
      ; [|congruence].
      destruct oitem' as [item'|]; inversion Ha; subst; reflexivity.
    + subst. rewrite app_assoc. reflexivity.
Qed.

(** [equivocator_vlsm_trace_project] acts like a morphism w.r.t. concatenation
(converse)
*)
Lemma equivocator_vlsm_trace_project_app_inv
  (bprefix bsuffix : list (vtransition_item equivocator_vlsm))
  (dlast dstart dmiddle : MachineDescriptor)
  (prefix suffix : list (vtransition_item X))
  (Hprefix : equivocator_vlsm_trace_project bprefix dmiddle = Some (prefix, dstart))
  (Hsuffix : equivocator_vlsm_trace_project bsuffix dlast = Some (suffix, dmiddle))
  : equivocator_vlsm_trace_project (bprefix ++ bsuffix) dlast = Some (prefix ++ suffix, dstart).
Proof.
  generalize dependent dstart. generalize dependent prefix.
  induction bprefix; intros.
  - inversion Hprefix. subst. assumption.
  - simpl in Hprefix.
    destruct (equivocator_vlsm_trace_project bprefix dmiddle) as [(prefix', dstart')|]
      eqn:Hprefix'
    ; [|congruence].
    specialize (IHbprefix prefix' dstart' eq_refl).
    simpl. rewrite IHbprefix.
    destruct (equivocator_vlsm_transition_item_project a dstart')
      as [[[item'|]i]|]
    ; inversion Hprefix; subst; reflexivity.
Qed.

(**
Next we prove some inversion properties for [equivocator_vlsm_transition_item_project].
*)
Lemma equivocator_protocol_transition_item_project_inv2
  (l : vlabel equivocator_vlsm)
  (s' s: vstate equivocator_vlsm)
  (iom oom : option message)
  (Hv: vvalid equivocator_vlsm l (s', iom))
  (Ht: vtransition equivocator_vlsm l (s', iom) = (s, oom))
  (item := {| l := l; input := iom; destination := s; output := oom |})
  (di di' : MachineDescriptor)
  (item' : vtransition_item X)
  (Hitem: equivocator_vlsm_transition_item_project item di = Some (Some item', di'))
  : exists
    (i : nat)
    (fi : bool)
    (Hdi : di = Existing _ i fi)
    (Hi : i < S (projT1 s))
    (sx := projT2 s (of_nat_lt Hi))
    (Hitem' : item' = {| l := fst l; input := iom; destination := sx; output := oom |})
    (i' : nat)
    (fi' : bool)
    (Hdi' : di' = Existing _ i' fi')
    (Hi' : i' < S (projT1 s'))
    (s'x := projT2 s' (of_nat_lt Hi')),
    vvalid X (fst l) (s'x, iom) /\
    vtransition X (fst l) (s'x, iom) = (sx, oom).
Proof.
  unfold vvalid in Hv. unfold vtransition in Ht.
  unfold_transition Ht.
  simpl in Hv.
  unfold equivocator_vlsm_transition_item_project in Hitem.
  destruct di as [sn| i fi]; [congruence|].
  exists i. exists fi. exists eq_refl. unfold item in Hitem.
  destruct l as (lx, descriptor).
  destruct s as (ns, bs).
  destruct (le_lt_dec (S ns) i); [congruence|].
  exists l. unfold snd in Ht. unfold snd in Hv.
  destruct descriptor as [sn| j is_equiv].
  - destruct (nat_eq_dec (S i) (S ns)); congruence.
  - destruct Hv as [Hj Hv].
    destruct (le_lt_dec (S (projT1 s')) j); [lia|].
    replace (of_nat_lt l0) with (of_nat_lt Hj) in * by apply of_nat_ext. clear l0.
    simpl in Ht.
    destruct (vtransition X lx (projT2 s' (of_nat_lt Hj), iom))
      as (si', om') eqn:Htx.
    destruct s' as (n', bs').
    destruct is_equiv as [|].
    + destruct (nat_eq_dec (S i) (S ns)); [|congruence].
      inversion Hitem. subst di' item'. clear Hitem.
      exists eq_refl.
      exists j. exists true. exists eq_refl.
      exists Hj. split; [assumption|].
      inversion Ht. subst. clear Ht. inversion e. subst i. clear e.
      apply inj_pairT2 in H1. subst. simpl.
      rewrite to_nat_of_nat.
      destruct (nat_eq_dec (S n') (S n')); [assumption|].
      elim n. reflexivity.
    + destruct (nat_eq_dec j i); [|congruence]. subst.
      inversion Hitem. subst di' item'. clear Hitem.
      exists eq_refl. exists i. exists false. exists eq_refl.
      exists Hj. split; [assumption|].
      inversion Ht. subst. clear Ht.
      apply inj_pairT2 in H1. subst. simpl.
      rewrite eq_dec_if_true by apply of_nat_ext.
      assumption.
Qed.

Lemma equivocator_protocol_transition_item_project_inv3
  (l : vlabel equivocator_vlsm)
  (s s' : vstate equivocator_vlsm)
  (iom oom : option message)
  (Hv: vvalid equivocator_vlsm l (s', iom))
  (Ht: vtransition equivocator_vlsm l (s', iom) = (s, oom))
  (item := {| l := l; input := iom; destination := s; output := oom |})
  (di di' : MachineDescriptor)
  (Hitem: equivocator_vlsm_transition_item_project item di = Some (None, di'))
  : match di with
    | NewMachine _ sn => di' = di
    | Existing _ i fi =>
      match di' with
      | Existing _ i' fi' =>
        exists
          (Hi : i < S (projT1 s))
          (Hi' : i' < S (projT1 s')),
          projT2 s' (of_nat_lt Hi') = projT2 s (of_nat_lt Hi)
      | NewMachine _ sn' =>
        exists
          (Hl : snd l = NewMachine _ sn')
          (Hi : i = (projT1 s))
          (Hiom : iom = None)
          (Hoom : oom = None)
          (Hsn : projT2 s (of_nat_lt (le_n (S (projT1 s)))) = sn')
          ,
          vinitial_state_prop X sn'
      end
    end.
Proof.
  unfold vvalid in Hv. unfold vtransition in Ht.
  destruct l as (lx, d).
  simpl in Hv. unfold_transition Ht. unfold snd in Ht.
  unfold equivocator_vlsm_transition_item_project in Hitem.
  destruct di as [si | i fi]; [inversion Hitem; reflexivity|].
  simpl in Hv. unfold item in Hitem.
  destruct s as (ns, bs).
  destruct (le_lt_dec (S ns) i); [congruence|].
  destruct d as [sd | id fd].
  - destruct (nat_eq_dec (S i) (S ns)); inversion Hitem; subst; clear Hitem.
    + simpl. exists eq_refl. inversion e. exists eq_refl.
      destruct s' as (ns', bs'). inversion Ht. subst.
      simpl_existT.
      destruct Hv. repeat split; [assumption| |assumption].
      rewrite to_nat_of_nat.
      destruct (nat_eq_dec (S ns') (S ns')); [|elim n]; reflexivity.
    + simpl. exists l. inversion Ht. subst.
      destruct s' as (ns', bs').
      simpl in H0. inversion H0. subst.
      simpl_existT. simpl.
      assert (Hi : i < S ns') by lia.
      exists Hi. subst.
      rewrite to_nat_of_nat.
      destruct (nat_eq_dec i (S ns')); [lia|].
      f_equal. apply of_nat_ext.
  - destruct Hv as [Hj Hv].
    destruct (le_lt_dec (S (projT1 s')) id); [lia|].
    replace (of_nat_lt l0) with (of_nat_lt Hj) in * by apply of_nat_ext. clear l0.
    destruct s' as (n', bs'). simpl in Hv. unfold projT2 in Ht. simpl in Hj.
    simpl in Ht.
    destruct
      (@vtransition message X lx
      (@pair (@vstate message X) (option message)
         (bs' (@of_nat_lt id (S n') Hj)) iom))
      as (si', om') eqn:Htx.
    destruct fd as [|].
    + destruct (nat_eq_dec (S i) (S ns)); [congruence|].
      inversion Hitem. subst di'. clear Hitem.
      simpl. exists l. inversion Ht. subst.
      assert (Hi' : i < S n') by lia.
      exists Hi'.
      simpl_existT. subst.
      rewrite to_nat_of_nat in *.
      destruct (nat_eq_dec i (S n')); [lia|].
      f_equal.
      apply of_nat_ext.
    + destruct (nat_eq_dec id i); [congruence|].
      inversion Hitem. subst di'. clear Hitem. simpl.
      exists l. inversion Ht. subst. exists l.
      simpl_existT. subst.
      rewrite eq_dec_if_false; [reflexivity|].
      intro contra. apply (f_equal to_nat) in contra.
      repeat rewrite to_nat_of_nat in contra.
      inversion contra. elim n. assumption.
Qed.

Lemma equivocator_protocol_transition_item_project_inv4
  (l : vlabel equivocator_vlsm)
  (s s' : vstate equivocator_vlsm)
  (iom oom : option message)
  (Hv: vvalid equivocator_vlsm l (s', iom))
  (Ht: vtransition equivocator_vlsm l (s', iom) = (s, oom))
  (i' : nat)
  (fi' : bool)
  (Hi' : i' < S (projT1 s'))
  : exists
    (Hi'' : i' < S (projT1 s))
    (fi'' : bool)
    (oitem : option (vtransition_item X))
    (item := {| l := l; input := iom; destination := s; output := oom |}),
    equivocator_vlsm_transition_item_project item (Existing _ i' fi') = Some (oitem, Existing _ i' fi'').
Proof.
  unfold vvalid in Hv. unfold vtransition in Ht.
  simpl in Hv. unfold_transition Ht. unfold equivocator_vlsm_transition_item_project.
  destruct l as (lx, descriptor). simpl in Hv. unfold snd in Ht.
  destruct s as (ns, bs).
  destruct s' as (n', bs').
  destruct descriptor as [sn | j is_equiv].
  - simpl in Ht.
    inversion Ht. subst. clear Ht. simpl_existT.
    unfold projT1.
    simpl in Hi'.
    assert (Hi'' : i' < S (S n')) by lia.
    exists Hi''.
    destruct (le_lt_dec (S (S n')) i'). { lia. }
    replace (of_nat_lt l) with (of_nat_lt Hi'') in * by apply of_nat_ext. clear l.
    rewrite eq_dec_if_false.
    + exists false. exists None. reflexivity.
    + lia.
  - destruct Hv as [Hj Hv]. unfold projT1 in Ht. simpl in Hj.
    destruct (le_lt_dec (S n') j); [lia|].
    replace (of_nat_lt l) with (of_nat_lt Hj) in * by apply of_nat_ext. clear l.
    simpl in Ht.
    destruct (vtransition X lx (bs' (of_nat_lt Hj), iom))
      as (si', om') eqn:Htx.
    simpl in Hi'.
    assert (Hi'' : i' < S (S n')) by lia.
    destruct is_equiv as [|] eqn:Hflag
    ; inversion Ht; subst ns om'; clear Ht
    ; apply inj_pairT2 in H1; subst bs.
    + destruct (le_lt_dec (S (S n')) i'); [lia|].
      destruct (nat_eq_dec (S i') (S (S n'))); [lia|].
      exists Hi''. exists false.
      exists None. reflexivity.
    + destruct (le_lt_dec (S n') i'); [lia|].
      destruct (nat_eq_dec j i').
      * subst j.
        rewrite eq_dec_if_true by apply of_nat_ext.
        exists Hi'. exists false.
        exists (Some {| l := lx; input := iom; destination := si'; output := oom |}).
        reflexivity.
      * exists Hi'. exists false. exists None. reflexivity.
Qed.

Lemma equivocator_protocol_transition_item_project_inv5_new_machine
  (l : vlabel equivocator_vlsm)
  (s s' : vstate equivocator_vlsm)
  (iom oom : option message)
  (Hv: vvalid equivocator_vlsm l (s', iom))
  (Ht: vtransition equivocator_vlsm l (s', iom) = (s, oom))
  (item := {| l := l; input := iom; destination := s; output := oom |})
  (fi : bool)
  (sn : state)
  (Hnew : snd l = NewMachine _ sn)
  : exists
    (i : nat)
    (Hi : i < S (projT1 s)),
    equivocator_vlsm_transition_item_project item (Existing _ i fi) = Some (None, snd l).
Proof.
  unfold equivocator_vlsm_transition_item_project.
  destruct s as (ns, bs).
  destruct s' as (ns', bs').
  unfold vtransition in Ht. unfold_transition Ht.
  unfold vvalid in Hv. simpl in Hv.
  destruct l as (lx, d). unfold snd in Ht. simpl in Hv.
  simpl in Hnew. subst d.
  inversion Ht. subst; clear Ht.
  simpl_existT.
  exists (S ns').  split; [simpl; lia|].
  unfold snd. unfold item.
  destruct (le_lt_dec (S (S ns')) (S ns')); [lia|].
  rewrite eq_dec_if_true; reflexivity.
Qed.

Lemma equivocator_protocol_transition_item_project_inv5
  (l : vlabel equivocator_vlsm)
  (s s' : vstate equivocator_vlsm)
  (iom oom : option message)
  (Hv: vvalid equivocator_vlsm l (s', iom))
  (Ht: vtransition equivocator_vlsm l (s', iom) = (s, oom))
  (item := {| l := l; input := iom; destination := s; output := oom |})
  (fi : bool)
  (i : nat)
  (is_equiv : bool)
  (Hsndl : snd l = Existing _ i is_equiv)
  : exists
    (i : nat)
    (Hi : i < S (projT1 s))
    (itemx : vtransition_item X),
    equivocator_vlsm_transition_item_project item (Existing _ i fi) = Some (Some itemx, snd l).
Proof.
  unfold equivocator_vlsm_transition_item_project.
  destruct s as (ns, bs).
  destruct s' as (ns', bs').
  unfold vtransition in Ht. unfold_transition Ht.
  unfold vvalid in Hv. simpl in Hv.
  destruct l as (lx, d). unfold snd in Ht. simpl in Hv.
  simpl in Hsndl. subst d.
  unfold snd. unfold item. destruct Hv as [Hi Hv].
  unfold projT1 in Ht.
  destruct (le_lt_dec (S ns') i); [lia|].
  replace (of_nat_lt l) with (of_nat_lt Hi) in * by apply of_nat_ext. clear l.
  simpl in Ht.
  destruct (vtransition X lx (bs' (of_nat_lt Hi), iom)) as (sn', om').
  destruct is_equiv as [|]; inversion Ht; subst; clear Ht; apply inj_pairT2 in H1; subst.
  + exists (S ns'). split; [simpl; lia|].
    destruct (le_lt_dec (S (S ns')) (S ns')); [lia|].
    rewrite eq_dec_if_true by  reflexivity.
    eexists _. reflexivity.
  + exists i. exists Hi.
    destruct (le_lt_dec (S ns) i); [lia|].
    rewrite eq_dec_if_true by reflexivity.
    eexists _. reflexivity.
Qed.

(**
The projection of a segment of an [equivocator_vlsm] protocol trace
is defined and a protocol trace segment in the original vlsm.
*)
Lemma equivocator_vlsm_trace_project_protocol
  (bs : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (Hbtr : finite_protocol_trace_from equivocator_vlsm bs btr)
  (j : nat)
  (Hj : j < S (projT1 (finite_trace_last bs btr)))
  (jf : bool)
  : exists
    (tr : list (vtransition_item X))
    (di : MachineDescriptor)
    (Htr : equivocator_vlsm_trace_project btr (Existing _ j jf) = Some (tr, di)),
    match di with
    | NewMachine _ sn =>
      vinitial_state_prop X sn
      /\ projT2 (finite_trace_last bs btr) (of_nat_lt Hj) = finite_trace_last sn tr
      /\ finite_protocol_trace_from X sn tr
    | Existing _ i fi =>
      exists
      (Hi : i < S (projT1 bs))
      (s := projT2 bs (of_nat_lt Hi))
      (Hlast : projT2 (finite_trace_last bs btr) (of_nat_lt Hj) = finite_trace_last s tr)
      ,
      finite_protocol_trace_from X s tr
    end.
Proof.
  induction Hbtr; intros.
  - exists []. simpl. exists (Existing _ j jf). exists eq_refl. exists Hj. exists eq_refl.
    constructor. apply equivocator_state_project_protocol_state in H.
    destruct s. simpl. apply H.
  - remember {| l := l; input := iom; destination := s; output := oom |} as item.
    destruct H as [[Hs' [Hiom Hv]] Ht].
    apply equivocator_state_project_protocol_state in Hs'.
    apply equivocator_state_project_protocol_message in Hiom.
    remember (finite_trace_last s' (item :: tl)) as lst.
    rewrite finite_trace_last_cons in Heqlst.
    rewrite Heqitem in Heqlst. simpl in Heqlst.
    subst lst.
    specialize (IHHbtr Hj).
    destruct IHHbtr as [tr [di [Htl Hdi]]].
    simpl. rewrite Htl.
    destruct di as [sn| i fi].
    + simpl. exists tr. exists (NewMachine _ sn). exists eq_refl. assumption.
    + destruct (equivocator_vlsm_transition_item_project item (Existing _ i fi)) as [[[item'|]di']|]
        eqn:Hitem.
      * exists (item' :: tr). exists di'. exists eq_refl.
        subst item.
        apply (equivocator_protocol_transition_item_project_inv2 l s' s) in Hitem
        ; [|assumption|assumption].
        destruct Hitem as [_i [_fi [Heq [Hi [Heqitem' Hitem]]]]].
        inversion Heq. subst _i _fi. clear Heq.
        destruct Hdi as [_Hi Hlst].
        replace (of_nat_lt _Hi) with (of_nat_lt Hi) in * by apply of_nat_ext. clear _Hi.
        simpl in Hlst. destruct Hlst as [Hlst Htr].
        repeat rewrite map_cons.
        destruct Hitem as [i' [fi' [Hdi' [Hi' [Hv' Ht']]]]].
        subst di'. exists Hi'.
        rewrite finite_trace_last_cons. subst. simpl. exists Hlst.
        constructor; [assumption|].
        repeat split; [|assumption|assumption|assumption].
        destruct s' as (ns', bs'). apply Hs'.
      * subst item.
        destruct Hdi as [Hi [Hlst Htr]].
        apply (equivocator_protocol_transition_item_project_inv3 l s s') in Hitem
        ; [|assumption|assumption].
        eexists _. eexists _. exists eq_refl.
        destruct di' as [sn' | i' fi'].
        -- destruct Hitem as [Hl [Hi' [Hiom' [Hoom [Hsn'eq Hsn']]]]]. subst.
          replace (of_nat_lt (le_n (S (projT1 s)))) with (of_nat_lt Hi) in * by apply of_nat_ext.
          repeat split; assumption.
        -- destruct Hitem as [_Hi [Hi' Heq]].
          replace (of_nat_lt _Hi) with (of_nat_lt Hi) in Heq by apply of_nat_ext. clear _Hi.
          exists Hi'. rewrite Heq. exists Hlst. assumption.
      * apply equivocator_transition_item_project_inv_none in Hitem.
        destruct Hitem as [_i [_fi [Heq Hitem]]].
        destruct Hdi as [Hi Hdi].
        inversion Heq. subst _i _fi item. simpl in Hitem. lia.
Qed.

(**
The projection of a segment of a protocol trace from the [pre_loaded_with_all_messages_vlsm]
corresponding to the [equivocator_vlsm] is defined and it is a protocol
trace segment in the [pre_loaded_with_all_messages_vlsm] corresponding to the original vlsm.
*)
Lemma preloaded_equivocator_vlsm_trace_project_protocol
  (bs bf : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (Hbtr : finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm equivocator_vlsm) bs bf btr)
  (j : nat)
  (Hj : j < S (projT1 bf))
  (jf : bool)
  : exists
    (tr : list (vtransition_item X))
    (di : MachineDescriptor)
    (Htr : equivocator_vlsm_trace_project btr (Existing _ j jf) = Some (tr, di)),
    match di with
    | NewMachine _ sn =>
      finite_protocol_trace_init_to (pre_loaded_with_all_messages_vlsm X)
           sn (projT2 bf (of_nat_lt Hj)) tr
    | Existing _ i fi =>
      exists
      (Hi : i < S (projT1 bs))
      (s := projT2 bs (of_nat_lt Hi))
      (f := projT2 bf (of_nat_lt Hj))
      ,
      finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm X) s f tr
    end.
Proof.
  induction Hbtr; intros.
  - exists []. simpl. exists (Existing _ j jf). exists eq_refl. exists Hj.
    constructor.
    apply (preloaded_equivocator_state_project_protocol_state _ s H (of_nat_lt Hj)).
  - remember {| l := l; input := iom; destination := s; output := oom |} as item.
    destruct H as [[Hs' [Hiom Hv]] Ht].
    specialize (preloaded_equivocator_state_project_protocol_state _ _ Hs') as Hs'X.
    remember
      (@finite_trace_last message
      (@type message equivocator_vlsm) s'
      (item::tl))
      as lst.
    rewrite finite_trace_last_cons in Heqlst.
    rewrite Heqitem in Heqlst. simpl in Heqlst.
    subst lst.
    specialize (IHHbtr Hj).
    destruct IHHbtr as [tr [di [Htl Hdi]]].
    simpl. rewrite Htl.
    destruct di as [sn| i fi].
    + simpl. exists tr. exists (NewMachine _ sn). exists eq_refl. assumption.
    + destruct (equivocator_vlsm_transition_item_project item (Existing _ i fi)) as [[[item'|]di']|]
        eqn:Hitem.
      * exists (item' :: tr). exists di'. exists eq_refl.
        subst item.
        apply (equivocator_protocol_transition_item_project_inv2 l s' s) in Hitem
        ; [|assumption|assumption].
        destruct Hitem as [_i [_fi [Heq [Hi [Heqitem' Hitem]]]]].
        inversion Heq. subst _i _fi. clear Heq.
        destruct Hdi as [_Hi Htr].
        replace (of_nat_lt _Hi) with (of_nat_lt Hi) in * by apply of_nat_ext. clear _Hi.
        destruct di' as [sn'| i' fi']
        ; [destruct Hitem as [i' [fi' [Hcontra _]]]; congruence|].
        destruct Hitem as [_i' [_fi' [Heq [Hi' [Hv' Ht']]]]].
        inversion Heq. subst _i' _fi'. clear Heq.
        exists Hi'.
        subst item'.
        apply (finite_ptrace_from_to_extend (pre_loaded_with_all_messages_vlsm X)); [assumption|].
        repeat split; [apply Hs'X| |assumption|assumption].
        exists (proj1_sig (vs0 X)). apply (pre_loaded_with_all_messages_message_protocol_prop X).
      * subst item.
        apply (equivocator_protocol_transition_item_project_inv3 l s s') in Hitem
        ; [|assumption|assumption].
        destruct Hdi as [Hi Htr].
        eexists _. eexists _. exists eq_refl.
        destruct di' as [sn' | i' fi'].
        -- destruct Hitem as [Hl [_Hi [_Hiom [_Hoom [_Hsn' Hsn']]]]]. subst.
          split; [|assumption].
          replace (of_nat_lt (le_n (S (projT1 s)))) with (of_nat_lt Hi) in * by apply of_nat_ext.
          exact Htr.
        -- destruct Hitem as [_Hi [Hi' Heq]].
          replace (of_nat_lt _Hi) with (of_nat_lt Hi) in * by apply of_nat_ext. clear _Hi.
          exists Hi'. rewrite Heq. assumption.
      * apply equivocator_transition_item_project_inv_none in Hitem.
        destruct Hitem as [_i [_fi [Heq Hitem]]].
        destruct Hdi as [Hi Hdi].
        inversion Heq. subst _i _fi item. simpl in Hitem. lia.
Qed.

(**
The projection of a protocol trace from the [pre_loaded_with_all_messages_vlsm]
corresponding to the [equivocator_vlsm] is defined and it is a protocol
trace in the [pre_loaded_with_all_messages_vlsm] corresponding to the original vlsm.
*)
Lemma preloaded_equivocator_vlsm_project_protocol_trace
  (bs bf : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (Hbtr : finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm equivocator_vlsm) bs bf btr)
  (j : nat)
  (Hj : j < S (projT1 bf))
  (jf : bool)
  : exists
    (tr : list (vtransition_item X))
    (di : MachineDescriptor)
    (Htr : equivocator_vlsm_trace_project btr (Existing _ j jf) = Some (tr, di)),
    match di with
    | NewMachine _ sn =>
      finite_protocol_trace_init_to (pre_loaded_with_all_messages_vlsm X)
        sn (projT2 bf (of_nat_lt Hj)) tr
    | Existing _ i fi =>
      exists
      (Hi : i < S (projT1 bs))
      (s := projT2 bs (of_nat_lt Hi))
      (f := projT2 bf (of_nat_lt Hj))
      ,
      finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm X) s f tr
      /\ (vinitial_state_prop (pre_loaded_with_all_messages_vlsm equivocator_vlsm) bs
          -> vinitial_state_prop (pre_loaded_with_all_messages_vlsm X) s)
    end.
Proof.
  destruct (preloaded_equivocator_vlsm_trace_project_protocol bs bf btr Hbtr j Hj jf)
    as [tr [di [Hproject Hdi]]].
  exists tr.
  exists di.
  exists Hproject.
  destruct di as [sn | i fi].
  - destruct Hdi as [Hsn Htr].
    repeat split; assumption.
  - destruct Hdi as [Hi Htr].
    exists Hi. split; [assumption|].
    intro Hinit.
    destruct Hinit.
    cut (projT2 bs (of_nat_lt (Hzero X bs)) = projT2 bs (of_nat_lt Hi)).
    { intro R. rewrite <- R. assumption. }
    f_equal. assert (Hi0 : i = 0) by lia. subst. apply of_nat_ext.
Qed.

(**
If [equivocator_vlsm_trace_project] does not fail, then the index of the
machine descriptor is valid for the last state of the trace argument.
*)
Set Printing Implicit.
Lemma equivocator_vlsm_trace_project_inv
  (tr: list transition_item)
  (Hntr : tr <> [])
  (j: nat)
  (fj : bool)
  (HtrX: equivocator_vlsm_trace_project tr (Existing _ j fj) <> None)
  (is: state)
  : j < S (projT1 (finite_trace_last is tr)).
Proof.
  apply exists_last in Hntr.
  destruct Hntr as [suffix [x Heq]]. subst tr.
  destruct (equivocator_vlsm_trace_project (suffix ++ [x]) (Existing _ j fj)) eqn:Htr
  ; [|elim HtrX; reflexivity].
  clear HtrX. destruct p as (trX, d).
  apply equivocator_vlsm_trace_project_app in Htr.
  destruct Htr as [dmiddle [_ [lx [_ [Hx _]]]]].
  rewrite finite_trace_last_is_last.
  remember (Existing _ j fj) as dj.
  simpl in *.
  destruct (equivocator_vlsm_transition_item_project x dj)
    as [(_x, _dmiddle)|]
    eqn:Hx'
  ; [|congruence].
  destruct _x as [itemx|]; inversion Hx; subst lx _dmiddle; clear Hx.
  - subst. destruct x. unfold equivocator_vlsm_transition_item_project in Hx'.
    destruct l. destruct destination.
    destruct (le_lt_dec (S x) j); [congruence|].
    assumption.
  - subst. unfold equivocator_vlsm_transition_item_project in Hx'. destruct x. destruct l. destruct destination.
    destruct (le_lt_dec (S x) j); [congruence|].
    assumption.
Qed.

(**
Projecting a protocol trace segment on an index which is valid for the
first state of the trace does not fail and yields the same index.
*)
Lemma preloaded_equivocator_vlsm_trace_project_protocol_inv
  (bs : vstate equivocator_vlsm)
  (btr : list (vtransition_item equivocator_vlsm))
  (Hbtr : finite_protocol_trace_from (pre_loaded_with_all_messages_vlsm equivocator_vlsm) bs btr)
  (i : nat)
  (Hi : i < S (projT1 bs))
  (fi : bool)
  : exists
    (fii : bool)
    (tr : list (vtransition_item X)),
    equivocator_vlsm_trace_project btr (Existing _ i fi) = Some (tr, Existing _ i fii).
Proof.
  revert fi.
  generalize dependent i.
  induction Hbtr; intros.
  - simpl. exists fi. exists []. reflexivity.
  - remember {| l := l; input := iom; destination := s; output := oom |} as item.
    simpl.
    destruct H as [[_ [_ Hv]] Ht].
    specialize
      (equivocator_protocol_transition_item_project_inv4 l s s' iom oom Hv Ht i)
      as Hitem.
    replace
      (@Build_transition_item message (@type message equivocator_vlsm) l iom s oom)
      with item in Hitem.
    destruct (Hitem false Hi) as [Hi' _].
    spec IHHbtr i Hi' fi.
    destruct IHHbtr as [fii' [tr Htr]].
    rewrite Htr.
    spec Hitem fii' Hi.
    destruct Hitem as [_ [fi'' [oitem Hoitem]]].
    rewrite Hoitem. exists fi''.
    destruct oitem as [itemx|].
    + exists (itemx :: tr). reflexivity.
    + exists tr. reflexivity.
Qed.

(**
An inversion lemma about projections of a protocol trace segment
*)
Lemma preloaded_equivocator_vlsm_trace_project_protocol_inv2
  (is fs: state)
  (tr: list transition_item)
  (Hntr : tr <> [])
  (Htr: finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm equivocator_vlsm) is fs tr)
  (j : nat)
  (fj : bool)
  (di : MachineDescriptor)
  (trX: list (vtransition_item X))
  (HtrX: equivocator_vlsm_trace_project tr (Existing _ j fj) = Some (trX, di))
  : exists (Hj : j < S (projT1 fs)),
    match di with
    | NewMachine _ sn =>
      finite_protocol_trace_init_to (pre_loaded_with_all_messages_vlsm X)
        sn (projT2 fs (of_nat_lt Hj)) trX
    | Existing _ i fi =>
      exists
      (Hi : i < S (projT1 is)),
      finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm X)
        (projT2 is (of_nat_lt Hi)) (projT2 fs (of_nat_lt Hj)) trX
    end.
Proof.
  specialize (equivocator_vlsm_trace_project_inv _ Hntr j fj) as Hj.
  spec Hj. { rewrite HtrX. intro contra. congruence. }
  spec Hj is.
  replace (@finite_trace_last _ (@type _ equivocator_vlsm) is tr) with fs in Hj
    by (rewrite <- (ptrace_get_last Htr);reflexivity).
  exists Hj.
  destruct
    (preloaded_equivocator_vlsm_trace_project_protocol _ _ _ Htr _ Hj fj)
    as [trX' [di' [HtrX' Hdi']]].
  rewrite HtrX in HtrX'.
  inversion HtrX'. subst di' trX'. clear HtrX'.
  assumption.
Qed.

(**
An inversion lemma about projections of a protocol trace
*)
Lemma preloaded_equivocator_vlsm_protocol_trace_project_inv2
  (is fs: state)
  (tr: list transition_item)
  (Hntr : tr <> [])
  (Htr: finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm equivocator_vlsm) is fs tr)
  (j : nat)
  (fj : bool)
  (di : MachineDescriptor)
  (trX: list (vtransition_item X))
  (HtrX: equivocator_vlsm_trace_project tr (Existing _ j fj) = Some (trX, di))
  : exists
    (Hj : j < S (projT1 fs)),
    match di with
    | NewMachine _ sn =>
      finite_protocol_trace_init_to (pre_loaded_with_all_messages_vlsm X)
        sn (projT2 fs (of_nat_lt Hj)) trX
    | Existing _ i fi =>
      exists
      (Hi : i < S (projT1 is))
      (s := projT2 is (of_nat_lt Hi))
      (f := projT2 fs (of_nat_lt Hj))
      ,
      finite_protocol_trace_from_to (pre_loaded_with_all_messages_vlsm X) s f trX
      /\ (vinitial_state_prop (pre_loaded_with_all_messages_vlsm equivocator_vlsm) is -> vinitial_state_prop (pre_loaded_with_all_messages_vlsm X) s)
    end.
Proof.
  specialize (equivocator_vlsm_trace_project_inv _ Hntr j fj) as Hj.
  spec Hj. { rewrite HtrX. intro contra. congruence. }
  spec Hj is.
  replace (@finite_trace_last _ (@type _ equivocator_vlsm) is tr) with fs in Hj
    by (symmetry;apply (ptrace_get_last Htr)).
  exists Hj.
  destruct
    (preloaded_equivocator_vlsm_project_protocol_trace _ _ _ Htr _ Hj fj)
    as [trX' [di' [HtrX' Hdi]]].
  rewrite HtrX in HtrX'.
  inversion HtrX'. subst di' trX'.  clear HtrX'.
  assumption.
Qed.

End equivocator_vlsm_projections.


Require Import List.
Require Import ZArith.
Require Import Psatz.
Require Import ITree.ITree.
Require Import ITree.Interp.Traces.
Require Import compcert.lib.Integers.
Require Import compcert.common.Memory.
Require Import VST.progs.io_specs.
Require Import VST.progs.io_dry.
Import ExtLib.Structures.Monad.

Import MonadNotation.
Local Open Scope monad_scope.
Local Open Scope Z.

(* Weaker pre condition using trace_incl instead of eutt. *)
Definition getchar_pre' (m : mem) (witness : int -> IO_itree) (z : IO_itree) :=
  let k := witness in trace_incl (r <- read;; k r) z.

(* getchar_pre' really is weaker. *)
Goal forall m w z,
  getchar_pre m w z -> getchar_pre' m w z.
Proof.
  unfold getchar_pre, getchar_pre', trace_incl; intros ? * Heq * Htrace.
  apply eutt_trace_eq in Heq.
  apply Heq; auto.
Qed.

(* CertiKOS specs must terminate. Could get blocking version back by
   wrapping getchar in a loop. *)
Definition getchar_post' (m0 m : mem) r (witness : (int -> IO_itree) * IO_itree) (z : IO_itree) :=
  m0 = m /\
    (* Success *)
    ((0 <= Int.signed r <= two_p 8 - 1 /\ let (k, _) := witness in z = k r) \/
    (* No character to read *)
    let (_, z0) := witness in z = z0 /\ Int.signed r = -1).

(** Traces *)
Inductive IO_trace_event :=
| ETRead (r : Z)
| ETWrite (c : Z).
Definition etrace := list IO_trace_event.

Definition trace_event_rtype (e : IO_trace_event) :=
  match e with
  | ETRead _ => int
  | ETWrite _ => unit
  end.

Definition io_event_of_io_tevent (e : IO_trace_event)
  : IO_event (trace_event_rtype e) * (trace_event_rtype e) :=
  match e with
  | ETRead r => (ERead, Int.repr r)
  | ETWrite c => (EWrite (Int.repr c), tt)
  end.

Fixpoint trace_of_etrace (t : etrace) : @trace IO_event unit :=
  match t with
  | nil => TEnd
  | e :: t' =>
      let (e', r) := io_event_of_io_tevent e in
      TEventResponse e' r (trace_of_etrace t')
  end.

Section SanityChecks.
  Variable k : int -> itree IO_event unit.
  Definition tree := (r <- read;; k r).

  Goal is_trace tree (@TEnd _ unit).
  Proof.
    hnf; cbn.
    constructor.
  Qed.

  Goal is_trace tree (@TEventEnd _ unit _ ERead).
  Proof.
    hnf; cbn.
    constructor.
  Qed.

  Goal is_trace tree (@TEventResponse _ unit _ ERead Int.zero TEnd).
  Proof.
    hnf; cbn.
    repeat constructor.
  Qed.

  Goal is_trace tree (trace_of_etrace nil).
  Proof.
    hnf; cbn.
    constructor.
  Qed.

  Goal is_trace tree (trace_of_etrace (ETRead 0 :: nil)).
  Proof.
    hnf; cbn.
    repeat constructor.
  Qed.
End SanityChecks.

(** CertiKOS Specs *)
Section Specs.

  Class ConsoleLen := {
    CONSOLE_MAX_LEN : Z;
    console_len_pos : 0 < CONSOLE_MAX_LEN
  }.
  Context {Hclen : ConsoleLen}.

  Class SerialOracle := {
    serial_oracle : etrace -> Z;
    serial_oracle_in_range : forall tr,
      0 <= serial_oracle tr <= 255
  }.
  Context {Horacle : SerialOracle}.

  Record state := mkSt {
    st_mem : mem;
    st_console : list Z;
    st_trace : etrace;
  }.

  (* Read a character from the serial device and place it in the console buffer.
     Triggered by an interrupt from the serial device. *)
  Definition serial_getc (st : state) : state :=
    let (mem, cons, tr) := st in
    let c := serial_oracle tr in
    let cons' := if Zlength cons <? CONSOLE_MAX_LEN then cons
                 else skipn 1 cons in
    mkSt mem (cons' ++ c :: nil) (tr ++ ETRead c :: nil).

  (* Take the first element from the console buffer or -1 if it is empty. *)
  Definition console_read (st : state) : state * Z :=
    let (mem, cons, tr) := st in
    match cons with
    | nil => (st, -1)
    | c :: rest =>
      let st' := mkSt mem rest tr in
      (st', c)
    end.

  (* Return the new state, the read character, and the section of the trace to
     be consumed. *)
  Definition getchar_spec (st : state) : state * Z * etrace :=
    let (st', r) := console_read st in
    (* Success *)
    if 0 <=? r then (st', r, ETRead r :: nil)
    (* Error *)
    else (st', -1, nil).

  (* Invariant that everything in the trace was put there by the serial
     device. *)
  Definition valid_trace st :=
    forall c,
      In (ETRead c) st.(st_trace) ->
      exists tr, serial_oracle tr = c.

  (* Invariant that everything in the console buffer is also in the trace. *)
  Definition valid_console st :=
    Zlength st.(st_console) <= CONSOLE_MAX_LEN /\
    forall c,
      In c st.(st_console) ->
      In (ETRead c) st.(st_trace).

  Definition valid_state st :=
    valid_trace st /\ valid_console st.

  Lemma serial_getc_preserve_valid_trace : forall st st',
    valid_trace st ->
    serial_getc st = st' ->
    valid_trace st'.
  Proof.
    unfold valid_trace, serial_getc; intros * Hvalid Hspec c Hin.
    destruct st as [? ? tr]; inv Hspec; cbn in *.
    rewrite in_app_iff in Hin; cbn in Hin.
    intuition.
    inv H0; eauto.
  Qed.

  Lemma serial_getc_preserve_valid_console : forall st st',
    valid_console st ->
    serial_getc st = st' ->
    valid_console st'.
  Proof.
    unfold valid_console, serial_getc; intros * (Hlen & Hvalid) Hspec.
    destruct st as [? cons ?]; inv Hspec; cbn in *.
    rewrite ?Zlength_correct in *.
    destruct (_ <? _) eqn:Hlt; [rewrite Z.ltb_lt in Hlt | rewrite Z.ltb_nlt in Hlt].
    + rewrite app_length; cbn.
      split; try lia.
      intros c; rewrite ?in_app_iff; cbn.
      intuition (subst; auto).
    + pose proof console_len_pos.
      rewrite app_length; cbn.
      split; [destruct cons; cbn in *; lia |].
      intros c; rewrite ?in_app_iff; cbn.
      destruct cons; intuition (subst; auto).
      intuition.
  Qed.

  Lemma getchar_spec_preserve_valid_trace : forall st st' c tr,
    valid_trace st ->
    getchar_spec st = (st', c, tr) ->
    valid_trace st'.
  Proof.
    unfold valid_trace, getchar_spec, console_read; intros * Hvalid Hspec c Hin.
    destruct st as [? [| c' cons] ?].
    - inv Hspec; eauto.
    - destruct (0 <=? c'); inv Hspec; cbn in *; eauto.
  Qed.

  Lemma getchar_spec_preserve_valid_console : forall st st' c tr,
    valid_console st ->
    getchar_spec st = (st', c, tr) ->
    valid_console st'.
  Proof.
    unfold valid_console, getchar_spec, console_read; intros * (Hlen & Hvalid) Hspec.
    destruct st as [? [| c' cons] ?].
    - inv Hspec; eauto.
    - rewrite ?Zlength_correct in *.
      destruct (0 <=? c'); inv Hspec; cbn in *; split; eauto; lia.
  Qed.

End Specs.

Section SpecsCorrect.

  Context `{SerialOracle} `{ConsoleLen}.

  (* For any trace that the new itree (z) allows, the old itree (z0) allowed it
     with the generated trace (t) as a prefix. *)
  Definition consume_trace (z0 z : IO_itree) (et : etrace) :=
    let t := trace_of_etrace et in
    forall t',
      is_trace z t' ->
      is_trace z0 (app_trace t t').

  Lemma getchar_correct k z m c t :
    (* Initial state is valid *)
    let st := mkSt m c t in
    valid_state st ->
    (* Pre condition holds *)
    getchar_pre' m k z ->
    exists st' r t',
      (* Spec with same initial memory returns some state and result *)
      getchar_spec st = (st', r, t') /\
      (* New itree is old k applied to result, or same as old itree if nothing
         to read *)
      let z' := if 0 <=? r then k (Int.repr r) else z in
      (* Post condition holds on new state, itree, and result *)
      getchar_post' m st'.(st_mem) (Int.repr r) (k, z) z' /\
      (* The new itree 'consumed' the generated trace *)
      consume_trace z z' t'.
  Proof.
    unfold getchar_pre'; intros Hval Hpre; cbn.
    unfold getchar_spec; cbn.
    destruct c as [| r c]; cbn.
    - (* Nothing to read *)
      do 4 esplit; eauto.
      split; hnf; cbn; auto.
    - (* Read r *)
      destruct Hval as (Hval_tr & (Hlen & Hval_cons)).
      specialize (Hval_cons _ ltac:(cbn; auto)).
      specialize (Hval_tr _ Hval_cons).
      destruct Hval_tr as (? & Hr).
      assert (0 <= r <= 255)
        by (subst; apply serial_oracle_in_range; auto).
      rewrite Zle_imp_le_bool by lia.
      do 4 esplit; eauto.
      rewrite Zle_imp_le_bool by lia.
      split; hnf; cbn.
      + rewrite Int.signed_repr; auto.
        cbn; lia.
      + intros * Htrace.
        apply Hpre.
        hnf; cbn.
        repeat constructor.
        apply Htrace.
  Qed.

End SpecsCorrect.


From PlutusCert Require Import
  PlutusIR
  Analysis.FreeVars
  Analysis.UniqueBinders
  Analysis.WellScoped
  Transform.Congruence
  .
Import NamedTerm.
Import Term.

From Coq Require Import
  Strings.String
  Lists.List
  Lists.ListSet
  .
Import ListNotations.

(* A binding group (Let without a body) *)
Definition binding_group := (Recursivity * list Binding)%type.

(*
Assuming globally unique variables, the new binding groups much satisfy:
  - Well-scoped: each free variable in a binding RHS is bound
  - All bindings equals those in the let-rec before transformaton

Note that strictness of bindings does not matter: if one of the (strict)
bindings diverges, the whole let-block diverges. This behaviour remains when
regrouping/reordering all bindings.
*)

Definition list_eq_elems {A} xs ys : Prop :=
  forall (x : A), In x xs <-> In x ys.

Definition min_Rec (r1 r2 : Recursivity) : Recursivity :=
  match r1, r2 with
    | NonRec, NonRec => NonRec
    | _ , _ => Rec
  end.

(* Collect subsequent binding groups, together with the "inner" term and
   minimum recursivity *)
Inductive outer_binds : Term -> list Binding -> Term -> Recursivity -> Prop :=

  | cv_Let : forall t_body lets t_inner r bs r_body,
      outer_binds t_body lets t_inner r_body ->
      outer_binds (Let r bs t_body) (bs ++ lets) t_inner (min_Rec r_body r)

  | cv_Other : forall t_inner,
      outer_binds t_inner [] t_inner NonRec

  .

Inductive split_syn : Term -> Term -> Prop :=
  | split_rec_let : forall bs t_body t bgs t_inner min_rec,

      (* a decision-procedure would need to find the list bgs of binding groups that
         satisfies the second premise (needs to do backtracking) *)
      outer_binds t bgs t_inner min_rec ->
      list_eq_elems bs bgs ->
      split_syn t_body t_inner ->
      split_syn (Let Rec bs t_body) t

  | split_rec_cong : forall t t',
      Cong split_syn t t' ->
      split_syn t t'
.

Definition split_rec t t' :=
  split_syn t t' /\
  unique t /\
  closed t'
.